Commit 7c3d4a1f authored by simonpj's avatar simonpj
Browse files

[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.
parent d51aa9da
......@@ -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 -----------------" $$
......
......@@ -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}
......
......@@ -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
......
......@@ -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))
......
......@@ -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)
......
......@@ -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,
......
......@@ -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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment