1 module CLasH.Translator
7 import qualified System.Directory as Directory
10 import qualified System.FilePath as FilePath
11 import Text.PrettyPrint.HughesPJ (render)
14 import qualified CoreSyn
16 import qualified HscTypes
17 import qualified UniqSupply
20 import qualified Language.VHDL.AST as AST
21 import qualified Language.VHDL.FileIO
22 import qualified Language.VHDL.Ppr as Ppr
25 import CLasH.Normalize
26 import CLasH.Translator.Annotations
27 import CLasH.Utils.Core.CoreTools
28 import CLasH.Utils.GhcTools
31 -- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial
32 -- State and Test Inputs.
34 FilePath -- ^ The GHC Library Dir
35 -> [FilePath] -- ^ The FileNames
36 -> String -- ^ The TopEntity
37 -> String -- ^ The InitState
38 -> String -- ^ The TestInput
39 -> Bool -- ^ Is it stateful? (in case InitState is empty)
41 makeVHDLStrings libdir filenames topentity initstate testinput stateful = do
42 makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
44 findTopEntity = findBind (hasVarName topentity)
45 findInitState = findBind (hasVarName initstate)
46 findTestInput = findExpr (hasVarName testinput)
48 -- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
49 -- and Test Inputs found in the Files.
50 makeVHDLAnnotations ::
51 FilePath -- ^ The GHC Library Dir
52 -> [FilePath] -- ^ The FileNames
53 -> Bool -- ^ Is it stateful? (in case InitState is not specified)
55 makeVHDLAnnotations libdir filenames stateful = do
56 makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
58 findTopEntity = findBind (hasCLasHAnnotation isTopEntity)
59 findInitState = findBind (hasCLasHAnnotation isInitState)
60 findTestInput = findExpr (hasCLasHAnnotation isTestInput)
62 -- | Turn Haskell to VHDL, using the given finder functions to find the Top
63 -- Entity, Initial State and Test Inputs in the Haskell Files.
65 FilePath -- ^ The GHC Library Dir
66 -> [FilePath] -- ^ The Filenames
67 -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Top Entity Finder
68 -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Init State Finder
69 -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreExpr)) -- ^ The Test Input Finder
70 -> Bool -- ^ Indicates if it is meant to be stateful
72 makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful = do
74 (cores, top, init, test, env) <- loadModules libdir filenames topEntFinder initStateFinder testInputFinder
76 vhdl <- moduleToVHDL env cores top init test stateful
78 let top_entity = Maybe.fromJust $ head top
79 let dir = "./vhdl/" ++ (show top_entity) ++ "/"
81 mapM (writeVHDL dir) vhdl
84 -- | Translate the binds with the given names from the given core module to
85 -- VHDL. The Bool in the tuple makes the function stateful (True) or
88 HscTypes.HscEnv -- ^ The GHC Environment
89 -> [HscTypes.CoreModule] -- ^ The Core Modules
90 -> [Maybe CoreSyn.CoreBndr] -- ^ The TopEntity
91 -> [Maybe CoreSyn.CoreBndr] -- ^ The InitState
92 -> [Maybe CoreSyn.CoreExpr] -- ^ The TestInput
93 -> Bool -- ^ Is it stateful (in case InitState is not specified)
94 -> IO [(AST.VHDLId, AST.DesignFile)]
95 moduleToVHDL env cores top init test stateful = do
96 let topEntity = Maybe.catMaybes top
98 [] -> error "Top Entity Not Found"
100 let initialState = Maybe.catMaybes init
101 let isStateful = not (null initialState) || stateful
102 let testInput = Maybe.catMaybes test
103 -- Generate a UniqSupply
105 -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
106 -- on the compiler dir of ghc suggests that 'z' is not used to generate
107 -- a unique supply anywhere.
108 uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
109 let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
110 let testexprs = case testInput of [] -> [] ; [x] -> reduceCoreListToHsList x
111 let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topEnt] [isStateful]
112 let vhdl = createDesignFiles typestate normalized_bindings topEnt test_bindings
113 mapM (putStr . render . Ppr.ppr . snd) vhdl
115 xs -> error "More than one topentity found"
117 -- | Prepares the directory for writing VHDL files. This means creating the
118 -- dir if it does not exist and removing all existing .vhdl files from it.
119 prepareDir :: String -> IO()
121 -- Create the dir if needed
122 Directory.createDirectoryIfMissing True dir
123 -- Find all .vhdl files in the directory
124 files <- Directory.getDirectoryContents dir
125 let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
126 -- Prepend the dirname to the filenames
127 let abs_to_remove = map (FilePath.combine dir) to_remove
129 mapM_ Directory.removeFile abs_to_remove
131 -- | Write the given design file to a file with the given name inside the
133 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
134 writeVHDL dir (name, vhdl) = do
136 let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
138 Language.VHDL.FileIO.writeDesignFile vhdl fname
140 -- vim: set ts=8 sw=2 sts=2 expandtab: