Automatic RTTI for ghci bindings
authorPepe Iborra <mnislaih@gmail.com>
Sat, 14 Jul 2007 11:49:46 +0000 (11:49 +0000)
committerPepe Iborra <mnislaih@gmail.com>
Sat, 14 Jul 2007 11:49:46 +0000 (11:49 +0000)
With this patch, ghci runs rtti (bounded in the term treewith a max. depth of 10)
automatically after evaluating any expression in the interactive env.
In addition, a rtti step is performed on the local bindings in a breakpoint,
before returning control to the user

Let's see how well this works in practice

compiler/ghci/Debugger.hs
compiler/ghci/RtClosureInspect.hs
compiler/main/HscTypes.lhs
compiler/main/InteractiveEval.hs

index 8491069..20bdbf6 100644 (file)
@@ -28,7 +28,8 @@ import Type
 import TcType
 import TcGadt
 import GHC
-
+import GhciMonad
+import InteractiveEval
 import Outputable
 import Pretty                    ( Mode(..), showDocWith )
 import FastString
@@ -44,7 +45,6 @@ import System.IO
 import GHC.Exts
 
 #include "HsVersions.h"
-
 -------------------------------------
 -- | The :print & friends commands
 -------------------------------------
@@ -56,8 +56,10 @@ pprintClosureCommand session bindThings force str = do
                       (words str)
   substs <- catMaybes `liftM` mapM (go session) 
                                    [id | AnId id <- tythings]
-  mapM (applySubstToEnv session . skolemSubst) substs
-  return ()
+  modifySession session $ \hsc_env -> 
+         hsc_env{hsc_IC = foldr (flip substInteractiveContext) 
+                                (hsc_IC hsc_env) 
+                                (map skolemiseSubst substs)}
  where 
 
    -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
@@ -77,38 +79,11 @@ pprintClosureCommand session bindThings force str = do
      --  Then, we extract a substitution, 
      --  mapping the old tyvars to the reconstructed types.
        let Just reconstructed_type = termType term
