2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser}
7 #include "HsVersions.h"
12 worthSplitting, setUnpackStrategy,
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,
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)
37 import Util ( zipWithEqual, zipEqual, assertPanic, panic, pprPanic )
42 %************************************************************************
44 \subsection[datatype-WwLib]{@WwBinding@: a datatype for worker/wrapper-ing}
46 %************************************************************************
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).
55 | WwCase (CoreExpr -> CoreExpr)
56 -- the "case" will be a "strict let" of the form:
61 -- (instead of "let <blah> = rhs in body")
63 -- The expr you pass to the function is "body" (the
64 -- expression that goes "in the corner").
67 %************************************************************************
69 \subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
71 %************************************************************************
73 ************ WARNING ******************
74 these comments are rather out of date
75 *****************************************
77 @mkWrapperAndWorker@ is given:
80 The {\em original function} \tr{f}, of the form:
82 f = /\ tyvars -> \ args -> body
84 The original-binder \tr{f}, the \tr{tyvars}, \tr{args}, and \tr{body}
87 We use the Id \tr{f} mostly to get its type.
90 Strictness information about \tr{f}, in the form of a list of
97 @mkWrapperAndWorker@ produces (A BIT OUT-OF-DATE...):
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.
110 Maybe \tr{Just (wrapper_Id, wrapper_body, worker_Id, worker_body)}.
112 The @wrapper_Id@ is just the one that was passed in, with its
113 strictness IdInfo updated.
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
120 Here's an example. The original function is:
122 g :: forall a . Int -> [a] -> a
124 g = /\ a -> \ x ys ->
130 From this, we want to produce:
132 -- wrapper (an unfolding)
133 g :: forall a . Int -> [a] -> a
135 g = /\ a -> \ x ys ->
137 I# x# -> g.wrk a x# ys
138 -- call the worker; don't forget the type args!
141 g.wrk :: forall a . Int# -> [a] -> a
143 g.wrk = /\ a -> \ x# ys ->
147 case x of -- note: body of g moved intact
152 Something we have to be careful about: Here's an example:
154 -- "f" strictness: U(P)U(P)
155 f (I# a) (I# b) = a +# b
157 g = f -- "g" strictness same as "f"
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.
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.
170 %************************************************************************
172 \subsection{Functions over Demands}
174 %************************************************************************
177 mAX_WORKER_ARGS :: Int -- ToDo: set via flag
180 setUnpackStrategy :: [Demand] -> [Demand]
182 = snd (go (mAX_WORKER_ARGS - nonAbsentArgs ds) ds)
184 go :: Int -- Max number of args available for sub-components of [Demand]
186 -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked
188 go n (WwUnpack nd _ cs : ds) | n' >= 0
189 = WwUnpack nd True cs' `cons` go n'' ds
191 = WwUnpack nd False cs `cons` go n ds
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
198 go n (d:ds) = d `cons` go n ds
201 cons d (n,ds) = (n, d:ds)
203 nonAbsentArgs :: [Demand] -> Int
205 nonAbsentArgs (WwLazy True : ds) = nonAbsentArgs ds
206 nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds
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
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
222 %************************************************************************
224 \subsection{The worker wrapper core}
226 %************************************************************************
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).
232 mkWrapper :: Type -- Wrapper type
233 -> [Demand] -- Wrapper strictness info
234 -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id
236 mkWrapper fun_ty demands
238 n_wrap_args = length demands
240 getUniques n_wrap_args `thenUs` \ wrap_uniqs ->
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
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
255 mkWwBodies tyvars wrap_args final_body_ty demands `thenUs` \ (wrap_fn, _, _) ->
259 @mkWwBodies@ is called when doing the worker/wrapper split inside a module.
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
268 mkWwBodies tyvars args body_ty demands
269 | allAbsent demands &&
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:
275 -- f = /\abc. \xyz. fw abc void
276 -- fw = /\abc. \v. body
278 getUnique `thenUs` \ void_arg_uniq ->
280 void_arg = mk_ww_local void_arg_uniq voidTy
282 returnUs (\ work_id -> mkLam tyvars args (App (mkTyApp (Var work_id) (mkTyVarTys tyvars)) (VarArg voidId)),
283 \ body -> mkLam tyvars [void_arg] body,
286 mkWwBodies tyvars args body_ty demands
289 args_w_demands = zipEqual "mkWwBodies" args demands
291 mkWW args_w_demands `thenUs` \ (wrap_fn, work_args_w_demands, work_fn) ->
293 (work_args, work_demands) = unzip work_args_w_demands
295 returnUs (\ work_id -> mkLam tyvars args (wrap_fn (mkTyApp (Var work_id) (mkTyVarTys tyvars))),
296 \ body -> mkLam tyvars work_args (work_fn body),
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
311 = returnUs (\ wrapper_body -> wrapper_body,
313 \ worker_body -> worker_body)
317 mkWW ((arg,WwLazy True) : ds)
318 = mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) ->
319 returnUs (\ wrapper_body -> wrap_fn wrapper_body,
321 \ worker_body -> mk_absent_let arg (work_fn worker_body))
325 mkWW ((arg,WwUnpack new_or_data True cs) : ds)
326 = getUniques (length inst_con_arg_tys) `thenUs` \ uniqs ->
328 unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
329 unpk_args_w_ds = zipEqual "mkWW" unpk_args cs
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),
334 \ worker_body -> work_fn (mk_pk_let new_or_data arg data_con tycon_arg_tys unpk_args worker_body))
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
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)
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"
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,
357 %************************************************************************
359 \subsection{Utilities}
361 %************************************************************************
365 mk_absent_let arg body
366 | not (isPrimType arg_ty)
367 = Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body
369 = panic "WwLib: haven't done mk_absent_let for primitives yet"
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)))
379 (unpk_arg:other_args) = unpk_args
381 mk_unpk_case DataType arg unpk_args boxing_con boxing_tycon body
383 = ASSERT( isDataTyCon boxing_tycon )
385 (AlgAlts [(boxing_con, unpk_args, body)]
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
393 (unpk_arg:other_args) = unpk_args
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
399 con_args = map TyArg con_tys ++ map VarArg unpk_args
403 = mkSysLocal SLIT("ww") uniq ty noSrcLoc