liftIO $ printBinds (cm_binds core)
let bind = findBind "half_adder" (cm_binds core)
let NonRec var expr = bind
+ let sess = VHDLSession 0 builtin_funcs
+ let (sess', name, f) = mkHWFunction sess bind
+ let sess = addFunc sess' name f
liftIO $ putStr $ showSDoc $ ppr expr
liftIO $ putStr "\n\n"
- liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ getArchitecture bind
+ liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ getArchitecture sess bind
return expr
printTarget (Target (TargetFile file (Just x)) obj Nothing) =
-- Accepts a port name and an argument to map to it.
-- Returns the appropriate line for in the port map
-getPortMapEntry binds portname (Var id) =
+getPortMapEntry binds (Port portname) (Var id) =
(Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))
where
Port signalname = Maybe.fromMaybe
getPortMapEntry binds _ a = error $ "Unsupported argument: " ++ (showSDoc $ ppr a)
getInstantiations ::
- PortNameMap -- The arguments that need to be applied to the
+ VHDLSession
+ -> PortNameMap -- The arguments that need to be applied to the
-- expression. Should always be the Args
-- constructor.
-> 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
+ -> [AST.ConcSm] -- The resulting VHDL code
-- A lambda expression binds the first argument (a) to the binder b.
-getInstantiations (Args (a:as)) outs binds (Lam b expr) =
- getInstantiations (Args as) outs ((b, a):binds) expr
+getInstantiations sess (Args (a:as)) outs binds (Lam b expr) =
+ getInstantiations sess (Args 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 args outs binds (Case (Var v) b _ [res]) =
+getInstantiations sess args outs binds (Case (Var v) b _ [res]) =
case altcon of
DataAlt datacon ->
if (DataCon.isTupleCon datacon) then
- getInstantiations args outs binds' expr
+ getInstantiations sess 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 args outs binds app@(App expr arg) =
+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 args outs' binds expr')
+ (\outs' expr' -> getInstantiations sess args outs' binds expr')
outports vals
else
[AST.CSISm comp]
(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 (Args inports) outport = hwfunc
ports =
- zipWith (getPortMapEntry binds) ["portin0", "portin1"] fargs
- ++ mapOutputPorts (Port "portout") outs
+ zipWith (getPortMapEntry binds) inports fargs
+ ++ mapOutputPorts outport outs
-getInstantiations args outs binds expr =
+getInstantiations sess args outs binds expr =
error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
-- Is the given name a (binary) tuple constructor
concat (zipWith mapOutputPorts ports signals)
getArchitecture ::
- CoreBind -- The binder to expand into an architecture
+ VHDLSession
+ -> CoreBind -- The binder to expand into an architecture
-> AST.ArchBody -- The resulting architecture
-getArchitecture (Rec _) = error "Recursive binders not supported"
+getArchitecture sess (Rec _) = error "Recursive binders not supported"
-getArchitecture (NonRec var expr) =
+getArchitecture sess (NonRec var expr) =
AST.ArchBody
(AST.unsafeVHDLBasicId "structural")
-- Use unsafe for now, to prevent pulling in ForSyDe error handling
(AST.NSimple (AST.unsafeVHDLBasicId name))
[]
- (getInstantiations (Args inportnames) outport [] expr)
+ (getInstantiations sess (Args inports) outport [] expr)
where
name = (getOccString var)
- ty = CoreUtils.exprType expr
- (fargs, res) = Type.splitFunTys ty
- --state = if length fargs == 1 then () else (last fargs)
- ports = if length fargs == 1 then fargs else (init fargs)
- inportnames = case ports of
- [port] -> [getPortNameMapForTy "portin" port]
- ps -> getPortNameMapForTys "portin" 0 ps
- outport = getPortNameMapForTy "portout" res
+ hwfunc = Maybe.fromMaybe
+ (error $ "Function " ++ name ++ "is unknown? This should not happen!")
+ (lookup name (funcs sess))
+ HWFunction (Args inports) outport = hwfunc
data PortNameMap =
Args [PortNameMap] -- Each of the submaps represent an argument to the
Port name
where
(tycon, args) = Type.splitTyConApp ty
+
+data HWFunction = HWFunction { -- A function that is available in hardware
+ inPorts :: PortNameMap,
+ outPorts :: PortNameMap
+ --entity :: AST.EntityDec
+}
+
+-- Turns a CoreExpr describing a function into a description of its input and
+-- output ports.
+mkHWFunction ::
+ VHDLSession
+ -> CoreBind -- The core binder to generate the interface for
+ -> (VHDLSession, String, HWFunction) -- The name of the function and its interface
+
+mkHWFunction sess (NonRec var expr) =
+ (sess, name, HWFunction (Args inports) outport)
+ where
+ name = (getOccString var)
+ ty = CoreUtils.exprType expr
+ (fargs, res) = Type.splitFunTys ty
+ args = if length fargs == 1 then fargs else (init fargs)
+ --state = if length fargs == 1 then () else (last fargs)
+ inports = case args of
+ -- Handle a single port specially, to prevent an extra 0 in the name
+ [port] -> [getPortNameMapForTy "portin" port]
+ ps -> getPortNameMapForTys "portin" 0 ps
+ outport = getPortNameMapForTy "portout" res
+
+mkHWFunction sess (Rec _) =
+ error "Recursive binders not supported"
+
+data VHDLSession = VHDLSession {
+ nameCount :: Int, -- A counter that can be used to generate unique names
+ funcs :: [(String, HWFunction)] -- All functions available, indexed by name
+}
+
+-- Add the function to the session
+addFunc :: VHDLSession -> String -> HWFunction -> VHDLSession
+addFunc sess name f =
+ sess {funcs = (name, f) : (funcs sess) }
+
+builtin_funcs =
+ [
+ ("hwxor", HWFunction (Args [Port "a", Port "b"]) (Port "o")),
+ ("hwand", HWFunction (Args [Port "a", Port "b"]) (Port "o"))
+ ]
projects / matthijs / master-project / cλash.git / blobdiff