ghc/compiler/stranal/WwLib.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module WwLib (
  10         WwBinding(..),
  11
  12         mkWwBodies, mAX_WORKER_ARGS
  13     ) where
  14
  15 IMP_Ubiq(){-uitous-}
  16
  17 import CoreSyn
  18 import Id               ( idType, mkSysLocal, dataConArgTys )
  19 import IdInfo           ( mkStrictnessInfo, nonAbsentArgs, Demand(..) )
  20 import PrelVals         ( aBSENT_ERROR_ID )
  21 import SrcLoc           ( mkUnknownSrcLoc )
  22 import Type             ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys,
  23                           maybeAppDataTyConExpandingDicts
  24                         )
  25 import UniqSupply       ( returnUs, thenUs, thenMaybeUs,
  26                           getUniques, UniqSM(..)
  27                         )
  28 import Util             ( zipWithEqual, assertPanic, panic )
  29 \end{code}
  30
  31 %************************************************************************
  32 %*                                                                      *
  33 \subsection[datatype-WwLib]{@WwBinding@: a datatype for worker/wrapper-ing}
  34 %*                                                                      *
  35 %************************************************************************
  36
  37 In the worker/wrapper stuff, we want to carry around @CoreBindings@ in
  38 an ``intermediate form'' that can later be turned into a \tr{let} or
  39 \tr{case} (depending on strictness info).
  40
  41 \begin{code}
  42 data WwBinding
  43   = WwLet  [CoreBinding]
  44   | WwCase (CoreExpr -> CoreExpr)
  45                 -- the "case" will be a "strict let" of the form:
  46                 --
  47                 --  case rhs of
  48                 --    <blah> -> body
  49                 --
  50                 -- (instead of "let <blah> = rhs in body")
  51                 --
  52                 -- The expr you pass to the function is "body" (the
  53                 -- expression that goes "in the corner").
  54 \end{code}
  55
  56 %************************************************************************
  57 %*                                                                      *
  58 \subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
  59 %*                                                                      *
  60 %************************************************************************
  61
  62         ************   WARNING  ******************
  63         these comments are rather out of date
  64         *****************************************
  65
  66 @mkWrapperAndWorker@ is given:
  67 \begin{enumerate}
  68 \item
  69 The {\em original function} \tr{f}, of the form:
  70 \begin{verbatim}
  71 f = /\ tyvars -> \ args -> body
  72 \end{verbatim}
  73 The original-binder \tr{f}, the \tr{tyvars}, \tr{args}, and \tr{body}
  74 are given separately.
  75
  76 We use the Id \tr{f} mostly to get its type.
  77
  78 \item
  79 Strictness information about \tr{f}, in the form of a list of
  80 @Demands@.
  81
  82 \item
  83 A @UniqueSupply@.
  84 \end{enumerate}
  85
  86 @mkWrapperAndWorker@ produces (A BIT OUT-OF-DATE...):
  87 \begin{enumerate}
  88 \item
  89 Maybe @Nothing@: no worker/wrappering going on in this case. This can
  90 happen (a)~if the strictness info says that there is nothing
  91 interesting to do or (b)~if *any* of the argument types corresponding
  92 to ``active'' arg postitions is abstract or will be to the outside
  93 world (i.e., {\em this} module can see the constructors, but nobody
  94 else will be able to).  An ``active'' arg position is one which the
  95 wrapper has to unpack.  An importing module can't do this unpacking,
  96 so it simply has to give up and call the wrapper only.
  97
  98 \item
  99 Maybe \tr{Just (wrapper_Id, wrapper_body, worker_Id, worker_body)}.
 100
 101 The @wrapper_Id@ is just the one that was passed in, with its
 102 strictness IdInfo updated.
 103 \end{enumerate}
 104
 105 The \tr{body} of the original function may not be given (i.e., it's
 106 BOTTOM), in which case you'd jolly well better not tug on the
 107 worker-body output!
 108
 109 Here's an example.  The original function is:
 110 \begin{verbatim}
 111 g :: forall a . Int -> [a] -> a
 112
 113 g = /\ a -> \ x ys ->
 114         case x of
 115           0 -> head ys
 116           _ -> head (tail ys)
 117 \end{verbatim}
 118
 119 From this, we want to produce:
 120 \begin{verbatim}
 121 -- wrapper (an unfolding)
 122 g :: forall a . Int -> [a] -> a
 123
 124 g = /\ a -> \ x ys ->
 125         case x of
 126           I# x# -> g.wrk a x# ys
 127             -- call the worker; don't forget the type args!
 128
 129 -- worker
 130 g.wrk :: forall a . Int# -> [a] -> a
 131
 132 g.wrk = /\ a -> \ x# ys ->
 133         let
 134             x = I# x#
 135         in
 136             case x of               -- note: body of g moved intact
 137               0 -> head ys
 138               _ -> head (tail ys)
 139 \end{verbatim}
 140
 141 Something we have to be careful about:  Here's an example:
 142 \begin{verbatim}
 143 -- "f" strictness: U(P)U(P)
 144 f (I# a) (I# b) = a +# b
 145
 146 g = f   -- "g" strictness same as "f"
 147 \end{verbatim}
 148 \tr{f} will get a worker all nice and friendly-like; that's good.
 149 {\em But we don't want a worker for \tr{g}}, even though it has the
 150 same strictness as \tr{f}.  Doing so could break laziness, at best.
 151
 152 Consequently, we insist that the number of strictness-info items is
 153 exactly the same as the number of lambda-bound arguments.  (This is
 154 probably slightly paranoid, but OK in practice.)  If it isn't the
 155 same, we ``revise'' the strictness info, so that we won't propagate
 156 the unusable strictness-info into the interfaces.
 157
 158 ==========================
 159
 160 Here's the real fun... The wrapper's ``deconstructing'' of arguments
 161 and the worker's putting them back together again are ``duals'' in
 162 some sense.
 163
 164 What we do is walk along the @Demand@ list, producing two
 165 expressions (one for wrapper, one for worker...), each with a ``hole''
 166 in it, where we will later plug in more information.  For our previous
 167 example, the expressions-with-HOLES are:
 168 \begin{verbatim}
 169 \ x ys ->               -- wrapper
 170         case x of
 171           I# x# -> <<HOLE>> x# ys
 172
 173 \ x# ys ->              -- worker
 174         let
 175             x = I# x#
 176         in
 177             <<HOLE>>
 178 \end{verbatim}
 179 (Actually, we add the lambda-bound arguments at the end...) (The big
 180 Lambdas are added on the front later.)
 181
 182 \begin{code}
 183 mkWwBodies
 184         :: Type         -- Type of the *body* of the orig
 185                                 -- function; i.e. /\ tyvars -> \ vars -> body
 186         -> [TyVar]              -- Type lambda vars of original function
 187         -> [Id]                 -- Args of original function
 188         -> [Demand]             -- Strictness info for those args
 189
 190         -> UniqSM (Maybe        -- Nothing iff (a) no interesting split possible
 191                                 --             (b) any unpack on abstract type
 192                      (Id -> CoreExpr,           -- Wrapper expr w/
 193                                                         --   hole for worker id
 194                       CoreExpr -> CoreExpr,     -- Worker expr w/ hole
 195                                                         --   for original fn body
 196                       StrictnessInfo,                   -- Worker strictness info
 197                       Type -> Type)             -- Worker type w/ hole
 198            )                                            --   for type of original fn body
 199
 200
 201 mkWwBodies body_ty tyvars args arg_infos
 202   = ASSERT(length args == length arg_infos)
 203     -- or you can get disastrous user/definer-module mismatches
 204     if (all_absent_args_and_unboxed_value body_ty arg_infos)
 205     then returnUs Nothing
 206
 207     else -- the rest...
 208     mk_ww_arg_processing args arg_infos (mAX_WORKER_ARGS - nonAbsentArgs arg_infos)
 209                 `thenMaybeUs` \ (wrap_frag, work_args_info, work_frag) ->
 210     let
 211         (work_args, wrkr_demands) = unzip work_args_info
 212
 213         wrkr_strictness = mkStrictnessInfo wrkr_demands Nothing -- no worker-of-worker...
 214
 215         wrapper_w_hole = \ worker_id ->
 216                                 mkLam tyvars args (
 217                                 wrap_frag (
 218                                 mkTyApp (Var worker_id) (mkTyVarTys tyvars)
 219                          ))
 220
 221         worker_w_hole = \ orig_body ->
 222                                 mkLam tyvars work_args (
 223                                 work_frag orig_body
 224                         )
 225
 226         worker_ty_w_hole = \ body_ty ->
 227                                 mkForAllTys tyvars $
 228                                 mkFunTys (map idType work_args) body_ty
 229     in
 230     returnUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole))
 231   where
 232     -- "all_absent_args_and_unboxed_value":
 233     -- check for the obscure case of "\ x y z ... -> body" where
 234     -- (a) *all* of the args x, y, z,... are absent, and
 235     -- (b) the type of body is unboxed
 236     -- If these conditions are true, we must *not* play worker/wrapper games!
 237
 238     all_absent_args_and_unboxed_value body_ty arg_infos
 239       = not (null arg_infos)
 240         && all is_absent_arg arg_infos
 241         && isPrimType body_ty
 242
 243     is_absent_arg (WwLazy True) = True
 244     is_absent_arg _             = False
 245 \end{code}
 246
 247 Important: mk_ww_arg_processing doesn't check
 248 for an "interesting" split.  It just races ahead and makes the
 249 split, even if there's no unpacking at all.  This is important for
 250 when it calls itself recursively.
 251
 252 It returns Nothing only if it encounters an abstract type in mid-flight.
 253
 254 \begin{code}
 255 mAX_WORKER_ARGS :: Int          -- ToDo: set via flag
 256 mAX_WORKER_ARGS = 6             -- Hmm... but this is an everything-must-
 257                                 -- be-compiled-with-the-same-val thing...
 258
 259 mk_ww_arg_processing
 260         :: [Id]                 -- Args of original function
 261         -> [Demand]             -- Strictness info for those args
 262                                 --   must be at least as long as args
 263
 264         -> Int                  -- Number of extra args we are prepared to add.
 265                                 -- This prevents over-eager unpacking, leading
 266                                 -- to huge-arity functions.
 267
 268         -> UniqSM (Maybe        -- Nothing iff any unpack on abstract type
 269                      (CoreExpr -> CoreExpr,     -- Wrapper expr w/
 270                                                         --   hole for worker id
 271                                                         --   applied to types
 272                       [(Id,Demand)],                    -- Worker's args
 273                                                         -- and their strictness info
 274                       CoreExpr -> CoreExpr)     -- Worker body expr w/ hole
 275            )                                            --   for original fn body
 276
 277 mk_ww_arg_processing [] _ _ = returnUs (Just (id, [], id))
 278
 279 mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args
 280   =     -- Absent argument
 281         -- So, finish args to the right...
 282     --pprTrace "Absent; num_wrkr_args=" (ppInt num_wrkr_args) (
 283     let
 284         arg_ty = idType arg
 285     in
 286     mk_ww_arg_processing args infos max_extra_args
 287                                     -- we've already discounted for absent args,
 288                                     -- so we don't change max_extra_args
 289                    `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
 290
 291                 -- wrapper doesn't pass this arg to worker:
 292     returnUs (Just (
 293                  -- wrapper:
 294                  \ hole -> wrap_rest hole,
 295
 296                  -- worker:
 297                  work_args_info, -- NB: no argument added
 298                  \ hole -> mk_absent_let arg arg_ty (work_rest hole)
 299     ))
 300     --)
 301   where
 302     mk_absent_let arg arg_ty body
 303       = if not (isPrimType arg_ty) then
 304             Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body
 305         else -- quite horrible
 306             panic "WwLib: haven't done mk_absent_let for primitives yet"
 307
 308
 309 mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args
 310   | new_max_extra_args > 0      -- Check that we are prepared to add arguments
 311   =     -- this is the complicated one.
 312     --pprTrace "Unpack; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr "; new_max=", ppInt new_num_wrkr_args, ppStr "; arg=", ppr PprDebug arg, ppr PprDebug (WwUnpack cmpnt_infos)]) $
 313
 314     case (maybeAppDataTyConExpandingDicts arg_ty) of
 315
 316           Nothing         ->       -- Not a data type
 317                                    panic "mk_ww_arg_processing: not datatype"
 318
 319           Just (_, _, []) ->       -- An abstract type
 320                                    -- We have to give up on the whole idea
 321                                    returnUs Nothing
 322           Just (_, _, (_:_:_)) ->  -- Two or more constructors; that's odd
 323                                    panic "mk_ww_arg_processing: multi-constr"
 324
 325           Just (arg_tycon, tycon_arg_tys, [data_con]) ->
 326                         -- The main event: a single-constructor data type
 327
 328             let
 329                 inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
 330             in
 331             getUniques (length inst_con_arg_tys)    `thenUs` \ uniqs ->
 332
 333             let
 334                 unpk_args = zipWithEqual "mk_ww_arg_processing"
 335                              (\ u t -> mkSysLocal SLIT("upk") u t mkUnknownSrcLoc)
 336                              uniqs inst_con_arg_tys
 337             in
 338                 -- In processing the rest, push the sub-component args
 339                 -- and infos on the front of the current bunch
 340             mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) new_max_extra_args
 341                         `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
 342
 343             returnUs (Just (
 344               -- wrapper: unpack the value
 345               \ hole -> mk_unpk_case arg unpk_args
 346                             data_con arg_tycon
 347                             (wrap_rest hole),
 348
 349               -- worker: expect the unpacked value;
 350               -- reconstruct the orig value with a "let"
 351               work_args_info,
 352               \ hole -> work_rest (mk_pk_let arg data_con tycon_arg_tys unpk_args hole)
 353             ))
 354   where
 355     arg_ty = idType arg
 356
 357     new_max_extra_args
 358       = max_extra_args
 359         + 1                         -- We won't pass the original arg now
 360         - nonAbsentArgs cmpnt_infos -- But we will pass an arg for each cmpt
 361
 362     mk_unpk_case arg unpk_args boxing_con boxing_tycon body
 363       = Case (Var arg) (
 364           AlgAlts [(boxing_con, unpk_args, body)]
 365           NoDefault
 366         )
 367
 368     mk_pk_let arg boxing_con con_tys unpk_args body
 369       = Let (NonRec arg (Con boxing_con
 370                             (map TyArg con_tys ++ map VarArg unpk_args)))
 371               body
 372
 373 mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args
 374   | otherwise
 375   =     -- For all others at the moment, we just
 376         -- pass them to the worker unchanged.
 377     --pprTrace "Other; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr ";arg=", ppr PprDebug arg, ppr PprDebug arg_demand]) (
 378
 379         -- Finish args to the right...
 380     mk_ww_arg_processing args infos max_extra_args
 381                         `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
 382
 383     returnUs (Just (
 384               -- wrapper:
 385               \ hole -> wrap_rest (App hole (VarArg arg)),
 386
 387               -- worker:
 388               (arg, arg_demand) : work_args_info,
 389               \ hole -> work_rest hole
 390     ))
 391     --)
 392 \end{code}