SimplCore.lhs 18.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
module SimplCore ( core2core, simplifyExpr ) where
8
9
10

#include "HsVersions.h"

chak's avatar
chak committed
11
12
import CmdLineOpts	( CoreToDo(..), SimplifierSwitch(..),
			  SimplifierMode(..), DynFlags, DynFlag(..), dopt,
13
			  dopt_CoreToDo, buildCoreToDo
14
15
			)
import CoreSyn
16
import TcIface		( loadImportedRules )
17
18
import HscTypes		( HscEnv(..), ModGuts(..), ExternalPackageState(..),
			  ModDetails(..), HomeModInfo(..), hscEPS )
19
import CSE		( cseProgram )
20
21
import Rules		( RuleBase, ruleBaseIds, emptyRuleBase,
			  extendRuleBaseList, pprRuleBase, ruleCheckProgram )
22
import Module		( moduleEnvElts )
23
import PprCore		( pprCoreBindings, pprCoreExpr, pprIdRules )
24
import OccurAnal	( occurAnalyseBinds, occurAnalyseGlobalExpr )
25
import CoreUtils	( coreBindsSize )
26
import Simplify		( simplTopBinds, simplExpr )
27
import SimplEnv		( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
28
import SimplMonad
29
30
import ErrUtils		( dumpIfSet, dumpIfSet_dyn, showPass )
import CoreLint		( endPass )
31
import VarEnv		( mkInScopeSet )
32
33
import FloatIn		( floatInwards )
import FloatOut		( floatOutwards )
34
import Id		( idIsFrom, idSpecialisation, setIdSpecialisation )
35
36
37
38
import VarSet
import LiberateCase	( liberateCase )
import SAT		( doStaticArgs )
import Specialise	( specProgram)
39
import SpecConstr	( specConstrProgram)
40
import DmdAnal		( dmdAnalPgm )
41
import WorkWrap	        ( wwTopBinds )
42
43
#ifdef OLD_STRICTNESS
import StrictAnal	( saBinds )
44
import CprAnalyse       ( cprAnalyse )
45
#endif
46

47
import UniqSupply	( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
48
49
import IO		( hPutStr, stderr )
import Outputable
50
import List		( partition )
51
import Maybes		( orElse )
52
53
54
55
56
57
58
59
60
\end{code}

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

\begin{code}
61
62
63
core2core :: HscEnv
	  -> ModGuts
	  -> IO ModGuts
64

65
core2core hsc_env guts
66
  = do
67
        let dflags = hsc_dflags hsc_env
68
69
70
	    core_todos
		| Just todo <- dopt_CoreToDo dflags  =  todo
		| otherwise			     =  buildCoreToDo dflags
71

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

75
		-- COMPUTE THE RULE BASE TO USE
76
	(imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
77

78
		-- DO THE BUSINESS
79
80
81
	(stats, guts'') <- doCorePasses hsc_env cp_us
			 		(zeroSimplCount dflags) 
					imp_rule_base guts' core_todos
82

83
	dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
84
85
86
		  "Grand total simplifier statistics"
		  (pprSimplCount stats)

87
	return guts''
88
89


90
simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
91
92
	     -> CoreExpr
	     -> IO CoreExpr
93
94
-- simplifyExpr is called by the driver to simplify an
-- expression typed in at the interactive prompt
95
simplifyExpr dflags expr
96
  = do	{
97
98
	; showPass dflags "Simplify"

99
100
	; us <-  mkSplitUniqSupply 's'

101
102
	; let (expr', _counts) = initSmpl dflags us $
				 simplExprGently gentleSimplEnv expr
103

104
	; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
105
106
107
108
109
			(pprCoreExpr expr')

	; return expr'
	}

110
111
gentleSimplEnv :: SimplEnv
gentleSimplEnv = mkSimplEnv SimplGently 
112
113
			    (isAmongSimpl [])
			    emptyRuleBase
114

115
doCorePasses :: HscEnv
116
             -> UniqSupply      -- uniques
117
118
119
	     -> SimplCount      -- simplifier stats
             -> RuleBase        -- the main rule base
             -> ModGuts	        -- local binds in (with rules attached)
120
             -> [CoreToDo]      -- which passes to do
121
             -> IO (SimplCount, ModGuts)
122

123
124
doCorePasses hsc_env us stats rb guts []
  = return (stats, guts)
125

126
doCorePasses hsc_env us stats rb guts (to_do : to_dos) 
127
  = do
128
	let (us1, us2) = splitUniqSupply us
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
	(stats1, rb1, guts1) <- doCorePass to_do hsc_env us1 rb guts
	doCorePasses hsc_env us2 (stats `plusSimplCount` stats1) rb1 guts1 to_dos

doCorePass (CoreDoSimplify mode sws)   = _scc_ "Simplify"      simplifyPgm mode sws
doCorePass CoreCSE		       = _scc_ "CommonSubExpr" trBinds  cseProgram
doCorePass CoreLiberateCase	       = _scc_ "LiberateCase"  trBinds  liberateCase
doCorePass CoreDoFloatInwards          = _scc_ "FloatInwards"  trBinds  floatInwards
doCorePass (CoreDoFloatOutwards f)     = _scc_ "FloatOutwards" trBindsU (floatOutwards f)
doCorePass CoreDoStaticArgs	       = _scc_ "StaticArgs"    trBinds  doStaticArgs
doCorePass CoreDoStrictness	       = _scc_ "Stranal"       trBinds  dmdAnalPgm
doCorePass CoreDoWorkerWrapper         = _scc_ "WorkWrap"      trBindsU wwTopBinds
doCorePass CoreDoSpecialising          = _scc_ "Specialise"    trBindsU specProgram
doCorePass CoreDoSpecConstr	       = _scc_ "SpecConstr"    trBindsU specConstrProgram
doCorePass CoreDoGlomBinds	       = trBinds glomBinds
doCorePass CoreDoPrintCore	       = observe printCore
doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
doCorePass CoreDoNothing	       = observe (\ _ _ -> return ())
#ifdef OLD_STRICTNESS		       
doCorePass CoreDoOldStrictness	       = _scc_ "OldStrictness" trBinds doOldStrictness
148
#endif
149

150
#ifdef OLD_STRICTNESS
151
doOldStrictness dfs binds
152
153
154
  = do binds1 <- saBinds dfs binds
       binds2 <- cprAnalyse dfs binds1
       return binds2
155
156
#endif

157
printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
158

159
ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
160
				      printDump (ruleCheckProgram phase pat binds)
161

162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
-- Most passes return no stats and don't change rules
trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
	-> HscEnv -> UniqSupply -> RuleBase -> ModGuts
	-> IO (SimplCount, RuleBase, ModGuts)
trBinds do_pass hsc_env us rb guts
  = do	{ binds' <- do_pass dflags (mg_binds guts)
	; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) }
  where
    dflags = hsc_dflags hsc_env

trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
	-> HscEnv -> UniqSupply -> RuleBase -> ModGuts
	-> IO (SimplCount, RuleBase, ModGuts)
trBindsU do_pass hsc_env us rb guts
  = do	{ binds' <- do_pass dflags us (mg_binds guts)
	; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) }
  where
    dflags = hsc_dflags hsc_env

-- Observer passes just peek; don't modify the bindings at all
observe :: (DynFlags -> [CoreBind] -> IO a)
	-> HscEnv -> UniqSupply -> RuleBase -> ModGuts
	-> IO (SimplCount, RuleBase, ModGuts)
observe do_pass hsc_env us rb guts 
  = do	{ binds <- do_pass dflags (mg_binds guts)
	; return (zeroSimplCount dflags, rb, guts) }
  where
    dflags = hsc_dflags hsc_env
190
191
192
\end{code}


193

194
195
196
197
198
199
%************************************************************************
%*									*
\subsection{Dealing with rules}
%*									*
%************************************************************************

200
201
-- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
-- It attaches those rules that are for local Ids to their binders, and
202
-- returns the remainder attached to Ids in an IdSet.  
203
204

\begin{code}
205
prepareRules :: HscEnv 
206
	     -> ModGuts
207
	     -> UniqSupply
208
209
210
211
212
213
214
	     -> IO (RuleBase, 		-- Rule base for imported things, incl
					-- (a) rules defined in this module (orphans)
					-- (b) rules from other packages
					-- (c) rules from other modules in home package
		    ModGuts)		-- Modified fields are 
					--	(a) Bindings have rules attached,
					-- 	(b) Rules are now just orphan rules
215

216
prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
217
	     guts@(ModGuts { mg_binds = binds, mg_rules = local_rules })
218
	     us 
219
  = do	{ eps <- hscEPS hsc_env
220

221
222
223
	; let 	-- Simplify the local rules; boringly, we need to make an in-scope set
		-- from the local binders, to avoid warnings from Simplify.simplVar
	      local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
224
	      env	       = setInScopeSet gentleSimplEnv local_ids 
225
	      (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
226

227
	      (orphan_rules, rules_for_locals) = partition isOrphanRule better_rules
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
		-- Get the rules for locally-defined Ids out of the RuleBase
		-- If we miss any rules for Ids defined here, then we end up
		-- giving the local decl a new Unique (because the in-scope-set is (hackily) the
		-- same as the non-local-rule-id set, so the Id looks as if it's in scope
		-- and hence should be cloned), and now the binding for the class method 
		-- doesn't have the same Unique as the one in the Class and the tc-env
		--	Example:	class Foo a where
		--			  op :: a -> a
		--			{-# RULES "op" op x = x #-}

		-- NB: we assume that the imported rules dont include 
		--     rules for Ids in this module; if there is, the above bad things may happen

	      pkg_rule_base = eps_rule_base eps
	      hpt_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
	      imp_rule_base = extendRuleBaseList hpt_rule_base orphan_rules

		-- Update the binders in the local bindings with the lcoal rules
		-- Update the binders of top-level bindings by
		-- attaching the rules for each locally-defined Id to that Id.
		-- 
		-- 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
	      local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
	      binds_w_rules   = updateBinders local_rule_base binds
263
264

	; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
265
		(vcat [text "Local rules", pprIdRules better_rules,
266
		       text "",
267
		       text "Imported rules", pprRuleBase imp_rule_base])
268

269
#ifdef DEBUG
270
	; let bad_rules = filter (idIsFrom (mg_module guts)) 
271
				 (varSetElems (ruleBaseIds imp_rule_base))
272
273
274
	; WARN( not (null bad_rules), ppr bad_rules ) return ()
#endif
	; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules })
275
    }
276
  where
277
    add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
278

279
280
updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
updateBinders rule_base binds
281
  = map update_bndrs binds
282
  where
283
284
    rule_ids = ruleBaseIds rule_base

285
286
287
    update_bndrs (NonRec b r) = NonRec (update_bndr b) r
    update_bndrs (Rec prs)    = Rec [(update_bndr b, r) | (b,r) <- prs]

288
289
290
    update_bndr bndr = case lookupVarSet rule_ids bndr of
			  Nothing -> bndr
			  Just id -> bndr `setIdSpecialisation` idSpecialisation id
291
292
\end{code}

293

294
295
296
297
298
We must do some gentle simplification on the template (but not the RHS)
of each rule.  The case that forced me to add this was the fold/build rule,
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.
299

300
\begin{code}
301
simplRule env rule@(IdCoreRule id _ (BuiltinRule _ _))
302
  = returnSmpl rule
303
simplRule env (IdCoreRule id is_orph (Rule act name bndrs args rhs))
304
305
306
  = simplBinders env bndrs		`thenSmpl` \ (env, bndrs') -> 
    mapSmpl (simplExprGently env) args	`thenSmpl` \ args' ->
    simplExprGently env rhs		`thenSmpl` \ rhs' ->
307
    returnSmpl (IdCoreRule id is_orph (Rule act name bndrs' args' rhs'))
308

309
310
-- It's important that simplExprGently does eta reduction.
-- For example, in a rule like:
311
--	augment g (build h) 
312
-- we do not want to get
313
--	augment (\a. g a) (build h)
314
-- otherwise we don't match when given an argument like
315
--	(\a. h a a)
316
317
318
319
320
321
--
-- The simplifier does indeed do eta reduction (it's in
-- Simplify.completeLam) but only if -O is on.
\end{code}

\begin{code}
322
simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
323
324
325
326
327
328
-- 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
329
330
331
332
333
--
-- 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

334
335
336
simplExprGently env expr
  = simplExpr env (occurAnalyseGlobalExpr expr) 	`thenSmpl` \ expr1 ->
    simplExpr env (occurAnalyseGlobalExpr expr1)
337
338
\end{code}

339
340
341
342
343
344
345

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

346
\begin{code}
347
glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
-- 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.

373
glomBinds dflags binds
374
  = do { showPass dflags "GlomBinds" ;
375
376
377
378
379
380
	 let { recd_binds = [Rec (flattenBinds binds)] } ;
	 return recd_binds }
	-- Not much point in printing the result... 
	-- just consumes output bandwidth
\end{code}

381

382
383
384
385
386
387
388
%************************************************************************
%*									*
\subsection{The driver for the simplifier}
%*									*
%************************************************************************

\begin{code}
389
simplifyPgm :: SimplifierMode
390
	    -> [SimplifierSwitch]
391
	    -> HscEnv
392
	    -> UniqSupply
393
394
395
	    -> RuleBase
	    -> ModGuts
	    -> IO (SimplCount, RuleBase, ModGuts)  -- New bindings
396

397
simplifyPgm mode switches hsc_env us rule_base guts
398
  = do {
399
	showPass dflags "Simplify";
400

401
402
	(termination_msg, it_count, counts_out, rule_base', guts') 
	   <- do_iteration us rule_base 1 (zeroSimplCount dflags) guts;
403

404
405
	dumpIfSet (dopt Opt_D_verbose_core2core dflags 
                   && dopt Opt_D_dump_simpl_stats dflags)
406
407
408
409
410
		  "Simplifier statistics"
		  (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
			 text "",
			 pprSimplCount counts_out]);

411
	endPass dflags "Simplify" Opt_D_verbose_core2core (mg_binds guts');
412

413
	return (counts_out, rule_base', guts')
414
415
    }
  where
416
    dflags 	      = hsc_dflags hsc_env
417
418
419
420
    phase_info	      = case mode of
			  SimplGently  -> "gentle"
			  SimplPhase n -> show n

421
    sw_chkr	      = isAmongSimpl switches
422
    max_iterations    = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
423
 
424
    do_iteration us rule_base iteration_no counts guts
425
426
427
428
429
430
431
432
433
434
435
436
437
438
	-- 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
      = do {
#ifdef DEBUG
	    if  max_iterations > 2 then
		hPutStr stderr ("NOTE: Simplifier still going after " ++ 
				show max_iterations ++ 
			    	" iterations; bailing out.\n")
	    else 
		return ();
#endif
		-- Subtract 1 from iteration_no to get the
		-- number of iterations we actually completed
439
	    return ("Simplifier baled out", iteration_no - 1, counts, rule_base, guts)
440
441
	}

442
443
      -- Try and force thunks off the binds; significantly reduces
      -- space usage, especially with -O.  JRS, 000620.
444
      | let sz = coreBindsSize (mg_binds guts) in sz == sz
445
446
      = do {
		-- Occurrence analysis
447
	   let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds (mg_binds guts) } ;
448

449
	   dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
450
451
		     (pprCoreBindings tagged_binds);

452
453
454
455
456
457
458
459
460
461
	   	-- Get any new rules, and extend the rule base
		-- (on the side this extends the package rule base in the
		--  ExternalPackageTable, ready for the next complation 
		--  in --make mode)
		-- 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
	   new_rules <- loadImportedRules hsc_env guts ;
	   let	{ rule_base' = extendRuleBaseList rule_base new_rules
462
		; simpl_env  = mkSimplEnv mode sw_chkr rule_base' } ;
463
464
465
466
467
468
			-- The new rule base Ids are used to initialise
			-- the in-scope set.  That way, the simplifier will change any
			-- occurrences of the imported id to the one in the imported_rule_ids
			-- set, which are decorated with their rules.
	   
		-- Simplify the program
469
470
471
472
473
474
475
		-- 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 ...
		--	counts' = snd t
		--   in
476
		-- 	case t of {(_,counts') -> if counts'=0 then ... }
477
478
		-- So the conditional didn't force counts', because the
		-- selection got duplicated.  Sigh!
479
	   case initSmpl dflags us1 (simplTopBinds simpl_env tagged_binds) of {
480
	  	(binds', counts') -> do {
481

482
483
484
	   let	{ guts'      = guts { mg_binds = binds' }
		; all_counts = counts `plusSimplCount` counts'
		; herald     = "Simplifier phase " ++ phase_info ++ 
485
486
487
			      ", iteration " ++ show iteration_no ++
			      " out of " ++ show max_iterations
	        } ;
488
489
490

		-- Stop if nothing happened; don't dump output
	   if isZeroSimplCount counts' then
491
492
		return ("Simplifier reached fixed point", iteration_no, 
			all_counts, rule_base', guts')
493
494
495
	   else do {

		-- Dump the result of this iteration
496
	   dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
497
		         (pprSimplCount counts') ;
498

499
	   endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
500

501
		-- Loop
502
  	   do_iteration us2 rule_base' (iteration_no + 1) all_counts guts'
503
	}  } } }
504
505
506
      where
  	  (us1, us2) = splitUniqSupply us
\end{code}