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

Tidier printing routines for Rules

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)
 

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
 

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

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 _)

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}
 
 

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}
 

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}

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}
 
 

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}
 
 %************************************************************************