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, count) <- 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
105 vhdl <- case topbinds of
106 [] -> error "Could not find top entity requested"
107 tops -> createDesignFiles (tops ++ test_binds)
108 count <- get tsTransformCounter
110 mapM_ (putStr . render . Ppr.ppr . snd) vhdl
111 putStr $ "Total number of transformations applied: " ++ (show count) ++ "\n"
114 mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr)
115 -- Create a testbench for any entry that has test input
116 mkTest (_, _, Nothing) = return Nothing
117 mkTest (Nothing, _, _) = return Nothing
118 mkTest (Just top, _, Just input) = do
119 bndr <- createTestbench Nothing cores input top
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 0
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 FileIO.writeDesignFile vhdl fname
159 -- vim: set ts=8 sw=2 sts=2 expandtab: