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