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
15 import qualified Data.Time.Clock as Clock
19 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 as FileIO
26 import qualified Language.VHDL.Ppr as Ppr
29 import CLasH.Translator.TranslatorTypes
30 import CLasH.Translator.Annotations
32 import CLasH.Utils.GhcTools
34 import CLasH.VHDL.VHDLTools
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 -- (isCLasHAnnotation isInitState)
52 -- (hasVarName testinput)
54 -- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
55 -- and Test Inputs found in the Files.
56 makeVHDLAnnotations ::
57 FilePath -- ^ The GHC Library Dir
58 -> [FilePath] -- ^ The FileNames
60 makeVHDLAnnotations libdir filenames =
61 makeVHDL libdir filenames finder
63 finder = findSpec (hasCLasHAnnotation isTopEntity)
64 (hasCLasHAnnotation isInitState)
65 (isCLasHAnnotation isInitState)
66 (hasCLasHAnnotation isTestInput)
68 -- | Turn Haskell to VHDL, using the given finder functions to find the Top
69 -- Entity, Initial State and Test Inputs in the Haskell Files.
71 FilePath -- ^ The GHC Library Dir
72 -> [FilePath] -- ^ The Filenames
75 makeVHDL libdir filenames finder = do
76 start <- Clock.getCurrentTime
78 (cores, env, specs) <- loadModules libdir filenames (Just finder)
80 vhdl <- moduleToVHDL env cores specs
81 -- Write VHDL to file. Just use the first entity for the name
82 let top_entity = head $ Maybe.catMaybes $ map (\(t, _, _) -> t) specs
83 let dir = "./vhdl/" ++ (show top_entity) ++ "/"
85 mapM_ (writeVHDL dir) vhdl
86 end <- Clock.getCurrentTime
87 trace ("\nTotal compilation took " ++ show (Clock.diffUTCTime end start)) $
90 -- | Translate the specified entities in the given modules to VHDL.
92 HscTypes.HscEnv -- ^ The GHC Environment
93 -> [HscTypes.CoreModule] -- ^ The Core Modules
94 -> [EntitySpec] -- ^ The entities to generate
95 -> IO [(AST.VHDLId, AST.DesignFile)]
96 moduleToVHDL env cores specs = do
97 vhdl <- runTranslatorSession env $ do
98 let all_bindings = concatMap (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores
99 -- Store the bindings we loaded
100 tsBindings %= Map.fromList all_bindings
101 let all_initstates = concatMap (\x -> case x of (_, Nothing, _) -> []; (_, Just inits, _) -> inits) specs
102 tsInitStates %= Map.fromList all_initstates
103 test_binds <- catMaybesM $ Monad.mapM mkTest 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
119 -- Run the given translator session. Generates a new UniqSupply for that
121 runTranslatorSession :: HscTypes.HscEnv -> TranslatorSession a -> IO a
122 runTranslatorSession env session = do
123 -- Generate a UniqSupply
125 -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
126 -- on the compiler dir of ghc suggests that 'z' is not used to generate
127 -- a unique supply anywhere.
128 uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
129 let init_typestate = TypeState builtin_types [] Map.empty Map.empty env
130 let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty
131 return $ State.evalState session init_state
133 -- | Prepares the directory for writing VHDL files. This means creating the
134 -- dir if it does not exist and removing all existing .vhdl files from it.
135 prepareDir :: String -> IO()
137 -- Create the dir if needed
138 Directory.createDirectoryIfMissing True dir
139 -- Find all .vhdl files in the directory
140 files <- Directory.getDirectoryContents dir
141 let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
142 -- Prepend the dirname to the filenames
143 let abs_to_remove = map (FilePath.combine dir) to_remove
145 mapM_ Directory.removeFile abs_to_remove
147 -- | Write the given design file to a file with the given name inside the
149 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
150 writeVHDL dir (name, vhdl) = do
152 let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
154 FileIO.writeDesignFile vhdl fname
156 -- vim: set ts=8 sw=2 sts=2 expandtab: