[project @ 2001-09-26 16:19:28 by simonpj]
[ghc-hetmet.git] / ghc / compiler / simplCore / SimplCore.lhs
index 76dbd65..7d3c04a 100644 (file)
@@ -8,11 +8,9 @@ module SimplCore ( core2core, simplifyExpr ) where
 
 #include "HsVersions.h"
 
-import CmdLineOpts     ( CoreToDo(..), SimplifierSwitch(..), 
-                         SwitchResult(..), intSwitchSet,
+import CmdLineOpts     ( CoreToDo(..), SimplifierSwitch(..), SimplifierMode(..),
                          DynFlags, DynFlag(..), dopt, dopt_CoreToDo
                        )
-import CoreLint                ( showPass, endPass )
 import CoreSyn
 import CoreFVs         ( ruleRhsFreeVars )
 import HscTypes                ( PersistentCompilerState(..),
@@ -20,25 +18,28 @@ import HscTypes             ( PersistentCompilerState(..),
                        )
 import CSE             ( cseProgram )
 import Rules           ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds, 
-                         extendRuleBaseList, addRuleBaseFVs )
+                         extendRuleBaseList, addRuleBaseFVs, pprRuleBase, 
+                         ruleCheckProgram )
 import Module          ( moduleEnvElts )
-import CoreUnfold
-import PprCore         ( pprCoreBindings, pprIdCoreRule, pprCoreExpr )
+import PprCore         ( pprCoreBindings, pprCoreExpr )
 import OccurAnal       ( occurAnalyseBinds, occurAnalyseGlobalExpr )
 import CoreUtils       ( coreBindsSize )
 import Simplify                ( simplTopBinds, simplExpr )
 import SimplUtils      ( simplBinders )
 import SimplMonad
-import ErrUtils                ( dumpIfSet, dumpIfSet_dyn )
+import ErrUtils                ( dumpIfSet, dumpIfSet_dyn, showPass )
+import CoreLint                ( endPass )
 import FloatIn         ( floatInwards )
 import FloatOut                ( floatOutwards )
-import Id              ( idName, isDataConWrapId, setIdNoDiscard, isLocalId )
+import Id              ( idName, setIdLocalExported, isImplicitId )
 import VarSet
 import LiberateCase    ( liberateCase )
 import SAT             ( doStaticArgs )
 import Specialise      ( specProgram)
+import SpecConstr      ( specConstrProgram)
 import UsageSPInf       ( doUsageSPInf )
 import StrictAnal      ( saBinds )
+import DmdAnal         ( dmdAnalPgm )
 import WorkWrap                ( wwTopBinds )
 import CprAnalyse       ( cprAnalyse )
 
@@ -61,24 +62,25 @@ core2core :: DynFlags               -- includes spec of what core-to-core passes to do
          -> PersistentCompilerState
          -> HomeSymbolTable
          -> IsExported
-         -> [CoreBind]         -- Binds in
-         -> [IdCoreRule]       -- Rules in
-         -> IO ([CoreBind], [IdCoreRule])  -- binds, local orphan rules out
+         -> ModDetails
+         -> IO ModDetails
 
-core2core dflags pcs hst is_exported binds rules
+core2core dflags pcs hst is_exported 
+         mod_details@(ModDetails { md_binds = binds_in, md_rules = rules_in })
   = do
         let core_todos    = dopt_CoreToDo dflags
        let pkg_rule_base = pcs_rules pcs               -- Rule-base accumulated from imported packages
+       
 
        us <-  mkSplitUniqSupply 's'
        let (cp_us, ru_us) = splitUniqSupply us
 
                -- COMPUTE THE RULE BASE TO USE
