Fix reading and writing arities into DWARF.

* libguile/gsubr.h:
* libguile/gsubr.c (scm_i_primitive_call_ip):
* libguile/programs.c (scm_primitive_call_ip): Adapt to return an
  absolute address.

* module/system/vm/assembler.scm (write-arity-headers): Adapt to write
  byte addresses (relative to the text base).

* module/system/vm/debug.scm (arity-low-pc, arity-high-pc): Return
  absolute addresses, instead of word offsets relative to the text
  base.
  (find-first-arity): Adapt for absolute addresses.

* module/system/vm/program.scm (program-arguments-alist): Adapt for
  arity-low-pc / arity-high-pc absolute addresses.

diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 5dd767d..96fab4e 100644 (file)
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -286,7 +286,7 @@ scm_i_primitive_arity (SCM prim, int *req, int *opt, int *rest)
   return 1;
 }
 
-int
+scm_t_uintptr
 scm_i_primitive_call_ip (SCM subr)
 {
   const scm_t_uint32 *code = SCM_RTL_PROGRAM_CODE (subr);
@@ -294,7 +294,7 @@ scm_i_primitive_call_ip (SCM subr)
   /* A stub is 4 32-bit words long, or 16 bytes.  The call will be one
      instruction, in either the fourth, third, or second word.  Return a
      byte offset from the entry.  */
-  return code[3] ? 12 : code[2] ? 8 : 4;
+  return (scm_t_uintptr)(code + (code[3] ? 3 : code[2] ? 2 : 1));
 }
 
 SCM

diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index 6bdfe6b..3350e2f 100644 (file)
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -55,7 +55,7 @@
 \f
 
 SCM_INTERNAL int scm_i_primitive_arity (SCM subr, int *req, int *opt, int *rest);
-SCM_INTERNAL int scm_i_primitive_call_ip (SCM subr);
+SCM_INTERNAL scm_t_uintptr scm_i_primitive_call_ip (SCM subr);
 
 SCM_API SCM scm_c_make_gsubr (const char *name,
                              int req, int opt, int rst, scm_t_subr fcn);

diff --git a/libguile/programs.c b/libguile/programs.c
index 3e228f7..f74e4ed 100644 (file)
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -248,7 +248,7 @@ SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0,
 {
   SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);
 
-  return scm_from_int (scm_i_primitive_call_ip (prim));
+  return scm_from_uintptr_t (scm_i_primitive_call_ip (prim));
 }
 #undef FUNC_NAME
 

diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index d6b417f..7020487 100644 (file)
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1380,8 +1380,8 @@ it will be added to the GC roots at runtime."
 
 (define (write-arity-headers metas bv endianness)
   (define (write-arity-header* pos low-pc high-pc flags nreq nopt)
-    (bytevector-u32-set! bv pos low-pc endianness)
-    (bytevector-u32-set! bv (+ pos 4) high-pc endianness)
+    (bytevector-u32-set! bv pos (* low-pc 4) endianness)
+    (bytevector-u32-set! bv (+ pos 4) (* high-pc 4) endianness)
     (bytevector-u32-set! bv (+ pos 8) 0 endianness) ; offset
     (bytevector-u32-set! bv (+ pos 12) flags endianness)
     (bytevector-u32-set! bv (+ pos 16) nreq endianness)

diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index a3aede7..5611432 100644 (file)
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -272,12 +272,18 @@ section of the ELF image.  Returns an ELF symbol, or @code{#f}."
 (define (is-case-lambda? flags)   (not (zero? (logand flags (ash 1 3)))))
 
 (define (arity-low-pc arity)
-  (arity-low-pc* (elf-bytes (debug-context-elf (arity-context arity)))
-                 (arity-header-offset arity)))
+  (let ((ctx (arity-context arity)))
+    (+ (debug-context-base ctx)
+       (debug-context-text-base ctx)
+       (arity-low-pc* (elf-bytes (debug-context-elf ctx))
+                      (arity-header-offset arity)))))
 
 (define (arity-high-pc arity)
-  (arity-high-pc* (elf-bytes (debug-context-elf (arity-context arity)))
-                  (arity-header-offset arity)))
+  (let ((ctx (arity-context arity)))
+    (+ (debug-context-base ctx)
+       (debug-context-text-base ctx)
+       (arity-high-pc* (elf-bytes (debug-context-elf ctx))
+                       (arity-header-offset arity)))))
 
 (define (arity-nreq arity)
   (arity-nreq* (elf-bytes (debug-context-elf (arity-context arity)))
@@ -352,9 +358,9 @@ section of the ELF image.  Returns an ELF symbol, or @code{#f}."
     (let lp ((pos headers-start))
       (cond
        ((>= pos headers-end) #f)
-       ((< text-offset (* (arity-low-pc* bv pos) 4))
+       ((< text-offset (arity-low-pc* bv pos))
         #f)
-       ((<= (* (arity-high-pc* bv pos) 4) text-offset)
+       ((<= (arity-high-pc* bv pos) text-offset)
         (lp (+ pos arity-header-len)))
        (else
         (make-arity context base pos))))))

diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index ecac6a7..cf77c28 100644 (file)
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -314,13 +314,12 @@
                prog
                (list 0 0 nreq nopt rest? '(#f . ()))))))))
    ((rtl-program? prog)
-    (let ((pc (and ip (+ (rtl-program-code prog) ip))))
-      (or-map (lambda (arity)
-                (and (or (not pc)
-                         (and (<= (arity-low-pc arity) pc)
-                              (< pc (arity-high-pc arity))))
-                     (arity-arguments-alist arity)))
-              (or (find-program-arities (rtl-program-code prog)) '()))))
+    (or-map (lambda (arity)
+              (and (or (not ip)
+                       (and (<= (arity-low-pc arity) ip)
+                            (< ip (arity-high-pc arity))))
+                   (arity-arguments-alist arity)))
+            (or (find-program-arities (rtl-program-code prog)) '())))
    (else
     (let ((arity (program-arity prog ip)))
       (and arity