~ chicken-core (chicken-5) 3ba051df156cc7c5e9e6c4a31184f23c0885b1cc
commit 3ba051df156cc7c5e9e6c4a31184f23c0885b1cc
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Dec 8 00:47:10 2009 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Dec 11 21:32:01 2009 +0100
- added `fpabs'
- documented `-debug U'
- unboxed rewrites for `fp-' and `fp/'
- this still fails:
(use srfi-4)
(define x 64.0)
(pp (fp- 23.4 x))
here an unboxed temporary for `x' is used in the assignment,
but it is never introduced through a binding
diff --git a/c-platform.scm b/c-platform.scm
index cff469e0..23ce02f8 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -130,7 +130,7 @@
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 fpsin fpcos fptan fpasin fpacos fpatan
- fpatan2 fpexp fpexpt fplog fpsqrt
+ fpatan2 fpexp fpexpt fplog fpsqrt fpabs
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
@@ -801,6 +801,7 @@
(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 'fpabs 16 1 "C_a_i_flonum_abs" #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)
diff --git a/chicken.h b/chicken.h
index 739e2b5c..af8d2691 100644
--- a/chicken.h
+++ b/chicken.h
@@ -886,6 +886,7 @@ DECL_C_PROC_p0 (128, 1,0,0,0,0,0,0,0)
# define C_floor floor
# define C_round round
# define C_trunc trunc
+# define C_fabs fabs
# ifdef __linux__
extern double round(double);
extern double trunc(double);
@@ -1284,7 +1285,9 @@ extern double trunc(double);
#endif
#define C_ub_i_flonum_plus(x, y) ((x) + (y))
+#define C_ub_i_flonum_difference(x, y) ((x) - (y))
#define C_ub_i_flonum_times(x, y) ((x) * (y))
+#define C_ub_i_flonum_quotient(x, y) ((x) / (y))
#define C_end_of_main
@@ -1324,6 +1327,7 @@ extern double trunc(double);
#define C_a_i_flonum_expt(ptr, c, x, y) C_flonum(ptr, C_pow(C_flonum_magnitude(x), C_flonum_magnitude(y)))
#define C_a_i_flonum_log(ptr, c, x) C_flonum(ptr, C_log(C_flonum_magnitude(x)))
#define C_a_i_flonum_sqrt(ptr, c, x) C_flonum(ptr, C_sqrt(C_flonum_magnitude(x)))
+#define C_a_i_flonum_abs(ptr, c, x) C_flonum(ptr, C_fabs(C_flonum_magnitude(x)))
/* Variables: */
diff --git a/library.scm b/library.scm
index b725c2ae..fe6da61f 100644
--- a/library.scm
+++ b/library.scm
@@ -962,6 +962,11 @@ EOF
(fp-check-flonum x 'fpsqrt)
(##core#inline_allocate ("C_a_i_flonum_sqrt" 4) x))
+(define (fpabs x)
+ #+(not unsafe)
+ (fp-check-flonum x 'fpabs)
+ (##core#inline_allocate ("C_a_i_flonum_abs" 4) x))
+
(define * (##core#primitive "C_times"))
(define - (##core#primitive "C_minus"))
(define + (##core#primitive "C_plus"))
diff --git a/manual/Unit library b/manual/Unit library
index 27ca46de..89d16720 100644
--- a/manual/Unit library
+++ b/manual/Unit library
@@ -121,6 +121,7 @@ in unsafe mode can crash the system.
<procedure>(fpexp X)</procedure>
<procedure>(fpexpt X Y)</procedure>
<procedure>(fpsqrt X)</procedure>
+<procedure>(fpabs X)</procedure>
Note: {{fpround}} implements POSIX, which is different from R5RS.
diff --git a/manual/Using the compiler b/manual/Using the compiler
index 4848837d..248f66a9 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -56,6 +56,7 @@ Possible options are:
S show applications of compiler syntax
T show expressions after converting to node tree
L show expressions after lambda-lifting
+ U show expressions after unboxing
M show syntax-/runtime-requirements
1 show source expressions
2 show canonicalized expressions
diff --git a/manual/faq b/manual/faq
index effaad74..bfa503cc 100644
--- a/manual/faq
+++ b/manual/faq
@@ -435,7 +435,9 @@ The following extended bindings are handled specially:
{{flonum?}} {{fp+}}
{{fp-}} {{fp*}} {{fp/}} {{atom?}}
{{fp=}} {{fp>}} {{fp>=}} {{fpneg}} {{fpmax}} {{fpmin}}
-{{fpfloor}} {{fpceiling}} {{fpround}} {{fptruncate}}
+{{fpfloor}} {{fpceiling}} {{fpround}} {{fptruncate}} {{fpsqrt}} {{fpabs}}
+{{fplog}} {{fpexp}} {{fpexpt}} {{fpsin}} {{fpcos}} {{fptan}} {{fpasin}}
+{{fpacos}} {{fpatan}} {{fpatan2}}
{{arithmetic-shift}} {{signum}} {{flush-output}} {{thread-specific}} {{thread-specific-set!}}
{{not-pair?}} {{null-list?}} {{print}} {{print*}} {{u8vector->blob/shared}}
{{s8vector->blob/shared}} {{u16vector->blob/shared}} {{s16vector->blob/shared}}
diff --git a/tests/fft.scm b/tests/fft.scm
index ca28bb3a..53332f47 100644
--- a/tests/fft.scm
+++ b/tests/fft.scm
@@ -2063,8 +2063,8 @@
(let ((a
(make-f64vector (fx* two^n 2) 0.)))
(do ((i 0 (fx+ i 1)))
- ((fx= i iters)) ; (write table) (newline))
+ ((fx= i iters)); (write table) (newline))
(direct-fft-recursive-4 a table)
(inverse-fft-recursive-4 a table)))))
-(test 1000 11)
+(test 2000 11)
diff --git a/types.db b/types.db
index cc6edc79..62831445 100644
--- a/types.db
+++ b/types.db
@@ -298,6 +298,7 @@
(fp= (procedure fp= (float float) boolean))
(fp> (procedure fp> (float float) boolean))
(fp>= (procedure fp>= (float float) boolean))
+(fpabs (procedure fpabs (float) float))
(fpacos (procedure fpacos (float) float))
(fpasin (procedure fpasin (float) float))
(fpatan (procedure fpatan (float) float))
diff --git a/unboxing.scm b/unboxing.scm
index 76b992eb..e7708498 100644
--- a/unboxing.scm
+++ b/unboxing.scm
@@ -91,7 +91,7 @@
(else #f)))
(define (rewrite! n alt anodes avals atypes0 rtype dest)
- (d "rewrite: ~a -> ~a" (first (node-parameters n)) alt)
+ (d "rewrite: ~a -> ~a (dest: ~a)" (first (node-parameters n)) alt dest)
(let ((s (symbolify alt)))
(##sys#hash-table-set!
stats s (add1 (or (##sys#hash-table-ref stats s) 0))))
@@ -327,6 +327,8 @@
(define-unboxed-ops
(C_a_i_flonum_plus (flo flo) flo "C_ub_i_flonum_plus")
+ (C_a_i_flonum_difference (flo flo) flo "C_ub_i_flonum_difference")
(C_a_i_flonum_times (flo flo) flo "C_ub_i_flonum_times")
+ (C_a_i_flonum_quotient (flo flo) flo "C_ub_i_flonum_quotient")
;...
)
Trap