#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 )
import VarSet
import Bag ( isEmptyBag, mapBag, emptyBag )
import CoreLint ( showPass, endPass )
+import CoreFVs ( ruleRhsFreeVars )
import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings,
addShortWarnLocLine, errorsFound )
import Outputable
-- 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
where
dflags = hsc_dflags hsc_env
+ ghci_mode = hsc_mode hsc_env
print_unqual = unQualInScope rdr_env
-- Desugarer warnings are SDocs; here we
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 -----------------" $$
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
)
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 )
-> 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
<- 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)
(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
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
-- (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}
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
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,
\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
-----------------------------------------
deriveOrdinaryStuff [] -- Short cut
- = returnM ([], EmptyBinds)
+ = returnM ([], EmptyMonoBinds)
deriveOrdinaryStuff eqns
= do { -- Take the equation list and solve it, to deliver a list of
-- 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}
\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
(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) $
-- 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))
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)
tcg_deprecs = NoDeprecs,
tcg_insts = [],
tcg_rules = [],
- tcg_fords = []
+ tcg_fords = [],
+ tcg_keep = emptyNameSet
} ;
lcl_env = TcLclEnv {
tcl_errs = errs_var,
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
projects / ghc-hetmet.git / commitdiff