X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FDriverPipeline.hs;h=0116aeeb79f5641534eab2932ba2e02f71d70d14;hb=81c59c75ebe2ea832479c0f423c6ca234844a3fb;hp=4521e34ee7005e2109e3442f4199789b863d0418;hpb=cd20fd58e77d3593cd5870a7345285869b2e32f3;p=ghc-hetmet.git diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 4521e34..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 @@ -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 @@ -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" @@ -487,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) ------------------------------------------------------------------------------- @@ -658,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 @@ -994,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 @@ -1146,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 @@ -1167,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