474743a955b5334c1d50ae17486382d4f8e769bb
[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, vanillaIdInfo )
22 import DataCon
23 import Demand
24 import MkCore ( mkRuntimeErrorApp, aBSENT_ERROR_ID, mkCoreUbxTup
25 , mkCoreApp, mkCoreLet )
26 import MkId ( voidArgId, voidPrimId )
27 import TysPrim ( voidPrimTy )
28 import TysWiredIn ( tupleDataCon )
29 import VarEnv ( mkInScopeSet )
30 import VarSet ( VarSet )
31 import Type
32 import RepType ( isVoidTy )
33 import Coercion
34 import FamInstEnv
35 import BasicTypes ( Boxity(..) )
36 import Literal ( absentLiteralOf )
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 -> Maybe JoinArity -- Just ar <=> is join point with join arity ar
127 -> Type -- Type of original function
128 -> [Demand] -- Strictness of original function
129 -> DmdResult -- Info about function result
130 -> UniqSM (Maybe WwResult)
131
132 -- wrap_fn_args E = \x y -> E
133 -- work_fn_args E = E x y
134
135 -- wrap_fn_str E = case x of { (a,b) ->
136 -- case a of { (a1,a2) ->
137 -- E a1 a2 b y }}
138 -- work_fn_str E = \a2 a2 b y ->
139 -- let a = (a1,a2) in
140 -- let x = (a,b) in
141 -- E
142
143 mkWwBodies dflags fam_envs rhs_fvs mb_join_arity fun_ty demands res_info
144 = do { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs)
145 -- See Note [Freshen WW arguments]
146
147 ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs empty_subst fun_ty demands
148 ; (useful1, work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags fam_envs wrap_args
149
150 -- Do CPR w/w. See Note [Always do CPR w/w]
151 ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)
152 <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty res_info
153
154 ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty
155 worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]
156 wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var
157 worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args
158
159 ; if isWorkerSmallEnough dflags work_args
160 && not (too_many_args_for_join_point wrap_args)
161 && (useful1 && not only_one_void_argument || useful2)
162 then return (Just (worker_args_dmds, length work_call_args,
163 wrapper_body, worker_body))
164 else return Nothing
165 }
166 -- We use an INLINE unconditionally, even if the wrapper turns out to be
167 -- something trivial like
168 -- fw = ...
169 -- f = __inline__ (coerce T fw)
170 -- The point is to propagate the coerce to f's call sites, so even though
171 -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
172 -- fw from being inlined into f's RHS
173 where
174 -- Note [Do not split void functions]
175 only_one_void_argument
176 | [d] <- demands
177 , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty
178 , isAbsDmd d && isVoidTy arg_ty1
179 = True
180 | otherwise
181 = False
182
183 -- Note [Join points returning functions]
184 too_many_args_for_join_point wrap_args
185 | Just join_arity <- mb_join_arity
186 , wrap_args `lengthExceeds` join_arity
187 = WARN(True, text "Unable to worker/wrapper join point with arity " <+>
188 int join_arity <+> text "but" <+>
189 int (length wrap_args) <+> text "args")
190 True
191 | otherwise
192 = False
193
194 -- See Note [Limit w/w arity]
195 isWorkerSmallEnough :: DynFlags -> [Var] -> Bool
196 isWorkerSmallEnough dflags vars = count isId vars <= maxWorkerArgs dflags
197 -- We count only Free variables (isId) to skip Type, Kind
198 -- variables which have no runtime representation.
199
200 {-
201 Note [Always do CPR w/w]
202 ~~~~~~~~~~~~~~~~~~~~~~~~
203 At one time we refrained from doing CPR w/w for thunks, on the grounds that
204 we might duplicate work. But that is already handled by the demand analyser,
205 which doesn't give the CPR proprety if w/w might waste work: see
206 Note [CPR for thunks] in DmdAnal.
207
208 And if something *has* been given the CPR property and we don't w/w, it's
209 a disaster, because then the enclosing function might say it has the CPR
210 property, but now doesn't and there a cascade of disaster. A good example
211 is Trac #5920.
212
213 Note [Limit w/w arity]
214 ~~~~~~~~~~~~~~~~~~~~~~~~
215 Guard against high worker arity as it generates a lot of stack traffic.
216 A simplified example is Trac #11565#comment:6
217
218 Current strategy is very simple: don't perform w/w transformation at all
219 if the result produces a wrapper with arity higher than -fmax-worker-args=.
220
221 It is a bit all or nothing, consider
222
223 f (x,y) (a,b,c,d,e ... , z) = rhs
224
225 Currently we will remove all w/w ness entirely. But actually we could
226 w/w on the (x,y) pair... it's the huge product that is the problem.
227
228 Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd
229 solve f. But we can get a lot of args from deeply-nested products:
230
231 g (a, (b, (c, (d, ...)))) = rhs
232
233 This is harder to spot on an arg-by-arg basis. Previously mkWwStr was
234 given some "fuel" saying how many arguments it could add; when we ran
235 out of fuel it would stop w/wing.
236 Still not very clever because it had a left-right bias.
237
238 ************************************************************************
239 * *
240 \subsection{Making wrapper args}
241 * *
242 ************************************************************************
243
244 During worker-wrapper stuff we may end up with an unlifted thing
245 which we want to let-bind without losing laziness. So we
246 add a void argument. E.g.
247
248 f = /\a -> \x y z -> E::Int# -- E does not mention x,y,z
249 ==>
250 fw = /\ a -> \void -> E
251 f = /\ a -> \x y z -> fw realworld
252
253 We use the state-token type which generates no code.
254 -}
255
256 mkWorkerArgs :: DynFlags -> [Var]
257 -> Type -- Type of body
258 -> ([Var], -- Lambda bound args
259 [Var]) -- Args at call site
260 mkWorkerArgs dflags args res_ty
261 | any isId args || not needsAValueLambda
262 = (args, args)
263 | otherwise
264 = (args ++ [voidArgId], args ++ [voidPrimId])
265 where
266 needsAValueLambda =
267 isUnliftedType res_ty
268 || not (gopt Opt_FunToThunk dflags)
269 -- see Note [Protecting the last value argument]
270
271 {-
272 Note [Protecting the last value argument]
273 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
274 If the user writes (\_ -> E), they might be intentionally disallowing
275 the sharing of E. Since absence analysis and worker-wrapper are keen
276 to remove such unused arguments, we add in a void argument to prevent
277 the function from becoming a thunk.
278
279 The user can avoid adding the void argument with the -ffun-to-thunk
280 flag. However, this can create sharing, which may be bad in two ways. 1) It can
281 create a space leak. 2) It can prevent inlining *under a lambda*. If w/w
282 removes the last argument from a function f, then f now looks like a thunk, and
283 so f can't be inlined *under a lambda*.
284
285 Note [Join points and beta-redexes]
286 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
287
288 Originally, the worker would invoke the original function by calling it with
289 arguments, thus producing a beta-redex for the simplifier to munch away:
290
291 \x y z -> e => (\x y z -> e) wx wy wz
292
293 Now that we have special rules about join points, however, this is Not Good if
294 the original function is itself a join point, as then it may contain invocations
295 of other join points:
296
297 join j1 x = ...
298 join j2 y = if y == 0 then 0 else j1 y
299
300 =>
301
302 join j1 x = ...
303 join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy
304 join j2 y = case y of I# y# -> jump $wj2 y#
305
306 There can't be an intervening lambda between a join point's declaration and its
307 occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:
308
309 ...
310 let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y
311 ...
312
313 Hence we simply do the beta-reduction here. (This would be harder if we had to
314 worry about hygiene, but luckily wy is freshly generated.)
315
316 Note [Join points returning functions]
317 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
318
319 It is crucial that the arity of a join point depends on its *callers,* not its
320 own syntax. What this means is that a join point can have "extra lambdas":
321
322 f :: Int -> Int -> (Int, Int) -> Int
323 f x y = join j (z, w) = \(u, v) -> ...
324 in jump j (x, y)
325
326 Typically this happens with functions that are seen as computing functions,
327 rather than being curried. (The real-life example was GraphOps.addConflicts.)
328
329 When we create the wrapper, it *must* be in "eta-contracted" form so that the
330 jump has the right number of arguments:
331
332 f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...
333 j (z, w) = jump $wj z w
334
335 (See Note [Join points and beta-redexes] for where the lets come from.) If j
336 were a function, we would instead say
337
338 f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...
339 j (z, w) (u, v) = $wj z w u v
340
341 Notice that the worker ends up with the same lambdas; it's only the wrapper we
342 have to be concerned about.
343
344 FIXME Currently the functionality to produce "eta-contracted" wrappers is
345 unimplemented; we simply give up.
346
347 ************************************************************************
348 * *
349 \subsection{Coercion stuff}
350 * *
351 ************************************************************************
352
353 We really want to "look through" coerces.
354 Reason: I've seen this situation:
355
356 let f = coerce T (\s -> E)
357 in \x -> case x of
358 p -> coerce T' f
359 q -> \s -> E2
360 r -> coerce T' f
361
362 If only we w/w'd f, we'd get
363 let f = coerce T (\s -> fw s)
364 fw = \s -> E
365 in ...
366
367 Now we'll inline f to get
368
369 let fw = \s -> E
370 in \x -> case x of
371 p -> fw
372 q -> \s -> E2
373 r -> fw
374
375 Now we'll see that fw has arity 1, and will arity expand
376 the \x to get what we want.
377 -}
378
379 -- mkWWargs just does eta expansion
380 -- is driven off the function type and arity.
381 -- It chomps bites off foralls, arrows, newtypes
382 -- and keeps repeating that until it's satisfied the supplied arity
383
384 mkWWargs :: TCvSubst -- Freshening substitution to apply to the type
385 -- See Note [Freshen WW arguments]
386 -> Type -- The type of the function
387 -> [Demand] -- Demands and one-shot info for value arguments
388 -> UniqSM ([Var], -- Wrapper args
389 CoreExpr -> CoreExpr, -- Wrapper fn
390 CoreExpr -> CoreExpr, -- Worker fn
391 Type) -- Type of wrapper body
392
393 mkWWargs subst fun_ty demands
394 | null demands
395 = return ([], id, id, substTy subst fun_ty)
396
397 | (dmd:demands') <- demands
398 , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty
399 = do { uniq <- getUniqueM
400 ; let arg_ty' = substTy subst arg_ty
401 id = mk_wrap_arg uniq arg_ty' dmd
402 ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
403 <- mkWWargs subst fun_ty' demands'
404 ; return (id : wrap_args,
405 Lam id . wrap_fn_args,
406 apply_or_bind_then work_fn_args (varToCoreExpr id),
407 res_ty) }
408
409 | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty
410 = do { uniq <- getUniqueM
411 ; let (subst', tv') = cloneTyVarBndr subst tv uniq
412 -- See Note [Freshen WW arguments]
413 ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
414 <- mkWWargs subst' fun_ty' demands
415 ; return (tv' : wrap_args,
416 Lam tv' . wrap_fn_args,
417 apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')),
418 res_ty) }
419
420 | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty
421 -- The newtype case is for when the function has
422 -- a newtype after the arrow (rare)
423 --
424 -- It's also important when we have a function returning (say) a pair
425 -- wrapped in a newtype, at least if CPR analysis can look
426 -- through such newtypes, which it probably can since they are
427 -- simply coerces.
428
429 = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)
430 <- mkWWargs subst rep_ty demands
431 ; let co' = substCo subst co
432 ; return (wrap_args,
433 \e -> Cast (wrap_fn_args e) (mkSymCo co'),
434 \e -> work_fn_args (Cast e co'),
435 res_ty) }
436
437 | otherwise
438 = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand
439 return ([], id, id, substTy subst fun_ty) -- then there should be a function arrow
440 where
441 -- See Note [Join points and beta-redexes]
442 apply_or_bind_then k arg (Lam bndr body)
443 = mkCoreLet (NonRec bndr arg) (k body) -- Important that arg is fresh!
444 apply_or_bind_then k arg fun
445 = k $ mkCoreApp (text "mkWWargs") fun arg
446 applyToVars :: [Var] -> CoreExpr -> CoreExpr
447 applyToVars vars fn = mkVarApps fn vars
448
449 mk_wrap_arg :: Unique -> Type -> Demand -> Id
450 mk_wrap_arg uniq ty dmd
451 = mkSysLocalOrCoVar (fsLit "w") uniq ty
452 `setIdDemandInfo` dmd
453
454 {- Note [Freshen WW arguments]
455 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
456 Wen we do a worker/wrapper split, we must not in-scope names as the arguments
457 of the worker, else we'll get name capture. E.g.
458
459 -- y1 is in scope from further out
460 f x = ..y1..
461
462 If we accidentally choose y1 as a worker argument disaster results:
463
464 fww y1 y2 = let x = (y1,y2) in ...y1...
465
466 To avoid this:
467
468 * We use a fresh unique for both type-variable and term-variable binders
469 Originally we lacked this freshness for type variables, and that led
470 to the very obscure Trac #12562. (A type variable in the worker shadowed
471 an outer term-variable binding.)
472
473 * Because of this cloning we have to substitute in the type/kind of the
474 new binders. That's why we carry the TCvSubst through mkWWargs.
475
476 So we need a decent in-scope set, just in case that type/kind
477 itself has foralls. We get this from the free vars of the RHS of the
478 function since those are the only variables that might be captured.
479 It's a lazy thunk, which will only be poked if the type/kind has a forall.
480
481 Another tricky case was when f :: forall a. a -> forall a. a->a
482 (i.e. with shadowing), and then the worker used the same 'a' twice.
483
484 ************************************************************************
485 * *
486 \subsection{Strictness stuff}
487 * *
488 ************************************************************************
489 -}
490
491 mkWWstr :: DynFlags
492 -> FamInstEnvs
493 -> [Var] -- Wrapper args; have their demand info on them
494 -- *Includes type variables*
495 -> UniqSM (Bool, -- Is this useful
496 [Var], -- Worker args
497 CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call
498 -- and without its lambdas
499 -- This fn adds the unboxing
500
501 CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function,
502 -- and lacking its lambdas.
503 -- This fn does the reboxing
504 mkWWstr _ _ []
505 = return (False, [], nop_fn, nop_fn)
506
507 mkWWstr dflags fam_envs (arg : args) = do
508 (useful1, args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags fam_envs arg
509 (useful2, args2, wrap_fn2, work_fn2) <- mkWWstr dflags fam_envs args
510 return (useful1 || useful2, args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
511
512 {-
513 Note [Unpacking arguments with product and polymorphic demands]
514 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
515 The argument is unpacked in a case if it has a product type and has a
516 strict *and* used demand put on it. I.e., arguments, with demands such
517 as the following ones:
518
519 <S,U(U, L)>
520 <S(L,S),U>
521
522 will be unpacked, but
523
524 <S,U> or <B,U>
525
526 will not, because the pieces aren't used. This is quite important otherwise
527 we end up unpacking massive tuples passed to the bottoming function. Example:
528
529 f :: ((Int,Int) -> String) -> (Int,Int) -> a
530 f g pr = error (g pr)
531
532 main = print (f fst (1, error "no"))
533
534 Does 'main' print "error 1" or "error no"? We don't really want 'f'
535 to unbox its second argument. This actually happened in GHC's onwn
536 source code, in Packages.applyPackageFlag, which ended up un-boxing
537 the enormous DynFlags tuple, and being strict in the
538 as-yet-un-filled-in pkgState files.
539 -}
540
541 ----------------------
542 -- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)
543 -- * wrap_fn assumes wrap_arg is in scope,
544 -- brings into scope work_args (via cases)
545 -- * work_fn assumes work_args are in scope, a
546 -- brings into scope wrap_arg (via lets)
547 mkWWstr_one :: DynFlags -> FamInstEnvs -> Var
548 -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
549 mkWWstr_one dflags fam_envs arg
550 | isTyVar arg
551 = return (False, [arg], nop_fn, nop_fn)
552
553 -- See Note [Worker-wrapper for bottoming functions]
554 | isAbsDmd dmd
555 , Just work_fn <- mk_absent_let dflags arg
556 -- Absent case. We can't always handle absence for arbitrary
557 -- unlifted types, so we need to choose just the cases we can
558 --- (that's what mk_absent_let does)
559 = return (True, [], nop_fn, work_fn)
560
561 -- See Note [Worthy functions for Worker-Wrapper split]
562 | isSeqDmd dmd -- `seq` demand; evaluate in wrapper in the hope
563 -- of dropping seqs in the worker
564 = let arg_w_unf = arg `setIdUnfolding` evaldUnfolding
565 -- Tell the worker arg that it's sure to be evaluated
566 -- so that internal seqs can be dropped
567 in return (True, [arg_w_unf], mk_seq_case arg, nop_fn)
568 -- Pass the arg, anyway, even if it is in theory discarded
569 -- Consider
570 -- f x y = x `seq` y
571 -- x gets a (Eval (Poly Abs)) demand, but if we fail to pass it to the worker
572 -- we ABSOLUTELY MUST record that x is evaluated in the wrapper.
573 -- Something like:
574 -- f x y = x `seq` fw y
575 -- fw y = let x{Evald} = error "oops" in (x `seq` y)
576 -- If we don't pin on the "Evald" flag, the seq doesn't disappear, and
577 -- we end up evaluating the absent thunk.
578 -- But the Evald flag is pretty weird, and I worry that it might disappear
579 -- during simplification, so for now I've just nuked this whole case
580
581 | isStrictDmd dmd
582 , Just cs <- splitProdDmd_maybe dmd
583 -- See Note [Unpacking arguments with product and polymorphic demands]
584 , Just (data_con, inst_tys, inst_con_arg_tys, co)
585 <- deepSplitProductType_maybe fam_envs (idType arg)
586 , cs `equalLength` inst_con_arg_tys
587 -- See Note [mkWWstr and unsafeCoerce]
588 = do { (uniq1:uniqs) <- getUniquesM
589 ; let unpk_args = zipWith3 mk_ww_arg uniqs inst_con_arg_tys cs
590 unbox_fn = mkUnpackCase (Var arg) co uniq1
591 data_con unpk_args
592 arg_no_unf = zapStableUnfolding arg
593 -- See Note [Zap unfolding when beta-reducing]
594 -- in Simplify.hs; and see Trac #13890
595 rebox_fn = Let (NonRec arg_no_unf con_app)
596 con_app = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
597 ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs unpk_args
598 ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
599 -- Don't pass the arg, rebox instead
600
601 | otherwise -- Other cases
602 = return (False, [arg], nop_fn, nop_fn)
603
604 where
605 dmd = idDemandInfo arg
606 mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd
607
608 ----------------------
609 nop_fn :: CoreExpr -> CoreExpr
610 nop_fn body = body
611
612 {-
613 Note [mkWWstr and unsafeCoerce]
614 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
615 By using unsafeCoerce, it is possible to make the number of demands fail to
616 match the number of constructor arguments; this happened in Trac #8037.
617 If so, the worker/wrapper split doesn't work right and we get a Core Lint
618 bug. The fix here is simply to decline to do w/w if that happens.
619
620 Note [Record evaluated-ness in worker/wrapper]
621 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
622 Suppose we have
623
624 data T = MkT !Int Int
625
626 f :: T -> T
627 f x = e
628
629 and f's is strict, and has the CPR property. The we are going to generate
630 this w/w split
631
632 f x = case x of
633 MkT x1 x2 -> case $wf x1 x2 of
634 (# r1, r2 #) -> MkT r1 r2
635
636 $wfw x1 x2 = let x = MkT x1 x2 in
637 case e of
638 MkT r1 r2 -> (# r1, r2 #)
639
640 Note that
641
642 * In the worker $wf, inside 'e' we can be sure that x1 will be
643 evaluated (it came from unpacking the argument MkT. But that's no
644 immediately apparent in $wf
645
646 * In the wrapper 'f', which we'll inline at call sites, we can be sure
647 that 'r1' has been evaluated (because it came from unpacking the result
648 MkT. But that is not immediately apparent from the wrapper code.
649
650 Missing these facts isn't unsound, but it loses possible future
651 opportunities for optimisation.
652
653 Solution: use setCaseBndrEvald when creating
654 (A) The arg binders x1,x2 in mkWstr_one
655 See Trac #13077, test T13077
656 (B) The result binders r1,r2 in mkWWcpr_help
657 See Trace #13077, test T13077a
658 And Trac #13027 comment:20, item (4)
659 to record that the relevant binder is evaluated.
660
661
662 ************************************************************************
663 * *
664 Type scrutiny that is specific to demand analysis
665 * *
666 ************************************************************************
667
668 Note [Do not unpack class dictionaries]
669 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
670 If we have
671 f :: Ord a => [a] -> Int -> a
672 {-# INLINABLE f #-}
673 and we worker/wrapper f, we'll get a worker with an INLINABLE pragma
674 (see Note [Worker-wrapper for INLINABLE functions] in WorkWrap), which
675 can still be specialised by the type-class specialiser, something like
676 fw :: Ord a => [a] -> Int# -> a
677
678 BUT if f is strict in the Ord dictionary, we might unpack it, to get
679 fw :: (a->a->Bool) -> [a] -> Int# -> a
680 and the type-class specialiser can't specialise that. An example is
681 Trac #6056.
682
683 Moreover, dictionaries can have a lot of fields, so unpacking them can
684 increase closure sizes.
685
686 Conclusion: don't unpack dictionaries.
687 -}
688
689 deepSplitProductType_maybe
690 :: FamInstEnvs -> Type
691 -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
692 -- If deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)
693 -- then dc @ tys (args::arg_tys) :: rep_ty
694 -- co :: ty ~ rep_ty
695 -- Why do we return the strictness of the data-con arguments?
696 -- Answer: see Note [Record evaluated-ness in worker/wrapper]
697 deepSplitProductType_maybe fam_envs ty
698 | let (co, ty1) = topNormaliseType_maybe fam_envs ty
699 `orElse` (mkRepReflCo ty, ty)
700 , Just (tc, tc_args) <- splitTyConApp_maybe ty1
701 , Just con <- isDataProductTyCon_maybe tc
702 , not (isClassTyCon tc) -- See Note [Do not unpack class dictionaries]
703 , let arg_tys = dataConInstArgTys con tc_args
704 strict_marks = dataConRepStrictness con
705 = Just (con, tc_args, zipEqual "dspt" arg_tys strict_marks, co)
706 deepSplitProductType_maybe _ _ = Nothing
707
708 deepSplitCprType_maybe
709 :: FamInstEnvs -> ConTag -> Type
710 -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
711 -- If deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co)
712 -- then dc @ tys (args::arg_tys) :: rep_ty
713 -- co :: ty ~ rep_ty
714 -- Why do we return the strictness of the data-con arguments?
715 -- Answer: see Note [Record evaluated-ness in worker/wrapper]
716 deepSplitCprType_maybe fam_envs con_tag ty
717 | let (co, ty1) = topNormaliseType_maybe fam_envs ty
718 `orElse` (mkRepReflCo ty, ty)
719 , Just (tc, tc_args) <- splitTyConApp_maybe ty1
720 , isDataTyCon tc
721 , let cons = tyConDataCons tc
722 , cons `lengthAtLeast` con_tag -- This might not be true if we import the
723 -- type constructor via a .hs-bool file (#8743)
724 , let con = cons `getNth` (con_tag - fIRST_TAG)
725 arg_tys = dataConInstArgTys con tc_args
726 strict_marks = dataConRepStrictness con
727 = Just (con, tc_args, zipEqual "dsct" arg_tys strict_marks, co)
728 deepSplitCprType_maybe _ _ _ = Nothing
729
730 findTypeShape :: FamInstEnvs -> Type -> TypeShape
731 -- Uncover the arrow and product shape of a type
732 -- The data type TypeShape is defined in Demand
733 -- See Note [Trimming a demand to a type] in Demand
734 findTypeShape fam_envs ty
735 | Just (tc, tc_args) <- splitTyConApp_maybe ty
736 , Just con <- isDataProductTyCon_maybe tc
737 = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args)
738
739 | Just (_, res) <- splitFunTy_maybe ty
740 = TsFun (findTypeShape fam_envs res)
741
742 | Just (_, ty') <- splitForAllTy_maybe ty
743 = findTypeShape fam_envs ty'
744
745 | Just (_, ty') <- topNormaliseType_maybe fam_envs ty
746 = findTypeShape fam_envs ty'
747
748 | otherwise
749 = TsUnk
750
751 {-
752 ************************************************************************
753 * *
754 \subsection{CPR stuff}
755 * *
756 ************************************************************************
757
758
759 @mkWWcpr@ takes the worker/wrapper pair produced from the strictness
760 info and adds in the CPR transformation. The worker returns an
761 unboxed tuple containing non-CPR components. The wrapper takes this
762 tuple and re-produces the correct structured output.
763
764 The non-CPR results appear ordered in the unboxed tuple as if by a
765 left-to-right traversal of the result structure.
766 -}
767
768 mkWWcpr :: Bool
769 -> FamInstEnvs
770 -> Type -- function body type
771 -> DmdResult -- CPR analysis results
772 -> UniqSM (Bool, -- Is w/w'ing useful?
773 CoreExpr -> CoreExpr, -- New wrapper
774 CoreExpr -> CoreExpr, -- New worker
775 Type) -- Type of worker's body
776
777 mkWWcpr opt_CprAnal fam_envs body_ty res
778 -- CPR explicitly turned off (or in -O0)
779 | not opt_CprAnal = return (False, id, id, body_ty)
780 -- CPR is turned on by default for -O and O2
781 | otherwise
782 = case returnsCPR_maybe res of
783 Nothing -> return (False, id, id, body_ty) -- No CPR info
784 Just con_tag | Just stuff <- deepSplitCprType_maybe fam_envs con_tag body_ty
785 -> mkWWcpr_help stuff
786 | otherwise
787 -- See Note [non-algebraic or open body type warning]
788 -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
789 return (False, id, id, body_ty)
790
791 mkWWcpr_help :: (DataCon, [Type], [(Type,StrictnessMark)], Coercion)
792 -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
793
794 mkWWcpr_help (data_con, inst_tys, arg_tys, co)
795 | [arg1@(arg_ty1, _)] <- arg_tys
796 , isUnliftedType arg_ty1
797 -- Special case when there is a single result of unlifted type
798 --
799 -- Wrapper: case (..call worker..) of x -> C x
800 -- Worker: case ( ..body.. ) of C x -> x
801 = do { (work_uniq : arg_uniq : _) <- getUniquesM
802 ; let arg = mk_ww_local arg_uniq arg1
803 con_app = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co
804
805 ; return ( True
806 , \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]
807 , \ body -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg)
808 -- varToCoreExpr important here: arg can be a coercion
809 -- Lacking this caused Trac #10658
810 , arg_ty1 ) }
811
812 | otherwise -- The general case
813 -- Wrapper: case (..call worker..) of (# a, b #) -> C a b
814 -- Worker: case ( ...body... ) of C a b -> (# a, b #)
815 = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM
816 ; let wrap_wild = mk_ww_local wild_uniq (ubx_tup_ty,MarkedStrict)
817 args = zipWith mk_ww_local uniqs arg_tys
818 ubx_tup_ty = exprType ubx_tup_app
819 ubx_tup_app = mkCoreUbxTup (map fst arg_tys) (map varToCoreExpr args)
820 con_app = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co
821
822 ; return (True
823 , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app) [(DataAlt (tupleDataCon Unboxed (length arg_tys)), args, con_app)]
824 , \ body -> mkUnpackCase body co work_uniq data_con args ubx_tup_app
825 , ubx_tup_ty ) }
826
827 mkUnpackCase :: CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
828 -- (mkUnpackCase e co uniq Con args body)
829 -- returns
830 -- case e |> co of bndr { Con args -> body }
831
832 mkUnpackCase (Tick tickish e) co uniq con args body -- See Note [Profiling and unpacking]
833 = Tick tickish (mkUnpackCase e co uniq con args body)
834 mkUnpackCase scrut co uniq boxing_con unpk_args body
835 = Case casted_scrut bndr (exprType body)
836 [(DataAlt boxing_con, unpk_args, body)]
837 where
838 casted_scrut = scrut `mkCast` co
839 bndr = mk_ww_local uniq (exprType casted_scrut, MarkedStrict)
840
841 {-
842 Note [non-algebraic or open body type warning]
843 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
844
845 There are a few cases where the W/W transformation is told that something
846 returns a constructor, but the type at hand doesn't really match this. One
847 real-world example involves unsafeCoerce:
848 foo = IO a
849 foo = unsafeCoerce c_exit
850 foreign import ccall "c_exit" c_exit :: IO ()
851 Here CPR will tell you that `foo` returns a () constructor for sure, but trying
852 to create a worker/wrapper for type `a` obviously fails.
853 (This was a real example until ee8e792 in libraries/base.)
854
855 It does not seem feasible to avoid all such cases already in the analyser (and
856 after all, the analysis is not really wrong), so we simply do nothing here in
857 mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch
858 other cases where something went avoidably wrong.
859
860
861 Note [Profiling and unpacking]
862 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
863 If the original function looked like
864 f = \ x -> {-# SCC "foo" #-} E
865
866 then we want the CPR'd worker to look like
867 \ x -> {-# SCC "foo" #-} (case E of I# x -> x)
868 and definitely not
869 \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)
870
871 This transform doesn't move work or allocation
872 from one cost centre to another.
873
874 Later [SDM]: presumably this is because we want the simplifier to
875 eliminate the case, and the scc would get in the way? I'm ok with
876 including the case itself in the cost centre, since it is morally
877 part of the function (post transformation) anyway.
878
879
880 ************************************************************************
881 * *
882 \subsection{Utilities}
883 * *
884 ************************************************************************
885
886 Note [Absent errors]
887 ~~~~~~~~~~~~~~~~~~~~
888 We make a new binding for Ids that are marked absent, thus
889 let x = absentError "x :: Int"
890 The idea is that this binding will never be used; but if it
891 buggily is used we'll get a runtime error message.
892
893 Coping with absence for *unlifted* types is important; see, for
894 example, Trac #4306. For these we find a suitable literal,
895 using Literal.absentLiteralOf. We don't have literals for
896 every primitive type, so the function is partial.
897
898 [I did try the experiment of using an error thunk for unlifted
899 things too, relying on the simplifier to drop it as dead code,
900 by making absentError
901 (a) *not* be a bottoming Id,
902 (b) be "ok for speculation"
903 But that relies on the simplifier finding that it really
904 is dead code, which is fragile, and indeed failed when
905 profiling is on, which disables various optimisations. So
906 using a literal will do.]
907 -}
908
909 mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
910 mk_absent_let dflags arg
911 | not (isUnliftedType arg_ty)
912 = Just (Let (NonRec lifted_arg abs_rhs))
913 | Just tc <- tyConAppTyCon_maybe arg_ty
914 , Just lit <- absentLiteralOf tc
915 = Just (Let (NonRec arg (Lit lit)))
916 | arg_ty `eqType` voidPrimTy
917 = Just (Let (NonRec arg (Var voidPrimId)))
918 | otherwise
919 = WARN( True, text "No absent value for" <+> ppr arg_ty )
920 Nothing
921 where
922 arg_ty = idType arg
923 abs_rhs = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg
924 lifted_arg = arg `setIdStrictness` exnSig
925 -- Note in strictness signature that this is bottoming
926 -- (for the sake of the "empty case scrutinee not known to
927 -- diverge for sure lint" warning)
928 msg = showSDoc (gopt_set dflags Opt_SuppressUniques)
929 (ppr arg <+> ppr (idType arg))
930 -- We need to suppress uniques here because otherwise they'd
931 -- end up in the generated code as strings. This is bad for
932 -- determinism, because with different uniques the strings
933 -- will have different lengths and hence different costs for
934 -- the inliner leading to different inlining.
935 -- See also Note [Unique Determinism] in Unique
936
937 mk_seq_case :: Id -> CoreExpr -> CoreExpr
938 mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)]
939
940 sanitiseCaseBndr :: Id -> Id
941 -- The argument we are scrutinising has the right type to be
942 -- a case binder, so it's convenient to re-use it for that purpose.
943 -- But we *must* throw away all its IdInfo. In particular, the argument
944 -- will have demand info on it, and that demand info may be incorrect for
945 -- the case binder. e.g. case ww_arg of ww_arg { I# x -> ... }
946 -- Quite likely ww_arg isn't used in '...'. The case may get discarded
947 -- if the case binder says "I'm demanded". This happened in a situation
948 -- like (x+y) `seq` ....
949 sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo
950
951 mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id
952 -- The StrictnessMark comes form the data constructor and says
953 -- whether this field is strict
954 -- See Note [Record evaluated-ness in worker/wrapper]
955 mk_ww_local uniq (ty,str)
956 = setCaseBndrEvald str $
957 mkSysLocalOrCoVar (fsLit "ww") uniq ty