X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FDriverPipeline.hs;h=81c2f4698cc8b7bfcb378786e897f2507f780b82;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=87977cb1f705611f7aa45655e5eca78ec4566f7a;hpb=abbc5a0be1df84a33015470319062ed7a3aa3153;p=ghc-hetmet.git diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 87977cb..81c2f46 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -6,7 +6,7 @@ -- ----------------------------------------------------------------------------- -#include "../includes/config.h" +#include "../includes/ghcconfig.h" module DriverPipeline ( @@ -41,6 +41,7 @@ import Module import ErrUtils import CmdLineOpts import Config +import RdrName ( GlobalRdrEnv ) import Panic import Util import BasicTypes ( SuccessFlag(..) ) @@ -51,9 +52,7 @@ import ParserCoreUtils ( getCoreModuleName ) import EXCEPTION import DATA_IOREF ( readIORef, writeIORef ) -#ifdef GHCI -import Time ( getClockTime ) -#endif +import Time ( ClockTime ) import Directory import System import IO @@ -69,7 +68,7 @@ import Maybe preprocess :: FilePath -> IO FilePath preprocess filename = - ASSERT(haskellish_src_file filename) + ASSERT(isHaskellSrcFilename filename) do restoreDynFlags -- Restore to state of last save runPipeline (StopBefore Hsc) ("preprocess") False{-temporary output file-} @@ -95,29 +94,30 @@ preprocess filename = -- NB. No old interface can also mean that the source has changed. -compile :: GhciMode -- distinguish batch from interactive +compile :: HscEnv -> Module -> ModLocation + -> ClockTime -- timestamp of original source file -> Bool -- True <=> source unchanged -> Bool -- True <=> have object -> Maybe ModIface -- old interface, if available - -> HomePackageTable -- For home-module stuff - -> PersistentCompilerState -- persistent compiler state -> IO CompResult data CompResult - = CompOK PersistentCompilerState -- Updated PCS - ModDetails -- New details + = CompOK ModDetails -- New details + (Maybe GlobalRdrEnv) -- Lexical environment for the module + -- (Maybe because we may have loaded it from + -- its precompiled interface) ModIface -- New iface (Maybe Linkable) -- New code; Nothing => compilation was not reqd -- (old code is still valid) - | CompErrs PersistentCompilerState -- Updated PCS + | CompErrs -compile ghci_mode this_mod location +compile hsc_env this_mod location src_timestamp source_unchanged have_object - old_iface hpt pcs = do + old_iface = do dyn_flags <- restoreDynFlags -- Restore to the state of the last save @@ -154,20 +154,18 @@ compile ghci_mode this_mod location -- -no-recomp should also work with --make do_recomp <- readIORef v_Recomp let source_unchanged' = source_unchanged && do_recomp - hsc_env = HscEnv { hsc_mode = ghci_mode, - hsc_dflags = dyn_flags', - hsc_HPT = hpt } + hsc_env' = hsc_env { hsc_dflags = dyn_flags' } -- run the compiler - hsc_result <- hscMain hsc_env pcs this_mod location + hsc_result <- hscMain hsc_env' printErrorsAndWarnings this_mod location source_unchanged' have_object old_iface case hsc_result of - HscFail pcs -> return (CompErrs pcs) + HscFail -> return CompErrs - HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing) + HscNoRecomp details iface -> return (CompOK details Nothing iface Nothing) - HscRecomp pcs details iface + HscRecomp details rdr_env iface stub_h_exists stub_c_exists maybe_interpreted_code -> do let maybe_stub_o <- compileStub dyn_flags' stub_c_exists @@ -183,8 +181,13 @@ compile ghci_mode this_mod location HscInterpreted -> case maybe_interpreted_code of #ifdef GHCI - Just comp_bc -> do tm <- getClockTime - return ([BCOs comp_bc], tm) + Just comp_bc -> return ([BCOs comp_bc], src_timestamp) + -- 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. #endif Nothing -> panic "compile: no interpreted code" @@ -202,7 +205,7 @@ compile ghci_mode this_mod location let linkable = LM unlinked_time mod_name (hs_unlinked ++ stub_unlinked) - return (CompOK pcs details iface (Just linkable)) + return (CompOK details rdr_env iface (Just linkable)) ----------------------------------------------------------------------------- -- stub .h and .c files (for foreign export support) @@ -383,7 +386,8 @@ pipeLoop phase stop_phase input_fn orig_basename orig_suff genOutputFilenameFunc :: Bool -> Maybe FilePath -> Phase -> String -> IO (Phase{-next phase-} -> Maybe ModLocation -> IO FilePath) -genOutputFilenameFunc keep_output maybe_output_filename stop_phase basename +genOutputFilenameFunc keep_final_output maybe_output_filename + stop_phase basename = do hcsuf <- readIORef v_HC_suf odir <- readIORef v_Output_dir @@ -401,23 +405,30 @@ genOutputFilenameFunc keep_output maybe_output_filename stop_phase basename myPhaseInputExt other = phaseInputExt other func next_phase maybe_location - | next_phase == stop_phase - = case maybe_output_filename of - Just file -> return file - Nothing - | Ln <- next_phase -> return odir_persistent - | keep_output -> return persistent - | otherwise -> newTempName suffix - -- sometimes, we keep output from intermediate stages - | otherwise - = case next_phase of - Ln -> return odir_persistent - Mangle | keep_raw_s -> return persistent - As | keep_s -> return persistent - HCc | keep_hc -> return persistent - _other -> newTempName suffix + | is_last_phase, Just f <- maybe_output_filename = return f + | is_last_phase && keep_final_output = persistent_fn + | keep_this_output = persistent_fn + | otherwise = newTempName suffix + where + is_last_phase = next_phase == stop_phase + + -- sometimes, we keep output from intermediate stages + keep_this_output = + case next_phase of + Ln -> 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 + | Ln <- next_phase = return odir_persistent + | otherwise = return persistent + persistent = basename ++ '.':suffix odir_persistent @@ -480,40 +491,8 @@ runPhase Cpp basename suff input_fn get_output_fn maybe_loc -- to the next phase of the pipeline. return (Just HsPp, maybe_loc, input_fn) else do - hscpp_opts <- getOpts opt_P - hs_src_cpp_opts <- readIORef v_Hs_source_cpp_opts - - cmdline_include_paths <- readIORef v_Include_paths - - pkg_include_dirs <- getPackageIncludePath [] - let include_paths = foldr (\ x xs -> "-I" : x : xs) [] - (cmdline_include_paths ++ pkg_include_dirs) - - verb <- getVerbFlag - (md_c_flags, _) <- machdepCCOpts - output_fn <- get_output_fn HsPp maybe_loc - - SysTools.runCpp ([SysTools.Option verb] - ++ map SysTools.Option include_paths - ++ map SysTools.Option hs_src_cpp_opts - ++ map SysTools.Option hscpp_opts - ++ map SysTools.Option md_c_flags - ++ [ 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 - ]) - + doCpp True{-raw-} False{-no CC opts-} input_fn output_fn return (Just HsPp, maybe_loc, output_fn) ------------------------------------------------------------------------------- @@ -563,7 +542,7 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do -- gather the imports and module name (_,_,mod_name) <- - if extcoreish_suffix suff + if isExtCoreFilename ('.':suff) then do -- no explicit imports in ExtCore input. m <- getCoreModuleName input_fn @@ -620,14 +599,10 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do hscStubCOutName = basename ++ "_stub.c", hscStubHOutName = basename ++ "_stub.h", extCoreName = basename ++ ".hcr" } - hsc_env = HscEnv { hsc_mode = OneShot, - hsc_dflags = dyn_flags', - hsc_HPT = emptyHomePackageTable } - + hsc_env <- newHscEnv OneShot dyn_flags' -- run the compiler! - pcs <- initPersistentCompilerState - result <- hscMain hsc_env pcs mod + result <- hscMain hsc_env printErrorsAndWarnings mod location{ ml_hspp_file=Just input_fn } source_unchanged False @@ -635,13 +610,14 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do case result of - HscFail pcs -> throwDyn (PhaseFailed "hsc" (ExitFailure 1)) + HscFail -> throwDyn (PhaseFailed "hsc" (ExitFailure 1)) - HscNoRecomp pcs details iface -> do + HscNoRecomp details iface -> do SysTools.touch "Touching object file" o_file return (Nothing, Just location, output_fn) - HscRecomp _pcs _details _iface stub_h_exists stub_c_exists + HscRecomp _details _rdr_env _iface + stub_h_exists stub_c_exists _maybe_interpreted_code -> do -- deal with stubs @@ -654,6 +630,34 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do _ -> return (Just next_phase, Just location, output_fn) ----------------------------------------------------------------------------- +-- Cmm phase + +runPhase CmmCpp basename suff input_fn get_output_fn maybe_loc + = do + output_fn <- get_output_fn Cmm maybe_loc + doCpp False{-not raw-} True{-include CC opts-} input_fn output_fn + return (Just Cmm, maybe_loc, output_fn) + +runPhase Cmm basename suff input_fn get_output_fn maybe_loc + = do + dyn_flags <- getDynFlags + hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags) + next_phase <- hscNextPhase hsc_lang + output_fn <- get_output_fn next_phase maybe_loc + + let dyn_flags' = dyn_flags { hscLang = hsc_lang, + hscOutName = output_fn, + hscStubCOutName = basename ++ "_stub.c", + hscStubHOutName = basename ++ "_stub.h", + extCoreName = basename ++ ".hcr" } + + ok <- hscCmmFile dyn_flags' input_fn + + when (not ok) $ throwDyn (PhaseFailed "cmm" (ExitFailure 1)) + + return (Just next_phase, maybe_loc, output_fn) + +----------------------------------------------------------------------------- -- Cc phase -- we don't support preprocessing .c files (with -E) now. Doing so introduces @@ -1023,6 +1027,30 @@ staticLink o_files dep_packages = do [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, basePackage] + ways <- readIORef v_Ways + + -- 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 = [] + let extra_os = if static || no_hs_main then [] else [ head (library_dirs rts_pkg) ++ "/Main.dll_o", @@ -1050,6 +1078,8 @@ staticLink o_files dep_packages = do ++ pkg_framework_path_opts ++ pkg_framework_opts #endif + ++ debug_opts + ++ thread_opts )) -- parallel only: move binary to another dir -- HWL @@ -1116,6 +1146,50 @@ doMkDLL o_files dep_packages = do -- ----------------------------------------------------------------------------- -- Misc. +doCpp :: Bool -> Bool -> FilePath -> FilePath -> IO () +doCpp raw include_cc_opts input_fn output_fn = do + hscpp_opts <- getOpts opt_P + + cmdline_include_paths <- readIORef v_Include_paths + + pkg_include_dirs <- getPackageIncludePath [] + let include_paths = foldr (\ x xs -> "-I" : x : xs) [] + (cmdline_include_paths ++ pkg_include_dirs) + + verb <- getVerbFlag + + cc_opts <- if not include_cc_opts + then return [] + else do optc <- getOpts opt_c + (md_c_flags, _) <- machdepCCOpts + return (optc ++ md_c_flags) + + let cpp_prog args | raw = SysTools.runCpp args + | otherwise = SysTools.runCc (SysTools.Option "-E" : args) + + cpp_prog ([SysTools.Option verb] + ++ map SysTools.Option include_paths + ++ map SysTools.Option hsSourceCppOpts + ++ map SysTools.Option hscpp_opts + ++ map SysTools.Option cc_opts + ++ [ 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 + ]) + +-- ----------------------------------------------------------------------------- +-- Misc. + hscNextPhase :: HscLang -> IO Phase hscNextPhase hsc_lang = do split <- readIORef v_Split_object_files @@ -1137,8 +1211,6 @@ hscMaybeAdjustLang current_hsc_lang = do | current_hsc_lang == HscInterpreted = current_hsc_lang -- force -fvia-C if we are being asked for a .hc file | todo == StopBefore HCc || keep_hc = HscC - -- force -fvia-C when profiling or ticky-ticky is on - | opt_SccProfilingOn || opt_DoTickyProfiling = HscC -- otherwise, stick to the plan | otherwise = current_hsc_lang return hsc_lang