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 )
21 -- The following modules come from the ForSyDe project. They are really
22 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
23 -- ForSyDe to get access to these modules.
24 import qualified ForSyDe.Backend.VHDL.AST as AST
25 import qualified ForSyDe.Backend.VHDL.Ppr
26 import qualified ForSyDe.Backend.Ppr
27 -- This is needed for rendering the pretty printed VHDL
28 import Text.PrettyPrint.HughesPJ (render)
32 defaultErrorHandler defaultDynFlags $ do
33 runGhc (Just libdir) $ do
34 dflags <- getSessionDynFlags
35 setSessionDynFlags dflags
36 --target <- guessTarget "adder.hs" Nothing
37 --liftIO (print (showSDoc (ppr (target))))
38 --liftIO $ printTarget target
41 --core <- GHC.compileToCoreSimplified "Adders.hs"
42 core <- GHC.compileToCoreSimplified "Adders.hs"
43 liftIO $ printBinds (cm_binds core)
44 let bind = findBind "invinv" (cm_binds core)
45 let NonRec var expr = bind
46 -- Turn bind into VHDL
47 let vhdl = State.evalState (mkVHDL bind) (VHDLSession 0 builtin_funcs)
48 liftIO $ putStr $ showSDoc $ ppr expr
49 liftIO $ putStr "\n\n"
50 liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ vhdl
53 -- Turns the given bind into VHDL
55 -- Get the function signature
56 (name, f) <- mkHWFunction bind
57 -- Add it to the session
59 arch <- getArchitecture bind
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 :: String -> [CoreBind] -> CoreBind
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
89 Maybe.fromJust . find (\b -> case b of
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 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 -- TODO: This uses the bit type hardcoded
204 let (signal_id, signal_decl) = mkSignal signal_name vhdl_bit_ty
205 -- Add the binder to the list of binds
206 let binds' = (b, Signal signal_id) : binds
207 -- Expand the rest of the expression
208 (signal_decls, statements, arg_signals, res_signal) <- expandExpr binds' expr
209 -- Properly merge the results
210 return (signal_decl : signal_decls,
212 (Signal signal_id) : arg_signals,
215 expandExpr binds (Var id) =
216 return ([], [], [], Signal signal_id)
218 -- Lookup the id in our binds map
219 Signal signal_id = Maybe.fromMaybe
220 (error $ "Argument " ++ getOccString id ++ "is unknown")
223 expandExpr binds app@(App _ _) = do
224 let ((Var f), args) = collectArgs app
225 if isTupleConstructor f
227 expandBuildTupleExpr binds args
229 expandApplicationExpr binds (CoreUtils.exprType app) f args
231 expandExpr binds expr =
232 error $ "Unsupported expression: " ++ (showSDoc $ ppr $ expr)
234 -- Expands the construction of a tuple into VHDL
235 expandBuildTupleExpr ::
236 [(CoreBndr, SignalNameMap AST.VHDLId)]
237 -- A list of bindings in effect
238 -> [CoreExpr] -- A list of expressions to put in the tuple
239 -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
241 expandBuildTupleExpr binds args =
242 error $ "Tuple construction not supported"
244 -- Expands the application of argument to a function into VHDL
245 expandApplicationExpr ::
246 [(CoreBndr, SignalNameMap AST.VHDLId)]
247 -- A list of bindings in effect
248 -> Type -- The result type of the function call
249 -> Var.Var -- The function to call
250 -> [CoreExpr] -- A list of argumetns to apply to the function
251 -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
253 expandApplicationExpr binds ty f args = do
254 let name = getOccString f
255 -- Generate a unique name for the application
256 appname <- uniqueName ("app-" ++ name)
257 -- Lookup the hwfunction to instantiate
258 HWFunction inports outport <- getHWFunc name
259 -- Expand each of the args, so each of them is reduced to output signals
260 (arg_signal_decls, arg_statements, arg_res_signals) <- expandArgs binds args
261 -- Bind each of the input ports to the expanded arguments
262 let inmaps = concat $ zipWith createAssocElems inports arg_res_signals
263 -- Create signal names for our result
264 let res_signal = getPortNameMapForTy (appname ++ "-out") ty
265 -- Create the corresponding signal declarations
266 let signal_decls = mkSignalsFromMap res_signal
267 -- Bind each of the output ports to our output signals
268 let outmaps = mapOutputPorts outport res_signal
269 -- Instantiate the component
270 let component = AST.CSISm $ AST.CompInsSm
271 (AST.unsafeVHDLBasicId appname)
272 (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
273 (AST.PMapAspect (inmaps ++ outmaps))
274 -- Merge the generated declarations
276 signal_decls ++ arg_signal_decls,
277 component : arg_statements,
278 [], -- We don't take any extra arguments; we don't support higher order functions yet
281 -- Creates a list of AssocElems (port map lines) that maps the given signals
282 -- to the given ports.
284 SignalNameMap AST.VHDLId -- The port names to bind to
285 -> SignalNameMap AST.VHDLId -- The signals to bind to it
286 -> [AST.AssocElem] -- The resulting port map lines
288 createAssocElems (Signal port_id) (Signal signal_id) =
289 [(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
291 createAssocElems (Tuple ports) (Tuple signals) =
292 concat $ zipWith createAssocElems ports signals
294 -- Generate a signal declaration for a signal with the given name and the
295 -- given type and no value. Also returns the id of the signal.
296 mkSignal :: String -> AST.TypeMark -> (AST.VHDLId, AST.SigDec)
298 (id, mkSignalFromId id ty)
300 id = AST.unsafeVHDLBasicId name
302 mkSignalFromId :: AST.VHDLId -> AST.TypeMark -> AST.SigDec
303 mkSignalFromId id ty =
304 AST.SigDec id ty Nothing
306 -- Generates signal declarations for all the signals in the given map
308 SignalNameMap AST.VHDLId
311 mkSignalsFromMap (Signal id) =
312 -- TODO: This uses the bit type hardcoded
313 [mkSignalFromId id vhdl_bit_ty]
315 mkSignalsFromMap (Tuple signals) =
316 concat $ map mkSignalsFromMap signals
319 [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
320 -> [CoreExpr] -- The arguments to expand
321 -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId])
322 -- The resulting signal declarations,
323 -- component instantiations and a
324 -- VHDLName for each of the
325 -- expressions passed in.
326 expandArgs binds (e:exprs) = do
327 -- Expand the first expression
328 (signal_decls, statements, arg_signals, res_signal) <- expandExpr binds e
329 if not (null arg_signals)
330 then error $ "Passing functions as arguments not supported: " ++ (showSDoc $ ppr e)
332 (signal_decls', statements', res_signals') <- expandArgs binds exprs
334 signal_decls ++ signal_decls',
335 statements ++ statements',
336 res_signal : res_signals')
338 expandArgs _ [] = return ([], [], [])
340 -- Is the given name a (binary) tuple constructor
341 isTupleConstructor :: Var.Var -> Bool
342 isTupleConstructor var =
343 Name.isWiredInName name
344 && Name.nameModule name == tuple_mod
345 && (Name.occNameString $ Name.nameOccName name) == "(,)"
347 name = Var.varName var
348 mod = nameModule name
349 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
351 -- Split arguments into type arguments and value arguments This is probably
352 -- not really sufficient (not sure if Types can actually occur as value
354 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
355 splitTupleConstructorArgs (e:es) =
357 Type t -> (e:tys, vals)
358 otherwise -> (tys, e:vals)
360 (tys, vals) = splitTupleConstructorArgs es
363 SignalNameMap AST.VHDLId -- The output portnames of the component
364 -> SignalNameMap AST.VHDLId -- The output portnames and/or signals to map these to
365 -> [AST.AssocElem] -- The resulting output ports
367 -- Map the output port of a component to the output port of the containing
369 mapOutputPorts (Signal portname) (Signal signalname) =
370 [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
372 -- Map matching output ports in the tuple
373 mapOutputPorts (Tuple ports) (Tuple signals) =
374 concat (zipWith mapOutputPorts ports signals)
377 CoreBind -- The binder to expand into an architecture
378 -> VHDLState AST.ArchBody -- The resulting architecture
380 getArchitecture (Rec _) = error "Recursive binders not supported"
382 getArchitecture (NonRec var expr) = do
383 let name = (getOccString var)
384 HWFunction inports outport <- getHWFunc name
386 (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
387 let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
388 let outport_assigns = createSignalAssignments outport res_signal
389 return $ AST.ArchBody
390 (AST.unsafeVHDLBasicId "structural")
391 -- Use unsafe for now, to prevent pulling in ForSyDe error handling
392 (AST.NSimple (AST.unsafeVHDLBasicId name))
393 (map AST.BDISD signal_decls)
394 (inport_assigns ++ outport_assigns ++ statements)
396 -- Create concurrent assignments of one map of signals to another. The maps
397 -- should have a similar form.
398 createSignalAssignments ::
399 SignalNameMap AST.VHDLId -- The signals to assign to
400 -> SignalNameMap AST.VHDLId -- The signals to assign
401 -> [AST.ConcSm] -- The resulting assignments
403 -- A simple assignment of one signal to another (greatly complicated because
404 -- signal assignments can be conditional with multiple conditions in VHDL).
405 createSignalAssignments (Signal dst) (Signal src) =
408 src_name = AST.NSimple src
409 src_expr = AST.PrimName src_name
410 src_wform = AST.Wform [AST.WformElem src_expr Nothing]
411 dst_name = (AST.NSimple dst)
412 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
414 createSignalAssignments (Tuple dsts) (Tuple srcs) =
415 concat $ zipWith createSignalAssignments dsts srcs
417 data SignalNameMap t =
418 Tuple [SignalNameMap t]
422 -- Generate a port name map (or multiple for tuple types) in the given direction for
424 getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap AST.VHDLId]
425 getPortNameMapForTys prefix num [] = []
426 getPortNameMapForTys prefix num (t:ts) =
427 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
429 getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
430 getPortNameMapForTy name ty =
431 if (TyCon.isTupleTyCon tycon) then
432 -- Expand tuples we find
433 Tuple (getPortNameMapForTys name 0 args)
434 else -- Assume it's a type constructor application, ie simple data type
436 Signal (AST.unsafeVHDLBasicId name)
438 (tycon, args) = Type.splitTyConApp ty
440 data HWFunction = HWFunction { -- A function that is available in hardware
441 inPorts :: [SignalNameMap AST.VHDLId],
442 outPort :: SignalNameMap AST.VHDLId
443 --entity :: AST.EntityDec
446 -- Turns a CoreExpr describing a function into a description of its input and
449 CoreBind -- The core binder to generate the interface for
450 -> VHDLState (String, HWFunction) -- The name of the function and its interface
452 mkHWFunction (NonRec var expr) =
453 return (name, HWFunction inports outport)
455 name = (getOccString var)
456 ty = CoreUtils.exprType expr
457 (fargs, res) = Type.splitFunTys ty
458 args = if length fargs == 1 then fargs else (init fargs)
459 --state = if length fargs == 1 then () else (last fargs)
460 inports = case args of
461 -- Handle a single port specially, to prevent an extra 0 in the name
462 [port] -> [getPortNameMapForTy "portin" port]
463 ps -> getPortNameMapForTys "portin" 0 ps
464 outport = getPortNameMapForTy "portout" res
466 mkHWFunction (Rec _) =
467 error "Recursive binders not supported"
469 data VHDLSession = VHDLSession {
470 nameCount :: Int, -- A counter that can be used to generate unique names
471 funcs :: [(String, HWFunction)] -- All functions available, indexed by name
474 type VHDLState = State.State VHDLSession
476 -- Add the function to the session
477 addFunc :: String -> HWFunction -> VHDLState ()
479 fs <- State.gets funcs -- Get the funcs element from the session
480 State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
482 -- Lookup the function with the given name in the current session. Errors if
484 getHWFunc :: String -> VHDLState HWFunction
486 fs <- State.gets funcs -- Get the funcs element from the session
487 return $ Maybe.fromMaybe
488 (error $ "Function " ++ name ++ "is unknown? This should not happen!")
491 -- Makes the given name unique by appending a unique number.
492 -- This does not do any checking against existing names, so it only guarantees
493 -- uniqueness with other names generated by uniqueName.
494 uniqueName :: String -> VHDLState String
496 count <- State.gets nameCount -- Get the funcs element from the session
497 State.modify (\s -> s {nameCount = count + 1})
498 return $ name ++ "-" ++ (show count)
501 mkVHDLId :: String -> AST.VHDLId
502 mkVHDLId = AST.unsafeVHDLBasicId
506 ("hwxor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
507 ("hwand", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
508 ("hwnot", HWFunction [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
511 vhdl_bit_ty :: AST.TypeMark
512 vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
514 -- vim: set ts=8 sw=2 sts=2 expandtab: