----------------------------------------
Make dict funs and default methods
into LocalIds only at their binding site
----------------------------------------
[part of 3 related commits]
There's a long comment about this with MkId.mkDefaultMethodId,
which I reproduce below.
While I was at it, I renamed setIdNoDiscard to setIdLocalExported.
Which is hardly an improvement, I'm afraid. This renaming touches
Var.lhs, Id.lhs, SimplCore.lhs
in a trivial way.
---------------------
Dict funs and default methods are *not* ImplicitIds. Their definition
involves user-written code, so we can't figure out their strictness etc
based on fixed info, as we can for constructors and record selectors (say).
We build them as GlobalIds, but when in the module where they are
bound, we turn the Id at the *binding site* into an exported LocalId.
This ensures that they are taken to account by free-variable finding
and dependency analysis (e.g. CoreFVs.exprFreeVars). The simplifier
will propagate the LocalId to all occurrence sites.
Why shouldn't they be bound as GlobalIds? Because, in particular, if
they are globals, the specialiser floats dict uses above their defns,
which prevents good simplifications happening. Also the strictness
analyser treats a occurrence of a GlobalId as imported and assumes it
contains strictness in its IdInfo, which isn't true if the thing is
bound in the same module as the occurrence.
It's OK for dfuns to be LocalIds, because we form the instance-env to
pass on to the next module (md_insts) in CoreTidy, afer tidying
and globalising the top-level Ids.
BUT make sure they are *exported* LocalIds (setIdLocalExported) so
that they aren't discarded by the occurrence analyser.
recordSelectorFieldLabel,
-- Modifying an Id
recordSelectorFieldLabel,
-- Modifying an Id
- setIdName, setIdUnique, setIdType, setIdNoDiscard, setGlobalIdDetails,
+ setIdName, setIdUnique, setIdType, setIdLocalExported, setGlobalIdDetails,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
zapLamIdInfo, zapDemandIdInfo,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
zapLamIdInfo, zapDemandIdInfo,
import Var ( Id, DictId,
isId, isExportedId, isSpecPragmaId, isLocalId,
idName, idType, idUnique, idInfo, isGlobalId,
import Var ( Id, DictId,
isId, isExportedId, isSpecPragmaId, isLocalId,
idName, idType, idUnique, idInfo, isGlobalId,
- setIdName, setVarType, setIdUnique, setIdNoDiscard,
+ setIdName, setVarType, setIdUnique, setIdLocalExported,
setIdInfo, lazySetIdInfo, modifyIdInfo,
maybeModifyIdInfo,
globalIdDetails, setGlobalIdDetails
setIdInfo, lazySetIdInfo, modifyIdInfo,
maybeModifyIdInfo,
globalIdDetails, setGlobalIdDetails
Id, DictId,
idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo,
setIdName, setIdUnique, setIdInfo, lazySetIdInfo,
Id, DictId,
idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo,
setIdName, setIdUnique, setIdInfo, lazySetIdInfo,
- setIdNoDiscard, zapSpecPragmaId,
+ setIdLocalExported, zapSpecPragmaId,
globalIdDetails, setGlobalIdDetails,
globalIdDetails, setGlobalIdDetails,
import Name ( Name, OccName, NamedThing(..),
setNameUnique, setNameOcc, nameUnique,
import Name ( Name, OccName, NamedThing(..),
setNameUnique, setNameOcc, nameUnique,
- mkSysLocalName, isExternallyVisibleName
)
import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey )
import FastTypes
)
import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey )
import FastTypes
setIdName :: Id -> Name -> Id
setIdName = setVarName
setIdName :: Id -> Name -> Id
setIdName = setVarName
-setIdNoDiscard :: Id -> Id
-setIdNoDiscard id
- = WARN( not (isLocalId id), ppr id )
- id { varDetails = LocalId Exported }
+setIdLocalExported :: Id -> Id
+setIdLocalExported id = id { varDetails = LocalId Exported }
zapSpecPragmaId :: Id -> Id
zapSpecPragmaId id
zapSpecPragmaId :: Id -> Id
zapSpecPragmaId id
import ErrUtils ( dumpIfSet, dumpIfSet_dyn )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import ErrUtils ( dumpIfSet, dumpIfSet_dyn )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( idName, isDataConWrapId, setIdNoDiscard, isImplicitId )
+import Id ( idName, isDataConWrapId, setIdLocalExported, isImplicitId )
import VarSet
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
import VarSet
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
update_bndr bndr
| isImplicitId bndr = bndr -- Constructors, selectors; doesn't
update_bndr bndr
| isImplicitId bndr = bndr -- Constructors, selectors; doesn't
- -- make sense to call setIdNoDiscard
+ -- make sense to call setIdLocalExported
- | dont_discard bndr = setIdNoDiscard bndr_with_rules
+ | dont_discard bndr = setIdLocalExported bndr_with_rules
| otherwise = bndr_with_rules
where
bndr_with_rules = lookupVarSet rule_ids bndr `orElse` bndr
| otherwise = bndr_with_rules
where
bndr_with_rules = lookupVarSet rule_ids bndr `orElse` bndr
Class, ClassOpItem, DefMeth (..) )
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon )
Class, ClassOpItem, DefMeth (..) )
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon )
-import Id ( idType, idName )
+import Id ( idType, idName, setIdLocalExported )
import Module ( Module )
import Name ( Name, NamedThing(..) )
import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
import Module ( Module )
import Name ( Name, NamedThing(..) )
import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
tcClassSig :: RecTcEnv -- Knot tying only!
-> Class -- ...ditto...
-> [TyVar] -- The class type variable, used for error check only
tcClassSig :: RecTcEnv -- Knot tying only!
-> Class -- ...ditto...
-> [TyVar] -- The class type variable, used for error check only
- -> Maybe (NameEnv Bool) -- Info about default methods
+ -> Maybe (NameEnv Bool) -- Info about default methods;
+ -- Nothing => imported class defn with no method binds
-> RenamedClassOpSig
-> TcM (Type, -- Type of the method
ClassOpItem) -- Selector Id, default-method Id, True if explicit default binding
-> RenamedClassOpSig
-> TcM (Type, -- Type of the method
ClassOpItem) -- Selector Id, default-method Id, True if explicit default binding
= tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
let
theta = [(mkClassPred clas inst_tys)]
= tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
let
theta = [(mkClassPred clas inst_tys)]
+ local_dm_id = setIdLocalExported dm_id
+ -- Reason for setIdLocalExported: see notes with MkId.mkDictFunId
in
newDicts origin theta `thenNF_Tc` \ [this_dict] ->
in
newDicts origin theta `thenNF_Tc` \ [this_dict] ->
full_bind = AbsBinds
clas_tyvars'
[instToId this_dict]
full_bind = AbsBinds
clas_tyvars'
[instToId this_dict]
- [(clas_tyvars', dm_id, instToId local_dm_inst)]
+ [(clas_tyvars', local_dm_id, instToId local_dm_inst)]
emptyNameSet -- No inlines (yet)
(dict_binds `andMonoBinds` defm_bind)
in
emptyNameSet -- No inlines (yet)
(dict_binds `andMonoBinds` defm_bind)
in
import Class ( Class, DefMeth(..), classBigSig )
import Var ( idName, idType )
import VarSet ( emptyVarSet )
import Class ( Class, DefMeth(..), classBigSig )
import Var ( idName, idType )
import VarSet ( emptyVarSet )
+import Id ( setIdLocalExported )
import MkId ( mkDictFunId )
import FunDeps ( checkInstFDs )
import Generics ( validGenericInstanceType )
import MkId ( mkDictFunId )
import FunDeps ( checkInstFDs )
import Generics ( validGenericInstanceType )
| null groups
= returnTc [] -- The comon case: no generic default methods
| null groups
= returnTc [] -- The comon case: no generic default methods
- | otherwise -- A local class decl with generic default methods
+ | otherwise -- A source class decl with generic default methods
= recoverNF_Tc (returnNF_Tc []) $
tcAddDeclCtxt decl $
tcLookupClass class_name `thenTc` \ clas ->
= recoverNF_Tc (returnNF_Tc []) $
tcAddDeclCtxt decl $
tcLookupClass class_name `thenTc` \ clas ->
-- Create the result bindings
let
-- Create the result bindings
let
+ local_dfun_id = setIdLocalExported dfun_id
+ -- Reason for setIdLocalExported: see notes with MkId.mkDictFunId
+
dict_constr = classDataCon clas
scs_and_meths = map instToId (sc_dicts ++ meth_insts)
this_dict_id = instToId this_dict
dict_constr = classDataCon clas
scs_and_meths = map instToId (sc_dicts ++ meth_insts)
this_dict_id = instToId this_dict