CorePrep.lhs 25.7 KB
Newer Older
1 2 3 4 5 6
%
% (c) The University of Glasgow, 1994-2000
%
\section{Core pass to saturate constructors and PrimOps}

\begin{code}
7 8
module CorePrep (
      corePrepPgm, corePrepExpr
9 10 11 12
  ) where

#include "HsVersions.h"

13
import CoreUtils( exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
14 15
import CoreFVs	( exprFreeVars )
import CoreLint	( endPass )
16
import CoreSyn
17
import Type	( Type, applyTy, splitFunTy_maybe, 
18
		  isUnLiftedType, isUnboxedTupleType, seqType )
19
import TcType	( TyThing( AnId ) )
20
import NewDemand  ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
21
import Var 	( Var, Id, setVarUnique )
22
import VarSet
23
import VarEnv
24
import Id	( mkSysLocal, idType, idNewDemandInfo, idArity,
25
		  isFCallId, isGlobalId, isImplicitId,
26
		  isLocalId, hasNoBinding, idNewStrictness, 
27
		  idUnfolding, isDataConWorkId_maybe
28
		)
29
import HscTypes ( ModGuts(..), ModGuts, typeEnvElts )
30
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
31 32
		    RecFlag(..), isNonRec
		  )
33 34
import UniqSupply
import Maybes
35
import OrdList
36 37
import ErrUtils
import CmdLineOpts
sof's avatar
sof committed
38
import Util       ( listLengthCmp )
39 40 41
import Outputable
\end{code}

42 43 44
-- ---------------------------------------------------------------------------
-- Overview
-- ---------------------------------------------------------------------------
45

46
The goal of this pass is to prepare for code generation.
47

48
1.  Saturate constructor and primop applications.
49

50
2.  Convert to A-normal form:
51

52 53 54
    * Use case for strict arguments:
	f E ==> case E of x -> f x
    	(where f is strict)
55

56 57 58
    * Use let for non-trivial lazy arguments
	f E ==> let x = E in f x
	(were f is lazy and x is non-trivial)
59

60 61 62
3.  Similarly, convert any unboxed lets into cases.
    [I'm experimenting with leaving 'ok-for-speculation' 
     rhss in let-form right up to this point.]
63

64
4.  Ensure that lambdas only occur as the RHS of a binding
65 66
    (The code generator can't deal with anything else.)

67
5.  [Not any more; nuked Jun 2002] Do the seq/par munging.
68

69 70 71 72 73 74 75 76 77
6.  Clone all local Ids.
    This means that all such Ids are unique, rather than the 
    weaker guarantee of no clashes which the simplifier provides.
    And that is what the code generator needs.

    We don't clone TyVars. The code gen doesn't need that, 
    and doing so would be tiresome because then we'd need
    to substitute in types.

78 79 80 81

7.  Give each dynamic CCall occurrence a fresh unique; this is
    rather like the cloning step above.

82 83 84 85 86 87 88
8.  Inject bindings for the "implicit" Ids:
	* Constructor wrappers
	* Constructor workers
	* Record selectors
    We want curried definitions for all of these in case they
    aren't inlined by some caller.
	
89 90 91
This is all done modulo type applications and abstractions, so that
when type erasure is done for conversion to STG, we don't end up with
any trivial or useless bindings.
92

93
  
94 95 96 97 98 99

-- -----------------------------------------------------------------------------
-- Top level stuff
-- -----------------------------------------------------------------------------

\begin{code}
100 101
corePrepPgm :: DynFlags -> ModGuts -> IO ModGuts
corePrepPgm dflags mod_impl
102
  = do	showPass dflags "CorePrep"
103
	us <- mkSplitUniqSupply 's'
104

105
	let implicit_binds = mkImplicitBinds (mg_types mod_impl)
106 107
		-- NB: we must feed mkImplicitBinds through corePrep too
		-- so that they are suitably cloned and eta-expanded
108

109
	    binds_out = initUs_ us (
110 111
			  corePrepTopBinds (mg_binds mod_impl)	`thenUs` \ floats1 ->
			  corePrepTopBinds implicit_binds	`thenUs` \ floats2 ->
112 113 114 115
			  returnUs (deFloatTop (floats1 `appOL` floats2))
			)
	    
        endPass dflags "CorePrep" Opt_D_dump_prep binds_out
116
	return (mod_impl { mg_binds = binds_out })
117

118 119 120
corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
corePrepExpr dflags expr
  = do showPass dflags "CorePrep"
121
       us <- mkSplitUniqSupply 's'
122
       let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr)
