CoreTidy.lhs 24.4 KB
Newer Older
1 2 3 4 5 6 7
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section{Tidying up Core}

\begin{code}
module CoreTidy (
8
	tidyCorePgm, tidyExpr, tidyCoreExpr, tidyIdRules,
9 10 11 12 13
	tidyBndr, tidyBndrs
    ) where

#include "HsVersions.h"

14
import CmdLineOpts	( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
15
import CoreSyn
16
import CoreUnfold	( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
17
import CoreFVs		( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars )
18
import PprCore		( pprIdRules )
19
import CoreLint		( showPass, endPass )
20
import CoreUtils	( exprArity )
21 22
import VarEnv
import VarSet
23
import Var		( Id, Var )
24 25
import Id		( idType, idInfo, idName, idCoreRules, 
			  isExportedId, idUnique, mkVanillaGlobal, isLocalId, 
26
			  isImplicitId, mkUserLocal, setIdInfo
27
			) 
28
import IdInfo		{- loads of stuff -}
29
import NewDemand	( isBottomingSig, topSig )
30
import BasicTypes	( isNeverActive )
31 32
import Name		( getOccName, nameOccName, mkInternalName, mkExternalName, 
		  	  localiseName, isExternalName, nameSrcLoc
33
			)
34
import NameEnv		( filterNameEnv )
35
import OccName		( TidyOccEnv, initTidyOccEnv, tidyOccName )
36
import Type		( tidyTopType, tidyType, tidyTyVarBndr )
37
import Module		( Module, moduleName )
38 39
import HscTypes		( PersistentCompilerState( pcs_PRS ), 
			  PersistentRenamerState( prsOrig ),
40
			  NameSupply( nsNames, nsUniqs ),
41
			  TypeEnv, extendTypeEnvList, typeEnvIds,
42
			  ModDetails(..), TyThing(..)
43 44
			)
import FiniteMap	( lookupFM, addToFM )
45
import Maybes		( orElse )
46
import ErrUtils		( showPass, dumpIfSet_core )
47
import SrcLoc		( noSrcLoc )
48
import UniqFM		( mapUFM )
49
import UniqSupply	( splitUniqSupply, uniqFromSupply )
50
import List		( partition )
51
import Util		( mapAccumL )
52
import Maybe		( isJust )
53
import Outputable
54 55 56 57 58
\end{code}



%************************************************************************
59 60 61
%*				 					*
\subsection{What goes on}
%*				 					* 
62 63
%************************************************************************

64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
[SLPJ: 19 Nov 00]

The plan is this.  

Step 1: Figure out external Ids
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
First we figure out which Ids are "external" Ids.  An
"external" Id is one that is visible from outside the compilation
unit.  These are
	a) the user exported ones
	b) ones mentioned in the unfoldings, workers, 
	   or rules of externally-visible ones 
This exercise takes a sweep of the bindings bottom to top.  Actually,
in Step 2 we're also going to need to know which Ids should be
exported with their unfoldings, so we produce not an IdSet but an
IdEnv Bool


Step 2: Tidy the program
~~~~~~~~~~~~~~~~~~~~~~~~
84
Next we traverse the bindings top to bottom.  For each *top-level*
85 86
binder

87 88 89 90 91 92 93 94 95 96 97 98 99
 1. Make it into a GlobalId

 2. Give it a system-wide Unique.
    [Even non-exported things need system-wide Uniques because the
    byte-code generator builds a single Name->BCO symbol table.]

    We use the NameSupply kept in the PersistentRenamerState as the
    source of such system-wide uniques.

    For external Ids, use the original-name cache in the NameSupply 
    to ensure that the unique assigned is the same as the Id had 
    in any previous compilation run.
  
100 101
 3. If it's an external Id, make it have a global Name, otherwise
    make it have a local Name.
102 103 104
    This is used by the code generator to decide whether
    to make the label externally visible

105
 4. Give external Ids a "tidy" occurrence name.  This means
106 107 108
    we can print them in interface files without confusing 
    "x" (unique 5) with "x" (unique 10).
  
109
 5. Give it its UTTERLY FINAL IdInfo; in ptic, 
110 111
	* Its IdDetails becomes VanillaGlobal, reflecting the fact that
	  from now on we regard it as a global, not local, Id
