WwLib.lhs 24.4 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
%
Ian Lynagh's avatar
Ian Lynagh committed
4
\section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser}
5
6

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
7
8
9
10
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
11
--     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
Ian Lynagh's avatar
Ian Lynagh committed
12
13
-- for details

14
module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs, deepSplitProductType_maybe ) where
15

16
#include "HsVersions.h"
17

18
import CoreSyn
19
import CoreUtils	( exprType, mkCast )
20
import Id		( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo,
21
			  isOneShotLambda, setOneShotLambda, setIdUnfolding,
22
                          setIdInfo
23
			)
24
import IdInfo		( vanillaIdInfo )
25
import DataCon
26
import Demand        
27
import MkCore		( mkRuntimeErrorApp, aBSENT_ERROR_ID )
28
import MkId		( realWorldPrimId, voidArgId )
29
import TysPrim		( realWorldStatePrimTy )
30
import TysWiredIn	( tupleCon )
31
import Type
32
import Coercion hiding  ( substTy, substTyVarBndr )
batterseapower's avatar
batterseapower committed
33
import BasicTypes	( TupleSort(..) )
34
import Literal		( absentLiteralOf )
35
import TyCon
36
import UniqSupply
37
import Unique
38
import Maybes
39
import Util
sof's avatar
sof committed
40
import Outputable
41
import DynFlags
42
import FastString
43
44
45
46
47
48
49
50
51
52
\end{code}


%************************************************************************
%*									*
\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
%*									*
%************************************************************************

Here's an example.  The original function is:
53

54
55
56
\begin{verbatim}
g :: forall a . Int -> [a] -> a

Ian Lynagh's avatar
Ian Lynagh committed
57
g = \/\ a -> \ x ys ->
58
59
60
61
62
63
64
65
66
67
	case x of
	  0 -> head ys
	  _ -> head (tail ys)
\end{verbatim}

From this, we want to produce:
\begin{verbatim}
-- wrapper (an unfolding)
g :: forall a . Int -> [a] -> a

Ian Lynagh's avatar
Ian Lynagh committed
68
g = \/\ a -> \ x ys ->
69
	case x of
70
	  I# x# -> $wg a x# ys
71
72
73
	    -- call the worker; don't forget the type args!

-- worker
74
$wg :: forall a . Int# -> [a] -> a
75

Ian Lynagh's avatar
Ian Lynagh committed
76
$wg = \/\ a -> \ x# ys ->
77
78
79
80
81
82
83
84
85
	let
	    x = I# x#
	in
	    case x of		    -- note: body of g moved intact
	      0 -> head ys
	      _ -> head (tail ys)
\end{verbatim}

Something we have to be careful about:  Here's an example:
86

87
88
89
90
91
92
\begin{verbatim}
-- "f" strictness: U(P)U(P)
f (I# a) (I# b) = a +# b

g = f	-- "g" strictness same as "f"
\end{verbatim}
93

94
95
96
97
98
99
100
101
102
103
104
\tr{f} will get a worker all nice and friendly-like; that's good.
{\em But we don't want a worker for \tr{g}}, even though it has the
same strictness as \tr{f}.  Doing so could break laziness, at best.

Consequently, we insist that the number of strictness-info items is
exactly the same as the number of lambda-bound arguments.  (This is
probably slightly paranoid, but OK in practice.)  If it isn't the
same, we ``revise'' the strictness info, so that we won't propagate
the unusable strictness-info into the interfaces.


105
106
107
108
109
%************************************************************************
%*									*
\subsection{The worker wrapper core}
%*									*
%************************************************************************
110

Ian Lynagh's avatar
Ian Lynagh committed
111
@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.
112
113

\begin{code}
114
115
mkWwBodies :: DynFlags
       -> Type				-- Type of original function
116
	   -> [Demand]				-- Strictness of original function
117
	   -> DmdResult				-- Info about function result
118
	   -> [Bool]				-- One-shot-ness of the function
119
	   -> UniqSM ([Demand],			-- Demands for worker (value) args
120
121
122
		      Id -> CoreExpr,		-- Wrapper body, lacking only the worker Id
		      CoreExpr -> CoreExpr)	-- Worker body, lacking the original function rhs

123
124
125
126
127
128
129
130
131
132
133
-- wrap_fn_args E	= \x y -> E
-- work_fn_args E	= E x y

-- wrap_fn_str E 	= case x of { (a,b) -> 
--			  case a of { (a1,a2) ->
--			  E a1 a2 b y }}
-- work_fn_str E	= \a2 a2 b y ->
--			  let a = (a1,a2) in
--			  let x = (a,b) in
--			  E

134
mkWwBodies dflags fun_ty demands res_info one_shots
135
  = do	{ let arg_info = demands `zip` (one_shots ++ repeat False)
136
              all_one_shots = all snd arg_info
137
	; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs emptyTvSubst fun_ty arg_info
138
	; (work_args, wrap_fn_str,  work_fn_str) <- mkWWstr dflags wrap_args
139

140
141
142
        -- Do CPR w/w.  See Note [Always do CPR w/w]
	; (wrap_fn_cpr, work_fn_cpr,  cpr_res_ty) <- mkWWcpr res_ty res_info

143
	; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args all_one_shots cpr_res_ty
144
	; return ([idDemandInfo v | v <- work_call_args, isId v],
145
                  wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var,
Simon Marlow's avatar
Simon Marlow committed
146
                  mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) }
147
148
149
150
151
152
153
        -- We use an INLINE unconditionally, even if the wrapper turns out to be
        -- something trivial like
        --      fw = ...
        --      f = __inline__ (coerce T fw)
        -- The point is to propagate the coerce to f's call sites, so even though
        -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
        -- fw from being inlined into f's RHS
154
\end{code}
155

156
157
158
159
160
161
162
163
164
165
166
167
Note [Always do CPR w/w]
~~~~~~~~~~~~~~~~~~~~~~~~
At one time we refrained from doing CPR w/w for thunks, on the grounds that
we might duplicate work.  But that is already handled by the demand analyser,
which doesn't give the CPR proprety if w/w might waste work: see
Note [CPR for thunks] in DmdAnal.    

And if something *has* been given the CPR property and we don't w/w, it's
a disaster, because then the enclosing function might say it has the CPR
property, but now doesn't and there a cascade of disaster.  A good example
is Trac #5920.

168
169
170
171
172
173
174
175
176
177
178

%************************************************************************
%*									*
\subsection{Making wrapper args}
%*									*
%************************************************************************

During worker-wrapper stuff we may end up with an unlifted thing
which we want to let-bind without losing laziness.  So we
add a void argument.  E.g.

179
	f = /\a -> \x y z -> E::Int#	-- E does not mention x,y,z
180
181
182
183
184
185
186
==>
	fw = /\ a -> \void -> E
	f  = /\ a -> \x y z -> fw realworld

We use the state-token type which generates no code.

\begin{code}
187
mkWorkerArgs :: DynFlags -> [Var]
188
             -> Bool    -- Whether all arguments are one-shot
189
190
191
	     -> Type	-- Type of body
	     -> ([Var],	-- Lambda bound args
		 [Var])	-- Args at call site
192
193
mkWorkerArgs dflags args all_one_shot res_ty
    | any isId args || not needsAValueLambda
194
195
    = (args, args)
    | otherwise	
196
197
    = (args ++ [newArg], args ++ [realWorldPrimId])
    where
198
199
200
201
202
      needsAValueLambda =
        isUnLiftedType res_ty
        || not (gopt Opt_FunToThunk dflags)
           -- see Note [Protecting the last value argument]

203
204
205
206
      -- see Note [All One-Shot Arguments of a Worker]
      newArg = if all_one_shot 
               then setOneShotLambda voidArgId
               else voidArgId     
207
208
\end{code}

209
210
211
212
213
214
215
216
Note [Protecting the last value argument]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

If the user writes (\_ -> E), they might be intentionally disallowing
the sharing of E. Since absence analysis and worker-wrapper are keen
to remove such unused arguments, we add in a void argument to prevent
the function from becoming a thunk.

217
218
219
220
221
The user can avoid adding the void argument with the -ffun-to-thunk
flag. However, this can create sharing, which may be bad in two ways. 1) It can
create a space leak. 2) It can prevent inlining *under a lambda*. If w/w
removes the last argument from a function f, then f now looks like a thunk, and
so f can't be inlined *under a lambda*.
222

223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
Note [All One-Shot Arguments of a Worker]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Sometimes, derived joint-points are just lambda-lifted thunks, whose
only argument is of the unit type and is never used. This might
interfere with the absence analysis, basing on which results these
never-used arguments are eliminated in the worker. The additional
argument `all_one_shot` of `mkWorkerArgs` is to prevent this.

An example for this phenomenon is a `treejoin` program from the
`nofib` suite, which features the following joint points:

$j_s1l1 =
  \ _ ->
     case GHC.Prim.<=# 56320 y_aOy of _ {
        GHC.Types.False -> $j_s1kP GHC.Prim.realWorld#;
        GHC.Types.True ->  ... }
240
241
242
243
244
245
246

%************************************************************************
%*									*
\subsection{Coercion stuff}
%*									*
%************************************************************************

247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
We really want to "look through" coerces.
Reason: I've seen this situation:

	let f = coerce T (\s -> E)
	in \x -> case x of
	   	    p -> coerce T' f
		    q -> \s -> E2
	   	    r -> coerce T' f

If only we w/w'd f, we'd get
	let f = coerce T (\s -> fw s)
	    fw = \s -> E
	in ...

Now we'll inline f to get

	let fw = \s -> E
	in \x -> case x of
	   	    p -> fw
		    q -> \s -> E2
	   	    r -> fw

Now we'll see that fw has arity 1, and will arity expand
the \x to get what we want.
271
272

\begin{code}
273
274
-- mkWWargs just does eta expansion
-- is driven off the function type and arity.
275
276
-- It chomps bites off foralls, arrows, newtypes
-- and keeps repeating that until it's satisfied the supplied arity
277

278
279
280
281
mkWWargs :: TvSubst		-- Freshening substitution to apply to the type
				--   See Note [Freshen type variables]
	 -> Type		-- The type of the function
	 -> [(Demand,Bool)]	-- Demands and one-shot info for value arguments
282
	 -> UniqSM  ([Var],		-- Wrapper args
283
284
285
		     CoreExpr -> CoreExpr,	-- Wrapper fn
		     CoreExpr -> CoreExpr,	-- Worker fn
		     Type)			-- Type of wrapper body
286

287
288
mkWWargs subst fun_ty arg_info
  | Just (rep_ty, co) <- splitNewTypeRepCo_maybe fun_ty
289
290
291
292
293
294
295
296
297
298
   	-- The newtype case is for when the function has
	-- a recursive newtype after the arrow (rare)
	-- We check for arity >= 0 to avoid looping in the case
	-- of a function whose type is, in effect, infinite
	-- [Arity is driven by looking at the term, not just the type.]
	--
	-- It's also important when we have a function returning (say) a pair
	-- wrapped in a recursive newtype, at least if CPR analysis can look 
	-- through such newtypes, which it probably can since they are 
	-- simply coerces.
299
300
301
302
303
304
305
	--
	-- Note (Sept 08): This case applies even if demands is empty.
	--		   I'm not quite sure why; perhaps it makes it
	--		   easier for CPR
  = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)
	    <-  mkWWargs subst rep_ty arg_info
 	; return (wrap_args,
306
	     	  \e -> Cast (wrap_fn_args e) (mkSymCo co),
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
     		  \e -> work_fn_args (Cast e co),
     		  res_ty) } 

  | null arg_info
  = return ([], id, id, substTy subst fun_ty)

  | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty
  = do 	{ let (subst', tv') = substTyVarBndr subst tv
		-- This substTyVarBndr clones the type variable when necy
		-- See Note [Freshen type variables]
  	; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
	     <- mkWWargs subst' fun_ty' arg_info
	; return (tv' : wrap_args,
        	  Lam tv' . wrap_fn_args,
        	  work_fn_args . (`App` Type (mkTyVarTy tv')),
        	  res_ty) }

  | ((dmd,one_shot):arg_info') <- arg_info
  , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty
  = do	{ uniq <- getUniqueM
	; let arg_ty' = substTy subst arg_ty
	      id = mk_wrap_arg uniq arg_ty' dmd one_shot
	; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
	      <- mkWWargs subst fun_ty' arg_info'
	; return (id : wrap_args,
	          Lam id . wrap_fn_args,
333
        	  work_fn_args . (`App` varToCoreExpr id),
334
        	  res_ty) }
335

336
  | otherwise
337
338
  = WARN( True, ppr fun_ty )			-- Should not happen: if there is a demand
    return ([], id, id, substTy subst fun_ty) 	-- then there should be a function arrow
339
340

applyToVars :: [Var] -> CoreExpr -> CoreExpr
341
342
applyToVars vars fn = mkVarApps fn vars

343
mk_wrap_arg :: Unique -> Type -> Demand -> Bool -> Id
344
mk_wrap_arg uniq ty dmd one_shot 
345
  = set_one_shot one_shot (setIdDemandInfo (mkSysLocal (fsLit "w") uniq ty) dmd)
346
347
348
  where
    set_one_shot True  id = setOneShotLambda id
    set_one_shot False id = id
349
\end{code}
350

351
352
Note [Freshen type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
353
Wen we do a worker/wrapper split, we must not use shadowed names,
354
else we'll get
355
356
357
358
   f = /\ a /\a. fw a a
which is obviously wrong.  Type variables can can in principle shadow,
within a type (e.g. forall a. a -> forall a. a->a).  But type
variables *are* mentioned in <blah>, so we must substitute.
359
360
361

That's why we carry the TvSubst through mkWWargs
	
362
363
364
365
366
367
368
%************************************************************************
%*									*
\subsection{Strictness stuff}
%*									*
%************************************************************************

\begin{code}
369
370
mkWWstr :: DynFlags
        -> [Var]				-- Wrapper args; have their demand info on them
371
						--  *Includes type variables*
372
        -> UniqSM ([Var],			-- Worker args
373
		   CoreExpr -> CoreExpr,	-- Wrapper body, lacking the worker call
374
						-- and without its lambdas 
375
						-- This fn adds the unboxing
376
				
377
		   CoreExpr -> CoreExpr)	-- Worker body, lacking the original body of the function,
378
379
						-- and lacking its lambdas.
						-- This fn does the reboxing
380
mkWWstr _ []
381
  = return ([], nop_fn, nop_fn)
382

383
384
385
mkWWstr dflags (arg : args) = do
    (args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags arg
    (args2, wrap_fn2, work_fn2) <- mkWWstr dflags args
386
    return (args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
387

388
389
390
391
392
\end{code}

Note [Unpacking arguments with product and polymorphic demands]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The argument is unpacked in a case if it has a product type and has a
Simon Peyton Jones's avatar
Simon Peyton Jones committed
393
strict *and* used demand put on it. I.e., arguments, with demands such
394
395
as the following ones:

Simon Peyton Jones's avatar
Simon Peyton Jones committed
396
397
   <S,U(U, L)>
   <S(L,S),U>
398

Simon Peyton Jones's avatar
Simon Peyton Jones committed
399
will be unpacked, but
400

Simon Peyton Jones's avatar
Simon Peyton Jones committed
401
402
403
404
405
406
407
408
409
410
411
412
413
414
   <S,U> or <B,U>

will not, because the pieces aren't used. This is quite important otherwise
we end up unpacking massive tuples passed to the bottoming function. Example:

 	f :: ((Int,Int) -> String) -> (Int,Int) -> a
 	f g pr = error (g pr)

 	main = print (f fst (1, error "no"))

Does 'main' print "error 1" or "error no"?  We don't really want 'f'
to unbox its second argument.  This actually happened in GHC's onwn
source code, in Packages.applyPackageFlag, which ended up un-boxing
the enormous DynFlags tuple, and being strict in the
Simon Peyton Jones's avatar
Simon Peyton Jones committed
415
as-yet-un-filled-in pkgState files.
416
417

\begin{code}
418
----------------------
419
420
421
422
423
-- mkWWstr_one wrap_arg = (work_args, wrap_fn, work_fn)
--   *  wrap_fn assumes wrap_arg is in scope,
--	  brings into scope work_args (via cases)
--   * work_fn assumes work_args are in scope, a
--	  brings into scope wrap_arg (via lets)
424
425
mkWWstr_one :: DynFlags -> Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one dflags arg
426
  | isTyVar arg
427
  = return ([arg],  nop_fn, nop_fn)
428

429
430
431
432
433
434
435
436
437
438
439
440
441
  | isAbsDmd dmd
  , Just work_fn <- mk_absent_let dflags arg
     -- Absent case.  We can't always handle absence for arbitrary
     -- unlifted types, so we need to choose just the cases we can
     --- (that's what mk_absent_let does)
  = return ([], nop_fn, work_fn)
      
  | isSeqDmd dmd  -- `seq` demand; evaluate in wrapper in the hope
                  -- of dropping seqs in the worker
  = let arg_w_unf = arg `setIdUnfolding` evaldUnfolding
	  -- Tell the worker arg that it's sure to be evaluated
          -- so that internal seqs can be dropped
    in return ([arg_w_unf], mk_seq_case arg, nop_fn)
442
443
444
	  	-- Pass the arg, anyway, even if it is in theory discarded
		-- Consider
		--	f x y = x `seq` y
445
		-- x gets a (Eval (Poly Abs)) demand, but if we fail to pass it to the worker
446
447
448
449
450
451
		-- we ABSOLUTELY MUST record that x is evaluated in the wrapper.
		-- Something like:
		--	f x y = x `seq` fw y
		--	fw y = let x{Evald} = error "oops" in (x `seq` y)
		-- If we don't pin on the "Evald" flag, the seq doesn't disappear, and
		-- we end up evaluating the absent thunk.
452
		-- But the Evald flag is pretty weird, and I worry that it might disappear
453
		-- during simplification, so for now I've just nuked this whole case
454
455

  | isStrictDmd dmd
456
  , Just cs <- splitProdDmd_maybe dmd
Simon Peyton Jones's avatar
Simon Peyton Jones committed
457
      -- See Note [Unpacking arguments with product and polymorphic demands]
458
  , Just (data_con, inst_tys, inst_con_arg_tys, co) 
459
             <- deepSplitProductType_maybe (idType arg)
460
461
  =  do { (uniq1:uniqs) <- getUniquesM
	; let   unpk_args      = zipWith mk_ww_local uniqs inst_con_arg_tys
462
	        unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs
463
464
	        unbox_fn       = mkUnpackCase (Var arg `mkCast` co) uniq1
                                              data_con unpk_args
465
	        rebox_fn       = Let (NonRec arg con_app) 
466
	        con_app        = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
467
468
469
	 ; (worker_args, wrap_fn, work_fn) <- mkWWstr dflags unpk_args_w_ds
	 ; return (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
	  		   -- Don't pass the arg, rebox instead
470
			
471
472
  | otherwise	-- Other cases
  = return ([arg], nop_fn, nop_fn)
473

474
  where
475
    dmd = idDemandInfo arg
476
477
478
	-- If the wrapper argument is a one-shot lambda, then
	-- so should (all) the corresponding worker arguments be
	-- This bites when we do w/w on a case join point
479
    set_worker_arg_info worker_arg demand = set_one_shot (setIdDemandInfo worker_arg demand)
480
481
482

    set_one_shot | isOneShotLambda arg = setOneShotLambda
		 | otherwise	       = \x -> x
483
484
485
486

----------------------
nop_fn :: CoreExpr -> CoreExpr
nop_fn body = body
487
\end{code}
488
489

\begin{code}
490
491
492
deepSplitProductType_maybe :: Type -> Maybe (DataCon, [Type], [Type], Coercion)
-- If    deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)
-- then  dc @ tys (args::arg_tys)  |> co :: ty
493
deepSplitProductType_maybe ty
494
  | let (ty1, co) = topNormaliseNewType ty `orElse` (ty, mkReflCo Representational ty)
495
496
497
498
499
500
501
  , Just (tc, tc_args) <- splitTyConApp_maybe ty1
  , Just con <- isDataProductTyCon_maybe tc
  = Just (con, tc_args, dataConInstArgTys con tc_args, co)
deepSplitProductType_maybe _ = Nothing

deepSplitCprType_maybe :: ConTag -> Type -> Maybe (DataCon, [Type], [Type], Coercion)
deepSplitCprType_maybe con_tag ty
502
  | let (ty1, co) = topNormaliseNewType ty `orElse` (ty, mkReflCo Representational ty)
503
504
505
506
507
508
  , Just (tc, tc_args) <- splitTyConApp_maybe ty1
  , isDataTyCon tc
  , let cons = tyConDataCons tc
        con = ASSERT( cons `lengthAtLeast` con_tag ) cons !! (con_tag - fIRST_TAG)
  = Just (con, tc_args, dataConInstArgTys con tc_args, co)
deepSplitCprType_maybe _ _ = Nothing
509
\end{code}
510

511
512
513
514
515
516
517
518

%************************************************************************
%*									*
\subsection{CPR stuff}
%*									*
%************************************************************************


519
520
521
522
523
524
525
526
527
528
@mkWWcpr@ takes the worker/wrapper pair produced from the strictness
info and adds in the CPR transformation.  The worker returns an
unboxed tuple containing non-CPR components.  The wrapper takes this
tuple and re-produces the correct structured output.

The non-CPR results appear ordered in the unboxed tuple as if by a
left-to-right traversal of the result structure.


\begin{code}
529
mkWWcpr :: Type                              -- function body type
530
        -> DmdResult                         -- CPR analysis results
531
        -> UniqSM (CoreExpr -> CoreExpr,             -- New wrapper 
532
533
                   CoreExpr -> CoreExpr,	     -- New worker
		   Type)			-- Type of worker's body 
534

535
mkWWcpr body_ty res
536
537
538
539
540
541
542
543
544
545
546
547
548
549
  = case returnsCPR_maybe res of
       Nothing      -> return (id, id, body_ty)  -- No CPR info
       Just con_tag | Just stuff <- deepSplitCprType_maybe con_tag body_ty
                    -> mkWWcpr_help stuff
                    |  otherwise
                    -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
                       return (id, id, body_ty)
          
mkWWcpr_help :: (DataCon, [Type], [Type], Coercion)
             -> UniqSM (CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)

mkWWcpr_help (data_con, inst_tys, arg_tys, co)
  | [arg_ty1] <- arg_tys
  , isUnLiftedType arg_ty1
550
	-- Special case when there is a single result of unlifted type
551
552
553
	--
	-- Wrapper:	case (..call worker..) of x -> C x
	-- Worker:	case (   ..body..    ) of C x -> x
554
555
556
  = do { (work_uniq : arg_uniq : _) <- getUniquesM
       ; let arg       = mk_ww_local arg_uniq  arg_ty1
	     con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` co
557

558
559
560
       ; return ( \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]
                , \ body     -> mkUnpackCase body work_uniq data_con [arg] (Var arg)
                , arg_ty1 ) }
561

562
  | otherwise 	-- The general case
563
564
	-- Wrapper: case (..call worker..) of (# a, b #) -> C a b
	-- Worker:  case (   ...body...  ) of C a b -> (# a, b #)     
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
  = do { (work_uniq : uniqs) <- getUniquesM
       ; let (wrap_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : arg_tys)
	     ubx_tup_con  = tupleCon UnboxedTuple (length arg_tys)
	     ubx_tup_ty	  = exprType ubx_tup_app
	     ubx_tup_app  = mkConApp2 ubx_tup_con arg_tys args
             con_app	  = mkConApp2 data_con inst_tys args `mkCast` co

       ; return ( \ wkr_call -> Case wkr_call wrap_wild (exprType con_app)  [(DataAlt ubx_tup_con, args, con_app)]
		, \ body     -> mkUnpackCase body work_uniq data_con args ubx_tup_app
		, ubx_tup_ty ) }

mkUnpackCase ::  CoreExpr -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
-- (mkUnpackCase e bndr Con args body)
--      returns
-- case e of bndr { Con args -> body }
-- 
-- the type of the bndr passed in is irrelevent

mkUnpackCase (Tick tickish e) uniq con args body   -- See Note [Profiling and unpacking]
  = Tick tickish (mkUnpackCase e uniq con args body)
mkUnpackCase scrut uniq boxing_con unpk_args body
  = Case scrut 
         (mk_ww_local uniq (exprType scrut)) (exprType body) 
         [(DataAlt boxing_con, unpk_args, body)]
589
\end{code}
590

591
592
593
Note [Profiling and unpacking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
602
603
604
605
606
607
608

This transform doesn't move work or allocation
from one cost centre to another.

Later [SDM]: presumably this is because we want the simplifier to
eliminate the case, and the scc would get in the way?  I'm ok with
including the case itself in the cost centre, since it is morally
part of the function (post transformation) anyway.

609

610
611
612
613
614
615
%************************************************************************
%*									*
\subsection{Utilities}
%*									*
%************************************************************************

616
617
Note [Absent errors]
~~~~~~~~~~~~~~~~~~~~
618
619
620
621
622
We make a new binding for Ids that are marked absent, thus
   let x = absentError "x :: Int"
The idea is that this binding will never be used; but if it 
buggily is used we'll get a runtime error message.

623
624
625
626
627
628
629
630
631
632
633
634
635
636
Coping with absence for *unlifted* types is important; see, for
example, Trac #4306.  For these we find a suitable literal,
using Literal.absentLiteralOf.  We don't have literals for
every primitive type, so the function is partial.

    [I did try the experiment of using an error thunk for unlifted
    things too, relying on the simplifier to drop it as dead code,
    by making absentError 
      (a) *not* be a bottoming Id, 
      (b) be "ok for speculation"
    But that relies on the simplifier finding that it really
    is dead code, which is fragile, and indeed failed when 
    profiling is on, which disables various optimisations.  So
    using a literal will do.]
637

638
\begin{code}
639
640
mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
mk_absent_let dflags arg
641
642
  | not (isUnLiftedType arg_ty)
  = Just (Let (NonRec arg abs_rhs))
643
  | Just tc <- tyConAppTyCon_maybe arg_ty
644
645
  , Just lit <- absentLiteralOf tc
  = 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
653
    arg_ty  = idType arg
    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
660
661
662
663
664
665
666
667
668
sanitiseCaseBndr :: Id -> Id
-- The argument we are scrutinising has the right type to be
-- a case binder, so it's convenient to re-use it for that purpose.
-- But we *must* throw away all its IdInfo.  In particular, the argument
-- will have demand info on it, and that demand info may be incorrect for
-- the case binder.  e.g.  	case ww_arg of ww_arg { I# x -> ... }
-- Quite likely ww_arg isn't used in '...'.  The case may get discarded
-- if the case binder says "I'm demanded".  This happened in a situation 
-- like		(x+y) `seq` ....
sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo
669

670
mk_ww_local :: Unique -> Type -> Id
Ian Lynagh's avatar
Ian Lynagh committed
671
mk_ww_local uniq ty = mkSysLocal (fsLit "ww") uniq ty
672
\end{code}