X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=26247b143ad2279b27df7be5ca5d2da7675011fa;hp=dd88f721f125e12d584bae144fd65f9f8c7e8c4e;hb=7bb3d1fc79521d591cd9f824893963141a7997b6;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69 diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index dd88f72..26247b1 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -1,10 +1,13 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 % - -\section[GHC_Main]{Main driver for Glasgow Haskell compiler} - \begin{code} +-- | Main driver for the compiling plain Haskell source code. +-- +-- This module implements compilation of a Haskell-only source file. It is +-- /not/ concerned with preprocessing of source files; this is handled in +-- "DriverPipeline". +-- module HscMain ( newHscEnv, hscCmmFile , hscParseIdentifier @@ -14,12 +17,15 @@ 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) , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails) , HscStatus' (..) - , InteractiveStatus, NothingStatus, OneShotStatus, BatchStatus + , InteractiveStatus, HscStatus -- The new interface , hscParse @@ -81,6 +87,7 @@ import CodeGen ( codeGen ) import Cmm ( Cmm ) import PprCmm ( pprCmms ) import CmmParse ( parseCmmFile ) +import CmmBuildInfoTables import CmmCPS import CmmCPSZ import CmmInfo @@ -105,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" @@ -121,8 +128,8 @@ import Data.IORef %************************************************************************ \begin{code} -newHscEnv :: DynFlags -> IO HscEnv -newHscEnv dflags +newHscEnv :: GhcApiCallbacks -> DynFlags -> IO HscEnv +newHscEnv callbacks dflags = do { eps_var <- newIORef initExternalPackageState ; us <- mkSplitUniqSupply 'r' ; nc_var <- newIORef (initNameCache us knownKeyNames) @@ -130,6 +137,7 @@ newHscEnv dflags ; mlc_var <- newIORef emptyModuleEnv ; optFuel <- initOptFuelState ; return (HscEnv { hsc_dflags = dflags, + hsc_callbacks = callbacks, hsc_targets = [], hsc_mod_graph = [], hsc_IC = emptyInteractiveContext, @@ -221,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) @@ -307,17 +316,13 @@ 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 HscStatus = HscStatus' () +type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks)) + -- INVARIANT: result is @Nothing@ <=> input was a boot file -type OneShotStatus = HscStatus' HscOneShotTag -type BatchStatus = 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 @@ -330,36 +335,41 @@ 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, + + hscBackend :: GhcMonad m => + TcGblEnv -> 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 @@ -374,147 +384,176 @@ 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 - _other -> do - guts <- hscDesugar mod_summary tc_result - hscGenOutput 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 -------------------------------------------------------------- -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 + + , 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 + 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) + , hscBackend = genericHscBackend hscBatchCompiler - 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) + , 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) + } -- 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 + , hscBackend = genericHscBackend hscInteractiveCompiler - hscGenBootOutput _ _ _ = panic "hscCompileInteractive: HsBootFile" + , 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 - (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 + hscBackend hscNothingCompiler tc_result mod_summary mb_old_hash + + , 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" + } -- 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 @@ -667,24 +706,23 @@ hscGenHardCode cgguts mod_summary <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds - ------------------ Try new code gen route ---------- - cmms <- tryNewCodeGen hsc_env this_mod data_tycons - dir_imps cost_centre_info - stg_binds hpc_info - ------------------ Code generation ------------------ cmms <- if dopt Opt_TryNewCodeGen (hsc_dflags hsc_env) - then pprTrace "cmms" (ppr cmms) $ return cmms + then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons + dir_imps cost_centre_info + stg_binds hpc_info + return cmms else {-# SCC "CodeGen" #-} codeGen dflags this_mod data_tycons dir_imps cost_centre_info 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 @@ -721,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 @@ -735,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" @@ -764,16 +803,19 @@ tryNewCodeGen hsc_env this_mod data_tycons imported_mods ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog -- Control flow optimisation - ; prog <- mapM (protoCmmCPSZ hsc_env) prog + -- Note: Have to thread the module's SRT through all the procedures + -- because we greedily build it as we go. + ; us <- mkSplitUniqSupply 'S' + ; let topSRT = initUs_ us emptySRT + ; (topSRT, prog) <- foldM (protoCmmCPSZ hsc_env) (topSRT, []) prog -- The main CPS conversion - ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog + ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog) -- Control flow optimisation, again - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" - (pprCmms prog) - - ; return $ map cmmOfZgraph prog } + ; let prog' = map cmmOfZgraph prog + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog') + ; return prog' } optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm] @@ -802,14 +844,15 @@ testCmmConversion hsc_env cmm = let cvtm = do g <- cmmToZgraph cmm return $ cfopts g let zgraph = initUs_ us cvtm - cps_zgraph <- protoCmmCPSZ hsc_env zgraph + us <- mkSplitUniqSupply 'S' + let topSRT = initUs_ us emptySRT + (_, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph) showPass dflags "Convert from Z back to 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