ghc/compiler/simplCore/SimplVar.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[SimplVar]{Simplifier stuff related to variables}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module SimplVar (
  10         completeVar,
  11         leastItCouldCost
  12     ) where
  13
  14 import SimplMonad
  15 import SimplEnv
  16 import Literal          ( isNoRepLit )
  17
  18 import Type             ( getAppDataTyCon, maybeAppDataTyCon,
  19                           getTyConFamilySize, isPrimType
  20                         )
  21 import BinderInfo       ( oneTextualOcc, oneSafeOcc )
  22 import CgCompInfo       ( uNFOLDING_USE_THRESHOLD,
  23                           uNFOLDING_CON_DISCOUNT_WEIGHT
  24                         )
  25 import CmdLineOpts      ( switchIsOn, intSwitchSet, SimplifierSwitch(..) )
  26 import Id               ( idType, getIdInfo )
  27 import IdInfo
  28 import Maybes           ( maybeToBool, Maybe(..) )
  29 import Simplify         ( simplExpr )
  30 import SimplUtils       ( simplIdWantsToBeINLINEd )
  31 import MagicUFs
  32 import Pretty
  33 import Util
  34 \end{code}
  35
  36 %************************************************************************
  37 %*                                                                      *
  38 \subsection[Simplify-var]{Completing variables}
  39 %*                                                                      *
  40 %************************************************************************
  41
  42 This where all the heavy-duty unfolding stuff comes into its own.
  43
  44 \begin{code}
  45 completeVar :: SimplEnv -> OutId -> [OutArg] -> SmplM OutExpr
  46
  47 completeVar env var args
  48   = let
  49         boring_result = mkGenApp (Var var) args
  50     in
  51     case (lookupUnfolding env var) of
  52
  53       LitForm lit
  54         | not (isNoRepLit lit)
  55                 -- Inline literals, if they aren't no-repish things
  56         -> ASSERT( null args )
  57            returnSmpl (Lit lit)
  58
  59       ConForm con ty_args val_args
  60                 -- Always inline constructors.
  61                 -- See comments before completeLetBinding
  62         -> ASSERT( null args )
  63            returnSmpl (Con con ty_args val_args)
  64
  65       GenForm txt_occ form_summary template guidance
  66         -> considerUnfolding env var args
  67                              txt_occ form_summary template guidance
  68
  69       MagicForm str magic_fun
  70         ->  applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result ->
  71             case result of
  72               Nothing           -> returnSmpl boring_result
  73               Just magic_result ->
  74                 {- pprTrace "MagicForm:- " (ppAbove
  75                         (ppBesides [
  76                            ppr PprDebug var,
  77                            ppr PprDebug args])
  78                         (ppBesides [
  79                                 ppStr "AFTER    :- ",
  80                            ppr PprDebug magic_result])) (returnSmpl ()) `thenSmpl` \ () ->
  81                 -}
  82                 tick MagicUnfold                `thenSmpl_`
  83                 returnSmpl magic_result
  84
  85       IWantToBeINLINEd _ -> returnSmpl boring_result
  86
  87       other -> returnSmpl boring_result
  88 \end{code}
  89
  90
  91 %************************************************************************
  92 %*                                                                      *
  93 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
  94 %*                                                                      *
  95 %************************************************************************
  96
  97 We have very limited information about an unfolding expression: (1)~so
  98 many type arguments and so many value arguments expected---for our
  99 purposes here, we assume we've got those.  (2)~A ``size'' or ``cost,''
 100 a single integer.  (3)~An ``argument info'' vector.  For this, what we
 101 have at the moment is a Boolean per argument position that says, ``I
 102 will look with great favour on an explicit constructor in this
 103 position.''
 104
 105 Assuming we have enough type- and value arguments (if not, we give up
 106 immediately), then we see if the ``discounted size'' is below some
 107 (semi-arbitrary) threshold.  It works like this: for every argument
 108 position where we're looking for a constructor AND WE HAVE ONE in our
 109 hands, we get a (again, semi-arbitrary) discount [proportion to the
 110 number of constructors in the type being scrutinized].
 111
 112 \begin{code}
 113 considerUnfolding
 114         :: SimplEnv
 115         -> OutId                -- Id we're thinking about
 116         -> [OutArg]             -- Applied to these
 117         -> Bool                 -- If True then *always* inline,
 118                                 -- because it's the only one
 119         -> FormSummary
 120         -> InExpr               -- Template for unfolding;
 121         -> UnfoldingGuidance    -- To help us decide...
 122         -> SmplM CoreExpr       -- Result!
 123
 124 considerUnfolding env var args txt_occ form_summary template guidance
 125   | switchIsOn sw_chkr EssentialUnfoldingsOnly
 126   = dont_go_for_it -- we're probably in a hurry in this simpl round...
 127
 128   | do_deforest
 129   = pprTrace "" (ppBesides [ppStr "not attempting to unfold `",
 130                                     ppr PprDebug var,
 131                                     ppStr "' due to DEFOREST pragma"])
 132                         dont_go_for_it
 133
 134   | txt_occ
 135   = go_for_it
 136
 137   | (case form_summary of {BottomForm -> True; other -> False} &&
 138     not (any isPrimType [ ty | (TypeArg ty) <- args ]))
 139                 -- Always inline bottoming applications, unless
 140                 -- there's a primitive type lurking around...
 141   = go_for_it
 142
 143   | otherwise
 144   =
 145     -- If this is a deforestable Id, then don't unfold it (the deforester
 146     -- will do it).
 147
 148     case getInfo (getIdInfo var) of {
 149        DoDeforest -> pprTrace "" (ppBesides [ppStr "not unfolding `",
 150                                     ppr PprDebug var,
 151                                     ppStr "' due to DEFOREST pragma"])
 152                         dont_go_for_it;
 153        Don'tDeforest ->
 154
 155     case guidance of
 156       UnfoldNever  -> dont_go_for_it
 157
 158       UnfoldAlways -> go_for_it
 159
 160       EssentialUnfolding -> go_for_it
 161
 162       UnfoldIfGoodArgs m_tys_wanted n_vals_wanted is_con_vec size
 163         -> if m_tys_wanted > no_tyargs
 164            || n_vals_wanted > no_valargs then
 165               --pprTrace "dont_go_for_it1:" (ppAbove (ppr PprDebug guidance) (ppr PprDebug var))
 166               dont_go_for_it
 167
 168            else if n_vals_wanted == 0
 169                 && rhs_looks_like_a_Con then
 170               -- we are very keen on inlining data values
 171               -- (see comments elsewhere); we ignore any size issues!
 172               go_for_it
 173
 174            else -- we try the fun stuff
 175               let
 176                   discounted_size
 177                     = discountedCost env con_discount size no_valargs is_con_vec valargs
 178               in
 179               if discounted_size <= unfold_use_threshold then
 180                   go_for_it
 181               else
 182                   --pprTrace "dont_go_for_it2:" (ppCat [ppr PprDebug var, ppInt size, ppInt discounted_size, ppInt unfold_use_threshold, ppr PprDebug guidance])
 183                   dont_go_for_it
 184     }
 185   where
 186     sw_chkr = getSwitchChecker env
 187
 188     unfold_use_threshold
 189       = case (intSwitchSet sw_chkr SimplUnfoldingUseThreshold) of
 190           Nothing -> uNFOLDING_USE_THRESHOLD
 191           Just xx -> xx
 192
 193     con_discount  -- ToDo: ************ get from a switch *********
 194       = uNFOLDING_CON_DISCOUNT_WEIGHT
 195
 196     (tyargs, valargs, args_left) = decomposeArgs args
 197     no_tyargs  = length tyargs
 198     no_valargs = length valargs
 199
 200     rhs_looks_like_a_Con
 201       = let
 202             (_,_,val_binders,body) = digForLambdas template
 203         in
 204         case (val_binders, body) of
 205           ([], Con _ _ _) -> True
 206           other -> False
 207
 208     dont_go_for_it = returnSmpl (mkGenApp (Var var) args)
 209
 210     go_for_it      = --pprTrace "unfolding:" (ppCat [ppr PprDebug var, ppChar ':', ppr PprDebug template]) (
 211                      tick UnfoldingDone         `thenSmpl_`
 212                      simplExpr env template args
 213                      --)
 214
 215 #if OMIT_DEFORESTER
 216     do_deforest = False
 217 #else
 218     do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
 219 #endif
 220 \end{code}
 221
 222 \begin{code}
 223 type ArgInfoVector = [Bool]
 224
 225 discountedCost
 226         :: SimplEnv         -- so we can look up things about the args
 227         -> Int              -- the discount for a "constructor" hit;
 228                             -- we multiply by the # of cons in the type.
 229         -> Int              -- the size/cost of the expr
 230         -> Int              -- the number of val args (== length args)
 231         -> ArgInfoVector    -- what we know about the *use* of the arguments
 232         -> [OutAtom]        -- *an actual set of value arguments*!
 233         -> Int
 234
 235     -- If we apply an expression (usually a function) of given "costs"
 236     -- to a particular set of arguments (possibly none), what will
 237     -- the resulting expression "cost"?
 238
 239 discountedCost env con_discount_weight size no_args is_con_vec args
 240   = ASSERT(no_args == length args)
 241     disc (size - no_args) is_con_vec args
 242         -- we start w/ a "discount" equal to the # of args...
 243   where
 244     disc size [] _ = size
 245     disc size _ [] = size
 246
 247     disc size (want_con_here:want_cons) (arg:rest_args)
 248       = let
 249             full_price           = disc size
 250             take_something_off v = let
 251                                      (tycon, _, _) = getAppDataTyCon (idType v)
 252                                      no_cons = case (getTyConFamilySize tycon) of
 253                                                  Just n -> n
 254                                      reduced_size
 255                                        = size - (no_cons * con_discount_weight)
 256                                    in
 257                                    disc reduced_size
 258         in
 259         (if not want_con_here then
 260             full_price
 261         else
 262             case arg of
 263               LitArg _ -> full_price
 264               VarArg v -> case lookupUnfolding env v of
 265                                ConForm _ _ _ -> take_something_off v
 266                                other_form            -> full_price
 267
 268         ) want_cons rest_args
 269 \end{code}
 270
 271 We use this one to avoid exporting inlinings that we ``couldn't possibly
 272 use'' on the other side.  Can be overridden w/ flaggery.
 273 \begin{code}
 274 leastItCouldCost
 275         :: Int
 276         -> Int              -- the size/cost of the expr
 277         -> Int              -- number of value args
 278         -> ArgInfoVector    -- what we know about the *use* of the arguments
 279         -> [Type]           -- NB: actual arguments *not* looked at;
 280                             -- but we know their types
 281         -> Int
 282
 283 leastItCouldCost con_discount_weight size no_val_args is_con_vec arg_tys
 284   = ASSERT(no_val_args == length arg_tys)
 285     disc (size - no_val_args) is_con_vec arg_tys
 286         -- we start w/ a "discount" equal to the # of args...
 287   where
 288     -- ToDo: rather sad that this isn't commoned-up w/ the one above...
 289
 290     disc size [] _ = size
 291     disc size _ [] = size
 292
 293     disc size (want_con_here:want_cons) (arg_ty:rest_arg_tys)
 294       = let
 295             take_something_off tycon
 296               = let
 297                     no_cons = case (getTyConFamilySize tycon) of { Just n -> n }
 298
 299                     reduced_size
 300                       = size - (no_cons * con_discount_weight)
 301                 in
 302                 reduced_size
 303         in
 304         if not want_con_here then
 305             disc size want_cons rest_arg_tys
 306         else
 307             case (maybeAppDataTyCon arg_ty, isPrimType arg_ty) of
 308               (Just (tycon, _, _), False) ->
 309                 disc (take_something_off tycon) want_cons rest_arg_tys
 310
 311               other -> disc size want_cons rest_arg_tys
 312 \end{code}
 313