import qualified DataCon
import qualified Maybe
import qualified Module
+import qualified Control.Monad.State as State
import Name
import Data.Generics
import NameEnv ( lookupNameEnv )
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
+ -- Add the HWFunction from the bind to the session
+ let sess = State.execState (addF bind) (VHDLSession 0 builtin_funcs)
liftIO $ putStr $ showSDoc $ ppr expr
liftIO $ putStr "\n\n"
liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ getArchitecture sess bind
return expr
+ where
+ -- Turns the given bind into VHDL
+ addF bind = do
+ -- Get the function signature
+ (name, f) <- mkHWFunction bind
+ -- Add it to the session
+ addFunc name f
printTarget (Target (TargetFile file (Just x)) obj Nothing) =
print $ show file
getInstantiations ::
VHDLSession
- -> PortNameMap -- The arguments that need to be applied to the
- -- expression. Should always be the Args
- -- constructor.
+ -> [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
-- A lambda expression binds the first argument (a) to the binder b.
-getInstantiations sess (Args (a:as)) outs binds (Lam b expr) =
- getInstantiations sess (Args as) outs ((b, a):binds) expr
+getInstantiations sess (a:as) outs binds (Lam b expr) =
+ getInstantiations sess 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
hwfunc = Maybe.fromMaybe
(error $ "Function " ++ compname ++ "is unknown")
(lookup compname (funcs sess))
- HWFunction (Args inports) outport = hwfunc
+ HWFunction inports outport = hwfunc
ports =
zipWith (getPortMapEntry binds) inports fargs
++ mapOutputPorts outport outs
-- Use unsafe for now, to prevent pulling in ForSyDe error handling
(AST.NSimple (AST.unsafeVHDLBasicId name))
[]
- (getInstantiations sess (Args inports) outport [] expr)
+ (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 (Args inports) outport = hwfunc
+ HWFunction inports outport = hwfunc
data PortNameMap =
- Args [PortNameMap] -- Each of the submaps represent an argument to the
- -- function. Should only occur at top level.
- | Tuple [PortNameMap]
+ Tuple [PortNameMap]
| Port String
+ deriving (Show)
-- Generate a port name map (or multiple for tuple types) in the given direction for
-- each type given.
(tycon, args) = Type.splitTyConApp ty
data HWFunction = HWFunction { -- A function that is available in hardware
- inPorts :: PortNameMap,
- outPorts :: PortNameMap
+ inPorts :: [PortNameMap],
+ outPort :: PortNameMap
--entity :: AST.EntityDec
-}
+} deriving (Show)
-- 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
+ CoreBind -- The core binder to generate the interface for
+ -> VHDLState (String, HWFunction) -- The name of the function and its interface
-mkHWFunction sess (NonRec var expr) =
- (sess, name, HWFunction (Args inports) outport)
+mkHWFunction (NonRec var expr) =
+ return (name, HWFunction inports outport)
where
name = (getOccString var)
ty = CoreUtils.exprType expr
ps -> getPortNameMapForTys "portin" 0 ps
outport = getPortNameMapForTy "portout" res
-mkHWFunction sess (Rec _) =
+mkHWFunction (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
-}
+} deriving (Show)
+
+type VHDLState = State.State VHDLSession
-- Add the function to the session
-addFunc :: VHDLSession -> String -> HWFunction -> VHDLSession
-addFunc sess name f =
- sess {funcs = (name, f) : (funcs sess) }
+addFunc :: String -> HWFunction -> VHDLState ()
+addFunc name f = do
+ fs <- State.gets funcs -- Get the funcs element form the session
+ State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
builtin_funcs =
[
- ("hwxor", HWFunction (Args [Port "a", Port "b"]) (Port "o")),
- ("hwand", HWFunction (Args [Port "a", Port "b"]) (Port "o"))
+ ("hwxor", HWFunction [Port "a", Port "b"] (Port "o")),
+ ("hwand", HWFunction [Port "a", Port "b"] (Port "o"))
]
projects / matthijs / master-project / cλash.git / blobdiff