From: Taylor R Campbell Date: Fri, 6 Aug 2010 00:38:40 +0000 (+0000) Subject: New procedures FLO:EXPM1 and FLO:LOG1P just like libm's. X-Git-Tag: 20101212-Gtk~121 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c47628aae36040bc9f8c9db16ba445505d49971a;p=mit-scheme.git New procedures FLO:EXPM1 and FLO:LOG1P just like libm's. Defined only on an interval about 0 of radius 1/log 2 and 1/sqrt 2, respectively; intended for computing (exp x) - 1 and log (1 + x) for very small x with high precision, unlike FLO:EXP and FLO:LOG. --- diff --git a/src/compiler/base/utils.scm b/src/compiler/base/utils.scm index 7af378e69..e0e591daa 100644 --- a/src/compiler/base/utils.scm +++ b/src/compiler/base/utils.scm @@ -234,8 +234,9 @@ USA. INT:+ INT:- INT:* INT:DIVIDE INT:QUOTIENT INT:REMAINDER INT:ABS INT:1+ INT:-1+ INT:NEGATE - FLO:+ FLO:- FLO:* FLO:/ FLO:NEGATE FLO:ABS FLO:EXP FLO:LOG FLO:SIN FLO:COS - FLO:TAN FLO:ASIN FLO:ACOS FLO:ATAN FLO:ATAN2 FLO:SQRT FLO:EXPT FLO:FLOOR + FLO:+ FLO:- FLO:* FLO:/ FLO:NEGATE FLO:ABS + FLO:EXP FLO:EXPM1 FLO:LOG FLO:LOG1P FLO:SIN FLO:COS FLO:TAN + FLO:ASIN FLO:ACOS FLO:ATAN FLO:ATAN2 FLO:SQRT FLO:EXPT FLO:FLOOR FLO:CEILING FLO:TRUNCATE FLO:ROUND FLO:FLOOR->EXACT FLO:CEILING->EXACT FLO:TRUNCATE->EXACT FLO:ROUND->EXACT diff --git a/src/compiler/machines/C/rulflo.scm b/src/compiler/machines/C/rulflo.scm index c7a071c04..99ff99915 100644 --- a/src/compiler/machines/C/rulflo.scm +++ b/src/compiler/machines/C/rulflo.scm @@ -170,8 +170,10 @@ USA. (define-use-function 'FLONUM-CEILING "DOUBLE_CEILING") (define-use-function 'FLONUM-COS "DOUBLE_COS") (define-use-function 'FLONUM-EXP "DOUBLE_EXP") + (define-use-function 'FLONUM-EXPM1 "DOUBLE_EXPM1") (define-use-function 'FLONUM-FLOOR "DOUBLE_FLOOR") (define-use-function 'FLONUM-LOG "DOUBLE_LOG") + (define-use-function 'FLONUM-LOG1P "DOUBLE_LOG1P") (define-use-function 'FLONUM-ROUND "DOUBLE_ROUND") (define-use-function 'FLONUM-SIN "DOUBLE_SIN") (define-use-function 'FLONUM-SQRT "DOUBLE_SQRT") diff --git a/src/compiler/machines/alpha/machin.scm b/src/compiler/machines/alpha/machin.scm index d7442c7e8..f298564c0 100644 --- a/src/compiler/machines/alpha/machin.scm +++ b/src/compiler/machines/alpha/machin.scm @@ -458,4 +458,4 @@ USA. FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-REMAINDER FLONUM-SQRT FLONUM-TRUNCATE FLONUM-ROUND FLONUM-CEILING FLONUM-FLOOR VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS - FLOATING-VECTOR-REF FLOATING-VECTOR-SET!)) + FLOATING-VECTOR-REF FLOATING-VECTOR-SET! FLONUM-EXPM1 FLONUM-LOG1P)) \ No newline at end of file diff --git a/src/compiler/machines/bobcat/machin.scm b/src/compiler/machines/bobcat/machin.scm index a62ca85cb..f36197592 100644 --- a/src/compiler/machines/bobcat/machin.scm +++ b/src/compiler/machines/bobcat/machin.scm @@ -394,4 +394,4 @@ USA. (define compiler:primitives-with-no-open-coding '(DIVIDE-FIXNUM GCD-FIXNUM &/ VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS - FLONUM-CEILING FLONUM-FLOOR FLONUM-ATAN2)) \ No newline at end of file + FLONUM-CEILING FLONUM-FLOOR FLONUM-ATAN2 FLONUM-EXPM1 FLONUM-LOG1P)) \ No newline at end of file diff --git a/src/compiler/machines/i386/rulflo.scm b/src/compiler/machines/i386/rulflo.scm index c4ec20e4b..04eea3493 100644 --- a/src/compiler/machines/i386/rulflo.scm +++ b/src/compiler/machines/i386/rulflo.scm @@ -319,6 +319,24 @@ USA. (FXCH (ST 0) (ST 1)) (FYL2X))))) +(define-arithmetic-method 'FLONUM-LOG1P flonum-methods/1-arg + ;; Computes LOG(X+1). + ;; X must be in the range: (- (SQRT 1/2) 1) <= X <= (- 1 (SQRT 1/2)) + (flonum-unary-operation/stack-top + (lambda () + (LAP (FLDLN2) + (FXCH (ST 0) (ST 1)) + (FYL2XP1))))) + +(define-arithmetic-method 'FLONUM-EXPM1 flonum-methods/1-arg + ;; Computes EXP(X)-1. + ;; X must be in the range: (- (LOG 2)) <= X <= (LOG 2) + (flonum-unary-operation/stack-top + (lambda () + (LAP (FLDL2E) + (FMULP (ST 1) (ST 0)) + (F2XM1))))) + (define-arithmetic-method 'FLONUM-EXP flonum-methods/1-arg (flonum-unary-operation/stack-top (lambda () diff --git a/src/compiler/machines/mips/machin.scm b/src/compiler/machines/mips/machin.scm index a2a4fc1eb..5d8f7bb94 100644 --- a/src/compiler/machines/mips/machin.scm +++ b/src/compiler/machines/mips/machin.scm @@ -392,4 +392,5 @@ USA. FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS FLONUM-ATAN2 FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-REMAINDER FLONUM-SQRT FLONUM-TRUNCATE FLONUM-ROUND FLONUM-CEILING FLONUM-FLOOR - VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS)) \ No newline at end of file + VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS + FLONUM-EXPM1 FLONUM-LOG1P)) \ No newline at end of file diff --git a/src/compiler/machines/sparc/machin.scm b/src/compiler/machines/sparc/machin.scm index 12ace79a2..2a3630f48 100644 --- a/src/compiler/machines/sparc/machin.scm +++ b/src/compiler/machines/sparc/machin.scm @@ -400,6 +400,6 @@ USA. INTEGER-QUOTIENT INTEGER-REMAINDER &/ QUOTIENT REMAINDER FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-TRUNCATE FLONUM-ROUND - FLONUM-REMAINDER FLONUM-SQRT + FLONUM-REMAINDER FLONUM-SQRT FLONUM-EXPM1 FLONUM-LOG1P VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS FLOATING-VECTOR-REF FLOATING-VECTOR-SET!)) \ No newline at end of file diff --git a/src/compiler/machines/spectrum/machin.scm b/src/compiler/machines/spectrum/machin.scm index 0ea94cadd..36eff339d 100644 --- a/src/compiler/machines/spectrum/machin.scm +++ b/src/compiler/machines/spectrum/machin.scm @@ -410,4 +410,4 @@ USA. true) (define compiler:primitives-with-no-open-coding - '(DIVIDE-FIXNUM GCD-FIXNUM &/)) \ No newline at end of file + '(DIVIDE-FIXNUM GCD-FIXNUM &/ FLONUM-EXPM1 FLONUM-LOG1P)) \ No newline at end of file diff --git a/src/compiler/machines/svm/machine.scm b/src/compiler/machines/svm/machine.scm index 994cad264..5bdb8604a 100644 --- a/src/compiler/machines/svm/machine.scm +++ b/src/compiler/machines/svm/machine.scm @@ -508,7 +508,7 @@ USA. #t) (define compiler:primitives-with-no-open-coding - '(DIVIDE-FIXNUM GCD-FIXNUM &/ + '(DIVIDE-FIXNUM GCD-FIXNUM &/ FLONUM-EXPM1 FLONUM-LOG1P VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS)) ;;;; Closure format diff --git a/src/compiler/machines/vax/machin.scm b/src/compiler/machines/vax/machin.scm index a397cc557..f73a73afa 100644 --- a/src/compiler/machines/vax/machin.scm +++ b/src/compiler/machines/vax/machin.scm @@ -295,4 +295,4 @@ USA. (define compiler:primitives-with-no-open-coding '(DIVIDE-FIXNUM GCD-FIXNUM &/ VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS - FLOATING-VECTOR-REF FLOATING-VECTOR-SET!)) \ No newline at end of file + FLOATING-VECTOR-REF FLOATING-VECTOR-SET! FLONUM-EXPM1 FLONUM-LOG1P)) \ No newline at end of file diff --git a/src/compiler/machines/x86-64/machin.scm b/src/compiler/machines/x86-64/machin.scm index 96e03c603..06a340edb 100644 --- a/src/compiler/machines/x86-64/machin.scm +++ b/src/compiler/machines/x86-64/machin.scm @@ -414,6 +414,6 @@ USA. '(DIVIDE-FIXNUM &/ FLOATING-VECTOR-CONS FLONUM-ACOS FLONUM-ASIN FLONUM-ATAN - FLONUM-ATAN2 FLONUM-CEILING FLONUM-COS FLONUM-EXP FLONUM-FLOOR - FLONUM-LOG FLONUM-ROUND FLONUM-SIN FLONUM-TAN FLONUM-TRUNCATE - GCD-FIXNUM STRING-ALLOCATE VECTOR-CONS)) \ No newline at end of file + FLONUM-ATAN2 FLONUM-CEILING FLONUM-COS FLONUM-EXP FLONUM-EXPM1 + FLONUM-FLOOR FLONUM-LOG FLONUM-LOG1P FLONUM-ROUND FLONUM-SIN + FLONUM-TAN FLONUM-TRUNCATE GCD-FIXNUM STRING-ALLOCATE VECTOR-CONS)) \ No newline at end of file diff --git a/src/compiler/rtlgen/opncod.scm b/src/compiler/rtlgen/opncod.scm index 4cfbce150..23964e978 100644 --- a/src/compiler/rtlgen/opncod.scm +++ b/src/compiler/rtlgen/opncod.scm @@ -1404,8 +1404,8 @@ USA. '(0) internal-close-coding-for-type-checks))) '(FLONUM-NEGATE FLONUM-ABS FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN - FLONUM-ACOS FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-SQRT FLONUM-ROUND - FLONUM-TRUNCATE FLONUM-CEILING FLONUM-FLOOR)) + FLONUM-ACOS FLONUM-ATAN FLONUM-EXP FLONUM-EXPM1 FLONUM-LOG FLONUM-LOG1P + FLONUM-SQRT FLONUM-ROUND FLONUM-TRUNCATE FLONUM-CEILING FLONUM-FLOOR)) (for-each (lambda (flonum-operator) diff --git a/src/microcode/flonum.c b/src/microcode/flonum.c index 0418ecfbc..e191bb492 100644 --- a/src/microcode/flonum.c +++ b/src/microcode/flonum.c @@ -146,6 +146,13 @@ DEFINE_PRIMITIVE ("FLONUM-NEGATIVE?", Prim_flonum_negative_p, 1, 1, 0) FLONUM_RESULT (result); \ } +DEFINE_PRIMITIVE ("FLONUM-EXPM1", Prim_flonum_expm1, 1, 1, 0) + RESTRICTED_TRANSCENDENTAL_FUNCTION + (expm1, ((x >= - M_LN2) && (x <= M_LN2))) +DEFINE_PRIMITIVE ("FLONUM-LOG1P", Prim_flonum_log1p, 1, 1, 0) + RESTRICTED_TRANSCENDENTAL_FUNCTION + (log1p, ((x >= (M_SQRT1_2 - 1.0)) && (x <= (1.0 - M_SQRT1_2)))) + DEFINE_PRIMITIVE ("FLONUM-EXP", Prim_flonum_exp, 1, 1, 0) SIMPLE_TRANSCENDENTAL_FUNCTION (exp) DEFINE_PRIMITIVE ("FLONUM-LOG", Prim_flonum_log, 1, 1, 0) diff --git a/src/microcode/liarc.h b/src/microcode/liarc.h index a50f8a491..8b01192de 100644 --- a/src/microcode/liarc.h +++ b/src/microcode/liarc.h @@ -469,8 +469,10 @@ extern int multiply_with_overflow (long, long, long *); #define DOUBLE_CEILING ceil #define DOUBLE_COS cos #define DOUBLE_EXP exp +#define DOUBLE_EXPM1 expm1 #define DOUBLE_FLOOR floor #define DOUBLE_LOG log +#define DOUBLE_LOG1P log1p #define DOUBLE_SIN sin #define DOUBLE_SQRT sqrt #define DOUBLE_TAN tan diff --git a/src/runtime/fixart.scm b/src/runtime/fixart.scm index eb0d8ce84..0674952ce 100644 --- a/src/runtime/fixart.scm +++ b/src/runtime/fixart.scm @@ -85,7 +85,9 @@ USA. (flo:negate flonum-negate 1) (flo:abs flonum-abs 1) (flo:exp flonum-exp 1) + (flo:expm1 flonum-expm1 1) (flo:log flonum-log 1) + (flo:log1p flonum-log1p 1) (flo:sin flonum-sin 1) (flo:cos flonum-cos 1) (flo:tan flonum-tan 1) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 47a222cba..e34b06044 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -227,12 +227,14 @@ USA. flo:ceiling->exact flo:cos flo:exp + flo:expm1 flo:expt flo:finite? flo:flonum? flo:floor flo:floor->exact flo:log + flo:log1p flo:max flo:min flo:negate diff --git a/src/sf/gconst.scm b/src/sf/gconst.scm index fe1262514..0add2e241 100644 --- a/src/sf/gconst.scm +++ b/src/sf/gconst.scm @@ -117,11 +117,13 @@ USA. (FLO:CEILING->EXACT FLONUM-CEILING->EXACT) (FLO:COS FLONUM-COS) (FLO:EXP FLONUM-EXP) + (FLO:EXPM1 FLONUM-EXPM1) (FLO:EXPT FLONUM-EXPT) (FLO:FLONUM? FLONUM?) (FLO:FLOOR FLONUM-FLOOR) (FLO:FLOOR->EXACT FLONUM-FLOOR->EXACT) (FLO:LOG FLONUM-LOG) + (FLO:LOG1P FLONUM-LOG1P) (FLO:NEGATE FLONUM-NEGATE) (FLO:NEGATIVE? FLONUM-NEGATIVE?) (FLO:POSITIVE? FLONUM-POSITIVE?)