X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplStg%2FStgVarInfo.lhs;h=1947e9593a17255f1af8a59163a6f469051bccde;hb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;hp=10d618c4a78fa5456c6782070d98c95358485dc1;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs index 10d618c..1947e95 100644 --- a/ghc/compiler/simplStg/StgVarInfo.lhs +++ b/ghc/compiler/simplStg/StgVarInfo.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 % \section[StgVarInfo]{Sets free/live variable info in STG syntax} @@ -11,19 +11,24 @@ let-no-escapes. module StgVarInfo ( setStgVarInfo ) where -IMPORT_Trace -- ToDo: rm (debugging only) -import Pretty -import Outputable +IMP_Ubiq(){-uitous-} import StgSyn -import Id ( getIdArity, externallyVisibleId ) -import IdInfo -- ( arityMaybe, ArityInfo ) - -import IdEnv -import Maybes ( maybeToBool, Maybe(..) ) -import UniqSet -import Util +import Id ( emptyIdSet, mkIdSet, minusIdSet, + unionIdSets, unionManyIdSets, isEmptyIdSet, + unitIdSet, intersectIdSets, + addOneToIdSet, IdSet(..), + nullIdEnv, growIdEnvList, lookupIdEnv, + unitIdEnv, combineIdEnvs, delManyFromIdEnv, + rngIdEnv, IdEnv(..), + GenId{-instance Eq-} + ) +import Maybes ( maybeToBool ) +import Name ( isLocallyDefined ) +import PprStyle ( PprStyle(..) ) +import PprType ( GenType{-instance Outputable-} ) +import Util ( panic, pprPanic, assertPanic ) infixr 9 `thenLne`, `thenLne_` \end{code} @@ -44,7 +49,7 @@ it can be referred to {\em directly} again. In particular, a dead variable's stack slot (if it has one): \begin{enumerate} \item -should be stubbed to avoid space leaks, and +should be stubbed to avoid space leaks, and \item may be reused for something else. \end{enumerate} @@ -52,14 +57,14 @@ may be reused for something else. There ought to be a better way to say this. Here are some examples: \begin{verbatim} let v = [q] \[x] -> e - in + in ...v... (but no q's) \end{verbatim} Just after the `in', v is live, but q is dead. If the whole of that let expression was enclosed in a case expression, thus: \begin{verbatim} - case (let v = [q] \[x] -> e in ...v...) of + case (let v = [q] \[x] -> e in ...v...) of alts[...q...] \end{verbatim} (ie @alts@ mention @q@), then @q@ is live even after the `in'; because @@ -68,7 +73,7 @@ we'll return later to the @alts@ and need it. Let-no-escapes make this a bit more interesting: \begin{verbatim} let-no-escape v = [q] \ [x] -> e - in + in ...v... \end{verbatim} Here, @q@ is still live at the `in', because @v@ is represented not by @@ -86,14 +91,14 @@ if @v@ is. Top-level: \begin{code} setStgVarInfo :: Bool -- True <=> do let-no-escapes - -> [PlainStgBinding] -- input - -> [PlainStgBinding] -- result + -> [StgBinding] -- input + -> [StgBinding] -- result -setStgVarInfo want_LNEs pgm - = pgm' +setStgVarInfo want_LNEs pgm + = pgm' where (pgm', _) = initLne want_LNEs (varsTopBinds pgm) - + \end{code} For top-level guys, we basically aren't worried about this @@ -101,7 +106,7 @@ live-variable stuff; we do need to keep adding to the environment as we step through the bindings (using @extendVarEnv@). \begin{code} -varsTopBinds :: [PlainStgBinding] -> LneM ([PlainStgBinding], FreeVarsInfo) +varsTopBinds :: [StgBinding] -> LneM ([StgBinding], FreeVarsInfo) varsTopBinds [] = returnLne ([], emptyFVInfo) varsTopBinds (bind:binds) @@ -111,13 +116,13 @@ varsTopBinds (bind:binds) returnLne ((bind' : binds'), (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders ) - + ) where - env_extension = [(b, LetrecBound + env_extension = [(b, LetrecBound True {- top level -} (rhsArity rhs) - emptyUniqSet) + emptyIdSet) | (b,rhs) <- pairs] pairs = case bind of @@ -128,8 +133,8 @@ varsTopBinds (bind:binds) varsTopBind :: FreeVarsInfo -- Info about the body - -> PlainStgBinding - -> LneM (PlainStgBinding, FreeVarsInfo) + -> StgBinding + -> LneM (StgBinding, FreeVarsInfo) varsTopBind body_fvs (StgNonRec binder rhs) = varsRhs body_fvs (binder,rhs) `thenLne` \ (rhs2, fvs, _) -> @@ -140,7 +145,7 @@ varsTopBind body_fvs (StgRec pairs) (binders, rhss) = unzip pairs in fixLne (\ ~(_, rec_rhs_fvs) -> - let + let scope_fvs = unionFVInfo body_fvs rec_rhs_fvs in mapAndUnzip3Lne (varsRhs scope_fvs) pairs `thenLne` \ (rhss2, fvss, _) -> @@ -154,41 +159,41 @@ varsTopBind body_fvs (StgRec pairs) \begin{code} varsRhs :: FreeVarsInfo -- Free var info for the scope of the binding - -> (Id,PlainStgRhs) - -> LneM (PlainStgRhs, FreeVarsInfo, EscVarsSet) + -> (Id,StgRhs) + -> LneM (StgRhs, FreeVarsInfo, EscVarsSet) varsRhs scope_fv_info (binder, StgRhsCon cc con args) = varsAtoms args `thenLne` \ fvs -> returnLne (StgRhsCon cc con args, fvs, getFVSet fvs) -varsRhs scope_fv_info (binder, StgRhsClosure cc _ _ upd args body) +varsRhs scope_fv_info (binder, StgRhsClosure cc _ _ upd args body) = extendVarEnv [ (a, LambdaBound) | a <- args ] ( do_body args body `thenLne` \ (body2, body_fvs, body_escs) -> let - set_of_args = mkUniqSet args + set_of_args = mkIdSet args rhs_fvs = body_fvs `minusFVBinders` args - rhs_escs = body_escs `minusUniqSet` set_of_args - binder_info = lookupFVInfo scope_fv_info binder + rhs_escs = body_escs `minusIdSet` set_of_args + binder_info = lookupFVInfo scope_fv_info binder in - returnLne (StgRhsClosure cc binder_info (getFVs rhs_fvs) upd args body2, + returnLne (StgRhsClosure cc binder_info (getFVs rhs_fvs) upd args body2, rhs_fvs, rhs_escs) ) where -- Pick out special case of application in body of thunk - do_body [] (StgApp (StgVarAtom f) args _) = varsApp (Just upd) f args + do_body [] (StgApp (StgVarArg f) args _) = varsApp (Just upd) f args do_body _ other_body = varsExpr other_body \end{code} \begin{code} -varsAtoms :: [PlainStgAtom] +varsAtoms :: [StgArg] -> LneM FreeVarsInfo varsAtoms atoms = mapLne var_atom atoms `thenLne` \ fvs_lists -> returnLne (unionFVInfos fvs_lists) where - var_atom a@(StgLitAtom _) = returnLne emptyFVInfo - var_atom a@(StgVarAtom v) + var_atom a@(StgLitArg _) = returnLne emptyFVInfo + var_atom a@(StgVarArg v) = lookupVarEnv v `thenLne` \ how_bound -> returnLne (singletonFVInfo v how_bound stgArgOcc) \end{code} @@ -202,21 +207,21 @@ varsAtoms atoms @varsExpr@ carries in a monad-ised environment, which binds each let(rec) variable (ie non top level, not imported, not lambda bound, not case-alternative bound) to: - - its STG arity, and - - its set of live vars. + - its STG arity, and + - its set of live vars. For normal variables the set of live vars is just the variable itself. For let-no-escaped variables, the set of live vars is the set live at the moment the variable is entered. The set is guaranteed to have no further let-no-escaped vars in it. \begin{code} -varsExpr :: PlainStgExpr - -> LneM (PlainStgExpr, -- Decorated expr +varsExpr :: StgExpr + -> LneM (StgExpr, -- Decorated expr FreeVarsInfo, -- Its free vars (NB free, not live) EscVarsSet) -- Its escapees, a subset of its free vars; -- also a subset of the domain of the envt -- because we are only interested in the escapees - -- for vars which might be turned into + -- for vars which might be turned into -- let-no-escaped ones. \end{code} @@ -227,24 +232,22 @@ on these components, but it in turn is not scrutinised as the basis for any decisions. Hence no black holes. \begin{code} -varsExpr (StgApp lit@(StgLitAtom _) args _) - = --(if null args then id else (trace (ppShow 80 (ppr PprShowAll args)))) ( - returnLne (StgApp lit [] emptyUniqSet, emptyFVInfo, emptyUniqSet) - --) +varsExpr (StgApp lit@(StgLitArg _) args _) + = returnLne (StgApp lit [] emptyIdSet, emptyFVInfo, emptyIdSet) -varsExpr (StgApp fun@(StgVarAtom f) args _) = varsApp Nothing f args +varsExpr (StgApp fun@(StgVarArg f) args _) = varsApp Nothing f args -varsExpr (StgConApp con args _) +varsExpr (StgCon con args _) = getVarsLiveInCont `thenLne` \ live_in_cont -> varsAtoms args `thenLne` \ args_fvs -> - returnLne (StgConApp con args live_in_cont, args_fvs, getFVSet args_fvs) + returnLne (StgCon con args live_in_cont, args_fvs, getFVSet args_fvs) -varsExpr (StgPrimApp op args _) +varsExpr (StgPrim op args _) = getVarsLiveInCont `thenLne` \ live_in_cont -> varsAtoms args `thenLne` \ args_fvs -> - returnLne (StgPrimApp op args live_in_cont, args_fvs, getFVSet args_fvs) + returnLne (StgPrim op args live_in_cont, args_fvs, getFVSet args_fvs) varsExpr (StgSCC ty label expr) = varsExpr expr `thenLne` ( \ (expr2, fvs, escs) -> @@ -258,7 +261,7 @@ varsExpr (StgCase scrut _ _ uniq alts) vars_alts alts `thenLne` \ (alts2, alts_fvs, alts_escs) -> lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs -> let - live_in_alts = live_in_cont `unionUniqSets` alts_lvs + live_in_alts = live_in_cont `unionIdSets` alts_lvs in -- we tell the scrutinee that everything live in the alts -- is live in it, too. @@ -267,12 +270,12 @@ varsExpr (StgCase scrut _ _ uniq alts) ) `thenLne` \ (scrut2, scrut_fvs, scrut_escs) -> lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs -> let - live_in_whole_case = live_in_alts `unionUniqSets` scrut_lvs + live_in_whole_case = live_in_alts `unionIdSets` scrut_lvs in returnLne ( StgCase scrut2 live_in_whole_case live_in_alts uniq alts2, scrut_fvs `unionFVInfo` alts_fvs, - alts_escs `unionUniqSets` (getFVSet scrut_fvs) -- All free vars in the scrutinee escape + alts_escs `unionIdSets` (getFVSet scrut_fvs) -- All free vars in the scrutinee escape ) where vars_alts (StgAlgAlts ty alts deflt) @@ -280,13 +283,13 @@ varsExpr (StgCase scrut _ _ uniq alts) `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) -> let alts_fvs = unionFVInfos alts_fvs_list - alts_escs = unionManyUniqSets alts_escs_list + alts_escs = unionManyIdSets alts_escs_list in vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) -> returnLne ( StgAlgAlts ty alts2 deflt2, alts_fvs `unionFVInfo` deflt_fvs, - alts_escs `unionUniqSets` deflt_escs + alts_escs `unionIdSets` deflt_escs ) where vars_alg_alt (con, binders, worthless_use_mask, rhs) @@ -299,7 +302,7 @@ varsExpr (StgCase scrut _ _ uniq alts) returnLne ( (con, binders, good_use_mask, rhs2), rhs_fvs `minusFVBinders` binders, - rhs_escs `minusUniqSet` mkUniqSet binders -- ToDo: remove the minusUniqSet; + rhs_escs `minusIdSet` mkIdSet binders -- ToDo: remove the minusIdSet; -- since escs won't include -- any of these binders )) @@ -309,13 +312,13 @@ varsExpr (StgCase scrut _ _ uniq alts) `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) -> let alts_fvs = unionFVInfos alts_fvs_list - alts_escs = unionManyUniqSets alts_escs_list + alts_escs = unionManyIdSets alts_escs_list in vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) -> returnLne ( StgPrimAlts ty alts2 deflt2, alts_fvs `unionFVInfo` deflt_fvs, - alts_escs `unionUniqSets` deflt_escs + alts_escs `unionIdSets` deflt_escs ) where vars_prim_alt (lit, rhs) @@ -323,7 +326,7 @@ varsExpr (StgCase scrut _ _ uniq alts) returnLne ((lit, rhs2), rhs_fvs, rhs_escs) vars_deflt StgNoDefault - = returnLne (StgNoDefault, emptyFVInfo, emptyUniqSet) + = returnLne (StgNoDefault, emptyFVInfo, emptyIdSet) vars_deflt (StgBindDefault binder _ rhs) = extendVarEnv [(binder, CaseBound)] ( @@ -334,7 +337,7 @@ varsExpr (StgCase scrut _ _ uniq alts) returnLne ( StgBindDefault binder used_in_rhs rhs2, rhs_fvs `minusFVBinders` [binder], - rhs_escs `minusUniqSet` singletonUniqSet binder + rhs_escs `minusIdSet` unitIdSet binder )) \end{code} @@ -345,26 +348,19 @@ then to let-no-escapes, if we wish. \begin{code} varsExpr (StgLetNoEscape _ _ _ _) = panic "varsExpr: unexpected StgLetNoEscape" -varsExpr (StgLet bind body) +varsExpr (StgLet bind body) = isSwitchSetLne {-StgDoLetNoEscapes-} `thenLne` \ want_LNEs -> (fixLne (\ ~(_, _, _, no_binder_escapes) -> - let + let non_escaping_let = want_LNEs && no_binder_escapes in - vars_let non_escaping_let bind body + vars_let non_escaping_let bind body )) `thenLne` \ (new_let, fvs, escs, _) -> returnLne (new_let, fvs, escs) \end{code} -\begin{code} -#ifdef DPH --- rest of varsExpr goes here - -#endif {- Data Parallel Haskell -} -\end{code} - Applications: \begin{code} varsApp :: Maybe UpdateFlag -- Just upd <=> this application is @@ -372,24 +368,24 @@ varsApp :: Maybe UpdateFlag -- Just upd <=> this application is -- x = [...] \upd [] -> the_app -- with specified update flag -> Id -- Function - -> [PlainStgAtom] -- Arguments - -> LneM (PlainStgExpr, FreeVarsInfo, EscVarsSet) + -> [StgArg] -- Arguments + -> LneM (StgExpr, FreeVarsInfo, EscVarsSet) varsApp maybe_thunk_body f args = getVarsLiveInCont `thenLne` \ live_in_cont -> varsAtoms args `thenLne` \ args_fvs -> - + lookupVarEnv f `thenLne` \ how_bound -> - + let - n_args = length args + n_args = length args fun_fvs = singletonFVInfo f how_bound fun_occ fun_occ = - case how_bound of - LetrecBound _ arity _ + case how_bound of + LetrecBound _ arity _ | n_args == 0 -> stgFakeFunAppOcc -- Function Application -- with no arguments. -- used by the lambda lifter. @@ -410,17 +406,17 @@ varsApp maybe_thunk_body f args other -> NoStgBinderInfo -- uninteresting variable - myself = singletonUniqSet f + myself = unitIdSet f fun_escs = case how_bound of - LetrecBound _ arity lvs -> + LetrecBound _ arity lvs -> if arity == n_args then - emptyUniqSet -- Function doesn't escape + emptyIdSet -- Function doesn't escape else myself -- Inexact application; it does escape - other -> emptyUniqSet -- Only letrec-bound escapees + other -> emptyIdSet -- Only letrec-bound escapees -- are interesting -- At the moment of the call: @@ -435,14 +431,14 @@ varsApp maybe_thunk_body f args -- two regardless. live_at_call - = live_in_cont `unionUniqSets` case how_bound of - LetrecBound _ _ lvs -> lvs `minusUniqSet` myself - other -> emptyUniqSet + = live_in_cont `unionIdSets` case how_bound of + LetrecBound _ _ lvs -> lvs `minusIdSet` myself + other -> emptyIdSet in returnLne ( - StgApp (StgVarAtom f) args live_at_call, + StgApp (StgVarArg f) args live_at_call, fun_fvs `unionFVInfo` args_fvs, - fun_escs `unionUniqSets` (getFVSet args_fvs) + fun_escs `unionIdSets` (getFVSet args_fvs) -- All the free vars of the args are disqualified -- from being let-no-escaped. ) @@ -451,9 +447,9 @@ varsApp maybe_thunk_body f args The magic for lets: \begin{code} vars_let :: Bool -- True <=> yes, we are let-no-escaping this let - -> PlainStgBinding -- bindings - -> PlainStgExpr -- body - -> LneM (PlainStgExpr, -- new let + -> StgBinding -- bindings + -> StgExpr -- body + -> LneM (StgExpr, -- new let FreeVarsInfo, -- variables free in the whole let EscVarsSet, -- variables that escape from the whole let Bool) -- True <=> none of the binders in the bindings @@ -466,7 +462,7 @@ vars_let let_no_escape bind body -- we ain't in a let-no-escape world getVarsLiveInCont `thenLne` \ live_in_cont -> setVarsLiveInCont - (if let_no_escape then live_in_cont else emptyUniqSet) + (if let_no_escape then live_in_cont else emptyIdSet) (vars_bind rec_bind_lvs rec_body_fvs bind) `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) -> @@ -474,27 +470,27 @@ vars_let let_no_escape bind body -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs) -- together with the live_in_cont ones lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders) `thenLne` \ lvs_from_fvs -> - let - bind_lvs = lvs_from_fvs `unionUniqSets` live_in_cont + let + bind_lvs = lvs_from_fvs `unionIdSets` live_in_cont in -- bind_fvs and bind_escs still include the binders of the let(rec) -- but bind_lvs does not -- Do the body - extendVarEnv env_ext ( - varsExpr body `thenLne` \ (body2, body_fvs, body_escs) -> - lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs -> + extendVarEnv env_ext ( + varsExpr body `thenLne` \ (body2, body_fvs, body_escs) -> + lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs -> - returnLne (bind2, bind_fvs, bind_escs, bind_lvs, - body2, body_fvs, body_escs, body_lvs) + returnLne (bind2, bind_fvs, bind_escs, bind_lvs, + body2, body_fvs, body_escs, body_lvs) )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, body2, body_fvs, body_escs, body_lvs) -> -- Compute the new let-expression - let + let new_let = if let_no_escape then -- trace "StgLetNoEscape!" ( StgLetNoEscape live_in_whole_let bind_lvs bind2 body2 @@ -506,21 +502,21 @@ vars_let let_no_escape bind body = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders live_in_whole_let - = bind_lvs `unionUniqSets` (body_lvs `minusUniqSet` set_of_binders) + = bind_lvs `unionIdSets` (body_lvs `minusIdSet` set_of_binders) - real_bind_escs = if let_no_escape then + real_bind_escs = if let_no_escape then bind_escs else getFVSet bind_fvs -- Everything escapes which is free in the bindings - let_escs = (real_bind_escs `unionUniqSets` body_escs) `minusUniqSet` set_of_binders + let_escs = (real_bind_escs `unionIdSets` body_escs) `minusIdSet` set_of_binders - all_escs = bind_escs `unionUniqSets` body_escs -- Still includes binders of + all_escs = bind_escs `unionIdSets` body_escs -- Still includes binders of -- this let(rec) - no_binder_escapes = isEmptyUniqSet (set_of_binders `intersectUniqSets` all_escs) - -- Mustn't depend on the passed-in let_no_escape flag, since + no_binder_escapes = isEmptyIdSet (set_of_binders `intersectIdSets` all_escs) + -- Mustn't depend on the passed-in let_no_escape flag, since -- no_binder_escapes is used by the caller to derive the flag! in returnLne ( @@ -533,7 +529,7 @@ vars_let let_no_escape bind body binders = case bind of StgNonRec binder rhs -> [binder] StgRec pairs -> map fst pairs - set_of_binders = mkUniqSet binders + set_of_binders = mkIdSet binders mk_binding bind_lvs (binder,rhs) = (binder, @@ -542,15 +538,15 @@ vars_let let_no_escape bind body live_vars ) where - live_vars = if let_no_escape then - bind_lvs `unionUniqSets` singletonUniqSet binder - else - singletonUniqSet binder + live_vars = if let_no_escape then + addOneToIdSet bind_lvs binder + else + unitIdSet binder - vars_bind :: PlainStgLiveVars + vars_bind :: StgLiveVars -> FreeVarsInfo -- Free var info for body of binding - -> PlainStgBinding - -> LneM (PlainStgBinding, + -> StgBinding + -> LneM (StgBinding, FreeVarsInfo, EscVarsSet, -- free vars; escapee vars [(Id, HowBound)]) -- extension to environment @@ -569,13 +565,13 @@ vars_let let_no_escape bind body in extendVarEnv env_ext ( fixLne (\ ~(_, rec_rhs_fvs, _, _) -> - let + let rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs in mapAndUnzip3Lne (varsRhs rec_scope_fvs) pairs `thenLne` \ (rhss2, fvss, escss) -> let fvs = unionFVInfos fvss - escs = unionManyUniqSets escss + escs = unionManyIdSets escss in returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext) )) @@ -593,23 +589,21 @@ help. All the stuff here is only passed {\em down}. \begin{code} type LneM a = Bool -- True <=> do let-no-escapes -> IdEnv HowBound - -> PlainStgLiveVars -- vars live in continuation + -> StgLiveVars -- vars live in continuation -> a -type Arity = Int - data HowBound = ImportBound | CaseBound | LambdaBound - | LetrecBound - Bool -- True <=> bound at top level - Arity -- Arity - PlainStgLiveVars -- Live vars... see notes below + | LetrecBound + Bool -- True <=> bound at top level + Arity -- Arity + StgLiveVars -- Live vars... see notes below \end{code} -For a let(rec)-bound variable, x, we record what varibles are live if -x is live. For "normal" variables that is just x alone. If x is +For a let(rec)-bound variable, x, we record what varibles are live if +x is live. For "normal" variables that is just x alone. If x is a let-no-escaped variable then x is represented by a code pointer and a stack pointer (well, one for each stack). So all of the variables needed in the execution of x are live if x is, and are therefore recorded @@ -618,13 +612,11 @@ in the LetrecBound constructor; x itself *is* included. The std monad functions: \begin{code} initLne :: Bool -> LneM a -> a -initLne want_LNEs m = m want_LNEs nullIdEnv emptyUniqSet +initLne want_LNEs m = m want_LNEs nullIdEnv emptyIdSet -#ifdef __GLASGOW_HASKELL__ {-# INLINE thenLne #-} {-# INLINE thenLne_ #-} {-# INLINE returnLne #-} -#endif returnLne :: a -> LneM a returnLne e sw env lvs_cont = e @@ -671,20 +663,14 @@ fixLne expr sw env lvs_cont = result Functions specific to this monad: \begin{code} -{- NOT USED: -ifSwitchSetLne :: GlobalSwitch -> LneM a -> LneM a -> LneM a -ifSwitchSetLne switch then_ else_ switch_checker env lvs_cont - = (if switch_checker switch then then_ else else_) switch_checker env lvs_cont --} - isSwitchSetLne :: LneM Bool isSwitchSetLne want_LNEs env lvs_cont = want_LNEs -getVarsLiveInCont :: LneM PlainStgLiveVars +getVarsLiveInCont :: LneM StgLiveVars getVarsLiveInCont sw env lvs_cont = lvs_cont -setVarsLiveInCont :: PlainStgLiveVars -> LneM a -> LneM a +setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a setVarsLiveInCont new_lvs_cont expr sw env lvs_cont = expr sw env new_lvs_cont @@ -705,20 +691,20 @@ lookupVarEnv v sw env lvs_cont -- only ever tacked onto a decorated expression. It is never used as -- the basis of a control decision, which might give a black hole. -lookupLiveVarsForSet :: FreeVarsInfo -> LneM PlainStgLiveVars +lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars lookupLiveVarsForSet fvs sw env lvs_cont - = returnLne (unionManyUniqSets (map do_one (getFVs fvs))) + = returnLne (unionManyIdSets (map do_one (getFVs fvs))) sw env lvs_cont where do_one v = if isLocallyDefined v then case (lookupIdEnv env v) of - Just (LetrecBound _ _ lvs) -> lvs `unionUniqSets` singletonUniqSet v - Just _ -> singletonUniqSet v + Just (LetrecBound _ _ lvs) -> addOneToIdSet lvs v + Just _ -> unitIdSet v Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr PprShowAll v) else - emptyUniqSet + emptyIdSet \end{code} @@ -729,18 +715,18 @@ lookupLiveVarsForSet fvs sw env lvs_cont %************************************************************************ \begin{code} -type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo) +type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo) -- If f is mapped to NoStgBinderInfo, that means -- that f *is* mentioned (else it wouldn't be in the -- IdEnv at all), but only in a saturated applications. - -- + -- -- All case/lambda-bound things are also mapped to -- NoStgBinderInfo, since we aren't interested in their -- occurence info. -- -- The Bool is True <=> the Id is top level letrec bound -type EscVarsSet = UniqSet Id +type EscVarsSet = IdSet \end{code} \begin{code} @@ -772,8 +758,8 @@ lookupFVInfo fvs id = case lookupIdEnv fvs id of getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only getFVs fvs = [id | (id,False,_) <- rngIdEnv fvs] -getFVSet :: FreeVarsInfo -> UniqSet Id -getFVSet fvs = mkUniqSet (getFVs fvs) +getFVSet :: FreeVarsInfo -> IdSet +getFVSet fvs = mkIdSet (getFVs fvs) plusFVInfo (id1,top1,info1) (id2,top2,info2) = ASSERT (id1 == id2 && top1 == top2) @@ -781,7 +767,7 @@ plusFVInfo (id1,top1,info1) (id2,top2,info2) \end{code} \begin{code} -rhsArity :: PlainStgRhs -> Arity +rhsArity :: StgRhs -> Arity rhsArity (StgRhsCon _ _ _) = 0 rhsArity (StgRhsClosure _ _ _ _ args _) = length args \end{code}