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