Commit 17d765ce authored by simonpj's avatar simonpj
Browse files

[project @ 2001-03-19 16:13:22 by simonpj]

-------------------------------
	Improve orphan-module resolution
	-------------------------------

Consider the following rule (and there are lots of these in
the Prelude):

	fromIntegral T = fromIntegral_T

where T is defined in the module being compiled.

is an orphan.  Of course it isn't, an declaring it an orphan would
make the whole module an orphan module, which is bad.

This commit arranges to determine orphan rules, and the orphan-hood
of a module, much later than before.  (Before mi_orphan was set by
the renamer, now it is set by MkIface.)
parent bc83a34d
......@@ -11,7 +11,8 @@ module CoreFVs (
exprSomeFreeVars, exprsSomeFreeVars,
idRuleVars, idFreeVars, idFreeTyVars,
ruleSomeFreeVars, ruleSomeLhsFreeVars, ruleRhsFreeVars,
ruleSomeFreeVars, ruleRhsFreeVars,
ruleLhsFreeNames, ruleLhsFreeIds,
CoreExprWithFVs, -- = AnnExpr Id VarSet
CoreBindWithFVs, -- = AnnBind Id VarSet
......@@ -22,10 +23,11 @@ module CoreFVs (
#include "HsVersions.h"
import CoreSyn
import Id ( Id, idType, isLocalId, hasNoBinding, idSpecialisation )
import Id ( Id, idType, idSpecialisation )
import NameSet
import VarSet
import Var ( Var, isId, isLocalVar )
import Type ( tyVarsOfType )
import Var ( Var, isId, isLocalVar, varName )
import Type ( tyVarsOfType, namesOfType )
import Util ( mapAndUnzip )
import Outputable
\end{code}
......@@ -140,6 +142,61 @@ expr_fvs (Let (Rec pairs) body)
\end{code}
%************************************************************************
%* *
\section{Free names}
%* *
%************************************************************************
exprFreeNames finds the free *names* of an expression, notably
including the names of type constructors (which of course do not show
up in exprFreeVars). Similarly ruleLhsFreeNames. The latter is used
when deciding whethera rule is an orphan. In particular, suppose that
T is defined in this module; we want to avoid declaring that a rule like
fromIntegral T = fromIntegral_T
is an orphan. Of course it isn't, an declaring it an orphan would
make the whole module an orphan module, which is bad.
\begin{code}
ruleLhsFreeNames :: IdCoreRule -> NameSet
ruleLhsFreeNames (fn, BuiltinRule _) = unitNameSet (varName fn)
ruleLhsFreeNames (fn, Rule _ tpl_vars tpl_args rhs)
= addOneToNameSet (exprsFreeNames tpl_args `del_binders` tpl_vars) (varName fn)
exprFreeNames :: CoreExpr -> NameSet
exprFreeNames (Var v) = unitNameSet (varName v)
exprFreeNames (Lit _) = emptyNameSet
exprFreeNames (Type ty) = namesOfType ty
exprFreeNames (App e1 e2) = exprFreeNames e1 `unionNameSets` exprFreeNames e2
exprFreeNames (Lam v e) = exprFreeNames e `delFromNameSet` varName v
exprFreeNames (Note n e) = exprFreeNames e
exprFreeNames (Let (NonRec b r) e) = (exprFreeNames e `delFromNameSet` varName b)
`unionNameSets` exprFreeNames r
exprFreeNames (Let (Rec prs) e) = (exprsFreeNames rs `unionNameSets` exprFreeNames e)
`del_binders` bs
where
(bs, rs) = unzip prs
exprFreeNames (Case e b as) = exprFreeNames e `unionNameSets`
(unionManyNameSets (map altFreeNames as) `delFromNameSet` varName b)
-- Helpers
altFreeNames (_,bs,r) = exprFreeNames r `del_binders` bs
exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es
del_binders :: NameSet -> [Var] -> NameSet
del_binders names bndrs = foldl (\s b -> delFromNameSet s (varName b)) names bndrs
\end{code}
%************************************************************************
%* *
\section[freevars-everywhere]{Attaching free variables to every sub-expression}
%* *
%************************************************************************
\begin{code}
rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet
......@@ -161,10 +218,12 @@ ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs)
rule_fvs = addBndrs tpl_vars $
foldr (union . expr_fvs) (expr_fvs rhs) tpl_args
ruleSomeLhsFreeVars :: InterestingVarFun -> CoreRule -> VarSet
ruleSomeLhsFreeVars fn (BuiltinRule _) = noFVs
ruleSomeLhsFreeVars fn (Rule _ tpl_vars tpl_args rhs)
= foldl delVarSet (exprsSomeFreeVars fn tpl_args) tpl_vars
ruleLhsFreeIds :: CoreRule -> VarSet
-- This finds all the free Ids on the LHS of the rule
-- *including* imported ids
ruleLhsFreeIds (BuiltinRule _) = noFVs
ruleLhsFreeIds (Rule _ tpl_vars tpl_args rhs)
= foldl delVarSet (exprsSomeFreeVars isId tpl_args) tpl_vars
\end{code}
......
......@@ -14,12 +14,11 @@ module CoreTidy (
import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars,
ruleSomeLhsFreeVars )
import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars )
import CoreLint ( showPass, endPass )
import VarEnv
import VarSet
import Var ( Id, Var, varName )
import Var ( Id, Var )
import Id ( idType, idInfo, idName, isExportedId,
idSpecialisation, idUnique,
mkVanillaGlobal, isLocalId, isImplicitId,
......@@ -27,7 +26,7 @@ import Id ( idType, idInfo, idName, isExportedId,
)
import IdInfo {- loads of stuff -}
import Name ( getOccName, nameOccName, globaliseName, setNameOcc,
localiseName, isGlobalName, isLocalName
localiseName, isGlobalName
)
import NameEnv ( filterNameEnv )
import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
......@@ -228,22 +227,10 @@ findExternalRules binds orphan_rules ext_ids
| id <- bindersOfBinds binds,
id `elemVarEnv` ext_ids,
rule <- rulesRules (idSpecialisation id),
not (isBuiltinRule rule),
not (isBuiltinRule rule)
-- We can't print builtin rules in interface files
-- Since they are built in, an importing module
-- will have access to them anyway
-- Sept 00: I've disabled this test. It doesn't stop
-- many, if any, rules from coming out, and to make it
-- work properly we need to add ????
-- (put it back in for now)
isEmptyVarSet (ruleSomeLhsFreeVars (isLocalName . varName) rule)
-- Spit out a rule only if none of its LHS free
-- vars are LocalName things i.e. things that
-- aren't visible to importing modules This is a
-- good reason not to do it when we emit the Id
-- itself
]
\end{code}
......
......@@ -38,7 +38,7 @@ import Rename ( checkOldIface, renameModule, closeIfaceDecls )
import Rules ( emptyRuleBase )
import PrelInfo ( wiredInThingEnv, wiredInThings )
import PrelNames ( vanillaSyntaxMap, knownKeyNames )
import MkIface ( completeIface, writeIface, pprIface )
import MkIface ( mkFinalIface )
import TcModule
import InstEnv ( emptyInstEnv )
import Desugar
......@@ -356,32 +356,6 @@ hscRecomp ghci_mode dflags have_object
maybe_bcos)
}}}}}}}
mkFinalIface ghci_mode dflags location
maybe_old_iface new_iface new_details
= case completeIface maybe_old_iface new_iface new_details of
(new_iface, Nothing) -- no change in the interfacfe
-> do when (dopt Opt_D_dump_hi_diffs dflags)
(printDump (text "INTERFACE UNCHANGED"))
dumpIfSet_dyn dflags Opt_D_dump_hi
"UNCHANGED FINAL INTERFACE" (pprIface new_iface)
return new_iface
(new_iface, Just sdoc_diffs)
-> do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "INTERFACE HAS CHANGED"
sdoc_diffs
dumpIfSet_dyn dflags Opt_D_dump_hi "NEW FINAL INTERFACE"
(pprIface new_iface)
-- Write the interface file, if not in interactive mode
when (ghci_mode /= Interactive)
(writeIface (unJust "hscRecomp:hi" (ml_hi_file location))
new_iface)
return new_iface
myParseModule dflags src_filename
= do -------------------------- Parser ----------------
showPass dflags "Parser"
......
......@@ -5,7 +5,7 @@
\begin{code}
module MkIface (
completeIface, writeIface,
mkFinalIface,
pprModDetails, pprIface, pprUsage
) where
......@@ -20,12 +20,14 @@ import BasicTypes ( Fixity(..), NewOrData(..),
import RnMonad
import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl )
import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..),
ModuleLocation(..),
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
TyThing(..), DFunId, Avails,
WhatsImported(..), GenAvailInfo(..),
ImportVersion, AvailInfo, Deprecations(..),
lookupVersion,
)
import CmStaticInfo ( GhciMode(..) )
import CmdLineOpts
import Id ( idType, idInfo, isImplicitId, idCgInfo,
......@@ -34,22 +36,27 @@ import Id ( idType, idInfo, isImplicitId, idCgInfo,
import DataCon ( StrictnessMark(..), dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo -- Lots
import CoreSyn ( CoreRule(..) )
import CoreFVs ( ruleLhsFreeNames )
import CoreUnfold ( neverUnfold, unfoldingTemplate )
import PprCore ( pprIdCoreRule )
import Name ( getName, nameModule, toRdrName, isGlobalName, Name, NamedThing(..) )
import Name ( getName, nameModule, toRdrName, isGlobalName,
nameIsLocalOrFrom, Name, NamedThing(..) )
import NameEnv
import NameSet
import OccName ( pprOccName )
import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConGenIds,
tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, isClassTyCon
)
import Class ( classExtraBigSig, classTyCon, DefMeth(..) )
import FieldLabel ( fieldLabelType )
import Type ( splitSigmaTy, tidyTopType, deNoteType )
import Type ( splitSigmaTy, tidyTopType, deNoteType, namesOfType )
import SrcLoc ( noSrcLoc )
import Outputable
import Module ( ModuleName )
import Util ( sortLt )
import Util ( sortLt, unJust )
import ErrUtils ( dumpIfSet_dyn )
import Monad ( when )
import IO ( IOMode(..), openFile, hClose )
\end{code}
......@@ -61,25 +68,78 @@ import IO ( IOMode(..), openFile, hClose )
%************************************************************************
\begin{code}
completeIface :: Maybe ModIface -- The old interface, if we have it
-> ModIface -- The new one, minus the decls and versions
-> ModDetails -- The ModDetails for this module
-> (ModIface, Maybe SDoc) -- The new one, complete with decls and versions
-- The SDoc is a debug document giving differences
-- Nothing => no change
-- NB: 'Nothing' means that even the usages havn't changed, so there's no
-- need to write a new interface file. But even if the usages have
-- changed, the module version may not have.
completeIface maybe_old_iface new_iface mod_details
= addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
mkFinalIface :: GhciMode
-> DynFlags
-> ModuleLocation
-> Maybe ModIface -- The old interface, if we have it
-> ModIface -- The new one, minus the decls and versions
-> ModDetails -- The ModDetails for this module
-> IO ModIface -- The new one, complete with decls and versions
-- mkFinalIface
-- a) completes the interface
-- b) writes it out to a file if necessary
mkFinalIface ghci_mode dflags location
maybe_old_iface new_iface new_details
= do {
-- Add the new declarations, and the is-orphan flag
let iface_w_decls = new_iface { mi_decls = new_decls,
mi_orphan = orphan_mod }
-- Add version information
; let (final_iface, maybe_diffs) = addVersionInfo maybe_old_iface iface_w_decls
-- Write the interface file, if necessary
; when (must_write_hi_file maybe_diffs)
(writeIface hi_file_path final_iface)
-- Debug printing
; write_diffs dflags final_iface maybe_diffs
; return final_iface }
where
new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls
inst_dcls = map ifaceInstance (md_insts mod_details)
ty_cls_dcls = foldNameEnv ifaceTyCls [] (md_types mod_details)
rule_dcls = map ifaceRule (md_rules mod_details)
must_write_hi_file Nothing = False
must_write_hi_file (Just diffs) = ghci_mode /= Interactive
-- We must write a new .hi file if there are some changes
-- and we're not in interactive mode
-- maybe_diffs = 'Nothing' means that even the usages havn't changed,
-- so there's no need to write a new interface file. But even if
-- the usages have changed, the module version may not have.
hi_file_path = unJust "mkFinalIface" (ml_hi_file location)
new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls
inst_dcls = map ifaceInstance (md_insts new_details)
ty_cls_dcls = foldNameEnv ifaceTyCls [] (md_types new_details)
rule_dcls = map ifaceRule (md_rules new_details)
orphan_mod = isOrphanModule (mi_module new_iface) new_details
write_diffs dflags new_iface Nothing
= do when (dopt Opt_D_dump_hi_diffs dflags) (printDump (text "INTERFACE UNCHANGED"))
dumpIfSet_dyn dflags Opt_D_dump_hi "UNCHANGED FINAL INTERFACE" (pprIface new_iface)
write_diffs dflags new_iface (Just sdoc_diffs)
= do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "INTERFACE HAS CHANGED" sdoc_diffs
dumpIfSet_dyn dflags Opt_D_dump_hi "NEW FINAL INTERFACE" (pprIface new_iface)
\end{code}
\begin{code}
isOrphanModule this_mod (ModDetails {md_insts = insts, md_rules = rules})
= any orphan_inst insts || any orphan_rule rules
where
orphan_inst dfun_id = no_locals (namesOfType (dfun_head_type dfun_id))
orphan_rule rule = no_locals (ruleLhsFreeNames rule)
no_locals names = isEmptyNameSet (filterNameSet (nameIsLocalOrFrom this_mod) names)
dfun_head_type dfun = case splitSigmaTy (idType dfun) of
(_,_,head_ty) -> head_ty
-- The 'dfun_head_type' is because of
-- instance Foo a => Baz T where ...
-- The decl is an orphan if Baz and T are both not locally defined,
-- even if Foo *is* locally defined
\end{code}
\begin{code}
ifaceTyCls :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
......
......@@ -14,7 +14,7 @@ import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation,
RdrNameStmt
)
import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl,
extractHsTyNames, RenamedStmt,
RenamedStmt,
instDeclFVs, tyClDeclFVs, ruleDeclFVs
)
......@@ -27,7 +27,7 @@ import RnIfaces ( slurpImpDecls, mkImportInfo, recordLocalSlurps,
closeDecls,
RecompileRequired, outOfDate, recompileRequired
)
import RnHiFiles ( readIface, removeContext, loadInterface,
import RnHiFiles ( readIface, loadInterface,
loadExports, loadFixDecls, loadDeprecs,
)
import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv,
......@@ -41,7 +41,7 @@ import Module ( Module, ModuleName, WhereFrom(..),
moduleNameUserString, moduleName,
moduleEnvElts
)
import Name ( Name, nameIsLocalOrFrom, nameModule )
import Name ( Name, nameModule )
import NameEnv
import NameSet
import RdrName ( foldRdrEnv, isQual )
......@@ -60,7 +60,7 @@ import HscTypes ( PersistentCompilerState, HomeIfaceTable, HomeSymbolTable,
VersionInfo(..), ImportVersion, IsExported,
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
GlobalRdrEnv, GlobalRdrElt(..), pprGlobalRdrEnv,
AvailEnv, GenAvailInfo(..), AvailInfo, Avails,
AvailEnv, GenAvailInfo(..), AvailInfo,
Provenance(..), ImportReason(..), initialVersionInfo,
Deprecations(..),
LocalRdrEnv
......@@ -275,13 +275,12 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec
my_exports = groupAvails this_module export_avails
final_decls = rn_local_decls ++ rn_imp_decls
is_orphan = any (isOrphanDecl this_module) rn_local_decls
mod_iface = ModIface { mi_module = this_module,
mi_version = initialVersionInfo,
mi_usages = my_usages,
mi_boot = False,
mi_orphan = is_orphan,
mi_orphan = panic "is_orphan",
mi_exports = my_exports,
mi_globals = gbl_env,
mi_fixities = fixities,
......@@ -305,35 +304,6 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec
mod_name = moduleName this_module
\end{code}
\begin{code}
isOrphanDecl this_mod (InstD (InstDecl inst_ty _ _ _ _))
= not (foldNameSet ((||) . nameIsLocalOrFrom this_mod) False
(extractHsTyNames (removeContext inst_ty)))
-- The 'removeContext' is because of
-- instance Foo a => Baz T where ...
-- The decl is an orphan if Baz and T are both not locally defined,
-- even if Foo *is* locally defined
isOrphanDecl this_mod (RuleD (HsRule _ _ _ lhs _ _))
= check lhs
where
-- At the moment we just check for common LHS forms
-- Expand as necessary. Getting it wrong just means
-- more orphans than necessary
check (HsVar v) = not (nameIsLocalOrFrom this_mod v)
check (HsApp f a) = check f && check a
check (HsLit _) = False
check (HsOverLit _) = False
check (OpApp l o _ r) = check l && check o && check r
check (NegApp e) = check e
check (HsPar e) = check e
check (SectionL e o) = check e && check o
check (SectionR o e) = check e && check o
check other = True -- Safe fall through
isOrphanDecl _ _ = False
\end{code}
%*********************************************************
......
......@@ -17,7 +17,7 @@ module Rules (
import CoreSyn -- All of it
import OccurAnal ( occurAnalyseRule )
import CoreFVs ( exprFreeVars, ruleRhsFreeVars, ruleSomeLhsFreeVars )
import CoreFVs ( exprFreeVars, ruleRhsFreeVars, ruleLhsFreeIds )
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
import CoreUtils ( eqExpr )
import PprCore ( pprCoreRule )
......@@ -487,8 +487,8 @@ extendRuleBase (RuleBase rule_ids rule_fvs) (id, rule)
Nothing -> emptyCoreRules
Just id' -> idSpecialisation id'
lhs_fvs = ruleSomeLhsFreeVars isId rule
-- Find *all* the free Ids of the LHS, not just
lhs_fvs = ruleLhsFreeIds rule
-- Finds *all* the free Ids of the LHS, not just
-- locally defined ones!!
pprRuleBase :: RuleBase -> SDoc
......
Supports Markdown
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