X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDriverPipeline.hs;h=4eccce3a8f99281a2bbdbe1f517a5768be6923c0;hb=dc055e5ce94940711e5c342afd13d6f5d9bafed4;hp=2bf19b9c76813bd5cb666f441853e4168a6d417a;hpb=f7fd7fce1c50ea0014ab88f52313058d402d346e;p=ghc-hetmet.git diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 2bf19b9..4eccce3 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -19,7 +19,7 @@ module DriverPipeline ( -- Interfaces for the compilation manager (interpreted/batch-mode) preprocess, - compile, + compile, compile', link, ) where @@ -52,7 +52,7 @@ import MonadUtils import Data.Either import Exception -import Data.IORef ( readIORef, writeIORef, IORef ) +import Data.IORef ( readIORef ) import GHC.Exts ( Int(..) ) import System.Directory import System.FilePath @@ -103,7 +103,26 @@ compile :: GhcMonad m => -> 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 +compile = compile' (hscCompileNothing, hscCompileInteractive, hscCompileBatch) + +type Compiler m a = HscEnv -> ModSummary -> Bool + -> Maybe ModIface -> Maybe (Int, Int) + -> m a + +compile' :: GhcMonad m => + (Compiler m (HscStatus, ModIface, ModDetails), + Compiler m (InteractiveStatus, ModIface, ModDetails), + Compiler m (HscStatus, ModIface, ModDetails)) + -> 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' (nothingCompiler, interactiveCompiler, batchCompiler) + hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable = do let dflags0 = ms_hspp_opts summary this_mod = ms_mod summary @@ -153,7 +172,7 @@ compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable = ASSERT (isJust maybe_old_linkable) return maybe_old_linkable - handleBatch (HscRecomp hasStub) + handleBatch (HscRecomp hasStub _) | isHsBoot src_flavour = do when (isObjectTarget hsc_lang) $ -- interpreted reaches here too liftIO $ SysTools.touch dflags' "Touching object file" @@ -179,10 +198,13 @@ compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable (hs_unlinked ++ stub_unlinked) return (Just linkable) - handleInterpreted InteractiveNoRecomp + handleInterpreted HscNoRecomp = ASSERT (isJust maybe_old_linkable) return maybe_old_linkable - handleInterpreted (InteractiveRecomp hasStub comp_bc modBreaks) + handleInterpreted (HscRecomp _hasStub Nothing) + = ASSERT (isHsBoot src_flavour) + return maybe_old_linkable + handleInterpreted (HscRecomp hasStub (Just (comp_bc, modBreaks))) = do stub_unlinked <- getStubLinkable hasStub let hs_unlinked = [BCOs comp_bc modBreaks] unlinked_time = ms_hs_date summary @@ -208,15 +230,13 @@ compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable hm_linkable = linkable }) -- run the compiler case hsc_lang of - HscInterpreted - | isHsBoot src_flavour -> - runCompiler hscCompileNothing handleBatch - | otherwise -> - runCompiler hscCompileInteractive handleInterpreted + HscInterpreted -> + runCompiler interactiveCompiler handleInterpreted HscNothing -> - runCompiler hscCompileNothing handleBatch + runCompiler nothingCompiler handleBatch _other -> - runCompiler hscCompileBatch handleBatch + runCompiler batchCompiler handleBatch + ----------------------------------------------------------------------------- -- stub .h and .c files (for foreign export support) @@ -666,7 +686,7 @@ runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc 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 + handleFlagWarnings dflags warns checkProcessArgsResult unhandled_flags if not (dopt Opt_Cpp dflags) then @@ -830,7 +850,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- 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) + (HscRecomp hasStub _) -> do when hasStub $ do stub_o <- compileStub hsc_env' mod location4 liftIO $ consIORef v_Ld_inputs stub_o @@ -973,6 +993,13 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- This is a temporary hack. ++ ["-mcpu=v9"] #endif +#if defined(darwin_TARGET_OS) && defined(i386_TARGET_ARCH) + -- By default, gcc on OS X will generate SSE + -- instructions, which need things 16-byte aligned, + -- but we don't 16-byte align things. Thus drop + -- back to generic i686 compatibility. Trac #2983. + ++ ["-march=i686"] +#endif ++ (if hcc && mangle then md_regd_c_flags else []) @@ -1048,13 +1075,13 @@ runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe -- 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) + dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) } -- Remember to delete all these files - addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s" - | n <- [1..n_files]] + addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s" + | n <- [1..n_files]] - return (SplitAs, dflags, maybe_loc, "**splitmangle**") + return (SplitAs, dflags', maybe_loc, "**splitmangle**") -- we don't use the filename ----------------------------------------------------------------------------- @@ -1112,7 +1139,9 @@ runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc let as_opts = getOpts dflags opt_a - (split_s_prefix, n) <- readIORef v_Split_info + let (split_s_prefix, n) = case splitInfo dflags of + Nothing -> panic "No split info" + Just x -> x let split_s n = split_s_prefix ++ "__" ++ show n <.> "s" split_obj n = split_odir @@ -1121,6 +1150,16 @@ runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc let assemble_file n = SysTools.runAs dflags (map SysTools.Option as_opts ++ +#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.Option "-o" , SysTools.FileOption "" (split_obj n) @@ -1706,5 +1745,3 @@ hscMaybeAdjustTarget dflags stop _ current_hsc_lang -- otherwise, stick to the plan | otherwise = current_hsc_lang -GLOBAL_VAR(v_Split_info, ("",0), (String,Int)) - -- The split prefix and number of files