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,
19 import Id ( idType, mkSysLocal, dataConArgTys )
20 import IdInfo ( mkStrictnessInfo, nonAbsentArgs, Demand(..) )
21 import PrelVals ( aBSENT_ERROR_ID, voidId )
22 import TysPrim ( voidTy )
23 import SrcLoc ( noSrcLoc )
24 import Type ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys,
25 splitForAllTy, splitFunTyExpandingDicts,
26 maybeAppDataTyConExpandingDicts
28 import UniqSupply ( returnUs, thenUs, thenMaybeUs,
29 getUniques, getUnique, SYN_IE(UniqSM)
31 import Util ( zipWithEqual, zipEqual, assertPanic, panic )
34 %************************************************************************
36 \subsection[datatype-WwLib]{@WwBinding@: a datatype for worker/wrapper-ing}
38 %************************************************************************
40 In the worker/wrapper stuff, we want to carry around @CoreBindings@ in
41 an ``intermediate form'' that can later be turned into a \tr{let} or
42 \tr{case} (depending on strictness info).
47 | WwCase (CoreExpr -> CoreExpr)
48 -- the "case" will be a "strict let" of the form:
53 -- (instead of "let <blah> = rhs in body")
55 -- The expr you pass to the function is "body" (the
56 -- expression that goes "in the corner").
59 %************************************************************************
61 \subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
63 %************************************************************************
65 ************ WARNING ******************
66 these comments are rather out of date
67 *****************************************
69 @mkWrapperAndWorker@ is given:
72 The {\em original function} \tr{f}, of the form:
74 f = /\ tyvars -> \ args -> body
76 The original-binder \tr{f}, the \tr{tyvars}, \tr{args}, and \tr{body}
79 We use the Id \tr{f} mostly to get its type.
82 Strictness information about \tr{f}, in the form of a list of
89 @mkWrapperAndWorker@ produces (A BIT OUT-OF-DATE...):
92 Maybe @Nothing@: no worker/wrappering going on in this case. This can
93 happen (a)~if the strictness info says that there is nothing
94 interesting to do or (b)~if *any* of the argument types corresponding
95 to ``active'' arg postitions is abstract or will be to the outside
96 world (i.e., {\em this} module can see the constructors, but nobody
97 else will be able to). An ``active'' arg position is one which the
98 wrapper has to unpack. An importing module can't do this unpacking,
99 so it simply has to give up and call the wrapper only.
102 Maybe \tr{Just (wrapper_Id, wrapper_body, worker_Id, worker_body)}.
104 The @wrapper_Id@ is just the one that was passed in, with its
105 strictness IdInfo updated.
108 The \tr{body} of the original function may not be given (i.e., it's
109 BOTTOM), in which case you'd jolly well better not tug on the
112 Here's an example. The original function is:
114 g :: forall a . Int -> [a] -> a
116 g = /\ a -> \ x ys ->
122 From this, we want to produce:
124 -- wrapper (an unfolding)
125 g :: forall a . Int -> [a] -> a
127 g = /\ a -> \ x ys ->
129 I# x# -> g.wrk a x# ys
130 -- call the worker; don't forget the type args!
133 g.wrk :: forall a . Int# -> [a] -> a
135 g.wrk = /\ a -> \ x# ys ->
139 case x of -- note: body of g moved intact
144 Something we have to be careful about: Here's an example:
146 -- "f" strictness: U(P)U(P)
147 f (I# a) (I# b) = a +# b
149 g = f -- "g" strictness same as "f"
151 \tr{f} will get a worker all nice and friendly-like; that's good.
152 {\em But we don't want a worker for \tr{g}}, even though it has the
153 same strictness as \tr{f}. Doing so could break laziness, at best.
155 Consequently, we insist that the number of strictness-info items is
156 exactly the same as the number of lambda-bound arguments. (This is
157 probably slightly paranoid, but OK in practice.) If it isn't the
158 same, we ``revise'' the strictness info, so that we won't propagate
159 the unusable strictness-info into the interfaces.
162 %************************************************************************
164 \subsection{Functions over Demands}
166 %************************************************************************
169 mAX_WORKER_ARGS :: Int -- ToDo: set via flag
172 setUnpackStrategy :: [Demand] -> [Demand]
174 = snd (go (mAX_WORKER_ARGS - nonAbsentArgs ds) ds)
176 go :: Int -- Max number of args available for sub-components of [Demand]
178 -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked
180 go n (WwUnpack _ cs : ds) | n' >= 0
181 = WwUnpack True cs' `cons` go n'' ds
183 = WwUnpack False cs `cons` go n ds
185 n' = n + 1 - nonAbsentArgs cs
186 -- Add one because we don't pass the top-level arg any more
187 -- Delete # of non-absent args to which we'll now be committed
190 go n (d:ds) = d `cons` go n ds
193 cons d (n,ds) = (n, d:ds)
195 nonAbsentArgs :: [Demand] -> Int
197 nonAbsentArgs (WwLazy True : ds) = nonAbsentArgs ds
198 nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds
200 worthSplitting :: [Demand] -> Bool -- True <=> the wrapper would not be an identity function
201 worthSplitting [] = False
202 worthSplitting (WwLazy True : ds) = True -- Absent arg
203 worthSplitting (WwUnpack True _ : ds) = True -- Arg to unpack
204 worthSplitting (d : ds) = worthSplitting ds
206 allAbsent :: [Demand] -> Bool
207 allAbsent (WwLazy True : ds) = allAbsent ds
208 allAbsent (WwUnpack True cs : ds) = allAbsent cs && allAbsent ds
209 allAbsent (d : ds) = False
214 %************************************************************************
216 \subsection{The worker wrapper core}
218 %************************************************************************
220 @mkWrapper@ is called when importing a function. We have the type of
221 the function and the name of its worker, and we want to make its body (the wrapper).
224 mkWrapper :: Type -- Wrapper type
225 -> [Demand] -- Wrapper strictness info
226 -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id
228 mkWrapper fun_ty demands
230 n_wrap_args = length demands
232 getUniques n_wrap_args `thenUs` \ wrap_uniqs ->
234 (tyvars, tau_ty) = splitForAllTy fun_ty
235 (arg_tys, body_ty) = splitFunTyExpandingDicts tau_ty
236 wrap_args = zipWith mk_ww_local wrap_uniqs arg_tys
237 leftover_arg_tys = drop n_wrap_args arg_tys
238 final_body_ty = mkFunTys leftover_arg_tys body_ty
240 mkWwBodies tyvars wrap_args final_body_ty demands `thenUs` \ (wrap_fn, _, _) ->
244 @mkWwBodies@ is called when doing the worker/wrapper split inside a module.
247 mkWwBodies :: [TyVar] -> [Id] -> Type -- Original fn args and body type
248 -> [Demand] -- Strictness info for original fn; corresp 1-1 with args
249 -> UniqSM (Id -> CoreExpr, -- Wrapper body, lacking only the worker Id
250 CoreExpr -> CoreExpr, -- Worker body, lacking the original function body
251 [Demand]) -- Strictness info for worker
253 mkWwBodies tyvars args body_ty demands
254 | allAbsent demands &&
256 = -- Horrid special case. If the worker would have no arguments, and the
257 -- function returns a primitive type value, that would make the worker into
258 -- an unboxed value. We box it by passing a dummy void argument, thus:
260 -- f = /\abc. \xyz. fw abc void
261 -- fw = /\abc. \v. body
263 getUnique `thenUs` \ void_arg_uniq ->
265 void_arg = mk_ww_local void_arg_uniq voidTy
267 returnUs (\ work_id -> mkLam tyvars args (App (mkTyApp (Var work_id) (mkTyVarTys tyvars)) (VarArg voidId)),
268 \ body -> mkLam tyvars [void_arg] body,
271 mkWwBodies tyvars args body_ty demands
274 args_w_demands = zipEqual "mkWwBodies" args demands
276 mkWW args_w_demands `thenUs` \ (wrap_fn, work_args_w_demands, work_fn) ->
278 (work_args, work_demands) = unzip work_args_w_demands
280 returnUs (\ work_id -> mkLam tyvars args (wrap_fn (mkTyApp (Var work_id) (mkTyVarTys tyvars))),
281 \ body -> mkLam tyvars work_args (work_fn body),
287 mkWW :: [(Id,Demand)]
288 -> UniqSM (CoreExpr -> CoreExpr, -- Wrapper body, lacking the inner call to the worker
289 -- and without its lambdas
290 [(Id,Demand)], -- Worker args and their demand infos
291 CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function
296 = returnUs (\ wrapper_body -> wrapper_body,
298 \ worker_body -> worker_body)
302 mkWW ((arg,WwLazy True) : ds)
303 = mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) ->
304 returnUs (\ wrapper_body -> wrap_fn wrapper_body,
306 \ worker_body -> mk_absent_let arg (work_fn worker_body))
310 mkWW ((arg,WwUnpack True cs) : ds)
311 = getUniques (length inst_con_arg_tys) `thenUs` \ uniqs ->
313 unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
314 unpk_args_w_ds = zipEqual "mkWW" unpk_args cs
316 mkWW (unpk_args_w_ds ++ ds) `thenUs` \ (wrap_fn, worker_args, work_fn) ->
317 returnUs (\ wrapper_body -> mk_unpk_case arg unpk_args data_con arg_tycon (wrap_fn wrapper_body),
319 \ worker_body -> work_fn (mk_pk_let arg data_con tycon_arg_tys unpk_args worker_body))
321 inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
322 (arg_tycon, tycon_arg_tys, data_con)
323 = case (maybeAppDataTyConExpandingDicts (idType arg)) of
325 Just (arg_tycon, tycon_arg_tys, [data_con]) ->
326 -- The main event: a single-constructor data type
327 (arg_tycon, tycon_arg_tys, data_con)
329 Just (_, _, data_cons) -> panic "mk_ww_arg_processing: not one constr"
330 Nothing -> panic "mk_ww_arg_processing: not datatype"
334 mkWW ((arg,other_demand) : ds)
335 = mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) ->
336 returnUs (\ wrapper_body -> wrap_fn (App wrapper_body (VarArg arg)),
337 (arg,other_demand) : worker_args,
342 %************************************************************************
344 \subsection{Utilities}
346 %************************************************************************
350 mk_absent_let arg body
351 | not (isPrimType arg_ty)
352 = Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body
354 = panic "WwLib: haven't done mk_absent_let for primitives yet"
358 mk_unpk_case arg unpk_args boxing_con boxing_tycon body
360 (AlgAlts [(boxing_con, unpk_args, body)]
364 mk_pk_let arg boxing_con con_tys unpk_args body
365 = Let (NonRec arg (Con boxing_con con_args)) body
367 con_args = map TyArg con_tys ++ map VarArg unpk_args
370 = mkSysLocal SLIT("ww") uniq ty noSrcLoc