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