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