X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=3242dba9e57fd535a632a3d29da7b885a8a21565;hp=ff1c11577b44fa93d8e155e4634c0bd9dae432f0;hb=6084fb5517da34f65034370a3695e2af3b85ce2b;hpb=7379e82aafc7d0c1b839a13a20d52babeafed023 diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index ff1c115..3242dba 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -8,6 +8,10 @@ module HscMain ( newHscEnv, hscCmmFile , hscParseIdentifier + , hscSimplify + , evalComp + , hscNormalIface, hscWriteIface, hscOneShot + , CompState (..) #ifdef GHCI , hscStmt, hscTcExpr, hscKcType , compileExpr @@ -28,15 +32,12 @@ module HscMain , makeSimpleDetails ) where -#include "HsVersions.h" - #ifdef GHCI import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker ( HValue, linkExpr ) import CoreTidy ( tidyExpr ) import CorePrep ( corePrepExpr ) -import Flattening ( flattenExpr ) import Desugar ( deSugarExpr ) import SimplCore ( simplifyExpr ) import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType ) @@ -50,7 +51,7 @@ import VarSet import VarEnv ( emptyTidyEnv ) #endif -import Var ( Id ) +import Id ( Id ) import Module ( emptyModuleEnv, ModLocation(..), Module ) import RdrName import HsSyn @@ -60,7 +61,7 @@ import StringBuffer import Parser import Lexer import SrcLoc ( mkSrcLoc ) -import TcRnDriver ( tcRnModule, tcRnExtCore ) +import TcRnDriver ( tcRnModule ) import TcIface ( typecheckIface ) import TcRnMonad ( initIfaceCheck, TcGblEnv(..) ) import IfaceEnv ( initNameCache ) @@ -83,6 +84,7 @@ import CmmParse ( parseCmmFile ) import CmmCPS import CmmCPSZ import CmmInfo +import OptimizationFuel ( initOptFuelState ) import CmmCvt import CmmTx import CmmContFlowOpt @@ -97,10 +99,8 @@ import Outputable import HscStats ( ppSourceStats ) import HscTypes import MkExternalCore ( emitExternalCore ) -import ParserCore -import ParserCoreUtils import FastString -import UniqFM ( emptyUFM ) +import LazyUniqFM ( emptyUFM ) import UniqSupply ( initUs_ ) import Bag ( unitBag ) @@ -124,16 +124,19 @@ newHscEnv dflags ; us <- mkSplitUniqSupply 'r' ; nc_var <- newIORef (initNameCache us knownKeyNames) ; fc_var <- newIORef emptyUFM - ; mlc_var <- newIORef emptyModuleEnv + ; mlc_var <- newIORef emptyModuleEnv + ; optFuel <- initOptFuelState ; return (HscEnv { hsc_dflags = dflags, hsc_targets = [], hsc_mod_graph = [], - hsc_IC = emptyInteractiveContext, - hsc_HPT = emptyHomePackageTable, - hsc_EPS = eps_var, - hsc_NC = nc_var, - hsc_FC = fc_var, - hsc_MLC = mlc_var, + hsc_IC = emptyInteractiveContext, + hsc_HPT = emptyHomePackageTable, + hsc_EPS = eps_var, + hsc_NC = nc_var, + hsc_FC = fc_var, + hsc_MLC = mlc_var, + hsc_OptFuel = optFuel, + hsc_type_env_var = Nothing, hsc_global_rdr_env = emptyGlobalRdrEnv, hsc_global_type_env = emptyNameEnv } ) } @@ -217,7 +220,7 @@ deSugarModule hsc_env mod_summary tc_result makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails -> IO (ModIface,Bool) makeSimpleIface hsc_env maybe_old_iface tc_result details = do - mkIfaceTc hsc_env maybe_old_iface details tc_result + mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result -- | Make a 'ModDetails' from the results of typechecking. Used when -- typechecking only, as opposed to full compilation. @@ -333,43 +336,64 @@ type Compiler result = HscEnv -- Compile Haskell, boot and extCore in OneShot mode. hscCompileOneShot :: Compiler HscStatus -hscCompileOneShot - = hscCompiler norecompOneShot oneShotMsg backend boot_backend +hscCompileOneShot 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 <- newIORef emptyNameEnv + let + mod = ms_mod mod_summary + hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) } + --- + hscCompilerOneShot' hsc_env' mod_summary src_changed mb_old_iface mb_i_of_n + +hscCompilerOneShot' :: Compiler HscStatus +hscCompilerOneShot' + = hscCompiler norecompOneShot oneShotMsg (genComp backend boot_backend) where backend inp = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscOneShot - boot_backend inp = hscSimpleIface inp >>= hscWriteIface >> return (HscRecomp False) + boot_backend inp = hscSimpleIface inp >>= hscWriteIface >> return (Just (HscRecomp False)) -- Compile Haskell, boot and extCore in batch mode. hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails) hscCompileBatch - = hscCompiler norecompBatch batchMsg backend boot_backend + = hscCompiler norecompBatch batchMsg (genComp backend boot_backend) where backend inp = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscBatch boot_backend inp = hscSimpleIface inp >>= hscWriteIface >>= hscNothing --- Type-check Haskell, boot and extCore. --- Does it make sense to compile extCore to nothing? -hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails) -hscCompileNothing - = hscCompiler norecompBatch batchMsg backend backend - where - backend inp = hscSimpleIface inp >>= hscIgnoreIface >>= hscNothing - -- Compile Haskell, extCore to bytecode. hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails) hscCompileInteractive - = hscCompiler norecompInteractive batchMsg backend boot_backend + = hscCompiler norecompInteractive batchMsg (genComp backend boot_backend) where backend inp = hscSimplify inp >>= hscNormalIface >>= hscIgnoreIface >>= hscInteractive - boot_backend = panic "hscCompileInteractive: can't do boot files here" + boot_backend _ = panic "hscCompileInteractive: HsBootFile" +-- Type-check Haskell and .hs-boot only (no external core) +hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails) +hscCompileNothing + = hscCompiler norecompBatch batchMsg comp + where + backend tc = hscSimpleIface tc >>= hscIgnoreIface >>= hscNothing + + comp = do -- genComp doesn't fit here, because we want to omit + -- desugaring and for the backend to take a TcGblEnv + mod_summary <- gets compModSummary + case ms_hsc_src mod_summary of + ExtCoreFile -> panic "hscCompileNothing: cannot do external core" + _other -> do + mb_tc <- hscFileFrontEnd + case mb_tc of + Nothing -> return Nothing + Just tc_result -> backend tc_result + hscCompiler - :: NoRecomp result -- No recomp necessary - -> (Maybe (Int,Int) -> Bool -> Comp ()) -- Message callback - -> (ModGuts -> Comp result) -- Compile normal file - -> (ModGuts -> Comp result) -- Compile boot file + :: NoRecomp result -- No recomp necessary + -> (Maybe (Int,Int) -> Bool -> Comp ()) -- Message callback + -> Comp (Maybe result) -> Compiler result -hscCompiler norecomp messenger nonBootComp bootComp hsc_env mod_summary +hscCompiler norecomp messenger recomp hsc_env mod_summary source_unchanged mbOldIface mbModIndex = flip evalComp (CompState hsc_env mod_summary mbOldIface) $ do (recomp_reqd, mbCheckedIface) @@ -387,21 +411,29 @@ hscCompiler norecomp messenger nonBootComp bootComp hsc_env mod_summary return (Just result) _otherwise -> do messenger mbModIndex True - mb_modguts <- frontend - case mb_modguts of - Nothing - -> return Nothing - Just core - -> do result <- backend core - return (Just result) - where - frontend :: Comp (Maybe ModGuts) -- Front end - -- backend :: (ModGuts -> Comp result) -- Backend. - (frontend,backend) - = case ms_hsc_src mod_summary of - ExtCoreFile -> (hscCoreFrontEnd, nonBootComp) - HsSrcFile -> (hscFileFrontEnd, nonBootComp) - HsBootFile -> (hscFileFrontEnd, bootComp) + recomp + +-- the usual way to build the Comp (Maybe result) to pass to hscCompiler +genComp :: (ModGuts -> Comp (Maybe a)) + -> (TcGblEnv -> Comp (Maybe a)) + -> Comp (Maybe a) +genComp backend boot_backend = do + mod_summary <- gets compModSummary + case ms_hsc_src mod_summary of + ExtCoreFile -> do + panic "GHC does not currently support reading External Core files" + _not_core -> do + mb_tc <- hscFileFrontEnd + case mb_tc of + Nothing -> return Nothing + Just tc_result -> + case ms_hsc_src mod_summary of + HsBootFile -> boot_backend tc_result + _other -> do + mb_guts <- hscDesugar tc_result + case mb_guts of + Nothing -> return Nothing + Just guts -> backend guts -------------------------------------------------------------- -- NoRecomp handlers @@ -423,7 +455,6 @@ norecompInteractive = norecompWorker InteractiveNoRecomp True norecompWorker :: a -> Bool -> NoRecomp (a, ModIface, ModDetails) norecompWorker a _isInterp old_iface = do hsc_env <- gets compHscEnv - _mod_summary <- gets compModSummary liftIO $ do new_details <- {-# SCC "tcRnIface" #-} initIfaceCheck hsc_env $ @@ -461,33 +492,7 @@ batchMsg mb_mod_index recomp -------------------------------------------------------------- -- FrontEnds -------------------------------------------------------------- - -hscCoreFrontEnd :: Comp (Maybe ModGuts) -hscCoreFrontEnd = - do hsc_env <- gets compHscEnv - mod_summary <- gets compModSummary - liftIO $ do - ------------------- - -- PARSE - ------------------- - inp <- readFile (ms_hspp_file mod_summary) - case parseCore inp 1 of - FailP s - -> do errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-}) - return Nothing - OkP rdr_module - ------------------- - -- RENAME and TYPECHECK - ------------------- - -> do (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-} - tcRnExtCore hsc_env rdr_module - printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs - case maybe_tc_result of - Nothing -> return Nothing - Just mod_guts -> return (Just mod_guts) -- No desugaring to do! - - -hscFileFrontEnd :: Comp (Maybe ModGuts) +hscFileFrontEnd :: Comp (Maybe TcGblEnv) hscFileFrontEnd = do hsc_env <- gets compHscEnv mod_summary <- gets compModSummary @@ -511,14 +516,23 @@ hscFileFrontEnd = <- {-# SCC "Typecheck-Rename" #-} tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module printErrorsAndWarnings dflags tc_msgs - case maybe_tc_result of - Nothing - -> return Nothing - Just tc_result - ------------------- - -- DESUGAR - ------------------- - -> {-# SCC "DeSugar" #-} deSugar hsc_env (ms_location mod_summary) tc_result + return maybe_tc_result + +-------------------------------------------------------------- +-- Desugaring +-------------------------------------------------------------- + +hscDesugar :: TcGblEnv -> Comp (Maybe ModGuts) +hscDesugar tc_result + = do mod_summary <- gets compModSummary + hsc_env <- gets compHscEnv + liftIO $ do + ------------------- + -- DESUGAR + ------------------- + ds_result <- {-# SCC "DeSugar" #-} + deSugar hsc_env (ms_location mod_summary) tc_result + return ds_result -------------------------------------------------------------- -- Simplifiers @@ -542,19 +556,18 @@ hscSimplify ds_result -- HACK: we return ModGuts even though we know it's not gonna be used. -- We do this because the type signature needs to be identical -- in structure to the type of 'hscNormalIface'. -hscSimpleIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, ModGuts) -hscSimpleIface ds_result +hscSimpleIface :: TcGblEnv -> Comp (ModIface, Bool, ModDetails, TcGblEnv) +hscSimpleIface tc_result = do hsc_env <- gets compHscEnv - _mod_summary <- gets compModSummary maybe_old_iface <- gets compOldIface liftIO $ do - details <- mkBootModDetailsDs hsc_env ds_result + details <- mkBootModDetailsTc hsc_env tc_result (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - mkIface hsc_env maybe_old_iface details ds_result + mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result -- And the answer is ... dumpIfaceStats hsc_env - return (new_iface, no_change, details, ds_result) + return (new_iface, no_change, details, tc_result) hscNormalIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, CgGuts) hscNormalIface simpl_result @@ -576,9 +589,13 @@ hscNormalIface simpl_result -- until after code output (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - mkIface hsc_env maybe_old_iface details simpl_result + mkIface hsc_env (fmap mi_iface_hash maybe_old_iface) + details simpl_result -- Emit external core - emitExternalCore (hsc_dflags hsc_env) (availsToNameSet (mg_exports simpl_result)) cg_guts -- Move this? --Lemmih 03/07/2006 + -- This should definitely be here and not after CorePrep, + -- because CorePrep produces unqualified constructor wrapper declarations, + -- so its output isn't valid External Core (without some preprocessing). + emitExternalCore (hsc_dflags hsc_env) cg_guts dumpIfaceStats hsc_env ------------------- @@ -604,21 +621,21 @@ hscIgnoreIface (iface, _no_change, details, a) = return (iface, details, a) -- Don't output any code. -hscNothing :: (ModIface, ModDetails, a) -> Comp (HscStatus, ModIface, ModDetails) +hscNothing :: (ModIface, ModDetails, a) -> Comp (Maybe (HscStatus, ModIface, ModDetails)) hscNothing (iface, details, _) - = return (HscRecomp False, iface, details) + = return (Just (HscRecomp False, iface, details)) -- Generate code and return both the new ModIface and the ModDetails. -hscBatch :: (ModIface, ModDetails, CgGuts) -> Comp (HscStatus, ModIface, ModDetails) +hscBatch :: (ModIface, ModDetails, CgGuts) -> Comp (Maybe (HscStatus, ModIface, ModDetails)) hscBatch (iface, details, cgguts) = do hasStub <- hscCompile cgguts - return (HscRecomp hasStub, iface, details) + return (Just (HscRecomp hasStub, iface, details)) -- Here we don't need the ModIface and ModDetails anymore. -hscOneShot :: (ModIface, ModDetails, CgGuts) -> Comp HscStatus +hscOneShot :: (ModIface, ModDetails, CgGuts) -> Comp (Maybe HscStatus) hscOneShot (_, _, cgguts) = do hasStub <- hscCompile cgguts - return (HscRecomp hasStub) + return (Just (HscRecomp hasStub)) -- Compile to hard-code. hscCompile :: CgGuts -> Comp Bool @@ -656,8 +673,8 @@ hscCompile cgguts dir_imps cost_centre_info stg_binds hpc_info --- Optionally run experimental Cmm transformations --- - cmms <- optionallyConvertAndOrCPS dflags cmms - -- ^ unless certain dflags are on, the identity function + cmms <- optionallyConvertAndOrCPS hsc_env cmms + -- unless certain dflags are on, the identity function ------------------ Code output ----------------------- rawcmms <- cmmToRawCmm cmms (_stub_h_exists, stub_c_exists) @@ -666,7 +683,7 @@ hscCompile cgguts return stub_c_exists hscInteractive :: (ModIface, ModDetails, CgGuts) - -> Comp (InteractiveStatus, ModIface, ModDetails) + -> Comp (Maybe (InteractiveStatus, ModIface, ModDetails)) #ifdef GHCI hscInteractive (iface, details, cgguts) = do hsc_env <- gets compHscEnv @@ -695,20 +712,21 @@ hscInteractive (iface, details, cgguts) ------------------ Create f-x-dynamic C-side stuff --- (_istub_h_exists, istub_c_exists) <- outputForeignStubs dflags this_mod location foreign_stubs - return (InteractiveRecomp istub_c_exists comp_bc mod_breaks, iface, details) + return (Just (InteractiveRecomp istub_c_exists comp_bc mod_breaks, iface, details)) #else hscInteractive _ = panic "GHC not compiled with interpreter" #endif ------------------------------ -hscCmmFile :: DynFlags -> FilePath -> IO Bool -hscCmmFile dflags filename = do +hscCmmFile :: HscEnv -> FilePath -> IO Bool +hscCmmFile hsc_env filename = do + dflags <- return $ hsc_dflags hsc_env maybe_cmm <- parseCmmFile dflags filename case maybe_cmm of Nothing -> return False Just cmm -> do - cmms <- optionallyConvertAndOrCPS dflags [cmm] + cmms <- optionallyConvertAndOrCPS hsc_env [cmm] rawCmms <- cmmToRawCmm cmms codeOutput dflags no_mod no_loc NoStubs [] rawCmms return True @@ -718,11 +736,12 @@ hscCmmFile dflags filename = do ml_hi_file = panic "hscCmmFile: no hi file", ml_obj_file = panic "hscCmmFile: no obj file" } -optionallyConvertAndOrCPS :: DynFlags -> [Cmm] -> IO [Cmm] -optionallyConvertAndOrCPS dflags cmms = - do -------- Optionally convert to and from zipper ------ +optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm] +optionallyConvertAndOrCPS hsc_env cmms = + do let dflags = hsc_dflags hsc_env + -------- Optionally convert to and from zipper ------ cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags - then mapM (testCmmConversion dflags) cmms + then mapM (testCmmConversion hsc_env) cmms else return cmms --------- Optionally convert to CPS (MDA) ----------- cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) && @@ -732,9 +751,10 @@ optionallyConvertAndOrCPS dflags cmms = return cmms -testCmmConversion :: DynFlags -> Cmm -> IO Cmm -testCmmConversion dflags cmm = - do showPass dflags "CmmToCmm" +testCmmConversion :: HscEnv -> Cmm -> IO Cmm +testCmmConversion hsc_env cmm = + do let dflags = hsc_dflags hsc_env + showPass dflags "CmmToCmm" dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm) --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm us <- mkSplitUniqSupply 'C' @@ -742,7 +762,7 @@ testCmmConversion dflags cmm = let cvtm = do g <- cmmToZgraph cmm return $ cfopts g let zgraph = initUs_ us cvtm - cps_zgraph <- protoCmmCPSZ dflags zgraph + cps_zgraph <- protoCmmCPSZ hsc_env 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" @@ -927,7 +947,7 @@ hscParseThing parser dflags str buf <- stringToStringBuffer str - let loc = mkSrcLoc FSLIT("") 1 0 + let loc = mkSrcLoc (fsLit "") 1 0 case unP parser (mkPState buf loc dflags) of { @@ -961,11 +981,8 @@ compileExpr hsc_env srcspan ds_expr = do { let { dflags = hsc_dflags hsc_env ; lint_on = dopt Opt_DoCoreLinting dflags } - -- Flatten it - ; flat_expr <- flattenExpr hsc_env ds_expr - -- Simplify it - ; simpl_expr <- simplifyExpr dflags flat_expr + ; simpl_expr <- simplifyExpr dflags ds_expr -- Tidy it (temporary, until coreSat does cloning) ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr