From d5c7622a852d7fb55120706ac75ae1323ce3939f Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 20 Feb 2001 09:39:00 +0000 Subject: [PATCH] [project @ 2001-02-20 09:38:59 by simonpj] Back end changes [CgExpr, ClosureInfo, CoreSat, CoreUtils, ~~~~~~~~~~~~~~~~ CmdLineOpts, HscMain, CoreToStg, StgSyn] * Move CoreTidy and interface-file dumping *before* CoreSat. In this way interface files are not in A-normal form, so they are less bulky, and a bit easier to use as input to the optimiser. So now CoreSat is regarded as a pre-pass to CoreToStg. Since CoreTidy pins on utterly-final IdInfo, CoreSat has to be very careful not to change the arity of any function. * CoreSat uses OrdList instead of lists to collect floating binds This in turn meant I could simplify the FloatingBind type a bit * Greatly simplfy the StgBinderInfo data type. It was gathering far more information than we needed. * Add a flag -fkeep-stg-types, which keeps type abstractions and applications in STG code, for the benefit of code generators that are typed; notably the .NET ILX code generator. --- ghc/compiler/codeGen/CgExpr.lhs | 5 +- ghc/compiler/codeGen/ClosureInfo.lhs | 26 +-- ghc/compiler/coreSyn/CoreSat.lhs | 380 ++++++++++++++++------------------ ghc/compiler/coreSyn/CoreUtils.lhs | 11 +- ghc/compiler/main/CmdLineOpts.lhs | 6 +- ghc/compiler/main/HscMain.lhs | 17 +- ghc/compiler/stgSyn/CoreToStg.lhs | 315 ++++++++++++++-------------- ghc/compiler/stgSyn/StgSyn.lhs | 67 ++---- 8 files changed, 383 insertions(+), 444 deletions(-) diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index 8e8b5e2..7f01cd9 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.40 2000/11/24 09:51:38 simonpj Exp $ +% $Id: CgExpr.lhs,v 1.41 2001/02/20 09:38:59 simonpj Exp $ % %******************************************************** %* * @@ -434,7 +434,8 @@ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside! cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder (StgRhsCon cc con args) - = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec + = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} NoSRT + full_live_in_rhss rhs_eob_info maybe_cc_slot rec [] --No args; the binder is data structure, not a function (StgConApp con args) \end{code} diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 05a05b4..d1a40ac 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: ClosureInfo.lhs,v 1.44 2000/12/06 13:19:49 simonmar Exp $ +% $Id: ClosureInfo.lhs,v 1.45 2001/02/20 09:38:59 simonpj Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -85,8 +85,7 @@ import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, ) import TyCon ( isBoxedTupleTyCon ) import IdInfo ( ArityInfo(..) ) -import Name ( Name, isExternallyVisibleName, nameUnique, - getOccName ) +import Name ( Name, nameUnique, getOccName ) import OccName ( occNameUserString ) import PprType ( getTyDescription ) import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep ) @@ -830,13 +829,11 @@ staticClosureRequired -> StgBinderInfo -> LambdaFormInfo -> Bool -staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) +staticClosureRequired binder bndr_info (LFReEntrant _ top_level _ _ _ _) -- It's a function = ASSERT( isTopLevel top_level ) -- Assumption: it's a top-level, no-free-var binding - arg_occ -- There's an argument occurrence - || unsat_occ -- There's an unsaturated call - || isExternallyVisibleName binder + not (satCallsOnly bndr_info) staticClosureRequired binder other_binder_info other_lf_info = True @@ -845,27 +842,20 @@ slowFunEntryCodeRequired -- Assumption: it's a function, not a thunk. -> StgBinderInfo -> EntryConvention -> Bool -slowFunEntryCodeRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) entry_conv - = arg_occ -- There's an argument occurrence - || unsat_occ -- There's an unsaturated call - || isExternallyVisibleName binder +slowFunEntryCodeRequired binder bndr_info entry_conv + = not (satCallsOnly bndr_info) || (case entry_conv of { DirectEntry _ _ _ -> False; other -> True }) {- The last case deals with the parallel world; a function usually as a DirectEntry convention, but if it doesn't we must generate slow-entry code -} -slowFunEntryCodeRequired binder NoStgBinderInfo _ = True - funInfoTableRequired :: Name -> StgBinderInfo -> LambdaFormInfo -> Bool -funInfoTableRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) - (LFReEntrant _ top_level _ _ _ _) +funInfoTableRequired binder bndr_info (LFReEntrant _ top_level _ _ _ _) = isNotTopLevel top_level - || arg_occ -- There's an argument occurrence - || unsat_occ -- There's an unsaturated call - || isExternallyVisibleName binder + || not (satCallsOnly bndr_info) funInfoTableRequired other_binder_info binder other_lf_info = True \end{code} diff --git a/ghc/compiler/coreSyn/CoreSat.lhs b/ghc/compiler/coreSyn/CoreSat.lhs index 9282637..b26f3a8 100644 --- a/ghc/compiler/coreSyn/CoreSat.lhs +++ b/ghc/compiler/coreSyn/CoreSat.lhs @@ -10,19 +10,22 @@ module CoreSat ( #include "HsVersions.h" -import CoreUtils -import CoreFVs -import CoreLint +import CoreUtils( exprIsTrivial, exprIsAtom, exprType, exprIsValue, etaExpand ) +import CoreFVs ( exprFreeVars ) +import CoreLint ( endPass ) import CoreSyn -import Type -import Demand -import Var ( TyVar, setTyVarUnique ) +import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy, + isUnLiftedType, isUnboxedTupleType, repType, + uaUTy, usOnce, usMany, seqType ) +import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) ) +import Var ( Id, TyVar, setTyVarUnique ) import VarSet -import IdInfo -import Id -import PrimOp +import IdInfo ( IdFlavour(..) ) +import Id ( mkSysLocal, idType, idStrictness, idFlavour, idDemandInfo, idArity ) + import UniqSupply import Maybes +import OrdList import ErrUtils import CmdLineOpts import Outputable @@ -32,34 +35,44 @@ import Outputable -- Overview -- --------------------------------------------------------------------------- +MAJOR CONSTRAINT: + By the time this pass happens, we have spat out tidied Core into + the interface file, including all IdInfo. + + So we must not change the arity of any top-level function, + because we've already fixed it and put it out into the interface file. + + It's ok to introduce extra bindings, which don't appear in the + interface file. We don't put arity info on these extra bindings, + because they are never fully applied, so there's no chance of + compiling just-a-fast-entry point for them. + Most of the contents of this pass used to be in CoreToStg. The primary goals here are: -1. Get the program into "A-normal form". In particular: +1. Saturate constructor and primop applications. - f E ==> let x = E in f x - OR ==> case E of x -> f x +2. Convert to A-normal form: + * Use case for strict arguments: + f E ==> case E of x -> f x + (where f is strict) - if E is a non-trivial expression. - Which transformation is used depends on whether f is strict or not. - [Previously the transformation to case used to be done by the - simplifier, but it's better done here. It does mean that f needs - to have its strictness info correct!.] + * Use let for non-trivial lazy arguments + f E ==> let x = E in f x + (were f is lazy and x is non-trivial) -2. Similarly, convert any unboxed lets into cases. - [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form - right up to this point.] +3. Similarly, convert any unboxed lets into cases. + [I'm experimenting with leaving 'ok-for-speculation' + rhss in let-form right up to this point.] - This is all done modulo type applications and abstractions, so that - when type erasure is done for conversion to STG, we don't end up with - any trivial or useless bindings. - -3. Ensure that lambdas only occur as the RHS of a binding +4. Ensure that lambdas only occur as the RHS of a binding (The code generator can't deal with anything else.) -4. Saturate constructor and primop applications. - +This is all done modulo type applications and abstractions, so that +when type erasure is done for conversion to STG, we don't end up with +any trivial or useless bindings. + -- ----------------------------------------------------------------------------- @@ -71,7 +84,7 @@ coreSatPgm :: DynFlags -> [CoreBind] -> IO [CoreBind] coreSatPgm dflags binds = do showPass dflags "CoreSat" us <- mkSplitUniqSupply 's' - let new_binds = initUs_ us (coreSatBinds binds) + let new_binds = initUs_ us (coreSatTopBinds binds) endPass dflags "CoreSat" Opt_D_dump_sat new_binds coreSatExpr :: DynFlags -> CoreExpr -> IO CoreExpr @@ -80,66 +93,68 @@ coreSatExpr dflags expr us <- mkSplitUniqSupply 's' let new_expr = initUs_ us (coreSatAnExpr expr) dumpIfSet_dyn dflags Opt_D_dump_sat "Saturated/Normal form syntax:" - (ppr new_expr) + (ppr new_expr) return new_expr -- --------------------------------------------------------------------------- -- Dealing with bindings -- --------------------------------------------------------------------------- -data FloatingBind - = RecF [(Id, CoreExpr)] - | NonRecF Id - CoreExpr -- *Can* be a Lam - RhsDemand - [FloatingBind] - -coreSatBinds :: [CoreBind] -> UniqSM [CoreBind] -coreSatBinds [] = returnUs [] -coreSatBinds (b:bs) - = coreSatBind b `thenUs` \ float -> - coreSatBinds bs `thenUs` \ new_bs -> - case float of - NonRecF bndr rhs dem floats - -> ASSERT2( not (isStrictDem dem) && - not (isUnLiftedType (idType bndr)), - ppr b ) -- No top-level cases! - - mkBinds floats rhs `thenUs` \ new_rhs -> - returnUs (NonRec bndr new_rhs : new_bs) - -- Keep all the floats inside... - -- Some might be cases etc - -- We might want to revisit this decision - - RecF prs -> returnUs (Rec prs : new_bs) - -coreSatBind :: CoreBind -> UniqSM FloatingBind +data FloatingBind = FloatBind CoreBind + | FloatCase Id CoreExpr + +coreSatTopBinds :: [CoreBind] -> UniqSM [CoreBind] +-- Very careful to preserve the arity of top-level functions +coreSatTopBinds bs + = mapUs do_bind bs + where + do_bind (NonRec b r) = coreSatAnExpr r `thenUs` \ r' -> + returnUs (NonRec b r') + do_bind (Rec prs) = mapUs do_pair prs `thenUs` \ prs' -> + returnUs (Rec prs') + do_pair (b,r) = coreSatAnExpr r `thenUs` \ r' -> + returnUs (b, r') + + +coreSatBind :: CoreBind -> UniqSM (OrdList FloatingBind) +-- Used for non-top-level bindings +-- We return a *list* of bindings because we may start with +-- x* = f (g y) +-- where x is demanded, in which case we want to finish with +-- a = g y +-- x* = f a +-- And then x will actually end up case-bound + coreSatBind (NonRec binder rhs) - = coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) -> - returnUs (NonRecF binder new_rhs (bdrDem binder) floats) + = coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) -> + mkNonRec binder new_rhs (bdrDem binder) floats + -- NB: if there are any lambdas at the top of the RHS, + -- the floats will be empty, so the arity won't be affected + coreSatBind (Rec pairs) - = mapUs do_rhs pairs `thenUs` \ new_rhss -> - returnUs (RecF (binders `zip` new_rhss)) + = mapUs do_rhs pairs `thenUs` \ new_pairs -> + returnUs (unitOL (FloatBind (Rec new_pairs))) where - binders = map fst pairs - do_rhs (bndr,rhs) = - coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) -> - mkBinds floats new_rhs `thenUs` \ new_rhs' -> - -- NB: new_rhs' might still be a Lam (and we want that) - returnUs new_rhs' + do_rhs (bndr,rhs) = coreSatAnExpr rhs `thenUs` \ new_rhs' -> + returnUs (bndr,new_rhs') + -- --------------------------------------------------------------------------- -- Making arguments atomic (function args & constructor args) -- --------------------------------------------------------------------------- -- This is where we arrange that a non-trivial argument is let-bound -coreSatArg :: CoreArg -> RhsDemand -> UniqSM ([FloatingBind], CoreArg) +coreSatArg :: CoreArg -> RhsDemand -> UniqSM (OrdList FloatingBind, CoreArg) coreSatArg arg dem = coreSatExprFloat arg `thenUs` \ (floats, arg') -> - if exprIsTrivial arg' + if needs_binding arg' then returnUs (floats, arg') else newVar (exprType arg') `thenUs` \ v -> - returnUs ([NonRecF v arg' dem floats], Var v) + mkNonRec v arg' dem floats `thenUs` \ floats' -> + returnUs (floats', Var v) + +needs_binding | opt_KeepStgTypes = exprIsAtom + | otherwise = exprIsTrivial -- --------------------------------------------------------------------------- -- Dealing with expressions @@ -151,7 +166,7 @@ coreSatAnExpr expr mkBinds floats expr -coreSatExprFloat :: CoreExpr -> UniqSM ([FloatingBind], CoreExpr) +coreSatExprFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr) -- If -- e ===> (bs, e') -- then @@ -162,31 +177,33 @@ coreSatExprFloat :: CoreExpr -> UniqSM ([FloatingBind], CoreExpr) coreSatExprFloat (Var v) = maybeSaturate v (Var v) 0 (idType v) `thenUs` \ app -> - returnUs ([], app) + returnUs (nilOL, app) coreSatExprFloat (Lit lit) - = returnUs ([], Lit lit) + = returnUs (nilOL, Lit lit) coreSatExprFloat (Let bind body) - = coreSatBind bind `thenUs` \ new_bind -> + = coreSatBind bind `thenUs` \ new_binds -> coreSatExprFloat body `thenUs` \ (floats, new_body) -> - returnUs (new_bind:floats, new_body) + returnUs (new_binds `appOL` floats, new_body) coreSatExprFloat (Note n@(SCC _) expr) = coreSatAnExpr expr `thenUs` \ expr -> deLam expr `thenUs` \ expr -> - returnUs ([], Note n expr) + returnUs (nilOL, Note n expr) coreSatExprFloat (Note other_note expr) = coreSatExprFloat expr `thenUs` \ (floats, expr) -> returnUs (floats, Note other_note expr) coreSatExprFloat expr@(Type _) - = returnUs ([], expr) + = returnUs (nilOL, expr) -coreSatExprFloat (Lam v e) - = coreSatAnExpr e `thenUs` \ e' -> - returnUs ([], Lam v e') +coreSatExprFloat expr@(Lam _ _) + = coreSatAnExpr body `thenUs` \ body' -> + returnUs (nilOL, mkLams bndrs body') + where + (bndrs,body) = collectBinders expr coreSatExprFloat (Case scrut bndr alts) = coreSatExprFloat scrut `thenUs` \ (floats, scrut) -> @@ -194,8 +211,8 @@ coreSatExprFloat (Case scrut bndr alts) returnUs (floats, Case scrut bndr alts) where sat_alt (con, bs, rhs) - = coreSatAnExpr rhs `thenUs` \ rhs -> - deLam rhs `thenUs` \ rhs -> + = coreSatAnExpr rhs `thenUs` \ rhs -> + deLam rhs `thenUs` \ rhs -> returnUs (con, bs, rhs) coreSatExprFloat expr@(App _ _) @@ -213,19 +230,19 @@ coreSatExprFloat expr@(App _ _) -- Deconstruct and rebuild the application, floating any non-atomic -- arguments to the outside. We collect the type of the expression, - -- the head of the applicaiton, and the number of actual value arguments, + -- the head of the application, and the number of actual value arguments, -- all of which are used to possibly saturate this application if it -- has a constructor or primop at the head. collect_args :: CoreExpr - -> Int -- current app depth - -> UniqSM (CoreExpr, -- the rebuilt expression - (CoreExpr,Int), -- the head of the application, + -> Int -- current app depth + -> UniqSM (CoreExpr, -- the rebuilt expression + (CoreExpr,Int), -- the head of the application, -- and no. of args it was applied to - Type, -- type of the whole expr - [FloatingBind], -- any floats we pulled out - [Demand]) -- remaining argument demands + Type, -- type of the whole expr + OrdList FloatingBind, -- any floats we pulled out + [Demand]) -- remaining argument demands collect_args (App fun arg@(Type arg_ty)) depth = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) -> @@ -241,10 +258,10 @@ coreSatExprFloat expr@(App _ _) splitFunTy_maybe fun_ty in coreSatArg arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') -> - returnUs (App fun' arg', hd, res_ty, fs ++ floats, ss_rest) + returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest) collect_args (Var v) depth - = returnUs (Var v, (Var v, depth), idType v, [], stricts) + = returnUs (Var v, (Var v, depth), idType v, nilOL, stricts) where stricts = case idStrictness v of StrictnessInfo demands _ @@ -268,11 +285,12 @@ coreSatExprFloat expr@(App _ _) -- non-variable fun, better let-bind it collect_args fun depth - = newVar ty `thenUs` \ fn_id -> - coreSatExprFloat fun `thenUs` \ (fun_floats, fun) -> - returnUs (Var fn_id, (Var fn_id, depth), ty, - [NonRecF fn_id fun onceDem fun_floats], []) - where ty = exprType fun + = coreSatExprFloat fun `thenUs` \ (fun_floats, fun) -> + newVar ty `thenUs` \ fn_id -> + mkNonRec fn_id fun onceDem fun_floats `thenUs` \ floats -> + returnUs (Var fn_id, (Var fn_id, depth), ty, floats, []) + where + ty = exprType fun ignore_note InlineCall = True ignore_note InlineMe = True @@ -313,132 +331,80 @@ maybeSaturate fn expr n_args ty returnUs (etaExpand excess_arity us expr ty) -- --------------------------------------------------------------------------- --- Eliminate Lam as a non-rhs (STG doesn't have such a thing) +-- Precipitating the floating bindings -- --------------------------------------------------------------------------- -deLam (Note n e) - = deLam e `thenUs` \ e -> - returnUs (Note n e) - - -- types will all disappear, so that's ok -deLam (Lam x e) | isTyVar x - = deLam e `thenUs` \ e -> - returnUs (Lam x e) - -deLam expr@(Lam _ _) - -- Try for eta reduction - | Just e <- eta body - = returnUs e - - -- Eta failed, so let-bind the lambda - | otherwise - = newVar (exprType expr) `thenUs` \ fn -> - returnUs (Let (NonRec fn expr) (Var fn)) - +-- mkNonrec is used for local bindings only, not top level +mkNonRec bndr rhs dem floats + | isUnLiftedType bndr_rep_ty + || isStrictDem dem && not (exprIsValue rhs) + = ASSERT( not (isUnboxedTupleType bndr_rep_ty) ) + returnUs (floats `snocOL` FloatCase bndr rhs) where - (bndrs, body) = collectBinders expr - - eta expr@(App _ _) - | ok_to_eta_reduce f && - n_remaining >= 0 && - and (zipWith ok bndrs last_args) && - not (any (`elemVarSet` fvs_remaining) bndrs) - = Just remaining_expr - where - (f, args) = collectArgs expr - remaining_expr = mkApps f remaining_args - fvs_remaining = exprFreeVars remaining_expr - (remaining_args, last_args) = splitAt n_remaining args - n_remaining = length args - length bndrs - - ok bndr (Var arg) = bndr == arg - ok bndr other = False - - -- we can't eta reduce something which must be saturated. - ok_to_eta_reduce (Var f) - = case idFlavour f of - PrimOpId op -> False - DataConId dc -> False - other -> True - ok_to_eta_reduce _ = False --safe. ToDo: generalise - - eta (Let bind@(NonRec b r) body) - | not (any (`elemVarSet` fvs) bndrs) - = case eta body of - Just e -> Just (Let bind e) - Nothing -> Nothing - where fvs = exprFreeVars r + bndr_rep_ty = repType (idType bndr) - eta _ = Nothing +mkNonRec bndr rhs dem floats + = mkBinds floats rhs `thenUs` \ rhs' -> + returnUs (unitOL (FloatBind (NonRec bndr rhs'))) -deLam expr = returnUs expr +mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr +mkBinds binds body + | isNilOL binds = returnUs body + | otherwise = deLam body `thenUs` \ body' -> + returnUs (foldOL mk_bind body' binds) + where + mk_bind (FloatCase bndr rhs) body = Case rhs bndr [(DEFAULT, [], body)] + mk_bind (FloatBind bind) body = Let bind body -- --------------------------------------------------------------------------- --- Precipitating the floating bindings +-- Eliminate Lam as a non-rhs (STG doesn't have such a thing) +-- We arrange that they only show up as the RHS of a let(rec) -- --------------------------------------------------------------------------- -mkBinds :: [FloatingBind] -> CoreExpr -> UniqSM CoreExpr -mkBinds [] body = returnUs body -mkBinds (b:bs) body - = deLam body `thenUs` \ body' -> - go (b:bs) body' +deLam :: CoreExpr -> UniqSM CoreExpr +-- Remove top level lambdas by let-bindinig +deLam expr + | null bndrs = returnUs expr + | otherwise = case tryEta bndrs body of + Just no_lam_result -> returnUs no_lam_result + Nothing -> newVar (exprType expr) `thenUs` \ fn -> + returnUs (Let (NonRec fn expr) (Var fn)) where - go [] body = returnUs body - go (b:bs) body = go bs body `thenUs` \ body' -> - mkBind b body' - --- body can't be Lam -mkBind (RecF prs) body = returnUs (Let (Rec prs) body) - -mkBind (NonRecF bndr rhs dem floats) body -#ifdef DEBUG - -- We shouldn't get let or case of the form v=w - = if exprIsTrivial rhs - then pprTrace "mkBind" (ppr bndr <+> ppr rhs) - (mk_let bndr rhs dem floats body) - else mk_let bndr rhs dem floats body - -mk_let bndr rhs dem floats body -#endif - | isUnLiftedType bndr_rep_ty - = ASSERT( not (isUnboxedTupleType bndr_rep_ty) ) - mkBinds floats (Case rhs bndr [(DEFAULT, [], body)]) - - | is_whnf - = if is_strict then - -- Strict let with WHNF rhs - mkBinds floats $ - Let (NonRec bndr rhs) body - else - -- Lazy let with WHNF rhs; float until we find a strict binding - let - (floats_out, floats_in) = splitFloats floats - in - mkBinds floats_in rhs `thenUs` \ new_rhs -> - mkBinds floats_out $ - Let (NonRec bndr new_rhs) body - - | otherwise -- Not WHNF - = if is_strict then - -- Strict let with non-WHNF rhs - mkBinds floats (Case rhs bndr [(DEFAULT, [], body)]) - else - -- Lazy let with non-WHNF rhs, so keep the floats in the RHS - mkBinds floats rhs `thenUs` \ new_rhs -> - returnUs (Let (NonRec bndr new_rhs) body) - + (bndrs,body) = collectBinders expr + +tryEta bndrs expr@(App _ _) + | ok_to_eta_reduce f && + n_remaining >= 0 && + and (zipWith ok bndrs last_args) && + not (any (`elemVarSet` fvs_remaining) bndrs) + = Just remaining_expr where - bndr_rep_ty = repType (idType bndr) - is_strict = isStrictDem dem - is_whnf = exprIsValue rhs + (f, args) = collectArgs expr + remaining_expr = mkApps f remaining_args + fvs_remaining = exprFreeVars remaining_expr + (remaining_args, last_args) = splitAt n_remaining args + n_remaining = length args - length bndrs -splitFloats fs@(NonRecF _ _ dem _ : _) - | isStrictDem dem = ([], fs) + ok bndr (Var arg) = bndr == arg + ok bndr other = False -splitFloats (f : fs) = case splitFloats fs of - (fs_out, fs_in) -> (f : fs_out, fs_in) + -- we can't eta reduce something which must be saturated. + ok_to_eta_reduce (Var f) + = case idFlavour f of + PrimOpId op -> False + DataConId dc -> False + other -> True + ok_to_eta_reduce _ = False --safe. ToDo: generalise + +tryEta bndrs (Let bind@(NonRec b r) body) + | not (any (`elemVarSet` fvs) bndrs) + = case tryEta bndrs body of + Just e -> Just (Let bind e) + Nothing -> Nothing + where + fvs = exprFreeVars r -splitFloats [] = ([], []) +tryEta bndrs _ = Nothing -- ----------------------------------------------------------------------------- -- Demands diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 78230bc..baae2ba 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -14,7 +14,7 @@ module CoreUtils ( exprType, coreAltsType, exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsValue,exprOkForSpeculation, exprIsBig, - exprIsConApp_maybe, + exprIsConApp_maybe, exprIsAtom, idAppIsBottom, idAppIsCheap, exprArity, @@ -266,6 +266,15 @@ exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e exprIsTrivial (Note _ e) = exprIsTrivial e exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body exprIsTrivial other = False + +exprIsAtom :: CoreExpr -> Bool +-- Used to decide whether to let-binding an STG argument +-- when compiling to ILX => type applications are not allowed +exprIsAtom (Var v) = True -- primOpIsDupable? +exprIsAtom (Lit lit) = True +exprIsAtom (Type ty) = True +exprIsAtom (Note _ e) = exprIsAtom e +exprIsAtom other = False \end{code} diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index d438189..3e6d0bf 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -52,6 +52,7 @@ module CmdLineOpts ( opt_Parallel, opt_SMP, opt_NoMonomorphismRestriction, + opt_KeepStgTypes, -- optimisation opts opt_NoMethodSharing, @@ -236,6 +237,7 @@ data DynFlag | Opt_D_dump_stranal | Opt_D_dump_tc | Opt_D_dump_types + | Opt_D_dump_tc_trace | Opt_D_dump_rules | Opt_D_dump_usagesp | Opt_D_dump_cse @@ -450,7 +452,7 @@ opt_UnboxStrictFields = lookUp SLIT("-funbox-strict-fields") {- The optional '-inpackage=P' flag tells what package we are compiling this module for. - The Prelude, for example is compiled with '-package prelude' + The Prelude, for example is compiled with '-inpackage prelude' -} opt_InPackage = case lookup_str "-inpackage=" of Just p -> _PK_ p @@ -466,6 +468,7 @@ opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas") opt_NoHiCheck = lookUp SLIT("-fno-hi-version-check") opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing") opt_OmitInterfacePragmas = lookUp SLIT("-fomit-interface-pragmas") +opt_KeepStgTypes = lookUp SLIT("-fkeep-stg-types") -- Simplifier switches opt_SimplNoPreInlining = lookUp SLIT("-fno-pre-inlining") @@ -532,6 +535,7 @@ isStaticHscFlag f = "fno-method-sharing", "fno-monomorphism-restriction", "fomit-interface-pragmas", + "fkeep-stg-types", "fno-pre-inlining", "fdo-eta-reduction", "fdo-lambda-eta-expansion", diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index ee0dd3f..2217126 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -31,7 +31,7 @@ import SrcLoc ( mkSrcLoc ) import Rename ( checkOldIface, renameModule, closeIfaceDecls ) import Rules ( emptyRuleBase ) import PrelInfo ( wiredInThingEnv, wiredInThings ) -import PrelNames ( knownKeyNames ) +import PrelNames ( vanillaSyntaxMap, knownKeyNames ) import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails, writeIface, pprIface ) import TcModule @@ -157,7 +157,7 @@ hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch -- TYPECHECK maybe_tc_result <- typecheckModule dflags pcs_cl hst - old_iface alwaysQualify cl_hs_decls + old_iface alwaysQualify (vanillaSyntaxMap, cl_hs_decls) False{-don't check for Main.main-}; case maybe_tc_result of { Nothing -> return (HscFail pcs_cl); @@ -248,10 +248,13 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch ------------------- -- CONVERT TO STG and COMPLETE CODE GENERATION ------------------- + -- Do saturation and convert to A-normal form + ; saturated <- coreSatPgm dflags tidy_binds + ; (maybe_stub_h_filename, maybe_stub_c_filename, maybe_bcos) <- restOfCodeGeneration dflags toInterp this_mod (map ideclName (hsModuleImports rdr_module)) - foreign_stuff env_tc tidy_binds + foreign_stuff env_tc saturated hit (pcs_PIT pcs_simpl) -- and the answer is ... @@ -318,13 +321,9 @@ simplThenTidy dflags pcs hst this_mod dont_discard binds rules (simplified, orphan_rules) <- core2core dflags pcs hst dont_discard binds rules - -- Do saturation and convert to A-normal form - -- NOTE: subsequent passes may not transform the syntax, only annotate it - saturated <- coreSatPgm dflags simplified - -- Do the final tidy-up (pcs', tidy_binds, tidy_orphan_rules) - <- tidyCorePgm dflags this_mod pcs saturated orphan_rules + <- tidyCorePgm dflags this_mod pcs simplified orphan_rules return (pcs', tidy_binds, tidy_orphan_rules) @@ -432,7 +431,7 @@ hscExpr dflags wrap_io hst hit pcs0 this_module expr -- Typecheck it maybe_tc_return - <- typecheckExpr dflags wrap_io pcs1 hst print_unqual this_module rn_expr; + <- typecheckExpr dflags wrap_io syn_map pcs1 hst print_unqual this_module rn_expr; case maybe_tc_return of { Nothing -> return ({-WAS:pcs1-} pcs0, Nothing); Just (pcs2, tc_expr, ty) -> do diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index da7f0cb..9bad7a9 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -20,6 +20,7 @@ import StgSyn import Type import TyCon ( isAlgTyCon ) import Id +import Var ( Var ) import IdInfo import DataCon import CostCentre ( noCCS ) @@ -30,14 +31,14 @@ import IdInfo ( OccInfo(..) ) import PrimOp ( PrimOp(..), ccallMayGC ) import TysPrim ( foreignObjPrimTyCon ) import Maybes ( maybeToBool, orElse ) -import Name ( getOccName ) +import Name ( getOccName, isExternallyVisibleName ) import Module ( Module ) import OccName ( occNameUserString ) import BasicTypes ( TopLevelFlag(..), isNotTopLevel ) -import CmdLineOpts ( DynFlags ) +import CmdLineOpts ( DynFlags, opt_KeepStgTypes ) import Outputable -infixr 9 `thenLne`, `thenLne_` +infixr 9 `thenLne` \end{code} %************************************************************************ @@ -160,37 +161,32 @@ coreToStgRhs coreToStgRhs scope_fv_info top (binder, rhs) = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) -> - case new_rhs of - - StgLam _ bndrs body - -> let binder_info = lookupFVInfo scope_fv_info binder - in returnLne (StgRhsClosure noCCS - binder_info - noSRT - (getFVs rhs_fvs) - ReEntrant - bndrs - body, - rhs_fvs, rhs_escs) + returnLne (mkStgRhs top rhs_fvs binder_info new_rhs, + rhs_fvs, rhs_escs) + where + binder_info = lookupFVInfo scope_fv_info binder + +mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo + -> StgExpr -> StgRhs + +mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body) + = StgRhsClosure noCCS binder_info noSRT + (getFVs rhs_fvs) + ReEntrant + bndrs body - StgConApp con args - | isNotTopLevel top || not (isDllConApp con args) - -> returnLne (StgRhsCon noCCS con args, rhs_fvs, rhs_escs) - - _other_expr - -> let binder_info = lookupFVInfo scope_fv_info binder - in returnLne (StgRhsClosure noCCS - binder_info - noSRT - (getFVs rhs_fvs) - (updatable [] new_rhs) - [] - new_rhs, - rhs_fvs, rhs_escs - ) - -updatable args body | null args && isPAP body = ReEntrant - | otherwise = Updatable +mkStgRhs top rhs_fvs binder_info (StgConApp con args) + | isNotTopLevel top || not (isDllConApp con args) + = StgRhsCon noCCS con args + +mkStgRhs top rhs_fvs binder_info rhs + = StgRhsClosure noCCS binder_info noSRT + (getFVs rhs_fvs) + (updatable [] rhs) + [] rhs + where + updatable args body | null args && isPAP body = ReEntrant + | otherwise = Updatable {- ToDo: upd = if isOnceDem dem then (if isNotTop toplev @@ -233,41 +229,14 @@ any top-level PAPs. \begin{code} isPAP (StgApp f args) = idArity f > length args isPAP _ = False +\end{code} --- --------------------------------------------------------------------------- --- Atoms --- --------------------------------------------------------------------------- - -coreToStgAtoms :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo) -coreToStgAtoms atoms - = let val_atoms = filter isValArg atoms in - mapAndUnzipLne coreToStgAtom val_atoms `thenLne` \ (args', fvs_lists) -> - returnLne (args', unionFVInfos fvs_lists) - where - coreToStgAtom e - = coreToStgExpr e `thenLne` \ (expr, fvs, escs) -> - case expr of - StgApp v [] -> returnLne (StgVarArg v, fvs) - StgConApp con [] -> returnLne (StgVarArg (dataConWrapId con), fvs) - StgLit lit -> returnLne (StgLitArg lit, fvs) - _ -> pprPanic "coreToStgAtom" (ppr expr) -- --------------------------------------------------------------------------- -- Expressions -- --------------------------------------------------------------------------- -{- -@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. -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} coreToStgExpr :: CoreExpr -> LneM (StgExpr, -- Decorated STG expr @@ -286,19 +255,17 @@ on these components, but it in turn is not scrutinised as the basis for any decisions. Hence no black holes. \begin{code} -coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet) - -coreToStgExpr (Var v) - = coreToStgApp Nothing v [] +coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet) +coreToStgExpr (Var v) = coreToStgApp Nothing v [] coreToStgExpr expr@(App _ _) - = let (f, args) = myCollectArgs expr - in - coreToStgApp Nothing (shouldBeVar f) args + = coreToStgApp Nothing f args + where + (f, args) = myCollectArgs expr coreToStgExpr expr@(Lam _ _) = let (args, body) = myCollectBinders expr - args' = filter isId args + args' = filterStgBinders args in extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $ coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) -> @@ -322,15 +289,15 @@ coreToStgExpr (Note other_note expr) -- Cases require a little more real work. coreToStgExpr (Case scrut bndr alts) - = getVarsLiveInCont `thenLne` \ live_in_cont -> + = getVarsLiveInCont `thenLne` \ live_in_cont -> extendVarEnvLne [(bndr, CaseBound)] $ - vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) -> - lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs -> + vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) -> + lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs -> let -- determine whether the default binder is dead or not - bndr'= if (bndr `elementOfFVInfo` alts_fvs) - then bndr `setIdOccInfo` NoOccInfo - else bndr `setIdOccInfo` IAmDead + bndr' = bndr `setIdOccInfo` occ_info + occ_info | bndr `elementOfFVInfo` alts_fvs = NoOccInfo + | otherwise = IAmDead -- for a _ccall_GC_, some of the *arguments* need to live across the -- call (see findLiveArgs comments.), so we annotate them as being live @@ -338,7 +305,7 @@ coreToStgExpr (Case scrut bndr alts) mb_live_across_case = case scrut of -- ToDo: Notes? - e@(App _ _) | (Var v, args) <- myCollectArgs e, + e@(App _ _) | (v, args) <- myCollectArgs e, PrimOpId (CCallOp ccall) <- idFlavour v, ccallMayGC ccall -> Just (filterVarSet isForeignObjArg (exprFreeVars e)) @@ -409,7 +376,7 @@ coreToStgExpr (Case scrut bndr alts) vars_alg_alt (DataAlt con, binders, rhs) = let -- remove type variables - binders' = filter isId binders + binders' = filterStgBinders binders in extendVarEnvLne [(b, CaseBound) | b <- binders'] $ coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> @@ -431,7 +398,6 @@ coreToStgExpr (Case scrut bndr alts) vars_deflt (Just rhs) = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs) - \end{code} Lets not only take quite a bit of work, but this is where we convert @@ -511,7 +477,10 @@ mkStgPrimAlts ty alts deflt \end{code} -Applications: +-- --------------------------------------------------------------------------- +-- Applications +-- --------------------------------------------------------------------------- + \begin{code} coreToStgApp :: Maybe UpdateFlag -- Just upd <=> this application is @@ -524,43 +493,36 @@ coreToStgApp coreToStgApp maybe_thunk_body f args = getVarsLiveInCont `thenLne` \ live_in_cont -> - coreToStgAtoms args `thenLne` \ (args', args_fvs) -> + coreToStgArgs args `thenLne` \ (args', args_fvs) -> lookupVarLne f `thenLne` \ how_bound -> let n_args = length args not_letrec_bound = not (isLetrecBound how_bound) - f_arity = idArity f fun_fvs = singletonFVInfo f how_bound fun_occ + -- Mostly, the arity info of a function is in the fn's IdInfo + -- But new bindings introduced by CoreSat may not have no + -- arity info; it would do us no good anyway. For example: + -- 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 + fun_occ - | not_letrec_bound = NoStgBinderInfo -- Uninteresting variable - - -- Otherwise it is letrec bound; must have its arity - | n_args == 0 = stgFakeFunAppOcc -- Function Application - -- with no arguments. - -- used by the lambda lifter. - | f_arity > n_args = stgUnsatOcc -- Unsaturated - - | f_arity == n_args && - maybeToBool maybe_thunk_body -- Exactly saturated, - -- and rhs of thunk - = case maybe_thunk_body of - Just Updatable -> stgStdHeapOcc - Just SingleEntry -> stgNoUpdHeapOcc - other -> panic "coreToStgApp" - - | otherwise = stgNormalOcc - -- Record only that it occurs free - - myself = unitVarSet f - - fun_escs | not_letrec_bound = emptyVarSet - -- Only letrec-bound escapees are interesting - | f_arity == n_args = emptyVarSet - -- Function doesn't escape - | otherwise = myself - -- Inexact application; it does escape + | not_letrec_bound = noBinderInfo -- Uninteresting variable + | f_arity > 0 && f_arity <= n_args = stgSatOcc -- Saturated or over-saturated function call + | otherwise = stgUnsatOcc -- Unsaturated function or thunk + + 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 + -- saturated call doesn't escape + -- (let-no-escape applies to 'thunks' too) + + | otherwise = unitVarSet f -- Inexact application; it does escape -- At the moment of the call: @@ -573,12 +535,6 @@ coreToStgApp maybe_thunk_body f args -- continuation, but it does no harm to just union the -- two regardless. - -- XXX not needed? - -- live_at_call - -- = live_in_cont `unionVarSet` case how_bound of - -- LetrecBound _ lvs -> lvs `minusVarSet` myself - -- other -> emptyVarSet - app = case idFlavour f of DataConId dc -> StgConApp dc args' PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args)) @@ -594,6 +550,37 @@ coreToStgApp maybe_thunk_body f args ) + +-- --------------------------------------------------------------------------- +-- Argument lists +-- This is the guy that turns applications into A-normal form +-- --------------------------------------------------------------------------- + +coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo) +coreToStgArgs [] + = returnLne ([], emptyFVInfo) + +coreToStgArgs (Type ty : args) -- Type argument + = coreToStgArgs args `thenLne` \ (args', fvs) -> + if opt_KeepStgTypes then + returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty)) + else + returnLne (args', fvs) + +coreToStgArgs (arg : args) -- Non-type argument + = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) -> + coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) -> + let + fvs = args_fvs `unionFVInfo` arg_fvs + stg_arg = case arg' of + StgApp v [] -> StgVarArg v + StgConApp con [] -> StgVarArg (dataConWrapId con) + StgLit lit -> StgLitArg lit + _ -> pprPanic "coreToStgArgs" (ppr arg) + in + returnLne (stg_arg : stg_args, fvs) + + -- --------------------------------------------------------------------------- -- The magic for lets: -- --------------------------------------------------------------------------- @@ -663,7 +650,7 @@ coreToStgLet let_no_escape bind body let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of - -- this let(rec) + -- this let(rec) no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs) @@ -754,7 +741,7 @@ There's a lot of stuff to pass around, so we use this @LneM@ monad to help. All the stuff here is only passed {\em down}. \begin{code} -type LneM a = IdEnv HowBound +type LneM a = IdEnv HowBound -> StgLiveVars -- vars live in continuation -> a @@ -770,12 +757,16 @@ isLetrecBound (LetrecBound _ _) = True isLetrecBound other = False \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 -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 -in the LetrecBound constructor; x itself *is* included. +For a let(rec)-bound variable, x, we record StgLiveVars, the set of +variables that 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 in the LetrecBound constructor; x itself +*is* included. + +The set of live variables is guaranteed ot have no further let-no-escaped +variables in it. The std monad functions: \begin{code} @@ -783,7 +774,6 @@ initLne :: LneM a -> a initLne m = m emptyVarEnv emptyVarSet {-# INLINE thenLne #-} -{-# INLINE thenLne_ #-} {-# INLINE returnLne #-} returnLne :: a -> LneM a @@ -791,13 +781,7 @@ returnLne e env lvs_cont = e thenLne :: LneM a -> (a -> LneM b) -> LneM b thenLne m k env lvs_cont - = case (m env lvs_cont) of - m_result -> k m_result env lvs_cont - -thenLne_ :: LneM a -> LneM b -> LneM b -thenLne_ m k env lvs_cont - = case (m env lvs_cont) of - _ -> k env lvs_cont + = k (m env lvs_cont) env lvs_cont mapLne :: (a -> LneM b) -> [a] -> LneM [b] mapLne f [] = returnLne [] @@ -823,13 +807,14 @@ mapAndUnzip3Lne f (x:xs) returnLne (r1:rs1, r2:rs2, r3:rs3) fixLne :: (a -> LneM a) -> LneM a -fixLne expr env lvs_cont = result +fixLne expr env lvs_cont + = result where result = expr result env lvs_cont --- ^^^^^^ ------ ^^^^^^ \end{code} Functions specific to this monad: + \begin{code} getVarsLiveInCont :: LneM StgLiveVars getVarsLiveInCont env lvs_cont = lvs_cont @@ -878,18 +863,21 @@ lookupLiveVarsForSet fvs env lvs_cont %************************************************************************ \begin{code} -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 = IdSet +type FreeVarsInfo = VarEnv (Var, Bool, StgBinderInfo) + -- If f is mapped to noBinderInfo, 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 + -- noBinderInfo, since we aren't interested in their + -- occurence info. + -- + -- The Bool is True <=> the Id is top level letrec bound + -- + -- For ILX we track free var info for type variables too; + -- hence VarEnv not IdEnv + +type EscVarsSet = IdSet \end{code} \begin{code} @@ -901,6 +889,11 @@ singletonFVInfo id ImportBound info = emptyVarEnv singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info) singletonFVInfo id other info = unitVarEnv id (id, False, info) +tyvarFVInfo :: TyVarSet -> FreeVarsInfo +tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs + where + add tv fvs = extendVarEnv fvs tv (tv, False, noBinderInfo) + unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2 @@ -914,8 +907,12 @@ elementOfFVInfo :: Id -> FreeVarsInfo -> Bool elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id) lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo -lookupFVInfo fvs id = case lookupVarEnv fvs id of - Nothing -> NoStgBinderInfo +-- Find how the given Id is used. +-- Externally visible things may be used any old how +lookupFVInfo fvs id + | isExternallyVisibleName (idName id) = noBinderInfo + | otherwise = case lookupVarEnv fvs id of + Nothing -> noBinderInfo Just (_,_,info) -> info getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only @@ -930,13 +927,16 @@ plusFVInfo (id1,top1,info1) (id2,top2,info2) \end{code} Misc. - \begin{code} -shouldBeVar (Note _ e) = shouldBeVar e -shouldBeVar (Var v) = v -shouldBeVar e = pprPanic "shouldBeVar" (ppr e) +filterStgBinders :: [Var] -> [Var] +filterStgBinders bndrs + | opt_KeepStgTypes = bndrs + | otherwise = filter isId bndrs +\end{code} --- ignore all notes except SCC + +\begin{code} + -- Ignore all notes except SCC myCollectBinders expr = go [] expr where @@ -945,12 +945,15 @@ myCollectBinders expr go bs (Note _ e) = go bs e go bs e = (reverse bs, e) -myCollectArgs :: Expr b -> (Expr b, [Arg b]) +myCollectArgs :: CoreExpr -> (Id, [CoreArg]) + -- We assume that we only have variables + -- in the function position by now myCollectArgs expr = go expr [] where + go (Var v) as = (v, as) go (App f a) as = go f (a:as) - go (Note (SCC _) e) as = panic "CoreToStg.myCollectArgs" - go (Note n e) as = go e as - go e as = (e, as) + go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) + go (Note n e) as = go e as + go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) \end{code} diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 82477d5..e0efc58 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -18,9 +18,8 @@ module StgSyn ( UpdateFlag(..), isUpdatable, - StgBinderInfo(..), - stgArgOcc, stgUnsatOcc, stgStdHeapOcc, stgNoUpdHeapOcc, - stgNormalOcc, stgFakeFunAppOcc, + StgBinderInfo, + noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly, combineStgBinderInfo, -- a set of synonyms for the most common (only :-) parameterisation @@ -385,43 +384,26 @@ Here's the @StgBinderInfo@ type, and its combining op: \begin{code} data StgBinderInfo = NoStgBinderInfo - | StgBinderInfo - Bool -- At least one occurrence as an argument + | SatCallsOnly -- All occurrences are *saturated* *function* calls + -- This means we don't need to build an info table and + -- slow entry code for the thing + -- Thunks never get this value - Bool -- At least one occurrence in an unsaturated application +noBinderInfo = NoStgBinderInfo +stgUnsatOcc = NoStgBinderInfo +stgSatOcc = SatCallsOnly - Bool -- This thing (f) has at least occurrence of the form: - -- x = [..] \u [] -> f a b c - -- where the application is saturated - - Bool -- Ditto for non-updatable x. - - Bool -- At least one fake application occurrence, that is - -- an StgApp f args where args is an empty list - -- This is due to the fact that we do not have a - -- StgVar constructor. - -- Used by the lambda lifter. - -- True => "at least one unsat app" is True too - -stgArgOcc = StgBinderInfo True False False False False -stgUnsatOcc = StgBinderInfo False True False False False -stgStdHeapOcc = StgBinderInfo False False True False False -stgNoUpdHeapOcc = StgBinderInfo False False False True False -stgNormalOcc = StgBinderInfo False False False False False --- [Andre] can't think of a good name for the last one. -stgFakeFunAppOcc = StgBinderInfo False True False False True +satCallsOnly :: StgBinderInfo -> Bool +satCallsOnly SatCallsOnly = True +satCallsOnly NoStgBinderInfo = False combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo +combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly +combineStgBinderInfo info1 info2 = NoStgBinderInfo -combineStgBinderInfo NoStgBinderInfo info2 = info2 -combineStgBinderInfo info1 NoStgBinderInfo = info1 -combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1) - (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2) - = StgBinderInfo (arg1 || arg2) - (unsat1 || unsat2) - (std_heap1 || std_heap2) - (upd_heap1 || upd_heap2) - (fkap1 || fkap2) +-------------- +pp_binder_info NoStgBinderInfo = empty +pp_binder_info SatCallsOnly = ptext SLIT("sat-only") \end{code} %************************************************************************ @@ -764,21 +746,6 @@ pprStgRhs (StgRhsCon cc con args) pprMaybeSRT (NoSRT) = empty pprMaybeSRT srt = ptext SLIT(" srt: ") <> pprSRT srt - --------------- - -pp_binder_info NoStgBinderInfo = empty - --- cases so boring that we print nothing -pp_binder_info (StgBinderInfo True b c d e) = empty - --- general case -pp_binder_info (StgBinderInfo a b c d e) - = getPprStyle $ \ sty -> - if userStyle sty then - empty - else - parens (hsep (punctuate comma (map ppr [a,b,c,d,e]))) \end{code} Collect @IdInfo@ stuff that is most easily just snaffled straight -- 1.7.10.4