From 47d54b54f077e17d74f581552606e0aba438877d Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 8 Dec 2000 12:02:28 +0000 Subject: [PATCH] [project @ 2000-12-08 12:02:25 by simonpj] Slight repackaging in HscMain --- ghc/compiler/deSugar/Desugar.lhs | 6 ++-- ghc/compiler/main/HscMain.lhs | 73 +++++++++++++++++--------------------- 2 files changed, 36 insertions(+), 43 deletions(-) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 4b2143b..3e1ff60 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -50,7 +50,7 @@ deSugar :: DynFlags -> PersistentCompilerState -> HomeSymbolTable -> Module -> PrintUnqualified -> TcResults - -> IO ([CoreBind], [(Id,CoreRule)], SDoc, SDoc, [CoreBndr]) + -> IO ([CoreBind], [(Id,CoreRule)], (SDoc, SDoc, [CoreBndr])) deSugar dflags pcs hst mod_name unqual (TcResults {tc_env = local_type_env, @@ -63,7 +63,7 @@ deSugar dflags pcs hst mod_name unqual -- Do desugaring ; let (result, ds_warns) = initDs dflags us lookup mod_name (dsProgram mod_name all_binds rules fo_decls) - (ds_binds, ds_rules, _, _, _) = result + (ds_binds, ds_rules, _) = result -- Display any warnings ; doIfSet (not (isEmptyBag ds_warns)) @@ -135,7 +135,7 @@ dsProgram mod_name all_binds rules fo_decls local_binders = mkVarSet (bindersOfBinds ds_binds) in mapDs (dsRule local_binders) rules `thenDs` \ rules' -> - returnDs (ds_binds, rules', h_code, c_code, fe_binders) + returnDs (ds_binds, rules', (h_code, c_code, fe_binders)) where auto_scc | opt_SccProfilingOn = TopLevel | otherwise = NoSccs diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 49139b7..e185f8e 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -14,6 +14,8 @@ module HscMain ( HscResult(..), hscMain, #ifdef GHCI import RdrHsSyn ( RdrNameHsExpr ) +import Rename ( renameExpr ) +import CoreToStg ( coreExprToStg ) import StringBuffer ( stringToStringBuffer, freeStringBuffer ) import Unique ( Uniquable(..) ) import Type ( splitTyConApp_maybe ) @@ -27,22 +29,20 @@ import StringBuffer ( hGetStringBuffer ) import Parser import Lex ( PState(..), ParseResult(..) ) import SrcLoc ( mkSrcLoc ) -import Rename ( checkOldIface, renameModule, renameExpr, closeIfaceDecls ) +import Rename ( checkOldIface, renameModule, closeIfaceDecls ) import Rules ( emptyRuleBase ) import PrelInfo ( wiredInThingEnv, wiredInThings ) import PrelNames ( knownKeyNames ) import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails, writeIface, pprIface ) import TcModule -import Type import InstEnv ( emptyInstEnv ) import Desugar import SimplCore -import CoreSyn ( bindersOfBinds ) import CoreUtils ( coreBindsSize ) import CoreTidy ( tidyCorePgm ) import CoreSat -import CoreToStg ( coreToStg, coreExprToStg ) +import CoreToStg ( coreToStg ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) import CodeOutput ( codeOutput ) @@ -215,17 +215,22 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch ; let env_tc = tc_env tc_result ------------------- - -- DESUGAR, SIMPLIFY, TIDY-CORE + -- DESUGAR + ------------------- + ; (ds_binds, ds_rules, foreign_stuff) + <- deSugar dflags pcs_tc hst this_mod print_unqualified tc_result + + ------------------- + -- SIMPLIFY, TIDY-CORE ------------------- -- We grab the the unfoldings at this point. - ; (pcs_simpl, tidy_binds, orphan_rules, foreign_stuff) - <- dsThenSimplThenTidy dflags pcs_tc hst this_mod - print_unqualified is_exported tc_result + ; (pcs_simpl, tidy_binds, orphan_rules) + <- simplThenTidy dflags pcs_tc hst this_mod is_exported ds_binds ds_rules ------------------- -- BUILD THE NEW ModDetails AND ModIface ------------------- - ; let new_details = mkModDetails env_tc tidy_binds orphan_rules + ; let new_details = mkModDetails env_tc tidy_binds orphan_rules ; final_iface <- mkFinalIface ghci_mode dflags location maybe_checked_iface new_iface new_details @@ -235,7 +240,6 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch ; (stg_binds, cost_centre_info) <- myCoreToStg dflags this_mod tidy_binds - ------------------- -- COMPLETE CODE GENERATION ------------------- @@ -301,6 +305,23 @@ myParseModule dflags src_filename }} +simplThenTidy dflags pcs hst this_mod is_exported binds rules + = do -- Do main Core-language transformations --------- + -- _scc_ "Core2Core" + (simplified, orphan_rules) + <- core2core dflags pcs hst is_exported binds rules + + -- Do saturation and convert to A-normal form + -- NOTE: future passes cannot transform the syntax, only annotate it + saturated <- coreSatPgm dflags simplified + + -- Do the final tidy-up + (pcs', tidy_binds, tidy_orphan_rules) + <- tidyCorePgm dflags this_mod pcs saturated orphan_rules + + return (pcs', tidy_binds, tidy_orphan_rules) + + restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_info foreign_stuff env_tc stg_binds tidy_binds hit pit -- these last two for mapping ModNames to Modules @@ -329,7 +350,7 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_ local_tycons = typeEnvTyCons env_tc local_classes = typeEnvClasses env_tc imported_modules = map mod_name_to_Module imported_module_names - (fe_binders,h_code,c_code) = foreign_stuff + (h_code,c_code,fe_binders) = foreign_stuff mod_name_to_Module :: ModuleName -> Module mod_name_to_Module nm @@ -343,28 +364,6 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_ (ppr nm) -dsThenSimplThenTidy dflags pcs hst this_mod print_unqual is_exported tc_result - = do ------------------ Desugaring --------------------------------- - -- _scc_ "DeSugar" - (desugared, rules, h_code, c_code, fe_binders) - <- deSugar dflags pcs hst this_mod print_unqual tc_result - - ------------------ Main Core-language transformations --------- - -- _scc_ "Core2Core" - (simplified, orphan_rules) - <- core2core dflags pcs hst is_exported desugared rules - - -- Do saturation and convert to A-normal form - -- NOTE: future passes cannot transform the syntax, only annotate it - saturated <- coreSatPgm dflags simplified - - -- Do the final tidy-up - (pcs', tidy_binds, tidy_orphan_rules) - <- tidyCorePgm dflags this_mod pcs saturated orphan_rules - - return (pcs', tidy_binds, tidy_orphan_rules, (fe_binders,h_code,c_code)) - - myCoreToStg dflags this_mod tidy_binds = do () <- coreBindsSize tidy_binds `seq` return () @@ -392,13 +391,7 @@ myCoreToStg dflags this_mod tidy_binds %************************************************************************ \begin{code} -#ifndef GHCI -hscExpr dflags hst hit pcs this_module expr - = panic "hscExpr: non-interactive build" -hscTypeExpr dflags hst hit pcs0 this_module expr - = panic "hscTypeExpr: non-interactive build" -#else - +#ifdef GHCI hscExpr :: DynFlags -> HomeSymbolTable -- 1.7.10.4