* Added native support for $fl+, $fl-, $fl*, $fl/

benchmarks.larceny/results.Larceny-r6rs

@@ -6362,3 +6362,63 @@ Words allocated: 151779700
 Words reclaimed: 0
 Elapsed time...: 4619 ms (User: 3127 ms; System: 1452 ms)
 Elapsed GC time: 276 ms (CPU: 252 in 579 collections.)
+
+****************************
+Benchmarking Larceny-r6rs on Thu Jun 14 20:31:38 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
+
+Testing cpstak under Larceny-r6rs
+Compiling...
+Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
+
+
+> 
+> 
+Running...
+Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
+
+
+> 
+Words allocated: 318239872
+Words reclaimed: 0
+Elapsed time...: 1497 ms (User: 1479 ms; System: 10 ms)
+Elapsed GC time: 444 ms (CPU: 436 in 1214 collections.)
+
+****************************
+Benchmarking Larceny-r6rs on Thu Jun 14 20:34:33 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
+
+Testing mbrot under Larceny-r6rs
+Compiling...
+Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
+
+
+> 
+> 
+Running...
+Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
+
+
+> 
+Words allocated: 551809361
+Words reclaimed: 0
+Elapsed time...: 2293 ms (User: 2246 ms; System: 24 ms)
+Elapsed GC time: 781 ms (CPU: 744 in 2105 collections.)
+
+****************************
+Benchmarking Larceny-r6rs on Thu Jun 14 20:38:10 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
+
+Testing mbrot under Larceny-r6rs
+Compiling...
+Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
+
+
+> 
+> 
+Running...
+Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
+
+
+> 
+Words allocated: 551809361
+Words reclaimed: 0
+Elapsed time...: 2272 ms (User: 2241 ms; System: 20 ms)
+Elapsed GC time: 763 ms (CPU: 755 in 2105 collections.)

benchmarks/BUGS

@@ -0,0 +1,42 @@
+* conform needs char-downcase.
+* maze needs bitwise-and
+* ray needs many fl procedures
+* quicksort needs bignum modulo.
+* scheme needs complex? and other stuff.
+* simplex needs flpositive?
+* slatex needs string-ci=?
+* compiler needs string-downcase
+
+* ctak crashes with a bus error.
+* fibc crashes with a segfault.
+* ntakl kinda slow
+* string too slow
+* nbody does not work
+
+* fibfp does not terminate
+* mbrot too slow
+* pnpoly kinda slow
+* sumfp/fpsum too slow
+
+BEFORE:
+  running stats for fibfp:
+      no collections
+      13316 ms elapsed cpu time
+      13984 ms elapsed real time
+      1433313736 bytes allocated
+  running stats for mbrot:
+      12145 collections
+      7608 ms elapsed cpu time
+      7660 ms elapsed real time
+      2215766392 bytes allocated
+  running stats for pnpoly:
+      81 collections
+      2622 ms elapsed cpu time
+      2637 ms elapsed real time
+      335204784 bytes allocated
+  running stats for sumfp:
+      no collections
+      13917 ms elapsed cpu time
+      30995 ms elapsed real time
+      1600160040 bytes allocated
+  

benchmarks/bench.ss

@@ -2,7 +2,7 @@
 
 (import
   (ikarus)
-  (r6rs-benchmarks))
+  #;(r6rs-benchmarks))
 
 (define (run name)
   (eval '(main) (environment (list 'r6rs-benchmarks name))))

benchmarks/r6rs-benchmarks/BUGS

@@ -1,18 +0,0 @@
-* conform needs char-downcase.
-* maze needs bitwise-and
-* ray needs many fl procedures
-* quicksort needs bignum modulo.
-* scheme needs complex? and other stuff.
-* simplex needs flpositive?
-* slatex needs string-ci=?
-* compiler needs string-downcase
-
-* ctak crashes with a bus error.
-* fibc crashes with a segfault.
-* fibfp does not terminate
-* mbrot too slow
-* ntakl kinda slow
-* pnpoly kinda slow
-* sumfp/fpsum too slow
-* string too slow
-* nbody does not work

