- tycount = length $ DataCon.dataConAllTyVars dc
-
-mapOutputPorts ::
- 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
--- entity.
-mapOutputPorts (Single (portname, _)) (Single (signalname, _)) =
- [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
-
--- Map matching output ports in the tuple
-mapOutputPorts (Tuple ports) (Tuple signals) =
- concat (zipWith mapOutputPorts ports signals)
-
-expandBind ::
- CoreBind -- The binder to expand into VHDL
- -> VHDLState [AST.LibraryUnit] -- The resulting VHDL
-
-expandBind (Rec _) = error "Recursive binders not supported"
-
-expandBind bind@(NonRec var expr) = do
- -- Create the function signature
- hwfunc <- mkHWFunction bind
- let ty = CoreUtils.exprType expr
- let hsfunc = mkHsFunction var ty
- -- Add it to the session
- addFunc hsfunc hwfunc
- arch <- getArchitecture hwfunc expr
- let entity = getEntity hwfunc
- return $ [
- AST.LUEntity entity,
- AST.LUArch arch ]
-
-getArchitecture ::
- 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
- -- 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
- return $ AST.ArchBody
- (AST.unsafeVHDLBasicId "structural")
- (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 (Single (port_id, ty)) =
- [AST.IfaceSigDec port_id mode 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 -- 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
--- signal assignments can be conditional with multiple conditions in VHDL).
-createSignalAssignments (Single (dst, _)) (Single (src, _)) =
- [AST.CSSASm assign]
- where
- src_name = AST.NSimple src
- src_expr = AST.PrimName src_name
- src_wform = AST.Wform [AST.WformElem src_expr Nothing]
- 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 dst src =
- error $ "Non matching source and destination: " ++ show dst ++ "\nand\n" ++ show src
-
-type SignalNameMap = HsValueMap (AST.VHDLId, AST.TypeMark)
-
--- | A datatype that maps each of the single values in a haskell structure to
--- a mapto. The map has the same structure as the haskell type mapped, ie
--- nested tuples etc.
-data HsValueMap mapto =
- Tuple [HsValueMap mapto]
- | Single mapto
- deriving (Show, Eq)
-
--- | 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
- -- (basically anything but tuples) to a
- -- HsValueMap (not limited to the Single
- -- constructor)
- -> Type -- ^ The type to map to a HsValueMap
- -> HsValueMap mapto -- ^ The resulting map
-
-mkHsValueMap f ty =
- case Type.splitTyConApp_maybe ty of
- Just (tycon, args) ->
- if (TyCon.isTupleTyCon tycon)
- then
- -- Handle tuple construction especially
- Tuple (map (mkHsValueMap f) args)
- else
- -- And let f handle the rest
- f ty
- -- And let f handle the rest
- Nothing -> f ty
-
--- Generate a port name map (or multiple for tuple types) in the given direction for
--- each type given.
-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
-getPortNameMapForTy name ty =
- if (TyCon.isTupleTyCon tycon) then
- -- Expand tuples we find
- Tuple (getPortNameMapForTys name 0 args)
- else -- Assume it's a type constructor application, ie simple data type
- Single ((AST.unsafeVHDLBasicId name), (vhdl_ty ty))
+ hsfunc = appFunc def
+ args = appArgs def
+ res = appRes def
+ our_states = filter our_state states
+ -- A state signal belongs in this function if the old state is
+ -- passed in, and the new state returned
+ our_state (old, new) =
+ any (old `Foldable.elem`) args
+ && new `Foldable.elem` res
+ (our_old, our_new) = unzip our_states
+ -- Mark the result
+ zipped_res = zipValueMaps res (hsFuncRes hsfunc)
+ res' = fmap (mark_state (zip our_new [0..])) zipped_res
+ -- Mark the args
+ zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
+ args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
+ hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
+
+ mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
+ mark_state states (id, use) =
+ case lookup id states of
+ Nothing -> use
+ Just state_id -> State state_id
+
+-- | Returns pairs of signals that should be mapped to state in this function.
+getStateSignals ::
+ HsFunction -- | The function to look at
+ -> FlatFunction -- | The function to look at
+ -> [(SignalId, SignalId)]
+ -- | TODO The state signals. The first is the state number, the second the
+ -- signal to assign the current state to, the last is the signal
+ -- that holds the new state.
+
+getStateSignals hsfunc flatfunc =
+ [(old_id, new_id)
+ | (old_num, old_id) <- args
+ , (new_num, new_id) <- res
+ , old_num == new_num]