--load LoadAllTargets
--core <- GHC.compileToCoreSimplified "Adders.hs"
core <- GHC.compileToCoreSimplified "Adders.hs"
- liftIO $ printBinds (cm_binds core)
- let bind = findBind "full_adder" (cm_binds core)
- let NonRec var expr = bind
+ --liftIO $ printBinds (cm_binds core)
+ let binds = Maybe.mapMaybe (findBind (cm_binds core)) ["full_adder", "half_adder"]
+ liftIO $ printBinds binds
-- 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 $ vhdl
- return expr
+ let vhdl = State.evalState (mkVHDL binds) (VHDLSession 0 [])
+ liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl
+ return ()
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
+ mkVHDL binds = do
+ -- Add the builtin functions
+ mapM (uncurry addFunc) builtin_funcs
+ -- Get the function signatures
+ funcs <- mapM mkHWFunction binds
+ -- Add them to the session
+ mapM (uncurry addFunc) funcs
+ let entities = map getEntity (snd $ unzip funcs)
+ -- Create architectures for them
+ archs <- mapM getArchitecture binds
+ return $ AST.DesignFile
+ []
+ ((map AST.LUEntity entities) ++ (map AST.LUArch archs))
printTarget (Target (TargetFile file (Just x)) obj Nothing) =
print $ show file
printBind' (b, expr) = do
putStr $ getOccString b
- --putStr $ showSDoc $ ppr expr
+ putStr $ showSDoc $ ppr expr
putStr "\n"
-findBind :: String -> [CoreBind] -> CoreBind
-findBind lookfor =
+findBind :: [CoreBind] -> String -> Maybe CoreBind
+findBind binds lookfor =
-- This ignores Recs and compares the name of the bind with lookfor,
-- disregarding any namespaces in OccName and extra attributes in Name and
-- Var.
- Maybe.fromJust . find (\b -> case b of
+ find (\b -> case b of
Rec l -> False
NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
- )
+ ) binds
getPortMapEntry ::
- SignalNameMap AST.VHDLId -- The port name to bind to
- -> SignalNameMap AST.VHDLId
+ SignalNameMap -- The port name to bind to
+ -> SignalNameMap
-- The signal or port to bind to it
-> AST.AssocElem -- The resulting port map entry
(Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
getInstantiations ::
- [SignalNameMap AST.VHDLId] -- The arguments that need to be applied to the
+ [SignalNameMap] -- The arguments that need to be applied to the
-- expression.
- -> SignalNameMap AST.VHDLId -- The output ports that the expression should generate.
- -> [(CoreBndr, SignalNameMap AST.VHDLId)]
+ -> SignalNameMap -- The output ports that the expression should generate.
+ -> [(CoreBndr, SignalNameMap)]
-- A list of bindings in effect
-> CoreSyn.CoreExpr -- The expression to generate an architecture for
-> VHDLState ([AST.SigDec], [AST.ConcSm])
-- This is an normal function application, which maps to a component
-- instantiation.
-- Lookup the hwfunction to instantiate
- HWFunction inports outport <- getHWFunc name
+ HWFunction vhdl_id inports outport <- getHWFunc name
-- Generate a unique name for the application
appname <- uniqueName "app"
-- Expand each argument to a signal or port name, possibly generating
-- Build and return a component instantiation
let comp = AST.CompInsSm
(AST.unsafeVHDLBasicId appname)
- (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
+ (AST.IUEntity (AST.NSimple vhdl_id))
(AST.PMapAspect (inmaps ++ outmaps))
return (sigs, (AST.CSISm comp) : comps)
error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
expandExpr ::
- [(CoreBndr, SignalNameMap AST.VHDLId)]
+ [(CoreBndr, SignalNameMap)]
-- A list of bindings in effect
-> CoreExpr -- The expression to expand
-> VHDLState (
[AST.SigDec], -- Needed signal declarations
[AST.ConcSm], -- Needed component instantations and
-- signal assignments.
- [SignalNameMap AST.VHDLId], -- The signal names corresponding to
+ [SignalNameMap], -- The signal names corresponding to
-- the expression's arguments
- SignalNameMap AST.VHDLId) -- The signal names corresponding to
+ SignalNameMap) -- The signal names corresponding to
-- the expression's result.
expandExpr binds lam@(Lam b expr) = do
-- Generate a new signal to which we will expect this argument to be bound.
(error $ "Argument " ++ getOccString id ++ "is unknown")
(lookup id binds)
+expandExpr binds l@(Let (NonRec b bexpr) expr) = do
+ (signal_decls, statements, arg_signals, res_signals) <- expandExpr binds bexpr
+ let binds' = (b, res_signals) : binds
+ (signal_decls', statements', arg_signals', res_signals') <- expandExpr binds' expr
+ return (
+ signal_decls ++ signal_decls',
+ statements ++ statements',
+ arg_signals',
+ res_signals')
+
expandExpr binds app@(App _ _) = do
let ((Var f), args) = collectArgs app
if isTupleConstructor f
-- Expands the construction of a tuple into VHDL
expandBuildTupleExpr ::
- [(CoreBndr, SignalNameMap AST.VHDLId)]
+ [(CoreBndr, SignalNameMap)]
-- A list of bindings in effect
-> [CoreExpr] -- A list of expressions to put in the tuple
- -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
+ -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap], SignalNameMap)
-- See expandExpr
expandBuildTupleExpr binds args = do
-- Split the tuple constructor arguments into types and actual values.
-- and has a single alternative. This simple form currently allows only for
-- unpacking tuple variables.
expandSingleAltCaseExpr ::
- [(CoreBndr, SignalNameMap AST.VHDLId)]
+ [(CoreBndr, SignalNameMap)]
-- A list of bindings in effect
-> Var.Var -- The scrutinee
-> CoreBndr -- The binder to bind the scrutinee to
-> CoreAlt -- The single alternative
- -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
+ -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap], SignalNameMap)
-- See expandExpr
expandSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
-- Expands the application of argument to a function into VHDL
expandApplicationExpr ::
- [(CoreBndr, SignalNameMap AST.VHDLId)]
+ [(CoreBndr, SignalNameMap)]
-- A list of bindings in effect
-> Type -- The result type of the function call
-> Var.Var -- The function to call
-> [CoreExpr] -- A list of argumetns to apply to the function
- -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
+ -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap], SignalNameMap)
-- See expandExpr
expandApplicationExpr binds ty f args = do
let name = getOccString f
-- Generate a unique name for the application
appname <- uniqueName ("app-" ++ name)
-- Lookup the hwfunction to instantiate
- HWFunction inports outport <- getHWFunc name
+ HWFunction vhdl_id inports outport <- getHWFunc name
-- Expand each of the args, so each of them is reduced to output signals
(arg_signal_decls, arg_statements, arg_res_signals) <- expandArgs binds args
-- Bind each of the input ports to the expanded arguments
-- Instantiate the component
let component = AST.CSISm $ AST.CompInsSm
(AST.unsafeVHDLBasicId appname)
- (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
+ (AST.IUEntity (AST.NSimple vhdl_id))
(AST.PMapAspect (inmaps ++ outmaps))
-- Merge the generated declarations
return (
-- Creates a list of AssocElems (port map lines) that maps the given signals
-- to the given ports.
createAssocElems ::
- SignalNameMap AST.VHDLId -- The port names to bind to
- -> SignalNameMap AST.VHDLId -- The signals to bind to it
+ SignalNameMap -- The port names to bind to
+ -> SignalNameMap -- The signals to bind to it
-> [AST.AssocElem] -- The resulting port map lines
createAssocElems (Signal port_id) (Signal signal_id) =
-- Generates signal declarations for all the signals in the given map
mkSignalsFromMap ::
- SignalNameMap AST.VHDLId
+ SignalNameMap
-> [AST.SigDec]
mkSignalsFromMap (Signal id) =
concat $ map mkSignalsFromMap signals
expandArgs ::
- [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
+ [(CoreBndr, SignalNameMap)] -- A list of bindings in effect
-> [CoreExpr] -- The arguments to expand
- -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId])
+ -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap])
-- The resulting signal declarations,
-- component instantiations and a
-- VHDLName for each of the
splitTupleConstructorArgs [] = ([], [])
mapOutputPorts ::
- SignalNameMap AST.VHDLId -- The output portnames of the component
- -> SignalNameMap AST.VHDLId -- The output portnames and/or signals to map these to
+ SignalNameMap -- The output portnames of the component
+ -> SignalNameMap -- The output portnames and/or signals to map these to
-> [AST.AssocElem] -- The resulting output ports
-- Map the output port of a component to the output port of the containing
getArchitecture (NonRec var expr) = do
let name = (getOccString var)
- HWFunction inports outport <- getHWFunc name
+ HWFunction vhdl_id inports outport <- getHWFunc name
sess <- State.get
(signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
let outport_assigns = createSignalAssignments outport res_signal
return $ AST.ArchBody
(AST.unsafeVHDLBasicId "structural")
- -- Use unsafe for now, to prevent pulling in ForSyDe error handling
- (AST.NSimple (AST.unsafeVHDLBasicId name))
+ (AST.NSimple vhdl_id)
(map AST.BDISD signal_decls)
(inport_assigns ++ outport_assigns ++ statements)
+-- Generate a VHDL entity declaration for the given function
+getEntity :: HWFunction -> AST.EntityDec
+getEntity (HWFunction vhdl_id inports outport) =
+ AST.EntityDec vhdl_id ports
+ where
+ ports =
+ (concat $ map (mkIfaceSigDecs AST.In) inports)
+ ++ mkIfaceSigDecs AST.Out outport
+
+mkIfaceSigDecs ::
+ AST.Mode -- The port's mode (In or Out)
+ -> SignalNameMap -- The ports to generate a map for
+ -> [AST.IfaceSigDec] -- The resulting ports
+
+mkIfaceSigDecs mode (Signal port_id) =
+ -- TODO: Remove hardcoded type
+ [AST.IfaceSigDec port_id mode vhdl_bit_ty]
+
+mkIfaceSigDecs mode (Tuple ports) =
+ concat $ map (mkIfaceSigDecs mode) ports
+
-- Create concurrent assignments of one map of signals to another. The maps
-- should have a similar form.
createSignalAssignments ::
- SignalNameMap AST.VHDLId -- The signals to assign to
- -> SignalNameMap AST.VHDLId -- The signals to assign
+ SignalNameMap -- The signals to assign to
+ -> SignalNameMap -- The signals to assign
-> [AST.ConcSm] -- The resulting assignments
-- A simple assignment of one signal to another (greatly complicated because
createSignalAssignments (Tuple dsts) (Tuple srcs) =
concat $ zipWith createSignalAssignments dsts srcs
-data SignalNameMap t =
- Tuple [SignalNameMap t]
- | Signal t
+createSignalAssignments dst src =
+ error $ "Non matching source and destination: " ++ show dst ++ "\nand\n" ++ show src
+
+data SignalNameMap =
+ Tuple [SignalNameMap]
+ | Signal AST.VHDLId
deriving (Show)
-- Generate a port name map (or multiple for tuple types) in the given direction for
-- each type given.
-getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap AST.VHDLId]
+getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap]
getPortNameMapForTys prefix num [] = []
getPortNameMapForTys prefix num (t:ts) =
(getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
-getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
+getPortNameMapForTy :: String -> Type -> SignalNameMap
getPortNameMapForTy name ty =
if (TyCon.isTupleTyCon tycon) then
-- Expand tuples we find
(tycon, args) = Type.splitTyConApp ty
data HWFunction = HWFunction { -- A function that is available in hardware
- inPorts :: [SignalNameMap AST.VHDLId],
- outPort :: SignalNameMap AST.VHDLId
+ vhdlId :: AST.VHDLId,
+ inPorts :: [SignalNameMap],
+ outPort :: SignalNameMap
--entity :: AST.EntityDec
} deriving (Show)
-> VHDLState (String, HWFunction) -- The name of the function and its interface
mkHWFunction (NonRec var expr) =
- return (name, HWFunction inports outport)
+ return (name, HWFunction (mkVHDLId name) inports outport)
where
- name = (getOccString var)
+ name = getOccString var
ty = CoreUtils.exprType expr
(fargs, res) = Type.splitFunTys ty
args = if length fargs == 1 then fargs else (init fargs)
builtin_funcs =
[
- ("hwxor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
- ("hwand", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
- ("hwor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
- ("hwnot", HWFunction [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
+ ("hwxor", HWFunction (mkVHDLId "hwxor") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
+ ("hwand", HWFunction (mkVHDLId "hwand") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
+ ("hwor", HWFunction (mkVHDLId "hwor") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
+ ("hwnot", HWFunction (mkVHDLId "hwnot") [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
]
vhdl_bit_ty :: AST.TypeMark
projects / matthijs / master-project / cλash.git / blobdiff