#include "HsVersions.h"
-import CoreSyn ( Unfolding, CoreRules, IdCoreRule, rulesRules )
+import CoreSyn ( Unfolding, CoreRules, IdCoreRule(..), rulesRules )
import BasicTypes ( Arity )
import Var ( Id, DictId,
isId, isExportedId, isSpecPragmaId, isLocalId,
idSpecialisation id = specInfo (idInfo id)
idCoreRules :: Id -> [IdCoreRule]
-idCoreRules id = [(id,rule) | rule <- rulesRules (idSpecialisation id)]
+idCoreRules id = [IdCoreRule id False rule | rule <- rulesRules (idSpecialisation id)]
setIdSpecialisation :: Id -> CoreRules -> Id
setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
| Exported -- Exported
| SpecPragma -- Not exported, but not to be discarded either
-- It's unclean that this is so deeply built in
+ -- Exported and SpecPragma Ids are kept alive;
+ -- NotExported things may be discarded as dead code.
\end{code}
LocalId and GlobalId
\begin{code}
ruleLhsFreeNames :: IdCoreRule -> NameSet
-ruleLhsFreeNames (fn, BuiltinRule _ _) = unitNameSet (varName fn)
-ruleLhsFreeNames (fn, Rule _ _ tpl_vars tpl_args rhs)
+ruleLhsFreeNames (IdCoreRule fn _ (BuiltinRule _ _)) = unitNameSet (varName fn)
+ruleLhsFreeNames (IdCoreRule fn _ (Rule _ _ tpl_vars tpl_args rhs))
= addOneToNameSet (exprsFreeNames tpl_args `del_binders` tpl_vars) (varName fn)
exprFreeNames :: CoreExpr -> NameSet
rule_fvs = addBndrs tpl_vars (expr_fvs rhs)
ruleLhsFreeIds :: CoreRule -> VarSet
--- This finds all the free Ids on the LHS of the rule
--- *including* imported ids
+-- This finds all locally-defined free Ids on the LHS of the rule
ruleLhsFreeIds (BuiltinRule _ _) = noFVs
ruleLhsFreeIds (Rule _ _ tpl_vars tpl_args rhs)
- = foldl delVarSet (exprsSomeFreeVars isId tpl_args) tpl_vars
+ = foldl delVarSet (exprsFreeVars tpl_args) tpl_vars
\end{code}
-- Core rules
CoreRules(..), -- Representation needed by friends
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
- IdCoreRule,
+ IdCoreRule(..), isOrphanRule,
RuleName,
emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
isBuiltinRule, ruleName
\begin{code}
type RuleName = FastString
-type IdCoreRule = (Id,CoreRule) -- Rules don't have their leading Id inside them
+data IdCoreRule = IdCoreRule Id -- A rule for this Id
+ Bool -- True <=> orphan rule
+ CoreRule -- The rule itself
+
+isOrphanRule :: IdCoreRule -> Bool
+isOrphanRule (IdCoreRule _ is_orphan _) = is_orphan
data CoreRule
= Rule RuleName
------------ Rules --------------
tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule]
tidyIdRules env [] = []
-tidyIdRules env ((fn,rule) : rules)
+tidyIdRules env (IdCoreRule fn is_orph rule : rules)
= tidyRule env rule =: \ rule ->
tidyIdRules env rules =: \ rules ->
- ((tidyVarOcc env fn, rule) : rules)
+ (IdCoreRule (tidyVarOcc env fn) is_orph rule : rules)
tidyRule :: TidyEnv -> CoreRule -> CoreRule
tidyRule env rule@(BuiltinRule _ _) = rule
pprIdRules rules = vcat (map pprIdRule rules)
pprIdRule :: IdCoreRule -> SDoc
-pprIdRule (id,rule) = pprCoreRule (ppr id) rule
+pprIdRule (IdCoreRule id _ rule) = pprCoreRule (ppr id) rule
pprCoreRule :: SDoc -> CoreRule -> SDoc
pprCoreRule pp_fn (BuiltinRule name _)
HsBindGroup(..), LRuleDecl, HsBind(..) )
import TcRnTypes ( TcGblEnv(..), ImportAvails(..) )
import MkIface ( mkUsageInfo )
-import Id ( Id, setIdLocalExported, idName )
+import Id ( Id, setIdLocalExported, idName, idIsFrom, isLocalId )
import Name ( Name, isExternalName )
import CoreSyn
import PprCore ( pprIdRules, pprCoreExpr )
tcg_dus = dus,
tcg_inst_uses = dfun_uses_var,
tcg_th_used = th_var,
+ tcg_keep = keep_var,
tcg_rdr_env = rdr_env,
tcg_fix_env = fix_env,
tcg_deprecs = deprecs,
+ tcg_binds = binds,
+ tcg_fords = fords,
+ tcg_rules = rules,
tcg_insts = insts })
= do { showPass dflags "Desugar"
- -- Do desugaring
- ; (results, warnings) <- initDs hsc_env mod type_env $
- dsProgram ghci_mode tcg_env
+ -- Desugar the program
+ ; ((all_prs, ds_rules, ds_fords), warns)
+ <- initDs hsc_env mod rdr_env type_env $ do
+ { core_prs <- dsHsBinds auto_scc binds []
+ ; (ds_fords, foreign_prs) <- dsForeigns fords
+ ; let all_prs = foreign_prs ++ core_prs
+ local_bndrs = mkVarSet (map fst all_prs)
+ ; ds_rules <- mappM (dsRule mod local_bndrs) rules
+ ; return (all_prs, ds_rules, ds_fords) }
+
- ; let { (ds_binds, ds_rules, ds_fords) = results
- ; warns = mapBag mk_warn warnings
- }
-- If warnings are considered errors, leave.
; if errorsFound dflags (warns, emptyBag)
then return (warns, Nothing)
else do
+ { -- Add export flags to bindings
+ keep_alive <- readIORef keep_var
+ ; let final_prs = addExportFlags ghci_mode exports keep_alive
+ 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#!
+
-- Lint result if necessary
- { endPass dflags "Desugar" Opt_D_dump_ds ds_binds
+ ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds
-- Dump output
; doIfSet (dopt Opt_D_dump_ds dflags)
(printDump (ppr_ds_rules ds_rules))
; dfun_uses <- readIORef dfun_uses_var -- What dfuns are used
- ; th_used <- readIORef th_var
+ ; th_used <- readIORef th_var -- Whether TH is used
; let used_names = allUses dus `unionNameSets` dfun_uses
pkgs | th_used = insertList thPackage (imp_dep_pkgs imports)
| otherwise = imp_dep_pkgs imports
where
dflags = hsc_dflags hsc_env
ghci_mode = hsc_mode hsc_env
- print_unqual = unQualInScope rdr_env
-
- -- Desugarer warnings are SDocs; here we
- -- add the info about whether or not to print unqualified
- mk_warn :: (SrcSpan,SDoc) -> WarnMsg
- mk_warn (loc, sdoc) = mkWarnMsg loc print_unqual sdoc
-
+ auto_scc | opt_SccProfilingOn = TopLevel
+ | otherwise = NoSccs
deSugarExpr :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
; us <- mkSplitUniqSupply 'd'
-- Do desugaring
- ; (core_expr, ds_warns) <- initDs hsc_env this_mod type_env $
+ ; (core_expr, ds_warns) <- initDs hsc_env this_mod rdr_env type_env $
dsLExpr tc_expr
-- Display any warnings
-- Note: if -Werror is used, we don't signal an error here.
; doIfSet (not (isEmptyBag ds_warns))
- (printErrs (pprBagOfWarnings (mapBag mk_warn ds_warns)))
+ (printErrs (pprBagOfWarnings ds_warns))
-- Dump output
; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr)
}
where
dflags = hsc_dflags hsc_env
- print_unqual = unQualInScope rdr_env
-
- mk_warn :: (SrcSpan,SDoc) -> WarnMsg
- mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc
-dsProgram ghci_mode (TcGblEnv { tcg_exports = exports,
- tcg_keep = keep_alive,
- tcg_binds = binds,
- tcg_fords = fords,
- tcg_rules = rules })
- = dsHsBinds 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
- 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#!
- in
- 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
-- 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
+addExportFlags ghci_mode exports keep_alive prs rules
= [(add_export bndr, rhs) | (bndr,rhs) <- prs]
where
- add_export bndr | dont_discard bndr = setIdLocalExported bndr
- | otherwise = bndr
+ add_export bndr
+ | isLocalId bndr && dont_discard bndr = setIdLocalExported bndr
+ -- The isLocalId check is to avoid fiddling with
+ -- locally-defined Ids like data cons and class ops
+ -- which are "born" as GlobalIds
+ | 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
+ | IdCoreRule _ is_orphan_rule rule <- rules,
+ is_orphan_rule ]
+ -- An orphan rule keeps alive the free vars of its right-hand side.
+ -- Non-orphan rules are (later, after gentle simplification)
+ -- attached to the Id and that keeps the rhs free vars alive
dont_discard bndr = is_exported name
|| name `elemNameSet` keep_alive
%************************************************************************
\begin{code}
-dsRule :: IdSet -> LRuleDecl Id -> DsM (Id, CoreRule)
-dsRule in_scope (L loc (HsRule name act vars lhs rhs))
+dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM IdCoreRule
+dsRule mod in_scope (L loc (HsRule name act vars lhs rhs))
= putSrcSpanDs loc $
ds_lhs all_vars lhs `thenDs` \ (fn, args) ->
dsLExpr rhs `thenDs` \ core_rhs ->
- returnDs (fn, Rule name act tpl_vars args core_rhs)
+ returnDs (IdCoreRule fn (is_orphan fn) (Rule name act tpl_vars args core_rhs))
where
- tpl_vars = [var | RuleBndr (L _ var) <- vars]
- all_vars = mkInScopeSet (extendVarSetList in_scope tpl_vars)
+ tpl_vars = [var | RuleBndr (L _ var) <- vars]
+ all_vars = mkInScopeSet (extendVarSetList in_scope tpl_vars)
+ is_orphan id = not (idIsFrom mod id)
+ -- NB we can't use isLocalId in the orphan test,
+ -- because isLocalId isn't true of class methods
ds_lhs all_vars lhs
= let
other -> (emptyBag, lhs)
in
mappM ds_dict_bind (bagToList dict_binds) `thenDs` \ dict_binds' ->
- dsLExpr body `thenDs` \ body' ->
+ dsLExpr body `thenDs` \ body' ->
-- Substitute the dict bindings eagerly,
-- and take the body apart into a (f args) form
import TcRnMonad
import HsSyn ( HsExpr, HsMatchContext, Pat )
import TcIface ( tcIfaceGlobal )
+import RdrName ( GlobalRdrEnv )
import HscTypes ( TyThing(..), TypeEnv, HscEnv,
- tyThingId, tyThingTyCon, tyThingDataCon )
+ tyThingId, tyThingTyCon, tyThingDataCon, unQualInScope )
import Bag ( emptyBag, snocBag, Bag )
import DataCon ( DataCon )
import TyCon ( TyCon )
import NameEnv
import OccName ( occNameFS )
import CmdLineOpts ( DynFlags )
+import ErrUtils ( WarnMsg, mkWarnMsg )
+import Bag ( mapBag )
import DATA_IOREF ( newIORef, readIORef )
-- initDs returns the UniqSupply out the end (not just the result)
initDs :: HscEnv
- -> Module -> TypeEnv
+ -> Module -> GlobalRdrEnv -> TypeEnv
-> DsM a
- -> IO (a, Bag DsWarning)
+ -> IO (a, Bag WarnMsg)
-initDs hsc_env mod type_env thing_inside
+initDs hsc_env mod rdr_env type_env thing_inside
= do { warn_var <- newIORef emptyBag
; let { if_env = IfGblEnv { if_rec_types = Just (mod, return type_env) }
; gbl_env = DsGblEnv { ds_mod = mod,
; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside
; warns <- readIORef warn_var
- ; return (res, warns)
+ ; return (res, mapBag mk_warn warns)
}
+ where
+ print_unqual = unQualInScope rdr_env
+
+ mk_warn :: (SrcSpan,SDoc) -> WarnMsg
+ mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc
\end{code}
And all this mysterious stuff is so we can occasionally reach out and
--------------------------
coreRuleToIfaceRule :: ModuleName -> (Name -> IfaceExtName) -> IdCoreRule -> IfaceRule
-coreRuleToIfaceRule mod ext (id, BuiltinRule _ _)
+coreRuleToIfaceRule mod ext (IdCoreRule id _ (BuiltinRule _ _))
= pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule (mkIfaceExtName (getName id)))
-coreRuleToIfaceRule mod ext (id, Rule name act bndrs args rhs)
- = IfaceRule { ifRuleName = name, ifActivation = act,
+coreRuleToIfaceRule mod ext (IdCoreRule id _ (Rule name act bndrs args rhs))
+ = IfaceRule { ifRuleName = name, ifActivation = act,
ifRuleBndrs = map (toIfaceBndr ext) bndrs,
- ifRuleHead = ext (idName id),
- ifRuleArgs = map (toIfaceExpr (mkLhsNameFn mod)) args,
+ ifRuleHead = ext (idName id),
+ ifRuleArgs = map (toIfaceExpr (mkLhsNameFn mod)) args,
-- Use LHS name-fn for the args
ifRuleRhs = toIfaceExpr ext rhs }
do { fn <- tcIfaceExtId fn_rdr
; args' <- mappM tcIfaceExpr args
; rhs' <- tcIfaceExpr rhs
- ; returnM (fn, (Rule rule_name act bndrs' args' rhs')) }
+ ; let rule = Rule rule_name act bndrs' args' rhs'
+ ; returnM (IdCoreRule fn (isOrphNm fn_rdr) rule) }
+ where
tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule)
= do { fn <- tcIfaceExtId fn_rdr
- ; returnM (fn, core_rule) }
+ ; returnM (IdCoreRule fn (isOrphNm fn_rdr) core_rule) }
+
+isOrphNm :: IfaceExtName -> Bool
+isOrphNm (LocalTop _) = False
+isOrphNm (LocalTopSub _ _) = False
+isOrphNm other = True
\end{code}
import CmdLineOpts ( DynFlag(..), dopt )
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding )
-import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars )
+import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars )
import CoreTidy ( tidyExpr, tidyVarOcc, tidyIdRules )
import PprCore ( pprIdRules )
import CoreLint ( showPass, endPass )
; showPass dflags "Tidy Core"
; let omit_iface_prags = dopt Opt_OmitInterfacePragmas dflags
- ; let ext_ids = findExternalSet omit_iface_prags binds_in orphans_in
+ ; let ext_ids = findExternalSet omit_iface_prags binds_in
; let ext_rules = findExternalRules omit_iface_prags binds_in orphans_in ext_ids
-- findExternalRules filters ext_rules to avoid binders that
-- aren't externally visible; but the externally-visible binders
-- are computed (by findExternalSet) assuming that all orphan
- -- rules are exported. So in fact we may export more than we
- -- need. (It's a sort of mutual recursion.)
+ -- rules are exported (they get their Exported flag set in the desugarer)
+ -- So in fact we may export more than we need.
+ -- (It's a sort of mutual recursion.)
-- We also make sure to avoid any exported binders. Consider
-- f{-u1-} = 1 -- Local decl
findExternalRules omit_iface_prags binds orphan_rules ext_ids
| omit_iface_prags = []
| otherwise
- = filter needed_rule (orphan_rules ++ local_rules)
+ = filter (not . internal_rule) (orphan_rules ++ local_rules)
where
local_rules = [ rule
| id <- bindersOfBinds binds,
id `elemVarEnv` ext_ids,
rule <- idCoreRules id
]
- needed_rule (id, rule)
- = not (isBuiltinRule rule)
+ internal_rule (IdCoreRule id is_orphan rule)
+ = isBuiltinRule rule
-- We can't print builtin rules in interface files
-- Since they are built in, an importing module
-- will have access to them anyway
- && not (any internal_id (varSetElems (ruleLhsFreeIds rule)))
+ || (not is_orphan && internal_id id)
+ -- Rule for an Id in this module; internal if the
+ -- Id is not exported
+
+ || any internal_id (varSetElems (ruleLhsFreeIds rule))
-- Don't export a rule whose LHS mentions an Id that
-- is completely internal (i.e. not visible to an
-- importing module)
- internal_id id = isLocalId id && not (id `elemVarEnv` ext_ids)
+ internal_id id = not (id `elemVarEnv` ext_ids)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-findExternalSet :: Bool -- omit interface pragmas
- -> [CoreBind] -> [IdCoreRule]
+findExternalSet :: Bool -- Omit interface pragmas
+ -> [CoreBind]
-> IdEnv Bool -- In domain => external
-- Range = True <=> show unfolding
-- Step 1 from the notes above
-findExternalSet omit_iface_prags binds orphan_rules
- = foldr find init_needed binds
+findExternalSet omit_iface_prags binds
+ = foldr find emptyVarEnv binds
where
- orphan_rule_ids :: IdSet
- orphan_rule_ids = unionVarSets [ ruleRhsFreeVars rule
- | (_, rule) <- orphan_rules]
- init_needed :: IdEnv Bool
- init_needed = mapUFM (\_ -> False) orphan_rule_ids
- -- The mapUFM is a bit cheesy. It is a cheap way
- -- to turn the set of orphan_rule_ids, which we use to initialise
- -- the sweep, into a mapping saying 'don't expose unfolding'
- -- (When we come to the binding site we may change our mind, of course.)
-
find (NonRec id rhs) needed
| need_id needed id = addExternal omit_iface_prags (id,rhs) needed
| otherwise = needed
-- (b) Rules are now just orphan rules
prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
- guts@(ModGuts { mg_binds = binds, mg_rules = local_rules, mg_module = this_mod })
+ guts@(ModGuts { mg_binds = binds, mg_rules = local_rules })
us
= do { eps <- hscEPS hsc_env
env = setInScopeSet (emptySimplEnv SimplGently []) local_ids
(better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
- (rules_for_locals, orphan_rules) = partition is_local_rule better_rules
- is_local_rule (id,_) = idIsFrom this_mod id
+ (orphan_rules, rules_for_locals) = partition isOrphanRule better_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 (hackily) the
-- Example: class Foo a where
-- op :: a -> a
-- {-# RULES "op" op x = x #-}
- --
- -- NB we can't use isLocalId, because isLocalId isn't true of class methods.
-- NB: we assume that the imported rules dont include
-- rules for Ids in this module; if there is, the above bad things may happen
text "Imported rules", pprRuleBase imp_rule_base])
#ifdef DEBUG
- ; let bad_rules = filter (idIsFrom this_mod) (varSetElems (ruleBaseIds imp_rule_base))
+ ; let bad_rules = filter (idIsFrom (mg_mod guts))
+ (varSetElems (ruleBaseIds imp_rule_base))
; WARN( not (null bad_rules), ppr bad_rules ) return ()
#endif
; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules })
This doesn't match unless you do eta reduction on the build argument.
\begin{code}
-simplRule env rule@(id, BuiltinRule _ _)
+simplRule env rule@(IdCoreRule id _ (BuiltinRule _ _))
= returnSmpl rule
-simplRule env rule@(id, Rule act name bndrs args rhs)
+simplRule env (IdCoreRule id is_orph (Rule act name bndrs args rhs))
= simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
simplExprGently env rhs `thenSmpl` \ rhs' ->
- returnSmpl (id, Rule act name bndrs' args' rhs')
+ returnSmpl (IdCoreRule id is_orph (Rule act name bndrs' args' rhs'))
-- It's important that simplExprGently does eta reduction.
-- For example, in a rule like:
ruleBaseIds (RuleBase ids) = ids
emptyRuleBase = RuleBase emptyVarSet
-extendRuleBaseList :: RuleBase -> [(Id,CoreRule)] -> RuleBase
+extendRuleBaseList :: RuleBase -> [IdCoreRule] -> RuleBase
extendRuleBaseList rule_base new_guys
= foldl extendRuleBase rule_base new_guys
-extendRuleBase :: RuleBase -> (Id,CoreRule) -> RuleBase
-extendRuleBase (RuleBase rule_ids) (id, rule)
+extendRuleBase :: RuleBase -> IdCoreRule -> RuleBase
+extendRuleBase (RuleBase rule_ids) (IdCoreRule id _ rule)
= RuleBase (extendVarSet rule_ids new_id)
where
new_id = setIdSpecialisation id (addRule id old_rules rule)
\begin{code}
tcDeriving :: [LTyClDecl Name] -- All type constructors
-> TcM ([InstInfo], -- The generated "instance decls"
- [HsBindGroup Name], -- Extra generated top-level bindings
- NameSet) -- Binders to keep alive
+ [HsBindGroup Name]) -- Extra generated top-level bindings
tcDeriving tycl_decls
- = recoverM (returnM ([], [], emptyNameSet)) $
+ = recoverM (returnM ([], [])) $
do { -- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns tycl_decls
-- Rename these extra bindings, discarding warnings about unused bindings etc
-- Set -fglasgow exts so that we can have type signatures in patterns,
-- which is used in the generic binds
- ; (rn_binds, gen_bndrs)
+ ; rn_binds
<- discardWarnings $ setOptM Opt_GlasgowExts $ do
{ (rn_deriv, _dus1) <- rnTopBinds deriv_binds []
; (rn_gen, dus_gen) <- rnTopBinds gen_binds []
- ; return (rn_deriv ++ rn_gen, duDefs dus_gen) }
+ ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to
+ -- be kept alive
+ ; return (rn_deriv ++ rn_gen) }
; 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)
+ ; returnM (inst_info, rn_binds)
}
where
ddump_deriving :: [InstInfo] -> [HsBindGroup Name] -> SDoc
-- Indicates the legal transitions on bracket( [| |] ).
bracketOK :: ThStage -> Maybe ThLevel
bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
-bracketOK stage = (Just (thLevel stage + 1))
+bracketOK stage = Just (thLevel stage + 1)
-- Indicates the legal transitions on splice($).
spliceOK :: ThStage -> Maybe ThLevel
)
import Kind ( openTypeKind, liftedTypeKind, argTypeKind )
-import Id ( idType, recordSelectorFieldLabel, isRecordSelector )
+import Id ( idType, recordSelectorFieldLabel, isRecordSelector, idName )
import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId )
-import Name ( Name )
+import Name ( Name, isExternalName )
import TyCon ( TyCon, FieldLabel, tyConTyVars, tyConStupidTheta,
tyConDataCons, tyConFields )
import Type ( zipTopTvSubst, mkTopTvSubst, substTheta, substTy )
-- Return the type variables at which the function
-- is instantiated, as well as the translated variable and its type
-tcId name -- Look up the Id and instantiate its type
- = tcLookup name `thenM` \ thing ->
+tcId id_name -- Look up the Id and instantiate its type
+ = tcLookup id_name `thenM` \ thing ->
case thing of {
- AGlobal (AnId id) -> instantiate id
- -- A global cannot possibly be ill-staged
- -- nor does it need the 'lifting' treatment
-
- ; AGlobal (ADataCon con) -- Similar, but instantiate the stupid theta too
+ AGlobal (ADataCon con) -- Similar, but instantiate the stupid theta too
-> do { (expr, tvs, tau) <- instantiate (dataConWrapId con)
; tcInstStupidTheta con (mkTyVarTys tvs)
-- Remember to chuck in the constraints from the "silly context"
; return (expr, tvs, tau) }
+ ; AGlobal (AnId id) -> instantiate id
+ -- A global cannot possibly be ill-staged
+ -- nor does it need the 'lifting' treatment
+
; ATcId id th_level proc_level
-> do { checkProcLevel id proc_level
; tc_local_id id th_level }
- ; other -> pprPanic "tcId" (ppr name $$ ppr thing)
+ ; other -> pprPanic "tcId" (ppr id_name $$ ppr thing)
}
where
case use_stage of
Brack use_lvl ps_var lie_var
| use_lvl > th_bind_lvl
- -> -- E.g. \x -> [| h x |]
- -- We must behave as if the reference to x was
- -- h $(lift x)
- -- We use 'x' itself as the splice proxy, used by
- -- the desugarer to stitch it all back together.
- -- If 'x' occurs many times we may get many identical
- -- bindings of the same splice proxy, but that doesn't
- -- matter, although it's a mite untidy.
- let
- id_ty = idType id
- in
- checkTc (isTauTy id_ty) (polySpliceErr id) `thenM_`
- -- If x is polymorphic, its occurrence sites might
- -- have different instantiations, so we can't use plain
- -- 'x' as the splice proxy name. I don't know how to
- -- solve this, and it's probably unimportant, so I'm
- -- just going to flag an error for now
-
- setLIEVar lie_var (
- newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift ->
- -- Put the 'lift' constraint into the right LIE
-
- -- Update the pending splices
- readMutVar ps_var `thenM` \ ps ->
- writeMutVar ps_var ((name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps) `thenM_`
-
- returnM (HsVar id, [], id_ty))
+ -> if isExternalName id_name then
+ -- Top-level identifiers in this module,
+ -- (which have External Names)
+ -- are just like the imported case:
+ -- no need for the 'lifting' treatment
+ -- E.g. this is fine:
+ -- f x = x
+ -- g y = [| f 3 |]
+ -- But we do need to put f into the keep-alive
+ -- set, because after desugaring the code will
+ -- only mention f's *name*, not f itself.
+ keepAliveTc id_name `thenM_`
+ instantiate id
+
+ else -- Nested identifiers, such as 'x' in
+ -- E.g. \x -> [| h x |]
+ -- We must behave as if the reference to x was
+ -- h $(lift x)
+ -- We use 'x' itself as the splice proxy, used by
+ -- the desugarer to stitch it all back together.
+ -- If 'x' occurs many times we may get many identical
+ -- bindings of the same splice proxy, but that doesn't
+ -- matter, although it's a mite untidy.
+ let
+ id_ty = idType id
+ in
+ checkTc (isTauTy id_ty) (polySpliceErr id) `thenM_`
+ -- If x is polymorphic, its occurrence sites might
+ -- have different instantiations, so we can't use plain
+ -- 'x' as the splice proxy name. I don't know how to
+ -- solve this, and it's probably unimportant, so I'm
+ -- just going to flag an error for now
+
+ setLIEVar lie_var (
+ newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift ->
+ -- Put the 'lift' constraint into the right LIE
+
+ -- Update the pending splices
+ readMutVar ps_var `thenM` \ ps ->
+ writeMutVar ps_var ((id_name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps) `thenM_`
+
+ returnM (HsVar id, [], id_ty))
other ->
checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage `thenM_`
(_,[],_) -> False -- Not overloaded
(_,theta,_) -> not (any isLinearPred theta)
- orig = OccurrenceOf name
+ orig = OccurrenceOf id_name
\end{code}
%************************************************************************
-- (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, keep_alive) ->
+ tcDeriving tycl_decls `thenM` \ (deriv_inst_info, deriv_binds) ->
addInsts deriv_inst_info $
getGblEnv `thenM` \ gbl_env ->
- returnM (gbl_env { tcg_keep = tcg_keep gbl_env `unionNameSets` keep_alive },
+ returnM (gbl_env,
generic_inst_info ++ deriv_inst_info ++ local_inst_info,
deriv_binds)
-- Process the export list
exports <- exportsFromAvail (isJust maybe_mod) exports ;
-{- Jan 04: I don't think this is necessary any more; usage info is derived from tcg_dus
- -- Get any supporting decls for the exports that have not already
- -- been sucked in for the declarations in the body of the module.
- -- (This can happen if something is imported only to be re-exported.)
- --
- -- Importing these supporting declarations is required
- -- *only* to gether usage information
- -- (see comments with MkIface.mkImportInfo for why)
- -- We don't need the results, but sucking them in may side-effect
- -- the ExternalPackageState, apart from recording usage
- mappM (tcLookupGlobal . availName) export_avails ;
--}
-
-- Check whether the entire module is deprecated
-- This happens only once per module
let { mod_deprecs = checkModDeprec mod_deprec } ;
-- If we are in module Main, check that 'main' is defined.
-- It may be imported from another module!
--
- -- ToDo: We have to return the main_name separately, because it's a
- -- bona fide 'use', and should be recorded as such, but the others
- -- aren't
--
-- Blimey: a whole page of code to do this...
| mod_name /= main_mod
`snocBag` main_bind,
tcg_dus = tcg_dus tcg_env
`plusDU` usesOnly (unitFV main_name)
+ -- Record the use of 'main', so that we don't
+ -- complain about it being defined but not used
})
}}}
where
mkLocMessage, mkLongErrMsg )
import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) )
import NameEnv ( emptyNameEnv )
-import NameSet ( emptyDUs, emptyNameSet )
+import NameSet ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet )
import OccName ( emptyOccEnv )
import Module ( moduleName )
import Bag ( emptyBag )
tvs_var <- newIORef emptyVarSet ;
type_env_var <- newIORef emptyNameEnv ;
dfuns_var <- newIORef emptyNameSet ;
+ keep_var <- newIORef emptyNameSet ;
th_var <- newIORef False ;
let {
tcg_insts = [],
tcg_rules = [],
tcg_fords = [],
- tcg_keep = emptyNameSet
+ tcg_keep = keep_var
} ;
lcl_env = TcLclEnv {
tcl_errs = errs_var,
recordThUse :: TcM ()
recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True }
+keepAliveTc :: Name -> TcM () -- Record the name in the keep-alive set
+keepAliveTc n = do { env <- getGblEnv;
+ ; updMutVar (tcg_keep env) (`addOneToNameSet` n) }
+
+keepAliveSetTc :: NameSet -> TcM () -- Record the name in the keep-alive set
+keepAliveSetTc ns = do { env <- getGblEnv;
+ ; updMutVar (tcg_keep env) (`unionNameSets` ns) }
+
getStage :: TcM ThStage
getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
tcg_inst_env :: InstEnv, -- Instance envt for *home-package* modules
-- Includes the dfuns in tcg_insts
- tcg_inst_uses :: TcRef NameSet, -- Home-package Dfuns actually used
- -- Used to generate version dependencies
- -- This records usages, rather like tcg_dus, but it has to
- -- be a mutable variable so it can be augmented
- -- when we look up an instance. These uses of dfuns are
- -- rather like the free variables of the program, but
- -- are implicit instead of explicit.
-
- tcg_th_used :: TcRef Bool, -- True <=> Template Haskell syntax used
- -- We need this so that we can generate a dependency on the
- -- Template Haskell package, becuase the desugarer is going to
- -- emit loads of references to TH symbols. It's rather like
- -- tcg_inst_uses; the reference is implicit rather than explicit,
- -- so we have to zap a mutable variable.
-
-- Now a bunch of things about this module that are simply
-- accumulated, but never consulted until the end.
-- Nevertheless, it's convenient to accumulate them along
-- 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.
+ tcg_keep :: TcRef NameSet, -- Locally-defined top-level names to keep alive
+ -- "Keep alive" means give them an Exported flag, so
+ -- that the simplifier does not discard them as dead
+ -- code, and so that they are exposed in the interface file
+ -- (but not to export to the user).
+ --
+ -- Some things, like dict-fun Ids and default-method Ids are
+ -- "born" with the Exported flag on, for exactly the above reason,
+ -- but some we only discover as we go. Specifically:
+ -- * The to/from functions for generic data types
+ -- * Top-level variables appearing free in the RHS of an orphan rule
+ -- * Top-level variables appearing free in a TH bracket
+
+ tcg_inst_uses :: TcRef NameSet, -- Home-package Dfuns actually used
+ -- Used to generate version dependencies
+ -- This records usages, rather like tcg_dus, but it has to
+ -- be a mutable variable so it can be augmented
+ -- when we look up an instance. These uses of dfuns are
+ -- rather like the free variables of the program, but
+ -- are implicit instead of explicit.
+
+ tcg_th_used :: TcRef Bool, -- True <=> Template Haskell syntax used
+ -- We need this so that we can generate a dependency on the
+ -- Template Haskell package, becuase the desugarer is going to
+ -- emit loads of references to TH symbols. It's rather like
+ -- tcg_inst_uses; the reference is implicit rather than explicit,
+ -- so we have to zap a mutable variable.
-- The next fields accumulate the payload of the module
-- The binds, rules and foreign-decl fiels are collected
-- Template Haskell levels
---------------------------
-type ThLevel = Int -- Always >= 0
+type ThLevel = Int
+ -- Indicates how many levels of brackets we are inside
+ -- (always >= 0)
+ -- Incremented when going inside a bracket,
+ -- decremented when going inside a splice
+
+impLevel, topLevel :: ThLevel
+topLevel = 1 -- Things defined at top level of this module
+impLevel = 0 -- Imported things; they can be used inside a top level splice
+--
+-- For example:
+-- f = ...
+-- g1 = $(map ...) is OK
+-- g2 = $(f ...) is not OK; because we havn't compiled f yet
+
data ThStage
= Comp -- Ordinary compiling, at level topLevel
topSpliceStage = Splice (topLevel - 1) -- Stage for the body of a top-level splice
-impLevel, topLevel :: ThLevel
-topLevel = 1 -- Things defined at top level of this module
-impLevel = 0 -- Imported things; they can be used inside a top level splice
---
--- For example:
--- f = ...
--- g1 = $(map ...) is OK
--- g2 = $(f ...) is not OK; because we havn't compiled f yet
-
-
---------------------------
-- Arrow-notation stages
---------------------------
\begin{code}
instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
- qNewName s = do { u <- newUnique
+ qNewName s = do { u <- newUnique
; let i = getKey u
; return (TH.mkNameU s i) }
projects / ghc-hetmet.git / commitdiff