-       (rule_base, local_rule_stuff, orphan_rules)
-               <- prepareRules dflags pkg_rule_base hst ru_us binds rules
+       (rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
+               <- prepareRules dflags pkg_rule_base hst ru_us binds_in rules_in
 
                -- PREPARE THE BINDINGS
-       let binds1 = updateBinders local_rule_stuff is_exported binds
+       let binds1 = updateBinders local_rule_ids rule_rhs_fvs is_exported binds_in
 
                -- DO THE BUSINESS
        (stats, processed_binds)
@@ -91,7 +93,7 @@ core2core dflags pcs hst is_exported binds rules
        -- Return results
         -- We only return local orphan rules, i.e., local rules not attached to an Id
        -- The bindings cotain more rules, embedded in the Ids
-       return (processed_binds, orphan_rules)
+       return (mod_details { md_binds = processed_binds, md_rules = orphan_rules})
 
 
 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
@@ -107,17 +109,14 @@ simplifyExpr dflags pcs hst expr
 
        ; us <-  mkSplitUniqSupply 's'
 
-       ; let (expr', _counts) = initSmpl dflags sw_chkr us emptyVarSet black_list_all  
-                                         (simplExprGently expr)
+       ; let env              = emptySimplEnv (SimplPhase 0) [] emptyVarSet
+             (expr', _counts) = initSmpl dflags us (simplExprGently env expr)
 
        ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
                        (pprCoreExpr expr')
 
        ; return expr'
        }
-  where
-    sw_chkr any             = SwBool False     -- A bit bogus
-    black_list_all v = True            -- Black list everything
 
 
 doCorePasses :: DynFlags
@@ -139,8 +138,8 @@ doCorePasses dflags rb stats us binds (to_do : to_dos)
 
        doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
 
-doCorePass dfs rb us binds (CoreDoSimplify sw_chkr) 
-   = _scc_ "Simplify"      simplifyPgm dfs rb sw_chkr us binds
+doCorePass dfs rb us binds (CoreDoSimplify mode switches) 
+   = _scc_ "Simplify"      simplifyPgm dfs rb mode switches us binds
 doCorePass dfs rb us binds CoreCSE                     
    = _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds)
 doCorePass dfs rb us binds CoreLiberateCase            
@@ -152,11 +151,14 @@ doCorePass dfs rb us binds (CoreDoFloatOutwards f)
 doCorePass dfs rb us binds CoreDoStaticArgs            
    = _scc_ "StaticArgs"    noStats dfs (doStaticArgs us binds)
 doCorePass dfs rb us binds CoreDoStrictness            
-   = _scc_ "Stranal"       noStats dfs (saBinds dfs binds)
+   = _scc_ "Stranal"       noStats dfs (do { binds1 <- saBinds dfs binds ;
+                                            dmdAnalPgm dfs binds1 })
 doCorePass dfs rb us binds CoreDoWorkerWrapper      
    = _scc_ "WorkWrap"      noStats dfs (wwTopBinds dfs us binds)
 doCorePass dfs rb us binds CoreDoSpecialising       
    = _scc_ "Specialise"    noStats dfs (specProgram dfs us binds)
+doCorePass dfs rb us binds CoreDoSpecConstr
+   = _scc_ "SpecConstr"    noStats dfs (specConstrProgram dfs us binds)
 doCorePass dfs rb us binds CoreDoCPResult              
    = _scc_ "CPResult"      noStats dfs (cprAnalyse dfs binds)
 doCorePass dfs rb us binds CoreDoPrintCore             
@@ -165,6 +167,8 @@ doCorePass dfs rb us binds CoreDoUSPInf
    = _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds)
 doCorePass dfs rb us binds CoreDoGlomBinds             
    = noStats dfs (glomBinds dfs binds)
+doCorePass dfs rb us binds (CoreDoRuleCheck phase pat)
+   = noStats dfs (ruleCheck dfs phase pat binds)
 doCorePass dfs rb us binds CoreDoNothing
    = noStats dfs (return binds)
 
@@ -172,8 +176,13 @@ printCore binds = do dumpIfSet True "Print Core"
                               (pprCoreBindings binds)
                     return binds
 
+ruleCheck dflags phase pat binds = do showPass dflags "RuleCheck"
+                                     printDump (ruleCheckProgram phase pat binds)
+                                     return binds
+
 -- most passes return no stats and don't change rules
 noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) }
+
 \end{code}
 
 
@@ -198,18 +207,26 @@ prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable
             -> [CoreBind]
             -> [IdCoreRule]            -- Local rules
             -> IO (RuleBase,           -- Full rule base
-                   (IdSet,IdSet),      -- Local rule Ids, and RHS fvs
-                   [IdCoreRule])       -- Orphan rules
-
-prepareRules dflags pkg_rule_base hst us binds rules
-  = do { let (better_rules,_) = initSmpl dflags sw_chkr us local_ids black_list_all 
-                                         (mapSmpl simplRule rules)
-
-       ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
-                       (vcat (map pprIdCoreRule better_rules))
-
-       ; let (local_rules, orphan_rules) = partition (isLocalId . fst) better_rules
-             local_rule_rhs_fvs          = unionVarSets (map (ruleRhsFreeVars . snd) local_rules)
+                   IdSet,              -- Local rule Ids
+                   [IdCoreRule],       -- Orphan rules
+                   IdSet)              -- RHS free vars of all rules
+
+prepareRules dflags pkg_rule_base hst us binds local_rules
+  = do { let env              = emptySimplEnv SimplGently [] local_ids 
+             (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
+
+       ; let (local_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules
+               -- We use (`elemVarSet` local_ids) rather than isLocalId because
+               -- isLocalId isn't true of class methods.
+               -- 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 the
+               -- same as the rule-id set), 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 #-}
+
+             rule_rhs_fvs                = unionVarSets (map (ruleRhsFreeVars . snd) better_rules)
              local_rule_base             = extendRuleBaseList emptyRuleBase local_rules
              local_rule_ids              = ruleBaseIds local_rule_base -- Local Ids with rules attached
              imp_rule_base               = foldl add_rules pkg_rule_base (moduleEnvElts hst)
@@ -217,24 +234,22 @@ prepareRules dflags pkg_rule_base hst us binds rules
              final_rule_base             = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base)
                -- The last step black-lists the free vars of local rules too
 
-       ; return (final_rule_base, (local_rule_ids, local_rule_rhs_fvs), orphan_rules)
+       ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
+               (vcat [text "Local rules", pprRuleBase local_rule_base,
+                      text "",
+                      text "Imported rules", pprRuleBase final_rule_base])
+
+       ; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
     }
   where
-    sw_chkr any             = SwBool False                     -- A bit bogus
-    black_list_all v = not (isDataConWrapId v)
-               -- This stops all inlining except the
-               -- wrappers for data constructors
-
     add_rules rule_base mds = extendRuleBaseList rule_base (md_rules mds)
 
        -- Boringly, we need to gather the in-scope set.
-       -- Typically this thunk won't even be forced, but the test in
-       -- simpVar fails if it isn't right, and it might conceiveably matter
     local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
 
 
-updateBinders :: (IdSet,               -- Locally defined ids with their Rules attached
-                 IdSet)                -- Ids free in the RHS of local rules
+updateBinders :: IdSet                 -- Locally defined ids with their Rules attached
+             -> IdSet                  -- Ids free in the RHS of local rules
              -> IsExported
              -> [CoreBind] -> [CoreBind]
        -- A horrible function
@@ -260,18 +275,23 @@ updateBinders :: (IdSet,          -- Locally defined ids with their Rules attached
 --     the rules (maybe we should?), so this substitution would make the rule
 --     bogus.
 
-updateBinders (rule_ids, rule_rhs_fvs) is_exported binds
+updateBinders rule_ids rule_rhs_fvs is_exported binds
   = map update_bndrs binds
   where
     update_bndrs (NonRec b r) = NonRec (update_bndr b) r
     update_bndrs (Rec prs)    = Rec [(update_bndr b, r) | (b,r) <- prs]
 
     update_bndr bndr 
-       |  is_exported (idName bndr)
-       || bndr `elemVarSet` rule_rhs_fvs = setIdNoDiscard bndr'
-       | otherwise                       = bndr'
+       | isImplicitId bndr = bndr      -- Constructors, selectors; doesn't 
+                                       -- make sense to call setIdLocalExported
+                                       -- Also can't have rules
+       | dont_discard bndr = setIdLocalExported bndr_with_rules
+       | otherwise         = bndr_with_rules
        where
-         bndr' = lookupVarSet rule_ids bndr `orElse` bndr
+         bndr_with_rules = lookupVarSet rule_ids bndr `orElse` bndr
+
+    dont_discard bndr =  is_exported (idName bndr)
+                     || bndr `elemVarSet` rule_rhs_fvs 
 \end{code}
 
 
@@ -282,13 +302,13 @@ which without simplification looked like:
 This doesn't match unless you do eta reduction on the build argument.
 
 \begin{code}
-simplRule rule@(id, BuiltinRule _)
+simplRule env rule@(id, BuiltinRule _ _)
   = returnSmpl rule
-simplRule rule@(id, Rule name bndrs args rhs)
-  = simplBinders bndrs                 $ \ bndrs' -> 
-    mapSmpl simplExprGently args       `thenSmpl` \ args' ->
-    simplExprGently rhs                        `thenSmpl` \ rhs' ->
-    returnSmpl (id, Rule name bndrs' args' rhs')
+simplRule env rule@(id, Rule act name bndrs args rhs)
+  = simplBinders env bndrs             `thenSmpl` \ (env, bndrs') -> 
+    mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
+    simplExprGently env rhs            `thenSmpl` \ rhs' ->
+    returnSmpl (id, Rule act name bndrs' args' rhs')
 
 -- It's important that simplExprGently does eta reduction.
 -- For example, in a rule like:
@@ -303,16 +323,16 @@ simplRule rule@(id, Rule name bndrs args rhs)
 \end{code}
 
 \begin{code}
-simplExprGently :: CoreExpr -> SimplM CoreExpr
+simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 -- 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
-simplExprGently expr
-  = simplExpr (occurAnalyseGlobalExpr expr)    `thenSmpl` \ expr1 ->
-    simplExpr (occurAnalyseGlobalExpr expr1)
+simplExprGently env expr
+  = simplExpr env (occurAnalyseGlobalExpr expr)        `thenSmpl` \ expr1 ->
+    simplExpr env (occurAnalyseGlobalExpr expr1)
 \end{code}
 
 
@@ -367,13 +387,14 @@ glomBinds dflags binds
 \begin{code}
 simplifyPgm :: DynFlags 
            -> RuleBase
-           -> (SimplifierSwitch -> SwitchResult)
+           -> SimplifierMode
+           -> [SimplifierSwitch]
            -> UniqSupply
            -> [CoreBind]                   -- Input
            -> IO (SimplCount, [CoreBind])  -- New bindings
 
 simplifyPgm dflags rule_base
-           sw_chkr us binds
+           mode switches us binds
   = do {
        showPass dflags "Simplify";
 
@@ -392,10 +413,14 @@ simplifyPgm dflags rule_base
        return (counts_out, binds')
     }
   where
-    max_iterations    = getSimplIntSwitch sw_chkr MaxSimplifierIterations
-    black_list_fn     = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
+    phase_info       = case mode of
+                         SimplGently  -> "gentle"
+                         SimplPhase n -> show n
+
     imported_rule_ids = ruleBaseIds rule_base
-    rule_lhs_fvs      = ruleBaseFVs rule_base
+    simpl_env        = emptySimplEnv mode switches imported_rule_ids
+    sw_chkr          = getSwitchChecker simpl_env
+    max_iterations    = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
  
     iteration us iteration_no counts binds
       -- Try and force thunks off the binds; significantly reduces
@@ -419,15 +444,18 @@ simplifyPgm dflags rule_base
                --      case t of {(_,counts') -> if counts'=0 then ...
                -- So the conditional didn't force counts', because the
                -- selection got duplicated.  Sigh!
-          case initSmpl dflags sw_chkr us1 imported_rule_ids black_list_fn 
-                        (simplTopBinds tagged_binds)
-               of { (binds', counts') -> do {
+          case initSmpl dflags us1 (simplTopBinds simpl_env tagged_binds) of {
+               (binds', counts') -> do {
                        -- The imported_rule_ids are used by initSmpl 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.
 
-          let { all_counts = counts `plusSimplCount` counts' } ;
+          let { all_counts = counts `plusSimplCount` counts' ;
+                herald     = "Simplifier phase " ++ phase_info ++ 
+                             ", iteration " ++ show iteration_no ++
+                             " out of " ++ show max_iterations
+               } ;
 
                -- Stop if nothing happened; don't dump output
           if isZeroSimplCount counts' then
@@ -435,15 +463,10 @@ simplifyPgm dflags rule_base
           else do {
 
                -- Dump the result of this iteration
-          dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations
-                    ("Simplifier iteration " ++ show iteration_no 
-                     ++ " out of " ++ show max_iterations)
+          dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
                     (pprSimplCount counts') ;
 
-          endPass dflags 
-                    ("Simplifier iteration " ++ show iteration_no ++ " result")
-                   Opt_D_dump_simpl_iterations
-                   binds' ;
+          endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
 
                -- Stop if we've run out of iterations
           if iteration_no == max_iterations then