ghc/compiler/stranal/WwLib.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   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
  14         -- our friendly worker/wrapper monad:
  15         WwM(..),
  16         returnWw, thenWw, mapWw,
  17         getUniqueWw, uniqSMtoWwM,
  18
  19         -- and to make the interface self-sufficient...
  20         GlobalSwitch, CoreBinding, CoreExpr, PlainCoreBinding(..),
  21         PlainCoreExpr(..), Id, Demand, MaybeErr,
  22         TyVar, UniType, Unique, SplitUniqSupply, SUniqSM(..)
  23
  24         IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA getSUnique)
  25         IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily)
  26     ) where
  27
  28 IMPORT_Trace
  29 import Outputable       -- ToDo: rm (debugging)
  30 import Pretty
  31
  32 import AbsPrel          ( aBSENT_ERROR_ID, mkFunTy )
  33 import AbsUniType       ( mkTyVarTy, isPrimType, getUniDataTyCon_maybe,
  34                           quantifyTy, TyVarTemplate
  35                         )
  36 import CmdLineOpts      ( GlobalSwitch(..) )
  37 import Id               ( mkWorkerId, mkSysLocal, getIdUniType,
  38                           getInstantiatedDataConSig, getIdInfo,
  39                           replaceIdInfo, addIdStrictness, DataCon(..)
  40                         )
  41 import IdInfo           -- lots of things
  42 import Maybes           ( maybeToBool, Maybe(..), MaybeErr )
  43 import PlainCore
  44 import SaLib
  45 import SrcLoc           ( mkUnknownSrcLoc )
  46 import SplitUniq
  47 import Unique
  48 import Util
  49
  50 infixr 9 `thenWw`
  51 \end{code}
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection[datatype-WwLib]{@WwBinding@: a datatype for worker/wrapper-ing}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 In the worker/wrapper stuff, we want to carry around @CoreBindings@ in
  60 an ``intermediate form'' that can later be turned into a \tr{let} or
  61 \tr{case} (depending on strictness info).
  62
  63 \begin{code}
  64 data WwBinding
  65   = WwLet  [PlainCoreBinding]
  66   | WwCase (PlainCoreExpr -> PlainCoreExpr)
  67                 -- the "case" will be a "strict let" of the form:
  68                 --
  69                 --  case rhs of
  70                 --    <blah> -> body
  71                 --
  72                 -- (instead of "let <blah> = rhs in body")
  73                 --
  74                 -- The expr you pass to the function is "body" (the
  75                 -- expression that goes "in the corner").
  76 \end{code}
  77
  78 %************************************************************************
  79 %*                                                                      *
  80 \subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
  81 %*                                                                      *
  82 %************************************************************************
  83
  84         ************   WARNING  ******************
  85         these comments are rather out of date
  86         *****************************************
  87
  88 @mkWrapperAndWorker@ is given:
  89 \begin{enumerate}
  90 \item
  91 The {\em original function} \tr{f}, of the form:
  92 \begin{verbatim}
  93 f = /\ tyvars -> \ args -> body
  94 \end{verbatim}
  95 The original-binder \tr{f}, the \tr{tyvars}, \tr{args}, and \tr{body}
  96 are given separately.
  97
  98 We use the Id \tr{f} mostly to get its type.
  99
 100 \item
 101 Strictness information about \tr{f}, in the form of a list of
 102 @Demands@.
 103
 104 \item
 105 A @UniqueSupply@.
 106 \end{enumerate}
 107
 108 @mkWrapperAndWorker@ produces (A BIT OUT-OF-DATE...):
 109 \begin{enumerate}
 110 \item
 111 Maybe @Nothing@: no worker/wrappering going on in this case. This can
 112 happen (a)~if the strictness info says that there is nothing
 113 interesting to do or (b)~if *any* of the argument types corresponding
 114 to ``active'' arg postitions is abstract or will be to the outside
 115 world (i.e., {\em this} module can see the constructors, but nobody
 116 else will be able to).  An ``active'' arg position is one which the
 117 wrapper has to unpack.  An importing module can't do this unpacking,
 118 so it simply has to give up and call the wrapper only.
 119
 120 \item
 121 Maybe \tr{Just (wrapper_Id, wrapper_body, worker_Id, worker_body)}.
 122
 123 The @wrapper_Id@ is just the one that was passed in, with its
 124 strictness IdInfo updated.
 125 \end{enumerate}
 126
 127 The \tr{body} of the original function may not be given (i.e., it's
 128 BOTTOM), in which case you'd jolly well better not tug on the
 129 worker-body output!
 130
 131 Here's an example.  The original function is:
 132 \begin{verbatim}
 133 g :: forall a . Int -> [a] -> a
 134
 135 g = /\ a -> \ x ys ->
 136         case x of
 137           0 -> head ys
 138           _ -> head (tail ys)
 139 \end{verbatim}
 140
 141 From this, we want to produce:
 142 \begin{verbatim}
 143 -- wrapper (an unfolding)
 144 g :: forall a . Int -> [a] -> a
 145
 146 g = /\ a -> \ x ys ->
 147         case x of
 148           I# x# -> g.wrk a x# ys
 149             -- call the worker; don't forget the type args!
 150
 151 -- worker
 152 g.wrk :: forall a . Int# -> [a] -> a
 153
 154 g.wrk = /\ a -> \ x# ys ->
 155         let
 156             x = I# x#
 157         in
 158             case x of               -- note: body of g moved intact
 159               0 -> head ys
 160               _ -> head (tail ys)
 161 \end{verbatim}
 162
 163 Something we have to be careful about:  Here's an example:
 164 \begin{verbatim}
 165 -- "f" strictness: U(P)U(P)
 166 f (I# a) (I# b) = a +# b
 167
 168 g = f   -- "g" strictness same as "f"
 169 \end{verbatim}
 170 \tr{f} will get a worker all nice and friendly-like; that's good.
 171 {\em But we don't want a worker for \tr{g}}, even though it has the
 172 same strictness as \tr{f}.  Doing so could break laziness, at best.
 173
 174 Consequently, we insist that the number of strictness-info items is
 175 exactly the same as the number of lambda-bound arguments.  (This is
 176 probably slightly paranoid, but OK in practice.)  If it isn't the
 177 same, we ``revise'' the strictness info, so that we won't propagate
 178 the unusable strictness-info into the interfaces.
 179
 180 ==========================
 181
 182 Here's the real fun... The wrapper's ``deconstructing'' of arguments
 183 and the worker's putting them back together again are ``duals'' in
 184 some sense.
 185
 186 What we do is walk along the @Demand@ list, producing two
 187 expressions (one for wrapper, one for worker...), each with a ``hole''
 188 in it, where we will later plug in more information.  For our previous
 189 example, the expressions-with-HOLES are:
 190 \begin{verbatim}
 191 \ x ys ->               -- wrapper
 192         case x of
 193           I# x# -> <<HOLE>> x# ys
 194
 195 \ x# ys ->              -- worker
 196         let
 197             x = I# x#
 198         in
 199             <<HOLE>>
 200 \end{verbatim}
 201 (Actually, we add the lambda-bound arguments at the end...) (The big
 202 Lambdas are added on the front later.)
 203
 204 \begin{code}
 205 mkWwBodies
 206         :: UniType              -- Type of the *body* of the orig
 207                                 -- function; i.e. /\ tyvars -> \ vars -> body
 208         -> [TyVar]              -- Type lambda vars of original function
 209         -> [Id]                 -- Args of original function
 210         -> [Demand]             -- Strictness info for those args
 211
 212         -> SUniqSM (Maybe       -- Nothing iff (a) no interesting split possible
 213                                 --             (b) any unpack on abstract type
 214                      (Id -> PlainCoreExpr,              -- Wrapper expr w/
 215                                                         --   hole for worker id
 216                       PlainCoreExpr -> PlainCoreExpr,   -- Worker expr w/ hole
 217                                                         --   for original fn body
 218                       StrictnessInfo,                   -- Worker strictness info
 219                       UniType -> UniType)               -- Worker type w/ hole
 220            )                                            --   for type of original fn body
 221
 222
 223 mkWwBodies body_ty tyvars args arg_infos
 224   = ASSERT(length args == length arg_infos)
 225     -- or you can get disastrous user/definer-module mismatches
 226     if (all_absent_args_and_unboxed_value body_ty arg_infos)
 227     then returnSUs Nothing
 228
 229     else -- the rest...
 230     mk_ww_arg_processing args arg_infos (mAX_WORKER_ARGS - nonAbsentArgs arg_infos)
 231                 `thenUsMaybe` \ (wrap_frag, work_args_info, work_frag) ->
 232     let
 233         (work_args, wrkr_demands) = unzip work_args_info
 234
 235         wrkr_strictness = mkStrictnessInfo wrkr_demands Nothing -- no worker-of-worker...
 236
 237         wrapper_w_hole = \ worker_id ->
 238                                 mkCoTyLam tyvars (
 239                                 mkCoLam args (
 240                                 wrap_frag (
 241                                 mkCoTyApps (CoVar worker_id) (map mkTyVarTy tyvars)
 242                          )))
 243
 244         worker_w_hole = \ orig_body ->
 245                                 mkCoTyLam tyvars (
 246                                 mkCoLam work_args (
 247                                 work_frag orig_body
 248                         ))
 249
 250         worker_ty_w_hole = \ body_ty ->
 251                                 snd (quantifyTy tyvars (
 252                                 foldr mkFunTy body_ty (map getIdUniType work_args)
 253                            ))
 254     in
 255     returnSUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole))
 256   where
 257     -- "all_absent_args_and_unboxed_value":
 258     -- check for the obscure case of "\ x y z ... -> body" where
 259     -- (a) *all* of the args x, y, z,... are absent, and
 260     -- (b) the type of body is unboxed
 261     -- If these conditions are true, we must *not* play worker/wrapper games!
 262
 263     all_absent_args_and_unboxed_value body_ty arg_infos
 264       = not (null arg_infos)
 265         && all is_absent_arg arg_infos
 266         && isPrimType body_ty
 267
 268     is_absent_arg (WwLazy True) = True
 269     is_absent_arg _             = False
 270 \end{code}
 271
 272 Important: mk_ww_arg_processing doesn't check
 273 for an "interesting" split.  It just races ahead and makes the
 274 split, even if there's no unpacking at all.  This is important for
 275 when it calls itself recursively.
 276
 277 It returns Nothing only if it encounters an abstract type in mid-flight.
 278
 279 \begin{code}
 280 mAX_WORKER_ARGS :: Int          -- ToDo: set via flag
 281 mAX_WORKER_ARGS = 6             -- Hmm... but this is an everything-must-
 282                                 -- be-compiled-with-the-same-val thing...
 283
 284 mk_ww_arg_processing
 285         :: [Id]                 -- Args of original function
 286         -> [Demand]             -- Strictness info for those args
 287                                 --   must be at least as long as args
 288
 289         -> Int                  -- Number of extra args we are prepared to add.
 290                                 -- This prevents over-eager unpacking, leading
 291                                 -- to huge-arity functions.
 292
 293         -> SUniqSM (Maybe       -- Nothing iff any unpack on abstract type
 294                      (PlainCoreExpr -> PlainCoreExpr,   -- Wrapper expr w/
 295                                                         --   hole for worker id
 296                                                         --   applied to types
 297                       [(Id,Demand)],                    -- Worker's args
 298                                                         -- and their strictness info
 299                       PlainCoreExpr -> PlainCoreExpr)   -- Worker body expr w/ hole
 300            )                                            --   for original fn body
 301
 302 mk_ww_arg_processing [] _ _ = returnSUs (Just (id, [], id))
 303
 304 mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args
 305   =     -- Absent argument
 306         -- So, finish args to the right...
 307     --pprTrace "Absent; num_wrkr_args=" (ppInt num_wrkr_args) (
 308     let
 309         arg_ty = getIdUniType arg
 310     in
 311     mk_ww_arg_processing args infos max_extra_args
 312                                     -- we've already discounted for absent args,
 313                                     -- so we don't change max_extra_args
 314                    `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) ->
 315
 316                 -- wrapper doesn't pass this arg to worker:
 317     returnSUs (Just (
 318                  -- wrapper:
 319                  \ hole -> wrap_rest hole,
 320
 321                  -- worker:
 322                  work_args_info, -- NB: no argument added
 323                  \ hole -> mk_absent_let arg arg_ty (work_rest hole)
 324     ))
 325     --)
 326   where
 327     mk_absent_let arg arg_ty body
 328       = if not (isPrimType arg_ty) then
 329             CoLet (CoNonRec arg (mkCoTyApp (CoVar aBSENT_ERROR_ID) arg_ty))
 330                   body
 331         else -- quite horrible
 332             panic "WwLib: haven't done mk_absent_let for primitives yet"
 333
 334
 335 mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args
 336   | new_max_extra_args > 0      -- Check that we are prepared to add arguments
 337   =     -- this is the complicated one.
 338     --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)]) (
 339     case getUniDataTyCon_maybe arg_ty of
 340
 341           Nothing         ->       -- Not a data type
 342                                    panic "mk_ww_arg_processing: not datatype"
 343
 344           Just (_, _, []) ->       -- An abstract type
 345                                    -- We have to give up on the whole idea
 346                                    returnSUs Nothing
 347           Just (_, _, (_:_:_)) ->  -- Two or more constructors; that's odd
 348                                    panic "mk_ww_arg_processing: multi-constr"
 349
 350           Just (arg_tycon, tycon_arg_tys, [data_con]) ->
 351                         -- The main event: a single-constructor data type
 352
 353             let
 354                 (_,inst_con_arg_tys,_)
 355                   = getInstantiatedDataConSig data_con tycon_arg_tys
 356             in
 357             getSUniques (length inst_con_arg_tys)    `thenSUs` \ uniqs ->
 358
 359             let unpk_args = zipWith (\ u t -> mkSysLocal SLIT("upk") u t mkUnknownSrcLoc)
 360                                     uniqs inst_con_arg_tys
 361             in
 362                 -- In processing the rest, push the sub-component args
 363                 -- and infos on the front of the current bunch
 364             mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) new_max_extra_args
 365                         `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) ->
 366
 367             returnSUs (Just (
 368               -- wrapper: unpack the value
 369               \ hole -> mk_unpk_case arg unpk_args
 370                             data_con arg_tycon
 371                             (wrap_rest hole),
 372
 373               -- worker: expect the unpacked value;
 374               -- reconstruct the orig value with a "let"
 375               work_args_info,
 376               \ hole -> work_rest (mk_pk_let arg data_con tycon_arg_tys unpk_args hole)
 377             ))
 378     --)
 379   where
 380     arg_ty = getIdUniType arg
 381
 382     new_max_extra_args
 383       = max_extra_args
 384         + 1                         -- We won't pass the original arg now
 385         - nonAbsentArgs cmpnt_infos -- But we will pass an arg for each cmpt
 386
 387     mk_unpk_case arg unpk_args boxing_con boxing_tycon body
 388       = CoCase (CoVar arg) (
 389           CoAlgAlts [(boxing_con, unpk_args, body)]
 390           CoNoDefault
 391         )
 392
 393     mk_pk_let arg boxing_con con_tys unpk_args body
 394       = CoLet (CoNonRec arg (CoCon boxing_con con_tys [CoVarAtom a | a <- unpk_args]))
 395               body
 396
 397 mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args
 398   | otherwise
 399   =     -- For all others at the moment, we just
 400         -- pass them to the worker unchanged.
 401     --pprTrace "Other; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr ";arg=", ppr PprDebug arg, ppr PprDebug arg_demand]) (
 402
 403         -- Finish args to the right...
 404     mk_ww_arg_processing args infos max_extra_args
 405                         `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) ->
 406
 407     returnSUs (Just (
 408               -- wrapper:
 409               \ hole -> wrap_rest (CoApp hole (CoVarAtom arg)),
 410
 411               -- worker:
 412               (arg, arg_demand) : work_args_info,
 413               \ hole -> work_rest hole
 414     ))
 415     --)
 416 \end{code}
 417
 418 %************************************************************************
 419 %*                                                                      *
 420 \subsection[monad-WwLib]{Simple monad for worker/wrapper}
 421 %*                                                                      *
 422 %************************************************************************
 423
 424 In this monad, we thread a @UniqueSupply@, and we carry a
 425 @GlobalSwitch@-lookup function downwards.
 426
 427 \begin{code}
 428 type WwM result
 429   =  SplitUniqSupply
 430   -> (GlobalSwitch -> Bool)
 431   -> result
 432
 433 #ifdef __GLASGOW_HASKELL__
 434 {-# INLINE thenWw #-}
 435 {-# INLINE returnWw #-}
 436 #endif
 437
 438 returnWw :: a -> WwM a
 439 thenWw   :: WwM a -> (a -> WwM b) -> WwM b
 440 mapWw    :: (a -> WwM b) -> [a] -> WwM [b]
 441
 442 returnWw expr ns sw = expr
 443
 444 thenWw m k us sw_chk
 445   = case splitUniqSupply us     of { (s1, s2) ->
 446     case (m s1 sw_chk)          of { m_res ->
 447     k m_res s2 sw_chk }}
 448
 449 mapWw f []     = returnWw []
 450 mapWw f (x:xs)
 451   = f x         `thenWw` \ x'  ->
 452     mapWw f xs  `thenWw` \ xs' ->
 453     returnWw (x':xs')
 454 \end{code}
 455
 456 \begin{code}
 457 getUniqueWw :: WwM Unique
 458 uniqSMtoWwM :: SUniqSM a -> WwM a
 459
 460 getUniqueWw us sw_chk = getSUnique us
 461
 462 uniqSMtoWwM u_obj us sw_chk = u_obj us
 463
 464 thenUsMaybe :: SUniqSM (Maybe a) -> (a -> SUniqSM (Maybe b)) -> SUniqSM (Maybe b)
 465 thenUsMaybe m k
 466   = m   `thenSUs` \ result ->
 467     case result of
 468       Nothing -> returnSUs Nothing
 469       Just x  -> k x
 470 \end{code}