From 8d48737f404f079a3deec1c00c86aa028a124efb Mon Sep 17 00:00:00 2001 From: Thomas Schilling Date: Fri, 28 Nov 2008 16:37:46 +0000 Subject: [PATCH] Expose a separate 'hscBackend' phase for 'HsCompiler' and change parameter to 'InteractiveStatus' to a 'Maybe'. --- compiler/main/DriverPipeline.hs | 7 ++++-- compiler/main/HscMain.lhs | 47 ++++++++++++++++++++++++++++++--------- 2 files changed, 41 insertions(+), 13 deletions(-) diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 2846eaf..c4c49be 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 @@ -182,7 +182,10 @@ compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable handleInterpreted HscNoRecomp = ASSERT (isJust maybe_old_linkable) return maybe_old_linkable - handleInterpreted (HscRecomp 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 diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index e95be76..03daf34 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -17,6 +17,9 @@ module HscMain , hscStmt, hscTcExpr, hscKcType , compileExpr #endif + , HsCompiler(..) + , hscOneShotCompiler, hscNothingCompiler + , hscInteractiveCompiler, hscBatchCompiler , hscCompileOneShot -- :: Compiler HscStatus , hscCompileBatch -- :: Compiler (HscStatus, ModIface, ModDetails) , hscCompileNothing -- :: Compiler (HscStatus, ModIface, ModDetails) @@ -313,7 +316,8 @@ 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 InteractiveStatus = HscStatus' (CompiledByteCode, ModBreaks) +type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks)) + -- INVARIANT: result is @Nothing@ <=> input was a boot file type OneShotResult = HscStatus type BatchResult = (HscStatus, ModIface, ModDetails) @@ -346,6 +350,9 @@ data HsCompiler a hscRecompile :: GhcMonad m => ModSummary -> Maybe Fingerprint -> m a, + hscBackend :: GhcMonad m => + TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a, + -- | Code generation for Boot modules. hscGenBootOutput :: GhcMonad m => TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a, @@ -390,12 +397,18 @@ genericHscRecompile compiler mod_summary mb_old_hash panic "GHC does not currently support reading External Core files" | otherwise = do tc_result <- hscFileFrontEnd mod_summary - case ms_hsc_src mod_summary of - HsBootFile -> - hscGenBootOutput compiler tc_result mod_summary mb_old_hash - _other -> do - guts <- hscDesugar mod_summary tc_result - hscGenOutput compiler guts mod_summary mb_old_hash + hscBackend compiler tc_result mod_summary mb_old_hash + +genericHscBackend :: GhcMonad m => + HsCompiler a + -> TcGblEnv -> ModSummary -> Maybe Fingerprint + -> m a +genericHscBackend compiler tc_result mod_summary mb_old_hash + | HsBootFile <- ms_hsc_src mod_summary = + hscGenBootOutput compiler tc_result mod_summary mb_old_hash + | otherwise = do + guts <- hscDesugar mod_summary tc_result + hscGenOutput compiler guts mod_summary mb_old_hash -------------------------------------------------------------- -- Compilers @@ -423,6 +436,8 @@ hscOneShotCompiler = , hscRecompile = genericHscRecompile hscOneShotCompiler + , hscBackend = genericHscBackend hscOneShotCompiler + , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface hscWriteIface iface changed mod_summary @@ -455,6 +470,8 @@ hscBatchCompiler = , hscRecompile = genericHscRecompile hscBatchCompiler + , hscBackend = genericHscBackend hscBatchCompiler + , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do (iface, changed, details) <- hscSimpleIface tc_result mb_old_iface @@ -487,7 +504,11 @@ hscInteractiveCompiler = , hscRecompile = genericHscRecompile hscInteractiveCompiler - , hscGenBootOutput = \_ _ _ -> panic "hscCompileInteractive: HsBootFile" + , hscBackend = genericHscBackend 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) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify guts0 @@ -517,12 +538,15 @@ hscNothingCompiler = panic "hscCompileNothing: cannot do external core" _otherwise -> do tc_result <- hscFileFrontEnd mod_summary - hscGenBootOutput hscNothingCompiler tc_result mod_summary mb_old_hash + hscBackend hscNothingCompiler tc_result mod_summary mb_old_hash - , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do + , hscBackend = \tc_result _mod_summary mb_old_iface -> do (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface return (HscRecomp False (), iface, details) + , hscGenBootOutput = \_ _ _ -> + panic "hscCompileNothing: hscGenBootOutput should not be called" + , hscGenOutput = \_ _ _ -> panic "hscCompileNothing: hscGenOutput should not be called" } @@ -733,7 +757,8 @@ hscInteractive (iface, details, cgguts) mod_summary ------------------ Create f-x-dynamic C-side stuff --- (_istub_h_exists, istub_c_exists) <- outputForeignStubs dflags this_mod location foreign_stubs - return (HscRecomp istub_c_exists (comp_bc, mod_breaks), iface, details) + return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks)) + , iface, details) #else hscInteractive _ _ = panic "GHC not compiled with interpreter" #endif -- 1.7.10.4