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