Add a double invertor model.
[matthijs/master-project/cλash.git] / Translator.hs
1 module Main(main) where
2 import GHC
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 Data.Generics
14 import NameEnv ( lookupNameEnv )
15 import HscTypes ( cm_binds, cm_types )
16 import MonadUtils ( liftIO )
17 import Outputable ( showSDoc, ppr )
18 import GHC.Paths ( libdir )
19 import DynFlags ( defaultDynFlags )
20 import List ( find )
21 -- The following modules come from the ForSyDe project. They are really
22 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
23 -- ForSyDe to get access to these modules.
24 import qualified ForSyDe.Backend.VHDL.AST as AST
25 import qualified ForSyDe.Backend.VHDL.Ppr
26 import qualified ForSyDe.Backend.Ppr
27 -- This is needed for rendering the pretty printed VHDL
28 import Text.PrettyPrint.HughesPJ (render)
29
30 main = 
31     do
32       defaultErrorHandler defaultDynFlags $ do
33         runGhc (Just libdir) $ do
34           dflags <- getSessionDynFlags
35           setSessionDynFlags dflags
36           --target <- guessTarget "adder.hs" Nothing
37           --liftIO (print (showSDoc (ppr (target))))
38           --liftIO $ printTarget target
39           --setTargets [target]
40           --load LoadAllTargets
41           --core <- GHC.compileToCoreSimplified "Adders.hs"
42           core <- GHC.compileToCoreSimplified "Adders.hs"
43           liftIO $ printBinds (cm_binds core)
44           let bind = findBind "inv" (cm_binds core)
45           let NonRec var expr = bind
46           -- Turn bind into VHDL
47           let vhdl = State.evalState (mkVHDL bind) (VHDLSession 0 builtin_funcs)
48           liftIO $ putStr $ showSDoc $ ppr expr
49           liftIO $ putStr "\n\n"
50           liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ vhdl
51           return expr
52   where
53     -- Turns the given bind into VHDL
54     mkVHDL bind = do
55       -- Get the function signature
56       (name, f) <- mkHWFunction bind
57       -- Add it to the session
58       addFunc name f
59       arch <- getArchitecture bind
60       return arch
61
62 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
63   print $ show file
64
65 printBinds [] = putStr "done\n\n"
66 printBinds (b:bs) = do
67   printBind b
68   putStr "\n"
69   printBinds bs
70
71 printBind (NonRec b expr) = do
72   putStr "NonRec: "
73   printBind' (b, expr)
74
75 printBind (Rec binds) = do
76   putStr "Rec: \n"  
77   foldl1 (>>) (map printBind' binds)
78
79 printBind' (b, expr) = do
80   putStr $ getOccString b
81   --putStr $ showSDoc $ ppr expr
82   putStr "\n"
83
84 findBind :: String -> [CoreBind] -> CoreBind
85 findBind lookfor =
86   -- This ignores Recs and compares the name of the bind with lookfor,
87   -- disregarding any namespaces in OccName and extra attributes in Name and
88   -- Var.
89   Maybe.fromJust . find (\b -> case b of 
90     Rec l -> False
91     NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
92   )
93
94 getPortMapEntry ::
95   SignalNameMap AST.VHDLId  -- The port name to bind to
96   -> SignalNameMap AST.VHDLId 
97                             -- The signal or port to bind to it
98   -> AST.AssocElem          -- The resulting port map entry
99   
100 -- Accepts a port name and an argument to map to it.
101 -- Returns the appropriate line for in the port map
102 getPortMapEntry (Signal portname) (Signal signame) = 
103   (Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
104
105 getInstantiations ::
106   [SignalNameMap AST.VHDLId]   -- The arguments that need to be applied to the
107                                -- expression.
108   -> SignalNameMap AST.VHDLId  -- The output ports that the expression should generate.
109   -> [(CoreBndr, SignalNameMap AST.VHDLId)] 
110                                -- A list of bindings in effect
111   -> CoreSyn.CoreExpr          -- The expression to generate an architecture for
112   -> VHDLState ([AST.SigDec], [AST.ConcSm])    
113                                -- The resulting VHDL code
114
115 -- A lambda expression binds the first argument (a) to the binder b.
116 getInstantiations (a:as) outs binds (Lam b expr) =
117   getInstantiations as outs ((b, a):binds) expr
118
119 -- A case expression that checks a single variable and has a single
120 -- alternative, can be used to take tuples apart
121 getInstantiations args outs binds (Case (Var v) b _ [res]) =
122   -- Split out the type of alternative constructor, the variables it binds
123   -- and the expression to evaluate with the variables bound.
124   let (altcon, bind_vars, expr) = res in
125   case altcon of
126     DataAlt datacon ->
127       if (DataCon.isTupleCon datacon) then
128         let 
129           -- Lookup the scrutinee (which must be a variable bound to a tuple) in
130           -- the existing bindings list and get the portname map for each of
131           -- it's elements.
132           Tuple tuple_ports = Maybe.fromMaybe 
133             (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
134             (lookup v binds)
135           -- Merge our existing binds with the new binds.
136           binds' = (zip bind_vars tuple_ports) ++ binds 
137         in
138           -- Evaluate the expression with the new binds list
139           getInstantiations args outs binds' expr
140       else
141         error "Data constructors other than tuples not supported"
142     otherwise ->
143       error "Case binders other than tuples not supported"
144
145 -- An application is an instantiation of a component
146 getInstantiations args outs binds app@(App expr arg) = do
147   let ((Var f), fargs) = collectArgs app
148       name = getOccString f
149   if isTupleConstructor f 
150     then do
151       -- Get the signals we should bind our results to
152       let Tuple outports = outs
153       -- Split the tuple constructor arguments into types and actual values.
154       let (_, vals) = splitTupleConstructorArgs fargs
155       -- Bind each argument to each output signal
156       res <- sequence $ zipWith 
157         (\outs' expr' -> getInstantiations args outs' binds expr')
158         outports vals
159       -- res is a list of pairs of lists, so split out the signals and
160       -- components into separate lists of lists
161       let (sigs, comps) = unzip res
162       -- And join all the signals and component instantiations together
163       return $ (concat sigs, concat comps)
164     else do
165       -- This is an normal function application, which maps to a component
166       -- instantiation.
167       -- Lookup the hwfunction to instantiate
168       HWFunction inports outport <- getHWFunc name
169       -- Generate a unique name for the application
170       appname <- uniqueName "app"
171       -- Expand each argument to a signal or port name, possibly generating
172       -- new signals and component instantiations
173       (sigs, comps, args) <- expandArgs binds fargs
174       -- Bind each of the input ports to the expanded signal or port
175       let inmaps = zipWith getPortMapEntry inports args
176       -- Bind each of the output ports to our output signals
177       let outmaps = mapOutputPorts outport outs
178       -- Build and return a component instantiation
179       let comp = AST.CompInsSm
180             (AST.unsafeVHDLBasicId appname)
181             (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
182             (AST.PMapAspect (inmaps ++ outmaps))
183       return (sigs, (AST.CSISm comp) : comps)
184
185 getInstantiations args outs binds expr = 
186   error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
187
188 expandExpr ::
189   [(CoreBndr, SignalNameMap AST.VHDLId)] 
190                                          -- A list of bindings in effect
191   -> CoreExpr                            -- The expression to expand
192   -> VHDLState (
193        [AST.SigDec],                     -- Needed signal declarations
194        [AST.ConcSm],                     -- Needed component instantations and
195                                          -- signal assignments.
196        [SignalNameMap AST.VHDLId],       -- The signal names corresponding to
197                                          -- the expression's arguments
198        SignalNameMap AST.VHDLId)         -- The signal names corresponding to
199                                          -- the expression's result.
200 expandExpr binds (Lam b expr) = do
201   -- Generate a new signal to which we will expect this argument to be bound.
202   signal_name <- uniqueName ("arg-" ++ getOccString b)
203   -- TODO: This uses the bit type hardcoded
204   let (signal_id, signal_decl) = mkSignal signal_name vhdl_bit_ty
205   -- Add the binder to the list of binds
206   let binds' = (b, Signal signal_id) : binds
207   -- Expand the rest of the expression
208   (signal_decls, statements, arg_signals, res_signal) <- expandExpr binds' expr
209   -- Properly merge the results
210   return (signal_decl : signal_decls,
211           statements,
212           (Signal signal_id) : arg_signals,
213           res_signal)
214
215 expandExpr binds (Var id) =
216   return ([], [], [], Signal signal_id)
217   where
218     -- Lookup the id in our binds map
219     Signal signal_id = Maybe.fromMaybe
220       (error $ "Argument " ++ getOccString id ++ "is unknown")
221       (lookup id binds)
222
223 expandExpr binds app@(App _ _) = do
224   let ((Var f), args) = collectArgs app
225   if isTupleConstructor f 
226     then
227       expandBuildTupleExpr binds args
228     else
229       expandApplicationExpr binds (CoreUtils.exprType app) f args
230
231 expandExpr binds expr = 
232   error $ "Unsupported expression: " ++ (showSDoc $ ppr $ expr)
233
234 -- Expands the construction of a tuple into VHDL
235 expandBuildTupleExpr ::
236   [(CoreBndr, SignalNameMap AST.VHDLId)] 
237                                          -- A list of bindings in effect
238   -> [CoreExpr]                          -- A list of expressions to put in the tuple
239   -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
240                                          -- See expandExpr
241 expandBuildTupleExpr binds args =
242   error $ "Tuple construction not supported"
243
244 -- Expands the application of argument to a function into VHDL
245 expandApplicationExpr ::
246   [(CoreBndr, SignalNameMap AST.VHDLId)] 
247                                          -- A list of bindings in effect
248   -> Type                                -- The result type of the function call
249   -> Var.Var                             -- The function to call
250   -> [CoreExpr]                          -- A list of argumetns to apply to the function
251   -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
252                                          -- See expandExpr
253 expandApplicationExpr binds ty f args = do
254   let name = getOccString f
255   -- Generate a unique name for the application
256   appname <- uniqueName ("app-" ++ name)
257   -- Lookup the hwfunction to instantiate
258   HWFunction inports outport <- getHWFunc name
259   -- Expand each of the args, so each of them is reduced to output signals
260   (arg_signal_decls, arg_statements, arg_res_signals) <- expandArgs binds args
261   -- Bind each of the input ports to the expanded arguments
262   let inmaps = concat $ zipWith createAssocElems inports arg_res_signals
263   -- Create signal names for our result
264   let res_signal = getPortNameMapForTy (appname ++ "-out") ty
265   -- Create the corresponding signal declarations
266   let signal_decls = mkSignalsFromMap res_signal
267   -- Bind each of the output ports to our output signals
268   let outmaps = mapOutputPorts outport res_signal
269   -- Instantiate the component
270   let component = AST.CSISm $ AST.CompInsSm
271         (AST.unsafeVHDLBasicId appname)
272         (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
273         (AST.PMapAspect (inmaps ++ outmaps))
274   -- Merge the generated declarations
275   return (
276     signal_decls ++ arg_signal_decls,
277     component : arg_statements,
278     [], -- We don't take any extra arguments; we don't support higher order functions yet
279     res_signal)
280   
281 -- Creates a list of AssocElems (port map lines) that maps the given signals
282 -- to the given ports.
283 createAssocElems ::
284   SignalNameMap AST.VHDLId      -- The port names to bind to
285   -> SignalNameMap AST.VHDLId   -- The signals to bind to it
286   -> [AST.AssocElem]            -- The resulting port map lines
287   
288 createAssocElems (Signal port_id) (Signal signal_id) = 
289   [(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
290
291 createAssocElems (Tuple ports) (Tuple signals) = 
292   concat $ zipWith createAssocElems ports signals
293
294 -- Generate a signal declaration for a signal with the given name and the
295 -- given type and no value. Also returns the id of the signal.
296 mkSignal :: String -> AST.TypeMark -> (AST.VHDLId, AST.SigDec)
297 mkSignal name ty =
298   (id, mkSignalFromId id ty)
299   where 
300     id = AST.unsafeVHDLBasicId name
301
302 mkSignalFromId :: AST.VHDLId -> AST.TypeMark -> AST.SigDec
303 mkSignalFromId id ty =
304   AST.SigDec id ty Nothing
305
306 -- Generates signal declarations for all the signals in the given map
307 mkSignalsFromMap ::
308   SignalNameMap AST.VHDLId 
309   -> [AST.SigDec]
310
311 mkSignalsFromMap (Signal id) =
312   -- TODO: This uses the bit type hardcoded
313   [mkSignalFromId id vhdl_bit_ty]
314
315 mkSignalsFromMap (Tuple signals) =
316   concat $ map mkSignalsFromMap signals
317
318 expandArgs :: 
319   [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
320   -> [CoreExpr]                          -- The arguments to expand
321   -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId])  
322                                          -- The resulting signal declarations,
323                                          -- component instantiations and a
324                                          -- VHDLName for each of the
325                                          -- expressions passed in.
326 expandArgs binds (e:exprs) = do
327   -- Expand the first expression
328   arg <- case e of
329     -- A simple variable reference should be in our binds map
330     Var id -> return $ let
331         -- Lookup the id in our binds map
332         Signal signalid = Maybe.fromMaybe
333           (error $ "Argument " ++ getOccString id ++ "is unknown")
334           (lookup id binds)
335       in
336         -- Create a VHDL name from the signal name
337         Signal signalid
338     -- Other expressions are unsupported
339     otherwise -> error ("Unsupported expression used as argument: " ++ (showSDoc $ ppr e))
340   -- Expand the rest
341   (sigs, comps, args) <- expandArgs binds exprs
342   -- Return all results
343   return (sigs, comps, arg:args)
344
345 expandArgs _ [] = return ([], [], [])
346
347 -- Is the given name a (binary) tuple constructor
348 isTupleConstructor :: Var.Var -> Bool
349 isTupleConstructor var =
350   Name.isWiredInName name
351   && Name.nameModule name == tuple_mod
352   && (Name.occNameString $ Name.nameOccName name) == "(,)"
353   where
354     name = Var.varName var
355     mod = nameModule name
356     tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
357
358 -- Split arguments into type arguments and value arguments This is probably
359 -- not really sufficient (not sure if Types can actually occur as value
360 -- arguments...)
361 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
362 splitTupleConstructorArgs (e:es) =
363   case e of
364     Type t     -> (e:tys, vals)
365     otherwise  -> (tys, e:vals)
366   where
367     (tys, vals) = splitTupleConstructorArgs es
368
369 mapOutputPorts ::
370   SignalNameMap AST.VHDLId      -- The output portnames of the component
371   -> SignalNameMap AST.VHDLId   -- The output portnames and/or signals to map these to
372   -> [AST.AssocElem]            -- The resulting output ports
373
374 -- Map the output port of a component to the output port of the containing
375 -- entity.
376 mapOutputPorts (Signal portname) (Signal signalname) =
377   [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
378
379 -- Map matching output ports in the tuple
380 mapOutputPorts (Tuple ports) (Tuple signals) =
381   concat (zipWith mapOutputPorts ports signals)
382
383 getArchitecture ::
384   CoreBind                  -- The binder to expand into an architecture
385   -> VHDLState AST.ArchBody -- The resulting architecture
386    
387 getArchitecture (Rec _) = error "Recursive binders not supported"
388
389 getArchitecture (NonRec var expr) = do
390   let name = (getOccString var)
391   HWFunction inports outport <- getHWFunc name
392   sess <- State.get
393   (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
394   let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
395   let outport_assigns = createSignalAssignments outport res_signal
396   return $ AST.ArchBody
397     (AST.unsafeVHDLBasicId "structural")
398     -- Use unsafe for now, to prevent pulling in ForSyDe error handling
399     (AST.NSimple (AST.unsafeVHDLBasicId name))
400     (map AST.BDISD signal_decls)
401     (inport_assigns ++ outport_assigns ++ statements)
402
403 -- Create concurrent assignments of one map of signals to another. The maps
404 -- should have a similar form.
405 createSignalAssignments ::
406   SignalNameMap AST.VHDLId         -- The signals to assign to
407   -> SignalNameMap AST.VHDLId      -- The signals to assign
408   -> [AST.ConcSm]                  -- The resulting assignments
409
410 -- A simple assignment of one signal to another (greatly complicated because
411 -- signal assignments can be conditional with multiple conditions in VHDL).
412 createSignalAssignments (Signal dst) (Signal src) =
413     [AST.CSSASm assign]
414   where
415     src_name  = AST.NSimple src
416     src_expr  = AST.PrimName src_name
417     src_wform = AST.Wform [AST.WformElem src_expr Nothing]
418     dst_name  = (AST.NSimple dst)
419     assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
420
421 createSignalAssignments (Tuple dsts) (Tuple srcs) =
422   concat $ zipWith createSignalAssignments dsts srcs
423
424 data SignalNameMap t =
425   Tuple [SignalNameMap t]
426   | Signal  t
427   deriving (Show)
428
429 -- Generate a port name map (or multiple for tuple types) in the given direction for
430 -- each type given.
431 getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap AST.VHDLId]
432 getPortNameMapForTys prefix num [] = [] 
433 getPortNameMapForTys prefix num (t:ts) =
434   (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
435
436 getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
437 getPortNameMapForTy name ty =
438   if (TyCon.isTupleTyCon tycon) then
439     -- Expand tuples we find
440     Tuple (getPortNameMapForTys name 0 args)
441   else -- Assume it's a type constructor application, ie simple data type
442     -- TODO: Add type?
443     Signal (AST.unsafeVHDLBasicId name)
444   where
445     (tycon, args) = Type.splitTyConApp ty 
446
447 data HWFunction = HWFunction { -- A function that is available in hardware
448   inPorts   :: [SignalNameMap AST.VHDLId],
449   outPort   :: SignalNameMap AST.VHDLId
450   --entity    :: AST.EntityDec
451 } deriving (Show)
452
453 -- Turns a CoreExpr describing a function into a description of its input and
454 -- output ports.
455 mkHWFunction ::
456   CoreBind                                   -- The core binder to generate the interface for
457   -> VHDLState (String, HWFunction)          -- The name of the function and its interface
458
459 mkHWFunction (NonRec var expr) =
460     return (name, HWFunction inports outport)
461   where
462     name = (getOccString var)
463     ty = CoreUtils.exprType expr
464     (fargs, res) = Type.splitFunTys ty
465     args = if length fargs == 1 then fargs else (init fargs)
466     --state = if length fargs == 1 then () else (last fargs)
467     inports = case args of
468       -- Handle a single port specially, to prevent an extra 0 in the name
469       [port] -> [getPortNameMapForTy "portin" port]
470       ps     -> getPortNameMapForTys "portin" 0 ps
471     outport = getPortNameMapForTy "portout" res
472
473 mkHWFunction (Rec _) =
474   error "Recursive binders not supported"
475
476 data VHDLSession = VHDLSession {
477   nameCount :: Int,                      -- A counter that can be used to generate unique names
478   funcs     :: [(String, HWFunction)]    -- All functions available, indexed by name
479 } deriving (Show)
480
481 type VHDLState = State.State VHDLSession
482
483 -- Add the function to the session
484 addFunc :: String -> HWFunction -> VHDLState ()
485 addFunc name f = do
486   fs <- State.gets funcs -- Get the funcs element from the session
487   State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
488
489 -- Lookup the function with the given name in the current session. Errors if
490 -- it was not found.
491 getHWFunc :: String -> VHDLState HWFunction
492 getHWFunc name = do
493   fs <- State.gets funcs -- Get the funcs element from the session
494   return $ Maybe.fromMaybe
495     (error $ "Function " ++ name ++ "is unknown? This should not happen!")
496     (lookup name fs)
497
498 -- Makes the given name unique by appending a unique number.
499 -- This does not do any checking against existing names, so it only guarantees
500 -- uniqueness with other names generated by uniqueName.
501 uniqueName :: String -> VHDLState String
502 uniqueName name = do
503   count <- State.gets nameCount -- Get the funcs element from the session
504   State.modify (\s -> s {nameCount = count + 1})
505   return $ name ++ "-" ++ (show count)
506
507 -- Shortcut
508 mkVHDLId :: String -> AST.VHDLId
509 mkVHDLId = AST.unsafeVHDLBasicId
510
511 builtin_funcs = 
512   [ 
513     ("hwxor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
514     ("hwand", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
515     ("hwnot", HWFunction [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
516   ]
517
518 vhdl_bit_ty :: AST.TypeMark
519 vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
520
521 -- vim: set ts=8 sw=2 sts=2 expandtab: