liftIO $ printBinds (cm_binds core)
let bind = findBind "half_adder" (cm_binds core)
let NonRec var expr = bind
- let sess = State.execState (do {(name, f) <- mkHWFunction bind; addFunc name f}) (VHDLSession 0 builtin_funcs)
+ -- Turn bind into VHDL
+ let vhdl = State.evalState (mkVHDL bind) (VHDLSession 0 builtin_funcs)
liftIO $ putStr $ showSDoc $ ppr expr
liftIO $ putStr "\n\n"
- liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ getArchitecture sess bind
+ liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ vhdl
return expr
+ where
+ -- Turns the given bind into VHDL
+ mkVHDL bind = do
+ -- Get the function signature
+ (name, f) <- mkHWFunction bind
+ -- Add it to the session
+ addFunc name f
+ arch <- getArchitecture bind
+ return arch
printTarget (Target (TargetFile file (Just x)) obj Nothing) =
print $ show file
getPortMapEntry binds _ a = error $ "Unsupported argument: " ++ (showSDoc $ ppr a)
getInstantiations ::
- VHDLSession
- -> [PortNameMap] -- The arguments that need to be applied to the
+ [PortNameMap] -- The arguments that need to be applied to the
-- expression.
-> PortNameMap -- The output ports that the expression should generate.
-> [(CoreBndr, PortNameMap)] -- A list of bindings in effect
-> CoreSyn.CoreExpr -- The expression to generate an architecture for
- -> [AST.ConcSm] -- The resulting VHDL code
+ -> VHDLState [AST.ConcSm] -- The resulting VHDL code
-- A lambda expression binds the first argument (a) to the binder b.
-getInstantiations sess (a:as) outs binds (Lam b expr) =
- getInstantiations sess as outs ((b, a):binds) expr
+getInstantiations (a:as) outs binds (Lam b expr) =
+ getInstantiations as outs ((b, a):binds) expr
-- A case expression that checks a single variable and has a single
-- alternative, can be used to take tuples apart
-getInstantiations sess args outs binds (Case (Var v) b _ [res]) =
+getInstantiations args outs binds (Case (Var v) b _ [res]) =
case altcon of
DataAlt datacon ->
if (DataCon.isTupleCon datacon) then
- getInstantiations sess args outs binds' expr
+ getInstantiations args outs binds' expr
else
error "Data constructors other than tuples not supported"
otherwise ->
(lookup v binds)
-- An application is an instantiation of a component
-getInstantiations sess args outs binds app@(App expr arg) =
- if isTupleConstructor f then
- let
- Tuple outports = outs
- (tys, vals) = splitTupleConstructorArgs fargs
- in
- concat $ zipWith
- (\outs' expr' -> getInstantiations sess args outs' binds expr')
+getInstantiations args outs binds app@(App expr arg) = do
+ let ((Var f), fargs) = collectArgs app
+ name = getOccString f
+ if isTupleConstructor f
+ then do
+ let Tuple outports = outs
+ (tys, vals) = splitTupleConstructorArgs fargs
+ insts <- sequence $ zipWith
+ (\outs' expr' -> getInstantiations args outs' binds expr')
outports vals
- else
- [AST.CSISm comp]
- where
- ((Var f), fargs) = collectArgs app
- comp = AST.CompInsSm
- (AST.unsafeVHDLBasicId "app")
- (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId compname)))
- (AST.PMapAspect ports)
- compname = getOccString f
- hwfunc = Maybe.fromMaybe
- (error $ "Function " ++ compname ++ "is unknown")
- (lookup compname (funcs sess))
- HWFunction inports outport = hwfunc
- ports =
- zipWith (getPortMapEntry binds) inports fargs
- ++ mapOutputPorts outport outs
-
-getInstantiations sess args outs binds expr =
+ return $ concat insts
+ else do
+ HWFunction inports outport <- getHWFunc name
+ let comp = AST.CompInsSm
+ (AST.unsafeVHDLBasicId "app")
+ (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
+ (AST.PMapAspect ports)
+ ports =
+ zipWith (getPortMapEntry binds) inports fargs
+ ++ mapOutputPorts outport outs
+ return [AST.CSISm comp]
+
+getInstantiations args outs binds expr =
error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
-- Is the given name a (binary) tuple constructor
concat (zipWith mapOutputPorts ports signals)
getArchitecture ::
- VHDLSession
- -> CoreBind -- The binder to expand into an architecture
- -> AST.ArchBody -- The resulting architecture
+ CoreBind -- The binder to expand into an architecture
+ -> VHDLState AST.ArchBody -- The resulting architecture
-getArchitecture sess (Rec _) = error "Recursive binders not supported"
-
-getArchitecture sess (NonRec var expr) =
- AST.ArchBody
+getArchitecture (Rec _) = error "Recursive binders not supported"
+
+getArchitecture (NonRec var expr) = do
+ let name = (getOccString var)
+ HWFunction inports outport <- getHWFunc name
+ sess <- State.get
+ insts <- getInstantiations inports outport [] expr
+ return $ AST.ArchBody
(AST.unsafeVHDLBasicId "structural")
-- Use unsafe for now, to prevent pulling in ForSyDe error handling
(AST.NSimple (AST.unsafeVHDLBasicId name))
[]
- (getInstantiations sess inports outport [] expr)
- where
- name = (getOccString var)
- hwfunc = Maybe.fromMaybe
- (error $ "Function " ++ name ++ "is unknown? This should not happen!")
- (lookup name (funcs sess))
- HWFunction inports outport = hwfunc
+ (insts)
data PortNameMap =
Tuple [PortNameMap]
-- Add the function to the session
addFunc :: String -> HWFunction -> VHDLState ()
addFunc name f = do
- fs <- State.gets funcs -- Get the funcs element form the session
+ fs <- State.gets funcs -- Get the funcs element from the session
State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
+-- Lookup the function with the given name in the current session. Errors if
+-- it was not found.
+getHWFunc :: String -> VHDLState HWFunction
+getHWFunc name = do
+ fs <- State.gets funcs -- Get the funcs element from the session
+ return $ Maybe.fromMaybe
+ (error $ "Function " ++ name ++ "is unknown? This should not happen!")
+ (lookup name fs)
+
builtin_funcs =
[
("hwxor", HWFunction [Port "a", Port "b"] (Port "o")),
projects / matthijs / master-project / cλash.git / blobdiff