X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscMain.lhs;h=187f6442f38d2623b7bfcfb3c34f19c8443cea4a;hb=03a9ff01812afc81eb5236fd3063cbec44cf469e;hp=8b3ad405be0a92de1ce609d02207ff89bc6a8ebd;hpb=dd313897eb9a14bcc7b81f97e4f2292c30039efd;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 8b3ad40..187f644 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -12,7 +12,6 @@ module HscMain ( hscParseIdentifier, #ifdef GHCI hscStmt, hscTcExpr, hscKcType, - hscGetInfo, GetInfoResult, compileExpr, #endif ) where @@ -21,7 +20,6 @@ module HscMain ( #ifdef GHCI import HsSyn ( Stmt(..), LHsExpr, LStmt, LHsType ) -import IfaceSyn ( IfaceDecl, IfaceInst ) import Module ( Module ) import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) @@ -29,16 +27,13 @@ import Linker ( HValue, linkExpr ) import CoreTidy ( tidyExpr ) import CorePrep ( corePrepExpr ) import Flattening ( flattenExpr ) -import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnGetInfo, GetInfoResult, tcRnType ) -import RdrName ( rdrNameOcc ) -import OccName ( occNameUserString ) +import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType ) import Type ( Type ) import PrelNames ( iNTERACTIVE ) import Kind ( Kind ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) -import BasicTypes ( Fixity ) -import SrcLoc ( SrcLoc, noSrcLoc ) +import SrcLoc ( noSrcLoc ) import VarEnv ( emptyTidyEnv ) #endif @@ -61,9 +56,11 @@ import MkIface ( checkOldIface, mkIface, writeIfaceFile ) import Desugar import Flattening ( flatten ) import SimplCore -import TidyPgm ( optTidyPgm, simpleTidyPgm ) +import TidyPgm ( tidyProgram, mkBootModDetails ) import CorePrep ( corePrepPgm ) import CoreToStg ( coreToStg ) +import TyCon ( isDataTyCon ) +import Packages ( mkHomeModules ) import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) @@ -71,7 +68,6 @@ import CmmParse ( parseCmmFile ) import CodeOutput ( codeOutput ) import DynFlags -import DriverPhases ( HscSource(..) ) import ErrUtils import UniqSupply ( mkSplitUniqSupply ) @@ -355,23 +351,18 @@ hscBootBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO hscBootBackEnd hsc_env mod_summary maybe_old_iface Nothing = return HscFail hscBootBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) - = do { tidy_pgm <- simpleTidyPgm hsc_env ds_result + = do { details <- mkBootModDetails hsc_env ds_result ; (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - mkIface hsc_env maybe_old_iface tidy_pgm + mkIface hsc_env maybe_old_iface ds_result details ; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change - ; let { final_details = ModDetails { md_types = mg_types ds_result, - md_exports = mg_exports ds_result, - md_insts = mg_insts ds_result, - md_rules = mg_rules ds_result } } -- And the answer is ... ; dumpIfaceStats hsc_env - ; return (HscRecomp final_details - new_iface + ; return (HscRecomp details new_iface False False Nothing) } @@ -427,14 +418,8 @@ hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) ------------------- -- TIDY ------------------- - ; let omit_prags = dopt Opt_OmitInterfacePragmas dflags - ; tidy_result <- {-# SCC "CoreTidy" #-} - if omit_prags - then simpleTidyPgm hsc_env simpl_result - else optTidyPgm hsc_env simpl_result - - -- Emit external core - ; emitExternalCore dflags tidy_result + ; (cg_guts, details) <- {-# SCC "CoreTidy" #-} + tidyProgram hsc_env simpl_result -- Alive at this point: -- tidy_result, pcs_final @@ -446,8 +431,9 @@ hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) -- This has to happen *after* code gen so that the back-end -- info has been set. Not yet clear if it matters waiting -- until after code output - ; (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - mkIface hsc_env maybe_old_iface tidy_result + ; (new_iface, no_change) + <- {-# SCC "MkFinalIface" #-} + mkIface hsc_env maybe_old_iface simpl_result details ; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change @@ -459,18 +445,16 @@ hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) -- Build the final ModDetails (except in one-shot mode, where -- we won't need this information after compilation). - ; final_details <- - if one_shot then return (error "no final details") - else return $! ModDetails { - md_types = mg_types tidy_result, - md_exports = mg_exports tidy_result, - md_insts = mg_insts tidy_result, - md_rules = mg_rules tidy_result } + ; final_details <- if one_shot then return (error "no final details") + else return $! details + + -- Emit external core + ; emitExternalCore dflags cg_guts ------------------- -- CONVERT TO STG and COMPLETE CODE GENERATION ; (stub_h_exists, stub_c_exists, maybe_bcos) - <- hscCodeGen dflags tidy_result + <- hscCodeGen dflags cg_guts -- And the answer is ... ; dumpIfaceStats hsc_env @@ -484,20 +468,25 @@ hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) hscCodeGen dflags - ModGuts{ -- This is the last use of the ModGuts in a compilation. + CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. - mg_module = this_mod, - mg_binds = core_binds, - mg_types = type_env, - mg_dir_imps = dir_imps, - mg_foreign = foreign_stubs, - mg_deps = dependencies } = do { + cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_dir_imps = dir_imps, + cg_foreign = foreign_stubs, + cg_home_mods = home_mods, + cg_dep_pkgs = dependencies } = do { + + let { data_tycons = filter isDataTyCon tycons } ; + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes ------------------- -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form prepd_binds <- {-# SCC "CorePrep" #-} - corePrepPgm dflags core_binds type_env; + corePrepPgm dflags core_binds data_tycons ; case hscTarget dflags of HscNothing -> return (False, False, Nothing) @@ -505,7 +494,7 @@ hscCodeGen dflags HscInterpreted -> #ifdef GHCI do ----------------- Generate byte code ------------------ - comp_bc <- byteCodeGen dflags prepd_binds type_env + comp_bc <- byteCodeGen dflags prepd_binds data_tycons ------------------ Create f-x-dynamic C-side stuff --- (istub_h_exists, istub_c_exists) @@ -520,12 +509,13 @@ hscCodeGen dflags do ----------------- Convert to STG ------------------ (stg_binds, cost_centre_info) <- {-# SCC "CoreToStg" #-} - myCoreToStg dflags this_mod prepd_binds + myCoreToStg dflags home_mods this_mod prepd_binds ------------------ Code generation ------------------ abstractC <- {-# SCC "CodeGen" #-} - codeGen dflags this_mod type_env foreign_stubs - dir_imps cost_centre_info stg_binds + codeGen dflags home_mods this_mod data_tycons + foreign_stubs dir_imps cost_centre_info + stg_binds ------------------ Code output ----------------------- (stub_h_exists, stub_c_exists) @@ -538,11 +528,11 @@ hscCodeGen dflags hscCmmFile :: DynFlags -> FilePath -> IO Bool hscCmmFile dflags filename = do - maybe_cmm <- parseCmmFile dflags filename + maybe_cmm <- parseCmmFile dflags (mkHomeModules []) filename case maybe_cmm of Nothing -> return False Just cmm -> do - codeOutput dflags no_mod NoStubs noDependencies [cmm] + codeOutput dflags no_mod NoStubs [] [cmm] return True where no_mod = panic "hscCmmFile: no_mod" @@ -578,13 +568,13 @@ myParseModule dflags src_filename maybe_src_buf }} -myCoreToStg dflags this_mod prepd_binds +myCoreToStg dflags home_mods this_mod prepd_binds = do stg_binds <- {-# SCC "Core2Stg" #-} - coreToStg dflags prepd_binds + coreToStg home_mods prepd_binds - (stg_binds2, cost_centre_info) <- {-# SCC "Core2Stg" #-} - stg2stg dflags this_mod stg_binds + (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-} + stg2stg dflags home_mods this_mod stg_binds return (stg_binds2, cost_centre_info) \end{code} @@ -727,34 +717,6 @@ hscParseThing parser dflags str %************************************************************************ %* * -\subsection{Getting information about an identifer} -%* * -%************************************************************************ - -\begin{code} -#ifdef GHCI -hscGetInfo -- like hscStmt, but deals with a single identifier - :: HscEnv - -> String -- The identifier - -> IO [GetInfoResult] - -hscGetInfo hsc_env str - = do maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str - case maybe_rdr_name of { - Nothing -> return []; - Just (L _ rdr_name) -> do - - maybe_tc_result <- tcRnGetInfo hsc_env (hsc_IC hsc_env) rdr_name - - case maybe_tc_result of - Nothing -> return [] - Just things -> return things - } -#endif -\end{code} - -%************************************************************************ -%* * Desugar, simplify, convert to bytecode, and link an expression %* * %************************************************************************