diff options
| -rw-r--r-- | compiler/main/CodeOutput.lhs | 30 | ||||
| -rw-r--r-- | compiler/main/DriverPhases.hs | 8 | ||||
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 486 | ||||
| -rw-r--r-- | compiler/main/Finder.lhs | 20 | ||||
| -rw-r--r-- | compiler/main/GhcMake.hs | 41 | ||||
| -rw-r--r-- | compiler/main/HscMain.lhs | 15 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 13 | ||||
| -rw-r--r-- | rules/build-package-way.mk | 15 |
8 files changed, 368 insertions, 260 deletions
diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index 85f34025fc..e9906a6c5b 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -30,6 +30,7 @@ import OldCmm ( RawCmm ) import HscTypes import DynFlags import Config +import SysTools import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable @@ -56,7 +57,7 @@ codeOutput :: DynFlags -> ForeignStubs -> [PackageId] -> [RawCmm] -- Compiled C-- - -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-}) + -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}) codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC = @@ -212,18 +213,21 @@ outputJava dflags filenm mod tycons core_binds \begin{code} outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs -> IO (Bool, -- Header file created - Bool) -- C file created + Maybe FilePath) -- C file created outputForeignStubs dflags mod location stubs - = case stubs of - NoStubs -> do + = do + let stub_h = mkStubPaths dflags (moduleName mod) location + stub_c <- newTempName dflags "c" + + case stubs of + NoStubs -> do -- When compiling External Core files, may need to use stub -- files from a previous compilation - stub_c_exists <- doesFileExist stub_c - stub_h_exists <- doesFileExist stub_h - return (stub_h_exists, stub_c_exists) + stub_h_exists <- doesFileExist stub_h + return (stub_h_exists, Nothing) - ForeignStubs h_code c_code -> do - let + ForeignStubs h_code c_code -> do + let stub_c_output_d = pprCode CStyle c_code stub_c_output_w = showSDoc stub_c_output_d @@ -266,10 +270,10 @@ outputForeignStubs dflags mod location stubs -- isn't really HC code, so we need to define IN_STG_CODE==0 to -- avoid the register variables etc. being enabled. - return (stub_h_file_exists, stub_c_file_exists) - where - (stub_c, stub_h, _) = mkStubPaths dflags (moduleName mod) location - + return (stub_h_file_exists, if stub_c_file_exists + then Just stub_c + else Nothing ) + where cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n" cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n" diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs index 5b00261e96..87ae663fcb 100644 --- a/compiler/main/DriverPhases.hs +++ b/compiler/main/DriverPhases.hs @@ -84,6 +84,7 @@ data Phase | LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM | CmmCpp -- pre-process Cmm source | Cmm -- parse & compile Cmm code + | MergeStub -- merge in the stub object file -- The final phase is a pseudo-phase that tells the pipeline to stop. -- There is no runPhase case for it. @@ -118,6 +119,7 @@ eqPhase LlvmLlc LlvmLlc = True eqPhase LlvmMangle LlvmMangle = True eqPhase CmmCpp CmmCpp = True eqPhase Cmm Cmm = True +eqPhase MergeStub MergeStub = True eqPhase StopLn StopLn = True eqPhase _ _ = False @@ -131,7 +133,7 @@ x `happensBefore` y = after_x `eqPhase` y || after_x `happensBefore` y after_x = nextPhase x nextPhase :: Phase -> Phase --- A conservative approximation the next phase, used in happensBefore +-- A conservative approximation to the next phase, used in happensBefore nextPhase (Unlit sf) = Cpp sf nextPhase (Cpp sf) = HsPp sf nextPhase (HsPp sf) = Hsc sf @@ -145,12 +147,13 @@ nextPhase LlvmLlc = LlvmMangle nextPhase LlvmLlc = As #endif nextPhase LlvmMangle = As -nextPhase SplitAs = StopLn +nextPhase SplitAs = MergeStub nextPhase Ccpp = As nextPhase Cc = As nextPhase CmmCpp = Cmm nextPhase Cmm = HCc nextPhase HCc = As +nextPhase MergeStub = StopLn nextPhase StopLn = panic "nextPhase: nothing after StopLn" -- the first compilation phase for a given file is determined @@ -204,6 +207,7 @@ phaseInputExt LlvmMangle = "lm_s" phaseInputExt SplitAs = "split_s" -- not really generated phaseInputExt CmmCpp = "cmm" phaseInputExt Cmm = "cmmcpp" +phaseInputExt MergeStub = "o" phaseInputExt StopLn = "o" haskellish_src_suffixes, haskellish_suffixes, cish_suffixes, diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index e015876e9e..e1a2f469ca 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1,4 +1,5 @@ {-# OPTIONS -fno-cse #-} +{-# LANGUAGE NamedFieldPuns #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly ----------------------------------------------------------------------------- @@ -78,7 +79,7 @@ preprocess :: HscEnv preprocess hsc_env (filename, mb_phase) = ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) runPipeline anyHsc hsc_env (filename, mb_phase) - Nothing Temporary Nothing{-no ModLocation-} + Nothing Temporary Nothing{-no ModLocation-} Nothing{-no stub-} -- --------------------------------------------------------------------------- @@ -158,12 +159,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) source_unchanged = isJust maybe_old_linkable && not force_recomp object_filename = ml_obj_file location - let getStubLinkable False = return [] - getStubLinkable True - = do stub_o <- compileStub hsc_env' this_mod location - return [ DotO stub_o ] - - handleBatch HscNoRecomp + let handleBatch HscNoRecomp = ASSERT (isJust maybe_old_linkable) return maybe_old_linkable @@ -175,22 +171,27 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) return maybe_old_linkable | otherwise - = do stub_unlinked <- getStubLinkable hasStub - (hs_unlinked, unlinked_time) <- + = do (hs_unlinked, unlinked_time) <- case hsc_lang of - HscNothing - -> return ([], ms_hs_date summary) + HscNothing -> + return ([], ms_hs_date summary) -- We're in --make mode: finish the compilation pipeline. - _other - -> do _ <- runPipeline StopLn hsc_env' (output_fn,Nothing) + _other -> do + maybe_stub_o <- case hasStub of + Nothing -> return Nothing + Just stub_c -> do + stub_o <- compileStub hsc_env' stub_c + return (Just stub_o) + _ <- runPipeline StopLn hsc_env' (output_fn,Nothing) (Just basename) Persistent (Just location) + maybe_stub_o -- The object filename comes from the ModLocation - o_time <- getModificationTime object_filename - return ([DotO object_filename], o_time) - let linkable = LM unlinked_time this_mod - (hs_unlinked ++ stub_unlinked) + o_time <- getModificationTime object_filename + return ([DotO object_filename], o_time) + + let linkable = LM unlinked_time this_mod hs_unlinked return (Just linkable) handleInterpreted HscNoRecomp @@ -200,7 +201,12 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) = ASSERT (isHsBoot src_flavour) return maybe_old_linkable handleInterpreted (HscRecomp hasStub (Just (comp_bc, modBreaks))) - = do stub_unlinked <- getStubLinkable hasStub + = do stub_o <- case hasStub of + Nothing -> return [] + Just stub_c -> do + stub_o <- compileStub hsc_env' stub_c + return [DotO stub_o] + let hs_unlinked = [BCOs comp_bc modBreaks] unlinked_time = ms_hs_date summary -- Why do we use the timestamp of the source file here, @@ -210,7 +216,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) -- if the source is modified, then the linkable will -- be out of date. let linkable = LM unlinked_time this_mod - (hs_unlinked ++ stub_unlinked) + (hs_unlinked ++ stub_o) return (Just linkable) let -- runCompiler :: Compiler result -> (result -> Maybe Linkable) @@ -235,31 +241,17 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) -- 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. --- --- This isn't necessarily the same as the object filename we --- would get if we just compiled the _stub.c file using the pipeline. --- For example: --- --- ghc src/A.hs -odir obj --- --- results in obj/A.o, and src/A_stub.c. If we compile src/A_stub.c with --- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want --- obj/A_stub.o. +-- The object file created by compiling the _stub.c file is put into a +-- temporary file, which will be later combined with the main .o file +-- (see the MergeStubs phase). -compileStub :: HscEnv -> Module -> ModLocation -> IO FilePath -compileStub hsc_env mod location = do - -- compile the _stub.c file w/ gcc - let (stub_c,_,stub_o) = mkStubPaths (hsc_dflags hsc_env) - (moduleName mod) location - - _ <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing - (SpecificFile stub_o) Nothing{-no ModLocation-} +compileStub :: HscEnv -> FilePath -> IO FilePath +compileStub hsc_env stub_c = do + (_, stub_o) <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing + Temporary Nothing{-no ModLocation-} Nothing return stub_o - -- --------------------------------------------------------------------------- -- Link @@ -436,7 +428,7 @@ compileFile hsc_env stop_phase (src, mb_phase) = do ( _, out_file) <- runPipeline stop_phase' hsc_env (src, mb_phase) Nothing output - Nothing{-no ModLocation-} + Nothing{-no ModLocation-} Nothing return out_file @@ -482,9 +474,11 @@ runPipeline -> Maybe FilePath -- ^ original basename (if different from ^^^) -> PipelineOutput -- ^ Output filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module + -> Maybe FilePath -- ^ stub object, if we have one -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) -runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc +runPipeline stop_phase hsc_env0 (input_fn, mb_phase) + mb_basename output maybe_loc maybe_stub_o = do let dflags0 = hsc_dflags hsc_env0 (input_basename, suffix) = splitExtension input_fn @@ -516,9 +510,17 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_lo let get_output_fn = getOutputFilename stop_phase output basename -- Execute the pipeline... - (dflags', output_fn, maybe_loc) <- - pipeLoop hsc_env start_phase stop_phase input_fn - basename suffix' get_output_fn maybe_loc + let env = PipeEnv{ stop_phase, + src_basename = basename, + src_suffix = suffix', + output_spec = output } + + state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o } + + (state', output_fn) <- unP (pipeLoop start_phase input_fn) env state + + let PipeState{ hsc_env=hsc_env', maybe_loc } = state' + dflags' = hsc_dflags hsc_env' -- Sometimes, a compilation phase doesn't actually generate any output -- (eg. the CPP phase when -fcpp is not turned on). If we end on this @@ -536,38 +538,102 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_lo copyWithHeader dflags msg line_prag output_fn final_fn return (dflags', final_fn) +-- ----------------------------------------------------------------------------- +-- The pipeline uses a monad to carry around various bits of information + +-- PipeEnv: invariant information passed down +data PipeEnv = PipeEnv { + stop_phase :: Phase, -- ^ Stop just before this phase + src_basename :: String, -- ^ basename of original input source + src_suffix :: String, -- ^ its extension + output_spec :: PipelineOutput -- ^ says where to put the pipeline output + } + +-- PipeState: information that might change during a pipeline run +data PipeState = PipeState { + hsc_env :: HscEnv, + -- ^ only the DynFlags change in the HscEnv. The DynFlags change + -- at various points, for example when we read the OPTIONS_GHC + -- pragmas in the Cpp phase. + maybe_loc :: Maybe ModLocation, + -- ^ the ModLocation. This is discovered during compilation, + -- in the Hsc phase where we read the module header. + maybe_stub_o :: Maybe FilePath + -- ^ the stub object. This is set by the Hsc phase if a stub + -- object was created. The stub object will be joined with + -- the main compilation object using "ld -r" at the end. + } + +getPipeEnv :: CompPipeline PipeEnv +getPipeEnv = P $ \env state -> return (state, env) + +getPipeState :: CompPipeline PipeState +getPipeState = P $ \_env state -> return (state, state) + +getDynFlags :: CompPipeline DynFlags +getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) + +setDynFlags :: DynFlags -> CompPipeline () +setDynFlags dflags = P $ \_env state -> + return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) + +setModLocation :: ModLocation -> CompPipeline () +setModLocation loc = P $ \_env state -> + return (state{ maybe_loc = Just loc }, ()) + +setStubO :: FilePath -> CompPipeline () +setStubO stub_o = P $ \_env state -> + return (state{ maybe_stub_o = Just stub_o }, ()) + +newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } + +instance Monad CompPipeline where + return a = P $ \_env state -> return (state, a) + P m >>= k = P $ \env state -> do (state',a) <- m env state + unP (k a) env state' + +io :: IO a -> CompPipeline a +io m = P $ \_env state -> do a <- m; return (state, a) + +phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath +phaseOutputFilename next_phase = do + PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv + PipeState{maybe_loc, hsc_env} <- getPipeState + let dflags = hsc_dflags hsc_env + io $ getOutputFilename stop_phase output_spec + src_basename dflags next_phase maybe_loc - -pipeLoop :: HscEnv -> Phase -> Phase - -> FilePath -> String -> Suffix - -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath) - -> Maybe ModLocation - -> IO (DynFlags, FilePath, Maybe ModLocation) - -pipeLoop hsc_env phase stop_phase - input_fn orig_basename orig_suff - orig_get_output_fn maybe_loc - - | phase `eqPhase` stop_phase -- All done - = return (hsc_dflags hsc_env, input_fn, maybe_loc) - - | not (phase `happensBefore` stop_phase) +-- --------------------------------------------------------------------------- +-- outer pipeline loop + +-- | pipeLoop runs phases until we reach the stop phase +pipeLoop :: Phase -> FilePath -> CompPipeline FilePath +pipeLoop phase input_fn = do + PipeEnv{stop_phase} <- getPipeEnv + PipeState{hsc_env} <- getPipeState + case () of + _ | phase `eqPhase` stop_phase -- All done + -> return input_fn + + | not (phase `happensBefore` stop_phase) -- Something has gone wrong. We'll try to cover all the cases when -- this could happen, so if we reach here it is a panic. -- eg. it might happen if the -C flag is used on a source file that -- has {-# OPTIONS -fasm #-}. - = panic ("pipeLoop: at phase " ++ show phase ++ + -> panic ("pipeLoop: at phase " ++ show phase ++ " but I wanted to stop at phase " ++ show stop_phase) - | otherwise - = do debugTraceMsg (hsc_dflags hsc_env) 4 + | otherwise + -> do io $ debugTraceMsg (hsc_dflags hsc_env) 4 (ptext (sLit "Running phase") <+> ppr phase) - (next_phase, dflags', maybe_loc, output_fn) - <- runPhase phase stop_phase hsc_env orig_basename - orig_suff input_fn orig_get_output_fn maybe_loc - let hsc_env' = hsc_env {hsc_dflags = dflags'} - pipeLoop hsc_env' next_phase stop_phase output_fn - orig_basename orig_suff orig_get_output_fn maybe_loc + dflags <- getDynFlags + (next_phase, output_fn) <- runPhase phase input_fn dflags + pipeLoop next_phase output_fn + +-- ----------------------------------------------------------------------------- +-- In each phase, we need to know into what filename to generate the +-- output. All the logic about which filenames we generate output +-- into is embodied in the following function. getOutputFilename :: Phase -> PipelineOutput -> String @@ -588,16 +654,16 @@ getOutputFilename stop_phase output basename keep_s = dopt Opt_KeepSFiles dflags keep_bc = dopt Opt_KeepLlvmFiles dflags - myPhaseInputExt HCc = hcsuf - myPhaseInputExt StopLn = osuf - myPhaseInputExt other = phaseInputExt other + myPhaseInputExt HCc = hcsuf + myPhaseInputExt MergeStub = osuf + myPhaseInputExt StopLn = osuf + myPhaseInputExt other = phaseInputExt other is_last_phase = next_phase `eqPhase` stop_phase -- sometimes, we keep output from intermediate stages keep_this_output = case next_phase of - StopLn -> True As | keep_s -> True LlvmOpt | keep_bc -> True HCc | keep_hc -> True @@ -628,31 +694,23 @@ getOutputFilename stop_phase output basename -- of a source file can change the latter stages of the pipeline from -- taking the via-C route to using the native code generator. -- -runPhase :: Phase -- ^ Do this phase first - -> Phase -- ^ Stop just before this phase - -> HscEnv - -> String -- ^ basename of original input source - -> String -- ^ its extension - -> FilePath -- ^ name of file which contains the input to this phase. - -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath) - -- ^ how to calculate the output filename - -> Maybe ModLocation -- ^ the ModLocation, if we have one - -> IO (Phase, -- next phase - DynFlags, -- new dynamic flags - Maybe ModLocation, -- the ModLocation, if we have one - FilePath) -- output filename +runPhase :: Phase -- ^ Run this phase + -> FilePath -- ^ name of the input file + -> DynFlags -- ^ for convenience, we pass the current dflags in + -> CompPipeline (Phase, -- next phase to run + FilePath) -- output filename -- Invariant: the output filename always contains the output -- Interesting case: Hsc when there is no recompilation to do -- Then the output filename is still a .o file + ------------------------------------------------------------------------------- -- Unlit phase -runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase (Unlit sf) input_fn dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags (Cpp sf) maybe_loc + output_fn <- phaseOutputFilename (Cpp sf) let unlit_flags = getOpts dflags opt_L flags = map SysTools.Option unlit_flags ++ @@ -666,56 +724,60 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l , SysTools.FileOption "" output_fn ] - SysTools.runUnlit dflags flags + io $ SysTools.runUnlit dflags flags - return (Cpp sf, dflags, maybe_loc, output_fn) + return (Cpp sf, output_fn) ------------------------------------------------------------------------------- -- Cpp phase : (a) gets OPTIONS out of file -- (b) runs cpp if necessary -runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do let dflags0 = hsc_dflags hsc_env - src_opts <- getOptionsFromFile dflags0 input_fn +runPhase (Cpp sf) input_fn dflags0 + = do + src_opts <- io $ getOptionsFromFile dflags0 input_fn (dflags1, unhandled_flags, warns) - <- parseDynamicNoPackageFlags dflags0 src_opts - checkProcessArgsResult unhandled_flags + <- io $ parseDynamicNoPackageFlags dflags0 src_opts + setDynFlags dflags1 + io $ checkProcessArgsResult unhandled_flags if not (xopt Opt_Cpp dflags1) then do -- we have to be careful to emit warnings only once. - unless (dopt Opt_Pp dflags1) $ handleFlagWarnings dflags1 warns + unless (dopt Opt_Pp dflags1) $ io $ handleFlagWarnings dflags1 warns -- no need to preprocess CPP, just pass input file along -- to the next phase of the pipeline. - return (HsPp sf, dflags1, maybe_loc, input_fn) + return (HsPp sf, input_fn) else do - output_fn <- get_output_fn dflags1 (HsPp sf) maybe_loc - doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn + output_fn <- phaseOutputFilename (HsPp sf) + io $ doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn -- re-read the pragmas now that we've preprocessed the file -- See #2464,#3457 - src_opts <- getOptionsFromFile dflags0 output_fn + src_opts <- io $ getOptionsFromFile dflags0 output_fn (dflags2, unhandled_flags, warns) - <- parseDynamicNoPackageFlags dflags0 src_opts - unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns + <- io $ parseDynamicNoPackageFlags dflags0 src_opts + unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns -- the HsPp pass below will emit warnings - checkProcessArgsResult unhandled_flags + io $ checkProcessArgsResult unhandled_flags + + setDynFlags dflags2 - return (HsPp sf, dflags2, maybe_loc, output_fn) + return (HsPp sf, output_fn) ------------------------------------------------------------------------------- -- HsPp phase -runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc - = do let dflags = hsc_dflags hsc_env +runPhase (HsPp sf) input_fn dflags + = do if not (dopt Opt_Pp dflags) then -- no need to preprocess, just pass input file along -- to the next phase of the pipeline. - return (Hsc sf, dflags, maybe_loc, input_fn) + return (Hsc sf, input_fn) else do let hspp_opts = getOpts dflags opt_F - let orig_fn = basename <.> suff - output_fn <- get_output_fn dflags (Hsc sf) maybe_loc - SysTools.runPp dflags + PipeEnv{src_basename, src_suffix} <- getPipeEnv + let orig_fn = src_basename <.> src_suffix + output_fn <- phaseOutputFilename (Hsc sf) + io $ SysTools.runPp dflags ( [ SysTools.Option orig_fn , SysTools.Option input_fn , SysTools.FileOption "" output_fn @@ -724,22 +786,26 @@ runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc ) -- re-read pragmas now that we've parsed the file (see #3674) - src_opts <- getOptionsFromFile dflags output_fn + src_opts <- io $ getOptionsFromFile dflags output_fn (dflags1, unhandled_flags, warns) - <- parseDynamicNoPackageFlags dflags src_opts - handleFlagWarnings dflags1 warns - checkProcessArgsResult unhandled_flags + <- io $ parseDynamicNoPackageFlags dflags src_opts + setDynFlags dflags1 + io $ handleFlagWarnings dflags1 warns + io $ checkProcessArgsResult unhandled_flags - return (Hsc sf, dflags1, maybe_loc, output_fn) + return (Hsc sf, output_fn) ----------------------------------------------------------------------------- -- Hsc phase -- Compilation of a single module, in "legacy" mode (_not_ under -- the direction of the compilation manager). -runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _maybe_loc +runPhase (Hsc src_flavour) input_fn dflags0 = do -- normal Hsc mode, not mkdependHS - let dflags0 = hsc_dflags hsc_env + + PipeEnv{ stop_phase=stop, + src_basename=basename, + src_suffix=suff } <- getPipeEnv -- we add the current directory (i.e. the directory in which -- the .hs files resides) to the include path, since this is @@ -751,8 +817,10 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma paths = includePaths dflags0 dflags = dflags0 { includePaths = current_dir : paths } + setDynFlags dflags + -- gather the imports and module name - (hspp_buf,mod_name,imps,src_imps) <- + (hspp_buf,mod_name,imps,src_imps) <- io $ case src_flavour of ExtCoreFile -> do -- no explicit imports in ExtCore input. m <- getCoreModuleName input_fn @@ -769,7 +837,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- the .hi and .o filenames, and this is as good a way -- as any to generate them, and better than most. (e.g. takes -- into accout the -osuf flags) - location1 <- mkHomeModLocation2 dflags mod_name basename suff + location1 <- io $ mkHomeModLocation2 dflags mod_name basename suff -- Boot-ify it if necessary let location2 | isHsBoot src_flavour = addBootSuffixLocn location1 @@ -796,6 +864,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma o_file = ml_obj_file location4 -- The real object file + setModLocation location4 -- Figure out if the source has changed, for recompilation avoidance. -- @@ -804,11 +873,11 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- changed (which the compiler itself figures out). -- Setting source_unchanged to False tells the compiler that M.o is out of -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. - src_timestamp <- getModificationTime (basename <.> suff) + src_timestamp <- io $ getModificationTime (basename <.> suff) let force_recomp = dopt Opt_ForceRecomp dflags hsc_lang = hscTarget dflags - source_unchanged <- + source_unchanged <- io $ if force_recomp || not (isStopLn stop) -- Set source_unchanged to False unconditionally if -- (a) recompilation checker is off, or @@ -825,16 +894,17 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- get the DynFlags let next_phase = hscNextPhase dflags src_flavour hsc_lang - output_fn <- get_output_fn dflags next_phase (Just location4) + output_fn <- phaseOutputFilename next_phase let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, extCoreName = basename ++ ".hcr" } - let hsc_env' = hsc_env {hsc_dflags = dflags'} + setDynFlags dflags' + PipeState{hsc_env=hsc_env'} <- getPipeState -- Tell the finder cache about this module - mod <- addHomeModuleToFinder hsc_env' mod_name location4 + mod <- io $ addHomeModuleToFinder hsc_env' mod_name location4 -- Make the ModSummary to hand to hscMain let @@ -850,58 +920,64 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma ms_srcimps = src_imps } -- run the compiler! - result <- hscCompileOneShot hsc_env' + result <- io $ hscCompileOneShot hsc_env' mod_summary source_unchanged Nothing -- No iface Nothing -- No "module i of n" progress info case result of HscNoRecomp - -> do SysTools.touch dflags' "Touching object file" o_file + -> do io $ SysTools.touch dflags' "Touching object file" o_file -- The .o file must have a later modification date -- 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) + return (StopLn, o_file) (HscRecomp hasStub _) - -> do when hasStub $ - do stub_o <- compileStub hsc_env' mod location4 - liftIO $ consIORef v_Ld_inputs stub_o + -> do case hasStub of + Nothing -> return () + Just stub_c -> + do stub_o <- io $ compileStub hsc_env' stub_c + setStubO stub_o -- In the case of hs-boot files, generate a dummy .o-boot -- stamp file for the benefit of Make when (isHsBoot src_flavour) $ - SysTools.touch dflags' "Touching object file" o_file - return (next_phase, dflags', Just location4, output_fn) + io $ SysTools.touch dflags' "Touching object file" o_file + return (next_phase, output_fn) ----------------------------------------------------------------------------- -- Cmm phase -runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase CmmCpp input_fn dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags Cmm maybe_loc - doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn - return (Cmm, dflags, maybe_loc, output_fn) + output_fn <- phaseOutputFilename Cmm + io $ doCpp dflags False{-not raw-} True{-include CC opts-} + input_fn output_fn + return (Cmm, output_fn) -runPhase Cmm _ hsc_env basename _ input_fn get_output_fn maybe_loc +runPhase Cmm input_fn dflags = do - let dflags = hsc_dflags hsc_env + PipeEnv{stop_phase,src_basename} <- getPipeEnv let hsc_lang = hscTarget dflags + let next_phase = hscNextPhase dflags HsSrcFile hsc_lang - output_fn <- get_output_fn dflags next_phase maybe_loc + + output_fn <- phaseOutputFilename next_phase let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, - extCoreName = basename ++ ".hcr" } - let hsc_env' = hsc_env {hsc_dflags = dflags'} + extCoreName = src_basename ++ ".hcr" } - hscCompileCmmFile hsc_env' input_fn + setDynFlags dflags' + PipeState{hsc_env} <- getPipeState + + io $ hscCompileCmmFile hsc_env input_fn -- XXX: catch errors above and convert them into ghcError? Original -- code was: -- --when (not ok) $ ghcError (PhaseFailed "cmm" (ExitFailure 1)) - return (next_phase, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) ----------------------------------------------------------------------------- -- Cc phase @@ -909,26 +985,26 @@ runPhase Cmm _ hsc_env basename _ input_fn get_output_fn maybe_loc -- we don't support preprocessing .c files (with -E) now. Doing so introduces -- way too many hacks, and I can't say I've ever used it anyway. -runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase cc_phase input_fn dflags | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc - = do let dflags = hsc_dflags hsc_env + = do let cc_opts = getOpts dflags opt_c hcc = cc_phase `eqPhase` HCc let cmdline_include_paths = includePaths dflags -- HC files have the dependent packages stamped into them - pkgs <- if hcc then getHCFilePackages input_fn else return [] + pkgs <- if hcc then io $ getHCFilePackages input_fn else return [] -- add package include paths even if we're just compiling .c -- files; this is the Value Add(TM) that using ghc instead of -- gcc gives you :) - pkg_include_dirs <- getPackageIncludePath dflags pkgs + pkg_include_dirs <- io $ getPackageIncludePath dflags pkgs let include_paths = foldr (\ x xs -> "-I" : x : xs) [] (cmdline_include_paths ++ pkg_include_dirs) let md_c_flags = machdepCCOpts dflags - gcc_extra_viac_flags <- getExtraViaCOpts dflags + gcc_extra_viac_flags <- io $ getExtraViaCOpts dflags let pic_c_flags = picCCOpts dflags let verb = getVerbFlag dflags @@ -936,13 +1012,13 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- cc-options are not passed when compiling .hc files. Our -- hc code doesn't not #include any header files anyway, so these -- options aren't necessary. - pkg_extra_cc_opts <- + pkg_extra_cc_opts <- io $ if cc_phase `eqPhase` HCc then return [] else getPackageExtraCcOpts dflags pkgs #ifdef darwin_TARGET_OS - pkg_framework_paths <- getPackageFrameworkPath dflags pkgs + pkg_framework_paths <- io $ getPackageFrameworkPath dflags pkgs let cmdline_framework_paths = frameworkPaths dflags let framework_paths = map ("-F"++) (cmdline_framework_paths ++ pkg_framework_paths) @@ -958,7 +1034,7 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- Decide next phase let next_phase = As - output_fn <- get_output_fn dflags next_phase maybe_loc + output_fn <- phaseOutputFilename next_phase let more_hcc_opts = @@ -978,7 +1054,7 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- very weakly typed, being derived from C--. ["-fno-strict-aliasing"] - SysTools.runCc dflags ( + io $ SysTools.runCc dflags ( -- force the C compiler to interpret this file as C when -- compiling .hc files, by adding the -x c option. -- Also useful for plain .c files, just in case GHC saw a @@ -1028,54 +1104,56 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc ++ pkg_extra_cc_opts )) - return (next_phase, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) -- ToDo: postprocess the output from gcc ----------------------------------------------------------------------------- -- Splitting phase -runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc +runPhase SplitMangle input_fn dflags = do -- tmp_pfx is the prefix used for the split .s files - -- We also use it as the file to contain the no. of split .s files (sigh) - let dflags = hsc_dflags hsc_env - split_s_prefix <- SysTools.newTempName dflags "split" + + split_s_prefix <- io $ SysTools.newTempName dflags "split" let n_files_fn = split_s_prefix - SysTools.runSplit dflags + io $ SysTools.runSplit dflags [ SysTools.FileOption "" input_fn , SysTools.FileOption "" split_s_prefix , SysTools.FileOption "" n_files_fn ] -- Save the number of split files for future references - s <- readFile n_files_fn + s <- io $ readFile n_files_fn let n_files = read s :: Int dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) } + setDynFlags dflags' + -- Remember to delete all these files - addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s" - | n <- [1..n_files]] + io $ addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s" + | n <- [1..n_files]] - return (SplitAs, dflags', maybe_loc, "**splitmangle**") + return (SplitAs, "**splitmangle**") -- we don't use the filename ----------------------------------------------------------------------------- -- As phase -runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do let dflags = hsc_dflags hsc_env +runPhase As input_fn dflags + = do let as_opts = getOpts dflags opt_a let cmdline_include_paths = includePaths dflags - output_fn <- get_output_fn dflags StopLn maybe_loc + next_phase <- maybeMergeStub + output_fn <- phaseOutputFilename next_phase -- we create directories for the object file, because it -- might be a hierarchical module. - createDirectoryHierarchy (takeDirectory output_fn) + io $ createDirectoryHierarchy (takeDirectory output_fn) let md_c_flags = machdepCCOpts dflags - SysTools.runAs dflags + io $ SysTools.runAs dflags (map SysTools.Option as_opts ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] #ifdef sparc_TARGET_ARCH @@ -1095,24 +1173,25 @@ runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc ] ++ map SysTools.Option md_c_flags) - return (StopLn, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) -runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc +runPhase SplitAs _input_fn dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags StopLn maybe_loc + next_phase <- maybeMergeStub + output_fn <- phaseOutputFilename next_phase let base_o = dropExtension output_fn osuf = objectSuf dflags split_odir = base_o ++ "_" ++ osuf ++ "_split" - createDirectoryHierarchy split_odir + io $ 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 </>) $ filter (osuf `isSuffixOf`) fs + fs <- io $ getDirectoryContents split_odir + io $ mapM_ removeFile $ + map (split_odir </>) $ filter (osuf `isSuffixOf`) fs let as_opts = getOpts dflags opt_a @@ -1145,19 +1224,18 @@ runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc ] ++ map SysTools.Option md_c_flags) - mapM_ assemble_file [1..n] + io $ mapM_ assemble_file [1..n] -- join them into a single .o file - joinObjectFiles dflags (map split_obj [1..n]) output_fn + io $ joinObjectFiles dflags (map split_obj [1..n]) output_fn - return (StopLn, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) ----------------------------------------------------------------------------- -- LlvmOpt phase -runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase LlvmOpt input_fn dflags = do - let dflags = hsc_dflags hsc_env let lo_opts = getOpts dflags opt_lo let opt_lvl = max 0 (min 2 $ optLevel dflags) -- don't specify anything if user has specified commands. We do this for @@ -1168,16 +1246,16 @@ runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc then [SysTools.Option (llvmOpts !! opt_lvl)] else [] - output_fn <- get_output_fn dflags LlvmLlc maybe_loc + output_fn <- phaseOutputFilename LlvmLlc - SysTools.runLlvmOpt dflags + io $ SysTools.runLlvmOpt dflags ([ SysTools.FileOption "" input_fn, SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ optFlag ++ map SysTools.Option lo_opts) - return (LlvmLlc, dflags, maybe_loc, output_fn) + return (LlvmLlc, output_fn) where -- we always (unless -optlo specified) run Opt since we rely on it to -- fix up some pretty big deficiencies in the code we generate @@ -1187,9 +1265,8 @@ runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc ----------------------------------------------------------------------------- -- LlvmLlc phase -runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase LlvmLlc input_fn dflags = do - let dflags = hsc_dflags hsc_env let lc_opts = getOpts dflags opt_lc let opt_lvl = max 0 (min 2 $ optLevel dflags) #if darwin_TARGET_OS @@ -1201,16 +1278,16 @@ runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc | not opt_Static = "dynamic-no-pic" | otherwise = "static" - output_fn <- get_output_fn dflags nphase maybe_loc + output_fn <- phaseOutputFilename nphase - SysTools.runLlvmLlc dflags + io $ SysTools.runLlvmLlc dflags ([ SysTools.Option (llvmOpts !! opt_lvl), SysTools.Option $ "-relocation-model=" ++ rmodel, SysTools.FileOption "" input_fn, SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ map SysTools.Option lc_opts) - return (nphase, dflags, maybe_loc, output_fn) + return (nphase, output_fn) where #if darwin_TARGET_OS llvmOpts = ["-O1", "-O2", "-O2"] @@ -1222,17 +1299,36 @@ runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc ----------------------------------------------------------------------------- -- LlvmMangle phase -runPhase LlvmMangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase LlvmMangle input_fn _dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags As maybe_loc - llvmFixupAsm input_fn output_fn - return (As, dflags, maybe_loc, output_fn) + output_fn <- phaseOutputFilename As + io $ llvmFixupAsm input_fn output_fn + return (As, output_fn) +----------------------------------------------------------------------------- +-- merge in stub objects + +runPhase MergeStub input_fn dflags + = do + PipeState{maybe_stub_o} <- getPipeState + output_fn <- phaseOutputFilename StopLn + case maybe_stub_o of + Nothing -> + panic "runPhase(MergeStub): no stub" + Just stub_o -> do + io $ joinObjectFiles dflags [input_fn, stub_o] output_fn + return (StopLn, output_fn) -- warning suppression -runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc = +runPhase other _input_fn _dflags = panic ("runPhase: don't know how to run phase " ++ show other) + +maybeMergeStub :: CompPipeline Phase +maybeMergeStub + = do + PipeState{maybe_stub_o} <- getPipeState + if isJust maybe_stub_o then return MergeStub else return StopLn + ----------------------------------------------------------------------------- -- MoveBinary sort-of-phase -- After having produced a binary, move it somewhere else and generate a diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index d8a627167c..5cbcd411e2 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -498,7 +498,7 @@ mkStubPaths :: DynFlags -> ModuleName -> ModLocation - -> (FilePath,FilePath,FilePath) + -> FilePath mkStubPaths dflags mod location = let @@ -513,15 +513,8 @@ mkStubPaths dflags mod location | otherwise = src_basename stub_basename = stub_basename0 ++ "_stub" - - obj = ml_obj_file location - osuf = objectSuf dflags - stub_obj_base = dropTail (length osuf + 1) obj ++ "_stub" - -- NB. not takeFileName, see #3093 in - (stub_basename <.> "c", - stub_basename <.> "h", - stub_obj_base <.> objectSuf dflags) + stub_basename <.> "h" -- ----------------------------------------------------------------------------- -- findLinkable isn't related to the other stuff in here, @@ -538,12 +531,9 @@ findObjectLinkableMaybe mod locn -- Make an object linkable when we know the object file exists, and we know -- its modification time. findObjectLinkable :: Module -> FilePath -> ClockTime -> IO Linkable -findObjectLinkable mod obj_fn obj_time = do - let stub_fn = (dropExtension obj_fn ++ "_stub") <.> "o" - stub_exist <- doesFileExist stub_fn - if stub_exist - then return (LM obj_time mod [DotO obj_fn, DotO stub_fn]) - else return (LM obj_time mod [DotO obj_fn]) +findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) + -- We used to look for _stub.o files here, but that was a bug (#706) + -- Now GHC merges the stub.o into the main .o (#3687) -- ----------------------------------------------------------------------------- -- Error messages diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 5387245257..0d4143560f 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -250,8 +250,9 @@ load2 how_much mod_graph = do mg = stable_mg ++ partial_mg -- clean up between compilations - let cleanup = cleanTempFilesExcept dflags - (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps)) + let cleanup hsc_env = intermediateCleanTempFiles dflags + (flattenSCCs mg2_with_srcimps) + hsc_env liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") 2 (ppr mg)) @@ -276,9 +277,10 @@ load2 how_much mod_graph = do do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") -- Clean up after ourselves - liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) + hsc_env1 <- getSession + liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1 - -- Issue a warning for the confusing case where the user + -- Issue a warning for the confusing case where the user -- said '-o foo' but we're not going to do any linking. -- We attempt linking if either (a) one of the modules is -- called Main, or (b) the user said -no-hs-main, indicating @@ -300,7 +302,6 @@ load2 how_much mod_graph = do moduleNameString (moduleName main_mod) ++ " module.") -- link everything together - hsc_env1 <- getSession linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) loadFinish Succeeded linkresult @@ -325,7 +326,7 @@ load2 how_much mod_graph = do (hsc_HPT hsc_env1) -- Clean up after ourselves - liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep) + liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1 -- there should be no Nothings where linkables should be, now ASSERT(all (isJust.hm_linkable) @@ -363,11 +364,21 @@ discardProg hsc_env hsc_IC = emptyInteractiveContext, hsc_HPT = emptyHomePackageTable } --- used to fish out the preprocess output files for the purposes of --- cleaning up. The preprocessed file *might* be the same as the --- source file, but that doesn't do any harm. -ppFilesFromSummaries :: [ModSummary] -> [FilePath] -ppFilesFromSummaries summaries = map ms_hspp_file summaries +intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO () +intermediateCleanTempFiles dflags summaries hsc_env + = cleanTempFilesExcept dflags except + where + except = + -- Save preprocessed files. The preprocessed file *might* be + -- the same as the source file, but that doesn't do any + -- harm. + map ms_hspp_file summaries ++ + -- Save object files for loaded modules. The point of this + -- is that we might have generated and compiled a stub C + -- file, and in the case of GHCi the object file will be a + -- temporary file which we must not remove because we need + -- to load/link it later. + hptObjs (hsc_HPT hsc_env) -- | If there is no -o option, guess the name of target executable -- by using top-level source file name as a base. @@ -591,7 +602,7 @@ upsweep :: GhcMonad m => HomePackageTable -- ^ HPT from last time round (pruned) -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) - -> IO () -- ^ How to clean up unwanted tmp files + -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files -> [SCC ModSummary] -- ^ Mods to do (the worklist) -> m (SuccessFlag, [ModSummary]) @@ -624,6 +635,10 @@ upsweep old_hpt stable_mods cleanup sccs = do let logger _mod = defaultWarnErrLogger hsc_env <- getSession + + -- Remove unwanted tmp files between compilations + liftIO (cleanup hsc_env) + mb_mod_info <- handleSourceError (\err -> do logger mod (Just err); return Nothing) $ do @@ -632,8 +647,6 @@ upsweep old_hpt stable_mods cleanup sccs = do logger mod Nothing -- log warnings return (Just mod_info) - liftIO cleanup -- Remove unwanted tmp files between compilations - case mb_mod_info of Nothing -> return (Failed, done) Just mod_info -> do diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 37c65bbf0f..841125a0c5 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -460,7 +460,8 @@ error. This is the only thing that isn't caught by the type-system. data HscStatus' a = HscNoRecomp | HscRecomp - Bool -- Has stub files. This is a hack. We can't compile C files here + (Maybe FilePath) + -- Has stub files. This is a hack. We can't compile C files here -- since it's done in DriverPipeline. For now we just return True -- if we want the caller to compile them for us. a @@ -596,14 +597,14 @@ hscOneShotCompiler = , hscBackend = \ tc_result mod_summary mb_old_hash -> do dflags <- getDynFlags case hscTarget dflags of - HscNothing -> return (HscRecomp False ()) + HscNothing -> return (HscRecomp Nothing ()) _otherw -> genericHscBackend hscOneShotCompiler tc_result mod_summary mb_old_hash , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface hscWriteIface iface changed mod_summary - return (HscRecomp False ()) + return (HscRecomp Nothing ()) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 @@ -649,7 +650,7 @@ hscBatchCompiler = , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do (iface, changed, details) <- hscSimpleIface tc_result mb_old_iface hscWriteIface iface changed mod_summary - return (HscRecomp False (), iface, details) + return (HscRecomp Nothing (), iface, details) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 @@ -681,7 +682,7 @@ hscInteractiveCompiler = , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface - return (HscRecomp False Nothing, iface, details) + return (HscRecomp Nothing Nothing, iface, details) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 @@ -710,7 +711,7 @@ hscNothingCompiler = , hscBackend = \tc_result _mod_summary mb_old_iface -> do handleWarnings (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface - return (HscRecomp False (), iface, details) + return (HscRecomp Nothing (), iface, details) , hscGenBootOutput = \_ _ _ -> panic "hscCompileNothing: hscGenBootOutput should not be called" @@ -852,7 +853,7 @@ hscWriteIface iface no_change mod_summary -- | Compile to hard-code. hscGenHardCode :: CgGuts -> ModSummary - -> Hsc Bool -- ^ @True@ <=> stub.c exists + -> Hsc (Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode cgguts mod_summary = do hsc_env <- getHscEnv diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 3673b3ee7a..3d441cce57 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -25,8 +25,9 @@ module HscTypes ( -- * State relating to modules in this package HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - hptInstances, hptRules, hptVectInfo, - + hptInstances, hptRules, hptVectInfo, + hptObjs, + -- * State relating to known packages ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, @@ -76,7 +77,7 @@ module HscTypes ( Warnings(..), WarningTxt(..), plusWarns, -- * Linker stuff - Linkable(..), isObjectLinkable, + Linkable(..), isObjectLinkable, linkableObjs, Unlinked(..), CompiledByteCode, isObject, nameOfObject, isInterpretable, byteCodeOfObject, @@ -494,6 +495,9 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps -- And get its dfuns , thing <- things ] + +hptObjs :: HomePackageTable -> [FilePath] +hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsUFM hpt)) \end{code} %************************************************************************ @@ -1790,6 +1794,9 @@ isObjectLinkable l = not (null unlinked) && all isObject unlinked -- compiling a module in HscNothing mode, and this choice -- happens to work well with checkStability in module GHC. +linkableObjs :: Linkable -> [FilePath] +linkableObjs l = [ f | DotO f <- linkableUnlinked l ] + instance Outputable Linkable where ppr (LM when_made mod unlinkeds) = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) diff --git a/rules/build-package-way.mk b/rules/build-package-way.mk index 8b67ce2239..d6c1560e10 100644 --- a/rules/build-package-way.mk +++ b/rules/build-package-way.mk @@ -40,12 +40,7 @@ endif # All the .a/.so library file dependencies for this library $1_$2_$3_DEPS_LIBS=$$(foreach dep,$$($1_$2_DEPS),$$($$(dep)_$2_$3_LIB)) -ifneq "$$(BootingFromHc)" "YES" -$1_$2_$3_MKSTUBOBJS = $$(FIND) $1/$2/build -name "*_stub.$$($3_osuf)" -print -# HACK ^^^ we tried to use $(wildcard), but apparently it fails due to -# make using cached directory contents, or something. -else -$1_$2_$3_MKSTUBOBJS = true +ifeq "$$(BootingFromHc)" "YES" $1_$2_$3_C_OBJS += $$(shell $$(FIND) $1/$2/build -name "*_stub.c" -print | sed 's/c$$$$/o/') endif @@ -70,7 +65,6 @@ ifeq "$3" "dyn" ifeq "$$(HOSTPLATFORM)" "i386-unknown-mingw32" $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS) "$$($1_$2_HC)" $$($1_$2_$3_ALL_OBJS) \ - `$$($1_$2_$3_MKSTUBOBJS)` \ -shared -dynamic -dynload deploy \ $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) \ -no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \ @@ -78,7 +72,6 @@ $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS) else $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS) "$$($1_$2_HC)" $$($1_$2_$3_ALL_OBJS) \ - `$$($1_$2_$3_MKSTUBOBJS)` \ -shared -dynamic -dynload deploy \ -dylib-install-name $(ghclibdir)/`basename "$$@" | sed 's/^libHS//;s/[-]ghc.*//'`/`basename "$$@"` \ -no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \ @@ -90,9 +83,9 @@ $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) "$$(RM)" $$(RM_OPTS) $$@ $$@.contents ifeq "$$($1_$2_SplitObjs)" "YES" $$(FIND) $$(patsubst %.$$($3_osuf),%_$$($3_osuf)_split,$$($1_$2_$3_HS_OBJS)) -name '*.$$($3_osuf)' -print >> $$@.contents - echo $$($1_$2_$3_NON_HS_OBJS) `$$($1_$2_$3_MKSTUBOBJS)` >> $$@.contents + echo $$($1_$2_$3_NON_HS_OBJS) >> $$@.contents else - echo $$($1_$2_$3_ALL_OBJS) `$$($1_$2_$3_MKSTUBOBJS)` >> $$@.contents + echo $$($1_$2_$3_ALL_OBJS) >> $$@.contents endif ifeq "$$(ArSupportsAtFile)" "YES" "$$(AR)" $$(AR_OPTS) $$(EXTRA_AR_ARGS) $$@ @$$@.contents @@ -121,7 +114,7 @@ BINDIST_LIBS += $$($1_$2_GHCI_LIB) endif endif $$($1_$2_GHCI_LIB) : $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS) - "$$(LD)" -r -o $$@ $$(EXTRA_LD_OPTS) $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) `$$($1_$2_$3_MKSTUBOBJS)` $$($1_$2_EXTRA_OBJS) + "$$(LD)" -r -o $$@ $$(EXTRA_LD_OPTS) $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS) ifeq "$$($1_$2_BUILD_GHCI_LIB)" "YES" # Don't bother making ghci libs for bootstrapping packages |