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 void s_nanosleep PROTO((ptr sec, ptr nsec));
static ptr s_set_collect_trip_bytes PROTO((ptr n)); static ptr s_set_collect_trip_bytes PROTO((ptr n));
static void c_exit PROTO((I32 status)); 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 #ifdef PTHREADS
static s_thread_rv_t s_backdoor_thread_start PROTO((void *p)); static s_thread_rv_t s_backdoor_thread_start PROTO((void *p));
static iptr s_backdoor_thread PROTO((ptr 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); 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; ptr t, ls; uptr a, m, n;
require(Scodep(co),"s_get_reloc","~s is not a code object",co); require(Scodep(co),"s_get_reloc","~s is not a code object",co);
if (s_generation(co) == FIX(static_generation))
return Snil;
ls = Snil; ls = Snil;
t = CODERELOC(co); t = CODERELOC(co);
m = RELOCSIZE(t); m = RELOCSIZE(t);
@ -1726,13 +1730,17 @@ static ptr s_get_reloc(co) ptr co; {
a += code_off; a += code_off;
obj = S_get_code_obj(RELOC_TYPE(entry), co, a, item_off); obj = S_get_code_obj(RELOC_TYPE(entry), co, a, item_off);
if (!Sfixnump(obj)) { if (!Sfixnump(obj)) {
ptr x; if (with_offsets) {
for (x = ls; ; x = Scdr(x)) { ls = Scons(Scons(obj, FIX(a-code_data_disp)), ls);
if (x == Snil) { } else {
ls = Scons(obj,ls); ptr x;
break; for (x = ls; ; x = Scdr(x)) {
} else if (Scar(x) == obj) if (x == Snil) {
break; 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 (define get-reloc-objs
(foreign-procedure "(cs)s_get_reloc" (foreign-procedure "(cs)s_get_reloc"
(scheme-object) scheme-object)) (scheme-object boolean) scheme-object))
(module (get-code-src get-code-sexpr) (module (get-code-src get-code-sexpr)
(include "types.ss") (include "types.ss")
@ -2200,13 +2200,15 @@
[name () ($code-name x)] [name () ($code-name x)]
[info () (make-object ($code-info x))] [info () (make-object ($code-info x))]
[free-count () ($code-free-count x)] [free-count () ($code-free-count x)]
[arity-mask () ($code-arity-mask x)]
[source () [source ()
(cond (cond
[(get-code-sexpr x) => make-object] [(get-code-sexpr x) => make-object]
[else #f])] [else #f])]
[source-path () (return-source (get-code-src x))] [source-path () (return-source (get-code-src x))]
[source-object () (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)] [size (g) (compute-size x g)]
[write (p) (write x p)] [write (p) (write x p)]
[print (p) (pretty-print x p)])) [print (p) (pretty-print x p)]))

2
s/syntax.ss
View File

@ -545,7 +545,7 @@
[(clause (,x* ...) ,interface ,body) interface])) [(clause (,x* ...) ,interface ,body) interface]))
clauses)) clauses))
($oops #f "libspec interface mismatch ~s" libspec)) ($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 (define build-call
(lambda (ae e e*) (lambda (ae e e*)