- :: [Linkable] -- old linkables
- -> [ModSummary] -- all modules in the program
- -> IO [Linkable] -- still-valid linkables
-
-getValidLinkables old_linkables summaries
- = do lis <- mapM (getValidLinkable old_linkables) summaries
- return (concat lis)
-
-getValidLinkable old_linkables summary
- = do let mod_name = moduleName (ms_mod summary)
- maybe_disk_linkable
- <- case ml_obj_file (ms_location summary) of
- Nothing -> return Nothing
- Just obj_fn -> maybe_getFileLinkable mod_name obj_fn
-
- -- find an old in-core linkable if we have one. (forget about
- -- on-disk linkables for now, we'll check again whether there's
- -- one here below, just in case a new one has popped up recently).
- let old_linkable = findModuleLinkable_maybe old_linkables mod_name
- maybe_old_linkable =
- case old_linkable of
- Just (LM _ _ ls) | all isInterpretable ls -> old_linkable
- _ -> Nothing
-
- -- The most recent of the old UI linkable or whatever we could
- -- find on disk is returned as the linkable if compile
- -- doesn't think we need to recompile.
- let linkable_list
- = case (maybe_old_linkable, maybe_disk_linkable) of
- (Nothing, Nothing) -> []
- (Nothing, Just di) -> [di]
- (Just ui, Nothing) -> [ui]
- (Just ui, Just di)
- | linkableTime ui >= linkableTime di -> [ui]
- | otherwise -> [di]
-
- -- only linkables newer than the source code are valid
- let maybe_src_date = ms_hs_date summary
-
- valid_linkable_list
- = case maybe_src_date of
- Nothing -> panic "valid_linkable_list"
- Just src_date
- -> filter (\li -> linkableTime li > src_date) linkable_list
-
- return valid_linkable_list
-
-
-
-maybe_getFileLinkable :: ModuleName -> FilePath -> IO (Maybe Linkable)
-maybe_getFileLinkable mod_name obj_fn
- = do obj_exist <- doesFileExist obj_fn
- if not obj_exist
- then return Nothing
- else
- do let stub_fn = case splitFilename3 obj_fn of
- (dir, base, ext) -> dir ++ "/" ++ base ++ ".stub_o"
- stub_exist <- doesFileExist stub_fn
- obj_time <- getModificationTime obj_fn
- if stub_exist
- then return (Just (LM obj_time mod_name [DotO obj_fn, DotO stub_fn]))
- else return (Just (LM obj_time mod_name [DotO obj_fn]))
+ :: 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)