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         worthSplitting, setUnpackStrategy,
  13         mkWwBodies, mkWrapper
  14     ) where
  15
  16 IMP_Ubiq(){-uitous-}
  17 IMPORT_1_3(List(nub))
  18
  19 import CoreSyn
  20 import Id               ( GenId, idType, mkSysLocal, dataConArgTys, isDataCon, isNewCon, SYN_IE(Id) )
  21 import IdInfo           ( mkStrictnessInfo, {-??nonAbsentArgs,-} Demand(..) )
  22 import PrelVals         ( aBSENT_ERROR_ID, voidId )
  23 import TysPrim          ( voidTy )
  24 import SrcLoc           ( noSrcLoc )
  25 import Type             ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys,
  26                           splitForAllTyExpandingDicts, splitForAllTy, splitFunTyExpandingDicts,
  27                           maybeAppDataTyConExpandingDicts,
  28                           SYN_IE(Type)
  29                         )
  30 import TyCon            ( isNewTyCon, isDataTyCon )
  31 import BasicTypes       ( NewOrData(..) )
  32 import TyVar            ( SYN_IE(TyVar) )
  33 import PprType          ( GenType, GenTyVar )
  34 import UniqSupply       ( returnUs, thenUs, thenMaybeUs,
  35                           getUniques, getUnique, SYN_IE(UniqSM)
  36                         )
  37 import Util             ( zipWithEqual, zipEqual, assertPanic, panic, pprPanic )
  38 import Pretty
  39 import Outputable
  40 \end{code}
  41
  42 %************************************************************************
  43 %*                                                                      *
  44 \subsection[datatype-WwLib]{@WwBinding@: a datatype for worker/wrapper-ing}
  45 %*                                                                      *
  46 %************************************************************************
  47
  48 In the worker/wrapper stuff, we want to carry around @CoreBindings@ in
  49 an ``intermediate form'' that can later be turned into a \tr{let} or
  50 \tr{case} (depending on strictness info).
  51
  52 \begin{code}
  53 data WwBinding
  54   = WwLet  [CoreBinding]
  55   | WwCase (CoreExpr -> CoreExpr)
  56                 -- the "case" will be a "strict let" of the form:
  57                 --
  58                 --  case rhs of
  59                 --    <blah> -> body
  60                 --
  61                 -- (instead of "let <blah> = rhs in body")
  62                 --
  63                 -- The expr you pass to the function is "body" (the
  64                 -- expression that goes "in the corner").
  65 \end{code}
  66
  67 %************************************************************************
  68 %*                                                                      *
  69 \subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
  70 %*                                                                      *
  71 %************************************************************************
  72
  73         ************   WARNING  ******************
  74         these comments are rather out of date
  75         *****************************************
  76
  77 @mkWrapperAndWorker@ is given:
  78 \begin{enumerate}
  79 \item
  80 The {\em original function} \tr{f}, of the form:
  81 \begin{verbatim}
  82 f = /\ tyvars -> \ args -> body
  83 \end{verbatim}
  84 The original-binder \tr{f}, the \tr{tyvars}, \tr{args}, and \tr{body}
  85 are given separately.
  86
  87 We use the Id \tr{f} mostly to get its type.
  88
  89 \item
  90 Strictness information about \tr{f}, in the form of a list of
  91 @Demands@.
  92
  93 \item
  94 A @UniqueSupply@.
  95 \end{enumerate}
  96
  97 @mkWrapperAndWorker@ produces (A BIT OUT-OF-DATE...):
  98 \begin{enumerate}
  99 \item
 100 Maybe @Nothing@: no worker/wrappering going on in this case. This can
 101 happen (a)~if the strictness info says that there is nothing
 102 interesting to do or (b)~if *any* of the argument types corresponding
 103 to ``active'' arg postitions is abstract or will be to the outside
 104 world (i.e., {\em this} module can see the constructors, but nobody
 105 else will be able to).  An ``active'' arg position is one which the
 106 wrapper has to unpack.  An importing module can't do this unpacking,
 107 so it simply has to give up and call the wrapper only.
 108
 109 \item
 110 Maybe \tr{Just (wrapper_Id, wrapper_body, worker_Id, worker_body)}.
 111
 112 The @wrapper_Id@ is just the one that was passed in, with its
 113 strictness IdInfo updated.
 114 \end{enumerate}
 115
 116 The \tr{body} of the original function may not be given (i.e., it's
 117 BOTTOM), in which case you'd jolly well better not tug on the
 118 worker-body output!
 119
 120 Here's an example.  The original function is:
 121 \begin{verbatim}
 122 g :: forall a . Int -> [a] -> a
 123
 124 g = /\ a -> \ x ys ->
 125         case x of
 126           0 -> head ys
 127           _ -> head (tail ys)
 128 \end{verbatim}
 129
 130 From this, we want to produce:
 131 \begin{verbatim}
 132 -- wrapper (an unfolding)
 133 g :: forall a . Int -> [a] -> a
 134
 135 g = /\ a -> \ x ys ->
 136         case x of
 137           I# x# -> g.wrk a x# ys
 138             -- call the worker; don't forget the type args!
 139
 140 -- worker
 141 g.wrk :: forall a . Int# -> [a] -> a
 142
 143 g.wrk = /\ a -> \ x# ys ->
 144         let
 145             x = I# x#
 146         in
 147             case x of               -- note: body of g moved intact
 148               0 -> head ys
 149               _ -> head (tail ys)
 150 \end{verbatim}
 151
 152 Something we have to be careful about:  Here's an example:
 153 \begin{verbatim}
 154 -- "f" strictness: U(P)U(P)
 155 f (I# a) (I# b) = a +# b
 156
 157 g = f   -- "g" strictness same as "f"
 158 \end{verbatim}
 159 \tr{f} will get a worker all nice and friendly-like; that's good.
 160 {\em But we don't want a worker for \tr{g}}, even though it has the
 161 same strictness as \tr{f}.  Doing so could break laziness, at best.
 162
 163 Consequently, we insist that the number of strictness-info items is
 164 exactly the same as the number of lambda-bound arguments.  (This is
 165 probably slightly paranoid, but OK in practice.)  If it isn't the
 166 same, we ``revise'' the strictness info, so that we won't propagate
 167 the unusable strictness-info into the interfaces.
 168
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsection{Functions over Demands}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 \begin{code}
 177 mAX_WORKER_ARGS :: Int          -- ToDo: set via flag
 178 mAX_WORKER_ARGS = 6
 179
 180 setUnpackStrategy :: [Demand] -> [Demand]
 181 setUnpackStrategy ds
 182   = snd (go (mAX_WORKER_ARGS - nonAbsentArgs ds) ds)
 183   where
 184     go :: Int                   -- Max number of args available for sub-components of [Demand]
 185        -> [Demand]
 186        -> (Int, [Demand])       -- Args remaining after subcomponents of [Demand] are unpacked
 187
 188     go n (WwUnpack nd _ cs : ds) | n' >= 0
 189                                  = WwUnpack nd True cs' `cons` go n'' ds
 190                                  | otherwise
 191                                  = WwUnpack nd False cs `cons` go n ds
 192                                  where
 193                                    n' = n + 1 - nonAbsentArgs cs
 194                                         -- Add one because we don't pass the top-level arg any more
 195                                         -- Delete # of non-absent args to which we'll now be committed
 196                                    (n'',cs') = go n' cs
 197
 198     go n (d:ds) = d `cons` go n ds
 199     go n []     = (n,[])
 200
 201     cons d (n,ds) = (n, d:ds)
 202
 203 nonAbsentArgs :: [Demand] -> Int
 204 nonAbsentArgs []                 = 0
 205 nonAbsentArgs (WwLazy True : ds) = nonAbsentArgs ds
 206 nonAbsentArgs (d           : ds) = 1 + nonAbsentArgs ds
 207
 208 worthSplitting :: [Demand] -> Bool      -- True <=> the wrapper would not be an identity function
 209 worthSplitting []                       = False
 210 worthSplitting (WwLazy True : ds)       = True          -- Absent arg
 211 worthSplitting (WwUnpack _ True _ : ds) = True          -- Arg to unpack
 212 worthSplitting (d : ds)                 = worthSplitting ds
 213
 214 allAbsent :: [Demand] -> Bool
 215 allAbsent (WwLazy True      : ds)   = allAbsent ds
 216 allAbsent (WwUnpack _ True cs : ds) = allAbsent cs && allAbsent ds
 217 allAbsent (d                : ds)   = False
 218 allAbsent []                        = True
 219 \end{code}
 220
 221
 222 %************************************************************************
 223 %*                                                                      *
 224 \subsection{The worker wrapper core}
 225 %*                                                                      *
 226 %************************************************************************
 227
 228 @mkWrapper@ is called when importing a function.  We have the type of
 229 the function and the name of its worker, and we want to make its body (the wrapper).
 230
 231 \begin{code}
 232 mkWrapper :: Type               -- Wrapper type
 233           -> [Demand]           -- Wrapper strictness info
 234           -> UniqSM (Id -> CoreExpr)    -- Wrapper body, missing worker Id
 235
 236 mkWrapper fun_ty demands
 237   = let
 238         n_wrap_args = length demands
 239     in
 240     getUniques n_wrap_args      `thenUs` \ wrap_uniqs ->
 241     let
 242         (tyvars, tau_ty)   = splitForAllTyExpandingDicts fun_ty
 243         (arg_tys, body_ty) = splitFunTyExpandingDicts tau_ty
 244                 -- The "expanding dicts" part here is important, even for the splitForAll
 245                 -- The imported thing might be a dictionary, such as Functor Foo
 246                 -- But Functor Foo = forall a b. (a->b) -> Foo a -> Foo b
 247                 -- and as such might have some strictness info attached.
 248                 -- Then we need to have enough args to zip to the strictness info
 249
 250         wrap_args          = zipWith mk_ww_local wrap_uniqs arg_tys
 251         leftover_arg_tys   = drop n_wrap_args arg_tys
 252         final_body_ty      = mkFunTys leftover_arg_tys body_ty
 253     in
 254     mkWwBodies tyvars wrap_args final_body_ty demands   `thenUs` \ (wrap_fn, _, _) ->
 255     returnUs wrap_fn
 256 \end{code}
 257
 258 @mkWwBodies@ is called when doing the worker/wrapper split inside a module.
 259
 260 \begin{code}
 261 mkWwBodies :: [TyVar] -> [Id] -> Type           -- Original fn args and body type
 262            -> [Demand]                          -- Strictness info for original fn; corresp 1-1 with args
 263            -> UniqSM (Id -> CoreExpr,           -- Wrapper body, lacking only the worker Id
 264                       CoreExpr -> CoreExpr,     -- Worker body, lacking the original function body
 265                       [Demand])                 -- Strictness info for worker
 266
 267 mkWwBodies tyvars args body_ty demands
 268   | allAbsent demands &&
 269     isPrimType body_ty
 270   =     -- Horrid special case.  If the worker would have no arguments, and the
 271         -- function returns a primitive type value, that would make the worker into
 272         -- an unboxed value.  We box it by passing a dummy void argument, thus:
 273         --
 274         --      f = /\abc. \xyz. fw abc void
 275         --      fw = /\abc. \v. body
 276         --
 277     getUnique           `thenUs` \ void_arg_uniq ->
 278     let
 279         void_arg = mk_ww_local void_arg_uniq voidTy
 280     in
 281     returnUs (\ work_id -> mkLam tyvars args (App (mkTyApp (Var work_id) (mkTyVarTys tyvars)) (VarArg voidId)),
 282               \ body    -> mkLam tyvars [void_arg] body,
 283               [WwLazy True])
 284
 285 mkWwBodies tyvars args body_ty demands
 286   | otherwise
 287   = let
 288         args_w_demands = zipEqual "mkWwBodies" args demands
 289     in
 290     mkWW args_w_demands         `thenUs` \ (wrap_fn, work_args_w_demands, work_fn) ->
 291     let
 292         (work_args, work_demands) = unzip work_args_w_demands
 293     in
 294     returnUs (\ work_id -> mkLam tyvars args (wrap_fn (mkTyApp (Var work_id) (mkTyVarTys tyvars))),
 295               \ body    -> mkLam tyvars work_args (work_fn body),
 296               work_demands)
 297 \end{code}
 298
 299
 300 \begin{code}
 301 mkWW :: [(Id,Demand)]
 302      -> UniqSM (CoreExpr -> CoreExpr,   -- Wrapper body, lacking the inner call to the worker
 303                                         -- and without its lambdas
 304                 [(Id,Demand)],          -- Worker args and their demand infos
 305                 CoreExpr -> CoreExpr)   -- Worker body, lacking the original body of the function
 306
 307
 308         -- Empty case
 309 mkWW []
 310   = returnUs (\ wrapper_body -> wrapper_body,
 311               [],
 312               \ worker_body  -> worker_body)
 313
 314
 315         -- Absent case
 316 mkWW ((arg,WwLazy True) : ds)
 317   = mkWW ds             `thenUs` \ (wrap_fn, worker_args, work_fn) ->
 318     returnUs (\ wrapper_body -> wrap_fn wrapper_body,
 319               worker_args,
 320               \ worker_body  -> mk_absent_let arg (work_fn worker_body))
 321
 322
 323         -- Unpack case
 324 mkWW ((arg,WwUnpack new_or_data True cs) : ds)
 325   = getUniques (length inst_con_arg_tys)                `thenUs` \ uniqs ->
 326     let
 327         unpk_args        = zipWith mk_ww_local uniqs inst_con_arg_tys
 328         unpk_args_w_ds   = zipEqual "mkWW" unpk_args cs
 329     in
 330     mkWW (unpk_args_w_ds ++ ds)         `thenUs` \ (wrap_fn, worker_args, work_fn) ->
 331     returnUs (\ wrapper_body -> mk_unpk_case new_or_data arg unpk_args data_con arg_tycon (wrap_fn wrapper_body),
 332               worker_args,
 333               \ worker_body  -> work_fn (mk_pk_let new_or_data arg data_con tycon_arg_tys unpk_args worker_body))
 334   where
 335     inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
 336     (arg_tycon, tycon_arg_tys, data_con)
 337         = case (maybeAppDataTyConExpandingDicts (idType arg)) of
 338
 339               Just (arg_tycon, tycon_arg_tys, [data_con]) ->
 340                                      -- The main event: a single-constructor data type
 341                                      (arg_tycon, tycon_arg_tys, data_con)
 342
 343               Just (_, _, data_cons) ->  pprPanic "mk_ww_arg_processing: not one constr (interface files not consistent/up to date ?)" ((ppr PprDebug arg) <+> (ppr PprDebug (idType arg)))
 344               Nothing                ->  panic "mk_ww_arg_processing: not datatype"
 345
 346
 347         -- Other cases
 348 mkWW ((arg,other_demand) : ds)
 349   = mkWW ds             `thenUs` \ (wrap_fn, worker_args, work_fn) ->
 350     returnUs (\ wrapper_body -> wrap_fn (App wrapper_body (VarArg arg)),
 351               (arg,other_demand) : worker_args,
 352               work_fn)
 353 \end{code}
 354
 355
 356 %************************************************************************
 357 %*                                                                      *
 358 \subsection{Utilities}
 359 %*                                                                      *
 360 %************************************************************************
 361
 362
 363 \begin{code}
 364 mk_absent_let arg body
 365   | not (isPrimType arg_ty)
 366   = Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body
 367   | otherwise
 368   = panic "WwLib: haven't done mk_absent_let for primitives yet"
 369   where
 370     arg_ty = idType arg
 371
 372 mk_unpk_case NewType arg unpk_args boxing_con boxing_tycon body
 373         -- A newtype!  Use a coercion not a case
 374   = ASSERT( null other_args && isNewTyCon boxing_tycon )
 375     Let (NonRec unpk_arg (Coerce (CoerceOut boxing_con) (idType unpk_arg) (Var arg)))
 376         body
 377   where
 378     (unpk_arg:other_args) = unpk_args
 379
 380 mk_unpk_case DataType arg unpk_args boxing_con boxing_tycon body
 381         -- A data type
 382   = ASSERT( isDataTyCon boxing_tycon )
 383     Case (Var arg)
 384          (AlgAlts [(boxing_con, unpk_args, body)]
 385                   NoDefault
 386          )
 387
 388 mk_pk_let NewType arg boxing_con con_tys unpk_args body
 389   = ASSERT( null other_args && isNewCon boxing_con )
 390     Let (NonRec arg (Coerce (CoerceIn boxing_con) (idType arg) (Var unpk_arg))) body
 391   where
 392     (unpk_arg:other_args) = unpk_args
 393
 394 mk_pk_let DataType arg boxing_con con_tys unpk_args body
 395   = ASSERT( isDataCon boxing_con )
 396     Let (NonRec arg (Con boxing_con con_args)) body
 397   where
 398     con_args = map TyArg con_tys ++ map VarArg unpk_args
 399
 400
 401 mk_ww_local uniq ty
 402   = mkSysLocal SLIT("ww") uniq ty noSrcLoc
 403 \end{code}