hunk ./DriverPipeline4Lsk.hs 1 -{-# OPTIONS -fno-cse #-} --- -fno-cse is needed for GLOBAL_VAR's to behave properly - ------------------------------------------------------------------------------ --- --- GHC Driver --- --- (c) The University of Glasgow 2005 --- ------------------------------------------------------------------------------ -module DriverPipeline4Lsk ( - -- Run a series of compilation steps in a pipeline, for a - -- collection of source files. - oneShot, compileFile, - - -- Interfaces for the batch-mode driver - linkBinary, - - -- Interfaces for the compilation manager (interpreted/batch-mode) - preprocess, - compile, - link, - - ) where - -#include "HsVersions4Lsk.h" - -import Packages -import HeaderInfo -import DriverPhases -import SysTools -import HscMain -import qualified HscMain4Lsk as HML -import Finder -import HscTypes -import Outputable -import Module -import LazyUniqFM ( eltsUFM ) -import ErrUtils -import DynFlags -import StaticFlags ( v_Ld_inputs, opt_Static, WayName(..) ) -import Config -import Panic -import Util -import StringBuffer ( hGetStringBuffer ) -import BasicTypes ( SuccessFlag(..) ) -import Maybes ( expectJust ) -import ParserCoreUtils ( getCoreModuleName ) -import SrcLoc -import FastString -import MonadUtils - -import Data.Either -import Exception -import Data.IORef ( readIORef, writeIORef, IORef ) -import GHC.Exts ( Int(..) ) -import System.Directory -import System.FilePath -import System.IO -import System.IO.Error as IO -import Control.Monad -import Data.List ( isSuffixOf ) -import Data.Maybe -import System.Environment -import LskFileHandler - --- --------------------------------------------------------------------------- --- Pre-process - --- | Just preprocess a file, put the result in a temp. file (used by the --- compilation manager during the summary phase). --- --- We return the augmented DynFlags, because they contain the result --- of slurping in the OPTIONS pragmas - -preprocess :: GhcMonad m => - HscEnv - -> (FilePath, Maybe Phase) -- ^ filename and starting phase - -> m (DynFlags, FilePath) -preprocess hsc_env (filename, mb_phase) = -#warning FIXME: preprocess liskell files? - if isLiskellSrcFilename filename then return (hsc_dflags hsc_env, filename) - else - ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) - do - runPipeline anyHsc hsc_env (filename, mb_phase) - Nothing Temporary Nothing{-no ModLocation-} - --- --------------------------------------------------------------------------- - --- | Compile --- --- Compile a single module, under the control of the compilation manager. --- --- This is the interface between the compilation manager and the --- compiler proper (hsc), where we deal with tedious details like --- reading the OPTIONS pragma from the source file, and passing the --- output of hsc through the C compiler. --- --- NB. No old interface can also mean that the source has changed. - -compile :: GhcMonad m => - HscEnv - -> ModSummary -- ^ summary for module being compiled - -> Int -- ^ module N ... - -> Int -- ^ ... of M - -> Maybe ModIface -- ^ old interface, if we have one - -> Maybe Linkable -- ^ old linkable, if we have one - -> m HomeModInfo -- ^ the complete HomeModInfo, if successful - -compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable - = do - let dflags0 = ms_hspp_opts summary - this_mod = ms_mod summary - src_flavour = ms_hsc_src summary - location = ms_location summary - input_fn = expectJust "compile:hs" (ml_hs_file location) - input_fnpp = ms_hspp_file summary - - liftIO $ debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp) - - let basename = dropExtension input_fn - - -- We add the directory in which the .hs files resides) to the import path. - -- This is needed when we try to compile the .hc file later, if it - -- imports a _stub.h file that we created here. - let current_dir = case takeDirectory basename of - "" -> "." -- XXX Hack - d -> d - old_paths = includePaths dflags0 - dflags = dflags0 { includePaths = current_dir : old_paths } - hsc_env = hsc_env0 {hsc_dflags = dflags} - - -- Figure out what lang we're generating - let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags) - -- ... and what the next phase should be - let next_phase = hscNextPhase dflags src_flavour hsc_lang - -- ... and what file to generate the output into - output_fn <- liftIO $ getOutputFilename next_phase - Temporary basename dflags next_phase (Just location) - - let dflags' = dflags { hscTarget = hsc_lang, - hscOutName = output_fn, - extCoreName = basename ++ ".hcr" } - let hsc_env' = hsc_env { hsc_dflags = dflags' } - - -- -fforce-recomp should also work with --make - let force_recomp = dopt Opt_ForceRecomp dflags - source_unchanged = isJust maybe_old_linkable && not force_recomp - object_filename = ml_obj_file location - - let getStubLinkable False = return [] - getStubLinkable True - = do stub_o <- compileStub hsc_env' this_mod location - return [ DotO stub_o ] - - handleBatch HML.HscNoRecomp - = ASSERT (isJust maybe_old_linkable) - return maybe_old_linkable - - handleBatch (HML.HscRecomp hasStub) - | isHsBoot src_flavour - = do when (isObjectTarget hsc_lang) $ -- interpreted reaches here too - liftIO $ SysTools.touch dflags' "Touching object file" - object_filename - return maybe_old_linkable - - | otherwise - = do stub_unlinked <- getStubLinkable hasStub - (hs_unlinked, unlinked_time) <- - case hsc_lang of - HscNothing - -> return ([], ms_hs_date summary) - -- We're in --make mode: finish the compilation pipeline. - _other - -> do runPipeline StopLn hsc_env' (output_fn,Nothing) - (Just basename) - Persistent - (Just location) - -- The object filename comes from the ModLocation - o_time <- liftIO $ getModificationTime object_filename - return ([DotO object_filename], o_time) - let linkable = LM unlinked_time this_mod - (hs_unlinked ++ stub_unlinked) - return (Just linkable) - - handleInterpreted HML.InteractiveNoRecomp - = ASSERT (isJust maybe_old_linkable) - return maybe_old_linkable - handleInterpreted (HML.InteractiveRecomp hasStub comp_bc modBreaks) - = do stub_unlinked <- getStubLinkable hasStub - let hs_unlinked = [BCOs comp_bc modBreaks] - unlinked_time = ms_hs_date summary - -- Why do we use the timestamp of the source file here, - -- rather than the current time? This works better in - -- the case where the local clock is out of sync - -- with the filesystem's clock. It's just as accurate: - -- if the source is modified, then the linkable will - -- be out of date. - let linkable = LM unlinked_time this_mod - (hs_unlinked ++ stub_unlinked) - return (Just linkable) - - let -- runCompiler :: Compiler result -> (result -> Maybe Linkable) - -- -> m HomeModInfo - runCompiler compiler handle - = do (result, iface, details) - <- compiler hsc_env' summary source_unchanged mb_old_iface - (Just (mod_index, nmods)) - linkable <- handle result - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = linkable }) - -- run the compiler - case hsc_lang of - HscInterpreted - | isHsBoot src_flavour -> - runCompiler HML.hscCompileNothing handleBatch - | otherwise -> - runCompiler HML.hscCompileInteractive handleInterpreted - HscNothing -> - runCompiler HML.hscCompileNothing handleBatch - _other -> - runCompiler HML.hscCompileBatch handleBatch - ------------------------------------------------------------------------------ --- stub .h and .c files (for foreign export support) - --- The _stub.c file is derived from the haskell source file, possibly taking --- into account the -stubdir option. --- --- Consequently, we derive the _stub.o filename from the haskell object --- filename. --- --- This isn't necessarily the same as the object filename we --- would get if we just compiled the _stub.c file using the pipeline. --- For example: --- --- ghc src/A.hs -odir obj --- --- results in obj/A.o, and src/A_stub.c. If we compile src/A_stub.c with --- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want --- obj/A_stub.o. - -compileStub :: GhcMonad m => HscEnv -> Module -> ModLocation - -> m FilePath -compileStub hsc_env mod location = do - let (o_base, o_ext) = splitExtension (ml_obj_file location) - stub_o = (o_base ++ "_stub") <.> o_ext - - -- compile the _stub.c file w/ gcc - let (stub_c,_,_) = mkStubPaths (hsc_dflags hsc_env) (moduleName mod) location - runPipeline StopLn hsc_env (stub_c,Nothing) Nothing - (SpecificFile stub_o) Nothing{-no ModLocation-} - - return stub_o - - --- --------------------------------------------------------------------------- --- Link - -link :: GhcLink -- interactive or batch - -> DynFlags -- dynamic flags - -> Bool -- attempt linking in batch mode? - -> HomePackageTable -- what to link - -> IO SuccessFlag - --- For the moment, in the batch linker, we don't bother to tell doLink --- which packages to link -- it just tries all that are available. --- batch_attempt_linking should only be *looked at* in batch mode. It --- should only be True if the upsweep was successful and someone --- exports main, i.e., we have good reason to believe that linking --- will succeed. - -#ifdef GHCI -link LinkInMemory _ _ _ - = do -- Not Linking...(demand linker will do the job) - return Succeeded -#endif - -link NoLink _ _ _ - = return Succeeded - -link LinkBinary dflags batch_attempt_linking hpt - | batch_attempt_linking - = do - let - home_mod_infos = eltsUFM hpt - - -- the packages we depend on - pkg_deps = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos - - -- the linkables to link - linkables = map (expectJust "link".hm_linkable) home_mod_infos - - debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) - - -- check for the -no-link flag - if isNoLink (ghcLink dflags) - then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).") - return Succeeded - else do - - let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) - obj_files = concatMap getOfiles linkables - - exe_file = exeFileName dflags - - linking_needed <- linkingNeeded dflags linkables pkg_deps - - if not (dopt Opt_ForceRecomp dflags) && not linking_needed - then do debugTraceMsg dflags 2 (text exe_file <+> ptext (sLit "is up to date, linking not required.")) - return Succeeded - else do - - debugTraceMsg dflags 1 (ptext (sLit "Linking") <+> text exe_file - <+> text "...") - - -- Don't showPass in Batch mode; doLink will do that for us. - let link = case ghcLink dflags of - LinkBinary -> linkBinary - LinkDynLib -> linkDynLib - other -> panicBadLink other - link dflags obj_files pkg_deps - - debugTraceMsg dflags 3 (text "link: done") - - -- linkBinary only returns if it succeeds - return Succeeded - - | otherwise - = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$ - text " Main.main not exported; not linking.") - return Succeeded - --- warning suppression -link other _ _ _ = panicBadLink other - -panicBadLink :: GhcLink -> a -panicBadLink other = panic ("link: GHC not built to link this way: " ++ - show other) - - -linkingNeeded :: DynFlags -> [Linkable] -> [PackageId] -> IO Bool -linkingNeeded dflags linkables pkg_deps = do - -- if the modification time on the executable is later than the - -- modification times on all of the objects and libraries, then omit - -- linking (unless the -fforce-recomp flag was given). - let exe_file = exeFileName dflags - e_exe_time <- IO.try $ getModificationTime exe_file - case e_exe_time of - Left _ -> return True - Right t -> do - -- first check object files and extra_ld_inputs - extra_ld_inputs <- readIORef v_Ld_inputs - e_extra_times <- mapM (IO.try . getModificationTime) extra_ld_inputs - let (errs,extra_times) = splitEithers e_extra_times - let obj_times = map linkableTime linkables ++ extra_times - if not (null errs) || any (t <) obj_times - then return True - else do - - -- next, check libraries. XXX this only checks Haskell libraries, - -- not extra_libraries or -l things from the command line. - let pkg_map = pkgIdMap (pkgState dflags) - pkg_hslibs = [ (libraryDirs c, lib) - | Just c <- map (lookupPackage pkg_map) pkg_deps, - lib <- packageHsLibs dflags c ] - - pkg_libfiles <- mapM (uncurry findHSLib) pkg_hslibs - if any isNothing pkg_libfiles then return True else do - e_lib_times <- mapM (IO.try . getModificationTime) - (catMaybes pkg_libfiles) - let (lib_errs,lib_times) = splitEithers e_lib_times - if not (null lib_errs) || any (t <) lib_times - then return True - else return False - -findHSLib :: [String] -> String -> IO (Maybe FilePath) -findHSLib dirs lib = do - let batch_lib_file = "lib" ++ lib <.> "a" - found <- filterM doesFileExist (map ( batch_lib_file) dirs) - case found of - [] -> return Nothing - (x:_) -> return (Just x) - --- ----------------------------------------------------------------------------- --- Compile files in one-shot mode. - -oneShot :: GhcMonad m => - HscEnv -> Phase -> [(String, Maybe Phase)] -> m () -oneShot hsc_env stop_phase srcs = do - o_files <- mapM (compileFile hsc_env stop_phase) srcs - liftIO $ doLink (hsc_dflags hsc_env) stop_phase o_files - -compileFile :: GhcMonad m => - HscEnv -> Phase -> (FilePath, Maybe Phase) -> m FilePath -compileFile hsc_env stop_phase (src, mb_phase) = do - exists <- liftIO $ doesFileExist src - when (not exists) $ - ghcError (CmdLineError ("does not exist: " ++ src)) - - let - dflags = hsc_dflags hsc_env - split = dopt Opt_SplitObjs dflags - mb_o_file = outputFile dflags - ghc_link = ghcLink dflags -- Set by -c or -no-link - - -- When linking, the -o argument refers to the linker's output. - -- otherwise, we use it as the name for the pipeline's output. - output - | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent - -- -o foo applies to linker - | Just o_file <- mb_o_file = SpecificFile o_file - -- -o foo applies to the file we are compiling now - | otherwise = Persistent - - stop_phase' = case stop_phase of - As | split -> SplitAs - _ -> stop_phase - - ( _, out_file) <- runPipeline stop_phase' hsc_env - (src, mb_phase) Nothing output - Nothing{-no ModLocation-} - return out_file - - -doLink :: DynFlags -> Phase -> [FilePath] -> IO () -doLink dflags stop_phase o_files - | not (isStopLn stop_phase) - = return () -- We stopped before the linking phase - - | otherwise - = case ghcLink dflags of - NoLink -> return () - LinkBinary -> linkBinary dflags o_files link_pkgs - LinkDynLib -> linkDynLib dflags o_files [] - other -> panicBadLink other - where - -- Always link in the haskell98 package for static linking. Other - -- packages have to be specified via the -package flag. - link_pkgs - | dopt Opt_AutoLinkPackages dflags = [haskell98PackageId] - | otherwise = [] - - --- --------------------------------------------------------------------------- - -data PipelineOutput - = Temporary - -- ^ Output should be to a temporary file: we're going to - -- run more compilation steps on this output later. - | Persistent - -- ^ We want a persistent file, i.e. a file in the current directory - -- derived from the input filename, but with the appropriate extension. - -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o. - | SpecificFile FilePath - -- ^ The output must go into the specified file. - --- | Run a compilation pipeline, consisting of multiple phases. --- --- This is the interface to the compilation pipeline, which runs --- a series of compilation steps on a single source file, specifying --- at which stage to stop. --- --- The DynFlags can be modified by phases in the pipeline (eg. by --- GHC_OPTIONS pragmas), and the changes affect later phases in the --- pipeline. -runPipeline - :: GhcMonad m => - Phase -- ^ When to stop - -> HscEnv -- ^ Compilation environment - -> (FilePath,Maybe Phase) -- ^ Input filename (and maybe -x suffix) - -> Maybe FilePath -- ^ original basename (if different from ^^^) - -> PipelineOutput -- ^ Output filename - -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module - -> m (DynFlags, FilePath) -- ^ (final flags, output filename) - -runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc - = do - let dflags0 = hsc_dflags hsc_env0 - (input_basename, suffix) = splitExtension input_fn - suffix' = drop 1 suffix -- strip off the . - basename | Just b <- mb_basename = b - | otherwise = input_basename - - -- Decide where dump files should go based on the pipeline output - dflags = dflags0 { dumpPrefix = Just (basename ++ ".") } - hsc_env = hsc_env0 {hsc_dflags = dflags} - - -- If we were given a -x flag, then use that phase to start from - start_phase = fromMaybe (startPhase suffix') mb_phase - - -- We want to catch cases of "you can't get there from here" before - -- we start the pipeline, because otherwise it will just run off the - -- end. - -- - -- There is a partial ordering on phases, where A < B iff A occurs - -- before B in a normal compilation pipeline. - - when (not (start_phase `happensBefore` stop_phase)) $ - ghcError (UsageError - ("cannot compile this file to desired target: " - ++ input_fn)) - - -- this is a function which will be used to calculate output file names - -- as we go along (we partially apply it to some of its inputs here) - let get_output_fn = getOutputFilename stop_phase output basename - - -- Execute the pipeline... - (dflags', output_fn, maybe_loc) <- - pipeLoop hsc_env start_phase stop_phase input_fn - basename suffix' get_output_fn maybe_loc - - -- Sometimes, a compilation phase doesn't actually generate any output - -- (eg. the CPP phase when -fcpp is not turned on). If we end on this - -- stage, but we wanted to keep the output, then we have to explicitly - -- copy the file, remembering to prepend a {-# LINE #-} pragma so that - -- further compilation stages can tell what the original filename was. - case output of - Temporary -> - return (dflags', output_fn) - _other -> liftIO $ - do final_fn <- get_output_fn dflags' stop_phase maybe_loc - when (final_fn /= output_fn) $ do - let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'") - line_prag = Just ("{-# LINE 1 \"" ++ input_fn ++ "\" #-}\n") - copyWithHeader dflags msg line_prag output_fn final_fn - return (dflags', final_fn) - - - -pipeLoop :: GhcMonad m => - HscEnv -> Phase -> Phase - -> FilePath -> String -> Suffix - -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath) - -> Maybe ModLocation - -> m (DynFlags, FilePath, Maybe ModLocation) - -pipeLoop hsc_env phase stop_phase - input_fn orig_basename orig_suff - orig_get_output_fn maybe_loc - - | phase `eqPhase` stop_phase -- All done - = return (hsc_dflags hsc_env, input_fn, maybe_loc) - - | not (phase `happensBefore` stop_phase) - -- Something has gone wrong. We'll try to cover all the cases when - -- this could happen, so if we reach here it is a panic. - -- eg. it might happen if the -C flag is used on a source file that - -- has {-# OPTIONS -fasm #-}. - = panic ("pipeLoop: at phase " ++ show phase ++ - " but I wanted to stop at phase " ++ show stop_phase) - - | otherwise - = do (next_phase, dflags', maybe_loc, output_fn) - <- runPhase phase stop_phase hsc_env orig_basename - orig_suff input_fn orig_get_output_fn maybe_loc - let hsc_env' = hsc_env {hsc_dflags = dflags'} - pipeLoop hsc_env' next_phase stop_phase output_fn - orig_basename orig_suff orig_get_output_fn maybe_loc - -getOutputFilename - :: Phase -> PipelineOutput -> String - -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath -getOutputFilename stop_phase output basename - = func - where - func dflags next_phase maybe_location - | is_last_phase, Persistent <- output = persistent_fn - | is_last_phase, SpecificFile f <- output = return f - | keep_this_output = persistent_fn - | otherwise = newTempName dflags suffix - where - hcsuf = hcSuf dflags - odir = objectDir dflags - osuf = objectSuf dflags - keep_hc = dopt Opt_KeepHcFiles dflags - keep_raw_s = dopt Opt_KeepRawSFiles dflags - keep_s = dopt Opt_KeepSFiles dflags - - myPhaseInputExt HCc = hcsuf - myPhaseInputExt StopLn = osuf - myPhaseInputExt other = phaseInputExt other - - is_last_phase = next_phase `eqPhase` stop_phase - - -- sometimes, we keep output from intermediate stages - keep_this_output = - case next_phase of - StopLn -> True - Mangle | keep_raw_s -> True - As | keep_s -> True - HCc | keep_hc -> True - _other -> False - - suffix = myPhaseInputExt next_phase - - -- persistent object files get put in odir - persistent_fn - | StopLn <- next_phase = return odir_persistent - | otherwise = return persistent - - persistent = basename <.> suffix - - odir_persistent - | Just loc <- maybe_location = ml_obj_file loc - | Just d <- odir = d persistent - | otherwise = persistent - - --- ----------------------------------------------------------------------------- --- | Each phase in the pipeline returns the next phase to execute, and the --- name of the file in which the output was placed. --- --- We must do things dynamically this way, because we often don't know --- what the rest of the phases will be until part-way through the --- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning --- of a source file can change the latter stages of the pipeline from --- taking the via-C route to using the native code generator. --- -runPhase :: GhcMonad m => - Phase -- ^ Do this phase first - -> Phase -- ^ Stop just before this phase - -> HscEnv - -> String -- ^ basename of original input source - -> String -- ^ its extension - -> FilePath -- ^ name of file which contains the input to this phase. - -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath) - -- ^ how to calculate the output filename - -> Maybe ModLocation -- ^ the ModLocation, if we have one - -> m (Phase, -- next phase - DynFlags, -- new dynamic flags - Maybe ModLocation, -- the ModLocation, if we have one - FilePath) -- output filename - - -- Invariant: the output filename always contains the output - -- Interesting case: Hsc when there is no recompilation to do - -- Then the output filename is still a .o file - -------------------------------------------------------------------------------- --- Unlit phase - -runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do - let dflags = hsc_dflags hsc_env - output_fn <- liftIO $ get_output_fn dflags (Cpp sf) maybe_loc - - let unlit_flags = getOpts dflags opt_L - flags = map SysTools.Option unlit_flags ++ - [ -- The -h option passes the file name for unlit to - -- put in a #line directive - SysTools.Option "-h" - -- cpp interprets \b etc as escape sequences, - -- so we use / for filenames in pragmas - , SysTools.Option $ reslash Forwards $ normalise input_fn - , SysTools.FileOption "" input_fn - , SysTools.FileOption "" output_fn - ] - - liftIO $ SysTools.runUnlit dflags flags - - return (Cpp sf, dflags, maybe_loc, output_fn) - -------------------------------------------------------------------------------- --- Cpp phase : (a) gets OPTIONS out of file --- (b) runs cpp if necessary - -runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do let dflags0 = hsc_dflags hsc_env - src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn - (dflags, unhandled_flags, warns) - <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts - liftIO $ handleFlagWarnings dflags warns -- XXX: may exit the program - liftIO $ checkProcessArgsResult unhandled_flags -- XXX: may throw program error - - if not (dopt Opt_Cpp dflags) then - -- no need to preprocess CPP, just pass input file along - -- to the next phase of the pipeline. - return (HsPp sf, dflags, maybe_loc, input_fn) - else do - output_fn <- liftIO $ get_output_fn dflags (HsPp sf) maybe_loc - liftIO $ doCpp dflags True{-raw-} False{-no CC opts-} input_fn output_fn - return (HsPp sf, dflags, maybe_loc, output_fn) - -------------------------------------------------------------------------------- --- HsPp phase - -runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc - = do let dflags = hsc_dflags hsc_env - if not (dopt Opt_Pp dflags) then - -- no need to preprocess, just pass input file along - -- to the next phase of the pipeline. - return (Hsc sf, dflags, maybe_loc, input_fn) - else do - let hspp_opts = getOpts dflags opt_F - let orig_fn = basename <.> suff - output_fn <- liftIO $ get_output_fn dflags (Hsc sf) maybe_loc - liftIO $ SysTools.runPp dflags - ( [ SysTools.Option orig_fn - , SysTools.Option input_fn - , SysTools.FileOption "" output_fn - ] ++ - map SysTools.Option hspp_opts - ) - return (Hsc sf, dflags, maybe_loc, output_fn) - ------------------------------------------------------------------------------ --- Hsc phase - --- Compilation of a single module, in "legacy" mode (_not_ under --- the direction of the compilation manager). -runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _maybe_loc - = do -- normal Hsc mode, not mkdependHS - let dflags0 = hsc_dflags hsc_env - - -- we add the current directory (i.e. the directory in which - -- the .hs files resides) to the include path, since this is - -- what gcc does, and it's probably what you want. - let current_dir = case takeDirectory basename of - "" -> "." -- XXX Hack - d -> d - - paths = includePaths dflags0 - dflags = dflags0 { includePaths = current_dir : paths } - - -- gather the imports and module name - (hspp_buf,mod_name,imps,src_imps) <- - case src_flavour of - ExtCoreFile -> do -- no explicit imports in ExtCore input. - m <- liftIO $ getCoreModuleName input_fn - return (Nothing, mkModuleName m, [], []) - - _ -> liftIO $ do - buf <- hGetStringBuffer input_fn - (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff) - return (Just buf, mod_name, imps, src_imps) - - -- Build a ModLocation to pass to hscMain. - -- The source filename is rather irrelevant by now, but it's used - -- by hscMain for messages. hscMain also needs - -- the .hi and .o filenames, and this is as good a way - -- as any to generate them, and better than most. (e.g. takes - -- into accout the -osuf flags) - location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff - - -- Boot-ify it if necessary - let location2 | isHsBoot src_flavour = addBootSuffixLocn location1 - | otherwise = location1 - - - -- Take -ohi into account if present - -- This can't be done in mkHomeModuleLocation because - -- it only applies to the module being compiles - let ohi = outputHi dflags - location3 | Just fn <- ohi = location2{ ml_hi_file = fn } - | otherwise = location2 - - -- Take -o into account if present - -- Very like -ohi, but we must *only* do this if we aren't linking - -- (If we're linking then the -o applies to the linked thing, not to - -- the object file for one module.) - -- Note the nasty duplication with the same computation in compileFile above - let expl_o_file = outputFile dflags - location4 | Just ofile <- expl_o_file - , isNoLink (ghcLink dflags) - = location3 { ml_obj_file = ofile } - | otherwise = location3 - - o_file = ml_obj_file location4 -- The real object file - - - -- Figure out if the source has changed, for recompilation avoidance. - -- - -- Setting source_unchanged to True means that M.o seems - -- to be up to date wrt M.hs; so no need to recompile unless imports have - -- changed (which the compiler itself figures out). - -- Setting source_unchanged to False tells the compiler that M.o is out of - -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. - src_timestamp <- liftIO $ getModificationTime (basename <.> suff) - - let force_recomp = dopt Opt_ForceRecomp dflags - source_unchanged <- - if force_recomp || not (isStopLn stop) - -- Set source_unchanged to False unconditionally if - -- (a) recompilation checker is off, or - -- (b) we aren't going all the way to .o file (e.g. ghc -S) - then return False - -- Otherwise look at file modification dates - else do o_file_exists <- liftIO $ doesFileExist o_file - if not o_file_exists - then return False -- Need to recompile - else do t2 <- liftIO $ getModificationTime o_file - if t2 > src_timestamp - then return True - else return False - - -- get the DynFlags - let hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags) - let next_phase = hscNextPhase dflags src_flavour hsc_lang - output_fn <- liftIO $ get_output_fn dflags next_phase (Just location4) - - let dflags' = dflags { hscTarget = hsc_lang, - hscOutName = output_fn, - extCoreName = basename ++ ".hcr" } - - let hsc_env' = hsc_env {hsc_dflags = dflags'} - - -- Tell the finder cache about this module - mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location4 - - -- Make the ModSummary to hand to hscMain - let - mod_summary = ModSummary { ms_mod = mod, - ms_hsc_src = src_flavour, - ms_hspp_file = input_fn, - ms_hspp_opts = dflags, - ms_hspp_buf = hspp_buf, - ms_location = location4, - ms_hs_date = src_timestamp, - ms_obj_date = Nothing, - ms_imps = imps, - ms_srcimps = src_imps } - - -- run the compiler! - result <- hscCompileOneShot hsc_env' - mod_summary source_unchanged - Nothing -- No iface - Nothing -- No "module i of n" progress info - - case result of - HscNoRecomp - -> do liftIO $ SysTools.touch dflags' "Touching object file" o_file - -- The .o file must have a later modification date - -- than the source file (else we wouldn't be in HscNoRecomp) - -- but we touch it anyway, to keep 'make' happy (we think). - return (StopLn, dflags', Just location4, o_file) - (HscRecomp hasStub) - -> do when hasStub $ - do stub_o <- compileStub hsc_env' mod location4 - liftIO $ consIORef v_Ld_inputs stub_o - -- In the case of hs-boot files, generate a dummy .o-boot - -- stamp file for the benefit of Make - when (isHsBoot src_flavour) $ - liftIO $ SysTools.touch dflags' "Touching object file" o_file - return (next_phase, dflags', Just location4, output_fn) - ------------------------------------------------------------------------------ --- Cmm phase - -runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do - let dflags = hsc_dflags hsc_env - output_fn <- liftIO $ get_output_fn dflags Cmm maybe_loc - liftIO $ doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn - return (Cmm, dflags, maybe_loc, output_fn) - -runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc - = do - let dflags = hsc_dflags hsc_env - let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags) - let next_phase = hscNextPhase dflags HsSrcFile hsc_lang - output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc - - let dflags' = dflags { hscTarget = hsc_lang, - hscOutName = output_fn, - extCoreName = basename ++ ".hcr" } - let hsc_env' = hsc_env {hsc_dflags = dflags'} - - hscCmmFile hsc_env' input_fn - - -- XXX: catch errors above and convert them into ghcError? Original - -- code was: - -- - --when (not ok) $ ghcError (PhaseFailed "cmm" (ExitFailure 1)) - - return (next_phase, dflags, maybe_loc, output_fn) - ------------------------------------------------------------------------------ --- Cc phase - --- we don't support preprocessing .c files (with -E) now. Doing so introduces --- way too many hacks, and I can't say I've ever used it anyway. - -runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc - = do let dflags = hsc_dflags hsc_env - let cc_opts = getOpts dflags opt_c - hcc = cc_phase `eqPhase` HCc - - let cmdline_include_paths = includePaths dflags - - -- HC files have the dependent packages stamped into them - pkgs <- if hcc then liftIO (getHCFilePackages input_fn) else return [] - - -- add package include paths even if we're just compiling .c - -- files; this is the Value Add(TM) that using ghc instead of - -- gcc gives you :) - pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs - let include_paths = foldr (\ x xs -> "-I" : x : xs) [] - (cmdline_include_paths ++ pkg_include_dirs) - - let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags - gcc_extra_viac_flags <- liftIO $ getExtraViaCOpts dflags - let pic_c_flags = picCCOpts dflags - - let verb = getVerbFlag dflags - - -- cc-options are not passed when compiling .hc files. Our - -- hc code doesn't not #include any header files anyway, so these - -- options aren't necessary. - pkg_extra_cc_opts <- - if cc_phase `eqPhase` HCc - then return [] - else liftIO $ getPackageExtraCcOpts dflags pkgs - -#ifdef darwin_TARGET_OS - pkg_framework_paths <- liftIO $ getPackageFrameworkPath dflags pkgs - let cmdline_framework_paths = frameworkPaths dflags - let framework_paths = map ("-F"++) - (cmdline_framework_paths ++ pkg_framework_paths) -#endif - - let split_objs = dopt Opt_SplitObjs dflags - split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ] - | otherwise = [ ] - - let cc_opt | optLevel dflags >= 2 = "-O2" - | otherwise = "-O" - - -- Decide next phase - - let mangle = dopt Opt_DoAsmMangling dflags - next_phase - | hcc && mangle = Mangle - | otherwise = As - output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc - - let - more_hcc_opts = -#if i386_TARGET_ARCH - -- on x86 the floating point regs have greater precision - -- than a double, which leads to unpredictable results. - -- By default, we turn this off with -ffloat-store unless - -- the user specified -fexcess-precision. - (if dopt Opt_ExcessPrecision dflags - then [] - else [ "-ffloat-store" ]) ++ -#endif - -- gcc's -fstrict-aliasing allows two accesses to memory - -- to be considered non-aliasing if they have different types. - -- This interacts badly with the C code we generate, which is - -- very weakly typed, being derived from C--. - ["-fno-strict-aliasing"] - - - - liftIO $ SysTools.runCc dflags ( - -- force the C compiler to interpret this file as C when - -- compiling .hc files, by adding the -x c option. - -- Also useful for plain .c files, just in case GHC saw a - -- -x c option. - [ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp - then SysTools.Option "c++" else SysTools.Option "c"] ++ - [ SysTools.FileOption "" input_fn - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] - ++ map SysTools.Option ( - md_c_flags - ++ pic_c_flags -#ifdef sparc_TARGET_ARCH - -- We only support SparcV9 and better because V8 lacks an atomic CAS - -- instruction. Note that the user can still override this - -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag - -- regardless of the ordering. - -- - -- This is a temporary hack. - ++ ["-mcpu=v9"] -#endif - ++ (if hcc && mangle - then md_regd_c_flags - else []) - ++ (if hcc - then if mangle - then gcc_extra_viac_flags - else filter (=="-fwrapv") - gcc_extra_viac_flags - -- still want -fwrapv even for unreg'd - else []) - ++ (if hcc - then more_hcc_opts - else []) - ++ [ verb, "-S", "-Wimplicit", cc_opt ] - ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] -#ifdef darwin_TARGET_OS - ++ framework_paths -#endif - ++ cc_opts - ++ split_opt - ++ include_paths - ++ pkg_extra_cc_opts - )) - - return (next_phase, dflags, maybe_loc, output_fn) - - -- ToDo: postprocess the output from gcc - ------------------------------------------------------------------------------ --- Mangle phase - -runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do let dflags = hsc_dflags hsc_env - let mangler_opts = getOpts dflags opt_m - -#if i386_TARGET_ARCH - machdep_opts <- return [ show (stolen_x86_regs dflags) ] -#else - machdep_opts <- return [] -#endif - - let split = dopt Opt_SplitObjs dflags - next_phase - | split = SplitMangle - | otherwise = As - output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc - - liftIO $ SysTools.runMangle dflags (map SysTools.Option mangler_opts - ++ [ SysTools.FileOption "" input_fn - , SysTools.FileOption "" output_fn - ] - ++ map SysTools.Option machdep_opts) - - return (next_phase, dflags, maybe_loc, output_fn) - ------------------------------------------------------------------------------ --- Splitting phase - -runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc - = liftIO $ - do -- tmp_pfx is the prefix used for the split .s files - -- We also use it as the file to contain the no. of split .s files (sigh) - let dflags = hsc_dflags hsc_env - split_s_prefix <- SysTools.newTempName dflags "split" - let n_files_fn = split_s_prefix - - SysTools.runSplit dflags - [ SysTools.FileOption "" input_fn - , SysTools.FileOption "" split_s_prefix - , SysTools.FileOption "" n_files_fn - ] - - -- Save the number of split files for future references - s <- readFile n_files_fn - let n_files = read s :: Int - writeIORef v_Split_info (split_s_prefix, n_files) - - -- Remember to delete all these files - addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s" - | n <- [1..n_files]] - - return (SplitAs, dflags, maybe_loc, "**splitmangle**") - -- we don't use the filename - ------------------------------------------------------------------------------ --- As phase - -runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = liftIO $ - do let dflags = hsc_dflags hsc_env - let as_opts = getOpts dflags opt_a - let cmdline_include_paths = includePaths dflags - - output_fn <- get_output_fn dflags StopLn maybe_loc - - -- we create directories for the object file, because it - -- might be a hierarchical module. - createDirectoryHierarchy (takeDirectory output_fn) - - SysTools.runAs dflags - (map SysTools.Option as_opts - ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] -#ifdef sparc_TARGET_ARCH - -- We only support SparcV9 and better because V8 lacks an atomic CAS - -- instruction so we have to make sure that the assembler accepts the - -- instruction set. Note that the user can still override this - -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag - -- regardless of the ordering. - -- - -- This is a temporary hack. - ++ [ SysTools.Option "-mcpu=v9" ] -#endif - ++ [ SysTools.Option "-c" - , SysTools.FileOption "" input_fn - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ]) - - return (StopLn, dflags, maybe_loc, output_fn) - - -runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc - = liftIO $ do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags StopLn maybe_loc - - let base_o = dropExtension output_fn - split_odir = base_o ++ "_split" - osuf = objectSuf dflags - - createDirectoryHierarchy split_odir - - -- remove M_split/ *.o, because we're going to archive M_split/ *.o - -- later and we don't want to pick up any old objects. - fs <- getDirectoryContents split_odir - mapM_ removeFile $ map (split_odir ) $ filter (osuf `isSuffixOf`) fs - - let as_opts = getOpts dflags opt_a - - (split_s_prefix, n) <- readIORef v_Split_info - - let split_s n = split_s_prefix ++ "__" ++ show n <.> "s" - split_obj n = split_odir - takeFileName base_o ++ "__" ++ show n <.> osuf - - let assemble_file n - = SysTools.runAs dflags - (map SysTools.Option as_opts ++ - [ SysTools.Option "-c" - , SysTools.Option "-o" - , SysTools.FileOption "" (split_obj n) - , SysTools.FileOption "" (split_s n) - ]) - - mapM_ assemble_file [1..n] - - -- and join the split objects into a single object file: - let ld_r args = SysTools.runLink dflags ([ - SysTools.Option "-nostdlib", - SysTools.Option "-nodefaultlibs", - SysTools.Option "-Wl,-r", - SysTools.Option ld_x_flag, - SysTools.Option "-o", - SysTools.FileOption "" output_fn ] ++ args) - ld_x_flag | null cLD_X = "" - | otherwise = "-Wl,-x" - - if cLdIsGNULd == "YES" - then do - let script = split_odir "ld.script" - writeFile script $ - "INPUT(" ++ unwords (map split_obj [1..n]) ++ ")" - ld_r [SysTools.FileOption "" script] - else do - ld_r (map (SysTools.FileOption "" . split_obj) [1..n]) - - return (StopLn, dflags, maybe_loc, output_fn) - --- warning suppression -runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc = - panic ("runPhase: don't know how to run phase " ++ show other) ------------------------------------------------------------------------------ --- MoveBinary sort-of-phase --- After having produced a binary, move it somewhere else and generate a --- wrapper script calling the binary. Currently, we need this only in --- a parallel way (i.e. in GUM), because PVM expects the binary in a --- central directory. --- This is called from linkBinary below, after linking. I haven't made it --- a separate phase to minimise interfering with other modules, and --- we don't need the generality of a phase (MoveBinary is always --- done after linking and makes only sense in a parallel setup) -- HWL - -runPhase_MoveBinary :: DynFlags -> FilePath -> [PackageId] -> IO Bool -runPhase_MoveBinary dflags input_fn dep_packages - | WayPar `elem` (wayNames dflags) && not opt_Static = - panic ("Don't know how to combine PVM wrapper and dynamic wrapper") - | WayPar `elem` (wayNames dflags) = do - let sysMan = pgm_sysman dflags - pvm_root <- getEnv "PVM_ROOT" - pvm_arch <- getEnv "PVM_ARCH" - let - pvm_executable_base = "=" ++ input_fn - pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base - -- nuke old binary; maybe use configur'ed names for cp and rm? - tryIO (removeFile pvm_executable) - -- move the newly created binary into PVM land - copy dflags "copying PVM executable" input_fn pvm_executable - -- generate a wrapper script for running a parallel prg under PVM - writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan) - return True - | not opt_Static = - case (dynLibLoader dflags) of - Wrapped wrapmode -> - do - let (o_base, o_ext) = splitExtension input_fn - let wrapped_executable | o_ext == "exe" = (o_base ++ "_real") <.> o_ext - | otherwise = input_fn ++ "_real" - behaviour <- wrapper_behaviour dflags wrapmode dep_packages - - -- THINKME isn't this possible to do a bit nicer? - let behaviour' = concatMap (\x -> if x=='\\' then "\\\\" else [x]) behaviour - renameFile input_fn wrapped_executable - let rtsDetails = (getPackageDetails (pkgState dflags) rtsPackageId); - SysTools.runCc dflags - ([ SysTools.FileOption "" ((head (libraryDirs rtsDetails)) ++ "/dyn-wrapper.c") - , SysTools.Option ("-DBEHAVIOUR=\"" ++ behaviour' ++ "\"") - , SysTools.Option "-o" - , SysTools.FileOption "" input_fn - ] ++ map (SysTools.FileOption "-I") (includeDirs rtsDetails)) - return True - _ -> return True - | otherwise = return True - -wrapper_behaviour :: DynFlags -> Maybe [Char] -> [PackageId] -> IO [Char] -wrapper_behaviour dflags mode dep_packages = - let seperateBySemiColon strs = tail $ concatMap (';':) strs - in case mode of - Nothing -> do - pkg_lib_paths <- getPackageLibraryPath dflags dep_packages - return ('H' : (seperateBySemiColon pkg_lib_paths)) - Just s -> do - allpkg <- getPreloadPackagesAnd dflags dep_packages - putStrLn (unwords (map (packageIdString . packageConfigId) allpkg)) - return $ 'F':s ++ ';':(seperateBySemiColon (map (packageIdString . packageConfigId) allpkg)) - --- generates a Perl skript starting a parallel prg under PVM -mk_pvm_wrapper_script :: String -> String -> String -> String -mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $ - [ - "eval 'exec perl -S $0 ${1+\"$@\"}'", - " if $running_under_some_shell;", - "# =!=!=!=!=!=!=!=!=!=!=!", - "# This script is automatically generated: DO NOT EDIT!!!", - "# Generated by Glasgow Haskell Compiler", - "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!", - "#", - "$pvm_executable = '" ++ pvm_executable ++ "';", - "$pvm_executable_base = '" ++ pvm_executable_base ++ "';", - "$SysMan = '" ++ sysMan ++ "';", - "", - {- ToDo: add the magical shortcuts again iff we actually use them -- HWL - "# first, some magical shortcuts to run "commands" on the binary", - "# (which is hidden)", - "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {", - " local($cmd) = $1;", - " system("$cmd $pvm_executable");", - " exit(0); # all done", - "}", -} - "", - "# Now, run the real binary; process the args first", - "$ENV{'PE'} = $pvm_executable_base;", -- ++ pvm_executable_base, - "$debug = '';", - "$nprocessors = 0; # the default: as many PEs as machines in PVM config", - "@nonPVM_args = ();", - "$in_RTS_args = 0;", - "", - "args: while ($a = shift(@ARGV)) {", - " if ( $a eq '+RTS' ) {", - " $in_RTS_args = 1;", - " } elsif ( $a eq '-RTS' ) {", - " $in_RTS_args = 0;", - " }", - " if ( $a eq '-d' && $in_RTS_args ) {", - " $debug = '-';", - " } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {", - " $nprocessors = $1;", - " } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {", - " $nprocessors = $1;", - " } else {", - " push(@nonPVM_args, $a);", - " }", - "}", - "", - "local($return_val) = 0;", - "# Start the parallel execution by calling SysMan", - "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");", - "$return_val = $?;", - "# ToDo: fix race condition moving files and flushing them!!", - "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";", - "exit($return_val);" - ] - ------------------------------------------------------------------------------ --- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file - -getHCFilePackages :: FilePath -> IO [PackageId] -getHCFilePackages filename = - Exception.bracket (openFile filename ReadMode) hClose $ \h -> do - l <- hGetLine h - case l of - '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> - return (map stringToPackageId (words rest)) - _other -> - return [] - ------------------------------------------------------------------------------ --- Static linking, of .o files - --- The list of packages passed to link is the list of packages on --- which this program depends, as discovered by the compilation --- manager. It is combined with the list of packages that the user --- specifies on the command line with -package flags. --- --- In one-shot linking mode, we can't discover the package --- dependencies (because we haven't actually done any compilation or --- read any interface files), so the user must explicitly specify all --- the packages. - -linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO () -linkBinary dflags o_files dep_packages = do - let verb = getVerbFlag dflags - output_fn = exeFileName dflags - - -- get the full list of packages to link with, by combining the - -- explicit packages with the auto packages and all of their - -- dependencies, and eliminating duplicates. - - pkg_lib_paths <- getPackageLibraryPath dflags dep_packages - let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths) -#ifdef linux_TARGET_OS - get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] - | otherwise = ["-L" ++ l] -#else - get_pkg_lib_path_opts l = ["-L" ++ l] -#endif - - let lib_paths = libraryPaths dflags - let lib_path_opts = map ("-L"++) lib_paths - - pkg_link_opts <- getPackageLinkOpts dflags dep_packages - -#ifdef darwin_TARGET_OS - pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages - let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths - - let framework_paths = frameworkPaths dflags - framework_path_opts = map ("-F"++) framework_paths - - pkg_frameworks <- getPackageFrameworks dflags dep_packages - let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ] - - let frameworks = cmdlineFrameworks dflags - framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ] - -- reverse because they're added in reverse order from the cmd line -#endif -#ifdef mingw32_TARGET_OS - let dynMain = if not opt_Static then - (head (libraryDirs (getPackageDetails (pkgState dflags) rtsPackageId))) ++ "/Main.dyn_o" - else - "" -#endif - -- probably _stub.o files - extra_ld_inputs <- readIORef v_Ld_inputs - - -- opts from -optl- (including -l options) - let extra_ld_opts = getOpts dflags opt_l - - let ways = wayNames dflags - - -- Here are some libs that need to be linked at the *end* of - -- the command line, because they contain symbols that are referred to - -- by the RTS. We can't therefore use the ordinary way opts for these. - let - debug_opts | WayDebug `elem` ways = [ -#if defined(HAVE_LIBBFD) - "-lbfd", "-liberty" -#endif - ] - | otherwise = [] - - let - thread_opts | WayThreaded `elem` ways = [ -#if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) - "-lpthread" -#endif -#if defined(osf3_TARGET_OS) - , "-lexc" -#endif - ] - | otherwise = [] - - rc_objs <- maybeCreateManifest dflags output_fn - - let (md_c_flags, _) = machdepCCOpts dflags - SysTools.runLink dflags ( - [ SysTools.Option verb - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] - ++ map SysTools.Option ( - md_c_flags - ++ o_files -#ifdef mingw32_TARGET_OS - ++ [dynMain] -#endif - ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts - ++ rc_objs -#ifdef darwin_TARGET_OS - ++ framework_path_opts - ++ framework_opts -#endif - ++ pkg_lib_path_opts - ++ pkg_link_opts -#ifdef darwin_TARGET_OS - ++ pkg_framework_path_opts - ++ pkg_framework_opts -#endif - ++ debug_opts - ++ thread_opts - )) - - -- parallel only: move binary to another dir -- HWL - success <- runPhase_MoveBinary dflags output_fn dep_packages - if success then return () - else ghcError (InstallationError ("cannot move binary")) - - -exeFileName :: DynFlags -> FilePath -exeFileName dflags - | Just s <- outputFile dflags = -#if defined(mingw32_HOST_OS) - if null (takeExtension s) - then s <.> "exe" - else s -#else - s -#endif - | otherwise = -#if defined(mingw32_HOST_OS) - "main.exe" -#else - "a.out" -#endif - -maybeCreateManifest - :: DynFlags - -> FilePath -- filename of executable - -> IO [FilePath] -- extra objects to embed, maybe -#ifndef mingw32_TARGET_OS -maybeCreateManifest _ _ = do - return [] -#else -maybeCreateManifest dflags exe_filename = do - if not (dopt Opt_GenManifest dflags) then return [] else do - - let manifest_filename = exe_filename <.> "manifest" - - writeFile manifest_filename $ - "\n"++ - " \n"++ - " \n\n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - "\n" - - -- Windows will find the manifest file if it is named foo.exe.manifest. - -- However, for extra robustness, and so that we can move the binary around, - -- we can embed the manifest in the binary itself using windres: - if not (dopt Opt_EmbedManifest dflags) then return [] else do - - rc_filename <- newTempName dflags "rc" - rc_obj_filename <- newTempName dflags (objectSuf dflags) - - writeFile rc_filename $ - "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" - -- magic numbers :-) - -- show is a bit hackish above, but we need to escape the - -- backslashes in the path. - - let wr_opts = getOpts dflags opt_windres - runWindres dflags $ map SysTools.Option $ - ["--input="++rc_filename, - "--output="++rc_obj_filename, - "--output-format=coff"] - ++ wr_opts - -- no FileOptions here: windres doesn't like seeing - -- backslashes, apparently - - return [rc_obj_filename] -#endif - - -linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () -linkDynLib dflags o_files dep_packages = do - let verb = getVerbFlag dflags - let o_file = outputFile dflags - - -- We don't want to link our dynamic libs against the RTS package, - -- because the RTS lib comes in several flavours and we want to be - -- able to pick the flavour when a binary is linked. - pkgs <- getPreloadPackagesAnd dflags dep_packages - let pkgs_no_rts = filter ((/= rtsPackageId) . packageConfigId) pkgs - - let pkg_lib_paths = collectLibraryPaths pkgs_no_rts - let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths - - let lib_paths = libraryPaths dflags - let lib_path_opts = map ("-L"++) lib_paths - - let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts - - -- probably _stub.o files - extra_ld_inputs <- readIORef v_Ld_inputs - - let (md_c_flags, _) = machdepCCOpts dflags - let extra_ld_opts = getOpts dflags opt_l -#if defined(mingw32_HOST_OS) - ----------------------------------------------------------------------------- - -- Making a DLL - ----------------------------------------------------------------------------- - let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; } - - SysTools.runLink dflags - ([ SysTools.Option verb - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - , SysTools.Option "-shared" - , SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a") - ] - ++ map (SysTools.FileOption "") o_files - ++ map SysTools.Option ( - md_c_flags - ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts - ++ pkg_lib_path_opts - ++ pkg_link_opts - )) -#elif defined(darwin_TARGET_OS) - ----------------------------------------------------------------------------- - -- Making a darwin dylib - ----------------------------------------------------------------------------- - -- About the options used for Darwin: - -- -dynamiclib - -- Apple's way of saying -shared - -- -undefined dynamic_lookup: - -- Without these options, we'd have to specify the correct dependencies - -- for each of the dylibs. Note that we could (and should) do without this - -- for all libraries except the RTS; all we need to do is to pass the - -- correct HSfoo_dyn.dylib files to the link command. - -- This feature requires Mac OS X 10.3 or later; there is a similar feature, - -- -flat_namespace -undefined suppress, which works on earlier versions, - -- but it has other disadvantages. - -- -single_module - -- Build the dynamic library as a single "module", i.e. no dynamic binding - -- nonsense when referring to symbols from within the library. The NCG - -- assumes that this option is specified (on i386, at least). - -- -Wl,-macosx_version_min -Wl,10.3 - -- Tell the linker its safe to assume that the library will run on 10.3 or - -- later, so that it will not complain about the use of the option - -- -undefined dynamic_lookup above. - -- -install_name - -- Causes the dynamic linker to ignore the DYLD_LIBRARY_PATH when loading - -- this lib and instead look for it at its absolute path. - -- When installing the .dylibs (see target.mk), we'll change that path to - -- point to the place they are installed. Therefore, we won't have to set - -- up DYLD_LIBRARY_PATH specifically for ghc. - ----------------------------------------------------------------------------- - - let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - - pwd <- getCurrentDirectory - SysTools.runLink dflags - ([ SysTools.Option verb - , SysTools.Option "-dynamiclib" - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] - ++ map SysTools.Option ( - md_c_flags - ++ o_files - ++ [ "-undefined", "dynamic_lookup", "-single_module", "-Wl,-macosx_version_min","-Wl,10.3", "-install_name " ++ (pwd output_fn) ] - ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts - ++ pkg_lib_path_opts - ++ pkg_link_opts - )) -#else - ----------------------------------------------------------------------------- - -- Making a DSO - ----------------------------------------------------------------------------- - - let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - - SysTools.runLink dflags - ([ SysTools.Option verb - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] - ++ map SysTools.Option ( - md_c_flags - ++ o_files - ++ [ "-shared", "-Wl,-Bsymbolic" ] -- we need symbolic linking to resolve non-PIC intra-package-relocations - ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts - ++ pkg_lib_path_opts - ++ pkg_link_opts - )) -#endif --- ----------------------------------------------------------------------------- --- Running CPP - -doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO () -doCpp dflags raw include_cc_opts input_fn output_fn = do - let hscpp_opts = getOpts dflags opt_P - let cmdline_include_paths = includePaths dflags - - pkg_include_dirs <- getPackageIncludePath dflags [] - let include_paths = foldr (\ x xs -> "-I" : x : xs) [] - (cmdline_include_paths ++ pkg_include_dirs) - - let verb = getVerbFlag dflags - - let cc_opts - | not include_cc_opts = [] - | otherwise = (optc ++ md_c_flags) - where - optc = getOpts dflags opt_c - (md_c_flags, _) = machdepCCOpts dflags - - let cpp_prog args | raw = SysTools.runCpp dflags args - | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args) - - let target_defs = - [ "-D" ++ HOST_OS ++ "_BUILD_OS=1", - "-D" ++ HOST_ARCH ++ "_BUILD_ARCH=1", - "-D" ++ TARGET_OS ++ "_HOST_OS=1", - "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ] - -- remember, in code we *compile*, the HOST is the same our TARGET, - -- and BUILD is the same as our HOST. - - cpp_prog ([SysTools.Option verb] - ++ map SysTools.Option include_paths - ++ map SysTools.Option hsSourceCppOpts - ++ map SysTools.Option hscpp_opts - ++ map SysTools.Option cc_opts - ++ map SysTools.Option target_defs - ++ [ SysTools.Option "-x" - , SysTools.Option "c" - , SysTools.Option input_fn - -- We hackily use Option instead of FileOption here, so that the file - -- name is not back-slashed on Windows. cpp is capable of - -- dealing with / in filenames, so it works fine. Furthermore - -- if we put in backslashes, cpp outputs #line directives - -- with *double* backslashes. And that in turn means that - -- our error messages get double backslashes in them. - -- In due course we should arrange that the lexer deals - -- with these \\ escapes properly. - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ]) - -cHaskell1Version :: String -cHaskell1Version = "5" -- i.e., Haskell 98 - -hsSourceCppOpts :: [String] --- Default CPP defines in Haskell source -hsSourceCppOpts = - [ "-D__HASKELL1__="++cHaskell1Version - , "-D__GLASGOW_HASKELL__="++cProjectVersionInt - , "-D__HASKELL98__" - , "-D__CONCURRENT_HASKELL__" - ] - - --- ----------------------------------------------------------------------------- --- Misc. - -hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase -hscNextPhase _ HsBootFile _ = StopLn -hscNextPhase dflags _ hsc_lang = - case hsc_lang of - HscC -> HCc - HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle - | otherwise -> As - HscNothing -> StopLn - HscInterpreted -> StopLn - _other -> StopLn - - -hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget -hscMaybeAdjustTarget dflags stop _ current_hsc_lang - = hsc_lang - where - keep_hc = dopt Opt_KeepHcFiles dflags - hsc_lang - -- don't change the lang if we're interpreting - | current_hsc_lang == HscInterpreted = current_hsc_lang - - -- force -fvia-C if we are being asked for a .hc file - | HCc <- stop = HscC - | keep_hc = HscC - -- otherwise, stick to the plan - | otherwise = current_hsc_lang - -GLOBAL_VAR(v_Split_info, ("",0), (String,Int)) - -- The split prefix and number of files rmfile ./DriverPipeline4Lsk.hs hunk ./Finder4Lsk.hs 1 -module Finder4Lsk where -import qualified Finder as F -import HscTypes -import Module -import FastString -import DynFlags -import Data.IORef ( IORef, writeIORef, readIORef, modifyIORef ) -import LazyUniqFM -import PrelNames ( gHC_PRIM ) -import System.Directory -import System.FilePath -import FiniteMap -import Util - -findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult -findImportedModule hsc_env mod_name mb_pkg = - case mb_pkg of - Nothing -> unqual_import - Just pkg | pkg == fsLit "this" -> home_import -- "this" is special - | otherwise -> pkg_import - where - home_import = findHomeModule hsc_env mod_name - - pkg_import = F.findImportedModule hsc_env mod_name mb_pkg - - unqual_import = home_import - `orIfNotFound` - F.findImportedModule hsc_env mod_name Nothing - -findHomeModule :: HscEnv -> ModuleName -> IO FindResult -findHomeModule hsc_env mod_name = - homeSearchCache hsc_env mod_name $ - let - dflags = hsc_dflags hsc_env - home_path = importPaths dflags - hisuf = hiSuf dflags - mod = mkModule (thisPackage dflags) mod_name - - source_exts = - [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") - , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs") - , ("lsk", mkHomeModLocationSearched dflags mod_name "lsk") - ] - - hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf) - , (addBootSuffix hisuf, mkHiOnlyModLocation dflags hisuf) - ] - - -- In compilation manager modes, we look for source files in the home - -- package because we can compile these automatically. In one-shot - -- compilation mode we look for .hi and .hi-boot files only. - exts | isOneShot (ghcMode dflags) = hi_exts - | otherwise = source_exts - in - - -- special case for GHC.Prim; we won't find it in the filesystem. - -- This is important only when compiling the base package (where GHC.Prim - -- is a home module). - if mod == gHC_PRIM - then return (Found (error "GHC.Prim ModLocation") mod) - else - - searchPathExts home_path mod exts - -orIfNotFound :: IO FindResult -> IO FindResult -> IO FindResult -this `orIfNotFound` or_this = do - res <- this - case res of - NotFound here _ -> do - res2 <- or_this - case res2 of - NotFound or_here pkg -> return (NotFound (here ++ or_here) pkg) - _other -> return res2 - _other -> return res - -homeSearchCache :: HscEnv -> ModuleName -> IO FindResult -> IO FindResult -homeSearchCache hsc_env mod_name do_this = do - m <- lookupFinderCache (hsc_FC hsc_env) mod_name - case m of - Just result -> return result - Nothing -> do - result <- do_this - addToFinderCache (hsc_FC hsc_env) mod_name result - case result of - Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc - _other -> return () - return result - -mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt - -> FilePath -> BaseName -> IO ModLocation -mkHomeModLocationSearched dflags mod suff path basename = do - F.mkHomeModLocation2 dflags mod (path basename) suff - -addToFinderCache :: IORef FinderCache -> ModuleName -> FindResult -> IO () -addToFinderCache ref key val = modifyIORef ref $ \c -> addToUFM c key val - -addToModLocationCache :: IORef ModLocationCache -> Module -> ModLocation -> IO () -addToModLocationCache ref key val = modifyIORef ref $ \c -> addToFM c key val - -lookupFinderCache :: IORef FinderCache -> ModuleName -> IO (Maybe FindResult) -lookupFinderCache ref key = do - c <- readIORef ref - return $! lookupUFM c key - -searchPathExts - :: [FilePath] -- paths to search - -> Module -- module name - -> [ ( - FileExt, -- suffix - FilePath -> BaseName -> IO ModLocation -- action - ) - ] - -> IO FindResult - -searchPathExts paths mod exts - = do result <- search to_search -{- - hPutStrLn stderr (showSDoc $ - vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) - , nest 2 (vcat (map text paths)) - , case result of - Succeeded (loc, p) -> text "Found" <+> ppr loc - Failed fs -> text "not found"]) --} - return result - - where - basename = moduleNameSlashes (moduleName mod) - - to_search :: [(FilePath, IO ModLocation)] - to_search = [ (file, fn path basename) - | path <- paths, - (ext,fn) <- exts, - let base | path == "." = basename - | otherwise = path basename - file = base <.> ext - ] - - search [] = return (NotFound (map fst to_search) (Just (modulePackageId mod))) - search ((file, mk_result) : rest) = do - b <- doesFileExist file - if b - then do { loc <- mk_result; return (Found loc mod) } - else search rest - -type FileExt = String -- Filename extension -type BaseName = String -- Basename of file - -mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String - -> IO ModLocation -mkHiOnlyModLocation dflags hisuf path basename - = do let full_basename = path basename - obj_fn <- mkObjPath dflags full_basename basename - return ModLocation{ ml_hs_file = Nothing, - ml_hi_file = full_basename <.> hisuf, - -- Remove the .hi-boot suffix from - -- hi_file, if it had one. We always - -- want the name of the real .hi file - -- in the ml_hi_file field. - ml_obj_file = obj_fn - } - -mkObjPath - :: DynFlags - -> FilePath -- the filename of the source file, minus the extension - -> String -- the module name with dots replaced by slashes - -> IO FilePath -mkObjPath dflags basename mod_basename - = do let - odir = objectDir dflags - osuf = objectSuf dflags - - obj_basename | Just dir <- odir = dir mod_basename - | otherwise = basename - - return (obj_basename <.> osuf) rmfile ./Finder4Lsk.hs hunk ./GHC4Lsk.hs 1 --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2005 --- --- The GHC API --- --- ----------------------------------------------------------------------------- -module GHC4Lsk ( - -- * Initialisation - defaultErrorHandler, - defaultCleanupHandler, - - -- * GHC Monad - Ghc, GhcT, GhcMonad(..), - runGhc, runGhcT, initGhcMonad, - gcatch, gbracket, gfinally, - clearWarnings, getWarnings, hasWarnings, - printExceptionAndWarnings, printWarnings, - handleSourceError, - - -- * Flags and settings - DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, - GhcMode(..), GhcLink(..), defaultObjectTarget, - parseDynamicFlags, - getSessionDynFlags, - setSessionDynFlags, - parseStaticFlags, - - -- * Targets - Target(..), TargetId(..), Phase, - setTargets, - getTargets, - addTarget, - removeTarget, - guessTarget, - - -- * Extending the program scope - extendGlobalRdrScope, - setGlobalRdrScope, - extendGlobalTypeScope, - setGlobalTypeScope, - - -- * Loading\/compiling the program - depanal, - load, loadWithLogger, LoadHowMuch(..), SuccessFlag(..), -- also does depanal - defaultWarnErrLogger, WarnErrLogger, - workingDirectoryChanged, - parseModule, typecheckModule, desugarModule, loadModule, - ParsedModule(..), TypecheckedModule(..), DesugaredModule, -- all abstract - TypecheckedSource, ParsedSource, RenamedSource, -- ditto - TypecheckedMod, ParsedMod, - moduleInfo, renamedSource, typecheckedSource, - parsedSource, coreModule, - compileToCoreModule, compileToCoreSimplified, - compileCoreToObj, - getModSummary, - - -- * Parsing Haddock comments - parseHaddockComment, - - -- * Inspecting the module structure of the program - ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), - getModuleGraph, - isLoaded, - topSortModuleGraph, - - -- * Inspecting modules - ModuleInfo, - getModuleInfo, - modInfoTyThings, - modInfoTopLevelScope, - modInfoExports, - modInfoInstances, - modInfoIsExportedName, - modInfoLookupName, - lookupGlobalName, - mkPrintUnqualifiedForModule, - - -- * Printing - PrintUnqualified, alwaysQualify, - - -- * Interactive evaluation - getBindings, getPrintUnqual, - findModule, -#ifdef GHCI - setContext, getContext, - getNamesInScope, - getRdrNamesInScope, - getGRE, - moduleIsInterpreted, - getInfo, - exprType, - typeKind, - parseName, - RunResult(..), - runStmt, SingleStep(..), - resume, - Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, - resumeHistory, resumeHistoryIx), - History(historyBreakInfo, historyEnclosingDecl), - GHC4Lsk.getHistorySpan, getHistoryModule, - getResumeContext, - abandon, abandonAll, - InteractiveEval.back, - InteractiveEval.forward, - showModule, - isModuleInterpreted, - InteractiveEval.compileExpr, HValue, dynCompileExpr, - lookupName, - GHC4Lsk.obtainTermFromId, GHC4Lsk.obtainTermFromVal, reconstructType, - modInfoModBreaks, - ModBreaks(..), BreakIndex, - BreakInfo(breakInfo_number, breakInfo_module), - BreakArray, setBreakOn, setBreakOff, getBreak, -#endif - - -- * Abstract syntax elements - - -- ** Packages - PackageId, - - -- ** Modules - Module, mkModule, pprModule, moduleName, modulePackageId, - ModuleName, mkModuleName, moduleNameString, - - -- ** Names - Name, - isExternalName, nameModule, pprParenSymName, nameSrcSpan, - NamedThing(..), - RdrName(Qual,Unqual), - - -- ** Identifiers - Id, idType, - isImplicitId, isDeadBinder, - isExportedId, isLocalId, isGlobalId, - isRecordSelector, - isPrimOpId, isFCallId, isClassOpId_maybe, - isDataConWorkId, idDataCon, - isBottomingId, isDictonaryId, - recordSelectorFieldLabel, - - -- ** Type constructors - TyCon, - tyConTyVars, tyConDataCons, tyConArity, - isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, - isOpenTyCon, - synTyConDefn, synTyConType, synTyConResKind, - - -- ** Type variables - TyVar, - alphaTyVars, - - -- ** Data constructors - DataCon, - dataConSig, dataConType, dataConTyCon, dataConFieldLabels, - dataConIsInfix, isVanillaDataCon, - dataConStrictMarks, - StrictnessMark(..), isMarkedStrict, - - -- ** Classes - Class, - classMethods, classSCTheta, classTvsFds, - pprFundeps, - - -- ** Instances - Instance, - instanceDFunId, pprInstance, pprInstanceHdr, - - -- ** Types and Kinds - Type, splitForAllTys, funResultTy, - pprParendType, pprTypeApp, - Kind, - PredType, - ThetaType, pprThetaArrow, - - -- ** Entities - TyThing(..), - - -- ** Syntax - module HsSyn, -- ToDo: remove extraneous bits - - -- ** Fixities - FixityDirection(..), - defaultFixity, maxPrecedence, - negateFixity, - compareFixity, - - -- ** Source locations - SrcLoc, pprDefnLoc, - mkSrcLoc, isGoodSrcLoc, noSrcLoc, - srcLocFile, srcLocLine, srcLocCol, - SrcSpan, - mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, - srcSpanStart, srcSpanEnd, - srcSpanFile, - srcSpanStartLine, srcSpanEndLine, - srcSpanStartCol, srcSpanEndCol, - - -- ** Located - Located(..), - - -- *** Constructing Located - noLoc, mkGeneralLocated, - - -- *** Deconstructing Located - getLoc, unLoc, - - -- *** Combining and comparing Located values - eqLocated, cmpLocated, combineLocs, addCLoc, - leftmost_smallest, leftmost_largest, rightmost, - spans, isSubspanOf, - - -- * Exceptions - GhcException(..), showGhcException, - - -- * Token stream manipulations - Token, - getTokenStream, getRichTokenStream, - showRichTokenStream, addSourceToTokens, - - -- * Miscellaneous - --sessionHscEnv, - cyclicModuleErr, - - compileHsExpr, - unload - ) where - -{- - ToDo: - - * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt. - * what StaticFlags should we expose, if any? --} - -#include "HsVersions4Lsk.h" - -#ifdef GHCI -import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) -import CodeOutput ( outputForeignStubs ) -import CorePrep ( corePrepPgm ) -import CorePrep ( corePrepExpr ) -import qualified Linker -import Linker ( HValue ) -import ByteCodeInstr -import BreakArray -import NameSet -import InteractiveEval -import TcRnDriver -import TcRnDriver4Lsk -import Desugar ( deSugarExpr ) -import PrelNames -#endif - -import TcIface -import TcRnTypes hiding (LIE) -import TcRnMonad ( initIfaceCheck, getLIE, initTcPrintErrors, failIfErrsM ) -import Packages -import NameSet -import RdrName -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 -import TysPrim ( alphaTyVars ) -import TyCon -import Class -import FunDeps -import DataCon -import Name hiding ( varName ) -import OccName ( parenSymOcc ) -import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr, - emptyInstEnv ) -import FamInstEnv ( emptyFamInstEnv ) -import SrcLoc ---import CoreSyn -import TidyPgm -import DriverPipeline4Lsk -import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase ) -import HeaderInfo -import Finder -import qualified Finder4Lsk as FL -import HscMain -import HscTypes -import DynFlags -import StaticFlagParser -import qualified StaticFlags -import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, - cleanTempDirs ) -import Module -import LazyUniqFM -import UniqSet -import Unique -import FiniteMap -import Panic -import Digraph -import Bag ( unitBag, listToBag, emptyBag, isEmptyBag ) -import ErrUtils -import MonadUtils -import Util -import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar ) -import Outputable -import BasicTypes -import Maybes ( expectJust, mapCatMaybes ) -import HaddockParse -import HaddockLex ( tokenise ) -import FastString -import Lexer - -import Control.Concurrent -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, getClockTime ) -import Exception -import Data.IORef -import System.FilePath -import System.IO -import System.IO.Error ( try, isDoesNotExistError ) -import Prelude hiding (init) - -import LskFileHandler -import TcHsSyn -import GHC.Exts ( unsafeCoerce# ) -import RnExpr -import RnEnv -import TcEnv -import TcExpr -import TcSimplify -import SimplCore ( core2core ) - --- ----------------------------------------------------------------------------- --- Exception handlers - --- | Install some default exception handlers and run the inner computation. --- Unless you want to handle exceptions yourself, you should wrap this around --- the top level of your program. The default handlers output the error --- message(s) to stderr and exit cleanly. -defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a -defaultErrorHandler dflags inner = - -- top-level exception handler: any unrecognised exception is a compiler bug. - ghandle (\exception -> liftIO $ do - hFlush stdout - case fromException exception of - -- an IO exception probably isn't our fault, so don't panic - Just (ioe :: IOException) -> - fatalErrorMsg dflags (text (show ioe)) - _ -> case fromException exception of - Just StackOverflow -> - fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") - _ -> case fromException exception of - Just (ex :: ExitCode) -> throw ex - _ -> - fatalErrorMsg dflags - (text (show (Panic (show exception)))) - exitWith (ExitFailure 1) - ) $ - - -- error messages propagated as exceptions - handleGhcException - (\ge -> liftIO $ do - hFlush stdout - case ge of - PhaseFailed _ code -> exitWith code - Interrupted -> exitWith (ExitFailure 1) - _ -> do fatalErrorMsg dflags (text (show ge)) - exitWith (ExitFailure 1) - ) $ - inner - --- | Install a default cleanup handler to remove temporary files deposited by --- a GHC run. This is seperate from 'defaultErrorHandler', because you might --- want to override the error handling, but still get the ordinary cleanup --- behaviour. -defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) => - DynFlags -> m a -> m a -defaultCleanupHandler dflags inner = - -- make sure we clean up after ourselves - inner `gonException` - (liftIO $ 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. - --- | Print the error message and all warnings. Useful inside exception --- handlers. Clears warnings after printing. -printExceptionAndWarnings :: GhcMonad m => SourceError -> m () -printExceptionAndWarnings err = do - let errs = srcErrorMessages err - warns <- getWarnings - dflags <- getSessionDynFlags - if isEmptyBag errs - -- Empty errors means we failed due to -Werror. (Since this function - -- takes a source error as argument, we know for sure _some_ error - -- did indeed happen.) - then liftIO $ do - printBagOfWarnings dflags warns - printBagOfErrors dflags (unitBag warnIsErrorMsg) - else liftIO $ printBagOfErrors dflags errs - clearWarnings - --- | Print all accumulated warnings using 'log_action'. -printWarnings :: GhcMonad m => m () -printWarnings = do - dflags <- getSessionDynFlags - warns <- getWarnings - liftIO $ printBagOfWarnings dflags warns - clearWarnings - --- | Run function for the 'Ghc' monad. --- --- It initialises the GHC session and warnings via 'initGhcMonad'. Each call --- to this function will create a new session which should not be shared among --- several threads. --- --- Any errors not handled inside the 'Ghc' action are propagated as IO --- exceptions. - -runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. - -> Ghc a -- ^ The action to perform. - -> IO a -runGhc mb_top_dir ghc = do - wref <- newIORef emptyBag - ref <- newIORef undefined - let session = Session ref wref - flip unGhc session $ do - initGhcMonad mb_top_dir - ghc - -- XXX: unregister interrupt handlers here? - --- | Run function for 'GhcT' monad transformer. --- --- It initialises the GHC session and warnings via 'initGhcMonad'. Each call --- to this function will create a new session which should not be shared among --- several threads. - -runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) => - Maybe FilePath -- ^ See argument to 'initGhcMonad'. - -> GhcT m a -- ^ The action to perform. - -> m a -runGhcT mb_top_dir ghct = do - wref <- liftIO $ newIORef emptyBag - ref <- liftIO $ newIORef undefined - let session = Session ref wref - flip unGhcT session $ do - initGhcMonad mb_top_dir - ghct - --- | Initialise a GHC session. --- --- If you implement a custom 'GhcMonad' you must call this function in the --- monad run function. It will initialise the session variable and clear all --- warnings. --- --- The first argument should point to the directory where GHC's library files --- reside. More precisely, this should be the output of @ghc --print-libdir@ --- of the version of GHC the module using this API is compiled with. For --- portability, you should use the @ghc-paths@ package, available at --- . - -initGhcMonad :: GhcMonad m => Maybe FilePath -> m () -initGhcMonad mb_top_dir = do - -- catch ^C - main_thread <- liftIO $ myThreadId - liftIO $ modifyMVar_ interruptTargetThread (return . (main_thread :)) - liftIO $ installSignalHandlers - - liftIO $ StaticFlags.initStaticOpts - - dflags0 <- liftIO $ initDynFlags defaultDynFlags - dflags <- liftIO $ initSysTools mb_top_dir dflags0 - env <- liftIO $ newHscEnv dflags - setSession env - clearWarnings - --- ----------------------------------------------------------------------------- --- Flags & settings - --- | Grabs the DynFlags from the Session -getSessionDynFlags :: GhcMonad m => m DynFlags -getSessionDynFlags = withSession (return . hsc_dflags) - --- | Updates the DynFlags in a Session. This also reads --- the package database (unless it has already been read), --- and prepares the compilers knowledge about packages. It --- can be called again to load new packages: just add new --- package flags to (packageFlags dflags). --- --- Returns a list of new packages that may need to be linked in using --- the dynamic linker (see 'linkPackages') as a result of new package --- flags. If you are not doing linking or doing static linking, you --- can ignore the list of packages returned. --- -setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId] -setSessionDynFlags dflags = do - (dflags', preload) <- liftIO $ initPackages dflags - modifySession (\h -> h{ hsc_dflags = dflags' }) - return preload - --- | If there is no -o option, guess the name of target executable --- by using top-level source file name as a base. -guessOutputFile :: GhcMonad m => m () -guessOutputFile = modifySession $ \env -> - let dflags = hsc_dflags env - mod_graph = hsc_mod_graph env - mainModuleSrcPath :: Maybe String - mainModuleSrcPath = do - let isMain = (== mainModIs dflags) . ms_mod - [ms] <- return (filter isMain mod_graph) - ml_hs_file (ms_location ms) - 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 = name_exe } } - --- ----------------------------------------------------------------------------- --- Targets - --- ToDo: think about relative vs. absolute file paths. And what --- happens when the current directory changes. - --- | Sets the targets for this session. Each target may be a module name --- or a filename. The targets correspond to the set of root modules for --- the program\/library. Unloading the current program is achieved by --- setting the current set of targets to be empty, followed by 'load'. -setTargets :: GhcMonad m => [Target] -> m () -setTargets targets = modifySession (\h -> h{ hsc_targets = targets }) - --- | Returns the current set of targets -getTargets :: GhcMonad m => m [Target] -getTargets = withSession (return . hsc_targets) - --- | Add another target. -addTarget :: GhcMonad m => Target -> m () -addTarget target - = modifySession (\h -> h{ hsc_targets = target : hsc_targets h }) - --- | Remove a target -removeTarget :: GhcMonad m => TargetId -> m () -removeTarget target_id - = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) }) - where - 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: --- --- - if the string looks like a Haskell source filename, then interpret it --- as such --- --- - if adding a .hs or .lhs suffix yields the name of an existing file, --- then use that --- --- - otherwise interpret the string as a module name --- -guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target -guessTarget str (Just phase) - = return (Target (TargetFile str (Just phase)) True Nothing) -guessTarget str Nothing - | isHaskellSrcFilename file - = return (target (TargetFile file Nothing)) - | otherwise - = do exists <- liftIO $ doesFileExist hs_file - if exists - then return (target (TargetFile hs_file Nothing)) - else do - exists <- liftIO $ doesFileExist lhs_file - if exists - then return (target (TargetFile lhs_file Nothing)) - else do - exists <- liftIO $ doesFileExist lsk_file - if exists - then return (target (TargetFile lsk_file Nothing)) - else do - 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 - (file,obj_allowed) - | '*':rest <- str = (rest, False) - | otherwise = (str, True) - - hs_file = file <.> "hs" - lhs_file = file <.> "lhs" - lsk_file = file <.> "lsk" - - target tid = Target tid obj_allowed Nothing - --- ----------------------------------------------------------------------------- --- Extending the program scope - -extendGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m () -extendGlobalRdrScope rdrElts - = modifySession $ \hscEnv -> - let global_rdr = hsc_global_rdr_env hscEnv - in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts } - -setGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m () -setGlobalRdrScope rdrElts - = modifySession $ \hscEnv -> - hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts } - -extendGlobalTypeScope :: GhcMonad m => [Id] -> m () -extendGlobalTypeScope ids - = modifySession $ \hscEnv -> - let global_type = hsc_global_type_env hscEnv - in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids } - -setGlobalTypeScope :: GhcMonad m => [Id] -> m () -setGlobalTypeScope ids - = modifySession $ \hscEnv -> - hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids } - --- ----------------------------------------------------------------------------- --- Parsing Haddock comments - -parseHaddockComment :: String -> Either String (HsDoc RdrName) -parseHaddockComment string = - case parseHaddockParagraphs (tokenise string) of - MyLeft x -> Left x - MyRight x -> Right x - --- ----------------------------------------------------------------------------- --- Loading the program - --- | Perform a dependency analysis starting from the current targets --- and update the session with the new module graph. -depanal :: GhcMonad m => - [ModuleName] -- ^ excluded modules - -> Bool -- ^ allow duplicate roots - -> m ModuleGraph -depanal excluded_mods allow_dup_roots = do - hsc_env <- getSession - let - dflags = hsc_dflags hsc_env - targets = hsc_targets hsc_env - old_graph = hsc_mod_graph hsc_env - - liftIO $ showPass dflags "Chasing dependencies" - liftIO $ debugTraceMsg dflags 2 (hcat [ - text "Chasing modules from: ", - hcat (punctuate comma (map pprTarget targets))]) - - mod_graph <- downsweep hsc_env old_graph excluded_mods allow_dup_roots - modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } - return mod_graph - -data LoadHowMuch - = LoadAllTargets - | LoadUpTo ModuleName - | LoadDependenciesOf ModuleName - --- | Try to load the program. Calls 'loadWithLogger' with the default --- compiler that just immediately logs all warnings and errors. -load :: GhcMonad m => LoadHowMuch -> m SuccessFlag -load how_much = - loadWithLogger defaultWarnErrLogger how_much - --- | A function called to log warnings and errors. -type WarnErrLogger = GhcMonad m => Maybe SourceError -> m () - -defaultWarnErrLogger :: WarnErrLogger -defaultWarnErrLogger Nothing = printWarnings -defaultWarnErrLogger (Just e) = printExceptionAndWarnings e - --- | Try to load the program. If a Module is supplied, then just --- attempt to load up to this target. If no Module is supplied, --- then try to load all targets. --- --- The first argument is a function that is called after compiling each --- module to print wanrings and errors. - -loadWithLogger :: GhcMonad m => WarnErrLogger -> LoadHowMuch -> m SuccessFlag -loadWithLogger logger 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 - -- graph is still retained in the Session. We can tell which modules - -- were successfully loaded by inspecting the Session's HPT. - mod_graph <- depanal [] False - load2 how_much mod_graph logger - -load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> WarnErrLogger - -> m SuccessFlag -load2 how_much mod_graph logger = do - guessOutputFile - hsc_env <- getSession - - let hpt1 = hsc_HPT hsc_env - let dflags = hsc_dflags hsc_env - - -- The "bad" boot modules are the ones for which we have - -- B.hs-boot in the module graph, but no B.hs - -- The downsweep should have ensured this does not happen - -- (see msDeps) - let all_home_mods = [ms_mod_name s - | s <- mod_graph, not (isBootSummary s)] - bad_boot_mods = [s | s <- mod_graph, isBootSummary s, - 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 - liftIO $ 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 - -- upsweep, and for removing from hpt all the modules - -- not in strict downwards closure, during calls to compile. - let mg2_with_srcimps :: [SCC ModSummary] - mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing - - -- If we can determine that any of the {-# SOURCE #-} imports - -- are definitely unnecessary, then emit a warning. - warnUnnecessarySourceImports dflags mg2_with_srcimps - - let - -- check the stability property for each module. - stable_mods@(stable_obj,stable_bco) - = checkStability hpt1 mg2_with_srcimps all_home_mods - - -- prune bits of the HPT which are definitely redundant now, - -- to save space. - pruned_hpt = pruneHomePackageTable hpt1 - (flattenSCCs mg2_with_srcimps) - stable_mods - - liftIO $ 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. - modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext, - hsc_HPT = pruned_hpt } - - liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ - text "Stable BCO:" <+> ppr stable_bco) - - -- Unload any modules which are going to be re-linked this time around. - let stable_linkables = [ linkable - | m <- stable_obj++stable_bco, - Just hmi <- [lookupUFM pruned_hpt m], - Just linkable <- [hm_linkable hmi] ] - liftIO $ unload hsc_env stable_linkables - - -- We could at this point detect cycles which aren't broken by - -- a source-import, and complain immediately, but it seems better - -- to let upsweep_mods do this, so at least some useful work gets - -- done before the upsweep is abandoned. - --hPutStrLn stderr "after tsort:\n" - --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) - - -- Now do the upsweep, calling compile for each module in - -- turn. Final result is version 3 of everything. - - -- Topologically sort the module graph, this time including hi-boot - -- nodes, and possibly just including the portion of the graph - -- reachable from the module specified in the 2nd argument to load. - -- This graph should be cycle-free. - -- If we're restricting the upsweep to a portion of the graph, we - -- also want to retain everything that is still stable. - let full_mg :: [SCC ModSummary] - full_mg = topSortModuleGraph False mod_graph Nothing - - maybe_top_mod = case how_much of - LoadUpTo m -> Just m - LoadDependenciesOf m -> Just m - _ -> Nothing - - partial_mg0 :: [SCC ModSummary] - partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod - - -- LoadDependenciesOf m: we want the upsweep to stop just - -- short of the specified module (unless the specified module - -- is stable). - partial_mg - | LoadDependenciesOf _mod <- how_much - = ASSERT( case last partial_mg0 of - AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) - List.init partial_mg0 - | otherwise - = partial_mg0 - - stable_mg = - [ AcyclicSCC ms - | AcyclicSCC ms <- full_mg, - ms_mod_name ms `elem` stable_obj++stable_bco, - ms_mod_name ms `notElem` [ ms_mod_name ms' | - AcyclicSCC ms' <- partial_mg ] ] - - mg = stable_mg ++ partial_mg - - -- clean up between compilations - let cleanup = cleanTempFilesExcept dflags - (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps)) - - liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") - 2 (ppr mg)) - (upsweep_ok, hsc_env1, modsUpswept) - <- upsweep logger - (hsc_env { hsc_HPT = emptyHomePackageTable }) - pruned_hpt stable_mods cleanup mg - - -- Make modsDone be the summaries for each home module now - -- available; this should equal the domain of hpt3. - -- Get in in a roughly top .. bottom order (hence reverse). - - let modsDone = reverse modsUpswept - - -- Try and do linking in some form, depending on whether the - -- upsweep was completely or only partially successful. - - if succeeded upsweep_ok - - then - -- Easy; just relink it all. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") - - -- Clean up after ourselves - liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) - - -- Issue a warning for the confusing case where the user - -- said '-o foo' but we're not going to do any linking. - -- We attempt linking if either (a) one of the modules is - -- called Main, or (b) the user said -no-hs-main, indicating - -- that main() is going to come from somewhere else. - -- - let ofile = outputFile dflags - let no_hs_main = dopt Opt_NoHsMain dflags - let - main_mod = mainModIs dflags - a_root_is_Main = any ((==main_mod).ms_mod) mod_graph - do_linking = a_root_is_Main || no_hs_main - - when (ghcLink dflags == LinkBinary - && isJust ofile && not do_linking) $ - liftIO $ debugTraceMsg dflags 1 $ - text ("Warning: output was redirected with -o, " ++ - "but no output will be generated\n" ++ - "because there is no " ++ - moduleNameString (moduleName main_mod) ++ " module.") - - -- link everything together - linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) - - loadFinish Succeeded linkresult hsc_env1 - - 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 liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") - - let modsDone_names - = map ms_mod modsDone - let mods_to_zap_names - = findPartiallyCompletedCycles modsDone_names - mg2_with_srcimps - let mods_to_keep - = filter ((`notElem` mods_to_zap_names).ms_mod) - modsDone - - let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) - (hsc_HPT hsc_env1) - - -- Clean up after ourselves - liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep) - - -- there should be no Nothings where linkables should be, now - ASSERT(all (isJust.hm_linkable) - (eltsUFM (hsc_HPT hsc_env))) do - - -- Link everything together - linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 - - let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 } - loadFinish Failed linkresult hsc_env4 - --- Finish up after a load. - --- If the link failed, unload everything and return. -loadFinish :: GhcMonad m => - SuccessFlag -> SuccessFlag -> HscEnv - -> m SuccessFlag -loadFinish _all_ok Failed hsc_env - = do liftIO $ unload hsc_env [] - modifySession $ \_ -> discardProg hsc_env - return Failed - --- Empty the interactive context and set the module context to the topmost --- newly loaded module, or the Prelude if none were loaded. -loadFinish all_ok Succeeded hsc_env - = do modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext } - return all_ok - - --- Forget the current program, but retain the persistent info in HscEnv -discardProg :: HscEnv -> HscEnv -discardProg hsc_env - = hsc_env { hsc_mod_graph = emptyMG, - hsc_IC = emptyInteractiveContext, - hsc_HPT = emptyHomePackageTable } - --- 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 :: [ModSummary] -> [FilePath] -ppFilesFromSummaries summaries = map ms_hspp_file summaries - --- ----------------------------------------------------------------------------- - -class ParsedMod m where - modSummary :: m -> ModSummary - parsedSource :: m -> ParsedSource - -class ParsedMod m => TypecheckedMod m where - renamedSource :: m -> Maybe RenamedSource - typecheckedSource :: m -> TypecheckedSource - moduleInfo :: m -> ModuleInfo - tm_internals :: m -> (TcGblEnv, ModDetails) - -- ToDo: improvements that could be made here: - -- if the module succeeded renaming but not typechecking, - -- we can still get back the GlobalRdrEnv and exports, so - -- perhaps the ModuleInfo should be split up into separate - -- fields. - -class TypecheckedMod m => DesugaredMod m where - coreModule :: m -> ModGuts - --- | The result of successful parsing. -data ParsedModule = - ParsedModule { pm_mod_summary :: ModSummary - , pm_parsed_source :: ParsedSource } - -instance ParsedMod ParsedModule where - modSummary m = pm_mod_summary m - parsedSource m = pm_parsed_source m - --- | The result of successful typechecking. It also contains the parser --- result. -data TypecheckedModule = - TypecheckedModule { tm_parsed_module :: ParsedModule - , tm_renamed_source :: Maybe RenamedSource - , tm_typechecked_source :: TypecheckedSource - , tm_checked_module_info :: ModuleInfo - , tm_internals_ :: (TcGblEnv, ModDetails) - } - -instance ParsedMod TypecheckedModule where - modSummary m = modSummary (tm_parsed_module m) - parsedSource m = parsedSource (tm_parsed_module m) - -instance TypecheckedMod TypecheckedModule where - renamedSource m = tm_renamed_source m - typecheckedSource m = tm_typechecked_source m - moduleInfo m = tm_checked_module_info m - tm_internals m = tm_internals_ m - --- | The result of successful desugaring (i.e., translation to core). Also --- contains all the information of a typechecked module. -data DesugaredModule = - DesugaredModule { dm_typechecked_module :: TypecheckedModule - , dm_core_module :: ModGuts - } - -instance ParsedMod DesugaredModule where - modSummary m = modSummary (dm_typechecked_module m) - parsedSource m = parsedSource (dm_typechecked_module m) - -instance TypecheckedMod DesugaredModule where - renamedSource m = renamedSource (dm_typechecked_module m) - typecheckedSource m = typecheckedSource (dm_typechecked_module m) - moduleInfo m = moduleInfo (dm_typechecked_module m) - tm_internals m = tm_internals_ (dm_typechecked_module m) - -instance DesugaredMod DesugaredModule where - coreModule m = dm_core_module m - -type ParsedSource = Located (HsModule RdrName) -type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], - Maybe (HsDoc Name), HaddockModInfo Name) -type TypecheckedSource = LHsBinds Id - --- NOTE: --- - things that aren't in the output of the typechecker right now: --- - the export list --- - the imports --- - type signatures --- - type/data/newtype declarations --- - class declarations --- - instances --- - extra things in the typechecker's output: --- - default methods are turned into top-level decls. --- - dictionary bindings - --- | Return the 'ModSummary' of a module with the given name. --- --- The module must be part of the module graph (see 'hsc_mod_graph' and --- 'ModuleGraph'). If this is not the case, this function will throw a --- 'GhcApiError'. --- --- This function ignores boot modules and requires that there is only one --- non-boot module with the given name. -getModSummary :: GhcMonad m => ModuleName -> m ModSummary -getModSummary mod = do - mg <- liftM hsc_mod_graph getSession - case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of - [] -> throw $ mkApiErr (text "Module not part of module graph") - [ms] -> return ms - multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple) - --- | Parse a module. --- --- Throws a 'SourceError' on parse error. -parseModule :: GhcMonad m => ModSummary -> m ParsedModule -parseModule ms = do - hsc_env0 <- getSession - let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } - rdr_module <- parseFile hsc_env ms - return (ParsedModule ms rdr_module) - --- | Typecheck and rename a parsed module. --- --- Throws a 'SourceError' if either fails. -typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule -typecheckModule pmod = do - let ms = modSummary pmod - hsc_env0 <- getSession - let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } - (tc_gbl_env, rn_info) - <- typecheckRenameModule hsc_env ms (parsedSource pmod) - details <- liftIO $ makeSimpleDetails hsc_env tc_gbl_env - return $ - TypecheckedModule { - tm_internals_ = (tc_gbl_env, details), - tm_parsed_module = pmod, - tm_renamed_source = rn_info, - tm_typechecked_source = tcg_binds tc_gbl_env, - tm_checked_module_info = - ModuleInfo { - minf_type_env = md_types details, - minf_exports = availsToNameSet $ md_exports details, - minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), - minf_instances = md_insts details -#ifdef GHCI - ,minf_modBreaks = emptyModBreaks -#endif - }} - --- | Desugar a typechecked module. -desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule -desugarModule tcm = do - let ms = modSummary tcm - hsc_env0 <- getSession - let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } - let (tcg, _) = tm_internals tcm - guts <- deSugarModule hsc_env ms tcg - return $ - DesugaredModule { - dm_typechecked_module = tcm, - dm_core_module = guts - } - --- | Load a module. Input doesn't need to be desugared. --- --- XXX: Describe usage. - -hscInteractive' hsc_env mod_summary (iface, details, cgguts) - = do - let CgGuts{ -- This is the last use of the ModGuts in a compilation. - -- From now on, we just use the bits we need. - cg_module = this_mod, - cg_binds = core_binds, - cg_tycons = tycons, - cg_foreign = foreign_stubs, - cg_modBreaks = mod_breaks } = cgguts - dflags = hsc_dflags hsc_env --- location = ms_location mod_summary - data_tycons = filter isDataTyCon tycons - -- cg_tycons includes newtypes, for the benefit of External Core, - -- but we don't generate any code for newtypes - ------------------- - -- PREPARE FOR CODE GENERATION - -- Do saturation and convert to A-normal form - prepd_binds <- {-# SCC "CorePrep" #-} - corePrepPgm dflags core_binds data_tycons ; - ----------------- Generate byte code ------------------ - comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks - ------------------ Create f-x-dynamic C-side stuff --- --- (_istub_h_exists, istub_c_exists) --- <- outputForeignStubs dflags this_mod location foreign_stubs - clock <- getClockTime - return (LM clock this_mod [BCOs comp_bc emptyModBreaks]) --- return (Just (InteractiveRecomp istub_c_exists comp_bc mod_breaks, iface, details)) - -loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod -loadModule tcm = do - let ms = modSummary tcm - let mod = ms_mod_name ms - hsc_env0 <- getSession - let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } - let (tcg, details) = tm_internals tcm - (iface,_) <- liftIO $ makeSimpleIface hsc_env Nothing tcg details - modguts <- deSugarModule hsc_env ms tcg - modguts' <- liftIO $ core2core hsc_env modguts - (cgguts, _moddetails) <- liftIO $ tidyProgram hsc_env modguts' - linkable <- liftIO $ hscInteractive' hsc_env ms (iface, details, cgguts) - let mod_info = HomeModInfo { - hm_iface = iface, - hm_details = details, - hm_linkable = Just $ linkable } - let hpt_new = addToUFM (hsc_HPT hsc_env) mod mod_info - modifySession $ \_ -> hsc_env0{ hsc_HPT = hpt_new } - return tcm - --- | This is the way to get access to the Core bindings corresponding --- to a module. 'compileToCore' parses, typechecks, and --- desugars the module, then returns the resulting Core module (consisting of --- the module name, type declarations, and function declarations) if --- successful. -compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule -compileToCoreModule = compileCore False - --- | Like compileToCoreModule, but invokes the simplifier, so --- as to return simplified and tidied Core. -compileToCoreSimplified :: GhcMonad m => FilePath -> m 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 :: GhcMonad m => FilePath -> m [CoreBind] -compileToCore fn = do - mod <- compileToCoreModule session fn - return $ cm_binds mod --} --- | 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 :: GhcMonad m => Bool -> CoreModule -> m () -compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do - hscEnv <- getSession - dflags <- getSessionDynFlags - currentTime <- liftIO $ getClockTime - cwd <- liftIO $ getCurrentDirectory - modLocation <- liftIO $ 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 - } - - ioMsgMaybe $ flip evalComp (CompState{ compHscEnv=hscEnv, - compModSummary=modSummary, - compOldIface=Nothing}) $ - let maybe_simplify mod_guts | simplify = hscSimplify mod_guts - | otherwise = return mod_guts - in maybe_simplify (mkModGuts cm) - >>= hscNormalIface - >>= hscWriteIface - >>= hscOneShot - return () - --- 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 :: GhcMonad m => Bool -> FilePath -> m CoreModule -compileCore simplify fn = do - -- First, set the target to the desired filename - target <- guessTarget fn Nothing - addTarget target - load LoadAllTargets - -- Then find dependencies - modGraph <- depanal [] True - case find ((== fn) . msHsFilePath) modGraph of - Just modSummary -> do - -- Now we have the module name; - -- parse, typecheck and desugar the module - mod_guts <- coreModule `fmap` - (desugarModule =<< typecheckModule =<< parseModule modSummary) - liftM gutsToCoreModule $ - if simplify - then do - -- If simplify is true: simplify (hscSimplify), then tidy - -- (tidyProgram). - hsc_env <- getSession - simpl_guts <- ioMsg $ evalComp (hscSimplify mod_guts) - (CompState{ - compHscEnv = hsc_env, - compModSummary = modSummary, - compOldIface = Nothing}) - tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts - return $ Left tidy_guts - else - return $ Right mod_guts - - 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 - } - --- --------------------------------------------------------------------------- --- Unloading - -unload :: HscEnv -> [Linkable] -> IO () -unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' - = case ghcLink (hsc_dflags hsc_env) of -#ifdef GHCI - LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables -#else - LinkInMemory -> panic "unload: no interpreter" - -- urgh. avoid warnings: - hsc_env stable_linkables -#endif - _other -> return () - --- ----------------------------------------------------------------------------- - -{- | - - Stability tells us which modules definitely do not need to be recompiled. - There are two main reasons for having stability: - - - avoid doing a complete upsweep of the module graph in GHCi when - modules near the bottom of the tree have not changed. - - - to tell GHCi when it can load object code: we can only load object code - for a module when we also load object code fo all of the imports of the - module. So we need to know that we will definitely not be recompiling - any of these modules, and we can use the object code. - - The stability check is as follows. Both stableObject and - stableBCO are used during the upsweep phase later. - -@ - stable m = stableObject m || stableBCO m - - stableObject m = - all stableObject (imports m) - && old linkable does not exist, or is == on-disk .o - && date(on-disk .o) > date(.hs) - - stableBCO m = - all stable (imports m) - && date(BCO) > date(.hs) -@ - - These properties embody the following ideas: - - - if a module is stable, then: - - - if it has been compiled in a previous pass (present in HPT) - then it does not need to be compiled or re-linked. - - - if it has not been compiled in a previous pass, - then we only need to read its .hi file from disk and - link it to produce a 'ModDetails'. - - - if a modules is not stable, we will definitely be at least - re-linking, and possibly re-compiling it during the 'upsweep'. - All non-stable modules can (and should) therefore be unlinked - before the 'upsweep'. - - - Note that objects are only considered stable if they only depend - on other objects. We can't link object code against byte code. --} - -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 - :: GhcMonad m => - WarnErrLogger -- ^ Called to print warnings and errors. - -> 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) - -> m (SuccessFlag, - HscEnv, -- With an updated HPT - [ModSummary]) -- Mods which succeeded - -upsweep logger 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 liftIO $ 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 - - mb_mod_info - <- handleSourceError - (\err -> do logger (Just err); return Nothing) $ do - mod_info <- upsweep_mod hsc_env old_hpt stable_mods - mod mod_index nmods - logger Nothing -- log warnings - return (Just mod_info) - - liftIO cleanup -- Remove unwanted tmp files between compilations - - case mb_mod_info of - Nothing -> return (Failed, hsc_env, done) - 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 <- liftIO $ 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 :: GhcMonad m => - HscEnv - -> HomePackageTable - -> ([ModuleName],[ModuleName]) - -> ModSummary - -> Int -- index of module - -> Int -- total number of modules - -> m HomeModInfo - -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 :: GhcMonad m => Maybe Linkable -> m HomeModInfo - compile_it = compile hsc_env summary' mod_index nmods mb_old_iface - - compile_it_discard_iface :: GhcMonad m => - Maybe Linkable -> m HomeModInfo - 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 -> - let Just hmi = old_hmi in - return hmi - -- object is stable, and we have an entry in the - -- old HPT: nothing to do - - | is_stable_obj, isNothing old_hmi -> do - linkable <- liftIO $ findObjectLinkable this_mod obj_fn - (expectJust "upsweep1" 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 - let Just hmi = old_hmi in - return 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 <- liftIO $ 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,_,_) <- 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] - -> 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 be cyclic - -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] - -> (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 -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 :: GhcMonad m => DynFlags -> [SCC ModSummary] -> m () -warnUnnecessarySourceImports dflags sccs = - liftIO $ printBagOfWarnings dflags (listToBag (concatMap (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 :: GhcMonad m => - 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 - -> m [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 - = do -- catch error messages and return them - --handleErrMsg -- should be covered by GhcMonad now - -- (\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 summs - where - roots = hsc_targets hsc_env - - old_summary_map :: NodeMap ModSummary - old_summary_map = mkNodeMap old_summaries - - getRootSummary :: GhcMonad m => Target -> m ModSummary - getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) - = do --- liftIO $ putStrLn "getRootSummary for TargetFile" - exists <- liftIO $ doesFileExist file - if exists - then summariseFile hsc_env old_summaries file mb_phase - obj_allowed maybe_buf - else throwOneError $ mkPlainErrMsg noSrcSpan $ - text "can't find file:" <+> text file - getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) - = do --- liftIO $ putStrLn "getRootSummary for TargetModule" - maybe_summary <- summariseModule hsc_env old_summary_map False - (L rootLoc modl) obj_allowed - maybe_buf excl_mods - case maybe_summary of - Nothing -> packageModErr modl - Just s -> return s - - rootLoc = mkGeneralSrcSpan (fsLit "") - - -- 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 :: GhcMonad m => NodeMap [ModSummary] -> m () - checkDuplicates root_map - | allow_dup_roots = return () - | null dup_roots = return () - | otherwise = liftIO $ multiRootsErr (head dup_roots) - where - dup_roots :: [[ModSummary]] -- Each at least of length 2 - dup_roots = filterOut isSingleton (nodeMapElts root_map) - - loop :: GhcMonad m => - [(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 - -> m [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 { liftIO $ multiRootsErr summs; return [] } - | 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) - -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 - :: GhcMonad m => - HscEnv - -> [ModSummary] -- old summaries - -> FilePath -- source file name - -> Maybe Phase -- start phase - -> Bool -- object code allowed? - -> Maybe (StringBuffer,ClockTime) - -> m ModSummary - -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. - | 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 -> liftIO $ 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 <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ getObjTimestamp location False - else return Nothing - 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 hsc_env file mb_phase maybe_buf - - (srcimps,the_imps, L _ mod_name) <- liftIO $ LskFileHandler.getImportsLsk dflags' buf hspp_fn file - - -- Make a ModLocation for this file - location <- liftIO $ 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 <- liftIO $ addHomeModuleToFinder hsc_env mod_name location - - src_timestamp <- case maybe_buf of - Just (_,t) -> return t - Nothing -> liftIO $ getModificationTime file - -- getMofificationTime may fail - - -- 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 liftIO $ modificationTimeIfExists (ml_obj_file location) - else return Nothing - - 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 - :: GhcMonad m => - HscEnv - -> 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 - -> m (Maybe ModSummary) -- Its new summary - -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 - - | 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 <- liftIO $ 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 -> liftIO $ 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 <- liftIO $ - 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. - 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. - liftIO $ uncacheModule hsc_env wanted_mod - found <- liftIO $ FL.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 - - err -> liftIO $ 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 <- liftIO $ 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 hsc_env src_fn Nothing maybe_buf - (srcimps, the_imps, L mod_loc mod_name) <- liftIO $ getImportsLsk dflags' buf hspp_fn src_fn - - when (mod_name /= wanted_mod) $ - throwOneError $ 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 <- liftIO $ - 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, - 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 :: GhcMonad m => - HscEnv - -> FilePath - -> Maybe Phase -- ^ Starting phase - -> Maybe (StringBuffer,ClockTime) - -> m (DynFlags, FilePath, StringBuffer) -preprocessFile hsc_env src_fn mb_phase Nothing - = do - (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) - buf <- liftIO $ hGetStringBuffer hspp_fn - return (dflags', hspp_fn, buf) - -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 dflags buf src_fn - -- - (dflags', leftovers, warns) - <- parseDynamicNoPackageFlags dflags local_opts - liftIO $ checkProcessArgsResult leftovers -- XXX: throws exceptions - liftIO $ handleFlagWarnings dflags' warns -- XXX: throws exceptions - - 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 - = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err - -noHsFileErr :: GhcMonad m => SrcSpan -> String -> m a -noHsFileErr loc path - = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path - -packageModErr :: GhcMonad m => ModuleName -> m a -packageModErr mod - = throwOneError $ mkPlainErrMsg noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> text "is a package module" - -multiRootsErr :: [ModSummary] -> IO () -multiRootsErr [] = panic "multiRootsErr" -multiRootsErr summs@(summ1:_) - = throwOneError $ 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 :: GhcMonad m => m () -workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) - --- ----------------------------------------------------------------------------- --- inspecting the session - --- | Get the module dependency graph. -getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary -getModuleGraph = liftM hsc_mod_graph getSession - --- | Return @True@ <==> module is loaded. -isLoaded :: GhcMonad m => ModuleName -> m Bool -isLoaded m = withSession $ \hsc_env -> - return $! isJust (lookupUFM (hsc_HPT hsc_env) m) - --- | Return the bindings for the current interactive session. -getBindings :: GhcMonad m => m [TyThing] -getBindings = withSession $ \hsc_env -> - -- we have to implement the shadowing behaviour of ic_tmp_ids here - -- (see InteractiveContext) and the quickest way is to use an OccEnv. - let - tmp_ids = ic_tmp_ids (hsc_IC hsc_env) - filtered = foldr f (const []) tmp_ids emptyUniqSet - f id rest set - | uniq `elementOfUniqSet` set = rest set - | otherwise = AnId id : rest (addOneToUniqSet set uniq) - where uniq = getUnique (nameOccName (idName id)) - in - return filtered - -getPrintUnqual :: GhcMonad m => m PrintUnqualified -getPrintUnqual = withSession $ \hsc_env -> - return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env)) - --- | Container for information about a 'Module'. -data ModuleInfo = ModuleInfo { - minf_type_env :: TypeEnv, - minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? - minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod - minf_instances :: [Instance] -#ifdef GHCI - ,minf_modBreaks :: ModBreaks -#endif - -- ToDo: this should really contain the ModIface too - } - -- We don't want HomeModInfo here, because a ModuleInfo applies - -- to package modules too. - --- | Request information about a loaded 'Module' -getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X -getModuleInfo mdl = withSession $ \hsc_env -> do - let mg = hsc_mod_graph hsc_env - if mdl `elem` map ms_mod mg - then liftIO $ getHomeModuleInfo hsc_env (moduleName mdl) - else do - {- if isHomeModule (hsc_dflags hsc_env) mdl - then return Nothing - else -} liftIO $ getPackageModuleInfo hsc_env mdl - -- getPackageModuleInfo will attempt to find the interface, so - -- we don't want to call it for a home module, just in case there - -- was a problem loading the module and the interface doesn't - -- exist... hence the isHomeModule test here. (ToDo: reinstate) - -getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -#ifdef GHCI -getPackageModuleInfo hsc_env mdl = do - (_msgs, mb_avails) <- getModuleExports hsc_env mdl - case mb_avails of - Nothing -> return Nothing - Just avails -> do - eps <- readIORef (hsc_EPS hsc_env) - let - names = availsToNameSet avails - pte = eps_PTE eps - tys = [ ty | name <- concatMap availNames avails, - Just ty <- [lookupTypeEnv pte name] ] - -- - return (Just (ModuleInfo { - minf_type_env = mkTypeEnv tys, - minf_exports = names, - minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl), - minf_instances = error "getModuleInfo: instances for package module unimplemented", - minf_modBreaks = emptyModBreaks - })) -#else -getPackageModuleInfo _hsc_env _mdl = do - -- bogusly different for non-GHCI (ToDo) - return Nothing -#endif - -getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo) -getHomeModuleInfo hsc_env mdl = - case lookupUFM (hsc_HPT hsc_env) mdl of - Nothing -> return Nothing - Just hmi -> do - let details = hm_details hmi - return (Just (ModuleInfo { - minf_type_env = md_types details, - minf_exports = availsToNameSet (md_exports details), - minf_rdr_env = mi_globals $! hm_iface hmi, - minf_instances = md_insts details -#ifdef GHCI - ,minf_modBreaks = getModBreaks hmi -#endif - })) - --- | The list of top-level entities defined in a module -modInfoTyThings :: ModuleInfo -> [TyThing] -modInfoTyThings minf = typeEnvElts (minf_type_env minf) - -modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] -modInfoTopLevelScope minf - = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf) - -modInfoExports :: ModuleInfo -> [Name] -modInfoExports minf = nameSetToList $! minf_exports minf - --- | Returns the instances defined by the specified module. --- Warning: currently unimplemented for package modules. -modInfoInstances :: ModuleInfo -> [Instance] -modInfoInstances = minf_instances - -modInfoIsExportedName :: ModuleInfo -> Name -> Bool -modInfoIsExportedName minf name = elemNameSet name (minf_exports minf) - -mkPrintUnqualifiedForModule :: GhcMonad m => - ModuleInfo - -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X -mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do - return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf)) - -modInfoLookupName :: GhcMonad m => - ModuleInfo -> Name - -> m (Maybe TyThing) -- XXX: returns a Maybe X -modInfoLookupName minf name = withSession $ \hsc_env -> do - case lookupTypeEnv (minf_type_env minf) name of - Just tyThing -> return (Just tyThing) - Nothing -> do - eps <- liftIO $ readIORef (hsc_EPS hsc_env) - return $! lookupType (hsc_dflags hsc_env) - (hsc_HPT hsc_env) (eps_PTE eps) name - -#ifdef GHCI -modInfoModBreaks :: ModuleInfo -> ModBreaks -modInfoModBreaks = minf_modBreaks -#endif - -isDictonaryId :: Id -> Bool -isDictonaryId id - = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau } - --- | Looks up a global name: that is, any top-level name in any --- visible module. Unlike 'lookupName', lookupGlobalName does not use --- the interactive context, and therefore does not require a preceding --- 'setContext'. -lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing) -lookupGlobalName name = withSession $ \hsc_env -> do - eps <- liftIO $ readIORef (hsc_EPS hsc_env) - return $! lookupType (hsc_dflags hsc_env) - (hsc_HPT hsc_env) (eps_PTE eps) name - -#ifdef GHCI --- | get the GlobalRdrEnv for a session -getGRE :: GhcMonad m => m GlobalRdrEnv -getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) -#endif - --- ----------------------------------------------------------------------------- --- Misc exported utils - -dataConType :: DataCon -> Type -dataConType dc = idType (dataConWrapId dc) - --- | print a 'NamedThing', adding parentheses if the name is an operator. -pprParenSymName :: NamedThing a => a -> SDoc -pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) - --- ---------------------------------------------------------------------------- - -#if 0 - --- ToDo: --- - Data and Typeable instances for HsSyn. - --- ToDo: check for small transformations that happen to the syntax in --- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral) - --- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way --- to get from TyCons, Ids etc. to TH syntax (reify). - --- :browse will use either lm_toplev or inspect lm_interface, depending --- on whether the module is interpreted or not. - -#endif - --- Extract the filename, stringbuffer content and dynflags associed to a module --- --- XXX: Explain pre-conditions -getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags) -getModuleSourceAndFlags mod = do - m <- getModSummary (moduleName mod) - case ml_hs_file $ ms_location m of - Nothing -> throw $ mkApiErr (text "No source available for module " <+> ppr mod) - Just sourceFile -> do - source <- liftIO $ hGetStringBuffer sourceFile - return (sourceFile, source, ms_hspp_opts m) - - --- | Return module source as token stream, including comments. --- --- The module must be in the module graph and its source must be available. --- Throws a 'HscTypes.SourceError' on parse error. -getTokenStream :: GhcMonad m => Module -> m [Located Token] -getTokenStream mod = do - (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0 - case lexTokenStream source startLoc flags of - POk _ ts -> return ts - PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) - --- | Give even more information on the source than 'getTokenStream' --- This function allows reconstructing the source completely with --- 'showRichTokenStream'. -getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] -getRichTokenStream mod = do - (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0 - case lexTokenStream source startLoc flags of - POk _ ts -> return $ addSourceToTokens startLoc source ts - PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) - --- | Given a source location and a StringBuffer corresponding to this --- location, return a rich token stream with the source associated to the --- tokens. -addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token] - -> [(Located Token, String)] -addSourceToTokens _ _ [] = [] -addSourceToTokens loc buf (t@(L span _) : ts) - | not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts - | otherwise = (t,str) : addSourceToTokens newLoc newBuf ts - where - (newLoc, newBuf, str) = go "" loc buf - start = srcSpanStart span - end = srcSpanEnd span - go acc loc buf | loc < start = go acc nLoc nBuf - | start <= loc && loc < end = go (ch:acc) nLoc nBuf - | otherwise = (loc, buf, reverse acc) - where (ch, nBuf) = nextChar buf - nLoc = advanceSrcLoc loc ch - - --- | Take a rich token stream such as produced from 'getRichTokenStream' and --- return source code almost identical to the original code (except for --- insignificant whitespace.) -showRichTokenStream :: [(Located Token, String)] -> String -showRichTokenStream ts = go startLoc ts "" - where sourceFile = srcSpanFile (getLoc . fst . head $ ts) - startLoc = mkSrcLoc sourceFile 0 0 - go _ [] = id - go loc ((L span _, str):ts) - | not (isGoodSrcSpan span) = go loc ts - | locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++) - . (str ++) - . go tokEnd ts - | otherwise = ((replicate (tokLine - locLine) '\n') ++) - . ((replicate tokCol ' ') ++) - . (str ++) - . go tokEnd ts - where (locLine, locCol) = (srcLocLine loc, srcLocCol loc) - (tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span) - tokEnd = srcSpanEnd span - --- ----------------------------------------------------------------------------- --- Interactive evaluation - --- | 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 :: GhcMonad m => ModuleName -> Maybe FastString -> m Module -findModule mod_name maybe_pkg = withSession $ \hsc_env -> liftIO $ -- XXX - let - dflags = hsc_dflags hsc_env - hpt = hsc_HPT hsc_env - this_pkg = thisPackage dflags - in - case lookupUFM hpt mod_name of - Just mod_info -> return (mi_module (hm_iface mod_info)) - _not_a_home_module -> do - res <- findImportedModule hsc_env mod_name maybe_pkg - case res of - Found _ m | modulePackageId m /= this_pkg -> return m - | otherwise -> ghcError (CmdLineError (showSDoc $ - text "module" <+> quotes (ppr (moduleName m)) <+> - text "is not loaded. QUAK!")) - err -> let msg = cannotFindModule dflags mod_name err in - ghcError (CmdLineError (showSDoc msg)) - -#ifdef GHCI -getHistorySpan :: GhcMonad m => History -> m SrcSpan -getHistorySpan h = withSession $ \hsc_env -> - return$ InteractiveEval.getHistorySpan hsc_env h - -obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term -obtainTermFromVal bound force ty a = - withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a - -obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term -obtainTermFromId bound force id = - withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id - -#endif - -compileHsExpr -- Compile a stmt all the way to an HValue, but don't run it - :: GhcMonad m => - HscEnv - -> LHsExpr RdrName -- The statement - -> TcM Type - -> m (Maybe HValue) - -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error -compileHsExpr hsc_env rdr_expr get_expr_type = do - let ictxt = hsc_IC hsc_env - (msg,maybe_tc_expr) <- liftIO $ - initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext' hsc_env ictxt $ do { - (rn_expr, fvs) <- rnLExpr rdr_expr ; - failIfErrsM ; - expr_type <- get_expr_type; - (tc_expr, lie) <- getLIE $ tcMonoExpr rn_expr expr_type; - const_binds <- tcSimplifyTop lie; - tc_expr' <- zonkTopLExpr (mkHsDictLet const_binds tc_expr); - return tc_expr'; - } - liftIO $ printErrorsAndWarnings (hsc_dflags hsc_env) msg - case maybe_tc_expr of - Nothing -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg noSrcSpan (text "Type checking failed")) - (Just tc_expr) -> do - let rdr_env = ic_rn_gbl_env ictxt - type_env = mkTypeEnv (map AnId (ic_tmp_ids ictxt)) - ds_expr <- ioMsgMaybe $ - deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr - let src_span = srcLocSpan interactiveSrcLoc --- liftIO $ Linker.initDynLinker (hsc_dflags hsc_env) --- liftIO $ Linker.showLinkerState - hval <- liftIO $ HscMain.compileExpr hsc_env src_span ds_expr --- liftIO $ Linker.showLinkerState - return $ Just hval - where - smpl_doc = ptext (sLit "main expression") - rmfile ./GHC4Lsk.hs hunk ./GHC4Lsk.hs-boot 1 -module GHC4Lsk (ParsedMod,loadModule,typecheckModule,runGhc,setSessionDynFlags,getSessionDynFlags,findModule,ParsedModule(..),compileHsExpr,setTargets,LoadHowMuch(..),load,unload) where -import GhciMonad -import HscTypes -import Module -import FastString -import DynFlags -import SrcLoc -import HsSyn -import RdrName -import TcRnTypes hiding (LIE) -import Name -import Var -import ByteCodeLink -import BasicTypes -import TypeRep - -findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module - -getSessionDynFlags :: GhcMonad m => m DynFlags - -setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId] - -runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. - -> Ghc a -- ^ The action to perform. - -> IO a - -loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod - -typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule - -class ParsedMod m => TypecheckedMod m where - renamedSource :: m -> Maybe RenamedSource - typecheckedSource :: m -> TypecheckedSource - moduleInfo :: m -> ModuleInfo - tm_internals :: m -> (TcGblEnv, ModDetails) - -- ToDo: improvements that could be made here: - -- if the module succeeded renaming but not typechecking, - -- we can still get back the GlobalRdrEnv and exports, so - -- perhaps the ModuleInfo should be split up into separate - -- fields. - -class ParsedMod m where - -data TypecheckedModule -type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], - Maybe (HsDoc Name), HaddockModInfo Name) -type TypecheckedSource = LHsBinds Id - -data ParsedModule = - ParsedModule { pm_mod_summary :: ModSummary - , pm_parsed_source :: ParsedSource } -type ParsedSource = Located (HsModule RdrName) - - -instance TypecheckedMod TypecheckedModule where - -data ModuleInfo - -compileHsExpr -- Compile a stmt all the way to an HValue, but don't run it - :: GhcMonad m => - HscEnv - -> LHsExpr RdrName -- The statement - -> TcM Type - -> m (Maybe HValue) - -setTargets :: GhcMonad m => [Target] -> m () - -data LoadHowMuch - = LoadAllTargets - | LoadUpTo ModuleName - | LoadDependenciesOf ModuleName - -load :: GhcMonad m => LoadHowMuch -> m SuccessFlag - -unload :: HscEnv -> [Linkable] -> IO () rmfile ./GHC4Lsk.hs-boot adddir ./GHCSalat addfile ./GHCSalat/DriverPipeline4Lsk.hs hunk ./GHCSalat/DriverPipeline4Lsk.hs 1 +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +----------------------------------------------------------------------------- +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- +module GHCSalat.DriverPipeline4Lsk ( + -- Run a series of compilation steps in a pipeline, for a + -- collection of source files. + oneShot, compileFile, + + -- Interfaces for the batch-mode driver + linkBinary, + + -- Interfaces for the compilation manager (interpreted/batch-mode) + preprocess, + compile, + link, + + ) where + +#include "HsVersions4Lsk.h" + +import Packages +import HeaderInfo +import DriverPhases +import SysTools +import HscMain +import qualified GHCSalat.HscMain4Lsk as HML +import Finder +import HscTypes +import Outputable +import Module +import LazyUniqFM ( eltsUFM ) +import ErrUtils +import DynFlags +import StaticFlags ( v_Ld_inputs, opt_Static, WayName(..) ) +import Config +import Panic +import Util +import StringBuffer ( hGetStringBuffer ) +import BasicTypes ( SuccessFlag(..) ) +import Maybes ( expectJust ) +import ParserCoreUtils ( getCoreModuleName ) +import SrcLoc +import FastString +import MonadUtils + +import Data.Either +import Exception +import Data.IORef ( readIORef, writeIORef, IORef ) +import GHC.Exts ( Int(..) ) +import System.Directory +import System.FilePath +import System.IO +import System.IO.Error as IO +import Control.Monad +import Data.List ( isSuffixOf ) +import Data.Maybe +import System.Environment +import LskFileHandler + +-- --------------------------------------------------------------------------- +-- Pre-process + +-- | Just preprocess a file, put the result in a temp. file (used by the +-- compilation manager during the summary phase). +-- +-- We return the augmented DynFlags, because they contain the result +-- of slurping in the OPTIONS pragmas + +preprocess :: GhcMonad m => + HscEnv + -> (FilePath, Maybe Phase) -- ^ filename and starting phase + -> m (DynFlags, FilePath) +preprocess hsc_env (filename, mb_phase) = +#warning FIXME: preprocess liskell files? + if isLiskellSrcFilename filename then return (hsc_dflags hsc_env, filename) + else + ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) + do + runPipeline anyHsc hsc_env (filename, mb_phase) + Nothing Temporary Nothing{-no ModLocation-} + +-- --------------------------------------------------------------------------- + +-- | Compile +-- +-- Compile a single module, under the control of the compilation manager. +-- +-- This is the interface between the compilation manager and the +-- compiler proper (hsc), where we deal with tedious details like +-- reading the OPTIONS pragma from the source file, and passing the +-- output of hsc through the C compiler. +-- +-- NB. No old interface can also mean that the source has changed. + +compile :: GhcMonad m => + HscEnv + -> ModSummary -- ^ summary for module being compiled + -> Int -- ^ module N ... + -> Int -- ^ ... of M + -> Maybe ModIface -- ^ old interface, if we have one + -> Maybe Linkable -- ^ old linkable, if we have one + -> m HomeModInfo -- ^ the complete HomeModInfo, if successful + +compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable + = do + let dflags0 = ms_hspp_opts summary + this_mod = ms_mod summary + src_flavour = ms_hsc_src summary + location = ms_location summary + input_fn = expectJust "compile:hs" (ml_hs_file location) + input_fnpp = ms_hspp_file summary + + liftIO $ debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp) + + let basename = dropExtension input_fn + + -- We add the directory in which the .hs files resides) to the import path. + -- This is needed when we try to compile the .hc file later, if it + -- imports a _stub.h file that we created here. + let current_dir = case takeDirectory basename of + "" -> "." -- XXX Hack + d -> d + old_paths = includePaths dflags0 + dflags = dflags0 { includePaths = current_dir : old_paths } + hsc_env = hsc_env0 {hsc_dflags = dflags} + + -- Figure out what lang we're generating + let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags) + -- ... and what the next phase should be + let next_phase = hscNextPhase dflags src_flavour hsc_lang + -- ... and what file to generate the output into + output_fn <- liftIO $ getOutputFilename next_phase + Temporary basename dflags next_phase (Just location) + + let dflags' = dflags { hscTarget = hsc_lang, + hscOutName = output_fn, + extCoreName = basename ++ ".hcr" } + let hsc_env' = hsc_env { hsc_dflags = dflags' } + + -- -fforce-recomp should also work with --make + let force_recomp = dopt Opt_ForceRecomp dflags + source_unchanged = isJust maybe_old_linkable && not force_recomp + object_filename = ml_obj_file location + + let getStubLinkable False = return [] + getStubLinkable True + = do stub_o <- compileStub hsc_env' this_mod location + return [ DotO stub_o ] + + handleBatch HML.HscNoRecomp + = ASSERT (isJust maybe_old_linkable) + return maybe_old_linkable + + handleBatch (HML.HscRecomp hasStub) + | isHsBoot src_flavour + = do when (isObjectTarget hsc_lang) $ -- interpreted reaches here too + liftIO $ SysTools.touch dflags' "Touching object file" + object_filename + return maybe_old_linkable + + | otherwise + = do stub_unlinked <- getStubLinkable hasStub + (hs_unlinked, unlinked_time) <- + case hsc_lang of + HscNothing + -> return ([], ms_hs_date summary) + -- We're in --make mode: finish the compilation pipeline. + _other + -> do runPipeline StopLn hsc_env' (output_fn,Nothing) + (Just basename) + Persistent + (Just location) + -- The object filename comes from the ModLocation + o_time <- liftIO $ getModificationTime object_filename + return ([DotO object_filename], o_time) + let linkable = LM unlinked_time this_mod + (hs_unlinked ++ stub_unlinked) + return (Just linkable) + + handleInterpreted HML.InteractiveNoRecomp + = ASSERT (isJust maybe_old_linkable) + return maybe_old_linkable + handleInterpreted (HML.InteractiveRecomp hasStub comp_bc modBreaks) + = do stub_unlinked <- getStubLinkable hasStub + let hs_unlinked = [BCOs comp_bc modBreaks] + unlinked_time = ms_hs_date summary + -- Why do we use the timestamp of the source file here, + -- rather than the current time? This works better in + -- the case where the local clock is out of sync + -- with the filesystem's clock. It's just as accurate: + -- if the source is modified, then the linkable will + -- be out of date. + let linkable = LM unlinked_time this_mod + (hs_unlinked ++ stub_unlinked) + return (Just linkable) + + let -- runCompiler :: Compiler result -> (result -> Maybe Linkable) + -- -> m HomeModInfo + runCompiler compiler handle + = do (result, iface, details) + <- compiler hsc_env' summary source_unchanged mb_old_iface + (Just (mod_index, nmods)) + linkable <- handle result + return (HomeModInfo{ hm_details = details, + hm_iface = iface, + hm_linkable = linkable }) + -- run the compiler + case hsc_lang of + HscInterpreted + | isHsBoot src_flavour -> + runCompiler HML.hscCompileNothing handleBatch + | otherwise -> + runCompiler HML.hscCompileInteractive handleInterpreted + HscNothing -> + runCompiler HML.hscCompileNothing handleBatch + _other -> + runCompiler HML.hscCompileBatch handleBatch + +----------------------------------------------------------------------------- +-- stub .h and .c files (for foreign export support) + +-- The _stub.c file is derived from the haskell source file, possibly taking +-- into account the -stubdir option. +-- +-- Consequently, we derive the _stub.o filename from the haskell object +-- filename. +-- +-- This isn't necessarily the same as the object filename we +-- would get if we just compiled the _stub.c file using the pipeline. +-- For example: +-- +-- ghc src/A.hs -odir obj +-- +-- results in obj/A.o, and src/A_stub.c. If we compile src/A_stub.c with +-- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want +-- obj/A_stub.o. + +compileStub :: GhcMonad m => HscEnv -> Module -> ModLocation + -> m FilePath +compileStub hsc_env mod location = do + let (o_base, o_ext) = splitExtension (ml_obj_file location) + stub_o = (o_base ++ "_stub") <.> o_ext + + -- compile the _stub.c file w/ gcc + let (stub_c,_,_) = mkStubPaths (hsc_dflags hsc_env) (moduleName mod) location + runPipeline StopLn hsc_env (stub_c,Nothing) Nothing + (SpecificFile stub_o) Nothing{-no ModLocation-} + + return stub_o + + +-- --------------------------------------------------------------------------- +-- Link + +link :: GhcLink -- interactive or batch + -> DynFlags -- dynamic flags + -> Bool -- attempt linking in batch mode? + -> HomePackageTable -- what to link + -> IO SuccessFlag + +-- For the moment, in the batch linker, we don't bother to tell doLink +-- which packages to link -- it just tries all that are available. +-- batch_attempt_linking should only be *looked at* in batch mode. It +-- should only be True if the upsweep was successful and someone +-- exports main, i.e., we have good reason to believe that linking +-- will succeed. + +#ifdef GHCI +link LinkInMemory _ _ _ + = do -- Not Linking...(demand linker will do the job) + return Succeeded +#endif + +link NoLink _ _ _ + = return Succeeded + +link LinkBinary dflags batch_attempt_linking hpt + | batch_attempt_linking + = do + let + home_mod_infos = eltsUFM hpt + + -- the packages we depend on + pkg_deps = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos + + -- the linkables to link + linkables = map (expectJust "link".hm_linkable) home_mod_infos + + debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) + + -- check for the -no-link flag + if isNoLink (ghcLink dflags) + then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).") + return Succeeded + else do + + let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) + obj_files = concatMap getOfiles linkables + + exe_file = exeFileName dflags + + linking_needed <- linkingNeeded dflags linkables pkg_deps + + if not (dopt Opt_ForceRecomp dflags) && not linking_needed + then do debugTraceMsg dflags 2 (text exe_file <+> ptext (sLit "is up to date, linking not required.")) + return Succeeded + else do + + debugTraceMsg dflags 1 (ptext (sLit "Linking") <+> text exe_file + <+> text "...") + + -- Don't showPass in Batch mode; doLink will do that for us. + let link = case ghcLink dflags of + LinkBinary -> linkBinary + LinkDynLib -> linkDynLib + other -> panicBadLink other + link dflags obj_files pkg_deps + + debugTraceMsg dflags 3 (text "link: done") + + -- linkBinary only returns if it succeeds + return Succeeded + + | otherwise + = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$ + text " Main.main not exported; not linking.") + return Succeeded + +-- warning suppression +link other _ _ _ = panicBadLink other + +panicBadLink :: GhcLink -> a +panicBadLink other = panic ("link: GHC not built to link this way: " ++ + show other) + + +linkingNeeded :: DynFlags -> [Linkable] -> [PackageId] -> IO Bool +linkingNeeded dflags linkables pkg_deps = do + -- if the modification time on the executable is later than the + -- modification times on all of the objects and libraries, then omit + -- linking (unless the -fforce-recomp flag was given). + let exe_file = exeFileName dflags + e_exe_time <- IO.try $ getModificationTime exe_file + case e_exe_time of + Left _ -> return True + Right t -> do + -- first check object files and extra_ld_inputs + extra_ld_inputs <- readIORef v_Ld_inputs + e_extra_times <- mapM (IO.try . getModificationTime) extra_ld_inputs + let (errs,extra_times) = splitEithers e_extra_times + let obj_times = map linkableTime linkables ++ extra_times + if not (null errs) || any (t <) obj_times + then return True + else do + + -- next, check libraries. XXX this only checks Haskell libraries, + -- not extra_libraries or -l things from the command line. + let pkg_map = pkgIdMap (pkgState dflags) + pkg_hslibs = [ (libraryDirs c, lib) + | Just c <- map (lookupPackage pkg_map) pkg_deps, + lib <- packageHsLibs dflags c ] + + pkg_libfiles <- mapM (uncurry findHSLib) pkg_hslibs + if any isNothing pkg_libfiles then return True else do + e_lib_times <- mapM (IO.try . getModificationTime) + (catMaybes pkg_libfiles) + let (lib_errs,lib_times) = splitEithers e_lib_times + if not (null lib_errs) || any (t <) lib_times + then return True + else return False + +findHSLib :: [String] -> String -> IO (Maybe FilePath) +findHSLib dirs lib = do + let batch_lib_file = "lib" ++ lib <.> "a" + found <- filterM doesFileExist (map ( batch_lib_file) dirs) + case found of + [] -> return Nothing + (x:_) -> return (Just x) + +-- ----------------------------------------------------------------------------- +-- Compile files in one-shot mode. + +oneShot :: GhcMonad m => + HscEnv -> Phase -> [(String, Maybe Phase)] -> m () +oneShot hsc_env stop_phase srcs = do + o_files <- mapM (compileFile hsc_env stop_phase) srcs + liftIO $ doLink (hsc_dflags hsc_env) stop_phase o_files + +compileFile :: GhcMonad m => + HscEnv -> Phase -> (FilePath, Maybe Phase) -> m FilePath +compileFile hsc_env stop_phase (src, mb_phase) = do + exists <- liftIO $ doesFileExist src + when (not exists) $ + ghcError (CmdLineError ("does not exist: " ++ src)) + + let + dflags = hsc_dflags hsc_env + split = dopt Opt_SplitObjs dflags + mb_o_file = outputFile dflags + ghc_link = ghcLink dflags -- Set by -c or -no-link + + -- When linking, the -o argument refers to the linker's output. + -- otherwise, we use it as the name for the pipeline's output. + output + | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent + -- -o foo applies to linker + | Just o_file <- mb_o_file = SpecificFile o_file + -- -o foo applies to the file we are compiling now + | otherwise = Persistent + + stop_phase' = case stop_phase of + As | split -> SplitAs + _ -> stop_phase + + ( _, out_file) <- runPipeline stop_phase' hsc_env + (src, mb_phase) Nothing output + Nothing{-no ModLocation-} + return out_file + + +doLink :: DynFlags -> Phase -> [FilePath] -> IO () +doLink dflags stop_phase o_files + | not (isStopLn stop_phase) + = return () -- We stopped before the linking phase + + | otherwise + = case ghcLink dflags of + NoLink -> return () + LinkBinary -> linkBinary dflags o_files link_pkgs + LinkDynLib -> linkDynLib dflags o_files [] + other -> panicBadLink other + where + -- Always link in the haskell98 package for static linking. Other + -- packages have to be specified via the -package flag. + link_pkgs + | dopt Opt_AutoLinkPackages dflags = [haskell98PackageId] + | otherwise = [] + + +-- --------------------------------------------------------------------------- + +data PipelineOutput + = Temporary + -- ^ Output should be to a temporary file: we're going to + -- run more compilation steps on this output later. + | Persistent + -- ^ We want a persistent file, i.e. a file in the current directory + -- derived from the input filename, but with the appropriate extension. + -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o. + | SpecificFile FilePath + -- ^ The output must go into the specified file. + +-- | Run a compilation pipeline, consisting of multiple phases. +-- +-- This is the interface to the compilation pipeline, which runs +-- a series of compilation steps on a single source file, specifying +-- at which stage to stop. +-- +-- The DynFlags can be modified by phases in the pipeline (eg. by +-- GHC_OPTIONS pragmas), and the changes affect later phases in the +-- pipeline. +runPipeline + :: GhcMonad m => + Phase -- ^ When to stop + -> HscEnv -- ^ Compilation environment + -> (FilePath,Maybe Phase) -- ^ Input filename (and maybe -x suffix) + -> Maybe FilePath -- ^ original basename (if different from ^^^) + -> PipelineOutput -- ^ Output filename + -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module + -> m (DynFlags, FilePath) -- ^ (final flags, output filename) + +runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc + = do + let dflags0 = hsc_dflags hsc_env0 + (input_basename, suffix) = splitExtension input_fn + suffix' = drop 1 suffix -- strip off the . + basename | Just b <- mb_basename = b + | otherwise = input_basename + + -- Decide where dump files should go based on the pipeline output + dflags = dflags0 { dumpPrefix = Just (basename ++ ".") } + hsc_env = hsc_env0 {hsc_dflags = dflags} + + -- If we were given a -x flag, then use that phase to start from + start_phase = fromMaybe (startPhase suffix') mb_phase + + -- We want to catch cases of "you can't get there from here" before + -- we start the pipeline, because otherwise it will just run off the + -- end. + -- + -- There is a partial ordering on phases, where A < B iff A occurs + -- before B in a normal compilation pipeline. + + when (not (start_phase `happensBefore` stop_phase)) $ + ghcError (UsageError + ("cannot compile this file to desired target: " + ++ input_fn)) + + -- this is a function which will be used to calculate output file names + -- as we go along (we partially apply it to some of its inputs here) + let get_output_fn = getOutputFilename stop_phase output basename + + -- Execute the pipeline... + (dflags', output_fn, maybe_loc) <- + pipeLoop hsc_env start_phase stop_phase input_fn + basename suffix' get_output_fn maybe_loc + + -- Sometimes, a compilation phase doesn't actually generate any output + -- (eg. the CPP phase when -fcpp is not turned on). If we end on this + -- stage, but we wanted to keep the output, then we have to explicitly + -- copy the file, remembering to prepend a {-# LINE #-} pragma so that + -- further compilation stages can tell what the original filename was. + case output of + Temporary -> + return (dflags', output_fn) + _other -> liftIO $ + do final_fn <- get_output_fn dflags' stop_phase maybe_loc + when (final_fn /= output_fn) $ do + let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'") + line_prag = Just ("{-# LINE 1 \"" ++ input_fn ++ "\" #-}\n") + copyWithHeader dflags msg line_prag output_fn final_fn + return (dflags', final_fn) + + + +pipeLoop :: GhcMonad m => + HscEnv -> Phase -> Phase + -> FilePath -> String -> Suffix + -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath) + -> Maybe ModLocation + -> m (DynFlags, FilePath, Maybe ModLocation) + +pipeLoop hsc_env phase stop_phase + input_fn orig_basename orig_suff + orig_get_output_fn maybe_loc + + | phase `eqPhase` stop_phase -- All done + = return (hsc_dflags hsc_env, input_fn, maybe_loc) + + | not (phase `happensBefore` stop_phase) + -- Something has gone wrong. We'll try to cover all the cases when + -- this could happen, so if we reach here it is a panic. + -- eg. it might happen if the -C flag is used on a source file that + -- has {-# OPTIONS -fasm #-}. + = panic ("pipeLoop: at phase " ++ show phase ++ + " but I wanted to stop at phase " ++ show stop_phase) + + | otherwise + = do (next_phase, dflags', maybe_loc, output_fn) + <- runPhase phase stop_phase hsc_env orig_basename + orig_suff input_fn orig_get_output_fn maybe_loc + let hsc_env' = hsc_env {hsc_dflags = dflags'} + pipeLoop hsc_env' next_phase stop_phase output_fn + orig_basename orig_suff orig_get_output_fn maybe_loc + +getOutputFilename + :: Phase -> PipelineOutput -> String + -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath +getOutputFilename stop_phase output basename + = func + where + func dflags next_phase maybe_location + | is_last_phase, Persistent <- output = persistent_fn + | is_last_phase, SpecificFile f <- output = return f + | keep_this_output = persistent_fn + | otherwise = newTempName dflags suffix + where + hcsuf = hcSuf dflags + odir = objectDir dflags + osuf = objectSuf dflags + keep_hc = dopt Opt_KeepHcFiles dflags + keep_raw_s = dopt Opt_KeepRawSFiles dflags + keep_s = dopt Opt_KeepSFiles dflags + + myPhaseInputExt HCc = hcsuf + myPhaseInputExt StopLn = osuf + myPhaseInputExt other = phaseInputExt other + + is_last_phase = next_phase `eqPhase` stop_phase + + -- sometimes, we keep output from intermediate stages + keep_this_output = + case next_phase of + StopLn -> True + Mangle | keep_raw_s -> True + As | keep_s -> True + HCc | keep_hc -> True + _other -> False + + suffix = myPhaseInputExt next_phase + + -- persistent object files get put in odir + persistent_fn + | StopLn <- next_phase = return odir_persistent + | otherwise = return persistent + + persistent = basename <.> suffix + + odir_persistent + | Just loc <- maybe_location = ml_obj_file loc + | Just d <- odir = d persistent + | otherwise = persistent + + +-- ----------------------------------------------------------------------------- +-- | Each phase in the pipeline returns the next phase to execute, and the +-- name of the file in which the output was placed. +-- +-- We must do things dynamically this way, because we often don't know +-- what the rest of the phases will be until part-way through the +-- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning +-- of a source file can change the latter stages of the pipeline from +-- taking the via-C route to using the native code generator. +-- +runPhase :: GhcMonad m => + Phase -- ^ Do this phase first + -> Phase -- ^ Stop just before this phase + -> HscEnv + -> String -- ^ basename of original input source + -> String -- ^ its extension + -> FilePath -- ^ name of file which contains the input to this phase. + -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath) + -- ^ how to calculate the output filename + -> Maybe ModLocation -- ^ the ModLocation, if we have one + -> m (Phase, -- next phase + DynFlags, -- new dynamic flags + Maybe ModLocation, -- the ModLocation, if we have one + FilePath) -- output filename + + -- Invariant: the output filename always contains the output + -- Interesting case: Hsc when there is no recompilation to do + -- Then the output filename is still a .o file + +------------------------------------------------------------------------------- +-- Unlit phase + +runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc + = do + let dflags = hsc_dflags hsc_env + output_fn <- liftIO $ get_output_fn dflags (Cpp sf) maybe_loc + + let unlit_flags = getOpts dflags opt_L + flags = map SysTools.Option unlit_flags ++ + [ -- The -h option passes the file name for unlit to + -- put in a #line directive + SysTools.Option "-h" + -- cpp interprets \b etc as escape sequences, + -- so we use / for filenames in pragmas + , SysTools.Option $ reslash Forwards $ normalise input_fn + , SysTools.FileOption "" input_fn + , SysTools.FileOption "" output_fn + ] + + liftIO $ SysTools.runUnlit dflags flags + + return (Cpp sf, dflags, maybe_loc, output_fn) + +------------------------------------------------------------------------------- +-- Cpp phase : (a) gets OPTIONS out of file +-- (b) runs cpp if necessary + +runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc + = do let dflags0 = hsc_dflags hsc_env + src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn + (dflags, unhandled_flags, warns) + <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts + liftIO $ handleFlagWarnings dflags warns -- XXX: may exit the program + liftIO $ checkProcessArgsResult unhandled_flags -- XXX: may throw program error + + if not (dopt Opt_Cpp dflags) then + -- no need to preprocess CPP, just pass input file along + -- to the next phase of the pipeline. + return (HsPp sf, dflags, maybe_loc, input_fn) + else do + output_fn <- liftIO $ get_output_fn dflags (HsPp sf) maybe_loc + liftIO $ doCpp dflags True{-raw-} False{-no CC opts-} input_fn output_fn + return (HsPp sf, dflags, maybe_loc, output_fn) + +------------------------------------------------------------------------------- +-- HsPp phase + +runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc + = do let dflags = hsc_dflags hsc_env + if not (dopt Opt_Pp dflags) then + -- no need to preprocess, just pass input file along + -- to the next phase of the pipeline. + return (Hsc sf, dflags, maybe_loc, input_fn) + else do + let hspp_opts = getOpts dflags opt_F + let orig_fn = basename <.> suff + output_fn <- liftIO $ get_output_fn dflags (Hsc sf) maybe_loc + liftIO $ SysTools.runPp dflags + ( [ SysTools.Option orig_fn + , SysTools.Option input_fn + , SysTools.FileOption "" output_fn + ] ++ + map SysTools.Option hspp_opts + ) + return (Hsc sf, dflags, maybe_loc, output_fn) + +----------------------------------------------------------------------------- +-- Hsc phase + +-- Compilation of a single module, in "legacy" mode (_not_ under +-- the direction of the compilation manager). +runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _maybe_loc + = do -- normal Hsc mode, not mkdependHS + let dflags0 = hsc_dflags hsc_env + + -- we add the current directory (i.e. the directory in which + -- the .hs files resides) to the include path, since this is + -- what gcc does, and it's probably what you want. + let current_dir = case takeDirectory basename of + "" -> "." -- XXX Hack + d -> d + + paths = includePaths dflags0 + dflags = dflags0 { includePaths = current_dir : paths } + + -- gather the imports and module name + (hspp_buf,mod_name,imps,src_imps) <- + case src_flavour of + ExtCoreFile -> do -- no explicit imports in ExtCore input. + m <- liftIO $ getCoreModuleName input_fn + return (Nothing, mkModuleName m, [], []) + + _ -> liftIO $ do + buf <- hGetStringBuffer input_fn + (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff) + return (Just buf, mod_name, imps, src_imps) + + -- Build a ModLocation to pass to hscMain. + -- The source filename is rather irrelevant by now, but it's used + -- by hscMain for messages. hscMain also needs + -- the .hi and .o filenames, and this is as good a way + -- as any to generate them, and better than most. (e.g. takes + -- into accout the -osuf flags) + location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff + + -- Boot-ify it if necessary + let location2 | isHsBoot src_flavour = addBootSuffixLocn location1 + | otherwise = location1 + + + -- Take -ohi into account if present + -- This can't be done in mkHomeModuleLocation because + -- it only applies to the module being compiles + let ohi = outputHi dflags + location3 | Just fn <- ohi = location2{ ml_hi_file = fn } + | otherwise = location2 + + -- Take -o into account if present + -- Very like -ohi, but we must *only* do this if we aren't linking + -- (If we're linking then the -o applies to the linked thing, not to + -- the object file for one module.) + -- Note the nasty duplication with the same computation in compileFile above + let expl_o_file = outputFile dflags + location4 | Just ofile <- expl_o_file + , isNoLink (ghcLink dflags) + = location3 { ml_obj_file = ofile } + | otherwise = location3 + + o_file = ml_obj_file location4 -- The real object file + + + -- Figure out if the source has changed, for recompilation avoidance. + -- + -- Setting source_unchanged to True means that M.o seems + -- to be up to date wrt M.hs; so no need to recompile unless imports have + -- changed (which the compiler itself figures out). + -- Setting source_unchanged to False tells the compiler that M.o is out of + -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. + src_timestamp <- liftIO $ getModificationTime (basename <.> suff) + + let force_recomp = dopt Opt_ForceRecomp dflags + source_unchanged <- + if force_recomp || not (isStopLn stop) + -- Set source_unchanged to False unconditionally if + -- (a) recompilation checker is off, or + -- (b) we aren't going all the way to .o file (e.g. ghc -S) + then return False + -- Otherwise look at file modification dates + else do o_file_exists <- liftIO $ doesFileExist o_file + if not o_file_exists + then return False -- Need to recompile + else do t2 <- liftIO $ getModificationTime o_file + if t2 > src_timestamp + then return True + else return False + + -- get the DynFlags + let hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags) + let next_phase = hscNextPhase dflags src_flavour hsc_lang + output_fn <- liftIO $ get_output_fn dflags next_phase (Just location4) + + let dflags' = dflags { hscTarget = hsc_lang, + hscOutName = output_fn, + extCoreName = basename ++ ".hcr" } + + let hsc_env' = hsc_env {hsc_dflags = dflags'} + + -- Tell the finder cache about this module + mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location4 + + -- Make the ModSummary to hand to hscMain + let + mod_summary = ModSummary { ms_mod = mod, + ms_hsc_src = src_flavour, + ms_hspp_file = input_fn, + ms_hspp_opts = dflags, + ms_hspp_buf = hspp_buf, + ms_location = location4, + ms_hs_date = src_timestamp, + ms_obj_date = Nothing, + ms_imps = imps, + ms_srcimps = src_imps } + + -- run the compiler! + result <- hscCompileOneShot hsc_env' + mod_summary source_unchanged + Nothing -- No iface + Nothing -- No "module i of n" progress info + + case result of + HscNoRecomp + -> do liftIO $ SysTools.touch dflags' "Touching object file" o_file + -- The .o file must have a later modification date + -- than the source file (else we wouldn't be in HscNoRecomp) + -- but we touch it anyway, to keep 'make' happy (we think). + return (StopLn, dflags', Just location4, o_file) + (HscRecomp hasStub) + -> do when hasStub $ + do stub_o <- compileStub hsc_env' mod location4 + liftIO $ consIORef v_Ld_inputs stub_o + -- In the case of hs-boot files, generate a dummy .o-boot + -- stamp file for the benefit of Make + when (isHsBoot src_flavour) $ + liftIO $ SysTools.touch dflags' "Touching object file" o_file + return (next_phase, dflags', Just location4, output_fn) + +----------------------------------------------------------------------------- +-- Cmm phase + +runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc + = do + let dflags = hsc_dflags hsc_env + output_fn <- liftIO $ get_output_fn dflags Cmm maybe_loc + liftIO $ doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn + return (Cmm, dflags, maybe_loc, output_fn) + +runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc + = do + let dflags = hsc_dflags hsc_env + let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags) + let next_phase = hscNextPhase dflags HsSrcFile hsc_lang + output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc + + let dflags' = dflags { hscTarget = hsc_lang, + hscOutName = output_fn, + extCoreName = basename ++ ".hcr" } + let hsc_env' = hsc_env {hsc_dflags = dflags'} + + hscCmmFile hsc_env' input_fn + + -- XXX: catch errors above and convert them into ghcError? Original + -- code was: + -- + --when (not ok) $ ghcError (PhaseFailed "cmm" (ExitFailure 1)) + + return (next_phase, dflags, maybe_loc, output_fn) + +----------------------------------------------------------------------------- +-- Cc phase + +-- we don't support preprocessing .c files (with -E) now. Doing so introduces +-- way too many hacks, and I can't say I've ever used it anyway. + +runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc + | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc + = do let dflags = hsc_dflags hsc_env + let cc_opts = getOpts dflags opt_c + hcc = cc_phase `eqPhase` HCc + + let cmdline_include_paths = includePaths dflags + + -- HC files have the dependent packages stamped into them + pkgs <- if hcc then liftIO (getHCFilePackages input_fn) else return [] + + -- add package include paths even if we're just compiling .c + -- files; this is the Value Add(TM) that using ghc instead of + -- gcc gives you :) + pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs + let include_paths = foldr (\ x xs -> "-I" : x : xs) [] + (cmdline_include_paths ++ pkg_include_dirs) + + let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags + gcc_extra_viac_flags <- liftIO $ getExtraViaCOpts dflags + let pic_c_flags = picCCOpts dflags + + let verb = getVerbFlag dflags + + -- cc-options are not passed when compiling .hc files. Our + -- hc code doesn't not #include any header files anyway, so these + -- options aren't necessary. + pkg_extra_cc_opts <- + if cc_phase `eqPhase` HCc + then return [] + else liftIO $ getPackageExtraCcOpts dflags pkgs + +#ifdef darwin_TARGET_OS + pkg_framework_paths <- liftIO $ getPackageFrameworkPath dflags pkgs + let cmdline_framework_paths = frameworkPaths dflags + let framework_paths = map ("-F"++) + (cmdline_framework_paths ++ pkg_framework_paths) +#endif + + let split_objs = dopt Opt_SplitObjs dflags + split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ] + | otherwise = [ ] + + let cc_opt | optLevel dflags >= 2 = "-O2" + | otherwise = "-O" + + -- Decide next phase + + let mangle = dopt Opt_DoAsmMangling dflags + next_phase + | hcc && mangle = Mangle + | otherwise = As + output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc + + let + more_hcc_opts = +#if i386_TARGET_ARCH + -- on x86 the floating point regs have greater precision + -- than a double, which leads to unpredictable results. + -- By default, we turn this off with -ffloat-store unless + -- the user specified -fexcess-precision. + (if dopt Opt_ExcessPrecision dflags + then [] + else [ "-ffloat-store" ]) ++ +#endif + -- gcc's -fstrict-aliasing allows two accesses to memory + -- to be considered non-aliasing if they have different types. + -- This interacts badly with the C code we generate, which is + -- very weakly typed, being derived from C--. + ["-fno-strict-aliasing"] + + + + liftIO $ SysTools.runCc dflags ( + -- force the C compiler to interpret this file as C when + -- compiling .hc files, by adding the -x c option. + -- Also useful for plain .c files, just in case GHC saw a + -- -x c option. + [ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp + then SysTools.Option "c++" else SysTools.Option "c"] ++ + [ SysTools.FileOption "" input_fn + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + md_c_flags + ++ pic_c_flags +#ifdef sparc_TARGET_ARCH + -- We only support SparcV9 and better because V8 lacks an atomic CAS + -- instruction. Note that the user can still override this + -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag + -- regardless of the ordering. + -- + -- This is a temporary hack. + ++ ["-mcpu=v9"] +#endif + ++ (if hcc && mangle + then md_regd_c_flags + else []) + ++ (if hcc + then if mangle + then gcc_extra_viac_flags + else filter (=="-fwrapv") + gcc_extra_viac_flags + -- still want -fwrapv even for unreg'd + else []) + ++ (if hcc + then more_hcc_opts + else []) + ++ [ verb, "-S", "-Wimplicit", cc_opt ] + ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] +#ifdef darwin_TARGET_OS + ++ framework_paths +#endif + ++ cc_opts + ++ split_opt + ++ include_paths + ++ pkg_extra_cc_opts + )) + + return (next_phase, dflags, maybe_loc, output_fn) + + -- ToDo: postprocess the output from gcc + +----------------------------------------------------------------------------- +-- Mangle phase + +runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc + = do let dflags = hsc_dflags hsc_env + let mangler_opts = getOpts dflags opt_m + +#if i386_TARGET_ARCH + machdep_opts <- return [ show (stolen_x86_regs dflags) ] +#else + machdep_opts <- return [] +#endif + + let split = dopt Opt_SplitObjs dflags + next_phase + | split = SplitMangle + | otherwise = As + output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc + + liftIO $ SysTools.runMangle dflags (map SysTools.Option mangler_opts + ++ [ SysTools.FileOption "" input_fn + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option machdep_opts) + + return (next_phase, dflags, maybe_loc, output_fn) + +----------------------------------------------------------------------------- +-- Splitting phase + +runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc + = liftIO $ + do -- tmp_pfx is the prefix used for the split .s files + -- We also use it as the file to contain the no. of split .s files (sigh) + let dflags = hsc_dflags hsc_env + split_s_prefix <- SysTools.newTempName dflags "split" + let n_files_fn = split_s_prefix + + SysTools.runSplit dflags + [ SysTools.FileOption "" input_fn + , SysTools.FileOption "" split_s_prefix + , SysTools.FileOption "" n_files_fn + ] + + -- Save the number of split files for future references + s <- readFile n_files_fn + let n_files = read s :: Int + writeIORef v_Split_info (split_s_prefix, n_files) + + -- Remember to delete all these files + addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s" + | n <- [1..n_files]] + + return (SplitAs, dflags, maybe_loc, "**splitmangle**") + -- we don't use the filename + +----------------------------------------------------------------------------- +-- As phase + +runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc + = liftIO $ + do let dflags = hsc_dflags hsc_env + let as_opts = getOpts dflags opt_a + let cmdline_include_paths = includePaths dflags + + output_fn <- get_output_fn dflags StopLn maybe_loc + + -- we create directories for the object file, because it + -- might be a hierarchical module. + createDirectoryHierarchy (takeDirectory output_fn) + + SysTools.runAs dflags + (map SysTools.Option as_opts + ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] +#ifdef sparc_TARGET_ARCH + -- We only support SparcV9 and better because V8 lacks an atomic CAS + -- instruction so we have to make sure that the assembler accepts the + -- instruction set. Note that the user can still override this + -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag + -- regardless of the ordering. + -- + -- This is a temporary hack. + ++ [ SysTools.Option "-mcpu=v9" ] +#endif + ++ [ SysTools.Option "-c" + , SysTools.FileOption "" input_fn + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ]) + + return (StopLn, dflags, maybe_loc, output_fn) + + +runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc + = liftIO $ do + let dflags = hsc_dflags hsc_env + output_fn <- get_output_fn dflags StopLn maybe_loc + + let base_o = dropExtension output_fn + split_odir = base_o ++ "_split" + osuf = objectSuf dflags + + createDirectoryHierarchy split_odir + + -- remove M_split/ *.o, because we're going to archive M_split/ *.o + -- later and we don't want to pick up any old objects. + fs <- getDirectoryContents split_odir + mapM_ removeFile $ map (split_odir ) $ filter (osuf `isSuffixOf`) fs + + let as_opts = getOpts dflags opt_a + + (split_s_prefix, n) <- readIORef v_Split_info + + let split_s n = split_s_prefix ++ "__" ++ show n <.> "s" + split_obj n = split_odir + takeFileName base_o ++ "__" ++ show n <.> osuf + + let assemble_file n + = SysTools.runAs dflags + (map SysTools.Option as_opts ++ + [ SysTools.Option "-c" + , SysTools.Option "-o" + , SysTools.FileOption "" (split_obj n) + , SysTools.FileOption "" (split_s n) + ]) + + mapM_ assemble_file [1..n] + + -- and join the split objects into a single object file: + let ld_r args = SysTools.runLink dflags ([ + SysTools.Option "-nostdlib", + SysTools.Option "-nodefaultlibs", + SysTools.Option "-Wl,-r", + SysTools.Option ld_x_flag, + SysTools.Option "-o", + SysTools.FileOption "" output_fn ] ++ args) + ld_x_flag | null cLD_X = "" + | otherwise = "-Wl,-x" + + if cLdIsGNULd == "YES" + then do + let script = split_odir "ld.script" + writeFile script $ + "INPUT(" ++ unwords (map split_obj [1..n]) ++ ")" + ld_r [SysTools.FileOption "" script] + else do + ld_r (map (SysTools.FileOption "" . split_obj) [1..n]) + + return (StopLn, dflags, maybe_loc, output_fn) + +-- warning suppression +runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc = + panic ("runPhase: don't know how to run phase " ++ show other) +----------------------------------------------------------------------------- +-- MoveBinary sort-of-phase +-- After having produced a binary, move it somewhere else and generate a +-- wrapper script calling the binary. Currently, we need this only in +-- a parallel way (i.e. in GUM), because PVM expects the binary in a +-- central directory. +-- This is called from linkBinary below, after linking. I haven't made it +-- a separate phase to minimise interfering with other modules, and +-- we don't need the generality of a phase (MoveBinary is always +-- done after linking and makes only sense in a parallel setup) -- HWL + +runPhase_MoveBinary :: DynFlags -> FilePath -> [PackageId] -> IO Bool +runPhase_MoveBinary dflags input_fn dep_packages + | WayPar `elem` (wayNames dflags) && not opt_Static = + panic ("Don't know how to combine PVM wrapper and dynamic wrapper") + | WayPar `elem` (wayNames dflags) = do + let sysMan = pgm_sysman dflags + pvm_root <- getEnv "PVM_ROOT" + pvm_arch <- getEnv "PVM_ARCH" + let + pvm_executable_base = "=" ++ input_fn + pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base + -- nuke old binary; maybe use configur'ed names for cp and rm? + tryIO (removeFile pvm_executable) + -- move the newly created binary into PVM land + copy dflags "copying PVM executable" input_fn pvm_executable + -- generate a wrapper script for running a parallel prg under PVM + writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan) + return True + | not opt_Static = + case (dynLibLoader dflags) of + Wrapped wrapmode -> + do + let (o_base, o_ext) = splitExtension input_fn + let wrapped_executable | o_ext == "exe" = (o_base ++ "_real") <.> o_ext + | otherwise = input_fn ++ "_real" + behaviour <- wrapper_behaviour dflags wrapmode dep_packages + + -- THINKME isn't this possible to do a bit nicer? + let behaviour' = concatMap (\x -> if x=='\\' then "\\\\" else [x]) behaviour + renameFile input_fn wrapped_executable + let rtsDetails = (getPackageDetails (pkgState dflags) rtsPackageId); + SysTools.runCc dflags + ([ SysTools.FileOption "" ((head (libraryDirs rtsDetails)) ++ "/dyn-wrapper.c") + , SysTools.Option ("-DBEHAVIOUR=\"" ++ behaviour' ++ "\"") + , SysTools.Option "-o" + , SysTools.FileOption "" input_fn + ] ++ map (SysTools.FileOption "-I") (includeDirs rtsDetails)) + return True + _ -> return True + | otherwise = return True + +wrapper_behaviour :: DynFlags -> Maybe [Char] -> [PackageId] -> IO [Char] +wrapper_behaviour dflags mode dep_packages = + let seperateBySemiColon strs = tail $ concatMap (';':) strs + in case mode of + Nothing -> do + pkg_lib_paths <- getPackageLibraryPath dflags dep_packages + return ('H' : (seperateBySemiColon pkg_lib_paths)) + Just s -> do + allpkg <- getPreloadPackagesAnd dflags dep_packages + putStrLn (unwords (map (packageIdString . packageConfigId) allpkg)) + return $ 'F':s ++ ';':(seperateBySemiColon (map (packageIdString . packageConfigId) allpkg)) + +-- generates a Perl skript starting a parallel prg under PVM +mk_pvm_wrapper_script :: String -> String -> String -> String +mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $ + [ + "eval 'exec perl -S $0 ${1+\"$@\"}'", + " if $running_under_some_shell;", + "# =!=!=!=!=!=!=!=!=!=!=!", + "# This script is automatically generated: DO NOT EDIT!!!", + "# Generated by Glasgow Haskell Compiler", + "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!", + "#", + "$pvm_executable = '" ++ pvm_executable ++ "';", + "$pvm_executable_base = '" ++ pvm_executable_base ++ "';", + "$SysMan = '" ++ sysMan ++ "';", + "", + {- ToDo: add the magical shortcuts again iff we actually use them -- HWL + "# first, some magical shortcuts to run "commands" on the binary", + "# (which is hidden)", + "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {", + " local($cmd) = $1;", + " system("$cmd $pvm_executable");", + " exit(0); # all done", + "}", -} + "", + "# Now, run the real binary; process the args first", + "$ENV{'PE'} = $pvm_executable_base;", -- ++ pvm_executable_base, + "$debug = '';", + "$nprocessors = 0; # the default: as many PEs as machines in PVM config", + "@nonPVM_args = ();", + "$in_RTS_args = 0;", + "", + "args: while ($a = shift(@ARGV)) {", + " if ( $a eq '+RTS' ) {", + " $in_RTS_args = 1;", + " } elsif ( $a eq '-RTS' ) {", + " $in_RTS_args = 0;", + " }", + " if ( $a eq '-d' && $in_RTS_args ) {", + " $debug = '-';", + " } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {", + " $nprocessors = $1;", + " } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {", + " $nprocessors = $1;", + " } else {", + " push(@nonPVM_args, $a);", + " }", + "}", + "", + "local($return_val) = 0;", + "# Start the parallel execution by calling SysMan", + "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");", + "$return_val = $?;", + "# ToDo: fix race condition moving files and flushing them!!", + "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";", + "exit($return_val);" + ] + +----------------------------------------------------------------------------- +-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file + +getHCFilePackages :: FilePath -> IO [PackageId] +getHCFilePackages filename = + Exception.bracket (openFile filename ReadMode) hClose $ \h -> do + l <- hGetLine h + case l of + '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> + return (map stringToPackageId (words rest)) + _other -> + return [] + +----------------------------------------------------------------------------- +-- Static linking, of .o files + +-- The list of packages passed to link is the list of packages on +-- which this program depends, as discovered by the compilation +-- manager. It is combined with the list of packages that the user +-- specifies on the command line with -package flags. +-- +-- In one-shot linking mode, we can't discover the package +-- dependencies (because we haven't actually done any compilation or +-- read any interface files), so the user must explicitly specify all +-- the packages. + +linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO () +linkBinary dflags o_files dep_packages = do + let verb = getVerbFlag dflags + output_fn = exeFileName dflags + + -- get the full list of packages to link with, by combining the + -- explicit packages with the auto packages and all of their + -- dependencies, and eliminating duplicates. + + pkg_lib_paths <- getPackageLibraryPath dflags dep_packages + let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths) +#ifdef linux_TARGET_OS + get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] + | otherwise = ["-L" ++ l] +#else + get_pkg_lib_path_opts l = ["-L" ++ l] +#endif + + let lib_paths = libraryPaths dflags + let lib_path_opts = map ("-L"++) lib_paths + + pkg_link_opts <- getPackageLinkOpts dflags dep_packages + +#ifdef darwin_TARGET_OS + pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages + let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths + + let framework_paths = frameworkPaths dflags + framework_path_opts = map ("-F"++) framework_paths + + pkg_frameworks <- getPackageFrameworks dflags dep_packages + let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ] + + let frameworks = cmdlineFrameworks dflags + framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ] + -- reverse because they're added in reverse order from the cmd line +#endif +#ifdef mingw32_TARGET_OS + let dynMain = if not opt_Static then + (head (libraryDirs (getPackageDetails (pkgState dflags) rtsPackageId))) ++ "/Main.dyn_o" + else + "" +#endif + -- probably _stub.o files + extra_ld_inputs <- readIORef v_Ld_inputs + + -- opts from -optl- (including -l options) + let extra_ld_opts = getOpts dflags opt_l + + let ways = wayNames dflags + + -- Here are some libs that need to be linked at the *end* of + -- the command line, because they contain symbols that are referred to + -- by the RTS. We can't therefore use the ordinary way opts for these. + let + debug_opts | WayDebug `elem` ways = [ +#if defined(HAVE_LIBBFD) + "-lbfd", "-liberty" +#endif + ] + | otherwise = [] + + let + thread_opts | WayThreaded `elem` ways = [ +#if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) + "-lpthread" +#endif +#if defined(osf3_TARGET_OS) + , "-lexc" +#endif + ] + | otherwise = [] + + rc_objs <- maybeCreateManifest dflags output_fn + + let (md_c_flags, _) = machdepCCOpts dflags + SysTools.runLink dflags ( + [ SysTools.Option verb + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + md_c_flags + ++ o_files +#ifdef mingw32_TARGET_OS + ++ [dynMain] +#endif + ++ extra_ld_inputs + ++ lib_path_opts + ++ extra_ld_opts + ++ rc_objs +#ifdef darwin_TARGET_OS + ++ framework_path_opts + ++ framework_opts +#endif + ++ pkg_lib_path_opts + ++ pkg_link_opts +#ifdef darwin_TARGET_OS + ++ pkg_framework_path_opts + ++ pkg_framework_opts +#endif + ++ debug_opts + ++ thread_opts + )) + + -- parallel only: move binary to another dir -- HWL + success <- runPhase_MoveBinary dflags output_fn dep_packages + if success then return () + else ghcError (InstallationError ("cannot move binary")) + + +exeFileName :: DynFlags -> FilePath +exeFileName dflags + | Just s <- outputFile dflags = +#if defined(mingw32_HOST_OS) + if null (takeExtension s) + then s <.> "exe" + else s +#else + s +#endif + | otherwise = +#if defined(mingw32_HOST_OS) + "main.exe" +#else + "a.out" +#endif + +maybeCreateManifest + :: DynFlags + -> FilePath -- filename of executable + -> IO [FilePath] -- extra objects to embed, maybe +#ifndef mingw32_TARGET_OS +maybeCreateManifest _ _ = do + return [] +#else +maybeCreateManifest dflags exe_filename = do + if not (dopt Opt_GenManifest dflags) then return [] else do + + let manifest_filename = exe_filename <.> "manifest" + + writeFile manifest_filename $ + "\n"++ + " \n"++ + " \n\n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + "\n" + + -- Windows will find the manifest file if it is named foo.exe.manifest. + -- However, for extra robustness, and so that we can move the binary around, + -- we can embed the manifest in the binary itself using windres: + if not (dopt Opt_EmbedManifest dflags) then return [] else do + + rc_filename <- newTempName dflags "rc" + rc_obj_filename <- newTempName dflags (objectSuf dflags) + + writeFile rc_filename $ + "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" + -- magic numbers :-) + -- show is a bit hackish above, but we need to escape the + -- backslashes in the path. + + let wr_opts = getOpts dflags opt_windres + runWindres dflags $ map SysTools.Option $ + ["--input="++rc_filename, + "--output="++rc_obj_filename, + "--output-format=coff"] + ++ wr_opts + -- no FileOptions here: windres doesn't like seeing + -- backslashes, apparently + + return [rc_obj_filename] +#endif + + +linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () +linkDynLib dflags o_files dep_packages = do + let verb = getVerbFlag dflags + let o_file = outputFile dflags + + -- We don't want to link our dynamic libs against the RTS package, + -- because the RTS lib comes in several flavours and we want to be + -- able to pick the flavour when a binary is linked. + pkgs <- getPreloadPackagesAnd dflags dep_packages + let pkgs_no_rts = filter ((/= rtsPackageId) . packageConfigId) pkgs + + let pkg_lib_paths = collectLibraryPaths pkgs_no_rts + let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths + + let lib_paths = libraryPaths dflags + let lib_path_opts = map ("-L"++) lib_paths + + let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts + + -- probably _stub.o files + extra_ld_inputs <- readIORef v_Ld_inputs + + let (md_c_flags, _) = machdepCCOpts dflags + let extra_ld_opts = getOpts dflags opt_l +#if defined(mingw32_HOST_OS) + ----------------------------------------------------------------------------- + -- Making a DLL + ----------------------------------------------------------------------------- + let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; } + + SysTools.runLink dflags + ([ SysTools.Option verb + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + , SysTools.Option "-shared" + , SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a") + ] + ++ map (SysTools.FileOption "") o_files + ++ map SysTools.Option ( + md_c_flags + ++ extra_ld_inputs + ++ lib_path_opts + ++ extra_ld_opts + ++ pkg_lib_path_opts + ++ pkg_link_opts + )) +#elif defined(darwin_TARGET_OS) + ----------------------------------------------------------------------------- + -- Making a darwin dylib + ----------------------------------------------------------------------------- + -- About the options used for Darwin: + -- -dynamiclib + -- Apple's way of saying -shared + -- -undefined dynamic_lookup: + -- Without these options, we'd have to specify the correct dependencies + -- for each of the dylibs. Note that we could (and should) do without this + -- for all libraries except the RTS; all we need to do is to pass the + -- correct HSfoo_dyn.dylib files to the link command. + -- This feature requires Mac OS X 10.3 or later; there is a similar feature, + -- -flat_namespace -undefined suppress, which works on earlier versions, + -- but it has other disadvantages. + -- -single_module + -- Build the dynamic library as a single "module", i.e. no dynamic binding + -- nonsense when referring to symbols from within the library. The NCG + -- assumes that this option is specified (on i386, at least). + -- -Wl,-macosx_version_min -Wl,10.3 + -- Tell the linker its safe to assume that the library will run on 10.3 or + -- later, so that it will not complain about the use of the option + -- -undefined dynamic_lookup above. + -- -install_name + -- Causes the dynamic linker to ignore the DYLD_LIBRARY_PATH when loading + -- this lib and instead look for it at its absolute path. + -- When installing the .dylibs (see target.mk), we'll change that path to + -- point to the place they are installed. Therefore, we won't have to set + -- up DYLD_LIBRARY_PATH specifically for ghc. + ----------------------------------------------------------------------------- + + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + + pwd <- getCurrentDirectory + SysTools.runLink dflags + ([ SysTools.Option verb + , SysTools.Option "-dynamiclib" + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + md_c_flags + ++ o_files + ++ [ "-undefined", "dynamic_lookup", "-single_module", "-Wl,-macosx_version_min","-Wl,10.3", "-install_name " ++ (pwd output_fn) ] + ++ extra_ld_inputs + ++ lib_path_opts + ++ extra_ld_opts + ++ pkg_lib_path_opts + ++ pkg_link_opts + )) +#else + ----------------------------------------------------------------------------- + -- Making a DSO + ----------------------------------------------------------------------------- + + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + + SysTools.runLink dflags + ([ SysTools.Option verb + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + md_c_flags + ++ o_files + ++ [ "-shared", "-Wl,-Bsymbolic" ] -- we need symbolic linking to resolve non-PIC intra-package-relocations + ++ extra_ld_inputs + ++ lib_path_opts + ++ extra_ld_opts + ++ pkg_lib_path_opts + ++ pkg_link_opts + )) +#endif +-- ----------------------------------------------------------------------------- +-- Running CPP + +doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO () +doCpp dflags raw include_cc_opts input_fn output_fn = do + let hscpp_opts = getOpts dflags opt_P + let cmdline_include_paths = includePaths dflags + + pkg_include_dirs <- getPackageIncludePath dflags [] + let include_paths = foldr (\ x xs -> "-I" : x : xs) [] + (cmdline_include_paths ++ pkg_include_dirs) + + let verb = getVerbFlag dflags + + let cc_opts + | not include_cc_opts = [] + | otherwise = (optc ++ md_c_flags) + where + optc = getOpts dflags opt_c + (md_c_flags, _) = machdepCCOpts dflags + + let cpp_prog args | raw = SysTools.runCpp dflags args + | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args) + + let target_defs = + [ "-D" ++ HOST_OS ++ "_BUILD_OS=1", + "-D" ++ HOST_ARCH ++ "_BUILD_ARCH=1", + "-D" ++ TARGET_OS ++ "_HOST_OS=1", + "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ] + -- remember, in code we *compile*, the HOST is the same our TARGET, + -- and BUILD is the same as our HOST. + + cpp_prog ([SysTools.Option verb] + ++ map SysTools.Option include_paths + ++ map SysTools.Option hsSourceCppOpts + ++ map SysTools.Option hscpp_opts + ++ map SysTools.Option cc_opts + ++ map SysTools.Option target_defs + ++ [ SysTools.Option "-x" + , SysTools.Option "c" + , SysTools.Option input_fn + -- We hackily use Option instead of FileOption here, so that the file + -- name is not back-slashed on Windows. cpp is capable of + -- dealing with / in filenames, so it works fine. Furthermore + -- if we put in backslashes, cpp outputs #line directives + -- with *double* backslashes. And that in turn means that + -- our error messages get double backslashes in them. + -- In due course we should arrange that the lexer deals + -- with these \\ escapes properly. + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ]) + +cHaskell1Version :: String +cHaskell1Version = "5" -- i.e., Haskell 98 + +hsSourceCppOpts :: [String] +-- Default CPP defines in Haskell source +hsSourceCppOpts = + [ "-D__HASKELL1__="++cHaskell1Version + , "-D__GLASGOW_HASKELL__="++cProjectVersionInt + , "-D__HASKELL98__" + , "-D__CONCURRENT_HASKELL__" + ] + + +-- ----------------------------------------------------------------------------- +-- Misc. + +hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase +hscNextPhase _ HsBootFile _ = StopLn +hscNextPhase dflags _ hsc_lang = + case hsc_lang of + HscC -> HCc + HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle + | otherwise -> As + HscNothing -> StopLn + HscInterpreted -> StopLn + _other -> StopLn + + +hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget +hscMaybeAdjustTarget dflags stop _ current_hsc_lang + = hsc_lang + where + keep_hc = dopt Opt_KeepHcFiles dflags + hsc_lang + -- don't change the lang if we're interpreting + | current_hsc_lang == HscInterpreted = current_hsc_lang + + -- force -fvia-C if we are being asked for a .hc file + | HCc <- stop = HscC + | keep_hc = HscC + -- otherwise, stick to the plan + | otherwise = current_hsc_lang + +GLOBAL_VAR(v_Split_info, ("",0), (String,Int)) + -- The split prefix and number of files addfile ./GHCSalat/GHC4Lsk.hs hunk ./GHCSalat/GHC4Lsk.hs 1 +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2005 +-- +-- The GHC API +-- +-- ----------------------------------------------------------------------------- +module GHCSalat.GHC4Lsk ( + -- * Initialisation + defaultErrorHandler, + defaultCleanupHandler, + + -- * GHC Monad + Ghc, GhcT, GhcMonad(..), + runGhc, runGhcT, initGhcMonad, + gcatch, gbracket, gfinally, + clearWarnings, getWarnings, hasWarnings, + printExceptionAndWarnings, printWarnings, + handleSourceError, + + -- * Flags and settings + DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, + GhcMode(..), GhcLink(..), defaultObjectTarget, + parseDynamicFlags, + getSessionDynFlags, + setSessionDynFlags, + parseStaticFlags, + + -- * Targets + Target(..), TargetId(..), Phase, + setTargets, + getTargets, + addTarget, + removeTarget, + guessTarget, + + -- * Extending the program scope + extendGlobalRdrScope, + setGlobalRdrScope, + extendGlobalTypeScope, + setGlobalTypeScope, + + -- * Loading\/compiling the program + depanal, + load, loadWithLogger, LoadHowMuch(..), SuccessFlag(..), -- also does depanal + defaultWarnErrLogger, WarnErrLogger, + workingDirectoryChanged, + parseModule, typecheckModule, desugarModule, loadModule, + ParsedModule(..), TypecheckedModule(..), DesugaredModule, -- all abstract + TypecheckedSource, ParsedSource, RenamedSource, -- ditto + TypecheckedMod, ParsedMod, + moduleInfo, renamedSource, typecheckedSource, + parsedSource, coreModule, + compileToCoreModule, compileToCoreSimplified, + compileCoreToObj, + getModSummary, + + -- * Parsing Haddock comments + parseHaddockComment, + + -- * Inspecting the module structure of the program + ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), + getModuleGraph, + isLoaded, + topSortModuleGraph, + + -- * Inspecting modules + ModuleInfo, + getModuleInfo, + modInfoTyThings, + modInfoTopLevelScope, + modInfoExports, + modInfoInstances, + modInfoIsExportedName, + modInfoLookupName, + lookupGlobalName, + mkPrintUnqualifiedForModule, + + -- * Printing + PrintUnqualified, alwaysQualify, + + -- * Interactive evaluation + getBindings, getPrintUnqual, + findModule, +#ifdef GHCI + setContext, getContext, + getNamesInScope, + getRdrNamesInScope, + getGRE, + moduleIsInterpreted, + getInfo, + exprType, + typeKind, + parseName, + RunResult(..), + runStmt, SingleStep(..), + resume, + Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, + resumeHistory, resumeHistoryIx), + History(historyBreakInfo, historyEnclosingDecl), + GHCSalat.GHC4Lsk.getHistorySpan, getHistoryModule, + getResumeContext, + abandon, abandonAll, + InteractiveEval.back, + InteractiveEval.forward, + showModule, + isModuleInterpreted, + InteractiveEval.compileExpr, HValue, dynCompileExpr, + lookupName, + GHCSalat.GHC4Lsk.obtainTermFromId, GHCSalat.GHC4Lsk.obtainTermFromVal, reconstructType, + modInfoModBreaks, + ModBreaks(..), BreakIndex, + BreakInfo(breakInfo_number, breakInfo_module), + BreakArray, setBreakOn, setBreakOff, getBreak, +#endif + + -- * Abstract syntax elements + + -- ** Packages + PackageId, + + -- ** Modules + Module, mkModule, pprModule, moduleName, modulePackageId, + ModuleName, mkModuleName, moduleNameString, + + -- ** Names + Name, + isExternalName, nameModule, pprParenSymName, nameSrcSpan, + NamedThing(..), + RdrName(Qual,Unqual), + + -- ** Identifiers + Id, idType, + isImplicitId, isDeadBinder, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, + isPrimOpId, isFCallId, isClassOpId_maybe, + isDataConWorkId, idDataCon, + isBottomingId, isDictonaryId, + recordSelectorFieldLabel, + + -- ** Type constructors + TyCon, + tyConTyVars, tyConDataCons, tyConArity, + isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, + isOpenTyCon, + synTyConDefn, synTyConType, synTyConResKind, + + -- ** Type variables + TyVar, + alphaTyVars, + + -- ** Data constructors + DataCon, + dataConSig, dataConType, dataConTyCon, dataConFieldLabels, + dataConIsInfix, isVanillaDataCon, + dataConStrictMarks, + StrictnessMark(..), isMarkedStrict, + + -- ** Classes + Class, + classMethods, classSCTheta, classTvsFds, + pprFundeps, + + -- ** Instances + Instance, + instanceDFunId, pprInstance, pprInstanceHdr, + + -- ** Types and Kinds + Type, splitForAllTys, funResultTy, + pprParendType, pprTypeApp, + Kind, + PredType, + ThetaType, pprThetaArrow, + + -- ** Entities + TyThing(..), + + -- ** Syntax + module HsSyn, -- ToDo: remove extraneous bits + + -- ** Fixities + FixityDirection(..), + defaultFixity, maxPrecedence, + negateFixity, + compareFixity, + + -- ** Source locations + SrcLoc, pprDefnLoc, + mkSrcLoc, isGoodSrcLoc, noSrcLoc, + srcLocFile, srcLocLine, srcLocCol, + SrcSpan, + mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, + srcSpanStart, srcSpanEnd, + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, + + -- ** Located + Located(..), + + -- *** Constructing Located + noLoc, mkGeneralLocated, + + -- *** Deconstructing Located + getLoc, unLoc, + + -- *** Combining and comparing Located values + eqLocated, cmpLocated, combineLocs, addCLoc, + leftmost_smallest, leftmost_largest, rightmost, + spans, isSubspanOf, + + -- * Exceptions + GhcException(..), showGhcException, + + -- * Token stream manipulations + Token, + getTokenStream, getRichTokenStream, + showRichTokenStream, addSourceToTokens, + + -- * Miscellaneous + --sessionHscEnv, + cyclicModuleErr, + + compileHsExpr, + unload + ) where + +{- + ToDo: + + * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt. + * what StaticFlags should we expose, if any? +-} + +#include "HsVersions4Lsk.h" + +#ifdef GHCI +import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) +import CodeOutput ( outputForeignStubs ) +import CorePrep ( corePrepPgm ) +import CorePrep ( corePrepExpr ) +import qualified Linker +import Linker ( HValue ) +import ByteCodeInstr +import BreakArray +import NameSet +import InteractiveEval +import TcRnDriver +import GHCSalat.TcRnDriver4Lsk +import Desugar ( deSugarExpr ) +import PrelNames +#endif + +import TcIface +import TcRnTypes hiding (LIE) +import TcRnMonad ( initIfaceCheck, getLIE, initTcPrintErrors, failIfErrsM ) +import Packages +import NameSet +import RdrName +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 +import TysPrim ( alphaTyVars ) +import TyCon +import Class +import FunDeps +import DataCon +import Name hiding ( varName ) +import OccName ( parenSymOcc ) +import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr, + emptyInstEnv ) +import FamInstEnv ( emptyFamInstEnv ) +import SrcLoc +--import CoreSyn +import TidyPgm +import GHCSalat.DriverPipeline4Lsk +import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase ) +import HeaderInfo +import Finder +import qualified GHCSalat.Finder4Lsk as FL +import HscMain +import HscTypes +import DynFlags +import StaticFlagParser +import qualified StaticFlags +import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, + cleanTempDirs ) +import Module +import LazyUniqFM +import UniqSet +import Unique +import FiniteMap +import Panic +import Digraph +import Bag ( unitBag, listToBag, emptyBag, isEmptyBag ) +import ErrUtils +import MonadUtils +import Util +import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar ) +import Outputable +import BasicTypes +import Maybes ( expectJust, mapCatMaybes ) +import HaddockParse +import HaddockLex ( tokenise ) +import FastString +import Lexer + +import Control.Concurrent +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, getClockTime ) +import Exception +import Data.IORef +import System.FilePath +import System.IO +import System.IO.Error ( try, isDoesNotExistError ) +import Prelude hiding (init) + +import LskFileHandler +import TcHsSyn +import GHC.Exts ( unsafeCoerce# ) +import RnExpr +import RnEnv +import TcEnv +import TcExpr +import TcSimplify +import SimplCore ( core2core ) + +-- ----------------------------------------------------------------------------- +-- Exception handlers + +-- | Install some default exception handlers and run the inner computation. +-- Unless you want to handle exceptions yourself, you should wrap this around +-- the top level of your program. The default handlers output the error +-- message(s) to stderr and exit cleanly. +defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a +defaultErrorHandler dflags inner = + -- top-level exception handler: any unrecognised exception is a compiler bug. + ghandle (\exception -> liftIO $ do + hFlush stdout + case fromException exception of + -- an IO exception probably isn't our fault, so don't panic + Just (ioe :: IOException) -> + fatalErrorMsg dflags (text (show ioe)) + _ -> case fromException exception of + Just StackOverflow -> + fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") + _ -> case fromException exception of + Just (ex :: ExitCode) -> throw ex + _ -> + fatalErrorMsg dflags + (text (show (Panic (show exception)))) + exitWith (ExitFailure 1) + ) $ + + -- error messages propagated as exceptions + handleGhcException + (\ge -> liftIO $ do + hFlush stdout + case ge of + PhaseFailed _ code -> exitWith code + Interrupted -> exitWith (ExitFailure 1) + _ -> do fatalErrorMsg dflags (text (show ge)) + exitWith (ExitFailure 1) + ) $ + inner + +-- | Install a default cleanup handler to remove temporary files deposited by +-- a GHC run. This is seperate from 'defaultErrorHandler', because you might +-- want to override the error handling, but still get the ordinary cleanup +-- behaviour. +defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) => + DynFlags -> m a -> m a +defaultCleanupHandler dflags inner = + -- make sure we clean up after ourselves + inner `gonException` + (liftIO $ 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. + +-- | Print the error message and all warnings. Useful inside exception +-- handlers. Clears warnings after printing. +printExceptionAndWarnings :: GhcMonad m => SourceError -> m () +printExceptionAndWarnings err = do + let errs = srcErrorMessages err + warns <- getWarnings + dflags <- getSessionDynFlags + if isEmptyBag errs + -- Empty errors means we failed due to -Werror. (Since this function + -- takes a source error as argument, we know for sure _some_ error + -- did indeed happen.) + then liftIO $ do + printBagOfWarnings dflags warns + printBagOfErrors dflags (unitBag warnIsErrorMsg) + else liftIO $ printBagOfErrors dflags errs + clearWarnings + +-- | Print all accumulated warnings using 'log_action'. +printWarnings :: GhcMonad m => m () +printWarnings = do + dflags <- getSessionDynFlags + warns <- getWarnings + liftIO $ printBagOfWarnings dflags warns + clearWarnings + +-- | Run function for the 'Ghc' monad. +-- +-- It initialises the GHC session and warnings via 'initGhcMonad'. Each call +-- to this function will create a new session which should not be shared among +-- several threads. +-- +-- Any errors not handled inside the 'Ghc' action are propagated as IO +-- exceptions. + +runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. + -> Ghc a -- ^ The action to perform. + -> IO a +runGhc mb_top_dir ghc = do + wref <- newIORef emptyBag + ref <- newIORef undefined + let session = Session ref wref + flip unGhc session $ do + initGhcMonad mb_top_dir + ghc + -- XXX: unregister interrupt handlers here? + +-- | Run function for 'GhcT' monad transformer. +-- +-- It initialises the GHC session and warnings via 'initGhcMonad'. Each call +-- to this function will create a new session which should not be shared among +-- several threads. + +runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) => + Maybe FilePath -- ^ See argument to 'initGhcMonad'. + -> GhcT m a -- ^ The action to perform. + -> m a +runGhcT mb_top_dir ghct = do + wref <- liftIO $ newIORef emptyBag + ref <- liftIO $ newIORef undefined + let session = Session ref wref + flip unGhcT session $ do + initGhcMonad mb_top_dir + ghct + +-- | Initialise a GHC session. +-- +-- If you implement a custom 'GhcMonad' you must call this function in the +-- monad run function. It will initialise the session variable and clear all +-- warnings. +-- +-- The first argument should point to the directory where GHC's library files +-- reside. More precisely, this should be the output of @ghc --print-libdir@ +-- of the version of GHC the module using this API is compiled with. For +-- portability, you should use the @ghc-paths@ package, available at +-- . + +initGhcMonad :: GhcMonad m => Maybe FilePath -> m () +initGhcMonad mb_top_dir = do + -- catch ^C + main_thread <- liftIO $ myThreadId + liftIO $ modifyMVar_ interruptTargetThread (return . (main_thread :)) + liftIO $ installSignalHandlers + + liftIO $ StaticFlags.initStaticOpts + + dflags0 <- liftIO $ initDynFlags defaultDynFlags + dflags <- liftIO $ initSysTools mb_top_dir dflags0 + env <- liftIO $ newHscEnv dflags + setSession env + clearWarnings + +-- ----------------------------------------------------------------------------- +-- Flags & settings + +-- | Grabs the DynFlags from the Session +getSessionDynFlags :: GhcMonad m => m DynFlags +getSessionDynFlags = withSession (return . hsc_dflags) + +-- | Updates the DynFlags in a Session. This also reads +-- the package database (unless it has already been read), +-- and prepares the compilers knowledge about packages. It +-- can be called again to load new packages: just add new +-- package flags to (packageFlags dflags). +-- +-- Returns a list of new packages that may need to be linked in using +-- the dynamic linker (see 'linkPackages') as a result of new package +-- flags. If you are not doing linking or doing static linking, you +-- can ignore the list of packages returned. +-- +setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId] +setSessionDynFlags dflags = do + (dflags', preload) <- liftIO $ initPackages dflags + modifySession (\h -> h{ hsc_dflags = dflags' }) + return preload + +-- | If there is no -o option, guess the name of target executable +-- by using top-level source file name as a base. +guessOutputFile :: GhcMonad m => m () +guessOutputFile = modifySession $ \env -> + let dflags = hsc_dflags env + mod_graph = hsc_mod_graph env + mainModuleSrcPath :: Maybe String + mainModuleSrcPath = do + let isMain = (== mainModIs dflags) . ms_mod + [ms] <- return (filter isMain mod_graph) + ml_hs_file (ms_location ms) + 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 = name_exe } } + +-- ----------------------------------------------------------------------------- +-- Targets + +-- ToDo: think about relative vs. absolute file paths. And what +-- happens when the current directory changes. + +-- | Sets the targets for this session. Each target may be a module name +-- or a filename. The targets correspond to the set of root modules for +-- the program\/library. Unloading the current program is achieved by +-- setting the current set of targets to be empty, followed by 'load'. +setTargets :: GhcMonad m => [Target] -> m () +setTargets targets = modifySession (\h -> h{ hsc_targets = targets }) + +-- | Returns the current set of targets +getTargets :: GhcMonad m => m [Target] +getTargets = withSession (return . hsc_targets) + +-- | Add another target. +addTarget :: GhcMonad m => Target -> m () +addTarget target + = modifySession (\h -> h{ hsc_targets = target : hsc_targets h }) + +-- | Remove a target +removeTarget :: GhcMonad m => TargetId -> m () +removeTarget target_id + = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) }) + where + 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: +-- +-- - if the string looks like a Haskell source filename, then interpret it +-- as such +-- +-- - if adding a .hs or .lhs suffix yields the name of an existing file, +-- then use that +-- +-- - otherwise interpret the string as a module name +-- +guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target +guessTarget str (Just phase) + = return (Target (TargetFile str (Just phase)) True Nothing) +guessTarget str Nothing + | isHaskellSrcFilename file + = return (target (TargetFile file Nothing)) + | otherwise + = do exists <- liftIO $ doesFileExist hs_file + if exists + then return (target (TargetFile hs_file Nothing)) + else do + exists <- liftIO $ doesFileExist lhs_file + if exists + then return (target (TargetFile lhs_file Nothing)) + else do + exists <- liftIO $ doesFileExist lsk_file + if exists + then return (target (TargetFile lsk_file Nothing)) + else do + 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 + (file,obj_allowed) + | '*':rest <- str = (rest, False) + | otherwise = (str, True) + + hs_file = file <.> "hs" + lhs_file = file <.> "lhs" + lsk_file = file <.> "lsk" + + target tid = Target tid obj_allowed Nothing + +-- ----------------------------------------------------------------------------- +-- Extending the program scope + +extendGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m () +extendGlobalRdrScope rdrElts + = modifySession $ \hscEnv -> + let global_rdr = hsc_global_rdr_env hscEnv + in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts } + +setGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m () +setGlobalRdrScope rdrElts + = modifySession $ \hscEnv -> + hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts } + +extendGlobalTypeScope :: GhcMonad m => [Id] -> m () +extendGlobalTypeScope ids + = modifySession $ \hscEnv -> + let global_type = hsc_global_type_env hscEnv + in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids } + +setGlobalTypeScope :: GhcMonad m => [Id] -> m () +setGlobalTypeScope ids + = modifySession $ \hscEnv -> + hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids } + +-- ----------------------------------------------------------------------------- +-- Parsing Haddock comments + +parseHaddockComment :: String -> Either String (HsDoc RdrName) +parseHaddockComment string = + case parseHaddockParagraphs (tokenise string) of + MyLeft x -> Left x + MyRight x -> Right x + +-- ----------------------------------------------------------------------------- +-- Loading the program + +-- | Perform a dependency analysis starting from the current targets +-- and update the session with the new module graph. +depanal :: GhcMonad m => + [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m ModuleGraph +depanal excluded_mods allow_dup_roots = do + hsc_env <- getSession + let + dflags = hsc_dflags hsc_env + targets = hsc_targets hsc_env + old_graph = hsc_mod_graph hsc_env + + liftIO $ showPass dflags "Chasing dependencies" + liftIO $ debugTraceMsg dflags 2 (hcat [ + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) + + mod_graph <- downsweep hsc_env old_graph excluded_mods allow_dup_roots + modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } + return mod_graph + +data LoadHowMuch + = LoadAllTargets + | LoadUpTo ModuleName + | LoadDependenciesOf ModuleName + +-- | Try to load the program. Calls 'loadWithLogger' with the default +-- compiler that just immediately logs all warnings and errors. +load :: GhcMonad m => LoadHowMuch -> m SuccessFlag +load how_much = + loadWithLogger defaultWarnErrLogger how_much + +-- | A function called to log warnings and errors. +type WarnErrLogger = GhcMonad m => Maybe SourceError -> m () + +defaultWarnErrLogger :: WarnErrLogger +defaultWarnErrLogger Nothing = printWarnings +defaultWarnErrLogger (Just e) = printExceptionAndWarnings e + +-- | Try to load the program. If a Module is supplied, then just +-- attempt to load up to this target. If no Module is supplied, +-- then try to load all targets. +-- +-- The first argument is a function that is called after compiling each +-- module to print wanrings and errors. + +loadWithLogger :: GhcMonad m => WarnErrLogger -> LoadHowMuch -> m SuccessFlag +loadWithLogger logger 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 + -- graph is still retained in the Session. We can tell which modules + -- were successfully loaded by inspecting the Session's HPT. + mod_graph <- depanal [] False + load2 how_much mod_graph logger + +load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> WarnErrLogger + -> m SuccessFlag +load2 how_much mod_graph logger = do + guessOutputFile + hsc_env <- getSession + + let hpt1 = hsc_HPT hsc_env + let dflags = hsc_dflags hsc_env + + -- The "bad" boot modules are the ones for which we have + -- B.hs-boot in the module graph, but no B.hs + -- The downsweep should have ensured this does not happen + -- (see msDeps) + let all_home_mods = [ms_mod_name s + | s <- mod_graph, not (isBootSummary s)] + bad_boot_mods = [s | s <- mod_graph, isBootSummary s, + 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 + liftIO $ 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 + -- upsweep, and for removing from hpt all the modules + -- not in strict downwards closure, during calls to compile. + let mg2_with_srcimps :: [SCC ModSummary] + mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + + -- If we can determine that any of the {-# SOURCE #-} imports + -- are definitely unnecessary, then emit a warning. + warnUnnecessarySourceImports dflags mg2_with_srcimps + + let + -- check the stability property for each module. + stable_mods@(stable_obj,stable_bco) + = checkStability hpt1 mg2_with_srcimps all_home_mods + + -- prune bits of the HPT which are definitely redundant now, + -- to save space. + pruned_hpt = pruneHomePackageTable hpt1 + (flattenSCCs mg2_with_srcimps) + stable_mods + + liftIO $ 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. + modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext, + hsc_HPT = pruned_hpt } + + liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ + text "Stable BCO:" <+> ppr stable_bco) + + -- Unload any modules which are going to be re-linked this time around. + let stable_linkables = [ linkable + | m <- stable_obj++stable_bco, + Just hmi <- [lookupUFM pruned_hpt m], + Just linkable <- [hm_linkable hmi] ] + liftIO $ unload hsc_env stable_linkables + + -- We could at this point detect cycles which aren't broken by + -- a source-import, and complain immediately, but it seems better + -- to let upsweep_mods do this, so at least some useful work gets + -- done before the upsweep is abandoned. + --hPutStrLn stderr "after tsort:\n" + --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) + + -- Now do the upsweep, calling compile for each module in + -- turn. Final result is version 3 of everything. + + -- Topologically sort the module graph, this time including hi-boot + -- nodes, and possibly just including the portion of the graph + -- reachable from the module specified in the 2nd argument to load. + -- This graph should be cycle-free. + -- If we're restricting the upsweep to a portion of the graph, we + -- also want to retain everything that is still stable. + let full_mg :: [SCC ModSummary] + full_mg = topSortModuleGraph False mod_graph Nothing + + maybe_top_mod = case how_much of + LoadUpTo m -> Just m + LoadDependenciesOf m -> Just m + _ -> Nothing + + partial_mg0 :: [SCC ModSummary] + partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod + + -- LoadDependenciesOf m: we want the upsweep to stop just + -- short of the specified module (unless the specified module + -- is stable). + partial_mg + | LoadDependenciesOf _mod <- how_much + = ASSERT( case last partial_mg0 of + AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) + List.init partial_mg0 + | otherwise + = partial_mg0 + + stable_mg = + [ AcyclicSCC ms + | AcyclicSCC ms <- full_mg, + ms_mod_name ms `elem` stable_obj++stable_bco, + ms_mod_name ms `notElem` [ ms_mod_name ms' | + AcyclicSCC ms' <- partial_mg ] ] + + mg = stable_mg ++ partial_mg + + -- clean up between compilations + let cleanup = cleanTempFilesExcept dflags + (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps)) + + liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") + 2 (ppr mg)) + (upsweep_ok, hsc_env1, modsUpswept) + <- upsweep logger + (hsc_env { hsc_HPT = emptyHomePackageTable }) + pruned_hpt stable_mods cleanup mg + + -- Make modsDone be the summaries for each home module now + -- available; this should equal the domain of hpt3. + -- Get in in a roughly top .. bottom order (hence reverse). + + let modsDone = reverse modsUpswept + + -- Try and do linking in some form, depending on whether the + -- upsweep was completely or only partially successful. + + if succeeded upsweep_ok + + then + -- Easy; just relink it all. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") + + -- Clean up after ourselves + liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) + + -- Issue a warning for the confusing case where the user + -- said '-o foo' but we're not going to do any linking. + -- We attempt linking if either (a) one of the modules is + -- called Main, or (b) the user said -no-hs-main, indicating + -- that main() is going to come from somewhere else. + -- + let ofile = outputFile dflags + let no_hs_main = dopt Opt_NoHsMain dflags + let + main_mod = mainModIs dflags + a_root_is_Main = any ((==main_mod).ms_mod) mod_graph + do_linking = a_root_is_Main || no_hs_main + + when (ghcLink dflags == LinkBinary + && isJust ofile && not do_linking) $ + liftIO $ debugTraceMsg dflags 1 $ + text ("Warning: output was redirected with -o, " ++ + "but no output will be generated\n" ++ + "because there is no " ++ + moduleNameString (moduleName main_mod) ++ " module.") + + -- link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) + + loadFinish Succeeded linkresult hsc_env1 + + 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 liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") + + let modsDone_names + = map ms_mod modsDone + let mods_to_zap_names + = findPartiallyCompletedCycles modsDone_names + mg2_with_srcimps + let mods_to_keep + = filter ((`notElem` mods_to_zap_names).ms_mod) + modsDone + + let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) + (hsc_HPT hsc_env1) + + -- Clean up after ourselves + liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep) + + -- there should be no Nothings where linkables should be, now + ASSERT(all (isJust.hm_linkable) + (eltsUFM (hsc_HPT hsc_env))) do + + -- Link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 + + let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 } + loadFinish Failed linkresult hsc_env4 + +-- Finish up after a load. + +-- If the link failed, unload everything and return. +loadFinish :: GhcMonad m => + SuccessFlag -> SuccessFlag -> HscEnv + -> m SuccessFlag +loadFinish _all_ok Failed hsc_env + = do liftIO $ unload hsc_env [] + modifySession $ \_ -> discardProg hsc_env + return Failed + +-- Empty the interactive context and set the module context to the topmost +-- newly loaded module, or the Prelude if none were loaded. +loadFinish all_ok Succeeded hsc_env + = do modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext } + return all_ok + + +-- Forget the current program, but retain the persistent info in HscEnv +discardProg :: HscEnv -> HscEnv +discardProg hsc_env + = hsc_env { hsc_mod_graph = emptyMG, + hsc_IC = emptyInteractiveContext, + hsc_HPT = emptyHomePackageTable } + +-- 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 :: [ModSummary] -> [FilePath] +ppFilesFromSummaries summaries = map ms_hspp_file summaries + +-- ----------------------------------------------------------------------------- + +class ParsedMod m where + modSummary :: m -> ModSummary + parsedSource :: m -> ParsedSource + +class ParsedMod m => TypecheckedMod m where + renamedSource :: m -> Maybe RenamedSource + typecheckedSource :: m -> TypecheckedSource + moduleInfo :: m -> ModuleInfo + tm_internals :: m -> (TcGblEnv, ModDetails) + -- ToDo: improvements that could be made here: + -- if the module succeeded renaming but not typechecking, + -- we can still get back the GlobalRdrEnv and exports, so + -- perhaps the ModuleInfo should be split up into separate + -- fields. + +class TypecheckedMod m => DesugaredMod m where + coreModule :: m -> ModGuts + +-- | The result of successful parsing. +data ParsedModule = + ParsedModule { pm_mod_summary :: ModSummary + , pm_parsed_source :: ParsedSource } + +instance ParsedMod ParsedModule where + modSummary m = pm_mod_summary m + parsedSource m = pm_parsed_source m + +-- | The result of successful typechecking. It also contains the parser +-- result. +data TypecheckedModule = + TypecheckedModule { tm_parsed_module :: ParsedModule + , tm_renamed_source :: Maybe RenamedSource + , tm_typechecked_source :: TypecheckedSource + , tm_checked_module_info :: ModuleInfo + , tm_internals_ :: (TcGblEnv, ModDetails) + } + +instance ParsedMod TypecheckedModule where + modSummary m = modSummary (tm_parsed_module m) + parsedSource m = parsedSource (tm_parsed_module m) + +instance TypecheckedMod TypecheckedModule where + renamedSource m = tm_renamed_source m + typecheckedSource m = tm_typechecked_source m + moduleInfo m = tm_checked_module_info m + tm_internals m = tm_internals_ m + +-- | The result of successful desugaring (i.e., translation to core). Also +-- contains all the information of a typechecked module. +data DesugaredModule = + DesugaredModule { dm_typechecked_module :: TypecheckedModule + , dm_core_module :: ModGuts + } + +instance ParsedMod DesugaredModule where + modSummary m = modSummary (dm_typechecked_module m) + parsedSource m = parsedSource (dm_typechecked_module m) + +instance TypecheckedMod DesugaredModule where + renamedSource m = renamedSource (dm_typechecked_module m) + typecheckedSource m = typecheckedSource (dm_typechecked_module m) + moduleInfo m = moduleInfo (dm_typechecked_module m) + tm_internals m = tm_internals_ (dm_typechecked_module m) + +instance DesugaredMod DesugaredModule where + coreModule m = dm_core_module m + +type ParsedSource = Located (HsModule RdrName) +type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], + Maybe (HsDoc Name), HaddockModInfo Name) +type TypecheckedSource = LHsBinds Id + +-- NOTE: +-- - things that aren't in the output of the typechecker right now: +-- - the export list +-- - the imports +-- - type signatures +-- - type/data/newtype declarations +-- - class declarations +-- - instances +-- - extra things in the typechecker's output: +-- - default methods are turned into top-level decls. +-- - dictionary bindings + +-- | Return the 'ModSummary' of a module with the given name. +-- +-- The module must be part of the module graph (see 'hsc_mod_graph' and +-- 'ModuleGraph'). If this is not the case, this function will throw a +-- 'GhcApiError'. +-- +-- This function ignores boot modules and requires that there is only one +-- non-boot module with the given name. +getModSummary :: GhcMonad m => ModuleName -> m ModSummary +getModSummary mod = do + mg <- liftM hsc_mod_graph getSession + case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of + [] -> throw $ mkApiErr (text "Module not part of module graph") + [ms] -> return ms + multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple) + +-- | Parse a module. +-- +-- Throws a 'SourceError' on parse error. +parseModule :: GhcMonad m => ModSummary -> m ParsedModule +parseModule ms = do + hsc_env0 <- getSession + let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } + rdr_module <- parseFile hsc_env ms + return (ParsedModule ms rdr_module) + +-- | Typecheck and rename a parsed module. +-- +-- Throws a 'SourceError' if either fails. +typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule +typecheckModule pmod = do + let ms = modSummary pmod + hsc_env0 <- getSession + let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } + (tc_gbl_env, rn_info) + <- typecheckRenameModule hsc_env ms (parsedSource pmod) + details <- liftIO $ makeSimpleDetails hsc_env tc_gbl_env + return $ + TypecheckedModule { + tm_internals_ = (tc_gbl_env, details), + tm_parsed_module = pmod, + tm_renamed_source = rn_info, + tm_typechecked_source = tcg_binds tc_gbl_env, + tm_checked_module_info = + ModuleInfo { + minf_type_env = md_types details, + minf_exports = availsToNameSet $ md_exports details, + minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), + minf_instances = md_insts details +#ifdef GHCI + ,minf_modBreaks = emptyModBreaks +#endif + }} + +-- | Desugar a typechecked module. +desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule +desugarModule tcm = do + let ms = modSummary tcm + hsc_env0 <- getSession + let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } + let (tcg, _) = tm_internals tcm + guts <- deSugarModule hsc_env ms tcg + return $ + DesugaredModule { + dm_typechecked_module = tcm, + dm_core_module = guts + } + +-- | Load a module. Input doesn't need to be desugared. +-- +-- XXX: Describe usage. + +hscInteractive' hsc_env mod_summary (iface, details, cgguts) + = do + let CgGuts{ -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_foreign = foreign_stubs, + cg_modBreaks = mod_breaks } = cgguts + dflags = hsc_dflags hsc_env +-- location = ms_location mod_summary + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes + ------------------- + -- PREPARE FOR CODE GENERATION + -- Do saturation and convert to A-normal form + prepd_binds <- {-# SCC "CorePrep" #-} + corePrepPgm dflags core_binds data_tycons ; + ----------------- Generate byte code ------------------ + comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks + ------------------ Create f-x-dynamic C-side stuff --- +-- (_istub_h_exists, istub_c_exists) +-- <- outputForeignStubs dflags this_mod location foreign_stubs + clock <- getClockTime + return (LM clock this_mod [BCOs comp_bc emptyModBreaks]) +-- return (Just (InteractiveRecomp istub_c_exists comp_bc mod_breaks, iface, details)) + +loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod +loadModule tcm = do + let ms = modSummary tcm + let mod = ms_mod_name ms + hsc_env0 <- getSession + let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } + let (tcg, details) = tm_internals tcm + (iface,_) <- liftIO $ makeSimpleIface hsc_env Nothing tcg details + modguts <- deSugarModule hsc_env ms tcg + modguts' <- liftIO $ core2core hsc_env modguts + (cgguts, _moddetails) <- liftIO $ tidyProgram hsc_env modguts' + linkable <- liftIO $ hscInteractive' hsc_env ms (iface, details, cgguts) + let mod_info = HomeModInfo { + hm_iface = iface, + hm_details = details, + hm_linkable = Just $ linkable } + let hpt_new = addToUFM (hsc_HPT hsc_env) mod mod_info + modifySession $ \_ -> hsc_env0{ hsc_HPT = hpt_new } + return tcm + +-- | This is the way to get access to the Core bindings corresponding +-- to a module. 'compileToCore' parses, typechecks, and +-- desugars the module, then returns the resulting Core module (consisting of +-- the module name, type declarations, and function declarations) if +-- successful. +compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule +compileToCoreModule = compileCore False + +-- | Like compileToCoreModule, but invokes the simplifier, so +-- as to return simplified and tidied Core. +compileToCoreSimplified :: GhcMonad m => FilePath -> m 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 :: GhcMonad m => FilePath -> m [CoreBind] +compileToCore fn = do + mod <- compileToCoreModule session fn + return $ cm_binds mod +-} +-- | 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 :: GhcMonad m => Bool -> CoreModule -> m () +compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do + hscEnv <- getSession + dflags <- getSessionDynFlags + currentTime <- liftIO $ getClockTime + cwd <- liftIO $ getCurrentDirectory + modLocation <- liftIO $ 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 + } + + ioMsgMaybe $ flip evalComp (CompState{ compHscEnv=hscEnv, + compModSummary=modSummary, + compOldIface=Nothing}) $ + let maybe_simplify mod_guts | simplify = hscSimplify mod_guts + | otherwise = return mod_guts + in maybe_simplify (mkModGuts cm) + >>= hscNormalIface + >>= hscWriteIface + >>= hscOneShot + return () + +-- 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 :: GhcMonad m => Bool -> FilePath -> m CoreModule +compileCore simplify fn = do + -- First, set the target to the desired filename + target <- guessTarget fn Nothing + addTarget target + load LoadAllTargets + -- Then find dependencies + modGraph <- depanal [] True + case find ((== fn) . msHsFilePath) modGraph of + Just modSummary -> do + -- Now we have the module name; + -- parse, typecheck and desugar the module + mod_guts <- coreModule `fmap` + (desugarModule =<< typecheckModule =<< parseModule modSummary) + liftM gutsToCoreModule $ + if simplify + then do + -- If simplify is true: simplify (hscSimplify), then tidy + -- (tidyProgram). + hsc_env <- getSession + simpl_guts <- ioMsg $ evalComp (hscSimplify mod_guts) + (CompState{ + compHscEnv = hsc_env, + compModSummary = modSummary, + compOldIface = Nothing}) + tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts + return $ Left tidy_guts + else + return $ Right mod_guts + + 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 + } + +-- --------------------------------------------------------------------------- +-- Unloading + +unload :: HscEnv -> [Linkable] -> IO () +unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' + = case ghcLink (hsc_dflags hsc_env) of +#ifdef GHCI + LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables +#else + LinkInMemory -> panic "unload: no interpreter" + -- urgh. avoid warnings: + hsc_env stable_linkables +#endif + _other -> return () + +-- ----------------------------------------------------------------------------- + +{- | + + Stability tells us which modules definitely do not need to be recompiled. + There are two main reasons for having stability: + + - avoid doing a complete upsweep of the module graph in GHCi when + modules near the bottom of the tree have not changed. + + - to tell GHCi when it can load object code: we can only load object code + for a module when we also load object code fo all of the imports of the + module. So we need to know that we will definitely not be recompiling + any of these modules, and we can use the object code. + + The stability check is as follows. Both stableObject and + stableBCO are used during the upsweep phase later. + +@ + stable m = stableObject m || stableBCO m + + stableObject m = + all stableObject (imports m) + && old linkable does not exist, or is == on-disk .o + && date(on-disk .o) > date(.hs) + + stableBCO m = + all stable (imports m) + && date(BCO) > date(.hs) +@ + + These properties embody the following ideas: + + - if a module is stable, then: + + - if it has been compiled in a previous pass (present in HPT) + then it does not need to be compiled or re-linked. + + - if it has not been compiled in a previous pass, + then we only need to read its .hi file from disk and + link it to produce a 'ModDetails'. + + - if a modules is not stable, we will definitely be at least + re-linking, and possibly re-compiling it during the 'upsweep'. + All non-stable modules can (and should) therefore be unlinked + before the 'upsweep'. + + - Note that objects are only considered stable if they only depend + on other objects. We can't link object code against byte code. +-} + +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 + :: GhcMonad m => + WarnErrLogger -- ^ Called to print warnings and errors. + -> 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) + -> m (SuccessFlag, + HscEnv, -- With an updated HPT + [ModSummary]) -- Mods which succeeded + +upsweep logger 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 liftIO $ 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 + + mb_mod_info + <- handleSourceError + (\err -> do logger (Just err); return Nothing) $ do + mod_info <- upsweep_mod hsc_env old_hpt stable_mods + mod mod_index nmods + logger Nothing -- log warnings + return (Just mod_info) + + liftIO cleanup -- Remove unwanted tmp files between compilations + + case mb_mod_info of + Nothing -> return (Failed, hsc_env, done) + 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 <- liftIO $ 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 :: GhcMonad m => + HscEnv + -> HomePackageTable + -> ([ModuleName],[ModuleName]) + -> ModSummary + -> Int -- index of module + -> Int -- total number of modules + -> m HomeModInfo + +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 :: GhcMonad m => Maybe Linkable -> m HomeModInfo + compile_it = compile hsc_env summary' mod_index nmods mb_old_iface + + compile_it_discard_iface :: GhcMonad m => + Maybe Linkable -> m HomeModInfo + 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 -> + let Just hmi = old_hmi in + return hmi + -- object is stable, and we have an entry in the + -- old HPT: nothing to do + + | is_stable_obj, isNothing old_hmi -> do + linkable <- liftIO $ findObjectLinkable this_mod obj_fn + (expectJust "upsweep1" 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 + let Just hmi = old_hmi in + return 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 <- liftIO $ 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,_,_) <- 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] + -> 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 be cyclic + +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] + -> (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 +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 :: GhcMonad m => DynFlags -> [SCC ModSummary] -> m () +warnUnnecessarySourceImports dflags sccs = + liftIO $ printBagOfWarnings dflags (listToBag (concatMap (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 :: GhcMonad m => + 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 + -> m [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 + = do -- catch error messages and return them + --handleErrMsg -- should be covered by GhcMonad now + -- (\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 summs + where + roots = hsc_targets hsc_env + + old_summary_map :: NodeMap ModSummary + old_summary_map = mkNodeMap old_summaries + + getRootSummary :: GhcMonad m => Target -> m ModSummary + getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) + = do +-- liftIO $ putStrLn "getRootSummary for TargetFile" + exists <- liftIO $ doesFileExist file + if exists + then summariseFile hsc_env old_summaries file mb_phase + obj_allowed maybe_buf + else throwOneError $ mkPlainErrMsg noSrcSpan $ + text "can't find file:" <+> text file + getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) + = do +-- liftIO $ putStrLn "getRootSummary for TargetModule" + maybe_summary <- summariseModule hsc_env old_summary_map False + (L rootLoc modl) obj_allowed + maybe_buf excl_mods + case maybe_summary of + Nothing -> packageModErr modl + Just s -> return s + + rootLoc = mkGeneralSrcSpan (fsLit "") + + -- 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 :: GhcMonad m => NodeMap [ModSummary] -> m () + checkDuplicates root_map + | allow_dup_roots = return () + | null dup_roots = return () + | otherwise = liftIO $ multiRootsErr (head dup_roots) + where + dup_roots :: [[ModSummary]] -- Each at least of length 2 + dup_roots = filterOut isSingleton (nodeMapElts root_map) + + loop :: GhcMonad m => + [(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 + -> m [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 { liftIO $ multiRootsErr summs; return [] } + | 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) + +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 + :: GhcMonad m => + HscEnv + -> [ModSummary] -- old summaries + -> FilePath -- source file name + -> Maybe Phase -- start phase + -> Bool -- object code allowed? + -> Maybe (StringBuffer,ClockTime) + -> m ModSummary + +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. + | 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 -> liftIO $ 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 <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ getObjTimestamp location False + else return Nothing + 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 hsc_env file mb_phase maybe_buf + + (srcimps,the_imps, L _ mod_name) <- liftIO $ LskFileHandler.getImportsLsk dflags' buf hspp_fn file + + -- Make a ModLocation for this file + location <- liftIO $ 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 <- liftIO $ addHomeModuleToFinder hsc_env mod_name location + + src_timestamp <- case maybe_buf of + Just (_,t) -> return t + Nothing -> liftIO $ getModificationTime file + -- getMofificationTime may fail + + -- 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 liftIO $ modificationTimeIfExists (ml_obj_file location) + else return Nothing + + 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 + :: GhcMonad m => + HscEnv + -> 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 + -> m (Maybe ModSummary) -- Its new summary + +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 + + | 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 <- liftIO $ 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 -> liftIO $ 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 <- liftIO $ + 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. + 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. + liftIO $ uncacheModule hsc_env wanted_mod + found <- liftIO $ FL.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 + + err -> liftIO $ 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 <- liftIO $ 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 hsc_env src_fn Nothing maybe_buf + (srcimps, the_imps, L mod_loc mod_name) <- liftIO $ getImportsLsk dflags' buf hspp_fn src_fn + + when (mod_name /= wanted_mod) $ + throwOneError $ 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 <- liftIO $ + 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, + 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 :: GhcMonad m => + HscEnv + -> FilePath + -> Maybe Phase -- ^ Starting phase + -> Maybe (StringBuffer,ClockTime) + -> m (DynFlags, FilePath, StringBuffer) +preprocessFile hsc_env src_fn mb_phase Nothing + = do + (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) + buf <- liftIO $ hGetStringBuffer hspp_fn + return (dflags', hspp_fn, buf) + +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 dflags buf src_fn + -- + (dflags', leftovers, warns) + <- parseDynamicNoPackageFlags dflags local_opts + liftIO $ checkProcessArgsResult leftovers -- XXX: throws exceptions + liftIO $ handleFlagWarnings dflags' warns -- XXX: throws exceptions + + 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 + = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err + +noHsFileErr :: GhcMonad m => SrcSpan -> String -> m a +noHsFileErr loc path + = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path + +packageModErr :: GhcMonad m => ModuleName -> m a +packageModErr mod + = throwOneError $ mkPlainErrMsg noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> text "is a package module" + +multiRootsErr :: [ModSummary] -> IO () +multiRootsErr [] = panic "multiRootsErr" +multiRootsErr summs@(summ1:_) + = throwOneError $ 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 :: GhcMonad m => m () +workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) + +-- ----------------------------------------------------------------------------- +-- inspecting the session + +-- | Get the module dependency graph. +getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary +getModuleGraph = liftM hsc_mod_graph getSession + +-- | Return @True@ <==> module is loaded. +isLoaded :: GhcMonad m => ModuleName -> m Bool +isLoaded m = withSession $ \hsc_env -> + return $! isJust (lookupUFM (hsc_HPT hsc_env) m) + +-- | Return the bindings for the current interactive session. +getBindings :: GhcMonad m => m [TyThing] +getBindings = withSession $ \hsc_env -> + -- we have to implement the shadowing behaviour of ic_tmp_ids here + -- (see InteractiveContext) and the quickest way is to use an OccEnv. + let + tmp_ids = ic_tmp_ids (hsc_IC hsc_env) + filtered = foldr f (const []) tmp_ids emptyUniqSet + f id rest set + | uniq `elementOfUniqSet` set = rest set + | otherwise = AnId id : rest (addOneToUniqSet set uniq) + where uniq = getUnique (nameOccName (idName id)) + in + return filtered + +getPrintUnqual :: GhcMonad m => m PrintUnqualified +getPrintUnqual = withSession $ \hsc_env -> + return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env)) + +-- | Container for information about a 'Module'. +data ModuleInfo = ModuleInfo { + minf_type_env :: TypeEnv, + minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? + minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod + minf_instances :: [Instance] +#ifdef GHCI + ,minf_modBreaks :: ModBreaks +#endif + -- ToDo: this should really contain the ModIface too + } + -- We don't want HomeModInfo here, because a ModuleInfo applies + -- to package modules too. + +-- | Request information about a loaded 'Module' +getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X +getModuleInfo mdl = withSession $ \hsc_env -> do + let mg = hsc_mod_graph hsc_env + if mdl `elem` map ms_mod mg + then liftIO $ getHomeModuleInfo hsc_env (moduleName mdl) + else do + {- if isHomeModule (hsc_dflags hsc_env) mdl + then return Nothing + else -} liftIO $ getPackageModuleInfo hsc_env mdl + -- getPackageModuleInfo will attempt to find the interface, so + -- we don't want to call it for a home module, just in case there + -- was a problem loading the module and the interface doesn't + -- exist... hence the isHomeModule test here. (ToDo: reinstate) + +getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) +#ifdef GHCI +getPackageModuleInfo hsc_env mdl = do + (_msgs, mb_avails) <- getModuleExports hsc_env mdl + case mb_avails of + Nothing -> return Nothing + Just avails -> do + eps <- readIORef (hsc_EPS hsc_env) + let + names = availsToNameSet avails + pte = eps_PTE eps + tys = [ ty | name <- concatMap availNames avails, + Just ty <- [lookupTypeEnv pte name] ] + -- + return (Just (ModuleInfo { + minf_type_env = mkTypeEnv tys, + minf_exports = names, + minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl), + minf_instances = error "getModuleInfo: instances for package module unimplemented", + minf_modBreaks = emptyModBreaks + })) +#else +getPackageModuleInfo _hsc_env _mdl = do + -- bogusly different for non-GHCI (ToDo) + return Nothing +#endif + +getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo) +getHomeModuleInfo hsc_env mdl = + case lookupUFM (hsc_HPT hsc_env) mdl of + Nothing -> return Nothing + Just hmi -> do + let details = hm_details hmi + return (Just (ModuleInfo { + minf_type_env = md_types details, + minf_exports = availsToNameSet (md_exports details), + minf_rdr_env = mi_globals $! hm_iface hmi, + minf_instances = md_insts details +#ifdef GHCI + ,minf_modBreaks = getModBreaks hmi +#endif + })) + +-- | The list of top-level entities defined in a module +modInfoTyThings :: ModuleInfo -> [TyThing] +modInfoTyThings minf = typeEnvElts (minf_type_env minf) + +modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] +modInfoTopLevelScope minf + = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf) + +modInfoExports :: ModuleInfo -> [Name] +modInfoExports minf = nameSetToList $! minf_exports minf + +-- | Returns the instances defined by the specified module. +-- Warning: currently unimplemented for package modules. +modInfoInstances :: ModuleInfo -> [Instance] +modInfoInstances = minf_instances + +modInfoIsExportedName :: ModuleInfo -> Name -> Bool +modInfoIsExportedName minf name = elemNameSet name (minf_exports minf) + +mkPrintUnqualifiedForModule :: GhcMonad m => + ModuleInfo + -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X +mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do + return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf)) + +modInfoLookupName :: GhcMonad m => + ModuleInfo -> Name + -> m (Maybe TyThing) -- XXX: returns a Maybe X +modInfoLookupName minf name = withSession $ \hsc_env -> do + case lookupTypeEnv (minf_type_env minf) name of + Just tyThing -> return (Just tyThing) + Nothing -> do + eps <- liftIO $ readIORef (hsc_EPS hsc_env) + return $! lookupType (hsc_dflags hsc_env) + (hsc_HPT hsc_env) (eps_PTE eps) name + +#ifdef GHCI +modInfoModBreaks :: ModuleInfo -> ModBreaks +modInfoModBreaks = minf_modBreaks +#endif + +isDictonaryId :: Id -> Bool +isDictonaryId id + = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau } + +-- | Looks up a global name: that is, any top-level name in any +-- visible module. Unlike 'lookupName', lookupGlobalName does not use +-- the interactive context, and therefore does not require a preceding +-- 'setContext'. +lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing) +lookupGlobalName name = withSession $ \hsc_env -> do + eps <- liftIO $ readIORef (hsc_EPS hsc_env) + return $! lookupType (hsc_dflags hsc_env) + (hsc_HPT hsc_env) (eps_PTE eps) name + +#ifdef GHCI +-- | get the GlobalRdrEnv for a session +getGRE :: GhcMonad m => m GlobalRdrEnv +getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) +#endif + +-- ----------------------------------------------------------------------------- +-- Misc exported utils + +dataConType :: DataCon -> Type +dataConType dc = idType (dataConWrapId dc) + +-- | print a 'NamedThing', adding parentheses if the name is an operator. +pprParenSymName :: NamedThing a => a -> SDoc +pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) + +-- ---------------------------------------------------------------------------- + +#if 0 + +-- ToDo: +-- - Data and Typeable instances for HsSyn. + +-- ToDo: check for small transformations that happen to the syntax in +-- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral) + +-- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way +-- to get from TyCons, Ids etc. to TH syntax (reify). + +-- :browse will use either lm_toplev or inspect lm_interface, depending +-- on whether the module is interpreted or not. + +#endif + +-- Extract the filename, stringbuffer content and dynflags associed to a module +-- +-- XXX: Explain pre-conditions +getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags) +getModuleSourceAndFlags mod = do + m <- getModSummary (moduleName mod) + case ml_hs_file $ ms_location m of + Nothing -> throw $ mkApiErr (text "No source available for module " <+> ppr mod) + Just sourceFile -> do + source <- liftIO $ hGetStringBuffer sourceFile + return (sourceFile, source, ms_hspp_opts m) + + +-- | Return module source as token stream, including comments. +-- +-- The module must be in the module graph and its source must be available. +-- Throws a 'HscTypes.SourceError' on parse error. +getTokenStream :: GhcMonad m => Module -> m [Located Token] +getTokenStream mod = do + (sourceFile, source, flags) <- getModuleSourceAndFlags mod + let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0 + case lexTokenStream source startLoc flags of + POk _ ts -> return ts + PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) + +-- | Give even more information on the source than 'getTokenStream' +-- This function allows reconstructing the source completely with +-- 'showRichTokenStream'. +getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] +getRichTokenStream mod = do + (sourceFile, source, flags) <- getModuleSourceAndFlags mod + let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0 + case lexTokenStream source startLoc flags of + POk _ ts -> return $ addSourceToTokens startLoc source ts + PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) + +-- | Given a source location and a StringBuffer corresponding to this +-- location, return a rich token stream with the source associated to the +-- tokens. +addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token] + -> [(Located Token, String)] +addSourceToTokens _ _ [] = [] +addSourceToTokens loc buf (t@(L span _) : ts) + | not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts + | otherwise = (t,str) : addSourceToTokens newLoc newBuf ts + where + (newLoc, newBuf, str) = go "" loc buf + start = srcSpanStart span + end = srcSpanEnd span + go acc loc buf | loc < start = go acc nLoc nBuf + | start <= loc && loc < end = go (ch:acc) nLoc nBuf + | otherwise = (loc, buf, reverse acc) + where (ch, nBuf) = nextChar buf + nLoc = advanceSrcLoc loc ch + + +-- | Take a rich token stream such as produced from 'getRichTokenStream' and +-- return source code almost identical to the original code (except for +-- insignificant whitespace.) +showRichTokenStream :: [(Located Token, String)] -> String +showRichTokenStream ts = go startLoc ts "" + where sourceFile = srcSpanFile (getLoc . fst . head $ ts) + startLoc = mkSrcLoc sourceFile 0 0 + go _ [] = id + go loc ((L span _, str):ts) + | not (isGoodSrcSpan span) = go loc ts + | locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++) + . (str ++) + . go tokEnd ts + | otherwise = ((replicate (tokLine - locLine) '\n') ++) + . ((replicate tokCol ' ') ++) + . (str ++) + . go tokEnd ts + where (locLine, locCol) = (srcLocLine loc, srcLocCol loc) + (tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span) + tokEnd = srcSpanEnd span + +-- ----------------------------------------------------------------------------- +-- Interactive evaluation + +-- | 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 :: GhcMonad m => ModuleName -> Maybe FastString -> m Module +findModule mod_name maybe_pkg = withSession $ \hsc_env -> liftIO $ -- XXX + let + dflags = hsc_dflags hsc_env + hpt = hsc_HPT hsc_env + this_pkg = thisPackage dflags + in + case lookupUFM hpt mod_name of + Just mod_info -> return (mi_module (hm_iface mod_info)) + _not_a_home_module -> do + res <- findImportedModule hsc_env mod_name maybe_pkg + case res of + Found _ m | modulePackageId m /= this_pkg -> return m + | otherwise -> ghcError (CmdLineError (showSDoc $ + text "module" <+> quotes (ppr (moduleName m)) <+> + text "is not loaded. QUAK!")) + err -> let msg = cannotFindModule dflags mod_name err in + ghcError (CmdLineError (showSDoc msg)) + +#ifdef GHCI +getHistorySpan :: GhcMonad m => History -> m SrcSpan +getHistorySpan h = withSession $ \hsc_env -> + return$ InteractiveEval.getHistorySpan hsc_env h + +obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term +obtainTermFromVal bound force ty a = + withSession $ \hsc_env -> + liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a + +obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term +obtainTermFromId bound force id = + withSession $ \hsc_env -> + liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id + +#endif + +compileHsExpr -- Compile a stmt all the way to an HValue, but don't run it + :: GhcMonad m => + HscEnv + -> LHsExpr RdrName -- The statement + -> TcM Type + -> m (Maybe HValue) + -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error +compileHsExpr hsc_env rdr_expr get_expr_type = do + let ictxt = hsc_IC hsc_env + (msg,maybe_tc_expr) <- liftIO $ + initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext' hsc_env ictxt $ do { + (rn_expr, fvs) <- rnLExpr rdr_expr ; + failIfErrsM ; + expr_type <- get_expr_type; + (tc_expr, lie) <- getLIE $ tcMonoExpr rn_expr expr_type; + const_binds <- tcSimplifyTop lie; + tc_expr' <- zonkTopLExpr (mkHsDictLet const_binds tc_expr); + return tc_expr'; + } + liftIO $ printErrorsAndWarnings (hsc_dflags hsc_env) msg + case maybe_tc_expr of + Nothing -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg noSrcSpan (text "Type checking failed")) + (Just tc_expr) -> do + let rdr_env = ic_rn_gbl_env ictxt + type_env = mkTypeEnv (map AnId (ic_tmp_ids ictxt)) + ds_expr <- ioMsgMaybe $ + deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr + let src_span = srcLocSpan interactiveSrcLoc +-- liftIO $ Linker.initDynLinker (hsc_dflags hsc_env) +-- liftIO $ Linker.showLinkerState + hval <- liftIO $ HscMain.compileExpr hsc_env src_span ds_expr +-- liftIO $ Linker.showLinkerState + return $ Just hval + where + smpl_doc = ptext (sLit "main expression") + addfile ./GHCSalat/GHC4Lsk.hs-boot hunk ./GHCSalat/GHC4Lsk.hs-boot 1 +module GHCSalat.GHC4Lsk (ParsedMod,loadModule,typecheckModule,runGhc,setSessionDynFlags,getSessionDynFlags,findModule,ParsedModule(..),compileHsExpr,setTargets,LoadHowMuch(..),load,unload) where +import GHCSalat.GhciMonad +import HscTypes +import Module +import FastString +import DynFlags +import SrcLoc +import HsSyn +import RdrName +import TcRnTypes hiding (LIE) +import Name +import Var +import ByteCodeLink +import BasicTypes +import TypeRep + +findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module + +getSessionDynFlags :: GhcMonad m => m DynFlags + +setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId] + +runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. + -> Ghc a -- ^ The action to perform. + -> IO a + +loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod + +typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule + +class ParsedMod m => TypecheckedMod m where + renamedSource :: m -> Maybe RenamedSource + typecheckedSource :: m -> TypecheckedSource + moduleInfo :: m -> ModuleInfo + tm_internals :: m -> (TcGblEnv, ModDetails) + -- ToDo: improvements that could be made here: + -- if the module succeeded renaming but not typechecking, + -- we can still get back the GlobalRdrEnv and exports, so + -- perhaps the ModuleInfo should be split up into separate + -- fields. + +class ParsedMod m where + +data TypecheckedModule +type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], + Maybe (HsDoc Name), HaddockModInfo Name) +type TypecheckedSource = LHsBinds Id + +data ParsedModule = + ParsedModule { pm_mod_summary :: ModSummary + , pm_parsed_source :: ParsedSource } +type ParsedSource = Located (HsModule RdrName) + + +instance TypecheckedMod TypecheckedModule where + +data ModuleInfo + +compileHsExpr -- Compile a stmt all the way to an HValue, but don't run it + :: GhcMonad m => + HscEnv + -> LHsExpr RdrName -- The statement + -> TcM Type + -> m (Maybe HValue) + +setTargets :: GhcMonad m => [Target] -> m () + +data LoadHowMuch + = LoadAllTargets + | LoadUpTo ModuleName + | LoadDependenciesOf ModuleName + +load :: GhcMonad m => LoadHowMuch -> m SuccessFlag + +unload :: HscEnv -> [Linkable] -> IO () addfile ./GHCSalat/GhciMonad.hs hunk ./GHCSalat/GhciMonad.hs 1 +{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +----------------------------------------------------------------------------- +-- +-- Monadery code used in InteractiveUI +-- +-- (c) The GHC Team 2005-2006 +-- +----------------------------------------------------------------------------- + +module GHCSalat.GhciMonad where + +#include "HsVersions4Lsk.h" + +import qualified GHC +import Outputable hiding (printForUser, printForUserPartWay) +import qualified Outputable +import qualified Pretty +import Panic hiding (showException) +import Util +import DynFlags +import HscTypes hiding (liftIO) +import SrcLoc +import Module +import ObjLink +import Linker +import StaticFlags +import qualified MonadUtils as MonadUtils +import qualified ErrUtils as ErrUtils + +import Exception +import Data.Maybe +import Numeric +import Data.Array +import Data.Char +import Data.Int ( Int64 ) +import Data.IORef +import Data.List +import System.CPUTime +import System.Environment +import System.IO +import Control.Monad as Monad +import GHC.Exts + +import System.Console.Haskeline (CompletionFunc, InputT) +import qualified System.Console.Haskeline as Haskeline +import System.Console.Haskeline.Encoding +import Control.Monad.Trans as Trans +import qualified Data.ByteString as B + +----------------------------------------------------------------------------- +-- GHCi monad + +type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi) + +data GHCiState = GHCiState + { + progname :: String, + args :: [String], + prompt :: String, + editor :: String, + stop :: String, + options :: [GHCiOption], + prelude :: GHC.Module, + break_ctr :: !Int, + breaks :: ![(Int, BreakLocation)], + tickarrays :: ModuleEnv TickArray, + -- tickarrays caches the TickArray for loaded modules, + -- so that we don't rebuild it each time the user sets + -- a breakpoint. + -- ":" at the GHCi prompt repeats the last command, so we + -- remember is here: + last_command :: Maybe Command, + cmdqueue :: [String], + remembered_ctx :: [(CtxtCmd, [String], [String])], + -- we remember the :module commands between :loads, so that + -- on a :reload we can replay them. See bugs #2049, + -- \#1873, #1360. Previously we tried to remember modules that + -- were supposed to be in the context but currently had errors, + -- but this was complicated. Just replaying the :module commands + -- seems to be the right thing. + ghc_e :: Bool -- True if this is 'ghc -e' (or runghc) + } + +data CtxtCmd + = SetContext + | AddModules + | RemModules + +type TickArray = Array Int [(BreakIndex,SrcSpan)] + +data GHCiOption + = ShowTiming -- show time/allocs after evaluation + | ShowType -- show the type of expressions + | RevertCAFs -- revert CAFs after every evaluation + deriving Eq + +data BreakLocation + = BreakLocation + { breakModule :: !GHC.Module + , breakLoc :: !SrcSpan + , breakTick :: {-# UNPACK #-} !Int + , onBreakCmd :: String + } + +instance Eq BreakLocation where + loc1 == loc2 = breakModule loc1 == breakModule loc2 && + breakTick loc1 == breakTick loc2 + +prettyLocations :: [(Int, BreakLocation)] -> SDoc +prettyLocations [] = text "No active breakpoints." +prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs + +instance Outputable BreakLocation where + ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+> + if null (onBreakCmd loc) + then empty + else doubleQuotes (text (onBreakCmd loc)) + +recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int) +recordBreak brkLoc = do + st <- getGHCiState + let oldActiveBreaks = breaks st + -- don't store the same break point twice + case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of + (nm:_) -> return (True, nm) + [] -> do + let oldCounter = break_ctr st + newCounter = oldCounter + 1 + setGHCiState $ st { break_ctr = newCounter, + breaks = (oldCounter, brkLoc) : oldActiveBreaks + } + return (False, oldCounter) + +newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a } + +reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a +reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s + +reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a +reifyGHCi f = GHCi f' + where + -- f' :: IORef GHCiState -> Ghc a + f' gs = reifyGhc (f'' gs) + -- f'' :: IORef GHCiState -> Session -> IO a + f'' gs s = f (s, gs) + +startGHCi :: GHCi a -> GHCiState -> Ghc a +startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref + +instance Monad GHCi where + (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s + return a = GHCi $ \_ -> return a + +instance Functor GHCi where + fmap f m = m >>= return . f + +ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a +ghciHandleGhcException = handleGhcException + +getGHCiState :: GHCi GHCiState +getGHCiState = GHCi $ \r -> liftIO $ readIORef r +setGHCiState :: GHCiState -> GHCi () +setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s + +liftGhc :: Ghc a -> GHCi a +liftGhc m = GHCi $ \_ -> m + +instance MonadUtils.MonadIO GHCi where + liftIO = liftGhc . MonadUtils.liftIO + +instance Trans.MonadIO Ghc where + liftIO = MonadUtils.liftIO + +instance GhcMonad GHCi where + setSession s' = liftGhc $ setSession s' + getSession = liftGhc $ getSession + +instance GhcMonad (InputT GHCi) where + setSession = lift . setSession + getSession = lift getSession + +instance MonadUtils.MonadIO (InputT GHCi) where + liftIO = Trans.liftIO + +instance WarnLogMonad (InputT GHCi) where + setWarnings = lift . setWarnings + getWarnings = lift getWarnings + +instance ExceptionMonad GHCi where + gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r) + gblock (GHCi m) = GHCi $ \r -> gblock (m r) + gunblock (GHCi m) = GHCi $ \r -> gunblock (m r) + +instance WarnLogMonad GHCi where + setWarnings warns = liftGhc $ setWarnings warns + getWarnings = liftGhc $ getWarnings + +instance MonadIO GHCi where + liftIO = io + +instance Haskeline.MonadException GHCi where + catch = gcatch + block = gblock + unblock = gunblock + +instance ExceptionMonad (InputT GHCi) where + gcatch = Haskeline.catch + gblock = Haskeline.block + gunblock = Haskeline.unblock + +-- for convenience... +getPrelude :: GHCi Module +getPrelude = getGHCiState >>= return . prelude + +getDynFlags :: GhcMonad m => m DynFlags +getDynFlags = do + GHC.getSessionDynFlags + +setDynFlags :: DynFlags -> GHCi [PackageId] +setDynFlags dflags = do + GHC.setSessionDynFlags dflags + +isOptionSet :: GHCiOption -> GHCi Bool +isOptionSet opt + = do st <- getGHCiState + return (opt `elem` options st) + +setOption :: GHCiOption -> GHCi () +setOption opt + = do st <- getGHCiState + setGHCiState (st{ options = opt : filter (/= opt) (options st) }) + +unsetOption :: GHCiOption -> GHCi () +unsetOption opt + = do st <- getGHCiState + setGHCiState (st{ options = filter (/= opt) (options st) }) + +io :: IO a -> GHCi a +io = MonadUtils.liftIO + +printForUser :: SDoc -> GHCi () +printForUser doc = do + unqual <- GHC.getPrintUnqual + io $ Outputable.printForUser stdout unqual doc + +printForUser' :: SDoc -> InputT GHCi () +printForUser' doc = do + unqual <- GHC.getPrintUnqual + Haskeline.outputStrLn $ showSDocForUser unqual doc + +printForUserPartWay :: SDoc -> GHCi () +printForUserPartWay doc = do + unqual <- GHC.getPrintUnqual + io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc + +-- We set log_action to write encoded output. +-- This fails whenever GHC tries to mention an (already encoded) filename, +-- but I don't know how to work around that. +setLogAction :: InputT GHCi () +setLogAction = do + encoder <- getEncoder + dflags <- GHC.getSessionDynFlags + GHC.setSessionDynFlags dflags {log_action = logAction encoder} + return () + where + logAction encoder severity srcSpan style msg = case severity of + GHC.SevInfo -> printEncErrs encoder (msg style) + GHC.SevFatal -> printEncErrs encoder (msg style) + _ -> do + hPutChar stderr '\n' + printEncErrs encoder (ErrUtils.mkLocMessage srcSpan msg style) + printEncErrs encoder doc = do + str <- encoder (Pretty.showDocWith Pretty.PageMode doc) + B.hPutStrLn stderr str + hFlush stderr + +runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult +runStmt expr step = do + st <- getGHCiState + reifyGHCi $ \x -> + withProgName (progname st) $ + withArgs (args st) $ + reflectGHCi x $ do + GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e + return GHC.RunFailed) $ do + GHC.runStmt expr step + +resume :: (GHC.SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult +resume canLogSpan step = GHC.resume canLogSpan step + +-- -------------------------------------------------------------------------- +-- timing & statistics + +timeIt :: InputT GHCi a -> InputT GHCi a +timeIt action + = do b <- lift $ isOptionSet ShowTiming + if not b + then action + else do allocs1 <- liftIO $ getAllocations + time1 <- liftIO $ getCPUTime + a <- action + allocs2 <- liftIO $ getAllocations + time2 <- liftIO $ getCPUTime + liftIO $ printTimes (fromIntegral (allocs2 - allocs1)) + (time2 - time1) + return a + +foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64 + -- defined in ghc/rts/Stats.c + +printTimes :: Integer -> Integer -> IO () +printTimes allocs psecs + = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float + secs_str = showFFloat (Just 2) secs + putStrLn (showSDoc ( + parens (text (secs_str "") <+> text "secs" <> comma <+> + text (show allocs) <+> text "bytes"))) + +----------------------------------------------------------------------------- +-- reverting CAFs + +revertCAFs :: GHCi () +revertCAFs = do + io $ rts_revertCAFs + s <- getGHCiState + when (not (ghc_e s)) $ io turnOffBuffering + -- Have to turn off buffering again, because we just + -- reverted stdout, stderr & stdin to their defaults. + +foreign import ccall "revertCAFs" rts_revertCAFs :: IO () + -- Make it "safe", just in case + +----------------------------------------------------------------------------- +-- To flush buffers for the *interpreted* computation we need +-- to refer to *its* stdout/stderr handles + +GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ()) +GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ()) +GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ()) + +-- After various attempts, I believe this is the least bad way to do +-- what we want. We know look up the address of the static stdin, +-- stdout, and stderr closures in the loaded base package, and each +-- time we need to refer to them we cast the pointer to a Handle. +-- This avoids any problems with the CAF having been reverted, because +-- we'll always get the current value. +-- +-- The previous attempt that didn't work was to compile an expression +-- like "hSetBuffering stdout NoBuffering" into an expression of type +-- IO () and run this expression each time we needed it, but the +-- problem is that evaluating the expression might cache the contents +-- of the Handle rather than referring to it from its static address +-- each time. There's no safe workaround for this. + +initInterpBuffering :: Ghc () +initInterpBuffering = do -- make sure these are linked + dflags <- GHC.getSessionDynFlags + liftIO $ do + initDynLinker dflags + + -- ToDo: we should really look up these names properly, but + -- it's a fiddle and not all the bits are exposed via the GHC + -- interface. + mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure" + mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure" + mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure" + + let f ref (Just ptr) = writeIORef ref ptr + f _ Nothing = panic "interactiveUI:setBuffering2" + zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr] + [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr] + return () + +flushInterpBuffers :: GHCi () +flushInterpBuffers + = io $ do getHandle stdout_ptr >>= hFlush + getHandle stderr_ptr >>= hFlush + +turnOffBuffering :: IO () +turnOffBuffering + = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr] + mapM_ (\h -> hSetBuffering h NoBuffering) hdls + +getHandle :: IORef (Ptr ()) -> IO Handle +getHandle ref = do + (Ptr addr) <- readIORef ref + case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval) addfile ./GHCSalat/HsVersions4Lsk.h hunk ./GHCSalat/HsVersions4Lsk.h 1 +#define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else +#define ASSERT2(e,msg) if False && (const False (e,msg)) then pprPanic "ASSERT2" (msg) else +#if !defined(GHCI) +#define GHCI +#endif + +#define GLOBAL_VAR(name,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = Util.global (value); + + +#include + addfile ./GHCSalat/HscMain4Lsk.hs hunk ./GHCSalat/HscMain4Lsk.hs 1 +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 +-- + +module GHCSalat.HscMain4Lsk where +import TcRnMonad ( initIfaceCheck, TcGblEnv(..) ) +import TcIface ( typecheckIface ) +import ErrUtils +import HscTypes +import CorePrep ( corePrepPgm ) +import TyCon ( isDataTyCon ) +import CodeGen ( codeGen ) +import System.IO +import Data.IORef +import Panic +import DynFlags +import CmmInfo +import CodeOutput ( codeOutput ) +import TidyPgm +import MkIface +import Bag ( unitBag, emptyBag, unionBags ) +import qualified HscMain as HM +import SimplCore ( core2core ) +import MonadUtils +import LoadIface ( ifaceStats, initExternalPackageState ) +import Module +import CoreSyn +import StgSyn +import Id ( Id ) +import CostCentre +import Cmm ( Cmm ) +import CoreToStg ( coreToStg ) +import SimplStg ( stg2stg ) +import CmmCPS +import TcRnDriver ( tcRnModule ) +import Desugar ( deSugar ) +import Outputable +import UniqSupply ( mkSplitUniqSupply ) +import CmmTx +import CmmContFlowOpt +import CmmCvt +import UniqSupply ( initUs_ ) +import CmmCPSZ +import Parser +import Lexer +import SrcLoc ( mkSrcLoc ) +import SrcLoc ( Located(..) ) +import HsSyn +import RdrName +import StringBuffer +import FastString +import Control.Monad +import System.Exit +import HscStats ( ppSourceStats ) +import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) +import CodeOutput ( outputForeignStubs ) +import LskFileHandler +import LskToHs +import LskTransformationMonad +import LazyUniqFM + +hscNormalIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, CgGuts) +hscNormalIface guts = do + state <- gets id + (msgs,a) <- liftIO $ HM.evalComp (HM.hscNormalIface guts) (state :: HM.CompState) + logMsgs msgs + return a + +hscWriteIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a) +hscWriteIface details = do + state <- gets id + (msgs,a) <- liftIO $ HM.evalComp (HM.hscWriteIface details) (state :: HM.CompState) + logMsgs msgs + return a + +compHscEnv = HM.compHscEnv +compModSummary = HM.compModSummary +compOldIface = HM.compOldIface + + +hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails) +hscCompileBatch + = hscCompiler norecompBatch batchMsg (genComp backend boot_backend) + where + backend inp = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscBatch + boot_backend inp = hscSimpleIface inp >>= hscWriteIface >>= hscNothing + +data HscStatus + = HscNoRecomp + | HscRecomp Bool -- Has stub files. + -- This is a hack. We can't compile C files here + -- since it's done in DriverPipeline. For now we + -- just return True if we want the caller to compile + -- them for us. +-- Status of a compilation to byte-code. +data InteractiveStatus + = InteractiveNoRecomp + | InteractiveRecomp Bool -- Same as HscStatus + CompiledByteCode + ModBreaks + +norecompBatch :: NoRecomp (HscStatus, ModIface, ModDetails) +norecompBatch = norecompWorker HscNoRecomp False + +norecompWorker :: a -> Bool -> NoRecomp (a, ModIface, ModDetails) +norecompWorker a _isInterp old_iface + = do hsc_env <- gets compHscEnv + liftIO $ do + new_details <- {-# SCC "tcRnIface" #-} + initIfaceCheck hsc_env $ + typecheckIface old_iface + dumpIfaceStats hsc_env + return (a, old_iface, new_details) + + +batchMsg :: Maybe (Int,Int) -> Bool -> Comp () +batchMsg mb_mod_index recomp + = do hsc_env <- gets compHscEnv + mod_summary <- gets compModSummary + let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $ + (showModuleIndex mb_mod_index ++ + msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary) + liftIO $ do + if recomp + then showMsg "Compiling " + else if verbosity (hsc_dflags hsc_env) >= 2 + then showMsg "Skipping " + else return () + +hscSimpleIface :: TcGblEnv -> Comp (ModIface, Bool, ModDetails, TcGblEnv) +hscSimpleIface tc_result + = do hsc_env <- gets compHscEnv + maybe_old_iface <- gets compOldIface + liftIO $ do + details <- mkBootModDetailsTc hsc_env tc_result + (new_iface, no_change) + <- {-# SCC "MkFinalIface" #-} + mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result + -- And the answer is ... + dumpIfaceStats hsc_env + return (new_iface, no_change, details, tc_result) + +hscNothing :: (ModIface, ModDetails, a) -> Comp (Maybe (HscStatus, ModIface, ModDetails)) +hscNothing (iface, details, _) + = return (Just (HscRecomp False, iface, details)) + + +hscSimplify :: ModGuts -> Comp ModGuts +hscSimplify ds_result + = do hsc_env <- gets compHscEnv + liftIO $ do + ------------------- + -- SIMPLIFY + ------------------- + simpl_result <- {-# SCC "Core2Core" #-} + core2core hsc_env ds_result + return simpl_result + +-------------------------------------------------------------- +-- BackEnd combinators +-------------------------------------------------------------- + +-- Generate code and return both the new ModIface and the ModDetails. +hscBatch :: (ModIface, ModDetails, CgGuts) -> Comp (Maybe (HscStatus, ModIface, ModDetails)) +hscBatch (iface, details, cgguts) + = do hasStub <- hscCompile cgguts + return (Just (HscRecomp hasStub, iface, details)) + +-- Compile to hard-code. +hscCompile :: CgGuts -> Comp Bool +hscCompile cgguts + = do hsc_env <- gets compHscEnv + mod_summary <- gets compModSummary + liftIO $ do + let CgGuts{ -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_dir_imps = dir_imps, + cg_foreign = foreign_stubs, + cg_dep_pkgs = dependencies, + cg_hpc_info = hpc_info } = cgguts + dflags = hsc_dflags hsc_env + location = ms_location mod_summary + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes + + ------------------- + -- PREPARE FOR CODE GENERATION + -- Do saturation and convert to A-normal form + prepd_binds <- {-# SCC "CorePrep" #-} + corePrepPgm dflags core_binds data_tycons ; + ----------------- Convert to STG ------------------ + (stg_binds, cost_centre_info) + <- {-# SCC "CoreToStg" #-} + myCoreToStg dflags this_mod prepd_binds + ------------------ Code generation ------------------ + cmms <- {-# SCC "CodeGen" #-} + codeGen dflags this_mod data_tycons + dir_imps cost_centre_info + stg_binds hpc_info + --- Optionally run experimental Cmm transformations --- + cmms <- optionallyConvertAndOrCPS hsc_env cmms + -- unless certain dflags are on, the identity function + ------------------ Code output ----------------------- + rawcmms <- cmmToRawCmm cmms + (_stub_h_exists, stub_c_exists) + <- codeOutput dflags this_mod location foreign_stubs + dependencies rawcmms + return stub_c_exists + + +hscCompiler + :: NoRecomp result -- No recomp necessary + -> (Maybe (Int,Int) -> Bool -> Comp ()) -- Message callback + -> Comp (Maybe result) + -> Compiler result +hscCompiler norecomp messenger recomp hsc_env mod_summary + source_unchanged mbOldIface mbModIndex + = do + -- liftIO $ putStrLn ("hscCompiler home package table length " ++ (show (length $ ufmToList $ (hsc_HPT hsc_env)))) + ioMsgMaybe $ + flip evalComp (HM.CompState hsc_env mod_summary mbOldIface) $ + do (recomp_reqd, mbCheckedIface) + <- {-# SCC "checkOldIface" #-} + liftIO $ checkOldIface hsc_env mod_summary + source_unchanged mbOldIface + -- save the interface that comes back from checkOldIface. + -- In one-shot mode we don't have the old iface until this + -- point, when checkOldIface reads it from the disk. + modify (\s -> s{ HM.compOldIface = mbCheckedIface }) + case mbCheckedIface of + Just iface | not recomp_reqd + -> do messenger mbModIndex False + result <- norecomp iface + return (Just result) + _otherwise + -> do messenger mbModIndex True + recomp + +-- the usual way to build the Comp (Maybe result) to pass to hscCompiler +genComp :: (ModGuts -> Comp (Maybe a)) + -> (TcGblEnv -> Comp (Maybe a)) + -> Comp (Maybe a) +genComp backend boot_backend = do + mod_summary <- gets compModSummary + case ms_hsc_src mod_summary of + ExtCoreFile -> do + panic "GHC does not currently support reading External Core files" + _not_core -> do + mb_tc <- hscFileFrontEnd + case mb_tc of + Nothing -> return Nothing + Just tc_result -> + case ms_hsc_src mod_summary of + HsBootFile -> boot_backend tc_result + _other -> do + mb_guts <- hscDesugar tc_result + case mb_guts of + Nothing -> return Nothing + Just guts -> backend guts + + +-- I want Control.Monad.State! --Lemmih 03/07/2006 +newtype Comp a = Comp {runComp :: HM.CompState -> IORef Messages -> IO (a, HM.CompState)} + +instance Monad Comp where + g >>= fn = Comp $ \s r -> runComp g s r >>= \(a,s') -> runComp (fn a) s' r + return a = Comp $ \s _ -> return (a,s) + fail = error + +evalComp :: Comp a -> HM.CompState -> IO (Messages, a) +evalComp comp st = do r <- newIORef emptyMessages + (val,_st') <- runComp comp st r + msgs <- readIORef r + return (msgs, val) + +logMsgs :: Messages -> Comp () +logMsgs (warns', errs') = Comp $ \s r -> do + (warns, errs) <- readIORef r + writeIORef r $! ( warns' `unionBags` warns + , errs' `unionBags` errs ) + return ((), s) + +get :: Comp HM.CompState +get = Comp $ \s _ -> return (s,s) + +modify :: (HM.CompState -> HM.CompState) -> Comp () +modify f = Comp $ \s _ -> return ((), f s) + +gets :: (HM.CompState -> a) -> Comp a +gets getter = do st <- get + return (getter st) + +instance MonadIO Comp where + liftIO ioA = Comp $ \s _ -> do a <- ioA; return (a,s) + +type NoRecomp result = ModIface -> Comp result + +-- FIXME: The old interface and module index are only using in 'batch' and +-- 'interactive' mode. They should be removed from 'oneshot' mode. +type Compiler result = GhcMonad m => + HscEnv + -> ModSummary + -> Bool -- True <=> source unchanged + -> Maybe ModIface -- Old interface, if available + -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs) + -> m result + +dumpIfaceStats :: HscEnv -> IO () +dumpIfaceStats hsc_env + = do { eps <- readIORef (hsc_EPS hsc_env) + ; dumpIfSet (dump_if_trace || dump_rn_stats) + "Interface statistics" + (ifaceStats eps) } + where + dflags = hsc_dflags hsc_env + dump_rn_stats = dopt Opt_D_dump_rn_stats dflags + dump_if_trace = dopt Opt_D_dump_if_trace dflags + +showModuleIndex :: Maybe (Int, Int) -> String +showModuleIndex Nothing = "" +showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] " + where + n_str = show n + i_str = show i + padded = replicate (length n_str - length i_str) ' ' ++ i_str + +myCoreToStg :: DynFlags -> Module -> [CoreBind] + -> IO ( [(StgBinding,[(Id,[Id])])] -- output program + , CollectedCCs) -- cost centre info (declared and used) + +myCoreToStg dflags this_mod prepd_binds + = do + stg_binds <- {-# SCC "Core2Stg" #-} + coreToStg (thisPackage dflags) prepd_binds + + (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-} + stg2stg dflags this_mod stg_binds + + return (stg_binds2, cost_centre_info) + +optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm] +optionallyConvertAndOrCPS hsc_env cmms = + do let dflags = hsc_dflags hsc_env + -------- Optionally convert to and from zipper ------ + cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags + then mapM (testCmmConversion hsc_env) cmms + else return cmms + --------- Optionally convert to CPS (MDA) ----------- + cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) && + dopt Opt_RunCPSZ dflags + then cmmCPS dflags cmms + else return cmms + return cmms + +hscFileFrontEnd :: Comp (Maybe TcGblEnv) +hscFileFrontEnd = + do hsc_env <- gets compHscEnv + mod_summary <- gets compModSummary + + ------------------- + -- PARSE + ------------------- + let dflags = hsc_dflags hsc_env + hspp_file = ms_hspp_file mod_summary + hspp_buf = ms_hspp_buf mod_summary + + maybe_parsed <- + if isLiskellSrcFilename hspp_file then + liftIO $ myParseLiskellModule dflags hspp_file hspp_buf (newFreshVarStream (moduleNameString $ ms_mod_name mod_summary)) hsc_env + else + liftIO $ myParseModule dflags hspp_file hspp_buf + case maybe_parsed of + Left err + -> do logMsgs (emptyBag, unitBag err) + return Nothing + Right rdr_module + ------------------- + -- RENAME and TYPECHECK + ------------------- + -> do (tc_msgs, maybe_tc_result) + <- {-# SCC "Typecheck-Rename" #-} + liftIO $ tcRnModule hsc_env (ms_hsc_src mod_summary) + False rdr_module + logMsgs tc_msgs + return maybe_tc_result + +-------------------------------------------------------------- +-- Desugaring +-------------------------------------------------------------- + +hscDesugar :: TcGblEnv -> Comp (Maybe ModGuts) +hscDesugar tc_result + = do mod_summary <- gets compModSummary + hsc_env <- gets compHscEnv + + ------------------- + -- DESUGAR + ------------------- + (msgs, ds_result) + <- {-# SCC "DeSugar" #-} + liftIO $ deSugar hsc_env (ms_location mod_summary) tc_result + logMsgs msgs + return ds_result + +testCmmConversion :: HscEnv -> Cmm -> IO Cmm +testCmmConversion hsc_env cmm = + do let dflags = hsc_dflags hsc_env + showPass dflags "CmmToCmm" + dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm) + --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm + us <- mkSplitUniqSupply 'C' + let cfopts = runTx $ runCmmOpts cmmCfgOptsZ + let cvtm = do g <- cmmToZgraph cmm + return $ cfopts g + let zgraph = initUs_ us cvtm + cps_zgraph <- protoCmmCPSZ hsc_env zgraph + let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph + dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph) + showPass dflags "Convert from Z back to Cmm" + let cvt = cmmOfZgraph $ cfopts $ chosen_graph + dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt) + return cvt + -- return cmm -- don't use the conversion + + +myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer + -> IO (Either ErrMsg (Located (HsModule RdrName))) +myParseModule dflags src_filename maybe_src_buf + = -------------------------- Parser ---------------- + showPass dflags "Parser" >> + {-# SCC "Parser" #-} do + + -- sometimes we already have the buffer in memory, perhaps + -- because we needed to parse the imports out of it, or get the + -- module name. + buf <- case maybe_src_buf of + Just b -> return b + Nothing -> hGetStringBuffer src_filename + + let loc = mkSrcLoc (mkFastString src_filename) 1 0 + + case unP parseModule (mkPState buf loc dflags) of { + + PFailed span err -> return (Left (mkPlainErrMsg span err)); + + POk pst rdr_module -> do { + + let {ms = getMessages pst}; + printErrorsAndWarnings dflags ms; -- XXX + when (errorsFound dflags ms) $ exitWith (ExitFailure 1); + + dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; + + dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" + (ppSourceStats False rdr_module) ; + + return (Right rdr_module) + -- ToDo: free the string buffer later. + }} + +myParseLiskellModule dflags src_filename maybe_src_buf fresh_var_stream hsc_env + = -------------------------- Parser ---------------- + showPass dflags "Parser" >> + {-# SCC "Parser" #-} do + + -- sometimes we already have the buffer in memory, perhaps + -- because we needed to parse the imports out of it, or get the + -- module name. + buf <- case maybe_src_buf of + Just b -> return b + Nothing -> hGetStringBuffer src_filename + + let loc = mkSrcLoc (mkFastString src_filename) 1 0 + + env <- seedLskTrfEnv + + module_t <- runTM (liskell_transform_source buf loc) (TransformationState env hsc_env fresh_var_stream ([], [])) + + case module_t of { + + (Left (TrErr span err)) -> return (Left (mkPlainErrMsg span err)); + + Right (new_fresh_vars,rdr_module) -> + do { + dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module); + dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" (ppSourceStats False rdr_module); + + return (Right rdr_module) + -- ToDo: free the string buffer later. + }} + +-- Type-check Haskell and .hs-boot only (no external core) +hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails) +hscCompileNothing + = hscCompiler norecompBatch batchMsg comp + where + backend tc = hscSimpleIface tc >>= hscIgnoreIface >>= hscNothing + + comp = do -- genComp doesn't fit here, because we want to omit + -- desugaring and for the backend to take a TcGblEnv + mod_summary <- gets compModSummary + case ms_hsc_src mod_summary of + ExtCoreFile -> panic "hscCompileNothing: cannot do external core" + _other -> do + mb_tc <- hscFileFrontEnd + case mb_tc of + Nothing -> return Nothing + Just tc_result -> backend tc_result + +hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a) +hscIgnoreIface (iface, _no_change, details, a) + = return (iface, details, a) + +hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails) +hscCompileInteractive + = hscCompiler norecompInteractive batchMsg (genComp backend boot_backend) + where + backend inp = hscSimplify inp >>= hscNormalIface >>= hscIgnoreIface >>= hscInteractive + boot_backend _ = panic "hscCompileInteractive: HsBootFile" + +norecompInteractive :: NoRecomp (InteractiveStatus, ModIface, ModDetails) +norecompInteractive = norecompWorker InteractiveNoRecomp True + + +hscInteractive :: (ModIface, ModDetails, CgGuts) + -> Comp (Maybe (InteractiveStatus, ModIface, ModDetails)) +#ifdef GHCI +hscInteractive (iface, details, cgguts) + = do hsc_env <- gets compHscEnv + mod_summary <- gets compModSummary + liftIO $ do + let CgGuts{ -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_foreign = foreign_stubs, + cg_modBreaks = mod_breaks } = cgguts + dflags = hsc_dflags hsc_env + location = ms_location mod_summary + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes + + ------------------- + -- PREPARE FOR CODE GENERATION + -- Do saturation and convert to A-normal form + prepd_binds <- {-# SCC "CorePrep" #-} + corePrepPgm dflags core_binds data_tycons ; + ----------------- Generate byte code ------------------ + comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks + ------------------ Create f-x-dynamic C-side stuff --- + (_istub_h_exists, istub_c_exists) + <- outputForeignStubs dflags this_mod location foreign_stubs + return (Just (InteractiveRecomp istub_c_exists comp_bc mod_breaks, iface, details)) +#else +hscInteractive _ = panic "GHC not compiled with interpreter" +#endif addfile ./GHCSalat/InteractiveUI.hs hunk ./GHCSalat/InteractiveUI.hs 1 +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +{-# OPTIONS -#include "Linker.h" #-} +----------------------------------------------------------------------------- +-- +-- GHC Interactive User Interface +-- +-- (c) The GHC Team 2005-2006 +-- +----------------------------------------------------------------------------- + +module GHCSalat.InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where + +#include "HsVersions4Lsk.h" + +import qualified GHCSalat.GhciMonad as GhciMonad +import GHCSalat.GhciMonad hiding (runStmt) +import GHCSalat.GhciTags +import Debugger + +-- The GHC interface +import qualified GHC hiding (resume, runStmt) +import GHC ( LoadHowMuch(..), Target(..), TargetId(..), + Module, ModuleName, TyThing(..), Phase, + BreakIndex, SrcSpan, Resume, SingleStep, + Ghc, handleSourceError ) +import PprTyThing +import DynFlags + +import Packages +import PackageConfig +import UniqFM + +import HscTypes ( implicitTyThings ) +import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? +import Outputable hiding (printForUser, printForUserPartWay) +import Module -- for ModuleEnv +import Name +import SrcLoc + +-- Other random utilities +import ErrUtils +import CmdLineParser +import Digraph +import BasicTypes hiding (isTopLevel) +import Panic hiding (showException) +import Config +import StaticFlags +import Linker +import Util +import NameSet +import Maybes ( orElse, expectJust ) +import FastString +import Encoding + +#ifndef mingw32_HOST_OS +import System.Posix hiding (getEnv) +#else +import qualified System.Win32 +#endif + +import System.Console.Haskeline as Haskeline +import qualified System.Console.Haskeline.Encoding as Encoding +import Control.Monad.Trans + +--import SystemExts + +import Exception hiding (catch, block, unblock) +import qualified Exception +-- import Control.Concurrent + +import System.FilePath +import qualified Data.ByteString.Char8 as BS +import Data.List +import Data.Maybe +import System.Cmd +import System.Directory +import System.Environment +import System.Exit ( exitWith, ExitCode(..) ) +import System.IO +import System.IO.Error as IO +import Data.Char +import Data.Array +import Control.Monad as Monad +import Text.Printf +import Foreign +import GHC.Exts ( unsafeCoerce# ) +import GHC.IOBase ( IOErrorType(InvalidArgument) ) +import GHC.TopHandler + +import Data.IORef ( IORef, readIORef, writeIORef ) + +----------------------------------------------------------------------------- + +ghciWelcomeMsg :: String +ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ + ": http://www.haskell.org/ghc/ :? for help" + +cmdName :: Command -> String +cmdName (n,_,_) = n + +GLOBAL_VAR(macros_ref, [], [Command]) + +builtin_commands :: [Command] +builtin_commands = [ + -- Hugs users are accustomed to :e, so make sure it doesn't overlap + ("?", keepGoing help, noCompletion), + ("add", keepGoingPaths addModule, completeFilename), + ("abandon", keepGoing abandonCmd, noCompletion), + ("break", keepGoing breakCmd, completeIdentifier), + ("back", keepGoing backCmd, noCompletion), + ("browse", keepGoing' (browseCmd False), completeModule), + ("browse!", keepGoing' (browseCmd True), completeModule), + ("cd", keepGoing' changeDirectory, completeFilename), + ("check", keepGoing' checkModule, completeHomeModule), + ("continue", keepGoing continueCmd, noCompletion), + ("cmd", keepGoing cmdCmd, completeExpression), + ("ctags", keepGoing createCTagsFileCmd, completeFilename), + ("def", keepGoing (defineMacro False), completeExpression), + ("def!", keepGoing (defineMacro True), completeExpression), + ("delete", keepGoing deleteCmd, noCompletion), + ("e", keepGoing editFile, completeFilename), + ("edit", keepGoing editFile, completeFilename), + ("etags", keepGoing createETagsFileCmd, completeFilename), + ("force", keepGoing forceCmd, completeExpression), + ("forward", keepGoing forwardCmd, noCompletion), + ("help", keepGoing help, noCompletion), + ("history", keepGoing historyCmd, noCompletion), + ("info", keepGoing' info, completeIdentifier), + ("kind", keepGoing' kindOfType, completeIdentifier), + ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), + ("list", keepGoing' listCmd, noCompletion), + ("module", keepGoing setContext, completeModule), + ("main", keepGoing runMain, completeFilename), + ("print", keepGoing printCmd, completeExpression), + ("quit", quit, noCompletion), + ("reload", keepGoing' reloadModule, noCompletion), + ("run", keepGoing runRun, completeFilename), + ("set", keepGoing setCmd, completeSetOptions), + ("show", keepGoing showCmd, noCompletion), + ("sprint", keepGoing sprintCmd, completeExpression), + ("step", keepGoing stepCmd, completeIdentifier), + ("steplocal", keepGoing stepLocalCmd, completeIdentifier), + ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), + ("type", keepGoing' typeOfExpr, completeExpression), + ("trace", keepGoing traceCmd, completeExpression), + ("undef", keepGoing undefineMacro, completeMacro), + ("unset", keepGoing unsetOptions, completeSetOptions) + ] + + +-- We initialize readline (in the interactiveUI function) to use +-- word_break_chars as the default set of completion word break characters. +-- This can be overridden for a particular command (for example, filename +-- expansion shouldn't consider '/' to be a word break) by setting the third +-- entry in the Command tuple above. +-- +-- NOTE: in order for us to override the default correctly, any custom entry +-- must be a SUBSET of word_break_chars. +word_break_chars :: String +word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~" + specials = "(),;[]`{}" + spaces = " \t\n" + in spaces ++ specials ++ symbols + +flagWordBreakChars :: String +flagWordBreakChars = " \t\n" + + +keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool) +keepGoing a str = keepGoing' (lift . a) str + +keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool +keepGoing' a str = a str >> return False + +keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool) +keepGoingPaths a str + = do case toArgs str of + Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr + Right args -> a args + return False + +shortHelpText :: String +shortHelpText = "use :? for help.\n" + +helpText :: String +helpText = + " Commands available from the prompt:\n" ++ + "\n" ++ + " evaluate/run \n" ++ + " : repeat last command\n" ++ + " :{\\n ..lines.. \\n:}\\n multiline command\n" ++ + " :add [*] ... add module(s) to the current target set\n" ++ + " :browse[!] [[*]] display the names defined by module \n" ++ + " (!: more details; *: all top-level names)\n" ++ + " :cd change directory to \n" ++ + " :cmd run the commands returned by ::IO String\n" ++ + " :ctags [] create tags file for Vi (default: \"tags\")\n" ++ + " :def define a command :\n" ++ + " :edit edit file\n" ++ + " :edit edit last module\n" ++ + " :etags [] create tags file for Emacs (default: \"TAGS\")\n" ++ + " :help, :? display this list of commands\n" ++ + " :info [ ...] display information about the given names\n" ++ + " :kind show the kind of \n" ++ + " :load [*] ... load module(s) and their dependents\n" ++ + " :main [ ...] run the main function with the given arguments\n" ++ + " :module [+/-] [*] ... set the context for expression evaluation\n" ++ + " :quit exit GHCi\n" ++ + " :reload reload the current module set\n" ++ + " :run function [ ...] run the function with the given arguments\n" ++ + " :type show the type of \n" ++ + " :undef undefine user-defined command :\n" ++ + " :! run the shell command \n" ++ + "\n" ++ + " -- Commands for debugging:\n" ++ + "\n" ++ + " :abandon at a breakpoint, abandon current computation\n" ++ + " :back go back in the history (after :trace)\n" ++ + " :break [] [] set a breakpoint at the specified location\n" ++ + " :break set a breakpoint on the specified function\n" ++ + " :continue resume after a breakpoint\n" ++ + " :delete delete the specified breakpoint\n" ++ + " :delete * delete all breakpoints\n" ++ + " :force print , forcing unevaluated parts\n" ++ + " :forward go forward in the history (after :back)\n" ++ + " :history [] after :trace, show the execution history\n" ++ + " :list show the source code around current breakpoint\n" ++ + " :list identifier show the source code for \n" ++ + " :list [] show the source code around line number \n" ++ + " :print [ ...] prints a value without forcing its computation\n" ++ + " :sprint [ ...] simplifed version of :print\n" ++ + " :step single-step after stopping at a breakpoint\n"++ + " :step single-step into \n"++ + " :steplocal single-step within the current top-level binding\n"++ + " :stepmodule single-step restricted to the current module\n"++ + " :trace trace after stopping at a breakpoint\n"++ + " :trace evaluate with tracing on (see :history)\n"++ + + "\n" ++ + " -- Commands for changing settings:\n" ++ + "\n" ++ + " :set