From: simonmar Date: Mon, 19 Mar 2001 16:22:01 +0000 (+0000) Subject: [project @ 2001-03-19 16:22:00 by simonmar] X-Git-Tag: Approximately_9120_patches~2375 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=dd4bc7edc9c6bdb3fd295eb5bad3df4772aa58e2;p=ghc-hetmet.git [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 --- 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 --- 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 --- 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 --- 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 --- 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]