-
-checkStability
- :: HomePackageTable -- HPT from last compilation
- -> [SCC ModSummary] -- current module graph (cyclic)
- -> [ModuleName] -- all home modules
- -> ([ModuleName], -- stableObject
- [ModuleName]) -- stableBCO
-
-checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
- where
- checkSCC (stable_obj, stable_bco) scc0
- | stableObjects = (scc_mods ++ stable_obj, stable_bco)
- | stableBCOs = (stable_obj, scc_mods ++ stable_bco)
- | otherwise = (stable_obj, stable_bco)
- where
- scc = flattenSCC scc0
- scc_mods = map ms_mod_name scc
- home_module m = m `elem` all_home_mods && m `notElem` scc_mods
-
- scc_allimps = nub (filter home_module (concatMap ms_allimps scc))
- -- all imports outside the current SCC, but in the home pkg
-
- stable_obj_imps = map (`elem` stable_obj) scc_allimps
- stable_bco_imps = map (`elem` stable_bco) scc_allimps
-
- stableObjects =
- and stable_obj_imps
- && all object_ok scc
-
- stableBCOs =
- and (zipWith (||) stable_obj_imps stable_bco_imps)
- && all bco_ok scc
-
- object_ok ms
- | Just t <- ms_obj_date ms = t >= ms_hs_date ms
- && same_as_prev t
- | otherwise = False
- where
- same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
- Just hmi | Just l <- hm_linkable hmi
- -> isObjectLinkable l && t == linkableTime l
- _other -> True
- -- 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.
-
- bco_ok ms
- = case lookupUFM hpt (ms_mod_name ms) of
- Just hmi | Just l <- hm_linkable hmi ->
- not (isObjectLinkable l) &&
- linkableTime l >= ms_hs_date ms
- _other -> False
-
-ms_allimps :: ModSummary -> [ModuleName]
-ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
-
--- -----------------------------------------------------------------------------
--- Prune the HomePackageTable
-
--- Before doing an upsweep, we can throw away:
---
--- - 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.
---
--- Drop hi-boot nodes (first boolean arg)?
---
--- False: treat the hi-boot summaries as nodes of the graph,
--- so the graph must be acyclic
---
--- True: eliminate the hi-boot nodes, and instead pretend
--- the a source-import of Foo is an import of Foo
--- The resulting graph has no hi-boot nodes, but can by cyclic
-
-topSortModuleGraph drop_hs_boot_nodes summaries Nothing
- = stronglyConnComp (fst (moduleGraphNodes drop_hs_boot_nodes summaries))
-topSortModuleGraph drop_hs_boot_nodes summaries (Just mod)
- = stronglyConnComp (map vertex_fn (reachable graph root))
- where
- -- restrict the graph to just those modules reachable from
- -- the specified module. We do this by building a graph with
- -- the full set of nodes, and determining the reachable set from
- -- the specified node.
- (nodes, lookup_key) = moduleGraphNodes drop_hs_boot_nodes summaries
- (graph, vertex_fn, key_fn) = graphFromEdges' nodes
- root
- | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v
- | otherwise = throwDyn (ProgramError "module does not exist")
-
-moduleGraphNodes :: Bool -> [ModSummary]
- -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int)
-moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key)
- where
- -- Drop hs-boot nodes by using HsSrcFile as the key
- hs_boot_key | drop_hs_boot_nodes = HsSrcFile
- | otherwise = HsBootFile
-
- -- We use integers as the keys for the SCC algorithm
- nodes :: [(ModSummary, Int, [Int])]
- nodes = [(s, expectJust "topSort" $
- lookup_key (ms_hsc_src s) (ms_mod_name s),
- out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
- out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++
- (-- see [boot-edges] below
- if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
- then []
- else case lookup_key HsBootFile (ms_mod_name s) of
- Nothing -> []
- Just k -> [k])
- )
- | s <- summaries
- , not (isBootSummary s && drop_hs_boot_nodes) ]
- -- Drop the hi-boot ones if told to do so
-
- -- [boot-edges] if this is a .hs and there is an equivalent
- -- .hs-boot, add a link from the former to the latter. This
- -- has the effect of detecting bogus cases where the .hs-boot
- -- depends on the .hs, by introducing a cycle. Additionally,
- -- it ensures that we will always process the .hs-boot before
- -- the .hs, and so the HomePackageTable will always have the
- -- most up to date information.
-
- key_map :: NodeMap Int
- key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s)
- | s <- summaries]
- `zip` [1..])
-
- lookup_key :: HscSource -> ModuleName -> Maybe Int
- lookup_key hs_src mod = lookupFM key_map (mod, hs_src)
-
- out_edge_keys :: HscSource -> [ModuleName] -> [Int]
- out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
- -- If we want keep_hi_boot_nodes, then we do lookup_key with
- -- the IsBootInterface parameter True; else False
-
-
-type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
-type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs
-
-msKey :: ModSummary -> NodeKey
-msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
-
-mkNodeMap :: [ModSummary] -> NodeMap ModSummary
-mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
-
-nodeMapElts :: NodeMap a -> [a]
-nodeMapElts = eltsFM
-
--- If there are {-# SOURCE #-} imports between strongly connected
--- components in the topological sort, then those imports can
--- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
--- were necessary, then the edge would be part of a cycle.
-warnUnnecessarySourceImports :: DynFlags -> [SCC ModSummary] -> IO ()
-warnUnnecessarySourceImports dflags sccs =
- printBagOfWarnings dflags (listToBag (concat (map (check.flattenSCC) sccs)))
- where check ms =
- let mods_in_this_cycle = map ms_mod_name ms in
- [ warn i | m <- ms, i <- ms_srcimps m,
- unLoc i `notElem` mods_in_this_cycle ]
-
- warn :: Located ModuleName -> WarnMsg
- warn (L loc mod) =
- mkPlainErrMsg loc
- (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ")
- <+> quotes (ppr mod))
-
------------------------------------------------------------------------------
--- Downsweep (dependency analysis)
-
--- Chase downwards from the specified root set, returning summaries
--- for all home modules encountered. Only follow source-import
--- links.
-
--- We pass in the previous collection of summaries, which is used as a
--- cache to avoid recalculating a module summary if the source is
--- unchanged.
---
--- The returned list of [ModSummary] nodes has one node for each home-package
--- module, plus one for any hs-boot files. The imports of these nodes
--- are all there, including the imports of non-home-package modules.
-
-downsweep :: HscEnv
- -> [ModSummary] -- Old summaries
- -> [ModuleName] -- Ignore dependencies on these; treat
- -- them as if they were package modules
- -> Bool -- True <=> allow multiple targets to have
- -- the same module name; this is
- -- very useful for ghc -M
- -> IO (Maybe [ModSummary])
- -- The elts of [ModSummary] all have distinct
- -- (Modules, IsBoot) identifiers, unless the Bool is true
- -- in which case there can be repeats
-downsweep hsc_env old_summaries excl_mods allow_dup_roots
- = -- catch error messages and return them
- handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
- rootSummaries <- mapM getRootSummary roots
- let root_map = mkRootMap rootSummaries
- checkDuplicates root_map
- summs <- loop (concatMap msDeps rootSummaries) root_map
- return (Just summs)
- where
- roots = hsc_targets hsc_env
-
- old_summary_map :: NodeMap ModSummary
- old_summary_map = mkNodeMap old_summaries
-
- getRootSummary :: Target -> IO ModSummary
- getRootSummary (Target (TargetFile file mb_phase) maybe_buf)
- = do exists <- doesFileExist file
- if exists
- then summariseFile hsc_env old_summaries file mb_phase maybe_buf
- else throwDyn $ mkPlainErrMsg noSrcSpan $
- text "can't find file:" <+> text file
- getRootSummary (Target (TargetModule modl) maybe_buf)
- = do maybe_summary <- summariseModule hsc_env old_summary_map False
- (L rootLoc modl) maybe_buf excl_mods
- case maybe_summary of
- Nothing -> packageModErr modl
- Just s -> return s
-
- rootLoc = mkGeneralSrcSpan FSLIT("<command line>")
-
- -- In a root module, the filename is allowed to diverge from the module
- -- name, so we have to check that there aren't multiple root files
- -- defining the same module (otherwise the duplicates will be silently
- -- ignored, leading to confusing behaviour).
- checkDuplicates :: NodeMap [ModSummary] -> IO ()
- checkDuplicates root_map
- | allow_dup_roots = return ()
- | null dup_roots = return ()
- | otherwise = multiRootsErr (head dup_roots)
- where
- dup_roots :: [[ModSummary]] -- Each at least of length 2
- dup_roots = filterOut isSingleton (nodeMapElts root_map)
-
- loop :: [(Located ModuleName,IsBootInterface)]
- -- Work list: process these modules
- -> NodeMap [ModSummary]
- -- Visited set; the range is a list because
- -- the roots can have the same module names
- -- if allow_dup_roots is True
- -> IO [ModSummary]
- -- The result includes the worklist, except
- -- for those mentioned in the visited set
- loop [] done = return (concat (nodeMapElts done))
- loop ((wanted_mod, is_boot) : ss) done
- | Just summs <- lookupFM done key
- = if isSingleton summs then
- loop ss done
- else
- do { multiRootsErr summs; return [] }
- | otherwise = do { mb_s <- summariseModule hsc_env old_summary_map
- is_boot wanted_mod Nothing excl_mods
- ; case mb_s of
- Nothing -> loop ss done
- Just s -> loop (msDeps s ++ ss)
- (addToFM done key [s]) }
- where
- key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
-
-mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
-mkRootMap summaries = addListToFM_C (++) emptyFM
- [ (msKey s, [s]) | s <- summaries ]
-
-msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
--- (msDeps s) returns the dependencies of the ModSummary s.
--- A wrinkle is that for a {-# SOURCE #-} import we return
--- *both* the hs-boot file
--- *and* the source file
--- as "dependencies". That ensures that the list of all relevant
--- modules always contains B.hs if it contains B.hs-boot.
--- Remember, this pass isn't doing the topological sort. It's
--- just gathering the list of all relevant ModSummaries
-msDeps s =
- concat [ [(m,True), (m,False)] | m <- ms_srcimps s ]
- ++ [ (m,False) | m <- ms_imps s ]
-
------------------------------------------------------------------------------
--- Summarising modules
-
--- We have two types of summarisation:
---
--- * Summarise a file. This is used for the root module(s) passed to
--- cmLoadModules. The file is read, and used to determine the root
--- module name. The module name may differ from the filename.
---
--- * Summarise a module. We are given a module name, and must provide
--- a summary. The finder is used to locate the file in which the module
--- resides.
-
-summariseFile
- :: HscEnv
- -> [ModSummary] -- old summaries
- -> FilePath -- source file name
- -> Maybe Phase -- start phase
- -> Maybe (StringBuffer,ClockTime)
- -> IO ModSummary
-
-summariseFile hsc_env old_summaries file mb_phase maybe_buf
- -- we can use a cached summary if one is available and the
- -- source file hasn't changed, But we have to look up the summary
- -- by source file, rather than module name as we do in summarise.
- | Just old_summary <- findSummaryBySourceFile old_summaries file
- = do
- let location = ms_location old_summary
-
- -- return the cached summary if the source didn't change
- src_timestamp <- case maybe_buf of
- Just (_,t) -> return t
- Nothing -> getModificationTime file
- -- The file exists; we checked in getRootSummary above.
- -- If it gets removed subsequently, then this
- -- getModificationTime may fail, but that's the right
- -- behaviour.
-
- if ms_hs_date old_summary == src_timestamp
- then do -- update the object-file timestamp
- obj_timestamp <- getObjTimestamp location False
- return old_summary{ ms_obj_date = obj_timestamp }
- else
- new_summary
-
- | otherwise
- = new_summary
- where
- new_summary = do
- let dflags = hsc_dflags hsc_env
-
- (dflags', hspp_fn, buf)
- <- preprocessFile dflags file mb_phase maybe_buf
-
- (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
-
- -- Make a ModLocation for this file
- location <- mkHomeModLocation dflags mod_name file
-
- -- Tell the Finder cache where it is, so that subsequent calls
- -- to findModule will find it, even if it's not on any search path
- mod <- addHomeModuleToFinder hsc_env mod_name location
-
- src_timestamp <- case maybe_buf of
- Just (_,t) -> return t
- Nothing -> getModificationTime file
- -- getMofificationTime may fail
-
- obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
-
- return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
- ms_location = location,
- ms_hspp_file = hspp_fn,
- ms_hspp_opts = dflags',
- ms_hspp_buf = Just buf,
- ms_srcimps = srcimps, ms_imps = the_imps,
- ms_hs_date = src_timestamp,
- ms_obj_date = obj_timestamp })
-
-findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
-findSummaryBySourceFile summaries file
- = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
- expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
- [] -> Nothing
- (x:_) -> Just x
-
--- Summarise a module, and pick up source and timestamp.
-summariseModule
- :: HscEnv
- -> NodeMap ModSummary -- Map of old summaries
- -> IsBootInterface -- True <=> a {-# SOURCE #-} import
- -> Located ModuleName -- Imported module to be summarised
- -> Maybe (StringBuffer, ClockTime)
- -> [ModuleName] -- Modules to exclude
- -> IO (Maybe ModSummary) -- Its new summary
-
-summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods
- | wanted_mod `elem` excl_mods
- = return Nothing
-
- | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
- = do -- Find its new timestamp; all the
- -- ModSummaries in the old map have valid ml_hs_files
- let location = ms_location old_summary
- src_fn = expectJust "summariseModule" (ml_hs_file location)
-
- -- check the modification time on the source file, and
- -- return the cached summary if it hasn't changed. If the
- -- file has disappeared, we need to call the Finder again.
- case maybe_buf of
- Just (_,t) -> check_timestamp old_summary location src_fn t
- Nothing -> do
- m <- System.IO.Error.try (getModificationTime src_fn)
- case m of
- Right t -> check_timestamp old_summary location src_fn t
- Left e | isDoesNotExistError e -> find_it
- | otherwise -> ioError e
-
- | otherwise = find_it
- where
- dflags = hsc_dflags hsc_env
-
- hsc_src = if is_boot then HsBootFile else HsSrcFile
-
- check_timestamp old_summary location src_fn src_timestamp
- | ms_hs_date old_summary == src_timestamp = do
- -- update the object-file timestamp
- obj_timestamp <- getObjTimestamp location is_boot
- return (Just old_summary{ ms_obj_date = obj_timestamp })
- | otherwise =
- -- source changed: re-summarise.
- new_summary location (ms_mod old_summary) src_fn src_timestamp
-
- find_it = do
- -- Don't use the Finder's cache this time. If the module was
- -- previously a package module, it may have now appeared on the
- -- search path, so we want to consider it to be a home module. If
- -- the module was previously a home module, it may have moved.
- uncacheModule hsc_env wanted_mod
- found <- findImportedModule hsc_env wanted_mod Nothing
- case found of
- Found location mod
- | isJust (ml_hs_file location) ->
- -- Home package
- just_found location mod
- | otherwise ->
- -- Drop external-pkg
- ASSERT(modulePackageId mod /= thisPackage dflags)
- return Nothing
- where
-
- err -> noModError dflags loc wanted_mod err
- -- Not found
-
- just_found location mod = do
- -- Adjust location to point to the hs-boot source file,
- -- hi file, object file, when is_boot says so
- let location' | is_boot = addBootSuffixLocn location
- | otherwise = location
- src_fn = expectJust "summarise2" (ml_hs_file location')
-
- -- Check that it exists
- -- It might have been deleted since the Finder last found it
- maybe_t <- modificationTimeIfExists src_fn
- case maybe_t of
- Nothing -> noHsFileErr loc src_fn
- Just t -> new_summary location' mod src_fn t
-
-
- new_summary location mod src_fn src_timestamp
- = do
- -- Preprocess the source file and get its imports
- -- The dflags' contains the OPTIONS pragmas
- (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf
- (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
-
- when (mod_name /= wanted_mod) $
- throwDyn $ mkPlainErrMsg mod_loc $
- text "file name does not match module name"
- <+> quotes (ppr mod_name)
-
- -- Find the object timestamp, and return the summary
- obj_timestamp <- getObjTimestamp location is_boot
-
- return (Just ( ModSummary { ms_mod = mod,
- ms_hsc_src = hsc_src,
- ms_location = location,
- ms_hspp_file = hspp_fn,
- ms_hspp_opts = dflags',
- ms_hspp_buf = Just buf,
- ms_srcimps = srcimps,
- ms_imps = the_imps,
- ms_hs_date = src_timestamp,
- ms_obj_date = obj_timestamp }))
-
-
-getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime)
-getObjTimestamp location is_boot
- = if is_boot then return Nothing
- else modificationTimeIfExists (ml_obj_file location)
-
-
-preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
- -> IO (DynFlags, FilePath, StringBuffer)
-preprocessFile dflags src_fn mb_phase Nothing
- = do
- (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
- buf <- hGetStringBuffer hspp_fn
- return (dflags', hspp_fn, buf)
-
-preprocessFile dflags src_fn mb_phase (Just (buf, _time))
- = do
- -- case we bypass the preprocessing stage?
- let
- local_opts = getOptions buf src_fn
- --
- (dflags', _errs) <- parseDynamicFlags dflags (map unLoc local_opts)
- -- XXX: shouldn't we be reporting the errors?
-
- let
- needs_preprocessing
- | Just (Unlit _) <- mb_phase = True
- | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
- -- note: local_opts is only required if there's no Unlit phase
- | dopt Opt_Cpp dflags' = True
- | dopt Opt_Pp dflags' = True
- | otherwise = False
-
- when needs_preprocessing $
- ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
-
- return (dflags', src_fn, buf)
-
-
------------------------------------------------------------------------------
--- Error messages
------------------------------------------------------------------------------
-
-noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
--- ToDo: we don't have a proper line number for this error
-noModError dflags loc wanted_mod err
- = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
-
-noHsFileErr :: SrcSpan -> String -> a
-noHsFileErr loc path
- = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
-
-packageModErr :: ModuleName -> a
-packageModErr mod
- = throwDyn $ mkPlainErrMsg noSrcSpan $
- text "module" <+> quotes (ppr mod) <+> text "is a package module"
-
-multiRootsErr :: [ModSummary] -> IO ()
-multiRootsErr [] = panic "multiRootsErr"
-multiRootsErr summs@(summ1:_)
- = throwDyn $ mkPlainErrMsg noSrcSpan $
- text "module" <+> quotes (ppr mod) <+>
- text "is defined in multiple files:" <+>
- sep (map text files)
- where
- mod = ms_mod summ1
- files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
-
-cyclicModuleErr :: [ModSummary] -> SDoc
-cyclicModuleErr ms
- = hang (ptext SLIT("Module imports form a cycle for modules:"))
- 2 (vcat (map show_one ms))
- where
- show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
- nest 2 $ ptext SLIT("imports:") <+>
- (pp_imps HsBootFile (ms_srcimps ms)
- $$ pp_imps HsSrcFile (ms_imps ms))]
- show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
- pp_imps src mods = fsep (map (show_mod src) mods)
-
-
--- | Inform GHC that the working directory has changed. GHC will flush
--- its cache of module locations, since it may no longer be valid.
--- Note: if you change the working directory, you should also unload
--- the current program (set targets to empty, followed by load).
-workingDirectoryChanged :: Session -> IO ()
-workingDirectoryChanged s = withSession s $ flushFinderCaches
-
--- -----------------------------------------------------------------------------
--- inspecting the session