Export 'insertSymbol' and 'insertStableSymbol'.

'insertStableSymbol' is used for exporting closures that are affected by the GC.

diff --git a/compiler/ghci/ObjLink.lhs b/compiler/ghci/ObjLink.lhs
index 057938a..5988165 100644 (file)
--- a/compiler/ghci/ObjLink.lhs
+++ b/compiler/ghci/ObjLink.lhs
@@ -16,6 +16,8 @@ module ObjLink (
    loadDLL,             -- :: String -> IO (Maybe String)
    loadObj,             -- :: String -> IO ()
    unloadObj,           -- :: String -> IO ()
    loadDLL,             -- :: String -> IO (Maybe String)
    loadObj,             -- :: String -> IO ()
    unloadObj,           -- :: String -> IO ()

+   insertSymbol,         -- :: String -> String -> Ptr a -> IO ()
+   insertStableSymbol,   -- :: String -> String -> a -> IO ()

    lookupSymbol,        -- :: String -> IO (Maybe (Ptr a))
    resolveObjs          -- :: IO SuccessFlag
   )  where
    lookupSymbol,        -- :: String -> IO (Maybe (Ptr a))
    resolveObjs          -- :: IO SuccessFlag
   )  where

@@ -23,16 +25,32 @@ module ObjLink (
 import Monad            ( when )
 
 import Foreign.C
 import Monad            ( when )
 
 import Foreign.C

-import Foreign         ( Ptr, nullPtr )
+import Foreign         ( nullPtr )

 import Panic           ( panic )
 import BasicTypes      ( SuccessFlag, successIf )
 import Config          ( cLeadingUnderscore )
 import Outputable
 
 import Panic           ( panic )
 import BasicTypes      ( SuccessFlag, successIf )
 import Config          ( cLeadingUnderscore )
 import Outputable
 

+import GHC.Exts         ( Ptr(..), unsafeCoerce# )
+

 -- ---------------------------------------------------------------------------
 -- RTS Linker Interface
 -- ---------------------------------------------------------------------------
 
 -- ---------------------------------------------------------------------------
 -- RTS Linker Interface
 -- ---------------------------------------------------------------------------
 

+insertSymbol :: String -> String -> Ptr a -> IO ()
+insertSymbol obj_name key symbol
+    = let str = prefixUnderscore key
+      in withCString obj_name $ \c_obj_name ->
+         withCString str $ \c_str ->
+          c_insertSymbol c_obj_name c_str symbol
+
+insertStableSymbol :: String -> String -> a -> IO ()
+insertStableSymbol obj_name key symbol
+    = let str = prefixUnderscore key
+      in withCString obj_name $ \c_obj_name ->
+         withCString str $ \c_str ->
+          c_insertStableSymbol c_obj_name c_str (Ptr (unsafeCoerce# symbol))
+

 lookupSymbol :: String -> IO (Maybe (Ptr a))
 lookupSymbol str_in = do
    let str = prefixUnderscore str_in
 lookupSymbol :: String -> IO (Maybe (Ptr a))
 lookupSymbol str_in = do
    let str = prefixUnderscore str_in

@@ -81,6 +99,9 @@ resolveObjs = do
 #if __GLASGOW_HASKELL__ >= 504
 foreign import ccall unsafe "addDLL"      c_addDLL :: CString -> IO CString
 foreign import ccall unsafe "initLinker"   initObjLinker :: IO ()
 #if __GLASGOW_HASKELL__ >= 504
 foreign import ccall unsafe "addDLL"      c_addDLL :: CString -> IO CString
 foreign import ccall unsafe "initLinker"   initObjLinker :: IO ()

+foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CString -> CString -> Ptr a -> IO ()
+foreign import ccall unsafe "insertStableSymbol" c_insertStableSymbol
+    :: CString -> CString -> Ptr a -> IO ()

 foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a)
 foreign import ccall unsafe "loadObj"      c_loadObj :: CString -> IO Int
 foreign import ccall unsafe "unloadObj"    c_unloadObj :: CString -> IO Int
 foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a)
 foreign import ccall unsafe "loadObj"      c_loadObj :: CString -> IO Int
 foreign import ccall unsafe "unloadObj"    c_unloadObj :: CString -> IO Int

@@ -88,6 +109,9 @@ foreign import ccall unsafe "resolveObjs"  c_resolveObjs :: IO Int
 #else
 foreign import "addDLL"       unsafe   c_addDLL :: CString -> IO CString
 foreign import "initLinker"   unsafe   initLinker :: IO ()
 #else
 foreign import "addDLL"       unsafe   c_addDLL :: CString -> IO CString
 foreign import "initLinker"   unsafe   initLinker :: IO ()

+foreign import "insertSymbol" unsafe   c_insertSymbol :: CString -> CString -> Ptr a -> IO ()
+foreign import "insertStableSymbol" unsafe c_insertStableSymbol
+    :: CString -> CString -> Ptr a -> IO ()

 foreign import "lookupSymbol" unsafe   c_lookupSymbol :: CString -> IO (Ptr a)
 foreign import "loadObj"      unsafe   c_loadObj :: CString -> IO Int
 foreign import "unloadObj"    unsafe   c_unloadObj :: CString -> IO Int
 foreign import "lookupSymbol" unsafe   c_lookupSymbol :: CString -> IO (Ptr a)
 foreign import "loadObj"      unsafe   c_loadObj :: CString -> IO Int
 foreign import "unloadObj"    unsafe   c_unloadObj :: CString -> IO Int

diff --git a/includes/Linker.h b/includes/Linker.h
index bb1a4c2..948745b 100644 (file)
--- a/includes/Linker.h
+++ b/includes/Linker.h
@@ -12,6 +12,12 @@
 /* initialize the object linker */
 void initLinker( void );
 
 /* initialize the object linker */
 void initLinker( void );
 

+/* insert a stable symbol in the hash table */
+void insertStableSymbol(char* obj_name, char* key, StgPtr data);
+
+/* insert a symbol in the hash table */
+void insertSymbol(char* obj_name, char* key, void* data);
+

 /* lookup a symbol in the hash table */
 void *lookupSymbol( char *lbl );
 
 /* lookup a symbol in the hash table */
 void *lookupSymbol( char *lbl );
 

@@ -27,4 +33,7 @@ HsInt resolveObjs( void );
 /* load a dynamic library */
 char *addDLL( char* dll_name );
 
 /* load a dynamic library */
 char *addDLL( char* dll_name );
 

+extern void markRootPtrTable(evac_fn evac);
+
+

 #endif /* LINKER_H */
 #endif /* LINKER_H */

diff --git a/rts/GC.c b/rts/GC.c
index d71eaee..b75c549 100644 (file)
--- a/rts/GC.c
+++ b/rts/GC.c
@@ -666,6 +666,10 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc )
    */
   markStablePtrTable(mark_root);
 
    */
   markStablePtrTable(mark_root);
 

+  /* Mark the root pointer table.
+   */
+  markRootPtrTable(mark_root);
+

   /* -------------------------------------------------------------------------
    * Repeatedly scavenge all the areas we know about until there's no
    * more scavenging to be done.
   /* -------------------------------------------------------------------------
    * Repeatedly scavenge all the areas we know about until there's no
    * more scavenging to be done.

diff --git a/rts/Linker.c b/rts/Linker.c
index 92d0106..0db2c5e 100644 (file)
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -92,6 +92,17 @@
 /* Hash table mapping symbol names to Symbol */
 static /*Str*/HashTable *symhash;
 
 /* Hash table mapping symbol names to Symbol */
 static /*Str*/HashTable *symhash;
 

+typedef struct {
+  void *addr;
+} rootEntry;
+
+/* Hash table mapping symbol names to StgStablePtr */
+static /*Str*/HashTable *stablehash;
+rootEntry *root_ptr_table = NULL;
+static rootEntry *root_ptr_free = NULL;
+
+static unsigned int RPT_size = 0;
+

 /* List of currently loaded objects */
 ObjectCode *objects = NULL;    /* initially empty */
 
 /* List of currently loaded objects */
 ObjectCode *objects = NULL;    /* initially empty */
 

@@ -526,6 +537,8 @@ typedef struct _RtsSymbolVal {
       SymX(isFloatNegativeZero)                        \
       SymX(killThreadzh_fast)                  \
       SymX(loadObj)                            \
       SymX(isFloatNegativeZero)                        \
       SymX(killThreadzh_fast)                  \
       SymX(loadObj)                            \

+      SymX(insertStableSymbol)                         \
+      SymX(insertSymbol)                       \

       SymX(lookupSymbol)                       \
       SymX(makeStablePtrzh_fast)               \
       SymX(minusIntegerzh_fast)                        \
       SymX(lookupSymbol)                       \
       SymX(makeStablePtrzh_fast)               \
       SymX(minusIntegerzh_fast)                        \

@@ -790,6 +803,95 @@ static RtsSymbolVal rtsSyms[] = {
       { 0, 0 } /* sentinel */
 };
 
       { 0, 0 } /* sentinel */
 };
 

+
+/* -----------------------------------------------------------------------------
+ * Utilities for handling root pointers.
+ * -------------------------------------------------------------------------- */
+
+
+#define INIT_RPT_SIZE 64
+
+STATIC_INLINE void
+initFreeList(rootEntry *table, nat n, rootEntry *free)
+{
+  rootEntry *p;
+
+  for (p = table + n - 1; p >= table; p--) {
+    p->addr   = (P_)free;
+    free = p;
+  }
+  root_ptr_free = table;
+}
+
+void
+initRootPtrTable(void)
+{
+  if (RPT_size > 0)
+    return;
+
+  RPT_size = INIT_RPT_SIZE;
+  root_ptr_table = stgMallocBytes(RPT_size * sizeof(rootEntry),
+                                    "initRootPtrTable");
+
+  initFreeList(root_ptr_table,INIT_RPT_SIZE,NULL);
+}
+
+
+void
+enlargeRootPtrTable(void)
+{
+  nat old_RPT_size = RPT_size;
+
+  // 2nd and subsequent times
+  RPT_size *= 2;
+  root_ptr_table =
+    stgReallocBytes(root_ptr_table,
+                    RPT_size * sizeof(rootEntry),
+                    "enlargeRootPtrTable");
+
+  initFreeList(root_ptr_table + old_RPT_size, old_RPT_size, NULL);
+}
+
+static void
+addRootObject(void *addr)
+{
+  StgWord rt;
+
+  if (root_ptr_free == NULL) {
+    enlargeRootPtrTable();
+  }
+
+  rt = root_ptr_free - root_ptr_table;
+  root_ptr_free  = (rootEntry*)(root_ptr_free->addr);
+  root_ptr_table[rt].addr = addr;
+}
+
+/* -----------------------------------------------------------------------------
+ * Treat root pointers as roots for the garbage collector.
+ * -------------------------------------------------------------------------- */
+
+void
+markRootPtrTable(evac_fn evac)
+{
+  rootEntry *p, *end_root_ptr_table;
+  StgPtr q;
+
+  end_root_ptr_table = &root_ptr_table[RPT_size];
+
+  for (p = root_ptr_table; p < end_root_ptr_table; p++) {
+    q = p->addr;
+
+    if (q && (q < (P_)root_ptr_table || q >= (P_)end_root_ptr_table)) {
+        evac((StgClosure **)p->addr);
+    }
+  }
+}
+
+/* -----------------------------------------------------------------------------
+ * End of utilities for handling root pointers.
+ * -------------------------------------------------------------------------- */
+
+

 /* -----------------------------------------------------------------------------
  * Insert symbols into hash tables, checking for duplicates.
  */
 /* -----------------------------------------------------------------------------
  * Insert symbols into hash tables, checking for duplicates.
  */

@@ -852,6 +954,8 @@ initLinker( void )
       linker_init_done = 1;
     }
 
       linker_init_done = 1;
     }
 

