+{-# LANGUAGE ScopedTypeVariables #-}
+
module CLasH.Translator where
import qualified Directory
import qualified Module
import qualified Data.Foldable as Foldable
import qualified Control.Monad.Trans.State as State
+import qualified Control.Monad as Monad
import Name
import qualified Data.Map as Map
import Data.Accessor
import HscTypes ( cm_binds, cm_types )
import MonadUtils ( liftIO )
import Outputable ( showSDoc, ppr, showSDocDebug )
-import GHC.Paths ( libdir )
import DynFlags ( defaultDynFlags )
import qualified UniqSupply
import List ( find )
import qualified List
import qualified Monad
+import qualified Annotations
+import qualified Serialized
-- The following modules come from the ForSyDe project. They are really
-- internal modules, so ForSyDe.cabal has to be modified prior to installing
import Text.PrettyPrint.HughesPJ (render)
import CLasH.Translator.TranslatorTypes
+import CLasH.Translator.Annotations
import CLasH.Utils.Pretty
import CLasH.Normalize
import CLasH.VHDL.VHDLTypes
import qualified CLasH.VHDL as VHDL
-makeVHDL :: String -> String -> Bool -> IO ()
-makeVHDL filename name stateful = do
+makeVHDL :: FilePath -> String -> String -> Bool -> IO ()
+makeVHDL libdir filename name stateful = do
-- Load the module
- (core, env) <- loadModule filename
+ (core, env) <- loadModule libdir filename
-- Translate to VHDL
vhdl <- moduleToVHDL env core [(name, stateful)]
-- Write VHDL to file
prepareDir dir
mapM (writeVHDL dir) vhdl
return ()
+
+makeVHDLAnn :: FilePath -> String -> IO ()
+makeVHDLAnn libdir filename = do
+ (core, top, init, env) <- loadModuleAnn libdir filename
+ let top_entity = head top
+ vhdl <- case init of
+ [] -> moduleToVHDLAnn env core [top_entity]
+ xs -> moduleToVHDLAnnState env core [(top_entity, (head xs))]
+ let dir = "./vhdl/" ++ (show top_entity) ++ "/"
+ prepareDir dir
+ mapM (writeVHDL dir) vhdl
+ return ()
-listBindings :: String -> IO [()]
-listBindings filename = do
- (core, env) <- loadModule filename
+listBindings :: FilePath -> String -> IO [()]
+listBindings libdir filename = do
+ (core, env) <- loadModule libdir filename
let binds = CoreSyn.flattenBinds $ cm_binds core
mapM (listBinding) binds
putStr "\n\n"
-- | Show the core structure of the given binds in the given file.
-listBind :: String -> String -> IO ()
-listBind filename name = do
- (core, env) <- loadModule filename
+listBind :: FilePath -> String -> String -> IO ()
+listBind libdir filename name = do
+ (core, env) <- loadModule libdir filename
let [(b, expr)] = findBinds core [name]
- putStr "\n"
- putStr $ prettyShow expr
- putStr "\n\n"
- putStr $ showSDoc $ ppr expr
- putStr "\n\n"
- putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
- putStr "\n\n"
+ listBinding (b, expr)
-- | Translate the binds with the given names from the given core module to
-- VHDL. The Bool in the tuple makes the function stateful (True) or
mapM (putStr . render . Ppr.ppr . snd) vhdl
--putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
return vhdl
- where
+
+moduleToVHDLAnn :: HscTypes.HscEnv -> HscTypes.CoreModule -> [CoreSyn.CoreBndr] -> IO [(AST.VHDLId, AST.DesignFile)]
+moduleToVHDLAnn env core binds = do
+ -- Generate a UniqSupply
+ -- Running
+ -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
+ -- on the compiler dir of ghc suggests that 'z' is not used to generate a
+ -- unique supply anywhere.
+ uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
+ -- Turn bind into VHDL
+ let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
+ let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds [False]
+ let vhdl = VHDL.createDesignFiles typestate normalized_bindings
+ mapM (putStr . render . Ppr.ppr . snd) vhdl
+ --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
+ return vhdl
+
+moduleToVHDLAnnState :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)] -> IO [(AST.VHDLId, AST.DesignFile)]
+moduleToVHDLAnnState env core list = do
+ let (binds, init_states) = unzip list
+ -- Generate a UniqSupply
+ -- Running
+ -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
+ -- on the compiler dir of ghc suggests that 'z' is not used to generate a
+ -- unique supply anywhere.
+ uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
+ -- Turn bind into VHDL
+ let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
+ let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds [True]
+ let vhdl = VHDL.createDesignFiles typestate normalized_bindings
+ mapM (putStr . render . Ppr.ppr . snd) vhdl
+ --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
+ return vhdl
-- | Prepares the directory for writing VHDL files. This means creating the
-- dir if it does not exist and removing all existing .vhdl files from it.
Language.VHDL.FileIO.writeDesignFile vhdl fname
-- | Loads the given file and turns it into a core module.
-loadModule :: String -> IO (HscTypes.CoreModule, HscTypes.HscEnv)
-loadModule filename =
+loadModule :: FilePath -> String -> IO (HscTypes.CoreModule, HscTypes.HscEnv)
+loadModule libdir filename =
defaultErrorHandler defaultDynFlags $ do
runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
core <- GHC.compileToCoreModule filename
env <- GHC.getSession
return (core, env)
+
+-- | Loads the given file and turns it into a core module.
+loadModuleAnn :: FilePath -> String -> IO (HscTypes.CoreModule, [CoreSyn.CoreBndr], [CoreSyn.CoreBndr], HscTypes.HscEnv)
+loadModuleAnn libdir filename =
+ defaultErrorHandler defaultDynFlags $ do
+ runGhc (Just libdir) $ do
+ dflags <- getSessionDynFlags
+ setSessionDynFlags dflags
+ --target <- guessTarget "adder.hs" Nothing
+ --liftIO (print (showSDoc (ppr (target))))
+ --liftIO $ printTarget target
+ --setTargets [target]
+ --load LoadAllTargets
+ --core <- GHC.compileToCoreSimplified "Adders.hs"
+ core <- GHC.compileToCoreModule filename
+ env <- GHC.getSession
+ top_entity <- findTopEntity core
+ init_state <- findInitState core
+ return (core, top_entity, init_state, env)
+
+findTopEntity :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreBndr]
+findTopEntity core = do
+ let binds = CoreSyn.flattenBinds $ cm_binds core
+ topbinds <- Monad.filterM (hasTopEntityAnnotation . fst) binds
+ let bndrs = case topbinds of [] -> error $ "Couldn't find top entity in current module." ; xs -> fst (unzip topbinds)
+ return bndrs
+
+findInitState :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreBndr]
+findInitState core = do
+ let binds = CoreSyn.flattenBinds $ cm_binds core
+ statebinds <- Monad.filterM (hasInitStateAnnotation . fst) binds
+ let bndrs = case statebinds of [] -> [] ; xs -> fst (unzip statebinds)
+ return bndrs
+
+hasTopEntityAnnotation :: GhcMonad m => Var.Var -> m Bool
+hasTopEntityAnnotation var = do
+ let deserializer = Serialized.deserializeWithData
+ let target = Annotations.NamedTarget (Var.varName var)
+ (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
+ let top_ents = filter isTopEntity anns
+ case top_ents of
+ [] -> return False
+ xs -> return True
+
+hasInitStateAnnotation :: GhcMonad m => Var.Var -> m Bool
+hasInitStateAnnotation var = do
+ let deserializer = Serialized.deserializeWithData
+ let target = Annotations.NamedTarget (Var.varName var)
+ (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
+ let top_ents = filter isInitState anns
+ case top_ents of
+ [] -> return False
+ xs -> return True
-- | Extracts the named binds from the given module.
findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
projects / matthijs / master-project / cλash.git / blobdiff