- 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
- -> 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, _)) (Single Port)=
- ([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) (Tuple uses) =
- concat_elements $ unzip $ zipWith3 createSignalAssignments dsts srcs uses
-
-createSignalAssignments Unused (Single (src, _)) (Single (State n)) =
- -- Write state
- ([], [(n, src)])
-
-createSignalAssignments (Single (dst, _)) Unused (Single (State n)) =
- -- Read state
- ([], [(n, dst)])
-
-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)
-
--- | 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, s) -> (HsValueMap mapto, s))
- -- ^ A function to map single value Types
- -- (basically anything but tuples) to a
- -- HsValueMap (not limited to the Single
- -- 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, s) -- ^ The resulting map and state
-
-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 args', s')
- else
- -- And let f handle the rest
- f (ty, s)
- -- And let f handle the rest
- 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.
-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 Int -- ^ Use it as state (input or output). The int is used to
- -- match input state to output state.
- deriving (Show, Eq)
-
-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
-
--- | 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
- hsargs = map (useAsPort . CoreUtils.exprType) args
- hsres = useAsPort ty
- hsname = getOccString f