From 0e3a59f75050041f4f6b423a53193609335f708d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 8 Nov 2013 10:03:48 +0100 Subject: [PATCH] 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. --- libguile/gsubr.c | 4 ++-- libguile/gsubr.h | 2 +- libguile/programs.c | 2 +- module/system/vm/assembler.scm | 4 ++-- module/system/vm/debug.scm | 18 ++++++++++++------ module/system/vm/program.scm | 13 ++++++------- 6 files changed, 24 insertions(+), 19 deletions(-) diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 5dd767df7..96fab4eda 100644 --- 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 6bdfe6baf..3350e2fc8 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -55,7 +55,7 @@ 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 3e228f79c..f74e4ed5c 100644 --- 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 d6b417f76..7020487fd 100644 --- 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 a3aede73c..561143263 100644 --- 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 ecac6a791..cf77c2824 100644 --- 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 -- 2.20.1