diff options
author | Ian Lynagh <ian@well-typed.com> | 2013-03-02 23:49:41 +0000 |
---|---|---|
committer | Ian Lynagh <ian@well-typed.com> | 2013-03-02 23:49:41 +0000 |
commit | 7c6b3782ae02497ff1b539cc62ad838818fb29a8 (patch) | |
tree | a4056e874ced61c221bdde11a1fa3386dea22815 | |
parent | 04e3b98e5206bbd808d0868cbc96904d35433176 (diff) | |
download | haskell-7c6b3782ae02497ff1b539cc62ad838818fb29a8.tar.gz |
Make codeOutput and friends return the filename that they have created
-rw-r--r-- | compiler/main/CodeOutput.lhs | 5 | ||||
-rw-r--r-- | compiler/main/DriverPipeline.hs | 27 | ||||
-rw-r--r-- | compiler/main/HscMain.hs | 28 |
3 files changed, 37 insertions, 23 deletions
diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index 1b7871ca8d..a180789d2b 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -49,7 +49,8 @@ codeOutput :: DynFlags -> ForeignStubs -> [PackageId] -> Stream IO RawCmmGroup () -- Compiled C-- - -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}) + -> IO (FilePath, + (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})) codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream = @@ -80,7 +81,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream HscInterpreted -> panic "codeOutput: HscInterpreted"; HscNothing -> panic "codeOutput: HscNothing" } - ; return stubs_exist + ; return (filenm, stubs_exist) } doOutput :: String -> (Handle -> IO a) -> IO a diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index ff486e4c17..240cbf43d8 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -108,7 +108,7 @@ compile = compile' (hscCompileNothing, hscCompileInteractive, hscCompileBatch) compile' :: (Compiler (HscStatus, ModIface, ModDetails), Compiler (InteractiveStatus, ModIface, ModDetails), - Compiler (HscStatus, ModIface, ModDetails)) + Compiler (FileOutputStatus, ModIface, ModDetails)) -> HscEnv -> ModSummary -- ^ summary for module being compiled -> Int -- ^ module N ... @@ -440,6 +440,10 @@ compileFile hsc_env stop_phase (src, mb_phase) = do -- When linking, the -o argument refers to the linker's output. -- otherwise, we use it as the name for the pipeline's output. output + -- If we are dong -fno-code, then act as if the output is + -- 'Temporary'. This stops GHC trying to copy files to their + -- final location. + | HscNothing <- hscTarget dflags = Temporary | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent -- -o foo applies to linker | Just o_file <- mb_o_file = SpecificFile o_file @@ -1011,7 +1015,7 @@ runPhase (Hsc src_flavour) input_fn dflags0 -- than the source file (else we wouldn't be in HscNoRecomp) -- but we touch it anyway, to keep 'make' happy (we think). return (StopLn, o_file) - (HscRecomp hasStub _) + (HscRecomp hasStub mOutputFilename) -> do case hasStub of Nothing -> return () Just stub_c -> @@ -1019,12 +1023,19 @@ runPhase (Hsc src_flavour) input_fn dflags0 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) $ do - liftIO $ touchObjectFile dflags' o_file - whenGeneratingDynamicToo dflags' $ do - let dyn_o_file = addBootSuffix (replaceExtension o_file (dynObjectSuf dflags')) - liftIO $ touchObjectFile dflags' dyn_o_file - return (next_phase, output_fn) + outputFilename <- + case mOutputFilename of + Just x -> return x + Nothing -> + if isHsBoot src_flavour + then do liftIO $ touchObjectFile dflags' o_file + whenGeneratingDynamicToo dflags' $ do + let dyn_o_file = addBootSuffix (replaceExtension o_file (dynObjectSuf dflags')) + liftIO $ touchObjectFile dflags' dyn_o_file + return o_file + else return $ panic "runPhase Hsc: No output filename" + + return (next_phase, outputFilename) ----------------------------------------------------------------------------- -- Cmm phase diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 2f2b53efba..b7a37c3de2 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -34,6 +34,7 @@ module HscMain -- * Compiling complete source files , Compiler , HscStatus' (..) + , FileOutputStatus , InteractiveStatus, HscStatus , hscCompileOneShot , hscCompileBatch @@ -540,11 +541,12 @@ data HscStatus' a -- result type. Therefore we need to artificially distinguish some types. We do -- this by adding type tags which will simply be ignored by the caller. type HscStatus = HscStatus' () +type FileOutputStatus = HscStatus' (Maybe FilePath) type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks)) -- INVARIANT: result is @Nothing@ <=> input was a boot file -type OneShotResult = HscStatus -type BatchResult = (HscStatus, ModIface, ModDetails) +type OneShotResult = FileOutputStatus +type BatchResult = (FileOutputStatus, ModIface, ModDetails) type NothingResult = (HscStatus, ModIface, ModDetails) type InteractiveResult = (InteractiveStatus, ModIface, ModDetails) @@ -687,21 +689,21 @@ hscOneShotCompiler = HsCompiler { , hscBackend = \tc_result mod_summary mb_old_hash -> do dflags <- getDynFlags case hscTarget dflags of - HscNothing -> return (HscRecomp Nothing ()) + HscNothing -> return (HscRecomp Nothing 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 Nothing ()) + return (HscRecomp Nothing Nothing) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 (iface, changed, _details, cgguts) <- hscNormalIface guts mb_old_iface hscWriteIface iface changed mod_summary - hasStub <- hscGenHardCode cgguts mod_summary - return (HscRecomp hasStub ()) + (outputFilename, hasStub) <- hscGenHardCode cgguts mod_summary + return (HscRecomp hasStub (Just outputFilename)) } -- Compile Haskell, boot and extCore in OneShot mode. @@ -737,18 +739,18 @@ hscBatchCompiler = HsCompiler { , 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 Nothing (), iface, details) + return (HscRecomp Nothing Nothing, iface, details) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 (iface, changed, details, cgguts) <- hscNormalIface guts mb_old_iface hscWriteIface iface changed mod_summary - hasStub <- hscGenHardCode cgguts mod_summary - return (HscRecomp hasStub (), iface, details) + (outputFilename, hasStub) <- hscGenHardCode cgguts mod_summary + return (HscRecomp hasStub (Just outputFilename), iface, details) } -- | Compile Haskell, boot and extCore in batch mode. -hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails) +hscCompileBatch :: Compiler (FileOutputStatus, ModIface, ModDetails) hscCompileBatch = genericHscCompile hscBatchCompiler batchMsg hscBatchBackendOnly :: TcGblEnv -> Compiler BatchResult @@ -1256,7 +1258,7 @@ hscWriteIface iface no_change mod_summary = do -- | Compile to hard-code. hscGenHardCode :: CgGuts -> ModSummary - -> Hsc (Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f + -> Hsc (FilePath, Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode cgguts mod_summary = do hsc_env <- getHscEnv liftIO $ do @@ -1303,11 +1305,11 @@ hscGenHardCode cgguts mod_summary = do return a rawcmms1 = Stream.mapM dump rawcmms0 - (_stub_h_exists, stub_c_exists) + (output_filename, (_stub_h_exists, stub_c_exists)) <- {-# SCC "codeOutput" #-} codeOutput dflags this_mod location foreign_stubs dependencies rawcmms1 - return stub_c_exists + return (output_filename, stub_c_exists) hscInteractive :: (ModIface, ModDetails, CgGuts) |