From: simonpj Date: Thu, 28 Jan 1999 09:20:07 +0000 (+0000) Subject: [project @ 1999-01-28 09:19:57 by simonpj] X-Git-Tag: Approximately_9120_patches~6671 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b70e2f9494a0206e5102a54de39c3c7f78554095;p=ghc-hetmet.git [project @ 1999-01-28 09:19:57 by simonpj] Always inline nullary constructors. This makes a difference in: case x ># y of r { True -> f1 r False -> f2 r } The code generator currently has difficulty binding "r" to the boolean result of the comparision (and the compiler crashes). This fix substitutes for r, thus: case x ># y of r { True -> f1 True False -> f2 False } Voila. --- diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index c73df67..e16a754 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -11,7 +11,6 @@ module IdInfo ( IdInfo, -- Abstract noIdInfo, - ppIdInfo, -- Arity ArityInfo(..), @@ -110,24 +109,6 @@ noIdInfo = IdInfo { } \end{code} -\begin{code} -ppIdInfo :: IdInfo -> SDoc -ppIdInfo (IdInfo {arityInfo = a, - demandInfo = d, - strictnessInfo = s, - updateInfo = u, - cafInfo = c - }) - = hsep [ - ppArityInfo a, - ppUpdateInfo u, - ppStrictnessInfo s, - ppr d, - ppCafInfo c - -- Inline pragma printed out with all binders; see PprCore.pprIdBndr - ] -\end{code} - %************************************************************************ %* * \subsection[arity-IdInfo]{Arity info about an @Id@} @@ -280,7 +261,6 @@ might have a specialisation where pi' :: Lift Int# is the specialised version of pi. - %************************************************************************ %* * \subsection[strictness-IdInfo]{Strictness info about an @Id@} diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 20b38e9..bfdd645 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -130,26 +130,6 @@ mkWiredInTyConName uniq mod fs tycon = Name { n_uniq = uniq, n_sort = WiredInTyCon mod tycon, n_occ = mkSrcOccFS tcName fs, n_prov = SystemProv } -fixupSystemName :: Name -> Module -> Provenance -> Name - -- Give the SystemProv name an appropriate provenance, and - -- perhaps change the Moulde too (so that its HiFlag is right) - -- There is a painful hack in that we want to push this - -- better name into an WiredInId/TyCon so that it prints - -- nicely in error messages -fixupSystemName name@(Name {n_sort = Global _}) mod' prov' - = name {n_sort = Global mod', n_prov = prov'} - -fixupSystemName name@(Name {n_sort = WiredInId _ id}) mod' prov' - = name' - where - name' = name {n_sort = WiredInId mod' id', n_prov = prov'} - id' = setIdName id name' - -fixupSystemName name@(Name {n_sort = WiredInTyCon _ tc}) mod' prov' - = name' - where - name' = name {n_sort = WiredInTyCon mod' tc', n_prov = prov'} - tc' = setTyConName tc name' --------------------------------------------------------------------- mkDerivedName :: (OccName -> OccName) diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index c2816f9..8a49dd5 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -19,7 +19,7 @@ module CoreUnfold ( noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate, isEvaldUnfolding, hasUnfolding, - smallEnoughToInline, couldBeSmallEnoughToInline, + smallEnoughToInline, unfoldAlways, couldBeSmallEnoughToInline, certainlySmallEnoughToInline, okToUnfoldInHiFile, @@ -132,6 +132,10 @@ data UnfoldingGuidance Int -- Scrutinee discount: the discount to substract if the thing is in -- a context (case (thing args) of ...), -- (where there are the right number of arguments.) + +unfoldAlways :: UnfoldingGuidance -> Bool +unfoldAlways UnfoldAlways = True +unfoldAlways other = False \end{code} \begin{code} diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 90bcf9e..38b8c70 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -619,7 +619,7 @@ substId clone_fn ty' = fullSubstTy ty_subst in_scope id_ty -- id2 has its SpecEnv zapped - -- It's filled in later by + -- It's filled in later by Simplify.simplPrags (id2,old2) | isEmptySpecEnv spec_env = (id1, True) | otherwise = (setIdSpecialisation id1 emptySpecEnv, False) spec_env = getIdSpecialisation id diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index ba81cee..3da38c2 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -19,10 +19,15 @@ import CoreSyn import CostCentre ( pprCostCentreCore ) import Id ( idType, idInfo, getInlinePragma, getIdDemandInfo, Id ) import Var ( isTyVar ) -import IdInfo ( ppIdInfo ) +import IdInfo ( IdInfo, + arityInfo, ppArityInfo, + demandInfo, updateInfo, ppUpdateInfo, specInfo, + strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo + ) import Const ( Con(..), DataCon ) import DataCon ( isTupleCon, isUnboxedTupleCon ) import PprType ( pprParendType, pprTyVarBndr ) +import SpecEnv ( specEnvToList ) import PprEnv import Outputable \end{code} @@ -96,9 +101,8 @@ initCoreEnv pbdr (Just ppr) -- tyvar occs (Just pprParendType) -- types - (Just pbdr) (Just pprIdBndr) -- value vars - -- The pprIdBndr part here is a temporary debugging aid - -- Revert to ppr if it gets tiresome + (Just pbdr) (Just ppr) -- value vars + -- Use pprIdBndr for this last one as a debugging device. \end{code} %************************************************************************ @@ -315,3 +319,39 @@ pprTypedBinder binder -- When printing any Id binder in debug mode, we print its inline pragma pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdDemandInfo id)) \end{code} + + +\begin{code} +ppIdInfo :: IdInfo -> SDoc +ppIdInfo info + = hsep [ + ppArityInfo a, + ppUpdateInfo u, + ppStrictnessInfo s, + ppr d, + ppCafInfo c, + ppSpecInfo p + -- Inline pragma printed out with all binders; see PprCore.pprIdBndr + ] + where + a = arityInfo info + d = demandInfo info + s = strictnessInfo info + u = updateInfo info + c = cafInfo info + p = specInfo info +\end{code} + +\begin{code} +ppSpecInfo spec_env + = vcat (map pp_item (specEnvToList spec_env)) + where + pp_item (tyvars, tys, rhs) = hsep [ptext SLIT("__P"), + hsep (map pprParendType tys), + ptext SLIT("->"), + ppr head] + where + (_, body) = collectBinders rhs + (head, _) = collectArgs body +\end{code} + diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index b792459..5307d23 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -347,8 +347,10 @@ ifaceId get_idinfo needed_ids is_rec id rhs unfold_ids `unionVarSet` spec_ids - worker_ids | has_worker = unitVarSet work_id - | otherwise = emptyVarSet + worker_ids | has_worker && interesting work_id = unitVarSet work_id + -- Conceivably, the worker might come from + -- another module + | otherwise = emptyVarSet spec_ids = foldr add emptyVarSet spec_list where @@ -360,8 +362,9 @@ ifaceId get_idinfo needed_ids is_rec id rhs find_fvs expr = free_vars where free_vars = exprSomeFreeVars interesting expr - interesting id = isId id && isLocallyDefined id && - not (omitIfaceSigForId id) + + interesting id = isId id && isLocallyDefined id && + not (omitIfaceSigForId id) \end{code} \begin{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 7bdc834..c9c477e 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -71,7 +71,8 @@ newImportedGlobalName mod occ Just name | isSystemName name -- A known-key name; fix the provenance and module -> getOmitQualFn `thenRn` \ omit_fn -> let - new_name = fixupSystemName name mod (NonLocalDef ImplicitImport (omit_fn name)) + new_name = setNameProvenance (setNameModule name mod) + (NonLocalDef ImplicitImport (omit_fn name)) new_cache = addToFM cache key new_name in setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 005b44c..7215d93 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -251,7 +251,7 @@ occAnalBind :: OccEnv [CoreBind]) occAnalBind env (NonRec binder rhs) body_usage - | isDeadBinder tagged_binder -- It's not mentioned + | not (binder `usedIn` body_usage) -- It's not mentioned = (body_usage, []) | otherwise -- It's mentioned in the body @@ -341,7 +341,7 @@ occAnalBind env (Rec pairs) body_usage -- Non-recursive SCC do_final_bind (AcyclicSCC ((bndr, rhs_usage, rhs'), _, _)) (body_usage, binds_so_far) - | isDeadBinder tagged_bndr + | not (bndr `usedIn` body_usage) = (body_usage, binds_so_far) -- Dead code | otherwise = (combined_usage, new_bind : binds_so_far) @@ -352,7 +352,7 @@ occAnalBind env (Rec pairs) body_usage -- Recursive SCC do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far) - | all isDeadBinder tagged_bndrs + | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage = (body_usage, binds_so_far) -- Dead code | otherwise = (combined_usage, final_bind:binds_so_far) @@ -735,6 +735,11 @@ emptyDetails = (emptyVarEnv :: UsageDetails) unitDetails id info = (unitVarEnv id info :: UsageDetails) +usedIn :: Id -> UsageDetails -> Bool +v `usedIn` details = isExported v + || v `elemVarEnv` details + || isSpecPragmaId v + tagBinders :: UsageDetails -- Of scope -> [Id] -- Binders -> (UsageDetails, -- Details with binders removed diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index a3a5caf..1ce168c 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -42,7 +42,7 @@ import Name ( isExported, isLocallyDefined ) import CoreSyn import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), mkUnfolding, smallEnoughToInline, - isEvaldUnfolding + isEvaldUnfolding, unfoldAlways ) import CoreUtils ( IdSubst, SubstCoreExpr(..), cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial, @@ -774,7 +774,8 @@ simplPrags old_bndr new_bndr new_rhs = returnSmpl (bndr_w_unfolding) | otherwise - = getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) -> + = pprTrace "simplPrags" (ppr old_bndr) $ + getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) -> let spec_env' = substSpecEnv ty_subst in_scope (subst_val id_subst) spec_env in @@ -893,28 +894,6 @@ okToInline :: SwitchChecker -- so we can inline if it occurs once, or is small okToInline sw_chkr in_scope id form guidance cont - | switchIsOn sw_chkr EssentialUnfoldingsOnly - = -#ifdef DEBUG - if opt_D_dump_inlinings then - pprTrace "Considering inlining" - (ppr id <+> vcat [text "essential inlinings only", - text "inline prag:" <+> ppr inline_prag, - text "ANSWER =" <+> if result then text "YES" else text "NO"]) - result - else -#endif - result - where - inline_prag = getInlinePragma id - result = idMustBeINLINEd id - -- If "essential_unfoldings_only" is true we do no inlinings at all, - -- EXCEPT for things that absolutely have to be done - -- (see comments with idMustBeINLINEd) - - -okToInline sw_chkr in_scope id form guidance cont - -- Essential unfoldings only not on = #ifdef DEBUG if opt_D_dump_inlinings then @@ -927,27 +906,35 @@ okToInline sw_chkr in_scope id form guidance cont text "result scrut" <+> ppr result_scrut, text "ANSWER =" <+> if result then text "YES" else text "NO"]) result - else + else #endif result where - result = case inline_prag of - IAmDead -> pprTrace "okToInline: dead" (ppr id) False - - IAmASpecPragmaId -> False - IMustNotBeINLINEd -> False - IAmALoopBreaker -> False - IMustBeINLINEd -> True - IWantToBeINLINEd -> True - - ICanSafelyBeINLINEd inside_lam one_branch - -> (small_enough || one_branch) && some_benefit && - (whnf || not_inside_lam) - - where - not_inside_lam = case inside_lam of {InsideLam -> False; other -> True} - - other -> whnf && small_enough && some_benefit + result = + case inline_prag of + IAmDead -> pprTrace "okToInline: dead" (ppr id) False + IAmASpecPragmaId -> False + IMustNotBeINLINEd -> False + IAmALoopBreaker -> False + IMustBeINLINEd -> True -- If "essential_unfoldings_only" is true we do no inlinings at all, + -- EXCEPT for things that absolutely have to be done + -- (see comments with idMustBeINLINEd) + IWantToBeINLINEd -> inlinings_enabled + ICanSafelyBeINLINEd inside_lam one_branch + -> inlinings_enabled && (unfold_always || consider_single inside_lam one_branch) + NoInlinePragInfo -> inlinings_enabled && (unfold_always || consider_multi) + + inlinings_enabled = not (switchIsOn sw_chkr EssentialUnfoldingsOnly) + unfold_always = unfoldAlways guidance + + -- Consider benefit for ICanSafelyBeINLINEd + consider_single inside_lam one_branch + = (small_enough || one_branch) && some_benefit && (whnf || not_inside_lam) + where + not_inside_lam = case inside_lam of {InsideLam -> False; other -> True} + + -- Consider benefit for NoInlinePragInfo + consider_multi = whnf && small_enough && some_benefit -- We could consider using exprIsCheap here, -- as in postInlineUnconditionally, but unlike the latter we wouldn't -- necessarily eliminate a thunk; and the "form" doesn't tell @@ -992,8 +979,7 @@ contIsInteresting (ArgOf _ _ _) = False contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont contIsInteresting (CoerceIt _ _ _ cont) = contIsInteresting cont --- Even a case with only a default case is a bit interesting; --- we may be able to eliminate it after inlining. +-- See notes below on why a case with only a DEFAULT case is not intersting -- contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False contIsInteresting _ = True @@ -1033,6 +1019,7 @@ applies when x is bound to a lambda expression. Hence contIsInteresting looks for case expressions with just a single default case. + %************************************************************************ %* * \subsection{The main rebuilder} @@ -1455,19 +1442,20 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont' handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT] simpl_alt (DEFAULT, _, rhs) - = modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $ + = -- In the default case we record the constructors that the + -- case-binder *can't* be. + -- We take advantage of any OtherCon info in the case scrutinee + modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $ simplExpr rhs cont' `thenSmpl` \ rhs' -> returnSmpl (DEFAULT, [], rhs') simpl_alt (con, vs, rhs) - = -- Deal with the case-bound variables + = -- Deal with the pattern-bound variables -- Mark the ones that are in ! positions in the data constructor -- as certainly-evaluated simplBinders (add_evals con vs) $ \ vs' -> -- Bind the case-binder to (Con args) - -- In the default case we record the constructors it *can't* be. - -- We take advantage of any OtherCon info in the case scrutinee let con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs') in