cλash/CLasH/Translator.hs

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