Translator.hs

   1 module Translator where
   2 import qualified Directory
   3 import qualified System.FilePath as FilePath
   4 import qualified List
   5 import Debug.Trace
   6 import qualified Control.Arrow as Arrow
   7 import GHC hiding (loadModule, sigName)
   8 import CoreSyn
   9 import qualified CoreUtils
  10 import qualified Var
  11 import qualified Type
  12 import qualified TyCon
  13 import qualified DataCon
  14 import qualified HscMain
  15 import qualified SrcLoc
  16 import qualified FastString
  17 import qualified Maybe
  18 import qualified Module
  19 import qualified Data.Foldable as Foldable
  20 import qualified Control.Monad.Trans.State as State
  21 import Name
  22 import qualified Data.Map as Map
  23 import Data.Accessor
  24 import Data.Generics
  25 import NameEnv ( lookupNameEnv )
  26 import qualified HscTypes
  27 import HscTypes ( cm_binds, cm_types )
  28 import MonadUtils ( liftIO )
  29 import Outputable ( showSDoc, ppr, showSDocDebug )
  30 import GHC.Paths ( libdir )
  31 import DynFlags ( defaultDynFlags )
  32 import qualified UniqSupply
  33 import List ( find )
  34 import qualified List
  35 import qualified Monad
  36
  37 -- The following modules come from the ForSyDe project. They are really
  38 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
  39 -- ForSyDe to get access to these modules.
  40 import qualified Language.VHDL.AST as AST
  41 import qualified Language.VHDL.FileIO
  42 import qualified Language.VHDL.Ppr as Ppr
  43 -- This is needed for rendering the pretty printed VHDL
  44 import Text.PrettyPrint.HughesPJ (render)
  45
  46 import TranslatorTypes
  47 import HsValueMap
  48 import Pretty
  49 import Normalize
  50 -- import Flatten
  51 -- import FlattenTypes
  52 import VHDLTypes
  53 import qualified VHDL
  54
  55 makeVHDL :: String -> String -> Bool -> IO ()
  56 makeVHDL filename name stateful = do
  57   -- Load the module
  58   (core, env) <- loadModule filename
  59   -- Translate to VHDL
  60   vhdl <- moduleToVHDL env core [(name, stateful)]
  61   -- Write VHDL to file
  62   let dir = "./vhdl/" ++ name ++ "/"
  63   prepareDir dir
  64   mapM (writeVHDL dir) vhdl
  65   return ()
  66
  67 listBindings :: String -> IO [()]
  68 listBindings filename = do
  69   (core, env) <- loadModule filename
  70   let binds = CoreSyn.flattenBinds $ cm_binds core
  71   mapM (listBinding) binds
  72
  73 listBinding :: (CoreBndr, CoreExpr) -> IO ()
  74 listBinding (b, e) = do
  75   putStr "\nBinder: "
  76   putStr $ show b
  77   putStr "\nExpression: \n"
  78   putStr $ prettyShow e
  79   putStr "\n\n"
  80   putStr $ showSDoc $ ppr e
  81   putStr "\n\n"
  82   putStr $ showSDoc $ ppr $ CoreUtils.exprType e
  83   putStr "\n\n"
  84
  85 -- | Show the core structure of the given binds in the given file.
  86 listBind :: String -> String -> IO ()
  87 listBind filename name = do
  88   (core, env) <- loadModule filename
  89   let [(b, expr)] = findBinds core [name]
  90   putStr "\n"
  91   putStr $ prettyShow expr
  92   putStr "\n\n"
  93   putStr $ showSDoc $ ppr expr
  94   putStr "\n\n"
  95   putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
  96   putStr "\n\n"
  97
  98 -- | Translate the binds with the given names from the given core module to
  99 --   VHDL. The Bool in the tuple makes the function stateful (True) or
 100 --   stateless (False).
 101 moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
 102 moduleToVHDL env core list = do
 103   let (names, statefuls) = unzip list
 104   let binds = map fst $ findBinds core names
 105   -- Generate a UniqSupply
 106   -- Running
 107   --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
 108   -- on the compiler dir of ghc suggests that 'z' is not used to generate a
 109   -- unique supply anywhere.
 110   uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
 111   -- Turn bind into VHDL
 112   let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
 113   let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls
 114   let vhdl = VHDL.createDesignFiles typestate normalized_bindings
 115   mapM (putStr . render . Ppr.ppr . snd) vhdl
 116   --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
 117   return vhdl
 118   where
 119
 120 -- | Prepares the directory for writing VHDL files. This means creating the
 121 --   dir if it does not exist and removing all existing .vhdl files from it.
 122 prepareDir :: String -> IO()
 123 prepareDir dir = do
 124   -- Create the dir if needed
 125   exists <- Directory.doesDirectoryExist dir
 126   Monad.unless exists $ Directory.createDirectory dir
 127   -- Find all .vhdl files in the directory
 128   files <- Directory.getDirectoryContents dir
 129   let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
 130   -- Prepend the dirname to the filenames
 131   let abs_to_remove = map (FilePath.combine dir) to_remove
 132   -- Remove the files
 133   mapM_ Directory.removeFile abs_to_remove
 134
 135 -- | Write the given design file to a file with the given name inside the
 136 --   given dir
 137 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
 138 writeVHDL dir (name, vhdl) = do
 139   -- Find the filename
 140   let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
 141   -- Write the file
 142   Language.VHDL.FileIO.writeDesignFile vhdl fname
 143
 144 -- | Loads the given file and turns it into a core module.
 145 loadModule :: String -> IO (HscTypes.CoreModule, HscTypes.HscEnv)
 146 loadModule filename =
 147   defaultErrorHandler defaultDynFlags $ do
 148     runGhc (Just libdir) $ do
 149       dflags <- getSessionDynFlags
 150       setSessionDynFlags dflags
 151       --target <- guessTarget "adder.hs" Nothing
 152       --liftIO (print (showSDoc (ppr (target))))
 153       --liftIO $ printTarget target
 154       --setTargets [target]
 155       --load LoadAllTargets
 156       --core <- GHC.compileToCoreSimplified "Adders.hs"
 157       core <- GHC.compileToCoreModule filename
 158       env <- GHC.getSession
 159       return (core, env)
 160
 161 -- | Extracts the named binds from the given module.
 162 findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
 163 findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
 164
 165 -- | Extract a named bind from the given list of binds
 166 findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
 167 findBind binds lookfor =
 168   -- This ignores Recs and compares the name of the bind with lookfor,
 169   -- disregarding any namespaces in OccName and extra attributes in Name and
 170   -- Var.
 171   find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
 172
 173 -- | Flattens the given bind into the given signature and adds it to the
 174 --   session. Then (recursively) finds any functions it uses and does the same
 175 --   with them.
 176 -- flattenBind ::
 177 --   HsFunction                         -- The signature to flatten into
 178 --   -> (CoreBndr, CoreExpr)            -- The bind to flatten
 179 --   -> TranslatorState ()
 180 --
 181 -- flattenBind hsfunc bind@(var, expr) = do
 182 --   -- Flatten the function
 183 --   let flatfunc = flattenFunction hsfunc bind
 184 --   -- Propagate state variables
 185 --   let flatfunc' = propagateState hsfunc flatfunc
 186 --   -- Store the flat function in the session
 187 --   modA tsFlatFuncs (Map.insert hsfunc flatfunc')
 188 --   -- Flatten any functions used
 189 --   let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
 190 --   mapM_ resolvFunc used_hsfuncs
 191
 192 -- | Decide which incoming state variables will become state in the
 193 --   given function, and which will be propagate to other applied
 194 --   functions.
 195 -- propagateState ::
 196 --   HsFunction
 197 --   -> FlatFunction
 198 --   -> FlatFunction
 199 --
 200 -- propagateState hsfunc flatfunc =
 201 --     flatfunc {flat_defs = apps', flat_sigs = sigs'}
 202 --   where
 203 --     (olds, news) = unzip $ getStateSignals hsfunc flatfunc
 204 --     states' = zip olds news
 205 --     -- Find all signals used by all sigdefs
 206 --     uses = concatMap sigDefUses (flat_defs flatfunc)
 207 --     -- Find all signals that are used more than once (is there a
 208 --     -- prettier way to do this?)
 209 --     multiple_uses = uses List.\\ (List.nub uses)
 210 --     -- Find the states whose "old state" signal is used only once
 211 --     single_use_states = filter ((`notElem` multiple_uses) . fst) states'
 212 --     -- See if these single use states can be propagated
 213 --     (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
 214 --     substate_sigs = concat substate_sigss
 215 --     -- Mark any propagated state signals as SigSubState
 216 --     sigs' = map
 217 --       (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
 218 --       (flat_sigs flatfunc)
 219
 220 -- | Propagate the state into a single function application.
 221 -- propagateState' ::
 222 --   [(SignalId, SignalId)]
 223 --                       -- ^ TODO
 224 --   -> SigDef           -- ^ The SigDef to process.
 225 --   -> ([SignalId], SigDef)
 226 --                       -- ^ Any signal ids that should become substates,
 227 --                       --   and the resulting application.
 228 --
 229 -- propagateState' states def =
 230 --     if (is_FApp def) then
 231 --       (our_old ++ our_new, def {appFunc = hsfunc'})
 232 --     else
 233 --       ([], def)
 234 --   where
 235 --     hsfunc = appFunc def
 236 --     args = appArgs def
 237 --     res = appRes def
 238 --     our_states = filter our_state states
 239 --     -- A state signal belongs in this function if the old state is
 240 --     -- passed in, and the new state returned
 241 --     our_state (old, new) =
 242 --       any (old `Foldable.elem`) args
 243 --       && new `Foldable.elem` res
 244 --     (our_old, our_new) = unzip our_states
 245 --     -- Mark the result
 246 --     zipped_res = zipValueMaps res (hsFuncRes hsfunc)
 247 --     res' = fmap (mark_state (zip our_new [0..])) zipped_res
 248 --     -- Mark the args
 249 --     zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
 250 --     args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
 251 --     hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
 252 --
 253 --     mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
 254 --     mark_state states (id, use) =
 255 --       case lookup id states of
 256 --         Nothing -> use
 257 --         Just state_id -> State state_id
 258
 259 -- | Returns pairs of signals that should be mapped to state in this function.
 260 -- getStateSignals ::
 261 --   HsFunction                      -- | The function to look at
 262 --   -> FlatFunction                 -- | The function to look at
 263 --   -> [(SignalId, SignalId)]
 264 --         -- | TODO The state signals. The first is the state number, the second the
 265 --         --   signal to assign the current state to, the last is the signal
 266 --         --   that holds the new state.
 267 --
 268 -- getStateSignals hsfunc flatfunc =
 269 --   [(old_id, new_id)
 270 --     | (old_num, old_id) <- args
 271 --     , (new_num, new_id) <- res
 272 --     , old_num == new_num]
 273 --   where
 274 --     sigs = flat_sigs flatfunc
 275 --     -- Translate args and res to lists of (statenum, sigid)
 276 --     args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
 277 --     res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
 278
 279 -- | Find the given function, flatten it and add it to the session. Then
 280 --   (recursively) do the same for any functions used.
 281 -- resolvFunc ::
 282 --   HsFunction        -- | The function to look for
 283 --   -> TranslatorState ()
 284 --
 285 -- resolvFunc hsfunc = do
 286 --   flatfuncmap <- getA tsFlatFuncs
 287 --   -- Don't do anything if there is already a flat function for this hsfunc or
 288 --   -- when it is a builtin function.
 289 --   Monad.unless (Map.member hsfunc flatfuncmap) $ do
 290 --   -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
 291 --   -- New function, resolve it
 292 --   core <- getA tsCoreModule
 293 --   -- Find the named function
 294 --   let name = (hsFuncName hsfunc)
 295 --   let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name
 296 --   case bind of
 297 --     Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
 298 --     Just b  -> flattenBind hsfunc b
 299
 300 -- | Translate a top level function declaration to a HsFunction. i.e., which
 301 --   interface will be provided by this function. This function essentially
 302 --   defines the "calling convention" for hardware models.
 303 -- mkHsFunction ::
 304 --   Var.Var         -- ^ The function defined
 305 --   -> Type         -- ^ The function type (including arguments!)
 306 --   -> Bool         -- ^ Is this a stateful function?
 307 --   -> HsFunction   -- ^ The resulting HsFunction
 308 --
 309 -- mkHsFunction f ty stateful=
 310 --   HsFunction hsname hsargs hsres
 311 --   where
 312 --     hsname  = getOccString f
 313 --     (arg_tys, res_ty) = Type.splitFunTys ty
 314 --     (hsargs, hsres) =
 315 --       if stateful
 316 --       then
 317 --         let
 318 --           -- The last argument must be state
 319 --           state_ty = last arg_tys
 320 --           state    = useAsState (mkHsValueMap state_ty)
 321 --           -- All but the last argument are inports
 322 --           inports = map (useAsPort . mkHsValueMap)(init arg_tys)
 323 --           hsargs   = inports ++ [state]
 324 --           hsres    = case splitTupleType res_ty of
 325 --             -- Result type must be a two tuple (state, ports)
 326 --             Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
 327 --               then
 328 --                 Tuple [state, useAsPort (mkHsValueMap outport_ty)]
 329 --               else
 330 --                 error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
 331 --             otherwise                -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
 332 --         in
 333 --           (hsargs, hsres)
 334 --       else
 335 --         -- Just use everything as a port
 336 --         (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
 337
 338 -- | Adds signal names to the given FlatFunction
 339 -- nameFlatFunction ::
 340 --   FlatFunction
 341 --   -> FlatFunction
 342 --
 343 -- nameFlatFunction flatfunc =
 344 --   -- Name the signals
 345 --   let
 346 --     s = flat_sigs flatfunc
 347 --     s' = map nameSignal s in
 348 --   flatfunc { flat_sigs = s' }
 349 --   where
 350 --     nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
 351 --     nameSignal (id, info) =
 352 --       let hints = nameHints info in
 353 --       let parts = ("sig" : hints) ++ [show id] in
 354 --       let name = concat $ List.intersperse "_" parts in
 355 --       (id, info {sigName = Just name})
 356 --
 357 -- -- | Splits a tuple type into a list of element types, or Nothing if the type
 358 -- --   is not a tuple type.
 359 -- splitTupleType ::
 360 --   Type              -- ^ The type to split
 361 --   -> Maybe [Type]   -- ^ The tuples element types
 362 --
 363 -- splitTupleType ty =
 364 --   case Type.splitTyConApp_maybe ty of
 365 --     Just (tycon, args) -> if TyCon.isTupleTyCon tycon
 366 --       then
 367 --         Just args
 368 --       else
 369 --         Nothing
 370 --     Nothing -> Nothing
 371
 372 -- vim: set ts=8 sw=2 sts=2 expandtab: