X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplVar.lhs;h=2cfaf9144f07c0c6a17b11a1d36b1e6fecc1a474;hb=967cc47f37cb93a5e2b6df7822c9a646f0428247;hp=9cbbe560bf8e1d2fc957ac11b55e775cd62d0bbe;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index 9cbbe56..2cfaf91 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -1,40 +1,47 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1996 % \section[SimplVar]{Simplifier stuff related to variables} - + \begin{code} -#include "HsVersions.h" - module SimplVar ( completeVar, - leastItCouldCost + simplBinder, simplBinders, simplTyBinder, simplTyBinders ) where -IMPORT_Trace - -import SimplMonad -import SimplEnv -import PlainCore -import TaggedCore -import BasicLit ( isNoRepLit ) +#include "HsVersions.h" -import AbsUniType ( getUniDataTyCon, getUniDataTyCon_maybe, - getTyConFamilySize, isPrimType +import {-# SOURCE #-} Simplify ( simplExpr ) + +import CmdLineOpts ( switchIsOn, SimplifierSwitch(..) ) +import CoreSyn +import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), + FormSummary, whnfOrBottom, okToInline, + smallEnoughToInline ) +import CoreUtils ( coreExprCc ) +import BinderInfo ( BinderInfo, noBinderInfo ) + +import CostCentre ( CostCentre, noCostCentreAttached, isCurrentCostCentre ) +import Id ( idType, getIdUnfolding, externallyVisibleId, + getIdSpecialisation, setIdSpecialisation, + idMustBeINLINEd, idHasNoFreeTyVars, + mkIdWithNewUniq, mkIdWithNewType, + IdEnv, lookupIdEnv, delOneFromIdEnv, elemIdEnv, isNullIdEnv, addOneToIdEnv ) -import BinderInfo ( oneTextualOcc, oneSafeOcc ) -import CgCompInfo ( uNFOLDING_USE_THRESHOLD, - uNFOLDING_CON_DISCOUNT_WEIGHT +import SpecEnv ( lookupSpecEnv, isEmptySpecEnv, emptySpecEnv ) +import OccurAnal ( occurAnalyseGlobalExpr ) +import Literal ( isNoRepLit ) +import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun ) +import SimplEnv +import SimplMonad +import Type ( instantiateTy, mkTyVarTy ) +import TyCon ( tyConFamilySize ) +import TyVar ( TyVar, cloneTyVar, + isEmptyTyVarEnv, addToTyVarEnv, delFromTyVarEnv, + addOneToTyVarSet, elementOfTyVarSet ) -import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..) ) -import Id ( getIdUniType, getIdInfo ) -import IdInfo -import Maybes ( maybeToBool, Maybe(..) ) -import Simplify ( simplExpr ) -import SimplUtils ( simplIdWantsToBeINLINEd ) -import MagicUFs -import Pretty -import Util +import Maybes ( maybeToBool ) +import Outputable \end{code} %************************************************************************ @@ -46,272 +53,234 @@ import Util This where all the heavy-duty unfolding stuff comes into its own. \begin{code} -completeVar :: SimplEnv -> OutId -> [OutArg] -> SmplM OutExpr +completeVar env inline_call var args result_ty + + | maybeToBool maybe_magic_result + = tick MagicUnfold `thenSmpl_` + magic_result + + -- Look for existing specialisations before + -- trying inlining + | maybeToBool maybe_specialisation + = tick SpecialisationDone `thenSmpl_` + 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) -completeVar env var args - = let - boring_result = applyToArgs (CoVar var) args - in - case (lookupUnfolding env var) of - - LiteralForm lit - | not (isNoRepLit lit) - -- Inline literals, if they aren't no-repish things - -> ASSERT( null args ) - returnSmpl (CoLit lit) - - ConstructorForm con ty_args val_args - -- Always inline constructors. - -- See comments before completeLetBinding - -> ASSERT( null args ) - returnSmpl (CoCon con ty_args val_args) - - GeneralForm txt_occ form_summary template guidance - -> considerUnfolding env var args - txt_occ form_summary template guidance - - MagicForm str magic_fun - -> applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result -> - case result of - Nothing -> returnSmpl boring_result - Just magic_result -> - {- pprTrace "MagicForm:- " (ppAbove - (ppBesides [ - ppr PprDebug var, - ppr PprDebug args]) - (ppBesides [ - ppStr "AFTER :- ", - ppr PprDebug magic_result])) (returnSmpl ()) `thenSmpl` \ () -> - -} - tick MagicUnfold `thenSmpl_` - returnSmpl magic_result - - IWantToBeINLINEd _ -> returnSmpl boring_result - - other -> returnSmpl boring_result -\end{code} + | otherwise + = returnSmpl (mkGenApp (Var var') args) + + where + (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 of + MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn + env args + other -> Nothing + Just magic_result = maybe_magic_result + + ---------- Unfolding stuff + has_unfolding = case unfolding of + CoreUnfolding _ _ _ -> True + other -> False + + 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!! + + ---------- Specialisation stuff + (ty_args, remaining_args) = initialTyArgs args + 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 + 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 + + + + +-- costCentreOk checks that it's ok to inline this thing +-- The time it *isn't* is this: +-- +-- f x = let y = E in +-- scc "foo" (...y...) +-- +-- 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 + = isCurrentCostCentre cc_encl || not (noCostCentreAttached cc_rhs) +\end{code} %************************************************************************ %* * -\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} +\section{Dealing with a single binder} %* * %************************************************************************ -We have very limited information about an unfolding expression: (1)~so -many type arguments and so many value arguments expected---for our -purposes here, we assume we've got those. (2)~A ``size'' or ``cost,'' -a single integer. (3)~An ``argument info'' vector. For this, what we -have at the moment is a Boolean per argument position that says, ``I -will look with great favour on an explicit constructor in this -position.'' - -Assuming we have enough type- and value arguments (if not, we give up -immediately), then we see if the ``discounted size'' is below some -(semi-arbitrary) threshold. It works like this: for every argument -position where we're looking for a constructor AND WE HAVE ONE in our -hands, we get a (again, semi-arbitrary) discount [proportion to the -number of constructors in the type being scrutinized]. +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} -considerUnfolding - :: SimplEnv - -> OutId -- Id we're thinking about - -> [OutArg] -- Applied to these - -> Bool -- If True then *always* inline, - -- because it's the only one - -> FormSummary - -> InExpr -- Template for unfolding; - -> UnfoldingGuidance -- To help us decide... - -> SmplM PlainCoreExpr -- Result! - -considerUnfolding env var args txt_occ form_summary template guidance - | switchIsOn sw_chkr EssentialUnfoldingsOnly - = dont_go_for_it -- we're probably in a hurry in this simpl round... - - | do_deforest - = pprTrace "" (ppBesides [ppStr "not attempting to unfold `", - ppr PprDebug var, - ppStr "' due to DEFOREST pragma"]) - dont_go_for_it - - | txt_occ - = go_for_it - - | (case form_summary of {BottomForm -> True; other -> False} && - not (any isPrimType [ ty | (TypeArg ty) <- args ])) - -- Always inline bottoming applications, unless - -- there's a primitive type lurking around... - = go_for_it +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 this is a deforestable Id, then don't unfold it (the deforester - -- will do it). - - case getInfo (getIdInfo var) of { - DoDeforest -> pprTrace "" (ppBesides [ppStr "not unfolding `", - ppr PprDebug var, - ppStr "' due to DEFOREST pragma"]) - dont_go_for_it; - Don'tDeforest -> - - case guidance of - UnfoldNever -> dont_go_for_it - - UnfoldAlways -> go_for_it - - EssentialUnfolding -> go_for_it - - UnfoldIfGoodArgs m_tys_wanted n_vals_wanted is_con_vec size - -> if m_tys_wanted > no_tyargs - || n_vals_wanted > no_valargs then - --pprTrace "dont_go_for_it1:" (ppAbove (ppr PprDebug guidance) (ppr PprDebug var)) - dont_go_for_it - - else if n_vals_wanted == 0 - && looks_like_a_data_val_to_me then - -- we are very keen on inlining data values - -- (see comments elsewhere); we ignore any size issues! - go_for_it - - else -- we try the fun stuff - let - discounted_size - = discountedCost env con_discount size no_valargs is_con_vec valargs - in - if discounted_size <= unfold_use_threshold then - go_for_it - else - --pprTrace "dont_go_for_it2:" (ppCat [ppr PprDebug var, ppInt size, ppInt discounted_size, ppInt unfold_use_threshold, ppr PprDebug guidance]) - dont_go_for_it - } - where - sw_chkr = getSwitchChecker env - - unfold_use_threshold - = case (intSwitchSet sw_chkr SimplUnfoldingUseThreshold) of - Nothing -> uNFOLDING_USE_THRESHOLD - Just xx -> xx - - con_discount -- ToDo: ************ get from a switch ********* - = uNFOLDING_CON_DISCOUNT_WEIGHT - - (tyargs, valargs, args_left) = decomposeArgs args - no_tyargs = length tyargs - no_valargs = length valargs - - looks_like_a_data_val_to_me - = let - (_,val_binders,body) = digForLambdas template - in - case (val_binders, body) of - ([], CoCon _ _ _) -> True - other -> False - - dont_go_for_it = returnSmpl (applyToArgs (CoVar var) args) - - go_for_it = --pprTrace "unfolding:" (ppCat [ppr PprDebug var, ppChar ':', ppr PprDebug template]) ( - tick UnfoldingDone `thenSmpl_` - simplExpr env template args - --) - -#if OMIT_DEFORESTER - do_deforest = False -#else - do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False } + = +#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 -\end{code} - -\begin{code} -type ArgInfoVector = [Bool] - -discountedCost - :: SimplEnv -- so we can look up things about the args - -> Int -- the discount for a "constructor" hit; - -- we multiply by the # of cons in the type. - -> Int -- the size/cost of the expr - -> Int -- the number of val args (== length args) - -> ArgInfoVector -- what we know about the *use* of the arguments - -> [OutAtom] -- *an actual set of value arguments*! - -> Int - - -- If we apply an expression (usually a function) of given "costs" - -- to a particular set of arguments (possibly none), what will - -- the resulting expression "cost"? - -discountedCost env con_discount_weight size no_args is_con_vec args - = ASSERT(no_args == length args) - disc (size - no_args) is_con_vec args - -- we start w/ a "discount" equal to the # of args... - where - disc size [] _ = size - disc size _ [] = size - - disc size (want_con_here:want_cons) (arg:rest_args) - = let - full_price = disc size - take_something_off v = let - (tycon, _, _) = getUniDataTyCon (getIdUniType v) - no_cons = case (getTyConFamilySize tycon) of - Just n -> n - reduced_size - = size - (no_cons * con_discount_weight) - in - disc reduced_size + (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 - (if not want_con_here then - full_price - else - case arg of - CoLitAtom _ -> full_price - CoVarAtom v -> case lookupUnfolding env v of - ConstructorForm _ _ _ -> take_something_off v - other_form -> full_price - - ) want_cons rest_args + 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} -We use this one to avoid exporting inlinings that we ``couldn't possibly -use'' on the other side. Can be overridden w/ flaggery. -\begin{code} -leastItCouldCost - :: Int - -> Int -- the size/cost of the expr - -> Int -- number of value args - -> ArgInfoVector -- what we know about the *use* of the arguments - -> [UniType] -- NB: actual arguments *not* looked at; - -- but we know their types - -> Int - -leastItCouldCost con_discount_weight size no_val_args is_con_vec arg_tys - = ASSERT(no_val_args == length arg_tys) - disc (size - no_val_args) is_con_vec arg_tys - -- we start w/ a "discount" equal to the # of args... +\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 - -- ToDo: rather sad that this isn't commoned-up w/ the one above... + ((tyvars, ty_subst), (ids, id_subst)) = getEnvs env + no_need_to_clone = not (tyvar `elementOfTyVarSet` tyvars) && + not clone_binds_please - disc size [] _ = size - disc size _ [] = size + clone_binds_please = switchIsOn sw_chkr SimplCloneBinds + sw_chkr = getSwitchChecker env - disc size (want_con_here:want_cons) (arg_ty:rest_arg_tys) - = let - take_something_off tycon - = let - no_cons = case (getTyConFamilySize tycon) of { Just n -> n } - reduced_size - = size - (no_cons * con_discount_weight) - in - reduced_size - in - if not want_con_here then - disc size want_cons rest_arg_tys - else - case (getUniDataTyCon_maybe arg_ty, isPrimType arg_ty) of - (Just (tycon, _, _), False) -> - disc (take_something_off tycon) want_cons rest_arg_tys - - other -> disc size want_cons rest_arg_tys +simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar]) +simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders \end{code} -