Major refactoring of the type inference engine

[ghc-hetmet.git] / compiler / main / InteractiveEval.hs

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 696f612..8967c17 100644 (file)
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -546,7 +546,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
        exn_name  = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
        e_fs      = fsLit "e"
        e_name    = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
-       e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
+       e_tyvar   = mkRuntimeUnkTyVar e_name liftedTypeKind
        exn_id    = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
 
        ictxt0 = hsc_IC hsc_env
@@ -572,12 +572,16 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
        occs      = modBreaks_vars breaks ! index
        span      = modBreaks_locs breaks ! index
 
-   -- filter out any unboxed ids; we can't bind these at the prompt
-   let pointers = filter (\(id,_) -> isPointer id) vars
+           -- Filter out any unboxed ids;
+           -- we can't bind these at the prompt
+       pointers = filter (\(id,_) -> isPointer id) vars
        isPointer id | PtrRep <- idPrimRep id = True
                     | otherwise              = False
 
-   let (ids, offsets) = unzip pointers
+       (ids, offsets) = unzip pointers
+
+       free_tvs = foldr (unionVarSet . tyVarsOfType . idType)
+                        (tyVarsOfType result_ty) ids
 
    -- It might be that getIdValFromApStack fails, because the AP_STACK
    -- has been accidentally evaluated, or something else has gone wrong.
@@ -589,15 +593,18 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
       debugTraceMsg (hsc_dflags hsc_env) 1 $
          text "Warning: _result has been evaluated, some bindings have been lost"
 
-   new_ids <- zipWithM mkNewId occs filtered_ids
-   let names = map idName new_ids
+   us <- mkSplitUniqSupply 'I'
+   let (us1, us2) = splitUniqSupply us
+       tv_subst   = newTyVars us1 free_tvs
+       new_ids    = zipWith3 (mkNewId tv_subst) occs filtered_ids (uniqsFromSupply us2)
+       names      = map idName new_ids
 
    -- 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_name = mkInternalName (getUnique result_fs)
                           (mkVarOccFS result_fs) span
-       result_id   = Id.mkVanillaGlobal result_name result_ty 
+       result_id   = Id.mkVanillaGlobal result_name (substTy tv_subst result_ty)
 
    -- for each Id we're about to bind in the local envt:
    --    - tidy the type variables
@@ -619,20 +626,25 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
    return (hsc_env1, if result_ok then result_name:names else names, span)
   where
-   mkNewId :: OccName -> Id -> IO Id
-   mkNewId occ id = do
-     us <- mkSplitUniqSupply 'I'
-        -- we need a fresh Unique for each Id we bind, because the linker
+        -- We need a fresh Unique for each Id we bind, because the linker
         -- state is single-threaded and otherwise we'd spam old bindings
         -- whenever we stop at a breakpoint.  The InteractveContext is properly
         -- saved/restored, but not the linker state.  See #1743, test break026.
-     let 
-         uniq = uniqFromSupply us
-         loc = nameSrcSpan (idName id)
-         name = mkInternalName uniq occ loc
-         ty = idType id
-         new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
-     return new_id
+   mkNewId :: TvSubst -> OccName -> Id -> Unique -> Id
+   mkNewId tv_subst occ id uniq
+     = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
+     where
+         loc    = nameSrcSpan (idName id)
+         name   = mkInternalName uniq occ loc
+         ty     = substTy tv_subst (idType id)
+
+   newTyVars :: UniqSupply -> TcTyVarSet -> TvSubst
+     -- Similarly, clone the type variables mentioned in the types
+     -- we have here, *and* make them all RuntimeUnk tyars
+   newTyVars us tvs
+     = mkTopTvSubst [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
+                    | (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us
+                    , let name = setNameUnique (tyVarName tv) uniq ]
 
 rttiEnvironment :: HscEnv -> IO HscEnv 
 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
@@ -979,5 +991,7 @@ reconstructType hsc_env bound id = do
               hv <- Linker.getHValue hsc_env (varName id) 
               cvReconstructType hsc_env bound (idType id) hv
 
+mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
+mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk
 #endif /* GHCI */