112

113
  	* its unfolding, if it should have one
114 115 116 117 118
	
	* its arity, computed from the number of visible lambdas

	* its CAF info, computed from what is free in its RHS

119 120 121 122
		
Finally, substitute these new top-level binders consistently
throughout, including in unfoldings.  We also tidy binders in
RHSs, so that they print nicely in interfaces.
123 124

\begin{code}
125
tidyCorePgm :: DynFlags -> Module
126
	    -> PersistentCompilerState
127 128 129 130 131 132 133 134
	    -> CgInfoEnv		-- Information from the back end,
					-- to be splatted into the IdInfo
	    -> ModDetails
	    -> IO (PersistentCompilerState, ModDetails)

tidyCorePgm dflags mod pcs cg_info_env
	    (ModDetails { md_types = env_tc, md_insts = insts_tc, 
			  md_binds = binds_in, md_rules = orphans_in })
135 136
  = do	{ showPass dflags "Tidy Core"

137 138
	; let ext_ids   = findExternalSet   binds_in orphans_in
	; let ext_rules = findExternalRules binds_in orphans_in ext_ids
139 140 141 142 143
		-- findExternalRules filters ext_rules to avoid binders that 
		-- aren't externally visible; but the externally-visible binders 
		-- are computed (by findExternalSet) assuming that all orphan
		-- rules are exported.  So in fact we may export more than we
		-- need.  (It's a sort of mutual recursion.)
144

145 146 147 148 149 150 151 152 153 154 155 156
	-- We also make sure to avoid any exported binders.  Consider
	--	f{-u1-} = 1	-- Local decl
	--	...
	--	f{-u2-} = 2	-- Exported decl
	--
	-- The second exported decl must 'get' the name 'f', so we
	-- have to put 'f' in the avoids list before we get to the first
	-- decl.  tidyTopId then does a no-op on exported binders.
	; let   prs	      = pcs_PRS pcs
		orig_ns       = prsOrig prs

		init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv)
157 158
		avoids	      = [getOccName name | bndr <- typeEnvIds env_tc,
						   let name = idName bndr,
159
						   isExternalName name]
160 161 162 163 164 165
		-- In computing our "avoids" list, we must include
		--	all implicit Ids
		--	all things with global names (assigned once and for
		--					all by the renamer)
		-- since their names are "taken".
		-- The type environment is a convenient source of such things.
166 167

	; let ((orig_ns', occ_env, subst_env), tidy_binds) 
168
	       		= mapAccumL (tidyTopBind mod ext_ids cg_info_env) 
169
				    init_tidy_env binds_in
170

171
	; let tidy_rules = tidyIdCoreRules (occ_env,subst_env) ext_rules
172

173
	; let prs' = prs { prsOrig = orig_ns' }
174 175
	      pcs' = pcs { pcs_PRS = prs' }

176
	; let final_ids  = [ id 
177
			   | bind <- tidy_binds
178
			   , id <- bindersOf bind
179
			   , isExternalName (idName id)]
180 181 182 183 184 185 186

		-- Dfuns are local Ids that might have
		-- changed their unique during tidying
	; let lookup_dfun_id id = lookupVarEnv subst_env id `orElse` 
				  pprPanic "lookup_dfun_id" (ppr id)


187 188
	; let tidy_type_env = mkFinalTypeEnv env_tc final_ids
	      tidy_dfun_ids = map lookup_dfun_id insts_tc
189

190 191 192 193
	; let tidy_details = ModDetails { md_types = tidy_type_env,
					  md_rules = tidy_rules,
					  md_insts = tidy_dfun_ids,
					  md_binds = tidy_binds }
194 195

   	; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
196 197
	; dumpIfSet_core dflags Opt_D_dump_simpl
		"Tidy Core Rules"
198
		(pprIdRules tidy_rules)
199

200
	; return (pcs', tidy_details)
201
	}
202 203

tidyCoreExpr :: CoreExpr -> IO CoreExpr
204
tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr)
205 206 207
\end{code}


208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237
%************************************************************************
%*				 					*
\subsection{Write a new interface file}
%*				 					*
%************************************************************************

\begin{code}
mkFinalTypeEnv :: TypeEnv	-- From typechecker
	       -> [Id]		-- Final Ids
	       -> TypeEnv

