From 243dedb8741d13162fe944ebf2adace921e0108d Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 25 Oct 2000 13:51:52 +0000 Subject: [PATCH] [project @ 2000-10-25 13:51:50 by simonpj] Wibbles --- ghc/compiler/basicTypes/Module.lhs | 6 +- ghc/compiler/codeGen/CodeGen.lhs | 10 +-- ghc/compiler/coreSyn/CoreTidy.lhs | 8 +- ghc/compiler/deSugar/Desugar.lhs | 1 + ghc/compiler/main/HscTypes.lhs | 7 +- ghc/compiler/main/MkIface.lhs | 145 ++++++++++++++++++-------------- ghc/compiler/simplCore/FloatIn.lhs | 2 +- ghc/compiler/simplCore/FloatOut.lhs | 4 +- ghc/compiler/simplCore/SimplCore.lhs | 52 +++++++----- ghc/compiler/simplCore/SimplMonad.lhs | 3 +- ghc/compiler/simplCore/SimplUtils.lhs | 19 ++--- ghc/compiler/simplCore/Simplify.lhs | 11 ++- ghc/compiler/specialise/Rules.lhs | 9 +- ghc/compiler/specialise/Specialise.lhs | 25 ++---- 14 files changed, 160 insertions(+), 142 deletions(-) diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index e689c97..fa073be 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -56,7 +56,7 @@ module Module , elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv - , rngModuleEnv, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv + , moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv , lookupModuleEnvByName, extendModuleEnv_C ) where @@ -275,7 +275,7 @@ delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b -rngModuleEnv :: ModuleEnv a -> [a] +moduleEnvElts :: ModuleEnv a -> [a] isEmptyModuleEnv :: ModuleEnv a -> Bool lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a @@ -298,7 +298,7 @@ lookupWithDefaultModuleEnv = lookupWithDefaultUFM mapModuleEnv = mapUFM mkModuleEnv = listToUFM emptyModuleEnv = emptyUFM -rngModuleEnv = eltsUFM +moduleEnvElts = eltsUFM unitModuleEnv = unitUFM isEmptyModuleEnv = isNullUFM foldModuleEnv = foldUFM diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index e707cb0..90bc8f9 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -22,8 +22,7 @@ module CodeGen ( codeGen ) where import StgSyn import CgMonad import AbsCSyn -import CLabel ( CLabel, mkSRTLabel, mkClosureLabel, - mkModuleInitLabel, labelDynamic ) +import CLabel ( CLabel, mkSRTLabel, mkClosureLabel, mkModuleInitLabel ) import PprAbsC ( dumpRealC ) import AbsCUtils ( mkAbstractCs, flattenAbsC ) @@ -36,16 +35,13 @@ import CmdLineOpts ( DynFlags, DynFlag(..), opt_SccProfilingOn, opt_EnsureSplittableC ) import CostCentre ( CostCentre, CostCentreStack ) import Id ( Id, idName ) -import Module ( Module, moduleString, moduleName, - ModuleName ) -import PrimRep ( getPrimRepSize, PrimRep(..) ) -import Type ( Type ) +import Module ( Module ) +import PrimRep ( PrimRep(..) ) import TyCon ( TyCon, isDataTyCon ) import Class ( Class, classTyCon ) import BasicTypes ( TopLevelFlag(..) ) import UniqSupply ( mkSplitUniqSupply ) import ErrUtils ( dumpIfSet_dyn ) -import Util import Panic ( assertPanic ) \end{code} diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index e81a8bf..7335d3a 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -19,7 +19,7 @@ import UsageSPInf ( doUsageSPInf ) import VarEnv import VarSet import Var ( Id, Var ) -import Id ( idType, idInfo, idName, idSpecialisation, +import Id ( idType, idInfo, idName, mkVanillaId, mkId, exportWithOrigOccName, idStrictness, setIdStrictness, idDemandInfo, setIdDemandInfo, @@ -29,9 +29,9 @@ import IdInfo ( specInfo, setSpecInfo, workerInfo, setWorkerInfo, WorkerInfo(..) ) import Demand ( wwLazy ) -import Name ( getOccName, tidyTopName, mkLocalName, isLocallyDefined ) +import Name ( getOccName, tidyTopName, mkLocalName ) import OccName ( initTidyOccEnv, tidyOccName ) -import Type ( tidyTopType, tidyType, tidyTypes, tidyTyVar, tidyTyVars ) +import Type ( tidyTopType, tidyType, tidyTyVar ) import Module ( Module ) import UniqSupply ( mkSplitUniqSupply ) import Unique ( Uniquable(..) ) @@ -76,7 +76,7 @@ tidyCorePgm dflags module_name binds_in orphans_in binds_in1 <- if opt_UsageSPOn then _scc_ "CoreUsageSPInf" - doUsageSPInf dflags us binds_in rulebase_in + doUsageSPInf dflags us binds_in else return binds_in let (tidy_env1, binds_out) = mapAccumL (tidyBind (Just module_name)) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index d486059..70bec84 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -13,6 +13,7 @@ import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) ) import TcHsSyn ( TypecheckedRuleDecl ) import TcModule ( TcResults(..) ) +import Id ( Id ) import CoreSyn import PprCore ( pprIdCoreRule ) import Subst ( substExpr, mkSubst, mkInScopeSet ) diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 65669d8..9150218 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -16,7 +16,7 @@ module HscTypes ( VersionInfo(..), initialVersionInfo, - TyThing(..), groupTyThings, + TyThing(..), groupTyThings, isTyClThing, TypeEnv, extendTypeEnv, lookupTypeEnv, @@ -215,6 +215,11 @@ data TyThing = AnId Id | ATyCon TyCon | AClass Class +isTyClThing :: TyThing -> Bool +isTyClThing (ATyCon _) = True +isTyClThing (AClass _) = True +isTyClThing (AnId _) = False + instance NamedThing TyThing where getName (AnId id) = getName id getName (ATyCon tc) = getName tc diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 7b1123c..128bcf7 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -4,42 +4,43 @@ \section[MkIface]{Print an interface for a module} \begin{code} -module MkIface ( completeIface ) where +module MkIface ( + mkModDetails, mkModDetailsFromIface, completeIface + ) where #include "HsVersions.h" import HsSyn -import HsCore ( HsIdInfo(..), toUfExpr, ifaceSigName ) +import HsCore ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr ) import HsTypes ( toHsTyVars ) import BasicTypes ( Fixity(..), NewOrData(..), Version, bumpVersion, isLoopBreaker ) import RnMonad -import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedIfaceSig ) +import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl ) +import TcHsSyn ( TypecheckedRuleDecl ) import HscTypes ( VersionInfo(..), IfaceDecls(..), ModIface(..), ModDetails(..), - TyThing(..), DFunId ) + TyThing(..), DFunId, TypeEnv, isTyClThing + ) import CmdLineOpts import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding, - idSpecialisation + idSpecialisation, idName, setIdInfo ) import Var ( isId ) import VarSet import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks ) -import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..), - CprInfo(..), CafInfo(..), - inlinePragInfo, arityInfo, arityLowerBound, - strictnessInfo, isBottomingStrictness, - cafInfo, specInfo, cprInfo, - occInfo, isNeverInlinePrag, - workerInfo, WorkerInfo(..) +import IdInfo -- Lots +import CoreSyn ( CoreExpr, CoreBind, Bind(..), CoreRule(..), IdCoreRule, + isBuiltinRule, rulesRules, rulesRhsFreeVars, emptyCoreRules, + bindersOfBinds ) -import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars ) import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars ) -import CoreUnfold ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold ) -import Name ( isLocallyDefined, getName, nameModule, +import CoreUnfold ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold, unfoldingTemplate, noUnfolding ) +import Name ( isLocallyDefined, getName, Name, NamedThing(..), - plusNameEnv, lookupNameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv_NF, nameEnvElts + plusNameEnv, lookupNameEnv, emptyNameEnv, mkNameEnv, + extendNameEnv, lookupNameEnv_NF, nameEnvElts ) import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize @@ -47,13 +48,7 @@ import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, import Class ( classExtraBigSig, DefMeth(..) ) import FieldLabel ( fieldLabelType ) import Type ( splitSigmaTy, tidyTopType, deNoteType ) - -import Rules ( ProtoCoreRule(..) ) - -import Bag ( bagToList ) -import UniqFM ( lookupUFM, listToUFM ) import SrcLoc ( noSrcLoc ) -import Bag import Outputable import List ( partition ) @@ -67,27 +62,52 @@ import List ( partition ) %************************************************************************ \begin{code} -completeModDetails :: ModDetails - -> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the - -- code generator; they have authoritative arity info - -> [IdCoreRule] -- Tidy orphan rules - -> ModDetails -completeModDetails mds tidy_binds stg_ids orphan_rules - = ModDetails { - +mkModDetails :: TypeEnv -> [DFunId] -- From typechecker + -> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the + -- code generator; they have authoritative arity info + -> [IdCoreRule] -- Tidy orphan rules + -> ModDetails +mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules + = ModDetails { md_types = new_type_env, + md_rules = rule_dcls, + md_insts = dfun_ids } where - dfun_ids = md_insts mds - + -- The competed type environment is gotten from + -- a) keeping the types and classes + -- b) removing all Ids, and Ids with correct IdInfo + -- gotten from the bindings + new_type_env = mkNameEnv [(getName tycl, tycl) | tycl <- orig_type_env, isTyClThing tycl] + `plusNameEnv` + mkNameEnv [(idName id, AnId id) | id <- final_ids] + + orig_type_env = nameEnvElts type_env + final_ids = bindsToIds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids) (mkVarSet stg_ids) tidy_binds - rule_dcls | opt_OmitInterfacePragmas = [] - | otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids) - - orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule - | (_, rule) <- tidy_orphan_rules] - + -- The complete rules are gotten by combining + -- a) the orphan rules + -- b) rules embedded in the top-level Ids + rule_dcls | opt_OmitInterfacePragmas = [] + | otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids) + + orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule + | (_, rule) <- orphan_rules] + + +-- This version is used when we are re-linking a module +-- so we've only run the type checker on its previous interface +mkModDetailsFromIface :: TypeEnv -> [DFunId] -- From typechecker + -> [TypecheckedRuleDecl] + -> ModDetails +mkModDetailsFromIface type_env dfun_ids rules + = ModDetails { md_types = type_env, + md_rules = rule_dcls, + md_insts = dfun_ids } + where + rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules] + -- All the rules from an interface are of the IfaceRuleOut form completeIface :: Maybe ModIface -- The old interface, if we have it -> ModIface -- The new one, minus the decls and versions @@ -109,9 +129,9 @@ completeIface maybe_old_iface new_iface mod_details dcl_insts = inst_dcls, dcl_rules = rule_dcls } - inst_dcls = map ifaceInstance (mk_insts mds) - ty_cls_dcls = map ifaceTyCls (nameEnvElts (md_types details)) - rule_dcls = map ifaceRule (md_rules details) + inst_dcls = map ifaceInstance (md_insts mod_details) + ty_cls_dcls = map ifaceTyCls (nameEnvElts (md_types mod_details)) + rule_dcls = map ifaceRule (md_rules mod_details) \end{code} @@ -220,14 +240,14 @@ ifaceTyCls (AnId id) ------------ Worker -------------- - wkr_hsinfo = case workerInfo id_info of + wrkr_hsinfo = case workerInfo id_info of HasWorker work_id wrap_arity -> [HsWorker (getName work_id)] NoWorker -> [] ------------ Unfolding -------------- - unfold_info = unfoldInfo id_info - inine_prag = inlinePragInfo id_info - rhs = unfoldingTempate unfold_info + unfold_info = unfoldingInfo id_info + inline_prag = inlinePragInfo id_info + rhs = unfoldingTemplate unfold_info unfold_hsinfo | neverUnfold unfold_info = [] | otherwise = [HsUnfold inline_prag (toUfExpr rhs)] \end{code} @@ -293,7 +313,7 @@ bindsToIds needed_ids codegen_ids binds -- exported, there's no need to emit anything need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id - go needed [] decls emitted + go needed [] emitted | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:" (sep (map ppr (varSetElems needed))) emitted @@ -308,7 +328,7 @@ bindsToIds needed_ids codegen_ids binds binds (new_id:emitted) | otherwise - = go needed binds decls emitted + = go needed binds emitted where (new_id, extras) = mkFinalId codegen_ids False id rhs @@ -317,7 +337,7 @@ bindsToIds needed_ids codegen_ids binds -- have to look for a fixed point. We don't want necessarily them all, -- because without -O we may only need the first one (if we don't emit -- its unfolding) - go needed (Rec pairs : binds) decls emitted + go needed (Rec pairs : binds) emitted = go needed' binds emitted' where (new_emitted, extras) = go_rec needed pairs @@ -351,7 +371,6 @@ mkFinalId :: IdSet -- The Ids with arity info from the code generator mkFinalId codegen_ids is_rec id rhs = (id `setIdInfo` new_idinfo, new_needed_ids) where - id_type = idType id core_idinfo = idInfo id stg_idinfo = case lookupVarSet codegen_ids id of Just id' -> idInfo id' @@ -361,7 +380,7 @@ mkFinalId codegen_ids is_rec id rhs new_idinfo | opt_OmitInterfacePragmas = vanillaIdInfo | otherwise - = core_idinfo `setArityInfo` stg_arity_info + = core_idinfo `setArityInfo` arity_info `setCafInfo` cafInfo stg_idinfo `setUnfoldingInfo` unfold_info `setWorkerInfo` worker_info @@ -370,8 +389,8 @@ mkFinalId codegen_ids is_rec id rhs -- passed on separately through the modules IdCoreRules ------------ Arity -------------- - stg_arity_info = arityInfo stg_idinfo - stg_arity = arityLowerBound arity_info + arity_info = arityInfo stg_idinfo + stg_arity = arityLowerBound arity_info ------------ Worker -------------- -- We only treat a function as having a worker if @@ -396,8 +415,8 @@ mkFinalId codegen_ids is_rec id rhs -- compilation of this module it means "how many things can I apply -- this to". worker_info = case workerInfo core_idinfo of - HasWorker work_id wrap_arity - | wrap_arity == stg_arity -> worker_info_in + info@(HasWorker work_id wrap_arity) + | wrap_arity == stg_arity -> info | otherwise -> pprTrace "ifaceId: arity change:" (ppr id) NoWorker NoWorker -> NoWorker @@ -508,14 +527,14 @@ addVersionInfo (Just old_iface@(ModIface { mi_version = old_version, = Nothing | otherwise -- Add updated version numbers - = Just (final_iface, pp_tc_diffs $$ pp_sig_diffs) + = Just (final_iface, pp_tc_diffs) where final_iface = new_iface { mi_version = new_version } new_version = VersionInfo { vers_module = bumpVersion no_output_change (vers_module old_version), vers_exports = bumpVersion no_export_change (vers_exports old_version), vers_rules = bumpVersion no_rule_change (vers_rules old_version), - vers_decls = sig_vers `plusNameEnv` tc_vers } + vers_decls = tc_vers } no_output_change = no_tc_change && no_rule_change && no_export_change no_usage_change = mi_usages old_iface == mi_usages new_iface @@ -527,17 +546,19 @@ addVersionInfo (Just old_iface@(ModIface { mi_version = old_version, -- Set the flag if anything changes. -- Assumes that the decls are sorted by hsDeclName. old_vers_decls = vers_decls old_version - (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_vers_decls (dcl_tycl old_decls) (dcl_tycl new_decls) + (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_vers_decls old_fixities new_fixities + (dcl_tycl old_decls) (dcl_tycl new_decls) diffDecls :: NameEnv Version -- Old version map + -> NameEnv Fixity -> NameEnv Fixity -- Old and new fixities -> [RenamedTyClDecl] -> [RenamedTyClDecl] -- Old and new decls -> (Bool, -- True <=> no change SDoc, -- Record of differences NameEnv Version) -- New version -diffDecls old_vers old new +diffDecls old_vers old_fixities new_fixities old new = diff True empty emptyNameEnv old new where -- When seeing if two decls are the same, @@ -552,11 +573,11 @@ diffDecls old_vers old new = case od_name `compare` nd_name of LT -> diff False (pp $$ only_old od) new_vers ods (nd:nds) GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds - EQ | od `eq` nd -> diff ok_so_far pp new_vers ods nds - | otherwise -> diff False (pp $$ changed od nd) new_vers' ods nds + EQ | od `eq_tc` nd -> diff ok_so_far pp new_vers ods nds + | otherwise -> diff False (pp $$ changed od nd) new_vers' ods nds where - od_name = get_name od - nd_name = get_name nd + od_name = tyClDeclName od + nd_name = tyClDeclName nd new_vers' = extendNameEnv new_vers nd_name (bumpVersion True (lookupNameEnv_NF old_vers od_name)) diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 4744b33..72ca33c 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -270,7 +270,7 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) fiExpr to_drop (_,AnnLet (AnnRec bindings) body) = fiExpr new_to_drop body where - (binders, rhss) = unzip bindings + rhss = map snd bindings rhss_fvs = map freeVarsOf rhss body_fvs = freeVarsOf body diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs index 8e99776..2d593e0 100644 --- a/ghc/compiler/simplCore/FloatOut.lhs +++ b/ghc/compiler/simplCore/FloatOut.lhs @@ -16,14 +16,12 @@ import CoreUtils ( mkSCC ) import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) import ErrUtils ( dumpIfSet_dyn ) import CostCentre ( dupifyCC, CostCentre ) -import Id ( Id, idType ) +import Id ( Id ) import VarEnv import CoreLint ( beginPass, endPass ) import SetLevels ( setLevels, Level(..), tOP_LEVEL, ltMajLvl, ltLvl, isTopLvl ) -import Type ( isUnLiftedType ) -import Var ( TyVar ) import UniqSupply ( UniqSupply ) import List ( partition ) import Outputable diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 1d73c5b..723b776 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -15,19 +15,22 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), ) import CoreLint ( beginPass, endPass ) import CoreSyn +import CoreFVs ( ruleSomeFreeVars ) +import HscTypes ( PackageRuleBase, HomeSymbolTable, ModDetails(..) ) import CSE ( cseProgram ) -import Rules ( RuleBase, extendRuleBaseList, addRuleBaseFVs ) +import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds, extendRuleBaseList, addRuleBaseFVs ) +import Module ( moduleEnvElts ) import CoreUnfold -import PprCore ( pprCoreBindings, pprCoreRulePair ) +import PprCore ( pprCoreBindings, pprIdCoreRule ) import OccurAnal ( occurAnalyseBinds ) -import CoreUtils ( exprIsTrivial, etaReduceExpr, coreBindsSize ) +import CoreUtils ( etaReduceExpr, coreBindsSize ) import Simplify ( simplTopBinds, simplExpr ) import SimplUtils ( simplBinders ) import SimplMonad import ErrUtils ( dumpIfSet, dumpIfSet_dyn ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) -import Id ( isDataConWrapId ) +import Id ( Id, isDataConWrapId, setIdNoDiscard ) import VarSet import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) @@ -65,12 +68,13 @@ core2core dflags pkg_rule_base hst core_todos binds rules let (cp_us, ru_us) = splitUniqSupply us -- COMPUTE THE RULE BASE TO USE - (rule_base, binds1, orphan_rules) <- prepareRules pkg_rule_base hst binds rules + (rule_base, binds1, orphan_rules) + <- prepareRules dflags pkg_rule_base hst ru_us binds rules -- DO THE BUSINESS (stats, processed_binds) - <- doCorePasses dflags (zeroSimplCount dflags) cp_us binds1 rule_base core_todos + <- doCorePasses dflags rule_base (zeroSimplCount dflags) cp_us binds1 core_todos dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Grand total simplifier statistics" @@ -97,7 +101,7 @@ doCorePasses dflags rb stats us binds (to_do : to_dos) = do let (us1, us2) = splitUniqSupply us - (stats1, binds1, mlrb1) <- doCorePass dflags rb us1 binds to_do + (stats1, binds1) <- doCorePass dflags rb us1 binds to_do doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos @@ -121,7 +125,7 @@ doCorePass dfs rb us binds CoreDoSpecialising = _scc_ "Specialise" noStats dfs (specProgram dfs us binds) doCorePass dfs rb us binds CoreDoCPResult = _scc_ "CPResult" noStats dfs (cprAnalyse dfs binds) -doCorePass dfs us binds CoreDoPrintCore +doCorePass dfs rb us binds CoreDoPrintCore = _scc_ "PrintCore" noStats dfs (printCore binds) doCorePass dfs rb us binds CoreDoUSPInf = _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds) @@ -165,16 +169,16 @@ prepareRules dflags pkg_rule_base hst us binds rules (mapSmpl simplRule rules) ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules" - (vcat (map pprCoreRulePair better_rules)) + (vcat (map pprIdCoreRule better_rules)) - ; let (local_id_rules, orphan_rules) = partition (`elemVarSet` local_ids . fst) better_rules + ; let (local_id_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules (binds1, local_rule_fvs) = addRulesToBinds binds local_id_rules imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hst) rule_base = extendRuleBaseList imp_rule_base orphan_rules final_rule_base = addRuleBaseFVs rule_base local_rule_fvs -- The last step black-lists the free vars of local rules too - ; return (rule_base, binds1, orphan_rules) + ; return (final_rule_base, binds1, orphan_rules) } where sw_chkr any = SwBool False -- A bit bogus @@ -189,7 +193,7 @@ prepareRules dflags pkg_rule_base hst us binds rules -- simpVar fails if it isn't right, and it might conceiveably matter local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds -addRulesToBinds :: [CoreBind] -> [(Id,CoreRule)] -> ([CoreBind], FreeVars) +addRulesToBinds :: [CoreBind] -> [(Id,CoreRule)] -> ([CoreBind], IdSet) -- A horrible function -- Attach the rules for each locally-defined Id to that Id. @@ -201,22 +205,22 @@ addRulesToBinds :: [CoreBind] -> [(Id,CoreRule)] -> ([CoreBind], FreeVars) -- - It makes sure that, when we apply a rule, the free vars -- of the RHS are more likely to be in scope -- - -- The LHS and RHS Ids are marked 'no-discard'. + -- Both the LHS and RHS Ids are marked 'no-discard'. -- This means that the binding won't be discarded EVEN if the binding -- ends up being trivial (v = w) -- the simplifier would usually just -- substitute w for v throughout, but we don't apply the substitution to -- the rules (maybe we should?), so this substitution would make the rule -- bogus. -addRulesToBinds binds imported_rule_base local_rules +addRulesToBinds binds local_rules = (map zap_bind binds, rule_lhs_fvs) where - RuleBase rule_ids rule_lhs_fvs = extendRuleBaseList emptyRuleBase local_rules - - imported_id_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids - -- rule_fvs is the set of all variables mentioned in this module's rules - rule_fvs = foldVarSet (unionVarSet . idRuleVars) rule_lhs_fvs rule_ids + rule_fvs = unionVarSets [ ruleSomeFreeVars isId rule | (_,rule) <- local_rules ] + + rule_base = extendRuleBaseList emptyRuleBase local_rules + rule_lhs_fvs = ruleBaseFVs rule_base + rule_ids = ruleBaseIds rule_base zap_bind (NonRec b r) = NonRec (zap_bndr b) r zap_bind (Rec prs) = Rec [(zap_bndr b, r) | (b,r) <- prs] @@ -312,7 +316,7 @@ simplifyPgm :: DynFlags -> [CoreBind] -- Input -> IO (SimplCount, [CoreBind]) -- New bindings -simplifyPgm dflags (RuleBase imported_rule_ids rule_lhs_fvs) +simplifyPgm dflags rule_base sw_chkr us binds = do { beginPass dflags "Simplify"; @@ -335,9 +339,11 @@ simplifyPgm dflags (RuleBase imported_rule_ids rule_lhs_fvs) return (counts_out, binds') } where - max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations - black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase) - + max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations + black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase) + imported_rule_ids = ruleBaseIds rule_base + rule_lhs_fvs = ruleBaseFVs rule_base + iteration us iteration_no counts binds -- Try and force thunks off the binds; significantly reduces -- space usage, especially with -O. JRS, 000620. diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index e440e87..c120e49 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -55,13 +55,12 @@ import CoreUnfold ( isCompulsoryUnfolding ) import CoreUtils ( exprOkForSpeculation ) import PprCore () -- Instances import CostCentre ( CostCentreStack, subsumedCCS ) -import Name ( isLocallyDefined ) import OccName ( UserFS ) import VarEnv import VarSet import qualified Subst import Subst ( Subst, mkSubst, substEnv, - InScopeSet, mkInScopeSet, substInScope, isInScope + InScopeSet, mkInScopeSet, substInScope ) import Type ( Type, isUnLiftedType ) import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply, diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 866b8ff..05c989c 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -23,29 +23,26 @@ import CmdLineOpts ( switchIsOn, SimplifierSwitch(..), opt_UF_UpdateInPlace ) import CoreSyn -import CoreUnfold ( isValueUnfolding ) import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity, bindNonRec ) import Subst ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, substExpr ) -import Id ( Id, idType, isId, idName, - idOccInfo, idUnfolding, idStrictness, +import Id ( idType, idName, + idUnfolding, idStrictness, mkId, idInfo ) -import IdInfo ( StrictnessInfo(..), ArityInfo, atLeastArity, setOccInfo, vanillaIdInfo ) +import IdInfo ( StrictnessInfo(..), ArityInfo, atLeastArity, vanillaIdInfo ) import Maybes ( maybeToBool, catMaybes ) import Name ( setNameUnique ) -import Demand ( Demand, isStrict, wwLazy, wwLazy ) +import Demand ( isStrict ) import SimplMonad -import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, repType, - splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys, - isDictTy, isDataType, applyTy, splitFunTy, isUnLiftedType, +import Type ( Type, mkForAllTys, seqType, repType, + splitTyConApp_maybe, mkTyVarTys, splitFunTys, + isDictTy, isDataType, isUnLiftedType, splitRepFunTys ) import TyCon ( tyConDataConsIfAvailable ) import DataCon ( dataConRepArity ) -import VarSet -import VarEnv ( SubstEnv, SubstResult(..) ) +import VarEnv ( SubstEnv ) import Util ( lengthExceeds ) -import BasicTypes ( Arity ) import Outputable \end{code} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 9dd953b..c972821 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -29,11 +29,11 @@ import Id ( Id, idType, idInfo, isDataConId, zapLamIdInfo, setOneShotLambda, ) import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker, - ArityInfo, setArityInfo, unknownArity, + setArityInfo, unknownArity, setUnfoldingInfo, occInfo ) -import Demand ( Demand, isStrict ) +import Demand ( isStrict ) import DataCon ( dataConNumInstArgs, dataConRepStrictness, dataConSig, dataConArgTys ) @@ -44,16 +44,16 @@ import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, ) import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial, exprIsConApp_maybe, exprType, coreAltsType, exprIsValue, idAppIsCheap, - exprOkForSpeculation, etaReduceExpr, + exprOkForSpeculation, mkCoerce, mkSCC, mkInlineMe, mkAltExpr ) import Rules ( lookupRule ) import CostCentre ( currentCCS ) import Type ( mkTyVarTys, isUnLiftedType, seqType, - mkFunTy, splitFunTy, splitTyConApp_maybe, + mkFunTy, splitTyConApp_maybe, funResultTy ) -import Subst ( mkSubst, substTy, substExpr, +import Subst ( mkSubst, substTy, isInScope, lookupIdSubst, substIdInfo ) import TyCon ( isDataTyCon, tyConDataConsIfAvailable ) @@ -564,7 +564,6 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside old_info = idInfo old_bndr occ_info = occInfo old_info loop_breaker = isLoopBreaker occ_info - trivial_rhs = exprIsTrivial new_rhs must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr finally_bind_it arity_info new_rhs diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index efe68cd..1f5e74e 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -5,8 +5,10 @@ \begin{code} module Rules ( - RuleBase, emptyRuleBase, extendRuleBase, extendRuleBaseList, pprRuleBase, - addRuleBaseFVs, + RuleBase, emptyRuleBase, + extendRuleBase, extendRuleBaseList, addRuleBaseFVs, + ruleBaseIds, ruleBaseFVs, + pprRuleBase, lookupRule, addRule, addIdSpecialisations ) where @@ -465,6 +467,9 @@ data RuleBase = RuleBase -- This representation is a bit cute, and I wonder if we should -- change it to use (IdEnv CoreRule) which seems a bit more natural +ruleBaseIds (RuleBase ids _) = ids +ruleBaseFVs (RuleBase _ fvs) = fvs + emptyRuleBase = RuleBase emptyVarSet emptyVarSet addRuleBaseFVs :: RuleBase -> IdSet -> RuleBase diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 272fa27..9952c92 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -9,22 +9,20 @@ module Specialise ( specProgram ) where #include "HsVersions.h" import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) -import Id ( Id, idName, idType, mkTemplateLocals, mkUserLocal, - idSpecialisation, setIdNoDiscard, isExportedId, - modifyIdInfo, idUnfolding +import Id ( Id, idName, idType, mkUserLocal, + idSpecialisation, modifyIdInfo ) import IdInfo ( zapSpecPragInfo ) import VarSet import VarEnv -import Type ( Type, mkTyVarTy, splitSigmaTy, splitFunTysN, - tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, applyTys, - mkForAllTys, boxedTypeKind +import Type ( Type, mkTyVarTy, splitSigmaTy, + tyVarsOfTypes, tyVarsOfTheta, + mkForAllTys ) import Subst ( Subst, mkSubst, substTy, mkSubst, substBndrs, extendSubstList, mkInScopeSet, substId, substAndCloneId, substAndCloneIds, lookupIdSubst, substInScope ) -import Var ( TyVar, mkSysTyVar, setVarUnique ) import VarSet import VarEnv import CoreSyn @@ -37,15 +35,15 @@ import Rules ( addIdSpecialisations, lookupRule ) import UniqSupply ( UniqSupply, UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs, - getUs, setUs, uniqFromSupply, splitUniqSupply, mapUs + getUs, setUs, mapUs ) import Name ( nameOccName, mkSpecOcc, getSrcLoc ) import FiniteMap -import Maybes ( MaybeErr(..), catMaybes, maybeToBool ) +import Maybes ( catMaybes, maybeToBool ) import ErrUtils ( dumpIfSet_dyn ) import Bag import List ( partition ) -import Util ( zipEqual, zipWithEqual, mapAccumL ) +import Util ( zipEqual, zipWithEqual ) import Outputable @@ -1097,11 +1095,8 @@ lookupId env id = case lookupVarEnv env id of type SpecM a = UniqSM a thenSM = thenUs -thenSM_ = thenUs_ returnSM = returnUs getUniqSM = getUniqueUs -getUniqSupplySM = getUs -setUniqSupplySM = setUs mapSM = mapUs initSM = initUs_ @@ -1148,10 +1143,6 @@ newIdSM old_id new_ty new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name) in returnSM new_id - -newTyVarSM - = getUniqSM `thenSM` \ uniq -> - returnSM (mkSysTyVar uniq boxedTypeKind) \end{code} -- 1.7.10.4