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