ghc/compiler/simplCore/SimplVar.lhs

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