From ab11f71665aa36100c6c4352cf49d983e51d06cc Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Mon, 30 Mar 1998 03:05:54 +0000
Subject: [PATCH] Add the special float function %expm1, and an inline VOP
 implementation for the X86 port.

---
 code/exports.lisp        |   4 +-
 compiler/float-tran.lisp |   6 +-
 compiler/x86/float.lisp  | 132 +++++++++++++++++++++++++++++++++++++--
 3 files changed, 135 insertions(+), 7 deletions(-)

diff --git a/code/exports.lisp b/code/exports.lisp
index 47c221eca..bf187b157 100644
--- a/code/exports.lisp
+++ b/code/exports.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.149 1998/03/26 14:07:24 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.150 1998/03/30 03:05:50 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1416,7 +1416,7 @@
 	   "%ARRAY-FILL-POINTER-P" "%ASIN" "%ASINH" "%ATAN" "%ATAN2" "%ATANH"
 	   "%CALLER-FRAME-AND-PC" "%CHECK-BOUND" "%CLOSURE-FUNCTION"
 	   "%CLOSURE-INDEX-REF" "%COS" "%COS-QUICK" "%COSH" "%DEPOSIT-FIELD"
-	   "%DOUBLE-FLOAT" "%DPB" "%EXP" "%FUNCTION-HEADER-ARGLIST"
+	   "%DOUBLE-FLOAT" "%DPB" "%EXP" "%EXPM1" "%FUNCTION-HEADER-ARGLIST"
 	   "%FUNCTION-HEADER-NAME" "%FUNCTION-HEADER-TYPE" "%HYPOT" "%LDB"
 	   "%LOG" "%LOGB" "%LOG10" "%LOG1P" "%LONG-FLOAT"
 	   "%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE" "%MAKE-RATIO"
diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp
index 9ae8e2295..5d05c17ba 100644
--- a/compiler/float-tran.lisp
+++ b/compiler/float-tran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.67 1998/03/30 02:44:26 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.68 1998/03/30 03:05:52 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -419,6 +419,10 @@
     (double-float) (double-float 0.0d0)
     (movable foldable flushable))
 
+(defknown %expm1
+    (double-float) (double-float -1d0)
+    (movable foldable flushable))
+
 (defknown (%hypot)
     (double-float double-float) (double-float 0d0)
   (movable foldable flushable))
diff --git a/compiler/x86/float.lisp b/compiler/x86/float.lisp
index db8388e35..adfc312de 100644
--- a/compiler/x86/float.lisp
+++ b/compiler/x86/float.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.27 1998/03/30 02:41:17 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.28 1998/03/30 03:05:54 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2484,9 +2484,9 @@
   (:generator 5
      (note-this-location vop :internal-error)
      (unless (zerop (tn-offset x))
-	     (inst fxch x)		; x to top of stack
-	     (unless (location= x y)
-		     (inst fst x)))	; maybe save it
+       (inst fxch x)		; x to top of stack
+       (unless (location= x y)
+	 (inst fst x)))	; maybe save it
      ;; Check for Inf or NaN
      (inst fxam)
      (inst fnstsw)
@@ -2516,6 +2516,68 @@
      (unless (zerop (tn-offset y))
 	     (inst fstd y))))
 
+;;; Expm1 = exp(x) - 1.
+;;; Handles the following special cases:
+;;;   expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
+(define-vop (fexpm1)
+  (:translate %expm1)
+  (:args (x :scs (double-reg) :target fr0))
+  (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:temporary (:sc long-reg :offset fr2-offset
+		   :from :argument :to :result) fr2)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline expm1 function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore temp)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (unless (zerop (tn-offset x))
+       (inst fxch x)		; x to top of stack
+       (unless (location= x y)
+	 (inst fst x)))	; maybe save it
+     ;; Check for Inf or NaN
+     (inst fxam)
+     (inst fnstsw)
+     (inst sahf)
+     (inst jmp :nc NOINFNAN)            ; Neither Inf or NaN.
+     (inst jmp :np NOINFNAN)            ; NaN gives NaN? Continue.
+     (inst and ah-tn #x02)              ; Test sign of Inf.
+     (inst jmp :z DONE)                 ; +Inf gives +Inf.
+     (inst fstp fr0)                    ; -Inf gives -1.0
+     (inst fld1)
+     (inst fchs)
+     (inst jmp-short DONE)
+     NOINFNAN
+     ;; Free two stack slots leaving the argument on top.
+     (inst fstp fr2)
+     (inst fstp fr0)
+     (inst fldl2e)
+     (inst fmul fr1)	; Now fr0 = x log2(e)
+     (inst fst fr1)
+     (inst frndint)
+     (inst fsub-sti fr1)
+     (inst fxch fr1)
+     (inst f2xm1)
+     (inst fscale)
+     (inst fxch fr1)
+     (inst fld1)
+     (inst fscale)
+     (inst fstp fr1)
+     (inst fld1)
+     (inst fsub fr1)
+     (inst fsubr fr2)
+     DONE
+     (unless (zerop (tn-offset y))
+       (inst fstd y))))
+
 (define-vop (flog)
   (:translate %log)
   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
@@ -3539,6 +3601,68 @@
      (unless (zerop (tn-offset y))
 	     (inst fstd y))))
 
+;;; Expm1 = exp(x) - 1.
+;;; Handles the following special cases:
+;;;   expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
+(define-vop (fexpm1)
+  (:translate %expm1)
+  (:args (x :scs (long-reg) :target fr0))
+  (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:temporary (:sc long-reg :offset fr2-offset
+		   :from :argument :to :result) fr2)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:note "inline expm1 function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore temp)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (unless (zerop (tn-offset x))
+       (inst fxch x)		; x to top of stack
+       (unless (location= x y)
+	 (inst fst x)))	; maybe save it
+     ;; Check for Inf or NaN
+     (inst fxam)
+     (inst fnstsw)
+     (inst sahf)
+     (inst jmp :nc NOINFNAN)            ; Neither Inf or NaN.
+     (inst jmp :np NOINFNAN)            ; NaN gives NaN? Continue.
+     (inst and ah-tn #x02)              ; Test sign of Inf.
+     (inst jmp :z DONE)                 ; +Inf gives +Inf.
+     (inst fstp fr0)                    ; -Inf gives -1.0
+     (inst fld1)
+     (inst fchs)
+     (inst jmp-short DONE)
+     NOINFNAN
+     ;; Free two stack slots leaving the argument on top.
+     (inst fstp fr2)
+     (inst fstp fr0)
+     (inst fldl2e)
+     (inst fmul fr1)	; Now fr0 = x log2(e)
+     (inst fst fr1)
+     (inst frndint)
+     (inst fsub-sti fr1)
+     (inst fxch fr1)
+     (inst f2xm1)
+     (inst fscale)
+     (inst fxch fr1)
+     (inst fld1)
+     (inst fscale)
+     (inst fstp fr1)
+     (inst fld1)
+     (inst fsub fr1)
+     (inst fsubr fr2)
+     DONE
+     (unless (zerop (tn-offset y))
+       (inst fstd y))))
+
 (define-vop (flog)
   (:translate %log)
   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
-- 
GitLab