import CmLink
import CmTypes
+import CmStaticInfo ( GhciMode(..) )
+import DriverPipeline
+import DriverFlags ( getDynFlags )
+import DriverPhases
+import DriverUtil
+import Finder
+import HscMain ( initPersistentCompilerState )
import HscTypes
import RnEnv ( unQualInScope )
import Id ( idType, idName )
-import Name ( Name, lookupNameEnv, extendNameEnvList,
- NamedThing(..) )
-import RdrName ( emptyRdrEnv )
-import Module ( Module, ModuleName, moduleName, isHomeModule,
- mkModuleName, moduleNameUserString, moduleUserString )
-import CmStaticInfo ( GhciMode(..) )
-import DriverPipeline
+import Name ( Name, NamedThing(..), nameRdrName )
+import NameEnv
+import RdrName ( lookupRdrEnv, emptyRdrEnv )
+import Module
import GetImports
import Type ( tidyType )
import VarEnv ( emptyTidyEnv )
-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 )
-import DriverPhases
-import DriverUtil ( splitFilename3 )
import ErrUtils ( showPass )
import Util
-import DriverUtil
import TmpFiles
import Outputable
import Panic
import Exception ( throwDyn )
-- std
-import Time ( ClockTime )
import Directory ( getModificationTime, doesFileExist )
import IO
import Monad
Nothing -> do
mod <- moduleNameToModule mn
if isHomeModule mod
- then throwDyn (OtherError (showSDoc
+ then throwDyn (CmdLineError (showSDoc
(quotes (ppr (moduleName mod))
<+> text "is not currently loaded")))
else return mod
moduleNameToModule mn
= do maybe_stuff <- findModule mn
case maybe_stuff of
- Nothing -> throwDyn (OtherError ("can't find module `"
+ Nothing -> throwDyn (CmdLineError ("can't find module `"
++ moduleNameUserString mn ++ "'"))
Just (m,_) -> return m
ic_module = this_mod } = icontext
(new_pcs, maybe_stuff)
- <- hscStmt dflags hst hit pcs icontext expr
+ <- hscStmt dflags hst hit pcs icontext expr False{-stmt-}
case maybe_stuff of
Nothing -> return (cmstate{ pcs=new_pcs }, [])
- Just (ids, bcos) -> do
+ Just (ids, _, bcos) -> do
-- update the interactive context
let
- new_rn_env = extendLocalRdrEnv rn_env (map idName ids)
+ names = map idName ids
- -- Extend the renamer-env from bound_ids, not
- -- bound_names, because the latter may contain
- -- [it] when the former is empty
- new_type_env = extendNameEnvList type_env
+ -- these names have just been shadowed
+ shadowed = [ n | r <- map nameRdrName names,
+ Just n <- [lookupRdrEnv rn_env r] ]
+
+ new_rn_env = extendLocalRdrEnv rn_env names
+
+ -- remove any shadowed bindings from the type_env
+ filtered_type_env = delListFromNameEnv type_env shadowed
+
+ new_type_env = extendNameEnvList filtered_type_env
[ (getName id, AnId id) | id <- ids]
new_ic = icontext { ic_rn_env = new_rn_env,
let thing_to_run = unsafeCoerce# hval :: IO [HValue]
hvals <- thing_to_run
- -- get the newly bound things, and bind them
- let names = map idName ids
- new_pls <- updateClosureEnv pls (zip names hvals)
+ -- Get the newly bound things, and bind them. Don't forget
+ -- to delete any shadowed bindings from the closure_env, lest
+ -- we end up with a space leak.
+ pls <- delListFromClosureEnv pls shadowed
+ new_pls <- addListToClosureEnv pls (zip names hvals)
return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names)
where
#ifdef GHCI
cmTypeOfExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe String)
cmTypeOfExpr cmstate dflags expr
- = do (new_cmstate, names)
- <- cmRunStmt cmstate dflags ("let __cmTypeOfExpr=" ++ expr)
- case names of
- [name] -> do maybe_tystr <- cmTypeOfName new_cmstate name
- return (new_cmstate, maybe_tystr)
- _other -> pprPanic "cmTypeOfExpr" (ppr names)
+ = do (new_pcs, maybe_stuff)
+ <- hscStmt dflags hst hit pcs ic expr True{-just an expr-}
+
+ let new_cmstate = cmstate{pcs = new_pcs}
+
+ case maybe_stuff of
+ Nothing -> return (new_cmstate, Nothing)
+ Just (_, ty, _) ->
+ let pit = pcs_PIT pcs
+ modname = moduleName (ic_module ic)
+ tidy_ty = tidyType emptyTidyEnv ty
+ str = case lookupIfaceByModName hit pit modname of
+ Nothing -> showSDoc (ppr tidy_ty)
+ Just iface -> showSDocForUser unqual (ppr tidy_ty)
+ where unqual = unQualInScope (mi_globals iface)
+ in return (new_cmstate, Just str)
+ where
+ CmState{ hst=hst, hit=hit, pcs=pcs, ic=ic } = cmstate
#endif
-----------------------------------------------------------------------------
(new_pcs, maybe_stuff)
<- hscStmt dflags hst hit pcs icontext
- ("let __cmCompileExpr="++expr)
+ ("let __cmCompileExpr = "++expr) False{-stmt-}
case maybe_stuff of
Nothing -> return (cmstate{ pcs=new_pcs }, Nothing)
- Just (ids, bcos) -> do
+ Just (ids, _, bcos) -> do
-- link it
hval <- linkExpr pls bcos
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
-- only linkables newer than the source code are valid
- maybe_src_date = ms_hs_date summary
+ src_date = ms_hs_date summary
valid_linkable
- = case maybe_src_date of
- Nothing -> panic "valid_linkable_list"
- Just src_date
- -> filter (\l -> linkableTime l > src_date) linkable
+ = filter (\l -> linkableTime l > src_date) linkable
return (valid_linkable ++ new_linkables)
-- 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
-> [ModuleName]
-> IO (CmThreaded, Maybe Linkable)
-upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_from_here
+upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me
= do
let mod_name = name_of_summary summary1
let verb = verbosity dflags
source_unchanged = isJust maybe_old_linkable
+ reachable_only = filter (/= (name_of_summary summary1))
+ reachable_inc_me
+
+ -- in interactive mode, all home modules below us *must* have an
+ -- interface in the HIT. We never demand-load home interfaces in
+ -- interactive mode.
(hst1_strictDC, hit1_strictDC)
- = retainInTopLevelEnvs
- (filter (/= (name_of_summary summary1)) reachable_from_here)
- (hst1,hit1)
+ = ASSERT(ghci_mode == Batch ||
+ all (`elemUFM` hit1) reachable_only)
+ retainInTopLevelEnvs reachable_only (hst1,hit1)
old_linkable
= unJust "upsweep_mod:old_linkable" maybe_old_linkable
+ have_object
+ | Just l <- maybe_old_linkable, isObjectLinkable l = True
+ | otherwise = False
+
compresult <- compile ghci_mode summary1 source_unchanged
- old_iface hst1_strictDC hit1_strictDC pcs1
+ have_object old_iface hst1_strictDC hit1_strictDC pcs1
case compresult of
- -- Compilation "succeeded", but didn't return a new
- -- linkable, meaning that compilation wasn't needed, and the
- -- new details were manufactured from the old iface.
- CompOK pcs2 new_details new_iface Nothing
- -> do let hst2 = addToUFM hst1 mod_name new_details
- hit2 = addToUFM hit1 mod_name new_iface
- threaded2 = CmThreaded pcs2 hst2 hit2
-
- if ghci_mode == Interactive && verb >= 1 then
- -- if we're using an object file, tell the user
- case old_linkable of
- (LM _ _ objs@(DotO _:_))
- -> do hPutStrLn stderr (showSDoc (space <>
- parens (hsep (text "using":
- punctuate comma
- [ text o | DotO o <- objs ]))))
- _ -> return ()
- else
- return ()
-
- return (threaded2, Just old_linkable)
-
- -- Compilation really did happen, and succeeded. A new
- -- details, iface and linkable are returned.
- CompOK pcs2 new_details new_iface (Just new_linkable)
+ -- Compilation "succeeded", and may or may not have returned a new
+ -- linkable (depending on whether compilation was actually performed
+ -- or not).
+ CompOK pcs2 new_details new_iface maybe_new_linkable
-> do let hst2 = addToUFM hst1 mod_name new_details
hit2 = addToUFM hit1 mod_name new_iface
threaded2 = CmThreaded pcs2 hst2 hit2
- return (threaded2, Just new_linkable)
+ return (threaded2, if isJust maybe_new_linkable
+ then maybe_new_linkable
+ else Just old_linkable)
-- Compilation failed. compile may still have updated
-- the PCS, tho.
downwards_closure_of_module :: [ModSummary] -> ModuleName -> [ModuleName]
downwards_closure_of_module summaries root
= let toEdge :: ModSummary -> (ModuleName,[ModuleName])
- toEdge summ = (name_of_summary summ, ms_allimps summ)
- res = simple_transitive_closure (map toEdge summaries) [root]
+ toEdge summ = (name_of_summary summ,
+ filter (`elem` all_mods) (ms_allimps summ))
+
+ all_mods = map name_of_summary summaries
+
+ res = simple_transitive_closure (map toEdge summaries) [root]
in
--trace (showSDoc (text "DC of mod" <+> ppr root
-- <+> text "=" <+> ppr res)) (
rootSummaries
all_summaries
<- loop (concat (map ms_imps rootSummaries))
- (filter (isHomeModule.ms_mod) rootSummaries)
+ (mkModuleEnv [ (mod, s) | s <- rootSummaries,
+ let mod = ms_mod s, isHomeModule mod
+ ])
return (all_summaries, a_root_is_Main)
where
getRootSummary :: FilePath -> IO ModSummary
| haskellish_file file
= do exists <- doesFileExist file
if exists then summariseFile file else do
- throwDyn (OtherError ("can't find file `" ++ file ++ "'"))
+ throwDyn (CmdLineError ("can't find file `" ++ file ++ "'"))
| otherwise
= do exists <- doesFileExist hs_file
if exists then summariseFile hs_file else do
exists <- doesFileExist lhs_file
if exists then summariseFile lhs_file else do
- getSummary (mkModuleName file)
+ let mod_name = mkModuleName file
+ maybe_summary <- getSummary mod_name
+ case maybe_summary of
+ Nothing -> packageModErr mod_name
+ Just s -> return s
where
hs_file = file ++ ".hs"
lhs_file = file ++ ".lhs"
- getSummary :: ModuleName -> IO ModSummary
+ getSummary :: ModuleName -> IO (Maybe ModSummary)
getSummary nm
= do found <- findModule nm
case found of
Just (mod, location) -> do
let old_summary = findModInSummaries old_summaries mod
- new_summary <- summarise mod location old_summary
- case new_summary of
- Nothing -> return (fromJust old_summary)
- Just s -> return s
+ summarise mod location old_summary
- Nothing -> throwDyn (OtherError
+ Nothing -> throwDyn (CmdLineError
("can't find module `"
++ showSDoc (ppr nm) ++ "'"))
-
- -- loop invariant: home_summaries doesn't contain package modules
- loop :: [ModuleName] -> [ModSummary] -> IO [ModSummary]
- loop [] home_summaries = return home_summaries
- loop imps home_summaries
- = do -- all modules currently in homeSummaries
- let all_home = map (moduleName.ms_mod) home_summaries
- -- imports for modules we don't already have
- let needed_imps = nub (filter (`notElem` all_home) imps)
+ -- loop invariant: env doesn't contain package modules
+ loop :: [ModuleName] -> ModuleEnv ModSummary -> IO [ModSummary]
+ loop [] env = return (moduleEnvElts env)
+ loop imps env
+ = do -- imports for modules we don't already have
+ let needed_imps = nub (filter (not . (`elemUFM` env)) imps)
-- summarise them
needed_summaries <- mapM getSummary needed_imps
-- get just the "home" modules
- let new_home_summaries
- = filter (isHomeModule.ms_mod) needed_summaries
+ let new_home_summaries = [ s | Just s <- needed_summaries ]
-- loop, checking the new imports
let new_imps = concat (map ms_imps new_home_summaries)
- loop new_imps (new_home_summaries ++ home_summaries)
+ loop new_imps (extendModuleEnvList env
+ [ (ms_mod s, s) | s <- new_home_summaries ])
-----------------------------------------------------------------------------
-- Summarising modules
Just (mod, location)
<- mkHomeModuleLocn mod_name (path ++ '/':basename) file
- maybe_src_timestamp
+ src_timestamp
<- case ml_hs_file location of
- Nothing -> return Nothing
- Just src_fn -> maybe_getModificationTime src_fn
+ Nothing -> noHsFileErr mod_name
+ Just src_fn -> getModificationTime src_fn
return (ModSummary mod
location{ml_hspp_file=Just hspp_fn}
- srcimps imps
- maybe_src_timestamp)
+ srcimps imps src_timestamp)
-- Summarise a module, and pick up source and timestamp.
-summarise :: Module -> ModuleLocation -> Maybe ModSummary
- -> IO (Maybe ModSummary)
+summarise :: Module -> ModuleLocation -> Maybe ModSummary
+ -> IO (Maybe ModSummary)
summarise mod location old_summary
| isHomeModule mod
= do let hs_fn = unJust "summarise" (ml_hs_file location)
- maybe_src_timestamp
+ src_timestamp
<- case ml_hs_file location of
- Nothing -> return Nothing
- Just src_fn -> maybe_getModificationTime src_fn
+ Nothing -> noHsFileErr mod
+ Just src_fn -> getModificationTime src_fn
-- return the cached summary if the source didn't change
case old_summary of {
- Just s | ms_hs_date s == maybe_src_timestamp -> return Nothing;
+ Just s | ms_hs_date s == src_timestamp -> return (Just s);
_ -> do
hspp_fn <- preprocess hs_fn
modsrc <- readFile hspp_fn
let (srcimps,imps,mod_name) = getImports modsrc
- maybe_src_timestamp
- <- case ml_hs_file location of
- Nothing -> return Nothing
- Just src_fn -> maybe_getModificationTime src_fn
-
when (mod_name /= moduleName mod) $
- throwDyn (OtherError
- (showSDoc (text "file name does not match module name: "
- <+> ppr (moduleName mod) <+> text "vs"
- <+> ppr mod_name)))
+ throwDyn (ProgramError
+ (showSDoc (text modsrc
+ <> text ": file name does not match module name"
+ <+> quotes (ppr (moduleName mod)))))
return (Just (ModSummary mod location{ml_hspp_file=Just hspp_fn}
- srcimps imps
- maybe_src_timestamp))
+ srcimps imps src_timestamp))
}
- | otherwise
- = return (Just (ModSummary mod location [] [] Nothing))
+ | otherwise = return Nothing
+
+noHsFileErr mod
+ = panic (showSDoc (text "no source file for module" <+> quotes (ppr mod)))
-maybe_getModificationTime :: FilePath -> IO (Maybe ClockTime)
-maybe_getModificationTime fn
- = (do time <- getModificationTime fn
- return (Just time))
- `catch`
- (\err -> return Nothing)
+packageModErr mod
+ = throwDyn (CmdLineError (showSDoc (text "module" <+>
+ quotes (ppr mod) <+>
+ text "is a package module")))
\end{code}
projects / ghc-hetmet.git / blobdiff