-
-     -- tcUnifyTys doesn't look through forall's, so we drop them from 
-     -- the original type, instead of sigma-typing the reconstructed type
-     -- In addition, we strip newtypes too, since the reconstructed type might
-     --   not have recovered them all
-           mb_subst = tcUnifyTys (const BindMe) 
-                                 [repType' $ dropForAlls$ idType id] 
-                                 [repType' $ reconstructed_type]  
+           mb_subst = computeRTTIsubst (idType id) (reconstructed_type)
 
        ASSERT2 (isJust mb_subst, ppr reconstructed_type $$ (ppr$ idType id)) 
         return mb_subst
 
-   applySubstToEnv :: Session -> TvSubst -> IO ()
-   applySubstToEnv cms subst | isEmptyTvSubst subst = return ()
-   applySubstToEnv cms@(Session ref) subst = do
-      hsc_env <- readIORef ref
-      inScope <- GHC.getBindings cms
-      let ictxt    = hsc_IC hsc_env
-          ids      = ic_tmp_ids ictxt
-          ids'     = map (\id -> id `setIdType` substTy subst (idType id)) ids
-          subst_dom= varEnvKeys$ getTvSubstEnv subst
-          subst_ran= varEnvElts$ getTvSubstEnv subst
-          new_tvs  = [ tv | Just tv <- map getTyVar_maybe subst_ran]  
-          ic_tyvars'= (`delVarSetListByKey` subst_dom) 
-                    . (`extendVarSetList`   new_tvs)
-                        $ ic_tyvars ictxt
-          ictxt'   = ictxt { ic_tmp_ids = ids'
-                           , ic_tyvars   = ic_tyvars' }
-      writeIORef ref (hsc_env {hsc_IC = ictxt'})
-
-          where delVarSetListByKey = foldl' delVarSetByKey
-
    tidyTermTyVars :: Session -> Term -> IO Term
    tidyTermTyVars (Session ref) t = do
      hsc_env <- readIORef ref
@@ -133,7 +108,7 @@ bindSuspensions cms@(Session ref) t = do
       availNames_var  <- newIORef availNames
       (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
       let (names, tys, hvals) = unzip3 stuff
-      let tys' = map mk_skol_ty tys
+      let tys' = map (fst.skolemiseTy) tys
       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
                 | (name,ty) <- zip names tys']
           new_tyvars   = tyVarsOfTypes tys'
@@ -214,11 +189,3 @@ newGrimName cms userName  = do
         occname = mkOccName varName userName
         name    = mkInternalName unique occname noSrcSpan
     return name
-
-skolemSubst subst = subst `setTvSubstEnv` 
-                      mapVarEnv mk_skol_ty (getTvSubstEnv subst)
-mk_skol_ty ty | tyvars  <- varSetElems (tyVarsOfType ty)
-              , tyvars' <- map (mkTyVarTy . mk_skol_tv) tyvars
-              = substTyWith tyvars tyvars' ty
-mk_skol_tv tv = mkTcTyVar (tyVarName tv) (tyVarKind tv) 
-                      (SkolemTv RuntimeUnkSkol)
index 3ea2ba9..3ffc8c2 100644 (file)
@@ -26,6 +26,7 @@ module RtClosureInspect(
      termTyVars,
 --     unsafeDeepSeq, 
      cvReconstructType,
+     computeRTTIsubst, 
      sigmaType
  ) where 
 
@@ -582,7 +583,7 @@ cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do
               (ty',rev_subst) <- instScheme (sigmaType ty) 
               addConstraint tv ty'
               search (isMonomorphic `fmap` zonkTcType tv) 
-                     (uncurry go
+                     (\(ty,a) -> go ty a
                      [(tv, hval)]
                      max_depth
               substTy rev_subst `fmap` zonkTcType tv
@@ -591,9 +592,9 @@ cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do
   search stop expand [] depth  = return ()
   search stop expand x 0 = fail$ "Failed to reconstruct a type after " ++
                                 show max_depth ++ " steps"
-  search stop expand (x:xx) d  = do 
+  search stop expand (x:xx) d  = unlessM stop $ do 
     new <- expand x 
-    unlessM stop $ search stop expand (xx ++ new) $! (pred d)
+    search stop expand (xx ++ new) $! (pred d)
 
    -- returns unification tasks,since we are going to want a breadth-first search
   go :: Type -> HValue -> TR [(Type, HValue)]
@@ -602,19 +603,20 @@ cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do
     case tipe clos of
       Indirection _ -> go tv $! (ptrs clos ! 0)
       Constr -> do
-        mb_dcname <- dataConInfoPtrToName (infoPtr clos)
-        case mb_dcname of
-          Left tag -> do 
+        Right dcname <- dataConInfoPtrToName (infoPtr clos)
+        (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
+        case mb_dc of
+          Nothing-> do 
+                     --  TODO: Check this case
             vars     <- replicateM (length$ elems$ ptrs clos) 
                                    (newVar (liftedTypeKind))
             subTerms <- sequence [ appArr (go tv) (ptrs clos) i 
                                    | (i, tv) <- zip [0..] vars]    
             forM [0..length (elems $ ptrs clos)] $ \i -> do
-                        tv <- newVar openTypeKind 
+                        tv <- newVar liftedTypeKind 
                         return$ appArr (\e->(tv,e)) (ptrs clos) i
 
-          Right name -> do 
-            dc <- tcLookupDataCon name
+          Just dc -> do 
             let extra_args = length(dataConRepArgTys dc) - 
                              length(dataConOrigArgTys dc)
             subTtypes <- mapMif (not . isMonomorphic)
@@ -629,6 +631,19 @@ cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do
                        | (i,t) <- drop extra_args $ zip [0..] subTtypes]
       otherwise -> return []
 
+     -- This helper computes the difference between a base type t and the 
+     -- improved rtti_t computed by RTTI
+     -- The main difference between RTTI types and their normal counterparts
+     --  is that the former are _not_ polymorphic, thus polymorphism must
+     --  be stripped. Syntactically, forall's must be stripped
+computeRTTIsubst ty rtti_ty = 
+     -- In addition, we strip newtypes too, since the reconstructed type might
+     --   not have recovered them all
+           tcUnifyTys (const BindMe) 
+                      [repType' $ dropForAlls$ ty]
+                      [repType' $ rtti_ty]  
+-- TODO stripping newtypes shouldn't be necessary, test
+
 
 -- Dealing with newtypes
 {-
index f36b205..bb7acef 100644 (file)
@@ -29,6 +29,7 @@ module HscTypes (
 
        InteractiveContext(..), emptyInteractiveContext, 
        icPrintUnqual, mkPrintUnqualified, extendInteractiveContext,
+        substInteractiveContext,
 
        ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache,
        emptyIfaceDepCache,
@@ -92,9 +93,9 @@ import Rules          ( RuleBase )
 import CoreSyn         ( CoreBind )
 import VarEnv
 import VarSet
-import Var
+import Var       hiding ( setIdType )
 import Id
-import Type            ( TyThing(..) )
+import Type            
 
 import Class           ( Class, classSelIds, classATs, classTyCon )
 import TyCon
@@ -120,6 +121,7 @@ import StringBuffer ( StringBuffer )
 import System.Time     ( ClockTime )
 import Data.IORef
 import Data.Array       ( Array, array )
+import Data.List
 \end{code}
 
 
@@ -691,6 +693,22 @@ extendInteractiveContext ictxt ids tyvars
                           -- NB. must be this way around, because we want
                           -- new ids to shadow existing bindings.
             ic_tyvars   = ic_tyvars ictxt `unionVarSet` tyvars }
+
+
+substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext
+substInteractiveContext ictxt subst | isEmptyTvSubst subst = ictxt
+substInteractiveContext ictxt@InteractiveContext{ic_tmp_ids=ids} subst =
+   let ids'     = map (\id -> id `setIdType` substTy subst (idType id)) ids
+       subst_dom= varEnvKeys$ getTvSubstEnv subst
+       subst_ran= varEnvElts$ getTvSubstEnv subst
+       new_tvs  = [ tv | Just tv <- map getTyVar_maybe subst_ran]  
+       ic_tyvars'= (`delVarSetListByKey` subst_dom) 
+                 . (`extendVarSetList`   new_tvs)
+                   $ ic_tyvars ictxt
+    in ictxt { ic_tmp_ids = ids'
+             , ic_tyvars   = ic_tyvars' }
+
+          where delVarSetListByKey = foldl' delVarSetByKey
 \end{code}
 
 %************************************************************************
index f1e6079..3de25ce 100644 (file)
@@ -28,7 +28,8 @@ module InteractiveEval (
         isModuleInterpreted,
        compileExpr, dynCompileExpr,
        lookupName,
-        obtainTerm, obtainTerm1
+        obtainTerm, obtainTerm1, reconstructType,
+        skolemiseSubst, skolemiseTy
 #endif
         ) where
 
@@ -163,7 +164,7 @@ runStmt (Session ref) expr step
 
               let thing_to_run = unsafeCoerce# hval :: IO [HValue]
               status <- sandboxIO statusMVar thing_to_run
-
+              
               let ic = hsc_IC hsc_env
                   bindings = (ic_tmp_ids ic, ic_tyvars ic)
 
@@ -205,8 +206,9 @@ handleRunStatus expr ref bindings final_ids breakMVar statusMVar status
                                         final_ids emptyVarSet
                         -- the bound Ids never have any free TyVars
                     final_names = map idName final_ids
-                writeIORef ref hsc_env{hsc_IC=final_ic}
                 Linker.extendLinkEnv (zip final_names hvals)
+                hsc_env' <- rttiEnvironment hsc_env{hsc_IC=final_ic}
+                writeIORef ref hsc_env' 
                 return (RunOk final_names)
 
 
@@ -420,7 +422,8 @@ moveHist fn (Session ref) = do
 
 -- -----------------------------------------------------------------------------
 -- After stopping at a breakpoint, add free variables to the environment
-
+result_fs = FSLIT("_result")
+       
 bindLocalsAtBreakpoint
         :: HscEnv
         -> HValue
@@ -475,7 +478,8 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
    -- So that we don't fall over in a heap when this happens, just don't
    -- bind any free variables instead, and we emit a warning.
    mb_hValues <- mapM (getIdValFromApStack apStack) offsets
-   let filtered_ids = [ id | (id, Just _) <- zip ids mb_hValues ]
+   let (filtered_hvs, filtered_ids) = 
+                       unzip [ (hv, id) | (id, Just hv) <- zip ids mb_hValues ]
    when (any isNothing mb_hValues) $
       debugTraceMsg (hsc_dflags hsc_env) 1 $
          text "Warning: _result has been evaluated, some bindings have been lost"
@@ -486,8 +490,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
    -- 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)
+   let result_name = mkInternalName (getUnique result_fs)
                           (mkVarOccFS result_fs) span
        result_id   = Id.mkGlobalId VanillaGlobal result_name result_ty 
                                    vanillaIdInfo
@@ -504,14 +507,13 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
        (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
        new_tyvars = unionVarSets tyvarss             
-       final_ids = zipWith setIdType all_ids tidy_tys
-
-   let   ictxt0 = hsc_IC hsc_env
-         ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
-
+   let final_ids = zipWith setIdType all_ids tidy_tys
+       ictxt0 = hsc_IC hsc_env
+       ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
    Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
-   return (hsc_env{ hsc_IC = ictxt1 }, result_name:names, span)
+   hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
+   return (hsc_env1, result_name:names, span)
   where
    mkNewId :: OccName -> Id -> IO Id
    mkNewId occ id = do
@@ -522,6 +524,26 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
          new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
      return new_id
 
+rttiEnvironment :: HscEnv -> IO HscEnv 
+rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
+   let InteractiveContext{ic_tmp_ids=tmp_ids, ic_tyvars = tyvars} = ic
+       incompletelyTypedIds = 
+           [id | id <- tmp_ids
+               , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id)
+                              , isSkolemTyVar v]
+               , (occNameFS.nameOccName.idName) id /= result_fs]
+   tys <- reconstructType hsc_env False `mapM` incompletelyTypedIds
+          -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
+   
+   let substs = [computeRTTIsubst ty ty' 
+                 | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
+       ic'    = foldr (flip substInteractiveContext) ic 
+                           (map skolemiseSubst $ catMaybes substs)
+   return hsc_env{hsc_IC=ic'}
+
+skolemiseSubst subst = subst `setTvSubstEnv` 
+                        mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst)
+
 skolemiseTy :: Type -> (Type, TyVarSet)
 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
   where env           = mkVarEnv (zip tyvars new_tyvar_tys)
@@ -819,12 +841,21 @@ isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
                      where
                         obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 
+----------------------------------------------------------------------------
+-- RTTI primitives
+
 obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term
-obtainTerm1 hsc_env force mb_ty x = cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
+obtainTerm1 hsc_env force mb_ty x = 
+              cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
 
 obtainTerm :: HscEnv -> Bool -> Id -> IO Term
 obtainTerm hsc_env force id =  do
               hv <- Linker.getHValue hsc_env (varName id) 
               cvObtainTerm hsc_env force (Just$ idType id) hv
 
+-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
+reconstructType :: HscEnv -> Bool -> Id -> IO (Maybe Type)
+reconstructType hsc_env force id = do
+              hv <- Linker.getHValue hsc_env (varName id) 
+              cvReconstructType hsc_env force (Just$ idType id) hv
 #endif /* GHCI */