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
32 import CLasH.Utils.Core.CoreTools
33 import CLasH.Utils.GhcTools
35 import CLasH.VHDL.Testbench
37 -- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial
38 -- State and Test Inputs.
40 FilePath -- ^ The GHC Library Dir
41 -> [FilePath] -- ^ The FileNames
42 -> String -- ^ The TopEntity
43 -> String -- ^ The InitState
44 -> String -- ^ The TestInput
46 makeVHDLStrings libdir filenames topentity initstate testinput = do
47 makeVHDL libdir filenames finder
49 finder = findSpec (hasVarName topentity)
50 (hasVarName initstate)
51 (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
59 makeVHDLAnnotations libdir filenames = do
60 makeVHDL libdir filenames finder
62 finder = findSpec (hasCLasHAnnotation isTopEntity)
63 (hasCLasHAnnotation isInitState)
64 (hasCLasHAnnotation isTestInput)
66 -- | Turn Haskell to VHDL, using the given finder functions to find the Top
67 -- Entity, Initial State and Test Inputs in the Haskell Files.
69 FilePath -- ^ The GHC Library Dir
70 -> [FilePath] -- ^ The Filenames
73 makeVHDL libdir filenames finder = do
75 (cores, env, specs) <- loadModules libdir filenames (Just finder)
77 vhdl <- moduleToVHDL env cores specs
78 -- Write VHDL to file. Just use the first entity for the name
79 let top_entity = head $ Maybe.catMaybes $ map (\(t, _, _) -> t) specs
80 let dir = "./vhdl/" ++ (show top_entity) ++ "/"
82 mapM (writeVHDL dir) vhdl
85 -- | Translate the specified entities in the given modules to VHDL.
87 HscTypes.HscEnv -- ^ The GHC Environment
88 -> [HscTypes.CoreModule] -- ^ The Core Modules
89 -> [EntitySpec] -- ^ The entities to generate
90 -> IO [(AST.VHDLId, AST.DesignFile)]
91 moduleToVHDL env cores specs = do
92 vhdl <- runTranslatorSession env $ do
93 let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
94 -- Store the bindings we loaded
95 tsBindings %= Map.fromList all_bindings
96 test_binds <- catMaybesM $ Monad.mapM mkTest specs
97 let topbinds = Maybe.catMaybes $ map (\(top, _, _) -> top) specs
99 [] -> error $ "Could not find top entity requested"
100 tops -> createDesignFiles (tops ++ test_binds)
101 mapM (putStr . render . Ppr.ppr . snd) vhdl
104 mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr)
105 -- Create a testbench for any entry that has test input
106 mkTest (_, _, Nothing) = return Nothing
107 mkTest (Nothing, _, _) = return Nothing
108 mkTest (Just top, _, Just input) = do
109 bndr <- createTestbench Nothing cores input top
112 -- Run the given translator session. Generates a new UniqSupply for that
114 runTranslatorSession :: HscTypes.HscEnv -> TranslatorSession a -> IO a
115 runTranslatorSession env session = do
116 -- Generate a UniqSupply
118 -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
119 -- on the compiler dir of ghc suggests that 'z' is not used to generate
120 -- a unique supply anywhere.
121 uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
122 let init_typestate = TypeState Map.empty [] Map.empty Map.empty env
123 let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty
124 return $ State.evalState session init_state
126 -- | Prepares the directory for writing VHDL files. This means creating the
127 -- dir if it does not exist and removing all existing .vhdl files from it.
128 prepareDir :: String -> IO()
130 -- Create the dir if needed
131 Directory.createDirectoryIfMissing True dir
132 -- Find all .vhdl files in the directory
133 files <- Directory.getDirectoryContents dir
134 let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
135 -- Prepend the dirname to the filenames
136 let abs_to_remove = map (FilePath.combine dir) to_remove
138 mapM_ Directory.removeFile abs_to_remove
140 -- | Write the given design file to a file with the given name inside the
142 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
143 writeVHDL dir (name, vhdl) = do
145 let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
147 Language.VHDL.FileIO.writeDesignFile vhdl fname
149 -- vim: set ts=8 sw=2 sts=2 expandtab: