Playing with closures

RtClosureInspect includes a bunch of stuff for playing with closures:

- the datatype Closure is the low level representation type
- the datatype Term is the high level representation type
- cvObtainTerm is the main entry point, providing the Term representation of an arbitrary closure

compiler/ghci/Linker.lhs

@@ -14,11 +14,11 @@ necessary.
 \begin{code}
 {-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-}
 
-module Linker ( HValue, showLinkerState,
+module Linker ( HValue, getHValue, showLinkerState,
 		linkExpr, unload, extendLinkEnv, withExtendedLinkEnv,
                 extendLoadedPkgs,
-		linkPackages,initDynLinker
-               ,recoverDataCon
+		linkPackages,initDynLinker,
+                recoverDataCon
 	) where
 
 #include "HsVersions.h"
@@ -195,12 +195,14 @@ recoverDCInRTS a = do
                  helper [] = Nothing
                  helper x  = Just . second (drop 1) . break (==delim) $ x
               in unfoldr helper
-
-removeLeadingUnderscore = if cLeadingUnderscore=="YES" 
+          removeLeadingUnderscore = if cLeadingUnderscore=="YES" 
                                        then tail 
                                        else id
 
-
+getHValue :: Name -> IO (Maybe HValue)
+getHValue name = do
+    pls <- readIORef v_PersistentLinkerState
+    return$ fmap snd (lookupNameEnv (closure_env pls) name)
 
 withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
 withExtendedLinkEnv new_env action

compiler/main/GHC.hs

@@ -81,6 +81,8 @@ module GHC (
 	showModule,
 	compileExpr, HValue, dynCompileExpr,
 	lookupName,
+
+        obtainTerm,  
 #endif
 
 	-- * Abstract syntax elements
@@ -174,9 +176,6 @@ module GHC (
 #include "HsVersions.h"
 
 #ifdef GHCI
-import qualified Linker
-import Data.Dynamic     ( Dynamic )
-import Linker		( HValue, extendLinkEnv )
 import TcRnDriver	( tcRnLookupRdrName, tcRnGetInfo,
 			  tcRnLookupName, getModuleExports )
 import RdrName		( plusGlobalRdrEnv, Provenance(..), 
@@ -186,7 +185,25 @@ import HscMain		( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
 import Name		( nameOccName )
 import Type		( tidyType )
 import VarEnv		( emptyTidyEnv )
-import GHC.Exts		( unsafeCoerce# )
+import GHC.Exts         ( unsafeCoerce# )
+
+-- For breakpoints
+import Breakpoints      ( SiteNumber, Coord, nullBkptHandler, 
+                          BkptHandler(..), BkptLocation, noDbgSites )
+import Linker           ( initDynLinker )
+import PrelNames        ( breakpointJumpName, breakpointCondJumpName, 
+                          breakpointAutoJumpName )
+
+import GHC.Exts         ( Int(..), Ptr(..), int2Addr#, indexArray# )
+import GHC.Base         ( Opaque(..) )
+import Foreign.StablePtr( deRefStablePtr, castPtrToStablePtr )
+import Foreign          ( unsafePerformIO )
+import Data.Maybe       ( fromMaybe)
+import qualified Linker
+
+import Data.Dynamic     ( Dynamic )
+import RtClosureInspect ( cvObtainTerm, Term )
+import Linker		( HValue, getHValue, extendLinkEnv )
 #endif
 
 import Packages		( initPackages )
@@ -204,7 +221,7 @@ import Id		( Id, idType, isImplicitId, isDeadBinder,
                           isPrimOpId, isFCallId, isClassOpId_maybe,
                           isDataConWorkId, idDataCon,
                           isBottomingId )
-import Var		( TyVar )
+import Var		( TyVar, varName )
 import TysPrim		( alphaTyVars )
 import TyCon		( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
 			  isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity,
@@ -259,6 +276,7 @@ import System.Exit	( exitWith, ExitCode(..) )
 import System.Time	( ClockTime )
 import Control.Exception as Exception hiding (handle)
 import Data.IORef
+import Data.Traversable ( traverse )
 import System.IO
 import System.IO.Error	( isDoesNotExistError )
 import Prelude hiding (init)
@@ -2176,4 +2194,8 @@ showModule s mod_summary = withSession s $ \hsc_env -> do
 		      where
 			 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 
+obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term)
+obtainTerm sess force id = withSession sess $ \hsc_env -> 
+              getHValue (varName id) >>= traverse (cvObtainTerm hsc_env force Nothing)
+
 #endif /* GHCI */

compiler/typecheck/TcRnDriver.lhs

@@ -12,6 +12,7 @@ module TcRnDriver (
 	tcRnLookupName,
 	tcRnGetInfo,
 	getModuleExports, 
+        tcRnRecoverDataCon,
 #endif
 	tcRnModule, 
 	tcTopSrcDecls,
@@ -71,6 +72,8 @@ import HscTypes
 import Outputable
 
 #ifdef GHCI
+import Linker
+import DataCon
 import TcHsType
 import TcMType
 import TcMatches
@@ -306,7 +309,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 				mg_fix_env   = emptyFixityEnv,
 				mg_deprecs   = NoDeprecs,
 				mg_foreign   = NoStubs,
-				mg_hpc_info = noHpcInfo
+				mg_hpc_info  = noHpcInfo
 		    } } ;
 
    tcCoreDump mod_guts ;
@@ -1136,6 +1139,12 @@ lookup_rdr_name rdr_name = do {
     return good_names
  }
 
+tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon) 
+tcRnRecoverDataCon hsc_env a
+  = initTcPrintErrors hsc_env iNTERACTIVE $ 
+    setInteractiveContext hsc_env (hsc_IC hsc_env) $
+     do name    <- recoverDataCon a
+        tcLookupDataCon name
 
 tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
 tcRnLookupName hsc_env name
@@ -1171,7 +1180,6 @@ tcRnGetInfo hsc_env name
     ispecs <- lookupInsts (icPrintUnqual ictxt) thing
     return (thing, fixity, ispecs)
 
-
 lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance]
 -- Filter the instances by the ones whose tycons (or clases resp) 
 -- are in scope unqualified.  Otherwise we list a whole lot too many!

compiler/typecheck/TcRnDriver.lhs-boot

+>module TcRnDriver where
+>import HscTypes
+>import DataCon
+>
+>tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon) 
\ No newline at end of file