[project @ 2002-03-18 15:23:05 by simonpj]

Tidier printing routines for Rules

diff --git a/ghc/compiler/DEPEND-NOTES b/ghc/compiler/DEPEND-NOTES
index 903742a..9b44e81 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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}
 
 %************************************************************************