From b822aa0e9411a1909988c0367d342671806a0f75 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 30 Mar 2000 16:23:57 +0000 Subject: [PATCH] [project @ 2000-03-30 16:23:56 by simonpj] * Remove the unnecessary CPR parameter to mkUnfolding and friends * Make sure that even trivial wrappers have a __inline__ (this was causing lots of 'substWorker' DEBUG messages) * Nuke demand info when the unfolding is a value (see notes with IdInfo.setUnfoldingInfo) * Add an update-in-place test to the 'interesting context' predicate in SimplUtils. --- ghc/compiler/basicTypes/IdInfo.lhs | 16 +++++++++++++++- ghc/compiler/basicTypes/MkId.lhs | 6 +++--- ghc/compiler/coreSyn/CoreUnfold.lhs | 21 +++++---------------- ghc/compiler/rename/RnSource.lhs | 10 ++++------ ghc/compiler/simplCore/SimplUtils.lhs | 8 +++++--- ghc/compiler/simplCore/Simplify.lhs | 8 ++++---- ghc/compiler/stranal/WorkWrap.lhs | 7 ++++--- ghc/compiler/stranal/WwLib.lhs | 9 ++++++++- ghc/compiler/typecheck/TcIfaceSig.lhs | 4 ++-- 9 files changed, 50 insertions(+), 39 deletions(-) diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index e7056de..c94e81b 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -166,9 +166,23 @@ setOccInfo info oc = oc `seq` info { occInfo = oc } setStrictnessInfo info st = st `seq` info { strictnessInfo = st } -- Try to avoid spack leaks by seq'ing -setUnfoldingInfo info uf = info { unfoldingInfo = uf } +setUnfoldingInfo info uf + | isEvaldUnfolding uf && isStrict (demandInfo info) + -- If the unfolding is a value, the demand info may + -- go pear-shaped, so we nuke it. Example: + -- let x = (a,b) in + -- case x of (p,q) -> h p q x + -- Here x is certainly demanded. But after we've nuked + -- the case, we'll get just + -- let x = (a,b) in h a b x + -- and now x is not demanded (I'm assuming h is lazy) + -- This really happens. The solution here is a bit ad hoc... + = info { unfoldingInfo = uf, demandInfo = wwLazy } + + | otherwise -- We do *not* seq on the unfolding info, For some reason, doing so -- actually increases residency significantly. + = info { unfoldingInfo = uf } setUpdateInfo info ud = info { updateInfo = ud } setDemandInfo info dd = info { demandInfo = dd } diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 871b77d..c06c67c 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -229,7 +229,7 @@ mkDataConWrapId data_con work_id = dataConId data_con info = mkIdInfo (DataConWrapId data_con) - `setUnfoldingInfo` mkTopUnfolding cpr_info (mkInlineMe wrap_rhs) + `setUnfoldingInfo` mkTopUnfolding (mkInlineMe wrap_rhs) `setCprInfo` cpr_info -- The Cpr info can be important inside INLINE rhss, where the -- wrapper constructor isn't inlined @@ -369,7 +369,7 @@ mkRecordSelId tycon field_label `setCafInfo` NoCafRefs -- ToDo: consider adding further IdInfo - unfolding = mkTopUnfolding NoCPRInfo sel_rhs + unfolding = mkTopUnfolding sel_rhs [data_id] = mkTemplateLocals [data_ty] @@ -430,7 +430,7 @@ mkDictSelId name clas ty -- We no longer use 'must-inline' on record selectors. They'll -- inline like crazy if they scrutinise a constructor - unfolding = mkTopUnfolding NoCPRInfo rhs + unfolding = mkTopUnfolding rhs tyvars = classTyVars clas diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 80f9a06..35491cd 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -77,15 +77,15 @@ import GlaExts ( fromInt ) %************************************************************************ \begin{code} -mkTopUnfolding cpr_info expr = mkUnfolding True {- Top level -} cpr_info expr +mkTopUnfolding expr = mkUnfolding True {- Top level -} expr -mkUnfolding top_lvl cpr_info expr +mkUnfolding top_lvl expr = CoreUnfolding (occurAnalyseGlobalExpr expr) top_lvl (exprIsCheap expr) (exprIsValue expr) (exprIsBottom expr) - (calcUnfoldingGuidance opt_UF_CreationThreshold cpr_info expr) + (calcUnfoldingGuidance opt_UF_CreationThreshold expr) -- Sometimes during simplification, there's a large let-bound thing -- which has been substituted, and so is now dead; so 'expr' contains -- two copies of the thing while the occurrence-analysed expression doesn't @@ -120,10 +120,9 @@ instance Outputable UnfoldingGuidance where \begin{code} calcUnfoldingGuidance :: Int -- bomb out if size gets bigger than this - -> CprInfo -- CPR info for this RHS -> CoreExpr -- expression to look at -> UnfoldingGuidance -calcUnfoldingGuidance bOMB_OUT_SIZE cpr_info expr +calcUnfoldingGuidance bOMB_OUT_SIZE expr = case collect_val_bndrs expr of { (inline, val_binders, body) -> let n_val_binders = length val_binders @@ -135,16 +134,6 @@ calcUnfoldingGuidance bOMB_OUT_SIZE cpr_info expr -- so that INLINE things don't get inlined into entirely boring contexts, -- but no more. --- Experimental thing commented in for now --- max_inline_size = case cpr_info of --- NoCPRInfo -> n_val_binders + 2 --- ReturnsCPR -> n_val_binders + 1 - - -- However, the wrapper for a CPR'd function is particularly good to inline, - -- even in a boring context, because we may get to do update in place: - -- let x = case y of { I# y# -> I# (y# +# 1#) } - -- Hence the case on cpr_info - in case (sizeExpr bOMB_OUT_SIZE val_binders body) of @@ -437,7 +426,7 @@ Just the same as smallEnoughToInline, except that it has no actual arguments. \begin{code} couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool -couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold NoCPRInfo rhs of +couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold rhs of UnfoldNever -> False other -> True diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 982acda..abf4150 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -202,15 +202,13 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas (op_sigs, non_op_sigs) = partition isClassOpSig sigs (fix_sigs, non_sigs) = partition isFixitySig non_op_sigs in - checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` - mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs - `thenRn` \ (sigs', sig_fvs) -> - mapRn_ (unknownSigErr) non_sigs `thenRn_` + checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` + mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs `thenRn` \ (sigs', sig_fvs) -> + mapRn_ (unknownSigErr) non_sigs `thenRn_` let binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ] in - renameSigs False binders lookupOccRn fix_sigs - `thenRn` \ (fixs', fix_fvs) -> + renameSigs False binders lookupOccRn fix_sigs `thenRn` \ (fixs', fix_fvs) -> -- Check the methods checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_` diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 22d1357..f84278e 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -27,13 +27,13 @@ import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExp import Subst ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, lookupIdSubst ) import Id ( Id, idType, isId, idName, idOccInfo, idUnfolding, - idDemandInfo, mkId, idInfo + mkId, idInfo ) import IdInfo ( arityLowerBound, setOccInfo, vanillaIdInfo ) import Maybes ( maybeToBool, catMaybes ) import Name ( isLocalName, setNameUnique ) import SimplMonad -import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, +import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, repType, splitTyConApp_maybe, splitAlgTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys ) import DataCon ( dataConRepArity ) @@ -284,7 +284,9 @@ discardInline cont = cont -- small arity. But arity zero isn't good -- we share the single copy -- for that case, so no point in sharing. -canUpdateInPlace ty = case splitAlgTyConApp_maybe ty of +-- Note the repType: we want to look through newtypes for this purpose + +canUpdateInPlace ty = case splitAlgTyConApp_maybe (repType ty) of Just (_, _, [dc]) -> arity == 1 || arity == 2 where arity = dataConRepArity dc diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 9febaa7..8c08c66 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -551,12 +551,12 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside old_info = idInfo old_bndr new_bndr_info = substIdInfo subst old_info (idInfo new_bndr) `setArityInfo` ArityAtLeast (exprArity new_rhs) - `setUnfoldingInfo` mkUnfolding top_lvl (cprInfo old_info) new_rhs + `setUnfoldingInfo` mkUnfolding top_lvl new_rhs final_id = new_bndr `setIdInfo` new_bndr_info in - -- These seqs force the Ids, and hence the IdInfos, and hence any - -- inner substitutions + -- These seqs forces the Id, and hence its IdInfo, + -- and hence any inner substitutions final_id `seq` addLetBind final_id new_rhs $ modifyInScope new_bndr final_id thing_inside @@ -1395,7 +1395,7 @@ simplAlts zap_occ_info scrut_cons case_bndr' alts cont' -- Bind the case-binder to (con args) let - unfolding = mkUnfolding False NoCPRInfo (mkAltExpr con vs' inst_tys') + unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys') in modifyInScope case_bndr' (case_bndr' `setIdUnfolding` unfolding) $ simplExprC rhs cont' `thenSmpl` \ rhs' -> diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index b6d021a..92eaf08 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -14,11 +14,11 @@ import CmdLineOpts ( opt_UF_CreationThreshold , opt_D_verbose_core2core, opt_D_dump_worker_wrapper ) import CoreLint ( beginPass, endPass ) -import CoreUtils ( exprType, exprArity, exprEtaExpandArity, mkInlineMe ) +import CoreUtils ( exprType, exprArity, exprEtaExpandArity ) import DataCon ( DataCon ) import MkId ( mkWorkerId ) import Id ( Id, idType, idStrictness, setIdArityInfo, isOneShotLambda, - setIdStrictness, idDemandInfo, idInlinePragma, + setIdStrictness, idInlinePragma, setIdWorkerInfo, idCprInfo, setInlinePragma ) import VarSet import Type ( Type, isNewType, splitForAllTys, splitFunTys ) @@ -196,7 +196,7 @@ tryWW non_rec fn_id rhs -- twice, this test also prevents wrappers (which are INLINEd) -- from being re-done. -- - -- OUT OF DATE NOTE: + -- OUT OF DATE NOTE, kept for info: -- In this case we add an INLINE pragma to the RHS. Why? -- Because consider -- f = \x -> g x x @@ -237,6 +237,7 @@ tryWW non_rec fn_id rhs in returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) -- Worker first, because wrapper mentions it + -- Arrange to inline the wrapper unconditionally where fun_ty = idType fn_id arity = exprEtaExpandArity rhs diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index be6f333..1215078 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -235,8 +235,15 @@ mkWwBodies fun_ty arity demands res_bot one_shots cpr_info mkWWfixup cpr_res_ty work_dmds `thenUs` \ (final_work_dmds, wrap_fn_fixup, work_fn_fixup) -> returnUs (final_work_dmds, - mkInlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . wrap_fn_fixup . Var, + Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . wrap_fn_fixup . Var, work_fn_fixup . work_fn_str . work_fn_cpr . work_fn_args) + -- We use an INLINE unconditionally, even if the wrapper turns out to be + -- something trivial like + -- fw = ... + -- f = __inline__ (coerce T fw) + -- The point is to propagate the coerce to f's call sites, so even though + -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent + -- fw from being inlined into f's RHS where demands' = demands ++ repeat wwLazy one_shots' = one_shots ++ repeat False diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 57ff4c0..1778c8e 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -96,7 +96,7 @@ tcIdInfo unf_env in_scope_vars name ty info info_ins -- is never inspected; so the typecheck doesn't even happen unfold_info = case maybe_expr' of Nothing -> noUnfolding - Just expr' -> mkTopUnfolding (cprInfo info) expr' + Just expr' -> mkTopUnfolding expr' info1 = info `setUnfoldingInfo` unfold_info info2 = info1 `setInlinePragInfo` inline_prag in @@ -119,7 +119,7 @@ tcWorkerInfo unf_env ty info worker_name let -- Watch out! We can't pull on unf_env too eagerly! info' = case explicitLookupValue unf_env worker_name of - Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding cpr_info (wrap_fn worker_id) + Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id) `setWorkerInfo` HasWorker worker_id arity Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info -- 1.7.10.4