--- - For non-stable modules:
--- - all ModDetails, all linked code
--- - all unlinked code that is out of date with respect to
--- the source file
---
--- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
--- space at the end of the upsweep, because the topmost ModDetails of the
--- old HPT holds on to the entire type environment from the previous
--- compilation.
-
-pruneHomePackageTable
- :: HomePackageTable
- -> [ModSummary]
- -> ([ModuleName],[ModuleName])
- -> HomePackageTable
-
-pruneHomePackageTable hpt summ (stable_obj, stable_bco)
- = mapUFM prune hpt
- where prune hmi
- | is_stable modl = hmi'
- | otherwise = hmi'{ hm_details = emptyModDetails }
- where
- modl = moduleName (mi_module (hm_iface hmi))
- hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
- = hmi{ hm_linkable = Nothing }
- | otherwise
- = hmi
- where ms = expectJust "prune" (lookupUFM ms_map modl)
-
- ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
-
- is_stable m = m `elem` stable_obj || m `elem` stable_bco
-
--- -----------------------------------------------------------------------------
-
--- Return (names of) all those in modsDone who are part of a cycle
--- as defined by theGraph.
-findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
-findPartiallyCompletedCycles modsDone theGraph
- = chew theGraph
- where
- chew [] = []
- chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting.
- chew ((CyclicSCC vs):rest)
- = let names_in_this_cycle = nub (map ms_mod vs)
- mods_in_this_cycle
- = nub ([done | done <- modsDone,
- done `elem` names_in_this_cycle])
- chewed_rest = chew rest
- in
- if notNull mods_in_this_cycle
- && length mods_in_this_cycle < length names_in_this_cycle
- then mods_in_this_cycle ++ chewed_rest
- else chewed_rest
-
--- -----------------------------------------------------------------------------
--- The upsweep
-
--- This is where we compile each module in the module graph, in a pass
--- from the bottom to the top of the graph.
-
--- There better had not be any cyclic groups here -- we check for them.
-
-upsweep
- :: HscEnv -- Includes initially-empty HPT
- -> HomePackageTable -- HPT from last time round (pruned)
- -> ([ModuleName],[ModuleName]) -- stable modules (see checkStability)
- -> IO () -- How to clean up unwanted tmp files
- -> [SCC ModSummary] -- Mods to do (the worklist)
- -> IO (SuccessFlag,
- HscEnv, -- With an updated HPT
- [ModSummary]) -- Mods which succeeded
-
-upsweep hsc_env old_hpt stable_mods cleanup sccs = do
- (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs)
- return (res, hsc_env, reverse done)
- where
-
- upsweep' hsc_env _old_hpt done
- [] _ _
- = return (Succeeded, hsc_env, done)
-
- upsweep' hsc_env _old_hpt done
- (CyclicSCC ms:_) _ _
- = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
- return (Failed, hsc_env, done)
-
- upsweep' hsc_env old_hpt done
- (AcyclicSCC mod:mods) mod_index nmods
- = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
- -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
- -- (moduleEnvElts (hsc_HPT hsc_env)))
-
- mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod
- mod_index nmods
-
- cleanup -- Remove unwanted tmp files between compilations
-
- case mb_mod_info of
- Nothing -> return (Failed, hsc_env, [])
- Just mod_info -> do
- let this_mod = ms_mod_name mod
-
- -- Add new info to hsc_env
- hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
- hsc_env1 = hsc_env { hsc_HPT = hpt1 }
-
- -- Space-saving: delete the old HPT entry
- -- for mod BUT if mod is a hs-boot
- -- node, don't delete it. For the
- -- interface, the HPT entry is probaby for the
- -- main Haskell source file. Deleting it
- -- would force the real module to be recompiled
- -- every time.
- old_hpt1 | isBootSummary mod = old_hpt
- | otherwise = delFromUFM old_hpt this_mod
-
- done' = mod:done
-
- -- fixup our HomePackageTable after we've finished compiling
- -- a mutually-recursive loop. See reTypecheckLoop, below.
- hsc_env2 <- reTypecheckLoop hsc_env1 mod done'
-
- upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods
-
-
--- Compile a single module. Always produce a Linkable for it if
--- successful. If no compilation happened, return the old Linkable.
-upsweep_mod :: HscEnv
- -> HomePackageTable
- -> ([ModuleName],[ModuleName])
- -> ModSummary
- -> Int -- index of module
- -> Int -- total number of modules
- -> IO (Maybe HomeModInfo) -- Nothing => Failed
-
-upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
- = let
- this_mod_name = ms_mod_name summary
- this_mod = ms_mod summary
- mb_obj_date = ms_obj_date summary
- obj_fn = ml_obj_file (ms_location summary)
- hs_date = ms_hs_date summary
-
- is_stable_obj = this_mod_name `elem` stable_obj
- is_stable_bco = this_mod_name `elem` stable_bco
-
- old_hmi = lookupUFM old_hpt this_mod_name
-
- -- We're using the dflags for this module now, obtained by
- -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
- dflags = ms_hspp_opts summary
- prevailing_target = hscTarget (hsc_dflags hsc_env)
- local_target = hscTarget dflags
-
- -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
- -- we don't do anything dodgy: these should only work to change
- -- from -fvia-C to -fasm and vice-versa, otherwise we could
- -- end up trying to link object code to byte code.
- target = if prevailing_target /= local_target
- && (not (isObjectTarget prevailing_target)
- || not (isObjectTarget local_target))
- then prevailing_target
- else local_target
-
- -- store the corrected hscTarget into the summary
- summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
-
- -- The old interface is ok if
- -- a) we're compiling a source file, and the old HPT
- -- entry is for a source file
- -- b) we're compiling a hs-boot file
- -- Case (b) allows an hs-boot file to get the interface of its
- -- real source file on the second iteration of the compilation
- -- manager, but that does no harm. Otherwise the hs-boot file
- -- will always be recompiled
-
- mb_old_iface
- = case old_hmi of
- Nothing -> Nothing
- Just hm_info | isBootSummary summary -> Just iface
- | not (mi_boot iface) -> Just iface
- | otherwise -> Nothing
- where
- iface = hm_iface hm_info
-
- compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
- compile_it = compile hsc_env summary' mod_index nmods mb_old_iface
-
- compile_it_discard_iface
- = compile hsc_env summary' mod_index nmods Nothing
-
- in
- case target of
-
- _any
- -- Regardless of whether we're generating object code or
- -- byte code, we can always use an existing object file
- -- if it is *stable* (see checkStability).
- | is_stable_obj, isJust old_hmi ->
- return old_hmi
- -- object is stable, and we have an entry in the
- -- old HPT: nothing to do
-
- | is_stable_obj, isNothing old_hmi -> do
- linkable <- findObjectLinkable this_mod obj_fn
- (expectJust "upseep1" mb_obj_date)
- compile_it (Just linkable)
- -- object is stable, but we need to load the interface
- -- off disk to make a HMI.
-
- HscInterpreted
- | is_stable_bco ->
- ASSERT(isJust old_hmi) -- must be in the old_hpt
- return old_hmi
- -- BCO is stable: nothing to do
-
- | Just hmi <- old_hmi,
- Just l <- hm_linkable hmi, not (isObjectLinkable l),
- linkableTime l >= ms_hs_date summary ->
- compile_it (Just l)
- -- we have an old BCO that is up to date with respect
- -- to the source: do a recompilation check as normal.
-
- | otherwise ->
- compile_it Nothing
- -- no existing code at all: we must recompile.
-
- -- When generating object code, if there's an up-to-date
- -- object file on the disk, then we can use it.
- -- However, if the object file is new (compared to any
- -- linkable we had from a previous compilation), then we
- -- must discard any in-memory interface, because this
- -- means the user has compiled the source file
- -- separately and generated a new interface, that we must
- -- read from the disk.
- --
- obj | isObjectTarget obj,
- Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
- case old_hmi of
- Just hmi
- | Just l <- hm_linkable hmi,
- isObjectLinkable l && linkableTime l == obj_date
- -> compile_it (Just l)
- _otherwise -> do
- linkable <- findObjectLinkable this_mod obj_fn obj_date
- compile_it_discard_iface (Just linkable)
-
- _otherwise ->
- compile_it Nothing
-
-
-
--- Filter modules in the HPT
-retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
-retainInTopLevelEnvs keep_these hpt
- = listToUFM [ (mod, expectJust "retain" mb_mod_info)
- | mod <- keep_these
- , let mb_mod_info = lookupUFM hpt mod
- , isJust mb_mod_info ]
-
--- ---------------------------------------------------------------------------
--- Typecheck module loops
-
-{-
-See bug #930. This code fixes a long-standing bug in --make. The
-problem is that when compiling the modules *inside* a loop, a data
-type that is only defined at the top of the loop looks opaque; but
-after the loop is done, the structure of the data type becomes
-apparent.
-
-The difficulty is then that two different bits of code have
-different notions of what the data type looks like.
-
-The idea is that after we compile a module which also has an .hs-boot
-file, we re-generate the ModDetails for each of the modules that
-depends on the .hs-boot file, so that everyone points to the proper
-TyCons, Ids etc. defined by the real module, not the boot module.
-Fortunately re-generating a ModDetails from a ModIface is easy: the
-function TcIface.typecheckIface does exactly that.
-
-Picking the modules to re-typecheck is slightly tricky. Starting from
-the module graph consisting of the modules that have already been
-compiled, we reverse the edges (so they point from the imported module
-to the importing module), and depth-first-search from the .hs-boot
-node. This gives us all the modules that depend transitively on the
-.hs-boot module, and those are exactly the modules that we need to
-re-typecheck.
-
-Following this fix, GHC can compile itself with --make -O2.
--}
-
-reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
-reTypecheckLoop hsc_env ms graph
- | not (isBootSummary ms) &&
- any (\m -> ms_mod m == this_mod && isBootSummary m) graph
- = do
- let mss = reachableBackwards (ms_mod_name ms) graph
- non_boot = filter (not.isBootSummary) mss
- debugTraceMsg (hsc_dflags hsc_env) 2 $
- text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)
- typecheckLoop hsc_env (map ms_mod_name non_boot)
- | otherwise
- = return hsc_env
- where
- this_mod = ms_mod ms
-
-typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv
-typecheckLoop hsc_env mods = do
- new_hpt <-
- fixIO $ \new_hpt -> do
- let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
- mds <- initIfaceCheck new_hsc_env $
- mapM (typecheckIface . hm_iface) hmis
- let new_hpt = addListToUFM old_hpt
- (zip mods [ hmi{ hm_details = details }
- | (hmi,details) <- zip hmis mds ])
- return new_hpt
- return hsc_env{ hsc_HPT = new_hpt }
- where
- old_hpt = hsc_HPT hsc_env
- hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods
-
-reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
-reachableBackwards mod summaries
- = [ ms | (ms,_,_) <- map vertex_fn nodes_we_want ]
- where
- -- all the nodes reachable by traversing the edges backwards
- -- from the root node:
- nodes_we_want = reachable (transposeG graph) root
-
- -- the rest just sets up the graph:
- (nodes, lookup_key) = moduleGraphNodes False summaries
- (graph, vertex_fn, key_fn) = graphFromEdges' nodes
- root
- | Just key <- lookup_key HsBootFile mod, Just v <- key_fn key = v
- | otherwise = panic "reachableBackwards"
-
--- ---------------------------------------------------------------------------
--- Topological sort of the module graph
-
-topSortModuleGraph
- :: Bool -- Drop hi-boot nodes? (see below)
- -> [ModSummary]
- -> Maybe ModuleName
- -> [SCC ModSummary]
--- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
--- The resulting list of strongly-connected-components is in topologically
--- sorted order, starting with the module(s) at the bottom of the
--- dependency graph (ie compile them first) and ending with the ones at
--- the top.