123
       dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" 
124
		     (ppr new_expr)
125
       return new_expr
126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157
\end{code}

-- -----------------------------------------------------------------------------
-- Implicit bindings
-- -----------------------------------------------------------------------------

Create any necessary "implicit" bindings (data constructors etc).
Namely:
	* Constructor workers
	* Constructor wrappers
	* Data type record selectors
	* Class op selectors

In the latter three cases, the Id contains the unfolding to use for
the binding.  In the case of data con workers we create the rather 
strange (non-recursive!) binding

	$wC = \x y -> $wC x y

i.e. a curried constructor that allocates.  This means that we can
treat the worker for a constructor like any other function in the rest
of the compiler.  The point here is that CoreToStg will generate a
StgConApp for the RHS, rather than a call to the worker (which would
give a loop).  As Lennart says: the ice is thin here, but it works.

Hmm.  Should we create bindings for dictionary constructors?  They are
always fully applied, and the bindings are just there to support
partial applications. But it's easier to let them through.

\begin{code}
mkImplicitBinds type_env
  = [ NonRec id (get_unfolding id)
158 159 160 161
    | AnId id <- typeEnvElts type_env, isImplicitId id ]
	-- The type environment already contains all the implicit Ids, 
	-- so we just filter them out
	--
162 163 164
	-- The etaExpand is so that the manifest arity of the
	-- binding matches its claimed arity, which is an 
	-- invariant of top level bindings going into the code gen
165

166
get_unfolding id 	-- See notes above
167 168 169
  | Just data_con <- isDataConWorkId_maybe id = Var id	-- The ice is thin here, but it works
							-- CorePrep will eta-expand it
  | otherwise			     	      = unfoldingTemplate (idUnfolding id)
170 171 172 173
\end{code}
	

\begin{code}
174 175 176 177
-- ---------------------------------------------------------------------------
-- Dealing with bindings
-- ---------------------------------------------------------------------------

178
data FloatingBind = FloatLet CoreBind
179 180
		  | FloatCase Id CoreExpr Bool
			-- The bool indicates "ok-for-speculation"
181

182 183 184 185
instance Outputable FloatingBind where
  ppr (FloatLet bind)        = text "FloatLet" <+> ppr bind
  ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs

186 187
type CloneEnv = IdEnv Id	-- Clone local Ids

188 189 190 191 192 193 194 195
deFloatTop :: OrdList FloatingBind -> [CoreBind]
-- For top level only; we don't expect any FloatCases
deFloatTop floats
  = foldrOL get [] floats
  where
    get (FloatLet b) bs = b:bs
    get b	     bs = pprPanic "corePrepPgm" (ppr b)

196 197
allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
allLazy top_lvl is_rec floats 
198 199
  = foldrOL check True floats
  where
200 201
    unboxed_ok = isNotTopLevel top_lvl && isNonRec is_rec

202
    check (FloatLet _)  	      y = y
203
    check (FloatCase _ _ ok_for_spec) y = unboxed_ok && ok_for_spec && y
204 205
	-- The ok-for-speculation flag says that it's safe to
	-- float this Case out of a let, and thereby do it more eagerly
206 207
	-- We need the top-level flag because it's never ok to float
	-- an unboxed binding to the top level
208 209 210 211

-- ---------------------------------------------------------------------------
-- 			Bindings
-- ---------------------------------------------------------------------------
212

213 214 215 216 217 218 219 220
corePrepTopBinds :: [CoreBind] -> UniqSM (OrdList FloatingBind)
corePrepTopBinds binds 
  = go emptyVarEnv binds
  where
    go env []		  = returnUs nilOL
    go env (bind : binds) = corePrepTopBind env bind	`thenUs` \ (env', bind') ->
			    go env' binds		`thenUs` \ binds' ->
			    returnUs (bind' `appOL` binds')
221

222 223 224 225 226 227
-- NB: we do need to float out of top-level bindings
-- Consider	x = length [True,False]
-- We want to get
--		s1 = False : []
--		s2 = True  : s1
--		x  = length s2
228 229

