- name = Var.varName var
- mod = nameModule name
- tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
-
--- Split arguments into type arguments and value arguments This is probably
--- not really sufficient (not sure if Types can actually occur as value
--- arguments...)
-splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
-splitTupleConstructorArgs (e:es) =
- case e of
- Type t -> (e:tys, vals)
- otherwise -> (tys, e:vals)
- where
- (tys, vals) = splitTupleConstructorArgs es
-
-mapOutputPorts ::
- PortNameMap -- The output portnames of the component
- -> PortNameMap -- 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 (Port portname) (Port signalname) =
- [(Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))]
-
--- Map matching output ports in the tuple
-mapOutputPorts (Tuple ports) (Tuple signals) =
- concat (zipWith mapOutputPorts ports signals)
-
-getArchitecture ::
- CoreBind -- The binder to expand into an architecture
- -> VHDLState AST.ArchBody -- The resulting architecture
-
-getArchitecture (Rec _) = error "Recursive binders not supported"
-
-getArchitecture (NonRec var expr) = do
- let name = (getOccString var)
- HWFunction inports outport <- getHWFunc name
- sess <- State.get
- insts <- getInstantiations inports outport [] expr
- return $ AST.ArchBody
- (AST.unsafeVHDLBasicId "structural")
- -- Use unsafe for now, to prevent pulling in ForSyDe error handling
- (AST.NSimple (AST.unsafeVHDLBasicId name))
- []
- (insts)
-
-data PortNameMap =
- Tuple [PortNameMap]
- | Port String
- deriving (Show)
-
--- Generate a port name map (or multiple for tuple types) in the given direction for
--- each type given.
-getPortNameMapForTys :: String -> Int -> [Type] -> [PortNameMap]
-getPortNameMapForTys prefix num [] = []
-getPortNameMapForTys prefix num (t:ts) =
- (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
-
-getPortNameMapForTy :: String -> Type -> PortNameMap
-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
- -- TODO: Add type?
- Port name
- where
- (tycon, args) = Type.splitTyConApp ty
-
-data HWFunction = HWFunction { -- A function that is available in hardware
- inPorts :: [PortNameMap],
- outPort :: PortNameMap
- --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
- -> VHDLState (String, HWFunction) -- The name of the function and its interface
-
-mkHWFunction (NonRec var expr) =
- return (name, HWFunction inports outport)
+ hsname = getOccString f
+ (arg_tys, res_ty) = Type.splitFunTys ty
+ -- The last argument must be state
+ state_ty = last arg_tys
+ state = useAsState (mkHsValueMap state_ty)
+ -- All but the last argument are inports
+ inports = map (useAsPort . mkHsValueMap)(init arg_tys)
+ hsargs = inports ++ [state]
+ hsres = case splitTupleType res_ty of
+ -- Result type must be a two tuple (state, ports)
+ Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
+ then
+ Tuple [state, useAsPort (mkHsValueMap outport_ty)]
+ else
+ error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
+ otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
+
+-- | Adds signal names to the given FlatFunction
+nameFlatFunction ::
+ HsFunction
+ -> FuncData
+ -> VHDLState ()
+
+nameFlatFunction hsfunc fdata =
+ let func = flatFunc fdata in
+ case func of
+ -- Skip (builtin) functions without a FlatFunction
+ Nothing -> do return ()
+ -- Name the signals in all other functions
+ Just flatfunc ->
+ let s = flat_sigs flatfunc in
+ let s' = map (\(id, (SignalInfo Nothing use ty)) -> (id, SignalInfo (Just $ "sig_" ++ (show id)) use ty)) s in
+ let flatfunc' = flatfunc { flat_sigs = s' } in
+ setFlatFunc hsfunc flatfunc'
+
+-- | Splits a tuple type into a list of element types, or Nothing if the type
+-- is not a tuple type.
+splitTupleType ::
+ Type -- ^ The type to split
+ -> Maybe [Type] -- ^ The tuples element types
+
+splitTupleType ty =
+ case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) -> if TyCon.isTupleTyCon tycon
+ then
+ Just args
+ else
+ Nothing
+ Nothing -> Nothing
+
+-- | A consise representation of a (set of) ports on a builtin function
+type PortMap = HsValueMap (String, AST.TypeMark)
+-- | A consise representation of a builtin function
+data BuiltIn = BuiltIn String [PortMap] PortMap
+
+-- | Map a port specification of a builtin function to a VHDL Signal to put in
+-- a VHDLSignalMap
+toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
+toVHDLSignalMap = fmap (\(name, ty) -> Just (VHDL.mkVHDLId name, ty))
+
+-- | Translate a concise representation of a builtin function to something
+-- that can be put into FuncMap directly.
+addBuiltIn :: BuiltIn -> VHDLState ()
+addBuiltIn (BuiltIn name args res) = do
+ addFunc hsfunc
+ setEntity hsfunc entity