~ chicken-core (chicken-5) 4b517f9e64b0bb209de261a7f15072009016be2d
commit 4b517f9e64b0bb209de261a7f15072009016be2d
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Thu Mar 19 22:25:58 2015 +0100
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun May 31 14:55:23 2015 +0200
Convert generic negate and abs procedures to inlinable scratchspace-based versions
diff --git a/chicken.h b/chicken.h
index 8d85947a..d66cc772 100644
--- a/chicken.h
+++ b/chicken.h
@@ -538,7 +538,8 @@ static inline int isinf_ld (long double x)
/* This is for convenience and allows flexibility in representation */
#define C_SIZEOF_FIX_BIGNUM C_SIZEOF_BIGNUM(1)
-#define C_SIZEOF_BIGNUM(n) (C_SIZEOF_INTERNAL_BIGNUM_VECTOR(n)+C_SIZEOF_STRUCTURE(2))
+#define C_SIZEOF_BIGNUM_WRAPPER C_SIZEOF_STRUCTURE(2)
+#define C_SIZEOF_BIGNUM(n) (C_SIZEOF_INTERNAL_BIGNUM_VECTOR(n)+C_SIZEOF_BIGNUM_WRAPPER)
/* Fixed size types have pre-computed header tags */
#define C_PAIR_TAG (C_PAIR_TYPE | (C_SIZEOF_PAIR - 1))
@@ -694,6 +695,7 @@ static inline int isinf_ld (long double x)
#define C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR 51
#define C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR 52
#define C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION 53
+#define C_BAD_ARGUMENT_TYPE_COMPLEX_ABS 54
/* Platform information */
#if defined(C_BIG_ENDIAN)
@@ -1944,7 +1946,6 @@ C_fctexport C_char *C_private_repository_path();
C_fctimport void C_ccall C_toplevel(C_word c, C_word self, C_word k) C_noret;
C_fctimport void C_ccall C_invalid_procedure(int c, C_word self, ...) C_noret;
C_fctexport void C_ccall C_stop_timer(C_word c, C_word closure, C_word k) C_noret;
-C_fctexport void C_ccall C_abs(C_word c, C_word self, C_word k, C_word x) C_noret;
C_fctexport void C_ccall C_signum(C_word c, C_word self, C_word k, C_word x) C_noret;
C_fctexport void C_ccall C_apply(C_word c, C_word closure, C_word k, C_word fn, ...) C_noret;
C_fctexport void C_ccall C_do_apply(C_word n, C_word closure, C_word k) C_noret;
@@ -1964,7 +1965,6 @@ C_fctexport void C_ccall C_2_basic_plus(C_word c, C_word self, C_word k, C_word
C_fctexport void C_ccall C_u_2_integer_plus(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport void C_ccall C_minus(C_word c, C_word closure, C_word k, C_word n1, ...) C_noret;
-C_fctexport void C_ccall C_negate(C_word c, C_word self, C_word k, C_word x) C_noret;
C_fctexport void C_ccall C_2_basic_minus(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
C_fctexport void C_ccall C_u_2_integer_minus(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
@@ -2184,6 +2184,8 @@ C_fctexport C_word C_fcall C_a_i_string_to_number(C_word **a, int c, C_word str,
C_fctexport C_word C_fcall C_a_i_exact_to_inexact(C_word **a, int c, C_word n) C_regparm;
C_fctexport C_word C_fcall C_i_file_exists_p(C_word name, C_word file, C_word dir) C_regparm;
+C_fctexport C_word C_fcall C_s_a_i_abs(C_word **ptr, C_word n, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_s_a_i_negate(C_word **ptr, C_word n, C_word x) C_regparm;
C_fctexport C_word C_fcall C_s_a_u_i_integer_negate(C_word **ptr, C_word n, C_word x) C_regparm;
@@ -2431,6 +2433,17 @@ C_inline C_word C_a_i_record8(C_word **ptr, int n, C_word x1, C_word x2, C_word
return (C_word)p0;
}
+C_inline C_word C_cplxnum(C_word **ptr, C_word x, C_word y)
+{
+ return C_a_i_record3(ptr, 2, C_cplxnum_type_tag, x, y);
+}
+
+C_inline C_word C_ratnum(C_word **ptr, C_word x, C_word y)
+{
+ return C_a_i_record3(ptr, 2, C_ratnum_type_tag, x, y);
+}
+
+
/* Silly (this is not normalized) but in some cases needed internally */
C_inline C_word C_bignum0(C_word **ptr)
{
diff --git a/library.scm b/library.scm
index ece34b4f..0acbc0f0 100644
--- a/library.scm
+++ b/library.scm
@@ -1188,19 +1188,10 @@ EOF
;;; Basic arithmetic:
-(define abs (##core#primitive "C_abs"))
+(define (abs x) (##core#inline_allocate ("C_s_a_i_abs" 10) x))
;; OBSOLETE: Remove this (or change to define-inline)
(define (##sys#integer-abs x)
(##core#inline_allocate ("C_s_a_u_i_integer_abs" 6) x))
-(define (##sys#extended-abs x)
- (cond ((ratnum? x)
- (%make-ratnum (##sys#integer-abs (%ratnum-numerator x))
- (%ratnum-denominator x)))
- ((cplxnum? x)
- (##sys#signal-hook
- #:type-error 'abs
- "can not compute absolute value of complex number" x))
- (else (##sys#error-bad-number x 'abs))))
(define (+ . args)
(if (null? args)
@@ -1244,7 +1235,8 @@ EOF
(%make-ratnum numerator d))))
(else (##sys#error-bad-number y '+)) ) )
-(define ##sys#negate (##core#primitive "C_negate"))
+;; OBSOLETE: Remove this (or change to define-inline)
+(define (##sys#negate x) (##core#inline_allocate ("C_s_a_i_negate" 36) x))
;; OBSOLETE: Remove this (or change to define-inline)
(define (##sys#integer-negate x)
(##core#inline_allocate ("C_s_a_u_i_integer_negate" 6) x))
@@ -1262,15 +1254,6 @@ EOF
(define ##sys#--2 (##core#primitive "C_2_basic_minus"))
(define ##sys#integer-minus (##core#primitive "C_u_2_integer_minus"))
-(define (##sys#extended-negate x)
- (cond ((ratnum? x)
- (%make-ratnum (##sys#integer-negate (%ratnum-numerator x))
- (%ratnum-denominator x)))
- ((cplxnum? x)
- (make-complex (##sys#negate (%cplxnum-real x))
- (##sys#negate (%cplxnum-imag x))))
- (else (##sys#error-bad-number x '-)) ) ) ; loc?
-
(define (##sys#extended-minus x y)
(cond ((or (cplxnum? x) (cplxnum? y))
;; Just subtract real and imag parts from eachother
@@ -5444,6 +5427,7 @@ EOF
((51) (apply ##sys#signal-hook #:type-error loc "bad argument type - complex number has no ordering" args))
((52) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an exact integer" args))
((53) (apply ##sys#signal-hook #:type-error loc "number does not fit in foreign type" args))
+ ((54) (apply ##sys#signal-hook #:type-error loc "cannot compute absolute value of complex number" args))
(else (apply ##sys#signal-hook #:runtime-error loc "unknown internal error" args)) ) ) ) )
diff --git a/runtime.c b/runtime.c
index 1008727a..908ea064 100644
--- a/runtime.c
+++ b/runtime.c
@@ -842,7 +842,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
{
/* IMPORTANT: hardcoded table size -
this must match the number of C_pte calls + 1 (NULL terminator)! */
- C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 78);
+ C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 76);
int i = 0;
if(pt == NULL)
@@ -913,8 +913,6 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_flonum_to_string);
/* IMPORTANT: have you read the comments at the start and the end of this function? */
C_pte(C_signum);
- C_pte(C_abs);
- C_pte(C_negate);
C_pte(C_2_basic_plus);
C_pte(C_2_basic_minus);
C_pte(C_2_basic_times);
@@ -1871,6 +1869,11 @@ void barf(int code, char *loc, ...)
c = 1;
break;
+ case C_BAD_ARGUMENT_TYPE_COMPLEX_ABS:
+ msg = C_text("cannot compute absolute value of complex number");
+ c = 1;
+ break;
+
default: panic(C_text("illegal internal error code"));
}
@@ -5657,23 +5660,27 @@ C_regparm C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x)
return C_SCHEME_UNDEFINED;
}
-void C_ccall C_abs(C_word c, C_word self, C_word k, C_word x)
+/* This needs at most C_SIZEOF_FIX_BIGNUM + C_SIZEOF_STRUCTURE(3) so 10 words */
+C_regparm C_word C_fcall
+C_s_a_i_abs(C_word **ptr, C_word n, C_word x)
{
- if (c != 3) {
- C_bad_argc_2(c, 3, self);
- } else if (x & C_FIXNUM_BIT) {
- C_word *a = C_alloc(C_SIZEOF_FIX_BIGNUM);
- C_kontinue(k, C_a_i_fixnum_abs(&a, 1, x));
+ if (x & C_FIXNUM_BIT) {
+ return C_a_i_fixnum_abs(ptr, 1, x);
} else if (C_immediatep(x)) {
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x);
} else if (C_block_header(x) == C_FLONUM_TAG) {
- C_word *a = C_alloc(C_SIZEOF_FLONUM);
- C_kontinue(k, C_a_i_flonum_abs(&a, 1, x));
+ return C_a_i_flonum_abs(ptr, 1, x);
} else if (C_truep(C_bignump(x))) {
- C_word *a = C_alloc(C_SIZEOF_FIX_BIGNUM);
- C_kontinue(k, C_s_a_u_i_integer_abs(&a, 1, x));
+ return C_s_a_u_i_integer_abs(ptr, 1, x);
+ } else if (C_block_header(x) == C_STRUCTURE3_TAG &&
+ (C_block_item(x, 0) == C_ratnum_type_tag)) {
+ return C_ratnum(ptr, C_s_a_u_i_integer_abs(ptr, 1, C_block_item(x, 1)),
+ C_block_item(x, 2));
+ } else if (C_block_header(x) == C_STRUCTURE3_TAG &&
+ (C_block_item(x, 0) == C_cplxnum_type_tag)) {
+ barf(C_BAD_ARGUMENT_TYPE_COMPLEX_ABS, "abs", x);
} else {
- try_extended_number("\003sysextended-abs", 2, k, x);
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x);
}
}
@@ -5707,21 +5714,31 @@ C_regparm C_word C_fcall C_a_i_abs(C_word **a, int c, C_word x)
return C_flonum(a, fabs(C_flonum_magnitude(x)));
}
-void C_ccall C_negate(C_word c, C_word self, C_word k, C_word x)
+/* The maximum this can allocate is a cplxnum which consists of two
+ * ratnums that consist of 2 fix bignums each. So that's
+ * C_SIZEOF_STRUCTURE(3) * 3 + C_SIZEOF_FIX_BIGNUM * 4 = 36 words!
+ */
+C_regparm C_word C_fcall
+C_s_a_i_negate(C_word **ptr, C_word n, C_word x)
{
if (x & C_FIXNUM_BIT) {
- C_word *a = C_alloc(C_SIZEOF_FIX_BIGNUM);
- C_kontinue(k, C_a_i_fixnum_negate(&a, 1, x));
+ return C_a_i_fixnum_negate(ptr, 1, x);
} else if (C_immediatep(x)) {
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);
} else if (C_block_header(x) == C_FLONUM_TAG) {
- C_word *a = C_alloc(C_SIZEOF_FLONUM);
- C_kontinue(k, C_a_i_flonum_negate(&a, 1, x));
+ return C_a_i_flonum_negate(ptr, 1, x);
} else if (C_truep(C_bignump(x))) {
- C_word *a = C_alloc(C_SIZEOF_FIX_BIGNUM);
- C_kontinue(k, C_s_a_u_i_integer_negate(&a, 1, x));
+ return C_s_a_u_i_integer_negate(ptr, 1, x);
+ } else if (C_block_header(x) == C_STRUCTURE3_TAG &&
+ (C_block_item(x, 0) == C_ratnum_type_tag)) {
+ return C_ratnum(ptr, C_s_a_u_i_integer_negate(ptr, 1, C_block_item(x, 1)),
+ C_block_item(x, 2));
+ } else if (C_block_header(x) == C_STRUCTURE3_TAG &&
+ (C_block_item(x, 0) == C_cplxnum_type_tag)) {
+ return C_cplxnum(ptr, C_s_a_i_negate(ptr, 1, C_block_item(x, 1)),
+ C_s_a_i_negate(ptr, 1, C_block_item(x, 2)));
} else {
- try_extended_number("\003sysextended-negate", 2, k, x);
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);
}
}
diff --git a/types.db b/types.db
index e309d943..e12706f9 100644
--- a/types.db
+++ b/types.db
@@ -328,7 +328,7 @@
((integer) (integer)
(##core#inline_allocate ("C_s_a_u_i_integer_negate" 6) #(1)))
((float) (float) (##core#inline_allocate ("C_a_i_flonum_negate" 4) #(1)))
- ((number) (number) (##sys#negate #(1)))
+ ((*) (*) (##core#inline_allocate ("C_s_a_i_negate" 36) #(1)))
((float fixnum) (float)
(##core#inline_allocate
("C_a_i_flonum_difference" 4)
@@ -501,7 +501,9 @@
((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_abs" 6) #(1)))
((float) (float) (##core#inline_allocate ("C_a_i_flonum_abs" 4) #(1)))
((integer) (integer)
- (##core#inline_allocate ("C_s_a_u_i_integer_abs" 6) #(1))))
+ (##core#inline_allocate ("C_s_a_u_i_integer_abs" 6) #(1)))
+ ((*) (*)
+ (##core#inline_allocate ("C_s_a_i_abs" 10) #(1))))
(floor (#(procedure #:clean #:enforce #:foldable) floor ((or integer ratnum float)) (or integer ratnum float))
((fixnum) (fixnum) #(1))
@@ -797,7 +799,8 @@
((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_abs" 6) #(1)))
((integer) (##core#inline_allocate ("C_s_a_u_i_integer_abs" 6) #(1)))
((float) (float) (##core#inline_allocate ("C_a_i_flonum_abs" 4) #(1)))
- (((or fixnum float bignum ratnum)) (abs #(1))))
+ (((or fixnum float bignum ratnum))
+ (##core#inline_allocate ("C_s_a_i_abs" 10) #(1))))
(angle (#(procedure #:clean #:enforce #:foldable) angle (number) float)
((float) (##core#inline_allocate ("C_a_i_flonum_atan2" 4) '0.0 #(1)))
Trap