benchmarks/r6rs-benchmarks/ctak.ss

@@ -6,21 +6,21 @@
   
   (define (ctak x y z)
     (call-with-current-continuation
-     (lambda (k) (ctak-aux k x y z))))
+      (lambda (k) (ctak-aux k x y z))))
   
   (define (ctak-aux k x y z)
     (if (not (< y x))
         (k z)
         (call-with-current-continuation
-         (lambda (k)
+          (lambda (k)
-           (ctak-aux
+            (ctak-aux
-            k
+             k
-            (call-with-current-continuation
+             (call-with-current-continuation
-             (lambda (k) (ctak-aux k (- x 1) y z)))
+               (lambda (k) (ctak-aux k (- x 1) y z)))
-            (call-with-current-continuation
+             (call-with-current-continuation
-             (lambda (k) (ctak-aux k (- y 1) z x)))
+               (lambda (k) (ctak-aux k (- y 1) z x)))
-            (call-with-current-continuation
+             (call-with-current-continuation
-             (lambda (k) (ctak-aux k (- z 1) x y))))))))
+               (lambda (k) (ctak-aux k (- z 1) x y))))))))
   
   (define (main . args)
     (run-benchmark

src/ikarus.intel-assembler.ss

@@ -43,6 +43,14 @@
     [/5    0 5]
     [/6    0 6]
     [/7    0 7]
+    [xmm0 xmm 0]
+    [xmm1 xmm 1]
+    [xmm2 xmm 2]
+    [xmm3 xmm 3]
+    [xmm4 xmm 4]
+    [xmm5 xmm 5]
+    [xmm6 xmm 6]
+    [xmm7 xmm 7]
     ))
   
 (define register-index
@@ -55,14 +63,21 @@
   (lambda (x)
     (cond
       [(assq x register-mapping) =>
-       (lambda (x) (fx= (cadr x) 32))]
+       (lambda (x) (eqv? (cadr x) 32))]
       [else #f])))
 
 (define reg8?
   (lambda (x)
     (cond
       [(assq x register-mapping) =>
-       (lambda (x) (fx= (cadr x) 8))]
+       (lambda (x) (eqv? (cadr x) 8))]
+      [else #f])))
+
+(define xmmreg?
+  (lambda (x)
+    (cond
+      [(assq x register-mapping) =>
+       (lambda (x) (eqv? (cadr x) 'xmm))]
       [else #f])))
 
 (define reg?
@@ -343,7 +358,6 @@
               [else (error 'CODE/digit "unhandled ~s ~s" a0 a1)])))]
       [else (error 'CODE/digit "unhandled ~s" dst)])))
 
-
 (define CODEid
   (lambda (c /? n disp ac)
     (with-args disp
@@ -455,6 +469,33 @@
       [(and (reg8? src) (mem? dst)) (CODErd #x88 src dst ac)]
       [(and (mem? src) (reg8? dst)) (CODErd #x8A dst src ac)]
       [else (error who "invalid ~s" instr)])]
+   [(movsd src dst)
+    (cond
+      [(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
+       (CODE #xF2 (CODE #x0F ((CODE/digit #x10 dst) src ac)))]
+      [(and (xmmreg? src) (or (xmmreg? dst) (mem? dst)))
+       (CODE #xF2 (CODE #x0F ((CODE/digit #x11 src) dst ac)))]
+      [else (error who "invalid ~s" instr)])]
+   [(addsd src dst)
+    (cond
+      [(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
+       (CODE #xF2 (CODE #x0F ((CODE/digit #x58 dst) src ac)))]
+      [else (error who "invalid ~s" instr)])]
+   [(subsd src dst)
+    (cond
+      [(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
+       (CODE #xF2 (CODE #x0F ((CODE/digit #x5C dst) src ac)))]
+      [else (error who "invalid ~s" instr)])]
+   [(mulsd src dst)
+    (cond
+      [(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
+       (CODE #xF2 (CODE #x0F ((CODE/digit #x59 dst) src ac)))]
+      [else (error who "invalid ~s" instr)])] 
+   [(divsd src dst)
+    (cond
+      [(and (xmmreg? dst) (or (xmmreg? src) (mem? src)))
+       (CODE #xF2 (CODE #x0F ((CODE/digit #x5E dst) src ac)))]
+      [else (error who "invalid ~s" instr)])] 
    [(addl src dst)
     (cond   
       [(and (imm8? src) (reg? dst)) 

src/ikarus.numerics.ss

@@ -337,14 +337,17 @@
   (define (ratnum->flonum x) 
     (binary/ (exact->inexact ($ratnum-n x)) 
              (exact->inexact ($ratnum-d x))))
-  (define ($fl+ x y)
+
-    (foreign-call "ikrt_fl_plus" x y))
+  #;
-  (define ($fl- x y)
+  (begin
-    (foreign-call "ikrt_fl_minus" x y))
+    (define ($fl+ x y)
-  (define ($fl* x y)
+      (foreign-call "ikrt_fl_plus" x y))
-    (foreign-call "ikrt_fl_times" x y))
+    (define ($fl- x y)
-  (define ($fl/ x y)
+      (foreign-call "ikrt_fl_minus" x y))
-    (foreign-call "ikrt_fl_div" x y))
+    (define ($fl* x y)
+      (foreign-call "ikrt_fl_times" x y))
+    (define ($fl/ x y)
+      (foreign-call "ikrt_fl_div" x y)))
   
 
 
@@ -440,7 +443,7 @@
             (foreign-call "ikrt_fxbnminus" x y)]
            [(flonum? y)
             (if ($fx= x 0)
-                ($fl* y -1.0)
+                (fl* y -1.0)
                 ($fl- (fixnum->flonum x) y))]
            [(ratnum? y) 
             (let ([n ($ratnum-n y)] [d ($ratnum-d y)])
@@ -880,7 +883,7 @@
        (if ($bignum-positive? x) x (- x))]
       [(flonum? x)
        (if ($flnegative? x) 
-           ($fl* x -1.0)
+           (fl* x -1.0)
            x)]
       [(ratnum? x) 
        (let ([n ($ratnum-n x)])
@@ -1284,7 +1287,7 @@
              (f (fl- ac (car rest)) (cdr rest))))]
       [(x) 
        (if (flonum? x) 
-           ($fl- 0.0 x)
+           (fl- 0.0 x)
            (error 'fl+ "~s is not a flonum" x))]))
 
   (define fl*

src/libaltcogen.ss

@@ -443,6 +443,10 @@
                 (make-asm-instr op
                   (make-disp (car s*) (cadr s*)) 
                   (caddr s*))))]
+         [(fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!) 
+          (S* rands
+              (lambda (s*)
+                (make-asm-instr op (car s*) (cadr s*))))]
          [(nop interrupt) x]
          [else (error 'impose-effect "invalid instr ~s" x)])]
       [(funcall rator rands)
@@ -1394,7 +1398,8 @@
          [(cltd) 
           (mark-reg/vars-conf! edx vs)
           (R s vs (rem-reg edx rs) fs ns)]
-         [(mset bset/c bset/h) 
+         [(mset bset/c bset/h fl:load fl:store fl:add! fl:sub!
+                fl:mul! fl:div!) 
           (R* (list s d) vs rs fs ns)]
          [else (error who "invalid effect op ~s" (unparse x))])]
       [(ntcall target value args mask size)
@@ -1597,7 +1602,8 @@
                  (make-asm-instr op d s)]))]
            [(logand logor logxor int+ int- int* mset bset/c bset/h 
               sll sra srl
-              cltd idiv int-/overflow int+/overflow int*/overflow)
+              cltd idiv int-/overflow int+/overflow int*/overflow
+              fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!)
             (make-asm-instr op (R d) (R s))]
            [(nop) (make-primcall 'nop '())]
            [else (error who "invalid op ~s" op)])]
@@ -1843,7 +1849,7 @@
                   s))
               (set-union (set-union (R eax) (R edx))
                      (set-union (R v) s)))]
-           [(mset)
+           [(mset fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!)
             (set-union (R v) (set-union (R d) s))]
            [else (error who "invalid effect ~s" x)])]
         [(seq e0 e1) (E e0 (E e1 s))]
@@ -2167,6 +2173,14 @@
                         (E (make-asm-instr 'move u s2))
                         (E (make-asm-instr op (make-disp u s1) b))))]
                    [else x]))])]
+           [(fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!) 
+            (cond
+              [(mem? a) 
+               (let ([u (mku)])
+                 (make-seq
+                   (E (make-asm-instr 'move u a))
+                   (E (make-asm-instr op u b))))]
+              [else x])]
            [else (error who "invalid effect ~s" op)])]
         [(primcall op rands) 
          (case op
@@ -2437,6 +2451,18 @@
             (list* `(addl ,(R s) ,(R d)) 
                    `(jo ,L)
                    ac))]
+         [(fl:store) 
+          (cons `(movsd xmm0 ,(R (make-disp s d))) ac)]
+         [(fl:load) 
+          (cons `(movsd ,(R (make-disp s d)) xmm0) ac)]
+         [(fl:add!) 
+          (cons `(addsd ,(R (make-disp s d)) xmm0) ac)]
+         [(fl:sub!) 
+          (cons `(subsd ,(R (make-disp s d)) xmm0) ac)]
+         [(fl:mul!) 
+          (cons `(mulsd ,(R (make-disp s d)) xmm0) ac)]
+         [(fl:div!) 
+          (cons `(divsd ,(R (make-disp s d)) xmm0) ac)]
          [else (error who "invalid instr ~s" x)])]
       [(primcall op rands)
        (case op

src/makefile.ss

@@ -603,6 +603,10 @@
     [$flonum-signed-biased-exponent $flonums]
     [$flonum-rational?              $flonums]
     [$flonum-integer?               $flonums]
+    [$fl+                           $flonums]
+    [$fl-                           $flonums]
+    [$fl*                           $flonums]
+    [$fl/                           $flonums]
 
     [$make-bignum       $bignums]
     [$bignum-positive?  $bignums]

src/pass-specify-rep-primops.ss

@@ -721,6 +721,14 @@
 
 (section ;;; flonums
 
+(define ($flop-aux op fl0 fl1)
+  (with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
+     (prm 'mset x (K (- vector-tag)) (K flonum-tag))
+     (prm 'fl:load (T fl0) (K (- disp-flonum-data vector-tag)))
+     (prm op (T fl1) (K (- disp-flonum-data vector-tag)))
+     (prm 'fl:store x (K (- disp-flonum-data vector-tag)))
+     x))
+
 (define-primop flonum? safe
   [(P x) (sec-tag-test (T x) vector-mask vector-tag #f flonum-tag)]
   [(E x) (nop)])
@@ -760,6 +768,14 @@
             (prm 'sll (T v) (K (- 8 fx-shift))))]
      [else (interrupt)])])
 
+(define-primop $fl+ unsafe
+  [(V x y) ($flop-aux 'fl:add! x y)])
+(define-primop $fl- unsafe
+  [(V x y) ($flop-aux 'fl:sub! x y)])
+(define-primop $fl* unsafe
+  [(V x y) ($flop-aux 'fl:mul! x y)])
+(define-primop $fl/ unsafe
+  [(V x y) ($flop-aux 'fl:div! x y)])
 
 /section)