From 7d841483081735f5f906a6bb5e80249d97f3226b Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 18 Mar 2002 15:23:07 +0000 Subject: [PATCH] [project @ 2002-03-18 15:23:05 by simonpj] Tidier printing routines for Rules --- ghc/compiler/DEPEND-NOTES | 9 ++++++--- ghc/compiler/basicTypes/Id.lhs | 7 +++++-- ghc/compiler/coreSyn/CoreTidy.lhs | 30 ++++++++++++++++-------------- ghc/compiler/coreSyn/PprCore.lhs | 12 ++++++------ ghc/compiler/deSugar/Desugar.lhs | 4 ++-- ghc/compiler/main/MkIface.lhs | 4 ++-- ghc/compiler/specialise/Rules.lhs | 8 ++++---- ghc/compiler/specialise/SpecConstr.lhs | 7 ++++--- ghc/compiler/specialise/Specialise.lhs | 7 ++++--- 9 files changed, 49 insertions(+), 39 deletions(-) diff --git a/ghc/compiler/DEPEND-NOTES b/ghc/compiler/DEPEND-NOTES index 903742a..9b44e81 100644 --- a/ghc/compiler/DEPEND-NOTES +++ b/ghc/compiler/DEPEND-NOTES @@ -34,7 +34,7 @@ then then PrimOp (PprType, TysWiredIn) then - CoreSyn + CoreSyn [does not import Id] then IdInfo (CoreSyn.Unfolding, CoreSyn.CoreRules) then @@ -49,9 +49,12 @@ then then CoreUnfold (OccurAnal.occurAnalyseGlobalExpr) then - Rules (Unfolding), Subst (Unfolding, CoreFVs), CoreTidy (noUnfolding), Generics (mkTopUnfolding) + CoreTidy (CoreUnfold.noUnfolding) + Subst (Unfolding, CoreFVs) + Generics (mkTopUnfolding) then - MkId (CoreUnfold.mkUnfolding, Subst) + Rules (Unfolding, CoreTidy.tidyIdRules) + MkId (CoreUnfold.mkUnfolding, Subst, Rule.addRule) then PrelInfo (MkId) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 9fa37b1..b1a4a1a 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -67,7 +67,7 @@ module Id ( idTyGenInfo, idWorkerInfo, idUnfolding, - idSpecialisation, + idSpecialisation, idCoreRules, idCgInfo, idCafInfo, idLBVarInfo, @@ -82,7 +82,7 @@ module Id ( #include "HsVersions.h" -import CoreSyn ( Unfolding, CoreRules ) +import CoreSyn ( Unfolding, CoreRules, IdCoreRule, rulesRules ) import BasicTypes ( Arity ) import Var ( Id, DictId, isId, isExportedId, isSpecPragmaId, isLocalId, @@ -394,6 +394,9 @@ setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` dmd) id idSpecialisation :: Id -> CoreRules idSpecialisation id = specInfo (idInfo id) +idCoreRules :: Id -> [IdCoreRule] +idCoreRules id = [(id,rule) | rule <- rulesRules (idSpecialisation id)] + setIdSpecialisation :: Id -> CoreRules -> Id setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 72236c9..acc2c77 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -5,7 +5,7 @@ \begin{code} module CoreTidy ( - tidyCorePgm, tidyExpr, tidyCoreExpr, + tidyCorePgm, tidyExpr, tidyCoreExpr, tidyIdRules, tidyBndr, tidyBndrs ) where @@ -15,15 +15,14 @@ import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile ) import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars ) -import PprCore ( pprIdCoreRule ) +import PprCore ( pprIdRules ) import CoreLint ( showPass, endPass ) import CoreUtils ( exprArity ) import VarEnv import VarSet import Var ( Id, Var ) -import Id ( idType, idInfo, idName, isExportedId, - idSpecialisation, idUnique, - mkVanillaGlobal, isLocalId, +import Id ( idType, idInfo, idName, idCoreRules, + isExportedId, idUnique, mkVanillaGlobal, isLocalId, isImplicitId, mkUserLocal, setIdInfo ) import IdInfo {- loads of stuff -} @@ -169,7 +168,7 @@ tidyCorePgm dflags mod pcs cg_info_env = mapAccumL (tidyTopBind mod ext_ids cg_info_env) init_tidy_env binds_in - ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules + ; let tidy_rules = tidyIdCoreRules (occ_env,subst_env) ext_rules ; let prs' = prs { prsOrig = orig_ns' } pcs' = pcs { pcs_PRS = prs' } @@ -196,7 +195,7 @@ tidyCorePgm dflags mod pcs cg_info_env ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds ; dumpIfSet_core dflags Opt_D_dump_simpl "Tidy Core Rules" - (vcat (map pprIdCoreRule tidy_rules)) + (pprIdRules tidy_rules) ; return (pcs', tidy_details) } @@ -255,11 +254,11 @@ findExternalRules binds orphan_rules ext_ids | otherwise = filter needed_rule (orphan_rules ++ local_rules) where - local_rules = [ (id, rule) + local_rules = [ rule | id <- bindersOfBinds binds, id `elemVarEnv` ext_ids, - rule <- rulesRules (idSpecialisation id) - ] + rule <- idCoreRules id + ] needed_rule (id, rule) = not (isBuiltinRule rule) -- We can't print builtin rules in interface files @@ -570,11 +569,14 @@ tidyWorker tidy_env other = NoWorker ------------ Rules -------------- -tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule] -tidyIdRules env [] = [] -tidyIdRules env ((fn,rule) : rules) +tidyIdRules :: Id -> [IdCoreRule] +tidyIdRules id = tidyIdCoreRules emptyTidyEnv (idCoreRules id) + +tidyIdCoreRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule] +tidyIdCoreRules env [] = [] +tidyIdCoreRules env ((fn,rule) : rules) = tidyRule env rule =: \ rule -> - tidyIdRules env rules =: \ rules -> + tidyIdCoreRules env rules =: \ rules -> ((tidyVarOcc env fn, rule) : rules) tidyRule :: TidyEnv -> CoreRule -> CoreRule diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index e77cac8..8639a93 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -12,7 +12,7 @@ module PprCore ( pprCoreExpr, pprParendExpr, pprCoreBinding, pprCoreBindings, pprIdBndr, pprCoreBinding, pprCoreBindings, pprCoreAlt, - pprCoreRules, pprCoreRule, pprIdCoreRule + pprIdRules, pprCoreRule ) where #include "HsVersions.h" @@ -361,7 +361,7 @@ ppIdInfo b info ppCprInfo m, #endif ppr (newStrictnessInfo info), - pprCoreRules b p + vcat (map (pprCoreRule (ppr b)) (rulesRules p)) -- Inline pragma, occ, demand, lbvar info -- printed out with all binders (when debug is on); -- see PprCore.pprIdBndr @@ -378,11 +378,11 @@ ppIdInfo b info \begin{code} -pprCoreRules :: Id -> CoreRules -> SDoc -pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules) +pprIdRules :: [IdCoreRule] -> SDoc +pprIdRules rules = vcat (map pprIdRule rules) -pprIdCoreRule :: IdCoreRule -> SDoc -pprIdCoreRule (id,rule) = pprCoreRule (ppr id) rule +pprIdRule :: IdCoreRule -> SDoc +pprIdRule (id,rule) = pprCoreRule (ppr id) rule pprCoreRule :: SDoc -> CoreRule -> SDoc pprCoreRule pp_fn (BuiltinRule name _) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 261f319..5cece7a 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -16,7 +16,7 @@ import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr ) import TcModule ( TcResults(..) ) import Id ( Id ) import CoreSyn -import PprCore ( pprIdCoreRule, pprCoreExpr ) +import PprCore ( pprIdRules, pprCoreExpr ) import Subst ( substExpr, mkSubst, mkInScopeSet ) import DsMonad import DsExpr ( dsExpr ) @@ -150,7 +150,7 @@ dsProgram mod_name all_binds rules fo_decls ppr_ds_rules [] = empty ppr_ds_rules rules = text "" $$ text "-------------- DESUGARED RULES -----------------" $$ - vcat (map pprIdCoreRule rules) + pprIdRules rules \end{code} diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 8050e50..68a8d0f 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -44,7 +44,7 @@ import Var ( Var ) import CoreSyn ( CoreRule(..), IdCoreRule ) import CoreFVs ( ruleLhsFreeNames ) import CoreUnfold ( neverUnfold, unfoldingTemplate ) -import PprCore ( pprIdCoreRule ) +import PprCore ( pprIdRules ) import Name ( getName, nameModule, toRdrName, isExternalName, nameIsLocalOrFrom, Name, NamedThing(..) ) import NameEnv @@ -539,7 +539,7 @@ dump_sigs ids dump_rules :: [IdCoreRule] -> SDoc dump_rules [] = empty dump_rules rs = vcat [ptext SLIT("{-# RULES"), - nest 4 (vcat (map pprIdCoreRule rs)), + nest 4 (pprIdRules rs), ptext SLIT("#-}")] \end{code} diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 9e27df4..b8b00ec 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -19,8 +19,9 @@ import CoreSyn -- All of it import OccurAnal ( occurAnalyseRule ) import CoreFVs ( exprFreeVars, ruleRhsFreeVars, ruleLhsFreeIds ) import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) +import CoreTidy ( tidyIdRules ) import CoreUtils ( eqExpr ) -import PprCore ( pprCoreRule ) +import PprCore ( pprIdRules ) import Subst ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst, substEnv, setSubstEnv, emptySubst, isInScope, emptyInScopeSet, bindSubstList, unBindSubstList, substInScope, uniqAway @@ -629,7 +630,6 @@ extendRuleBase (RuleBase rule_ids rule_fvs) (id, rule) -- locally defined ones!! pprRuleBase :: RuleBase -> SDoc -pprRuleBase (RuleBase rules _) = vcat [ pprCoreRule (ppr id) rs - | id <- varSetElems rules, - rs <- rulesRules $ idSpecialisation id ] +pprRuleBase (RuleBase rules _) = vcat [ pprIdRules (tidyIdRules id) + | id <- varSetElems rules ] \end{code} diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs index 6622764..85bbd96 100644 --- a/ghc/compiler/specialise/SpecConstr.lhs +++ b/ghc/compiler/specialise/SpecConstr.lhs @@ -14,12 +14,13 @@ import CoreSyn import CoreLint ( showPass, endPass ) import CoreUtils ( exprType, eqExpr, mkPiTypes ) import CoreFVs ( exprsFreeVars ) +import CoreTidy ( tidyIdRules ) import WwLib ( mkWorkerArgs ) import DataCon ( dataConRepArity ) import Type ( tyConAppArgs ) -import PprCore ( pprCoreRules ) +import PprCore ( pprIdRules ) import Id ( Id, idName, idType, idSpecialisation, - isDataConId_maybe, + isDataConId_maybe, mkUserLocal, mkSysLocal ) import Var ( Var ) import VarEnv @@ -190,7 +191,7 @@ specConstrProgram dflags us binds go env' binds `thenUs` \ binds' -> returnUs (bind' : binds') -dump_specs var = pprCoreRules var (idSpecialisation var) + dump_specs var = pprIdRules (tidyIdRules var) \end{code} diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 746814f..51f32ce 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -25,8 +25,9 @@ import VarEnv import CoreSyn import CoreUtils ( applyTypeToArgs ) import CoreFVs ( exprFreeVars, exprsFreeVars ) +import CoreTidy ( tidyIdRules ) import CoreLint ( showPass, endPass ) -import PprCore ( pprCoreRules ) +import PprCore ( pprIdRules ) import Rules ( addIdSpecialisations, lookupRule ) import UniqSupply ( UniqSupply, @@ -590,6 +591,8 @@ specProgram dflags us binds return binds' where + dump_specs var = pprIdRules (tidyIdRules var) + -- We need to start with a Subst that knows all the things -- that are in scope, so that the substitution engine doesn't -- accidentally re-use a unique that's already in use @@ -601,8 +604,6 @@ specProgram dflags us binds go (bind:binds) = go binds `thenSM` \ (binds', uds) -> specBind top_subst bind uds `thenSM` \ (bind', uds') -> returnSM (bind' ++ binds', uds') - -dump_specs var = pprCoreRules var (idSpecialisation var) \end{code} %************************************************************************ -- 1.7.10.4