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