2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser}
7 #include "HsVersions.h"
12 mkWwBodies, mAX_WORKER_ARGS,
14 -- our friendly worker/wrapper monad:
16 returnWw, thenWw, mapWw,
17 getUniqueWw, uniqSMtoWwM,
19 -- and to make the interface self-sufficient...
20 GlobalSwitch, CoreBinding, CoreExpr, PlainCoreBinding(..),
21 PlainCoreExpr(..), Id, Demand, MaybeErr,
22 TyVar, UniType, Unique, SplitUniqSupply, SUniqSM(..)
24 IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA getSUnique)
25 IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily)
29 import Outputable -- ToDo: rm (debugging)
32 import AbsPrel ( aBSENT_ERROR_ID, mkFunTy )
33 import AbsUniType ( mkTyVarTy, isPrimType, getUniDataTyCon_maybe,
34 quantifyTy, TyVarTemplate
36 import CmdLineOpts ( GlobalSwitch(..) )
37 import Id ( mkWorkerId, mkSysLocal, getIdUniType,
38 getInstantiatedDataConSig, getIdInfo,
39 replaceIdInfo, addIdStrictness, DataCon(..)
41 import IdInfo -- lots of things
42 import Maybes ( maybeToBool, Maybe(..), MaybeErr )
45 import SrcLoc ( mkUnknownSrcLoc )
53 %************************************************************************
55 \subsection[datatype-WwLib]{@WwBinding@: a datatype for worker/wrapper-ing}
57 %************************************************************************
59 In the worker/wrapper stuff, we want to carry around @CoreBindings@ in
60 an ``intermediate form'' that can later be turned into a \tr{let} or
61 \tr{case} (depending on strictness info).
65 = WwLet [PlainCoreBinding]
66 | WwCase (PlainCoreExpr -> PlainCoreExpr)
67 -- the "case" will be a "strict let" of the form:
72 -- (instead of "let <blah> = rhs in body")
74 -- The expr you pass to the function is "body" (the
75 -- expression that goes "in the corner").
78 %************************************************************************
80 \subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
82 %************************************************************************
84 ************ WARNING ******************
85 these comments are rather out of date
86 *****************************************
88 @mkWrapperAndWorker@ is given:
91 The {\em original function} \tr{f}, of the form:
93 f = /\ tyvars -> \ args -> body
95 The original-binder \tr{f}, the \tr{tyvars}, \tr{args}, and \tr{body}
98 We use the Id \tr{f} mostly to get its type.
101 Strictness information about \tr{f}, in the form of a list of
108 @mkWrapperAndWorker@ produces (A BIT OUT-OF-DATE...):
111 Maybe @Nothing@: no worker/wrappering going on in this case. This can
112 happen (a)~if the strictness info says that there is nothing
113 interesting to do or (b)~if *any* of the argument types corresponding
114 to ``active'' arg postitions is abstract or will be to the outside
115 world (i.e., {\em this} module can see the constructors, but nobody
116 else will be able to). An ``active'' arg position is one which the
117 wrapper has to unpack. An importing module can't do this unpacking,
118 so it simply has to give up and call the wrapper only.
121 Maybe \tr{Just (wrapper_Id, wrapper_body, worker_Id, worker_body)}.
123 The @wrapper_Id@ is just the one that was passed in, with its
124 strictness IdInfo updated.
127 The \tr{body} of the original function may not be given (i.e., it's
128 BOTTOM), in which case you'd jolly well better not tug on the
131 Here's an example. The original function is:
133 g :: forall a . Int -> [a] -> a
135 g = /\ a -> \ x ys ->
141 From this, we want to produce:
143 -- wrapper (an unfolding)
144 g :: forall a . Int -> [a] -> a
146 g = /\ a -> \ x ys ->
148 I# x# -> g.wrk a x# ys
149 -- call the worker; don't forget the type args!
152 g.wrk :: forall a . Int# -> [a] -> a
154 g.wrk = /\ a -> \ x# ys ->
158 case x of -- note: body of g moved intact
163 Something we have to be careful about: Here's an example:
165 -- "f" strictness: U(P)U(P)
166 f (I# a) (I# b) = a +# b
168 g = f -- "g" strictness same as "f"
170 \tr{f} will get a worker all nice and friendly-like; that's good.
171 {\em But we don't want a worker for \tr{g}}, even though it has the
172 same strictness as \tr{f}. Doing so could break laziness, at best.
174 Consequently, we insist that the number of strictness-info items is
175 exactly the same as the number of lambda-bound arguments. (This is
176 probably slightly paranoid, but OK in practice.) If it isn't the
177 same, we ``revise'' the strictness info, so that we won't propagate
178 the unusable strictness-info into the interfaces.
180 ==========================
182 Here's the real fun... The wrapper's ``deconstructing'' of arguments
183 and the worker's putting them back together again are ``duals'' in
186 What we do is walk along the @Demand@ list, producing two
187 expressions (one for wrapper, one for worker...), each with a ``hole''
188 in it, where we will later plug in more information. For our previous
189 example, the expressions-with-HOLES are:
193 I# x# -> <<HOLE>> x# ys
201 (Actually, we add the lambda-bound arguments at the end...) (The big
202 Lambdas are added on the front later.)
206 :: UniType -- Type of the *body* of the orig
207 -- function; i.e. /\ tyvars -> \ vars -> body
208 -> [TyVar] -- Type lambda vars of original function
209 -> [Id] -- Args of original function
210 -> [Demand] -- Strictness info for those args
212 -> SUniqSM (Maybe -- Nothing iff (a) no interesting split possible
213 -- (b) any unpack on abstract type
214 (Id -> PlainCoreExpr, -- Wrapper expr w/
215 -- hole for worker id
216 PlainCoreExpr -> PlainCoreExpr, -- Worker expr w/ hole
217 -- for original fn body
218 StrictnessInfo, -- Worker strictness info
219 UniType -> UniType) -- Worker type w/ hole
220 ) -- for type of original fn body
223 mkWwBodies body_ty tyvars args arg_infos
224 = ASSERT(length args == length arg_infos)
225 -- or you can get disastrous user/definer-module mismatches
226 if (all_absent_args_and_unboxed_value body_ty arg_infos)
227 then returnSUs Nothing
230 mk_ww_arg_processing args arg_infos (mAX_WORKER_ARGS - nonAbsentArgs arg_infos)
231 `thenUsMaybe` \ (wrap_frag, work_args_info, work_frag) ->
233 (work_args, wrkr_demands) = unzip work_args_info
235 wrkr_strictness = mkStrictnessInfo wrkr_demands Nothing -- no worker-of-worker...
237 wrapper_w_hole = \ worker_id ->
241 mkCoTyApps (CoVar worker_id) (map mkTyVarTy tyvars)
244 worker_w_hole = \ orig_body ->
250 worker_ty_w_hole = \ body_ty ->
251 snd (quantifyTy tyvars (
252 foldr mkFunTy body_ty (map getIdUniType work_args)
255 returnSUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole))
257 -- "all_absent_args_and_unboxed_value":
258 -- check for the obscure case of "\ x y z ... -> body" where
259 -- (a) *all* of the args x, y, z,... are absent, and
260 -- (b) the type of body is unboxed
261 -- If these conditions are true, we must *not* play worker/wrapper games!
263 all_absent_args_and_unboxed_value body_ty arg_infos
264 = not (null arg_infos)
265 && all is_absent_arg arg_infos
266 && isPrimType body_ty
268 is_absent_arg (WwLazy True) = True
269 is_absent_arg _ = False
272 Important: mk_ww_arg_processing doesn't check
273 for an "interesting" split. It just races ahead and makes the
274 split, even if there's no unpacking at all. This is important for
275 when it calls itself recursively.
277 It returns Nothing only if it encounters an abstract type in mid-flight.
280 mAX_WORKER_ARGS :: Int -- ToDo: set via flag
281 mAX_WORKER_ARGS = 6 -- Hmm... but this is an everything-must-
282 -- be-compiled-with-the-same-val thing...
285 :: [Id] -- Args of original function
286 -> [Demand] -- Strictness info for those args
287 -- must be at least as long as args
289 -> Int -- Number of extra args we are prepared to add.
290 -- This prevents over-eager unpacking, leading
291 -- to huge-arity functions.
293 -> SUniqSM (Maybe -- Nothing iff any unpack on abstract type
294 (PlainCoreExpr -> PlainCoreExpr, -- Wrapper expr w/
295 -- hole for worker id
297 [(Id,Demand)], -- Worker's args
298 -- and their strictness info
299 PlainCoreExpr -> PlainCoreExpr) -- Worker body expr w/ hole
300 ) -- for original fn body
302 mk_ww_arg_processing [] _ _ = returnSUs (Just (id, [], id))
304 mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args
306 -- So, finish args to the right...
307 --pprTrace "Absent; num_wrkr_args=" (ppInt num_wrkr_args) (
309 arg_ty = getIdUniType arg
311 mk_ww_arg_processing args infos max_extra_args
312 -- we've already discounted for absent args,
313 -- so we don't change max_extra_args
314 `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) ->
316 -- wrapper doesn't pass this arg to worker:
319 \ hole -> wrap_rest hole,
322 work_args_info, -- NB: no argument added
323 \ hole -> mk_absent_let arg arg_ty (work_rest hole)
327 mk_absent_let arg arg_ty body
328 = if not (isPrimType arg_ty) then
329 CoLet (CoNonRec arg (mkCoTyApp (CoVar aBSENT_ERROR_ID) arg_ty))
331 else -- quite horrible
332 panic "WwLib: haven't done mk_absent_let for primitives yet"
335 mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args
336 | new_max_extra_args > 0 -- Check that we are prepared to add arguments
337 = -- this is the complicated one.
338 --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)]) (
339 case getUniDataTyCon_maybe arg_ty of
341 Nothing -> -- Not a data type
342 panic "mk_ww_arg_processing: not datatype"
344 Just (_, _, []) -> -- An abstract type
345 -- We have to give up on the whole idea
347 Just (_, _, (_:_:_)) -> -- Two or more constructors; that's odd
348 panic "mk_ww_arg_processing: multi-constr"
350 Just (arg_tycon, tycon_arg_tys, [data_con]) ->
351 -- The main event: a single-constructor data type
354 (_,inst_con_arg_tys,_)
355 = getInstantiatedDataConSig data_con tycon_arg_tys
357 getSUniques (length inst_con_arg_tys) `thenSUs` \ uniqs ->
359 let unpk_args = zipWith (\ u t -> mkSysLocal SLIT("upk") u t mkUnknownSrcLoc)
360 uniqs inst_con_arg_tys
362 -- In processing the rest, push the sub-component args
363 -- and infos on the front of the current bunch
364 mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) new_max_extra_args
365 `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) ->
368 -- wrapper: unpack the value
369 \ hole -> mk_unpk_case arg unpk_args
373 -- worker: expect the unpacked value;
374 -- reconstruct the orig value with a "let"
376 \ hole -> work_rest (mk_pk_let arg data_con tycon_arg_tys unpk_args hole)
380 arg_ty = getIdUniType arg
384 + 1 -- We won't pass the original arg now
385 - nonAbsentArgs cmpnt_infos -- But we will pass an arg for each cmpt
387 mk_unpk_case arg unpk_args boxing_con boxing_tycon body
388 = CoCase (CoVar arg) (
389 CoAlgAlts [(boxing_con, unpk_args, body)]
393 mk_pk_let arg boxing_con con_tys unpk_args body
394 = CoLet (CoNonRec arg (CoCon boxing_con con_tys [CoVarAtom a | a <- unpk_args]))
397 mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args
399 = -- For all others at the moment, we just
400 -- pass them to the worker unchanged.
401 --pprTrace "Other; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr ";arg=", ppr PprDebug arg, ppr PprDebug arg_demand]) (
403 -- Finish args to the right...
404 mk_ww_arg_processing args infos max_extra_args
405 `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) ->
409 \ hole -> wrap_rest (CoApp hole (CoVarAtom arg)),
412 (arg, arg_demand) : work_args_info,
413 \ hole -> work_rest hole
418 %************************************************************************
420 \subsection[monad-WwLib]{Simple monad for worker/wrapper}
422 %************************************************************************
424 In this monad, we thread a @UniqueSupply@, and we carry a
425 @GlobalSwitch@-lookup function downwards.
430 -> (GlobalSwitch -> Bool)
433 #ifdef __GLASGOW_HASKELL__
434 {-# INLINE thenWw #-}
435 {-# INLINE returnWw #-}
438 returnWw :: a -> WwM a
439 thenWw :: WwM a -> (a -> WwM b) -> WwM b
440 mapWw :: (a -> WwM b) -> [a] -> WwM [b]
442 returnWw expr ns sw = expr
445 = case splitUniqSupply us of { (s1, s2) ->
446 case (m s1 sw_chk) of { m_res ->
449 mapWw f [] = returnWw []
451 = f x `thenWw` \ x' ->
452 mapWw f xs `thenWw` \ xs' ->
457 getUniqueWw :: WwM Unique
458 uniqSMtoWwM :: SUniqSM a -> WwM a
460 getUniqueWw us sw_chk = getSUnique us
462 uniqSMtoWwM u_obj us sw_chk = u_obj us
464 thenUsMaybe :: SUniqSM (Maybe a) -> (a -> SUniqSM (Maybe b)) -> SUniqSM (Maybe b)
466 = m `thenSUs` \ result ->
468 Nothing -> returnSUs Nothing