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

compiler flonum tweaks

Browse Source 
svn: r17349
This commit is contained in:
Matthew Flatt 2009-12-18 16:59:05 +00:00
parent fdd7122994
commit 9192f073d0
8 changed files with 293 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

166
collects/tests/mzscheme/benchmarks/shootout/nbody-vec-generic.ss Normal file
View File

@ -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)))

74
collects/tests/mzscheme/benchmarks/shootout/nbody-vec.ss
View File

@ -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)))))
;; -------------------------------

12
collects/tests/mzscheme/benchmarks/shootout/nbody.ss
View File

@ -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)

26
collects/tests/mzscheme/benchmarks/shootout/spectralnorm.ss
View File

@ -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)))

98
src/mzscheme/src/eval.c
View File

@ -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;

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

@ -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);

2
src/mzscheme/src/schpriv.h
View File

@ -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 {

2
src/mzscheme/src/syntax.c
View File

@ -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 <expr> to app, and drop let-one: */
app->rand = ((Scheme_Let_One *)body)->value;
scheme_reset_app2_eval_type(app);