Fix a missing prime spotted by -fwarn-unused-binds

[ghc-hetmet.git] / compiler / ghci / Linker.lhs

diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index 37fe289..220ac3b 100644 (file)
--- 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) 
@@ -213,17 +217,11 @@ recoverDataCon x = do
 
    getConDescAddress :: Ptr StgInfoTable -> IO (Ptr CChar)
    getConDescAddress ptr = do
-       peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset
 #ifdef GHCI_TABLES_NEXT_TO_CODE
-       where
-       -- subtract a word number of bytes 
-       offset = negate (fromIntegral SIZEOF_VOID_P)
-#endif
-#ifndef GHCI_TABLES_NEXT_TO_CODE
-      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: 
@@ -561,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