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