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