X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=26247b143ad2279b27df7be5ca5d2da7675011fa;hp=e95be761b94c67f3bd311053691d7cb0d98ce9b2;hb=7bb3d1fc79521d591cd9f824893963141a7997b6;hpb=1dfe7f1ee44b6ae59e072eec720984b136fc1dc5 diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index e95be76..26247b1 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) @@ -109,10 +112,10 @@ import LazyUniqFM ( emptyUFM ) import UniqSupply ( initUs_ ) import Bag ( unitBag ) import Exception -import MonadUtils +-- import MonadUtils import Control.Monad -import System.IO +-- import System.IO import Data.IORef \end{code} #include "HsVersions.h" @@ -226,12 +229,13 @@ hscTypecheckRename mod_summary rdr_module = do <- {-# SCC "Typecheck-Rename" #-} ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module - let rn_info = do decl <- tcg_rn_decls tc_result - imports <- tcg_rn_imports tc_result - let exports = tcg_rn_exports tc_result - let doc = tcg_doc tc_result - let hmi = tcg_hmi tc_result - return (decl,imports,exports,doc,hmi) + let -- This 'do' is in the Maybe monad! + rn_info = do { decl <- tcg_rn_decls tc_result + ; let imports = tcg_rn_imports tc_result + exports = tcg_rn_exports tc_result + doc = tcg_doc tc_result + hmi = tcg_hmi tc_result + ; return (decl,imports,exports,doc,hmi) } return (tc_result, rn_info) @@ -313,7 +317,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 +351,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 +398,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 +437,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 +471,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 +505,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 +539,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" } @@ -693,10 +718,11 @@ hscGenHardCode cgguts mod_summary stg_binds hpc_info --- Optionally run experimental Cmm transformations --- - cmms <- optionallyConvertAndOrCPS hsc_env cmms + -- cmms <- optionallyConvertAndOrCPS hsc_env cmms -- unless certain dflags are on, the identity function ------------------ Code output ----------------------- rawcmms <- cmmToRawCmm cmms + dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr rawcmms) (_stub_h_exists, stub_c_exists) <- codeOutput dflags this_mod location foreign_stubs dependencies rawcmms @@ -733,7 +759,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 @@ -747,7 +774,7 @@ hscCmmFile hsc_env filename = do parseCmmFile dflags filename cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm] rawCmms <- liftIO $ cmmToRawCmm cmms - liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms + _ <- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms return () where no_mod = panic "hscCmmFile: no_mod" @@ -786,10 +813,8 @@ tryNewCodeGen hsc_env this_mod data_tycons imported_mods ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog) -- Control flow optimisation, again - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprCmms prog) - ; let prog' = map cmmOfZgraph prog - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr prog') + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog') ; return prog' } @@ -828,7 +853,6 @@ testCmmConversion hsc_env cmm = let cvt = cmmOfZgraph $ cfopts $ chosen_graph dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt) return cvt - -- return cmm -- don't use the conversion myCoreToStg :: DynFlags -> Module -> [CoreBind] -> IO ( [(StgBinding,[(Id,[Id])])] -- output program