)
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 )
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 )
-> 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)
-- 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
[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)
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
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}