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