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

safe-for-space repairs for functions with rest args

Browse Source
This commit is contained in:
Matthew Flatt 2011-04-22 14:42:57 -06:00
parent f4307c65a7
commit 0754ad0114
11 changed files with 111 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/compiler/decompile.rkt
View File

@ -307,6 +307,7 @@
,@(if (and name (not (null? name)))
`(',name)
null)
,@(if (null? flags) null `('(flags: ,@flags)))
,@(if (null? captures)
null
`('(captures: ,@(map (lambda (c t)

2
collects/compiler/zo-marshal.rkt
View File

@ -257,6 +257,7 @@
(define CLOS_HAS_REST 1)
(define CLOS_HAS_REF_ARGS 2)
(define CLOS_PRESERVES_MARKS 4)
(define CLOS_NEED_REST_CLEAR 8)
(define CLOS_IS_METHOD 16)
(define CLOS_SINGLE_RESULT 32)
@ -1006,6 +1007,7 @@
(+ (if rest? CLOS_HAS_REST 0)
(if any-refs? CLOS_HAS_REF_ARGS 0)
(if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0)
(if (memq 'sfs-clear-rest-args flags) CLOS_NEED_REST_CLEAR 0)
(if (memq 'is-method flags) CLOS_IS_METHOD 0)
(if (memq 'single-result flags) CLOS_SINGLE_RESULT 0))
num-all-params

2
collects/compiler/zo-parse.rkt
View File

@ -81,6 +81,7 @@
(define CLOS_HAS_REST 1)
(define CLOS_HAS_REF_ARGS 2)
(define CLOS_PRESERVES_MARKS 4)
(define CLOS_NEED_REST_CLEAR 8)
(define CLOS_IS_METHOD 16)
(define CLOS_SINGLE_RESULT 32)
(define BITS_PER_MZSHORT 32)
@ -118,6 +119,7 @@
(if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks))
(if (zero? (bitwise-and flags flags CLOS_IS_METHOD)) null '(is-method))
(if (zero? (bitwise-and flags flags CLOS_SINGLE_RESULT)) null '(single-result))
(if (zero? (bitwise-and flags flags CLOS_NEED_REST_CLEAR)) null '(sfs-clear-rest-args))
(if (and rest? (zero? num-params)) '(only-rest-arg-not-used) null))
(if (and rest? (num-params . > . 0))
(sub1 num-params)

3
collects/compiler/zo-structs.rkt
View File

@ -131,7 +131,8 @@
[internal-context (or/c #f #t stx?)]))
(define-form-struct (lam expr) ([name (or/c symbol? vector? empty?)]
[flags (listof (or/c 'preserves-marks 'is-method 'single-result 'only-rest-arg-not-used))]
[flags (listof (or/c 'preserves-marks 'is-method 'single-result
'only-rest-arg-not-used 'sfs-clear-rest-args))]
[num-params exact-nonnegative-integer?]
[param-types (listof (or/c 'val 'ref 'flonum))]
[rest? boolean?]

3
collects/scribblings/raco/zo-parse.scrbl
View File

@ -271,7 +271,8 @@
@defstruct+[(lam expr)
([name (or/c symbol? vector?)]
[flags (listof (or/c 'preserves-marks 'is-method 'single-result 'only-rest-arg-not-used))]
[flags (listof (or/c 'preserves-marks 'is-method 'single-result
'only-rest-arg-not-used 'sfs-clear-rest-args))]
[num-params exact-nonnegative-integer?]
[param-types (listof (or/c 'val 'ref 'flonum))]
[rest? boolean?]

23
src/racket/src/eval.c
View File

@ -8626,6 +8626,27 @@ static Scheme_Object *do_eval_k(void)
p->ku.k.i2);
}
#ifdef MZ_USE_JIT
static Scheme_Object *do_eval_native_k(void)
{
/* If argv corresponds to old runstack, copy to new runstack
and clear old argv for space safety. */
Scheme_Thread *p = scheme_current_thread;
Scheme_Object **argv = (Scheme_Object **)p->ku.k.p2;
if (argv == (p->runstack_saved->runstack_start
+ p->runstack_saved->runstack_offset)) {
int argc = p->ku.k.i1;
MZ_RUNSTACK -= argc;
memcpy(MZ_RUNSTACK, argv, argc * sizeof(Scheme_Object*));
memset(argv, 0, argc * sizeof(Scheme_Object*));
p->ku.k.p2 = MZ_RUNSTACK;
}
return do_eval_k();
}
#endif
static void unbound_global(Scheme_Object *obj)
{
Scheme_Object *tmp;
@ -9519,7 +9540,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
MZ_CONT_MARK_POS -= 2;
v = (Scheme_Object *)scheme_enlarge_runstack(data->max_let_depth / sizeof(void *),
(void *(*)(void))do_eval_k);
(void *(*)(void))do_eval_native_k);
MZ_CONT_MARK_POS += 2;
goto returnv;
}

3
src/racket/src/fun.c
View File

@ -1325,6 +1325,9 @@ Scheme_Object *scheme_sfs_closure(Scheme_Object *expr, SFS_Info *info, int self_
if (SCHEME_PAIRP(clears))
code = scheme_sfs_add_clears(code, clears, 1);
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)
SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_NEED_REST_CLEAR;
}
data->code = code;

88
src/racket/src/jit.c
View File

@ -99,6 +99,16 @@ static void wrong_argument_count(Scheme_Object *proc, int argc, Scheme_Object **
scheme_wrong_count((char *)proc, -1, -1, argc, argv);
}
static Scheme_Object *clear_rs_arguments(Scheme_Object *v, int size, int delta) XFORM_SKIP_PROC
{
int i;
Scheme_Object **argv = MZ_RUNSTACK;
for (i = size; i-- > delta; ) {
argv[i] = NULL;
}
return v;
}
#ifdef JIT_THREAD_LOCAL
void *scheme_jit_get_threadlocal_table() XFORM_SKIP_PROC { return &BOTTOM_VARIABLE; }
#endif
@ -2856,28 +2866,20 @@ static int generate_function_getarg(mz_jit_state *jitter, int has_rest, int num_
{
int i, cnt;
GC_CAN_IGNORE jit_insn *ref;
int set_ref;
/* If rands == runstack and there are no rest args, set runstack
base to runstack + rands (and don't copy rands), otherwise set
base to runstack and proceed normally. Implement this by
optimistically assuming rands == runstack, so that there's just
one jump. Skip this optimization when the procedure has
rest args, because we'll have to copy anyway. */
if (!has_rest && num_params) {
jit_lshi_l(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_R1, JIT_LOG_WORD_SIZE);
jit_addr_p(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_R2, JIT_RUNSTACK_BASE_OR_ALT(JIT_V1));
/* If rands == runstack, set runstack base to runstack + rands (and
don't copy rands), otherwise set base to runstack and copy
arguments at runstack. Implement the test by optimistically
assuming rands == runstack, so that there's just one jump. */
jit_lshi_l(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_R1, JIT_LOG_WORD_SIZE);
jit_addr_p(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_R2, JIT_RUNSTACK_BASE_OR_ALT(JIT_V1));
#ifndef JIT_RUNSTACK_BASE
mz_set_local_p(JIT_V1, JIT_RUNSTACK_BASE_LOCAL);
mz_set_local_p(JIT_V1, JIT_RUNSTACK_BASE_LOCAL);
#endif
__START_TINY_OR_SHORT_JUMPS__(num_params < 10, num_params < 100);
ref = jit_beqr_p(jit_forward(), JIT_RUNSTACK, JIT_R2);
__END_TINY_OR_SHORT_JUMPS__(num_params < 10, num_params < 100);
set_ref = 1;
} else {
ref = 0;
set_ref = 0;
}
__START_TINY_OR_SHORT_JUMPS__(num_params < 10, num_params < 100);
ref = jit_beqr_p(jit_forward(), JIT_RUNSTACK, JIT_R2);
__END_TINY_OR_SHORT_JUMPS__(num_params < 10, num_params < 100);
#ifdef JIT_RUNSTACK_BASE
jit_movr_p(JIT_RUNSTACK_BASE, JIT_RUNSTACK);
#else
@ -2901,11 +2903,9 @@ static int generate_function_getarg(mz_jit_state *jitter, int has_rest, int num_
CHECK_LIMIT();
}
if (set_ref) {
__START_TINY_OR_SHORT_JUMPS__(num_params < 10, num_params < 100);
mz_patch_branch(ref);
__END_TINY_OR_SHORT_JUMPS__(num_params < 10, num_params < 100);
}
__START_TINY_OR_SHORT_JUMPS__(num_params < 10, num_params < 100);
mz_patch_branch(ref);
__END_TINY_OR_SHORT_JUMPS__(num_params < 10, num_params < 100);
return cnt;
}
@ -2943,6 +2943,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
cnt = generate_function_getarg(jitter,
(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST),
data->num_params);
/* At this point, all non-rest arguments are now at the runstack */
CHECK_LIMIT();
/* A tail call with arity checking can start here.
@ -2980,7 +2981,8 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
tail_code = jit_get_ip().ptr;
/* 0 params and has_rest => (lambda args E) where args is not in E,
so accept any number of arguments and ignore them. */
so accept any number of arguments and just clear them (for space
safety). */
if (has_rest && data->num_params) {
/* If runstack == argv and argc == cnt, then we didn't
@ -2998,6 +3000,8 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
for (i = cnt; i--; ) {
jit_ldxi_p(JIT_V1, JIT_R2, WORDS_TO_BYTES(i));
jit_stxi_p(WORDS_TO_BYTES(i), JIT_RUNSTACK, JIT_V1);
/* space safety: */
jit_stxi_p(WORDS_TO_BYTES(i), JIT_R2, JIT_RUNSTACK);
CHECK_LIMIT();
}
(void)jit_movi_p(JIT_V1, scheme_null);
@ -3008,6 +3012,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
/* Build a list for extra arguments: */
mz_patch_branch(ref);
mz_patch_branch(ref3);
CHECK_LIMIT();
#ifndef JIT_PRECISE_GC
if (data->closure_size)
#endif
@ -3017,8 +3022,17 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
}
JIT_UPDATE_THREAD_RSPTR();
CHECK_LIMIT();
mz_prepare(3);
jit_movi_i(JIT_V1, cnt);
if ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_NEED_REST_CLEAR)) {
/* negative count => clear argv */
GC_CAN_IGNORE jit_insn *ref;
__START_INNER_TINY__(cnt < 100);
ref = jit_bner_p(jit_forward(), JIT_RUNSTACK, JIT_R2);
jit_negr_i(JIT_R1, JIT_R1);
mz_patch_branch(ref);
__END_INNER_TINY__(cnt < 100);
}
mz_prepare(3);
jit_pusharg_i(JIT_V1);
jit_pusharg_p(JIT_R2);
jit_pusharg_i(JIT_R1);
@ -3034,7 +3048,6 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
}
jit_stxi_p(WORDS_TO_BYTES(cnt), JIT_RUNSTACK, JIT_V1);
mz_patch_ucbranch(ref2); /* jump here if we copied and produced null */
CHECK_LIMIT();
__END_SHORT_JUMPS__(cnt < 100);
@ -3044,6 +3057,27 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
argc = 0;
}
} else {
if (has_rest && (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_NEED_REST_CLEAR)) {
/* if we get here, the rest argument isn't used */
GC_CAN_IGNORE jit_insn *ref;
__START_TINY_JUMPS__(1);
ref = jit_bner_p(jit_forward(), JIT_RUNSTACK, JIT_R2);
__END_TINY_JUMPS__(1);
mz_rs_sync();
JIT_UPDATE_THREAD_RSPTR();
CHECK_LIMIT();
mz_prepare(3);
jit_movi_i(JIT_V1, cnt);
jit_pusharg_i(JIT_V1);
jit_pusharg_i(JIT_R1);
jit_pusharg_p(JIT_R0);
CHECK_LIMIT();
(void)mz_finish(clear_rs_arguments);
jit_retval(JIT_R0);
__START_TINY_JUMPS__(1);
mz_patch_branch(ref);
__END_TINY_JUMPS__(1);
}
has_rest = 0;
if (argc != data->num_params) {
argv = NULL;

3
src/racket/src/jitinline.c
View File

@ -2976,9 +2976,8 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
}
int scheme_generate_cons_alloc(mz_jit_state *jitter, int rev, int inline_retry)
/* Args must be in R0 (car) and R1 (cdr); uses R2 and V1 as temporaries */
{
/* Args should be in R0 (car) and R1 (cdr) */
#ifdef CAN_INLINE_ALLOC
/* Inlined alloc */
scheme_inline_alloc(jitter, sizeof(Scheme_Simple_Object), scheme_pair_type, 0, 1, 0, inline_retry);

14
src/racket/src/list.c
View File

@ -848,12 +848,22 @@ Scheme_Object *scheme_build_list(int size, Scheme_Object **argv)
}
Scheme_Object *scheme_build_list_offset(int size, Scheme_Object **argv, int delta)
/* clears originals in argv for space safety! */
{
Scheme_Object *pair = scheme_null;
int i;
for (i = size; i-- > delta; ) {
pair = cons(argv[i], pair);
if (size < 0) {
/* clearing mode: */
size = -size;
for (i = size; i-- > delta; ) {
pair = cons(argv[i], pair);
argv[i] = NULL;
}
} else {
for (i = size; i-- > delta; ) {
pair = cons(argv[i], pair);
}
}
return pair;

3
src/racket/src/schpriv.h
View File

@ -2088,10 +2088,11 @@ typedef struct Scheme_Comp_Env
#define CLOS_HAS_REST 1
#define CLOS_HAS_TYPED_ARGS 2
#define CLOS_PRESERVES_MARKS 4
#define CLOS_SFS 8
#define CLOS_NEED_REST_CLEAR 8
#define CLOS_IS_METHOD 16
#define CLOS_SINGLE_RESULT 32
#define CLOS_RESULT_TENTATIVE 64
#define CLOS_SFS 128
#define CLOS_VALIDATED 128
/* BITS 8-15 used by write_compiled_closure() */