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 $ concat $ map (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 -- Create architectures for them
63 mapM getArchitecture binds
65 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
68 printBinds [] = putStr "done\n\n"
69 printBinds (b:bs) = do
74 printBind (NonRec b expr) = do
78 printBind (Rec binds) = do
80 foldl1 (>>) (map printBind' binds)
82 printBind' (b, expr) = do
83 putStr $ getOccString b
84 putStr $ showSDoc $ ppr expr
87 findBind :: [CoreBind] -> String -> Maybe CoreBind
88 findBind binds lookfor =
89 -- This ignores Recs and compares the name of the bind with lookfor,
90 -- disregarding any namespaces in OccName and extra attributes in Name and
94 NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
98 SignalNameMap AST.VHDLId -- The port name to bind to
99 -> SignalNameMap AST.VHDLId
100 -- The signal or port to bind to it
101 -> AST.AssocElem -- The resulting port map entry
103 -- Accepts a port name and an argument to map to it.
104 -- Returns the appropriate line for in the port map
105 getPortMapEntry (Signal portname) (Signal signame) =
106 (Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
109 [SignalNameMap AST.VHDLId] -- The arguments that need to be applied to the
111 -> SignalNameMap AST.VHDLId -- The output ports that the expression should generate.
112 -> [(CoreBndr, SignalNameMap AST.VHDLId)]
113 -- A list of bindings in effect
114 -> CoreSyn.CoreExpr -- The expression to generate an architecture for
115 -> VHDLState ([AST.SigDec], [AST.ConcSm])
116 -- The resulting VHDL code
118 -- A lambda expression binds the first argument (a) to the binder b.
119 getInstantiations (a:as) outs binds (Lam b expr) =
120 getInstantiations as outs ((b, a):binds) expr
122 -- A case expression that checks a single variable and has a single
123 -- alternative, can be used to take tuples apart
124 getInstantiations args outs binds (Case (Var v) b _ [res]) =
125 -- Split out the type of alternative constructor, the variables it binds
126 -- and the expression to evaluate with the variables bound.
127 let (altcon, bind_vars, expr) = res in
130 if (DataCon.isTupleCon datacon) then
132 -- Lookup the scrutinee (which must be a variable bound to a tuple) in
133 -- the existing bindings list and get the portname map for each of
135 Tuple tuple_ports = Maybe.fromMaybe
136 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
138 -- Merge our existing binds with the new binds.
139 binds' = (zip bind_vars tuple_ports) ++ binds
141 -- Evaluate the expression with the new binds list
142 getInstantiations args outs binds' expr
144 error "Data constructors other than tuples not supported"
146 error "Case binders other than tuples not supported"
148 -- An application is an instantiation of a component
149 getInstantiations args outs binds app@(App expr arg) = do
150 let ((Var f), fargs) = collectArgs app
151 name = getOccString f
152 if isTupleConstructor f
154 -- Get the signals we should bind our results to
155 let Tuple outports = outs
156 -- Split the tuple constructor arguments into types and actual values.
157 let (_, vals) = splitTupleConstructorArgs fargs
158 -- Bind each argument to each output signal
159 res <- sequence $ zipWith
160 (\outs' expr' -> getInstantiations args outs' binds expr')
162 -- res is a list of pairs of lists, so split out the signals and
163 -- components into separate lists of lists
164 let (sigs, comps) = unzip res
165 -- And join all the signals and component instantiations together
166 return $ (concat sigs, concat comps)
168 -- This is an normal function application, which maps to a component
170 -- Lookup the hwfunction to instantiate
171 HWFunction vhdl_id inports outport <- getHWFunc name
172 -- Generate a unique name for the application
173 appname <- uniqueName "app"
174 -- Expand each argument to a signal or port name, possibly generating
175 -- new signals and component instantiations
176 (sigs, comps, args) <- expandArgs binds fargs
177 -- Bind each of the input ports to the expanded signal or port
178 let inmaps = zipWith getPortMapEntry inports args
179 -- Bind each of the output ports to our output signals
180 let outmaps = mapOutputPorts outport outs
181 -- Build and return a component instantiation
182 let comp = AST.CompInsSm
183 (AST.unsafeVHDLBasicId appname)
184 (AST.IUEntity (AST.NSimple vhdl_id))
185 (AST.PMapAspect (inmaps ++ outmaps))
186 return (sigs, (AST.CSISm comp) : comps)
188 getInstantiations args outs binds expr =
189 error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
192 [(CoreBndr, SignalNameMap AST.VHDLId)]
193 -- A list of bindings in effect
194 -> CoreExpr -- The expression to expand
196 [AST.SigDec], -- Needed signal declarations
197 [AST.ConcSm], -- Needed component instantations and
198 -- signal assignments.
199 [SignalNameMap AST.VHDLId], -- The signal names corresponding to
200 -- the expression's arguments
201 SignalNameMap AST.VHDLId) -- The signal names corresponding to
202 -- the expression's result.
203 expandExpr binds lam@(Lam b expr) = do
204 -- Generate a new signal to which we will expect this argument to be bound.
205 signal_name <- uniqueName ("arg-" ++ getOccString b)
206 -- Find the type of the binder
207 let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
208 -- Create signal names for the binder
209 let arg_signal = getPortNameMapForTy ("xxx") arg_ty
210 -- Create the corresponding signal declarations
211 let signal_decls = mkSignalsFromMap arg_signal
212 -- Add the binder to the list of binds
213 let binds' = (b, arg_signal) : binds
214 -- Expand the rest of the expression
215 (signal_decls', statements', arg_signals', res_signal') <- expandExpr binds' expr
216 -- Properly merge the results
217 return (signal_decls ++ signal_decls',
219 arg_signal : arg_signals',
222 expandExpr binds (Var id) =
223 return ([], [], [], Signal signal_id)
225 -- Lookup the id in our binds map
226 Signal signal_id = Maybe.fromMaybe
227 (error $ "Argument " ++ getOccString id ++ "is unknown")
230 expandExpr binds l@(Let (NonRec b bexpr) expr) = do
231 (signal_decls, statements, arg_signals, res_signals) <- expandExpr binds bexpr
232 let binds' = (b, res_signals) : binds
233 (signal_decls', statements', arg_signals', res_signals') <- expandExpr binds' expr
235 signal_decls ++ signal_decls',
236 statements ++ statements',
240 expandExpr binds app@(App _ _) = do
241 let ((Var f), args) = collectArgs app
242 if isTupleConstructor f
244 expandBuildTupleExpr binds args
246 expandApplicationExpr binds (CoreUtils.exprType app) f args
248 expandExpr binds expr@(Case (Var v) b _ alts) =
250 [alt] -> expandSingleAltCaseExpr binds v b alt
251 otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
253 expandExpr binds expr@(Case _ b _ _) =
254 error $ "Case expression with non-variable scrutinee not supported: " ++ (showSDoc $ ppr expr)
256 expandExpr binds expr =
257 error $ "Unsupported expression: " ++ (showSDoc $ ppr $ expr)
259 -- Expands the construction of a tuple into VHDL
260 expandBuildTupleExpr ::
261 [(CoreBndr, SignalNameMap AST.VHDLId)]
262 -- A list of bindings in effect
263 -> [CoreExpr] -- A list of expressions to put in the tuple
264 -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
266 expandBuildTupleExpr binds args = do
267 -- Split the tuple constructor arguments into types and actual values.
268 let (_, vals) = splitTupleConstructorArgs args
269 -- Expand each of the values in the tuple
270 (signals_declss, statementss, arg_signalss, res_signals) <-
271 (Monad.liftM List.unzip4) $ mapM (expandExpr binds) vals
272 if any (not . null) arg_signalss
273 then error "Putting high order functions in tuples not supported"
276 concat signals_declss,
281 -- Expands the most simple case expression that scrutinizes a plain variable
282 -- and has a single alternative. This simple form currently allows only for
283 -- unpacking tuple variables.
284 expandSingleAltCaseExpr ::
285 [(CoreBndr, SignalNameMap AST.VHDLId)]
286 -- A list of bindings in effect
287 -> Var.Var -- The scrutinee
288 -> CoreBndr -- The binder to bind the scrutinee to
289 -> CoreAlt -- The single alternative
290 -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
293 expandSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
294 if not (DataCon.isTupleCon datacon)
296 error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
299 -- Lookup the scrutinee (which must be a variable bound to a tuple) in
300 -- the existing bindings list and get the portname map for each of
302 Tuple tuple_ports = Maybe.fromMaybe
303 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
305 -- TODO include b in the binds list
306 -- Merge our existing binds with the new binds.
307 binds' = (zip bind_vars tuple_ports) ++ binds
309 -- Expand the expression with the new binds list
310 expandExpr binds' expr
312 expandSingleAltCaseExpr _ _ _ alt =
313 error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
316 -- Expands the application of argument to a function into VHDL
317 expandApplicationExpr ::
318 [(CoreBndr, SignalNameMap AST.VHDLId)]
319 -- A list of bindings in effect
320 -> Type -- The result type of the function call
321 -> Var.Var -- The function to call
322 -> [CoreExpr] -- A list of argumetns to apply to the function
323 -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
325 expandApplicationExpr binds ty f args = do
326 let name = getOccString f
327 -- Generate a unique name for the application
328 appname <- uniqueName ("app-" ++ name)
329 -- Lookup the hwfunction to instantiate
330 HWFunction vhdl_id inports outport <- getHWFunc name
331 -- Expand each of the args, so each of them is reduced to output signals
332 (arg_signal_decls, arg_statements, arg_res_signals) <- expandArgs binds args
333 -- Bind each of the input ports to the expanded arguments
334 let inmaps = concat $ zipWith createAssocElems inports arg_res_signals
335 -- Create signal names for our result
336 let res_signal = getPortNameMapForTy (appname ++ "-out") ty
337 -- Create the corresponding signal declarations
338 let signal_decls = mkSignalsFromMap res_signal
339 -- Bind each of the output ports to our output signals
340 let outmaps = mapOutputPorts outport res_signal
341 -- Instantiate the component
342 let component = AST.CSISm $ AST.CompInsSm
343 (AST.unsafeVHDLBasicId appname)
344 (AST.IUEntity (AST.NSimple vhdl_id))
345 (AST.PMapAspect (inmaps ++ outmaps))
346 -- Merge the generated declarations
348 signal_decls ++ arg_signal_decls,
349 component : arg_statements,
350 [], -- We don't take any extra arguments; we don't support higher order functions yet
353 -- Creates a list of AssocElems (port map lines) that maps the given signals
354 -- to the given ports.
356 SignalNameMap AST.VHDLId -- The port names to bind to
357 -> SignalNameMap AST.VHDLId -- The signals to bind to it
358 -> [AST.AssocElem] -- The resulting port map lines
360 createAssocElems (Signal port_id) (Signal signal_id) =
361 [(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
363 createAssocElems (Tuple ports) (Tuple signals) =
364 concat $ zipWith createAssocElems ports signals
366 -- Generate a signal declaration for a signal with the given name and the
367 -- given type and no value. Also returns the id of the signal.
368 mkSignal :: String -> AST.TypeMark -> (AST.VHDLId, AST.SigDec)
370 (id, mkSignalFromId id ty)
372 id = AST.unsafeVHDLBasicId name
374 mkSignalFromId :: AST.VHDLId -> AST.TypeMark -> AST.SigDec
375 mkSignalFromId id ty =
376 AST.SigDec id ty Nothing
378 -- Generates signal declarations for all the signals in the given map
380 SignalNameMap AST.VHDLId
383 mkSignalsFromMap (Signal id) =
384 -- TODO: This uses the bit type hardcoded
385 [mkSignalFromId id vhdl_bit_ty]
387 mkSignalsFromMap (Tuple signals) =
388 concat $ map mkSignalsFromMap signals
391 [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
392 -> [CoreExpr] -- The arguments to expand
393 -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId])
394 -- The resulting signal declarations,
395 -- component instantiations and a
396 -- VHDLName for each of the
397 -- expressions passed in.
398 expandArgs binds (e:exprs) = do
399 -- Expand the first expression
400 (signal_decls, statements, arg_signals, res_signal) <- expandExpr binds e
401 if not (null arg_signals)
402 then error $ "Passing functions as arguments not supported: " ++ (showSDoc $ ppr e)
404 (signal_decls', statements', res_signals') <- expandArgs binds exprs
406 signal_decls ++ signal_decls',
407 statements ++ statements',
408 res_signal : res_signals')
410 expandArgs _ [] = return ([], [], [])
412 -- Is the given name a (binary) tuple constructor
413 isTupleConstructor :: Var.Var -> Bool
414 isTupleConstructor var =
415 Name.isWiredInName name
416 && Name.nameModule name == tuple_mod
417 && (Name.occNameString $ Name.nameOccName name) == "(,)"
419 name = Var.varName var
420 mod = nameModule name
421 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
423 -- Split arguments into type arguments and value arguments This is probably
424 -- not really sufficient (not sure if Types can actually occur as value
426 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
427 splitTupleConstructorArgs (e:es) =
429 Type t -> (e:tys, vals)
430 otherwise -> (tys, e:vals)
432 (tys, vals) = splitTupleConstructorArgs es
434 splitTupleConstructorArgs [] = ([], [])
437 SignalNameMap AST.VHDLId -- The output portnames of the component
438 -> SignalNameMap AST.VHDLId -- The output portnames and/or signals to map these to
439 -> [AST.AssocElem] -- The resulting output ports
441 -- Map the output port of a component to the output port of the containing
443 mapOutputPorts (Signal portname) (Signal signalname) =
444 [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
446 -- Map matching output ports in the tuple
447 mapOutputPorts (Tuple ports) (Tuple signals) =
448 concat (zipWith mapOutputPorts ports signals)
451 CoreBind -- The binder to expand into an architecture
452 -> VHDLState AST.ArchBody -- The resulting architecture
454 getArchitecture (Rec _) = error "Recursive binders not supported"
456 getArchitecture (NonRec var expr) = do
457 let name = (getOccString var)
458 HWFunction vhdl_id inports outport <- getHWFunc name
460 (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
461 let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
462 let outport_assigns = createSignalAssignments outport res_signal
463 return $ AST.ArchBody
464 (AST.unsafeVHDLBasicId "structural")
465 (AST.NSimple vhdl_id)
466 (map AST.BDISD signal_decls)
467 (inport_assigns ++ outport_assigns ++ statements)
469 -- Create concurrent assignments of one map of signals to another. The maps
470 -- should have a similar form.
471 createSignalAssignments ::
472 SignalNameMap AST.VHDLId -- The signals to assign to
473 -> SignalNameMap AST.VHDLId -- The signals to assign
474 -> [AST.ConcSm] -- The resulting assignments
476 -- A simple assignment of one signal to another (greatly complicated because
477 -- signal assignments can be conditional with multiple conditions in VHDL).
478 createSignalAssignments (Signal dst) (Signal src) =
481 src_name = AST.NSimple src
482 src_expr = AST.PrimName src_name
483 src_wform = AST.Wform [AST.WformElem src_expr Nothing]
484 dst_name = (AST.NSimple dst)
485 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
487 createSignalAssignments (Tuple dsts) (Tuple srcs) =
488 concat $ zipWith createSignalAssignments dsts srcs
490 createSignalAssignments dst src =
491 error $ "Non matching source and destination: " ++ show dst ++ "\nand\n" ++ show src
493 data SignalNameMap t =
494 Tuple [SignalNameMap t]
498 -- Generate a port name map (or multiple for tuple types) in the given direction for
500 getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap AST.VHDLId]
501 getPortNameMapForTys prefix num [] = []
502 getPortNameMapForTys prefix num (t:ts) =
503 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
505 getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
506 getPortNameMapForTy name ty =
507 if (TyCon.isTupleTyCon tycon) then
508 -- Expand tuples we find
509 Tuple (getPortNameMapForTys name 0 args)
510 else -- Assume it's a type constructor application, ie simple data type
512 Signal (AST.unsafeVHDLBasicId name)
514 (tycon, args) = Type.splitTyConApp ty
516 data HWFunction = HWFunction { -- A function that is available in hardware
517 vhdlId :: AST.VHDLId,
518 inPorts :: [SignalNameMap AST.VHDLId],
519 outPort :: SignalNameMap AST.VHDLId
520 --entity :: AST.EntityDec
523 -- Turns a CoreExpr describing a function into a description of its input and
526 CoreBind -- The core binder to generate the interface for
527 -> VHDLState (String, HWFunction) -- The name of the function and its interface
529 mkHWFunction (NonRec var expr) =
530 return (name, HWFunction (mkVHDLId name) inports outport)
532 name = getOccString var
533 ty = CoreUtils.exprType expr
534 (fargs, res) = Type.splitFunTys ty
535 args = if length fargs == 1 then fargs else (init fargs)
536 --state = if length fargs == 1 then () else (last fargs)
537 inports = case args of
538 -- Handle a single port specially, to prevent an extra 0 in the name
539 [port] -> [getPortNameMapForTy "portin" port]
540 ps -> getPortNameMapForTys "portin" 0 ps
541 outport = getPortNameMapForTy "portout" res
543 mkHWFunction (Rec _) =
544 error "Recursive binders not supported"
546 data VHDLSession = VHDLSession {
547 nameCount :: Int, -- A counter that can be used to generate unique names
548 funcs :: [(String, HWFunction)] -- All functions available, indexed by name
551 type VHDLState = State.State VHDLSession
553 -- Add the function to the session
554 addFunc :: String -> HWFunction -> VHDLState ()
556 fs <- State.gets funcs -- Get the funcs element from the session
557 State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
559 -- Lookup the function with the given name in the current session. Errors if
561 getHWFunc :: String -> VHDLState HWFunction
563 fs <- State.gets funcs -- Get the funcs element from the session
564 return $ Maybe.fromMaybe
565 (error $ "Function " ++ name ++ "is unknown? This should not happen!")
568 -- Makes the given name unique by appending a unique number.
569 -- This does not do any checking against existing names, so it only guarantees
570 -- uniqueness with other names generated by uniqueName.
571 uniqueName :: String -> VHDLState String
573 count <- State.gets nameCount -- Get the funcs element from the session
574 State.modify (\s -> s {nameCount = count + 1})
575 return $ name ++ "-" ++ (show count)
578 mkVHDLId :: String -> AST.VHDLId
579 mkVHDLId = AST.unsafeVHDLBasicId
583 ("hwxor", HWFunction (mkVHDLId "hwxor") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
584 ("hwand", HWFunction (mkVHDLId "hwand") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
585 ("hwor", HWFunction (mkVHDLId "hwor") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
586 ("hwnot", HWFunction (mkVHDLId "hwnot") [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
589 vhdl_bit_ty :: AST.TypeMark
590 vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
592 -- vim: set ts=8 sw=2 sts=2 expandtab: