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