X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FDriverPipeline.hs;h=0116aeeb79f5641534eab2932ba2e02f71d70d14;hb=81c59c75ebe2ea832479c0f423c6ca234844a3fb;hp=e889a72845edfe45e210c332fb3262859ecf6ede;hpb=98688c6e8fd33f31c51218cf93cbf03fe3a5e73d;p=ghc-hetmet.git diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index e889a72..0116aee 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 ( @@ -52,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 @@ -70,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-} @@ -99,6 +97,7 @@ preprocess filename = compile :: HscEnv -> Module -> ModLocation + -> ClockTime -- timestamp of original source file -> Bool -- True <=> source unchanged -> Bool -- True <=> have object -> Maybe ModIface -- old interface, if available @@ -116,7 +115,7 @@ data CompResult | CompErrs -compile hsc_env this_mod location +compile hsc_env this_mod location src_timestamp source_unchanged have_object old_iface = do @@ -158,7 +157,7 @@ compile hsc_env this_mod location hsc_env' = hsc_env { hsc_dflags = dyn_flags' } -- run the compiler - hsc_result <- hscMain hsc_env' this_mod location + hsc_result <- hscMain hsc_env' printErrorsAndWarnings this_mod location source_unchanged' have_object old_iface case hsc_result of @@ -182,8 +181,13 @@ compile hsc_env 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" @@ -382,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 @@ -400,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 @@ -479,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) ------------------------------------------------------------------------------- @@ -562,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 @@ -622,7 +602,7 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do hsc_env <- newHscEnv OneShot dyn_flags' -- run the compiler! - result <- hscMain hsc_env mod + result <- hscMain hsc_env printErrorsAndWarnings mod location{ ml_hspp_file=Just input_fn } source_unchanged False @@ -650,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 @@ -986,7 +994,11 @@ staticLink o_files dep_packages = do -- dependencies, and eliminating duplicates. o_file <- readIORef v_Output_file +#if defined(mingw32_HOST_OS) + let output_fn = case o_file of { Just s -> s; Nothing -> "main.exe"; } +#else let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } +#endif pkg_lib_paths <- getPackageLibraryPath dep_packages let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths @@ -1019,6 +1031,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", @@ -1046,6 +1082,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 @@ -1112,6 +1150,55 @@ 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) + + let target_defs = + [ "-D" ++ cTARGETOS ++ "_TARGET_OS=1", + "-D" ++ cTARGETARCH ++ "_TARGET_ARCH=1" ] + + 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 + ]) + +-- ----------------------------------------------------------------------------- +-- Misc. + hscNextPhase :: HscLang -> IO Phase hscNextPhase hsc_lang = do split <- readIORef v_Split_object_files @@ -1133,8 +1220,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