remember the type of _result

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index b09d739..444fe87 100644 (file)
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -298,6 +298,7 @@ schemeER_wrk d p rhs
                         { breakInfo_module = tickInfo_module tickInfo
                         , breakInfo_number = tickNumber 
                         , breakInfo_vars = idOffSets
+                        , breakInfo_resty = exprType (deAnnotate' newRhs)
                         }
         let breakInstr = case arr of (BA arr#) -> BRK_FUN arr# tickNumber breakInfo 
         return $ breakInstr `consOL` code

diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs
index 3f57d18..adb47c8 100644 (file)
--- a/compiler/ghci/ByteCodeInstr.lhs
+++ b/compiler/ghci/ByteCodeInstr.lhs
@@ -13,6 +13,7 @@ module ByteCodeInstr (
 
 import ByteCodeItbls   ( ItblPtr )
 
+import Type
 import Outputable
 import Name
 import Id
@@ -141,13 +142,15 @@ data BreakInfo
    { breakInfo_module :: Module
    , breakInfo_number :: Int
    , breakInfo_vars   :: [(Id,Int)]
+   , breakInfo_resty  :: Type
    }
 
 instance Outputable BreakInfo where
    ppr info = text "BreakInfo" <+>
               parens (ppr (breakInfo_module info) <+>
                       ppr (breakInfo_number info) <+>
-                      ppr (breakInfo_vars info))
+                      ppr (breakInfo_vars info) <+>
+                      ppr (breakInfo_resty info))
 
 -- -----------------------------------------------------------------------------
 -- Printing bytecode instructions

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 3c14bb7..c5e6fa0 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -2207,9 +2207,12 @@ handleRunStatus ref final_ic final_names resume_ic breakMVar statusMVar status =
         hsc_env <- readIORef ref
         mod_info <- getHomeModuleInfo hsc_env (moduleName (breakInfo_module info))
         let breaks = minf_modBreaks (expectJust "handlRunStatus" mod_info)
-        let occs = modBreaks_vars breaks ! breakInfo_number info
-        (new_hsc_env, names) <- extendEnvironment hsc_env apStack 
-                                        (breakInfo_vars info) occs
+        let index  = breakInfo_number info
+            occs   = modBreaks_vars breaks ! index
+            span   = modBreaks_locs breaks ! index
+        (new_hsc_env, names) <- extendEnvironment hsc_env apStack span
+                                        (breakInfo_vars info) 
+                                        (breakInfo_resty info) occs
         writeIORef ref new_hsc_env 
         let res = ResumeHandle breakMVar statusMVar final_names
                                final_ic resume_ic names
@@ -2315,31 +2318,33 @@ getIdValFromApStack apStack (identifier, stackDepth) = do
 extendEnvironment
         :: HscEnv
         -> a            -- the AP_STACK object built by the interpreter
+        -> SrcSpan
         -> [(Id, Int)]  -- free variables and offsets into the AP_STACK
+        -> Type
         -> [OccName]    -- names for the variables (from the source code)
         -> IO (HscEnv, [Name])
-extendEnvironment hsc_env apStack idsOffsets occs = do
+extendEnvironment hsc_env apStack span idsOffsets result_ty occs = do
    idsVals <- mapM (getIdValFromApStack apStack) idsOffsets 
    let (ids, hValues) = unzip idsVals 
    new_ids <- zipWithM mkNewId occs ids
    let names = map idName ids
 
-   let tyvars = varSetElems (tyVarsOfTypes (map idType new_ids))
-       new_tyvars = map mk_skol tyvars
-       new_tyvar_tys = map mkTyVarTy new_tyvars
-       mk_skol tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar) 
-                         (SkolemTv UnkSkol)
-       subst = mkTvSubst emptyInScopeSet (mkVarEnv (zip tyvars new_tyvar_tys))
-       subst_id id = id `setIdType` substTy subst (idType id)
-       subst_ids = map subst_id new_ids
-
-   Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknownTyConName
-   let result_name = mkSystemVarName (mkBuiltinUnique 33) FSLIT("_result")
-       result_id   = Id.mkLocalId result_name (mkTyConApp unknown_tc [])
+   -- make an Id for _result.  We use the Unique of the FastString "_result";
+   -- we don't care about uniqueness here, because there will only be one
+   -- _result in scope at any time.
+   let result_fs = FSLIT("_result")
+       result_name = mkInternalName (getUnique result_fs)
+                          (mkVarOccFS result_fs) (srcSpanStart span)
+       result_id   = Id.mkLocalId result_name result_ty
+
+   let all_ids = result_id : ids
+       (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
+       new_tyvars = unionVarSets tyvarss             
+       new_ids = zipWith setIdType all_ids id_tys
+
    let ictxt = hsc_IC hsc_env
        type_env = ic_type_env ictxt
-       all_new_ids  = result_id : subst_ids
-       bound_names = map idName all_new_ids
+       bound_names = map idName new_ids
        -- Remove any shadowed bindings from the type_env;
        -- they are inaccessible but might, I suppose, cause 
        -- a space leak if we leave them there
@@ -2348,10 +2353,10 @@ extendEnvironment hsc_env apStack idsOffsets occs = do
                          n <- old_bound_names,
                          nameOccName name == nameOccName n ] ;
        filtered_type_env = delListFromNameEnv type_env shadowed
-       new_type_env = extendTypeEnvWithIds filtered_type_env all_new_ids
+       new_type_env = extendTypeEnvWithIds filtered_type_env new_ids
        old_tyvars = ic_tyvars ictxt
        new_ic = ictxt { ic_type_env = new_type_env,
-                        ic_tyvars = extendVarSetList old_tyvars new_tyvars }
+                        ic_tyvars = old_tyvars `unionVarSet` new_tyvars }
    Linker.extendLinkEnv (zip names hValues)
    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
    return (hsc_env{hsc_IC = new_ic}, result_name:names)
@@ -2365,6 +2370,18 @@ extendEnvironment hsc_env apStack idsOffsets occs = do
          new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
      return new_id
 
+skolemiseTy :: Type -> (Type, TyVarSet)
+skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
+  where env           = mkVarEnv (zip tyvars new_tyvar_tys)
+        subst         = mkTvSubst emptyInScopeSet env
+        tyvars        = varSetElems (tyVarsOfType ty)
+        new_tyvars    = map skolemiseTyVar tyvars
+        new_tyvar_tys = map mkTyVarTy new_tyvars
+
+skolemiseTyVar :: TyVar -> TyVar
+skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar) 
+                                 (SkolemTv UnkSkol)
+
 -----------------------------------------------------------------------------
 -- show a module and it's source/object filenames