From 27e21e6e7d6b15ce9c123f0a9cefa6492dc698b5 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 29 Jan 2020 15:39:47 -0700
Subject: [PATCH] code inspector: improvements to reloc reporting

Fix 'reloc to avoid a crash on static-generation code, and add
'reloc+offset to report an offset for each entry.

original commit: 4d4195044377f9c619cfb46056e365044069d5bc
---
 c/prim5.c    | 26 +++++++++++++++++---------
 s/inspect.ss |  6 ++++--
 s/syntax.ss  |  2 +-
 3 files changed, 22 insertions(+), 12 deletions(-)

diff --git a/c/prim5.c b/c/prim5.c
index 55f89420ce..8954b1c867 100644
--- a/c/prim5.c
+++ b/c/prim5.c
@@ -85,7 +85,7 @@ static IBOOL s_fd_regularp PROTO((INT fd));
 static void s_nanosleep PROTO((ptr sec, ptr nsec));
 static ptr s_set_collect_trip_bytes PROTO((ptr n));
 static void c_exit PROTO((I32 status));
-static ptr s_get_reloc PROTO((ptr co));
+static ptr s_get_reloc PROTO((ptr co, IBOOL with_offsets));
 #ifdef PTHREADS
 static s_thread_rv_t s_backdoor_thread_start PROTO((void *p));
 static iptr s_backdoor_thread PROTO((ptr p));
@@ -1704,10 +1704,14 @@ void S_prim5_init() {
     Sforeign_symbol("(cs)s_set_profile_counters", (void *)s_set_profile_counters);
 }
 
-static ptr s_get_reloc(co) ptr co; {
+static ptr s_get_reloc(co, with_offsets) ptr co; IBOOL with_offsets; {
   ptr t, ls; uptr a, m, n;
 
   require(Scodep(co),"s_get_reloc","~s is not a code object",co);
+
+  if (s_generation(co) == FIX(static_generation))
+    return Snil;
+
   ls = Snil;
   t = CODERELOC(co);
   m = RELOCSIZE(t);
@@ -1726,13 +1730,17 @@ static ptr s_get_reloc(co) ptr co; {
     a += code_off;
     obj = S_get_code_obj(RELOC_TYPE(entry), co, a, item_off);
     if (!Sfixnump(obj)) {
-      ptr x;
-      for (x = ls; ; x = Scdr(x)) {
-        if (x == Snil) {
-          ls = Scons(obj,ls);
-          break;
-        } else if (Scar(x) == obj)
-          break;
+      if (with_offsets) {
+        ls = Scons(Scons(obj, FIX(a-code_data_disp)), ls);
+      } else {
+        ptr x;
+        for (x = ls; ; x = Scdr(x)) {
+          if (x == Snil) {
+            ls = Scons(obj,ls);
+            break;
+          } else if (Scar(x) == obj)
+            break;
+        }
       }
     }
   }
diff --git a/s/inspect.ss b/s/inspect.ss
index e75b34a62d..b97b698f01 100644
--- a/s/inspect.ss
+++ b/s/inspect.ss
@@ -2181,7 +2181,7 @@
 
     (define get-reloc-objs
       (foreign-procedure "(cs)s_get_reloc"
-        (scheme-object) scheme-object))
+        (scheme-object boolean) scheme-object))
 
     (module (get-code-src get-code-sexpr)
       (include "types.ss")
@@ -2200,13 +2200,15 @@
         [name () ($code-name x)]
         [info () (make-object ($code-info x))]
         [free-count () ($code-free-count x)]
+        [arity-mask () ($code-arity-mask x)]
         [source ()
           (cond
             [(get-code-sexpr x) => make-object]
             [else #f])]
         [source-path () (return-source (get-code-src x))]
         [source-object () (get-code-src x)]
-        [reloc () (make-object (get-reloc-objs x))]
+        [reloc () (make-object (get-reloc-objs x #f))]
+        [reloc+offset () (make-object (get-reloc-objs x #t))]
         [size (g) (compute-size x g)]
         [write (p) (write x p)]
         [print (p) (pretty-print x p)]))
diff --git a/s/syntax.ss b/s/syntax.ss
index 34855b1439..0006241af6 100644
--- a/s/syntax.ss
+++ b/s/syntax.ss
@@ -545,7 +545,7 @@
                              [(clause (,x* ...) ,interface ,body) interface]))
                       clauses))
             ($oops #f "libspec interface mismatch ~s" libspec))
-          `(case-lambda ,(make-preinfo-lambda (ae->src ae) #f libspec) ,clauses ...))))))
+          `(case-lambda ,(make-preinfo-lambda (ae->src ae) #f libspec (symbol->string (libspec-name libspec))) ,clauses ...))))))
 
 (define build-call
   (lambda (ae e e*)