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 builtin_funcs)
51 liftIO $ putStr $ concat $ map (render . ForSyDe.Backend.Ppr.ppr) vhdl
54 -- Turns the given bind into VHDL
56 -- Get the function signatures
57 funcs <- mapM mkHWFunction binds
58 -- Add them to the session
59 mapM (uncurry addFunc) funcs
60 -- Create architectures for them
61 mapM getArchitecture binds
63 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
66 printBinds [] = putStr "done\n\n"
67 printBinds (b:bs) = do
72 printBind (NonRec b expr) = do
76 printBind (Rec binds) = do
78 foldl1 (>>) (map printBind' binds)
80 printBind' (b, expr) = do
81 putStr $ getOccString b
82 putStr $ showSDoc $ ppr expr
85 findBind :: [CoreBind] -> String -> Maybe CoreBind
86 findBind binds lookfor =
87 -- This ignores Recs and compares the name of the bind with lookfor,
88 -- disregarding any namespaces in OccName and extra attributes in Name and
92 NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
96 SignalNameMap AST.VHDLId -- The port name to bind to
97 -> SignalNameMap AST.VHDLId
98 -- The signal or port to bind to it
99 -> AST.AssocElem -- The resulting port map entry
101 -- Accepts a port name and an argument to map to it.
102 -- Returns the appropriate line for in the port map
103 getPortMapEntry (Signal portname) (Signal signame) =
104 (Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
107 [SignalNameMap AST.VHDLId] -- The arguments that need to be applied to the
109 -> SignalNameMap AST.VHDLId -- The output ports that the expression should generate.
110 -> [(CoreBndr, SignalNameMap AST.VHDLId)]
111 -- A list of bindings in effect
112 -> CoreSyn.CoreExpr -- The expression to generate an architecture for
113 -> VHDLState ([AST.SigDec], [AST.ConcSm])
114 -- The resulting VHDL code
116 -- A lambda expression binds the first argument (a) to the binder b.
117 getInstantiations (a:as) outs binds (Lam b expr) =
118 getInstantiations as outs ((b, a):binds) expr
120 -- A case expression that checks a single variable and has a single
121 -- alternative, can be used to take tuples apart
122 getInstantiations args outs binds (Case (Var v) b _ [res]) =
123 -- Split out the type of alternative constructor, the variables it binds
124 -- and the expression to evaluate with the variables bound.
125 let (altcon, bind_vars, expr) = res in
128 if (DataCon.isTupleCon datacon) then
130 -- Lookup the scrutinee (which must be a variable bound to a tuple) in
131 -- the existing bindings list and get the portname map for each of
133 Tuple tuple_ports = Maybe.fromMaybe
134 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
136 -- Merge our existing binds with the new binds.
137 binds' = (zip bind_vars tuple_ports) ++ binds
139 -- Evaluate the expression with the new binds list
140 getInstantiations args outs binds' expr
142 error "Data constructors other than tuples not supported"
144 error "Case binders other than tuples not supported"
146 -- An application is an instantiation of a component
147 getInstantiations args outs binds app@(App expr arg) = do
148 let ((Var f), fargs) = collectArgs app
149 name = getOccString f
150 if isTupleConstructor f
152 -- Get the signals we should bind our results to
153 let Tuple outports = outs
154 -- Split the tuple constructor arguments into types and actual values.
155 let (_, vals) = splitTupleConstructorArgs fargs
156 -- Bind each argument to each output signal
157 res <- sequence $ zipWith
158 (\outs' expr' -> getInstantiations args outs' binds expr')
160 -- res is a list of pairs of lists, so split out the signals and
161 -- components into separate lists of lists
162 let (sigs, comps) = unzip res
163 -- And join all the signals and component instantiations together
164 return $ (concat sigs, concat comps)
166 -- This is an normal function application, which maps to a component
168 -- Lookup the hwfunction to instantiate
169 HWFunction inports outport <- getHWFunc name
170 -- Generate a unique name for the application
171 appname <- uniqueName "app"
172 -- Expand each argument to a signal or port name, possibly generating
173 -- new signals and component instantiations
174 (sigs, comps, args) <- expandArgs binds fargs
175 -- Bind each of the input ports to the expanded signal or port
176 let inmaps = zipWith getPortMapEntry inports args
177 -- Bind each of the output ports to our output signals
178 let outmaps = mapOutputPorts outport outs
179 -- Build and return a component instantiation
180 let comp = AST.CompInsSm
181 (AST.unsafeVHDLBasicId appname)
182 (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
183 (AST.PMapAspect (inmaps ++ outmaps))
184 return (sigs, (AST.CSISm comp) : comps)
186 getInstantiations args outs binds expr =
187 error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
190 [(CoreBndr, SignalNameMap AST.VHDLId)]
191 -- A list of bindings in effect
192 -> CoreExpr -- The expression to expand
194 [AST.SigDec], -- Needed signal declarations
195 [AST.ConcSm], -- Needed component instantations and
196 -- signal assignments.
197 [SignalNameMap AST.VHDLId], -- The signal names corresponding to
198 -- the expression's arguments
199 SignalNameMap AST.VHDLId) -- The signal names corresponding to
200 -- the expression's result.
201 expandExpr binds lam@(Lam b expr) = do
202 -- Generate a new signal to which we will expect this argument to be bound.
203 signal_name <- uniqueName ("arg-" ++ getOccString b)
204 -- Find the type of the binder
205 let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
206 -- Create signal names for the binder
207 let arg_signal = getPortNameMapForTy ("xxx") arg_ty
208 -- Create the corresponding signal declarations
209 let signal_decls = mkSignalsFromMap arg_signal
210 -- Add the binder to the list of binds
211 let binds' = (b, arg_signal) : binds
212 -- Expand the rest of the expression
213 (signal_decls', statements', arg_signals', res_signal') <- expandExpr binds' expr
214 -- Properly merge the results
215 return (signal_decls ++ signal_decls',
217 arg_signal : arg_signals',
220 expandExpr binds (Var id) =
221 return ([], [], [], Signal signal_id)
223 -- Lookup the id in our binds map
224 Signal signal_id = Maybe.fromMaybe
225 (error $ "Argument " ++ getOccString id ++ "is unknown")
228 expandExpr binds l@(Let (NonRec b bexpr) expr) = do
229 (signal_decls, statements, arg_signals, res_signals) <- expandExpr binds bexpr
230 let binds' = (b, res_signals) : binds
231 (signal_decls', statements', arg_signals', res_signals') <- expandExpr binds' expr
233 signal_decls ++ signal_decls',
234 statements ++ statements',
238 expandExpr binds app@(App _ _) = do
239 let ((Var f), args) = collectArgs app
240 if isTupleConstructor f
242 expandBuildTupleExpr binds args
244 expandApplicationExpr binds (CoreUtils.exprType app) f args
246 expandExpr binds expr@(Case (Var v) b _ alts) =
248 [alt] -> expandSingleAltCaseExpr binds v b alt
249 otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
251 expandExpr binds expr@(Case _ b _ _) =
252 error $ "Case expression with non-variable scrutinee not supported: " ++ (showSDoc $ ppr expr)
254 expandExpr binds expr =
255 error $ "Unsupported expression: " ++ (showSDoc $ ppr $ expr)
257 -- Expands the construction of a tuple into VHDL
258 expandBuildTupleExpr ::
259 [(CoreBndr, SignalNameMap AST.VHDLId)]
260 -- A list of bindings in effect
261 -> [CoreExpr] -- A list of expressions to put in the tuple
262 -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
264 expandBuildTupleExpr binds args = do
265 -- Split the tuple constructor arguments into types and actual values.
266 let (_, vals) = splitTupleConstructorArgs args
267 -- Expand each of the values in the tuple
268 (signals_declss, statementss, arg_signalss, res_signals) <-
269 (Monad.liftM List.unzip4) $ mapM (expandExpr binds) vals
270 if any (not . null) arg_signalss
271 then error "Putting high order functions in tuples not supported"
274 concat signals_declss,
279 -- Expands the most simple case expression that scrutinizes a plain variable
280 -- and has a single alternative. This simple form currently allows only for
281 -- unpacking tuple variables.
282 expandSingleAltCaseExpr ::
283 [(CoreBndr, SignalNameMap AST.VHDLId)]
284 -- A list of bindings in effect
285 -> Var.Var -- The scrutinee
286 -> CoreBndr -- The binder to bind the scrutinee to
287 -> CoreAlt -- The single alternative
288 -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
291 expandSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
292 if not (DataCon.isTupleCon datacon)
294 error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
297 -- Lookup the scrutinee (which must be a variable bound to a tuple) in
298 -- the existing bindings list and get the portname map for each of
300 Tuple tuple_ports = Maybe.fromMaybe
301 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
303 -- TODO include b in the binds list
304 -- Merge our existing binds with the new binds.
305 binds' = (zip bind_vars tuple_ports) ++ binds
307 -- Expand the expression with the new binds list
308 expandExpr binds' expr
310 expandSingleAltCaseExpr _ _ _ alt =
311 error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
314 -- Expands the application of argument to a function into VHDL
315 expandApplicationExpr ::
316 [(CoreBndr, SignalNameMap AST.VHDLId)]
317 -- A list of bindings in effect
318 -> Type -- The result type of the function call
319 -> Var.Var -- The function to call
320 -> [CoreExpr] -- A list of argumetns to apply to the function
321 -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
323 expandApplicationExpr binds ty f args = do
324 let name = getOccString f
325 -- Generate a unique name for the application
326 appname <- uniqueName ("app-" ++ name)
327 -- Lookup the hwfunction to instantiate
328 HWFunction inports outport <- getHWFunc name
329 -- Expand each of the args, so each of them is reduced to output signals
330 (arg_signal_decls, arg_statements, arg_res_signals) <- expandArgs binds args
331 -- Bind each of the input ports to the expanded arguments
332 let inmaps = concat $ zipWith createAssocElems inports arg_res_signals
333 -- Create signal names for our result
334 let res_signal = getPortNameMapForTy (appname ++ "-out") ty
335 -- Create the corresponding signal declarations
336 let signal_decls = mkSignalsFromMap res_signal
337 -- Bind each of the output ports to our output signals
338 let outmaps = mapOutputPorts outport res_signal
339 -- Instantiate the component
340 let component = AST.CSISm $ AST.CompInsSm
341 (AST.unsafeVHDLBasicId appname)
342 (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
343 (AST.PMapAspect (inmaps ++ outmaps))
344 -- Merge the generated declarations
346 signal_decls ++ arg_signal_decls,
347 component : arg_statements,
348 [], -- We don't take any extra arguments; we don't support higher order functions yet
351 -- Creates a list of AssocElems (port map lines) that maps the given signals
352 -- to the given ports.
354 SignalNameMap AST.VHDLId -- The port names to bind to
355 -> SignalNameMap AST.VHDLId -- The signals to bind to it
356 -> [AST.AssocElem] -- The resulting port map lines
358 createAssocElems (Signal port_id) (Signal signal_id) =
359 [(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
361 createAssocElems (Tuple ports) (Tuple signals) =
362 concat $ zipWith createAssocElems ports signals
364 -- Generate a signal declaration for a signal with the given name and the
365 -- given type and no value. Also returns the id of the signal.
366 mkSignal :: String -> AST.TypeMark -> (AST.VHDLId, AST.SigDec)
368 (id, mkSignalFromId id ty)
370 id = AST.unsafeVHDLBasicId name
372 mkSignalFromId :: AST.VHDLId -> AST.TypeMark -> AST.SigDec
373 mkSignalFromId id ty =
374 AST.SigDec id ty Nothing
376 -- Generates signal declarations for all the signals in the given map
378 SignalNameMap AST.VHDLId
381 mkSignalsFromMap (Signal id) =
382 -- TODO: This uses the bit type hardcoded
383 [mkSignalFromId id vhdl_bit_ty]
385 mkSignalsFromMap (Tuple signals) =
386 concat $ map mkSignalsFromMap signals
389 [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
390 -> [CoreExpr] -- The arguments to expand
391 -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId])
392 -- The resulting signal declarations,
393 -- component instantiations and a
394 -- VHDLName for each of the
395 -- expressions passed in.
396 expandArgs binds (e:exprs) = do
397 -- Expand the first expression
398 (signal_decls, statements, arg_signals, res_signal) <- expandExpr binds e
399 if not (null arg_signals)
400 then error $ "Passing functions as arguments not supported: " ++ (showSDoc $ ppr e)
402 (signal_decls', statements', res_signals') <- expandArgs binds exprs
404 signal_decls ++ signal_decls',
405 statements ++ statements',
406 res_signal : res_signals')
408 expandArgs _ [] = return ([], [], [])
410 -- Is the given name a (binary) tuple constructor
411 isTupleConstructor :: Var.Var -> Bool
412 isTupleConstructor var =
413 Name.isWiredInName name
414 && Name.nameModule name == tuple_mod
415 && (Name.occNameString $ Name.nameOccName name) == "(,)"
417 name = Var.varName var
418 mod = nameModule name
419 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
421 -- Split arguments into type arguments and value arguments This is probably
422 -- not really sufficient (not sure if Types can actually occur as value
424 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
425 splitTupleConstructorArgs (e:es) =
427 Type t -> (e:tys, vals)
428 otherwise -> (tys, e:vals)
430 (tys, vals) = splitTupleConstructorArgs es
432 splitTupleConstructorArgs [] = ([], [])
435 SignalNameMap AST.VHDLId -- The output portnames of the component
436 -> SignalNameMap AST.VHDLId -- The output portnames and/or signals to map these to
437 -> [AST.AssocElem] -- The resulting output ports
439 -- Map the output port of a component to the output port of the containing
441 mapOutputPorts (Signal portname) (Signal signalname) =
442 [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
444 -- Map matching output ports in the tuple
445 mapOutputPorts (Tuple ports) (Tuple signals) =
446 concat (zipWith mapOutputPorts ports signals)
449 CoreBind -- The binder to expand into an architecture
450 -> VHDLState AST.ArchBody -- The resulting architecture
452 getArchitecture (Rec _) = error "Recursive binders not supported"
454 getArchitecture (NonRec var expr) = do
455 let name = (getOccString var)
456 HWFunction inports outport <- getHWFunc name
458 (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
459 let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
460 let outport_assigns = createSignalAssignments outport res_signal
461 return $ AST.ArchBody
462 (AST.unsafeVHDLBasicId "structural")
463 -- Use unsafe for now, to prevent pulling in ForSyDe error handling
464 (AST.NSimple (AST.unsafeVHDLBasicId name))
465 (map AST.BDISD signal_decls)
466 (inport_assigns ++ outport_assigns ++ statements)
468 -- Create concurrent assignments of one map of signals to another. The maps
469 -- should have a similar form.
470 createSignalAssignments ::
471 SignalNameMap AST.VHDLId -- The signals to assign to
472 -> SignalNameMap AST.VHDLId -- The signals to assign
473 -> [AST.ConcSm] -- The resulting assignments
475 -- A simple assignment of one signal to another (greatly complicated because
476 -- signal assignments can be conditional with multiple conditions in VHDL).
477 createSignalAssignments (Signal dst) (Signal src) =
480 src_name = AST.NSimple src
481 src_expr = AST.PrimName src_name
482 src_wform = AST.Wform [AST.WformElem src_expr Nothing]
483 dst_name = (AST.NSimple dst)
484 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
486 createSignalAssignments (Tuple dsts) (Tuple srcs) =
487 concat $ zipWith createSignalAssignments dsts srcs
489 createSignalAssignments dst src =
490 error $ "Non matching source and destination: " ++ show dst ++ "\nand\n" ++ show src
492 data SignalNameMap t =
493 Tuple [SignalNameMap t]
497 -- Generate a port name map (or multiple for tuple types) in the given direction for
499 getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap AST.VHDLId]
500 getPortNameMapForTys prefix num [] = []
501 getPortNameMapForTys prefix num (t:ts) =
502 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
504 getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
505 getPortNameMapForTy name ty =
506 if (TyCon.isTupleTyCon tycon) then
507 -- Expand tuples we find
508 Tuple (getPortNameMapForTys name 0 args)
509 else -- Assume it's a type constructor application, ie simple data type
511 Signal (AST.unsafeVHDLBasicId name)
513 (tycon, args) = Type.splitTyConApp ty
515 data HWFunction = HWFunction { -- A function that is available in hardware
516 inPorts :: [SignalNameMap AST.VHDLId],
517 outPort :: SignalNameMap AST.VHDLId
518 --entity :: AST.EntityDec
521 -- Turns a CoreExpr describing a function into a description of its input and
524 CoreBind -- The core binder to generate the interface for
525 -> VHDLState (String, HWFunction) -- The name of the function and its interface
527 mkHWFunction (NonRec var expr) =
528 return (name, HWFunction inports outport)
530 name = (getOccString var)
531 ty = CoreUtils.exprType expr
532 (fargs, res) = Type.splitFunTys ty
533 args = if length fargs == 1 then fargs else (init fargs)
534 --state = if length fargs == 1 then () else (last fargs)
535 inports = case args of
536 -- Handle a single port specially, to prevent an extra 0 in the name
537 [port] -> [getPortNameMapForTy "portin" port]
538 ps -> getPortNameMapForTys "portin" 0 ps
539 outport = getPortNameMapForTy "portout" res
541 mkHWFunction (Rec _) =
542 error "Recursive binders not supported"
544 data VHDLSession = VHDLSession {
545 nameCount :: Int, -- A counter that can be used to generate unique names
546 funcs :: [(String, HWFunction)] -- All functions available, indexed by name
549 type VHDLState = State.State VHDLSession
551 -- Add the function to the session
552 addFunc :: String -> HWFunction -> VHDLState ()
554 fs <- State.gets funcs -- Get the funcs element from the session
555 State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
557 -- Lookup the function with the given name in the current session. Errors if
559 getHWFunc :: String -> VHDLState HWFunction
561 fs <- State.gets funcs -- Get the funcs element from the session
562 return $ Maybe.fromMaybe
563 (error $ "Function " ++ name ++ "is unknown? This should not happen!")
566 -- Makes the given name unique by appending a unique number.
567 -- This does not do any checking against existing names, so it only guarantees
568 -- uniqueness with other names generated by uniqueName.
569 uniqueName :: String -> VHDLState String
571 count <- State.gets nameCount -- Get the funcs element from the session
572 State.modify (\s -> s {nameCount = count + 1})
573 return $ name ++ "-" ++ (show count)
576 mkVHDLId :: String -> AST.VHDLId
577 mkVHDLId = AST.unsafeVHDLBasicId
581 ("hwxor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
582 ("hwand", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
583 ("hwor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
584 ("hwnot", HWFunction [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
587 vhdl_bit_ty :: AST.TypeMark
588 vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
590 -- vim: set ts=8 sw=2 sts=2 expandtab: