~ chicken-core (chicken-5) a1a5e4b8c7de7ceb861871e28e353ac4e55900d8
commit a1a5e4b8c7de7ceb861871e28e353ac4e55900d8
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Dec 4 20:21:42 2009 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Dec 4 20:21:42 2009 +0100
fp-op rewrites, new srfi-4 test, much better implementation of fvector access
diff --git a/c-platform.scm b/c-platform.scm
index d415a2d8..215acb88 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -129,7 +129,8 @@
'(bitwise-and bitwise-ior bitwise-xor bitwise-not add1 sub1 fx+ fx- fx* fx/ fxmod o
fx= fx> fx< fx>= fx<= fixnum? fxneg fxmax fxmin identity fp+ fp- fp* fp/ fpmin fpmax fpneg
fp> fp< fp= fp>= fp<= fxand fxnot fxior fxxor fxshr fxshl bit-set?
- fpfloor fpceiling fptruncate fpround
+ fpfloor fpceiling fptruncate fpround fpsin fpcos fptan fpasin fpacos fpatan
+ fpatan2 fpexp fpexpt fplog fpsqrt
arithmetic-shift void flush-output thread-specific thread-specific-set!
not-pair? atom? null-list? print print* error cpu-time proper-list? call/cc
blob-size u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared
@@ -144,7 +145,7 @@
u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length
f32vector-length f64vector-length setter
u8vector-ref s8vector-ref u16vector-ref s16vector-ref u32vector-ref s32vector-ref
- f32vector-ref f64vector-ref
+ f32vector-ref f64vector-ref f32vector-set! f64vector-set!
u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set!
locative-ref locative-set! locative->object locative? global-ref
null-pointer? pointer->object flonum? finite?
@@ -185,6 +186,7 @@
##sys#byte ##sys#setbyte
u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length
f32vector-length f64vector-length ##sys#apply-values ##sys#setter setter
+ f32vector-set! f64vector-set!
u8vector-ref s8vector-ref u16vector-ref s16vector-ref u32vector-ref s32vector-ref
u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set!
##sys#intern-symbol ##sys#make-symbol make-record-instance error cpu-time ##sys#block-set!) )
@@ -788,6 +790,18 @@
(rewrite 'truncate 15 'flonum 'fixnum 'fptruncate #f)
(rewrite 'round 15 'flonum 'fixnum 'fpround #f)
+(rewrite 'fpsin 16 1 "C_a_i_flonum_sin" #f words-per-flonum)
+(rewrite 'fpcos 16 1 "C_a_i_flonum_cos" #f words-per-flonum)
+(rewrite 'fptan 16 1 "C_a_i_flonum_tan" #f words-per-flonum)
+(rewrite 'fpasin 16 1 "C_a_i_flonum_asin" #f words-per-flonum)
+(rewrite 'fpacos 16 1 "C_a_i_flonum_acos" #f words-per-flonum)
+(rewrite 'fpatan 16 1 "C_a_i_flonum_atan" #f words-per-flonum)
+(rewrite 'fpatan2 16 2 "C_a_i_flonum_atan2" #f words-per-flonum)
+(rewrite 'fpexp 16 1 "C_a_i_flonum_exp" #f words-per-flonum)
+(rewrite 'fpexpt 16 2 "C_a_i_flonum_expt" #f words-per-flonum)
+(rewrite 'fplog 16 1 "C_a_i_flonum_log" #f words-per-flonum)
+(rewrite 'fpsqrt 16 1 "C_a_i_flonum_sqrt" #f words-per-flonum)
+
(rewrite 'cons 16 2 "C_a_i_cons" #t 3)
(rewrite '##sys#cons 16 2 "C_a_i_cons" #t 3)
(rewrite 'list 16 #f "C_a_i_list" #t '(3))
@@ -903,6 +917,8 @@
(rewrite 's16vector-set! 2 3 "C_u_i_s16vector_set" #f #f)
(rewrite 'u32vector-set! 2 3 "C_u_i_u32vector_set" #f #f)
(rewrite 's32vector-set! 2 3 "C_u_i_s32vector_set" #f #f)
+(rewrite 'f32vector-set! 2 3 "C_u_i_f32vector_set" #f #f)
+(rewrite 'f64vector-set! 2 3 "C_u_i_f64vector_set" #f #f)
(rewrite 'u8vector-length 2 1 "C_u_i_8vector_length" #f #f)
(rewrite 's8vector-length 2 1 "C_u_i_8vector_length" #f #f)
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index dfecdb9b..b7ad3133 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -151,22 +151,22 @@
(##sys#extend-macro-environment
'assert '()
(##sys#er-transformer
- (lambda (form r c)
- (##sys#check-syntax 'assert form '#(_ 1))
- (let* ((exp (cadr form))
- (msg-and-args (cddr form))
- (%if (r 'if))
- (%quote (r 'quote))
- (msg (if (eq? '() msg-and-args)
- `(##core#immutable '"assertion failed")
- (car msg-and-args) ) ) )
- `(,%if (##core#check ,exp)
- (##core#undefined)
- (##sys#error
- ,msg
- ,@(if (fx> (length msg-and-args) 1)
- (cdr msg-and-args)
- '() ) ) ) ) )) )
+ (lambda (form r c)
+ (##sys#check-syntax 'assert form '#(_ 1))
+ (let* ((exp (cadr form))
+ (msg-and-args (cddr form))
+ (%if (r 'if))
+ (%quote (r 'quote))
+ (msg (if (eq? '() msg-and-args)
+ `(##core#immutable '"assertion failed")
+ (car msg-and-args) ) ) )
+ `(,%if (##core#check ,exp)
+ (##core#undefined)
+ (##sys#error
+ ,msg
+ ,@(if (fx> (length msg-and-args) 1)
+ (cdr msg-and-args)
+ `((,%quote ,(##sys#strip-syntax exp))))))))))
(##sys#extend-macro-environment
'ensure
diff --git a/chicken.h b/chicken.h
index 1c6e2597..716aa58e 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1277,8 +1277,10 @@ extern double trunc(double);
#define C_a_i_flonum_floor(ptr, n, x) C_flonum(ptr, C_floor(C_flonum_magnitude(x)))
#define C_a_i_flonum_round(ptr, n, x) C_flonum(ptr, C_round(C_flonum_magnitude(x)))
-#define C_a_i_f32vector_ref(ptr, n, b, i) C_flonum(ptr, ((float *)C_data_pointer(b))[ C_unfix(i) ])
-#define C_a_i_f64vector_ref(ptr, n, b, i) C_flonum(ptr, ((double *)C_data_pointer(b))[ C_unfix(i) ])
+#define C_a_i_f32vector_ref(ptr, n, b, i) C_flonum(ptr, ((float *)C_data_pointer(C_block_item((b), 1)))[ C_unfix(i) ])
+#define C_a_i_f64vector_ref(ptr, n, b, i) C_flonum(ptr, ((double *)C_data_pointer(C_block_item((b), 1)))[ C_unfix(i) ])
+#define C_u_i_f32vector_set(v, i, x) ((((float *)C_data_pointer(C_block_item((v), 1)))[ C_unfix(i) ] = C_flonum_magnitude(x)), C_SCHEME_UNDEFINED)
+#define C_u_i_f64vector_set(v, i, x) ((((double *)C_data_pointer(C_block_item((v), 1)))[ C_unfix(i) ] = C_flonum_magnitude(x)), C_SCHEME_UNDEFINED)
#define C_a_i_flonum_sin(ptr, c, x) C_flonum(ptr, C_sin(C_flonum_magnitude(x)))
#define C_a_i_flonum_cos(ptr, c, x) C_flonum(ptr, C_cos(C_flonum_magnitude(x)))
diff --git a/distribution/manifest b/distribution/manifest
index e0efa5d0..927073cd 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -161,6 +161,7 @@ tests/inlining-tests.scm
tests/locative-stress-test.scm
tests/r4rstest.scm
tests/runtests.sh
+tests/srfi-4-tests.scm
tests/srfi-18-tests.scm
tests/hash-table-tests.scm
tests/apply-test.scm
diff --git a/srfi-4.scm b/srfi-4.scm
index 33d1c0d4..77bdde1a 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -118,8 +118,12 @@ EOF
(define (##sys#s16vector-set! v i x) (##core#inline "C_s16poke" (##core#inline "C_slot" v 1) i x))
(define (##sys#u32vector-set! v i x) (##core#inline "C_u32poke" (##core#inline "C_slot" v 1) i x))
(define (##sys#s32vector-set! v i x) (##core#inline "C_s32poke" (##core#inline "C_slot" v 1) i x))
-(define (##sys#f32vector-set! v i x) (##core#inline "C_f32poke" (##core#inline "C_slot" v 1) i x))
-(define (##sys#f64vector-set! v i x) (##core#inline "C_f64poke" (##core#inline "C_slot" v 1) i x))
+
+(define (##sys#f32vector-set! v i x)
+ (##core#inline "C_u_i_f32vector_set" v i x))
+
+(define (##sys#f64vector-set! v i x)
+ (##core#inline "C_u_i_f64vector_set" v i x))
;;; Get vector length:
diff --git a/tests/fft.scm b/tests/fft.scm
index 787fcebb..ca28bb3a 100644
--- a/tests/fft.scm
+++ b/tests/fft.scm
@@ -25,8 +25,7 @@
(defalias fl* fp*)
(defalias fl/ fp/)
(defalias fl+ fp+)
- (defalias fl- fp-)
- (defalias flsqrt sqrt)))
+ (defalias fl- fp-)))
(else))
(cond-expand
@@ -2064,7 +2063,7 @@
(let ((a
(make-f64vector (fx* two^n 2) 0.)))
(do ((i 0 (fx+ i 1)))
- ((fx= i iters))
+ ((fx= i iters)) ; (write table) (newline))
(direct-fft-recursive-4 a table)
(inverse-fft-recursive-4 a table)))))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 52246a22..f2267793 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -155,6 +155,9 @@ echo "======================================== fixnum tests ..."
$compile fixnum-tests.scm
./a.out
+echo "======================================== srfi-4 tests ..."
+$interpret -s srfi-4-tests.scm
+
echo "======================================== srfi-18 tests ..."
$interpret -s srfi-18-tests.scm
echo "*** Skipping \"feeley-dynwind\" (for now) ***"
@@ -208,7 +211,7 @@ $compile -e embedded2.scm
./a.out
echo "======================================== timing compilation ..."
-time $compile compiler.scm -S -O5 -debug pb -vv
+time $compile compiler.scm -S -O5 -debug pb -v
time ./a.out
echo "======================================== running floating-point benchmark ..."
diff --git a/tests/srfi-4-tests.scm b/tests/srfi-4-tests.scm
new file mode 100644
index 00000000..126fc294
--- /dev/null
+++ b/tests/srfi-4-tests.scm
@@ -0,0 +1,30 @@
+;;;; srfi-4-tests.scm
+
+
+(use srfi-1 srfi-4)
+
+
+(define-syntax (test1 x r c)
+ (let* ((t (strip-syntax (cadr x)))
+ (name (symbol->string (strip-syntax t))))
+ (define (conc op)
+ (string->symbol (string-append name op)))
+ `(let ((x (,(conc "vector") 100 101)))
+ (print x)
+ (assert (= 100 (,(conc "vector-ref") x 0)))
+ (,(conc "vector-set!") x 1 99)
+ (assert (= 99 (,(conc "vector-ref") x 1)))
+ (assert (= 2 (,(conc "vector-length") x)))
+ (assert
+ (every =
+ '(100 99)
+ (,(conc "vector->list") x))))))
+
+(test1 u8)
+(test1 u16)
+(test1 u32)
+(test1 s8)
+(test1 s16)
+(test1 s32)
+(test1 f32)
+(test1 f64)
Trap