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 -- Turn bind into VHDL
49 let vhdl = State.evalState (mkVHDL binds) (VHDLSession 0 builtin_funcs)
50 liftIO $ putStr $ concat $ map (render . ForSyDe.Backend.Ppr.ppr) vhdl
53 -- Turns the given bind into VHDL
55 -- Get the function signatures
56 funcs <- mapM mkHWFunction binds
57 -- Add them to the session
58 mapM (uncurry addFunc) funcs
59 -- Create architectures for them
60 mapM getArchitecture binds
62 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
65 printBinds [] = putStr "done\n\n"
66 printBinds (b:bs) = do
71 printBind (NonRec b expr) = do
75 printBind (Rec binds) = do
77 foldl1 (>>) (map printBind' binds)
79 printBind' (b, expr) = do
80 putStr $ getOccString b
81 --putStr $ showSDoc $ ppr expr
84 findBind :: [CoreBind] -> String -> Maybe CoreBind
85 findBind binds lookfor =
86 -- This ignores Recs and compares the name of the bind with lookfor,
87 -- disregarding any namespaces in OccName and extra attributes in Name and
91 NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
95 SignalNameMap AST.VHDLId -- The port name to bind to
96 -> SignalNameMap AST.VHDLId
97 -- The signal or port to bind to it
98 -> AST.AssocElem -- The resulting port map entry
100 -- Accepts a port name and an argument to map to it.
101 -- Returns the appropriate line for in the port map
102 getPortMapEntry (Signal portname) (Signal signame) =
103 (Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
106 [SignalNameMap AST.VHDLId] -- The arguments that need to be applied to the
108 -> SignalNameMap AST.VHDLId -- The output ports that the expression should generate.
109 -> [(CoreBndr, SignalNameMap AST.VHDLId)]
110 -- A list of bindings in effect
111 -> CoreSyn.CoreExpr -- The expression to generate an architecture for
112 -> VHDLState ([AST.SigDec], [AST.ConcSm])
113 -- The resulting VHDL code
115 -- A lambda expression binds the first argument (a) to the binder b.
116 getInstantiations (a:as) outs binds (Lam b expr) =
117 getInstantiations as outs ((b, a):binds) expr
119 -- A case expression that checks a single variable and has a single
120 -- alternative, can be used to take tuples apart
121 getInstantiations args outs binds (Case (Var v) b _ [res]) =
122 -- Split out the type of alternative constructor, the variables it binds
123 -- and the expression to evaluate with the variables bound.
124 let (altcon, bind_vars, expr) = res in
127 if (DataCon.isTupleCon datacon) then
129 -- Lookup the scrutinee (which must be a variable bound to a tuple) in
130 -- the existing bindings list and get the portname map for each of
132 Tuple tuple_ports = Maybe.fromMaybe
133 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
135 -- Merge our existing binds with the new binds.
136 binds' = (zip bind_vars tuple_ports) ++ binds
138 -- Evaluate the expression with the new binds list
139 getInstantiations args outs binds' expr
141 error "Data constructors other than tuples not supported"
143 error "Case binders other than tuples not supported"
145 -- An application is an instantiation of a component
146 getInstantiations args outs binds app@(App expr arg) = do
147 let ((Var f), fargs) = collectArgs app
148 name = getOccString f
149 if isTupleConstructor f
151 -- Get the signals we should bind our results to
152 let Tuple outports = outs
153 -- Split the tuple constructor arguments into types and actual values.
154 let (_, vals) = splitTupleConstructorArgs fargs
155 -- Bind each argument to each output signal
156 res <- sequence $ zipWith
157 (\outs' expr' -> getInstantiations args outs' binds expr')
159 -- res is a list of pairs of lists, so split out the signals and
160 -- components into separate lists of lists
161 let (sigs, comps) = unzip res
162 -- And join all the signals and component instantiations together
163 return $ (concat sigs, concat comps)
165 -- This is an normal function application, which maps to a component
167 -- Lookup the hwfunction to instantiate
168 HWFunction inports outport <- getHWFunc name
169 -- Generate a unique name for the application
170 appname <- uniqueName "app"
171 -- Expand each argument to a signal or port name, possibly generating
172 -- new signals and component instantiations
173 (sigs, comps, args) <- expandArgs binds fargs
174 -- Bind each of the input ports to the expanded signal or port
175 let inmaps = zipWith getPortMapEntry inports args
176 -- Bind each of the output ports to our output signals
177 let outmaps = mapOutputPorts outport outs
178 -- Build and return a component instantiation
179 let comp = AST.CompInsSm
180 (AST.unsafeVHDLBasicId appname)
181 (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
182 (AST.PMapAspect (inmaps ++ outmaps))
183 return (sigs, (AST.CSISm comp) : comps)
185 getInstantiations args outs binds expr =
186 error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
189 [(CoreBndr, SignalNameMap AST.VHDLId)]
190 -- A list of bindings in effect
191 -> CoreExpr -- The expression to expand
193 [AST.SigDec], -- Needed signal declarations
194 [AST.ConcSm], -- Needed component instantations and
195 -- signal assignments.
196 [SignalNameMap AST.VHDLId], -- The signal names corresponding to
197 -- the expression's arguments
198 SignalNameMap AST.VHDLId) -- The signal names corresponding to
199 -- the expression's result.
200 expandExpr binds lam@(Lam b expr) = do
201 -- Generate a new signal to which we will expect this argument to be bound.
202 signal_name <- uniqueName ("arg-" ++ getOccString b)
203 -- Find the type of the binder
204 let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
205 -- Create signal names for the binder
206 let arg_signal = getPortNameMapForTy ("xxx") arg_ty
207 -- Create the corresponding signal declarations
208 let signal_decls = mkSignalsFromMap arg_signal
209 -- Add the binder to the list of binds
210 let binds' = (b, arg_signal) : binds
211 -- Expand the rest of the expression
212 (signal_decls', statements', arg_signals', res_signal') <- expandExpr binds' expr
213 -- Properly merge the results
214 return (signal_decls ++ signal_decls',
216 arg_signal : arg_signals',
219 expandExpr binds (Var id) =
220 return ([], [], [], Signal signal_id)
222 -- Lookup the id in our binds map
223 Signal signal_id = Maybe.fromMaybe
224 (error $ "Argument " ++ getOccString id ++ "is unknown")
227 expandExpr binds l@(Let (NonRec b bexpr) expr) = do
228 (signal_decls, statements, arg_signals, res_signals) <- expandExpr binds bexpr
229 let binds' = (b, res_signals) : binds
230 (signal_decls', statements', arg_signals', res_signals') <- expandExpr binds' expr
232 signal_decls ++ signal_decls',
233 statements ++ statements',
237 expandExpr binds app@(App _ _) = do
238 let ((Var f), args) = collectArgs app
239 if isTupleConstructor f
241 expandBuildTupleExpr binds args
243 expandApplicationExpr binds (CoreUtils.exprType app) f args
245 expandExpr binds expr@(Case (Var v) b _ alts) =
247 [alt] -> expandSingleAltCaseExpr binds v b alt
248 otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
250 expandExpr binds expr@(Case _ b _ _) =
251 error $ "Case expression with non-variable scrutinee not supported: " ++ (showSDoc $ ppr expr)
253 expandExpr binds expr =
254 error $ "Unsupported expression: " ++ (showSDoc $ ppr $ expr)
256 -- Expands the construction of a tuple into VHDL
257 expandBuildTupleExpr ::
258 [(CoreBndr, SignalNameMap AST.VHDLId)]
259 -- A list of bindings in effect
260 -> [CoreExpr] -- A list of expressions to put in the tuple
261 -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
263 expandBuildTupleExpr binds args = do
264 -- Split the tuple constructor arguments into types and actual values.
265 let (_, vals) = splitTupleConstructorArgs args
266 -- Expand each of the values in the tuple
267 (signals_declss, statementss, arg_signalss, res_signals) <-
268 (Monad.liftM List.unzip4) $ mapM (expandExpr binds) vals
269 if any (not . null) arg_signalss
270 then error "Putting high order functions in tuples not supported"
273 concat signals_declss,
278 -- Expands the most simple case expression that scrutinizes a plain variable
279 -- and has a single alternative. This simple form currently allows only for
280 -- unpacking tuple variables.
281 expandSingleAltCaseExpr ::
282 [(CoreBndr, SignalNameMap AST.VHDLId)]
283 -- A list of bindings in effect
284 -> Var.Var -- The scrutinee
285 -> CoreBndr -- The binder to bind the scrutinee to
286 -> CoreAlt -- The single alternative
287 -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
290 expandSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
291 if not (DataCon.isTupleCon datacon)
293 error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
296 -- Lookup the scrutinee (which must be a variable bound to a tuple) in
297 -- the existing bindings list and get the portname map for each of
299 Tuple tuple_ports = Maybe.fromMaybe
300 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
302 -- TODO include b in the binds list
303 -- Merge our existing binds with the new binds.
304 binds' = (zip bind_vars tuple_ports) ++ binds
306 -- Expand the expression with the new binds list
307 expandExpr binds' expr
309 expandSingleAltCaseExpr _ _ _ alt =
310 error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
313 -- Expands the application of argument to a function into VHDL
314 expandApplicationExpr ::
315 [(CoreBndr, SignalNameMap AST.VHDLId)]
316 -- A list of bindings in effect
317 -> Type -- The result type of the function call
318 -> Var.Var -- The function to call
319 -> [CoreExpr] -- A list of argumetns to apply to the function
320 -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
322 expandApplicationExpr binds ty f args = do
323 let name = getOccString f
324 -- Generate a unique name for the application
325 appname <- uniqueName ("app-" ++ name)
326 -- Lookup the hwfunction to instantiate
327 HWFunction inports outport <- getHWFunc name
328 -- Expand each of the args, so each of them is reduced to output signals
329 (arg_signal_decls, arg_statements, arg_res_signals) <- expandArgs binds args
330 -- Bind each of the input ports to the expanded arguments
331 let inmaps = concat $ zipWith createAssocElems inports arg_res_signals
332 -- Create signal names for our result
333 let res_signal = getPortNameMapForTy (appname ++ "-out") ty
334 -- Create the corresponding signal declarations
335 let signal_decls = mkSignalsFromMap res_signal
336 -- Bind each of the output ports to our output signals
337 let outmaps = mapOutputPorts outport res_signal
338 -- Instantiate the component
339 let component = AST.CSISm $ AST.CompInsSm
340 (AST.unsafeVHDLBasicId appname)
341 (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
342 (AST.PMapAspect (inmaps ++ outmaps))
343 -- Merge the generated declarations
345 signal_decls ++ arg_signal_decls,
346 component : arg_statements,
347 [], -- We don't take any extra arguments; we don't support higher order functions yet
350 -- Creates a list of AssocElems (port map lines) that maps the given signals
351 -- to the given ports.
353 SignalNameMap AST.VHDLId -- The port names to bind to
354 -> SignalNameMap AST.VHDLId -- The signals to bind to it
355 -> [AST.AssocElem] -- The resulting port map lines
357 createAssocElems (Signal port_id) (Signal signal_id) =
358 [(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
360 createAssocElems (Tuple ports) (Tuple signals) =
361 concat $ zipWith createAssocElems ports signals
363 -- Generate a signal declaration for a signal with the given name and the
364 -- given type and no value. Also returns the id of the signal.
365 mkSignal :: String -> AST.TypeMark -> (AST.VHDLId, AST.SigDec)
367 (id, mkSignalFromId id ty)
369 id = AST.unsafeVHDLBasicId name
371 mkSignalFromId :: AST.VHDLId -> AST.TypeMark -> AST.SigDec
372 mkSignalFromId id ty =
373 AST.SigDec id ty Nothing
375 -- Generates signal declarations for all the signals in the given map
377 SignalNameMap AST.VHDLId
380 mkSignalsFromMap (Signal id) =
381 -- TODO: This uses the bit type hardcoded
382 [mkSignalFromId id vhdl_bit_ty]
384 mkSignalsFromMap (Tuple signals) =
385 concat $ map mkSignalsFromMap signals
388 [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
389 -> [CoreExpr] -- The arguments to expand
390 -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId])
391 -- The resulting signal declarations,
392 -- component instantiations and a
393 -- VHDLName for each of the
394 -- expressions passed in.
395 expandArgs binds (e:exprs) = do
396 -- Expand the first expression
397 (signal_decls, statements, arg_signals, res_signal) <- expandExpr binds e
398 if not (null arg_signals)
399 then error $ "Passing functions as arguments not supported: " ++ (showSDoc $ ppr e)
401 (signal_decls', statements', res_signals') <- expandArgs binds exprs
403 signal_decls ++ signal_decls',
404 statements ++ statements',
405 res_signal : res_signals')
407 expandArgs _ [] = return ([], [], [])
409 -- Is the given name a (binary) tuple constructor
410 isTupleConstructor :: Var.Var -> Bool
411 isTupleConstructor var =
412 Name.isWiredInName name
413 && Name.nameModule name == tuple_mod
414 && (Name.occNameString $ Name.nameOccName name) == "(,)"
416 name = Var.varName var
417 mod = nameModule name
418 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
420 -- Split arguments into type arguments and value arguments This is probably
421 -- not really sufficient (not sure if Types can actually occur as value
423 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
424 splitTupleConstructorArgs (e:es) =
426 Type t -> (e:tys, vals)
427 otherwise -> (tys, e:vals)
429 (tys, vals) = splitTupleConstructorArgs es
431 splitTupleConstructorArgs [] = ([], [])
434 SignalNameMap AST.VHDLId -- The output portnames of the component
435 -> SignalNameMap AST.VHDLId -- The output portnames and/or signals to map these to
436 -> [AST.AssocElem] -- The resulting output ports
438 -- Map the output port of a component to the output port of the containing
440 mapOutputPorts (Signal portname) (Signal signalname) =
441 [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
443 -- Map matching output ports in the tuple
444 mapOutputPorts (Tuple ports) (Tuple signals) =
445 concat (zipWith mapOutputPorts ports signals)
448 CoreBind -- The binder to expand into an architecture
449 -> VHDLState AST.ArchBody -- The resulting architecture
451 getArchitecture (Rec _) = error "Recursive binders not supported"
453 getArchitecture (NonRec var expr) = do
454 let name = (getOccString var)
455 HWFunction inports outport <- getHWFunc name
457 (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
458 let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
459 let outport_assigns = createSignalAssignments outport res_signal
460 return $ AST.ArchBody
461 (AST.unsafeVHDLBasicId "structural")
462 -- Use unsafe for now, to prevent pulling in ForSyDe error handling
463 (AST.NSimple (AST.unsafeVHDLBasicId name))
464 (map AST.BDISD signal_decls)
465 (inport_assigns ++ outport_assigns ++ statements)
467 -- Create concurrent assignments of one map of signals to another. The maps
468 -- should have a similar form.
469 createSignalAssignments ::
470 SignalNameMap AST.VHDLId -- The signals to assign to
471 -> SignalNameMap AST.VHDLId -- The signals to assign
472 -> [AST.ConcSm] -- The resulting assignments
474 -- A simple assignment of one signal to another (greatly complicated because
475 -- signal assignments can be conditional with multiple conditions in VHDL).
476 createSignalAssignments (Signal dst) (Signal src) =
479 src_name = AST.NSimple src
480 src_expr = AST.PrimName src_name
481 src_wform = AST.Wform [AST.WformElem src_expr Nothing]
482 dst_name = (AST.NSimple dst)
483 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
485 createSignalAssignments (Tuple dsts) (Tuple srcs) =
486 concat $ zipWith createSignalAssignments dsts srcs
488 createSignalAssignments dst src =
489 error $ "Non matching source and destination: " ++ show dst ++ "\nand\n" ++ show src
491 data SignalNameMap t =
492 Tuple [SignalNameMap t]
496 -- Generate a port name map (or multiple for tuple types) in the given direction for
498 getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap AST.VHDLId]
499 getPortNameMapForTys prefix num [] = []
500 getPortNameMapForTys prefix num (t:ts) =
501 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
503 getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
504 getPortNameMapForTy name ty =
505 if (TyCon.isTupleTyCon tycon) then
506 -- Expand tuples we find
507 Tuple (getPortNameMapForTys name 0 args)
508 else -- Assume it's a type constructor application, ie simple data type
510 Signal (AST.unsafeVHDLBasicId name)
512 (tycon, args) = Type.splitTyConApp ty
514 data HWFunction = HWFunction { -- A function that is available in hardware
515 inPorts :: [SignalNameMap AST.VHDLId],
516 outPort :: SignalNameMap AST.VHDLId
517 --entity :: AST.EntityDec
520 -- Turns a CoreExpr describing a function into a description of its input and
523 CoreBind -- The core binder to generate the interface for
524 -> VHDLState (String, HWFunction) -- The name of the function and its interface
526 mkHWFunction (NonRec var expr) =
527 return (name, HWFunction inports outport)
529 name = (getOccString var)
530 ty = CoreUtils.exprType expr
531 (fargs, res) = Type.splitFunTys ty
532 args = if length fargs == 1 then fargs else (init fargs)
533 --state = if length fargs == 1 then () else (last fargs)
534 inports = case args of
535 -- Handle a single port specially, to prevent an extra 0 in the name
536 [port] -> [getPortNameMapForTy "portin" port]
537 ps -> getPortNameMapForTys "portin" 0 ps
538 outport = getPortNameMapForTy "portout" res
540 mkHWFunction (Rec _) =
541 error "Recursive binders not supported"
543 data VHDLSession = VHDLSession {
544 nameCount :: Int, -- A counter that can be used to generate unique names
545 funcs :: [(String, HWFunction)] -- All functions available, indexed by name
548 type VHDLState = State.State VHDLSession
550 -- Add the function to the session
551 addFunc :: String -> HWFunction -> VHDLState ()
553 fs <- State.gets funcs -- Get the funcs element from the session
554 State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
556 -- Lookup the function with the given name in the current session. Errors if
558 getHWFunc :: String -> VHDLState HWFunction
560 fs <- State.gets funcs -- Get the funcs element from the session
561 return $ Maybe.fromMaybe
562 (error $ "Function " ++ name ++ "is unknown? This should not happen!")
565 -- Makes the given name unique by appending a unique number.
566 -- This does not do any checking against existing names, so it only guarantees
567 -- uniqueness with other names generated by uniqueName.
568 uniqueName :: String -> VHDLState String
570 count <- State.gets nameCount -- Get the funcs element from the session
571 State.modify (\s -> s {nameCount = count + 1})
572 return $ name ++ "-" ++ (show count)
575 mkVHDLId :: String -> AST.VHDLId
576 mkVHDLId = AST.unsafeVHDLBasicId
580 ("hwxor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
581 ("hwand", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
582 ("hwor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
583 ("hwnot", HWFunction [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
586 vhdl_bit_ty :: AST.TypeMark
587 vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
589 -- vim: set ts=8 sw=2 sts=2 expandtab: