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 bind = findBind "dup" (cm_binds core)
48 let NonRec var expr = bind
49 -- Turn bind into VHDL
50 let vhdl = State.evalState (mkVHDL bind) (VHDLSession 0 builtin_funcs)
51 liftIO $ putStr $ showSDoc $ ppr expr
52 liftIO $ putStr "\n\n"
53 liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ vhdl
56 -- Turns the given bind into VHDL
58 -- Get the function signature
59 (name, f) <- mkHWFunction bind
60 -- Add it to the session
62 arch <- getArchitecture bind
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 :: String -> [CoreBind] -> CoreBind
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
92 Maybe.fromJust . find (\b -> case b of
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 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 (AST.unsafeVHDLBasicId name)))
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 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 -- TODO: This uses the bit type hardcoded
207 let (signal_id, signal_decl) = mkSignal signal_name vhdl_bit_ty
208 -- Add the binder to the list of binds
209 let binds' = (b, Signal signal_id) : binds
210 -- Expand the rest of the expression
211 (signal_decls, statements, arg_signals, res_signal) <- expandExpr binds' expr
212 -- Properly merge the results
213 return (signal_decl : signal_decls,
215 (Signal signal_id) : arg_signals,
218 expandExpr binds (Var id) =
219 return ([], [], [], Signal signal_id)
221 -- Lookup the id in our binds map
222 Signal signal_id = Maybe.fromMaybe
223 (error $ "Argument " ++ getOccString id ++ "is unknown")
226 expandExpr binds app@(App _ _) = do
227 let ((Var f), args) = collectArgs app
228 if isTupleConstructor f
230 expandBuildTupleExpr binds args
232 expandApplicationExpr binds (CoreUtils.exprType app) f args
234 expandExpr binds expr =
235 error $ "Unsupported expression: " ++ (showSDoc $ ppr $ expr)
237 -- Expands the construction of a tuple into VHDL
238 expandBuildTupleExpr ::
239 [(CoreBndr, SignalNameMap AST.VHDLId)]
240 -- A list of bindings in effect
241 -> [CoreExpr] -- A list of expressions to put in the tuple
242 -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
244 expandBuildTupleExpr binds args = do
245 -- Split the tuple constructor arguments into types and actual values.
246 let (_, vals) = splitTupleConstructorArgs args
247 -- Expand each of the values in the tuple
248 (signals_declss, statementss, arg_signalss, res_signals) <-
249 (Monad.liftM List.unzip4) $ mapM (expandExpr binds) vals
250 if any (not . null) arg_signalss
251 then error "Putting high order functions in tuples not supported"
254 concat signals_declss,
259 -- Expands the application of argument to a function into VHDL
260 expandApplicationExpr ::
261 [(CoreBndr, SignalNameMap AST.VHDLId)]
262 -- A list of bindings in effect
263 -> Type -- The result type of the function call
264 -> Var.Var -- The function to call
265 -> [CoreExpr] -- A list of argumetns to apply to the function
266 -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
268 expandApplicationExpr binds ty f args = do
269 let name = getOccString f
270 -- Generate a unique name for the application
271 appname <- uniqueName ("app-" ++ name)
272 -- Lookup the hwfunction to instantiate
273 HWFunction inports outport <- getHWFunc name
274 -- Expand each of the args, so each of them is reduced to output signals
275 (arg_signal_decls, arg_statements, arg_res_signals) <- expandArgs binds args
276 -- Bind each of the input ports to the expanded arguments
277 let inmaps = concat $ zipWith createAssocElems inports arg_res_signals
278 -- Create signal names for our result
279 let res_signal = getPortNameMapForTy (appname ++ "-out") ty
280 -- Create the corresponding signal declarations
281 let signal_decls = mkSignalsFromMap res_signal
282 -- Bind each of the output ports to our output signals
283 let outmaps = mapOutputPorts outport res_signal
284 -- Instantiate the component
285 let component = AST.CSISm $ AST.CompInsSm
286 (AST.unsafeVHDLBasicId appname)
287 (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
288 (AST.PMapAspect (inmaps ++ outmaps))
289 -- Merge the generated declarations
291 signal_decls ++ arg_signal_decls,
292 component : arg_statements,
293 [], -- We don't take any extra arguments; we don't support higher order functions yet
296 -- Creates a list of AssocElems (port map lines) that maps the given signals
297 -- to the given ports.
299 SignalNameMap AST.VHDLId -- The port names to bind to
300 -> SignalNameMap AST.VHDLId -- The signals to bind to it
301 -> [AST.AssocElem] -- The resulting port map lines
303 createAssocElems (Signal port_id) (Signal signal_id) =
304 [(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
306 createAssocElems (Tuple ports) (Tuple signals) =
307 concat $ zipWith createAssocElems ports signals
309 -- Generate a signal declaration for a signal with the given name and the
310 -- given type and no value. Also returns the id of the signal.
311 mkSignal :: String -> AST.TypeMark -> (AST.VHDLId, AST.SigDec)
313 (id, mkSignalFromId id ty)
315 id = AST.unsafeVHDLBasicId name
317 mkSignalFromId :: AST.VHDLId -> AST.TypeMark -> AST.SigDec
318 mkSignalFromId id ty =
319 AST.SigDec id ty Nothing
321 -- Generates signal declarations for all the signals in the given map
323 SignalNameMap AST.VHDLId
326 mkSignalsFromMap (Signal id) =
327 -- TODO: This uses the bit type hardcoded
328 [mkSignalFromId id vhdl_bit_ty]
330 mkSignalsFromMap (Tuple signals) =
331 concat $ map mkSignalsFromMap signals
334 [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
335 -> [CoreExpr] -- The arguments to expand
336 -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId])
337 -- The resulting signal declarations,
338 -- component instantiations and a
339 -- VHDLName for each of the
340 -- expressions passed in.
341 expandArgs binds (e:exprs) = do
342 -- Expand the first expression
343 (signal_decls, statements, arg_signals, res_signal) <- expandExpr binds e
344 if not (null arg_signals)
345 then error $ "Passing functions as arguments not supported: " ++ (showSDoc $ ppr e)
347 (signal_decls', statements', res_signals') <- expandArgs binds exprs
349 signal_decls ++ signal_decls',
350 statements ++ statements',
351 res_signal : res_signals')
353 expandArgs _ [] = return ([], [], [])
355 -- Is the given name a (binary) tuple constructor
356 isTupleConstructor :: Var.Var -> Bool
357 isTupleConstructor var =
358 Name.isWiredInName name
359 && Name.nameModule name == tuple_mod
360 && (Name.occNameString $ Name.nameOccName name) == "(,)"
362 name = Var.varName var
363 mod = nameModule name
364 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
366 -- Split arguments into type arguments and value arguments This is probably
367 -- not really sufficient (not sure if Types can actually occur as value
369 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
370 splitTupleConstructorArgs (e:es) =
372 Type t -> (e:tys, vals)
373 otherwise -> (tys, e:vals)
375 (tys, vals) = splitTupleConstructorArgs es
377 splitTupleConstructorArgs [] = ([], [])
380 SignalNameMap AST.VHDLId -- The output portnames of the component
381 -> SignalNameMap AST.VHDLId -- The output portnames and/or signals to map these to
382 -> [AST.AssocElem] -- The resulting output ports
384 -- Map the output port of a component to the output port of the containing
386 mapOutputPorts (Signal portname) (Signal signalname) =
387 [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
389 -- Map matching output ports in the tuple
390 mapOutputPorts (Tuple ports) (Tuple signals) =
391 concat (zipWith mapOutputPorts ports signals)
394 CoreBind -- The binder to expand into an architecture
395 -> VHDLState AST.ArchBody -- The resulting architecture
397 getArchitecture (Rec _) = error "Recursive binders not supported"
399 getArchitecture (NonRec var expr) = do
400 let name = (getOccString var)
401 HWFunction inports outport <- getHWFunc name
403 (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
404 let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
405 let outport_assigns = createSignalAssignments outport res_signal
406 return $ AST.ArchBody
407 (AST.unsafeVHDLBasicId "structural")
408 -- Use unsafe for now, to prevent pulling in ForSyDe error handling
409 (AST.NSimple (AST.unsafeVHDLBasicId name))
410 (map AST.BDISD signal_decls)
411 (inport_assigns ++ outport_assigns ++ statements)
413 -- Create concurrent assignments of one map of signals to another. The maps
414 -- should have a similar form.
415 createSignalAssignments ::
416 SignalNameMap AST.VHDLId -- The signals to assign to
417 -> SignalNameMap AST.VHDLId -- The signals to assign
418 -> [AST.ConcSm] -- The resulting assignments
420 -- A simple assignment of one signal to another (greatly complicated because
421 -- signal assignments can be conditional with multiple conditions in VHDL).
422 createSignalAssignments (Signal dst) (Signal src) =
425 src_name = AST.NSimple src
426 src_expr = AST.PrimName src_name
427 src_wform = AST.Wform [AST.WformElem src_expr Nothing]
428 dst_name = (AST.NSimple dst)
429 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
431 createSignalAssignments (Tuple dsts) (Tuple srcs) =
432 concat $ zipWith createSignalAssignments dsts srcs
434 data SignalNameMap t =
435 Tuple [SignalNameMap t]
439 -- Generate a port name map (or multiple for tuple types) in the given direction for
441 getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap AST.VHDLId]
442 getPortNameMapForTys prefix num [] = []
443 getPortNameMapForTys prefix num (t:ts) =
444 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
446 getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
447 getPortNameMapForTy name ty =
448 if (TyCon.isTupleTyCon tycon) then
449 -- Expand tuples we find
450 Tuple (getPortNameMapForTys name 0 args)
451 else -- Assume it's a type constructor application, ie simple data type
453 Signal (AST.unsafeVHDLBasicId name)
455 (tycon, args) = Type.splitTyConApp ty
457 data HWFunction = HWFunction { -- A function that is available in hardware
458 inPorts :: [SignalNameMap AST.VHDLId],
459 outPort :: SignalNameMap AST.VHDLId
460 --entity :: AST.EntityDec
463 -- Turns a CoreExpr describing a function into a description of its input and
466 CoreBind -- The core binder to generate the interface for
467 -> VHDLState (String, HWFunction) -- The name of the function and its interface
469 mkHWFunction (NonRec var expr) =
470 return (name, HWFunction inports outport)
472 name = (getOccString var)
473 ty = CoreUtils.exprType expr
474 (fargs, res) = Type.splitFunTys ty
475 args = if length fargs == 1 then fargs else (init fargs)
476 --state = if length fargs == 1 then () else (last fargs)
477 inports = case args of
478 -- Handle a single port specially, to prevent an extra 0 in the name
479 [port] -> [getPortNameMapForTy "portin" port]
480 ps -> getPortNameMapForTys "portin" 0 ps
481 outport = getPortNameMapForTy "portout" res
483 mkHWFunction (Rec _) =
484 error "Recursive binders not supported"
486 data VHDLSession = VHDLSession {
487 nameCount :: Int, -- A counter that can be used to generate unique names
488 funcs :: [(String, HWFunction)] -- All functions available, indexed by name
491 type VHDLState = State.State VHDLSession
493 -- Add the function to the session
494 addFunc :: String -> HWFunction -> VHDLState ()
496 fs <- State.gets funcs -- Get the funcs element from the session
497 State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
499 -- Lookup the function with the given name in the current session. Errors if
501 getHWFunc :: String -> VHDLState HWFunction
503 fs <- State.gets funcs -- Get the funcs element from the session
504 return $ Maybe.fromMaybe
505 (error $ "Function " ++ name ++ "is unknown? This should not happen!")
508 -- Makes the given name unique by appending a unique number.
509 -- This does not do any checking against existing names, so it only guarantees
510 -- uniqueness with other names generated by uniqueName.
511 uniqueName :: String -> VHDLState String
513 count <- State.gets nameCount -- Get the funcs element from the session
514 State.modify (\s -> s {nameCount = count + 1})
515 return $ name ++ "-" ++ (show count)
518 mkVHDLId :: String -> AST.VHDLId
519 mkVHDLId = AST.unsafeVHDLBasicId
523 ("hwxor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
524 ("hwand", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
525 ("hwnot", HWFunction [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
528 vhdl_bit_ty :: AST.TypeMark
529 vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
531 -- vim: set ts=8 sw=2 sts=2 expandtab: