ed560ec59e136830a9433fe41a88174e7f4f5f58
[matthijs/master-project/cλash.git] / Translator.hs
1 module Translator where
2 import GHC hiding (loadModule, sigName)
3 import CoreSyn
4 import qualified CoreUtils
5 import qualified Var
6 import qualified Type
7 import qualified TyCon
8 import qualified DataCon
9 import qualified Maybe
10 import qualified Module
11 import qualified Control.Monad.State as State
12 import Name
13 import qualified Data.Map as Map
14 import Data.Generics
15 import NameEnv ( lookupNameEnv )
16 import qualified HscTypes
17 import HscTypes ( cm_binds, cm_types )
18 import MonadUtils ( liftIO )
19 import Outputable ( showSDoc, ppr )
20 import GHC.Paths ( libdir )
21 import DynFlags ( defaultDynFlags )
22 import List ( find )
23 import qualified List
24 import qualified Monad
25
26 -- The following modules come from the ForSyDe project. They are really
27 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
28 -- ForSyDe to get access to these modules.
29 import qualified ForSyDe.Backend.VHDL.AST as AST
30 import qualified ForSyDe.Backend.VHDL.Ppr
31 import qualified ForSyDe.Backend.VHDL.FileIO
32 import qualified ForSyDe.Backend.Ppr
33 -- This is needed for rendering the pretty printed VHDL
34 import Text.PrettyPrint.HughesPJ (render)
35
36 import TranslatorTypes
37 import HsValueMap
38 import Pretty
39 import Flatten
40 import FlattenTypes
41 import VHDLTypes
42 import qualified VHDL
43
44 main = do
45   makeVHDL "Alu.hs" "register_bank"
46
47 makeVHDL :: String -> String -> IO ()
48 makeVHDL filename name = do
49   -- Load the module
50   core <- loadModule filename
51   -- Translate to VHDL
52   vhdl <- moduleToVHDL core [name]
53   -- Write VHDL to file
54   mapM (writeVHDL "../vhdl/vhdl/") vhdl
55   return ()
56
57 -- | Show the core structure of the given binds in the given file.
58 listBind :: String -> String -> IO ()
59 listBind filename name = do
60   core <- loadModule filename
61   let binds = findBinds core [name]
62   putStr "\n"
63   putStr $ prettyShow binds
64   putStr "\n\n"
65   putStr $ showSDoc $ ppr binds
66   putStr "\n\n"
67
68 -- | Translate the binds with the given names from the given core module to
69 --   VHDL
70 moduleToVHDL :: HscTypes.CoreModule -> [String] -> IO [AST.DesignFile]
71 moduleToVHDL core names = do
72   --liftIO $ putStr $ prettyShow (cm_binds core)
73   let binds = findBinds core names
74   --putStr $ prettyShow binds
75   -- Turn bind into VHDL
76   let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession core 0 Map.empty)
77   mapM (putStr . render . ForSyDe.Backend.Ppr.ppr) vhdl
78   putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
79   return vhdl
80
81   where
82     -- Turns the given bind into VHDL
83     mkVHDL binds = do
84       -- Add the builtin functions
85       mapM addBuiltIn builtin_funcs
86       -- Create entities and architectures for them
87       mapM processBind binds
88       modFuncs nameFlatFunction
89       modFuncs VHDL.createEntity
90       modFuncs VHDL.createArchitecture
91       VHDL.getDesignFiles
92
93 -- | Write the given design file to a file inside the given dir
94 --   The first library unit in the designfile must be an entity, whose name
95 --   will be used as a filename.
96 writeVHDL :: String -> AST.DesignFile -> IO ()
97 writeVHDL dir vhdl = do
98   let AST.DesignFile _ (u:us) = vhdl
99   let AST.LUEntity (AST.EntityDec id _) = u
100   let fname = dir ++ AST.fromVHDLId id ++ ".vhdl"
101   ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
102
103 -- | Loads the given file and turns it into a core module.
104 loadModule :: String -> IO HscTypes.CoreModule
105 loadModule filename =
106   defaultErrorHandler defaultDynFlags $ do
107     runGhc (Just libdir) $ do
108       dflags <- getSessionDynFlags
109       setSessionDynFlags dflags
110       --target <- guessTarget "adder.hs" Nothing
111       --liftIO (print (showSDoc (ppr (target))))
112       --liftIO $ printTarget target
113       --setTargets [target]
114       --load LoadAllTargets
115       --core <- GHC.compileToCoreSimplified "Adders.hs"
116       core <- GHC.compileToCoreSimplified filename
117       return core
118
119 -- | Extracts the named binds from the given module.
120 findBinds :: HscTypes.CoreModule -> [String] -> [CoreBind]
121 findBinds core names = Maybe.mapMaybe (findBind (cm_binds core)) names
122
123 -- | Extract a named bind from the given list of binds
124 findBind :: [CoreBind] -> String -> Maybe CoreBind
125 findBind binds lookfor =
126   -- This ignores Recs and compares the name of the bind with lookfor,
127   -- disregarding any namespaces in OccName and extra attributes in Name and
128   -- Var.
129   find (\b -> case b of 
130     Rec l -> False
131     NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
132   ) binds
133
134 -- | Processes the given bind as a top level bind.
135 processBind ::
136   CoreBind                        -- The bind to process
137   -> VHDLState ()
138
139 processBind  (Rec _) = error "Recursive binders not supported"
140 processBind bind@(NonRec var expr) = do
141   -- Create the function signature
142   let ty = CoreUtils.exprType expr
143   let hsfunc = mkHsFunction var ty
144   flattenBind hsfunc bind
145
146 -- | Flattens the given bind into the given signature and adds it to the
147 --   session. Then (recursively) finds any functions it uses and does the same
148 --   with them.
149 flattenBind ::
150   HsFunction                         -- The signature to flatten into
151   -> CoreBind                        -- The bind to flatten
152   -> VHDLState ()
153
154 flattenBind _ (Rec _) = error "Recursive binders not supported"
155
156 flattenBind hsfunc bind@(NonRec var expr) = do
157   -- Flatten the function
158   let flatfunc = flattenFunction hsfunc bind
159   addFunc hsfunc
160   setFlatFunc hsfunc flatfunc
161   let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc)
162   State.mapM resolvFunc used_hsfuncs
163   return ()
164
165 -- | Find the given function, flatten it and add it to the session. Then
166 --   (recursively) do the same for any functions used.
167 resolvFunc ::
168   HsFunction        -- | The function to look for
169   -> VHDLState ()
170
171 resolvFunc hsfunc = do
172   -- See if the function is already known
173   func <- getFunc hsfunc
174   case func of
175     -- Already known, do nothing
176     Just _ -> do
177       return ()
178     -- New function, resolve it
179     Nothing -> do
180       -- Get the current module
181       core <- getModule
182       -- Find the named function
183       let bind = findBind (cm_binds core) name
184       case bind of
185         Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
186         Just b  -> flattenBind hsfunc b
187   where
188     name = hsFuncName hsfunc
189
190 -- | Translate a top level function declaration to a HsFunction. i.e., which
191 --   interface will be provided by this function. This function essentially
192 --   defines the "calling convention" for hardware models.
193 mkHsFunction ::
194   Var.Var         -- ^ The function defined
195   -> Type         -- ^ The function type (including arguments!)
196   -> HsFunction   -- ^ The resulting HsFunction
197
198 mkHsFunction f ty =
199   HsFunction hsname hsargs hsres
200   where
201     hsname  = getOccString f
202     (arg_tys, res_ty) = Type.splitFunTys ty
203     -- The last argument must be state
204     state_ty = last arg_tys
205     state    = useAsState (mkHsValueMap state_ty)
206     -- All but the last argument are inports
207     inports = map (useAsPort . mkHsValueMap)(init arg_tys)
208     hsargs   = inports ++ [state]
209     hsres    = case splitTupleType res_ty of
210       -- Result type must be a two tuple (state, ports)
211       Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
212         then
213           Tuple [state, useAsPort (mkHsValueMap outport_ty)]
214         else
215           error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
216       otherwise                -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
217
218 -- | Adds signal names to the given FlatFunction
219 nameFlatFunction ::
220   HsFunction
221   -> FuncData
222   -> VHDLState ()
223
224 nameFlatFunction hsfunc fdata =
225   let func = flatFunc fdata in
226   case func of
227     -- Skip (builtin) functions without a FlatFunction
228     Nothing -> do return ()
229     -- Name the signals in all other functions
230     Just flatfunc ->
231       let s = flat_sigs flatfunc in
232       let s' = map nameSignal s in
233       let flatfunc' = flatfunc { flat_sigs = s' } in
234       setFlatFunc hsfunc flatfunc'
235   where
236     nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
237     nameSignal (id, info) =
238       let hints = nameHints info in
239       let parts = ("sig" : hints) ++ [show id] in
240       let name = concat $ List.intersperse "_" parts in
241       (id, info {sigName = Just name})
242
243 -- | Splits a tuple type into a list of element types, or Nothing if the type
244 --   is not a tuple type.
245 splitTupleType ::
246   Type              -- ^ The type to split
247   -> Maybe [Type]   -- ^ The tuples element types
248
249 splitTupleType ty =
250   case Type.splitTyConApp_maybe ty of
251     Just (tycon, args) -> if TyCon.isTupleTyCon tycon 
252       then
253         Just args
254       else
255         Nothing
256     Nothing -> Nothing
257
258 -- | A consise representation of a (set of) ports on a builtin function
259 type PortMap = HsValueMap (String, AST.TypeMark)
260 -- | A consise representation of a builtin function
261 data BuiltIn = BuiltIn String [PortMap] PortMap
262
263 -- | Map a port specification of a builtin function to a VHDL Signal to put in
264 --   a VHDLSignalMap
265 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
266 toVHDLSignalMap = fmap (\(name, ty) -> Just (VHDL.mkVHDLId name, ty))
267
268 -- | Translate a concise representation of a builtin function to something
269 --   that can be put into FuncMap directly.
270 addBuiltIn :: BuiltIn -> VHDLState ()
271 addBuiltIn (BuiltIn name args res) = do
272     addFunc hsfunc
273     setEntity hsfunc entity
274   where
275     hsfunc = HsFunction name (map useAsPort args) (useAsPort res)
276     entity = Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res) Nothing
277
278 builtin_funcs = 
279   [ 
280     BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
281     BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
282     BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
283     BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
284   ]
285
286 -- vim: set ts=8 sw=2 sts=2 expandtab: