[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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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