From 17e8f5c279e5d23cfd44d25298646426d39342c8 Mon Sep 17 00:00:00 2001 From: simonmar Date: Tue, 13 Mar 2001 14:17:16 +0000 Subject: [PATCH] [project @ 2001-03-13 14:17:16 by simonmar] Fix let-no-escapes again. --- ghc/compiler/stgSyn/CoreToStg.lhs | 46 ++++++++++++++++++++----------------- 1 file changed, 25 insertions(+), 21 deletions(-) diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 07054ff..13c937e 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -31,7 +31,7 @@ import TysPrim ( foreignObjPrimTyCon ) import Maybes ( maybeToBool ) import Name ( getOccName, isExternallyVisibleName, isDllName ) import OccName ( occNameUserString ) -import BasicTypes ( TopLevelFlag(..), isNotTopLevel ) +import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity ) import CmdLineOpts ( DynFlags, opt_KeepStgTypes ) import FastTypes hiding ( fastOr ) import Outputable @@ -157,8 +157,9 @@ coreTopBindToStg coreTopBindToStg env body_fvs (NonRec id rhs) = let caf_info = hasCafRefs env rhs + arity = exprArity rhs - env' = extendVarEnv env id (LetBound how_bound emptyVarSet) + env' = extendVarEnv env id (LetBound how_bound emptyVarSet arity) how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs | otherwise = TopLevelNoCafs @@ -184,12 +185,14 @@ coreTopBindToStg env body_fvs (Rec pairs) -- to calculate caf_info, we initially map all the binders to -- TopLevelNoCafs. env1 = extendVarEnvList env - [ (b, LetBound TopLevelNoCafs emptyVarSet) | b <- binders ] + [ (b, LetBound TopLevelNoCafs emptyVarSet (error "no arity")) + | b <- binders ] caf_info = hasCafRefss env1{-NB: not env'-} rhss env' = extendVarEnvList env - [ (b, LetBound how_bound emptyVarSet) | b <- binders ] + [ (b, LetBound how_bound emptyVarSet (exprArity rhs)) + | (b,rhs) <- pairs ] how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs | otherwise = TopLevelNoCafs @@ -529,8 +532,9 @@ coreToStgApp maybe_thunk_body f args -- let f = \ab -> e in f -- No point in having correct arity info for f! -- Hence the hasArity stuff below. - f_arity_info = idArityInfo f - f_arity = arityLowerBound f_arity_info -- Zero if no info + f_arity = case how_bound of + LetBound _ _ arity -> arity + _ -> 0 fun_occ | not_letrec_bound = noBinderInfo -- Uninteresting variable @@ -539,8 +543,7 @@ coreToStgApp maybe_thunk_body f args fun_escs | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting - | hasArity f_arity_info && - f_arity == n_args = emptyVarSet -- A function *or thunk* with an exactly + | f_arity == n_args = emptyVarSet -- A function *or thunk* with an exactly -- saturated call doesn't escape -- (let-no-escape applies to 'thunks' too) @@ -692,9 +695,9 @@ coreToStgLet let_no_escape bind body NonRec binder rhs -> [binder] Rec pairs -> map fst pairs - mk_binding bind_lvs binder + mk_binding bind_lvs binder rhs = (binder, LetBound NotTopLevelBound -- Not top level - live_vars + live_vars (exprArity rhs) ) where live_vars = if let_no_escape then @@ -717,7 +720,7 @@ coreToStgLet let_no_escape bind body freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) -> let - env_ext_item@(binder', _) = mk_binding bind_lvs binder + env_ext_item@(binder', _) = mk_binding bind_lvs binder rhs in returnLne (StgNonRec (SRTEntries bind_cafs) binder' rhs2, bind_fvs, escs, bind_lvs, [env_ext_item]) @@ -728,7 +731,7 @@ coreToStgLet let_no_escape bind body let rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs binders = map fst pairs - env_ext = map (mk_binding bind_lvs) binders + env_ext = [ mk_binding bind_lvs b rhs | (b,rhs) <- pairs ] in extendVarEnvLne env_ext ( mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs @@ -772,9 +775,10 @@ data HowBound | LetBound TopLevelCafInfo StgLiveVars -- Live vars... see notes below + Arity -- its arity (local Ids don't have arity info at this point) -isLetBound (LetBound _ _) = True -isLetBound other = False +isLetBound (LetBound _ _ _) = True +isLetBound other = False \end{code} For a let(rec)-bound variable, x, we record StgLiveVars, the set of @@ -874,17 +878,17 @@ freeVarsToLiveVars fvs env live_in_cont do_one v = if isLocalId v then case (lookupVarEnv env v) of - Just (LetBound _ lvs) -> extendVarSet lvs v - Just _ -> unitVarSet v + Just (LetBound _ lvs _) -> extendVarSet lvs v + Just _ -> unitVarSet v Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v) else emptyVarSet is_caf_one v = case lookupVarEnv env v of - Just (LetBound TopLevelHasCafs lvs) -> + Just (LetBound TopLevelHasCafs lvs _) -> ASSERT( isEmptyVarSet lvs ) True - Just (LetBound _ _) -> False + Just (LetBound _ _ _) -> False _otherwise -> mayHaveCafRefs (idCafInfo v) \end{code} @@ -924,7 +928,7 @@ singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo singletonFVInfo id ImportBound info | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info) | otherwise = emptyVarEnv -singletonFVInfo id (LetBound top_level _) info +singletonFVInfo id (LetBound top_level _ _) info = unitVarEnv id (id, top_level, info) singletonFVInfo id other info = unitVarEnv id (id, NotTopLevelBound, info) @@ -1055,8 +1059,8 @@ cafRefs p (Var id) | isLocalId id = fastBool False | otherwise = case lookupVarEnv p id of - Just (LetBound TopLevelHasCafs _) -> fastBool True - Just (LetBound _ _) -> fastBool False + Just (LetBound TopLevelHasCafs _ _) -> fastBool True + Just (LetBound _ _ _) -> fastBool False Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) -- imported Ids cafRefs p (Lit l) = fastBool False -- 1.7.10.4