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)
13 import Data.Accessor.Monad.Trans.State
14 import qualified Data.Map as Map
18 import qualified CoreSyn
20 import qualified HscTypes
21 import qualified UniqSupply
24 import qualified Language.VHDL.AST as AST
25 import qualified Language.VHDL.FileIO
26 import qualified Language.VHDL.Ppr as Ppr
29 import CLasH.Normalize
30 import CLasH.Translator.TranslatorTypes
31 import CLasH.Translator.Annotations
33 import CLasH.Utils.Core.CoreTools
34 import CLasH.Utils.GhcTools
36 import CLasH.VHDL.VHDLTools
37 import CLasH.VHDL.Testbench
39 -- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial
40 -- State and Test Inputs.
42 -- FilePath -- ^ The GHC Library Dir
43 -- -> [FilePath] -- ^ The FileNames
44 -- -> String -- ^ The TopEntity
45 -- -> String -- ^ The InitState
46 -- -> String -- ^ The TestInput
48 -- makeVHDLStrings libdir filenames topentity initstate testinput = do
49 -- makeVHDL libdir filenames finder
51 -- finder = findSpec (hasVarName topentity)
52 -- (hasVarName initstate)
53 -- (isCLasHAnnotation isInitState)
54 -- (hasVarName testinput)
56 -- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
57 -- and Test Inputs found in the Files.
58 makeVHDLAnnotations ::
59 FilePath -- ^ The GHC Library Dir
60 -> [FilePath] -- ^ The FileNames
62 makeVHDLAnnotations libdir filenames = do
63 makeVHDL libdir filenames finder
65 finder = findSpec (hasCLasHAnnotation isTopEntity)
66 (hasCLasHAnnotation isInitState)
67 (isCLasHAnnotation isInitState)
68 (hasCLasHAnnotation isTestInput)
70 -- | Turn Haskell to VHDL, using the given finder functions to find the Top
71 -- Entity, Initial State and Test Inputs in the Haskell Files.
73 FilePath -- ^ The GHC Library Dir
74 -> [FilePath] -- ^ The Filenames
77 makeVHDL libdir filenames finder = do
79 (cores, env, specs) <- loadModules libdir filenames (Just finder)
81 vhdl <- moduleToVHDL env cores specs
82 -- Write VHDL to file. Just use the first entity for the name
83 let top_entity = head $ Maybe.catMaybes $ map (\(t, _, _) -> t) specs
84 let dir = "./vhdl/" ++ (show top_entity) ++ "/"
86 mapM (writeVHDL dir) vhdl
89 -- | Translate the specified entities in the given modules to VHDL.
91 HscTypes.HscEnv -- ^ The GHC Environment
92 -> [HscTypes.CoreModule] -- ^ The Core Modules
93 -> [EntitySpec] -- ^ The entities to generate
94 -> IO [(AST.VHDLId, AST.DesignFile)]
95 moduleToVHDL env cores specs = do
96 vhdl <- runTranslatorSession env $ do
97 let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
98 -- Store the bindings we loaded
99 tsBindings %= Map.fromList all_bindings
100 let all_initstates = concat (map (\x -> case x of (_, Nothing, _) -> []; (_, Just inits, _) -> inits) specs)
101 tsInitStates %= Map.fromList all_initstates
102 test_binds <- catMaybesM $ Monad.mapM mkTest specs
103 mapM_ printAnns specs
104 let topbinds = Maybe.catMaybes $ map (\(top, _, _) -> top) specs
106 [] -> error $ "Could not find top entity requested"
107 tops -> createDesignFiles (tops ++ test_binds)
108 mapM (putStr . render . Ppr.ppr . snd) vhdl
111 mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr)
112 -- Create a testbench for any entry that has test input
113 mkTest (_, _, Nothing) = return Nothing
114 mkTest (Nothing, _, _) = return Nothing
115 mkTest (Just top, _, Just input) = do
116 bndr <- createTestbench Nothing cores input top
118 printAnns :: EntitySpec -> TranslatorSession ()
119 printAnns (_, Nothing, _) = trace ("no anns found:\n\n") $ return ()
120 printAnns (_, (Just anns), _) = trace ("anns:\n\n" ++ show anns ++ "\n") $ return ()
122 -- Run the given translator session. Generates a new UniqSupply for that
124 runTranslatorSession :: HscTypes.HscEnv -> TranslatorSession a -> IO a
125 runTranslatorSession env session = do
126 -- Generate a UniqSupply
128 -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
129 -- on the compiler dir of ghc suggests that 'z' is not used to generate
130 -- a unique supply anywhere.
131 uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
132 let init_typestate = TypeState builtin_types [] Map.empty Map.empty env
133 let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty
134 return $ State.evalState session init_state
136 -- | Prepares the directory for writing VHDL files. This means creating the
137 -- dir if it does not exist and removing all existing .vhdl files from it.
138 prepareDir :: String -> IO()
140 -- Create the dir if needed
141 Directory.createDirectoryIfMissing True dir
142 -- Find all .vhdl files in the directory
143 files <- Directory.getDirectoryContents dir
144 let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
145 -- Prepend the dirname to the filenames
146 let abs_to_remove = map (FilePath.combine dir) to_remove
148 mapM_ Directory.removeFile abs_to_remove
150 -- | Write the given design file to a file with the given name inside the
152 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
153 writeVHDL dir (name, vhdl) = do
155 let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
157 Language.VHDL.FileIO.writeDesignFile vhdl fname
159 -- vim: set ts=8 sw=2 sts=2 expandtab: