hwfunc <- mkHWFunction bind hsfunc
-- Add it to the session
addFunc hsfunc hwfunc
- arch <- getArchitecture hwfunc expr
- let entity = getEntity hwfunc
+ arch <- getArchitecture hsfunc hwfunc expr
+ -- Give every entity a clock port
+ -- TODO: Omit this for stateless entities
+ let clk_port = AST.IfaceSigDec (mkVHDLId "clk") AST.In vhdl_bit_ty
+ let entity = getEntity hwfunc [clk_port]
return $ [
AST.LUEntity entity,
AST.LUArch arch ]
getArchitecture ::
- HWFunction -- The function to generate an architecture for
+ HsFunction -- The function interface
+ -> HWFunction -- The function to generate an architecture for
-> CoreExpr -- The expression that is bound to the function
-> VHDLState AST.ArchBody -- The resulting architecture
-getArchitecture hwfunc expr = do
+getArchitecture hsfunc hwfunc expr = do
-- Unpack our hwfunc
let HWFunction vhdl_id inports outport = hwfunc
-- Expand the expression into an architecture body
(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
+ let (inport_assigns, instate_map) = concat_elements $ unzip $ zipWith3 createSignalAssignments arg_signals inports (hsArgs hsfunc)
+ let (outport_assigns, outstate_map) = createSignalAssignments outport res_signal (hsRes hsfunc)
+ let state_procs = map AST.CSPSm $ createStateProcs (sortMap instate_map) (sortMap outstate_map)
return $ AST.ArchBody
(AST.unsafeVHDLBasicId "structural")
(AST.NSimple vhdl_id)
(map AST.BDISD signal_decls)
- (inport_assigns ++ outport_assigns ++ statements)
+ (state_procs ++ inport_assigns ++ outport_assigns ++ statements)
+
+-- | Sorts a map modeled as a list of (key,value) pairs by key
+sortMap :: Ord a => [(a, b)] -> [(a, b)]
+sortMap = List.sortBy (\(a, _) (b, _) -> compare a b)
+
+-- | Generate procs for state variables
+createStateProcs ::
+ [(Int, AST.VHDLId)]
+ -- ^ The sorted list of signals that should be assigned
+ -- to each state
+ -> [(Int, AST.VHDLId)]
+ -- ^ The sorted list of signals that contain each new state
+ -> [AST.ProcSm] -- ^ The resulting procs
+
+createStateProcs ((old_num, old_id):olds) ((new_num, new_id):news) =
+ if (old_num == new_num)
+ then
+ AST.ProcSm label [clk] [statement] : createStateProcs olds news
+ else
+ error "State numbers don't match!"
+ where
+ label = mkVHDLId $ "state_" ++ (show old_num)
+ clk = mkVHDLId "clk"
+ rising_edge = AST.NSimple $ mkVHDLId "rising_edge"
+ wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ new_id) Nothing]
+ assign = AST.SigAssign (AST.NSimple old_id) wform
+ rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
+ statement = AST.IfSm rising_edge_clk [assign] [] Nothing
+
+createStateProcs [] [] = []
-- Generate a VHDL entity declaration for the given function
-getEntity :: HWFunction -> AST.EntityDec
-getEntity (HWFunction vhdl_id inports outport) =
+getEntity :: HWFunction -> [AST.IfaceSigDec] -> AST.EntityDec
+getEntity (HWFunction vhdl_id inports outport) extra_ports =
AST.EntityDec vhdl_id ports
where
ports =
(concat $ map (mkIfaceSigDecs AST.In) inports)
++ mkIfaceSigDecs AST.Out outport
+ ++ extra_ports
mkIfaceSigDecs ::
AST.Mode -- The port's mode (In or Out)
-- Create concurrent assignments of one map of signals to another. The maps
-- should have a similar form.
createSignalAssignments ::
- SignalNameMap -- The signals to assign to
- -> SignalNameMap -- The signals to assign
- -> [AST.ConcSm] -- The resulting assignments
+ SignalNameMap -- The signals to assign to
+ -> SignalNameMap -- The signals to assign
+ -> HsUseMap -- What function does each of the signals have?
+ -> ([AST.ConcSm], -- The resulting assignments
+ [(Int, AST.VHDLId)]) -- The resulting state -> signal mappings
-- A simple assignment of one signal to another (greatly complicated because
-- signal assignments can be conditional with multiple conditions in VHDL).
-createSignalAssignments (Single (dst, _)) (Single (src, _)) =
- [AST.CSSASm assign]
+createSignalAssignments (Single (dst, _)) (Single (src, _)) (Single Port)=
+ ([AST.CSSASm assign], [])
where
src_name = AST.NSimple src
src_expr = AST.PrimName src_name
dst_name = (AST.NSimple dst)
assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
-createSignalAssignments (Tuple dsts) (Tuple srcs) =
- concat $ zipWith createSignalAssignments dsts srcs
+createSignalAssignments (Tuple dsts) (Tuple srcs) (Tuple uses) =
+ concat_elements $ unzip $ zipWith3 createSignalAssignments dsts srcs uses
-createSignalAssignments Unused (Single (src, _)) =
+createSignalAssignments Unused (Single (src, _)) (Single (State n)) =
-- Write state
- []
+ ([], [(n, src)])
-createSignalAssignments (Single (src, _)) Unused =
+createSignalAssignments (Single (dst, _)) Unused (Single (State n)) =
-- Read state
- []
+ ([], [(n, dst)])
-createSignalAssignments dst src =
- error $ "Non matching source and destination: " ++ show dst ++ " <= " ++ show src
+createSignalAssignments dst src use =
+ error $ "Non matching source and destination: " ++ show dst ++ " <= " ++ show src ++ " (Used as " ++ show use ++ ")"
type SignalNameMap = HsValueMap (AST.VHDLId, AST.TypeMark)
-- | Creates a HsValueMap with the same structure as the given type, using the
-- given function for mapping the single types.
mkHsValueMap ::
- (Type -> HsValueMap mapto) -- ^ A function to map single value Types
+ ((Type, s) -> (HsValueMap mapto, s))
+ -- ^ A function to map single value Types
-- (basically anything but tuples) to a
-- HsValueMap (not limited to the Single
- -- constructor)
+ -- constructor) Also accepts and produces a
+ -- state that will be passed on between
+ -- each call to the function.
+ -> s -- ^ The initial state
-> Type -- ^ The type to map to a HsValueMap
- -> HsValueMap mapto -- ^ The resulting map
+ -> (HsValueMap mapto, s) -- ^ The resulting map and state
-mkHsValueMap f ty =
+mkHsValueMap f s ty =
case Type.splitTyConApp_maybe ty of
Just (tycon, args) ->
if (TyCon.isTupleTyCon tycon)
then
+ let (args', s') = mapTuple f s args in
-- Handle tuple construction especially
- Tuple (map (mkHsValueMap f) args)
+ (Tuple args', s')
else
-- And let f handle the rest
- f ty
+ f (ty, s)
-- And let f handle the rest
- Nothing -> f ty
+ Nothing -> f (ty, s)
+ where
+ mapTuple f s (ty:tys) =
+ let (map, s') = mkHsValueMap f s ty in
+ let (maps, s'') = mapTuple f s' tys in
+ (map: maps, s'')
+ mapTuple f s [] = ([], s)
-- Generate a port name map (or multiple for tuple types) in the given direction for
-- each type given.
(getPortNameMapForTy (prefix ++ show num) t u) : getPortNameMapForTys prefix (num + 1) ts us
getPortNameMapForTy :: String -> Type -> HsUseMap -> SignalNameMap
-getPortNameMapForTy name _ (Single State) =
+getPortNameMapForTy name _ (Single (State _)) =
Unused
getPortNameMapForTy name ty use =
-- | How is a given (single) value in a function's type (ie, argument or
-- return value) used?
data HsValueUse =
- Port -- ^ Use it as a port (input or output)
- | State --- ^ Use it as state (input or output)
+ Port -- ^ Use it as a port (input or output)
+ | State Int -- ^ Use it as state (input or output). The int is used to
+ -- match input state to output state.
deriving (Show, Eq)
-useAsPort = mkHsValueMap (\x -> Single Port)
-useAsState = mkHsValueMap (\x -> Single State)
+useAsPort :: Type -> HsUseMap
+useAsPort = fst . (mkHsValueMap (\(ty, s) -> (Single Port, s)) 0)
+useAsState :: Type -> HsUseMap
+useAsState = fst . (mkHsValueMap (\(ty, s) -> (Single $ State s, s + 1)) 0)
type HsUseMap = HsValueMap HsValueUse
appToHsFunction f args ty =
HsFunction hsname hsargs hsres
where
- mkPort = \x -> Single Port
- hsargs = map (mkHsValueMap mkPort . CoreUtils.exprType) args
- hsres = mkHsValueMap mkPort ty
+ hsargs = map (useAsPort . CoreUtils.exprType) args
+ hsres = useAsPort ty
hsname = getOccString f
-- | Translate a top level function declaration to a HsFunction. i.e., which
mkVHDLId :: String -> AST.VHDLId
mkVHDLId = AST.unsafeVHDLBasicId
+-- Concatenate each of the lists of lists inside the given tuple.
+-- Since the element types in the lists might differ, we can't generalize
+-- this (unless we pass in f twice).
+concat_elements :: ([[a]], [[b]]) -> ([a], [b])
+concat_elements (a, b) = (concat a, concat b)
+
builtin_funcs =
[
(HsFunction "hwxor" [(Single Port), (Single Port)] (Single Port), HWFunction (mkVHDLId "hwxor") [Single (mkVHDLId "a", vhdl_bit_ty), Single (mkVHDLId "b", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty))),
projects / matthijs / master-project / cλash.git / blobdiff