SimplCore.lhs 28.1 KB
Newer Older
1 2 3 4 5 6
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[SimplCore]{Driver for simplifying @Core@ programs}

\begin{code}
7
{-# OPTIONS -w #-}
8 9 10
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
11
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
12 13
-- for details

14
module SimplCore ( core2core, simplifyExpr ) where
15 16 17

#include "HsVersions.h"

18
import DynFlags		( DynFlags, DynFlag(..), dopt )
19
import CoreSyn
20
import CoreSubst
21
import HscTypes
22
import CSE		( cseProgram )
23
import Rules		( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
24 25
			  extendRuleBaseList, pprRuleBase, pprRulesForUser,
			  ruleCheckProgram, rulesOfBinds,
26
			  addSpecInfo, addIdSpecialisations )
27
import PprCore		( pprCoreBindings, pprCoreExpr, pprRules )
28
import OccurAnal	( occurAnalysePgm, occurAnalyseExpr )
29
import IdInfo
30
import CoreUtils	( coreBindsSize )
31
import Simplify		( simplTopBinds, simplExpr )
32
import SimplUtils	( simplEnvForGHCi, simplEnvForRules )
33
import SimplEnv
34
import SimplMonad
35
import CoreMonad
36 37
import qualified ErrUtils as Err 
import CoreLint
38 39
import FloatIn		( floatInwards )
import FloatOut		( floatOutwards )
40
import FamInstEnv
41 42
import Id
import DataCon
43
import TyCon		( tyConDataCons )
44
import Class		( classSelIds )
45
import BasicTypes       ( CompilerPhase, isActive, isDefaultInlinePragma )
46
import VarSet
47
import VarEnv
48
import NameEnv		( lookupNameEnv )
49 50 51
import LiberateCase	( liberateCase )
import SAT		( doStaticArgs )
import Specialise	( specProgram)
52
import SpecConstr	( specConstrProgram)
53
import DmdAnal		( dmdAnalPgm )
54
import WorkWrap	        ( wwTopBinds )
55
import Vectorise        ( vectorise )
56
import FastString
Ian Lynagh's avatar
Ian Lynagh committed
57
import Util
58

59
import UniqSupply	( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
60
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
61
import Control.Monad
Ian Lynagh's avatar
Ian Lynagh committed
62 63
import Data.List
import System.IO
64
import Maybes
65 66 67 68 69 70 71 72 73
\end{code}

%************************************************************************
%*									*
\subsection{The driver for the simplifier}
%*									*
%************************************************************************

\begin{code}
74 75 76
core2core :: HscEnv
	  -> ModGuts
	  -> IO ModGuts
77

78 79 80 81 82 83 84
core2core hsc_env guts = do
    let dflags = hsc_dflags hsc_env

    us <- mkSplitUniqSupply 's'
    let (cp_us, ru_us) = splitUniqSupply us

    -- COMPUTE THE RULE BASE TO USE
85
    -- See Note [Overall plumbing for rules] in Rules.lhs
86
    (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_us
87

88 89 90 91 92 93
    -- Get the module out of the current HscEnv so we can retrieve it from the monad.
    -- This is very convienent for the users of the monad (e.g. plugins do not have to
    -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
    -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
    -- would mean our cached value would go out of date.
    let mod = mg_module guts
94
    (guts2, stats) <- runCoreM hsc_env hpt_rule_base cp_us mod $ do
95 96
        -- FIND BUILT-IN PASSES
        let builtin_core_todos = getCoreToDo dflags
97

98
        -- DO THE BUSINESS
99
        doCorePasses builtin_core_todos guts1
100

101 102 103
    Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
        "Grand total simplifier statistics"
        (pprSimplCount stats)
104

105
    return guts2
106

107

108
type CorePass = CoreToDo
109

110
simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
111 112
	     -> CoreExpr
	     -> IO CoreExpr
113 114
-- simplifyExpr is called by the driver to simplify an
-- expression typed in at the interactive prompt
115 116
--
-- Also used by Template Haskell
117
simplifyExpr dflags expr
118
  = do	{
119
	; Err.showPass dflags "Simplify"
120

121 122
	; us <-  mkSplitUniqSupply 's'

123
	; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
124
				 simplExprGently simplEnvForGHCi expr
125

126
	; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
127 128 129 130 131
			(pprCoreExpr expr')

	; return expr'
	}

132
doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
133 134 135 136 137 138 139 140 141 142 143
doCorePasses passes guts 
  = foldM do_pass guts passes
  where
    do_pass guts CoreDoNothing = return guts
    do_pass guts (CoreDoPasses ps) = doCorePasses ps guts
    do_pass guts pass 
       = do { dflags <- getDynFlags
       	    ; liftIO $ showPass dflags pass
       	    ; guts' <- doCorePass pass guts
       	    ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts')
       	    ; return guts' }
144 145

doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
146 147
doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
                                       simplifyPgm pass
148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173

doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}   
				       doPass cseProgram

doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}
                                       doPassD liberateCase

doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
                                       doPass floatInwards

doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
                                       doPassDUM (floatOutwards f)

doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
                                       doPassU doStaticArgs

doCorePass CoreDoStrictness          = {-# SCC "Stranal" #-}
                                       doPassDM dmdAnalPgm

doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
                                       doPassU wwTopBinds

doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
                                       doPassU specProgram

doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
174
                                       specConstrProgram
175 176 177 178

doCorePass (CoreDoVectorisation be)  = {-# SCC "Vectorise" #-}
                                       vectorise be

179 180 181
doCorePass CoreDoGlomBinds              = doPassDM  glomBinds
doCorePass CoreDoPrintCore              = observe   printCore
doCorePass (CoreDoRuleCheck phase pat)  = ruleCheck phase pat
182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199
doCorePass CoreDoNothing                = return
doCorePass (CoreDoPasses passes)        = doCorePasses passes
\end{code}

%************************************************************************
%*									*
\subsection{Core pass combinators}
%*									*
%************************************************************************

\begin{code}
printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)

ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
ruleCheck current_phase pat guts = do
    rb <- getRuleBase
    dflags <- getDynFlags
    liftIO $ Err.showPass dflags "RuleCheck"
200
    liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts))
201 202 203 204 205 206 207 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 238 239 240
    return guts


doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts
doPassDMS do_pass = doPassM $ \binds -> do
    dflags <- getDynFlags
    liftIOWithCount $ do_pass dflags binds

doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
doPassDUM do_pass = doPassM $ \binds -> do
    dflags <- getDynFlags
    us     <- getUniqueSupplyM
    liftIO $ do_pass dflags us binds

doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))

doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)

doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)

doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
doPassU do_pass = doPassDU (const do_pass)

-- Most passes return no stats and don't change rules: these combinators
-- let us lift them to the full blown ModGuts+CoreM world
doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
doPassM bind_f guts = do
    binds' <- bind_f (mg_binds guts)
    return (guts { mg_binds = binds' })

doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
doPassMG bind_f guts = do
    binds' <- bind_f guts
    return (guts { mg_binds = binds' })

doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
241 242

-- Observer passes just peek; don't modify the bindings at all
243 244 245 246 247
observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
observe do_pass = doPassM $ \binds -> do
    dflags <- getDynFlags
    liftIO $ do_pass dflags binds
    return binds
248 249 250 251 252
\end{code}


%************************************************************************
%*									*
253
	Dealing with rules
254 255 256
%*									*
%************************************************************************

257 258
-- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
-- It attaches those rules that are for local Ids to their binders, and
259
-- returns the remainder attached to Ids in an IdSet.  
260 261

\begin{code}
262
prepareRules :: HscEnv 
263
	     -> ModGuts
264
	     -> UniqSupply
265 266
	     -> IO (RuleBase, 		-- Rule base for imported things, incl
					-- (a) rules defined in this module (orphans)
267 268 269
					-- (b) rules from other modules in home package
					-- but not things from other packages

270 271
		    ModGuts)		-- Modified fields are 
					--	(a) Bindings have rules attached,
272
					--		and INLINE rules simplified
273
					-- 	(b) Rules are now just orphan rules
274

275
prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
276 277
	     guts@(ModGuts { mg_binds = binds, mg_deps = deps 
	     		   , mg_rules = local_rules, mg_rdr_env = rdr_env })
278
	     us 
279 280 281
  = do	{ us <- mkSplitUniqSupply 'w'

	; let 	-- Simplify the local rules; boringly, we need to make an in-scope set
282 283
		-- from the local binders, to avoid warnings from Simplify.simplVar
	      local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
284
	      env	       = setInScopeSet simplEnvForRules local_ids 
285 286 287 288 289 290 291 292 293
	      (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
				 mapM (simplRule env) local_rules

	; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules

	      home_pkg_rules = hptRules hsc_env (dep_mods deps)
	      hpt_rule_base  = mkRuleBase home_pkg_rules
	      binds_w_rules  = updateBinders rules_for_locals binds

294

295
	; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
296
		(withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
297
		 vcat [text "Local rules for local Ids", pprRules simpl_rules,
298
		       blankLine,
299
		       text "Local rules for imported Ids", pprRuleBase hpt_rule_base])
300

301
	; return (hpt_rule_base, guts { mg_binds = binds_w_rules, 
302
					mg_rules = rules_for_imps })
303
    }
304

305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325
-- Note [Attach rules to local ids]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Find the rules for locally-defined Ids; then we can attach them
-- to the binders in the top-level bindings
-- 
-- Reason
-- 	- It makes the rules easier to look up
--	- It means that transformation rules and specialisations for
--	  locally defined Ids are handled uniformly
--	- It keeps alive things that are referred to only from a rule
--	  (the occurrence analyser knows about rules attached to Ids)
--	- It makes sure that, when we apply a rule, the free vars
--	  of the RHS are more likely to be in scope
--	- The imported rules are carried in the in-scope set
--	  which is extended on each iteration by the new wave of
--	  local binders; any rules which aren't on the binding will
--	  thereby get dropped

updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind]
updateBinders rules_for_locals binds
  = map update_bind binds
326
  where
327 328 329 330 331 332 333 334 335 336 337 338 339
    local_rules = extendRuleBaseList emptyRuleBase rules_for_locals

    update_bind (NonRec b r) = NonRec (add_rules b) r
    update_bind (Rec prs)    = Rec (mapFst add_rules prs)

	-- See Note [Attach rules to local ids]
	-- NB: the binder might have some existing rules,
	-- arising from specialisation pragmas
    add_rules bndr
	| Just rules <- lookupNameEnv local_rules (idName bndr)
	= bndr `addIdSpecialisations` rules
	| otherwise
	= bndr
340 341
\end{code}

342 343 344 345
Note [Simplifying the left-hand side of a RULE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We must do some gentle simplification on the lhs (template) of each
rule.  The case that forced me to add this was the fold/build rule,
346 347 348
which without simplification looked like:
	fold k z (build (/\a. g a))  ==>  ...
This doesn't match unless you do eta reduction on the build argument.
349 350 351 352 353 354
Similarly for a LHS like
	augment g (build h) 
we do not want to get
	augment (\a. g a) (build h)
otherwise we don't match when given an argument like
	augment (\a. h a a) (build h)
355

356 357 358
The simplifier does indeed do eta reduction (it's in
Simplify.completeLam) but only if -O is on.

359
\begin{code}
360
simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule
361
simplRule env rule@(BuiltinRule {})
362
  = return rule
363
simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
364 365 366
  = do (env, bndrs') <- simplBinders env bndrs
       args' <- mapM (simplExprGently env) args
       rhs' <- simplExprGently env rhs
367 368
       return (rule { ru_bndrs = bndrs', ru_args = args'
                    , ru_rhs = occurAnalyseExpr rhs' })
369 370 371
\end{code}

\begin{code}
372
simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
373 374 375 376 377 378
-- Simplifies an expression 
-- 	does occurrence analysis, then simplification
--	and repeats (twice currently) because one pass
--	alone leaves tons of crud.
-- Used (a) for user expressions typed in at the interactive prompt
--	(b) the LHS and RHS of a RULE
379
--	(c) Template Haskell splices
380 381 382 383 384
--
-- The name 'Gently' suggests that the SimplifierMode is SimplGently,
-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
-- enforce that; it just simplifies the expression twice

385 386 387 388 389
-- It's important that simplExprGently does eta reduction; see
-- Note [Simplifying the left-hand side of a RULE] above.  The
-- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
-- but only if -O is on.

390 391
simplExprGently env expr = do
    expr1 <- simplExpr env (occurAnalyseExpr expr)
392
    simplExpr env (occurAnalyseExpr expr1)
393 394
\end{code}

395 396 397 398 399 400 401

%************************************************************************
%*									*
\subsection{Glomming}
%*									*
%************************************************************************

402
\begin{code}
403
glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428
-- Glom all binds together in one Rec, in case any
-- transformations have introduced any new dependencies
--
-- NB: the global invariant is this:
--	*** the top level bindings are never cloned, and are always unique ***
--
-- We sort them into dependency order, but applying transformation rules may
-- make something at the top refer to something at the bottom:
--	f = \x -> p (q x)
--	h = \y -> 3
--	
--	RULE:  p (q x) = h x
--
-- Applying this rule makes f refer to h, 
-- although it doesn't appear to in the source program.  
-- This pass lets us control where it happens.
--
-- NOTICE that this cannot happen for rules whose head is a locally-defined
-- function.  It only happens for rules whose head is an imported function
-- (p in the example above).  So, for example, the rule had been
--	RULE: f (p x) = h x
-- then the rule for f would be attached to f itself (in its IdInfo) 
-- by prepareLocalRuleBase and h would be regarded by the occurrency 
-- analyser as free in f.

429
glomBinds dflags binds
430
  = do { Err.showPass dflags "GlomBinds" ;
431 432 433 434 435 436
	 let { recd_binds = [Rec (flattenBinds binds)] } ;
	 return recd_binds }
	-- Not much point in printing the result... 
	-- just consumes output bandwidth
\end{code}

437

438 439 440 441 442 443 444
%************************************************************************
%*									*
\subsection{The driver for the simplifier}
%*									*
%************************************************************************

\begin{code}
445 446 447
simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
simplifyPgm pass guts
  = do { hsc_env <- getHscEnv
448 449
       ; us <- getUniqueSupplyM
       ; rb <- getRuleBase
450
       ; liftIOWithCount $  
451
       	 simplifyPgmIO pass hsc_env us rb guts }
452

453
simplifyPgmIO :: CoreToDo
454 455 456 457 458 459
	      -> HscEnv
	      -> UniqSupply
	      -> RuleBase
	      -> ModGuts
	      -> IO (SimplCount, ModGuts)  -- New bindings

460 461
simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
              hsc_env us hpt_rule_base 
462 463
              guts@(ModGuts { mg_binds = binds, mg_rules = rules
                            , mg_fam_inst_env = fam_inst_env })
464 465
  = do { (termination_msg, it_count, counts_out, guts') 
	   <- do_iteration us 1 [] binds rules 
466

467
	; Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
468
		  "Simplifier statistics for following pass"
469
		  (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
470
			 blankLine,
471
			 pprSimplCount counts_out])
472

473
	; return (counts_out, guts')
474 475
    }
  where
476
    dflags     	 = hsc_dflags hsc_env
477
    dump_phase 	 = dumpSimplPhase dflags mode
478
    sw_chkr	 = isAmongSimpl switches
479
    do_iteration :: UniqSupply
480 481 482 483
                 -> Int		 -- Counts iterations
		 -> [SimplCount] -- Counts from earlier iterations, reversed
		 -> [CoreBind]	 -- Bindings in
		 -> [CoreRule]	 -- and orphan rules
484 485
		 -> IO (String, Int, SimplCount, ModGuts)

486
    do_iteration us iteration_no counts_so_far binds rules
487 488 489
	-- iteration_no is the number of the iteration we are
	-- about to begin, with '1' for the first
      | iteration_no > max_iterations	-- Stop if we've run out of iterations
490 491 492
      = WARN( debugIsOn && (max_iterations > 2)
            , ptext (sLit "Simplifier baling out after") <+> int max_iterations
              <+> ptext (sLit "iterations") 
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
493 494
              <+> (brackets $ hsep $ punctuate comma $ 
                   map (int . simplCountN) (reverse counts_so_far))
495 496
              <+> ptext (sLit "Size =") <+> int (coreBindsSize binds) )

497 498
		-- Subtract 1 from iteration_no to get the
		-- number of iterations we actually completed
499 500
	return ("Simplifier baled out", iteration_no - 1, total_counts, 
                 guts { mg_binds = binds, mg_rules = rules })
501

502 503
      -- Try and force thunks off the binds; significantly reduces
      -- space usage, especially with -O.  JRS, 000620.
504
      | let sz = coreBindsSize binds in sz == sz
505 506
      = do {
		-- Occurrence analysis
507
	   let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
508
	   Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
509 510
		     (pprCoreBindings tagged_binds);

511
	   	-- Get any new rules, and extend the rule base
512
		-- See Note [Overall plumbing for rules] in Rules.lhs
513 514 515 516
		-- We need to do this regularly, because simplification can
		-- poke on IdInfo thunks, which in turn brings in new rules
		-- behind the scenes.  Otherwise there's a danger we'll simply
		-- miss the rules for Ids hidden inside imported inlinings
517
	   eps <- hscEPS hsc_env ;
518 519
	   let	{ rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
	        ; rule_base2 = extendRuleBaseList rule_base1 rules
520
		; simpl_env  = mkSimplEnv sw_chkr mode
521
		; simpl_binds = {-# SCC "SimplTopBinds" #-} 
522
				simplTopBinds simpl_env tagged_binds
523
		; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
524 525
	   
		-- Simplify the program
526 527 528 529 530
		-- We do this with a *case* not a *let* because lazy pattern
		-- matching bit us with bad space leak!
		-- With a let, we ended up with
		--   let
		--	t = initSmpl ...
531
		--	counts1 = snd t
532
		--   in
533 534
		-- 	case t of {(_,counts1) -> if counts1=0 then ... }
		-- So the conditional didn't force counts1, because the
535
		-- selection got duplicated.  Sigh!
536 537
	   case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
	  	(env1, counts1) -> do {
538

539
	   let	{ binds1 = getFloats env1
540
                ; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules
541
	        } ;
542 543

		-- Stop if nothing happened; don't dump output
544
	   if isZeroSimplCount counts1 then
545
		return ("Simplifier reached fixed point", iteration_no, total_counts,
546
			guts { mg_binds = binds1, mg_rules = rules1 })
547
	   else do {
548 549 550 551 552
		-- Short out indirections
		-- We do this *after* at least one run of the simplifier 
		-- because indirection-shorting uses the export flag on *occurrences*
		-- and that isn't guaranteed to be ok until after the first run propagates
		-- stuff from the binding site to its occurrences
553 554 555
		--
		-- ToDo: alas, this means that indirection-shorting does not happen at all
		--	 if the simplifier does nothing (not common, I know, but unsavoury)
556
	   let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
557 558

		-- Dump the result of this iteration
559
	   end_iteration dflags pass iteration_no counts1 binds2 rules1 ;
560

561
		-- Loop
562
  	   do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
563
	}  } } }
564
      where
565 566 567 568 569
  	(us1, us2) = splitUniqSupply us

	-- Remember the counts_so_far are reversed
        total_counts = foldr (\c acc -> acc `plusSimplCount` c) 
                             (zeroSimplCount dflags) counts_so_far
570 571

-------------------
572
end_iteration :: DynFlags -> CoreToDo -> Int 
573
             -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
574
-- Same as endIteration but with simplifier counts
575 576 577 578
end_iteration dflags pass iteration_no counts binds rules
  = do { dumpIfSet (dopt Opt_D_dump_simpl_iterations dflags)
                   pass (ptext (sLit "Simplifier counts"))
		   (pprSimplCount counts)
579

580
       ; endIteration dflags pass iteration_no binds rules }
581
\end{code}
582 583 584 585


%************************************************************************
%*									*
586
		Shorting out indirections
587 588 589
%*									*
%************************************************************************

590
If we have this:
591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606

	x_local = <expression>
	...bindings...
	x_exported = x_local

where x_exported is exported, and x_local is not, then we replace it with this:

	x_exported = <expression>
	x_local = x_exported
	...bindings...

Without this we never get rid of the x_exported = x_local thing.  This
save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
makes strictness information propagate better.  This used to happen in
the final phase, but it's tidier to do it here.

607 608 609 610
Note [Transferring IdInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to propagage any useful IdInfo on x_local to x_exported.

611 612 613 614 615 616
STRICTNESS: if we have done strictness analysis, we want the strictness info on
x_local to transfer to x_exported.  Hence the copyIdInfo call.

RULES: we want to *add* any RULES for x_local to x_exported.


simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
617
Note [Messing up the exported Id's RULES]
618
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
619 620 621
We must be careful about discarding (obviously) or even merging the
RULES on the exported Id. The example that went bad on me at one stage
was this one:
622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653
	
    iterate :: (a -> a) -> a -> [a]
	[Exported]
    iterate = iterateList	
    
    iterateFB c f x = x `c` iterateFB c f (f x)
    iterateList f x =  x : iterateList f (f x)
    	[Not exported]
    
    {-# RULES
    "iterate"	forall f x.	iterate f x = build (\c _n -> iterateFB c f x)
    "iterateFB" 		iterateFB (:) = iterateList
     #-}

This got shorted out to:

    iterateList :: (a -> a) -> a -> [a]
    iterateList = iterate
    
    iterateFB c f x = x `c` iterateFB c f (f x)
    iterate f x =  x : iterate f (f x)
    
    {-# RULES
    "iterate"	forall f x.	iterate f x = build (\c _n -> iterateFB c f x)
    "iterateFB" 		iterateFB (:) = iterate
     #-}

And now we get an infinite loop in the rule system 
	iterate f x -> build (\cn -> iterateFB c f x)
		    -> iterateFB (:) f x
		    -> iterate f x

654
Old "solution": 
655 656 657
	use rule switching-off pragmas to get rid 
	of iterateList in the first place

658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675
But in principle the user *might* want rules that only apply to the Id
he says.  And inline pragmas are similar
   {-# NOINLINE f #-}
   f = local
   local = <stuff>
Then we do not want to get rid of the NOINLINE.

Hence hasShortableIdinfo.


Note [Rules and indirection-zapping]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Problem: what if x_exported has a RULE that mentions something in ...bindings...?
Then the things mentioned can be out of scope!  Solution
 a) Make sure that in this pass the usage-info from x_exported is 
	available for ...bindings...
 b) If there are any such RULES, rec-ify the entire top-level. 
    It'll get sorted out next time round
676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713

Other remarks
~~~~~~~~~~~~~
If more than one exported thing is equal to a local thing (i.e., the
local thing really is shared), then we do one only:
\begin{verbatim}
	x_local = ....
	x_exported1 = x_local
	x_exported2 = x_local
==>
	x_exported1 = ....

	x_exported2 = x_exported1
\end{verbatim}

We rely on prior eta reduction to simplify things like
\begin{verbatim}
	x_exported = /\ tyvars -> x_local tyvars
==>
	x_exported = x_local
\end{verbatim}
Hence,there's a possibility of leaving unchanged something like this:
\begin{verbatim}
	x_local = ....
	x_exported1 = x_local Int
\end{verbatim}
By the time we've thrown away the types in STG land this 
could be eliminated.  But I don't think it's very common
and it's dangerous to do this fiddling in STG land 
because we might elminate a binding that's mentioned in the
unfolding for something.

\begin{code}
type IndEnv = IdEnv Id		-- Maps local_id -> exported_id

shortOutIndirections :: [CoreBind] -> [CoreBind]
shortOutIndirections binds
  | isEmptyVarEnv ind_env = binds
714 715
  | no_need_to_flatten	  = binds'			-- See Note [Rules and indirect-zapping]
  | otherwise 		  = [Rec (flattenBinds binds')]	-- for this no_need_to_flatten stuff
716 717
  where
    ind_env 	       = makeIndEnv binds
718 719
    exp_ids 	       = varSetElems ind_env	-- These exported Ids are the subjects
    exp_id_set	       = mkVarSet exp_ids	-- of the indirection-elimination
720
    no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745
    binds' 	       = concatMap zap binds

    zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
    zap (Rec pairs)	  = [Rec (concatMap zapPair pairs)]

    zapPair (bndr, rhs)
	| bndr `elemVarSet` exp_id_set 		   = []
	| Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
						      (bndr, Var exp_id)]
	| otherwise				   = [(bndr,rhs)]
			     
makeIndEnv :: [CoreBind] -> IndEnv
makeIndEnv binds
  = foldr add_bind emptyVarEnv binds
  where
    add_bind :: CoreBind -> IndEnv -> IndEnv
    add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
    add_bind (Rec pairs)	      env = foldr add_pair env pairs

    add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
    add_pair (exported_id, Var local_id) env
	| shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
    add_pair (exported_id, rhs) env
	= env
			
746
-----------------
747 748 749 750 751 752 753 754 755 756 757 758 759 760
shortMeOut ind_env exported_id local_id
-- The if-then-else stuff is just so I can get a pprTrace to see
-- how often I don't get shorting out becuase of IdInfo stuff
  = if isExportedId exported_id &&		-- Only if this is exported

       isLocalId local_id &&			-- Only if this one is defined in this
						-- 	module, so that we *can* change its
				 	 	-- 	binding to be the exported thing!

       not (isExportedId local_id) &&		-- Only if this one is not itself exported,
					   	--	since the transformation will nuke it
   
       not (local_id `elemVarEnv` ind_env)	-- Only if not already substituted for
    then
761 762 763 764
	if hasShortableIdInfo exported_id
	then True	-- See Note [Messing up the exported Id's IdInfo]
	else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
             False
765
    else
766
        False
767

768 769 770 771 772 773 774 775 776 777
-----------------
hasShortableIdInfo :: Id -> Bool
-- True if there is no user-attached IdInfo on exported_id,
-- so we can safely discard it
-- See Note [Messing up the exported Id's IdInfo]
hasShortableIdInfo id
  =  isEmptySpecInfo (specInfo info)
  && isDefaultInlinePragma (inlinePragInfo info)
  where
     info = idInfo id
778 779 780

-----------------
transferIdInfo :: Id -> Id -> Id
781
-- See Note [Transferring IdInfo]
782 783 784 785 786 787
-- If we have
--	lcl_id = e; exp_id = lcl_id
-- and lcl_id has useful IdInfo, we don't want to discard it by going
--	gbl_id = e; lcl_id = gbl_id
-- Instead, transfer IdInfo from lcl_id to exp_id
-- Overwriting, rather than merging, seems to work ok.
788 789 790 791
transferIdInfo exported_id local_id
  = modifyIdInfo transfer exported_id
  where
    local_info = idInfo local_id
792
    transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info
793
				 `setUnfoldingInfo`     unfoldingInfo local_info
794
				 `setInlinePragInfo`	inlinePragInfo local_info
795 796 797 798 799
				 `setSpecInfo`	        addSpecInfo (specInfo exp_info) new_info
    new_info = setSpecInfoHead (idName exported_id) 
			       (specInfo local_info)
	-- Remember to set the function-name field of the
	-- rules as we transfer them from one function to another
800
\end{code}