[project @ 2001-03-19 16:22:00 by simonmar]

Fix a problem with the 'it' variable in GHCi.  New bindings for 'it'
were getting confused with old bindings, because we always used the
same 'it' name.

Now, we generate a new unique for 'it' each time around.

Also, make sure that any existing variables shadowed by new
command-line bindings are correctly removed from the environments to
avoid space leaks.

diff --git a/ghc/compiler/basicTypes/NameEnv.lhs b/ghc/compiler/basicTypes/NameEnv.lhs
index 6872042..06cf190 100644 (file)
--- a/ghc/compiler/basicTypes/NameEnv.lhs
+++ b/ghc/compiler/basicTypes/NameEnv.lhs
@@ -9,7 +9,8 @@ module NameEnv (
        emptyNameEnv, unitNameEnv, nameEnvElts, 
        extendNameEnv_C, extendNameEnv, foldNameEnv, filterNameEnv,
        plusNameEnv, plusNameEnv_C, extendNameEnv, extendNameEnvList,
-       lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, elemNameEnv
+       lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,
+       elemNameEnv
     ) where
 
 #include "HsVersions.h"
@@ -37,6 +38,7 @@ plusNameEnv            :: NameEnv a -> NameEnv a -> NameEnv a
 plusNameEnv_C           :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a
 extendNameEnvList:: NameEnv a -> [(Name,a)] -> NameEnv a
 delFromNameEnv          :: NameEnv a -> Name -> NameEnv a
+delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a
 elemNameEnv             :: Name -> NameEnv a -> Bool
 unitNameEnv             :: Name -> a -> NameEnv a
 lookupNameEnv           :: NameEnv a -> Name -> Maybe a
@@ -55,6 +57,7 @@ plusNameEnv            = plusUFM
 plusNameEnv_C           = plusUFM_C
 extendNameEnvList= addListToUFM
 delFromNameEnv          = delFromUFM
+delListFromNameEnv = delListFromUFM
 elemNameEnv             = elemUFM
 mapNameEnv      = mapUFM
 unitNameEnv             = unitUFM

diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs
index 58d4580..a059ea7 100644 (file)
--- a/ghc/compiler/compMan/CmLink.lhs
+++ b/ghc/compiler/compMan/CmLink.lhs
@@ -12,7 +12,8 @@ module CmLink ( Linkable(..),  Unlinked(..),
                unload,
                 PersistentLinkerState{-abstractly!-}, emptyPLS,
 #ifdef GHCI
-               updateClosureEnv,
+               delListFromClosureEnv,
+               addListToClosureEnv,
                linkExpr
 #endif
   ) where
@@ -95,9 +96,14 @@ emptyPLS = return (PersistentLinkerState {})
 #endif
 
 #ifdef GHCI
-updateClosureEnv :: PersistentLinkerState -> [(Name,HValue)] 
+delListFromClosureEnv :: PersistentLinkerState -> [Name]
+       -> IO PersistentLinkerState
+delListFromClosureEnv pls names
+  = return pls{ closure_env = delListFromFM (closure_env pls) names }
+
+addListToClosureEnv :: PersistentLinkerState -> [(Name,HValue)] 
        -> IO PersistentLinkerState
-updateClosureEnv pls new_bindings
+addListToClosureEnv pls new_bindings
   = return pls{ closure_env = addListToFM (closure_env pls) new_bindings }
 #endif
 

diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index c6902be..e38b206 100644 (file)
--- a/ghc/compiler/compMan/CompManager.lhs
+++ b/ghc/compiler/compMan/CompManager.lhs
@@ -37,9 +37,9 @@ import CmTypes
 import HscTypes
 import RnEnv           ( unQualInScope )
 import Id              ( idType, idName )
-import Name            ( Name, NamedThing(..) )
+import Name            ( Name, NamedThing(..), nameRdrName )
 import NameEnv
-import RdrName         ( emptyRdrEnv )
+import RdrName         ( lookupRdrEnv, emptyRdrEnv )
 import Module          ( Module, ModuleName, moduleName, isHomeModule,
                          mkModuleName, moduleNameUserString, moduleUserString )
 import CmStaticInfo    ( GhciMode(..) )
