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