Toggle whether the RTS gets build with debugger support for ghci

[ghc-hetmet.git] / rts / Linker.c

diff --git a/rts/Linker.c b/rts/Linker.c
index 54251ac..d0c120b 100644 (file)
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -10,7 +10,7 @@
 #include "PosixSource.h"
 #endif
 
 #include "PosixSource.h"
 #endif
 

-/* Linux needs _GNU_SOURCE to get RTLD_DEFAULT from <dlfcn.h> and 
+/* Linux needs _GNU_SOURCE to get RTLD_DEFAULT from <dlfcn.h> and

    MREMAP_MAYMOVE from <sys/mman.h>.
  */
 #ifdef __linux__
    MREMAP_MAYMOVE from <sys/mman.h>.
  */
 #ifdef __linux__

@@ -92,16 +92,13 @@
 /* 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;
 /* 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;
+#if defined(DEBUGGER)
+/* Hash table mapping info table ptrs to DataCon names */
+static HashTable *dchash;
+#endif 

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

@@ -405,7 +402,11 @@ typedef struct _RtsSymbolVal {
 #define RTS_USER_SIGNALS_SYMBOLS \
    SymX(setIOManagerPipe)
 #else
 #define RTS_USER_SIGNALS_SYMBOLS \
    SymX(setIOManagerPipe)
 #else

-#define RTS_USER_SIGNALS_SYMBOLS /* nothing */
+#define RTS_USER_SIGNALS_SYMBOLS \
+   SymX(sendIOManagerEvent) \
+   SymX(readIOManagerEvent) \
+   SymX(getIOManagerEvent) \
+   SymX(console_handler)

 #endif
 
 #ifdef TABLES_NEXT_TO_CODE
 #endif
 
 #ifdef TABLES_NEXT_TO_CODE

@@ -525,6 +526,8 @@ typedef struct _RtsSymbolVal {
       SymX(hs_free_stable_ptr)                 \
       SymX(hs_free_fun_ptr)                    \
       SymX(initLinker)                         \
       SymX(hs_free_stable_ptr)                 \
       SymX(hs_free_fun_ptr)                    \
       SymX(initLinker)                         \

+      SymX(infoPtrzh_fast)                      \
+      SymX(closurePayloadzh_fast)               \

       SymX(int2Integerzh_fast)                 \
       SymX(integer2Intzh_fast)                 \
       SymX(integer2Wordzh_fast)                        \
       SymX(int2Integerzh_fast)                 \
       SymX(integer2Intzh_fast)                 \
       SymX(integer2Wordzh_fast)                        \

@@ -543,6 +546,7 @@ typedef struct _RtsSymbolVal {
       SymX(insertStableSymbol)                         \
       SymX(insertSymbol)                       \
       SymX(lookupSymbol)                       \
       SymX(insertStableSymbol)                         \
       SymX(insertSymbol)                       \
       SymX(lookupSymbol)                       \

+      SymX(lookupDataCon)                      \

       SymX(makeStablePtrzh_fast)               \
       SymX(minusIntegerzh_fast)                        \
       SymX(mkApUpd0zh_fast)                    \
       SymX(makeStablePtrzh_fast)               \
       SymX(minusIntegerzh_fast)                        \
       SymX(mkApUpd0zh_fast)                    \

@@ -809,97 +813,12 @@ static RtsSymbolVal rtsSyms[] = {
 };
 
 
 };
 
 

-/* -----------------------------------------------------------------------------
- * 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;
-}
-
-static 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);
-}
-
-
-static 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;
-  initRootPtrTable();
-  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.
  */

+int isSuffixOf(char* x, char* suffix);
+

 static void ghciInsertStrHashTable ( char* obj_name,
                                      HashTable *table,
                                      char* key,
 static void ghciInsertStrHashTable ( char* obj_name,
                                      HashTable *table,
                                      char* key,

@@ -909,6 +828,15 @@ static void ghciInsertStrHashTable ( char* obj_name,
    if (lookupHashTable(table, (StgWord)key) == NULL)
    {
       insertStrHashTable(table, (StgWord)key, data);
    if (lookupHashTable(table, (StgWord)key) == NULL)
    {
       insertStrHashTable(table, (StgWord)key, data);

+#if defined(DEBUGGER)    
+      // Insert the reverse pair in the datacon hash if it is a closure
+      {
+       if(isSuffixOf(key, "static_info") || isSuffixOf(key, "con_info")) {
+            insertHashTable(dchash, (StgWord)data, key);
+            //             debugBelch("DChash addSymbol: %s (%p)\n", key, data);
+          }
+      }
+#endif

       return;
    }
    debugBelch(
       return;
    }
    debugBelch(

@@ -929,8 +857,6 @@ static void ghciInsertStrHashTable ( char* obj_name,
    );
    exit(1);
 }
    );
    exit(1);
 }

-
-

 /* -----------------------------------------------------------------------------
  * initialize the object linker
  */
 /* -----------------------------------------------------------------------------
  * initialize the object linker
  */

@@ -956,6 +882,9 @@ initLinker( void )
 
     stablehash = allocStrHashTable();
     symhash = allocStrHashTable();
 
     stablehash = allocStrHashTable();
     symhash = allocStrHashTable();

+#if defined(DEBUGGER)
+    dchash  = allocHashTable();
+#endif

 
     /* populate the symbol table with stuff from the RTS */
     for (sym = rtsSyms; sym->lbl != NULL; sym++) {
 
     /* populate the symbol table with stuff from the RTS */
     for (sym = rtsSyms; sym->lbl != NULL; sym++) {

@@ -1174,6 +1103,24 @@ lookupSymbol( char *lbl )
     }
 }
 
     }
 }
 

+#if defined(DEBUGGER)
+char * 
+lookupDataCon( StgWord addr ) 
+{
+  void *val;
+    initLinker() ;
+    ASSERT(dchash != NULL);
+    val = lookupHashTable(dchash, addr); 
+
+    return val;
+}
+#else
+char* lookupDataCon( StgWord addr )
+{
+  return NULL;
+}
+#endif
+

 static
 __attribute((unused))
 void *
 static
 __attribute((unused))
 void *

@@ -1251,13 +1198,12 @@ loadObj( char *path )
    void *map_addr = NULL;
 #else
    FILE *f;
    void *map_addr = NULL;
 #else
    FILE *f;

-   int misalignment;

 #endif
    initLinker();
 
    /* debugBelch("loadObj %s\n", path ); */
 
 #endif
    initLinker();
 
    /* debugBelch("loadObj %s\n", path ); */
 

-   /* Check that we haven't already loaded this object. 
+   /* Check that we haven't already loaded this object.

       Ignore requests to load multiple times */
    {
        ObjectCode *o;
       Ignore requests to load multiple times */
    {
        ObjectCode *o;

@@ -1347,7 +1293,7 @@ loadObj( char *path )
 #define EXTRA_MAP_FLAGS 0
 #endif
 
 #define EXTRA_MAP_FLAGS 0
 #endif
 

-   oc->image = mmap(map_addr, n, PROT_EXEC|PROT_READ|PROT_WRITE, 
+   oc->image = mmap(map_addr, n, PROT_EXEC|PROT_READ|PROT_WRITE,

                    MAP_PRIVATE|EXTRA_MAP_FLAGS, fd, 0);
    if (oc->image == MAP_FAILED)
       barf("loadObj: can't map `%s'", path);
                    MAP_PRIVATE|EXTRA_MAP_FLAGS, fd, 0);
    if (oc->image == MAP_FAILED)
       barf("loadObj: can't map `%s'", path);

@@ -1361,7 +1307,12 @@ loadObj( char *path )
    if (!f)
        barf("loadObj: can't read `%s'", path);
 
    if (!f)
        barf("loadObj: can't read `%s'", path);
 

-#ifdef darwin_HOST_OS
+#   if defined(mingw32_HOST_OS)
+       // TODO: We would like to use allocateExec here, but allocateExec
+       //       cannot currently allocate blocks large enough.
+    oc->image = VirtualAlloc(NULL, oc->fileSize, MEM_RESERVE | MEM_COMMIT,
+                             PAGE_EXECUTE_READWRITE);
+#   elif defined(darwin_HOST_OS)

     // In a Mach-O .o file, all sections can and will be misaligned
     // if the total size of the headers is not a multiple of the
     // desired alignment. This is fine for .o files that only serve
     // In a Mach-O .o file, all sections can and will be misaligned
     // if the total size of the headers is not a multiple of the
     // desired alignment. This is fine for .o files that only serve

@@ -1371,15 +1322,12 @@ loadObj( char *path )
     // We calculate the correct alignment from the header before
     // reading the file, and then we misalign oc->image on purpose so
     // that the actual sections end up aligned again.
     // We calculate the correct alignment from the header before
     // reading the file, and then we misalign oc->image on purpose so
     // that the actual sections end up aligned again.

-   misalignment = machoGetMisalignment(f);
-   oc->misalignment = misalignment;
-#else
-   misalignment = 0;
-#endif
+   oc->misalignment = machoGetMisalignment(f);
+   oc->image = stgMallocBytes(oc->fileSize + oc->misalignment, "loadObj(image)");
+#  else
+   oc->image = stgMallocBytes(oc->fileSize, "loadObj(image)");
+#  endif

 
 

-   oc->image = stgMallocBytes(oc->fileSize + misalignment, "loadObj(image)");
-   oc->image += misalignment;
-   

    n = fread ( oc->image, 1, oc->fileSize, f );
    if (n != oc->fileSize)
       barf("loadObj: error whilst reading `%s'", path);
    n = fread ( oc->image, 1, oc->fileSize, f );
    if (n != oc->fileSize)
       barf("loadObj: error whilst reading `%s'", path);

@@ -1492,9 +1440,13 @@ unloadObj( char *path )
                prev->next = oc->next;
            }
 
                prev->next = oc->next;
            }
 

-           /* We're going to leave this in place, in case there are
-              any pointers from the heap into it: */
-           /* stgFree(oc->image); */
+           // We're going to leave this in place, in case there are
+           // any pointers from the heap into it:
+               // #ifdef mingw32_HOST_OS
+               //  VirtualFree(oc->image);
+               // #else
+           //  stgFree(oc->image);
+           // #endif

            stgFree(oc->fileName);
            stgFree(oc->symbols);
            stgFree(oc->sections);
            stgFree(oc->fileName);
            stgFree(oc->symbols);
            stgFree(oc->sections);

@@ -1569,7 +1521,7 @@ static void addSection ( ObjectCode* oc, SectionKind kind,
 
 /*
   ocAllocateJumpIslands
 
 /*
   ocAllocateJumpIslands

-  
+

   Allocate additional space at the end of the object file image to make room
   for jump islands.
   
   Allocate additional space at the end of the object file image to make room
   for jump islands.
   

@@ -3284,7 +3236,6 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
               S = (Elf_Addr)S_tmp;
             } else {
               stableVal = deRefStablePtr( stablePtr );
               S = (Elf_Addr)S_tmp;
             } else {
               stableVal = deRefStablePtr( stablePtr );

-              addRootObject((void*)P);

               S_tmp = stableVal;
               S = (Elf_Addr)S_tmp;
             }
               S_tmp = stableVal;
               S = (Elf_Addr)S_tmp;
             }

@@ -4445,3 +4396,18 @@ static int machoGetMisalignment( FILE * f )
 }
 
 #endif
 }
 
 #endif

+
+int isSuffixOf(char* x, char* suffix) {
+  int suffix_len = strlen (suffix);
+  int x_len = strlen (x);
+  
+  if (x_len == 0)
+    return 0;
+  if (suffix_len > x_len) 
+    return 0;
+  if (suffix_len == 0) 
+    return 1;
+  
+  char* x_suffix = &x[strlen(x)-strlen(suffix)];
+  return strcmp(x_suffix, suffix) == 0;
+  }