Commit 2c92736e authored by mnislaih's avatar mnislaih
Browse files

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
parent ab5b8aa3
......@@ -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
......
This diff is collapsed.
......@@ -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 */
......@@ -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!
......
>module TcRnDriver where
>import HscTypes
>import DataCon
>
>tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon)
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment