import Interpreter
import DriverPipeline
+import ByteCodeLink ( linkIModules, linkIExpr )
import CmTypes
import CmStaticInfo ( GhciMode(..) )
import Outputable ( SDoc )
import HscTypes
import HscMain ( initPersistentCompilerState )
import Finder
-import UniqFM ( lookupUFM, addToUFM, delListFromUFM,
- UniqFM, listToUFM )
+import UniqFM
import Unique ( Uniquable )
import Digraph ( SCC(..), stronglyConnComp, flattenSCC )
import DriverFlags ( getDynFlags )
case names of
[name] -> do maybe_tystr <- cmTypeOfName new_cmstate name
return (new_cmstate, maybe_tystr)
- _other -> pprPanic "cmTypeOfExpr" (ppr names)
+ _other -> return (new_cmstate, Nothing)
#endif
-----------------------------------------------------------------------------
let ghci_mode = gmode cmstate1 -- this never changes
-- Do the downsweep to reestablish the module graph
- -- then generate version 2's by retaining in HIT,HST,UI a
- -- stable set S of modules, as defined below.
-
dflags <- getDynFlags
let verb = verbosity dflags
-- 1. All home imports of ms are either in ms or S
-- 2. A valid linkable exists for each module in ms
- stable_mods
- <- preUpsweep valid_linkables mg2unsorted_names [] mg2_with_srcimps
+ stable_mods <- preUpsweep valid_linkables hit1
+ mg2unsorted_names [] mg2_with_srcimps
let stable_summaries
= concatMap (findInSummaries mg2unsorted) stable_mods
getValidLinkable old_linkables objects_allowed new_linkables summary
= do let mod_name = name_of_summary summary
- -- we only look for objects on disk the first time around;
- -- if the user compiles a module on the side during a GHCi session,
- -- it won't be picked up until the next ":load". This is what the
- -- "null old_linkables" test below is.
maybe_disk_linkable
<- if (not objects_allowed)
then return Nothing
Nothing -> False
Just l_disk -> linkableTime l == linkableTime l_disk
+ -- we only look for objects on disk the first time around;
+ -- if the user compiles a module on the side during a GHCi session,
+ -- it won't be picked up until the next ":load". This is what the
+ -- "null old_linkables" test below is.
linkable | null old_linkables = maybeToList maybe_disk_linkable
| otherwise = maybeToList maybe_old_linkable
-- Do a pre-upsweep without use of "compile", to establish a
-- (downward-closed) set of stable modules for which we won't call compile.
+-- a stable module:
+-- * has a valid linkable (see getValidLinkables above)
+-- * depends only on stable modules
+-- * has an interface in the HIT (interactive mode only)
+
preUpsweep :: [Linkable] -- new valid linkables
+ -> HomeIfaceTable
-> [ModuleName] -- names of all mods encountered in downsweep
-> [ModuleName] -- accumulating stable modules
-> [SCC ModSummary] -- scc-ified mod graph, including src imps
-> IO [ModuleName] -- stable modules
-preUpsweep valid_lis all_home_mods stable [] = return stable
-preUpsweep valid_lis all_home_mods stable (scc0:sccs)
+preUpsweep valid_lis hit all_home_mods stable [] = return stable
+preUpsweep valid_lis hit all_home_mods stable (scc0:sccs)
= do let scc = flattenSCC scc0
scc_allhomeimps :: [ModuleName]
scc_allhomeimps
= isJust (findModuleLinkable_maybe valid_lis modname)
where modname = name_of_summary new_summary
+ has_interface summary = ms_mod summary `elemUFM` hit
+
scc_is_stable = all_imports_in_scc_or_stable
&& all has_valid_linkable scc
+ && all has_interface scc
if scc_is_stable
- then preUpsweep valid_lis all_home_mods (scc_names++stable) sccs
- else preUpsweep valid_lis all_home_mods stable sccs
-
- where
+ then preUpsweep valid_lis hit all_home_mods (scc_names++stable) sccs
+ else preUpsweep valid_lis hit all_home_mods stable sccs
-- Helper for preUpsweep. Assuming that new_summary's imports are all
\begin{code}
module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue,
filterNameMap,
- byteCodeGen, coreExprToBCOs,
- linkIModules, linkIExpr
+ byteCodeGen, coreExprToBCOs
) where
#include "HsVersions.h"
import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse )
import ByteCodeItbls ( ItblEnv, mkITbls )
import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
- ClosureEnv, HValue, linkSomeBCOs, filterNameMap,
+ ClosureEnv, HValue, filterNameMap,
iNTERP_STACK_CHECK_THRESH )
import List ( intersperse, sortBy )
root_bco <- assembleBCO root_proto_bco
return (root_bco, auxiliary_bcos)
-
-
--- Linking stuff
-linkIModules :: ItblEnv -- incoming global itbl env; returned updated
- -> ClosureEnv -- incoming global closure env; returned updated
- -> [([UnlinkedBCO], ItblEnv)]
- -> IO ([HValue], ItblEnv, ClosureEnv)
-linkIModules gie gce mods
- = do let (bcoss, ies) = unzip mods
- bcos = concat bcoss
- final_gie = foldr plusFM gie ies
- (final_gce, linked_bcos) <- linkSomeBCOs True final_gie gce bcos
- return (linked_bcos, final_gie, final_gce)
-
-
-linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr
- -> IO HValue -- IO BCO# really
-linkIExpr ie ce (root_ul_bco, aux_ul_bcos)
- = do (aux_ce, _) <- linkSomeBCOs False ie ce aux_ul_bcos
- (_, [root_bco]) <- linkSomeBCOs False ie aux_ce [root_ul_bco]
- return root_bco
\end{code}
%************************************************************************
\begin{code}
module ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
- ClosureEnv, HValue, linkSomeBCOs, filterNameMap,
+ ClosureEnv, HValue, filterNameMap,
+ linkIModules, linkIExpr,
iNTERP_STACK_CHECK_THRESH
) where
newAddrArray, writeAddrArray )
import Foreign ( Word16, Ptr(..) )
import Addr ( Word, Addr, nullAddr )
+import FiniteMap
import PrelBase ( Int(..) )
import PrelGHC ( BCO#, newBCO#, unsafeCoerce#,
%************************************************************************
\begin{code}
+-- Linking stuff
+linkIModules :: ItblEnv -- incoming global itbl env; returned updated
+ -> ClosureEnv -- incoming global closure env; returned updated
+ -> [([UnlinkedBCO], ItblEnv)]
+ -> IO ([HValue], ItblEnv, ClosureEnv)
+linkIModules gie gce mods
+ = do let (bcoss, ies) = unzip mods
+ bcos = concat bcoss
+ final_gie = foldr plusFM gie ies
+ (final_gce, linked_bcos) <- linkSomeBCOs True final_gie gce bcos
+ return (linked_bcos, final_gie, final_gce)
+
+
+linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr
+ -> IO HValue -- IO BCO# really
+linkIExpr ie ce (root_ul_bco, aux_ul_bcos)
+ = do (aux_ce, _) <- linkSomeBCOs False ie ce aux_ul_bcos
+ (_, [root_bco]) <- linkSomeBCOs False ie aux_ce [root_ul_bco]
+ return root_bco
-- Link a bunch of BCOs and return them + updated closure env.
linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
ce_top_additions = filter (isGlobalName.fst) ce_all_additions
ce_additions = if toplevs_only then ce_top_additions
else ce_all_additions
- ce_out = addListToFM ce_in ce_additions
+ ce_out = -- make sure we're not inserting duplicate names into the
+ -- closure environment, which leads to trouble.
+ ASSERT (all (not . (`elemFM` ce_in)) (map fst ce_additions))
+ addListToFM ce_in ce_additions
return (ce_out, hvals)
where
-- A lazier zip, in which no demand is propagated to the second
import Rename ( checkOldIface, renameModule, closeIfaceDecls )
import Rules ( emptyRuleBase )
import PrelInfo ( wiredInThingEnv, wiredInThings )
-import PrelNames ( vanillaSyntaxMap, knownKeyNames )
+import PrelNames ( vanillaSyntaxMap, knownKeyNames, iNTERACTIVE )
import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails,
writeIface, pprIface )
import TcModule
hscStmt dflags hst hit pcs0 icontext stmt
= let
InteractiveContext {
- ic_rn_env = rn_env,
+ ic_rn_env = rn_env,
ic_type_env = type_env,
- ic_module = this_mod } = icontext
+ ic_module = scope_mod } = icontext
in
do { maybe_stmt <- hscParseStmt dflags stmt
; case maybe_stmt of
-- Rename it
(pcs1, print_unqual, maybe_renamed_stmt)
- <- renameStmt dflags hit hst pcs0 this_mod rn_env parsed_stmt
+ <- renameStmt dflags hit hst pcs0 scope_mod
+ iNTERACTIVE rn_env parsed_stmt
+
; case maybe_renamed_stmt of
Nothing -> return (pcs0, Nothing)
Just (bound_names, rn_stmt) -> do {
-- Typecheck it
- maybe_tc_return <- typecheckStmt dflags pcs1 hst type_env
- print_unqual this_mod bound_names rn_stmt
+ maybe_tc_return
+ <- typecheckStmt dflags pcs1 hst type_env
+ print_unqual iNTERACTIVE bound_names rn_stmt
; case maybe_tc_return of {
Nothing -> return (pcs0, Nothing) ;
Just (pcs2, tc_expr, bound_ids) -> do {
-- Desugar it
- ds_expr <- deSugarExpr dflags pcs2 hst this_mod print_unqual tc_expr
+ ds_expr <- deSugarExpr dflags pcs2 hst iNTERACTIVE print_unqual tc_expr
-- Simplify it
; simpl_expr <- simplifyExpr dflags pcs2 hst ds_expr
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
- VersionInfo(..), initialVersionInfo,
+ VersionInfo(..), initialVersionInfo, lookupVersion,
TyThing(..), isTyClThing, implicitTyThingIds,
import FiniteMap ( FiniteMap )
import Bag ( Bag )
-import Maybes ( seqMaybe )
+import Maybes ( seqMaybe, orElse )
import Outputable
import SrcLoc ( SrcLoc, isGoodSrcLoc )
import Util ( thenCmp, sortLt )
-- The version of an Id changes if its fixity changes
-- Ditto data constructors, class operations, except that the version of
-- the parent class/tycon changes
+ --
+ -- If a name isn't in the map, it means 'initialVersion'
}
initialVersionInfo :: VersionInfo
initialVersionInfo = VersionInfo { vers_module = initialVersion,
vers_exports = initialVersion,
vers_rules = initialVersion,
- vers_decls = emptyNameEnv }
+ vers_decls = emptyNameEnv
+ }
+
+lookupVersion :: NameEnv Version -> Name -> Version
+lookupVersion env name = lookupNameEnv env name `orElse` initialVersion
data Deprecations = NoDeprecs
| DeprecAll DeprecTxt -- Whole module deprecated
\begin{code}
module MkIface (
mkModDetails, mkModDetailsFromIface, completeIface,
- writeIface, pprIface
+ writeIface, pprIface, pprUsage
) where
#include "HsVersions.h"
TyThing(..), DFunId, TypeEnv, Avails,
WhatsImported(..), GenAvailInfo(..),
ImportVersion, AvailInfo, Deprecations(..),
- extendTypeEnvList
+ extendTypeEnvList, lookupVersion,
)
import CmdLineOpts
import SrcLoc ( noSrcLoc )
import Outputable
import Module ( ModuleName )
+import Maybes ( orElse )
import IO ( IOMode(..), openFile, hClose )
\end{code}
where
final_iface = new_iface { mi_version = new_version }
- new_version = VersionInfo { vers_module = bumpVersion no_output_change (vers_module old_version),
+ old_mod_vers = vers_module old_version
+ new_version = VersionInfo { vers_module = bumpVersion no_output_change old_mod_vers,
vers_exports = bumpVersion no_export_change (vers_exports old_version),
vers_rules = bumpVersion no_rule_change (vers_rules old_version),
vers_decls = tc_vers }
-- Fill in the version number on the new declarations by looking at the old declarations.
-- Set the flag if anything changes.
-- Assumes that the decls are sorted by hsDeclName.
- old_vers_decls = vers_decls old_version
- (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_vers_decls old_fixities new_fixities
+ (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_version old_fixities new_fixities
(dcl_tycl old_decls) (dcl_tycl new_decls)
pp_diffs = vcat [pp_tc_diffs,
pp_change no_export_change "Export list",
pp_change True what = empty
pp_change False what = text what <+> ptext SLIT("changed")
-diffDecls :: NameEnv Version -- Old version map
+diffDecls :: VersionInfo -- Old version
-> NameEnv Fixity -> NameEnv Fixity -- Old and new fixities
-> [RenamedTyClDecl] -> [RenamedTyClDecl] -- Old and new decls
-> (Bool, -- True <=> no change
SDoc, -- Record of differences
- NameEnv Version) -- New version
+ NameEnv Version) -- New version map
-diffDecls old_vers old_fixities new_fixities old new
+diffDecls (VersionInfo { vers_module = old_mod_vers, vers_decls = old_decls_vers })
+ old_fixities new_fixities old new
= diff True empty emptyNameEnv old new
where
-- When seeing if two decls are the same,
same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n
diff ok_so_far pp new_vers [] [] = (ok_so_far, pp, new_vers)
- diff ok_so_far pp new_vers (od:ods) [] = diff False (pp $$ only_old od) new_vers ods []
- diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
+ diff ok_so_far pp new_vers (od:ods) [] = diff False (pp $$ only_old od) new_vers ods []
+ diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers_with_new [] nds
+ where
+ new_vers_with_new = extendNameEnv new_vers (tyClDeclName nd) (bumpVersion False old_mod_vers)
+ -- When adding a new item, start from the old module version
+ -- This way, if you have version 4 of f, then delete f, then add f again,
+ -- you'll get version 6 of f, which will (correctly) force recompilation of
+ -- clients
+
diff ok_so_far pp new_vers (od:ods) (nd:nds)
= case od_name `compare` nd_name of
LT -> diff False (pp $$ only_old od) new_vers ods (nd:nds)
GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
- EQ | od `eq_tc` nd -> diff ok_so_far pp new_vers ods nds
- | otherwise -> diff False (pp $$ changed od nd) new_vers' ods nds
+ EQ | od `eq_tc` nd -> diff ok_so_far pp new_vers ods nds
+ | otherwise -> diff False (pp $$ changed od nd) new_vers_with_diff ods nds
where
od_name = tyClDeclName od
nd_name = tyClDeclName nd
- new_vers' = extendNameEnv new_vers nd_name
- (bumpVersion False (lookupNameEnv_NF old_vers od_name))
+ new_vers_with_diff = extendNameEnv new_vers nd_name (bumpVersion False old_version)
+ old_version = lookupVersion old_decls_vers od_name
only_old d = ptext SLIT("Only in old iface:") <+> ppr d
only_new d = ptext SLIT("Only in new iface:") <+> ppr d
import RnHiFiles ( readIface, removeContext, loadInterface,
loadExports, loadFixDecls, loadDeprecs,
)
+import MkIface ( pprUsage )
import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv,
emptyAvailEnv, unitAvailEnv, availEnvElts,
plusAvailEnv, groupAvails, warnUnusedImports,
renameStmt :: DynFlags
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
- -> Module -- current context (module)
+ -> Module -- current context (scope to compile in)
+ -> Module -- current module
-> LocalRdrEnv -- current context (temp bindings)
-> RdrNameStmt -- parsed stmt
-> IO ( PersistentCompilerState,
Maybe ([Name], (SyntaxMap, RenamedStmt, [RenamedHsDecl]))
)
-renameStmt dflags hit hst pcs this_module local_env stmt
+renameStmt dflags hit hst pcs scope_module this_module local_env stmt
= renameSource dflags hit hst pcs this_module $
-- Load the interface for the context module, so
-- that we can get its top-level lexical environment
-- Bale out if we fail to do this
- loadInterface doc (moduleName this_module) ImportByUser `thenRn` \ iface ->
+ loadInterface doc (moduleName scope_module) ImportByUser `thenRn` \ iface ->
let rdr_env = mi_globals iface
print_unqual = unQualInScope rdr_env
in
-- GENERATE THE VERSION/USAGE INFO
mkImportInfo mod_name imports `thenRn` \ my_usages ->
+ traceHiDiffsRn (vcat (map pprUsage my_usages)) `thenRn_`
-- BUILD THE MODULE INTERFACE
let
import Type ( namesOfType )
import TyCon ( isSynTyCon, getSynTyConDefn )
import Name ( Name {-instance NamedThing-}, nameOccName,
- nameModule, isLocalName, isHomePackageName,
- NamedThing(..)
+ nameModule, isLocalName, NamedThing(..)
)
import Name ( elemNameEnv, delFromNameEnv )
import Module ( Module, ModuleEnv,
-- The sort is to put them into canonical order
mk_import_items ns = [(n,v) | n <- sortLt lt_occ ns,
- let v = lookupNameEnv version_env n `orElse`
- pprPanic "mk_whats_imported" (ppr n)
+ let v = lookupVersion version_env n
]
where
lt_occ n1 n2 = nameOccName n1 < nameOccName n2
\begin{code}
-recordSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped),
- iSlurp = slurped_names,
- iVSlurp = (imp_mods, imp_names) })
+recordDeclSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped),
+ iSlurp = slurped_names,
+ iVSlurp = vslurp })
avail
= ASSERT2( not (isLocalName (availName avail)), ppr avail )
- ifaces { iDecls = (decls_map', n_slurped+1),
+ ifaces { iDecls = (new_decls_map, n_slurped+1),
iSlurp = new_slurped_names,
- iVSlurp = new_vslurp }
+ iVSlurp = updateVSlurp vslurp (availName avail) }
where
- decls_map' = foldl delFromNameEnv decls_map (availNames avail)
- main_name = availName avail
+ new_decls_map = foldl delFromNameEnv decls_map (availNames avail)
new_slurped_names = addAvailToNameSet slurped_names avail
- new_vslurp | isHomePackageName main_name = (imp_mods, addOneToNameSet imp_names main_name)
- | otherwise = (extendModuleSet imp_mods mod, imp_names)
- mod = nameModule main_name
+recordVSlurp ifaces name = ifaces { iVSlurp = updateVSlurp (iVSlurp ifaces) name }
+
+updateVSlurp (imp_mods, imp_names) main_name
+ | isHomeModule mod = (imp_mods, addOneToNameSet imp_names main_name)
+ | otherwise = (extendModuleSet imp_mods mod, imp_names)
+ where
+ mod = nameModule main_name
+
recordLocalSlurps new_names
= getIfacesRn `thenRn` \ ifaces ->
setIfacesRn (ifaces { iSlurp = iSlurp ifaces `unionNameSets` new_names })
returnRn AlreadySlurped
else
+
-- STEP 2: Check if it's already in the type environment
getTypeEnvRn `thenRn` \ lookup ->
case lookup name of {
- Just ty_thing | name `elemNameEnv` wiredInThingEnv
- -> -- When we find a wired-in name we must load its home
- -- module so that we find any instance decls lurking therein
- loadHomeInterface wi_doc name `thenRn_`
- returnRn (InTypeEnv ty_thing)
-
- | otherwise
- -> returnRn (InTypeEnv ty_thing) ;
+ Just ty_thing
+ | name `elemNameEnv` wiredInThingEnv
+ -> -- When we find a wired-in name we must load its home
+ -- module so that we find any instance decls lurking therein
+ loadHomeInterface wi_doc name `thenRn_`
+ returnRn (InTypeEnv ty_thing)
+
+ | otherwise
+ -> -- Record that we use this thing. We must do this
+ -- regardless of whether we need to demand-slurp it in
+ -- or we already have it in the type environment. Why?
+ -- because the slurp information is used to generate usage
+ -- information in the interface.
+ setIfacesRn (recordVSlurp ifaces (getName ty_thing)) `thenRn_`
+ returnRn (InTypeEnv ty_thing) ;
Nothing ->
(decls_map, _) = iDecls ifaces
in
case lookupNameEnv decls_map name of
- Just (avail,_,decl)
- -> setIfacesRn (recordSlurp ifaces avail) `thenRn_`
- returnRn (HereItIs decl)
+ Just (avail,_,decl) -> setIfacesRn (recordDeclSlurp ifaces avail) `thenRn_`
+ returnRn (HereItIs decl)
- Nothing
- -> addErrRn (getDeclErr name) `thenRn_`
- returnRn AlreadySlurped
+ Nothing -> addErrRn (getDeclErr name) `thenRn_`
+ returnRn AlreadySlurped
}
where
wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name
from | is_boot = ImportByUserSource
| otherwise = ImportByUser
in
+ traceHiDiffsRn (text "Checking usages for module" <+> ppr mod_name) `thenRn_`
tryLoadInterface doc_str mod_name from `thenRn` \ (iface, maybe_err) ->
case maybe_err of {
out_of_date (sep [ptext SLIT("No longer exported:"), ppr name])
Just new_vers -- It's there, but is it up to date?
- | new_vers == old_vers -> returnRn upToDate
+ | new_vers == old_vers -> traceHiDiffsRn (text "Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenRn_` returnRn upToDate
| otherwise -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name])
up_to_date msg = traceHiDiffsRn msg `thenRn_` returnRn upToDate
liftedTypeKind, mkTyConApp, tidyType )
import ErrUtils ( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, showPass )
import Id ( Id, idType, idName, isLocalId, idUnfolding )
-import Module ( Module, isHomeModule, moduleName )
+import Module ( Module, moduleName )
import Name ( Name, toRdrName, isGlobalName )
import Name ( nameEnvElts, lookupNameEnv )
import TyCon ( tyConGenInfo )
-- (on the GHCi command line, for example). In this case, we
-- want to treat everything we pulled in as an imported thing.
imported_things
- | isHomeModule this_mod
- = filter (not . isLocalThing this_mod) all_things
- | otherwise
- = all_things
-
+ = filter (not . isLocalThing this_mod) all_things
+
new_pte :: PackageTypeEnv
new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
projects / ghc-hetmet.git / commitdiff