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