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 mkWwBodies, mAX_WORKER_ARGS
18 import Id ( idType, mkSysLocal )
19 import IdInfo ( mkStrictnessInfo, nonAbsentArgs, Demand(..) )
20 import PrelInfo ( aBSENT_ERROR_ID )
21 import SrcLoc ( mkUnknownSrcLoc )
22 import Type ( isPrimType, mkTyVarTys, mkFunTys, maybeAppDataTyCon )
23 import UniqSupply ( returnUs, thenUs, thenMaybeUs,
24 getUniques, UniqSM(..)
26 import Util ( zipWithEqual, assertPanic, panic )
28 quantifyTy = panic "WwLib.quantifyTy"
29 getInstantiatedDataConSig = panic "WwLib.getInstantiatedDataConSig"
32 %************************************************************************
34 \subsection[datatype-WwLib]{@WwBinding@: a datatype for worker/wrapper-ing}
36 %************************************************************************
38 In the worker/wrapper stuff, we want to carry around @CoreBindings@ in
39 an ``intermediate form'' that can later be turned into a \tr{let} or
40 \tr{case} (depending on strictness info).
45 | WwCase (CoreExpr -> CoreExpr)
46 -- the "case" will be a "strict let" of the form:
51 -- (instead of "let <blah> = rhs in body")
53 -- The expr you pass to the function is "body" (the
54 -- expression that goes "in the corner").
57 %************************************************************************
59 \subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
61 %************************************************************************
63 ************ WARNING ******************
64 these comments are rather out of date
65 *****************************************
67 @mkWrapperAndWorker@ is given:
70 The {\em original function} \tr{f}, of the form:
72 f = /\ tyvars -> \ args -> body
74 The original-binder \tr{f}, the \tr{tyvars}, \tr{args}, and \tr{body}
77 We use the Id \tr{f} mostly to get its type.
80 Strictness information about \tr{f}, in the form of a list of
87 @mkWrapperAndWorker@ produces (A BIT OUT-OF-DATE...):
90 Maybe @Nothing@: no worker/wrappering going on in this case. This can
91 happen (a)~if the strictness info says that there is nothing
92 interesting to do or (b)~if *any* of the argument types corresponding
93 to ``active'' arg postitions is abstract or will be to the outside
94 world (i.e., {\em this} module can see the constructors, but nobody
95 else will be able to). An ``active'' arg position is one which the
96 wrapper has to unpack. An importing module can't do this unpacking,
97 so it simply has to give up and call the wrapper only.
100 Maybe \tr{Just (wrapper_Id, wrapper_body, worker_Id, worker_body)}.
102 The @wrapper_Id@ is just the one that was passed in, with its
103 strictness IdInfo updated.
106 The \tr{body} of the original function may not be given (i.e., it's
107 BOTTOM), in which case you'd jolly well better not tug on the
110 Here's an example. The original function is:
112 g :: forall a . Int -> [a] -> a
114 g = /\ a -> \ x ys ->
120 From this, we want to produce:
122 -- wrapper (an unfolding)
123 g :: forall a . Int -> [a] -> a
125 g = /\ a -> \ x ys ->
127 I# x# -> g.wrk a x# ys
128 -- call the worker; don't forget the type args!
131 g.wrk :: forall a . Int# -> [a] -> a
133 g.wrk = /\ a -> \ x# ys ->
137 case x of -- note: body of g moved intact
142 Something we have to be careful about: Here's an example:
144 -- "f" strictness: U(P)U(P)
145 f (I# a) (I# b) = a +# b
147 g = f -- "g" strictness same as "f"
149 \tr{f} will get a worker all nice and friendly-like; that's good.
150 {\em But we don't want a worker for \tr{g}}, even though it has the
151 same strictness as \tr{f}. Doing so could break laziness, at best.
153 Consequently, we insist that the number of strictness-info items is
154 exactly the same as the number of lambda-bound arguments. (This is
155 probably slightly paranoid, but OK in practice.) If it isn't the
156 same, we ``revise'' the strictness info, so that we won't propagate
157 the unusable strictness-info into the interfaces.
159 ==========================
161 Here's the real fun... The wrapper's ``deconstructing'' of arguments
162 and the worker's putting them back together again are ``duals'' in
165 What we do is walk along the @Demand@ list, producing two
166 expressions (one for wrapper, one for worker...), each with a ``hole''
167 in it, where we will later plug in more information. For our previous
168 example, the expressions-with-HOLES are:
172 I# x# -> <<HOLE>> x# ys
180 (Actually, we add the lambda-bound arguments at the end...) (The big
181 Lambdas are added on the front later.)
185 :: Type -- Type of the *body* of the orig
186 -- function; i.e. /\ tyvars -> \ vars -> body
187 -> [TyVar] -- Type lambda vars of original function
188 -> [Id] -- Args of original function
189 -> [Demand] -- Strictness info for those args
191 -> UniqSM (Maybe -- Nothing iff (a) no interesting split possible
192 -- (b) any unpack on abstract type
193 (Id -> CoreExpr, -- Wrapper expr w/
194 -- hole for worker id
195 CoreExpr -> CoreExpr, -- Worker expr w/ hole
196 -- for original fn body
197 StrictnessInfo, -- Worker strictness info
198 Type -> Type) -- Worker type w/ hole
199 ) -- for type of original fn body
202 mkWwBodies body_ty tyvars args arg_infos
203 = ASSERT(length args == length arg_infos)
204 -- or you can get disastrous user/definer-module mismatches
205 if (all_absent_args_and_unboxed_value body_ty arg_infos)
206 then returnUs Nothing
209 mk_ww_arg_processing args arg_infos (mAX_WORKER_ARGS - nonAbsentArgs arg_infos)
210 `thenMaybeUs` \ (wrap_frag, work_args_info, work_frag) ->
212 (work_args, wrkr_demands) = unzip work_args_info
214 wrkr_strictness = mkStrictnessInfo wrkr_demands Nothing -- no worker-of-worker...
216 wrapper_w_hole = \ worker_id ->
219 mkTyApp (Var worker_id) (mkTyVarTys tyvars)
222 worker_w_hole = \ orig_body ->
223 mkLam tyvars work_args (
227 worker_ty_w_hole = \ body_ty ->
228 snd (quantifyTy tyvars (
229 mkFunTys (map idType work_args) body_ty
232 returnUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole))
234 -- "all_absent_args_and_unboxed_value":
235 -- check for the obscure case of "\ x y z ... -> body" where
236 -- (a) *all* of the args x, y, z,... are absent, and
237 -- (b) the type of body is unboxed
238 -- If these conditions are true, we must *not* play worker/wrapper games!
240 all_absent_args_and_unboxed_value body_ty arg_infos
241 = not (null arg_infos)
242 && all is_absent_arg arg_infos
243 && isPrimType body_ty
245 is_absent_arg (WwLazy True) = True
246 is_absent_arg _ = False
249 Important: mk_ww_arg_processing doesn't check
250 for an "interesting" split. It just races ahead and makes the
251 split, even if there's no unpacking at all. This is important for
252 when it calls itself recursively.
254 It returns Nothing only if it encounters an abstract type in mid-flight.
257 mAX_WORKER_ARGS :: Int -- ToDo: set via flag
258 mAX_WORKER_ARGS = 6 -- Hmm... but this is an everything-must-
259 -- be-compiled-with-the-same-val thing...
262 :: [Id] -- Args of original function
263 -> [Demand] -- Strictness info for those args
264 -- must be at least as long as args
266 -> Int -- Number of extra args we are prepared to add.
267 -- This prevents over-eager unpacking, leading
268 -- to huge-arity functions.
270 -> UniqSM (Maybe -- Nothing iff any unpack on abstract type
271 (CoreExpr -> CoreExpr, -- Wrapper expr w/
272 -- hole for worker id
274 [(Id,Demand)], -- Worker's args
275 -- and their strictness info
276 CoreExpr -> CoreExpr) -- Worker body expr w/ hole
277 ) -- for original fn body
279 mk_ww_arg_processing [] _ _ = returnUs (Just (id, [], id))
281 mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args
283 -- So, finish args to the right...
284 --pprTrace "Absent; num_wrkr_args=" (ppInt num_wrkr_args) (
288 mk_ww_arg_processing args infos max_extra_args
289 -- we've already discounted for absent args,
290 -- so we don't change max_extra_args
291 `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
293 -- wrapper doesn't pass this arg to worker:
296 \ hole -> wrap_rest hole,
299 work_args_info, -- NB: no argument added
300 \ hole -> mk_absent_let arg arg_ty (work_rest hole)
304 mk_absent_let arg arg_ty body
305 = if not (isPrimType arg_ty) then
306 Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body
307 else -- quite horrible
308 panic "WwLib: haven't done mk_absent_let for primitives yet"
311 mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args
312 | new_max_extra_args > 0 -- Check that we are prepared to add arguments
313 = -- this is the complicated one.
314 --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)]) (
315 case maybeAppDataTyCon arg_ty of
317 Nothing -> -- Not a data type
318 panic "mk_ww_arg_processing: not datatype"
320 Just (_, _, []) -> -- An abstract type
321 -- We have to give up on the whole idea
323 Just (_, _, (_:_:_)) -> -- Two or more constructors; that's odd
324 panic "mk_ww_arg_processing: multi-constr"
326 Just (arg_tycon, tycon_arg_tys, [data_con]) ->
327 -- The main event: a single-constructor data type
330 (_,inst_con_arg_tys,_)
331 = getInstantiatedDataConSig data_con tycon_arg_tys
333 getUniques (length inst_con_arg_tys) `thenUs` \ uniqs ->
336 unpk_args = zipWithEqual
337 (\ u t -> mkSysLocal SLIT("upk") u t mkUnknownSrcLoc)
338 uniqs inst_con_arg_tys
340 -- In processing the rest, push the sub-component args
341 -- and infos on the front of the current bunch
342 mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) new_max_extra_args
343 `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
346 -- wrapper: unpack the value
347 \ hole -> mk_unpk_case arg unpk_args
351 -- worker: expect the unpacked value;
352 -- reconstruct the orig value with a "let"
354 \ hole -> work_rest (mk_pk_let arg data_con tycon_arg_tys unpk_args hole)
362 + 1 -- We won't pass the original arg now
363 - nonAbsentArgs cmpnt_infos -- But we will pass an arg for each cmpt
365 mk_unpk_case arg unpk_args boxing_con boxing_tycon body
367 AlgAlts [(boxing_con, unpk_args, body)]
371 mk_pk_let arg boxing_con con_tys unpk_args body
372 = Let (NonRec arg (Con boxing_con
373 (map TyArg con_tys ++ map VarArg unpk_args)))
376 mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args
378 = -- For all others at the moment, we just
379 -- pass them to the worker unchanged.
380 --pprTrace "Other; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr ";arg=", ppr PprDebug arg, ppr PprDebug arg_demand]) (
382 -- Finish args to the right...
383 mk_ww_arg_processing args infos max_extra_args
384 `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
388 \ hole -> wrap_rest (App hole (VarArg arg)),
391 (arg, arg_demand) : work_args_info,
392 \ hole -> work_rest hole