X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=604f7a7abc24c419041aa16dec83b53f613c2d23;hp=0b8a5a26758829bde29becd500621c5caaeabf15;hb=refs%2Ftags%2F2008-06-01;hpb=4c6a3f787abcaed009a574196d82237d9ae64fc8 diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 0b8a5a2..604f7a7 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -32,8 +32,6 @@ module HscMain , makeSimpleDetails ) where -#include "HsVersions.h" - #ifdef GHCI import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) @@ -86,6 +84,7 @@ import CmmParse ( parseCmmFile ) import CmmCPS import CmmCPSZ import CmmInfo +import OptimizationFuel ( initOptFuelState ) import CmmCvt import CmmTx import CmmContFlowOpt @@ -125,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 } ) } @@ -218,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. @@ -334,7 +336,19 @@ type Compiler result = HscEnv -- Compile Haskell, boot and extCore in OneShot mode. hscCompileOneShot :: Compiler HscStatus -hscCompileOneShot +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 @@ -550,7 +564,7 @@ hscSimpleIface tc_result details <- mkBootModDetailsTc hsc_env tc_result (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - mkIfaceTc hsc_env maybe_old_iface details tc_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, tc_result) @@ -575,7 +589,8 @@ 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 -- This should definitely be here and not after CorePrep, -- because CorePrep produces unqualified constructor wrapper declarations, @@ -658,7 +673,7 @@ hscCompile cgguts dir_imps cost_centre_info stg_binds hpc_info --- Optionally run experimental Cmm transformations --- - cmms <- optionallyConvertAndOrCPS dflags cmms + cmms <- optionallyConvertAndOrCPS hsc_env cmms -- ^ unless certain dflags are on, the identity function ------------------ Code output ----------------------- rawcmms <- cmmToRawCmm cmms @@ -704,13 +719,14 @@ hscInteractive _ = panic "GHC not compiled with interpreter" ------------------------------ -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 @@ -720,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) && @@ -734,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' @@ -744,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" @@ -929,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 {