diff --git a/collects/tests/mzscheme/benchmarks/shootout/nbody-vec-generic.ss b/collects/tests/mzscheme/benchmarks/shootout/nbody-vec-generic.ss new file mode 100644 index 0000000000..3829e54cc7 --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/shootout/nbody-vec-generic.ss @@ -0,0 +1,166 @@ +#!/usr/bin/mzscheme -qu +;; The Computer Language Benchmarks Game +;; http://shootout.alioth.debian.org/ +;; +;; Imperative-style implementation based on the SBCL implementation by +;; Patrick Frankenberger and Juho Snellman, but using only native Scheme +;; idioms like 'named let' and 'do' special form. +;; +;; Contributed by Anthony Borla, then converted for mzscheme +;; by Matthew Flatt and Brent Fulgham + +#| +Correct output N = 1000 is + +-0.169075164 +-0.169087605 +|# + +#lang scheme/base +(require scheme/cmdline) + +;; ------------------------------ +;; define planetary masses, initial positions & velocity + +(define +pi+ 3.141592653589793) +(define +days-per-year+ 365.24) + +(define +solar-mass+ (* 4 +pi+ +pi+)) + +(define +dt+ 0.01) + +(define make-body vector) +(define-syntax-rule (deffield n getter setter) + (begin (define (getter b) (vector-ref b n)) + (define (setter b x) (vector-set! b n x)))) +(deffield 0 body-x set-body-x!) +(deffield 1 body-y set-body-y!) +(deffield 2 body-z set-body-z!) +(deffield 3 body-vx set-body-vx!) +(deffield 4 body-vy set-body-vy!) +(deffield 5 body-vz set-body-vz!) +(deffield 6 body-mass set-body-mass!) + +(define *sun* + (make-body 0.0 0.0 0.0 0.0 0.0 0.0 +solar-mass+)) + +(define *jupiter* + (make-body 4.84143144246472090 + -1.16032004402742839 + -1.03622044471123109e-1 + (* 1.66007664274403694e-3 +days-per-year+) + (* 7.69901118419740425e-3 +days-per-year+) + (* -6.90460016972063023e-5 +days-per-year+) + (* 9.54791938424326609e-4 +solar-mass+))) + +(define *saturn* + (make-body 8.34336671824457987 + 4.12479856412430479 + -4.03523417114321381e-1 + (* -2.76742510726862411e-3 +days-per-year+) + (* 4.99852801234917238e-3 +days-per-year+) + (* 2.30417297573763929e-5 +days-per-year+) + (* 2.85885980666130812e-4 +solar-mass+))) + +(define *uranus* + (make-body 1.28943695621391310e1 + -1.51111514016986312e1 + -2.23307578892655734e-1 + (* 2.96460137564761618e-03 +days-per-year+) + (* 2.37847173959480950e-03 +days-per-year+) + (* -2.96589568540237556e-05 +days-per-year+) + (* 4.36624404335156298e-05 +solar-mass+))) + +(define *neptune* + (make-body 1.53796971148509165e+01 + -2.59193146099879641e+01 + 1.79258772950371181e-01 + (* 2.68067772490389322e-03 +days-per-year+) + (* 1.62824170038242295e-03 +days-per-year+) + (* -9.51592254519715870e-05 +days-per-year+) + (* 5.15138902046611451e-05 +solar-mass+))) + +(define *system* (list *sun* *jupiter* *saturn* *uranus* *neptune*)) + +;; ------------------------------- +(define (offset-momentum) + (let loop-i ([i *system*] [px 0.0] [py 0.0] [pz 0.0]) + (if (null? i) + (begin + (set-body-vx! (car *system*) (/ (- px) +solar-mass+)) + (set-body-vy! (car *system*) (/ (- py) +solar-mass+)) + (set-body-vz! (car *system*) (/ (- pz) +solar-mass+))) + (let ([i1 (car i)]) + (loop-i (cdr i) + (+ px (* (body-vx i1) (body-mass i1))) + (+ py (* (body-vy i1) (body-mass i1))) + (+ pz (* (body-vz i1) (body-mass i1)))))))) + +;; ------------------------------- +(define (energy) + (let loop-o ([o *system*] [e 0.0]) + (if (null? o) + e + (let* ([o1 (car o)] + [e (+ e (* 0.5 + (body-mass o1) + (+ (* (body-vx o1) (body-vx o1)) + (* (body-vy o1) (body-vy o1)) + (* (body-vz o1) (body-vz o1)))))]) + (let loop-i ([i (cdr o)] [e e]) + (if (null? i) + (loop-o (cdr o) e) + (let* ([i1 (car i)] + [dx (- (body-x o1) (body-x i1))] + [dy (- (body-y o1) (body-y i1))] + [dz (- (body-z o1) (body-z i1))] + [dist (sqrt (+ (* dx dx) (* dy dy) (* dz dz)))] + [e (- e (/ (* (body-mass o1) (body-mass i1)) dist))]) + (loop-i (cdr i) e)))))))) + +;; ------------------------------- +(define (advance) + (let loop-o ([o *system*]) + (when (pair? o) + (let* ([o1 (car o)] + [o1x (body-x o1)] + [o1y (body-y o1)] + [o1z (body-z o1)] + [om (body-mass o1)]) + (let loop-i ([i (cdr o)] + [vx (body-vx o1)] + [vy (body-vy o1)] + [vz (body-vz o1)]) + (if (pair? i) + (let* ([i1 (car i)] + [dx (- o1x (body-x i1))] + [dy (- o1y (body-y i1))] + [dz (- o1z (body-z i1))] + [dist2 (+ (* dx dx) (* dy dy) (* dz dz))] + [mag (/ +dt+ (* dist2 (sqrt dist2)))] + [dxmag (* dx mag)] + [dymag (* dy mag)] + [dzmag (* dz mag)] + [im (body-mass i1)]) + (set-body-vx! i1 (+ (body-vx i1) (* dxmag om))) + (set-body-vy! i1 (+ (body-vy i1) (* dymag om))) + (set-body-vz! i1 (+ (body-vz i1) (* dzmag om))) + (loop-i (cdr i) + (- vx (* dxmag im)) + (- vy (* dymag im)) + (- vz (* dzmag im)))) + (begin (set-body-vx! o1 vx) + (set-body-vy! o1 vy) + (set-body-vz! o1 vz) + (set-body-x! o1 (+ o1x (* +dt+ vx))) + (set-body-y! o1 (+ o1y (* +dt+ vy))) + (set-body-z! o1 (+ o1z (* +dt+ vz))))))) + (loop-o (cdr o))))) + +;; ------------------------------- + +(let ([n (command-line #:args (n) (string->number n))]) + (offset-momentum) + (printf "~a\n" (real->decimal-string (energy) 9)) + (for ([i (in-range n)]) (advance)) + (printf "~a\n" (real->decimal-string (energy) 9))) diff --git a/collects/tests/mzscheme/benchmarks/shootout/nbody-vec.ss b/collects/tests/mzscheme/benchmarks/shootout/nbody-vec.ss index 3dd3aff859..b89c888698 100644 --- a/collects/tests/mzscheme/benchmarks/shootout/nbody-vec.ss +++ b/collects/tests/mzscheme/benchmarks/shootout/nbody-vec.ss @@ -17,7 +17,8 @@ Correct output N = 1000 is |# #lang scheme/base -(require scheme/cmdline) +(require scheme/cmdline + scheme/flonum) ;; ------------------------------ ;; define planetary masses, initial positions & velocity @@ -29,10 +30,10 @@ Correct output N = 1000 is (define +dt+ 0.01) -(define make-body vector) +(define make-body flvector) (define-syntax-rule (deffield n getter setter) - (begin (define (getter b) (vector-ref b n)) - (define (setter b x) (vector-set! b n x)))) + (begin (define (getter b) (flvector-ref b n)) + (define (setter b x) (flvector-set! b n x)))) (deffield 0 body-x set-body-x!) (deffield 1 body-y set-body-y!) (deffield 2 body-z set-body-z!) @@ -87,14 +88,14 @@ Correct output N = 1000 is (let loop-i ([i *system*] [px 0.0] [py 0.0] [pz 0.0]) (if (null? i) (begin - (set-body-vx! (car *system*) (/ (- px) +solar-mass+)) - (set-body-vy! (car *system*) (/ (- py) +solar-mass+)) - (set-body-vz! (car *system*) (/ (- pz) +solar-mass+))) + (set-body-vx! (car *system*) (fl/ (fl- 0.0 px) +solar-mass+)) + (set-body-vy! (car *system*) (fl/ (fl- 0.0 py) +solar-mass+)) + (set-body-vz! (car *system*) (fl/ (fl- 0.0 pz) +solar-mass+))) (let ([i1 (car i)]) (loop-i (cdr i) - (+ px (* (body-vx i1) (body-mass i1))) - (+ py (* (body-vy i1) (body-mass i1))) - (+ pz (* (body-vz i1) (body-mass i1)))))))) + (fl+ px (fl* (body-vx i1) (body-mass i1))) + (fl+ py (fl* (body-vy i1) (body-mass i1))) + (fl+ pz (fl* (body-vz i1) (body-mass i1)))))))) ;; ------------------------------- (define (energy) @@ -102,19 +103,20 @@ Correct output N = 1000 is (if (null? o) e (let* ([o1 (car o)] - [e (+ e (* (* 0.5 (body-mass o1)) - (+ (+ (* (body-vx o1) (body-vx o1)) - (* (body-vy o1) (body-vy o1))) - (* (body-vz o1) (body-vz o1)))))]) + [e (+ e (fl* 0.5 + (fl* (body-mass o1) + (fl+ (fl+ (fl* (body-vx o1) (body-vx o1)) + (fl* (body-vy o1) (body-vy o1))) + (fl* (body-vz o1) (body-vz o1))))))]) (let loop-i ([i (cdr o)] [e e]) (if (null? i) (loop-o (cdr o) e) (let* ([i1 (car i)] - [dx (- (body-x o1) (body-x i1))] - [dy (- (body-y o1) (body-y i1))] - [dz (- (body-z o1) (body-z i1))] - [dist (sqrt (+ (+ (* dx dx) (* dy dy)) (* dz dz)))] - [e (- e (/ (* (body-mass o1) (body-mass i1)) dist))]) + [dx (fl- (body-x o1) (body-x i1))] + [dy (fl- (body-y o1) (body-y i1))] + [dz (fl- (body-z o1) (body-z i1))] + [dist (flsqrt (fl+ (fl+ (fl* dx dx) (fl* dy dy)) (fl* dz dz)))] + [e (fl- e (fl/ (fl* (body-mass o1) (body-mass i1)) dist))]) (loop-i (cdr i) e)))))))) ;; ------------------------------- @@ -132,28 +134,28 @@ Correct output N = 1000 is [vz (body-vz o1)]) (if (pair? i) (let* ([i1 (car i)] - [dx (- o1x (body-x i1))] - [dy (- o1y (body-y i1))] - [dz (- o1z (body-z i1))] - [dist2 (+ (+ (* dx dx) (* dy dy)) (* dz dz))] - [mag (/ +dt+ (* dist2 (sqrt dist2)))] - [dxmag (* dx mag)] - [dymag (* dy mag)] - [dzmag (* dz mag)] + [dx (fl- o1x (body-x i1))] + [dy (fl- o1y (body-y i1))] + [dz (fl- o1z (body-z i1))] + [dist2 (fl+ (fl+ (fl* dx dx) (fl* dy dy)) (fl* dz dz))] + [mag (fl/ +dt+ (fl* dist2 (flsqrt dist2)))] + [dxmag (fl* dx mag)] + [dymag (fl* dy mag)] + [dzmag (fl* dz mag)] [im (body-mass i1)]) - (set-body-vx! i1 (+ (body-vx i1) (* dxmag om))) - (set-body-vy! i1 (+ (body-vy i1) (* dymag om))) - (set-body-vz! i1 (+ (body-vz i1) (* dzmag om))) + (set-body-vx! i1 (fl+ (body-vx i1) (fl* dxmag om))) + (set-body-vy! i1 (fl+ (body-vy i1) (fl* dymag om))) + (set-body-vz! i1 (fl+ (body-vz i1) (fl* dzmag om))) (loop-i (cdr i) - (- vx (* dxmag im)) - (- vy (* dymag im)) - (- vz (* dzmag im)))) + (fl- vx (fl* dxmag im)) + (fl- vy (fl* dymag im)) + (fl- vz (fl* dzmag im)))) (begin (set-body-vx! o1 vx) (set-body-vy! o1 vy) (set-body-vz! o1 vz) - (set-body-x! o1 (+ o1x (* +dt+ vx))) - (set-body-y! o1 (+ o1y (* +dt+ vy))) - (set-body-z! o1 (+ o1z (* +dt+ vz))))))) + (set-body-x! o1 (fl+ o1x (fl* +dt+ vx))) + (set-body-y! o1 (fl+ o1y (fl* +dt+ vy))) + (set-body-z! o1 (fl+ o1z (fl* +dt+ vz))))))) (loop-o (cdr o))))) ;; ------------------------------- diff --git a/collects/tests/mzscheme/benchmarks/shootout/nbody.ss b/collects/tests/mzscheme/benchmarks/shootout/nbody.ss index 00d98461b2..4f00df5e31 100644 --- a/collects/tests/mzscheme/benchmarks/shootout/nbody.ss +++ b/collects/tests/mzscheme/benchmarks/shootout/nbody.ss @@ -79,14 +79,14 @@ Correct output N = 1000 is (let loop-i ([i *system*] [px 0.0] [py 0.0] [pz 0.0]) (if (null? i) (begin - (set-body-vx! (car *system*) (/ (- px) +solar-mass+)) - (set-body-vy! (car *system*) (/ (- py) +solar-mass+)) - (set-body-vz! (car *system*) (/ (- pz) +solar-mass+))) + (set-body-vx! (car *system*) (fl/ (fl- 0.0 px) +solar-mass+)) + (set-body-vy! (car *system*) (fl/ (fl- 0.0 py) +solar-mass+)) + (set-body-vz! (car *system*) (fl/ (fl- 0.0 pz) +solar-mass+))) (let ([i1 (car i)]) (loop-i (cdr i) - (+ px (* (body-vx i1) (body-mass i1))) - (+ py (* (body-vy i1) (body-mass i1))) - (+ pz (* (body-vz i1) (body-mass i1)))))))) + (fl+ px (fl* (body-vx i1) (body-mass i1))) + (fl+ py (fl* (body-vy i1) (body-mass i1))) + (fl+ pz (fl* (body-vz i1) (body-mass i1)))))))) ;; ------------------------------- (define (energy) diff --git a/collects/tests/mzscheme/benchmarks/shootout/spectralnorm.ss b/collects/tests/mzscheme/benchmarks/shootout/spectralnorm.ss index acb2e0bcf7..7b17629065 100644 --- a/collects/tests/mzscheme/benchmarks/shootout/spectralnorm.ss +++ b/collects/tests/mzscheme/benchmarks/shootout/spectralnorm.ss @@ -9,8 +9,8 @@ scheme/flonum) (define (Approximate n) - (let ([u (make-vector n 1.0)] - [v (make-vector n 0.0)]) + (let ([u (make-flvector n 1.0)] + [v (make-flvector n 0.0)]) ;; 20 steps of the power method (for ([i (in-range 10)]) (MultiplyAtAv n u v) @@ -21,9 +21,9 @@ (let loop ([i 0][vBv 0.0][vv 0.0]) (if (= i n) (flsqrt (fl/ vBv vv)) - (let ([vi (vector-ref v i)]) + (let ([vi (flvector-ref v i)]) (loop (add1 i) - (fl+ vBv (fl* (vector-ref u i) vi)) + (fl+ vBv (fl* (flvector-ref u i) vi)) (fl+ vv (fl* vi vi)))))))) ;; return element i,j of infinite matrix A @@ -35,22 +35,22 @@ ;; multiply vector v by matrix A (define (MultiplyAv n v Av) (for ([i (in-range n)]) - (vector-set! Av i - (for/fold ([r 0.0]) - ([j (in-range n)]) - (fl+ r (fl* (A i j) (vector-ref v j))))))) + (flvector-set! Av i + (for/fold ([r 0.0]) + ([j (in-range n)]) + (fl+ r (fl* (A i j) (flvector-ref v j))))))) ;; multiply vector v by matrix A transposed (define (MultiplyAtv n v Atv) (for ([i (in-range n)]) - (vector-set! Atv i - (for/fold ([r 0.0]) - ([j (in-range n)]) - (fl+ r (fl* (A j i) (vector-ref v j))))))) + (flvector-set! Atv i + (for/fold ([r 0.0]) + ([j (in-range n)]) + (fl+ r (fl* (A j i) (flvector-ref v j))))))) ;; multiply vector v by matrix A and then by matrix A transposed (define (MultiplyAtAv n v AtAv) - (let ([u (make-vector n 0.0)]) + (let ([u (make-flvector n 0.0)]) (MultiplyAv n v u) (MultiplyAtv n u AtAv))) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 2ebda0d5a1..cdf5095077 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -1004,8 +1004,8 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, return 0; } -static int single_valued_noncm_expression(Scheme_Object *expr) -/* Non-omittable but single-values expresions that are not sensitive +static int single_valued_noncm_expression(Scheme_Object *expr, int fuel) +/* Non-omittable but single-valued expresions that are not sensitive to being in tail position. */ { Scheme_Object *rator = NULL; @@ -1022,6 +1022,16 @@ static int single_valued_noncm_expression(Scheme_Object *expr) case scheme_application3_type: rator = ((Scheme_App2_Rec *)expr)->rator; break; + case scheme_compiled_let_void_type: + { + Scheme_Let_Header *lh = (Scheme_Let_Header *)expr; + Scheme_Compiled_Let_Value *clv; + if ((lh->count == 1) && (lh->num_clauses == 1) && (fuel > 0)) { + clv = (Scheme_Compiled_Let_Value *)lh->body; + return single_valued_noncm_expression(clv->body, fuel - 1); + } + } + break; } if (rator && SCHEME_PRIMP(rator)) { @@ -2686,7 +2696,8 @@ static int purely_functional_primitive(Scheme_Object *rator, int n) #define IS_NAMED_PRIM(p, nm) (!strcmp(((Scheme_Primitive_Proc *)p)->name, nm)) -int scheme_wants_flonum_arguments(Scheme_Object *rator, int rotate_mode) +int scheme_wants_flonum_arguments(Scheme_Object *rator, int argpos, int rotate_mode) +/* In rotate mode, we really want to know whether any argument wants to be lifted out. */ { if (SCHEME_PRIMP(rator)) { if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) { @@ -2701,7 +2712,8 @@ int scheme_wants_flonum_arguments(Scheme_Object *rator, int rotate_mode) || IS_NAMED_PRIM(rator, "unsafe-fl=") || IS_NAMED_PRIM(rator, "unsafe-fl>") || IS_NAMED_PRIM(rator, "unsafe-fl>=") - || IS_NAMED_PRIM(rator, "unsafe-flvector-ref")) + || (rotate_mode && IS_NAMED_PRIM(rator, "unsafe-flvector-ref")) + || (rotate_mode && IS_NAMED_PRIM(rator, "unsafe-fx->fl"))) return 1; } else if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNARY_INLINED) { if (!rotate_mode) { @@ -2719,12 +2731,15 @@ int scheme_wants_flonum_arguments(Scheme_Object *rator, int rotate_mode) || IS_NAMED_PRIM(rator, "fl<=") || IS_NAMED_PRIM(rator, "fl=") || IS_NAMED_PRIM(rator, "fl>") - || IS_NAMED_PRIM(rator, "fl>=") - || IS_NAMED_PRIM(rator, "flvector-ref")) + || IS_NAMED_PRIM(rator, "fl>=")) return 1; } } else if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_NARY_INLINED) { - if (IS_NAMED_PRIM(rator, "unsafe-flvector-set!")) + if ((rotate_mode || (argpos == 2)) + && IS_NAMED_PRIM(rator, "unsafe-flvector-set!")) + return 1; + if (!rotate_mode && (argpos == 2) + && IS_NAMED_PRIM(rator, "flvector-set!")) return 1; } } @@ -2732,7 +2747,7 @@ int scheme_wants_flonum_arguments(Scheme_Object *rator, int rotate_mode) return 0; } -static int produces_unboxed(Scheme_Object *rator) +static int produces_unboxed(Scheme_Object *rator, int *non_fl_args) { if (SCHEME_PRIMP(rator)) { if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) { @@ -2746,15 +2761,21 @@ static int produces_unboxed(Scheme_Object *rator) || IS_NAMED_PRIM(rator, "unsafe-fl<=") || IS_NAMED_PRIM(rator, "unsafe-fl=") || IS_NAMED_PRIM(rator, "unsafe-fl>") - || IS_NAMED_PRIM(rator, "unsafe-fl>=") - || IS_NAMED_PRIM(rator, "unsafe-flvector-ref") - || IS_NAMED_PRIM(rator, "unsafe-fx->fl")) + || IS_NAMED_PRIM(rator, "unsafe-fl>=")) return 1; + if (IS_NAMED_PRIM(rator, "unsafe-flvector-ref") + || IS_NAMED_PRIM(rator, "unsafe-fx->fl")) { + if (non_fl_args) *non_fl_args = 1; + return 1; + } } else if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNARY_INLINED) { if (IS_NAMED_PRIM(rator, "flabs") - || IS_NAMED_PRIM(rator, "flsqrt") - || IS_NAMED_PRIM(rator, "->fl")) + || IS_NAMED_PRIM(rator, "flsqrt")) return 1; + if (IS_NAMED_PRIM(rator, "->fl")) { + if (non_fl_args) *non_fl_args = 1; + return 1; + } } else if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_BINARY_INLINED) { if (IS_NAMED_PRIM(rator, "flabs") || IS_NAMED_PRIM(rator, "flsqrt") @@ -2766,9 +2787,12 @@ static int produces_unboxed(Scheme_Object *rator) || IS_NAMED_PRIM(rator, "fl<=") || IS_NAMED_PRIM(rator, "fl=") || IS_NAMED_PRIM(rator, "fl>") - || IS_NAMED_PRIM(rator, "fl>=") - || IS_NAMED_PRIM(rator, "flvector-ref")) + || IS_NAMED_PRIM(rator, "fl>=")) return 1; + if (IS_NAMED_PRIM(rator, "flvector-ref")) { + if (non_fl_args) *non_fl_args = 1; + return 1; + } } } @@ -2792,7 +2816,8 @@ static int is_unboxed_argument(Scheme_Object *rand, int fuel, Optimize_Info *inf case scheme_application_type: { Scheme_App_Rec *app = (Scheme_App_Rec *)rand; - if (produces_unboxed(app->args[0])) { + int non_fl_args = 0; + if (produces_unboxed(app->args[0], &non_fl_args)) { int i; for (i = app->num_args; i--; ) { fuel--; @@ -2806,7 +2831,8 @@ static int is_unboxed_argument(Scheme_Object *rand, int fuel, Optimize_Info *inf case scheme_application2_type: { Scheme_App2_Rec *app = (Scheme_App2_Rec *)rand; - if (produces_unboxed(app->rator)) { + int non_fl_args = 0; + if (produces_unboxed(app->rator, &non_fl_args)) { if (is_unboxed_argument(app->rand, fuel - 1, info, lifted)) return 1; } @@ -2815,7 +2841,8 @@ static int is_unboxed_argument(Scheme_Object *rand, int fuel, Optimize_Info *inf case scheme_application3_type: { Scheme_App3_Rec *app = (Scheme_App3_Rec *)rand; - if (produces_unboxed(app->rator)) { + int non_fl_args = 0; + if (produces_unboxed(app->rator, &non_fl_args)) { if (is_unboxed_argument(app->rand1, fuel - 1, info, lifted) && is_unboxed_argument(app->rand2, fuel - 2, info, lifted)) return 1; @@ -2838,19 +2865,19 @@ int scheme_expr_produces_flonum(Scheme_Object *expr) case scheme_application_type: { Scheme_App_Rec *app = (Scheme_App_Rec *)expr; - return produces_unboxed(app->args[0]); + return produces_unboxed(app->args[0], NULL); } break; case scheme_application2_type: { Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr; - return produces_unboxed(app->rator); + return produces_unboxed(app->rator, NULL); } break; case scheme_application3_type: { Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; - return produces_unboxed(app->rator); + return produces_unboxed(app->rator, NULL); } break; default: @@ -2868,7 +2895,7 @@ static Scheme_Object *check_unbox_rotation(Scheme_Object *_app, Scheme_Object *r Scheme_Compiled_Let_Value *inner = NULL; int i, lifted = 0; - if (scheme_wants_flonum_arguments(rator, 1)) { + if (scheme_wants_flonum_arguments(rator, 0, 1)) { for (i = 0; i < count; i++) { if (count == 1) rand = ((Scheme_App2_Rec *)_app)->rand; @@ -2943,6 +2970,8 @@ static Scheme_Object *check_unbox_rotation(Scheme_Object *_app, Scheme_Object *r flags = (int *)scheme_malloc_atomic(sizeof(int)); flags[0] = (SCHEME_WAS_USED | (1 << SCHEME_USE_COUNT_SHIFT)); + if (scheme_wants_flonum_arguments(rator, i, 0)) + flags[0] |= SCHEME_WAS_FLONUM_ARGUMENT; lv->flags = flags; head->body = (Scheme_Object *)lv; @@ -3017,6 +3046,11 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info if (le) return le; } + + + sub_context = 0; + if ((i > 0) && scheme_wants_flonum_arguments(app->args[0], i - 1, 0)) + sub_context = OPT_CONTEXT_FLONUM_ARG; le = scheme_optimize_expr(app->args[i], info, sub_context); app->args[i] = le; @@ -3028,9 +3062,6 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info if (le) return le; } - - if (scheme_wants_flonum_arguments(app->args[0], 0)) - sub_context |= OPT_CONTEXT_FLONUM_ARG; } if (i && (SCHEME_TYPE(le) < _scheme_compiled_values_types_)) @@ -3134,7 +3165,7 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf return le; } - if (scheme_wants_flonum_arguments(app->rator, 0)) + if (scheme_wants_flonum_arguments(app->rator, 0, 0)) sub_context |= OPT_CONTEXT_FLONUM_ARG; le = scheme_optimize_expr(app->rand, info, sub_context); @@ -3159,7 +3190,7 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf if ((SAME_OBJ(scheme_values_func, app->rator) || SAME_OBJ(scheme_list_star_proc, app->rator)) && (scheme_omittable_expr(app->rand, 1, -1, 0, info) - || single_valued_noncm_expression(app->rand))) { + || single_valued_noncm_expression(app->rand, 5))) { info->preserves_marks = 1; info->single_result = 1; return app->rand; @@ -3206,11 +3237,11 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf return le; } - if (scheme_wants_flonum_arguments(app->rator, 0)) - sub_context |= OPT_CONTEXT_FLONUM_ARG; - /* 1st arg */ + if (scheme_wants_flonum_arguments(app->rator, 0, 0)) + sub_context |= OPT_CONTEXT_FLONUM_ARG; + le = scheme_optimize_expr(app->rand1, info, sub_context); app->rand1 = le; @@ -3219,6 +3250,11 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf /* 2nd arg */ + if (scheme_wants_flonum_arguments(app->rator, 1, 0)) + sub_context |= OPT_CONTEXT_FLONUM_ARG; + else + sub_context &= ~OPT_CONTEXT_FLONUM_ARG; + le = scheme_optimize_expr(app->rand2, info, sub_context); app->rand2 = le; @@ -3674,7 +3710,7 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in if (SAME_TYPE(SCHEME_TYPE(val), scheme_once_used_type)) { Scheme_Once_Used *o = (Scheme_Once_Used *)val; if ((o->vclock == info->vclock) - && single_valued_noncm_expression(o->expr)) { + && single_valued_noncm_expression(o->expr, 5)) { val = scheme_optimize_clone(1, o->expr, info, o->delta, 0); if (val) { info->size -= 1; diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index cd55e9be12..b6024052b5 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -4376,7 +4376,7 @@ static int check_flonum_result(mz_jit_state *jitter, int reg, void *fail_code, S __END_TINY_JUMPS__(1); reffail = _jit.x.pc; - jit_movi_p(JIT_V1, ((Scheme_Primitive_Proc *)rator)->prim_val); + (void)jit_movi_p(JIT_V1, ((Scheme_Primitive_Proc *)rator)->prim_val); (void)jit_calli(fail_code); __START_TINY_JUMPS__(1); diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 8527a0741f..ae80fa6a41 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -2325,7 +2325,7 @@ Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *tl, int flags) void scheme_env_make_closure_map(Optimize_Info *frame, mzshort *size, mzshort **map); int scheme_env_uses_toplevel(Optimize_Info *frame); -int scheme_wants_flonum_arguments(Scheme_Object *rator, int rotate_mode); +int scheme_wants_flonum_arguments(Scheme_Object *rator, int argpos, int rotate_mode); int scheme_expr_produces_flonum(Scheme_Object *expr); typedef struct Scheme_Once_Used { diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index fae1bc9eab..8a420a9e79 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -3854,7 +3854,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type) && (SCHEME_LOCAL_POS(app->rand) == 1)) { if ((SCHEME_TYPE(app->rator) > _scheme_values_types_) - && !scheme_wants_flonum_arguments(app->rator, 1)) { + && !scheme_wants_flonum_arguments(app->rator, 0, 1)) { /* Move to app, and drop let-one: */ app->rand = ((Scheme_Let_One *)body)->value; scheme_reset_app2_eval_type(app);