workingDirectoryChanged,
checkModule, checkAndLoadModule, CheckedModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
- compileToCore, compileToCoreModule,
+ compileToCore, compileToCoreModule, compileToCoreSimplified,
+ compileCoreToObj,
-- * Parsing Haddock comments
parseHaddockComment,
import Packages
import NameSet
import RdrName
-import HsSyn
+import qualified HsSyn -- hack as we want to reexport the whole module
+import HsSyn hiding ((<.>))
import Type hiding (typeKind)
import TcType hiding (typeKind)
import Id
-import Var hiding (setIdType)
+import Var
import TysPrim ( alphaTyVars )
import TyCon
import Class
import DataCon
import Name hiding ( varName )
import OccName ( parenSymOcc )
-import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
+import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
+ emptyInstEnv )
+import FamInstEnv ( emptyFamInstEnv )
import SrcLoc
import CoreSyn
+import TidyPgm
import DriverPipeline
import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
-import HeaderInfo ( getImports, getOptions )
+import HeaderInfo
import Finder
import HscMain
import HscTypes
import DynFlags
import StaticFlags
+import StaticFlagParser
import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
cleanTempDirs )
import Module
-import UniqFM
+import LazyUniqFM
import UniqSet
import Unique
import FiniteMap
import Panic
import Digraph
import Bag ( unitBag, listToBag )
-import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
- mkPlainErrMsg, printBagOfErrors, printBagOfWarnings,
- WarnMsg )
-import qualified ErrUtils
+import ErrUtils
import Util
import StringBuffer ( StringBuffer, hGetStringBuffer )
import Outputable
import Maybes ( expectJust, mapCatMaybes )
import HaddockParse
import HaddockLex ( tokenise )
+import FastString
import Control.Concurrent
-import System.Directory ( getModificationTime, doesFileExist )
+import System.Directory ( getModificationTime, doesFileExist,
+ getCurrentDirectory )
import Data.Maybe
import Data.List
import qualified Data.List as List
import Control.Monad
import System.Exit ( exitWith, ExitCode(..) )
-import System.Time ( ClockTime )
-import Control.Exception as Exception hiding (handle)
+import System.Time ( ClockTime, getClockTime )
+import Exception
import Data.IORef
+import System.FilePath
import System.IO
import System.IO.Error ( try, isDoesNotExistError )
+#if __GLASGOW_HASKELL__ >= 609
+import Data.Typeable (cast)
+#endif
import Prelude hiding (init)
-- the top level of your program. The default handlers output the error
-- message(s) to stderr and exit cleanly.
defaultErrorHandler :: DynFlags -> IO a -> IO a
-defaultErrorHandler dflags inner =
+defaultErrorHandler dflags inner =
-- top-level exception handler: any unrecognised exception is a compiler bug.
+#if __GLASGOW_HASKELL__ < 609
handle (\exception -> do
- hFlush stdout
- case exception of
- -- an IO exception probably isn't our fault, so don't panic
- IOException _ ->
- fatalErrorMsg dflags (text (show exception))
- AsyncException StackOverflow ->
- fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
- _other ->
- fatalErrorMsg dflags (text (show (Panic (show exception))))
- exitWith (ExitFailure 1)
+ hFlush stdout
+ case exception of
+ -- an IO exception probably isn't our fault, so don't panic
+ IOException _ ->
+ fatalErrorMsg dflags (text (show exception))
+ AsyncException StackOverflow ->
+ fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
+ ExitException _ -> throw exception
+ _ ->
+ fatalErrorMsg dflags (text (show (Panic (show exception))))
+ exitWith (ExitFailure 1)
+ ) $
+#else
+ handle (\(SomeException exception) -> do
+ hFlush stdout
+ case cast exception of
+ -- an IO exception probably isn't our fault, so don't panic
+ Just (ioe :: IOException) ->
+ fatalErrorMsg dflags (text (show ioe))
+ _ -> case cast exception of
+ Just StackOverflow ->
+ fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
+ _ -> case cast exception of
+ Just (ex :: ExitCode) -> throw ex
+ _ ->
+ fatalErrorMsg dflags
+ (text (show (Panic (show exception))))
+ exitWith (ExitFailure 1)
) $
+#endif
-- program errors: messages with locations attached. Sometimes it is
-- convenient to just throw these as exceptions.
- handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
- exitWith (ExitFailure 1)) $
+ handleErrMsg
+ (\em -> do printBagOfErrors dflags (unitBag em)
+ exitWith (ExitFailure 1)) $
-- error messages propagated as exceptions
- handleDyn (\dyn -> do
+ handleGhcException
+ (\ge -> do
hFlush stdout
- case dyn of
+ case ge of
PhaseFailed _ code -> exitWith code
Interrupted -> exitWith (ExitFailure 1)
- _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
+ _ -> do fatalErrorMsg dflags (text (show ge))
exitWith (ExitFailure 1)
) $
inner
defaultCleanupHandler :: DynFlags -> IO a -> IO a
defaultCleanupHandler dflags inner =
-- make sure we clean up after ourselves
- later (do cleanTempFiles dflags
+ inner `onException`
+ (do cleanTempFiles dflags
cleanTempDirs dflags
)
-- exceptions will be blocked while we clean the temporary files,
-- so there shouldn't be any difficulty if we receive further
-- signals.
- inner
-- | Starts a new session. A session consists of a set of loaded
installSignalHandlers
initStaticOpts
- dflags0 <- initSysTools mb_top_dir defaultDynFlags
- dflags <- initDynFlags dflags0
+ dflags0 <- initDynFlags defaultDynFlags
+ dflags <- initSysTools mb_top_dir dflags0
env <- newHscEnv dflags
ref <- newIORef env
return (Session ref)
guessOutputFile s = modifySession s $ \env ->
let dflags = hsc_dflags env
mod_graph = hsc_mod_graph env
- mainModuleSrcPath, guessedName :: Maybe String
+ mainModuleSrcPath :: Maybe String
mainModuleSrcPath = do
let isMain = (== mainModIs dflags) . ms_mod
[ms] <- return (filter isMain mod_graph)
ml_hs_file (ms_location ms)
- guessedName = fmap basenameOf mainModuleSrcPath
+ name = fmap dropExtension mainModuleSrcPath
+
+#if defined(mingw32_HOST_OS)
+ -- we must add the .exe extention unconditionally here, otherwise
+ -- when name has an extension of its own, the .exe extension will
+ -- not be added by DriverPipeline.exeFileName. See #2248
+ name_exe = fmap (<.> "exe") name
+#else
+ name_exe = name
+#endif
in
case outputFile dflags of
Just _ -> env
- Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } }
+ Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
-- -----------------------------------------------------------------------------
-- Targets
removeTarget s target_id
= modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) })
where
- filter targets = [ t | t@(Target id _) <- targets, id /= target_id ]
+ filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
-- Attempts to guess what Target a string refers to. This function implements
-- the --make/GHCi command-line syntax for filenames:
-- - otherwise interpret the string as a module name
--
guessTarget :: String -> Maybe Phase -> IO Target
-guessTarget file (Just phase)
- = return (Target (TargetFile file (Just phase)) Nothing)
-guessTarget file Nothing
+guessTarget str (Just phase)
+ = return (Target (TargetFile str (Just phase)) True Nothing)
+guessTarget str Nothing
| isHaskellSrcFilename file
- = return (Target (TargetFile file Nothing) Nothing)
+ = return (target (TargetFile file Nothing))
| otherwise
= do exists <- doesFileExist hs_file
if exists
- then return (Target (TargetFile hs_file Nothing) Nothing)
+ then return (target (TargetFile hs_file Nothing))
else do
exists <- doesFileExist lhs_file
if exists
- then return (Target (TargetFile lhs_file Nothing) Nothing)
+ then return (target (TargetFile lhs_file Nothing))
else do
- return (Target (TargetModule (mkModuleName file)) Nothing)
+ if looksLikeModuleName file
+ then return (target (TargetModule (mkModuleName file)))
+ else do
+ throwGhcException
+ (ProgramError (showSDoc $
+ text "target" <+> quotes (text file) <+>
+ text "is not a module name or a source file"))
where
- hs_file = file `joinFileExt` "hs"
- lhs_file = file `joinFileExt` "lhs"
+ (file,obj_allowed)
+ | '*':rest <- str = (rest, False)
+ | otherwise = (str, True)
+
+ hs_file = file <.> "hs"
+ lhs_file = file <.> "lhs"
+
+ target tid = Target tid obj_allowed Nothing
-- -----------------------------------------------------------------------------
-- Extending the program scope
-- Parsing Haddock comments
parseHaddockComment :: String -> Either String (HsDoc RdrName)
-parseHaddockComment string = parseHaddockParagraphs (tokenise string)
+parseHaddockComment string =
+ case parseHaddockParagraphs (tokenise string) of
+ MyLeft x -> Left x
+ MyRight x -> Right x
-- -----------------------------------------------------------------------------
-- Loading the program
-- attempt to load up to this target. If no Module is supplied,
-- then try to load all targets.
load :: Session -> LoadHowMuch -> IO SuccessFlag
-load s@(Session ref) how_much
+load s how_much
= do
-- Dependency analysis first. Note that this fixes the module graph:
-- even if we don't get a fully successful upsweep, the full module
-- were successfully loaded by inspecting the Session's HPT.
mb_graph <- depanal s [] False
case mb_graph of
- Just mod_graph -> catchingFailure $ load2 s how_much mod_graph
+ Just mod_graph -> load2 s how_much mod_graph
Nothing -> return Failed
- where catchingFailure f = f `Exception.catch` \e -> do
- hsc_env <- readIORef ref
- -- trac #1565 / test ghci021:
- -- let bindings may explode if we try to use them after
- -- failing to reload
- writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext }
- throw e
load2 :: Session -> LoadHowMuch -> [ModSummary] -> IO SuccessFlag
load2 s@(Session ref) how_much mod_graph = do
not (ms_mod_name s `elem` all_home_mods)]
ASSERT( null bad_boot_mods ) return ()
+ -- check that the module given in HowMuch actually exists, otherwise
+ -- topSortModuleGraph will bomb later.
+ let checkHowMuch (LoadUpTo m) = checkMod m
+ checkHowMuch (LoadDependenciesOf m) = checkMod m
+ checkHowMuch _ = id
+
+ checkMod m and_then
+ | m `elem` all_home_mods = and_then
+ | otherwise = do
+ errorMsg dflags (text "no such module:" <+>
+ quotes (ppr m))
+ return Failed
+
+ checkHowMuch how_much $ do
+
-- mg2_with_srcimps drops the hi-boot nodes, returning a
-- graph with cycles. Among other things, it is used for
-- backing out partially complete cycles following a failed
evaluate pruned_hpt
+ -- before we unload anything, make sure we don't leave an old
+ -- interactive context around pointing to dead bindings. Also,
+ -- write the pruned HPT to allow the old HPT to be GC'd.
+ writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext,
+ hsc_HPT = pruned_hpt }
+
debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
text "Stable BCO:" <+> ppr stable_bco)
renamedSource :: Maybe RenamedSource,
typecheckedSource :: Maybe TypecheckedSource,
checkedModuleInfo :: Maybe ModuleInfo,
- coreModule :: Maybe CoreModule
+ coreModule :: Maybe ModGuts
}
-- ToDo: improvements that could be made here:
-- if the module succeeded renaming but not typechecking,
then deSugarModule hsc_env ms tcg
else return Nothing
- let mb_core = fmap (\ mg ->
- CoreModule { cm_module = mg_module mg,
- cm_types = mg_types mg,
- cm_binds = mg_binds mg })
- mb_guts
-
-- If we are loading this module so that we can typecheck
-- dependent modules, generate an interface and stuff it
-- all in the HomePackageTable.
renamedSource = rn_info,
typecheckedSource = Just tc_binds,
checkedModuleInfo = Just minf,
- coreModule = mb_core }))
+ coreModule = mb_guts }))
-- | This is the way to get access to the Core bindings corresponding
-- to a module. 'compileToCore' invokes 'checkModule' to parse, typecheck, and
-- the module name, type declarations, and function declarations) if
-- successful.
compileToCoreModule :: Session -> FilePath -> IO (Maybe CoreModule)
-compileToCoreModule session fn = do
+compileToCoreModule = compileCore False
+
+-- | Like compileToCoreModule, but invokes the simplifier, so
+-- as to return simplified and tidied Core.
+compileToCoreSimplified :: Session -> FilePath -> IO (Maybe CoreModule)
+compileToCoreSimplified = compileCore True
+
+-- | Provided for backwards-compatibility: compileToCore returns just the Core
+-- bindings, but for most purposes, you probably want to call
+-- compileToCoreModule.
+compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind])
+compileToCore session fn = do
+ maybeCoreModule <- compileToCoreModule session fn
+ return $ fmap cm_binds maybeCoreModule
+
+-- | Takes a CoreModule and compiles the bindings therein
+-- to object code. The first argument is a bool flag indicating
+-- whether to run the simplifier.
+-- The resulting .o, .hi, and executable files, if any, are stored in the
+-- current directory, and named according to the module name.
+-- Returns True iff compilation succeeded.
+-- This has only so far been tested with a single self-contained module.
+compileCoreToObj :: Bool -> Session -> CoreModule -> IO Bool
+compileCoreToObj simplify session cm@(CoreModule{ cm_module = mName }) = do
+ hscEnv <- sessionHscEnv session
+ dflags <- getSessionDynFlags session
+ currentTime <- getClockTime
+ cwd <- getCurrentDirectory
+ modLocation <- mkHiOnlyModLocation dflags (hiSuf dflags) cwd
+ ((moduleNameSlashes . moduleName) mName)
+
+ let modSummary = ModSummary { ms_mod = mName,
+ ms_hsc_src = ExtCoreFile,
+ ms_location = modLocation,
+ -- By setting the object file timestamp to Nothing,
+ -- we always force recompilation, which is what we
+ -- want. (Thus it doesn't matter what the timestamp
+ -- for the (nonexistent) source file is.)
+ ms_hs_date = currentTime,
+ ms_obj_date = Nothing,
+ -- Only handling the single-module case for now, so no imports.
+ ms_srcimps = [],
+ ms_imps = [],
+ -- No source file
+ ms_hspp_file = "",
+ ms_hspp_opts = dflags,
+ ms_hspp_buf = Nothing
+ }
+
+ mbHscResult <- evalComp
+ ((if simplify then hscSimplify else return) (mkModGuts cm)
+ >>= hscNormalIface >>= hscWriteIface >>= hscOneShot)
+ (CompState{ compHscEnv=hscEnv,
+ compModSummary=modSummary,
+ compOldIface=Nothing})
+ return $ isJust mbHscResult
+
+-- Makes a "vanilla" ModGuts.
+mkModGuts :: CoreModule -> ModGuts
+mkModGuts coreModule = ModGuts {
+ mg_module = cm_module coreModule,
+ mg_boot = False,
+ mg_exports = [],
+ mg_deps = noDependencies,
+ mg_dir_imps = emptyModuleEnv,
+ mg_used_names = emptyNameSet,
+ mg_rdr_env = emptyGlobalRdrEnv,
+ mg_fix_env = emptyFixityEnv,
+ mg_types = emptyTypeEnv,
+ mg_insts = [],
+ mg_fam_insts = [],
+ mg_rules = [],
+ mg_binds = cm_binds coreModule,
+ mg_foreign = NoStubs,
+ mg_warns = NoWarnings,
+ mg_hpc_info = emptyHpcInfo False,
+ mg_modBreaks = emptyModBreaks,
+ mg_vect_info = noVectInfo,
+ mg_inst_env = emptyInstEnv,
+ mg_fam_inst_env = emptyFamInstEnv
+}
+
+compileCore :: Bool -> Session -> FilePath -> IO (Maybe CoreModule)
+compileCore simplify session fn = do
-- First, set the target to the desired filename
target <- guessTarget fn Nothing
addTarget session target
maybeCheckedModule <- checkModule session mod True
case maybeCheckedModule of
Nothing -> return Nothing
- Just checkedMod -> return $ coreModule checkedMod
+ Just checkedMod -> (liftM $ fmap gutsToCoreModule) $
+ case (coreModule checkedMod) of
+ Just mg | simplify -> (sessionHscEnv session)
+ -- If simplify is true: simplify (hscSimplify),
+ -- then tidy (tidyProgram).
+ >>= \ hscEnv -> evalComp (hscSimplify mg)
+ (CompState{ compHscEnv=hscEnv,
+ compModSummary=modSummary,
+ compOldIface=Nothing})
+ >>= (tidyProgram hscEnv)
+ >>= (return . Just . Left)
+ Just guts -> return $ Just $ Right guts
+ Nothing -> return Nothing
Nothing -> panic "compileToCoreModule: target FilePath not found in\
module dependency graph"
+ where -- two versions, based on whether we simplify (thus run tidyProgram,
+ -- which returns a (CgGuts, ModDetails) pair, or not (in which case
+ -- we just have a ModGuts.
+ gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
+ gutsToCoreModule (Left (cg, md)) = CoreModule {
+ cm_module = cg_module cg, cm_types = md_types md,
+ cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg
+ }
+ gutsToCoreModule (Right mg) = CoreModule {
+ cm_module = mg_module mg, cm_types = mg_types mg,
+ cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg
+ }
--- | Provided for backwards-compatibility: compileToCore returns just the Core
--- bindings, but for most purposes, you probably want to call
--- compileToCoreModule.
-compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind])
-compileToCore session fn = do
- maybeCoreModule <- compileToCoreModule session fn
- return $ fmap cm_binds maybeCoreModule
-- ---------------------------------------------------------------------------
-- Unloading
cleanup -- Remove unwanted tmp files between compilations
case mb_mod_info of
- Nothing -> return (Failed, hsc_env, [])
+ Nothing -> return (Failed, hsc_env, done)
Just mod_info -> do
let this_mod = ms_mod_name mod
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"
+ = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
+ where -- the rest just sets up the graph:
+ (graph, lookup_node) = moduleGraphNodes False summaries
+ root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
-- ---------------------------------------------------------------------------
-- Topological sort of the module graph
+type SummaryNode = (ModSummary, Int, [Int])
+
topSortModuleGraph
:: Bool -- Drop hi-boot nodes? (see below)
-> [ModSummary]
-- 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")
+topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
+ = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
+ where
+ (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
+
+ initial_graph = case mb_root_mod of
+ Nothing -> graph
+ Just root_mod ->
+ -- 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.
+ let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
+ | otherwise = ghcError (ProgramError "module does not exist")
+ in graphFromEdgedVertices (seq root (reachableG graph root))
+
+summaryNodeKey :: SummaryNode -> Int
+summaryNodeKey (_, k, _) = k
+
+summaryNodeSummary :: SummaryNode -> ModSummary
+summaryNodeSummary (s, _, _) = s
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
+ -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
+moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
+ where
+ numbered_summaries = zip summaries [1..]
+
+ lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
+ lookup_node hs_src mod = lookupFM node_map (mod, hs_src)
+
+ lookup_key :: HscSource -> ModuleName -> Maybe Int
+ lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
+
+ node_map :: NodeMap SummaryNode
+ node_map = listToFM [ ((moduleName (ms_mod s), ms_hsc_src s), node)
+ | node@(s, _, _) <- nodes ]
+
+ -- We use integers as the keys for the SCC algorithm
+ nodes :: [SummaryNode]
+ nodes = [ (s, key, out_keys)
+ | (s, key) <- numbered_summaries
+ -- Drop the hi-boot ones if told to do so
+ , not (isBootSummary s && drop_hs_boot_nodes)
+ , let out_keys = 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]) ]
+
+ -- [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.
+
+ -- Drop hs-boot nodes by using HsSrcFile as the key
+ hs_boot_key | drop_hs_boot_nodes = HsSrcFile
+ | otherwise = HsBootFile
+
+ 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
warn :: Located ModuleName -> WarnMsg
warn (L loc mod) =
mkPlainErrMsg loc
- (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ")
+ (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")
<+> quotes (ppr mod))
-----------------------------------------------------------------------------
-- 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
+ handleErrMsg
+ (\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
old_summary_map = mkNodeMap old_summaries
getRootSummary :: Target -> IO ModSummary
- getRootSummary (Target (TargetFile file mb_phase) maybe_buf)
+ getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
= do exists <- doesFileExist file
if exists
- then summariseFile hsc_env old_summaries file mb_phase maybe_buf
- else throwDyn $ mkPlainErrMsg noSrcSpan $
+ then summariseFile hsc_env old_summaries file mb_phase
+ obj_allowed maybe_buf
+ else throwErrMsg $ mkPlainErrMsg noSrcSpan $
text "can't find file:" <+> text file
- getRootSummary (Target (TargetModule modl) maybe_buf)
+ getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
= do maybe_summary <- summariseModule hsc_env old_summary_map False
- (L rootLoc modl) maybe_buf excl_mods
+ (L rootLoc modl) obj_allowed
+ maybe_buf excl_mods
case maybe_summary of
Nothing -> packageModErr modl
Just s -> return s
- rootLoc = mkGeneralSrcSpan FSLIT("<command line>")
+ 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
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]) }
+ | otherwise
+ = do mb_s <- summariseModule hsc_env old_summary_map
+ is_boot wanted_mod True
+ 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)
-> [ModSummary] -- old summaries
-> FilePath -- source file name
-> Maybe Phase -- start phase
+ -> Bool -- object code allowed?
-> Maybe (StringBuffer,ClockTime)
-> IO ModSummary
-summariseFile hsc_env old_summaries file mb_phase maybe_buf
+summariseFile hsc_env old_summaries file mb_phase obj_allowed 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.
if ms_hs_date old_summary == src_timestamp
then do -- update the object-file timestamp
- obj_timestamp <- getObjTimestamp location False
+ obj_timestamp <-
+ if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+ || obj_allowed -- bug #1205
+ then getObjTimestamp location False
+ else return Nothing
return old_summary{ ms_obj_date = obj_timestamp }
else
new_summary
let dflags = hsc_dflags hsc_env
(dflags', hspp_fn, buf)
- <- preprocessFile dflags file mb_phase maybe_buf
+ <- preprocessFile hsc_env file mb_phase maybe_buf
(srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
Nothing -> getModificationTime file
-- getMofificationTime may fail
- obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
+ -- when the user asks to load a source file by name, we only
+ -- use an object file if -fobject-code is on. See #1205.
+ obj_timestamp <-
+ if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+ || obj_allowed -- bug #1205
+ then modificationTimeIfExists (ml_obj_file location)
+ else return Nothing
return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
ms_location = location,
-> NodeMap ModSummary -- Map of old summaries
-> IsBootInterface -- True <=> a {-# SOURCE #-} import
-> Located ModuleName -- Imported module to be summarised
+ -> Bool -- object code allowed?
-> 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
+summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
+ obj_allowed maybe_buf excl_mods
| wanted_mod `elem` excl_mods
= return Nothing
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
+ obj_timestamp <-
+ if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+ || obj_allowed -- bug #1205
+ then getObjTimestamp location is_boot
+ else return Nothing
return (Just old_summary{ ms_obj_date = obj_timestamp })
| otherwise =
-- source changed: re-summarise.
-- Drop external-pkg
ASSERT(modulePackageId mod /= thisPackage dflags)
return Nothing
- where
err -> noModError dflags loc wanted_mod err
-- Not found
= 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
+ (dflags', hspp_fn, buf) <- preprocessFile hsc_env 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)
+ throwErrMsg $ mkPlainErrMsg mod_loc $
+ text "File name does not match module name:"
+ $$ text "Saw:" <+> quotes (ppr mod_name)
+ $$ text "Expected:" <+> quotes (ppr wanted_mod)
-- Find the object timestamp, and return the summary
- obj_timestamp <- getObjTimestamp location is_boot
+
+ obj_timestamp <-
+ if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+ || obj_allowed -- bug #1205
+ then getObjTimestamp location is_boot
+ else return Nothing
return (Just ( ModSummary { ms_mod = mod,
ms_hsc_src = hsc_src,
else modificationTimeIfExists (ml_obj_file location)
-preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
+preprocessFile :: HscEnv -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
-> IO (DynFlags, FilePath, StringBuffer)
-preprocessFile dflags src_fn mb_phase Nothing
+preprocessFile hsc_env src_fn mb_phase Nothing
= do
- (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
+ (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
buf <- hGetStringBuffer hspp_fn
return (dflags', hspp_fn, buf)
-preprocessFile dflags src_fn mb_phase (Just (buf, _time))
+preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
= do
+ let dflags = hsc_dflags hsc_env
-- case we bypass the preprocessing stage?
let
- local_opts = getOptions buf src_fn
+ local_opts = getOptions dflags buf src_fn
--
- (dflags', _errs) <- parseDynamicFlags dflags (map unLoc local_opts)
- -- XXX: shouldn't we be reporting the errors?
+ (dflags', leftovers, warns) <- parseDynamicFlags dflags local_opts
+ checkProcessArgsResult leftovers
+ handleFlagWarnings dflags' warns
let
needs_preprocessing
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
+ = throwErrMsg $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
noHsFileErr :: SrcSpan -> String -> a
noHsFileErr loc path
- = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
+ = throwErrMsg $ mkPlainErrMsg loc $ text "Can't find" <+> text path
packageModErr :: ModuleName -> a
packageModErr mod
- = throwDyn $ mkPlainErrMsg noSrcSpan $
+ = throwErrMsg $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+> text "is a package module"
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr [] = panic "multiRootsErr"
multiRootsErr summs@(summ1:_)
- = throwDyn $ mkPlainErrMsg noSrcSpan $
+ = throwErrMsg $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+>
text "is defined in multiple files:" <+>
sep (map text files)
cyclicModuleErr :: [ModSummary] -> SDoc
cyclicModuleErr ms
- = hang (ptext SLIT("Module imports form a cycle for modules:"))
+ = 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:") <+>
+ 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)
-- 'setContext'.
lookupGlobalName :: Session -> Name -> IO (Maybe TyThing)
lookupGlobalName s name = withSession s $ \hsc_env -> do
- eps <- readIORef (hsc_EPS hsc_env)
+ eps <- hscEPS hsc_env
return $! lookupType (hsc_dflags hsc_env)
(hsc_HPT hsc_env) (eps_PTE eps) name
-- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
-- filesystem and package database to find the corresponding 'Module',
-- using the algorithm that is used for an @import@ declaration.
-findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module
+findModule :: Session -> ModuleName -> Maybe FastString -> IO Module
findModule s mod_name maybe_pkg = withSession s $ \hsc_env ->
let
dflags = hsc_dflags hsc_env
res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
Found _ m | modulePackageId m /= this_pkg -> return m
- | otherwise -> throwDyn (CmdLineError (showSDoc $
- text "module" <+> pprModule m <+>
+ | otherwise -> ghcError (CmdLineError (showSDoc $
+ text "module" <+> quotes (ppr (moduleName m)) <+>
text "is not loaded"))
err -> let msg = cannotFindModule dflags mod_name err in
- throwDyn (CmdLineError (showSDoc msg))
+ ghcError (CmdLineError (showSDoc msg))
#ifdef GHCI
getHistorySpan :: Session -> History -> IO SrcSpan
projects / ghc-hetmet.git / blobdiff