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