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

fix another(!) JIT bug related to the runstack pointer and GC --- this time when a jump to a native function has the wrong arity; more certificate-management shortcuts to avoid explosion of work for long expansion chains; changed scheme/base module-begin to not create long expansion chais in the first place

Browse Source 
svn: r8880
This commit is contained in:
Matthew Flatt 2008-03-04 19:41:21 +00:00
parent c51b8f1b1b
commit 944770a4d1
3 changed files with 57 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
collects/scheme/private/modbeg.ss
View File

@ -23,13 +23,22 @@
"bad syntax"
stx)
(void))
(datum->syntax
stx
(list (quote-syntax #%module-begin)
(cons (quote-syntax printing-module-begin)
(cdr (syntax-e stx))))
stx
stx)))
(let-values ([(l) (syntax->list stx)])
(if l
(void)
(raise-syntax-error
#f
"bad syntax (illegal use of `.')"
stx))
(datum->syntax
stx
(cons (quote-syntax #%module-begin)
(map (lambda (e)
(list (quote-syntax printing-module-begin)
e))
(cdr l)))
stx
stx))))
(define-syntaxes (printing-module-begin)
(lambda (stx)
@ -65,15 +74,18 @@
#f)
#f))
;; splice `begin'
(datum->syntax
stx
(cons (quote-syntax printing-module-begin)
(append (let-values ([(l) (syntax->list e)])
(map (lambda (elem)
(syntax-track-origin elem e (car l)))
(cdr l)))
(cdr r)))
stx)
(let-values ([(l) (syntax->list e)])
(datum->syntax
stx
(cons (car l)
(append
(map (lambda (elem)
(list
(quote-syntax printing-module-begin)
(syntax-track-origin elem e (car l))))
(cdr l))
(cdr r)))
stx))
;; no need to splice
(let-values ([(wrap?)
(let-values ([(e) (syntax-e e)])

8
src/mzscheme/src/jit.c
View File

@ -1638,6 +1638,10 @@ static int generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_na
mz_get_local_p(JIT_R1, JIT_LOCAL2);
}
jit_movr_p(JIT_R2, JIT_RUNSTACK);
if (need_set_rs) {
/* In case arity check fails, need to update runstack now: */
JIT_UPDATE_THREAD_RSPTR();
}
/* Now jump: */
jit_jmpr(JIT_V1);
CHECK_LIMIT();
@ -1885,6 +1889,10 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc
jit_ldxi_p(JIT_V1, JIT_V1, &((Scheme_Native_Closure_Data *)0x0)->u.tail_code);
} else {
jit_ldxi_p(JIT_V1, JIT_V1, &((Scheme_Native_Closure_Data *)0x0)->arity_code);
if (need_set_rs) {
/* In case arity check fails, need to update runstack now: */
JIT_UPDATE_THREAD_RSPTR();
}
}
jit_jmpr(JIT_V1); /* callee restores (copied) V registers, etc. */
jit_patch_movi(refr, (_jit.x.pc));

23
src/mzscheme/src/stxobj.c
View File

@ -2300,7 +2300,7 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj
Scheme_Cert *orig_certs, *cl, *now_certs, *next_certs;
Scheme_Stx *stx = (Scheme_Stx *)o, *res;
Scheme_Object *pr;
int copy_on_write;
int copy_on_write, shortcut;
if (!stx->certs) {
if (!certs)
@ -2337,6 +2337,25 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj
orig_certs = INACTIVE_CERTS(stx);
now_certs = orig_certs;
shortcut = 0;
if (now_certs && certs && !use_key && CERT_NO_KEY(certs)) {
if (now_certs->depth < certs->depth) {
/* Maybe we can add now_certs onto certs, instead of the other
way around. */
for (next_certs = certs; next_certs; next_certs = next_certs->next) {
if (cert_in_chain(next_certs->mark, use_key, now_certs)) {
break;
}
}
if (!next_certs) {
/* Yes, we can take that shortcut. */
certs = append_certs(now_certs, certs);
now_certs = NULL;
shortcut = 1;
}
}
}
for (; certs; certs = next_certs) {
next_certs = certs->next;
if (!cert_in_chain(certs->mark, use_key, now_certs)) {
@ -2357,7 +2376,7 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj
stx = res;
copy_on_write = 0;
}
if (!now_certs && !use_key && CERT_NO_KEY(certs)) {
if (!now_certs && !use_key && (shortcut || CERT_NO_KEY(certs))) {
cl = certs;
next_certs = NULL;
} else {