X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fmain%2FDriverPipeline.hs;h=8e4ee26a4630bb66e3188a005bd99af6ba260a1d;hb=ec968a32e9b02c230dfcbff9660c3e61900d8235;hp=a8fa8cedeb6f123733732426993b392f8cb32edc;hpb=d8afca91db837cc59ae505d113210c655d68c7b6;p=ghc-hetmet.git diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index a8fa8ce..8e4ee26 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -65,6 +65,7 @@ import Directory import System import IO import Monad +import Data.List ( isSuffixOf ) import Maybe @@ -157,8 +158,6 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, - hscStubCOutName = basename ++ "_stub.c", - hscStubHOutName = basename ++ "_stub.h", extCoreName = basename ++ ".hcr" } -- -no-recomp should also work with --make @@ -192,7 +191,7 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do -> do stub_unlinked <- if stub_c_exists then do - stub_o <- compileStub dflags' object_filename + stub_o <- compileStub dflags' this_mod location return [ DotO stub_o ] else return [] @@ -235,8 +234,9 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do ----------------------------------------------------------------------------- -- stub .h and .c files (for foreign export support) --- The _stub.c file is derived from the haskell source file (but stored --- in hscStubCOutName in the dflags for some reason, probably historical). +-- 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. -- @@ -250,12 +250,13 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do -- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want -- obj/A_stub.o. -compileStub dflags object_filename = do - let (o_base, o_ext) = splitFilename object_filename +compileStub :: DynFlags -> Module -> ModLocation -> IO FilePath +compileStub dflags mod location = do + let (o_base, o_ext) = splitFilename (ml_obj_file location) stub_o = o_base ++ "_stub" `joinFileExt` o_ext -- compile the _stub.c file w/ gcc - let stub_c = hscStubCOutName dflags + let (stub_c,_) = mkStubPaths dflags mod location runPipeline StopLn dflags (stub_c,Nothing) (SpecificFile stub_o) Nothing{-no ModLocation-} @@ -297,7 +298,7 @@ link BatchCompile dflags batch_attempt_linking hpt pkg_deps = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos -- the linkables to link - linkables = map (fromJust.hm_linkable) home_mod_infos + linkables = map (expectJust "link".hm_linkable) home_mod_infos debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) @@ -330,7 +331,10 @@ link BatchCompile dflags batch_attempt_linking hpt <+> text "...") -- Don't showPass in Batch mode; doLink will do that for us. - staticLink dflags obj_files pkg_deps + let link = case ghcLink dflags of + MkDLL -> doMkDLL + StaticLink -> staticLink + link dflags obj_files pkg_deps debugTraceMsg dflags 3 (text "link: done") @@ -509,7 +513,7 @@ getOutputFilename dflags stop_phase output basename = func where hcsuf = hcSuf dflags - odir = outputDir dflags + odir = objectDir dflags osuf = objectSuf dflags keep_hc = dopt Opt_KeepHcFiles dflags keep_raw_s = dopt Opt_KeepRawSFiles dflags @@ -742,8 +746,6 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, - hscStubCOutName = basename ++ "_stub.c", - hscStubHOutName = basename ++ "_stub.h", extCoreName = basename ++ ".hcr" } hsc_env <- newHscEnv dflags' @@ -774,7 +776,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma _maybe_interpreted_code -> do when stub_c_exists $ do - stub_o <- compileStub dflags' o_file + stub_o <- compileStub dflags' mod_name location4 consIORef v_Ld_inputs stub_o -- In the case of hs-boot files, generate a dummy .o-boot @@ -802,8 +804,6 @@ runPhase Cmm stop dflags basename suff input_fn get_output_fn maybe_loc let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, - hscStubCOutName = basename ++ "_stub.c", - hscStubHOutName = basename ++ "_stub.h", extCoreName = basename ++ ".hcr" } ok <- hscCmmFile dflags' input_fn @@ -848,6 +848,9 @@ runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc let excessPrecision = dopt Opt_ExcessPrecision dflags + let cc_opt | optLevel dflags >= 2 = "-O2" + | otherwise = "-O" + -- Decide next phase let mangle = dopt Opt_DoAsmMangling dflags @@ -856,6 +859,23 @@ runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc | otherwise = As output_fn <- get_output_fn 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 excessPrecision 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"] + + + SysTools.runCc dflags ( -- force the C compiler to interpret this file as C when -- compiling .hc files, by adding the -x c option. @@ -872,11 +892,13 @@ runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc ++ (if hcc && mangle then md_regd_c_flags else []) - ++ [ verb, "-S", "-Wimplicit", "-O" ] + ++ (if hcc + then more_hcc_opts + else []) + ++ [ verb, "-S", "-Wimplicit", cc_opt ] ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] ++ cc_opts ++ split_opt - ++ (if excessPrecision then [] else [ "-ffloat-store" ]) ++ include_paths ++ pkg_extra_cc_opts )) @@ -964,34 +986,64 @@ runPhase As stop dflags _basename _suff input_fn get_output_fn maybe_loc runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc - = do let as_opts = getOpts dflags opt_a + = do + output_fn <- get_output_fn StopLn maybe_loc + + let (base_o, _) = splitFilename 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 `joinFileName`) + $ filter (osuf `isSuffixOf`) fs + + let as_opts = getOpts dflags opt_a (split_s_prefix, n) <- readIORef v_Split_info - let real_odir - | Just d <- outputDir dflags = d - | otherwise = basename ++ "_split" + let split_s n = split_s_prefix ++ "__" ++ show n `joinFileExt` "s" + split_obj n = split_odir `joinFileName` + filenameOf base_o ++ "__" ++ show n + `joinFileExt` osuf let assemble_file n - = do let input_s = split_s_prefix ++ "__" ++ show n ++ ".s" - let output_o = replaceFilenameDirectory - (basename ++ "__" ++ show n ++ ".o") - real_odir - let osuf = objectSuf dflags - let real_o = replaceFilenameSuffix output_o osuf - SysTools.runAs dflags - (map SysTools.Option as_opts ++ - [ SysTools.Option "-c" - , SysTools.Option "-o" - , SysTools.FileOption "" real_o - , SysTools.FileOption "" input_s - ]) + = 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] - output_fn <- get_output_fn StopLn maybe_loc + -- 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 `joinFileName` "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) + ----------------------------------------------------------------------------- -- MoveBinary sort-of-phase -- After having produced a binary, move it somewhere else and generate a @@ -1209,7 +1261,14 @@ staticLink dflags o_files dep_packages = do exeFileName :: DynFlags -> FilePath exeFileName dflags - | Just s <- outputFile dflags = s + | Just s <- outputFile dflags = +#if defined(mingw32_HOST_OS) + if null (suffixOf s) + then s `joinFileExt` "exe" + else s +#else + s +#endif | otherwise = #if defined(mingw32_HOST_OS) "main.exe" @@ -1371,9 +1430,9 @@ getOptionsFromSource file | otherwise -> return [] getOptionsFromStringBuffer :: StringBuffer -> FilePath -> [(Int,String)] -getOptionsFromStringBuffer buffer@(StringBuffer _ len# _) fn = +getOptionsFromStringBuffer buffer@(StringBuffer _ len _) fn = let - ls = lines (lexemeToString buffer (I# len#)) -- lazy, so it's ok + ls = lines (lexemeToString buffer len) -- lazy, so it's ok in look 1 ls where