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         (tyvars, tau_ty)   = splitForAllTy fun_ty
 244         (arg_tys, body_ty) = splitFunTyExpandingDicts tau_ty
 245                 -- The "expanding dicts" part here is important, even for the splitForAll
 246                 -- The imported thing might be a dictionary, such as Functor Foo
 247                 -- But Functor Foo = forall a b. (a->b) -> Foo a -> Foo b
 248                 -- and as such might have some strictness info attached.
 249                 -- Then we need to have enough args to zip to the strictness info
 250
 251         wrap_args          = zipWith mk_ww_local wrap_uniqs arg_tys
 252         leftover_arg_tys   = drop n_wrap_args arg_tys
 253         final_body_ty      = mkFunTys leftover_arg_tys body_ty
 254     in
 255     mkWwBodies tyvars wrap_args final_body_ty demands   `thenUs` \ (wrap_fn, _, _) ->
 256     returnUs wrap_fn
 257 \end{code}
 258
 259 @mkWwBodies@ is called when doing the worker/wrapper split inside a module.
 260
 261 \begin{code}
 262 mkWwBodies :: [TyVar] -> [Id] -> Type           -- Original fn args and body type
 263            -> [Demand]                          -- Strictness info for original fn; corresp 1-1 with args
 264            -> UniqSM (Id -> CoreExpr,           -- Wrapper body, lacking only the worker Id
 265                       CoreExpr -> CoreExpr,     -- Worker body, lacking the original function body
 266                       [Demand])                 -- Strictness info for worker
 267
 268 mkWwBodies tyvars args body_ty demands
 269   | allAbsent demands &&
 270     isPrimType body_ty
 271   =     -- Horrid special case.  If the worker would have no arguments, and the
 272         -- function returns a primitive type value, that would make the worker into
 273         -- an unboxed value.  We box it by passing a dummy void argument, thus:
 274         --
 275         --      f = /\abc. \xyz. fw abc void
 276         --      fw = /\abc. \v. body
 277         --
 278     getUnique           `thenUs` \ void_arg_uniq ->
 279     let
 280         void_arg = mk_ww_local void_arg_uniq voidTy
 281     in
 282     returnUs (\ work_id -> mkLam tyvars args (App (mkTyApp (Var work_id) (mkTyVarTys tyvars)) (VarArg voidId)),
 283               \ body    -> mkLam tyvars [void_arg] body,
 284               [WwLazy True])
 285
 286 mkWwBodies tyvars args body_ty demands
 287   | otherwise
 288   = let
 289         args_w_demands = zipEqual "mkWwBodies" args demands
 290     in
 291     mkWW args_w_demands         `thenUs` \ (wrap_fn, work_args_w_demands, work_fn) ->
 292     let
 293         (work_args, work_demands) = unzip work_args_w_demands
 294     in
 295     returnUs (\ work_id -> mkLam tyvars args (wrap_fn (mkTyApp (Var work_id) (mkTyVarTys tyvars))),
 296               \ body    -> mkLam tyvars work_args (work_fn body),
 297               work_demands)
 298 \end{code}
 299
 300
 301 \begin{code}
 302 mkWW :: [(Id,Demand)]
 303      -> UniqSM (CoreExpr -> CoreExpr,   -- Wrapper body, lacking the inner call to the worker
 304                                         -- and without its lambdas
 305                 [(Id,Demand)],          -- Worker args and their demand infos
 306                 CoreExpr -> CoreExpr)   -- Worker body, lacking the original body of the function
 307
 308
 309         -- Empty case
 310 mkWW []
 311   = returnUs (\ wrapper_body -> wrapper_body,
 312               [],
 313               \ worker_body  -> worker_body)
 314
 315
 316         -- Absent case
 317 mkWW ((arg,WwLazy True) : ds)
 318   = mkWW ds             `thenUs` \ (wrap_fn, worker_args, work_fn) ->
 319     returnUs (\ wrapper_body -> wrap_fn wrapper_body,
 320               worker_args,
 321               \ worker_body  -> mk_absent_let arg (work_fn worker_body))
 322
 323
 324         -- Unpack case
 325 mkWW ((arg,WwUnpack new_or_data True cs) : ds)
 326   = getUniques (length inst_con_arg_tys)                `thenUs` \ uniqs ->
 327     let
 328         unpk_args        = zipWith mk_ww_local uniqs inst_con_arg_tys
 329         unpk_args_w_ds   = zipEqual "mkWW" unpk_args cs
 330     in
 331     mkWW (unpk_args_w_ds ++ ds)         `thenUs` \ (wrap_fn, worker_args, work_fn) ->
 332     returnUs (\ wrapper_body -> mk_unpk_case new_or_data arg unpk_args data_con arg_tycon (wrap_fn wrapper_body),
 333               worker_args,
 334               \ worker_body  -> work_fn (mk_pk_let new_or_data arg data_con tycon_arg_tys unpk_args worker_body))
 335   where
 336     inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
 337     (arg_tycon, tycon_arg_tys, data_con)
 338         = case (maybeAppDataTyConExpandingDicts (idType arg)) of
 339
 340               Just (arg_tycon, tycon_arg_tys, [data_con]) ->
 341                                      -- The main event: a single-constructor data type
 342                                      (arg_tycon, tycon_arg_tys, data_con)
 343
 344               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)))
 345               Nothing                ->  panic "mk_ww_arg_processing: not datatype"
 346
 347
 348         -- Other cases
 349 mkWW ((arg,other_demand) : ds)
 350   = mkWW ds             `thenUs` \ (wrap_fn, worker_args, work_fn) ->
 351     returnUs (\ wrapper_body -> wrap_fn (App wrapper_body (VarArg arg)),
 352               (arg,other_demand) : worker_args,
 353               work_fn)
 354 \end{code}
 355
 356
 357 %************************************************************************
 358 %*                                                                      *
 359 \subsection{Utilities}
 360 %*                                                                      *
 361 %************************************************************************
 362
 363
 364 \begin{code}
 365 mk_absent_let arg body
 366   | not (isPrimType arg_ty)
 367   = Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body
 368   | otherwise
 369   = panic "WwLib: haven't done mk_absent_let for primitives yet"
 370   where
 371     arg_ty = idType arg
 372
 373 mk_unpk_case NewType arg unpk_args boxing_con boxing_tycon body
 374         -- A newtype!  Use a coercion not a case
 375   = ASSERT( null other_args && isNewTyCon boxing_tycon )
 376     Let (NonRec unpk_arg (Coerce (CoerceOut boxing_con) (idType unpk_arg) (Var arg)))
 377         body
 378   where
 379     (unpk_arg:other_args) = unpk_args
 380
 381 mk_unpk_case DataType arg unpk_args boxing_con boxing_tycon body
 382         -- A data type
 383   = ASSERT( isDataTyCon boxing_tycon )
 384     Case (Var arg)
 385          (AlgAlts [(boxing_con, unpk_args, body)]
 386                   NoDefault
 387          )
 388
 389 mk_pk_let NewType arg boxing_con con_tys unpk_args body
 390   = ASSERT( null other_args && isNewCon boxing_con )
 391     Let (NonRec arg (Coerce (CoerceIn boxing_con) (idType arg) (Var unpk_arg))) body
 392   where
 393     (unpk_arg:other_args) = unpk_args
 394
 395 mk_pk_let DataType arg boxing_con con_tys unpk_args body
 396   = ASSERT( isDataCon boxing_con )
 397     Let (NonRec arg (Con boxing_con con_args)) body
 398   where
 399     con_args = map TyArg con_tys ++ map VarArg unpk_args
 400
 401
 402 mk_ww_local uniq ty
 403   = mkSysLocal SLIT("ww") uniq ty noSrcLoc
 404 \end{code}