{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module SAL( SContext, convAPackageToSAL ) 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 Data.List(intersperse, groupBy) import Util(snd3, fst2of3, eqSnd, 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(VArgInfo(..)) import ASyntax import ASyntaxUtil 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 -- convAPackageToSAL :: ErrorHandle -> Flags -> APackage -> IO SContext -- avoid work if a dump wasn't requested convAPackageToSAL errh flags apkg | not (hasDumpStrict flags DFdumpSAL) = let ctx_id = ctxId (apkg_name apkg) in return (SContext ctx_id [] []) -- handle noinline functions separately convAPackageToSAL 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] body = runCM defmap M.empty argset $ do ret_expr <- convAExpr ret_e ds <- mapM convUse (M.toList uses) return $ sLet ds ret_expr in [SDValue noinlineId (funcType arg_types rt) $ sLam arg_infos body] _ -> internalError ("convAPackageToSAL: noinline ifcs: " ++ ppReadable ifcs) -- context Id ctx_id = ctxId (apkg_name apkg) -- context comments cs = [] in return $ SContext ctx_id cs fn_defs convAPackageToSAL errh flags apkg0 = case (chkAPackage "SAL" apkg0) of Just wmsgs -> do bsWarning errh wmsgs let ctx_id = ctxId (apkg_name apkg0) return (SContext ctx_id [] []) 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 = makeModTypeDecl inps avis -- define the ctor (call submod ctors with inst args) ctor_defs = makeModCtorDecl defmap inps avis -- define each rule as a fn rule_defs = map (convARule defmap instmap mmap) rs -- define each method as a fn ifc_defs = concatMap (convAIFace defmap instmap mmap) ifcs -- context Id ctx_id = ctxId modId -- context comments cs = [] in return $ SContext ctx_id cs (state_defs ++ ctor_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 SContext = SContext SId SComment [SDefn] deriving (Eq, Show) data SId = SId String deriving (Eq, Show) data SQId = SQId (Maybe (SId, [SType], [SExpr])) SId deriving (Eq, Show) type SComment = [String] -- Top level definition data SDefn = SDComment SComment [SDefn] | SDType SId SType -- SDScalarType -- SDDatatType | SDValue SId SType SExpr -- SDContext -- SDModule deriving (Eq, Show) data SType = STVar SQId -- for us, arrays are always indexed by subtype starting at zero -- so the number here is the size | STArray Integer SType -- | STSub | STTuple [SType] | STFunc SType SType | STRecord [(SId, SType)] -- | STState deriving (Eq, Show) data SExpr = SLam [(SId, SType)] SExpr | SLet [(SId, SType, SExpr)] SExpr | SVar SQId | SIntLit Integer | SRealLit Double | SApply SExpr SExpr | SApplyInfix SExpr SId SExpr -- for us, arrays are always indexed by subtype starting at zero -- so the number here is the size | SArray SId Integer SExpr | SArrayUpd SExpr SExpr SExpr | SArraySel SExpr SExpr | SStruct [(SId, SExpr)] | SStructUpd SExpr SId SExpr | SStructSel SExpr SId | STuple [SExpr] | STupleUpd SExpr Integer SExpr | STupleSel SExpr Integer | SIf SExpr SExpr SExpr deriving (Eq, Show) -- ----- instance Hyper SContext where hyper x y = (x==x) `seq` y -- ----- instance PPrint SContext where pPrint d p (SContext i cs ds) = ppComment cs $+$ (pPrint d 0 i <+> colon <+> text "CONTEXT" <+> equals) $+$ -- for readability, put an empty line at the start and end beginEnd (vsepEmptyLine ([empty] ++ map (pPrint d 0) ds ++ [empty])) instance PPrint SId where pPrint d p (SId i) = text i instance PPrint SQId where pPrint d p (SQId Nothing i) = pPrint d 0 i pPrint d p (SQId (Just (ctx, ts, es)) i) = let -- don't add spaces, so that it reads as a unit ts_doc = hcat $ intersperse comma $ map (pPrint d 0) ts es_doc = hcat $ intersperse comma $ map (pPrint d 0) es ps_doc = case (ts, es) of ([], []) -> empty ([], _) -> lbrace <> es_doc <> rbrace (_, []) -> lbrace <> ts_doc <> rbrace (_, _) -> lbrace <> ts_doc <> semi <> es_doc <> rbrace in pPrint d 0 ctx <> ps_doc <> text "!" <> pPrint d 0 i instance PPrint SDefn where pPrint d p (SDComment cs ds) = ppComment cs $+$ vsep (map (pPrint d 0) ds) pPrint d p (SDType i t) = sep [pPrint d 0 i <+> colon <+> text "TYPE" <+> equals, nest 2 (pPrint d 0 t <+> semi)] pPrint d p (SDValue i t e) = ppDef d (i, t, e) <+> semi instance PPrint SType where pPrint d p (STVar i) = pPrint d 0 i pPrint d p (STArray sz t) = text "ARRAY" <+> ppArraySize sz <+> text "OF" <+> pPrint d 0 t pPrint d p (STTuple ts) = lbrack <+> commaSep (map (pPrint d 0) ts) <+> rbrack pPrint d p (STFunc t1 t2) = lbrack <+> pPrint d 0 t1 <+> text "->" <+> pPrint d 0 t2 <+> rbrack pPrint d p (STRecord fs) = let fdocs = map (ppField d) fs in case fdocs of [] -> internalError ("STRecord with no fields") [d] -> lhbrack <+> d <+> rhbrack _ -> let spcomma = text " ," sprhbrack = text " #]" in vcat $ (zipWith (<+>) (lhbrack : repeat spcomma) fdocs) ++ [sprhbrack] instance PPrint SExpr where pPrint d p (SLam as e) = (text "LAMBDA" <+> ppVarDecls d as <+> colon) $+$ pPrint d 0 e pPrint d p e@(SLet ds body) = let mkDefDocs [] = internalError ("empty SLet") mkDefDocs [def] = [text "LET" <+> ppDef d def] mkDefDocs defs = zipWith (<+>) (text "LET" : repeat (nest 2 comma)) (map (ppDef d) defs) recFn (SLet ds body) = case (recFn body) of (doc:docs) -> (mkDefDocs ds) ++ ((text "IN" <+> doc):docs) _ -> internalError ("pPrint SLet") recFn body = [pPrint d 0 body] in vsep (recFn e) pPrint d p (SVar i) = pPrint d 0 i pPrint d p (SIntLit v) = pPrint d 0 v pPrint d p (SRealLit v) = pPrint d 0 v -- there is one unary operator -- rather than represent it with SApplyUnary, we treat is specially here pPrint d p (SApply f e) | (f == notVar) = pparen (p > 0) $ pPrint d 0 f <+> pPrint d 1 e -- print application to a tuple like a C-style function pPrint d p (SApply f (STuple es)) = pPrint d 1 f <> -- tuples are printed with space between the parentheses --pPrint d 0 a lparen <> commaSep (map (pPrint d 0) es) <> rparen -- print application to a single argument like a C-style function pPrint d p (SApply f a) = pPrint d 1 f <> pparen True (pPrint d 0 a) {- 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)) -} pPrint d p (SApplyInfix a1 op a2) = pparen (p > 0) $ pPrint d 1 a1 <+> pPrint d 0 op <+> pPrint d 1 a2 pPrint d p (SArray i sz e) = sep [lbrack <> (lbrack <+> pPrint d 0 i <+> colon <+> ppArraySize sz <+> rbrack), nest 2 $ pPrint d 0 e <+> rbrack] pPrint d p (SArrayUpd arr_e idx_e val_e) = -- allow WITH to nest directly under the array expression, -- because we build arrays with many nested updates sep [pPrint d 0 arr_e, -- XXX if idx_e is big, we could nest val_e under it text "WITH" <+> lbrack <> pPrint d 0 idx_e <> rbrack <+> text ":=" <+> pPrint d 0 val_e] pPrint d p (SArraySel arr_e idx_e) = cat [pPrint d 1 arr_e, nest 2 $ lbrack <> pPrint d 0 idx_e <> rbrack] pPrint d p (SStruct fs) = let fdocs = map (ppFieldDef d) fs in case fdocs of [] -> lhparen <+> rhparen [d] -> lhparen <+> d <+> rhparen _ -> let spcomma = text " ," sprhparen = text " #)" in vcat $ (zipWith (<+>) (lhparen : repeat spcomma) fdocs) ++ [sprhparen] pPrint d p (SStructUpd se fi fe) = pPrint d 1 se <+> text "WITH" <+> text "." <> pPrint d 0 fi <+> text ":=" <+> pPrint d 0 fe pPrint d p (SStructSel se fi) = pPrint d 1 se <> text "." <> pPrint d 0 fi pPrint d p (STuple es) = lparen <+> commaSep (map (pPrint d 0) es) <+> rparen pPrint d p (STupleUpd te fn fe) = pPrint d 1 te <+> text "WITH" <+> text "." <> pPrint d 0 fn <+> text ":=" <+> pPrint d 0 fe pPrint d p (STupleSel te fn) = pPrint d 1 te <> text "." <> pPrint d 0 fn pPrint d p (SIf c t f) = pparen (p > 0) $ sep [text "IF" <+> pPrint d 1 c, nest 2 $ text "THEN" <+> pPrint d 0 t, nest 2 $ text "ELSE" <+> pPrint d 0 f, text "ENDIF"] -- 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) ppDef :: PDetail -> (SId, SType, SExpr) -> Doc ppDef d (i, t, e) = let (as_doc, t', body) = case (e, t) of (SLam as body, STFunc _ rt) -> (ppVarDecls d as, rt, body) _ -> (empty, t, e) in -- XXX do we want to allow putting the type on a new line? sep [(pPrint d 0 i <+> as_doc <+> colon <+> pPrint d 0 t' <+> text "="), nest 2 (pPrint d 0 body)] ppField :: PDetail -> (SId, SType) -> Doc ppField d (i, t) = pPrint d 0 i <+> colon <+> pPrint d 0 t ppFieldDef :: PDetail -> (SId, SExpr) -> Doc ppFieldDef d (i, e) = pPrint d 0 i <+> text ":=" <+> pPrint d 0 e ppVarDecls :: PDetail -> [(SId, SType)] -> Doc ppVarDecls d [] = internalError ("SAL.ppVarDecls empty") ppVarDecls d as = let as' = map (\ its@((_,t):_) -> (map fst its, t)) $ groupBy eqSnd as ppArg (is, t) = commaSep (map (pPrint d 0) is) <+> colon <+> pPrint d 0 t in lparen <> commaSep (map ppArg as') <> rparen ppArraySize :: Integer -> Doc ppArraySize sz = lbrack <> text ("0.." ++ itos (sz-1)) <> rbrack lhbrack, rhbrack :: Doc lhbrack = text "[#" rhbrack = text "#]" lhparen, rhparen :: Doc lhparen = text "(#" rhparen = text "#)" vsepEmptyLine :: [Doc] -> Doc vsepEmptyLine [] = empty vsepEmptyLine xs = foldr1 (\x y -> x $+$ text "" $+$ y) xs beginEnd :: Doc -> Doc beginEnd body = text "BEGIN" $+$ nest 2 body $+$ text "END" -- ----- {- usesSVar :: SQId -> SExpr -> Bool usesSVar qi (SLam vars body) = case qi of SQId Nothing i | isJust (lookup i vars) -> False _ -> usesSVar qi body usesSVar qi (SLet bs body) = case qi of SQId Nothing i | (i `elem` (map fst3 bs)) -> False _ -> any (usesSVar qi) (body : map thd bs) usesSVar qi (SVar v) = (v == qi) usesSVar qi (SIntLit _) = False usesSVar qi (SRealLit _) = False usesSVar qi (SApply f a) = any (usesSVar qi) [f, a] usesSVar qi (SApplyInfix e1 _ e2) = any (usesSVar qi) [e1, e2] usesSVar qi (SStruct fs) = any (usesSVar qi) (map snd fs) usesSVar qi (SStructUpd se _ fe) = any (usesSVar qi) [se, fe] usesSVar qi (SStructSel se _) = usesSVar qi se usesSVar qi (STuple es) = any (usesSVar qi) es usesSVar qi (STupleUpd te _ e) = any (usesSVar qi) [te, e] usesSVar qi (STupleSel te _) = usesSVar qi te usesSVar qi (SIf c te fe) = any (usesSVar qi) [c, te, fe] -} -- ------------------------- funcType :: [SType] -> SType -> SType funcType [] rt = rt funcType [t] rt = STFunc t rt funcType ts rt = STFunc (STTuple ts) rt -- ----- -- Primitives -- no parameters primCtx :: SId -> SQId primCtx baseId = SQId (Just (SId "Prim", [], [])) baseId -- one size parameter prim1Ctx :: Integer -> SId -> SQId prim1Ctx sz baseId = SQId (Just (SId "Prim1", [], [SIntLit sz])) baseId -- two size parameters prim2Ctx :: Integer -> Integer -> SId -> SQId prim2Ctx sz1 sz2 baseId = let es = [SIntLit sz1, SIntLit sz2] in SQId (Just (SId "Prim2", [], es)) baseId -- an array and a size arrPrim1Ctx :: Integer -> SType -> Integer -> SId -> SQId arrPrim1Ctx arrsz elemty sz baseId = let es = [SIntLit arrsz, SIntLit sz] in SQId (Just (SId "ArrayPrim1", [elemty], es)) baseId bitToBoolVar :: SExpr bitToBoolVar = SVar $ primCtx (SId "bitToBool") boolToBitVar :: SExpr boolToBitVar = SVar $ primCtx (SId "boolToBit") -- ----- anyVar :: AType -> SExpr anyVar (ATBit width) = SVar $ bitCtx width (SId "undef") anyVar t | (t == mkATBool) = SVar $ primCtx (SId "undefBool") anyVar (ATString _) = SVar $ stringCtx (SId "undef") anyVar (ATReal) = SVar $ primCtx (SId "undefReal") anyVar (ATArray sz t) = arrBuild sz $ replicate (fromInteger sz) (anyVar t) anyVar t@(ATAbstract {}) = internalError ("anyVar: " ++ ppReadable t) -- ----- boolType :: SType boolType = sTVar (SId "BOOLEAN") falseCon :: SExpr falseCon = sVar (SId "FALSE") trueCon :: SExpr trueCon = sVar (SId "TRUE") -- ----- voidCtx :: SId -> SQId voidCtx baseId = SQId (Just (SId "Unit", [], [])) baseId voidType :: SType voidType = STVar (voidCtx (SId "T")) voidCon :: SExpr voidCon = SVar (voidCtx (SId "unit")) -- ----- bitCtx :: Integer -> SId -> SQId bitCtx sz baseId = SQId (Just (SId "Bit", [], [SIntLit sz])) baseId bitNType :: Integer -> SType bitNType n = STVar (bitCtx n (SId "T")) {- bitUndet :: Integer -> SExpr bitUndet sz = SVar $ bitCtx sz (SId "mkUndet") -} bitConst :: Integer -> Integer -> SExpr bitConst sz n = SApply (SVar (bitCtx sz (SId "mkConst"))) (SIntLit n) -- ----- realType :: SType realType = sTVar (SId "REAL") -- ----- -- Instead of removing Strings from the design, use a dummy value -- (defined in String context) stringCtx :: SId -> SQId stringCtx baseId = SQId (Just (SId "String", [], [])) baseId stringType :: SType stringType = STVar (stringCtx (SId "T")) stringLit :: String -> SExpr stringLit _ = SVar (stringCtx (SId "mkConst")) -- ----- arrType :: Integer -> SType -> SType arrType sz elem_ty = STArray sz elem_ty -- the Integer should be the same as the length of the list arrBuild :: Integer -> [SExpr] -> SExpr arrBuild sz [] = internalError ("arrBuild: empty array") arrBuild sz (e0:es) = -- construct an array using array updates let z = SArray (SId "i") sz e0 foldFn arr (n, e) = SArrayUpd arr (SIntLit n) e in foldl foldFn z (zip [1..] es) arrSelect :: Integer -> SType -> Integer -> SExpr -> SExpr -> SExpr arrSelect arrsz elemty idxsz arr_e idx_e = -- the index will be a bit vector, so we can't use SArraySel let fnvar = SVar (arrPrim1Ctx arrsz elemty idxsz (SId "arrSelect")) in sApply fnvar [arr_e, idx_e] -- ----- tupleType :: [SType] -> SType tupleType ts = STTuple ts -- ------------------------- sLam :: [(SId, SType)] -> SExpr -> SExpr sLam [] body = body --sLam ((i,t):its) body = SLam i t (sLam its body) sLam vars body = SLam vars body sLet :: [(SId, SType, SExpr)] -> SExpr -> SExpr sLet [] body = body sLet [(i,t,e)] (SVar (SQId Nothing i2)) | (i == i2) = e -- It is safe to put every def in its own SLet: sLet (d:ds) body = SLet [d] (sLet ds body) {- -- We could try to do better, however this causes the "state" defs -- to be separate from the "act" defs sometimes, so this needs some -- exploration: -- XXX We already have the dependency info when we tsort; -- XXX is it more efficient to reuse that? sLet ds body = let foldFn d@(di, _, _) (SLet ds2 body) = let (ds2_stay, ds2_lift) = let uses_d (_, _, e) = usesSVar (SQId Nothing di) e in partition uses_d ds2 in SLet ([d] ++ ds2_lift) -- XXX is it too redundant to do this: --(sLet ds2_stay body) if (null ds2_stay) then body else (SLet ds2_stay body) -- if the original body isn't an SLet, then construct the first SLet foldFn d e = SLet [d] e in foldr foldFn body ds -} -- This assumes that the application is via a tuple sApply :: SExpr -> [SExpr] -> SExpr sApply f [] = f --sApply (SApply f as1) as2 = sApply f (as1 ++ as2) sApply f as = SApply f (STuple as) sVar :: SId -> SExpr sVar i = SVar (SQId Nothing i) sTVar :: SId -> SType sTVar i = STVar (SQId Nothing i) 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 :: SId andInfix = SId "AND" orInfix :: SId orInfix = SId "||" notVar :: SExpr notVar = sVar (SId "NOT") sBAnds :: [SExpr] -> SExpr sBAnds [] = trueCon sBAnds [b] = b sBAnds (b:bs) = SApplyInfix b andInfix (sBAnds bs) sBOrs :: [SExpr] -> SExpr sBOrs [] = falseCon sBOrs [b] = b sBOrs (b:bs) = SApplyInfix b orInfix (sBOrs bs) sBNot :: SExpr -> SExpr sBNot b = SApply notVar b -- construct the name for all other primitives primId :: PrimOp -> SId primId p = case (show p) of (c:cs) -> SId ((toLower c):cs) _ -> internalError ("primId: null op name") -- ------------------------- -- To guarantee that constructors and variables are properly capitalized -- and to avoid name-clash, we prefix all identifiers. -- ----- -- Context name: CTX_ ctxId :: Id -> SId ctxId i = SId ("CTX_" ++ getIdBaseString i) qualSId :: Id -> [Integer] -> SId -> SQId qualSId modId ns baseId = let ps = map SIntLit ns in SQId (Just (ctxId modId, [], ps)) baseId -- ----- -- Noinline functions: CTX_!fn noinlineId :: SId noinlineId = SId "fn" noinlineQId :: String -> SQId noinlineQId func = qualSId (mk_homeless_id func) [] $ noinlineId -- ----- -- Module state types: CTX_!MOD modTypeId :: SId modTypeId = SId "STATE" modType :: SType modType = sTVar modTypeId submodType :: String -> [Integer] -> SType submodType mod ns = STVar $ qualSId (mk_homeless_id mod) ns $ modTypeId -- The constructor function: CTX_!ctor modCtorId :: SId modCtorId = SId "ctor" submodCtor :: String -> [Integer] -> SExpr submodCtor mod ns = SVar $ qualSId (mk_homeless_id mod) ns $ modCtorId -- Lambda-binding for instantiation values passed to the constructor -- (for setting the port/param values in the state): val_ modArgId :: Id -> SId modArgId argId = SId ("val_" ++ getIdBaseString argId) -- ----- -- Fields of the state struct: -- inst_ -- port_ -- param_ -- Fields of datatypes in Haskell (and thus LC) must be unique, -- so these functions add the as a further uniquifier. instFieldId :: Id -> SId instFieldId instId = SId ("inst_" ++ getIdBaseString instId) portFieldId :: Id -> SId portFieldId portId = SId ("port_" ++ getIdBaseString portId) paramFieldId :: Id -> SId paramFieldId paramId = SId ("param_" ++ getIdBaseString paramId) -- ----- -- Rule function names: rule_ ruleId :: Id -> SId ruleId rId = SId ("rule_" ++ getIdBaseString rId) -- Rule type :: -> (Bool, ) ruleType :: SType -> SType ruleType stateType = funcType [stateType] (tupleType [boolType, stateType]) -- ----- -- Method function names: meth_ modMethId :: Id -> SId modMethId methId = SId ("meth_" ++ getIdBaseString methId) submodMethVar :: String -> [Integer] -> Id -> SExpr submodMethVar mod ns methId = SVar $ qualSId (mk_homeless_id mod) ns $ modMethId methId -- Action method type :: { ->} -> (, ) actionMethType :: [SType] -> SType -> SType -> SType actionMethType argTypes stateType returnType = funcType (argTypes ++ [stateType]) (tupleType [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 -> SId methArgId argId = SId ("arg_" ++ getIdBaseString argId) -- ----- -- let-bound defs: def_ defId :: Id -> SId defId def = SId ("def_" ++ getIdBaseString def) defVar :: Id -> SExpr defVar def = sVar (defId def) -- ------------------------- -- lambda-bound variable name for the state stateId :: SId stateId = SId "state0" -- reference to the lambda-bound state stateVar :: SExpr stateVar = sVar stateId -- ------------------------- makeModTypeDecl :: [(AAbstractInput, VArgInfo)] -> [AVInst] -> [SDefn] makeModTypeDecl inps avis = let -- ports/params are Bit type mkInputField (AAI_Port (i, t), Port {}) = Just $ (portFieldId i, convAType t) mkInputField (AAI_Port (i, t), Param {}) = Just $ (paramFieldId i, convAType t) mkInputField _ = Nothing inp_fs = mapMaybe mkInputField inps mkSubmodField avi = let fname = instFieldId (avi_vname avi) (submod, submod_tys) = getSubModType avi in (fname, submodType submod submod_tys) inst_fs = map mkSubmodField avis -- SAL does not support records with no fields fs = inp_fs ++ inst_fs mod_ty = if (null fs) then voidType else STRecord fs in [SDType modTypeId mod_ty] -- ------------------------- makeModCtorDecl :: DefMap -> [(AAbstractInput, VArgInfo)] -> [AVInst] -> [SDefn] makeModCtorDecl defmap inps avis = let -- ports/params are Bit type getInputInfo (AAI_Port (i, t), Port {}) = Just (modArgId i, convAType t, portFieldId i) getInputInfo (AAI_Port (i, t), Param {}) = Just (modArgId i, convAType t, paramFieldId 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 modType mkInputField (a, _, f) = (f, sVar a) inp_fs = map mkInputField inp_infos mkInstField :: ([(SId, SExpr)], M.Map AId (AType, AExpr)) -> AVInst -> CM ([(SId, SExpr)], M.Map AId (AType, AExpr)) mkInstField (accum_fs, accum_uses) avi = do let fname = instFieldId (avi_vname avi) (submod, submod_tys, args) = getSubModArgs avi submod_ctor = submodCtor submod submod_tys 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 defmap M.empty S.empty $ do (fs, uses) <- foldM mkInstField ([], M.empty) (reverse avis) ds <- mapM convUse (M.toList uses) return (fs, ds) -- SAL does not support records with no fields fs = inp_fs ++ inst_fs ctor_body = if (null fs) then voidCon else sLam ctor_args $ sLet letdefs $ SStruct fs in [SDValue modCtorId ctor_type ctor_body] -- ------------------------- convARule :: DefMap -> InstMap -> MethodOrderMap -> ARule -> SDefn convARule defmap instmap mmap r@(ARule rId _ _ _ p as _ _) = let body = runCM defmap instmap S.empty $ convRuleActions mmap p as in SDValue (ruleId rId) (ruleType modType) $ sLam [(stateId, modType)] $ body -- ------------------------- convAIFace :: DefMap -> InstMap -> MethodOrderMap -> AIFace -> [SDefn] convAIFace defmap instmap mmap (AIDef methId args _ p (ADef _ ret_t ret_e _) _ _) = 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] body = runCM defmap instmap argset $ do ret_expr <- convAExpr ret_e ds <- mapM convUse (M.toList uses) return $ sLet ds ret_expr in [SDValue (modMethId methId) (valueMethType arg_types modType rt) $ sLam (arg_infos ++ [(stateId, modType)]) $ body] convAIFace defmap instmap mmap (AIAction args _ p methId rs _) = let -- 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 defmap instmap argset $ convAIFaceBody mmap methId rs Nothing in [SDValue (modMethId methId) (actionMethType arg_types modType voidType) $ sLam (arg_infos ++ [(stateId, modType)]) $ body] convAIFace defmap instmap mmap (AIActionValue args _ p methId rs (ADef _ def_t def_e _) _) = let -- 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 defmap instmap argset $ convAIFaceBody mmap methId rs (Just def_e) in [SDValue (modMethId methId) (actionMethType arg_types modType ret_ty) $ sLam (arg_infos ++ [(stateId, modType)]) $ 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 -> [ARule] -> Maybe AExpr -> CM SExpr convAIFaceBody mmap methId 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 -- (and assuming that the pred_uses are already in scope) r_upd <- convMethActions (M.keys pred_uses) mmap 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 methId) -- 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 null_upd <- convMethActions (M.keys pred_uses) mmap [] m_ret rs_expr <- foldM foldFn null_upd (reverse rs) return $ sLet ds rs_expr -- ------------------------- data ConvState = ConvState { 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 } type CM = State ConvState runCM :: DefMap -> InstMap -> S.Set AId -> (CM a) -> a runCM defmap instmap argset fn = let state0 = ConvState { defMap = defmap, instMap = instmap, argSet = argset, uniqueNum = 1, curState = stateVar } 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 }) 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) -- ----- convRuleActions :: MethodOrderMap -> AExpr -> [AAction] -> CM SExpr convRuleActions mmap p as = convActions True [] mmap p as Nothing convMethActions :: [AId] -> MethodOrderMap -> [AAction] -> Maybe AExpr -> CM SExpr convMethActions ds mmap as m_ret = convActions False ds mmap mkATrue as m_ret convActions :: Bool -> [AId] -> MethodOrderMap -> AExpr -> [AAction] -> Maybe AExpr -> CM SExpr convActions isRule predefined_defs mmap p as m_ret = do defmap <- gets defMap -- get the current state/num, because we'll be changing them 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 avmap) ordered_blocks -- get the final state state_expr <- gets curState -- reset the state/num 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 = if isRule then STuple [p_expr, state_expr] else STuple [state_expr, ret_expr] return $ sLet let_defs ret_tup -- each statement generates let bindings, and possibly updates the state -- used by the later statements convStmt :: M.Map (AId, AId) (AId, AType) -> AStmt -> CM [(SId, 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 avmap (AStmtAction cset (ACall obj meth as)) = do let c = getCondExpr cset instmap <- gets instMap -- get the current state, because we'll be changing it prev_state <- gets curState -- 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 for the method call on this submodule type fnvar = submodMethVar submod submod_tys meth -- the field name for this instance in the state for the current module instname = instFieldId obj -- extract the state for this submod instance submod_state = SStructSel prev_state instname -- the type of the submod state submod_type = submodType 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#" and "state#" with a unique number n <- getUniqueNum -- the method call let act_id = SId ("act" ++ itos n) act_expr = sApply fnvar (a_exprs ++ [submod_state]) act_def = (act_id, tupleType [submod_type, av_type], act_expr) -- the resulting state let state_id = SId ("state" ++ itos n) -- don't apply the method if the condition is not True state_expr = sIf c_expr (SStructUpd prev_state instname (STupleSel (sVar act_id) 1)) prev_state state_def = (state_id, modType, state_expr) -- the return value let av_defs = case maybe_av_id of Nothing -> [] Just av_id -> let av_expr = STupleSel (sVar act_id) 2 in [(av_id, av_type, av_expr)] -- reset the state setState (sVar state_id) return $ (act_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, anyVar t)] Nothing -> -- its value is unused, so do nothing return [] convStmt avmap (AStmtIf cset tblk fblk) = do let c = getCondExpr cset -- get the current state, because we'll be changing it prev_state <- gets curState -- convert the condition c_expr <- convAExpr c -- convert the True branch tblk_defs <- concatMapM (convStmt avmap) tblk -- record the final state for this branch true_state <- gets curState -- convert the False branch, with the original state setState prev_state fblk_defs <- concatMapM (convStmt avmap) fblk -- record the final state for this branch false_state <- gets curState -- create new def "state#" for the chosen branch n <- getUniqueNum -- the resulting state let state_id = SId ("state" ++ itos n) state_expr = sIf c_expr true_state false_state state_def = (state_id, modType, state_expr) -- set the state setState (sVar state_id) return $ tblk_defs ++ fblk_defs ++ [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 $ bitConst width v convAExpr e@(ASInt {}) = internalError ("convAExpr: non-bit ASInt: " ++ ppReadable e) convAExpr e@(ASStr i t v) = return $ stringLit v convAExpr e@(ASReal i t v) = return $ SRealLit v convAExpr (ASDef t i) = return $ defVar i convAExpr (ASPort t i) = do 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 $ SStructSel stateVar (portFieldId i) convAExpr (ASParam t i) = do -- 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 $ SStructSel stateVar (paramFieldId 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) = return $ anyVar t convAExpr (APrim _ t p args) = convAPrim p t args convAExpr (AMethCall _ obj meth as) = do state_expr <- gets curState instmap <- gets instMap let (submod, submod_tys, _) = lookupMod instmap obj fnvar = submodMethVar submod submod_tys meth modState = SStructSel state_expr (instFieldId obj) a_exprs <- mapM convAExpr as return $ sApply fnvar (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 _ (ANoInlineFun name _ _ _) as) = do let func_id = noinlineQId name 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? return $ anyVar t 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) = return $ anyVar t -- ----- convAPrim :: PrimOp -> AType -> [AExpr] -> CM SExpr convAPrim PrimChr _ [a] = do a_expr <- convAExpr a return $ sApply bitToBoolVar [a_expr] convAPrim PrimOrd _ [a] = do a_expr <- convAExpr a return $ sApply boolToBitVar [a_expr] 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 arrty = ae_type arr arrsz = getArraySize arrty elemty = getArrayElemType arrty idxsz = aSize idx return $ arrSelect arrsz (convAType elemty) idxsz arr_expr idx_expr convAPrim PrimBuildArray arr_ty as = do a_exprs <- mapM convAExpr as -- XXX the size should also be the length of "as" let sz = getArraySize arr_ty return $ arrBuild sz a_exprs -- removed in IExpand -- convAPrim PrimArrayDynUpdate t as = -- PrimBAnd and PrimBOr need to be converted to native 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 the native "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 mapFn a = do a_expr <- convAExpr a return (aSize a, a_expr) a_exprs <- mapM mapFn as let foldFn (sz1, a1) (sz2, a2) = (sz1 + sz2, sApply (SVar (prim2Ctx sz1 sz2 (primId p))) [a1, a2]) return $ snd $ foldr1 foldFn a_exprs convAPrim p@(PrimExtract) (ATBit sz2) [a, _, _] = do a_expr <- convAExpr a return $ sApply (SVar (prim2Ctx (aSize a) sz2 (primId p))) [a_expr] -- converted to PrimSelect in IConv --convAPrim PrimSplit t as = -- only created in the Verilog backend --convAPrim PrimMux t as = --convAPrim PrimPriMux t as = -- converted to PrimExtract in AConv --convAPrim PrimSelect t as = -- removed in AConv --convAPrim PrimRange t as = convAPrim p t as | p `elem` [ PrimAdd, PrimSub, PrimAnd, PrimOr, PrimXor, PrimInv, PrimNeg ] = do a_exprs <- mapM convAExpr as return $ sApply (SVar (prim1Ctx (aSize t) (primId p))) a_exprs -- treat equality of booleans different from equality of bit vectors convAPrim p@(PrimEQ) t as@(a1:_) | (ae_type a1 == mkATBool) = do a_exprs <- mapM convAExpr as return $ sApply (SVar (primCtx (primId p))) a_exprs -- equality and comparison of bit vectors convAPrim p t as@(a1:_) | p `elem` [ PrimEQ, PrimULE, PrimULT, PrimSLE, PrimSLT ] = do a_exprs <- mapM convAExpr as return $ sApply (SVar (prim1Ctx (aSize a1) (primId p))) a_exprs convAPrim p t as@[val, idx] | p `elem` [ PrimSL, PrimSRL, PrimSRA ] = do a_exprs <- mapM convAExpr as let sz1 = aSize val sz2 = aSize idx return $ sApply (SVar (prim2Ctx sz1 sz2 (primId p))) a_exprs convAPrim p t as@[a1, a2] | p `elem` [ PrimMul, PrimQuot, PrimRem ] = do a_exprs <- mapM convAExpr as let sz1 = aSize a1 sz2 = aSize a2 return $ sApply (SVar (prim2Ctx sz1 sz2 (primId p))) a_exprs convAPrim p t [a] | p `elem` [ PrimSignExt, PrimZeroExt, PrimTrunc ] = do a_expr <- convAExpr a let sz1 = aSize a sz2 = aSize t return $ sApply (SVar (prim2Ctx sz1 sz2 (primId p))) [a_expr] convAPrim p _ as = do internalError ("convAPrim: " ++ ppReadable (p, as)) -- ----- -- convert the elements of a use map (returned by getAExprDefs etc) convUse :: (AId, (AType, AExpr)) -> CM (SId, SType, SExpr) convUse (i, (t, e)) = do e' <- convAExpr e return (defId i, convAType t, e') -- -------------------------