mkFinalTypeEnv type_env final_ids
  = extendTypeEnvList (filterNameEnv keep_it type_env)
		      (map AnId final_ids)
  where
	-- The competed type environment is gotten from
	-- 	a) keeping the types and classes
	--	b) removing all Ids, 
	--	c) adding Ids with correct IdInfo, including unfoldings,
	--		gotten from the bindings
	-- From (c) we keep only those Ids with Global names;
	--	    the CoreTidy pass makes sure these are all and only
	--	    the externally-accessible ones
	-- This truncates the type environment to include only the 
	-- exported Ids and things needed from them, which saves space
	--
	-- However, we do keep things like constructors, which should not appear 
	-- in interface files, because they are needed by importing modules when
	-- using the compilation manager

238 239 240
	-- We keep implicit Ids, because they won't appear 
	-- in the bindings from which final_ids are derived!
    keep_it (AnId id) = isImplicitId id	-- Remove all Ids except implicit ones
241 242 243 244
    keep_it other     = True		-- Keep all TyCons and Classes
\end{code}

\begin{code}
245 246 247 248
findExternalRules :: [CoreBind]
		  -> [IdCoreRule] -- Orphan rules
	          -> IdEnv a	  -- Ids that are exported, so we need their rules
	          -> [IdCoreRule]
249 250 251
  -- The complete rules are gotten by combining
  --	a) the orphan rules
  --	b) rules embedded in the top-level Ids
252
findExternalRules binds orphan_rules ext_ids
253 254
  | opt_OmitInterfacePragmas = []
  | otherwise
255
  = filter needed_rule (orphan_rules ++ local_rules)
256
  where
257
    local_rules  = [ rule
258 259
 		   | id <- bindersOfBinds binds,
		     id `elemVarEnv` ext_ids,
260 261
		     rule <- idCoreRules id
		   ]
262 263 264 265 266 267 268 269 270 271 272 273
    needed_rule (id, rule)
	=  not (isBuiltinRule rule)
	 	-- We can't print builtin rules in interface files
		-- Since they are built in, an importing module
		-- will have access to them anyway

	&& not (any internal_id (varSetElems (ruleLhsFreeIds rule)))
		-- Don't export a rule whose LHS mentions an Id that
		-- is completely internal (i.e. not visible to an
		-- importing module)

    internal_id id = isLocalId id && not (id `elemVarEnv` ext_ids)
274
\end{code}
275

276 277 278 279 280 281 282 283
%************************************************************************
%*				 					*
\subsection{Step 1: finding externals}
%*				 					* 
%************************************************************************

\begin{code}
findExternalSet :: [CoreBind] -> [IdCoreRule]
284 285
		-> IdEnv Bool	-- In domain => external
				-- Range = True <=> show unfolding
286 287
	-- Step 1 from the notes above
findExternalSet binds orphan_rules
288
  = foldr find init_needed binds
289 290
  where
    orphan_rule_ids :: IdSet
291
    orphan_rule_ids = unionVarSets [ ruleRhsFreeVars rule 
292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 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 333 334 335
				   | (_, rule) <- orphan_rules]
    init_needed :: IdEnv Bool
    init_needed = mapUFM (\_ -> False) orphan_rule_ids
	-- The mapUFM is a bit cheesy.  It is a cheap way
	-- to turn the set of orphan_rule_ids, which we use to initialise
	-- the sweep, into a mapping saying 'don't expose unfolding'	
	-- (When we come to the binding site we may change our mind, of course.)

    find (NonRec id rhs) needed
	| need_id needed id = addExternal (id,rhs) needed
	| otherwise 	    = needed
    find (Rec prs) needed   = find_prs prs needed

	-- For a recursive group we have to look for a fixed point
    find_prs prs needed	
	| null needed_prs = needed
	| otherwise	  = find_prs other_prs new_needed
	where
	  (needed_prs, other_prs) = partition (need_pr needed) prs
	  new_needed = foldr addExternal needed needed_prs

	-- The 'needed' set contains the Ids that are needed by earlier
	-- interface file emissions.  If the Id isn't in this set, and isn't
	-- exported, there's no need to emit anything
    need_id needed_set id       = id `elemVarEnv` needed_set || isExportedId id 
    need_pr needed_set (id,rhs)	= need_id needed_set id

addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
-- The Id is needed; extend the needed set
-- with it and its dependents (free vars etc)
addExternal (id,rhs) needed
  = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
		 id show_unfold
  where
    add_occ id needed = extendVarEnv needed id False
	-- "False" because we don't know we need the Id's unfolding
	-- We'll override it later when we find the binding site

    new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
	           | otherwise		      = worker_ids	`unionVarSet`
						unfold_ids	`unionVarSet`
						spec_ids

    idinfo	   = idInfo id
336
    dont_inline	   = isNeverActive (inlinePragInfo idinfo)
337
    loop_breaker   = isLoopBreaker (occInfo idinfo)
338
    bottoming_fn   = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357
    spec_ids	   = rulesRhsFreeVars (specInfo idinfo)
    worker_info	   = workerInfo idinfo

	-- Stuff to do with the Id's unfolding
	-- The simplifier has put an up-to-date unfolding
	-- in the IdInfo, but the RHS will do just as well
    unfolding	 = unfoldingInfo idinfo
    rhs_is_small = not (neverUnfold unfolding)

	-- We leave the unfolding there even if there is a worker
	-- In GHCI the unfolding is used by importers
	-- When writing an interface file, we omit the unfolding 
	-- if there is a worker
    show_unfold = not bottoming_fn	 &&	-- Not necessary
		  not dont_inline	 &&
		  not loop_breaker	 &&
		  rhs_is_small		 &&	-- Small enough
		  okToUnfoldInHiFile rhs 	-- No casms etc

358
    unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs
359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374
	       | otherwise   = emptyVarSet

    worker_ids = case worker_info of
		   HasWorker work_id _ -> unitVarSet work_id
		   otherwise	       -> emptyVarSet
\end{code}


%************************************************************************
%*									*
\subsection{Step 2: top-level tidying}
%*									*
%************************************************************************


\begin{code}
375
type TopTidyEnv = (NameSupply, TidyOccEnv, VarEnv Var)
376 377

-- TopTidyEnv: when tidying we need to know
378 379
--   * ns: The NameSupply, containing a unique supply and any pre-ordained Names.  
--	  These may have arisen because the
380 381 382 383 384
--	  renamer read in an interface file mentioning M.$wf, say,
--	  and assigned it unique r77.  If, on this compilation, we've
--	  invented an Id whose name is $wf (but with a different unique)
--	  we want to rename it to have unique r77, so that we can do easy
--	  comparisons with stuff from the interface file
385 386 387 388
--
--   * occ_env: The TidyOccEnv, which tells us which local occurrences 
--     are 'used'
--
389 390 391 392 393 394
--   * subst_env: A Var->Var mapping that substitutes the new Var for the old
\end{code}


\begin{code}
tidyTopBind :: Module
395
	    -> IdEnv Bool	-- Domain = Ids that should be external
396
				-- True <=> their unfolding is external too
397
	    -> CgInfoEnv
398 399 400
	    -> TopTidyEnv -> CoreBind
	    -> (TopTidyEnv, CoreBind)

401
tidyTopBind mod ext_ids cg_info_env top_tidy_env (NonRec bndr rhs)
402
  = ((orig,occ,subst) , NonRec bndr' rhs')
403
  where
404
    ((orig,occ,subst), bndr')
405
	 = tidyTopBinder mod ext_ids cg_info_env 
406
			 rec_tidy_env rhs rhs' top_tidy_env bndr
407 408
    rec_tidy_env = (occ,subst)
    rhs' = tidyExpr rec_tidy_env rhs
409

410
tidyTopBind mod ext_ids cg_info_env top_tidy_env (Rec prs)
411 412
  = (final_env, Rec prs')
  where
413 414
    (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs
    rec_tidy_env = (occ,subst)
415

416 417
    do_one top_tidy_env (bndr,rhs) 
	= ((orig,occ,subst), (bndr',rhs'))
418
	where
419
	((orig,occ,subst), bndr')
420
	   = tidyTopBinder mod ext_ids cg_info_env
421
		rec_tidy_env rhs rhs' top_tidy_env bndr
422 423

        rhs' = tidyExpr rec_tidy_env rhs
424

425
tidyTopBinder :: Module -> IdEnv Bool -> CgInfoEnv
426 427 428 429 430
	      -> TidyEnv 	-- The TidyEnv is used to tidy the IdInfo
	      -> CoreExpr	-- RHS *before* tidying
	      -> CoreExpr	-- RHS *after* tidying
			-- The TidyEnv and the after-tidying RHS are
			-- both are knot-tied: don't look at them!
431
	      -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
432
  -- NB: tidyTopBinder doesn't affect the unique supply
433

434
tidyTopBinder mod ext_ids cg_info_env rec_tidy_env rhs tidy_rhs
435
	      env@(ns2, occ_env2, subst_env2) id
436
	-- This function is the heart of Step 2
437
	-- The rec_tidy_env is the one to use for the IdInfo
438 439 440 441 442 443
	-- It's necessary because when we are dealing with a recursive
	-- group, a variable late in the group might be mentioned
	-- in the IdInfo of one early in the group

	-- The rhs is already tidied
	
444
  = ((orig_env', occ_env', subst_env'), id')
445
  where
446
    (orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2
447 448
					       is_external
					       (idName id)
449 450
    ty'	   = tidyTopType (idType id)
    idinfo = tidyTopIdInfo rec_tidy_env is_external 
451
			   (idInfo id) unfold_info arity
452
			   (lookupCgInfo cg_info_env name')
453

454
    id' = mkVanillaGlobal name' ty' idinfo
455

456
    subst_env' = extendVarEnv subst_env2 id id'
457 458

    maybe_external = lookupVarEnv ext_ids id
459
    is_external    = isJust maybe_external
460

461 462 463 464
    -- Expose an unfolding if ext_ids tells us to
    -- Remember that ext_ids maps an Id to a Bool: 
    --	True to show the unfolding, False to hide it
    show_unfold = maybe_external `orElse` False
465
    unfold_info | show_unfold = mkTopUnfolding tidy_rhs
466 467
		| otherwise   = noUnfolding

468 469 470 471 472 473
    -- Usually the Id will have an accurate arity on it, because
    -- the simplifier has just run, but not always. 
    -- One case I found was when the last thing the simplifier
    -- did was to let-bind a non-atomic argument and then float
    -- it to the top level. So it seems more robust just to
    -- fix it here.
474
    arity = exprArity rhs
475

476

477

478 479 480
-- tidyTopIdInfo creates the final IdInfo for top-level
-- binders.  There are two delicate pieces:
--
481
--  * Arity.  After CoreTidy, this arity must not change any more.
482 483 484 485 486 487 488 489 490 491 492 493 494 495 496
--	Indeed, CorePrep must eta expand where necessary to make
--	the manifest arity equal to the claimed arity.
--
-- * CAF info, which comes from the CoreToStg pass via a knot.
-- 	The CAF info will not be looked at by the downstream stuff:
-- 	it *generates* it, and knot-ties it back.  It will only be
-- 	looked at by (a) MkIface when generating an interface file
-- 		     (b) In GHCi, importing modules
-- 	Nevertheless, we add the info here so that it propagates to all
-- 	occurrences of the binders in RHSs, and hence to occurrences in
-- 	unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
--     
-- 	An alterative would be to do a second pass over the unfoldings 
-- 	of Ids, and rules, right at the top, but that would be a pain.

497
tidyTopIdInfo tidy_env is_external idinfo unfold_info arity cg_info
498
  | opt_OmitInterfacePragmas || not is_external
499 500
	-- Only basic info if the Id isn't external, or if we don't have -O
  = basic_info
501

502 503 504
  | otherwise	-- Add extra optimisation info
  = basic_info
	`setInlinePragInfo`    inlinePragInfo idinfo
505
	`setUnfoldingInfo`     unfold_info
506 507 508 509
	`setWorkerInfo`	       tidyWorker tidy_env (workerInfo idinfo)
		-- NB: we throw away the Rules
		-- They have already been extracted by findExternalRules
  
510
  where
511 512 513
	-- baasic_info is attached to every top-level binder
    basic_info = vanillaIdInfo 
			`setCgInfo` 	       cg_info
514
			`setArityInfo`	       arity
515
			`setAllStrictnessInfo` newStrictnessInfo idinfo
516

517
-- This is where we set names to local/global based on whether they really are 
518 519
-- externally visible (see comment at the top of this module).  If the name
-- was previously local, we have to give it a unique occurrence name if
520
-- we intend to externalise it.
521 522
tidyTopName mod ns occ_env external name
  | global && internal = (ns, occ_env, localiseName name)
523

524
  | global && external = (ns, occ_env, name)
525 526
	-- Global names are assumed to have been allocated by the renamer,
	-- so they already have the "right" unique
527
	-- And it's a system-wide unique too
528

529
  | local  && internal = (ns_w_local, occ_env', new_local_name)
530
	-- Even local, internal names must get a unique occurrence, because
531
	-- if we do -split-objs we externalise the name later, in the code generator
532 533 534 535 536
	--
	-- Similarly, we must make sure it has a system-wide Unique, because
	-- the byte-code generator builds a system-wide Name->BCO symbol table

  | local  && external = case lookupFM ns_names key of
537
			   Just orig -> (ns,	      occ_env', orig)
538 539
			   Nothing   -> (ns_w_global, occ_env', new_external_name)
	-- If we want to externalise a currently-local name, check
540
	-- whether we have already assigned a unique for it.
541
	-- If so, use it; if not, extend the table (ns_w_global).
542 543
	-- This is needed when *re*-compiling a module in GHCi; we want to
	-- use the same name for externally-visible things as we did before.
544

545
  where
546
    global	     = isExternalName name
547 548 549
    local	     = not global
    internal	     = not external

550 551 552 553 554
    (occ_env', occ') = tidyOccName occ_env (nameOccName name)
    key		     = (moduleName mod, occ')
    ns_names	     = nsNames ns
    ns_uniqs	     = nsUniqs ns
    (us1, us2)	     = splitUniqSupply ns_uniqs
555 556 557
    uniq	     = uniqFromSupply us1
    loc		     = nameSrcLoc name

558 559
    new_local_name     = mkInternalName  uniq     occ' loc
    new_external_name  = mkExternalName uniq mod occ' loc  
560 561

    ns_w_local	     = ns { nsUniqs = us2 }
562
    ns_w_global	     = ns { nsUniqs = us2, nsNames = addToFM ns_names key new_external_name }
563 564


565
------------  Worker  --------------
566
tidyWorker tidy_env (HasWorker work_id wrap_arity) 
567
  = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
568
tidyWorker tidy_env other
569 570 571
  = NoWorker

------------  Rules  --------------
572 573 574 575 576 577
tidyIdRules :: Id -> [IdCoreRule]
tidyIdRules id = tidyIdCoreRules emptyTidyEnv (idCoreRules id)

tidyIdCoreRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule]
tidyIdCoreRules env [] = []
tidyIdCoreRules env ((fn,rule) : rules)
578
  = tidyRule env rule  		=: \ rule ->
579
    tidyIdCoreRules env rules 	=: \ rules ->
580
     ((tidyVarOcc env fn, rule) : rules)
581

582
tidyRule :: TidyEnv -> CoreRule -> CoreRule
583
tidyRule env rule@(BuiltinRule _ _) = rule
584
tidyRule env (Rule name act vars tpl_args rhs)
585 586
  = tidyBndrs env vars			=: \ (env', vars) ->
    map (tidyExpr env') tpl_args  	=: \ tpl_args ->
587
     (Rule name act vars tpl_args (tidyExpr env' rhs))
588 589 590 591 592 593 594 595 596 597
\end{code}

%************************************************************************
%*									*
\subsection{Step 2: inner tidying
%*									*
%************************************************************************

\begin{code}
tidyBind :: TidyEnv
598
	 -> CoreBind
599 600
	 ->  (TidyEnv, CoreBind)

601
tidyBind env (NonRec bndr rhs)
602
  = tidyLetBndr env (bndr,rhs)		=: \ (env', bndr') ->
603
    (env', NonRec bndr' (tidyExpr env' rhs))
604

605
tidyBind env (Rec prs)
606
  = mapAccumL tidyLetBndr env prs	=: \ (env', bndrs') ->
607 608
    map (tidyExpr env') (map snd prs)	=: \ rhss' ->
    (env', Rec (zip bndrs' rhss'))
609

610

611 612 613 614 615
tidyExpr env (Var v)   	=  Var (tidyVarOcc env v)
tidyExpr env (Type ty) 	=  Type (tidyType env ty)
tidyExpr env (Lit lit) 	=  Lit lit
tidyExpr env (App f a) 	=  App (tidyExpr env f) (tidyExpr env a)
tidyExpr env (Note n e) =  Note (tidyNote env n) (tidyExpr env e)
616

617
tidyExpr env (Let b e) 
618 619
  = tidyBind env b 	=: \ (env', b') ->
    Let b' (tidyExpr env' e)
620

621
tidyExpr env (Case e b alts)
622 623
  = tidyBndr env b 	=: \ (env', b) ->
    Case (tidyExpr env e) b (map (tidyAlt env') alts)
624

625
tidyExpr env (Lam b e)
626 627
  = tidyBndr env b 	=: \ (env', b) ->
    Lam b (tidyExpr env' e)
628 629


630
tidyAlt env (con, vs, rhs)
631 632
  = tidyBndrs env vs 	=: \ (env', vs) ->
    (con, vs, tidyExpr env' rhs)
633 634

tidyNote env (Coerce t1 t2)  = Coerce (tidyType env t1) (tidyType env t2)
635 636 637 638 639 640
tidyNote env note            = note
\end{code}


%************************************************************************
%*									*
641
\subsection{Tidying up non-top-level binders}
642 643 644 645
%*									*
%************************************************************************

\begin{code}
646 647 648 649
tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
				  Just v' -> v'
				  Nothing -> v

650
-- tidyBndr is used for lambda and case binders
651
tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
652
tidyBndr env var
653 654
  | isTyVar var = tidyTyVarBndr env var
  | otherwise   = tidyIdBndr env var
655

656 657
tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
tidyBndrs env vars = mapAccumL tidyBndr env vars
658

659 660 661 662
tidyLetBndr :: TidyEnv -> (Id, CoreExpr) -> (TidyEnv, Var)
-- Used for local (non-top-level) let(rec)s
tidyLetBndr env (id,rhs) 
  = ((tidy_env,new_var_env), final_id)
663
  where
664 665 666 667 668 669 670 671 672 673 674
    ((tidy_env,var_env), new_id) = tidyIdBndr env id

	-- We need to keep around any interesting strictness and demand info
	-- because later on we may need to use it when converting to A-normal form.
	-- eg.
	--	f (g x),  where f is strict in its argument, will be converted
	--	into  case (g x) of z -> f z  by CorePrep, but only if f still
	-- 	has its strictness info.
	--
	-- Similarly for the demand info - on a let binder, this tells 
	-- CorePrep to turn the let into a case.
675 676 677 678 679
	--
	-- Similarly arity info for eta expansion in CorePrep
    final_id = new_id `setIdInfo` new_info
    idinfo   = idInfo id
    new_info = vanillaIdInfo 
680
		`setArityInfo`		exprArity rhs
681
		`setAllStrictnessInfo`	newStrictnessInfo idinfo
682
		`setNewDemandInfo`	newDemandInfo idinfo
683

684
    -- Override the env we get back from tidyId with the new IdInfo
685 686 687
    -- so it gets propagated to the usage sites.
    new_var_env = extendVarEnv var_env id final_id

688
-- Non-top-level variables
689 690
tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
tidyIdBndr env@(tidy_env, var_env) id
691 692 693
  = -- do this pattern match strictly, otherwise we end up holding on to
    -- stuff in the OccName.
    case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> 
694 695
    let 
	-- Give the Id a fresh print-name, *and* rename its type
696 697
	-- The SrcLoc isn't important now, 
	-- though we could extract it from the Id
698
	-- 
699 700
	-- All nested Ids now have the same IdInfo, namely none,
	-- which should save some space.
701
        ty'          	  = tidyType env (idType id)
702
	id'          	  = mkUserLocal occ' (idUnique id) ty' noSrcLoc
703 704
	var_env'	  = extendVarEnv var_env id id'
    in
705
     ((tidy_env', var_env'), id')
706
   }
707 708 709
\end{code}

\begin{code}
710
m =: k = m `seq` k m
711
\end{code}