From 1dfe7f1ee44b6ae59e072eec720984b136fc1dc5 Mon Sep 17 00:00:00 2001 From: Thomas Schilling Date: Fri, 28 Nov 2008 12:19:47 +0000 Subject: [PATCH] Use a record instead of a typeclass for 'HsCompiler'. This is mostly equivalent to a typeclass implementation that uses a functional dependency from the target mode to the result type. --- compiler/main/HscMain.lhs | 275 +++++++++++++++++++++++---------------------- 1 file changed, 142 insertions(+), 133 deletions(-) diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index dca1fef..e95be76 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -22,7 +22,7 @@ module HscMain , hscCompileNothing -- :: Compiler (HscStatus, ModIface, ModDetails) , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails) , HscStatus' (..) - , InteractiveStatus, NothingStatus, OneShotStatus, BatchStatus + , InteractiveStatus, HscStatus -- The new interface , hscParse @@ -312,17 +312,12 @@ data HscStatus' a -- functional dependencies, we have to parameterise the typeclass over the -- 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. -data HscOneShotTag = HscOneShotTag -data HscNothingTag = HscNothingTag - -type OneShotStatus = HscStatus' HscOneShotTag -type BatchStatus = HscStatus' () +type HscStatus = HscStatus' () type InteractiveStatus = HscStatus' (CompiledByteCode, ModBreaks) -type NothingStatus = HscStatus' HscNothingTag -type OneShotResult = OneShotStatus -type BatchResult = (BatchStatus, ModIface, ModDetails) -type NothingResult = (NothingStatus, ModIface, ModDetails) +type OneShotResult = HscStatus +type BatchResult = (HscStatus, ModIface, ModDetails) +type NothingResult = (HscStatus, ModIface, ModDetails) type InteractiveResult = (InteractiveStatus, ModIface, ModDetails) -- FIXME: The old interface and module index are only using in 'batch' and @@ -335,36 +330,38 @@ type Compiler result = GhcMonad m => -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs) -> m result -class HsCompiler a where - -- | The main interface. - hscCompile :: GhcMonad m => - HscEnv -> ModSummary -> Bool - -> Maybe ModIface -> Maybe (Int, Int) - -> m a - - -- | Called when no recompilation is necessary. - hscNoRecomp :: GhcMonad m => - ModIface -> m a - - -- | Called to recompile the module. - hscRecompile :: GhcMonad m => - ModSummary -> Maybe Fingerprint -> m a - - -- | Code generation for Boot modules. - hscGenBootOutput :: GhcMonad m => - TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a - - -- | Code generation for normal modules. - hscGenOutput :: GhcMonad m => - ModGuts -> ModSummary -> Maybe Fingerprint -> m a - - -genericHscCompile :: (HsCompiler a, GhcMonad m) => - (Maybe (Int,Int) -> Bool -> ModSummary -> m ()) +data HsCompiler a + = HsCompiler { + -- | The main interface. + hscCompile :: GhcMonad m => + HscEnv -> ModSummary -> Bool + -> Maybe ModIface -> Maybe (Int, Int) + -> m a, + + -- | Called when no recompilation is necessary. + hscNoRecomp :: GhcMonad m => + ModIface -> m a, + + -- | Called to recompile the module. + hscRecompile :: GhcMonad m => + ModSummary -> Maybe Fingerprint -> m a, + + -- | Code generation for Boot modules. + hscGenBootOutput :: GhcMonad m => + TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a, + + -- | Code generation for normal modules. + hscGenOutput :: GhcMonad m => + ModGuts -> ModSummary -> Maybe Fingerprint -> m a + } + +genericHscCompile :: GhcMonad m => + HsCompiler a + -> (Maybe (Int,Int) -> Bool -> ModSummary -> m ()) -> HscEnv -> ModSummary -> Bool -> Maybe ModIface -> Maybe (Int, Int) -> m a -genericHscCompile hscMessage +genericHscCompile compiler hscMessage hsc_env mod_summary source_unchanged mb_old_iface0 mb_mod_index = withTempSession (\_ -> hsc_env) $ do @@ -379,147 +376,159 @@ genericHscCompile hscMessage case mb_checked_iface of Just iface | not recomp_reqd -> do hscMessage mb_mod_index False mod_summary - hscNoRecomp iface + hscNoRecomp compiler iface _otherwise -> do hscMessage mb_mod_index True mod_summary - hscRecompile mod_summary mb_old_hash + hscRecompile compiler mod_summary mb_old_hash -genericHscRecompile :: (HsCompiler a, GhcMonad m) => - ModSummary -> Maybe Fingerprint +genericHscRecompile :: GhcMonad m => + HsCompiler a + -> ModSummary -> Maybe Fingerprint -> m a -genericHscRecompile mod_summary mb_old_hash +genericHscRecompile compiler mod_summary mb_old_hash | ExtCoreFile <- ms_hsc_src mod_summary = 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 tc_result mod_summary mb_old_hash + hscGenBootOutput compiler tc_result mod_summary mb_old_hash _other -> do guts <- hscDesugar mod_summary tc_result - hscGenOutput guts mod_summary mb_old_hash + hscGenOutput compiler guts mod_summary mb_old_hash -------------------------------------------------------------- -- Compilers -------------------------------------------------------------- -instance HsCompiler OneShotResult where - - hscCompile hsc_env mod_summary src_changed mb_old_iface mb_i_of_n = do - -- One-shot mode needs a knot-tying mutable variable for interface files. - -- See TcRnTypes.TcGblEnv.tcg_type_env_var. - type_env_var <- liftIO $ newIORef emptyNameEnv - let - mod = ms_mod mod_summary - hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) } - --- - genericHscCompile oneShotMsg hsc_env' mod_summary src_changed - mb_old_iface mb_i_of_n - - hscNoRecomp _old_iface = do - withSession (liftIO . dumpIfaceStats) - return HscNoRecomp - - hscRecompile = genericHscRecompile - - 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 HscOneShotTag) - - 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 HscOneShotTag) +hscOneShotCompiler :: HsCompiler OneShotResult +hscOneShotCompiler = + HsCompiler { + + hscCompile = \hsc_env mod_summary src_changed mb_old_iface mb_i_of_n -> do + -- One-shot mode needs a knot-tying mutable variable for interface + -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. + type_env_var <- liftIO $ newIORef emptyNameEnv + let + mod = ms_mod mod_summary + hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) } + --- + genericHscCompile hscOneShotCompiler + oneShotMsg hsc_env' mod_summary src_changed + mb_old_iface mb_i_of_n + + , hscNoRecomp = \_old_iface -> do + withSession (liftIO . dumpIfaceStats) + return HscNoRecomp + + , hscRecompile = genericHscRecompile hscOneShotCompiler + + , 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 ()) + + , 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 ()) + } -- Compile Haskell, boot and extCore in OneShot mode. -hscCompileOneShot :: Compiler OneShotStatus -hscCompileOneShot = hscCompile +hscCompileOneShot :: Compiler OneShotResult +hscCompileOneShot = hscCompile hscOneShotCompiler -------------------------------------------------------------- -instance HsCompiler BatchResult where +hscBatchCompiler :: HsCompiler BatchResult +hscBatchCompiler = + HsCompiler { - hscCompile = genericHscCompile batchMsg + hscCompile = genericHscCompile hscBatchCompiler batchMsg - hscNoRecomp iface = do - details <- genModDetails iface - return (HscNoRecomp, iface, details) + , hscNoRecomp = \iface -> do + details <- genModDetails iface + return (HscNoRecomp, iface, details) - hscRecompile = genericHscRecompile + , hscRecompile = genericHscRecompile 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) + , 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) - 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) + , 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) + } -- Compile Haskell, boot and extCore in batch mode. -hscCompileBatch :: Compiler (BatchStatus, ModIface, ModDetails) -hscCompileBatch = hscCompile +hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails) +hscCompileBatch = hscCompile hscBatchCompiler -------------------------------------------------------------- -instance HsCompiler InteractiveResult where +hscInteractiveCompiler :: HsCompiler InteractiveResult +hscInteractiveCompiler = + HsCompiler { + hscCompile = genericHscCompile hscInteractiveCompiler batchMsg - hscCompile = genericHscCompile batchMsg + , hscNoRecomp = \iface -> do + details <- genModDetails iface + return (HscNoRecomp, iface, details) - hscNoRecomp iface = do - details <- genModDetails iface - return (HscNoRecomp, iface, details) + , hscRecompile = genericHscRecompile hscInteractiveCompiler - hscRecompile = genericHscRecompile + , hscGenBootOutput = \_ _ _ -> panic "hscCompileInteractive: HsBootFile" - hscGenBootOutput _ _ _ = panic "hscCompileInteractive: HsBootFile" - - hscGenOutput guts0 mod_summary mb_old_iface = do - guts <- hscSimplify guts0 - (iface, _changed, details, cgguts) - <- hscNormalIface guts mb_old_iface - hscInteractive (iface, details, cgguts) mod_summary + , hscGenOutput = \guts0 mod_summary mb_old_iface -> do + guts <- hscSimplify guts0 + (iface, _changed, details, cgguts) + <- hscNormalIface guts mb_old_iface + hscInteractive (iface, details, cgguts) mod_summary + } -- Compile Haskell, extCore to bytecode. hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails) -hscCompileInteractive = hscCompile +hscCompileInteractive = hscCompile hscInteractiveCompiler -------------------------------------------------------------- -instance HsCompiler NothingResult where - - hscCompile = genericHscCompile batchMsg - - hscNoRecomp iface = do - details <- genModDetails iface - return (HscNoRecomp, iface, details) +hscNothingCompiler :: HsCompiler NothingResult +hscNothingCompiler = + HsCompiler { + hscCompile = genericHscCompile hscNothingCompiler batchMsg - hscRecompile mod_summary mb_old_hash - | ExtCoreFile <- ms_hsc_src mod_summary = - panic "hscCompileNothing: cannot do external core" - | otherwise = do - tc_result <- hscFileFrontEnd mod_summary - hscGenBootOutput tc_result mod_summary mb_old_hash - - hscGenBootOutput tc_result _mod_summary mb_old_iface = do - (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface - return (HscRecomp False HscNothingTag, iface, details) - - hscGenOutput _ _ _ = - panic "hscCompileNothing: hscGenOutput should not be called" + , hscNoRecomp = \iface -> do + details <- genModDetails iface + return (HscNoRecomp, iface, details) + , hscRecompile = \mod_summary mb_old_hash -> + case ms_hsc_src mod_summary of + ExtCoreFile -> + panic "hscCompileNothing: cannot do external core" + _otherwise -> do + tc_result <- hscFileFrontEnd mod_summary + hscGenBootOutput hscNothingCompiler tc_result mod_summary mb_old_hash + + , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do + (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface + return (HscRecomp False (), iface, details) + + , hscGenOutput = \_ _ _ -> + panic "hscCompileNothing: hscGenOutput should not be called" + } -- Type-check Haskell and .hs-boot only (no external core) -hscCompileNothing :: Compiler (NothingStatus, ModIface, ModDetails) -hscCompileNothing = hscCompile +hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails) +hscCompileNothing = hscCompile hscNothingCompiler -------------------------------------------------------------- -- NoRecomp handlers -- 1.7.10.4