From: simonpj Date: Fri, 7 Sep 2001 12:44:30 +0000 (+0000) Subject: [project @ 2001-09-07 12:44:30 by simonpj] X-Git-Tag: Approximately_9120_patches~1010 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;ds=sidebyside;h=991a868b891c98cd58baf59cab423355a6b7025e;p=ghc-hetmet.git [project @ 2001-09-07 12:44:30 by simonpj] ---------------------------------------- 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. --- diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index dd0bf19..9b40301 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -19,7 +19,7 @@ module Id ( recordSelectorFieldLabel, -- Modifying an Id - setIdName, setIdUnique, setIdType, setIdNoDiscard, setGlobalIdDetails, + setIdName, setIdUnique, setIdType, setIdLocalExported, setGlobalIdDetails, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, zapLamIdInfo, zapDemandIdInfo, @@ -79,7 +79,7 @@ import BasicTypes ( Arity ) 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 diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index 2362229..47d84a3 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -21,7 +21,7 @@ module Var ( Id, DictId, idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo, setIdName, setIdUnique, setIdInfo, lazySetIdInfo, - setIdNoDiscard, zapSpecPragmaId, + setIdLocalExported, zapSpecPragmaId, globalIdDetails, setGlobalIdDetails, @@ -41,7 +41,7 @@ import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId, import Name ( Name, OccName, NamedThing(..), setNameUnique, setNameOcc, nameUnique, - mkSysLocalName, isExternallyVisibleName + mkSysLocalName ) import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey ) import FastTypes @@ -253,10 +253,8 @@ setIdUnique = setVarUnique 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 diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index a886f2b..5ef10cd 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -32,7 +32,7 @@ import SimplMonad 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 ) @@ -285,9 +285,9 @@ updateBinders rule_ids rule_rhs_fvs is_exported binds update_bndr bndr | isImplicitId bndr = bndr -- Constructors, selectors; doesn't - -- make sense to call setIdNoDiscard + -- make sense to call setIdLocalExported -- Also can't have rules - | 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 diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 97e5d5b..0e37312 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -43,7 +43,7 @@ import Class ( classTyVars, classBigSig, classTyCon, className, 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 ) @@ -201,7 +201,8 @@ checkDefaultBinds clas ops (Just mbs) 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 @@ -423,6 +424,8 @@ tcDefMeth clas tyvars binds_in prags op_item@(_, DefMeth dm_id) = 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] -> @@ -447,7 +450,7 @@ tcDefMeth clas tyvars binds_in prags op_item@(_, DefMeth dm_id) 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 diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index f0c5950..540c92e 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -52,6 +52,7 @@ import DataCon ( classDataCon ) import Class ( Class, DefMeth(..), classBigSig ) import Var ( idName, idType ) import VarSet ( emptyVarSet ) +import Id ( setIdLocalExported ) import MkId ( mkDictFunId ) import FunDeps ( checkInstFDs ) import Generics ( validGenericInstanceType ) @@ -329,7 +330,7 @@ get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = Just def_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 -> @@ -603,6 +604,9 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, -- 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