X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=7b40c32f5e8551c05cfcb15bef9375ed6644db49;hb=ea539f1b58462de1e4813f35e5d66dc15a5e0e88;hp=4508e4b2dcd311eb4ed3e3921017f757642f4b73;hpb=b648333f6b4c78f7ac1528cd9f780221a058591e;p=ghc-hetmet.git

diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index 4508e4b..7b40c32 100644
--- a/compiler/ghci/Linker.lhs
+++ b/compiler/ghci/Linker.lhs
@@ -15,10 +15,11 @@ necessary.
 {-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-}
 
 module Linker ( HValue, getHValue, showLinkerState,
-		linkExpr, unload, extendLinkEnv, withExtendedLinkEnv,
-                extendLoadedPkgs,
+		linkExpr, unload, withExtendedLinkEnv,
+                extendLinkEnv, deleteFromLinkEnv,
+                extendLoadedPkgs, 
 		linkPackages,initDynLinker,
-                recoverDataCon
+                dataConInfoPtrToName
 	) where
 
 #include "HsVersions.h"
@@ -27,9 +28,9 @@ import ObjLink
 import ByteCodeLink
 import ByteCodeItbls
 import ByteCodeAsm
-import RtClosureInspect
+import CgInfoTbls
+import SMRep
 import IfaceEnv
-import OccName
 import TcRnMonad
 import Packages
 import DriverPhases
@@ -38,6 +39,7 @@ import HscTypes
 import Name
 import NameEnv
 import NameSet
+import qualified OccName
 import UniqFM
 import Module
 import ListSetOps
@@ -52,6 +54,7 @@ import ErrUtils
 import DriverPhases
 import SrcLoc
 import UniqSet
+import Constants
 
 -- Standard libraries
 import Control.Monad
@@ -68,13 +71,6 @@ import System.Directory
 
 import Control.Exception
 import Data.Maybe
-
-#if __GLASGOW_HASKELL__ >= 503
-import GHC.IOBase	( IO(..) )
-#else
-import PrelIOBase	( IO(..) )
-#endif
-
 \end{code}
 
 
@@ -149,6 +145,13 @@ extendLinkEnv new_bindings
 	    new_pls = pls { closure_env = new_closure_env }
 	writeIORef v_PersistentLinkerState new_pls
 
+deleteFromLinkEnv :: [Name] -> IO ()
+deleteFromLinkEnv to_remove
+  = do	pls <- readIORef v_PersistentLinkerState
+	let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
+	    new_pls = pls { closure_env = new_closure_env }
+	writeIORef v_PersistentLinkerState new_pls
+
 -- | Given a data constructor, find its internal name.
 --   The info tables for data constructors have a field which records the source name
 --   of the constructor as a CString. The format is:
@@ -158,12 +161,13 @@ extendLinkEnv new_bindings
 --   We use this string to lookup the interpreter's internal representation of the name
 --   using the lookupOrig.    
 
-recoverDataCon :: a -> TcM Name
-recoverDataCon x = do 
+dataConInfoPtrToName :: Ptr () -> TcM Name
+dataConInfoPtrToName x = do 
    theString <- ioToTcRn $ do
-      let ptr = getInfoTablePtr x 
+      let ptr = castPtr x :: Ptr StgInfoTable
       conDescAddress <- getConDescAddress ptr 
-      peekCString conDescAddress  
+      str <- peekCString conDescAddress  
+      return str
    let (pkg, mod, occ) = parse theString 
        occName = mkOccName OccName.dataName occ
        modName = mkModule (stringToPackageId pkg) (mkModuleName mod) 
@@ -214,18 +218,10 @@ recoverDataCon x = do
    getConDescAddress :: Ptr StgInfoTable -> IO (Ptr CChar)
    getConDescAddress ptr = do
 #ifdef GHCI_TABLES_NEXT_TO_CODE
-       offsetToString <- peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset
-       return $ ptr `plusPtr` offsetToString
-       where
-       -- subtract a word number of bytes 
-       offset = negate (fromIntegral SIZEOF_VOID_P)
-#endif
-#ifndef GHCI_TABLES_NEXT_TO_CODE
-        peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset
-      where 
-      -- add the standard info table size in bytes 
-      infoTableSizeBytes = sTD_ITBL_SIZE * wORD_SIZE
-      offset = infoTableSizeBytes 
+       offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
+       return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
+#else
+       peek $ intPtrToPtr $ (ptrToIntPtr ptr) + stdInfoTableSizeB
 #endif
 
    -- parsing names is a little bit fiddly because we have a string in the form: