Commit 7d841483 authored by simonpj's avatar simonpj

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

Tidier printing routines for Rules
parent 2e95d540
......@@ -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)
......@@ -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
......
......@@ -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,10 +254,10 @@ 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)
......@@ -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
......
......@@ -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 _)
......
......@@ -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}
......
......@@ -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}
......
......@@ -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}
......@@ -14,10 +14,11 @@ 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,
mkUserLocal, mkSysLocal )
......@@ -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}
......
......@@ -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}
%************************************************************************
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment