X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplStg%2FSatStgRhs.lhs;fp=ghc%2Fcompiler%2FsimplStg%2FSatStgRhs.lhs;h=16c903e726a910584a438e8596b54c4c829e8b2b;hb=6c381e873e222417d9a67aeec77b9555eca7b7a8;hp=a6793d7a781432c8543991e9e68debeab136575e;hpb=8147a9f0bcc48ef0db1e91f8b985a4f5c3fed560;p=ghc-hetmet.git diff --git a/ghc/compiler/simplStg/SatStgRhs.lhs b/ghc/compiler/simplStg/SatStgRhs.lhs index a6793d7..16c903e 100644 --- a/ghc/compiler/simplStg/SatStgRhs.lhs +++ b/ghc/compiler/simplStg/SatStgRhs.lhs @@ -60,16 +60,14 @@ module SatStgRhs ( satStgRhs ) where import StgSyn -import AbsUniType ( splitTypeWithDictsAsArgs, Class, +import Type ( splitTypeWithDictsAsArgs, Class, TyVarTemplate, TauType(..) ) import CostCentre -import IdEnv -import Id ( mkSysLocal, getIdUniType, getIdArity, addIdArity ) +import Id ( mkSysLocal, idType, getIdArity, addIdArity ) import IdInfo -- SIGH: ( arityMaybe, ArityInfo, OptIdInfo(..) ) import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) -import SplitUniq -import Unique +import UniqSupply import Util import Maybes @@ -79,12 +77,12 @@ type Count = Int type ExprArityInfo = Maybe Int -- Just n => This expression has a guaranteed -- arity of n -- Nothing => Don't know how many args it needs - + type Id_w_Arity = Id -- An Id with correct arity info pinned on it type SatEnv = IdEnv Id_w_Arity -- Binds only local, let(rec)-bound things \end{code} -This pass +This pass \begin{itemize} \item adds extra args where necessary; \item pins the correct arity on everything. @@ -97,17 +95,17 @@ This pass %************************************************************************ \begin{code} -satStgRhs :: PlainStgProgram -> SUniqSM PlainStgProgram +satStgRhs :: [StgBinding] -> UniqSM [StgBinding] satStgRhs p = satProgram nullIdEnv p -satProgram :: SatEnv -> PlainStgProgram -> SUniqSM PlainStgProgram -satProgram env [] = returnSUs [] +satProgram :: SatEnv -> [StgBinding] -> UniqSM [StgBinding] +satProgram env [] = returnUs [] -satProgram env (bind:binds) - = satBinding True{-toplevel-} env bind `thenSUs` \ (env2, bind2) -> - satProgram env2 binds `thenSUs` \ binds2 -> - returnSUs (bind2 : binds2) +satProgram env (bind:binds) + = satBinding True{-toplevel-} env bind `thenUs` \ (env2, bind2) -> + satProgram env2 binds `thenUs` \ binds2 -> + returnUs (bind2 : binds2) \end{code} %************************************************************************ @@ -118,44 +116,44 @@ satProgram env (bind:binds) \begin{code} satBinding :: Bool -- True <=> top-level - -> SatEnv - -> PlainStgBinding - -> SUniqSM (SatEnv, PlainStgBinding) + -> SatEnv + -> StgBinding + -> UniqSM (SatEnv, StgBinding) satBinding top env (StgNonRec b rhs) - = satRhs top env (b, rhs) `thenSUs` \ (b2, rhs2) -> + = satRhs top env (b, rhs) `thenUs` \ (b2, rhs2) -> let env2 = addOneToIdEnv env b b2 in - returnSUs (env2, StgNonRec b2 rhs2) + returnUs (env2, StgNonRec b2 rhs2) satBinding top env (StgRec pairs) = -- Do it once to get the arities right... - mapSUs (satRhs top env) pairs `thenSUs` \ pairs2 -> + mapUs (satRhs top env) pairs `thenUs` \ pairs2 -> let env2 = growIdEnvList env (map fst pairs `zip` map fst pairs2) in -- Do it again to *use* those arities: - mapSUs (satRhs top env2) pairs `thenSUs` \ pairs3 -> + mapUs (satRhs top env2) pairs `thenUs` \ pairs3 -> - returnSUs (env2, StgRec pairs3) + returnUs (env2, StgRec pairs3) -satRhs :: Bool -> SatEnv -> (Id, PlainStgRhs) -> SUniqSM (Id_w_Arity, PlainStgRhs) +satRhs :: Bool -> SatEnv -> (Id, StgRhs) -> UniqSM (Id_w_Arity, StgRhs) satRhs top env (b, StgRhsCon cc con args) -- Nothing much to do here - = let + = let b2 = b `addIdArity` 0 -- bound to a saturated constructor; hence zero. in - returnSUs (b2, StgRhsCon cc con (lookupArgs env args)) + returnUs (b2, StgRhsCon cc con (lookupArgs env args)) satRhs top env (b, StgRhsClosure cc bi fv u args body) - = satExpr env body `thenSUs` \ (arity_info, body2) -> + = satExpr env body `thenUs` \ (arity_info, body2) -> let num_args = length args in (case arity_info of Nothing -> - returnSUs (num_args, StgRhsClosure cc bi fv u args body2) + returnUs (num_args, StgRhsClosure cc bi fv u args body2) Just needed_args -> ASSERT(needed_args >= 1) @@ -165,7 +163,7 @@ satRhs top env (b, StgRhsClosure cc bi fv u args body) new_arity = num_args + needed_args -- get type info for this function: - (_,all_arg_tys,_) = splitTypeWithDictsAsArgs (getIdUniType b) + (_,all_arg_tys,_) = splitTypeWithDictsAsArgs (idType b) -- now, we already have "args"; we drop that many types args_we_dont_have_tys = drop num_args all_arg_tys @@ -175,25 +173,25 @@ satRhs top env (b, StgRhsClosure cc bi fv u args body) args_to_add_tys = take needed_args args_we_dont_have_tys in -- make up names for them - mapSUs newName args_to_add_tys `thenSUs` \ nns -> + mapUs newName args_to_add_tys `thenUs` \ nns -> -- and do the business let - body3 = saturate body2 (map StgVarAtom nns) + body3 = saturate body2 (map StgVarArg nns) new_cc -- if we're adding args, we'd better not -- keep calling something a CAF! (what about DICTs? ToDo: WDP 95/02) - = if not (isCafCC cc) - then cc -- unchanged + = if not (isCafCC cc) + then cc -- unchanged else if top then subsumedCosts else useCurrentCostCentre in - returnSUs (new_arity, StgRhsClosure new_cc bi fv ReEntrant (args++nns) body3) + returnUs (new_arity, StgRhsClosure new_cc bi fv ReEntrant (args++nns) body3) ) - `thenSUs` \ (arity, rhs2) -> - let + `thenUs` \ (arity, rhs2) -> + let b2 = b `addIdArity` arity in - returnSUs (b2, rhs2) + returnUs (b2, rhs2) \end{code} %************************************************************************ @@ -202,77 +200,77 @@ satRhs top env (b, StgRhsClosure cc bi fv u args body) %* * %************************************************************************ -\begin{code} -satExpr :: SatEnv -> PlainStgExpr -> SUniqSM (ExprArityInfo, PlainStgExpr) +\begin{code} +satExpr :: SatEnv -> StgExpr -> UniqSM (ExprArityInfo, StgExpr) -satExpr env app@(StgApp (StgLitAtom lit) [] lvs) = returnSUs (Nothing, app) +satExpr env app@(StgApp (StgLitArg lit) [] lvs) = returnUs (Nothing, app) -satExpr env app@(StgApp (StgVarAtom f) as lvs) - = returnSUs (arity_to_return, StgApp (StgVarAtom f2) as2 lvs) +satExpr env app@(StgApp (StgVarArg f) as lvs) + = returnUs (arity_to_return, StgApp (StgVarArg f2) as2 lvs) where as2 = lookupArgs env as f2 = lookupVar env f arity_to_return = case arityMaybe (getIdArity f2) of Nothing -> Nothing - Just f_arity -> if remaining_arity > 0 + Just f_arity -> if remaining_arity > 0 then Just remaining_arity else Nothing where remaining_arity = f_arity - length as - -satExpr env app@(StgConApp con as lvs) - = returnSUs (Nothing, StgConApp con (lookupArgs env as) lvs) -satExpr env app@(StgPrimApp op as lvs) - = returnSUs (Nothing, StgPrimApp op (lookupArgs env as) lvs) +satExpr env app@(StgCon con as lvs) + = returnUs (Nothing, StgCon con (lookupArgs env as) lvs) + +satExpr env app@(StgPrim op as lvs) + = returnUs (Nothing, StgPrim op (lookupArgs env as) lvs) satExpr env (StgSCC ty l e) - = satExpr env e `thenSUs` \ (_, e2) -> - returnSUs (Nothing, StgSCC ty l e2) + = satExpr env e `thenUs` \ (_, e2) -> + returnUs (Nothing, StgSCC ty l e2) {- OMITTED: Let-no-escapery should come *after* saturation satExpr (StgLetNoEscape lvs_whole lvs_rhss binds body) - = satBinding binds `thenSUs` \ (binds2, c) -> - satExpr body `thenSUs` \ (_, body2, c2) -> - returnSUs (Nothing, StgLetNoEscape lvs_whole lvs_rhss binds2 body2, c + c2) + = satBinding binds `thenUs` \ (binds2, c) -> + satExpr body `thenUs` \ (_, body2, c2) -> + returnUs (Nothing, StgLetNoEscape lvs_whole lvs_rhss binds2 body2, c + c2) -} satExpr env (StgLet binds body) - = satBinding False{-not top-level-} env binds `thenSUs` \ (env2, binds2) -> - satExpr env2 body `thenSUs` \ (_, body2) -> - returnSUs (Nothing, StgLet binds2 body2) + = satBinding False{-not top-level-} env binds `thenUs` \ (env2, binds2) -> + satExpr env2 body `thenUs` \ (_, body2) -> + returnUs (Nothing, StgLet binds2 body2) satExpr env (StgCase expr lve lva uniq alts) - = satExpr env expr `thenSUs` \ (_, expr2) -> - sat_alts alts `thenSUs` \ alts2 -> - returnSUs (Nothing, StgCase expr2 lve lva uniq alts2) + = satExpr env expr `thenUs` \ (_, expr2) -> + sat_alts alts `thenUs` \ alts2 -> + returnUs (Nothing, StgCase expr2 lve lva uniq alts2) where sat_alts (StgAlgAlts ty alts def) - = mapSUs sat_alg_alt alts `thenSUs` \ alts2 -> - sat_deflt def `thenSUs` \ def2 -> - returnSUs (StgAlgAlts ty alts2 def2) + = mapUs sat_alg_alt alts `thenUs` \ alts2 -> + sat_deflt def `thenUs` \ def2 -> + returnUs (StgAlgAlts ty alts2 def2) where sat_alg_alt (id, bs, use_mask, e) - = satExpr env e `thenSUs` \ (_, e2) -> - returnSUs (id, bs, use_mask, e2) + = satExpr env e `thenUs` \ (_, e2) -> + returnUs (id, bs, use_mask, e2) sat_alts (StgPrimAlts ty alts def) - = mapSUs sat_prim_alt alts `thenSUs` \ alts2 -> - sat_deflt def `thenSUs` \ def2 -> - returnSUs (StgPrimAlts ty alts2 def2) + = mapUs sat_prim_alt alts `thenUs` \ alts2 -> + sat_deflt def `thenUs` \ def2 -> + returnUs (StgPrimAlts ty alts2 def2) where sat_prim_alt (l, e) - = satExpr env e `thenSUs` \ (_, e2) -> - returnSUs (l, e2) + = satExpr env e `thenUs` \ (_, e2) -> + returnUs (l, e2) sat_deflt StgNoDefault - = returnSUs StgNoDefault + = returnUs StgNoDefault sat_deflt (StgBindDefault b u expr) - = satExpr env expr `thenSUs` \ (_,expr2) -> - returnSUs (StgBindDefault b u expr2) + = satExpr env expr `thenUs` \ (_,expr2) -> + returnUs (StgBindDefault b u expr2) \end{code} %************************************************************************ @@ -282,26 +280,26 @@ satExpr env (StgCase expr lve lva uniq alts) %************************************************************************ \begin{code} -saturate :: PlainStgExpr -> [PlainStgAtom] -> PlainStgExpr +saturate :: StgExpr -> [StgArg] -> StgExpr saturate (StgApp f as lvs) ids = StgApp f (as ++ ids) lvs saturate other _ = panic "SatStgRhs: saturate" \end{code} \begin{code} -lookupArgs :: SatEnv -> [PlainStgAtom] -> [PlainStgAtom] +lookupArgs :: SatEnv -> [StgArg] -> [StgArg] lookupArgs env args = map do args - where - do (StgVarAtom v) = StgVarAtom (lookupVar env v) - do a@(StgLitAtom lit) = a + where + do (StgVarArg v) = StgVarArg (lookupVar env v) + do a@(StgLitArg lit) = a lookupVar :: SatEnv -> Id -> Id lookupVar env v = case lookupIdEnv env v of Nothing -> v Just v2 -> v2 -newName :: UniType -> SUniqSM Id +newName :: Type -> UniqSM Id newName ut - = getSUnique `thenSUs` \ uniq -> - returnSUs (mkSysLocal SLIT("sat") uniq ut mkUnknownSrcLoc) + = getUnique `thenUs` \ uniq -> + returnUs (mkSysLocal SLIT("sat") uniq ut mkUnknownSrcLoc) \end{code}