X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplCore.lhs;h=b419461c031f5a1bb4e6f181701d358a7a3d2c0c;hb=0fa64bb9f9c587021529c64e28396ae08398555b;hp=bcfbbfa4931904a4ba20e63dd857e6c9945ea268;hpb=82f63df94dafed10f51f158ab531d52da97c2c86;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index bcfbbfa..b419461 100644 --- 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, 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,14 +206,21 @@ 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) + (mapSmpl simplRule 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 #-} - ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules" - (vcat (map pprIdCoreRule better_rules)) - - ; let (local_rules, orphan_rules) = partition (isLocalId . fst) better_rules 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 @@ -217,6 +228,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 @@ -228,8 +245,6 @@ prepareRules dflags pkg_rule_base hst us binds rules 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 @@ -267,11 +282,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}