X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplVar.lhs;h=2cfaf9144f07c0c6a17b11a1d36b1e6fecc1a474;hb=967cc47f37cb93a5e2b6df7822c9a646f0428247;hp=4e4ef5582a2ce436ac061176ce3383c0c3615343;hpb=12899612693163154531da3285ec99c1c8ca2226;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index 4e4ef55..2cfaf91 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -2,44 +2,46 @@ % (c) The AQUA Project, Glasgow University, 1993-1996 % \section[SimplVar]{Simplifier stuff related to variables} - + \begin{code} -#include "HsVersions.h" - module SimplVar ( - completeVar + completeVar, + simplBinder, simplBinders, simplTyBinder, simplTyBinders ) where -IMP_Ubiq(){-uitous-} -IMPORT_DELOOPER(SmplLoop) ( simplExpr ) +#include "HsVersions.h" + +import {-# SOURCE #-} Simplify ( simplExpr ) -import CgCompInfo ( uNFOLDING_USE_THRESHOLD, - uNFOLDING_CON_DISCOUNT_WEIGHT - ) import CmdLineOpts ( switchIsOn, SimplifierSwitch(..) ) import CoreSyn -import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding(..), - FormSummary, +import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), + FormSummary, whnfOrBottom, okToInline, smallEnoughToInline ) -import BinderInfo ( BinderInfo, noBinderInfo, okToInline ) +import CoreUtils ( coreExprCc ) +import BinderInfo ( BinderInfo, noBinderInfo ) -import CostCentre ( CostCentre, noCostCentreAttached ) -import Id ( idType, getIdInfo, getIdUnfolding, getIdSpecialisation, - GenId{-instance Outputable-} +import CostCentre ( CostCentre, noCostCentreAttached, isCurrentCostCentre ) +import Id ( idType, getIdUnfolding, externallyVisibleId, + getIdSpecialisation, setIdSpecialisation, + idMustBeINLINEd, idHasNoFreeTyVars, + mkIdWithNewUniq, mkIdWithNewType, + IdEnv, lookupIdEnv, delOneFromIdEnv, elemIdEnv, isNullIdEnv, addOneToIdEnv ) -import SpecEnv ( SpecEnv, lookupSpecEnv ) -import IdInfo ( DeforestInfo(..) ) +import SpecEnv ( lookupSpecEnv, isEmptySpecEnv, emptySpecEnv ) +import OccurAnal ( occurAnalyseGlobalExpr ) import Literal ( isNoRepLit ) import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun ) -import PprStyle ( PprStyle(..) ) -import PprType ( GenType{-instance Outputable-} ) -import Pretty ( ppBesides, ppStr ) import SimplEnv import SimplMonad +import Type ( instantiateTy, mkTyVarTy ) import TyCon ( tyConFamilySize ) -import Type ( isPrimType, getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts ) -import Util ( pprTrace, assertPanic, panic ) +import TyVar ( TyVar, cloneTyVar, + isEmptyTyVarEnv, addToTyVarEnv, delFromTyVarEnv, + addOneToTyVarSet, elementOfTyVarSet + ) import Maybes ( maybeToBool ) +import Outputable \end{code} %************************************************************************ @@ -51,80 +53,100 @@ import Maybes ( maybeToBool ) This where all the heavy-duty unfolding stuff comes into its own. \begin{code} -completeVar env var args +completeVar env inline_call var args result_ty | maybeToBool maybe_magic_result = tick MagicUnfold `thenSmpl_` magic_result - | not do_deforest && - maybeToBool maybe_unfolding_info && - (always_inline || (ok_to_inline && not essential_unfoldings_only)) && - costCentreOk (getEnclosingCC env) (getEnclosingCC unfold_env) - = tick UnfoldingDone `thenSmpl_` - simplExpr unfold_env unf_template args - + -- Look for existing specialisations before + -- trying inlining | maybeToBool maybe_specialisation = tick SpecialisationDone `thenSmpl_` - simplExpr (extendTyEnvList env spec_bindings) - spec_template - (map TyArg leftover_ty_args ++ remaining_args) + simplExpr (bindTyVars env spec_bindings) + (occurAnalyseGlobalExpr spec_template) + remaining_args + result_ty + + + -- Look for an unfolding. There's a binding for the + -- thing, but perhaps we want to inline it anyway + | has_unfolding + && (idMustBeINLINEd var || + (not essential_unfoldings_only + -- 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) + && (inline_call || ok_to_inline) + && costCentreOk (getEnclosingCC env) (coreExprCc unf_template))) + = +{- + pprTrace "Unfolding" (ppr var) $ + simplCount `thenSmpl` \ n -> + (if n > 1000 then + pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr var]) + else + id + ) + (if n>4000 then + returnSmpl (mkGenApp (Var var) args) + else +-} + tickUnfold var `thenSmpl_` + simplExpr unf_env unf_template args result_ty + + | inline_call -- There was an InlineCall note, but we didn't inline! + = returnSmpl (mkGenApp (Note InlineCall (Var var')) args) | otherwise - = returnSmpl (mkGenApp (Var var) args) + = returnSmpl (mkGenApp (Var var') args) where - unfolding_from_id = getIdUnfolding var + (var', occ_info, unfolding) = case lookupOutIdEnv env var of + Just stuff -> stuff + Nothing -> (var, noBinderInfo, getIdUnfolding var) ---------- Magic unfolding stuff - maybe_magic_result = case unfolding_from_id of + maybe_magic_result = case unfolding of MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn env args other -> Nothing - (Just magic_result) = maybe_magic_result + Just magic_result = maybe_magic_result ---------- Unfolding stuff - maybe_unfolding_info - = case (lookupOutIdEnv env var, unfolding_from_id) of - (Just (_, occ_info, OutUnfolding enc_cc unf), _) - -> Just (occ_info, setEnclosingCC env enc_cc, unf) - (Just (_, occ_info, InUnfolding env_unf unf), _) - -> Just (occ_info, combineSimplEnv env env_unf, unf) - (_, CoreUnfolding unf) - -> Just (noBinderInfo, env, unf) + has_unfolding = case unfolding of + CoreUnfolding _ _ _ -> True + other -> False - other -> Nothing + CoreUnfolding form guidance unf_template = unfolding + unf_env = zapSubstEnvs env + -- The template is already simplified, so don't re-substitute. + -- This is VITAL. Consider + -- let x = e in + -- let y = \z -> ...x... in + -- \ x -> ...y... + -- We'll clone the inner \x, adding x->x' in the id_subst + -- Then when we inline y, we must *not* replace x by x' in + -- the inlined copy!! - Just (occ_info, unfold_env, simple_unfolding) = maybe_unfolding_info - SimpleUnfolding form guidance unf_template = simple_unfolding - - ---------- Specialisation stuff + ---------- Specialisation stuff (ty_args, remaining_args) = initialTyArgs args - maybe_specialisation = lookupSpecEnv (getIdSpecialisation var) ty_args - (Just (spec_template, (spec_bindings, leftover_ty_args))) = maybe_specialisation + maybe_specialisation = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args + Just (spec_bindings, spec_template) = maybe_specialisation ---------- Switches sw_chkr = getSwitchChecker env essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly - always_inline = case guidance of {UnfoldAlways -> True; other -> False} - ok_to_inline = okToInline form - occ_info - small_enough - small_enough = smallEnoughToInline con_disc unf_thresh arg_evals guidance - arg_evals = [is_evald arg | arg <- args, isValArg arg] - - is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v) + is_case_scrutinee = switchIsOn sw_chkr SimplCaseScrutinee + ok_to_inline = okToInline var (whnfOrBottom form) small_enough occ_info + small_enough = smallEnoughToInline var arg_evals is_case_scrutinee guidance + arg_evals = [is_evald arg | arg <- args, isValArg arg] + + is_evald (VarArg v) = isEvaluated (lookupUnfolding env v) is_evald (LitArg l) = True - con_disc = getSimplIntSwitch sw_chkr SimplUnfoldingConDiscount - unf_thresh = getSimplIntSwitch sw_chkr SimplUnfoldingUseThreshold -#if OMIT_DEFORESTER - do_deforest = False -#else - do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False } -#endif -- costCentreOk checks that it's ok to inline this thing @@ -133,10 +155,132 @@ completeVar env var args -- f x = let y = E in -- scc "foo" (...y...) -- --- Here y has a subsumed cost centre, and we can't inline it inside "foo", +-- Here y has a "current cost centre", and we can't inline it inside "foo", -- regardless of whether E is a WHNF or not. costCentreOk cc_encl cc_rhs - = noCostCentreAttached cc_encl || not (noCostCentreAttached cc_rhs) + = isCurrentCostCentre cc_encl || not (noCostCentreAttached cc_rhs) \end{code} + +%************************************************************************ +%* * +\section{Dealing with a single binder} +%* * +%************************************************************************ + +When we hit a binder we may need to + (a) apply the the type envt (if non-empty) to its type + (b) apply the type envt and id envt to its SpecEnv (if it has one) + (c) give it a new unique to avoid name clashes + +\begin{code} +simplBinder :: SimplEnv -> InBinder -> SmplM (SimplEnv, OutId) +simplBinder env (id, occ_info) + | no_need_to_clone -- Not in scope (or cloning disabled), so no need to clone + && empty_ty_subst -- No type substitution to do inside the Id + && isNullIdEnv id_subst -- No id substitution to do inside the Id + = let + env' = setIdEnv env (new_in_scope_ids id, id_subst) + in + returnSmpl (env', id) + + | otherwise + = +#if DEBUG + -- I reckon the empty-env thing should catch + -- most no-free-tyvars things, so this test should be redundant +-- (if idHasNoFreeTyVars id then pprTrace "applyEnvsToId" (ppr id) else (\x -> x)) +#endif + (let + -- id1 has its type zapped + id1 | empty_ty_subst = id + | otherwise = mkIdWithNewType id ty' + -- id2 has its SpecEnv zapped (see comment inside Simplify.completeBind) + id2 | empty_spec_env = id1 + | otherwise = setIdSpecialisation id1 emptySpecEnv + in + if no_need_to_clone then + -- No need to clone, but we *must* zap any current substitution + -- for the variable. For example: + -- (\x.e) with id_subst = [x |-> e'] + -- Here we must simply zap the substitution for x + let + new_id_subst = delOneFromIdEnv id_subst id + new_env = setIdEnv env (new_in_scope_ids id2, new_id_subst) + in + returnSmpl (new_env, id2) + else + -- Must clone + getUniqueSmpl `thenSmpl` \ uniq -> + let + id3 = mkIdWithNewUniq id2 uniq + new_env = setIdEnv env (new_in_scope_ids id3, + addOneToIdEnv id_subst id (SubstVar id3)) + in + returnSmpl (new_env, id3) + ) + where + ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getEnvs env + + empty_ty_subst = isEmptyTyVarEnv ty_subst + empty_spec_env = isEmptySpecEnv (getIdSpecialisation id) + + no_need_to_clone = not need_to_clone + need_to_clone = not (externallyVisibleId id) && + ( elemIdEnv id in_scope_ids || clone_binds_please) + {- + The SimplCloneBinds option isn't just here as another simplifier knob we can + twiddle. Prior to floating bindings outwards, we have to make sure that no + duplicate bindings exist as floating may cause bindings with identical + uniques to come into scope, with disastrous consequences. + + To avoid this situation, we make sure that cloning is turned *on* in the + simplifier pass prior to running an outward floating pass. + -} + clone_binds_please = switchIsOn sw_chkr SimplCloneBinds + + new_in_scope_ids id' = addOneToIdEnv in_scope_ids id' (id', occ_info, NoUnfolding) + + ty = idType id + ty' = instantiateTy ty_subst ty + + sw_chkr = getSwitchChecker env + + +simplBinders :: SimplEnv -> [InBinder] -> SmplM (SimplEnv, [OutId]) +simplBinders env binders = mapAccumLSmpl simplBinder env binders +\end{code} + +\begin{code} +simplTyBinder :: SimplEnv -> TyVar -> SmplM (SimplEnv, TyVar) +simplTyBinder env tyvar + | no_need_to_clone + = -- No need to clone; but must zap any binding for tyvar + -- see comments with simplBinder above + let + env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar, + delFromTyVarEnv ty_subst tyvar) + in + returnSmpl (env', tyvar) + + | otherwise -- Need to clone + = getUniqueSmpl `thenSmpl` \ uniq -> + let + tyvar' = cloneTyVar tyvar uniq + env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar', + addToTyVarEnv ty_subst tyvar (mkTyVarTy tyvar')) + in + returnSmpl (env', tyvar') + where + ((tyvars, ty_subst), (ids, id_subst)) = getEnvs env + no_need_to_clone = not (tyvar `elementOfTyVarSet` tyvars) && + not clone_binds_please + + clone_binds_please = switchIsOn sw_chkr SimplCloneBinds + sw_chkr = getSwitchChecker env + + +simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar]) +simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders +\end{code}