suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

code inspector: improvements to reloc reporting

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

original commit: 4d4195044377f9c619cfb46056e365044069d5bc
This commit is contained in:
Matthew Flatt 2020-01-29 15:39:47 -07:00
parent 6962aceaf0
commit 27e21e6e7d
3 changed files with 22 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
c/prim5.c
View File

@ -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;
}
}
}
}

6
s/inspect.ss
View File

@ -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)]))

2
s/syntax.ss
View File

@ -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*)