[project @ 2001-04-26 13:52:57 by simonmar]

[ghc-hetmet.git] / ghc / compiler / simplCore / SimplCore.lhs

diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index bcfbbfa..7197e77 100644 (file)
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -20,10 +20,10 @@ import HscTypes             ( PersistentCompilerState(..),
                        )
 import CSE             ( cseProgram )
 import Rules           ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds, 
-                         extendRuleBaseList, addRuleBaseFVs )
+                         extendRuleBaseList, addRuleBaseFVs, pprRuleBase )
 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 )
@@ -32,11 +32,12 @@ import SimplMonad
 import ErrUtils                ( dumpIfSet, dumpIfSet_dyn )
 import FloatIn         ( floatInwards )
 import FloatOut                ( floatOutwards )
-import Id              ( idName, isDataConWrapId, setIdNoDiscard, isLocalId )
+import Id              ( idName, isDataConWrapId, setIdNoDiscard, isLocalId, isImplicitId )
 import VarSet
 import LiberateCase    ( liberateCase )
 import SAT             ( doStaticArgs )
 import Specialise      ( specProgram)
+import SpecConstr      ( specConstrProgram)
 import UsageSPInf       ( doUsageSPInf )
 import StrictAnal      ( saBinds )
 import WorkWrap                ( wwTopBinds )
@@ -61,24 +62,25 @@ core2core :: DynFlags               -- includes spec of what core-to-core passes to do
          -> PersistentCompilerState
          -> HomeSymbolTable
          -> IsExported
-         -> [CoreBind]         -- Binds in
-         -> [IdCoreRule]       -- Rules defined in this module
-         -> 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_ids, orphan_rules, rule_rhs_fvs)
-               <- prepareRules dflags pkg_rule_base hst ru_us binds rules
+               <- prepareRules dflags pkg_rule_base hst ru_us binds_in rules_in
 
                -- PREPARE THE BINDINGS
-       let binds1 = updateBinders local_rule_ids rule_rhs_fvs 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,7 +109,7 @@ simplifyExpr dflags pcs hst expr
 
        ; us <-  mkSplitUniqSupply 's'
 
-       ; let (expr', _counts) = initSmpl dflags sw_chkr us emptyVarSet black_list_all  
+       ; let (expr', _counts) = initSmpl dflags sw_chkr us emptyVarSet black_list_nothing      
                                          (simplExprGently expr)
 
        ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
@@ -116,8 +118,8 @@ simplifyExpr dflags pcs hst expr
        ; return expr'
        }
   where
-    sw_chkr any             = SwBool False     -- A bit bogus
-    black_list_all v = True            -- Black list everything
+    sw_chkr any                 = SwBool False -- A bit bogus
+    black_list_nothing v = False       -- Black list nothing
 
 
 doCorePasses :: DynFlags
@@ -157,6 +159,8 @@ 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             
@@ -202,12 +206,9 @@ prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable
                    [IdCoreRule],       -- Orphan rules
                    IdSet)              -- RHS free vars of all rules
 
-prepareRules dflags pkg_rule_base hst us binds rules
+prepareRules dflags pkg_rule_base hst us binds local_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))
+                                         (mapSmpl simplRule local_rules)
 
        ; let (local_rules, orphan_rules) = partition (isLocalId . fst) better_rules
              rule_rhs_fvs                = unionVarSets (map (ruleRhsFreeVars . snd) better_rules)
@@ -217,6 +218,12 @@ prepareRules dflags pkg_rule_base hst us binds rules
              rule_base                   = extendRuleBaseList imp_rule_base orphan_rules
              final_rule_base             = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base)
                -- The last step black-lists the free vars of local rules too
+
+       ; 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
@@ -267,11 +274,16 @@ updateBinders rule_ids rule_rhs_fvs is_exported binds
     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 setIdNoDiscard
+                                       -- Also can't have rules
+       | dont_discard bndr = setIdNoDiscard 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}