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