exprSomeFreeVars, exprsSomeFreeVars,
idRuleVars, idFreeVars, idFreeTyVars,
- ruleSomeFreeVars, ruleSomeLhsFreeVars, ruleRhsFreeVars,
+ ruleSomeFreeVars, ruleRhsFreeVars,
+ ruleLhsFreeNames, ruleLhsFreeIds,
CoreExprWithFVs, -- = AnnExpr Id VarSet
CoreBindWithFVs, -- = AnnBind Id VarSet
#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}
\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
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}
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,
)
import IdInfo {- loads of stuff -}
import Name ( getOccName, nameOccName, globaliseName, setNameOcc,
- localiseName, isGlobalName, isLocalName
+ localiseName, isGlobalName
)
import NameEnv ( filterNameEnv )
import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
| 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}
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
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"
\begin{code}
module MkIface (
- completeIface, writeIface,
+ mkFinalIface,
pprModDetails, pprIface, pprUsage
) where
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,
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}
%************************************************************************
\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]
RdrNameStmt
)
import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl,
- extractHsTyNames, RenamedStmt,
+ RenamedStmt,
instDeclFVs, tyClDeclFVs, ruleDeclFVs
)
closeDecls,
RecompileRequired, outOfDate, recompileRequired
)
-import RnHiFiles ( readIface, removeContext, loadInterface,
+import RnHiFiles ( readIface, loadInterface,
loadExports, loadFixDecls, loadDeprecs,
)
import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv,
moduleNameUserString, moduleName,
moduleEnvElts
)
-import Name ( Name, nameIsLocalOrFrom, nameModule )
+import Name ( Name, nameModule )
import NameEnv
import NameSet
import RdrName ( foldRdrEnv, isQual )
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
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,
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}
%*********************************************************
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 )
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
projects / ghc-hetmet.git / commitdiff