{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module LambdaCalc( SPackage, convAPackageToLambdaCalc ) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804) import Prelude hiding ((<>)) #endif import qualified Data.Map as M import qualified Data.Set as S import Control.Monad.State import Data.Maybe(mapMaybe) import Data.Char(toLower) import Util(snd3, fst2of3, itos, concatMapM, map_deleteMany, makePairs) import Error(internalError, ErrorHandle, bsWarning) import Flags import Eval import PPrint import Id import IntLit import Prim(PrimOp(..)) import VModInfo(vName, VArgInfo(..), isParam, isPort, getVNameString) import ASyntax import LambdaCalcUtil -- TODO: -- * filter out unused defs (such as arguments to foreign funcs/tasks) -- * figure out how to handle gated clocks -- ------------------------- -- requires that task splicing has already happened -- convAPackageToLambdaCalc :: ErrorHandle -> Flags -> APackage -> IO SPackage -- avoid work if a dump wasn't requested convAPackageToLambdaCalc errh flags apkg | not (hasDumpStrict flags DFdumpLambdaCalculus) = return (SPackage [] []) -- handle noinline functions separately convAPackageToLambdaCalc errh flags apkg0 | (apkg_is_wrapped apkg0) = let -- update the types of the primitives apkg = lcAPackageProcess errh flags apkg0 ds = apkg_local_defs apkg ifcs = apkg_interface apkg defmap = M.fromList [ (i, d) | d@(ADef i _ _ _) <- ds ] -- there should be one value method, and its constant RDY fn_defs = case ifcs of [AIDef methId args _ p (ADef _ ret_t ret_e _) _ _, AIDef rdyId _ _ _ (ADef _ _ rdy_e _) _ _] | (isRdyId rdyId) && (isTrue rdy_e) -> -- this is very similar to convAIFace for AIDef, -- except that the function doesn't take a state argument -- and has a different name let rt = convAType ret_t argset = S.fromList (map fst args) arg_infos = map (\(i,t) -> (methArgId i, convAType t)) args arg_types = map snd arg_infos -- get all the defs used by the return value uses = getAExprDefs defmap M.empty [ret_e] -- the module name is unused, but give one anyway; -- use the method name (the apkg name has "module_" prepended) body = runCM methId defmap M.empty argset $ do ret_expr <- convAExpr ret_e ds <- mapM convUse (M.toList uses) return $ sLet ds ret_expr in [SDValue (noinlineId methId) (funcType arg_types rt) $ sLam arg_infos body] _ -> internalError ("convAPackageToLambdaCalc: noinline ifcs: " ++ ppReadable ifcs) -- package comments cs = [] in return $ SPackage cs fn_defs convAPackageToLambdaCalc errh flags apkg0 = case (chkAPackage "lambda-calculus" apkg0) of Just wmsgs -> do bsWarning errh wmsgs return (SPackage [] []) Nothing -> let -- update the types of the primitives etc apkg = lcAPackageProcess errh flags apkg0 modId = apkg_name apkg avis = apkg_state_instances apkg ds = apkg_local_defs apkg rs = apkg_rules apkg ifcs = apkg_interface apkg inps = getAPackageInputs apkg defmap = M.fromList [ (i, d) | d@(ADef i _ _ _) <- ds ] instmap = M.fromList [ (inst, (vn, ps, mtmap)) | avi <- avis, let inst = avi_vname avi, let (vn, ps) = getSubModType avi, let mtmap = getSubModAVMethReturnTypes avi] mmap = mkMethodOrderMap avis -- declare the module type (record of submods) state_defs = makeModStructDecl modId inps avis -- define the ctor (call submod ctors with inst args) ctor_defs = makeModCtor defmap modId inps avis -- define the dimension fn (call the dimension fn on submods) dim_defs = makeModDimDefn modId avis -- define each rule as a fn rule_defs = map (convARule defmap instmap mmap modId) rs -- define each method as a fn ifc_defs = concatMap (convAIFace defmap instmap mmap modId) ifcs -- package comments cs = [] in return $ SPackage cs (state_defs ++ ctor_defs ++ dim_defs ++ rule_defs ++ ifc_defs) -- ------------------------- -- This dump was created for use in the SRI Smten tool (previously SERI), -- which is why the data types are prepended with "S". data SPackage = SPackage SComment [SDefn] deriving (Eq, Show) type SComment = [String] -- Top level definition data SDefn = SDStruct Id [(Id, SType)] | SDValue Id SType SExpr | SDComment SComment [SDefn] deriving (Eq, Show) data SType = STVar Id | STCon (STyCon) | STAp SType SType deriving (Eq, Show) data STyCon = STyCon Id | STyNum Integer deriving (Eq, Show) data SExpr = SLam Id SType SExpr | SLet [(Id, SType, SExpr)] SExpr | SVar Id | SCon Id | SBVLit Integer Integer -- width, value | SStringLit String | SRealLit Double | SApply SExpr [SExpr] | SApplyInfix Id [SExpr] | SStruct Id [(Id, SExpr)] | SStructUpd SExpr [(Id, SExpr)] | SSelect SExpr Id | SIf SExpr SExpr SExpr | SHasType SType SExpr -- type signature deriving (Eq, Show) -- ----- instance Hyper SPackage where hyper x y = (x==x) `seq` y -- ----- instance PPrint SPackage where pPrint d p (SPackage cs ds) = ppComment cs $+$ vsepEmptyLine (map (pPrint d 0) ds) instance PPrint SDefn where pPrint d p (SDComment cs ds) = ppComment cs $+$ vsep (map (pPrint d 0) ds) pPrint d p (SDStruct i fs) = let fdocs = map (ppField d) fs fpunc = case fdocs of [] -> lbrace <+> rbrace [d] -> lbrace <+> d <+> rbrace _ -> vcat $ (zipWith (<+>) (lbrace : repeat comma) fdocs) ++ [rbrace] in sep [text "data" <+> pPrint d 0 i <+> text "=", nest 4 (pPrint d 0 i), nest 8 (fpunc <> text ";")] pPrint d p (SDValue i t e) = pPrint d 0 i <+> text "::" <+> pPrint d 0 t <> text ";" $+$ pPrint d 0 i <+> text "=" $+$ nest 4 (pPrint d 0 e) <> text ";" instance PPrint SType where pPrint d p c@(STCon _) | (c == voidType) = text "()" pPrint d p (STCon c) = pPrint d 0 c pPrint d p (STVar i) = pPrint d 0 i pPrint d p (STAp (STAp pair a) b) | (pair == pairTCon) = pparen (p >= 0) (hsep [pPrint d 0 a <> text ",", pPrint d (-1) b]) pPrint d p (STAp (STAp arr a) r) | (arr == arrowTCon) = pparen (p > 8) (hsep [pPrint d 9 a <+> text "->", pPrint d 8 r]) pPrint d p (STAp a b) = pparen (p > 9) (hsep [pPrint d 9 a, pPrint d 10 b]) instance PPrint STyCon where pPrint d p (STyCon i) = pPrint d 0 i pPrint d p (STyNum n) = text "#" <> pPrint d 0 n instance PPrint SExpr where pPrint d p (SLam i t e) = pparen True $ sep [text "\\" <+> pparen True (pPrint d 0 i <+> text "::" <+> pPrint d 0 t) <+> text "->", pPrint d 0 e] pPrint d p (SLet ds body) = let ppDef (i, t, e) = sep [pparen True (pPrint d 0 i <+> text "::" <+> pPrint d 0 t) <+> text "=", nest 4 (pPrint d 0 e)] in pparen (p > 0) ( (text "let" <+> encloseSep lbrace rbrace semi (map ppDef ds)) $$ (text "in" <+> pPrint d 0 body) ) pPrint d p (SVar i) | (getIdString i == "primChr") = text "bitToBool" pPrint d p (SVar i) | (getIdString i == "primOrd") = text "boolToBit" pPrint d p (SVar i) = pPrint d 0 i pPrint d p c@(SCon _) | (c == voidCon) = text "()" pPrint d p (SCon i) = pPrint d 0 i pPrint d p (SBVLit w v) = -- XXX if the value is large, consider displaying as hex pparen True (pPrint d 0 v <+> text "::" <+> pPrint d 0 (bitNType w)) pPrint d p (SStringLit v) = doubleQuotes $ text v pPrint d p (SRealLit v) = pparen True (pPrint d 0 v <+> text "::" <+> pPrint d 0 realType) pPrint d p (SApply f as) = pparen (p > 0) $ -- allow the arguments to nest under the function sep ((pPrint d 1 f):(map (nest 4 . pPrint d 1) as)) -- special case for binary infix operators -- (commutative operators can take a variable number of arguments) pPrint _ _ (SApplyInfix _ as) | (length as < 2) = internalError ("SApplyInfix: " ++ ppReadable as) pPrint d p (SApplyInfix op as) = pparen (p > 0) $ encloseSep empty empty (pPrint d 0 op) (map (pPrint d 1) as) pPrint d p (SStruct si fs) = let ppFieldDef (i, e) = sep [pPrint d 0 i <+> text "=", nest 4 (pPrint d 0 e)] in pparen (p > 0) $ sep ([pPrint d 0 si] ++ map (nest 4) (enclose lbrace rbrace comma (map ppFieldDef fs))) pPrint d p (SStructUpd se fs) = let ppFieldDef (i, e) = sep [pPrint d 0 i <+> text "=", nest 4 (pPrint d 0 e)] in pparen (p > 0) $ sep ([pPrint d 0 se] ++ map (nest 4) (enclose lbrace rbrace comma (map ppFieldDef fs))) pPrint d p (SSelect e f) = pPrint d p (SApply (SVar f) [e]) pPrint d p (SIf c t f) = pparen (p > 0) $ sep [text "if" <+> pPrint d 1 c, text "then" <+> pPrint d 0 t, text "else" <+> pPrint d 0 f] pPrint d p (SHasType t e) = pparen True (pPrint d 1 e <+> text "::" <+> pPrint d 0 t) -- return "empty" if there is no comment, which is the unit of $+$, -- so there is no extra line in the output when there are no comments ppComment :: [String] -> Doc ppComment cs = let ppline str = text ("-- " ++ str) in foldr ($+$) empty (map ppline cs) ppField :: PDetail -> (Id, SType) -> Doc ppField d (i,t) = pPrint d 0 i <+> text "::" <+> pPrint d 0 t vsepEmptyLine :: [Doc] -> Doc vsepEmptyLine [] = empty vsepEmptyLine xs = foldr1 (\x y -> x $+$ text "" $+$ y) xs -- this is like "encloseSep" but without the call to "sep", -- allowing it to be combined with other Doc in "sep" in the caller enclose :: Doc -> Doc -> Doc -> [Doc] -> [Doc] enclose left right punc ds = case ds of [] -> [left <+> right] [d] -> [left <+> d <+> right] _ -> let ps = zipWith (<+>) (left : repeat punc) ds in ps ++ [right] -- ------------------------- arrowTCon :: SType arrowTCon = STCon (STyCon (mk_homeless_id "->")) funcType :: [SType] -> SType -> SType funcType [] rt = rt funcType (t:ts) rt = STAp (STAp arrowTCon t) (funcType ts rt) -- ----- -- a primitive indicating an unknown value with Type anyTVar :: SType -> SExpr anyTVar t = SHasType t (SVar (mk_homeless_id "primAny")) -- ----- voidType :: SType voidType = STCon (STyCon (mk_homeless_id "PrimUnit")) voidCon :: SExpr voidCon = SCon (mk_homeless_id "PrimUnit") -- ----- boolType :: SType boolType = STCon (STyCon (mk_homeless_id "Bool")) falseCon :: SExpr falseCon = SCon (mk_homeless_id "False") trueCon :: SExpr trueCon = SCon (mk_homeless_id "True") -- ----- numType :: Integer -> SType numType n = STCon (STyNum n) bitTCon :: SType bitTCon = STCon (STyCon (mk_homeless_id "Bit")) bitNType :: Integer -> SType bitNType n = STAp bitTCon (numType n) -- ----- stringType :: SType stringType = STCon (STyCon (mk_homeless_id "String")) -- ----- realType :: SType realType = STCon (STyCon (mk_homeless_id "Double")) -- ----- arrTCon :: SType arrTCon = STCon (STyCon (mk_homeless_id "Array")) arrType :: Integer -> SType -> SType arrType n t = STAp (STAp arrTCon (numType n)) t -- ----- pairTCon :: SType pairTCon = STCon (STyCon (mk_homeless_id "PrimPair")) tupleType :: [SType] -> SType tupleType [] = voidType tupleType [t] = t tupleType (t:ts) = STAp (STAp pairTCon t) (tupleType ts) mktupleVar :: SExpr mktupleVar = SVar (mk_homeless_id "mktuple") fst3Var :: SExpr fst3Var = SVar (mk_homeless_id "fst3") snd3Var :: SExpr snd3Var = SVar (mk_homeless_id "snd3") thdVar :: SExpr thdVar = SVar (mk_homeless_id "thd") -- ------------------------- sLam :: [(Id, SType)] -> SExpr -> SExpr sLam [] body = body sLam ((i,t):its) body = SLam i t (sLam its body) sLet :: [(Id, SType, SExpr)] -> SExpr -> SExpr sLet [] body = body sLet ds1 (SLet ds2 body) = sLet (ds1 ++ ds2) body -- XXX does this lose a type annotation that's needed in some places? sLet [(i,t,e)] (SVar i2) | (i == i2) = e sLet ds body = SLet ds body sApply :: SExpr -> [SExpr] -> SExpr sApply f [] = f sApply (SApply f as1) as2 = sApply f (as1 ++ as2) sApply f as = SApply f as sIf :: SExpr -> SExpr -> SExpr -> SExpr sIf pe te fe | (pe == trueCon) = te sIf pe te fe | (pe == falseCon) = fe sIf pe te fe = SIf pe te fe andInfix :: Id andInfix = mk_homeless_id "&&" orInfix :: Id orInfix = mk_homeless_id "||" notVar :: SExpr notVar = SVar (mk_homeless_id "not") -- note that we optimize for true values, but don't expect false sBAnd :: SExpr -> SExpr -> SExpr sBAnd b1 b2 | (b1 == trueCon) = b2 sBAnd b1 b2 | (b2 == trueCon) = b1 sBAnd b1 b2 = SApplyInfix andInfix [b1, b2] sBAnds :: [SExpr] -> SExpr sBAnds [] = trueCon sBAnds [b] = b sBAnds bs = SApplyInfix andInfix bs sBOrs :: [SExpr] -> SExpr sBOrs [] = falseCon sBOrs [b] = b sBOrs bs = SApplyInfix orInfix bs sBNot :: SExpr -> SExpr sBNot b = SApply notVar [b] -- construct the name for all other primitives by dropping the "prim" prefix -- and making it lowercase primVar :: PrimOp -> SExpr primVar p = let p_name = case (show p) of (c:cs) -> ((toLower c):cs) _ -> internalError ("primVar: null op name") in SVar (mk_homeless_id p_name) -- apply a binary primitive to 2 or more arguments primBinAps :: SExpr -> [SExpr] -> SExpr primBinAps p as@[] = internalError ("primBinAps: " ++ ppReadable (p, as)) primBinAps p as@[_] = internalError ("primBinAps: " ++ ppReadable (p, as)) primBinAps p [a1, a2] = SApply p [a1, a2] primBinAps p (a:as) = SApply p [a, primBinAps p as] -- ------------------------- -- To guarantee that constructors and variables are properly capitalized -- and to avoid name-clash, we prefix all identifiers. -- ----- -- Noinline functions: noinline_ noinlineId :: Id -> Id noinlineId funcId = mk_homeless_id ("noinline_" ++ getIdBaseString funcId) -- ----- -- Module state types: MOD_ modTypeId :: Id -> Id modTypeId modId = mk_homeless_id ("MOD_" ++ getIdBaseString modId) modType :: Id -> [Integer] -> SType modType modId ns = let con = STCon (STyCon (modTypeId modId)) tys = map (STCon . STyNum) ns in foldl STAp con tys -- The constructor function: ctor_ modCtorId :: Id -> Id modCtorId modId = mk_homeless_id ("ctor_" ++ getIdBaseString modId) -- Lambda-binding for instantiation values passed to the constructor -- (for setting the port/param values in the state): val_ modArgId :: Id -> Id modArgId argId = mk_homeless_id ("val_" ++ getIdBaseString argId) -- Function to assert that a state value is consistent: dim_ modDimId :: Id -> Id modDimId modId = mk_homeless_id ("dim_" ++ getIdBaseString modId) -- ----- -- Fields of the state struct: -- inst___ -- port___ -- param___ -- where is the module of which this is a submod/port/param -- Fields of datatypes in Haskell (and thus LC) must be unique, -- so these functions add the as a further uniquifier. instFieldId :: Id -> Id -> Id instFieldId modId instId = mk_homeless_id ("inst_" ++ getIdBaseString instId ++ "__" ++ getIdBaseString modId) portFieldId :: Id -> Id -> Id portFieldId modId portId = mk_homeless_id ("port_" ++ getIdBaseString portId ++ "__" ++ getIdBaseString modId) paramFieldId :: Id -> Id -> Id paramFieldId modId paramId = mk_homeless_id ("param_" ++ getIdBaseString paramId ++ "__" ++ getIdBaseString modId) -- ----- -- Rule function names: rule__ ruleId :: Id -> Id -> Id ruleId modId rId = mk_homeless_id ("rule_" ++ getIdBaseString rId ++ "_" ++ getIdBaseString modId) -- Rule type :: -> (Bool, , ()) ruleType :: SType -> SType ruleType stateType = funcType [stateType] (tupleType [boolType, stateType, voidType]) -- ----- -- Method function names: meth__ methId :: String -> Id -> Id methId mod meth = mk_homeless_id ("meth_" ++ getIdBaseString meth ++ "_" ++ mod) -- Action method type :: { ->} -> (Bool, , ) actionMethType :: [SType] -> SType -> SType -> SType actionMethType argTypes stateType returnType = funcType (argTypes ++ [stateType]) (tupleType [boolType, stateType, returnType]) -- Value method type :: { ->} -> valueMethType :: [SType] -> SType -> SType -> SType valueMethType argTypes stateType returnType = funcType (argTypes ++ [stateType]) returnType -- Lambda-binding for method arguments: arg_ methArgId :: Id -> Id methArgId argId = mk_homeless_id ("arg_" ++ getIdBaseString argId) -- ----- -- let-bound defs: def_ defId :: Id -> Id defId def = mk_homeless_id ("def_" ++ getIdBaseString def) defVar :: Id -> SExpr defVar def = SVar (defId def) -- ------------------------- -- lambda-bound variable name for the state stateId :: Id stateId = mk_homeless_id "state0" -- reference to the lambda-bound state stateVar :: SExpr stateVar = SVar stateId -- a function that returns (False, ?, ?) -- used as the default clause for split methods nullUpdVar :: SExpr nullUpdVar = SVar (mk_homeless_id "nullUpd") -- ------------------------- makeModStructDecl :: Id -> [(AAbstractInput, VArgInfo)] -> [AVInst] -> [SDefn] makeModStructDecl modId inps avis = let -- ports/params are Bit type mkInputField (AAI_Port (i, t), Port {}) = Just $ (portFieldId modId i, convAType t) mkInputField (AAI_Port (i, t), Param {}) = Just $ (paramFieldId modId i, convAType t) mkInputField _ = Nothing inp_fs = mapMaybe mkInputField inps mkSubmodField avi = let (mod, tys) = getSubModType avi in (instFieldId modId (avi_vname avi), modType (mk_homeless_id mod) tys) inst_fs = map mkSubmodField avis in [SDStruct (modTypeId modId) (inp_fs ++ inst_fs)] -- ------------------------- makeModCtor :: DefMap -> Id -> [(AAbstractInput, VArgInfo)] -> [AVInst] -> [SDefn] makeModCtor defmap modId inps avis = let mod_ty = modType modId [] -- ports/params are Bit type getInputInfo (AAI_Port (i, t), Port {}) = Just (modArgId i, convAType t, portFieldId modId i) getInputInfo (AAI_Port (i, t), Param {}) = Just (modArgId i, convAType t, paramFieldId modId i) getInputInfo _ = Nothing inp_infos = mapMaybe getInputInfo inps inp_types = map snd3 inp_infos ctor_args = map fst2of3 inp_infos ctor_type = funcType inp_types mod_ty mkInputField (a, _, f) = (f, SVar a) inp_fs = map mkInputField inp_infos mkInstField :: ([(Id, SExpr)], M.Map AId (AType, AExpr)) -> AVInst -> CM ([(Id, SExpr)], M.Map AId (AType, AExpr)) mkInstField (accum_fs, accum_uses) avi = do let fname = instFieldId modId (avi_vname avi) submod = getVNameString (vName (avi_vmi avi)) submod_ctor = SVar $ modCtorId (mk_homeless_id submod) args = [ e | (i, e) <- getInstArgs avi, isPort i || isParam i ] inst_args <- mapM convAExpr args let f = (fname, sApply submod_ctor inst_args) accum_fs' = (f:accum_fs) accum_uses' = getAExprDefs defmap accum_uses args return (accum_fs', accum_uses') (inst_fs, letdefs) = runCM modId defmap M.empty S.empty $ do (fs, uses) <- foldM mkInstField ([], M.empty) (reverse avis) ds <- mapM convUse (M.toList uses) return (fs, ds) ctor_body = sLam ctor_args $ sLet letdefs $ SStruct (modTypeId modId) (inp_fs ++ inst_fs) in [SDValue (modCtorId modId) ctor_type ctor_body] -- ------------------------- makeModDimDefn :: Id -> [AVInst] -> [SDefn] makeModDimDefn modId avis = let mod_ty = modType modId [] dim_type = funcType [mod_ty, mod_ty] boolType m1 = mk_homeless_id "mod1" m2 = mk_homeless_id "mod2" mkInstDim :: AVInst -> SExpr mkInstDim avi = let fname = instFieldId modId (avi_vname avi) fvalue1 = SSelect (SVar m1) fname fvalue2 = SSelect (SVar m2) fname submod = getVNameString (vName (avi_vmi avi)) submod_dim = SVar $ modDimId (mk_homeless_id submod) in SApply submod_dim [fvalue1, fvalue2] body = sBAnds (map mkInstDim avis) dim_body = sLam [(m1,mod_ty), (m2,mod_ty)] body in [SDValue (modDimId modId) dim_type dim_body] -- ------------------------- convARule :: DefMap -> InstMap -> MethodOrderMap -> Id -> ARule -> SDefn convARule defmap instmap mmap modId r@(ARule rId _ _ _ p as _ _) = let mod_ty = modType modId [] body = runCM modId defmap instmap S.empty $ convActions [] mmap modId p as Nothing in SDValue (ruleId modId rId) (ruleType mod_ty) $ SLam stateId mod_ty $ body -- ------------------------- convAIFace :: DefMap -> InstMap -> MethodOrderMap -> Id -> AIFace -> [SDefn] convAIFace defmap instmap mmap modId (AIDef mId args _ p (ADef _ ret_t ret_e _) _ _) = let mod_ty = modType modId [] rt = convAType ret_t argset = S.fromList (map fst args) arg_infos = map (\(i,t) -> (methArgId i, convAType t)) args arg_types = map snd arg_infos -- get all the defs used by the return value uses = getAExprDefs defmap M.empty [ret_e] body = runCM modId defmap instmap argset $ do ret_expr <- convAExpr ret_e ds <- mapM convUse (M.toList uses) return $ sLet ds ret_expr in [SDValue (methId (getIdBaseString modId) mId) (valueMethType arg_types mod_ty rt) $ sLam (arg_infos ++ [(stateId, mod_ty)]) $ body] convAIFace defmap instmap mmap modId (AIAction args _ p mId rs _) = let mod_ty = modType modId [] -- arguments are Bit type argset = S.fromList (map fst args) arg_infos = map (\(i,t) -> (methArgId i, convAType t)) args arg_types = map snd arg_infos body = runCM modId defmap instmap argset $ convAIFaceBody mmap modId mId rs Nothing in [SDValue (methId (getIdBaseString modId) mId) (actionMethType arg_types mod_ty voidType) $ sLam (arg_infos ++ [(stateId, mod_ty)]) $ body] convAIFace defmap instmap mmap modId (AIActionValue args _ p mId rs (ADef _ def_t def_e _) _) = let mod_ty = modType modId [] -- return value is Bit type ret_ty = convAType def_t -- arguments are Bit type argset = S.fromList (map fst args) arg_infos = map (\(i,t) -> (methArgId i, convAType t)) args arg_types = map snd arg_infos body = runCM modId defmap instmap argset $ convAIFaceBody mmap modId mId rs (Just def_e) in [SDValue (methId (getIdBaseString modId) mId) (actionMethType arg_types mod_ty ret_ty) $ sLam (arg_infos ++ [(stateId, mod_ty)]) $ body] -- ignore clocks, resets, inouts -- XXX do we need to make clock gates available? convAIFace _ _ _ _ _ = [] -- the common conversion for the body of Action and ActionValue methods convAIFaceBody :: MethodOrderMap -> AId -> AId -> [ARule] -> Maybe AExpr -> CM SExpr convAIFaceBody mmap modId mId rs m_ret = do defmap <- gets defMap let -- get all the defs used in the predicates of the rules pred_uses = getAExprDefs defmap M.empty (map arule_pred rs) -- conv one rule convRule (ARule _ _ _ _ p as _ _) = do p_expr <- convAExpr p -- convert the body without a predicate (mkATrue) -- (and assuming that the pred_uses are already in scope) r_upd <- convActions (M.keys pred_uses) mmap modId mkATrue as m_ret return (p_expr, r_upd) -- fold this in reverse foldFn accum r = do (p_expr, r_upd) <- convRule r return $ sIf p_expr r_upd accum -- XXX When there are split rules, the return value is duplicated. -- XXX We can lift the return value out, and exclude its uses from -- XXX inside the converted bodies. case rs of [] -> internalError ("convAIFace: no rules: " ++ ppReadable mId) -- a special case for one rule might have to check whether the rule's -- predicate is True (can we have split rules where one rule is removed, -- leaving one rule with a non-True predicate?) rs -> do -- the predicates in the if-else structure may refer to defs ds <- mapM convUse (M.toList pred_uses) -- we don't assume that the predicates are complete, -- so the final branch is a null update rs_expr <- foldM foldFn nullUpdVar (reverse rs) return $ sLet ds rs_expr -- ------------------------- data ConvState = ConvState { -- the Id of the module being converted curModId :: Id, defMap :: DefMap, instMap :: InstMap, -- the arguments to a method, when converting in a method body argSet :: S.Set AId, -- store of unique numbers for generating let-binding names uniqueNum :: Integer, -- the current state curState :: SExpr, -- the current guard curGuard :: SExpr } type CM = State ConvState runCM :: Id -> DefMap -> InstMap -> S.Set AId -> (CM a) -> a runCM modId defmap instmap argset fn = let state0 = ConvState { curModId = modId, defMap = defmap, instMap = instmap, argSet = argset, uniqueNum = 1, curState = stateVar, curGuard = trueCon } in fst $ runState fn state0 getUniqueNum :: CM Integer getUniqueNum = do s <- get let n = uniqueNum s put (s { uniqueNum = n + 1 }) return n setState :: SExpr -> CM () setState newState = do s <- get put (s { curState = newState }) setGuard :: SExpr -> CM () setGuard newGuard = do s <- get put (s { curGuard = newGuard }) setUniqueNum :: Integer -> CM () setUniqueNum n = do s <- get put (s { uniqueNum = n }) -- ------------------------- convAType :: AType -> SType convAType (ATBit width) = bitNType width convAType (ATString Nothing) = stringType convAType (ATString (Just width)) = stringType -- XXX ? convAType (ATReal) = realType convAType (ATArray sz t) = arrType sz (convAType t) convAType t | (t == mkATBool) = boolType convAType t@(ATAbstract {}) = internalError ("convAType: " ++ ppReadable t) -- ----- convActions :: [AId] -> MethodOrderMap -> AId -> AExpr -> [AAction] -> Maybe AExpr -> CM SExpr convActions predefined_defs mmap modId p as m_ret = do defmap <- gets defMap -- get the current guard/state/num, because we'll be changing them prev_guard_expr <- gets curGuard prev_state_expr <- gets curState prev_unique_num <- gets uniqueNum let -- get all defs used in the actions uses0 = getAActionDefs defmap M.empty as -- merge in the defs for the return value uses1 = case m_ret of Nothing -> uses0 Just ret -> getAExprDefs defmap uses0 [ret] -- merge in the defs for the predicate uses2 = getAExprDefs defmap uses1 [p] -- remove the defs that already defined uses = map_deleteMany predefined_defs uses2 -- order the defs and actions (ordered_stmts, avmap) = tsortActionsAndDefs mmap defmap uses as -- merge statements with common conditions into blocks let ordered_blocks = mergeStmts defmap ordered_stmts -- convert the pred first so that it uses the initial state p_expr <- convAExpr p let_defs <- concatMapM (convStmt modId avmap) ordered_blocks -- get the final guard and state guard_expr <- gets curGuard state_expr <- gets curState -- reset the state/guard/num setGuard prev_guard_expr setState prev_state_expr setUniqueNum prev_unique_num -- OK to convert the return expression here, because any state -- references should have been lifted to their own defs ret_expr <- case m_ret of Nothing -> return voidCon Just ret -> convAExpr ret let ret_tup = SApply mktupleVar [sBAnd p_expr guard_expr, state_expr, ret_expr] return $ sLet let_defs ret_tup -- each statement generates let bindings, and possibly updates the state -- and guard used by the later statements convStmt :: AId -> M.Map (AId, AId) (AId, AType) -> AStmt -> CM [(Id, SType, SExpr)] convStmt _ _ (AStmtDef (ADef i t (AMethValue { }) _ )) = -- the action will assign the def, so skip it here return [] convStmt _ _ (AStmtDef (ADef i t (ATaskValue { }) _ )) = -- the action will assign the def, so skip it here return [] convStmt _ _ (AStmtDef (ADef i t e _)) = do e_expr <- convAExpr e return [(defId i, convAType t, e_expr)] convStmt modId avmap (AStmtAction cset (ACall obj meth as)) = do let c = getCondExpr cset let mod_type = modType modId [] instmap <- gets instMap -- get the current state/guard, because we'll be changing them prev_state <- gets curState prev_guard <- gets curGuard -- convert the condition c_expr <- convAExpr c -- convert the arguments a_exprs <- mapM convAExpr as let -- the kind of module that this instance is (submod, submod_tys, meth_ty_map) = lookupMod instmap obj -- the function name for the method call on this submodule type fnname = methId submod meth -- the field name for this instance in the state for the current module instname = (instFieldId modId obj) -- extract the state for this submod instance submod_state = SSelect prev_state instname -- the type of the submod state submod_type = modType (mk_homeless_id submod) submod_tys -- get the return type for the action -- and if it has a name, then return the def name to bind it to (av_type, maybe_av_id) = case (M.lookup (obj, meth) avmap) of Just (i, t) -> (convAType t, Just (defId i)) Nothing -> -- no name because the value is unused -- but we still need to declare the correct type case (M.lookup (unQualId meth) meth_ty_map) of Just t -> (convAType t, Nothing) Nothing -> (voidType, Nothing) -- we'll create new defs "act#", "guard#", and "state#" with a unique number n <- getUniqueNum -- the method call let act_id = mk_homeless_id ("act" ++ itos n) act_expr = SApply (SVar fnname) (a_exprs ++ [submod_state]) act_def = (act_id, tupleType [boolType, submod_type, av_type], act_expr) -- the resulting guard let guard_id = mk_homeless_id ("guard" ++ itos n) -- don't apply the method if the condition is not True guard_expr = sIf c_expr (sBAnd prev_guard (SApply fst3Var [SVar act_id])) prev_guard guard_def = (guard_id, boolType, guard_expr) -- the resulting state let state_id = mk_homeless_id ("state" ++ itos n) -- don't apply the method if the condition is not True state_expr = sIf c_expr (SStructUpd prev_state [(instname, SApply snd3Var [SVar act_id])]) prev_state state_def = (state_id, mod_type, state_expr) -- the return value let av_defs = case maybe_av_id of Nothing -> [] Just av_id -> let av_expr = SApply thdVar [SVar act_id] in [(av_id, av_type, av_expr)] -- reset the guard and state setGuard (SVar guard_id) setState (SVar state_id) return $ (act_def:guard_def:state_def:av_defs) convStmt _ _ (AStmtAction cset (AFCall i f isC as isAssumpCheck)) = do -- the effect is outside our scope, and there is no return value, -- so do nothing return [] convStmt _ _ (AStmtAction cset (ATaskAction i f isC k as tmp t b)) = do -- the effect is outside our scope, but there is a return value, -- so assign it to an unknown value case tmp of Just i -> let st = convAType t in return [(defId i, st, anyTVar st)] Nothing -> -- its value is unused, so do nothing return [] convStmt modId avmap (AStmtIf cset tblk fblk) = do let c = getCondExpr cset let mod_type = modType modId [] -- get the current state/guard, because we'll be changing them prev_state <- gets curState prev_guard <- gets curGuard -- convert the condition c_expr <- convAExpr c -- convert the True branch tblk_defs <- concatMapM (convStmt modId avmap) tblk -- record the final state/guard for this branch true_state <- gets curState true_guard <- gets curGuard -- convert the False branch, with the original state/guard setState prev_state setGuard prev_guard fblk_defs <- concatMapM (convStmt modId avmap) fblk -- record the final state/guard for this branch false_state <- gets curState false_guard <- gets curGuard -- create new defs "guard#" and "state#" for the chosen branch n <- getUniqueNum -- the resulting guard let guard_id = mk_homeless_id ("guard" ++ itos n) guard_expr = sIf c_expr true_guard false_guard guard_def = (guard_id, boolType, guard_expr) -- the resulting state let state_id = mk_homeless_id ("state" ++ itos n) state_expr = sIf c_expr true_state false_state state_def = (state_id, mod_type, state_expr) -- reset the guard and state setGuard (SVar guard_id) setState (SVar state_id) return $ tblk_defs ++ fblk_defs ++ [guard_def, state_def] -- ----- convAExpr :: AExpr -> CM SExpr convAExpr (ASInt _ t (IntLit _ _ v)) | (t == mkATBool) = case v of 0 -> return falseCon 1 -> return trueCon _ -> internalError ("convAExpr: invalid Bool: " ++ ppReadable v) convAExpr (ASInt _ (ATBit width) (IntLit _ _ v)) = return $ SBVLit width v convAExpr e@(ASInt {}) = internalError ("convAExpr: non-bit ASInt: " ++ ppReadable e) convAExpr e@(ASStr i t v) = return $ SStringLit v convAExpr e@(ASReal i t v) = return $ SRealLit v convAExpr (ASDef t i) = return $ defVar i convAExpr (ASPort t i) = do modId <- gets curModId argset <- gets argSet if (S.member i argset) then -- just reference the argument return $ SVar (methArgId i) else -- select the value from the state -- XXX since this is read-only, we can take it from the original state -- XXX not from the sequenced state? return $ SSelect stateVar (portFieldId modId i) convAExpr (ASParam t i) = do modId <- gets curModId -- select the value from the state -- XXX since this is read-only, we can take it from the original state -- XXX not from the sequenced state? return $ SSelect stateVar (paramFieldId modId i) -- if we know what value will be picked, use that convAExpr (ASAny _ (Just e)) = convAExpr e -- otherwise, use a primitive to express that it's an unknown convAExpr (ASAny t Nothing) = let st = convAType t in return $ anyTVar st convAExpr (APrim _ t p args) = convAPrim p t args convAExpr (AMethCall _ obj meth as) = do modId <- gets curModId state_expr <- gets curState instmap <- gets instMap let (mod, _, _) = lookupMod instmap obj mname = methId mod meth modState = SSelect state_expr (instFieldId modId obj) a_exprs <- mapM convAExpr as return $ SApply (SVar mname) (a_exprs ++ [modState]) convAExpr e@(AMethValue t obj meth) = -- these are handled by convStmts and are not expected here internalError("convAExpr: AMethValue: " ++ ppReadable e) convAExpr (ANoInlineFunCall t i (ANoInlineFun name _ _ _) as) = do let func_id = noinlineId i a_exprs <- mapM convAExpr as return $ sApply (SVar func_id) a_exprs convAExpr (AFunCall t i f isC as) = -- probably can't assume anything about two calls with the same arguments, -- XXX so don't do anything with "as" here? let st = convAType t in return $ anyTVar st convAExpr e@(ATaskValue t i f isC k) = -- these are handled by convStmts and are not expected here internalError("convAExpr: ATaskValue: " ++ ppReadable e) -- These shouldn't appear convAExpr (ASClock {}) = internalError "convAExpr: ASClock" convAExpr (ASReset {}) = internalError "convAExpr: ASReset" convAExpr (ASInout {}) = internalError "convAExpr: ASInout" -- A gate might appear in a boolean condition -- XXX but we don't yet know how to handle it, so have to assume any value convAExpr (AMGate t o c) = let st = convAType t in return $ anyTVar st -- ----- convAPrim :: PrimOp -> AType -> [AExpr] -> CM SExpr convAPrim PrimIf _ [c, t, f] = do c_expr <- convAExpr c t_expr <- convAExpr t f_expr <- convAExpr f return (SIf c_expr t_expr f_expr) convAPrim PrimCase t (idx:dflt:ces) = -- XXX if this can be represented with a case-expr, do that let -- we didn't pass in an id, so make one up i = dummy_id foldFn (v, e) res = let c = APrim i aTBool PrimEQ [idx, v] in APrim i t PrimIf [c, e, res] in convAExpr (foldr foldFn dflt (makePairs ces)) convAPrim PrimArrayDynSelect t [arr, idx] = do arr_expr <- convAExpr arr idx_expr <- convAExpr idx let p_var = SVar (mk_homeless_id "arraySelect") return (SApply p_var [arr_expr, idx_expr]) convAPrim PrimBuildArray t as = do a_exprs <- mapM convAExpr as let sz = case t of ATArray n _ -> n _ -> internalError ("convAPrim: PrimBuildArray: " ++ ppReadable t) let p_var = SVar (mk_homeless_id ("buildArray" ++ show sz)) return (sApply p_var a_exprs) -- PrimBAnd and PrimBOr need to be converted to infix operators -- (in the ASyntax, they can handle variable arguments) convAPrim PrimBAnd _ as = do a_exprs <- mapM convAExpr as return (sBAnds a_exprs) convAPrim PrimBOr _ as = do a_exprs <- mapM convAExpr as return (sBOrs a_exprs) -- represent "primBNot" with simple Haskell "not" convAPrim PrimBNot _ [a] = do a_expr <- convAExpr a return (sBNot a_expr) -- PrimConcat needs to be converted to a binary function -- (in the ASyntax, it can handle variable arguments) convAPrim p@(PrimConcat) t as = do let p_var = primVar p a_exprs <- mapM convAExpr as return (primBinAps p_var a_exprs) -- PrimExtract needs a type signature for the result convAPrim p@(PrimExtract) t as = do let p_var = primVar p st = convAType t a_exprs <- mapM convAExpr as return (SHasType st (sApply p_var a_exprs)) convAPrim p _ as = do let p_var = primVar p a_exprs <- mapM convAExpr as return (sApply p_var a_exprs) -- ----- -- convert the elements of a use map (returned by getAExprDefs etc) convUse :: (AId, (AType, AExpr)) -> CM (Id, SType, SExpr) convUse (i, (t, e)) = do e' <- convAExpr e return (defId i, convAType t, e') -- -------------------------