X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=220ac3b6acbbd37416cbd56845c908595e1f0e00;hb=feee9bb8151fd592df9ad4d10fc2e418b26f3e2c;hp=2c1b668e6556d965cc9901dafdce22bc609fe63b;hpb=317fc69d18eda68fd65f5ba634feafbe4a3923da;p=ghc-hetmet.git

diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index 2c1b668..220ac3b 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
@@ -142,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:
@@ -151,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) 
@@ -207,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: 
@@ -556,7 +559,7 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
         | mi_boot iface
         = link_boot_mod_error mod
 	| otherwise
-        = follow_deps (map (mkModule this_pkg) boot_deps ++ mods) acc_mods' acc_pkgs'
+        = follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) acc_mods' acc_pkgs'
       where
         pkg   = modulePackageId mod
         iface = get_iface mod