1 module CLasH.Translator
7 import qualified System.Directory as Directory
10 import qualified System.FilePath as FilePath
11 import qualified Control.Monad.Trans.State as State
12 import Text.PrettyPrint.HughesPJ (render)
14 import qualified Data.Map as Map
17 import qualified CoreSyn
19 import qualified HscTypes
20 import qualified UniqSupply
23 import qualified Language.VHDL.AST as AST
24 import qualified Language.VHDL.FileIO
25 import qualified Language.VHDL.Ppr as Ppr
28 import CLasH.Normalize
29 import CLasH.Translator.TranslatorTypes
30 import CLasH.Translator.Annotations
31 import CLasH.Utils.Core.CoreTools
32 import CLasH.Utils.GhcTools
34 import CLasH.VHDL.Testbench
36 -- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial
37 -- State and Test Inputs.
39 FilePath -- ^ The GHC Library Dir
40 -> [FilePath] -- ^ The FileNames
41 -> String -- ^ The TopEntity
42 -> String -- ^ The InitState
43 -> String -- ^ The TestInput
44 -> Bool -- ^ Is it stateful? (in case InitState is empty)
46 makeVHDLStrings libdir filenames topentity initstate testinput stateful = do
47 makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
49 findTopEntity = findBind (hasVarName topentity)
50 findInitState = findBind (hasVarName initstate)
51 findTestInput = findExpr (hasVarName testinput)
53 -- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
54 -- and Test Inputs found in the Files.
55 makeVHDLAnnotations ::
56 FilePath -- ^ The GHC Library Dir
57 -> [FilePath] -- ^ The FileNames
58 -> Bool -- ^ Is it stateful? (in case InitState is not specified)
60 makeVHDLAnnotations libdir filenames stateful = do
61 makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
63 findTopEntity = findBind (hasCLasHAnnotation isTopEntity)
64 findInitState = findBind (hasCLasHAnnotation isInitState)
65 findTestInput = findExpr (hasCLasHAnnotation isTestInput)
67 -- | Turn Haskell to VHDL, using the given finder functions to find the Top
68 -- Entity, Initial State and Test Inputs in the Haskell Files.
70 FilePath -- ^ The GHC Library Dir
71 -> [FilePath] -- ^ The Filenames
72 -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Top Entity Finder
73 -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Init State Finder
74 -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreExpr)) -- ^ The Test Input Finder
75 -> Bool -- ^ Indicates if it is meant to be stateful
77 makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful = do
79 (cores, top, init, test, env) <- loadModules libdir filenames topEntFinder initStateFinder testInputFinder
81 vhdl <- moduleToVHDL env cores top init test stateful
83 let top_entity = Maybe.fromJust $ head top
84 let dir = "./vhdl/" ++ (show top_entity) ++ "/"
86 mapM (writeVHDL dir) vhdl
89 -- | Translate the binds with the given names from the given core module to
90 -- VHDL. The Bool in the tuple makes the function stateful (True) or
93 HscTypes.HscEnv -- ^ The GHC Environment
94 -> [HscTypes.CoreModule] -- ^ The Core Modules
95 -> [Maybe CoreSyn.CoreBndr] -- ^ The TopEntity
96 -> [Maybe CoreSyn.CoreBndr] -- ^ The InitState
97 -> [Maybe CoreSyn.CoreExpr] -- ^ The TestInput
98 -> Bool -- ^ Is it stateful (in case InitState is not specified)
99 -> IO [(AST.VHDLId, AST.DesignFile)]
100 moduleToVHDL env cores topbinds' init test stateful = do
101 let topbinds = Maybe.catMaybes topbinds'
102 let initialState = Maybe.catMaybes init
103 let testInput = Maybe.catMaybes test
104 vhdl <- runTranslatorSession env $ do
105 let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
106 -- Store the bindings we loaded
107 tsBindings %= Map.fromList all_bindings
108 test_binds <- Monad.zipWithM (createTestbench Nothing) testInput topbinds
109 createDesignFiles (topbinds ++ test_binds)
110 mapM (putStr . render . Ppr.ppr . snd) vhdl
113 -- Run the given translator session. Generates a new UniqSupply for that
115 runTranslatorSession :: HscTypes.HscEnv -> TranslatorSession a -> IO a
116 runTranslatorSession env session = do
117 -- Generate a UniqSupply
119 -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
120 -- on the compiler dir of ghc suggests that 'z' is not used to generate
121 -- a unique supply anywhere.
122 uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
123 let init_typestate = TypeState Map.empty [] Map.empty Map.empty env
124 let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty Map.empty Map.empty
125 return $ State.evalState session init_state
127 -- | Prepares the directory for writing VHDL files. This means creating the
128 -- dir if it does not exist and removing all existing .vhdl files from it.
129 prepareDir :: String -> IO()
131 -- Create the dir if needed
132 Directory.createDirectoryIfMissing True dir
133 -- Find all .vhdl files in the directory
134 files <- Directory.getDirectoryContents dir
135 let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
136 -- Prepend the dirname to the filenames
137 let abs_to_remove = map (FilePath.combine dir) to_remove
139 mapM_ Directory.removeFile abs_to_remove
141 -- | Write the given design file to a file with the given name inside the
143 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
144 writeVHDL dir (name, vhdl) = do
146 let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
148 Language.VHDL.FileIO.writeDesignFile vhdl fname
150 -- vim: set ts=8 sw=2 sts=2 expandtab: