* 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.
scm_i_primitive_call_ip (SCM subr)
{
const scm_t_uint32 *code = SCM_RTL_PROGRAM_CODE (subr);
scm_i_primitive_call_ip (SCM subr)
{
const scm_t_uint32 *code = SCM_RTL_PROGRAM_CODE (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. */
/* 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));
\f
SCM_INTERNAL int scm_i_primitive_arity (SCM subr, int *req, int *opt, int *rest);
\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);
SCM_API SCM scm_c_make_gsubr (const char *name,
int req, int opt, int rst, scm_t_subr fcn);
{
SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);
{
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));
(define (write-arity-headers metas bv endianness)
(define (write-arity-header* pos low-pc high-pc flags nreq nopt)
(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)
(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)
(define (is-case-lambda? flags) (not (zero? (logand flags (ash 1 3)))))
(define (arity-low-pc arity)
(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)
(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)))
(define (arity-nreq arity)
(arity-nreq* (elf-bytes (debug-context-elf (arity-context arity)))
(let lp ((pos headers-start))
(cond
((>= pos headers-end) #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))
- ((<= (* (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))))))
(lp (+ pos arity-header-len)))
(else
(make-arity context base pos))))))
prog
(list 0 0 nreq nopt rest? '(#f . ()))))))))
((rtl-program? prog)
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
(else
(let ((arity (program-arity prog ip)))
(and arity