Commit 1f7da302 authored by simonpj's avatar simonpj
Browse files

[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
parent c1a7d1a6
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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 _)
......
......@@ -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
......
......@@ -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
......
......@@ -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 }
......
......@@ -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}
......
......@@ -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
......
......@@ -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:
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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