From 1f7da30204a9b735e8bc543a5bacf03135bcc9c7 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 25 Nov 2004 11:37:19 +0000 Subject: [PATCH] [project @ 2004-11-25 11:36:34 by simonpj] ------------------------------------------ Keep-alive set and Template Haskell quotes ------------------------------------------ a) Template Haskell quotes should be able to mention top-leve things without resorting to lifting. Example module Foo( foo ) where f x = x foo = [| f 4 |] Here the reference to 'f' is ok; no need to 'lift' it. The relevant changes are in TcExpr.tcId b) However, we must take care not to discard the binding for f, so we add it to the 'keep-alive' set for the module. I've now made this into (another) mutable bucket, tcg_keep, in the TcGblEnv c) That in turn led me to look at the handling of orphan rules; as a result I made IdCoreRule into its own data type, which has simle but non-local ramifications --- ghc/compiler/basicTypes/Id.lhs | 4 +- ghc/compiler/basicTypes/Var.lhs | 2 + ghc/compiler/coreSyn/CoreFVs.lhs | 9 ++- ghc/compiler/coreSyn/CoreSyn.lhs | 9 ++- ghc/compiler/coreSyn/CoreTidy.lhs | 4 +- ghc/compiler/coreSyn/PprCore.lhs | 2 +- ghc/compiler/deSugar/Desugar.lhs | 117 +++++++++++++++------------------ ghc/compiler/deSugar/DsMonad.lhs | 18 +++-- ghc/compiler/iface/IfaceSyn.lhs | 10 +-- ghc/compiler/iface/TcIface.lhs | 11 +++- ghc/compiler/main/TidyPgm.lhs | 41 +++++------- ghc/compiler/simplCore/SimplCore.lhs | 16 ++--- ghc/compiler/specialise/Rules.lhs | 6 +- ghc/compiler/typecheck/TcDeriv.lhs | 13 ++-- ghc/compiler/typecheck/TcEnv.lhs | 2 +- ghc/compiler/typecheck/TcExpr.lhs | 91 ++++++++++++++----------- ghc/compiler/typecheck/TcInstDcls.lhs | 4 +- ghc/compiler/typecheck/TcRnDriver.lhs | 18 +---- ghc/compiler/typecheck/TcRnMonad.lhs | 13 +++- ghc/compiler/typecheck/TcRnTypes.lhs | 73 +++++++++++--------- ghc/compiler/typecheck/TcSplice.lhs | 2 +- 21 files changed, 245 insertions(+), 220 deletions(-) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index ae3c103..972c6ab 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -79,7 +79,7 @@ module Id ( #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, @@ -395,7 +395,7 @@ idSpecialisation :: Id -> CoreRules 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 diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index d02b9ec..0e282c2 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -93,6 +93,8 @@ data LocalIdDetails | 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 diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index 6aed662..f54b268 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -161,8 +161,8 @@ make the whole module an orphan module, which is bad. \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 @@ -211,11 +211,10 @@ ruleRhsFreeVars (Rule str _ tpl_vars tpl_args rhs) 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} diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 69c49dd..28c913d 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -41,7 +41,7 @@ module CoreSyn ( -- Core rules CoreRules(..), -- Representation needed by friends CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only - IdCoreRule, + IdCoreRule(..), isOrphanRule, RuleName, emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules, isBuiltinRule, ruleName @@ -186,7 +186,12 @@ rulesRules (Rules rules _) = rules \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 diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 9c03072..76d1bd3 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -94,10 +94,10 @@ tidyNote env note = note ------------ 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 diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index ec52bb6..10ad00c 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -352,7 +352,7 @@ pprIdRules :: [IdCoreRule] -> SDoc 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 _) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 1a5d7e8..e7ae7ee 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -15,7 +15,7 @@ import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr, 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 ) @@ -65,34 +65,53 @@ deSugar hsc_env 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 @@ -143,13 +162,8 @@ 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 - -- 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 @@ -160,13 +174,13 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr ; 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) @@ -175,39 +189,8 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_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 @@ -224,19 +207,22 @@ dsProgram ghci_mode (TcGblEnv { tcg_exports = exports, -- 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 @@ -270,15 +256,18 @@ ppr_ds_rules rules %************************************************************************ \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 @@ -288,7 +277,7 @@ ds_lhs all_vars lhs 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 diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index b5b8598..e656ab0 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -30,8 +30,9 @@ module DsMonad ( 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 ) @@ -47,6 +48,8 @@ import Name ( Name, nameOccName ) import NameEnv import OccName ( occNameFS ) import CmdLineOpts ( DynFlags ) +import ErrUtils ( WarnMsg, mkWarnMsg ) +import Bag ( mapBag ) import DATA_IOREF ( newIORef, readIORef ) @@ -100,11 +103,11 @@ data DsMetaVal -- 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, @@ -116,8 +119,13 @@ initDs hsc_env mod type_env thing_inside ; 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 diff --git a/ghc/compiler/iface/IfaceSyn.lhs b/ghc/compiler/iface/IfaceSyn.lhs index 3d3029c..2edcfc8 100644 --- a/ghc/compiler/iface/IfaceSyn.lhs +++ b/ghc/compiler/iface/IfaceSyn.lhs @@ -618,14 +618,14 @@ toIfaceIdInfo ext id_info -------------------------- 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 } diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 2ca88ba..2a875e0 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -549,11 +549,18 @@ tcIfaceRule (IfaceRule {ifRuleName = rule_name, ifActivation = act, ifRuleBndrs 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} diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index 01cdd0f..c925735 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -11,7 +11,7 @@ module TidyPgm( tidyCorePgm, tidyCoreExpr ) where 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 ) @@ -128,13 +128,14 @@ tidyCorePgm hsc_env ; 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 @@ -272,25 +273,29 @@ findExternalRules :: Bool -- Omit interface pragmas 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} %************************************************************************ @@ -300,24 +305,14 @@ findExternalRules omit_iface_prags binds orphan_rules ext_ids %************************************************************************ \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 diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index db7058a..ba34b0c 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -209,7 +209,7 @@ prepareRules :: HscEnv -- (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 @@ -219,8 +219,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) 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 @@ -230,8 +229,6 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) -- 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 @@ -265,7 +262,8 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) 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 }) @@ -295,13 +293,13 @@ which without simplification looked like: 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: diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 5f63dac..f627d46 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -613,12 +613,12 @@ data RuleBase = RuleBase 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) diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index b74daf3..a2b84ca 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -205,11 +205,10 @@ And then translate it to: \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 @@ -227,18 +226,20 @@ tcDeriving 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 diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 1aa86dc..3aba65f 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -485,7 +485,7 @@ topIdLvl id | isLocalId id = topLevel -- 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 diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 03d346f..ce7162c 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -43,9 +43,9 @@ import TcType ( Type, TcTyVar, TcType, TcSigmaType, TcRhoType, MetaDetails(..), ) 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 ) @@ -773,24 +773,24 @@ tcId :: Name -> TcM (HsExpr TcId, [TcTyVar], TcRhoType) -- 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 @@ -805,33 +805,48 @@ tcId name -- Look up the Id and instantiate its type 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_` @@ -870,7 +885,7 @@ tcId name -- Look up the Id and instantiate its type (_,[],_) -> False -- Not overloaded (_,theta,_) -> not (any isLinearPred theta) - orig = OccurrenceOf name + orig = OccurrenceOf id_name \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 4a22f9c..d428fd0 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -159,11 +159,11 @@ tcInstDecls1 tycl_decls inst_decls -- (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) diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 676792b..c981b99 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -197,19 +197,6 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports -- 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 } ; @@ -635,9 +622,6 @@ check_main ghci_mode tcg_env main_mod main_fn -- 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 @@ -665,6 +649,8 @@ check_main ghci_mode tcg_env main_mod main_fn `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 diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index a2db330..acbda80 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -32,7 +32,7 @@ import ErrUtils ( Message, Messages, emptyMessages, errorsFound, 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 ) @@ -75,6 +75,7 @@ initTc hsc_env mod do_this tvs_var <- newIORef emptyVarSet ; type_env_var <- newIORef emptyNameEnv ; dfuns_var <- newIORef emptyNameSet ; + keep_var <- newIORef emptyNameSet ; th_var <- newIORef False ; let { @@ -96,7 +97,7 @@ initTc hsc_env mod do_this tcg_insts = [], tcg_rules = [], tcg_fords = [], - tcg_keep = emptyNameSet + tcg_keep = keep_var } ; lcl_env = TcLclEnv { tcl_errs = errs_var, @@ -771,6 +772,14 @@ setLclTypeEnv lcl_env thing_inside 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) } diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index d30a6d6..df7dc46 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -150,21 +150,6 @@ data TcGblEnv 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 @@ -180,11 +165,33 @@ data TcGblEnv -- 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 @@ -312,7 +319,21 @@ pass it inwards. -- 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 @@ -325,16 +346,6 @@ topStage = Comp 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 --------------------------- diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 31dfd31..de0d620 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -397,7 +397,7 @@ To call runQ in the Tc monad, we need to make TcM an instance of Quasi: \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) } -- 1.7.10.4