+    initRootPtrTable();
+    stablehash = allocStrHashTable();

     symhash = allocStrHashTable();
 
     /* populate the symbol table with stuff from the RTS */
     symhash = allocStrHashTable();
 
     /* populate the symbol table with stuff from the RTS */

@@ -989,6 +1093,26 @@ addDLL( char *dll_name )
 }
 
 /* -----------------------------------------------------------------------------
 }
 
 /* -----------------------------------------------------------------------------

+ * insert a stable symbol in the hash table
+ */
+
+void
+insertStableSymbol(char* obj_name, char* key, StgPtr p)
+{
+  ghciInsertStrHashTable(obj_name, stablehash, key, getStablePtr(p));
+}
+
+
+/* -----------------------------------------------------------------------------
+ * insert a symbol in the hash table
+ */
+void
+insertSymbol(char* obj_name, char* key, void* data)
+{
+  ghciInsertStrHashTable(obj_name, symhash, key, data);
+}
+
+/* -----------------------------------------------------------------------------

  * lookup a symbol in the hash table
  */
 void *
  * lookup a symbol in the hash table
  */
 void *

@@ -3134,6 +3258,8 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
       Elf_Addr  S;
       void*     S_tmp;
       Elf_Addr  value;
       Elf_Addr  S;
       void*     S_tmp;
       Elf_Addr  value;

+      StgStablePtr stablePtr;
+      StgPtr stableVal;

 
       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p)",
                              j, (void*)offset, (void*)info ));
 
       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p)",
                              j, (void*)offset, (void*)info ));

@@ -3152,10 +3278,18 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
                        + stab[ELF_R_SYM(info)].st_value);
 
         } else {
                        + stab[ELF_R_SYM(info)].st_value);
 
         } else {

-            /* No, so look up the name in our global table. */

             symbol = strtab + sym.st_name;
             symbol = strtab + sym.st_name;

-            S_tmp = lookupSymbol( symbol );
-            S = (Elf_Addr)S_tmp;
+            stablePtr = (StgStablePtr)lookupHashTable(stablehash, (StgWord)symbol);
+            if (NULL == stablePtr) {
+              /* No, so look up the name in our global table. */
+              S_tmp = lookupSymbol( symbol );
+              S = (Elf_Addr)S_tmp;
+            } else {
+              stableVal = deRefStablePtr( stablePtr );
+              addRootObject((void*)P);
+              S_tmp = stableVal;
+              S = (Elf_Addr)S_tmp;
+            }

         }
          if (!S) {
             errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
         }
          if (!S) {
             errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);