[project @ 1999-06-28 16:40:18 by simonpj]
[ghc-hetmet.git] / ghc / compiler / simplCore / SimplCore.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[SimplCore]{Driver for simplifying @Core@ programs}
5
6 \begin{code}
7 module SimplCore ( core2core ) where
8
9 #include "HsVersions.h"
10
11 import CmdLineOpts      ( CoreToDo(..), SimplifierSwitch(..), 
12                           SwitchResult(..), switchIsOn, intSwitchSet,
13                           opt_D_dump_occur_anal, opt_D_dump_rules,
14                           opt_D_dump_simpl_iterations,
15                           opt_D_dump_simpl_stats,
16                           opt_D_dump_simpl, opt_D_dump_rules,
17                           opt_D_verbose_core2core,
18                           opt_D_dump_occur_anal,
19                           opt_UsageSPOn,
20                         )
21 import CoreLint         ( beginPass, endPass )
22 import CoreSyn
23 import CSE              ( cseProgram )
24 import Rules            ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )
25 import CoreUnfold
26 import PprCore          ( pprCoreBindings )
27 import OccurAnal        ( occurAnalyseBinds )
28 import CoreUtils        ( exprIsTrivial, coreExprType )
29 import Simplify         ( simplTopBinds, simplExpr )
30 import SimplUtils       ( etaCoreExpr, findDefault, simplBinders )
31 import SimplMonad
32 import Const            ( Con(..), Literal(..), literalType, mkMachInt )
33 import ErrUtils         ( dumpIfSet )
34 import FloatIn          ( floatInwards )
35 import FloatOut         ( floatOutwards )
36 import Id               ( Id, mkSysLocal, mkVanillaId, isBottomingId,
37                           idType, setIdType, idName, idInfo, setIdNoDiscard
38                         )
39 import VarEnv
40 import VarSet
41 import Module           ( Module )
42 import Name             ( mkLocalName, tidyOccName, tidyTopName, 
43                           NamedThing(..), OccName
44                         )
45 import TyCon            ( TyCon, isDataTyCon )
46 import PrimOp           ( PrimOp(..) )
47 import PrelInfo         ( unpackCStringId, unpackCString2Id, addr2IntegerId )
48 import Type             ( Type, splitAlgTyConApp_maybe, 
49                           isUnLiftedType,
50                           tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
51                           Type
52                         )
53 import TysWiredIn       ( smallIntegerDataCon, isIntegerTy )
54 import LiberateCase     ( liberateCase )
55 import SAT              ( doStaticArgs )
56 import Specialise       ( specProgram)
57 import UsageSPInf       ( doUsageSPInf )
58 import StrictAnal       ( saBinds )
59 import WorkWrap         ( wwTopBinds )
60 import CprAnalyse       ( cprAnalyse )
61
62 import Unique           ( Unique, Uniquable(..),
63                           ratioTyConKey
64                         )
65 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
66 import Constants        ( tARGET_MIN_INT, tARGET_MAX_INT )
67 import Util             ( mapAccumL )
68 import SrcLoc           ( noSrcLoc )
69 import Bag
70 import Maybes
71 import IO               ( hPutStr, stderr )
72 import Outputable
73
74 import Ratio            ( numerator, denominator )
75 \end{code}
76
77 %************************************************************************
78 %*                                                                      *
79 \subsection{The driver for the simplifier}
80 %*                                                                      *
81 %************************************************************************
82
83 \begin{code}
84 core2core :: [CoreToDo]         -- Spec of what core-to-core passes to do
85           -> [CoreBind]         -- Binds in
86           -> [ProtoCoreRule]    -- Rules
87           -> IO ([CoreBind], [ProtoCoreRule])
88
89 core2core core_todos binds rules
90   = do
91         us <-  mkSplitUniqSupply 's'
92         let (cp_us, us1)   = splitUniqSupply us
93             (ru_us, ps_us) = splitUniqSupply us1
94
95         better_rules <- simplRules ru_us rules binds
96
97         let (binds1, rule_base) = prepareRuleBase binds better_rules
98
99         -- Do the main business
100         (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1 
101                                                  rule_base core_todos
102
103         dumpIfSet opt_D_dump_simpl_stats
104                   "Grand total simplifier statistics"
105                   (pprSimplCount stats)
106
107         -- Do the post-simplification business
108         post_simpl_binds <- doPostSimplification ps_us processed_binds
109
110         -- Return results
111         return (post_simpl_binds, filter orphanRule better_rules)
112    
113
114 doCorePasses stats us binds irs []
115   = return (stats, binds)
116
117 doCorePasses stats us binds irs (to_do : to_dos) 
118   = do
119         let (us1, us2) =  splitUniqSupply us
120         (stats1, binds1) <- doCorePass us1 binds irs to_do
121         doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos
122
123 doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify"      simplifyPgm rb sw_chkr us binds
124 doCorePass us binds rb CoreCSE                  = _scc_ "CommonSubExpr" noStats (cseProgram binds)
125 doCorePass us binds rb CoreLiberateCase         = _scc_ "LiberateCase"  noStats (liberateCase binds)
126 doCorePass us binds rb CoreDoFloatInwards       = _scc_ "FloatInwards"  noStats (floatInwards binds)
127 doCorePass us binds rb CoreDoFullLaziness       = _scc_ "FloatOutwards" noStats (floatOutwards us binds)
128 doCorePass us binds rb CoreDoStaticArgs         = _scc_ "StaticArgs"    noStats (doStaticArgs us binds)
129 doCorePass us binds rb CoreDoStrictness         = _scc_ "Stranal"       noStats (saBinds binds)
130 doCorePass us binds rb CoreDoWorkerWrapper      = _scc_ "WorkWrap"      noStats (wwTopBinds us binds)
131 doCorePass us binds rb CoreDoSpecialising       = _scc_ "Specialise"    noStats (specProgram us binds)
132 doCorePass us binds rb CoreDoCPResult           = _scc_ "CPResult"      noStats (cprAnalyse binds)
133 doCorePass us binds rb CoreDoPrintCore          = _scc_ "PrintCore"     noStats (printCore binds)
134 doCorePass us binds rb CoreDoUSPInf
135   = _scc_ "CoreUsageSPInf" 
136     if opt_UsageSPOn then
137       noStats (doUsageSPInf us binds)
138     else
139       trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $
140       noStats (return binds)
141
142 printCore binds = do dumpIfSet True "Print Core"
143                                (pprCoreBindings binds)
144                      return binds
145
146 noStats thing = do { result <- thing; return (zeroSimplCount, result) }
147 \end{code}
148
149
150 %************************************************************************
151 %*                                                                      *
152 \subsection{Dealing with rules}
153 %*                                                                      *
154 %************************************************************************
155
156 We must do some gentle simplifiation on the template (but not the RHS)
157 of each rule.  The case that forced me to add this was the fold/build rule,
158 which without simplification looked like:
159         fold k z (build (/\a. g a))  ==>  ...
160 This doesn't match unless you do eta reduction on the build argument.
161
162 \begin{code}
163 simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]
164 simplRules us rules binds
165   = do  let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)
166         
167         dumpIfSet opt_D_dump_rules
168                   "Transformation rules"
169                   (vcat (map pprProtoCoreRule better_rules))
170
171         return better_rules
172   where
173     black_list_all v = True             -- This stops all inlining
174     sw_chkr any = SwBool False          -- A bit bogus
175
176         -- Boringly, we need to gather the in-scope set.
177         -- Typically this thunk won't even be force, but the test in
178         -- simpVar fails if it isn't right, and it might conceivably matter
179     bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
180
181
182 simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
183   | not is_local
184   = returnSmpl rule     -- No need to fiddle with imported rules
185   | otherwise
186   = simplBinders bndrs                  $ \ bndrs' -> 
187     mapSmpl simplExpr args              `thenSmpl` \ args' ->
188     simplExpr rhs                       `thenSmpl` \ rhs' ->
189     returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
190 \end{code}
191
192 %************************************************************************
193 %*                                                                      *
194 \subsection{The driver for the simplifier}
195 %*                                                                      *
196 %************************************************************************
197
198 \begin{code}
199 simplifyPgm :: RuleBase
200             -> (SimplifierSwitch -> SwitchResult)
201             -> UniqSupply
202             -> [CoreBind]                               -- Input
203             -> IO (SimplCount, [CoreBind])              -- New bindings
204
205 simplifyPgm (imported_rule_ids, rule_lhs_fvs) 
206             sw_chkr us binds
207   = do {
208         beginPass "Simplify";
209
210         -- Glom all binds together in one Rec, in case any
211         -- transformations have introduced any new dependencies
212         --
213         -- NB: the global invariant is this:
214         --      *** the top level bindings are never cloned, and are always unique ***
215         --
216         -- We sort them into dependency order, but applying transformation rules may
217         -- make something at the top refer to something at the bottom:
218         --      f = \x -> p (q x)
219         --      h = \y -> 3
220         --      
221         --      RULE:  p (q x) = h x
222         --
223         -- Applying this rule makes f refer to h, although it doesn't appear to in the
224         -- source program.  Our solution is to do this occasional glom-together step,
225         -- just once per overall simplfication step.
226
227         let { recd_binds = [Rec (flattenBinds binds)] };
228
229         (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;
230
231         dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)
232                   "Simplifier statistics"
233                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
234                          text "",
235                          pprSimplCount counts_out]);
236
237         endPass "Simplify" 
238                 (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
239                 binds' ;
240
241         return (counts_out, binds')
242     }
243   where
244     max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
245     black_list_fn  = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
246
247     core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
248                          | otherwise               = empty
249
250     iteration us iteration_no counts binds
251       = do {
252                 -- Occurrence analysis
253            let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
254
255            dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
256                      (pprCoreBindings tagged_binds);
257
258                 -- Simplify
259            let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids 
260                                               black_list_fn 
261                                               (simplTopBinds tagged_binds);
262                  all_counts        = counts `plusSimplCount` counts'
263                } ;
264
265                 -- Stop if nothing happened; don't dump output
266            if isZeroSimplCount counts' then
267                 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
268            else do {
269
270                 -- Dump the result of this iteration
271            dumpIfSet opt_D_dump_simpl_iterations
272                      ("Simplifier iteration " ++ show iteration_no 
273                       ++ " out of " ++ show max_iterations)
274                      (pprSimplCount counts') ;
275
276            if opt_D_dump_simpl_iterations then
277                 endPass ("Simplifier iteration " ++ show iteration_no ++ " result")
278                         opt_D_verbose_core2core
279                         binds'
280            else
281                 return [] ;
282
283                 -- Stop if we've run out of iterations
284            if iteration_no == max_iterations then
285                 do {
286                     if  max_iterations > 2 then
287                             hPutStr stderr ("NOTE: Simplifier still going after " ++ 
288                                     show max_iterations ++ 
289                                     " iterations; bailing out.\n")
290                     else return ();
291
292                     return ("Simplifier baled out", iteration_no, all_counts, binds')
293                 }
294
295                 -- Else loop
296            else iteration us2 (iteration_no + 1) all_counts binds'
297         }  }
298       where
299           (us1, us2) = splitUniqSupply us
300 \end{code}
301
302
303 %************************************************************************
304 %*                                                                      *
305 \subsection{PostSimplification}
306 %*                                                                      *
307 %************************************************************************
308
309 Several tasks are performed by the post-simplification pass
310
311 1.  Make the representation of NoRep literals explicit, and
312     float their bindings to the top level.  We only do the floating
313     part for NoRep lits inside a lambda (else no gain).  We need to
314     take care with      let x = "foo" in e
315     that we don't end up with a silly binding
316                         let x = y in e
317     with a floated "foo".  What a bore.
318     
319 4. Do eta reduction for lambda abstractions appearing in:
320         - the RHS of case alternatives
321         - the body of a let
322
323    These will otherwise turn into local bindings during Core->STG;
324    better to nuke them if possible.  (In general the simplifier does
325    eta expansion not eta reduction, up to this point.  It does eta
326    on the RHSs of bindings but not the RHSs of case alternatives and
327    let bodies)
328
329
330 ------------------- NOT DONE ANY MORE ------------------------
331 [March 98] Indirections are now elimianted by the occurrence analyser
332 1.  Eliminate indirections.  The point here is to transform
333         x_local = E
334         x_exported = x_local
335     ==>
336         x_exported = E
337
338 [Dec 98] [Not now done because there is no penalty in the code
339           generator for using the former form]
340 2.  Convert
341         case x of {...; x' -> ...x'...}
342     ==>
343         case x of {...; _  -> ...x... }
344     See notes in SimplCase.lhs, near simplDefault for the reasoning here.
345 --------------------------------------------------------------
346
347 Special case
348 ~~~~~~~~~~~~
349
350 NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
351 things, and we need local Ids for non-floated stuff):
352
353   Don't float stuff out of a binder that's marked as a bottoming Id.
354   Reason: it doesn't do any good, and creates more CAFs that increase
355   the size of SRTs.
356
357 eg.
358
359         f = error "string"
360
361 is translated to
362
363         f' = unpackCString# "string"
364         f = error f'
365
366 hence f' and f become CAFs.  Instead, the special case for
367 tidyTopBinding below makes sure this comes out as
368
369         f = let f' = unpackCString# "string" in error f'
370
371 and we can safely ignore f as a CAF, since it can only ever be entered once.
372
373
374
375 \begin{code}
376 doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
377 doPostSimplification us binds_in
378   = do
379         beginPass "Post-simplification pass"
380         let binds_out = initPM us (postSimplTopBinds binds_in)
381         endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
382
383 postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
384 postSimplTopBinds binds
385   = mapPM postSimplTopBind binds        `thenPM` \ binds' ->
386     returnPM (bagToList (unionManyBags binds'))
387
388 postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
389 postSimplTopBind (NonRec bndr rhs)
390   | isBottomingId bndr          -- Don't lift out floats for bottoming Ids
391                                 -- See notes above
392   = getFloatsPM (postSimplExpr rhs)     `thenPM` \ (rhs', floats) ->
393     returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
394
395 postSimplTopBind bind
396   = getFloatsPM (postSimplBind bind)    `thenPM` \ (bind', floats) ->
397     returnPM (floats `snocBag` bind')
398
399 postSimplBind (NonRec bndr rhs)
400   = postSimplExpr rhs           `thenPM` \ rhs' ->
401     returnPM (NonRec bndr rhs')
402
403 postSimplBind (Rec pairs)
404   = mapPM postSimplExpr rhss    `thenPM` \ rhss' ->
405     returnPM (Rec (bndrs `zip` rhss'))
406   where
407     (bndrs, rhss) = unzip pairs
408 \end{code}
409
410
411 Expressions
412 ~~~~~~~~~~~
413 \begin{code}
414 postSimplExpr (Var v)   = returnPM (Var v)
415 postSimplExpr (Type ty) = returnPM (Type ty)
416
417 postSimplExpr (App fun arg)
418   = postSimplExpr fun   `thenPM` \ fun' ->
419     postSimplExpr arg   `thenPM` \ arg' ->
420     returnPM (App fun' arg')
421
422 postSimplExpr (Con (Literal lit) args)
423   = ASSERT( null args )
424     litToRep lit        `thenPM` \ (lit_ty, lit_expr) ->
425     getInsideLambda     `thenPM` \ in_lam ->
426     if in_lam && not (exprIsTrivial lit_expr) then
427         -- It must have been a no-rep literal with a
428         -- non-trivial representation; and we're inside a lambda;
429         -- so float it to the top
430         addTopFloat lit_ty lit_expr     `thenPM` \ v ->
431         returnPM (Var v)
432     else
433         returnPM lit_expr
434
435 postSimplExpr (Con con args)
436   = mapPM postSimplExpr args    `thenPM` \ args' ->
437     returnPM (Con con args')
438
439 postSimplExpr (Lam bndr body)
440   = insideLambda bndr           $
441     postSimplExpr body          `thenPM` \ body' ->
442     returnPM (Lam bndr body')
443
444 postSimplExpr (Let bind body)
445   = postSimplBind bind          `thenPM` \ bind' ->
446     postSimplExprEta body       `thenPM` \ body' ->
447     returnPM (Let bind' body')
448
449 postSimplExpr (Note note body)
450   = postSimplExprEta body       `thenPM` \ body' ->
451     returnPM (Note note body')
452
453 postSimplExpr (Case scrut case_bndr alts)
454   = postSimplExpr scrut                 `thenPM` \ scrut' ->
455     mapPM ps_alt alts                   `thenPM` \ alts' ->
456     returnPM (Case scrut' case_bndr alts')
457   where
458     ps_alt (con,bndrs,rhs) = postSimplExprEta rhs       `thenPM` \ rhs' ->
459                              returnPM (con, bndrs, rhs')
460
461 postSimplExprEta e = postSimplExpr e    `thenPM` \ e' ->
462                      returnPM (etaCoreExpr e')
463 \end{code}
464
465
466 %************************************************************************
467 %*                                                                      *
468 \subsection[coreToStg-lits]{Converting literals}
469 %*                                                                      *
470 %************************************************************************
471
472 Literals: the NoRep kind need to be de-no-rep'd.
473 We always replace them with a simple variable, and float a suitable
474 binding out to the top level.
475
476 \begin{code}
477 litToRep :: Literal -> PostM (Type, CoreExpr)
478
479 litToRep (NoRepStr s ty)
480   = returnPM (ty, rhs)
481   where
482     rhs = if (any is_NUL (_UNPK_ s))
483
484           then   -- Must cater for NULs in literal string
485                 mkApps (Var unpackCString2Id)
486                        [mkLit (MachStr s),
487                         mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
488
489           else  -- No NULs in the string
490                 App (Var unpackCStringId) (mkLit (MachStr s))
491
492     is_NUL c = c == '\0'
493 \end{code}
494
495 If an Integer is small enough (Haskell implementations must support
496 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
497 otherwise, wrap with @addr2Integer@.
498
499 \begin{code}
500 litToRep (NoRepInteger i integer_ty)
501   = returnPM (integer_ty, rhs)
502   where
503     rhs | i > tARGET_MIN_INT &&         -- Small enough, so start from an Int
504           i < tARGET_MAX_INT
505         = Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]
506   
507         | otherwise                     -- Big, so start from a string
508         = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
509
510
511 litToRep (NoRepRational r rational_ty)
512   = postSimplExpr (mkLit (NoRepInteger (numerator   r) integer_ty))     `thenPM` \ num_arg ->
513     postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty))     `thenPM` \ denom_arg ->
514     returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
515   where
516     (ratio_data_con, integer_ty)
517       = case (splitAlgTyConApp_maybe rational_ty) of
518           Just (tycon, [i_ty], [con])
519             -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
520                (con, i_ty)
521
522           _ -> (panic "ratio_data_con", panic "integer_ty")
523
524 litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
525 \end{code}
526
527
528 %************************************************************************
529 %*                                                                      *
530 \subsection{The monad}
531 %*                                                                      *
532 %************************************************************************
533
534 \begin{code}
535 type PostM a =  Bool                            -- True <=> inside a *value* lambda
536              -> (UniqSupply, Bag CoreBind)      -- Unique supply and Floats in 
537              -> (a, (UniqSupply, Bag CoreBind))
538
539 initPM :: UniqSupply -> PostM a -> a
540 initPM us m
541   = case m False {- not inside lambda -} (us, emptyBag) of 
542         (result, _) -> result
543
544 returnPM v in_lam usf = (v, usf)
545 thenPM m k in_lam usf = case m in_lam usf of
546                                   (r, usf') -> k r in_lam usf'
547
548 mapPM f []     = returnPM []
549 mapPM f (x:xs) = f x            `thenPM` \ r ->
550                  mapPM f xs     `thenPM` \ rs ->
551                  returnPM (r:rs)
552
553 insideLambda :: CoreBndr -> PostM a -> PostM a
554 insideLambda bndr m in_lam usf | isId bndr = m True   usf
555                                | otherwise = m in_lam usf
556
557 getInsideLambda :: PostM Bool
558 getInsideLambda in_lam usf = (in_lam, usf)
559
560 getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
561 getFloatsPM m in_lam (us, floats)
562   = let
563         (a, (us', floats')) = m in_lam (us, emptyBag)
564     in
565     ((a, floats'), (us', floats))
566
567 addTopFloat :: Type -> CoreExpr -> PostM Id
568 addTopFloat lit_ty lit_rhs in_lam (us, floats)
569   = let
570         (us1, us2) = splitUniqSupply us
571         uniq       = uniqFromSupply us1
572         lit_id     = mkSysLocal SLIT("lf") uniq lit_ty
573     in
574     (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))
575 \end{code}
576
577