ghc/compiler/stranal/WorkWrap.lhs

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