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

futures: fix bug related to tail calls

Browse Source
This commit is contained in:
Matthew Flatt 2012-05-30 16:15:32 -06:00
parent 5461783076
commit e8645598d7
3 changed files with 32 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/tests/future/tail-apply.rkt Normal file
View File

@ -0,0 +1,29 @@
#lang racket
;; When run by itself, this example triggers a use of
;; _scheme_tail_apply_from_native_fixup_args().
(define (filt pred vs)
(if (empty? vs)
'()
(let ([v (car vs)])
(if (pred v)
(cons v (filt pred (cdr vs)))
(filt pred (cdr vs))))))
(define (qsort2-par vs)
(flatten (qsort2-par/private vs)))
(define (qsort2-par/private vs)
(if (or (null? vs) (null? (cdr vs)))
vs
(let* ([p-i 0]
[p (list-ref vs p-i)]
[lf (future (λ () (qsort2-par/private (filt (λ (v) (v . < . p)) vs))))]
[ef (future (λ () (filt (λ (v) (= v p)) vs)))]
[gf (future (λ () (qsort2-par/private (filt (λ (v) (v . > . p)) vs))))])
(list (touch lf) (touch ef) (touch gf)))))
(define l (build-list 10000 (λ (x) (random 2000))))
(void (qsort2-par l))

1
src/racket/src/jit_ts.c
View File

@ -130,7 +130,6 @@ define_ts_s_s(scheme_box, FSRC_OTHER)
# define ts__scheme_apply_multi_from_native _scheme_apply_multi_from_native
# define ts__scheme_apply_from_native _scheme_apply_from_native
# define ts__scheme_tail_apply_from_native _scheme_tail_apply_from_native
# define ts__scheme_tail_apply_from_native_fixup_args _scheme_tail_apply_from_native_fixup_args
# define ts_scheme_force_value_same_mark scheme_force_value_same_mark
# define ts_scheme_force_one_value_same_mark scheme_force_one_value_same_mark
# define ts_scheme_force_value_same_mark scheme_force_value_same_mark

4
src/racket/src/jitcall.c
View File

@ -152,6 +152,7 @@ Scheme_Object *scheme_ts_scheme_force_value_same_mark(Scheme_Object *v)
static Scheme_Object *_scheme_tail_apply_from_native_fixup_args(Scheme_Object *rator,
int argc,
Scheme_Object **argv)
XFORM_SKIP_PROC
{
int already = fixup_already_in_place, i;
Scheme_Object **base;
@ -455,7 +456,8 @@ int scheme_generate_finish_tail_call(mz_jit_state *jitter, int direct_native)
jit_pusharg_i(JIT_R0);
jit_pusharg_p(JIT_V1);
if (direct_native > 1) { /* => some_args_already_in_place */
(void)mz_finish(_scheme_tail_apply_from_native_fixup_args);
GC_CAN_IGNORE jit_insn *refr;
(void)mz_finish_lwe(_scheme_tail_apply_from_native_fixup_args, refr);
} else {
GC_CAN_IGNORE jit_insn *refr;
(void)mz_finish_lwe(ts__scheme_tail_apply_from_native, refr);