ghc/compiler/stranal/WorkWrap.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module WorkWrap ( workersAndWrappers ) where
  10
  11 IMPORT_Trace
  12 import Outputable
  13 import Pretty
  14
  15 import Id               ( idType, addIdStrictness, getIdStrictness,
  16                           getIdUnfolding, mkWorkerId,
  17                           replaceIdInfo, getIdInfo, idWantsToBeINLINEd
  18                         )
  19 import IdInfo           -- bits and pieces
  20 import Maybes           ( maybeToBool, Maybe(..) )
  21 import SaLib
  22 import SrcLoc           ( mkUnknownSrcLoc, SrcLoc )
  23 import Util
  24 import WwLib
  25 \end{code}
  26
  27 We take Core bindings whose binders have their strictness attached (by
  28 the front-end of the strictness analyser), and we return some
  29 ``plain'' bindings which have been worker/wrapper-ified, meaning:
  30 \begin{enumerate}
  31 \item
  32 Functions have been split into workers and wrappers where appropriate;
  33 \item
  34 Binders' @IdInfos@ have been updated to reflect the existence
  35 of these workers/wrappers (this is where we get STRICTNESS pragma
  36 info for exported values).
  37 \end{enumerate}
  38
  39 \begin{code}
  40 workersAndWrappers :: [CoreBinding] -> WwM [CoreBinding]
  41
  42 workersAndWrappers top_binds
  43   = mapWw (wwBind True{-top-level-}) top_binds `thenWw` \ top_binds2 ->
  44     let
  45         top_binds3 = map make_top_binding top_binds2
  46     in
  47     returnWw (concat top_binds3)
  48   where
  49     make_top_binding :: WwBinding -> [CoreBinding]
  50
  51     make_top_binding (WwLet binds) = binds
  52 \end{code}
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 @wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in
  61 turn.  Non-recursive case first, then recursive...
  62
  63 \begin{code}
  64 wwBind  :: Bool                 -- True <=> top-level binding
  65         -> CoreBinding
  66         -> WwM WwBinding        -- returns a WwBinding intermediate form;
  67                                 -- the caller will convert to Expr/Binding,
  68                                 -- as appropriate.
  69
  70 wwBind top_level (NonRec binder rhs)
  71   = wwExpr rhs                  `thenWw` \ new_rhs ->
  72     tryWW binder new_rhs        `thenWw` \ new_pairs ->
  73     returnWw (WwLet [NonRec b e | (b,e) <- new_pairs])
  74       -- Generated bindings must be non-recursive
  75       -- because the original binding was.
  76
  77 ------------------------------
  78
  79 wwBind top_level (Rec pairs)
  80   = mapWw do_one pairs          `thenWw` \ new_pairs ->
  81     returnWw (WwLet [Rec (concat new_pairs)])
  82   where
  83     do_one (binder, rhs) = wwExpr rhs   `thenWw` \ new_rhs ->
  84                            tryWW binder new_rhs
  85 \end{code}
  86
  87 @wwExpr@ basically just walks the tree, looking for appropriate
  88 annotations that can be used. Remember it is @wwBind@ that does the
  89 matching by looking for strict arguments of the correct type.
  90 @wwExpr@ is a version that just returns the ``Plain'' Tree.
  91 ???????????????? ToDo
  92
  93 \begin{code}
  94 wwExpr :: CoreExpr -> WwM CoreExpr
  95
  96 wwExpr e@(Var _)        = returnWw e
  97 wwExpr e@(Lit _)        = returnWw e
  98 wwExpr e@(Con  _ _ _) = returnWw e
  99 wwExpr e@(Prim _ _ _) = returnWw e
 100
 101 wwExpr (Lam binders expr)
 102   = wwExpr expr                 `thenWw` \ new_expr ->
 103     returnWw (Lam binders new_expr)
 104
 105 wwExpr (CoTyLam ty expr)
 106   = wwExpr expr                 `thenWw` \ new_expr ->
 107     returnWw (CoTyLam ty new_expr)
 108
 109 wwExpr (App e1 e2)
 110   = wwExpr e1                   `thenWw` \ new_e1 ->
 111     returnWw (App new_e1 e2)
 112
 113 wwExpr (CoTyApp expr ty)
 114   = wwExpr expr                 `thenWw` \ new_expr ->
 115     returnWw (CoTyApp new_expr ty)
 116
 117 wwExpr (SCC cc expr)
 118   = wwExpr expr                 `thenWw` \ new_expr ->
 119     returnWw (SCC cc new_expr)
 120
 121 wwExpr (Let bind expr)
 122   = wwBind False{-not top-level-} bind  `thenWw` \ intermediate_bind ->
 123     wwExpr expr                         `thenWw` \ new_expr ->
 124     returnWw (mash_ww_bind intermediate_bind new_expr)
 125   where
 126     mash_ww_bind (WwLet  binds)   body = mkCoLetsNoUnboxed binds body
 127     mash_ww_bind (WwCase case_fn) body = case_fn body
 128
 129 wwExpr (Case expr alts)
 130   = wwExpr expr                         `thenWw` \ new_expr ->
 131     ww_alts alts                        `thenWw` \ new_alts ->
 132     returnWw (Case new_expr new_alts)
 133   where
 134     ww_alts (AlgAlts alts deflt)
 135       = mapWw ww_alg_alt alts           `thenWw` \ new_alts ->
 136         ww_deflt deflt                  `thenWw` \ new_deflt ->
 137         returnWw (AlgAlts new_alts new_deflt)
 138
 139     ww_alts (PrimAlts alts deflt)
 140       = mapWw ww_prim_alt alts          `thenWw` \ new_alts ->
 141         ww_deflt deflt                  `thenWw` \ new_deflt ->
 142         returnWw (PrimAlts new_alts new_deflt)
 143
 144     ww_alg_alt (con, binders, rhs)
 145       = wwExpr rhs                      `thenWw` \ new_rhs ->
 146         returnWw (con, binders, new_rhs)
 147
 148     ww_prim_alt (lit, rhs)
 149       = wwExpr rhs                      `thenWw` \ new_rhs ->
 150         returnWw (lit, new_rhs)
 151
 152     ww_deflt NoDefault
 153       = returnWw NoDefault
 154
 155     ww_deflt (BindDefault binder rhs)
 156       = wwExpr rhs                      `thenWw` \ new_rhs ->
 157         returnWw (BindDefault binder new_rhs)
 158 \end{code}
 159
 160 %************************************************************************
 161 %*                                                                      *
 162 \subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair}
 163 %*                                                                      *
 164 %************************************************************************
 165
 166 @tryWW@ just accumulates arguments, converts strictness info from the
 167 front-end into the proper form, then calls @mkWwBodies@ to do
 168 the business.
 169
 170 We have to BE CAREFUL that we don't worker-wrapperize an Id that has
 171 already been w-w'd!  (You can end up with several liked-named Ids
 172 bouncing around at the same time---absolute mischief.)  So the
 173 criterion we use is: if an Id already has an unfolding (for whatever
 174 reason), then we don't w-w it.
 175
 176 The only reason this is monadised is for the unique supply.
 177
 178 \begin{code}
 179 tryWW   :: Id                           -- the fn binder
 180         -> CoreExpr             -- the bound rhs; its innards
 181                                         --   are already ww'd
 182         -> WwM [(Id, CoreExpr)] -- either *one* or *two* pairs;
 183                                         -- if one, then no worker (only
 184                                         -- the orig "wrapper" lives on);
 185                                         -- if two, then a worker and a
 186                                         -- wrapper.
 187 tryWW fn_id rhs
 188   | idWantsToBeINLINEd fn_id
 189     -- No point in worker/wrappering something that is going to be
 190     -- INLINEd wholesale anyway.  If the strictness analyser is run
 191     -- twice, this test also prevents wrappers (which are INLINEd)
 192     -- from being re-done.
 193   = do_nothing
 194
 195   | otherwise
 196   = case (getIdStrictness fn_id) of
 197
 198       NoStrictnessInfo    -> do_nothing
 199       BottomGuaranteed    -> do_nothing
 200       StrictnessInfo [] _ -> do_nothing -- V weird (but possible?)
 201
 202       StrictnessInfo args_info _ ->
 203         if not (indicatesWorker args_info) then
 204             do_nothing
 205         else
 206
 207         -- OK, it looks as if a worker is worth a try
 208         let
 209              (uvars, tyvars, args, body) = digForLambdas rhs
 210              body_ty                     = coreExprType body
 211         in
 212         uniqSMtoWwM (mkWwBodies body_ty tyvars args args_info) `thenWw` \ result ->
 213         case result of
 214
 215           Nothing ->    -- Very peculiar. This can only happen if we hit an
 216                         -- abstract type, which we shouldn't have since we've
 217                         -- constructed the args_info in this module!
 218
 219                         -- False. We might hit the all-args-absent-and-the-
 220                         -- body-is-unboxed case.  A Nothing is legit. (WDP 94/10)
 221                         do_nothing
 222
 223           Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
 224
 225                 -- Terrific!  It worked!
 226             getUniqueWw         `thenWw` \ worker_uniq ->
 227             let
 228                 worker_ty   = worker_ty_w_hole body_ty
 229
 230                 worker_id   = mkWorkerId worker_uniq fn_id worker_ty
 231                                 (noIdInfo `addInfo` worker_strictness)
 232
 233                 wrapper_rhs = wrapper_w_hole worker_id
 234                 worker_rhs  = worker_w_hole body
 235
 236                 revised_strictness_info
 237                   = -- We know the basic strictness info already, but
 238                     -- we need to slam in the exact identity of the
 239                     -- worker Id:
 240                     mkStrictnessInfo args_info (Just worker_id)
 241
 242                 wrapper_id  = fn_id `replaceIdInfo`
 243                               (getIdInfo fn_id          `addInfo`
 244                                revised_strictness_info  `addInfo_UF`
 245                                iWantToBeINLINEd UnfoldAlways)
 246                 -- NB! the "iWantToBeINLINEd" part adds an INLINE pragma to
 247                 -- the wrapper, which is of course what we want.
 248             in
 249             returnWw [ (worker_id,  worker_rhs),   -- worker comes first
 250                        (wrapper_id, wrapper_rhs) ] -- because wrapper mentions it
 251   where
 252     do_nothing = returnWw [ (fn_id, rhs) ]
 253 \end{code}