X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplVar.lhs;h=2a6499e4c955d6fb870572e8d678118b49bbdac1;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hp=10a9f3caa0c7d18a14b7c3723ddd60e6ec62ac95;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index 10a9f3c..2a6499e 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1996 % \section[SimplVar]{Simplifier stuff related to variables} @@ -7,30 +7,38 @@ #include "HsVersions.h" module SimplVar ( - completeVar, - leastItCouldCost + completeVar ) where -import SimplMonad -import SimplEnv -import Literal ( isNoRepLit ) +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(SmplLoop) ( simplExpr ) -import Type ( getAppDataTyCon, maybeAppDataTyCon, - getTyConFamilySize, isPrimType - ) -import BinderInfo ( oneTextualOcc, oneSafeOcc ) import CgCompInfo ( uNFOLDING_USE_THRESHOLD, uNFOLDING_CON_DISCOUNT_WEIGHT ) -import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..) ) -import Id ( idType, getIdInfo ) -import IdInfo -import Maybes ( maybeToBool, Maybe(..) ) -import Simplify ( simplExpr ) -import SimplUtils ( simplIdWantsToBeINLINEd ) -import MagicUFs -import Pretty -import Util +import CmdLineOpts ( switchIsOn, SimplifierSwitch(..) ) +import CoreSyn +import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding(..), + FormSummary, + smallEnoughToInline ) +import BinderInfo ( BinderInfo, noBinderInfo, okToInline ) + +import CostCentre ( CostCentre, noCostCentreAttached ) +import Id ( idType, getIdInfo, getIdUnfolding, getIdSpecialisation, + GenId{-instance Outputable-} + ) +import SpecEnv ( SpecEnv, lookupSpecEnv ) +import IdInfo ( DeforestInfo(..) ) +import Literal ( isNoRepLit ) +import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun ) +import PprStyle ( PprStyle(..) ) +import PprType ( GenType{-instance Outputable-} ) +import Pretty ( ppBesides, ppStr ) +import SimplEnv +import SimplMonad +import TyCon ( tyConFamilySize ) +import Util ( pprTrace, assertPanic, panic ) +import Maybes ( maybeToBool ) \end{code} %************************************************************************ @@ -42,272 +50,92 @@ import Util This where all the heavy-duty unfolding stuff comes into its own. \begin{code} -completeVar :: SimplEnv -> OutId -> [OutArg] -> SmplM OutExpr - completeVar env var args - = let - boring_result = mkGenApp (Var var) args - in - case (lookupUnfolding env var) of - - LitForm lit - | not (isNoRepLit lit) - -- Inline literals, if they aren't no-repish things - -> ASSERT( null args ) - returnSmpl (Lit lit) - - ConForm con ty_args val_args - -- Always inline constructors. - -- See comments before completeLetBinding - -> ASSERT( null args ) - returnSmpl (Con con ty_args val_args) - - GenForm 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} - - -%************************************************************************ -%* * -\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} -%* * -%************************************************************************ + | maybeToBool maybe_magic_result + = tick MagicUnfold `thenSmpl_` + magic_result -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.'' + | 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 -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]. - -\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 CoreExpr -- 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 + | maybeToBool maybe_specialisation + = tick SpecialisationDone `thenSmpl_` + simplExpr (extendTyEnvList env spec_bindings) + spec_template + (map TyArg leftover_ty_args ++ remaining_args) | 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 -> + = returnSmpl (mkGenApp (Var var) args) - 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 - && rhs_looks_like_a_Con 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 - - rhs_looks_like_a_Con - = let - (_,_,val_binders,body) = digForLambdas template - in - case (val_binders, body) of - ([], Con _ _ _) -> True - other -> False - - dont_go_for_it = returnSmpl (mkGenApp (Var var) args) - - go_for_it = --pprTrace "unfolding:" (ppCat [ppr PprDebug var, ppChar ':', ppr PprDebug template]) ( - tick UnfoldingDone `thenSmpl_` - simplExpr env template args - --) + unfolding_from_id = getIdUnfolding var + + ---------- Magic unfolding stuff + maybe_magic_result = case unfolding_from_id of + MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn + env args + other -> Nothing + (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) + + other -> Nothing + + Just (occ_info, unfold_env, simple_unfolding) = maybe_unfolding_info + SimpleUnfolding form guidance unf_template = simple_unfolding + + ---------- 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 + + + ---------- 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_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 -\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"? +-- 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 subsumed cost centre, and we can't inline it inside "foo", +-- regardless of whether E is a WHNF or not. -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, _, _) = getAppDataTyCon (idType v) - no_cons = case (getTyConFamilySize tycon) of - Just n -> n - reduced_size - = size - (no_cons * con_discount_weight) - in - disc reduced_size - in - (if not want_con_here then - full_price - else - case arg of - LitArg _ -> full_price - VarArg v -> case lookupUnfolding env v of - ConForm _ _ _ -> take_something_off v - other_form -> full_price - - ) want_cons rest_args -\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 - -> [Type] -- 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... - where - -- ToDo: rather sad that this isn't commoned-up w/ the one above... - - disc size [] _ = size - disc size _ [] = size - - 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 (maybeAppDataTyCon 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 -\end{code} +costCentreOk cc_encl cc_rhs + = noCostCentreAttached cc_encl || not (noCostCentreAttached cc_rhs) +\end{code}