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