From: simonpj Date: Thu, 16 Nov 2000 14:43:06 +0000 (+0000) Subject: [project @ 2000-11-16 14:43:05 by simonpj] X-Git-Tag: Approximately_9120_patches~3325 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=490cba33825083f8e785aeb35b5ac1667fc3954b;p=ghc-hetmet.git [project @ 2000-11-16 14:43:05 by simonpj] Add stuff to support hscExpr --- diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 49f8939..fb21765 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -4,18 +4,18 @@ \section[Desugar]{@deSugar@: the main function} \begin{code} -module Desugar ( deSugar ) where +module Desugar ( deSugar, deSugarExpr ) where #include "HsVersions.h" import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn ) import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) ) -import TcHsSyn ( TypecheckedRuleDecl ) +import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr ) import TcModule ( TcResults(..) ) import Id ( Id ) import CoreSyn -import PprCore ( pprIdCoreRule ) +import PprCore ( pprIdCoreRule, pprCoreExpr ) import Subst ( substExpr, mkSubst, mkInScopeSet ) import DsMonad import DsExpr ( dsExpr ) @@ -25,6 +25,7 @@ import DsExpr () -- Forces DsExpr to be compiled; DsBinds only -- depends on DsExpr.hi-boot. import Module ( Module ) import Id ( Id ) +import Name ( lookupNameEnv ) import VarEnv import VarSet import Bag ( isEmptyBag ) @@ -32,7 +33,7 @@ import CoreLint ( showPass, endPass ) import ErrUtils ( doIfSet, pprBagOfWarnings ) import Outputable import UniqSupply ( mkSplitUniqSupply ) -import HscTypes ( HomeSymbolTable ) +import HscTypes ( HomeSymbolTable, PersistentCompilerState(..), TyThing(..), lookupType, ) \end{code} %************************************************************************ @@ -46,14 +47,13 @@ start. \begin{code} deSugar :: DynFlags + -> PersistentCompilerState -> HomeSymbolTable -> Module -> PrintUnqualified - -> HomeSymbolTable -> TcResults -> IO ([CoreBind], [(Id,CoreRule)], SDoc, SDoc, [CoreBndr]) -deSugar dflags mod_name unqual hst - (TcResults {tc_env = global_val_env, - tc_pcs = pcs, +deSugar dflags pcs hst mod_name unqual + (TcResults {tc_env = local_type_env, tc_binds = all_binds, tc_rules = rules, tc_fords = fo_decls}) @@ -61,7 +61,7 @@ deSugar dflags mod_name unqual hst ; us <- mkSplitUniqSupply 'd' -- Do desugaring - ; let (result, ds_warns) = initDs dflags us (hst,pcs,global_val_env) mod_name + ; let (result, ds_warns) = initDs dflags us lookup mod_name (dsProgram mod_name all_binds rules fo_decls) (ds_binds, ds_rules, _, _, _) = result @@ -79,8 +79,47 @@ deSugar dflags mod_name unqual hst ; return result } --- deSugarExpr dflags unqual hst tc_expr --- = do { + where + -- The lookup function passed to initDs is used for well-known Ids, + -- such as fold, build, cons etc, so the chances are + -- it'll be found in the package symbol table. That's + -- why we don't merge all these tables + pte = pcs_PTE pcs + lookup n = case lookupType hst pte n of { + Just (AnId v) -> v ; + other -> + case lookupNameEnv local_type_env n of + Just (AnId v) -> v ; + other -> pprPanic "Desugar: lookup:" (ppr n) + } + +deSugarExpr :: DynFlags + -> PersistentCompilerState -> HomeSymbolTable + -> Module -> PrintUnqualified + -> TypecheckedHsExpr + -> IO CoreExpr +deSugarExpr dflags pcs hst mod_name unqual tc_expr + = do { showPass dflags "Desugar" + ; us <- mkSplitUniqSupply 'd' + + -- Do desugaring + ; let (core_expr, ds_warns) = initDs dflags us lookup mod_name (dsExpr tc_expr) + + -- Display any warnings + ; doIfSet (not (isEmptyBag ds_warns)) + (printErrs unqual (pprBagOfWarnings ds_warns)) + + -- Dump output + ; let do_dump_ds = dopt Opt_D_dump_ds dflags + ; doIfSet do_dump_ds (printDump (pprCoreExpr core_expr)) + + ; return core_expr + } + where + pte = pcs_PTE pcs + lookup n = case lookupType hst pte n of + Just (AnId v) -> v + other -> pprPanic "Desugar: lookup:" (ppr n) dsProgram mod_name all_binds rules fo_decls = dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs -> diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index bf73147..83b21bd 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -39,9 +39,6 @@ import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply, import Unique ( Unique ) import Util ( zipWithEqual ) import Name ( Name ) -import Name ( lookupNameEnv ) -import HscTypes ( HomeSymbolTable, PersistentCompilerState(..), - TyThing(..), TypeEnv, lookupType ) import CmdLineOpts ( DynFlags ) infixr 9 `thenDs` @@ -71,26 +68,13 @@ type DsWarnings = Bag WarnMsg -- The desugarer reports matches which a initDs :: DynFlags -> UniqSupply - -> (HomeSymbolTable, PersistentCompilerState, TypeEnv) + -> (Name -> Id) -> Module -- module name: for profiling -> DsM a -> (a, DsWarnings) -initDs dflags init_us (hst,pcs,local_type_env) mod action +initDs dflags init_us lookup mod action = action dflags init_us lookup noSrcLoc mod emptyBag - where - -- This lookup is used for well-known Ids, - -- such as fold, build, cons etc, so the chances are - -- it'll be found in the package symbol table. That's - -- why we don't merge all these tables - pte = pcs_PTE pcs - lookup n = case lookupType hst pte n of { - Just (AnId v) -> v ; - other -> - case lookupNameEnv local_type_env n of - Just (AnId v) -> v ; - other -> pprPanic "initDS: lookup:" (ppr n) - } thenDs :: DsM a -> (a -> DsM b) -> DsM b andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 3ba9df3..f7abbb0 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -120,7 +120,6 @@ hscNoRecomp dflags location maybe_checked_iface hst hit pcs_ch let old_iface = case maybe_checked_iface of Just old_if -> old_if Nothing -> panic "hscNoRecomp:old_iface" - this_mod = mi_module old_iface ; -- CLOSURE (pcs_cl, closure_errs, cl_hs_decls) @@ -130,14 +129,13 @@ hscNoRecomp dflags location maybe_checked_iface hst hit pcs_ch else do { -- TYPECHECK - maybe_tc_result <- typecheckModule dflags this_mod pcs_cl hst + maybe_tc_result <- typecheckModule dflags pcs_cl hst old_iface alwaysQualify cl_hs_decls; case maybe_tc_result of { Nothing -> return (HscFail pcs_cl); - Just tc_result -> do { + Just (pcs_tc, tc_result) -> do { - let pcs_tc = tc_pcs tc_result - env_tc = tc_env tc_result + let env_tc = tc_env tc_result local_insts = tc_insts tc_result local_rules = tc_rules tc_result ; @@ -175,28 +173,27 @@ hscRecomp dflags location maybe_checked_iface hst hit pcs_ch <- renameModule dflags hit hst pcs_ch this_mod rdr_module ; case maybe_rn_result of { Nothing -> return (HscFail pcs_rn); - Just (print_unqualified, is_exported, new_iface, rn_hs_decls) -> do { + Just (print_unqualified, (is_exported, new_iface, rn_hs_decls)) -> do { ------------------- -- TYPECHECK ------------------- - ; maybe_tc_result <- typecheckModule dflags this_mod pcs_rn hst new_iface + ; maybe_tc_result <- typecheckModule dflags pcs_rn hst new_iface print_unqualified rn_hs_decls ; case maybe_tc_result of { Nothing -> do { hPutStrLn stderr "Typecheck failed" ; return (HscFail pcs_rn) } ; - Just tc_result -> do { + Just (pcs_tc, tc_result) -> do { - ; let pcs_tc = tc_pcs tc_result - env_tc = tc_env tc_result + ; let env_tc = tc_env tc_result local_insts = tc_insts tc_result ------------------- -- DESUGAR, SIMPLIFY, TIDY-CORE ------------------- -- We grab the the unfoldings at this point. - ; simpl_result <- dsThenSimplThenTidy dflags (pcs_rules pcs_tc) this_mod - print_unqualified is_exported tc_result hst + ; simpl_result <- dsThenSimplThenTidy dflags pcs_tc hst this_mod + print_unqualified is_exported tc_result ; let (tidy_binds, orphan_rules, foreign_stuff) = simpl_result ------------------- @@ -316,16 +313,16 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_ (ppr nm) -dsThenSimplThenTidy dflags rule_base this_mod print_unqual is_exported tc_result hst +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 this_mod print_unqual hst tc_result + <- deSugar dflags pcs hst this_mod print_unqual tc_result -------------------------- Main Core-language transformations ---------------- -- _scc_ "Core2Core" (simplified, orphan_rules) - <- core2core dflags rule_base hst is_exported desugared rules + <- core2core dflags pcs hst is_exported desugared rules -- Do the final tidy-up (tidy_binds, tidy_orphan_rules) @@ -375,6 +372,7 @@ hscExpr hscExpr dflags hst hit pcs this_module expr = do { -- Parse it + let unqual = unQualInScope ; maybe_parsed <- myParseExpr dflags expr ; case maybe_parsed of { Nothing -> return (HscFail pcs_ch); @@ -384,13 +382,22 @@ hscExpr dflags hst hit pcs this_module expr (new_pcs, maybe_renamed_expr) <- renameExpr dflags hit hst pcs this_module parsed_expr ; ; case maybe_renamed_expr of { Nothing -> FAIL - Just renamed_expr -> + Just (print_unqual, rn_expr) -> -- Typecheck it - maybe_tc_expr <- typecheckExpr dflags pcs hst unqual renamed_expr + maybe_tc_expr <- typecheckExpr dflags pcs hst print_unqual rn_expr ; case maybe_tc_expr of Nothing -> FAIL - Just typechecked_expr -> + Just tc_expr -> + + -- Desugar it + ; ds_expr <- deSugarExpr dflags pcs hst this_module print_unqual tc_expr + + -- Simplify it + ; simpl_expr <- simplifyExpr dflags pcs hst ds_expr + + ; return I'M NOT SURE + } diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 9ff18cb..3a6402a 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -103,7 +103,7 @@ mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules -- a) the orphan rules -- b) rules embedded in the top-level Ids rule_dcls | opt_OmitInterfacePragmas = [] - | otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids) + | otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids) orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule | (_, rule) <- orphan_rules] diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 7677e22..841d7fc 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -87,15 +87,12 @@ renameModule :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState -> Module -> RdrNameHsModule - -> IO (PersistentCompilerState, Maybe (PrintUnqualified, IsExported, ModIface, [RenamedHsDecl])) + -> IO (PersistentCompilerState, Maybe (PrintUnqualified, (IsExported, ModIface, [RenamedHsDecl]))) -- Nothing => some error occurred in the renamer renameModule dflags hit hst pcs this_module rdr_module - = renameSource dflags hit hst pcs this_module get_unqual $ + = renameSource dflags hit hst pcs this_module $ rename this_module rdr_module - where - get_unqual (Just (unqual, _, _, _)) = unqual - get_unqual Nothing = alwaysQualify \end{code} @@ -104,16 +101,16 @@ renameExpr :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState -> Module -> RdrNameHsExpr - -> IO (PersistentCompilerState, Maybe RenamedHsExpr) + -> IO (PersistentCompilerState, Maybe (PrintUnqualified, RenamedHsExpr)) renameExpr dflags hit hst pcs this_module expr | Just iface <- lookupModuleEnv hit this_module = do { let rdr_env = mi_globals iface - ; let get_unqual _ = unQualInScope rdr_env + ; let print_unqual = unQualInScope rdr_env - ; renameSource dflags hit hst pcs this_module get_unqual $ + ; renameSource dflags hit hst pcs this_module $ initRnMS rdr_env emptyLocalFixityEnv SourceMode $ - (rnExpr expr `thenRn` \ (e,_) -> returnRn (Just e)) + (rnExpr expr `thenRn` \ (e,_) -> returnRn (Just (print_unqual, e))) } | otherwise @@ -134,19 +131,22 @@ renameSource :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState -> Module - -> (Maybe r -> PrintUnqualified) - -> RnMG (Maybe r) - -> IO (PersistentCompilerState, Maybe r) + -> RnMG (Maybe (PrintUnqualified, r)) + -> IO (PersistentCompilerState, Maybe (PrintUnqualified, r)) -- Nothing => some error occurred in the renamer -renameSource dflags hit hst old_pcs this_module get_unqual thing_inside +renameSource dflags hit hst old_pcs this_module thing_inside = do { showPass dflags "Renamer" -- Initialise the renamer monad ; (new_pcs, msgs, maybe_rn_stuff) <- initRn dflags hit hst old_pcs this_module thing_inside -- Print errors from renaming - ; printErrorsAndWarnings (get_unqual maybe_rn_stuff) msgs ; + ; let print_unqual = case maybe_rn_stuff of + Just (unqual, _) -> unqual + Nothing -> alwaysQualify + + ; printErrorsAndWarnings print_unqual msgs ; -- Return results. No harm in updating the PCS ; if errorsFound msgs then @@ -157,7 +157,7 @@ renameSource dflags hit hst old_pcs this_module get_unqual thing_inside \end{code} \begin{code} -rename :: Module -> RdrNameHsModule -> RnMG (Maybe (PrintUnqualified, IsExported, ModIface, [RenamedHsDecl])) +rename :: Module -> RdrNameHsModule -> RnMG (Maybe (PrintUnqualified, (IsExported, ModIface, [RenamedHsDecl]))) rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec loc) = pushSrcLocRn loc $ @@ -249,7 +249,7 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec imports global_avail_env source_fvs export_avails rn_imp_decls `thenRn_` - returnRn (Just (print_unqualified, is_exported, mod_iface, final_decls)) + returnRn (Just (print_unqualified, (is_exported, mod_iface, final_decls))) where mod_name = moduleName this_module \end{code} diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index b744da9..3fcfad5 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -4,7 +4,7 @@ \section[SimplCore]{Driver for simplifying @Core@ programs} \begin{code} -module SimplCore ( core2core ) where +module SimplCore ( core2core, simplifyExpr ) where #include "HsVersions.h" @@ -15,13 +15,15 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), import CoreLint ( showPass, endPass ) import CoreSyn import CoreFVs ( ruleRhsFreeVars ) -import HscTypes ( PackageRuleBase, HomeSymbolTable, IsExported, ModDetails(..) ) +import HscTypes ( PersistentCompilerState(..), + PackageRuleBase, HomeSymbolTable, IsExported, ModDetails(..) + ) import CSE ( cseProgram ) import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds, extendRuleBaseList, addRuleBaseFVs ) import Module ( moduleEnvElts ) import CoreUnfold -import PprCore ( pprCoreBindings, pprIdCoreRule ) +import PprCore ( pprCoreBindings, pprIdCoreRule, pprCoreExpr ) import OccurAnal ( occurAnalyseBinds ) import CoreUtils ( etaReduceExpr, coreBindsSize ) import Simplify ( simplTopBinds, simplExpr ) @@ -56,16 +58,18 @@ import List ( partition ) \begin{code} core2core :: DynFlags -- includes spec of what core-to-core passes to do - -> PackageRuleBase -- Rule-base accumulated from imported packages + -> PersistentCompilerState -> HomeSymbolTable -> IsExported -> [CoreBind] -- Binds in -> [IdCoreRule] -- Rules in -> IO ([CoreBind], [IdCoreRule]) -- binds, local orphan rules out -core2core dflags pkg_rule_base hst is_exported binds rules +core2core dflags pcs hst is_exported binds rules = do - let core_todos = dopt_CoreToDo dflags + let core_todos = dopt_CoreToDo dflags + let pkg_rule_base = pcs_rules pcs -- Rule-base accumulated from imported packages + us <- mkSplitUniqSupply 's' let (cp_us, ru_us) = splitUniqSupply us @@ -90,6 +94,28 @@ core2core dflags pkg_rule_base hst is_exported binds rules return (processed_binds, orphan_rules) +simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do + -> PersistentCompilerState + -> HomeSymbolTable + -> CoreExpr + -> IO CoreExpr +simplifyExpr dflags pcs hst expr + = do { + ; us <- mkSplitUniqSupply 's' + + ; let (expr', counts) = initSmpl dflags sw_chkr us emptyVarSet black_list_all + (simplExpr expr) + + ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplfied expression" + (pprCoreExpr expr') + + ; return expr' + } + where + sw_chkr any = SwBool False -- A bit bogus + black_list_all v = True -- Black list everything + + doCorePasses :: DynFlags -> RuleBase -- the main rule base -> SimplCount -- simplifier stats diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index ea69f29..256e5bb 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -65,9 +65,6 @@ Outside-world interface: -- Convenient type synonyms first: data TcResults = TcResults { - tc_pcs :: PersistentCompilerState, -- Augmented with imported information, - -- (but not stuff from this module) - -- All these fields have info *just for this module* tc_env :: TypeEnv, -- The top level TypeEnv tc_insts :: [DFunId], -- Instances @@ -79,20 +76,23 @@ data TcResults --------------- typecheckModule :: DynFlags - -> Module -> PersistentCompilerState -> HomeSymbolTable -> ModIface -- Iface for this module -> PrintUnqualified -- For error printing -> [RenamedHsDecl] - -> IO (Maybe TcResults) + -> IO (Maybe (PersistentCompilerState, TcResults)) + -- The new PCS is Augmented with imported information, + -- (but not stuff from this module) + -typecheckModule dflags this_mod pcs hst mod_iface unqual decls +typecheckModule dflags pcs hst mod_iface unqual decls = do { maybe_tc_result <- typecheck dflags pcs hst unqual $ - tcModule pcs hst get_fixity this_mod decls + tcModule pcs hst get_fixity this_mod decls ; printTcDump dflags maybe_tc_result ; return maybe_tc_result } where + this_mod = mi_module mod_iface fixity_env = mi_fixities mod_iface get_fixity :: Name -> Maybe Fixity @@ -121,8 +121,8 @@ typecheck :: DynFlags -> TcM r -> IO (Maybe r) -typecheck dflags pcs hst unqual thing_inside - = do { showPass dflags "Typechecker"; +typecheck dflags pcs hst unqual thing_inside + = do { showPass dflags "Typechecker"; ; env <- initTcEnv hst (pcs_PTE pcs) ; (maybe_tc_result, (warns,errs)) <- initTc dflags env thing_inside @@ -143,7 +143,7 @@ tcModule :: PersistentCompilerState -> (Name -> Maybe Fixity) -> Module -> [RenamedHsDecl] - -> TcM TcResults + -> TcM (PersistentCompilerState, TcResults) tcModule pcs hst get_fixity this_mod decls = -- Type-check the type and class decls @@ -283,8 +283,8 @@ tcModule pcs hst get_fixity this_mod decls } in -- traceTc (text "Tc10") `thenNF_Tc_` - returnTc (TcResults { tc_pcs = final_pcs, - tc_env = local_type_env, + returnTc (final_pcs, + TcResults { tc_env = local_type_env, tc_binds = all_binds', tc_insts = map iDFunId local_inst_info, tc_fords = foi_decls ++ foe_decls', @@ -305,7 +305,7 @@ get_binds decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls] \begin{code} printTcDump dflags Nothing = return () -printTcDump dflags (Just results) +printTcDump dflags (Just (_, results)) = do dumpIfSet_dyn dflags Opt_D_dump_types "Type signatures" (dump_sigs results) dumpIfSet_dyn dflags Opt_D_dump_tc