From 7c3d4a1f2b2529ce300b8acc1d26ad98312b9e96 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 29 Oct 2003 18:14:30 +0000 Subject: [PATCH] [project @ 2003-10-29 18:14:27 by simonpj] Fix a bad consequence of the new story for the generic toT/fromT functions derived from data types declarations. The problem was that they were being generated and then discarded by the simplifier, because there was nothing keeping them alive. This commit * Adds a field tcg_keep to the TcGblEnv, which records things to be kept alive; * Makes the desugarer pin the keep-alive flag on each binding (it's actually a call to setIdLocalExported) * Removes that job from updateBinders in SimplCore It's somewhat tiresome, but not really difficult. --- ghc/compiler/deSugar/Desugar.lhs | 105 +++++++++++++++++++++++++-------- ghc/compiler/simplCore/SimplCore.lhs | 71 +++++----------------- ghc/compiler/specialise/Rules.lhs | 5 +- ghc/compiler/typecheck/TcDeriv.lhs | 67 ++++++++++----------- ghc/compiler/typecheck/TcInstDcls.lhs | 9 ++- ghc/compiler/typecheck/TcRnMonad.lhs | 3 +- ghc/compiler/typecheck/TcRnTypes.lhs | 7 +++ 7 files changed, 143 insertions(+), 124 deletions(-) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 35083bd..c2bfd69 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -9,15 +9,16 @@ module Desugar ( deSugar, deSugarExpr ) where #include "HsVersions.h" import CmdLineOpts ( DynFlag(..), dopt, opt_SccProfilingOn ) -import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), +import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), GhciMode(..), Dependencies(..), TypeEnv, - unQualInScope ) + unQualInScope, availsToNameSet ) import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) ) import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr ) import TcRnTypes ( TcGblEnv(..), ImportAvails(..) ) import MkIface ( mkUsageInfo ) -import Id ( Id ) +import Id ( Id, setIdLocalExported, idName ) +import Name ( Name, isExternalName ) import CoreSyn import PprCore ( pprIdRules, pprCoreExpr ) import Subst ( substExpr, mkSubst, mkInScopeSet ) @@ -35,6 +36,7 @@ import VarEnv import VarSet import Bag ( isEmptyBag, mapBag, emptyBag ) import CoreLint ( showPass, endPass ) +import CoreFVs ( ruleRhsFreeVars ) import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, addShortWarnLocLine, errorsFound ) import Outputable @@ -56,25 +58,22 @@ deSugar :: HscEnv -> TcGblEnv -> IO (Maybe ModGuts) -- Can modify PCS by faulting in more declarations deSugar hsc_env - (TcGblEnv { tcg_mod = mod, - tcg_type_env = type_env, - tcg_imports = imports, - tcg_exports = exports, - tcg_dus = dus, - tcg_inst_uses = dfun_uses_var, - tcg_rdr_env = rdr_env, - tcg_fix_env = fix_env, - tcg_deprecs = deprecs, - tcg_insts = insts, - tcg_binds = binds, - tcg_fords = fords, - tcg_rules = rules }) + tcg_env@(TcGblEnv { tcg_mod = mod, + tcg_type_env = type_env, + tcg_imports = imports, + tcg_exports = exports, + tcg_dus = dus, + tcg_inst_uses = dfun_uses_var, + tcg_rdr_env = rdr_env, + tcg_fix_env = fix_env, + tcg_deprecs = deprecs, + tcg_insts = insts }) = do { showPass dflags "Desugar" -- Do desugaring ; let { is_boot = imp_dep_mods imports } ; (results, warnings) <- initDs hsc_env mod type_env is_boot $ - dsProgram binds rules fords + dsProgram ghci_mode tcg_env ; let { (ds_binds, ds_rules, ds_fords) = results ; warns = mapBag mk_warn warnings @@ -123,6 +122,7 @@ deSugar hsc_env where dflags = hsc_dflags hsc_env + ghci_mode = hsc_mode hsc_env print_unqual = unQualInScope rdr_env -- Desugarer warnings are SDocs; here we @@ -163,25 +163,82 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr mk_warn (loc,sdoc) = addShortWarnLocLine loc print_unqual sdoc -dsProgram all_binds rules fo_decls - = dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs -> - dsForeigns fo_decls `thenDs` \ (ds_fords, foreign_binds) -> +dsProgram ghci_mode (TcGblEnv { tcg_exports = exports, + tcg_keep = keep_alive, + tcg_binds = binds, + tcg_fords = fords, + tcg_rules = rules }) + = dsMonoBinds auto_scc binds [] `thenDs` \ core_prs -> + dsForeigns fords `thenDs` \ (ds_fords, foreign_prs) -> + let + all_prs = foreign_prs ++ core_prs + local_bndrs = mkVarSet (map fst all_prs) + in + mappM (dsRule local_bndrs) rules `thenDs` \ ds_rules -> let - ds_binds = [Rec (foreign_binds ++ core_prs)] + final_prs = addExportFlags ghci_mode exports keep_alive + local_bndrs all_prs ds_rules + ds_binds = [Rec final_prs] -- Notice that we put the whole lot in a big Rec, even the foreign binds -- When compiling PrelFloat, which defines data Float = F# Float# -- we want F# to be in scope in the foreign marshalling code! -- You might think it doesn't matter, but the simplifier brings all top-level -- things into the in-scope set before simplifying; so we get no unfolding for F#! - - local_binders = mkVarSet (bindersOfBinds ds_binds) in - mappM (dsRule local_binders) rules `thenDs` \ ds_rules -> returnDs (ds_binds, ds_rules, ds_fords) where auto_scc | opt_SccProfilingOn = TopLevel | otherwise = NoSccs +-- addExportFlags +-- Set the no-discard flag if either +-- a) the Id is exported +-- b) it's mentioned in the RHS of an orphan rule +-- c) it's in the keep-alive set +-- +-- It means that the binding won't be discarded EVEN if the binding +-- ends up being trivial (v = w) -- the simplifier would usually just +-- substitute w for v throughout, but we don't apply the substitution to +-- the rules (maybe we should?), so this substitution would make the rule +-- bogus. + +-- You might wonder why exported Ids aren't already marked as such; +-- it's just because the type checker is rather busy already and +-- I didn't want to pass in yet another mapping. + +addExportFlags ghci_mode exports keep_alive bndrs prs rules + = [(add_export bndr, rhs) | (bndr,rhs) <- prs] + where + add_export bndr | dont_discard bndr = setIdLocalExported bndr + | otherwise = bndr + + orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule + | (id, rule) <- rules, + not (id `elemVarSet` bndrs) ] + -- An orphan rule must keep alive the free vars + -- of its right-hand side. + -- Non-orphan rules are attached to the Id (bndr_with_rules above) + -- and that keeps the rhs free vars alive + + dont_discard bndr = is_exported name + || name `elemNameSet` keep_alive + || bndr `elemVarSet` orph_rhs_fvs + where + name = idName bndr + + -- In interactive mode, we don't want to discard any top-level + -- entities at all (eg. do not inline them away during + -- simplification), and retain them all in the TypeEnv so they are + -- available from the command line. + -- + -- isExternalName separates the user-defined top-level names from those + -- introduced by the type checker. + is_exported :: Name -> Bool + is_exported | ghci_mode == Interactive = isExternalName + | otherwise = (`elemNameSet` export_fvs) + + export_fvs = availsToNameSet exports + ppr_ds_rules [] = empty ppr_ds_rules rules = text "" $$ text "-------------- DESUGARED RULES -----------------" $$ diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 5c39b9f..8843455 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -13,10 +13,9 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), dopt_CoreToDo, buildCoreToDo ) import CoreSyn -import CoreFVs ( ruleRhsFreeVars ) import TcIface ( loadImportedRules ) import HscTypes ( HscEnv(..), GhciMode(..), - ModGuts(..), ModGuts, Avails, availsToNameSet, + ModGuts(..), ModGuts, Avails, ModDetails(..), HomeModInfo(..), ExternalPackageState(..), hscEPS ) @@ -37,7 +36,7 @@ import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass ) import CoreLint ( endPass ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) -import Id ( idName, idIsFrom, setIdLocalExported ) +import Id ( idName, idIsFrom, idSpecialisation, setIdSpecialisation ) import VarSet import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) @@ -70,11 +69,9 @@ core2core :: HscEnv -> IO ModGuts core2core hsc_env - mod_impl@(ModGuts { mg_exports = exports, - mg_binds = binds_in }) + mod_impl@(ModGuts { mg_binds = binds_in }) = do let dflags = hsc_dflags hsc_env - ghci_mode = hsc_mode hsc_env core_todos | Just todo <- dopt_CoreToDo dflags = todo | otherwise = buildCoreToDo dflags @@ -87,8 +84,7 @@ core2core hsc_env <- prepareRules hsc_env mod_impl ru_us -- PREPARE THE BINDINGS - let binds1 = updateBinders ghci_mode local_rule_ids - orphan_rules exports binds_in + let binds1 = updateBinders local_rule_ids binds_in -- DO THE BUSINESS (stats, processed_binds) @@ -234,6 +230,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) (local_rule_ids, final_rule_base) = getLocalRules this_mod full_rule_base -- NB: the imported rules may include rules for Ids in this module + -- which is why we suck the local rules out of full_rule_base orphan_rules = filter (not . idIsFrom this_mod . fst) better_rules @@ -251,23 +248,14 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds -updateBinders :: GhciMode - -> IdSet -- Locally defined ids with their Rules attached - -> [IdCoreRule] -- Orphan rules - -> Avails -- What is exported +updateBinders :: IdSet -- Locally defined ids with their Rules attached -> [CoreBind] -> [CoreBind] -- A horrible function --- Update the binders of top-level bindings as follows --- a) Attach the rules for each locally-defined Id to that Id. --- b) Set the no-discard flag if either the Id is exported, --- or it's mentioned in the RHS of a rule --- --- You might wonder why exported Ids aren't already marked as such; --- it's just because the type checker is rather busy already and --- I didn't want to pass in yet another mapping. +-- Update the binders of top-level bindings by +-- attaching the rules for each locally-defined Id to that Id. -- --- Reason for (a) +-- Reason -- - It makes the rules easier to look up -- - It means that transformation rules and specialisations for -- locally defined Ids are handled uniformly @@ -275,47 +263,16 @@ updateBinders :: GhciMode -- (the occurrence analyser knows about rules attached to Ids) -- - It makes sure that, when we apply a rule, the free vars -- of the RHS are more likely to be in scope --- --- Reason for (b) --- It means that the binding won't be discarded EVEN if the binding --- ends up being trivial (v = w) -- the simplifier would usually just --- substitute w for v throughout, but we don't apply the substitution to --- the rules (maybe we should?), so this substitution would make the rule --- bogus. - -updateBinders ghci_mode rule_ids orphan_rules exports binds + +updateBinders rule_ids binds = map update_bndrs binds where update_bndrs (NonRec b r) = NonRec (update_bndr b) r update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs] - update_bndr bndr - | dont_discard bndr = setIdLocalExported bndr_with_rules - | otherwise = bndr_with_rules - where - bndr_with_rules = lookupVarSet rule_ids bndr `orElse` bndr - - orph_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) orphan_rules) - -- An orphan rule must keep alive the free vars - -- of its right-hand side. - -- Non-orphan rules are attached to the Id (bndr_with_rules above) - -- and that keeps the rhs free vars alive - - dont_discard bndr = is_exported (idName bndr) - || bndr `elemVarSet` orph_rhs_fvs - - -- In interactive mode, we don't want to discard any top-level - -- entities at all (eg. do not inline them away during - -- simplification), and retain them all in the TypeEnv so they are - -- available from the command line. - -- - -- isExternalName separates the user-defined top-level names from those - -- introduced by the type checker. - is_exported :: Name -> Bool - is_exported | ghci_mode == Interactive = isExternalName - | otherwise = (`elemNameSet` export_fvs) - - export_fvs = availsToNameSet exports + update_bndr bndr = case lookupVarSet rule_ids bndr of + Nothing -> bndr + Just id -> bndr `setIdSpecialisation` idSpecialisation id \end{code} diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 7a2f320..19bced3 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -612,8 +612,9 @@ getLocalRules :: Module -> RuleBase -> (IdSet, -- Ids with local rules RuleBase) -- Non-local rules -- Get the rules for locally-defined Ids out of the RuleBase -- If we miss any rules for Ids defined here, then we end up --- giving the local decl a new Unique (because the in-scope-set is the --- same as the rule-id set), and now the binding for the class method +-- giving the local decl a new Unique (because the in-scope-set is (hackily) the +-- same as the non-local-rule-id set, so the Id looks as if it's in scope +-- and hence should be cloned), and now the binding for the class method -- doesn't have the same Unique as the one in the Class and the tc-env -- Example: class Foo a where -- op :: a -> a diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 012a5d0..dbe552e 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -40,6 +40,7 @@ import MkId ( mkDictFunId ) import DataCon ( dataConOrigArgTys, isNullaryDataCon, isExistentialDataCon ) import Maybes ( catMaybes ) import Name ( Name, getSrcLoc ) +import NameSet ( NameSet, emptyNameSet, duDefs ) import Unique ( Unique, getUnique ) import TyCon ( tyConTyVars, tyConDataCons, tyConArity, @@ -194,29 +195,40 @@ version. So now all classes are "offending". \begin{code} tcDeriving :: [RenamedTyClDecl] -- All type constructors -> TcM ([InstInfo], -- The generated "instance decls" - RenamedHsBinds) -- Extra generated top-level bindings + RenamedHsBinds, -- Extra generated top-level bindings + NameSet) -- Binders to keep alive tcDeriving tycl_decls - = recoverM (returnM ([], EmptyBinds)) $ - getDOpts `thenM` \ dflags -> + = recoverM (returnM ([], EmptyBinds, emptyNameSet)) $ + do { -- Fish the "deriving"-related information out of the TcEnv + -- and make the necessary "equations". + ; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns tycl_decls - -- Fish the "deriving"-related information out of the TcEnv - -- and make the necessary "equations". - makeDerivEqns tycl_decls `thenM` \ (ordinary_eqns, newtype_inst_info) -> - extendLocalInstEnv (map iDFunId newtype_inst_info) $ - -- Add the newtype-derived instances to the inst env - -- before tacking the "ordinary" ones + ; (ordinary_inst_info, deriv_binds) + <- extendLocalInstEnv (map iDFunId newtype_inst_info) $ + deriveOrdinaryStuff ordinary_eqns + -- Add the newtype-derived instances to the inst env + -- before tacking the "ordinary" ones - deriveOrdinaryStuff ordinary_eqns `thenM` \ (ordinary_inst_info, binds) -> - let - inst_info = newtype_inst_info ++ ordinary_inst_info - in + -- Generate the generic to/from functions from each type declaration + ; tcg_env <- getGblEnv + ; let gen_binds = mkGenericBinds (typeEnvTyCons (tcg_type_env tcg_env)) + ; let inst_info = newtype_inst_info ++ ordinary_inst_info + + -- Rename these extra bindings, discarding warnings about unused bindings etc + ; (rn_binds, gen_bndrs) + <- discardWarnings $ do + { (rn_deriv, _dus1) <- rnTopMonoBinds deriv_binds [] + ; (rn_gen, dus_gen) <- rnTopMonoBinds gen_binds [] + ; return (rn_deriv `ThenBinds` rn_gen, duDefs dus_gen) } - ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" - (ddump_deriving inst_info binds)) `thenM_` - returnM (inst_info, binds) + ; dflags <- getDOpts + ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" + (ddump_deriving inst_info rn_binds)) + ; returnM (inst_info, rn_binds, gen_bndrs) + } where ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc ddump_deriving inst_infos extra_binds @@ -228,7 +240,7 @@ tcDeriving tycl_decls ----------------------------------------- deriveOrdinaryStuff [] -- Short cut - = returnM ([], EmptyBinds) + = returnM ([], EmptyMonoBinds) deriveOrdinaryStuff eqns = do { -- Take the equation list and solve it, to deliver a list of @@ -244,20 +256,8 @@ deriveOrdinaryStuff eqns -- notably "con2tag" and/or "tag2con" functions. ; extra_binds <- genTaggeryBinds new_dfuns - -- Generate the generic to/from functions from each type declaration - ; tcg_env <- getGblEnv - ; let gen_binds = mkGenericBinds (typeEnvTyCons (tcg_type_env tcg_env)) - - -- Rename these extra bindings, discarding warnings about unused bindings etc - ; (rn_binds, _fvs1) <- discardWarnings $ - rnTopMonoBinds (extra_binds `AndMonoBinds` gen_binds) [] - - ; let all_binds = rn_binds `ThenBinds` - foldr ThenBinds EmptyBinds aux_binds_s - -- Done - ; traceTc (text "tcDeriv" <+> vcat (map pprInstInfo inst_infos)) - ; returnM (inst_infos, all_binds) } + ; returnM (inst_infos, andMonoBindList (extra_binds : aux_binds_s)) } \end{code} @@ -745,7 +745,7 @@ the renamer. What a great hack! \begin{code} -- Generate the InstInfo for the required instance, -- plus any auxiliary bindings required -genInst :: DFunId -> TcM (InstInfo, RenamedHsBinds) +genInst :: DFunId -> TcM (InstInfo, RdrNameMonoBinds) genInst dfun = getFixityEnv `thenM` \ fix_env -> let @@ -755,9 +755,6 @@ genInst dfun (meth_binds, aux_binds) = assoc "gen_bind:bad derived class" gen_list (getUnique clas) fix_env tycon in - -- Rename the auxiliary bindings (if any) - rnTopMonoBinds aux_binds [] `thenM` \ (rn_aux_binds, _dus) -> - -- Bring the right type variables into -- scope, and rename the method binds bindLocalNames (map varName tyvars) $ @@ -765,7 +762,7 @@ genInst dfun -- Build the InstInfo returnM (InstInfo { iDFunId = dfun, iBinds = VanillaInst rn_meth_binds [] }, - rn_aux_binds) + aux_binds) gen_list :: [(Unique, FixityEnv -> TyCon -> (RdrNameMonoBinds, RdrNameMonoBinds))] gen_list = [(eqClassKey, no_aux_binds (ignore_fix_env gen_Eq_binds)) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 4ee1bbb..f3e350a 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -159,20 +159,19 @@ tcInstDecls1 tycl_decls inst_decls getGenericInstances clas_decls `thenM` \ generic_inst_info -> -- Next, construct the instance environment so far, consisting of - -- a) imported instance decls (from this module) - -- b) local instance decls - -- c) generic instances + -- a) local instance decls + -- b) generic instances addInsts local_inst_info $ addInsts generic_inst_info $ -- (3) Compute instances from "deriving" clauses; -- This stuff computes a context for the derived instance decl, so it -- needs to know about all the instances possible; hence inst_env4 - tcDeriving tycl_decls `thenM` \ (deriv_inst_info, deriv_binds) -> + tcDeriving tycl_decls `thenM` \ (deriv_inst_info, deriv_binds, keep_alive) -> addInsts deriv_inst_info $ getGblEnv `thenM` \ gbl_env -> - returnM (gbl_env, + returnM (gbl_env { tcg_keep = tcg_keep gbl_env `unionNameSets` keep_alive }, generic_inst_info ++ deriv_inst_info ++ local_inst_info, deriv_binds) diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index dc0e8f0..47cd402 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -92,7 +92,8 @@ initTc hsc_env mod do_this tcg_deprecs = NoDeprecs, tcg_insts = [], tcg_rules = [], - tcg_fords = [] + tcg_fords = [], + tcg_keep = emptyNameSet } ; lcl_env = TcLclEnv { tcl_errs = errs_var, diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 01dbce1..8b5bc3b 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -163,12 +163,19 @@ data TcGblEnv tcg_imports :: ImportAvails, -- Information about what was imported -- from where, including things bound -- in this module + tcg_dus :: DefUses, -- What is defined in this module and what is used. -- The latter is used to generate -- (a) version tracking; no need to recompile if these -- things have not changed version stamp -- (b) unused-import info + tcg_keep :: NameSet, -- Set of names to keep alive, and to expose in the + -- interface file (but not to export to the user). + -- These are typically extra definitions generated from + -- data type declarations which would otherwise be + -- dropped as dead code. + -- The next fields accumulate the payload of the module -- The binds, rules and foreign-decl fiels are collected -- initially in un-zonked form and are finally zonked in tcRnSrcDecls -- 1.7.10.4