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           ( noSrcLoc )
  22 import Type             ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys,
  23                           maybeAppDataTyConExpandingDicts
  24                         )
  25 import UniqSupply       ( returnUs, thenUs, thenMaybeUs,
  26                           getUniques, SYN_IE(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 Id,                -- 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
 209                          False          -- Initialise the "useful-split" flag
 210                          (mAX_WORKER_ARGS - nonAbsentArgs arg_infos)
 211                 `thenMaybeUs` \ (wrap_frag, work_args_info, work_frag) ->
 212     let
 213         (work_args, wrkr_demands) = unzip work_args_info
 214
 215         wrkr_strictness = mkStrictnessInfo wrkr_demands Nothing -- no worker-of-worker...
 216
 217         wrapper_w_hole = \ worker_id ->
 218                                 mkLam tyvars args (
 219                                 wrap_frag (
 220                                 mkTyApp (Var worker_id) (mkTyVarTys tyvars)
 221                          ))
 222
 223         worker_w_hole = \ orig_body ->
 224                                 mkLam tyvars work_args (
 225                                 work_frag orig_body
 226                         )
 227
 228         worker_ty_w_hole = \ body_ty ->
 229                                 mkForAllTys tyvars $
 230                                 mkFunTys (map idType work_args) body_ty
 231     in
 232     returnUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole))
 233   where
 234     -- "all_absent_args_and_unboxed_value":
 235     -- check for the obscure case of "\ x y z ... -> body" where
 236     -- (a) *all* of the args x, y, z,... are absent, and
 237     -- (b) the type of body is unboxed
 238     -- If these conditions are true, we must *not* play worker/wrapper games!
 239
 240     all_absent_args_and_unboxed_value body_ty arg_infos
 241       = not (null arg_infos)
 242         && all is_absent_arg arg_infos
 243         && isPrimType body_ty
 244
 245     is_absent_arg (WwLazy True) = True
 246     is_absent_arg _             = False
 247 \end{code}
 248
 249 Important: mk_ww_arg_processing doesn't check
 250 for an "interesting" split.  It just races ahead and makes the
 251 split, even if there's no unpacking at all.  This is important for
 252 when it calls itself recursively.
 253
 254 It returns Nothing only if it encounters an abstract type in mid-flight.
 255
 256 \begin{code}
 257 mAX_WORKER_ARGS :: Int          -- ToDo: set via flag
 258 mAX_WORKER_ARGS = 6             -- Hmm... but this is an everything-must-
 259                                 -- be-compiled-with-the-same-val thing...
 260
 261 mk_ww_arg_processing
 262         :: [Id]                 -- Args of original function
 263         -> [Demand]             -- Strictness info for those args
 264                                 --   must be at least as long as args
 265
 266         -> Bool                 -- False <=> we've done nothing useful in an enclosing call
 267                                 -- If this is False when we hit the end of the arg list, we
 268                                 -- don't want to do a w/w split... the wrapper would be the identity fn!
 269                                 -- So we return Nothing
 270
 271         -> Int                  -- Number of extra args we are prepared to add.
 272                                 -- This prevents over-eager unpacking, leading
 273                                 -- to huge-arity functions.
 274
 275         -> UniqSM (Maybe        -- Nothing iff any unpack on abstract type
 276                                 -- or if the wrapper would be the identity fn (can happen if we unpack
 277                                 -- a huge structure, and decide not to do it)
 278
 279                      (CoreExpr -> CoreExpr,     -- Wrapper expr w/
 280                                                         --   hole for worker id
 281                                                         --   applied to types
 282                       [(Id,Demand)],                    -- Worker's args
 283                                                         -- and their strictness info
 284                       CoreExpr -> CoreExpr)     -- Worker body expr w/ hole
 285            )                                            --   for original fn body
 286
 287 mk_ww_arg_processing [] _ useful_split _ = if useful_split then
 288                                                 returnUs (Just (id, [], id))
 289                                            else
 290                                                 returnUs Nothing
 291
 292 mk_ww_arg_processing (arg : args) (WwLazy True : infos) useful_split max_extra_args
 293   =     -- Absent argument
 294         -- So, finish args to the right...
 295     --pprTrace "Absent; num_wrkr_args=" (ppInt num_wrkr_args) (
 296     let
 297         arg_ty = idType arg
 298     in
 299     mk_ww_arg_processing args infos True {- useful split -} max_extra_args
 300                                     -- We've already discounted for absent args,
 301                                     -- so we don't change max_extra_args
 302                    `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
 303
 304                 -- wrapper doesn't pass this arg to worker:
 305     returnUs (Just (
 306                  -- wrapper:
 307                  \ hole -> wrap_rest hole,
 308
 309                  -- worker:
 310                  work_args_info, -- NB: no argument added
 311                  \ hole -> mk_absent_let arg arg_ty (work_rest hole)
 312     ))
 313     --)
 314   where
 315     mk_absent_let arg arg_ty body
 316       = if not (isPrimType arg_ty) then
 317             Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body
 318         else -- quite horrible
 319             panic "WwLib: haven't done mk_absent_let for primitives yet"
 320
 321
 322 mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) useful_split max_extra_args
 323   | new_max_extra_args > 0      -- Check that we are prepared to add arguments
 324   =     -- this is the complicated one.
 325     --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)]) $
 326
 327     case (maybeAppDataTyConExpandingDicts arg_ty) of
 328
 329           Nothing         ->       -- Not a data type
 330                                    panic "mk_ww_arg_processing: not datatype"
 331
 332           Just (_, _, []) ->       -- An abstract type
 333                                    -- We have to give up on the whole idea
 334                                    returnUs Nothing
 335
 336           Just (_, _, (_:_:_)) ->  -- Two or more constructors; that's odd
 337                                    panic "mk_ww_arg_processing: multi-constr"
 338
 339           Just (arg_tycon, tycon_arg_tys, [data_con]) ->
 340                         -- The main event: a single-constructor data type
 341
 342             let
 343                 inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
 344             in
 345             getUniques (length inst_con_arg_tys)    `thenUs` \ uniqs ->
 346
 347             let
 348                 unpk_args = zipWithEqual "mk_ww_arg_processing"
 349                              (\ u t -> mkSysLocal SLIT("upk") u t noSrcLoc)
 350                              uniqs inst_con_arg_tys
 351             in
 352                 -- In processing the rest, push the sub-component args
 353                 -- and infos on the front of the current bunch
 354             mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) True {- useful split -} new_max_extra_args
 355                         `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
 356
 357             returnUs (Just (
 358               -- wrapper: unpack the value
 359               \ hole -> mk_unpk_case arg unpk_args
 360                             data_con arg_tycon
 361                             (wrap_rest hole),
 362
 363               -- worker: expect the unpacked value;
 364               -- reconstruct the orig value with a "let"
 365               work_args_info,
 366               \ hole -> work_rest (mk_pk_let arg data_con tycon_arg_tys unpk_args hole)
 367             ))
 368   where
 369     arg_ty = idType arg
 370
 371     new_max_extra_args
 372       = max_extra_args
 373         + 1                         -- We won't pass the original arg now
 374         - nonAbsentArgs cmpnt_infos -- But we will pass an arg for each cmpt
 375
 376     mk_unpk_case arg unpk_args boxing_con boxing_tycon body
 377       = Case (Var arg) (
 378           AlgAlts [(boxing_con, unpk_args, body)]
 379           NoDefault
 380         )
 381
 382     mk_pk_let arg boxing_con con_tys unpk_args body
 383       = Let (NonRec arg (Con boxing_con
 384                             (map TyArg con_tys ++ map VarArg unpk_args)))
 385               body
 386
 387 mk_ww_arg_processing (arg : args) (arg_demand : infos) useful_split max_extra_args
 388   | otherwise
 389   =     -- For all others at the moment, we just
 390         -- pass them to the worker unchanged.
 391     --pprTrace "Other; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr ";arg=", ppr PprDebug arg, ppr PprDebug arg_demand]) (
 392
 393         -- Finish args to the right...
 394     mk_ww_arg_processing args infos useful_split max_extra_args
 395                         `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
 396
 397     returnUs (Just (
 398               -- wrapper:
 399               \ hole -> wrap_rest (App hole (VarArg arg)),
 400
 401               -- worker:
 402               (arg, arg_demand) : work_args_info,
 403               \ hole -> work_rest hole
 404     ))
 405     --)
 406
 407 nonAbsentArgs :: [Demand] -> Int
 408 nonAbsentArgs cmpts = length [() | WwLazy True <- cmpts]
 409 \end{code}