- 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
-
--- Unused values (state) don't generate ports
-mkIfaceSigDecs mode Unused =
- []
-
--- 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 Unused (Single (src, _)) =
- -- Write state
- []
-
-createSignalAssignments (Single (src, _)) Unused =
- -- Read state
- []
-
-createSignalAssignments dst src =
- error $ "Non matching source and destination: " ++ show dst ++ " <= " ++ 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
- | Unused
- 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] -> [HsUseMap] -> [SignalNameMap]
-getPortNameMapForTys prefix num [] [] = []
-getPortNameMapForTys prefix num (t:ts) (u:us) =
- (getPortNameMapForTy (prefix ++ show num) t u) : getPortNameMapForTys prefix (num + 1) ts us
-
-getPortNameMapForTy :: String -> Type -> HsUseMap -> SignalNameMap
-getPortNameMapForTy name _ (Single State) =
- Unused
-
-getPortNameMapForTy name ty use =
- if (TyCon.isTupleTyCon tycon) then
- let (Tuple uses) = use in
- -- Expand tuples we find
- Tuple (getPortNameMapForTys name 0 args uses)
- else -- Assume it's a type constructor application, ie simple data type
- Single ((AST.unsafeVHDLBasicId name), (vhdl_ty ty))
- where
- (tycon, args) = Type.splitTyConApp ty
-
-data HWFunction = HWFunction { -- A function that is available in hardware
- vhdlId :: AST.VHDLId,
- inPorts :: [SignalNameMap],
- outPort :: SignalNameMap
- --entity :: AST.EntityDec
-} deriving (Show)
-
--- Turns a CoreExpr describing a function into a description of its input and
--- output ports.
-mkHWFunction ::
- CoreBind -- The core binder to generate the interface for
- -> HsFunction -- The HsFunction describing the function
- -> VHDLState HWFunction -- The function interface
-
-mkHWFunction (NonRec var expr) hsfunc =
- return $ HWFunction (mkVHDLId name) inports outport
- where
- name = getOccString var
- ty = CoreUtils.exprType expr
- (args, res) = Type.splitFunTys ty
- inports = case args of
- -- Handle a single port specially, to prevent an extra 0 in the name
- [port] -> [getPortNameMapForTy "portin" port (head $ hsArgs hsfunc)]
- ps -> getPortNameMapForTys "portin" 0 ps (hsArgs hsfunc)
- outport = getPortNameMapForTy "portout" res (hsRes hsfunc)
-
-mkHWFunction (Rec _) _ =
- error "Recursive binders not supported"
-
--- | 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)
- deriving (Show, Eq)
-
-useAsPort = mkHsValueMap (\x -> Single Port)
-useAsState = mkHsValueMap (\x -> Single State)
-
-type HsUseMap = HsValueMap HsValueUse
-
--- | This type describes a particular use of a Haskell function and is used to
--- look up an appropriate hardware description.
-data HsFunction = HsFunction {
- hsName :: String, -- ^ What was the name of the original Haskell function?
- hsArgs :: [HsUseMap], -- ^ How are the arguments used?
- hsRes :: HsUseMap -- ^ How is the result value used?
-} deriving (Show, Eq)
-
--- | Translate a function application to a HsFunction. i.e., which function
--- do you need to translate this function application.
-appToHsFunction ::
- Var.Var -- ^ The function to call
- -> [CoreExpr] -- ^ The function arguments
- -> Type -- ^ The return type
- -> HsFunction -- ^ The needed HsFunction
-
-appToHsFunction f args ty =
- HsFunction hsname hsargs hsres
- where
- mkPort = \x -> Single Port
- hsargs = map (mkHsValueMap mkPort . CoreUtils.exprType) args
- hsres = mkHsValueMap mkPort ty
- hsname = getOccString f