Retrieving the datacon of an arbitrary closure

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

diff --git a/rts/Linker.c b/rts/Linker.c
index 92d0106..45f5ff6 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__

@@ -25,8 +25,8 @@
 #include "LinkerInternals.h"
 #include "RtsUtils.h"
 #include "Schedule.h"
 #include "LinkerInternals.h"
 #include "RtsUtils.h"
 #include "Schedule.h"

-#include "Storage.h"

 #include "Sparks.h"
 #include "Sparks.h"

+#include "RtsTypeable.h"

 
 #ifdef HAVE_SYS_TYPES_H
 #include <sys/types.h>
 
 #ifdef HAVE_SYS_TYPES_H
 #include <sys/types.h>

@@ -92,6 +92,14 @@
 /* Hash table mapping symbol names to Symbol */
 static /*Str*/HashTable *symhash;
 
 /* Hash table mapping symbol names to Symbol */
 static /*Str*/HashTable *symhash;
 

+/* Hash table mapping symbol names to StgStablePtr */
+static /*Str*/HashTable *stablehash;
+
+#if defined(GHCI) && defined(BREAKPOINT)
+/* 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 */
 

@@ -322,6 +330,7 @@ typedef struct _RtsSymbolVal {
       Sym(mktime)                               \
       Sym(_imp___timezone)                      \
       Sym(_imp___tzname)                        \
       Sym(mktime)                               \
       Sym(_imp___timezone)                      \
       Sym(_imp___tzname)                        \

+      Sym(_imp__tzname)                         \

       Sym(_imp___iob)                           \
       Sym(_imp___osver)                         \
       Sym(localtime)                            \
       Sym(_imp___iob)                           \
       Sym(_imp___osver)                         \
       Sym(localtime)                            \

@@ -393,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

@@ -475,6 +488,7 @@ typedef struct _RtsSymbolVal {
       SymX(catchzh_fast)                       \
       SymX(catchRetryzh_fast)                  \
       SymX(catchSTMzh_fast)                    \
       SymX(catchzh_fast)                       \
       SymX(catchRetryzh_fast)                  \
       SymX(catchSTMzh_fast)                    \

+      SymX(checkzh_fast)                        \

       SymX(closure_flags)                       \
       SymX(cmp_thread)                         \
       SymX(cmpIntegerzh_fast)                  \
       SymX(closure_flags)                       \
       SymX(cmp_thread)                         \
       SymX(cmpIntegerzh_fast)                  \

@@ -496,6 +510,7 @@ typedef struct _RtsSymbolVal {
       SymX(forkOS_createThread)                        \
       SymX(freeHaskellFunctionPtr)             \
       SymX(freeStablePtr)                      \
       SymX(forkOS_createThread)                        \
       SymX(freeHaskellFunctionPtr)             \
       SymX(freeStablePtr)                      \

+      SymX(getOrSetTypeableStore)              \

       SymX(gcdIntegerzh_fast)                  \
       SymX(gcdIntegerIntzh_fast)               \
       SymX(gcdIntzh_fast)                      \
       SymX(gcdIntegerzh_fast)                  \
       SymX(gcdIntegerIntzh_fast)               \
       SymX(gcdIntzh_fast)                      \

@@ -511,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)                        \

@@ -526,7 +543,10 @@ typedef struct _RtsSymbolVal {
       SymX(isFloatNegativeZero)                        \
       SymX(killThreadzh_fast)                  \
       SymX(loadObj)                            \
       SymX(isFloatNegativeZero)                        \
       SymX(killThreadzh_fast)                  \
       SymX(loadObj)                            \

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

       SymX(lookupSymbol)                       \
       SymX(lookupSymbol)                       \

+      SymX(lookupDataCon)                      \

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

@@ -694,7 +714,8 @@ typedef struct _RtsSymbolVal {
       SymX(stg_interp_constr6_entry)            \
       SymX(stg_interp_constr7_entry)            \
       SymX(stg_interp_constr8_entry)            \
       SymX(stg_interp_constr6_entry)            \
       SymX(stg_interp_constr7_entry)            \
       SymX(stg_interp_constr8_entry)            \

-      SymX(stgMallocBytesRWX)                   \
+      SymX(allocateExec)                       \
+      SymX(freeExec)                           \

       SymX(getAllocations)                      \
       SymX(revertCAFs)                          \
       SymX(RtsFlags)                            \
       SymX(getAllocations)                      \
       SymX(revertCAFs)                          \
       SymX(RtsFlags)                            \

@@ -780,6 +801,7 @@ static RtsSymbolVal rtsSyms[] = {
       RTS_POSIX_ONLY_SYMBOLS
       RTS_MINGW_ONLY_SYMBOLS
       RTS_CYGWIN_ONLY_SYMBOLS
       RTS_POSIX_ONLY_SYMBOLS
       RTS_MINGW_ONLY_SYMBOLS
       RTS_CYGWIN_ONLY_SYMBOLS

+      RTS_DARWIN_ONLY_SYMBOLS

       RTS_LIBGCC_SYMBOLS
 #if defined(darwin_HOST_OS) && defined(i386_HOST_ARCH)
       // dyld stub code contains references to this,
       RTS_LIBGCC_SYMBOLS
 #if defined(darwin_HOST_OS) && defined(i386_HOST_ARCH)
       // dyld stub code contains references to this,

@@ -790,9 +812,12 @@ static RtsSymbolVal rtsSyms[] = {
       { 0, 0 } /* sentinel */
 };
 
       { 0, 0 } /* sentinel */
 };
 

+
+

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

+

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

@@ -802,6 +827,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(GHCI) && defined(BREAKPOINT)    
+      // 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(

@@ -823,7 +857,16 @@ static void ghciInsertStrHashTable ( char* obj_name,
    exit(1);
 }
 
    exit(1);
 }
 

+#if defined(GHCI) && defined(BREAKPOINT)
+static void ghciInsertDCTable ( char* obj_name,
+                               StgWord key,
+                               char* data
+                             )
+{
+    ghciInsertStrHashTable(obj_name, dchash, (char *)key, data);

 
 

+}
+#endif

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

@@ -835,11 +878,6 @@ static int linker_init_done = 0 ;
 static void *dl_prog_handle;
 #endif
 
 static void *dl_prog_handle;
 #endif
 

-/* dlopen(NULL,..) doesn't work so we grab libc explicitly */
-#if defined(openbsd_HOST_OS)
-static void *dl_libc_handle;
-#endif
-

 void
 initLinker( void )
 {
 void
 initLinker( void )
 {

@@ -852,7 +890,11 @@ initLinker( void )
       linker_init_done = 1;
     }
 
       linker_init_done = 1;
     }
 

+    stablehash = allocStrHashTable();

     symhash = allocStrHashTable();
     symhash = allocStrHashTable();

+#if defined(GHCI) && defined(BREAKPOINT)
+    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++) {

@@ -868,9 +910,6 @@ initLinker( void )
     dl_prog_handle = RTLD_DEFAULT;
 #   else
     dl_prog_handle = dlopen(NULL, RTLD_LAZY);
     dl_prog_handle = RTLD_DEFAULT;
 #   else
     dl_prog_handle = dlopen(NULL, RTLD_LAZY);

-#   if defined(openbsd_HOST_OS)
-    dl_libc_handle = dlopen("libc.so", RTLD_LAZY);
-#   endif

 #   endif /* RTLD_DEFAULT */
 #   endif
 }
 #   endif /* RTLD_DEFAULT */
 #   endif
 }

@@ -989,6 +1028,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 *

@@ -1001,10 +1060,7 @@ lookupSymbol( char *lbl )
 
     if (val == NULL) {
 #       if defined(OBJFORMAT_ELF)
 
     if (val == NULL) {
 #       if defined(OBJFORMAT_ELF)

-#      if defined(openbsd_HOST_OS)
-       val = dlsym(dl_prog_handle, lbl);
-       return (val != NULL) ? val : dlsym(dl_libc_handle,lbl);
-#      elif defined(x86_64_HOST_ARCH)
+#      if defined(x86_64_HOST_ARCH)

        val = dlsym(dl_prog_handle, lbl);
        if (val >= (void *)0x80000000) {
            void *new_val;
        val = dlsym(dl_prog_handle, lbl);
        if (val >= (void *)0x80000000) {
            void *new_val;

@@ -1014,7 +1070,7 @@ lookupSymbol( char *lbl )
        } else {
            return val;
        }
        } else {
            return val;
        }

-#      else /* not openbsd */
+#      else

        return dlsym(dl_prog_handle, lbl);
 #      endif
 #       elif defined(OBJFORMAT_MACHO)
        return dlsym(dl_prog_handle, lbl);
 #      endif
 #       elif defined(OBJFORMAT_MACHO)

@@ -1057,6 +1113,24 @@ lookupSymbol( char *lbl )
     }
 }
 
     }
 }
 

+#if defined(GHCI) && defined(BREAKPOINT)
+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 *

@@ -1134,13 +1208,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;

@@ -1230,7 +1303,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);

@@ -1244,7 +1317,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

@@ -1254,15 +1332,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);

@@ -1375,9 +1450,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);

@@ -1452,7 +1531,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.
   

@@ -2157,6 +2236,8 @@ ocGetNames_PEi386 ( ObjectCode* oc )
           && 0 != strcmp(".stabstr", sectab_i->Name)
           /* ignore constructor section for now */
           && 0 != strcmp(".ctors", sectab_i->Name)
           && 0 != strcmp(".stabstr", sectab_i->Name)
           /* ignore constructor section for now */
           && 0 != strcmp(".ctors", sectab_i->Name)

+          /* ignore section generated from .ident */
+          && 0!= strcmp("/4", sectab_i->Name)

          ) {
          errorBelch("Unknown PEi386 section name `%s' (while processing: %s)", sectab_i->Name, oc->fileName);
          return 0;
          ) {
          errorBelch("Unknown PEi386 section name `%s' (while processing: %s)", sectab_i->Name, oc->fileName);
          return 0;

@@ -2374,14 +2455,14 @@ ocResolve_PEi386 ( ObjectCode* oc )
                    + sym->Value);
          } else {
             copyName ( sym->Name, strtab, symbol, 1000-1 );
                    + sym->Value);
          } else {
             copyName ( sym->Name, strtab, symbol, 1000-1 );

-            (void*)S = lookupLocalSymbol( oc, symbol );
+            S = (UInt32) lookupLocalSymbol( oc, symbol );

             if ((void*)S != NULL) goto foundit;
             if ((void*)S != NULL) goto foundit;

-            (void*)S = lookupSymbol( symbol );
+            S = (UInt32) lookupSymbol( symbol );

             if ((void*)S != NULL) goto foundit;
             zapTrailingAtSign ( symbol );
             if ((void*)S != NULL) goto foundit;
             zapTrailingAtSign ( symbol );

-            (void*)S = lookupLocalSymbol( oc, symbol );
+            S = (UInt32) lookupLocalSymbol( oc, symbol );

             if ((void*)S != NULL) goto foundit;
             if ((void*)S != NULL) goto foundit;

-            (void*)S = lookupSymbol( symbol );
+            S = (UInt32) lookupSymbol( symbol );

             if ((void*)S != NULL) goto foundit;
            /* Newline first because the interactive linker has printed "linking..." */
             errorBelch("\n%s: unknown symbol `%s'", oc->fileName, symbol);
             if ((void*)S != NULL) goto foundit;
            /* Newline first because the interactive linker has printed "linking..." */
             errorBelch("\n%s: unknown symbol `%s'", oc->fileName, symbol);

@@ -2785,6 +2866,9 @@ ocVerifyImage_ELF ( ObjectCode* oc )
    IF_DEBUG(linker,debugBelch( "Architecture is " ));
    switch (ehdr->e_machine) {
       case EM_386:   IF_DEBUG(linker,debugBelch( "x86" )); break;
    IF_DEBUG(linker,debugBelch( "Architecture is " ));
    switch (ehdr->e_machine) {
       case EM_386:   IF_DEBUG(linker,debugBelch( "x86" )); break;

+#ifdef EM_SPARC32PLUS
+      case EM_SPARC32PLUS:
+#endif

       case EM_SPARC: IF_DEBUG(linker,debugBelch( "sparc" )); break;
 #ifdef EM_IA_64
       case EM_IA_64: IF_DEBUG(linker,debugBelch( "ia64" )); break;
       case EM_SPARC: IF_DEBUG(linker,debugBelch( "sparc" )); break;
 #ifdef EM_IA_64
       case EM_IA_64: IF_DEBUG(linker,debugBelch( "ia64" )); break;

@@ -3134,6 +3218,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 +3238,17 @@ 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 );
+              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);

@@ -4313,3 +4406,20 @@ static int machoGetMisalignment( FILE * f )
 }
 
 #endif
 }
 
 #endif

+
+#if defined(GHCI) && defined(BREAKPOINT)
+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;
+  }
+#endif