1 module Main(main) where
4 import qualified CoreUtils
8 import qualified DataCon
10 import qualified Module
11 import qualified Control.Monad.State as State
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 )
22 import qualified Monad
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.Ppr
30 -- This is needed for rendering the pretty printed VHDL
31 import Text.PrettyPrint.HughesPJ (render)
35 defaultErrorHandler defaultDynFlags $ do
36 runGhc (Just libdir) $ do
37 dflags <- getSessionDynFlags
38 setSessionDynFlags dflags
39 --target <- guessTarget "adder.hs" Nothing
40 --liftIO (print (showSDoc (ppr (target))))
41 --liftIO $ printTarget target
44 --core <- GHC.compileToCoreSimplified "Adders.hs"
45 core <- GHC.compileToCoreSimplified "Adders.hs"
46 --liftIO $ printBinds (cm_binds core)
47 let binds = Maybe.mapMaybe (findBind (cm_binds core)) ["full_adder", "half_adder"]
48 liftIO $ printBinds binds
49 -- Turn bind into VHDL
50 let vhdl = State.evalState (mkVHDL binds) (VHDLSession 0 [])
51 liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl
54 -- Turns the given bind into VHDL
56 -- Add the builtin functions
57 mapM (uncurry addFunc) builtin_funcs
58 -- Get the function signatures
59 funcs <- mapM mkHWFunction binds
60 -- Add them to the session
61 mapM (uncurry addFunc) funcs
62 let entities = map getEntity (snd $ unzip funcs)
63 -- Create architectures for them
64 archs <- mapM getArchitecture binds
65 return $ AST.DesignFile
67 ((map AST.LUEntity entities) ++ (map AST.LUArch archs))
69 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
72 printBinds [] = putStr "done\n\n"
73 printBinds (b:bs) = do
78 printBind (NonRec b expr) = do
82 printBind (Rec binds) = do
84 foldl1 (>>) (map printBind' binds)
86 printBind' (b, expr) = do
87 putStr $ getOccString b
88 putStr $ showSDoc $ ppr expr
91 findBind :: [CoreBind] -> String -> Maybe CoreBind
92 findBind binds lookfor =
93 -- This ignores Recs and compares the name of the bind with lookfor,
94 -- disregarding any namespaces in OccName and extra attributes in Name and
98 NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
102 SignalNameMap AST.VHDLId -- The port name to bind to
103 -> SignalNameMap AST.VHDLId
104 -- The signal or port to bind to it
105 -> AST.AssocElem -- The resulting port map entry
107 -- Accepts a port name and an argument to map to it.
108 -- Returns the appropriate line for in the port map
109 getPortMapEntry (Signal portname) (Signal signame) =
110 (Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
113 [SignalNameMap AST.VHDLId] -- The arguments that need to be applied to the
115 -> SignalNameMap AST.VHDLId -- The output ports that the expression should generate.
116 -> [(CoreBndr, SignalNameMap AST.VHDLId)]
117 -- A list of bindings in effect
118 -> CoreSyn.CoreExpr -- The expression to generate an architecture for
119 -> VHDLState ([AST.SigDec], [AST.ConcSm])
120 -- The resulting VHDL code
122 -- A lambda expression binds the first argument (a) to the binder b.
123 getInstantiations (a:as) outs binds (Lam b expr) =
124 getInstantiations as outs ((b, a):binds) expr
126 -- A case expression that checks a single variable and has a single
127 -- alternative, can be used to take tuples apart
128 getInstantiations args outs binds (Case (Var v) b _ [res]) =
129 -- Split out the type of alternative constructor, the variables it binds
130 -- and the expression to evaluate with the variables bound.
131 let (altcon, bind_vars, expr) = res in
134 if (DataCon.isTupleCon datacon) then
136 -- Lookup the scrutinee (which must be a variable bound to a tuple) in
137 -- the existing bindings list and get the portname map for each of
139 Tuple tuple_ports = Maybe.fromMaybe
140 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
142 -- Merge our existing binds with the new binds.
143 binds' = (zip bind_vars tuple_ports) ++ binds
145 -- Evaluate the expression with the new binds list
146 getInstantiations args outs binds' expr
148 error "Data constructors other than tuples not supported"
150 error "Case binders other than tuples not supported"
152 -- An application is an instantiation of a component
153 getInstantiations args outs binds app@(App expr arg) = do
154 let ((Var f), fargs) = collectArgs app
155 name = getOccString f
156 if isTupleConstructor f
158 -- Get the signals we should bind our results to
159 let Tuple outports = outs
160 -- Split the tuple constructor arguments into types and actual values.
161 let (_, vals) = splitTupleConstructorArgs fargs
162 -- Bind each argument to each output signal
163 res <- sequence $ zipWith
164 (\outs' expr' -> getInstantiations args outs' binds expr')
166 -- res is a list of pairs of lists, so split out the signals and
167 -- components into separate lists of lists
168 let (sigs, comps) = unzip res
169 -- And join all the signals and component instantiations together
170 return $ (concat sigs, concat comps)
172 -- This is an normal function application, which maps to a component
174 -- Lookup the hwfunction to instantiate
175 HWFunction vhdl_id inports outport <- getHWFunc name
176 -- Generate a unique name for the application
177 appname <- uniqueName "app"
178 -- Expand each argument to a signal or port name, possibly generating
179 -- new signals and component instantiations
180 (sigs, comps, args) <- expandArgs binds fargs
181 -- Bind each of the input ports to the expanded signal or port
182 let inmaps = zipWith getPortMapEntry inports args
183 -- Bind each of the output ports to our output signals
184 let outmaps = mapOutputPorts outport outs
185 -- Build and return a component instantiation
186 let comp = AST.CompInsSm
187 (AST.unsafeVHDLBasicId appname)
188 (AST.IUEntity (AST.NSimple vhdl_id))
189 (AST.PMapAspect (inmaps ++ outmaps))
190 return (sigs, (AST.CSISm comp) : comps)
192 getInstantiations args outs binds expr =
193 error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
196 [(CoreBndr, SignalNameMap AST.VHDLId)]
197 -- A list of bindings in effect
198 -> CoreExpr -- The expression to expand
200 [AST.SigDec], -- Needed signal declarations
201 [AST.ConcSm], -- Needed component instantations and
202 -- signal assignments.
203 [SignalNameMap AST.VHDLId], -- The signal names corresponding to
204 -- the expression's arguments
205 SignalNameMap AST.VHDLId) -- The signal names corresponding to
206 -- the expression's result.
207 expandExpr binds lam@(Lam b expr) = do
208 -- Generate a new signal to which we will expect this argument to be bound.
209 signal_name <- uniqueName ("arg-" ++ getOccString b)
210 -- Find the type of the binder
211 let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
212 -- Create signal names for the binder
213 let arg_signal = getPortNameMapForTy ("xxx") arg_ty
214 -- Create the corresponding signal declarations
215 let signal_decls = mkSignalsFromMap arg_signal
216 -- Add the binder to the list of binds
217 let binds' = (b, arg_signal) : binds
218 -- Expand the rest of the expression
219 (signal_decls', statements', arg_signals', res_signal') <- expandExpr binds' expr
220 -- Properly merge the results
221 return (signal_decls ++ signal_decls',
223 arg_signal : arg_signals',
226 expandExpr binds (Var id) =
227 return ([], [], [], Signal signal_id)
229 -- Lookup the id in our binds map
230 Signal signal_id = Maybe.fromMaybe
231 (error $ "Argument " ++ getOccString id ++ "is unknown")
234 expandExpr binds l@(Let (NonRec b bexpr) expr) = do
235 (signal_decls, statements, arg_signals, res_signals) <- expandExpr binds bexpr
236 let binds' = (b, res_signals) : binds
237 (signal_decls', statements', arg_signals', res_signals') <- expandExpr binds' expr
239 signal_decls ++ signal_decls',
240 statements ++ statements',
244 expandExpr binds app@(App _ _) = do
245 let ((Var f), args) = collectArgs app
246 if isTupleConstructor f
248 expandBuildTupleExpr binds args
250 expandApplicationExpr binds (CoreUtils.exprType app) f args
252 expandExpr binds expr@(Case (Var v) b _ alts) =
254 [alt] -> expandSingleAltCaseExpr binds v b alt
255 otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
257 expandExpr binds expr@(Case _ b _ _) =
258 error $ "Case expression with non-variable scrutinee not supported: " ++ (showSDoc $ ppr expr)
260 expandExpr binds expr =
261 error $ "Unsupported expression: " ++ (showSDoc $ ppr $ expr)
263 -- Expands the construction of a tuple into VHDL
264 expandBuildTupleExpr ::
265 [(CoreBndr, SignalNameMap AST.VHDLId)]
266 -- A list of bindings in effect
267 -> [CoreExpr] -- A list of expressions to put in the tuple
268 -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
270 expandBuildTupleExpr binds args = do
271 -- Split the tuple constructor arguments into types and actual values.
272 let (_, vals) = splitTupleConstructorArgs args
273 -- Expand each of the values in the tuple
274 (signals_declss, statementss, arg_signalss, res_signals) <-
275 (Monad.liftM List.unzip4) $ mapM (expandExpr binds) vals
276 if any (not . null) arg_signalss
277 then error "Putting high order functions in tuples not supported"
280 concat signals_declss,
285 -- Expands the most simple case expression that scrutinizes a plain variable
286 -- and has a single alternative. This simple form currently allows only for
287 -- unpacking tuple variables.
288 expandSingleAltCaseExpr ::
289 [(CoreBndr, SignalNameMap AST.VHDLId)]
290 -- A list of bindings in effect
291 -> Var.Var -- The scrutinee
292 -> CoreBndr -- The binder to bind the scrutinee to
293 -> CoreAlt -- The single alternative
294 -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
297 expandSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
298 if not (DataCon.isTupleCon datacon)
300 error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
303 -- Lookup the scrutinee (which must be a variable bound to a tuple) in
304 -- the existing bindings list and get the portname map for each of
306 Tuple tuple_ports = Maybe.fromMaybe
307 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
309 -- TODO include b in the binds list
310 -- Merge our existing binds with the new binds.
311 binds' = (zip bind_vars tuple_ports) ++ binds
313 -- Expand the expression with the new binds list
314 expandExpr binds' expr
316 expandSingleAltCaseExpr _ _ _ alt =
317 error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
320 -- Expands the application of argument to a function into VHDL
321 expandApplicationExpr ::
322 [(CoreBndr, SignalNameMap AST.VHDLId)]
323 -- A list of bindings in effect
324 -> Type -- The result type of the function call
325 -> Var.Var -- The function to call
326 -> [CoreExpr] -- A list of argumetns to apply to the function
327 -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
329 expandApplicationExpr binds ty f args = do
330 let name = getOccString f
331 -- Generate a unique name for the application
332 appname <- uniqueName ("app-" ++ name)
333 -- Lookup the hwfunction to instantiate
334 HWFunction vhdl_id inports outport <- getHWFunc name
335 -- Expand each of the args, so each of them is reduced to output signals
336 (arg_signal_decls, arg_statements, arg_res_signals) <- expandArgs binds args
337 -- Bind each of the input ports to the expanded arguments
338 let inmaps = concat $ zipWith createAssocElems inports arg_res_signals
339 -- Create signal names for our result
340 let res_signal = getPortNameMapForTy (appname ++ "-out") ty
341 -- Create the corresponding signal declarations
342 let signal_decls = mkSignalsFromMap res_signal
343 -- Bind each of the output ports to our output signals
344 let outmaps = mapOutputPorts outport res_signal
345 -- Instantiate the component
346 let component = AST.CSISm $ AST.CompInsSm
347 (AST.unsafeVHDLBasicId appname)
348 (AST.IUEntity (AST.NSimple vhdl_id))
349 (AST.PMapAspect (inmaps ++ outmaps))
350 -- Merge the generated declarations
352 signal_decls ++ arg_signal_decls,
353 component : arg_statements,
354 [], -- We don't take any extra arguments; we don't support higher order functions yet
357 -- Creates a list of AssocElems (port map lines) that maps the given signals
358 -- to the given ports.
360 SignalNameMap AST.VHDLId -- The port names to bind to
361 -> SignalNameMap AST.VHDLId -- The signals to bind to it
362 -> [AST.AssocElem] -- The resulting port map lines
364 createAssocElems (Signal port_id) (Signal signal_id) =
365 [(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
367 createAssocElems (Tuple ports) (Tuple signals) =
368 concat $ zipWith createAssocElems ports signals
370 -- Generate a signal declaration for a signal with the given name and the
371 -- given type and no value. Also returns the id of the signal.
372 mkSignal :: String -> AST.TypeMark -> (AST.VHDLId, AST.SigDec)
374 (id, mkSignalFromId id ty)
376 id = AST.unsafeVHDLBasicId name
378 mkSignalFromId :: AST.VHDLId -> AST.TypeMark -> AST.SigDec
379 mkSignalFromId id ty =
380 AST.SigDec id ty Nothing
382 -- Generates signal declarations for all the signals in the given map
384 SignalNameMap AST.VHDLId
387 mkSignalsFromMap (Signal id) =
388 -- TODO: This uses the bit type hardcoded
389 [mkSignalFromId id vhdl_bit_ty]
391 mkSignalsFromMap (Tuple signals) =
392 concat $ map mkSignalsFromMap signals
395 [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
396 -> [CoreExpr] -- The arguments to expand
397 -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId])
398 -- The resulting signal declarations,
399 -- component instantiations and a
400 -- VHDLName for each of the
401 -- expressions passed in.
402 expandArgs binds (e:exprs) = do
403 -- Expand the first expression
404 (signal_decls, statements, arg_signals, res_signal) <- expandExpr binds e
405 if not (null arg_signals)
406 then error $ "Passing functions as arguments not supported: " ++ (showSDoc $ ppr e)
408 (signal_decls', statements', res_signals') <- expandArgs binds exprs
410 signal_decls ++ signal_decls',
411 statements ++ statements',
412 res_signal : res_signals')
414 expandArgs _ [] = return ([], [], [])
416 -- Is the given name a (binary) tuple constructor
417 isTupleConstructor :: Var.Var -> Bool
418 isTupleConstructor var =
419 Name.isWiredInName name
420 && Name.nameModule name == tuple_mod
421 && (Name.occNameString $ Name.nameOccName name) == "(,)"
423 name = Var.varName var
424 mod = nameModule name
425 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
427 -- Split arguments into type arguments and value arguments This is probably
428 -- not really sufficient (not sure if Types can actually occur as value
430 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
431 splitTupleConstructorArgs (e:es) =
433 Type t -> (e:tys, vals)
434 otherwise -> (tys, e:vals)
436 (tys, vals) = splitTupleConstructorArgs es
438 splitTupleConstructorArgs [] = ([], [])
441 SignalNameMap AST.VHDLId -- The output portnames of the component
442 -> SignalNameMap AST.VHDLId -- The output portnames and/or signals to map these to
443 -> [AST.AssocElem] -- The resulting output ports
445 -- Map the output port of a component to the output port of the containing
447 mapOutputPorts (Signal portname) (Signal signalname) =
448 [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
450 -- Map matching output ports in the tuple
451 mapOutputPorts (Tuple ports) (Tuple signals) =
452 concat (zipWith mapOutputPorts ports signals)
455 CoreBind -- The binder to expand into an architecture
456 -> VHDLState AST.ArchBody -- The resulting architecture
458 getArchitecture (Rec _) = error "Recursive binders not supported"
460 getArchitecture (NonRec var expr) = do
461 let name = (getOccString var)
462 HWFunction vhdl_id inports outport <- getHWFunc name
464 (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
465 let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
466 let outport_assigns = createSignalAssignments outport res_signal
467 return $ AST.ArchBody
468 (AST.unsafeVHDLBasicId "structural")
469 (AST.NSimple vhdl_id)
470 (map AST.BDISD signal_decls)
471 (inport_assigns ++ outport_assigns ++ statements)
473 -- Generate a VHDL entity declaration for the given function
474 getEntity :: HWFunction -> AST.EntityDec
475 getEntity (HWFunction vhdl_id inports outport) =
476 AST.EntityDec vhdl_id ports
479 (concat $ map (mkIfaceSigDecs AST.In) inports)
480 ++ mkIfaceSigDecs AST.Out outport
483 AST.Mode -- The port's mode (In or Out)
484 -> SignalNameMap AST.VHDLId -- The ports to generate a map for
485 -> [AST.IfaceSigDec] -- The resulting ports
487 mkIfaceSigDecs mode (Signal port_id) =
488 -- TODO: Remove hardcoded type
489 [AST.IfaceSigDec port_id mode vhdl_bit_ty]
491 mkIfaceSigDecs mode (Tuple ports) =
492 concat $ map (mkIfaceSigDecs mode) ports
494 -- Create concurrent assignments of one map of signals to another. The maps
495 -- should have a similar form.
496 createSignalAssignments ::
497 SignalNameMap AST.VHDLId -- The signals to assign to
498 -> SignalNameMap AST.VHDLId -- The signals to assign
499 -> [AST.ConcSm] -- The resulting assignments
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) =
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)
512 createSignalAssignments (Tuple dsts) (Tuple srcs) =
513 concat $ zipWith createSignalAssignments dsts srcs
515 createSignalAssignments dst src =
516 error $ "Non matching source and destination: " ++ show dst ++ "\nand\n" ++ show src
518 data SignalNameMap t =
519 Tuple [SignalNameMap t]
523 -- Generate a port name map (or multiple for tuple types) in the given direction for
525 getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap AST.VHDLId]
526 getPortNameMapForTys prefix num [] = []
527 getPortNameMapForTys prefix num (t:ts) =
528 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
530 getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
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
537 Signal (AST.unsafeVHDLBasicId name)
539 (tycon, args) = Type.splitTyConApp ty
541 data HWFunction = HWFunction { -- A function that is available in hardware
542 vhdlId :: AST.VHDLId,
543 inPorts :: [SignalNameMap AST.VHDLId],
544 outPort :: SignalNameMap AST.VHDLId
545 --entity :: AST.EntityDec
548 -- Turns a CoreExpr describing a function into a description of its input and
551 CoreBind -- The core binder to generate the interface for
552 -> VHDLState (String, HWFunction) -- The name of the function and its interface
554 mkHWFunction (NonRec var expr) =
555 return (name, HWFunction (mkVHDLId name) inports outport)
557 name = getOccString var
558 ty = CoreUtils.exprType expr
559 (fargs, res) = Type.splitFunTys ty
560 args = if length fargs == 1 then fargs else (init fargs)
561 --state = if length fargs == 1 then () else (last fargs)
562 inports = case args of
563 -- Handle a single port specially, to prevent an extra 0 in the name
564 [port] -> [getPortNameMapForTy "portin" port]
565 ps -> getPortNameMapForTys "portin" 0 ps
566 outport = getPortNameMapForTy "portout" res
568 mkHWFunction (Rec _) =
569 error "Recursive binders not supported"
571 data VHDLSession = VHDLSession {
572 nameCount :: Int, -- A counter that can be used to generate unique names
573 funcs :: [(String, HWFunction)] -- All functions available, indexed by name
576 type VHDLState = State.State VHDLSession
578 -- Add the function to the session
579 addFunc :: String -> HWFunction -> VHDLState ()
581 fs <- State.gets funcs -- Get the funcs element from the session
582 State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
584 -- Lookup the function with the given name in the current session. Errors if
586 getHWFunc :: String -> VHDLState HWFunction
588 fs <- State.gets funcs -- Get the funcs element from the session
589 return $ Maybe.fromMaybe
590 (error $ "Function " ++ name ++ "is unknown? This should not happen!")
593 -- Makes the given name unique by appending a unique number.
594 -- This does not do any checking against existing names, so it only guarantees
595 -- uniqueness with other names generated by uniqueName.
596 uniqueName :: String -> VHDLState String
598 count <- State.gets nameCount -- Get the funcs element from the session
599 State.modify (\s -> s {nameCount = count + 1})
600 return $ name ++ "-" ++ (show count)
603 mkVHDLId :: String -> AST.VHDLId
604 mkVHDLId = AST.unsafeVHDLBasicId
608 ("hwxor", HWFunction (mkVHDLId "hwxor") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
609 ("hwand", HWFunction (mkVHDLId "hwand") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
610 ("hwor", HWFunction (mkVHDLId "hwor") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
611 ("hwnot", HWFunction (mkVHDLId "hwnot") [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
614 vhdl_bit_ty :: AST.TypeMark
615 vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
617 -- vim: set ts=8 sw=2 sts=2 expandtab: