7ea489f7d2a439926cb8d0376978841c46b57cc9
[matthijs/master-project/cλash.git] / Translator.hs
1 module CLasH.Translator 
2   ( makeVHDLStrings
3   , makeVHDLAnnotations
4   ) where
5
6 -- Standard Modules
7 import qualified Directory
8 import qualified Maybe
9 import qualified Monad
10 import qualified System.FilePath as FilePath
11 import Text.PrettyPrint.HughesPJ (render)
12
13 -- GHC API
14 import qualified CoreSyn
15 import qualified GHC
16 import qualified HscTypes
17 import qualified UniqSupply
18
19 -- VHDL Imports
20 import qualified Language.VHDL.AST as AST
21 import qualified Language.VHDL.FileIO
22 import qualified Language.VHDL.Ppr as Ppr
23
24 -- Local Imports
25 import CLasH.Normalize
26 import CLasH.Translator.Annotations
27 import CLasH.Utils.Core.CoreTools
28 import CLasH.Utils.GhcTools
29 import CLasH.VHDL
30
31 -- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial
32 --   State and Test Inputs.
33 makeVHDLStrings :: 
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)
40   -> IO ()
41 makeVHDLStrings libdir filenames topentity initstate testinput stateful = do
42   makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
43     where
44       findTopEntity = findBind (hasVarName topentity)
45       findInitState = findBind (hasVarName initstate)
46       findTestInput = findExpr (hasVarName testinput)
47
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)
54   -> IO ()
55 makeVHDLAnnotations libdir filenames stateful = do
56   makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
57     where
58       findTopEntity = findBind (hasCLasHAnnotation isTopEntity)
59       findInitState = findBind (hasCLasHAnnotation isInitState)
60       findTestInput = findExpr (hasCLasHAnnotation isTestInput)
61
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.
64 makeVHDL ::
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
71   -> IO ()
72 makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful = do
73   -- Load the modules
74   (cores, top, init, test, env) <- loadModules libdir filenames topEntFinder initStateFinder testInputFinder
75   -- Translate to VHDL
76   vhdl <- moduleToVHDL env cores top init test stateful
77   -- Write VHDL to file
78   let top_entity = Maybe.fromJust $ head top
79   let dir = "./vhdl/" ++ (show top_entity) ++ "/"
80   prepareDir dir
81   mapM (writeVHDL dir) vhdl
82   return ()
83
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
86 --   stateless (False).
87 moduleToVHDL ::
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
97   case topEntity of
98     [] -> error "Top Entity Not Found"
99     [topEnt] -> do
100       let initialState = Maybe.catMaybes init
101       let isStateful = not (null initialState) || stateful
102       let testInput = Maybe.catMaybes test
103       uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
104       let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
105       let testexprs = case testInput of [] -> [] ; [x] -> reduceCoreListToHsList x
106       let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topEnt] [isStateful]
107       let vhdl = createDesignFiles typestate normalized_bindings topEnt test_bindings
108       mapM (putStr . render . Ppr.ppr . snd) vhdl
109       return vhdl
110     xs -> error "More than one topentity found"
111
112 -- | Prepares the directory for writing VHDL files. This means creating the
113 --   dir if it does not exist and removing all existing .vhdl files from it.
114 prepareDir :: String -> IO()
115 prepareDir dir = do
116   -- Create the dir if needed
117   exists <- Directory.doesDirectoryExist dir
118   Monad.unless exists $ Directory.createDirectory dir
119   -- Find all .vhdl files in the directory
120   files <- Directory.getDirectoryContents dir
121   let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
122   -- Prepend the dirname to the filenames
123   let abs_to_remove = map (FilePath.combine dir) to_remove
124   -- Remove the files
125   mapM_ Directory.removeFile abs_to_remove
126
127 -- | Write the given design file to a file with the given name inside the
128 --   given dir
129 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
130 writeVHDL dir (name, vhdl) = do
131   -- Find the filename
132   let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
133   -- Write the file
134   Language.VHDL.FileIO.writeDesignFile vhdl fname
135
136 -- vim: set ts=8 sw=2 sts=2 expandtab: