WwLib.lhs 20.1 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
11
12
13
{-# 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
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

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

16
#include "HsVersions.h"
17

18
import CoreSyn
19
import CoreUtils	( exprType )
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		( Demand(..), DmdResult(..), Demands(..) ) 
27
28
import MkCore		( mkRuntimeErrorApp, aBSENT_ERROR_ID )
import MkId		( realWorldPrimId, voidArgId, 
29
                          mkUnpackCase, mkProductBox )
30
import TysPrim		( realWorldStatePrimTy )
31
import TysWiredIn	( tupleCon )
32
import Type
33
import Coercion         ( mkSymCo, splitNewTypeRepCo_maybe )
batterseapower's avatar
batterseapower committed
34
import BasicTypes	( TupleSort(..) )
35
import Literal		( absentLiteralOf )
36
import UniqSupply
37
import Unique
38
import Util		( zipWithEqual )
sof's avatar
sof committed
39
import Outputable
40
import DynFlags
41
import FastString
42
43
44
45
46
47
48
49
50
51
\end{code}


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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
56
g = \/\ a -> \ x ys ->
57
58
59
60
61
62
63
64
65
66
	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
67
g = \/\ a -> \ x ys ->
68
	case x of
69
	  I# x# -> $wg a x# ys
70
71
72
	    -- call the worker; don't forget the type args!

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

Ian Lynagh's avatar
Ian Lynagh committed
75
$wg = \/\ a -> \ x# ys ->
76
77
78
79
80
81
82
83
84
	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:
85

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

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

93
94
95
96
97
98
99
100
101
102
103
\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.


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

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

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

122
123
124
125
126
127
128
129
130
131
132
-- 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

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

138
139
140
141
        -- 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

	; let (work_lam_args, work_call_args) = mkWorkerArgs work_args cpr_res_ty
142
	; return ([idDemandInfo v | v <- work_call_args, isId v],
143
                  wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var,
Simon Marlow's avatar
Simon Marlow committed
144
                  mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) }
145
146
147
148
149
150
151
        -- 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
152
\end{code}
153

154
155
156
157
158
159
160
161
162
163
164
165
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.

166
167
168
169
170
171
172
173
174
175
176

%************************************************************************
%*									*
\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.

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

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

\begin{code}
mkWorkerArgs :: [Var]
	     -> Type	-- Type of body
	     -> ([Var],	-- Lambda bound args
		 [Var])	-- Args at call site
mkWorkerArgs args res_ty
190
    | any isId args || not (isUnLiftedType res_ty)
191
192
193
    = (args, args)
    | otherwise	
    = (args ++ [voidArgId], args ++ [realWorldPrimId])
194
195
196
197
198
199
200
201
202
\end{code}


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

203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
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.
227
228

\begin{code}
229
230
-- mkWWargs just does eta expansion
-- is driven off the function type and arity.
231
232
-- It chomps bites off foralls, arrows, newtypes
-- and keeps repeating that until it's satisfied the supplied arity
233

234
235
236
237
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
238
	 -> UniqSM  ([Var],		-- Wrapper args
239
240
241
		     CoreExpr -> CoreExpr,	-- Wrapper fn
		     CoreExpr -> CoreExpr,	-- Worker fn
		     Type)			-- Type of wrapper body
242

243
244
mkWWargs subst fun_ty arg_info
  | Just (rep_ty, co) <- splitNewTypeRepCo_maybe fun_ty
245
246
247
248
249
250
251
252
253
254
   	-- 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.
255
256
257
258
259
260
261
	--
	-- 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,
262
	     	  \e -> Cast (wrap_fn_args e) (mkSymCo co),
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
     		  \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,
289
        	  work_fn_args . (`App` varToCoreExpr id),
290
        	  res_ty) }
291

292
  | otherwise
293
294
  = 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
295
296

applyToVars :: [Var] -> CoreExpr -> CoreExpr
297
298
applyToVars vars fn = mkVarApps fn vars

299
mk_wrap_arg :: Unique -> Type -> Demand -> Bool -> Id
300
mk_wrap_arg uniq ty dmd one_shot 
301
  = set_one_shot one_shot (setIdDemandInfo (mkSysLocal (fsLit "w") uniq ty) dmd)
302
303
304
  where
    set_one_shot True  id = setOneShotLambda id
    set_one_shot False id = id
305
\end{code}
306

307
308
Note [Freshen type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
309
Wen we do a worker/wrapper split, we must not use shadowed names,
310
else we'll get
311
312
313
314
   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.
315
316
317

That's why we carry the TvSubst through mkWWargs
	
318
319
320
321
322
323
324
%************************************************************************
%*									*
\subsection{Strictness stuff}
%*									*
%************************************************************************

\begin{code}
325
326
mkWWstr :: DynFlags
        -> [Var]				-- Wrapper args; have their demand info on them
327
						--  *Includes type variables*
328
        -> UniqSM ([Var],			-- Worker args
329
		   CoreExpr -> CoreExpr,	-- Wrapper body, lacking the worker call
330
						-- and without its lambdas 
331
						-- This fn adds the unboxing
332
				
333
		   CoreExpr -> CoreExpr)	-- Worker body, lacking the original body of the function,
334
335
						-- and lacking its lambdas.
						-- This fn does the reboxing
336
mkWWstr _ []
337
  = return ([], nop_fn, nop_fn)
338

339
340
341
mkWWstr dflags (arg : args) = do
    (args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags arg
    (args2, wrap_fn2, work_fn2) <- mkWWstr dflags args
342
    return (args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
343
344

----------------------
345
346
347
348
349
-- 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)
350
351
mkWWstr_one :: DynFlags -> Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one dflags arg
352
  | isTyVar arg
353
  = return ([arg],  nop_fn, nop_fn)
354
355

  | otherwise
356
  = case idDemandInfo arg of
357

358
359
360
	-- 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)
361
      Abs | Just work_fn <- mk_absent_let dflags arg
362
          -> return ([], nop_fn, work_fn)
363

364
365
	-- Unpack case
      Eval (Prod cs)
366
	| Just (_arg_tycon, _tycon_arg_tys, data_con, inst_con_arg_tys) 
367
		<- deepSplitProductType_maybe (idType arg)
368
369
370
371
372
373
374
	-> do uniqs <- getUniquesM
	      let
	        unpk_args      = zipWith mk_ww_local uniqs inst_con_arg_tys
	        unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs
	        unbox_fn       = mkUnpackCase (sanitiseCaseBndr arg) (Var arg) unpk_args data_con
	        rebox_fn       = Let (NonRec arg con_app) 
	        con_app        = mkProductBox unpk_args (idType arg)
375
	      (worker_args, wrap_fn, work_fn) <- mkWWstr dflags unpk_args_w_ds
376
	      return (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) 
377
378
379
380
381
	  		   -- Don't pass the arg, rebox instead

	-- `seq` demand; evaluate in wrapper in the hope
	-- of dropping seqs in the worker
      Eval (Poly Abs)
382
	-> let
383
		arg_w_unf = arg `setIdUnfolding` evaldUnfolding
384
385
386
		-- Tell the worker arg that it's sure to be evaluated
		-- so that internal seqs can be dropped
	   in
387
	   return ([arg_w_unf], mk_seq_case arg, nop_fn)
388
389
390
	  	-- Pass the arg, anyway, even if it is in theory discarded
		-- Consider
		--	f x y = x `seq` y
391
		-- x gets a (Eval (Poly Abs)) demand, but if we fail to pass it to the worker
392
393
394
395
396
397
		-- 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.
398
		-- But the Evald flag is pretty weird, and I worry that it might disappear
399
400
		-- during simplification, so for now I've just nuked this whole case
			
401
	-- Other cases
402
      _other_demand -> return ([arg], nop_fn, nop_fn)
403

404
405
406
407
  where
	-- 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
408
    set_worker_arg_info worker_arg demand = set_one_shot (setIdDemandInfo worker_arg demand)
409
410
411

    set_one_shot | isOneShotLambda arg = setOneShotLambda
		 | otherwise	       = \x -> x
412
413
414
415

----------------------
nop_fn :: CoreExpr -> CoreExpr
nop_fn body = body
416
\end{code}
417

418
419
420
421
422
423
424
425

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


426
427
428
429
430
431
432
433
434
435
@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}
436
mkWWcpr :: Type                              -- function body type
437
        -> DmdResult                         -- CPR analysis results
438
        -> UniqSM (CoreExpr -> CoreExpr,             -- New wrapper 
439
440
                   CoreExpr -> CoreExpr,	     -- New worker
		   Type)			-- Type of worker's body 
441

442
mkWWcpr body_ty RetCPR
443
444
445
    | not (isClosedAlgType body_ty)
    = WARN( True, 
            text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
446
      return (id, id, body_ty)
447

448
    | n_con_args == 1 && isUnLiftedType con_arg_ty1 = do
449
	-- Special case when there is a single result of unlifted type
450
451
452
	--
	-- Wrapper:	case (..call worker..) of x -> C x
	-- Worker:	case (   ..body..    ) of C x -> x
453
      (work_uniq : arg_uniq : _) <- getUniquesM
454
      let
455
456
	work_wild = mk_ww_local work_uniq body_ty
	arg	  = mk_ww_local arg_uniq  con_arg_ty1
457
	con_app   = mkProductBox [arg] body_ty
458
459

      return (\ wkr_call -> Case wkr_call (arg) (exprType con_app) [(DEFAULT, [], con_app)],
460
		\ body     -> workerCase (work_wild) body [arg] data_con (Var arg),
461
		con_arg_ty1)
462

463
    | otherwise = do	-- The general case
464
465
	-- Wrapper: case (..call worker..) of (# a, b #) -> C a b
	-- Worker:  case (   ...body...  ) of C a b -> (# a, b #)     
466
      uniqs <- getUniquesM
467
      let
468
        (wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys)
469
	arg_vars		       = varsToCoreExprs args
batterseapower's avatar
batterseapower committed
470
	ubx_tup_con		       = tupleCon UnboxedTuple n_con_args
471
	ubx_tup_ty		       = exprType ubx_tup_app
472
	ubx_tup_app		       = mkConApp ubx_tup_con (map Type con_arg_tys   ++ arg_vars)
473
        con_app			       = mkProductBox args body_ty
474
475

      return (\ wkr_call -> Case wkr_call (wrap_wild) (exprType con_app)  [(DataAlt ubx_tup_con, args, con_app)],
476
		\ body     -> workerCase (work_wild) body args data_con ubx_tup_app,
477
		ubx_tup_ty)
478
    where
479
      (_arg_tycon, _tycon_arg_tys, data_con, con_arg_tys) = deepSplitProductType "mkWWcpr" body_ty
480
481
      n_con_args  = length con_arg_tys
      con_arg_ty1 = head con_arg_tys
482

483
mkWWcpr body_ty _other		-- No CPR info
484
    = return (id, id, body_ty)
485

486
487
488
489
490
491
492
493
494
-- If the original function looked like
--	f = \ x -> _scc_ "foo" E
--
-- then we want the CPR'd worker to look like
--	\ x -> _scc_ "foo" (case E of I# x -> x)
-- and definitely not
--	\ x -> case (_scc_ "foo" E) of I# x -> x)
--
-- This transform doesn't move work or allocation
495
496
497
498
499
500
501
-- 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.

502
workerCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
503
504
505
506
workerCase bndr (Tick tickish e) args con body
   = Tick tickish (mkUnpackCase bndr e args con body)
workerCase bndr e args con body
   = mkUnpackCase bndr e args con body
507
\end{code}
508

509

510
511
512
513
514
515
%************************************************************************
%*									*
\subsection{Utilities}
%*									*
%************************************************************************

516
517
Note [Absent errors]
~~~~~~~~~~~~~~~~~~~~
518
519
520
521
522
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.

523
524
525
526
527
528
529
530
531
532
533
534
535
536
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.]
537

538
\begin{code}
539
540
mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
mk_absent_let dflags arg
541
542
  | not (isUnLiftedType arg_ty)
  = Just (Let (NonRec arg abs_rhs))
543
  | Just tc <- tyConAppTyCon_maybe arg_ty
544
545
  , Just lit <- absentLiteralOf tc
  = Just (Let (NonRec arg (Lit lit)))
546
  | arg_ty `eqType` realWorldStatePrimTy 
547
  = Just (Let (NonRec arg (Var realWorldPrimId)))
548
  | otherwise
549
  = WARN( True, ptext (sLit "No absent value for") <+> ppr arg_ty )
550
    Nothing
551
  where
552
553
    arg_ty  = idType arg
    abs_rhs = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg
554
    msg     = showSDocDebug dflags (ppr arg <+> ppr (idType arg))
555

556
mk_seq_case :: Id -> CoreExpr -> CoreExpr
557
mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)]
558

559
560
561
562
563
564
565
566
567
568
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
569

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