@@ -194,12 +194,18 @@ cmRunStmt cmstate dflags expr
 
                -- update the interactive context
                let 
-                   new_rn_env   = extendLocalRdrEnv rn_env (map idName ids)
+                   names = map idName ids
 
-                       -- Extend the renamer-env from bound_ids, not
-                       -- bound_names, because the latter may contain
-                       -- [it] when the former is empty
-                   new_type_env = extendNameEnvList type_env   
+                   -- these names have just been shadowed
+                   shadowed = [ n | r <- map nameRdrName names,
+                                    Just n <- [lookupRdrEnv rn_env r] ]
+                   
+                   new_rn_env   = extendLocalRdrEnv rn_env names
+
+                   -- remove any shadowed bindings from the type_env
+                   filtered_type_env = delListFromNameEnv type_env shadowed
+
+                   new_type_env = extendNameEnvList filtered_type_env  
                                        [ (getName id, AnId id) | id <- ids]
 
                    new_ic = icontext { ic_rn_env   = new_rn_env, 
@@ -212,9 +218,11 @@ cmRunStmt cmstate dflags expr
                let thing_to_run = unsafeCoerce# hval :: IO [HValue]
                hvals <- thing_to_run
 
-               -- get the newly bound things, and bind them
-               let names = map idName ids
-               new_pls <- updateClosureEnv pls (zip names hvals)
+               -- Get the newly bound things, and bind them.  Don't forget
+               -- to delete any shadowed bindings from the closure_env, lest
+               -- we end up with a space leak.
+               pls <- delListFromClosureEnv pls shadowed
+               new_pls <- addListToClosureEnv pls (zip names hvals)
 
                return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names)
    where

diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs
index 477872c..ba20d43 100644 (file)
--- a/ghc/compiler/prelude/PrelNames.lhs
+++ b/ghc/compiler/prelude/PrelNames.lhs
@@ -67,7 +67,7 @@ import Panic    ( panic )
 This *local* name is used by the interactive stuff
 
 \begin{code}
-itName = mkLocalName itIdKey (mkOccFS varName SLIT("it")) noSrcLoc
+itName uniq = mkLocalName uniq (mkOccFS varName SLIT("it")) noSrcLoc
 \end{code}
 
 \begin{code}
@@ -864,7 +864,6 @@ mapIdKey                  = mkPreludeMiscIdUnique 120
 \begin{code}
 assertIdKey                  = mkPreludeMiscIdUnique 121
 runSTRepIdKey                = mkPreludeMiscIdUnique 122
-itIdKey                              = mkPreludeMiscIdUnique 123       -- "it" for the interactive interface
 \end{code}
 
 

diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index f6c9f64..4cb7f60 100644 (file)
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -159,13 +159,18 @@ tcUserStmt :: [Name] -> RenamedStmt -> TcM (TypecheckedHsExpr, [Id])
 
 tcUserStmt names (ExprStmt expr loc)
   = ASSERT( null names )
+    tcGetUnique                `thenNF_Tc` \ uniq ->
+    let 
+       fresh_it = itName uniq
+        the_bind = FunMonoBind fresh_it False 
+                       [ mkSimpleMatch [] expr Nothing loc ] loc
+    in
     tryTc_ (traceTc (text "tcs 1b") `thenNF_Tc_`
-               tc_stmts [itName] [LetStmt (MonoBind the_bind [] NonRecursive),
-                              ExprStmt (HsApp (HsVar printName) (HsVar itName)) loc])
+               tc_stmts [fresh_it] [
+                   LetStmt (MonoBind the_bind [] NonRecursive),
+                   ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) loc])
           (    traceTc (text "tcs 1a") `thenNF_Tc_`
-               tc_stmts [itName] [BindStmt (VarPatIn itName) expr loc])
-  where
-    the_bind = FunMonoBind itName False [mkSimpleMatch [] expr Nothing loc] loc
+               tc_stmts [fresh_it] [BindStmt (VarPatIn fresh_it) expr loc])
 
 tcUserStmt names stmt
   = tc_stmts names [stmt]