--- For each module in mods_to_group, extract the relevant linkable
--- out of "ui", and arrange these linkables in SCCs as defined by modGraph.
--- All this is so that we can pass SCCified Linkable groups to the
--- linker. A constraint that should be recorded somewhere is that
--- all sccs should either be all-interpreted or all-object, not a mixture.
-group_uis :: UnlinkedImage -> [SCC ModSummary] -> [ModuleName] -> [SCC Linkable]
-group_uis ui modGraph mods_to_group
- = map extract (cleanup (fishOut modGraph mods_to_group))
- where
- fishOut :: [SCC ModSummary] -> [ModuleName] -> [(Bool,[ModuleName])]
- fishOut [] unused
- | null unused = []
- | otherwise = panic "group_uis: modnames not in modgraph"
- fishOut ((AcyclicSCC ms):sccs) unused
- = case split (== (name_of_summary ms)) unused of
- (eq, not_eq) -> (False, eq) : fishOut sccs not_eq
- fishOut ((CyclicSCC mss):sccs) unused
- = case split (`elem` (map name_of_summary mss)) unused of
- (eq, not_eq) -> (True, eq) : fishOut sccs not_eq
-
- cleanup :: [(Bool,[ModuleName])] -> [SCC ModuleName]
- cleanup [] = []
- cleanup ((isRec,names):rest)
- | null names = cleanup rest
- | isRec = CyclicSCC names : cleanup rest
- | not isRec = case names of [name] -> AcyclicSCC name : cleanup rest
- other -> panic "group_uis(cleanup)"
-
- extract :: SCC ModuleName -> SCC Linkable
- extract (AcyclicSCC nm) = AcyclicSCC (getLi nm)
- extract (CyclicSCC nms) = CyclicSCC (map getLi nms)
-
- getLi nm = case [li | li <- ui, not (is_package_linkable li),
- nm == modname_of_linkable li] of
- [li] -> li
- other -> panic "group_uis:getLi"
-
- split f xs = (filter f xs, filter (not.f) xs)
-
-
--- Add the given (LM-form) Linkables to the UI, overwriting previous
--- versions if they exist.
-add_to_ui :: UnlinkedImage -> [Linkable] -> UnlinkedImage
-add_to_ui ui lis
- = foldr add1 ui lis
+ let cmstate3 = cmstate1 { cm_mg = modsDone, cm_hsc = hsc_env3 }
+ cmLoadFinish Succeeded linkresult cmstate3
+
+ else
+ -- Tricky. We need to back out the effects of compiling any
+ -- half-done cycles, both so as to clean up the top level envs
+ -- and to avoid telling the interactive linker to link them.
+ do when (verb >= 2) $
+ hPutStrLn stderr "Upsweep partially successful."
+
+ let modsDone_names
+ = map modSummaryName modsDone
+ let mods_to_zap_names
+ = findPartiallyCompletedCycles modsDone_names
+ mg2_with_srcimps
+ let mods_to_keep
+ = filter ((`notElem` mods_to_zap_names).modSummaryName)
+ modsDone
+
+ let hpt4 = retainInTopLevelEnvs (map modSummaryName mods_to_keep)
+ (hsc_HPT hsc_env3)
+
+ -- Clean up after ourselves
+ cleanTempFilesExcept verb (ppFilesFromSummaries mods_to_keep)
+
+ -- Link everything together
+ linkresult <- link ghci_mode dflags False hpt4
+
+ let cmstate3 = cmstate1 { cm_mg = mods_to_keep,
+ cm_hsc = hsc_env3 { hsc_HPT = hpt4 } }
+ cmLoadFinish Failed linkresult cmstate3
+
+
+-- Finish up after a cmLoad.
+
+-- If the link failed, unload everything and return.
+cmLoadFinish ok Failed cmstate
+ = do cm_unload (cm_hsc cmstate) []
+ return (discardCMInfo cmstate, Failed, [])
+
+-- Empty the interactive context and set the module context to the topmost
+-- newly loaded module, or the Prelude if none were loaded.
+cmLoadFinish ok Succeeded cmstate
+ = do let new_cmstate = cmstate { cm_ic = emptyInteractiveContext }
+ mods_loaded = map (moduleNameUserString.modSummaryName)
+ (cm_mg cmstate)
+
+ return (new_cmstate, ok, mods_loaded)
+
+-- used to fish out the preprocess output files for the purposes of
+-- cleaning up. The preprocessed file *might* be the same as the
+-- source file, but that doesn't do any harm.
+ppFilesFromSummaries summaries
+ = [ fn | Just fn <- map (ml_hspp_file.ms_location) summaries ]
+
+-----------------------------------------------------------------------------
+-- getValidLinkables
+
+-- For each module (or SCC of modules), we take:
+--
+-- - an on-disk linkable, if this is the first time around and one
+-- is available.
+--
+-- - the old linkable, otherwise (and if one is available).
+--
+-- and we throw away the linkable if it is older than the source file.
+-- In interactive mode, we also ignore the on-disk linkables unless
+-- all of the dependents of this SCC also have on-disk linkables (we
+-- can't have dynamically loaded objects that depend on interpreted
+-- modules in GHCi).
+--
+-- If a module has a valid linkable, then it may be STABLE (see below),
+-- and it is classified as SOURCE UNCHANGED for the purposes of calling
+-- compile.
+--
+-- ToDo: this pass could be merged with the preUpsweep.
+
+getValidLinkables
+ :: GhciMode
+ -> [Linkable] -- old linkables
+ -> [ModuleName] -- all home modules
+ -> [SCC ModSummary] -- all modules in the program, dependency order
+ -> IO ( [Linkable], -- still-valid linkables
+ [Linkable] -- new linkables we just found
+ )
+
+getValidLinkables mode old_linkables all_home_mods module_graph = do
+ ls <- foldM (getValidLinkablesSCC mode old_linkables all_home_mods)
+ [] module_graph
+ return (partition_it ls [] [])
+ where
+ partition_it [] valid new = (valid,new)
+ partition_it ((l,b):ls) valid new
+ | b = partition_it ls valid (l:new)
+ | otherwise = partition_it ls (l:valid) new
+
+
+getValidLinkablesSCC mode old_linkables all_home_mods new_linkables scc0
+ = let
+ scc = flattenSCC scc0
+ scc_names = map modSummaryName scc
+ home_module m = m `elem` all_home_mods && m `notElem` scc_names
+ scc_allhomeimps = nub (filter home_module (concatMap ms_imps scc))
+ -- NB. ms_imps, not ms_allimps above. We don't want to
+ -- force a module's SOURCE imports to be already compiled for
+ -- its object linkable to be valid.
+
+ has_object m =
+ case findModuleLinkable_maybe (map fst new_linkables) m of
+ Nothing -> False
+ Just l -> isObjectLinkable l
+
+ objects_allowed = mode == Batch || all has_object scc_allhomeimps
+ in do
+
+ new_linkables'
+ <- foldM (getValidLinkable old_linkables objects_allowed) [] scc
+
+ -- since an scc can contain only all objects or no objects at all,
+ -- we have to check whether we got all objects or not, and re-do
+ -- the linkable check if not.
+ new_linkables' <-
+ if objects_allowed
+ && not (all isObjectLinkable (map fst new_linkables'))
+ then foldM (getValidLinkable old_linkables False) [] scc
+ else return new_linkables'
+
+ return (new_linkables ++ new_linkables')
+
+
+getValidLinkable :: [Linkable] -> Bool -> [(Linkable,Bool)] -> ModSummary
+ -> IO [(Linkable,Bool)]
+ -- True <=> linkable is new; i.e. freshly discovered on the disk
+ -- presumably generated 'on the side'
+ -- by a separate GHC run
+getValidLinkable old_linkables objects_allowed new_linkables summary
+ -- 'objects_allowed' says whether we permit this module to
+ -- have a .o-file linkable. We only permit it if all the
+ -- modules it depends on also have .o files; a .o file can't
+ -- link to a bytecode module
+ = do let mod_name = modSummaryName summary
+
+ maybe_disk_linkable
+ <- if (not objects_allowed)
+ then return Nothing
+
+ else findLinkable mod_name (ms_location summary)
+
+ let old_linkable = findModuleLinkable_maybe old_linkables mod_name
+
+ new_linkables' =
+ case (old_linkable, maybe_disk_linkable) of
+ (Nothing, Nothing) -> []
+
+ -- new object linkable just appeared
+ (Nothing, Just l) -> up_to_date l True
+
+ (Just l, Nothing)
+ | isObjectLinkable l -> []
+ -- object linkable disappeared! In case we need to
+ -- relink the module, disregard the old linkable and
+ -- just interpret the module from now on.
+ | otherwise -> up_to_date l False
+ -- old byte code linkable
+
+ (Just l, Just l')
+ | not (isObjectLinkable l) -> up_to_date l False
+ -- if the previous linkable was interpreted, then we
+ -- ignore a newly compiled version, because the version
+ -- numbers in the interface file will be out-of-sync with
+ -- our internal ones.
+ | linkableTime l' > linkableTime l -> up_to_date l' True
+ | linkableTime l' == linkableTime l -> up_to_date l False
+ | otherwise -> []
+ -- on-disk linkable has been replaced by an older one!
+ -- again, disregard the previous one.
+
+ up_to_date l b
+ | linkableTime l < ms_hs_date summary = []
+ | otherwise = [(l,b)]
+ -- why '<' rather than '<=' above? If the filesystem stores
+ -- times to the nearset second, we may occasionally find that
+ -- the object & source have the same modification time,
+ -- especially if the source was automatically generated
+ -- and compiled. Using >= is slightly unsafe, but it matches
+ -- make's behaviour.
+
+ return (new_linkables' ++ new_linkables)
+
+
+hptLinkables :: HomePackageTable -> [Linkable]
+-- Get all the linkables from the home package table, one for each module
+-- Once the HPT is up to date, these are the ones we should link
+hptLinkables hpt = map hm_linkable (moduleEnvElts hpt)
+
+
+-----------------------------------------------------------------------------
+-- 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 HPT (interactive mode only)
+
+preUpsweep :: [Linkable] -- new valid linkables
+ -> [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)
+ = do let scc = flattenSCC scc0
+ scc_allhomeimps :: [ModuleName]
+ scc_allhomeimps
+ = nub (filter (`elem` all_home_mods) (concatMap ms_allimps scc))
+ all_imports_in_scc_or_stable
+ = all in_stable_or_scc scc_allhomeimps
+ scc_names
+ = map modSummaryName scc
+ in_stable_or_scc m
+ = m `elem` scc_names || m `elem` stable
+
+ -- now we check for valid linkables: each module in the SCC must
+ -- have a valid linkable (see getValidLinkables above).
+ has_valid_linkable new_summary
+ = isJust (findModuleLinkable_maybe valid_lis modname)
+ where modname = modSummaryName new_summary
+
+ scc_is_stable = all_imports_in_scc_or_stable
+ && all has_valid_linkable 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
+
+
+-- Helper for preUpsweep. Assuming that new_summary's imports are all
+-- stable (in the sense of preUpsweep), determine if new_summary is itself
+-- stable, and, if so, in batch mode, return its linkable.
+findInSummaries :: [ModSummary] -> ModuleName -> [ModSummary]
+findInSummaries old_summaries mod_name
+ = [s | s <- old_summaries, modSummaryName s == mod_name]
+
+findModInSummaries :: [ModSummary] -> Module -> Maybe ModSummary
+findModInSummaries old_summaries mod
+ = case [s | s <- old_summaries, ms_mod s == mod] of
+ [] -> Nothing
+ (s:_) -> Just s
+
+-- Return (names of) all those in modsDone who are part of a cycle
+-- as defined by theGraph.
+findPartiallyCompletedCycles :: [ModuleName] -> [SCC ModSummary] -> [ModuleName]
+findPartiallyCompletedCycles modsDone theGraph
+ = chew theGraph