-- We return a *list* of bindings, because we may start with
230 231 232 233 234 235
--	x* = f (g y)
-- where x is demanded, in which case we want to finish with
--	a = g y
--	x* = f a
-- And then x will actually end up case-bound

236
--------------------------------
237 238
corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
corePrepTopBind env (NonRec bndr rhs) 
239 240
  = cloneBndr env bndr					`thenUs` \ (env', bndr') ->
    corePrepRhs TopLevel NonRecursive env (bndr, rhs)	`thenUs` \ (floats, rhs') -> 
241 242 243 244
    returnUs (env', floats `snocOL` FloatLet (NonRec bndr' rhs'))

corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs

245
--------------------------------
246 247
corePrepBind ::  CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
	-- This one is used for *local* bindings
248
corePrepBind env (NonRec bndr rhs)
249 250
  = etaExpandRhs bndr rhs				`thenUs` \ rhs1 ->
    corePrepExprFloat env rhs1				`thenUs` \ (floats, rhs2) ->
251
    cloneBndr env bndr					`thenUs` \ (env', bndr') ->
252
    mkLocalNonRec bndr' (bdrDem bndr') floats rhs2	`thenUs` \ floats' ->
253
    returnUs (env', floats')
254

255 256 257 258 259 260 261 262
corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs

--------------------------------
corePrepRecPairs :: TopLevelFlag -> CloneEnv
		 -> [(Id,CoreExpr)]	-- Recursive bindings
		 -> UniqSM (CloneEnv, OrdList FloatingBind)
-- Used for all recursive bindings, top level and otherwise
corePrepRecPairs lvl env pairs
263 264 265 266 267 268 269 270 271 272
  = cloneBndrs env (map fst pairs)				`thenUs` \ (env', bndrs') ->
    mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs	`thenUs` \ (floats_s, rhss') ->
    returnUs (env', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' rhss'))))
  where
	-- Flatten all the floats, and the currrent
	-- group into a single giant Rec
    flatten floats bndrs rhss = foldrOL get (bndrs `zip` rhss) floats

    get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
    get (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2
273 274

--------------------------------
275 276
corePrepRhs :: TopLevelFlag -> RecFlag
	    -> CloneEnv -> (Id, CoreExpr)
277 278
	    -> UniqSM (OrdList FloatingBind, CoreExpr)
-- Used for top-level bindings, and local recursive bindings
279
corePrepRhs top_lvl is_rec env (bndr, rhs)
280 281
  = etaExpandRhs bndr rhs	`thenUs` \ rhs' ->
    corePrepExprFloat env rhs'	`thenUs` \ floats_w_rhs ->
282
    floatRhs top_lvl is_rec bndr floats_w_rhs
283

284 285 286 287 288 289

-- ---------------------------------------------------------------------------
-- Making arguments atomic (function args & constructor args)
-- ---------------------------------------------------------------------------

-- This is where we arrange that a non-trivial argument is let-bound
290 291 292 293
corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
	   -> UniqSM (OrdList FloatingBind, CoreArg)
corePrepArg env arg dem
  = corePrepExprFloat env arg		`thenUs` \ (floats, arg') ->
294
    if exprIsTrivial arg'
295
    then returnUs (floats, arg')
296 297
    else newVar (exprType arg')			`thenUs` \ v ->
	 mkLocalNonRec v dem floats arg'	`thenUs` \ floats' -> 
298
	 returnUs (floats', Var v)
299

300
-- version that doesn't consider an scc annotation to be trivial.
301
exprIsTrivial (Var v)		       = True
302 303 304 305 306 307 308 309
exprIsTrivial (Type _)	      	       = True
exprIsTrivial (Lit lit)       	       = True
exprIsTrivial (App e arg)     	       = isTypeArg arg && exprIsTrivial e
exprIsTrivial (Note (SCC _) e) 	       = False
exprIsTrivial (Note _ e)      	       = exprIsTrivial e
exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
exprIsTrivial other	      	       = False

310 311 312 313
-- ---------------------------------------------------------------------------
-- Dealing with expressions
-- ---------------------------------------------------------------------------

314 315 316
corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
corePrepAnExpr env expr
  = corePrepExprFloat env expr		`thenUs` \ (floats, expr) ->
317 318 319
    mkBinds floats expr


320
corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
321 322 323 324 325 326 327 328
-- If
--	e  ===>  (bs, e')
-- then	
--	e = let bs in e'	(semantically, that is!)
--
-- For example
--	f (g x)	  ===>   ([v = g x], f v)

329 330 331 332
corePrepExprFloat env (Var v)
  = fiddleCCall v				`thenUs` \ v1 ->
    let v2 = lookupVarEnv env v1 `orElse` v1 in
    maybeSaturate v2 (Var v2) 0 (idType v2) 	`thenUs` \ app ->
333
    returnUs (nilOL, app)
334

335 336
corePrepExprFloat env expr@(Type _)
  = returnUs (nilOL, expr)
337

338 339
corePrepExprFloat env expr@(Lit lit)
  = returnUs (nilOL, expr)
340

341
corePrepExprFloat env (Let bind body)
342 343
  = corePrepBind env bind		`thenUs` \ (env', new_binds) ->
    corePrepExprFloat env' body		`thenUs` \ (floats, new_body) ->
344
    returnUs (new_binds `appOL` floats, new_body)
345

346 347
corePrepExprFloat env (Note n@(SCC _) expr)
  = corePrepAnExpr env expr		`thenUs` \ expr1 ->
348 349
    deLamFloat expr1			`thenUs` \ (floats, expr2) ->
    returnUs (floats, Note n expr2)
350

351 352 353
corePrepExprFloat env (Note other_note expr)
  = corePrepExprFloat env expr		`thenUs` \ (floats, expr') ->
    returnUs (floats, Note other_note expr')
354

355
corePrepExprFloat env expr@(Lam _ _)
356 357 358
  = cloneBndrs env bndrs		`thenUs` \ (env', bndrs') ->
    corePrepAnExpr env' body		`thenUs` \ body' ->
    returnUs (nilOL, mkLams bndrs' body')
359 360
  where
    (bndrs,body) = collectBinders expr
361

362
corePrepExprFloat env (Case scrut bndr alts)
363 364
  = corePrepExprFloat env scrut		`thenUs` \ (floats1, scrut1) ->
    deLamFloat scrut1			`thenUs` \ (floats2, scrut2) ->
365 366
    cloneBndr env bndr			`thenUs` \ (env', bndr') ->
    mapUs (sat_alt env') alts		`thenUs` \ alts' ->
367
    returnUs (floats1 `appOL` floats2 , Case scrut2 bndr' alts')
368
  where
369 370 371 372 373 374 375 376
    sat_alt env (con, bs, rhs)
	  = cloneBndrs env bs		`thenUs` \ (env', bs') ->
	    corePrepAnExpr env' rhs  	`thenUs` \ rhs1 ->
	    deLam rhs1			`thenUs` \ rhs2 ->
	    returnUs (con, bs', rhs2)

corePrepExprFloat env expr@(App _ _)
  = collect_args expr 0  `thenUs` \ (app, (head,depth), ty, floats, ss) ->
377 378 379 380
    ASSERT(null ss)	-- make sure we used all the strictness info

	-- Now deal with the function
    case head of
381 382 383 384
      Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' -> 
	    	   returnUs (floats, app')

      _other    -> returnUs (floats, app)
385 386 387

  where

388 389
    -- Deconstruct and rebuild the application, floating any non-atomic
    -- arguments to the outside.  We collect the type of the expression,
390
    -- the head of the application, and the number of actual value arguments,
391 392 393
    -- all of which are used to possibly saturate this application if it
    -- has a constructor or primop at the head.

394 395
    collect_args
	:: CoreExpr
396 397 398
	-> Int				  -- current app depth
	-> UniqSM (CoreExpr,		  -- the rebuilt expression
		   (CoreExpr,Int),	  -- the head of the application,
399
				          -- and no. of args it was applied to
400 401 402
		   Type,		  -- type of the whole expr
		   OrdList FloatingBind,  -- any floats we pulled out
		   [Demand])		  -- remaining argument demands
403 404 405 406 407 408 409 410 411

    collect_args (App fun arg@(Type arg_ty)) depth
        = collect_args fun depth   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
	  returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)

    collect_args (App fun arg) depth
        = collect_args fun (depth+1)   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
	  let
	      (ss1, ss_rest)   = case ss of
412 413
				   (ss1:ss_rest) -> (ss1,     ss_rest)
				   []	         -> (lazyDmd, [])
414
              (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
415 416
                                 splitFunTy_maybe fun_ty
	  in
417
	  corePrepArg env arg (mkDemTy ss1 arg_ty)	`thenUs` \ (fs, arg') ->
418
	  returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
419 420

    collect_args (Var v) depth
421 422 423
	= fiddleCCall v `thenUs` \ v1 ->
	  let v2 = lookupVarEnv env v1 `orElse` v1 in
	  returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
424
	where
425 426
	  stricts = case idNewStrictness v of
			StrictSig (DmdType _ demands _)
sof's avatar
sof committed
427 428 429
			    | listLengthCmp demands depth /= GT -> demands
			            -- length demands <= depth
			    | otherwise                         -> []
430 431 432
		-- If depth < length demands, then we have too few args to 
		-- satisfy strictness  info so we have to  ignore all the 
		-- strictness info, e.g. + (error "urk")
433 434 435
		-- Here, we can't evaluate the arg strictly, because this 
		-- partial application might be seq'd

436 437 438 439 440 441 442 443 444 445 446

    collect_args (Note (Coerce ty1 ty2) fun) depth
        = collect_args fun depth  `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
	  returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)

    collect_args (Note note fun) depth
	| ignore_note note 
        = collect_args fun depth   `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
	  returnUs (Note note fun', hd, fun_ty, floats, ss)

	-- non-variable fun, better let-bind it
447 448
	-- ToDo: perhaps we can case-bind rather than let-bind this closure,
	-- since it is sure to be evaluated.
449
    collect_args fun depth
450
	= corePrepExprFloat env fun			`thenUs` \ (fun_floats, fun') ->
451
	  newVar ty			 		`thenUs` \ fn_id ->
452
          mkLocalNonRec fn_id onceDem fun_floats fun'	`thenUs` \ floats ->
453 454 455
	  returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
        where
	  ty = exprType fun
456

457 458 459 460 461
    ignore_note	(CoreNote _) = True 
    ignore_note	InlineCall   = True
    ignore_note	InlineMe     = True
    ignore_note	_other       = False
	-- We don't ignore SCCs, since they require some code generation
462 463 464 465 466

------------------------------------------------------------------------------
-- Building the saturated syntax
-- ---------------------------------------------------------------------------

467 468
-- maybeSaturate deals with saturating primops and constructors
-- The type is the type of the entire application
469 470
maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
maybeSaturate fn expr n_args ty
471
  | hasNoBinding fn = saturate_it
472
  | otherwise       = returnUs expr
473 474 475
  where
    fn_arity	 = idArity fn
    excess_arity = fn_arity - n_args
476 477
    saturate_it  = getUniquesUs 		`thenUs` \ us ->
		   returnUs (etaExpand excess_arity us expr ty)
478

479
-- ---------------------------------------------------------------------------
480
-- Precipitating the floating bindings
481
-- ---------------------------------------------------------------------------
482

483 484
floatRhs :: TopLevelFlag -> RecFlag
	 -> Id
485 486 487
	 -> (OrdList FloatingBind, CoreExpr)	-- Rhs: let binds in body
	 -> UniqSM (OrdList FloatingBind, 	-- Floats out of this bind
		    CoreExpr)			-- Final Rhs
488

489
floatRhs top_lvl is_rec bndr (floats, rhs)
490
  | isTopLevel top_lvl || exprIsValue rhs,	-- Float to expose value or 
491
    allLazy top_lvl is_rec floats 		-- at top level
492
  = 	-- Why the test for allLazy? 
493 494 495
	--	v = f (x `divInt#` y)
	-- we don't want to float the case, even if f has arity 2,
	-- because floating the case would make it evaluated too early
496 497
	--
	-- Finally, eta-expand the RHS, for the benefit of the code gen
498
    returnUs (floats, rhs)
499
    
500 501 502
  | otherwise
	-- Don't float; the RHS isn't a value
  = mkBinds floats rhs		`thenUs` \ rhs' ->
503
    returnUs (nilOL, rhs')
504 505 506 507 508 509 510

-- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
mkLocalNonRec :: Id  -> RhsDemand 			-- Lhs: id with demand
	      -> OrdList FloatingBind -> CoreExpr	-- Rhs: let binds in body
	      -> UniqSM (OrdList FloatingBind)

mkLocalNonRec bndr dem floats rhs
511 512
  | isUnLiftedType (idType bndr)
	-- If this is an unlifted binding, we always make a case for it.
513
  = ASSERT( not (isUnboxedTupleType (idType bndr)) )
514 515 516 517 518 519 520 521
    let
	float = FloatCase bndr rhs (exprOkForSpeculation rhs)
    in
    returnUs (floats `snocOL` float)

  | isStrict dem 
	-- It's a strict let so we definitely float all the bindings
 = let		-- Don't make a case for a value binding,
522 523 524 525 526 527
		-- even if it's strict.  Otherwise we get
		-- 	case (\x -> e) of ...!
	float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
	      | otherwise	= FloatCase bndr rhs (exprOkForSpeculation rhs)
    in
    returnUs (floats `snocOL` float)
528

529
  | otherwise
530
  = floatRhs NotTopLevel NonRecursive bndr (floats, rhs)	`thenUs` \ (floats', rhs') ->
531
    returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
532

533 534
  where
    bndr_ty	 = idType bndr
535

536

537 538 539 540
mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
mkBinds binds body 
  | isNilOL binds = returnUs body
  | otherwise	  = deLam body		`thenUs` \ body' ->
541
		    returnUs (foldrOL mk_bind body' binds)
542
  where
543
    mk_bind (FloatCase bndr rhs _) body = Case rhs bndr [(DEFAULT, [], body)]
544
    mk_bind (FloatLet bind)        body = Let bind body
545

546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565
etaExpandRhs bndr rhs
  = 	-- Eta expand to match the arity claimed by the binder
	-- Remember, after CorePrep we must not change arity
	--
	-- Eta expansion might not have happened already, 
	-- because it is done by the simplifier only when 
	-- there at least one lambda already.
	-- 
	-- NB1:we could refrain when the RHS is trivial (which can happen
	--     for exported things).  This would reduce the amount of code
	--     generated (a little) and make things a little words for
	--     code compiled without -O.  The case in point is data constructor
	--     wrappers.
	--
	-- NB2: we have to be careful that the result of etaExpand doesn't
	--    invalidate any of the assumptions that CorePrep is attempting
	--    to establish.  One possible cause is eta expanding inside of
	--    an SCC note - we're now careful in etaExpand to make sure the
	--    SCC is pushed inside any new lambdas that are generated.
	--
566 567 568 569 570 571 572 573 574 575
	-- NB3: It's important to do eta expansion, and *then* ANF-ising
	--		f = /\a -> g (h 3)	-- h has arity 2
	-- If we ANF first we get
	--		f = /\a -> let s = h 3 in g s
	-- and now eta expansion gives
	-- 		f = /\a -> \ y -> (let s = h 3 in g s) y
	-- which is horrible.
	-- Eta expanding first gives
	--		f = /\a -> \y -> let s = h 3 in g s y
	--
576
    getUniquesUs		`thenUs` \ us ->
577 578 579 580 581 582 583
    returnUs (etaExpand arity us rhs (idType bndr))
  where
	-- For a GlobalId, take the Arity from the Id.
	-- It was set in CoreTidy and must not change
	-- For all others, just expand at will
    arity | isGlobalId bndr = idArity bndr
	  | otherwise	    = exprArity rhs
584

585
-- ---------------------------------------------------------------------------
586 587
-- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
-- We arrange that they only show up as the RHS of a let(rec)
588 589
-- ---------------------------------------------------------------------------

590 591 592 593 594 595 596
deLam :: CoreExpr -> UniqSM CoreExpr
deLam expr = 
  deLamFloat expr   `thenUs` \ (floats, expr) ->
  mkBinds floats expr


deLamFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
597
-- Remove top level lambdas by let-bindinig
598

599
deLamFloat (Note n expr)
600 601
  =	-- You can get things like
	-- 	case e of { p -> coerce t (\s -> ...) }
602 603
    deLamFloat expr	`thenUs` \ (floats, expr') ->
    returnUs (floats, Note n expr')
604

605 606
deLamFloat expr 
  | null bndrs = returnUs (nilOL, expr)
607 608
  | otherwise 
  = case tryEta bndrs body of
609
      Just no_lam_result -> returnUs (nilOL, no_lam_result)
610
      Nothing	         -> newVar (exprType expr)	`thenUs` \ fn ->
611 612
			    returnUs (unitOL (FloatLet (NonRec fn expr)), 
				      Var fn)
613
  where
614 615
    (bndrs,body) = collectBinders expr

616 617 618 619 620
-- Why try eta reduction?  Hasn't the simplifier already done eta?
-- But the simplifier only eta reduces if that leaves something
-- trivial (like f, or f Int).  But for deLam it would be enough to
-- get to a partial application, like (map f).

621 622 623 624 625 626
tryEta bndrs expr@(App _ _)
  | ok_to_eta_reduce f &&
    n_remaining >= 0 &&
    and (zipWith ok bndrs last_args) &&
    not (any (`elemVarSet` fvs_remaining) bndrs)
  = Just remaining_expr
627
  where
628 629 630 631 632
    (f, args) = collectArgs expr
    remaining_expr = mkApps f remaining_args
    fvs_remaining = exprFreeVars remaining_expr
    (remaining_args, last_args) = splitAt n_remaining args
    n_remaining = length args - length bndrs
633

634
    ok bndr (Var arg) = bndr == arg
635
    ok bndr other     = False
636

637
	  -- we can't eta reduce something which must be saturated.
638
    ok_to_eta_reduce (Var f) = not (hasNoBinding f)
639
    ok_to_eta_reduce _       = False --safe. ToDo: generalise
640 641 642 643 644 645 646 647

tryEta bndrs (Let bind@(NonRec b r) body)
  | not (any (`elemVarSet` fvs) bndrs)
  = case tryEta bndrs body of
	Just e -> Just (Let bind e)
	Nothing -> Nothing
  where
    fvs = exprFreeVars r
648

649
tryEta bndrs _ = Nothing
650 651 652
\end{code}


653 654 655 656
-- -----------------------------------------------------------------------------
-- Demands
-- -----------------------------------------------------------------------------

657
\begin{code}
658
data RhsDemand
659
     = RhsDemand { isStrict :: Bool,  -- True => used at least once
660 661 662 663
                   isOnceDem   :: Bool   -- True => used at most once
                 }

mkDem :: Demand -> Bool -> RhsDemand
664
mkDem strict once = RhsDemand (isStrictDmd strict) once
665 666

mkDemTy :: Demand -> Type -> RhsDemand
667 668
mkDemTy strict ty = RhsDemand (isStrictDmd strict) 
			      False {- For now -}
669 670

bdrDem :: Id -> RhsDemand
671 672
bdrDem id = mkDem (idNewDemandInfo id)
		  False {- For now -}
673

674 675 676 677
-- safeDem :: RhsDemand
-- safeDem = RhsDemand False False  -- always safe to use this

onceDem :: RhsDemand
678 679
onceDem = RhsDemand False True   -- used at most once
\end{code}
680 681


682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699


%************************************************************************
%*									*
\subsection{Cloning}
%*									*
%************************************************************************

\begin{code}
------------------------------------------------------------------------------
-- Cloning binders
-- ---------------------------------------------------------------------------

cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
cloneBndrs env bs = mapAccumLUs cloneBndr env bs

cloneBndr  :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
cloneBndr env bndr
700
  | isLocalId bndr
701 702 703 704 705 706
  = getUniqueUs   `thenUs` \ uniq ->
    let
	bndr' = setVarUnique bndr uniq
    in
    returnUs (extendVarEnv env bndr bndr', bndr')

707 708 709 710 711 712
  | otherwise	-- Top level things, which we don't want
		-- to clone, have become GlobalIds by now
		-- And we don't clone tyvars
  = returnUs (env, bndr)
  

713 714 715 716 717 718 719
------------------------------------------------------------------------------
-- Cloning ccall Ids; each must have a unique name,
-- to give the code generator a handle to hang it on
-- ---------------------------------------------------------------------------

fiddleCCall :: Id -> UniqSM Id
fiddleCCall id 
720 721 722
  | isFCallId id = getUniqueUs   	`thenUs` \ uniq ->
		   returnUs (id `setVarUnique` uniq)
  | otherwise    = returnUs id
723 724 725 726 727

------------------------------------------------------------------------------
-- Generating new binders
-- ---------------------------------------------------------------------------

728 729
newVar :: Type -> UniqSM Id
newVar ty
730 731
 = seqType ty			`seq`
   getUniqueUs	 		`thenUs` \ uniq ->
732
   returnUs (mkSysLocal FSLIT("sat") uniq ty)
733
\end{code}