Update Trac ticket URLs to point to GitLab
[ghc.git] / compiler / stranal / WwLib.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
4 \section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser}
5 -}
6
7 {-# LANGUAGE CPP #-}
8
9 module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs
10 , deepSplitProductType_maybe, findTypeShape
11 , isWorkerSmallEnough
12 ) where
13
14 #include "HsVersions.h"
15
16 import GhcPrelude
17
18 import CoreSyn
19 import CoreUtils ( exprType, mkCast )
20 import Id
21 import IdInfo ( JoinArity )
22 import DataCon
23 import Demand
24 import MkCore ( mkAbsentErrorApp, mkCoreUbxTup
25 , mkCoreApp, mkCoreLet )
26 import MkId ( voidArgId, voidPrimId )
27 import TysWiredIn ( tupleDataCon )
28 import TysPrim ( voidPrimTy )
29 import Literal ( absentLiteralOf, rubbishLit )
30 import VarEnv ( mkInScopeSet )
31 import VarSet ( VarSet )
32 import Type
33 import RepType ( isVoidTy, typePrimRep )
34 import Coercion
35 import FamInstEnv
36 import BasicTypes ( Boxity(..) )
37 import TyCon
38 import UniqSupply
39 import Unique
40 import Maybes
41 import Util
42 import Outputable
43 import DynFlags
44 import FastString
45 import ListSetOps
46
47 {-
48 ************************************************************************
49 * *
50 \subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
51 * *
52 ************************************************************************
53
54 Here's an example. The original function is:
55
56 \begin{verbatim}
57 g :: forall a . Int -> [a] -> a
58
59 g = \/\ a -> \ x ys ->
60 case x of
61 0 -> head ys
62 _ -> head (tail ys)
63 \end{verbatim}
64
65 From this, we want to produce:
66 \begin{verbatim}
67 -- wrapper (an unfolding)
68 g :: forall a . Int -> [a] -> a
69
70 g = \/\ a -> \ x ys ->
71 case x of
72 I# x# -> $wg a x# ys
73 -- call the worker; don't forget the type args!
74
75 -- worker
76 $wg :: forall a . Int# -> [a] -> a
77
78 $wg = \/\ a -> \ x# ys ->
79 let
80 x = I# x#
81 in
82 case x of -- note: body of g moved intact
83 0 -> head ys
84 _ -> head (tail ys)
85 \end{verbatim}
86
87 Something we have to be careful about: Here's an example:
88
89 \begin{verbatim}
90 -- "f" strictness: U(P)U(P)
91 f (I# a) (I# b) = a +# b
92
93 g = f -- "g" strictness same as "f"
94 \end{verbatim}
95
96 \tr{f} will get a worker all nice and friendly-like; that's good.
97 {\em But we don't want a worker for \tr{g}}, even though it has the
98 same strictness as \tr{f}. Doing so could break laziness, at best.
99
100 Consequently, we insist that the number of strictness-info items is
101 exactly the same as the number of lambda-bound arguments. (This is
102 probably slightly paranoid, but OK in practice.) If it isn't the
103 same, we ``revise'' the strictness info, so that we won't propagate
104 the unusable strictness-info into the interfaces.
105
106
107 ************************************************************************
108 * *
109 \subsection{The worker wrapper core}
110 * *
111 ************************************************************************
112
113 @mkWwBodies@ is called when doing the worker\/wrapper split inside a module.
114 -}
115
116 type WwResult
117 = ([Demand], -- Demands for worker (value) args
118 JoinArity, -- Number of worker (type OR value) args
119 Id -> CoreExpr, -- Wrapper body, lacking only the worker Id
120 CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs
121
122 mkWwBodies :: DynFlags
123 -> FamInstEnvs
124 -> VarSet -- Free vars of RHS
125 -- See Note [Freshen WW arguments]
126 -> Id -- The original function
127 -> [Demand] -- Strictness of original function
128 -> DmdResult -- Info about function result
129 -> UniqSM (Maybe WwResult)
130
131 -- wrap_fn_args E = \x y -> E
132 -- work_fn_args E = E x y
133
134 -- wrap_fn_str E = case x of { (a,b) ->
135 -- case a of { (a1,a2) ->
136 -- E a1 a2 b y }}
137 -- work_fn_str E = \a2 a2 b y ->
138 -- let a = (a1,a2) in
139 -- let x = (a,b) in
140 -- E
141
142 mkWwBodies dflags fam_envs rhs_fvs fun_id demands res_info
143 = do { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs)
144 -- See Note [Freshen WW arguments]
145
146 ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
147 <- mkWWargs empty_subst fun_ty demands
148 ; (useful1, work_args, wrap_fn_str, work_fn_str)
149 <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args
150
151 -- Do CPR w/w. See Note [Always do CPR w/w]
152 ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)
153 <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty res_info
154
155 ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty
156 worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]
157 wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var
158 worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args
159
160 ; if isWorkerSmallEnough dflags work_args
161 && not (too_many_args_for_join_point wrap_args)
162 && ((useful1 && not only_one_void_argument) || useful2)
163 then return (Just (worker_args_dmds, length work_call_args,
164 wrapper_body, worker_body))
165 else return Nothing
166 }
167 -- We use an INLINE unconditionally, even if the wrapper turns out to be
168 -- something trivial like
169 -- fw = ...
170 -- f = __inline__ (coerce T fw)
171 -- The point is to propagate the coerce to f's call sites, so even though
172 -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
173 -- fw from being inlined into f's RHS
174 where
175 fun_ty = idType fun_id
176 mb_join_arity = isJoinId_maybe fun_id
177 has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id)
178 -- See Note [Do not unpack class dictionaries]
179
180 -- Note [Do not split void functions]
181 only_one_void_argument
182 | [d] <- demands
183 , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty
184 , isAbsDmd d && isVoidTy arg_ty1
185 = True
186 | otherwise
187 = False
188
189 -- Note [Join points returning functions]
190 too_many_args_for_join_point wrap_args
191 | Just join_arity <- mb_join_arity
192 , wrap_args `lengthExceeds` join_arity
193 = WARN(True, text "Unable to worker/wrapper join point with arity " <+>
194 int join_arity <+> text "but" <+>
195 int (length wrap_args) <+> text "args")
196 True
197 | otherwise
198 = False
199
200 -- See Note [Limit w/w arity]
201 isWorkerSmallEnough :: DynFlags -> [Var] -> Bool
202 isWorkerSmallEnough dflags vars = count isId vars <= maxWorkerArgs dflags
203 -- We count only Free variables (isId) to skip Type, Kind
204 -- variables which have no runtime representation.
205
206 {-
207 Note [Always do CPR w/w]
208 ~~~~~~~~~~~~~~~~~~~~~~~~
209 At one time we refrained from doing CPR w/w for thunks, on the grounds that
210 we might duplicate work. But that is already handled by the demand analyser,
211 which doesn't give the CPR proprety if w/w might waste work: see
212 Note [CPR for thunks] in DmdAnal.
213
214 And if something *has* been given the CPR property and we don't w/w, it's
215 a disaster, because then the enclosing function might say it has the CPR
216 property, but now doesn't and there a cascade of disaster. A good example
217 is #5920.
218
219 Note [Limit w/w arity]
220 ~~~~~~~~~~~~~~~~~~~~~~~~
221 Guard against high worker arity as it generates a lot of stack traffic.
222 A simplified example is #11565#comment:6
223
224 Current strategy is very simple: don't perform w/w transformation at all
225 if the result produces a wrapper with arity higher than -fmax-worker-args=.
226
227 It is a bit all or nothing, consider
228
229 f (x,y) (a,b,c,d,e ... , z) = rhs
230
231 Currently we will remove all w/w ness entirely. But actually we could
232 w/w on the (x,y) pair... it's the huge product that is the problem.
233
234 Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd
235 solve f. But we can get a lot of args from deeply-nested products:
236
237 g (a, (b, (c, (d, ...)))) = rhs
238
239 This is harder to spot on an arg-by-arg basis. Previously mkWwStr was
240 given some "fuel" saying how many arguments it could add; when we ran
241 out of fuel it would stop w/wing.
242 Still not very clever because it had a left-right bias.
243
244 ************************************************************************
245 * *
246 \subsection{Making wrapper args}
247 * *
248 ************************************************************************
249
250 During worker-wrapper stuff we may end up with an unlifted thing
251 which we want to let-bind without losing laziness. So we
252 add a void argument. E.g.
253
254 f = /\a -> \x y z -> E::Int# -- E does not mention x,y,z
255 ==>
256 fw = /\ a -> \void -> E
257 f = /\ a -> \x y z -> fw realworld
258
259 We use the state-token type which generates no code.
260 -}
261
262 mkWorkerArgs :: DynFlags -> [Var]
263 -> Type -- Type of body
264 -> ([Var], -- Lambda bound args
265 [Var]) -- Args at call site
266 mkWorkerArgs dflags args res_ty
267 | any isId args || not needsAValueLambda
268 = (args, args)
269 | otherwise
270 = (args ++ [voidArgId], args ++ [voidPrimId])
271 where
272 -- See "Making wrapper args" section above
273 needsAValueLambda =
274 lifted
275 -- We may encounter a levity-polymorphic result, in which case we
276 -- conservatively assume that we have laziness that needs preservation.
277 -- See #15186.
278 || not (gopt Opt_FunToThunk dflags)
279 -- see Note [Protecting the last value argument]
280
281 -- Might the result be lifted?
282 lifted =
283 case isLiftedType_maybe res_ty of
284 Just lifted -> lifted
285 Nothing -> True
286
287 {-
288 Note [Protecting the last value argument]
289 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
290 If the user writes (\_ -> E), they might be intentionally disallowing
291 the sharing of E. Since absence analysis and worker-wrapper are keen
292 to remove such unused arguments, we add in a void argument to prevent
293 the function from becoming a thunk.
294
295 The user can avoid adding the void argument with the -ffun-to-thunk
296 flag. However, this can create sharing, which may be bad in two ways. 1) It can
297 create a space leak. 2) It can prevent inlining *under a lambda*. If w/w
298 removes the last argument from a function f, then f now looks like a thunk, and
299 so f can't be inlined *under a lambda*.
300
301 Note [Join points and beta-redexes]
302 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
303
304 Originally, the worker would invoke the original function by calling it with
305 arguments, thus producing a beta-redex for the simplifier to munch away:
306
307 \x y z -> e => (\x y z -> e) wx wy wz
308
309 Now that we have special rules about join points, however, this is Not Good if
310 the original function is itself a join point, as then it may contain invocations
311 of other join points:
312
313 join j1 x = ...
314 join j2 y = if y == 0 then 0 else j1 y
315
316 =>
317
318 join j1 x = ...
319 join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy
320 join j2 y = case y of I# y# -> jump $wj2 y#
321
322 There can't be an intervening lambda between a join point's declaration and its
323 occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:
324
325 ...
326 let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y
327 ...
328
329 Hence we simply do the beta-reduction here. (This would be harder if we had to
330 worry about hygiene, but luckily wy is freshly generated.)
331
332 Note [Join points returning functions]
333 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
334
335 It is crucial that the arity of a join point depends on its *callers,* not its
336 own syntax. What this means is that a join point can have "extra lambdas":
337
338 f :: Int -> Int -> (Int, Int) -> Int
339 f x y = join j (z, w) = \(u, v) -> ...
340 in jump j (x, y)
341
342 Typically this happens with functions that are seen as computing functions,
343 rather than being curried. (The real-life example was GraphOps.addConflicts.)
344
345 When we create the wrapper, it *must* be in "eta-contracted" form so that the
346 jump has the right number of arguments:
347
348 f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...
349 j (z, w) = jump $wj z w
350
351 (See Note [Join points and beta-redexes] for where the lets come from.) If j
352 were a function, we would instead say
353
354 f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...
355 j (z, w) (u, v) = $wj z w u v
356
357 Notice that the worker ends up with the same lambdas; it's only the wrapper we
358 have to be concerned about.
359
360 FIXME Currently the functionality to produce "eta-contracted" wrappers is
361 unimplemented; we simply give up.
362
363 ************************************************************************
364 * *
365 \subsection{Coercion stuff}
366 * *
367 ************************************************************************
368
369 We really want to "look through" coerces.
370 Reason: I've seen this situation:
371
372 let f = coerce T (\s -> E)
373 in \x -> case x of
374 p -> coerce T' f
375 q -> \s -> E2
376 r -> coerce T' f
377
378 If only we w/w'd f, we'd get
379 let f = coerce T (\s -> fw s)
380 fw = \s -> E
381 in ...
382
383 Now we'll inline f to get
384
385 let fw = \s -> E
386 in \x -> case x of
387 p -> fw
388 q -> \s -> E2
389 r -> fw
390
391 Now we'll see that fw has arity 1, and will arity expand
392 the \x to get what we want.
393 -}
394
395 -- mkWWargs just does eta expansion
396 -- is driven off the function type and arity.
397 -- It chomps bites off foralls, arrows, newtypes
398 -- and keeps repeating that until it's satisfied the supplied arity
399
400 mkWWargs :: TCvSubst -- Freshening substitution to apply to the type
401 -- See Note [Freshen WW arguments]
402 -> Type -- The type of the function
403 -> [Demand] -- Demands and one-shot info for value arguments
404 -> UniqSM ([Var], -- Wrapper args
405 CoreExpr -> CoreExpr, -- Wrapper fn
406 CoreExpr -> CoreExpr, -- Worker fn
407 Type) -- Type of wrapper body
408
409 mkWWargs subst fun_ty demands
410 | null demands
411 = return ([], id, id, substTy subst fun_ty)
412
413 | (dmd:demands') <- demands
414 , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty
415 = do { uniq <- getUniqueM
416 ; let arg_ty' = substTy subst arg_ty
417 id = mk_wrap_arg uniq arg_ty' dmd
418 ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
419 <- mkWWargs subst fun_ty' demands'
420 ; return (id : wrap_args,
421 Lam id . wrap_fn_args,
422 apply_or_bind_then work_fn_args (varToCoreExpr id),
423 res_ty) }
424
425 | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty
426 = do { uniq <- getUniqueM
427 ; let (subst', tv') = cloneTyVarBndr subst tv uniq
428 -- See Note [Freshen WW arguments]
429 ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
430 <- mkWWargs subst' fun_ty' demands
431 ; return (tv' : wrap_args,
432 Lam tv' . wrap_fn_args,
433 apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')),
434 res_ty) }
435
436 | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty
437 -- The newtype case is for when the function has
438 -- a newtype after the arrow (rare)
439 --
440 -- It's also important when we have a function returning (say) a pair
441 -- wrapped in a newtype, at least if CPR analysis can look
442 -- through such newtypes, which it probably can since they are
443 -- simply coerces.
444
445 = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)
446 <- mkWWargs subst rep_ty demands
447 ; let co' = substCo subst co
448 ; return (wrap_args,
449 \e -> Cast (wrap_fn_args e) (mkSymCo co'),
450 \e -> work_fn_args (Cast e co'),
451 res_ty) }
452
453 | otherwise
454 = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand
455 return ([], id, id, substTy subst fun_ty) -- then there should be a function arrow
456 where
457 -- See Note [Join points and beta-redexes]
458 apply_or_bind_then k arg (Lam bndr body)
459 = mkCoreLet (NonRec bndr arg) (k body) -- Important that arg is fresh!
460 apply_or_bind_then k arg fun
461 = k $ mkCoreApp (text "mkWWargs") fun arg
462 applyToVars :: [Var] -> CoreExpr -> CoreExpr
463 applyToVars vars fn = mkVarApps fn vars
464
465 mk_wrap_arg :: Unique -> Type -> Demand -> Id
466 mk_wrap_arg uniq ty dmd
467 = mkSysLocalOrCoVar (fsLit "w") uniq ty
468 `setIdDemandInfo` dmd
469
470 {- Note [Freshen WW arguments]
471 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
472 Wen we do a worker/wrapper split, we must not in-scope names as the arguments
473 of the worker, else we'll get name capture. E.g.
474
475 -- y1 is in scope from further out
476 f x = ..y1..
477
478 If we accidentally choose y1 as a worker argument disaster results:
479
480 fww y1 y2 = let x = (y1,y2) in ...y1...
481
482 To avoid this:
483
484 * We use a fresh unique for both type-variable and term-variable binders
485 Originally we lacked this freshness for type variables, and that led
486 to the very obscure #12562. (A type variable in the worker shadowed
487 an outer term-variable binding.)
488
489 * Because of this cloning we have to substitute in the type/kind of the
490 new binders. That's why we carry the TCvSubst through mkWWargs.
491
492 So we need a decent in-scope set, just in case that type/kind
493 itself has foralls. We get this from the free vars of the RHS of the
494 function since those are the only variables that might be captured.
495 It's a lazy thunk, which will only be poked if the type/kind has a forall.
496
497 Another tricky case was when f :: forall a. a -> forall a. a->a
498 (i.e. with shadowing), and then the worker used the same 'a' twice.
499
500 ************************************************************************
501 * *
502 \subsection{Strictness stuff}
503 * *
504 ************************************************************************
505 -}
506
507 mkWWstr :: DynFlags
508 -> FamInstEnvs
509 -> Bool -- True <=> INLINEABLE pragma on this function defn
510 -- See Note [Do not unpack class dictionaries]
511 -> [Var] -- Wrapper args; have their demand info on them
512 -- *Includes type variables*
513 -> UniqSM (Bool, -- Is this useful
514 [Var], -- Worker args
515 CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call
516 -- and without its lambdas
517 -- This fn adds the unboxing
518
519 CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function,
520 -- and lacking its lambdas.
521 -- This fn does the reboxing
522 mkWWstr dflags fam_envs has_inlineable_prag args
523 = go args
524 where
525 go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg
526
527 go [] = return (False, [], nop_fn, nop_fn)
528 go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg
529 ; (useful2, args2, wrap_fn2, work_fn2) <- go args
530 ; return ( useful1 || useful2
531 , args1 ++ args2
532 , wrap_fn1 . wrap_fn2
533 , work_fn1 . work_fn2) }
534
535 {-
536 Note [Unpacking arguments with product and polymorphic demands]
537 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
538 The argument is unpacked in a case if it has a product type and has a
539 strict *and* used demand put on it. I.e., arguments, with demands such
540 as the following ones:
541
542 <S,U(U, L)>
543 <S(L,S),U>
544
545 will be unpacked, but
546
547 <S,U> or <B,U>
548
549 will not, because the pieces aren't used. This is quite important otherwise
550 we end up unpacking massive tuples passed to the bottoming function. Example:
551
552 f :: ((Int,Int) -> String) -> (Int,Int) -> a
553 f g pr = error (g pr)
554
555 main = print (f fst (1, error "no"))
556
557 Does 'main' print "error 1" or "error no"? We don't really want 'f'
558 to unbox its second argument. This actually happened in GHC's onwn
559 source code, in Packages.applyPackageFlag, which ended up un-boxing
560 the enormous DynFlags tuple, and being strict in the
561 as-yet-un-filled-in pkgState files.
562 -}
563
564 ----------------------
565 -- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)
566 -- * wrap_fn assumes wrap_arg is in scope,
567 -- brings into scope work_args (via cases)
568 -- * work_fn assumes work_args are in scope, a
569 -- brings into scope wrap_arg (via lets)
570 -- See Note [How to do the worker/wrapper split]
571 mkWWstr_one :: DynFlags -> FamInstEnvs
572 -> Bool -- True <=> INLINEABLE pragma on this function defn
573 -- See Note [Do not unpack class dictionaries]
574 -> Var
575 -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
576 mkWWstr_one dflags fam_envs has_inlineable_prag arg
577 | isTyVar arg
578 = return (False, [arg], nop_fn, nop_fn)
579
580 | isAbsDmd dmd
581 , Just work_fn <- mk_absent_let dflags arg
582 -- Absent case. We can't always handle absence for arbitrary
583 -- unlifted types, so we need to choose just the cases we can
584 -- (that's what mk_absent_let does)
585 = return (True, [], nop_fn, work_fn)
586
587 | isStrictDmd dmd
588 , Just cs <- splitProdDmd_maybe dmd
589 -- See Note [Unpacking arguments with product and polymorphic demands]
590 , not (has_inlineable_prag && isClassPred arg_ty)
591 -- See Note [Do not unpack class dictionaries]
592 , Just stuff@(_, _, inst_con_arg_tys, _) <- deepSplitProductType_maybe fam_envs arg_ty
593 , cs `equalLength` inst_con_arg_tys
594 -- See Note [mkWWstr and unsafeCoerce]
595 = unbox_one dflags fam_envs arg cs stuff
596
597 | isSeqDmd dmd -- For seqDmd, splitProdDmd_maybe will return Nothing, but
598 -- it should behave like <S, U(AAAA)>, for some suitable arity
599 , Just stuff@(_, _, inst_con_arg_tys, _) <- deepSplitProductType_maybe fam_envs arg_ty
600 , let abs_dmds = map (const absDmd) inst_con_arg_tys
601 = unbox_one dflags fam_envs arg abs_dmds stuff
602
603 | otherwise -- Other cases
604 = return (False, [arg], nop_fn, nop_fn)
605
606 where
607 arg_ty = idType arg
608 dmd = idDemandInfo arg
609
610 unbox_one :: DynFlags -> FamInstEnvs -> Var
611 -> [Demand]
612 -> (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
613 -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
614 unbox_one dflags fam_envs arg cs
615 (data_con, inst_tys, inst_con_arg_tys, co)
616 = do { (uniq1:uniqs) <- getUniquesM
617 ; let -- See Note [Add demands for strict constructors]
618 cs' = addDataConStrictness data_con cs
619 unpk_args = zipWith3 mk_ww_arg uniqs inst_con_arg_tys cs'
620 unbox_fn = mkUnpackCase (Var arg) co uniq1
621 data_con unpk_args
622 arg_no_unf = zapStableUnfolding arg
623 -- See Note [Zap unfolding when beta-reducing]
624 -- in Simplify.hs; and see #13890
625 rebox_fn = Let (NonRec arg_no_unf con_app)
626 con_app = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
627 ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False unpk_args
628 ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
629 -- Don't pass the arg, rebox instead
630 where
631 mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd
632
633 ----------------------
634 nop_fn :: CoreExpr -> CoreExpr
635 nop_fn body = body
636
637 addDataConStrictness :: DataCon -> [Demand] -> [Demand]
638 -- See Note [Add demands for strict constructors]
639 addDataConStrictness con ds
640 = ASSERT2( equalLength strs ds, ppr con $$ ppr strs $$ ppr ds )
641 zipWith add ds strs
642 where
643 strs = dataConRepStrictness con
644 add dmd str | isMarkedStrict str = strictifyDmd dmd
645 | otherwise = dmd
646
647 {- Note [How to do the worker/wrapper split]
648 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
649 The worker-wrapper transformation, mkWWstr_one, takes into account
650 several possibilities to decide if the function is worthy for
651 splitting:
652
653 1. If an argument is absent, it would be silly to pass it to
654 the worker. Hence the isAbsDmd case. This case must come
655 first because a demand like <S,A> or <B,A> is possible.
656 E.g. <B,A> comes from a function like
657 f x = error "urk"
658 and <S,A> can come from Note [Add demands for strict constructors]
659
660 2. If the argument is evaluated strictly, and we can split the
661 product demand (splitProdDmd_maybe), then unbox it and w/w its
662 pieces. For example
663
664 f :: (Int, Int) -> Int
665 f p = (case p of (a,b) -> a) + 1
666 is split to
667 f :: (Int, Int) -> Int
668 f p = case p of (a,b) -> $wf a
669
670 $wf :: Int -> Int
671 $wf a = a + 1
672
673 and
674 g :: Bool -> (Int, Int) -> Int
675 g c p = case p of (a,b) ->
676 if c then a else b
677 is split to
678 g c p = case p of (a,b) -> $gw c a b
679 $gw c a b = if c then a else b
680
681 2a But do /not/ split if the components are not used; that is, the
682 usage is just 'Used' rather than 'UProd'. In this case
683 splitProdDmd_maybe returns Nothing. Otherwise we risk decomposing
684 a massive tuple which is barely used. Example:
685
686 f :: ((Int,Int) -> String) -> (Int,Int) -> a
687 f g pr = error (g pr)
688
689 main = print (f fst (1, error "no"))
690
691 Here, f does not take 'pr' apart, and it's stupid to do so.
692 Imagine that it had millions of fields. This actually happened
693 in GHC itself where the tuple was DynFlags
694
695 3. A plain 'seqDmd', which is head-strict with usage UHead, can't
696 be split by splitProdDmd_maybe. But we want it to behave just
697 like U(AAAA) for suitable number of absent demands. So we have
698 a special case for it, with arity coming from the data constructor.
699
700 Note [Worker-wrapper for bottoming functions]
701 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
702 We used not to split if the result is bottom.
703 [Justification: there's no efficiency to be gained.]
704
705 But it's sometimes bad not to make a wrapper. Consider
706 fw = \x# -> let x = I# x# in case e of
707 p1 -> error_fn x
708 p2 -> error_fn x
709 p3 -> the real stuff
710 The re-boxing code won't go away unless error_fn gets a wrapper too.
711 [We don't do reboxing now, but in general it's better to pass an
712 unboxed thing to f, and have it reboxed in the error cases....]
713
714 Note [Add demands for strict constructors]
715 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
716 Consider this program (due to Roman):
717
718 data X a = X !a
719
720 foo :: X Int -> Int -> Int
721 foo (X a) n = go 0
722 where
723 go i | i < n = a + go (i+1)
724 | otherwise = 0
725
726 We want the worker for 'foo' too look like this:
727
728 $wfoo :: Int# -> Int# -> Int#
729
730 with the first argument unboxed, so that it is not eval'd each time
731 around the 'go' loop (which would otherwise happen, since 'foo' is not
732 strict in 'a'). It is sound for the wrapper to pass an unboxed arg
733 because X is strict, so its argument must be evaluated. And if we
734 *don't* pass an unboxed argument, we can't even repair it by adding a
735 `seq` thus:
736
737 foo (X a) n = a `seq` go 0
738
739 because the seq is discarded (very early) since X is strict!
740
741 So here's what we do
742
743 * We leave the demand-analysis alone. The demand on 'a' in the
744 definition of 'foo' is <L, U(U)>; the strictness info is Lazy
745 because foo's body may or may not evaluate 'a'; but the usage info
746 says that 'a' is unpacked and its content is used.
747
748 * During worker/wrapper, if we unpack a strict constructor (as we do
749 for 'foo'), we use 'addDataConStrictness' to bump up the strictness on
750 the strict arguments of the data constructor.
751
752 * That in turn means that, if the usage info supports doing so
753 (i.e. splitProdDmd_maybe returns Just), we will unpack that argument
754 -- even though the original demand (e.g. on 'a') was lazy.
755
756 * What does "bump up the strictness" mean? Just add a head-strict
757 demand to the strictness! Even for a demand like <L,A> we can
758 safely turn it into <S,A>; remember case (1) of
759 Note [How to do the worker/wrapper split].
760
761 The net effect is that the w/w transformation is more aggressive about
762 unpacking the strict arguments of a data constructor, when that
763 eagerness is supported by the usage info.
764
765 There is the usual danger of reboxing, which as usual we ignore. But
766 if X is monomorphic, and has an UNPACK pragma, then this optimisation
767 is even more important. We don't want the wrapper to rebox an unboxed
768 argument, and pass an Int to $wfoo!
769
770 This works in nested situations like
771
772 data family Bar a
773 data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)
774 newtype instance Bar Int = Bar Int
775
776 foo :: Bar ((Int, Int), Int) -> Int -> Int
777 foo f k = case f of BarPair x y ->
778 case burble of
779 True -> case x of
780 BarPair p q -> ...
781 False -> ...
782
783 The extra eagerness lets us produce a worker of type:
784 $wfoo :: Int# -> Int# -> Int# -> Int -> Int
785 $wfoo p# q# y# = ...
786
787 even though the `case x` is only lazily evaluated.
788
789 --------- Historical note ------------
790 We used to add data-con strictness demands when demand analysing case
791 expression. However, it was noticed in #15696 that this misses some cases. For
792 instance, consider the program (from T10482)
793
794 data family Bar a
795 data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)
796 newtype instance Bar Int = Bar Int
797
798 foo :: Bar ((Int, Int), Int) -> Int -> Int
799 foo f k =
800 case f of
801 BarPair x y -> case burble of
802 True -> case x of
803 BarPair p q -> ...
804 False -> ...
805
806 We really should be able to assume that `p` is already evaluated since it came
807 from a strict field of BarPair. This strictness would allow us to produce a
808 worker of type:
809
810 $wfoo :: Int# -> Int# -> Int# -> Int -> Int
811 $wfoo p# q# y# = ...
812
813 even though the `case x` is only lazily evaluated
814
815 Indeed before we fixed #15696 this would happen since we would float the inner
816 `case x` through the `case burble` to get:
817
818 foo f k =
819 case f of
820 BarPair x y -> case x of
821 BarPair p q -> case burble of
822 True -> ...
823 False -> ...
824
825 However, after fixing #15696 this could no longer happen (for the reasons
826 discussed in ticket:15696#comment:76). This means that the demand placed on `f`
827 would then be significantly weaker (since the False branch of the case on
828 `burble` is not strict in `p` or `q`).
829
830 Consequently, we now instead account for data-con strictness in mkWWstr_one,
831 applying the strictness demands to the final result of DmdAnal. The result is
832 that we get the strict demand signature we wanted even if we can't float
833 the case on `x` up through the case on `burble`.
834
835
836 Note [mkWWstr and unsafeCoerce]
837 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
838 By using unsafeCoerce, it is possible to make the number of demands fail to
839 match the number of constructor arguments; this happened in #8037.
840 If so, the worker/wrapper split doesn't work right and we get a Core Lint
841 bug. The fix here is simply to decline to do w/w if that happens.
842
843 Note [Record evaluated-ness in worker/wrapper]
844 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
845 Suppose we have
846
847 data T = MkT !Int Int
848
849 f :: T -> T
850 f x = e
851
852 and f's is strict, and has the CPR property. The we are going to generate
853 this w/w split
854
855 f x = case x of
856 MkT x1 x2 -> case $wf x1 x2 of
857 (# r1, r2 #) -> MkT r1 r2
858
859 $wfw x1 x2 = let x = MkT x1 x2 in
860 case e of
861 MkT r1 r2 -> (# r1, r2 #)
862
863 Note that
864
865 * In the worker $wf, inside 'e' we can be sure that x1 will be
866 evaluated (it came from unpacking the argument MkT. But that's no
867 immediately apparent in $wf
868
869 * In the wrapper 'f', which we'll inline at call sites, we can be sure
870 that 'r1' has been evaluated (because it came from unpacking the result
871 MkT. But that is not immediately apparent from the wrapper code.
872
873 Missing these facts isn't unsound, but it loses possible future
874 opportunities for optimisation.
875
876 Solution: use setCaseBndrEvald when creating
877 (A) The arg binders x1,x2 in mkWstr_one
878 See #13077, test T13077
879 (B) The result binders r1,r2 in mkWWcpr_help
880 See Trace #13077, test T13077a
881 And #13027 comment:20, item (4)
882 to record that the relevant binder is evaluated.
883
884
885 ************************************************************************
886 * *
887 Type scrutiny that is specific to demand analysis
888 * *
889 ************************************************************************
890
891 Note [Do not unpack class dictionaries]
892 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
893 If we have
894 f :: Ord a => [a] -> Int -> a
895 {-# INLINABLE f #-}
896 and we worker/wrapper f, we'll get a worker with an INLINABLE pragma
897 (see Note [Worker-wrapper for INLINABLE functions] in WorkWrap), which
898 can still be specialised by the type-class specialiser, something like
899 fw :: Ord a => [a] -> Int# -> a
900
901 BUT if f is strict in the Ord dictionary, we might unpack it, to get
902 fw :: (a->a->Bool) -> [a] -> Int# -> a
903 and the type-class specialiser can't specialise that. An example is
904 #6056.
905
906 But in any other situation a dictionary is just an ordinary value,
907 and can be unpacked. So we track the INLINABLE pragma, and switch
908 off the unpacking in mkWWstr_one (see the isClassPred test).
909
910 Historical note: #14955 describes how I got this fix wrong
911 the first time.
912 -}
913
914 deepSplitProductType_maybe
915 :: FamInstEnvs -> Type
916 -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
917 -- If deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)
918 -- then dc @ tys (args::arg_tys) :: rep_ty
919 -- co :: ty ~ rep_ty
920 -- Why do we return the strictness of the data-con arguments?
921 -- Answer: see Note [Record evaluated-ness in worker/wrapper]
922 deepSplitProductType_maybe fam_envs ty
923 | let (co, ty1) = topNormaliseType_maybe fam_envs ty
924 `orElse` (mkRepReflCo ty, ty)
925 , Just (tc, tc_args) <- splitTyConApp_maybe ty1
926 , Just con <- isDataProductTyCon_maybe tc
927 , let arg_tys = dataConInstArgTys con tc_args
928 strict_marks = dataConRepStrictness con
929 = Just (con, tc_args, zipEqual "dspt" arg_tys strict_marks, co)
930 deepSplitProductType_maybe _ _ = Nothing
931
932 deepSplitCprType_maybe
933 :: FamInstEnvs -> ConTag -> Type
934 -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
935 -- If deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co)
936 -- then dc @ tys (args::arg_tys) :: rep_ty
937 -- co :: ty ~ rep_ty
938 -- Why do we return the strictness of the data-con arguments?
939 -- Answer: see Note [Record evaluated-ness in worker/wrapper]
940 deepSplitCprType_maybe fam_envs con_tag ty
941 | let (co, ty1) = topNormaliseType_maybe fam_envs ty
942 `orElse` (mkRepReflCo ty, ty)
943 , Just (tc, tc_args) <- splitTyConApp_maybe ty1
944 , isDataTyCon tc
945 , let cons = tyConDataCons tc
946 , cons `lengthAtLeast` con_tag -- This might not be true if we import the
947 -- type constructor via a .hs-bool file (#8743)
948 , let con = cons `getNth` (con_tag - fIRST_TAG)
949 arg_tys = dataConInstArgTys con tc_args
950 strict_marks = dataConRepStrictness con
951 = Just (con, tc_args, zipEqual "dsct" arg_tys strict_marks, co)
952 deepSplitCprType_maybe _ _ _ = Nothing
953
954 findTypeShape :: FamInstEnvs -> Type -> TypeShape
955 -- Uncover the arrow and product shape of a type
956 -- The data type TypeShape is defined in Demand
957 -- See Note [Trimming a demand to a type] in Demand
958 findTypeShape fam_envs ty
959 | Just (tc, tc_args) <- splitTyConApp_maybe ty
960 , Just con <- isDataProductTyCon_maybe tc
961 = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args)
962
963 | Just (_, res) <- splitFunTy_maybe ty
964 = TsFun (findTypeShape fam_envs res)
965
966 | Just (_, ty') <- splitForAllTy_maybe ty
967 = findTypeShape fam_envs ty'
968
969 | Just (_, ty') <- topNormaliseType_maybe fam_envs ty
970 = findTypeShape fam_envs ty'
971
972 | otherwise
973 = TsUnk
974
975 {-
976 ************************************************************************
977 * *
978 \subsection{CPR stuff}
979 * *
980 ************************************************************************
981
982
983 @mkWWcpr@ takes the worker/wrapper pair produced from the strictness
984 info and adds in the CPR transformation. The worker returns an
985 unboxed tuple containing non-CPR components. The wrapper takes this
986 tuple and re-produces the correct structured output.
987
988 The non-CPR results appear ordered in the unboxed tuple as if by a
989 left-to-right traversal of the result structure.
990 -}
991
992 mkWWcpr :: Bool
993 -> FamInstEnvs
994 -> Type -- function body type
995 -> DmdResult -- CPR analysis results
996 -> UniqSM (Bool, -- Is w/w'ing useful?
997 CoreExpr -> CoreExpr, -- New wrapper
998 CoreExpr -> CoreExpr, -- New worker
999 Type) -- Type of worker's body
1000
1001 mkWWcpr opt_CprAnal fam_envs body_ty res
1002 -- CPR explicitly turned off (or in -O0)
1003 | not opt_CprAnal = return (False, id, id, body_ty)
1004 -- CPR is turned on by default for -O and O2
1005 | otherwise
1006 = case returnsCPR_maybe res of
1007 Nothing -> return (False, id, id, body_ty) -- No CPR info
1008 Just con_tag | Just stuff <- deepSplitCprType_maybe fam_envs con_tag body_ty
1009 -> mkWWcpr_help stuff
1010 | otherwise
1011 -- See Note [non-algebraic or open body type warning]
1012 -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
1013 return (False, id, id, body_ty)
1014
1015 mkWWcpr_help :: (DataCon, [Type], [(Type,StrictnessMark)], Coercion)
1016 -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
1017
1018 mkWWcpr_help (data_con, inst_tys, arg_tys, co)
1019 | [arg1@(arg_ty1, _)] <- arg_tys
1020 , isUnliftedType arg_ty1
1021 -- Special case when there is a single result of unlifted type
1022 --
1023 -- Wrapper: case (..call worker..) of x -> C x
1024 -- Worker: case ( ..body.. ) of C x -> x
1025 = do { (work_uniq : arg_uniq : _) <- getUniquesM
1026 ; let arg = mk_ww_local arg_uniq arg1
1027 con_app = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co
1028
1029 ; return ( True
1030 , \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]
1031 , \ body -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg)
1032 -- varToCoreExpr important here: arg can be a coercion
1033 -- Lacking this caused #10658
1034 , arg_ty1 ) }
1035
1036 | otherwise -- The general case
1037 -- Wrapper: case (..call worker..) of (# a, b #) -> C a b
1038 -- Worker: case ( ...body... ) of C a b -> (# a, b #)
1039 = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM
1040 ; let wrap_wild = mk_ww_local wild_uniq (ubx_tup_ty,MarkedStrict)
1041 args = zipWith mk_ww_local uniqs arg_tys
1042 ubx_tup_ty = exprType ubx_tup_app
1043 ubx_tup_app = mkCoreUbxTup (map fst arg_tys) (map varToCoreExpr args)
1044 con_app = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co
1045
1046 ; return (True
1047 , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app) [(DataAlt (tupleDataCon Unboxed (length arg_tys)), args, con_app)]
1048 , \ body -> mkUnpackCase body co work_uniq data_con args ubx_tup_app
1049 , ubx_tup_ty ) }
1050
1051 mkUnpackCase :: CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
1052 -- (mkUnpackCase e co uniq Con args body)
1053 -- returns
1054 -- case e |> co of bndr { Con args -> body }
1055
1056 mkUnpackCase (Tick tickish e) co uniq con args body -- See Note [Profiling and unpacking]
1057 = Tick tickish (mkUnpackCase e co uniq con args body)
1058 mkUnpackCase scrut co uniq boxing_con unpk_args body
1059 = Case casted_scrut bndr (exprType body)
1060 [(DataAlt boxing_con, unpk_args, body)]
1061 where
1062 casted_scrut = scrut `mkCast` co
1063 bndr = mk_ww_local uniq (exprType casted_scrut, MarkedStrict)
1064
1065 {-
1066 Note [non-algebraic or open body type warning]
1067 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1068
1069 There are a few cases where the W/W transformation is told that something
1070 returns a constructor, but the type at hand doesn't really match this. One
1071 real-world example involves unsafeCoerce:
1072 foo = IO a
1073 foo = unsafeCoerce c_exit
1074 foreign import ccall "c_exit" c_exit :: IO ()
1075 Here CPR will tell you that `foo` returns a () constructor for sure, but trying
1076 to create a worker/wrapper for type `a` obviously fails.
1077 (This was a real example until ee8e792 in libraries/base.)
1078
1079 It does not seem feasible to avoid all such cases already in the analyser (and
1080 after all, the analysis is not really wrong), so we simply do nothing here in
1081 mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch
1082 other cases where something went avoidably wrong.
1083
1084
1085 Note [Profiling and unpacking]
1086 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1087 If the original function looked like
1088 f = \ x -> {-# SCC "foo" #-} E
1089
1090 then we want the CPR'd worker to look like
1091 \ x -> {-# SCC "foo" #-} (case E of I# x -> x)
1092 and definitely not
1093 \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)
1094
1095 This transform doesn't move work or allocation
1096 from one cost centre to another.
1097
1098 Later [SDM]: presumably this is because we want the simplifier to
1099 eliminate the case, and the scc would get in the way? I'm ok with
1100 including the case itself in the cost centre, since it is morally
1101 part of the function (post transformation) anyway.
1102
1103
1104 ************************************************************************
1105 * *
1106 \subsection{Utilities}
1107 * *
1108 ************************************************************************
1109
1110 Note [Absent errors]
1111 ~~~~~~~~~~~~~~~~~~~~
1112 We make a new binding for Ids that are marked absent, thus
1113 let x = absentError "x :: Int"
1114 The idea is that this binding will never be used; but if it
1115 buggily is used we'll get a runtime error message.
1116
1117 Coping with absence for *unlifted* types is important; see, for
1118 example, #4306 and #15627. In the UnliftedRep case, we can
1119 use LitRubbish, which we need to apply to the required type.
1120 For the unlifted types of singleton kind like Float#, Addr#, etc. we
1121 also find a suitable literal, using Literal.absentLiteralOf. We don't
1122 have literals for every primitive type, so the function is partial.
1123
1124 Note: I did try the experiment of using an error thunk for unlifted
1125 things too, relying on the simplifier to drop it as dead code.
1126 But this is fragile
1127
1128 - It fails when profiling is on, which disables various optimisations
1129
1130 - It fails when reboxing happens. E.g.
1131 data T = MkT Int Int#
1132 f p@(MkT a _) = ...g p....
1133 where g is /lazy/ in 'p', but only uses the first component. Then
1134 'f' is /strict/ in 'p', and only uses the first component. So we only
1135 pass that component to the worker for 'f', which reconstructs 'p' to
1136 pass it to 'g'. Alas we can't say
1137 ...f (MkT a (absentError Int# "blah"))...
1138 bacause `MkT` is strict in its Int# argument, so we get an absentError
1139 exception when we shouldn't. Very annoying!
1140
1141 So absentError is only used for lifted types.
1142 -}
1143
1144 -- | Tries to find a suitable dummy RHS to bind the given absent identifier to.
1145 --
1146 -- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding
1147 -- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be
1148 -- found (currently only happens for bindings of 'VecRep' representation).
1149 mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
1150 mk_absent_let dflags arg
1151 -- The lifted case: Bind 'absentError'
1152 -- See Note [Absent errors]
1153 | not (isUnliftedType arg_ty)
1154 = Just (Let (NonRec lifted_arg abs_rhs))
1155 -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@
1156 -- See Note [Absent errors]
1157 | [UnliftedRep] <- typePrimRep arg_ty
1158 = Just (Let (NonRec arg unlifted_rhs))
1159 -- The monomorphic unlifted cases: Bind to some literal, if possible
1160 -- See Note [Absent errors]
1161 | Just tc <- tyConAppTyCon_maybe arg_ty
1162 , Just lit <- absentLiteralOf tc
1163 = Just (Let (NonRec arg (Lit lit)))
1164 | arg_ty `eqType` voidPrimTy
1165 = Just (Let (NonRec arg (Var voidPrimId)))
1166 | otherwise
1167 = WARN( True, text "No absent value for" <+> ppr arg_ty )
1168 Nothing -- Can happen for 'State#' and things of 'VecRep'
1169 where
1170 lifted_arg = arg `setIdStrictness` botSig
1171 -- Note in strictness signature that this is bottoming
1172 -- (for the sake of the "empty case scrutinee not known to
1173 -- diverge for sure lint" warning)
1174 arg_ty = idType arg
1175 abs_rhs = mkAbsentErrorApp arg_ty msg
1176 msg = showSDoc (gopt_set dflags Opt_SuppressUniques)
1177 (ppr arg <+> ppr (idType arg))
1178 -- We need to suppress uniques here because otherwise they'd
1179 -- end up in the generated code as strings. This is bad for
1180 -- determinism, because with different uniques the strings
1181 -- will have different lengths and hence different costs for
1182 -- the inliner leading to different inlining.
1183 -- See also Note [Unique Determinism] in Unique
1184 unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty]
1185
1186 mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id
1187 -- The StrictnessMark comes form the data constructor and says
1188 -- whether this field is strict
1189 -- See Note [Record evaluated-ness in worker/wrapper]
1190 mk_ww_local uniq (ty,str)
1191 = setCaseBndrEvald str $
1192 mkSysLocalOrCoVar (fsLit "ww") uniq ty