2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser}
7 module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs ) where
9 #include "HsVersions.h"
12 import CoreUtils ( exprType )
13 import Id ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo,
14 isOneShotLambda, setOneShotLambda, setIdUnfolding,
17 import IdInfo ( vanillaIdInfo )
19 import Demand ( Demand(..), DmdResult(..), Demands(..) )
20 import MkCore ( mkRuntimeErrorApp, aBSENT_ERROR_ID )
21 import MkId ( realWorldPrimId, voidArgId,
22 mkUnpackCase, mkProductBox )
23 import TysPrim ( realWorldStatePrimTy )
24 import TysWiredIn ( tupleCon )
26 import Coercion ( mkSymCoercion, splitNewTypeRepCo_maybe )
27 import BasicTypes ( Boxity(..) )
28 import Literal ( absentLiteralOf )
32 import Util ( zipWithEqual )
38 %************************************************************************
40 \subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
42 %************************************************************************
44 Here's an example. The original function is:
47 g :: forall a . Int -> [a] -> a
49 g = \/\ a -> \ x ys ->
55 From this, we want to produce:
57 -- wrapper (an unfolding)
58 g :: forall a . Int -> [a] -> a
60 g = \/\ a -> \ x ys ->
63 -- call the worker; don't forget the type args!
66 $wg :: forall a . Int# -> [a] -> a
68 $wg = \/\ a -> \ x# ys ->
72 case x of -- note: body of g moved intact
77 Something we have to be careful about: Here's an example:
80 -- "f" strictness: U(P)U(P)
81 f (I# a) (I# b) = a +# b
83 g = f -- "g" strictness same as "f"
86 \tr{f} will get a worker all nice and friendly-like; that's good.
87 {\em But we don't want a worker for \tr{g}}, even though it has the
88 same strictness as \tr{f}. Doing so could break laziness, at best.
90 Consequently, we insist that the number of strictness-info items is
91 exactly the same as the number of lambda-bound arguments. (This is
92 probably slightly paranoid, but OK in practice.) If it isn't the
93 same, we ``revise'' the strictness info, so that we won't propagate
94 the unusable strictness-info into the interfaces.
97 %************************************************************************
99 \subsection{The worker wrapper core}
101 %************************************************************************
103 @mkWwBodies@ is called when doing the worker\/wrapper split inside a module.
106 mkWwBodies :: Type -- Type of original function
107 -> [Demand] -- Strictness of original function
108 -> DmdResult -- Info about function result
109 -> [Bool] -- One-shot-ness of the function
110 -> UniqSM ([Demand], -- Demands for worker (value) args
111 Id -> CoreExpr, -- Wrapper body, lacking only the worker Id
112 CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs
114 -- wrap_fn_args E = \x y -> E
115 -- work_fn_args E = E x y
117 -- wrap_fn_str E = case x of { (a,b) ->
118 -- case a of { (a1,a2) ->
120 -- work_fn_str E = \a2 a2 b y ->
121 -- let a = (a1,a2) in
125 mkWwBodies fun_ty demands res_info one_shots
126 = do { let arg_info = demands `zip` (one_shots ++ repeat False)
127 ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs emptyTvSubst fun_ty arg_info
128 ; (work_args, wrap_fn_str, work_fn_str) <- mkWWstr wrap_args
130 -- Don't do CPR if the worker doesn't have any value arguments
131 -- Then the worker is just a constant, so we don't want to unbox it.
132 ; (wrap_fn_cpr, work_fn_cpr, _cpr_res_ty)
133 <- if any isId work_args then
134 mkWWcpr res_ty res_info
136 return (id, id, res_ty)
138 ; let (work_lam_args, work_call_args) = mkWorkerArgs work_args res_ty
139 ; return ([idDemandInfo v | v <- work_call_args, isId v],
140 wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var,
141 mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) }
142 -- We use an INLINE unconditionally, even if the wrapper turns out to be
143 -- something trivial like
145 -- f = __inline__ (coerce T fw)
146 -- The point is to propagate the coerce to f's call sites, so even though
147 -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
148 -- fw from being inlined into f's RHS
152 %************************************************************************
154 \subsection{Making wrapper args}
156 %************************************************************************
158 During worker-wrapper stuff we may end up with an unlifted thing
159 which we want to let-bind without losing laziness. So we
160 add a void argument. E.g.
162 f = /\a -> \x y z -> E::Int# -- E does not mention x,y,z
164 fw = /\ a -> \void -> E
165 f = /\ a -> \x y z -> fw realworld
167 We use the state-token type which generates no code.
170 mkWorkerArgs :: [Var]
171 -> Type -- Type of body
172 -> ([Var], -- Lambda bound args
173 [Var]) -- Args at call site
174 mkWorkerArgs args res_ty
175 | any isId args || not (isUnLiftedType res_ty)
178 = (args ++ [voidArgId], args ++ [realWorldPrimId])
182 %************************************************************************
184 \subsection{Coercion stuff}
186 %************************************************************************
188 We really want to "look through" coerces.
189 Reason: I've seen this situation:
191 let f = coerce T (\s -> E)
197 If only we w/w'd f, we'd get
198 let f = coerce T (\s -> fw s)
202 Now we'll inline f to get
210 Now we'll see that fw has arity 1, and will arity expand
211 the \x to get what we want.
214 -- mkWWargs just does eta expansion
215 -- is driven off the function type and arity.
216 -- It chomps bites off foralls, arrows, newtypes
217 -- and keeps repeating that until it's satisfied the supplied arity
219 mkWWargs :: TvSubst -- Freshening substitution to apply to the type
220 -- See Note [Freshen type variables]
221 -> Type -- The type of the function
222 -> [(Demand,Bool)] -- Demands and one-shot info for value arguments
223 -> UniqSM ([Var], -- Wrapper args
224 CoreExpr -> CoreExpr, -- Wrapper fn
225 CoreExpr -> CoreExpr, -- Worker fn
226 Type) -- Type of wrapper body
228 mkWWargs subst fun_ty arg_info
229 | Just (rep_ty, co) <- splitNewTypeRepCo_maybe fun_ty
230 -- The newtype case is for when the function has
231 -- a recursive newtype after the arrow (rare)
232 -- We check for arity >= 0 to avoid looping in the case
233 -- of a function whose type is, in effect, infinite
234 -- [Arity is driven by looking at the term, not just the type.]
236 -- It's also important when we have a function returning (say) a pair
237 -- wrapped in a recursive newtype, at least if CPR analysis can look
238 -- through such newtypes, which it probably can since they are
241 -- Note (Sept 08): This case applies even if demands is empty.
242 -- I'm not quite sure why; perhaps it makes it
244 = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)
245 <- mkWWargs subst rep_ty arg_info
247 \e -> Cast (wrap_fn_args e) (mkSymCoercion co),
248 \e -> work_fn_args (Cast e co),
252 = return ([], id, id, substTy subst fun_ty)
254 | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty
255 = do { let (subst', tv') = substTyVarBndr subst tv
256 -- This substTyVarBndr clones the type variable when necy
257 -- See Note [Freshen type variables]
258 ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
259 <- mkWWargs subst' fun_ty' arg_info
260 ; return (tv' : wrap_args,
261 Lam tv' . wrap_fn_args,
262 work_fn_args . (`App` Type (mkTyVarTy tv')),
265 | ((dmd,one_shot):arg_info') <- arg_info
266 , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty
267 = do { uniq <- getUniqueM
268 ; let arg_ty' = substTy subst arg_ty
269 id = mk_wrap_arg uniq arg_ty' dmd one_shot
270 ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
271 <- mkWWargs subst fun_ty' arg_info'
272 ; return (id : wrap_args,
273 Lam id . wrap_fn_args,
274 work_fn_args . (`App` Var id),
278 = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand
279 return ([], id, id, substTy subst fun_ty) -- then there should be a function arrow
281 applyToVars :: [Var] -> CoreExpr -> CoreExpr
282 applyToVars vars fn = mkVarApps fn vars
284 mk_wrap_arg :: Unique -> Type -> Demand -> Bool -> Id
285 mk_wrap_arg uniq ty dmd one_shot
286 = set_one_shot one_shot (setIdDemandInfo (mkSysLocal (fsLit "w") uniq ty) dmd)
288 set_one_shot True id = setOneShotLambda id
289 set_one_shot False id = id
292 Note [Freshen type variables]
293 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
294 mkWWargs may be given a type like (a~b) => <blah>
295 Which really means forall (co:a~b). <blah>
296 Because the name of the coercion variable, 'co', isn't mentioned in <blah>,
297 nested coercion foralls may all use the same variable; and sometimes do
300 However, when we do a worker/wrapper split, we must not use shadowed names,
302 f = /\ co /\co. fw co co
303 which is obviously wrong. Actually, the same is true of type variables, which
304 can in principle shadow, within a type (e.g. forall a. a -> forall a. a->a).
305 But type variables *are* mentioned in <blah>, so we must substitute.
307 That's why we carry the TvSubst through mkWWargs
309 %************************************************************************
311 \subsection{Strictness stuff}
313 %************************************************************************
316 mkWWstr :: [Var] -- Wrapper args; have their demand info on them
317 -- *Includes type variables*
318 -> UniqSM ([Var], -- Worker args
319 CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call
320 -- and without its lambdas
321 -- This fn adds the unboxing
323 CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function,
324 -- and lacking its lambdas.
325 -- This fn does the reboxing
327 = return ([], nop_fn, nop_fn)
329 mkWWstr (arg : args) = do
330 (args1, wrap_fn1, work_fn1) <- mkWWstr_one arg
331 (args2, wrap_fn2, work_fn2) <- mkWWstr args
332 return (args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
334 ----------------------
335 -- mkWWstr_one wrap_arg = (work_args, wrap_fn, work_fn)
336 -- * wrap_fn assumes wrap_arg is in scope,
337 -- brings into scope work_args (via cases)
338 -- * work_fn assumes work_args are in scope, a
339 -- brings into scope wrap_arg (via lets)
340 mkWWstr_one :: Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
343 = return ([arg], nop_fn, nop_fn)
346 = case idDemandInfo arg of
348 -- Absent case. We can't always handle absence for arbitrary
349 -- unlifted types, so we need to choose just the cases we can
350 -- (that's what mk_absent_let does)
351 Abs | Just work_fn <- mk_absent_let arg
352 -> return ([], nop_fn, work_fn)
356 | Just (_arg_tycon, _tycon_arg_tys, data_con, inst_con_arg_tys)
357 <- deepSplitProductType_maybe (idType arg)
358 -> do uniqs <- getUniquesM
360 unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
361 unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs
362 unbox_fn = mkUnpackCase (sanitiseCaseBndr arg) (Var arg) unpk_args data_con
363 rebox_fn = Let (NonRec arg con_app)
364 con_app = mkProductBox unpk_args (idType arg)
365 (worker_args, wrap_fn, work_fn) <- mkWWstr unpk_args_w_ds
366 return (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn)
367 -- Don't pass the arg, rebox instead
369 -- `seq` demand; evaluate in wrapper in the hope
370 -- of dropping seqs in the worker
373 arg_w_unf = arg `setIdUnfolding` evaldUnfolding
374 -- Tell the worker arg that it's sure to be evaluated
375 -- so that internal seqs can be dropped
377 return ([arg_w_unf], mk_seq_case arg, nop_fn)
378 -- Pass the arg, anyway, even if it is in theory discarded
381 -- x gets a (Eval (Poly Abs)) demand, but if we fail to pass it to the worker
382 -- we ABSOLUTELY MUST record that x is evaluated in the wrapper.
384 -- f x y = x `seq` fw y
385 -- fw y = let x{Evald} = error "oops" in (x `seq` y)
386 -- If we don't pin on the "Evald" flag, the seq doesn't disappear, and
387 -- we end up evaluating the absent thunk.
388 -- But the Evald flag is pretty weird, and I worry that it might disappear
389 -- during simplification, so for now I've just nuked this whole case
392 _other_demand -> return ([arg], nop_fn, nop_fn)
395 -- If the wrapper argument is a one-shot lambda, then
396 -- so should (all) the corresponding worker arguments be
397 -- This bites when we do w/w on a case join point
398 set_worker_arg_info worker_arg demand = set_one_shot (setIdDemandInfo worker_arg demand)
400 set_one_shot | isOneShotLambda arg = setOneShotLambda
401 | otherwise = \x -> x
403 ----------------------
404 nop_fn :: CoreExpr -> CoreExpr
409 %************************************************************************
411 \subsection{CPR stuff}
413 %************************************************************************
416 @mkWWcpr@ takes the worker/wrapper pair produced from the strictness
417 info and adds in the CPR transformation. The worker returns an
418 unboxed tuple containing non-CPR components. The wrapper takes this
419 tuple and re-produces the correct structured output.
421 The non-CPR results appear ordered in the unboxed tuple as if by a
422 left-to-right traversal of the result structure.
426 mkWWcpr :: Type -- function body type
427 -> DmdResult -- CPR analysis results
428 -> UniqSM (CoreExpr -> CoreExpr, -- New wrapper
429 CoreExpr -> CoreExpr, -- New worker
430 Type) -- Type of worker's body
432 mkWWcpr body_ty RetCPR
433 | not (isClosedAlgType body_ty)
435 text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
436 return (id, id, body_ty)
438 | n_con_args == 1 && isUnLiftedType con_arg_ty1 = do
439 -- Special case when there is a single result of unlifted type
441 -- Wrapper: case (..call worker..) of x -> C x
442 -- Worker: case ( ..body.. ) of C x -> x
443 (work_uniq : arg_uniq : _) <- getUniquesM
445 work_wild = mk_ww_local work_uniq body_ty
446 arg = mk_ww_local arg_uniq con_arg_ty1
447 con_app = mkProductBox [arg] body_ty
449 return (\ wkr_call -> Case wkr_call (arg) (exprType con_app) [(DEFAULT, [], con_app)],
450 \ body -> workerCase (work_wild) body [arg] data_con (Var arg),
453 | otherwise = do -- The general case
454 -- Wrapper: case (..call worker..) of (# a, b #) -> C a b
455 -- Worker: case ( ...body... ) of C a b -> (# a, b #)
458 (wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys)
459 arg_vars = map Var args
460 ubx_tup_con = tupleCon Unboxed n_con_args
461 ubx_tup_ty = exprType ubx_tup_app
462 ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars)
463 con_app = mkProductBox args body_ty
465 return (\ wkr_call -> Case wkr_call (wrap_wild) (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)],
466 \ body -> workerCase (work_wild) body args data_con ubx_tup_app,
469 (_arg_tycon, _tycon_arg_tys, data_con, con_arg_tys) = deepSplitProductType "mkWWcpr" body_ty
470 n_con_args = length con_arg_tys
471 con_arg_ty1 = head con_arg_tys
473 mkWWcpr body_ty _other -- No CPR info
474 = return (id, id, body_ty)
476 -- If the original function looked like
477 -- f = \ x -> _scc_ "foo" E
479 -- then we want the CPR'd worker to look like
480 -- \ x -> _scc_ "foo" (case E of I# x -> x)
481 -- and definitely not
482 -- \ x -> case (_scc_ "foo" E) of I# x -> x)
484 -- This transform doesn't move work or allocation
485 -- from one cost centre to another
486 workerCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
487 workerCase bndr (Note (SCC cc) e) args con body = Note (SCC cc) (mkUnpackCase bndr e args con body)
488 workerCase bndr e args con body = mkUnpackCase bndr e args con body
492 %************************************************************************
494 \subsection{Utilities}
496 %************************************************************************
500 We make a new binding for Ids that are marked absent, thus
501 let x = absentError "x :: Int"
502 The idea is that this binding will never be used; but if it
503 buggily is used we'll get a runtime error message.
505 Coping with absence for *unlifted* types is important; see, for
506 example, Trac #4306. For these we find a suitable literal,
507 using Literal.absentLiteralOf. We don't have literals for
508 every primitive type, so the function is partial.
510 [I did try the experiment of using an error thunk for unlifted
511 things too, relying on the simplifier to drop it as dead code,
512 by making absentError
513 (a) *not* be a bottoming Id,
514 (b) be "ok for speculation"
515 But that relies on the simplifier finding that it really
516 is dead code, which is fragile, and indeed failed when
517 profiling is on, which disables various optimisations. So
518 using a literal will do.]
521 mk_absent_let :: Id -> Maybe (CoreExpr -> CoreExpr)
523 | not (isUnLiftedType arg_ty)
524 = Just (Let (NonRec arg abs_rhs))
525 | Just (tc, _) <- splitTyConApp_maybe arg_ty
526 , Just lit <- absentLiteralOf tc
527 = Just (Let (NonRec arg (Lit lit)))
528 | arg_ty `coreEqType` realWorldStatePrimTy
529 = Just (Let (NonRec arg (Var realWorldPrimId)))
531 = WARN( True, ptext (sLit "No absent value for") <+> ppr arg_ty )
535 abs_rhs = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg
536 msg = showSDocDebug (ppr arg <+> ppr (idType arg))
538 mk_seq_case :: Id -> CoreExpr -> CoreExpr
539 mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)]
541 sanitiseCaseBndr :: Id -> Id
542 -- The argument we are scrutinising has the right type to be
543 -- a case binder, so it's convenient to re-use it for that purpose.
544 -- But we *must* throw away all its IdInfo. In particular, the argument
545 -- will have demand info on it, and that demand info may be incorrect for
546 -- the case binder. e.g. case ww_arg of ww_arg { I# x -> ... }
547 -- Quite likely ww_arg isn't used in '...'. The case may get discarded
548 -- if the case binder says "I'm demanded". This happened in a situation
549 -- like (x+y) `seq` ....
550 sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo
552 mk_ww_local :: Unique -> Type -> Id
553 mk_ww_local uniq ty = mkSysLocal (fsLit "ww") uniq ty