Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

7 changed files:

Changes:

  • src/code/exports.lisp
    ... ... @@ -2191,10 +2191,33 @@
    2191 2191
    2192 2192 
     	   "%IEEE754-REM-PI/2"
    2193 2193 
     	   "%SINCOS"
    2194 
    -
    2195 2194 
     	   "STANDARD-CHAR-TYPE"
    2196 2195 
     	   "MAKE-STANDARD-CHAR-TYPE"
    2197 
    -	   "STANDARD-CHAR-TYPE-P")
    2196 
    +	   "STANDARD-CHAR-TYPE-P"
    2197 
    +
    2198 
    +	   ;; Single-float functions
    2199 
    +	   "%ACOSF"
    2200 
    +	   "%ACOSHF"
    2201 
    +	   "%ASINF"
    2202 
    +	   "%ASINHF"
    2203 
    +	   "%ATAN2F"
    2204 
    +	   "%ATANF"
    2205 
    +	   "%ATANHF"
    2206 
    +	   "%COSF"
    2207 
    +	   "%COSHF"
    2208 
    +	   "%EXPF"
    2209 
    +	   "%EXPM1F"
    2210 
    +	   "%HYPOTF"
    2211 
    +	   "%LOG10F"
    2212 
    +	   "%LOG1PF"
    2213 
    +	   "%LOG2F"
    2214 
    +	   "%LOGF"
    2215 
    +	   "%POWF"
    2216 
    +	   "%SINF"
    2217 
    +	   "%SINHF"
    2218 
    +	   "%TANF"
    2219 
    +	   "%TANHF"
    2220 
    +	   )
    2198 2221 
       #+heap-overflow-check
    2199 2222 
       (:export "DYNAMIC-SPACE-OVERFLOW-WARNING-HIT"
    2200 2223 
     	   "DYNAMIC-SPACE-OVERFLOW-ERROR-HIT"

  • src/code/irrat.lisp
    ... ... @@ -40,28 +40,37 @@
    40 40 
     ;;; call, and saves number consing to boot.
    41 41 
     ;;;
    42 42 
     (defmacro def-math-rtn (name num-args)
    43 
    -  (multiple-value-bind (c-name lisp-name)
    44 
    -      (if (listp name)
    45 
    -	  (values (first name) (second name))
    46 
    -	  (values name
    47 
    -		  (intern (concatenate 'simple-string
    48 
    -				       "%"
    49 
    -				       (string-upcase name)))))
    50 
    -    `(progn
    51 
    -       (declaim (inline ,lisp-name))
    52 
    -       (export ',lisp-name)
    53 
    -       (alien:def-alien-routine (,c-name ,lisp-name) double-float
    54 
    -	 ,@(let ((results nil))
    55 
    -	     (dotimes (i num-args (nreverse results))
    56 
    -	       (push (list (intern (format nil "ARG-~D" i))
    57 
    -			   'double-float)
    58 
    -		     results)))))))
    43 
    +  (flet ((def-rtn (c-name lisp-name type)
    44 
    +	   `(progn
    45 
    +	      (declaim (inline ,lisp-name))
    46 
    +	      (export ',lisp-name)
    47 
    +	      (alien:def-alien-routine (,c-name ,lisp-name) ,type
    48 
    +		,@(let ((results nil))
    49 
    +		    (dotimes (i num-args (nreverse results))
    50 
    +		      (push (list (intern (format nil "ARG-~D" i))
    51 
    +				  type)
    52 
    +			    results)))))))
    53 
    +    (multiple-value-bind (c-name lisp-name)
    54 
    +	(if (listp name)
    55 
    +	    (values (first name) (second name))
    56 
    +	    (values name
    57 
    +		    (intern (concatenate 'simple-string
    58 
    +					 "%"
    59 
    +					 (string-upcase name)))))
    60 
    +      `(progn
    61 
    +	 ,(def-rtn c-name lisp-name 'double-float)
    62 
    +	 ;; The C99 convention is for the float version to have the same
    63 
    +	 ;; name as the double version but with an "f" appended.  We do
    64 
    +	 ;; the same here and append an "F" to the lisp name too.
    65 
    +	 ,(def-rtn (concatenate 'string c-name "f")
    66 
    +	           (symbolicate lisp-name "F")
    67 
    +	           'single-float)))))
    59 68
    60 69 
     (eval-when (compile load eval)
    61 70
    62 71 
     (defun handle-reals (function var)
    63 72 
       `((((foreach fixnum single-float bignum ratio))
    64 
    -     (coerce (,function (coerce ,var 'double-float)) 'single-float))
    73 
    +     (,(symbolicate function "F") (coerce ,var 'single-float)))
    65 74 
         ((double-float)
    66 75 
          (,function ,var))
    67 76 
         #+double-double
    ... ... @@ -213,21 +222,34 @@
    213 222 
       (y0 double-float :out)
    214 223 
       (y1 double-float :out))
    215 224
    216 
    -(declaim (inline %%sincos))
    225 
    +(declaim (inline %%sincos %%sincosf))
    217 226 
     (alien:def-alien-routine ("lisp_sincos" %%sincos)
    218 227 
       c-call:void
    219 228 
       (x double-float)
    220 229 
       (s double-float :out)
    221 230 
       (c double-float :out))
    222 231
    232 
    +(alien:def-alien-routine ("lisp_sincosf" %%sincosf)
    233 
    +  c-call:void
    234 
    +  (x single-float)
    235 
    +  (s single-float :out)
    236 
    +  (c single-float :out))
    237 
    +
    223 238 
     (declaim (inline %sincos))
    224 239 
     (export '%sincos)
    225 240 
     (defun %sincos (x)
    226 
    -  (declare (double-float x))
    227 
    -  (multiple-value-bind (ign s c)
    228 
    -      (%%sincos x)
    229 
    -    (declare (ignore ign))
    230 
    -    (values s c)))
    241 
    +  (declare (float x))
    242 
    +  (etypecase x
    243 
    +    (single-float
    244 
    +     (multiple-value-bind (ign s c)
    245 
    +	 (%%sincosf x)
    246 
    +       (declare (ignore ign))
    247 
    +       (values s c)))
    248 
    +    (double-float
    249 
    +     (multiple-value-bind (ign s c)
    250 
    +	 (%%sincos x)
    251 
    +       (declare (ignore ign))
    252 
    +       (values s c)))))
    231 253
    232 254
    233 255 
     ;;;; Power functions.
    ... ... @@ -993,17 +1015,17 @@
    993 1015 
       (if (complexp theta)
    994 1016 
           (error (intl:gettext "Argument to CIS is complex: ~S") theta)
    995 1017 
           (number-dispatch ((theta real))
    996 
    -	((rational)
    997 
    -	 (let ((arg (coerce theta 'double-float)))
    998 
    -	   (multiple-value-bind (s c)
    999 
    -	       (%sincos arg)
    1000 
    -	     (complex (coerce c 'single-float)
    1001 
    -		      (coerce s 'single-float)))))
    1002 
    -	(((foreach single-float double-float))
    1003 
    -	 (multiple-value-bind (s c)
    1004 
    -	     (%sincos (coerce theta 'double-float))
    1005 
    -	   (complex (coerce c '(dispatch-type theta))
    1006 
    -		    (coerce s '(dispatch-type theta)))))
    1018 
    +	(((foreach rational single-float))
    1019 
    +	 (let ((arg (coerce theta 'single-float)))
    1020 
    +	   (multiple-value-bind (ign s c)
    1021 
    +	       (%%sincosf arg)
    1022 
    +	     (declare (ignore ign))
    1023 
    +	     (complex c s))))
    1024 
    +	((double-float)
    1025 
    +	 (multiple-value-bind (ign s c)
    1026 
    +	     (%%sincos theta)
    1027 
    +	     (declare (ignore ign))
    1028 
    +	   (complex c s)))
    1007 1029 
     	#+double-double
    1008 1030 
     	((double-double-float)
    1009 1031 
     	 (multiple-value-bind (s c)
    ... ... @@ -1016,14 +1038,19 @@
    1016 1038 
         ((rational)
    1017 1039 
          (if (or (> number 1) (< number -1))
    1018 1040 
     	 (complex-asin number)
    1019 
    -	 (coerce (%asin (coerce number 'double-float)) 'single-float)))
    1020 
    -    (((foreach single-float double-float))
    1041 
    +	 (%asinf (coerce number 'single-float))))
    1042 
    +    ((single-float)
    1021 1043 
          (if (or (float-nan-p number)
    1022 1044 
     	     (and (<= number (coerce 1 '(dispatch-type number)))
    1023 1045 
     		  (>= number (coerce -1 '(dispatch-type number)))))
    1024 
    -	 (coerce (%asin (coerce number 'double-float))
    1025 
    -		 '(dispatch-type number))
    1046 
    +	 (%asinf number)
    1026 1047 
     	 (complex-asin number)))
    1048 
    +    ((double-float)
    1049 
    +     (if (or (float-nan-p number)
    1050 
    +	     (and (<= number (coerce 1 '(dispatch-type number)))
    1051 
    +		  (>= number (coerce -1 '(dispatch-type number)))))
    1052 
    +	 (%asin number))
    1053 
    +     (complex-asin number))
    1027 1054 
         #+double-double
    1028 1055 
         ((double-double-float)
    1029 1056 
          (if (or (float-nan-p number)
    ... ... @@ -1040,13 +1067,18 @@
    1040 1067 
         ((rational)
    1041 1068 
          (if (or (> number 1) (< number -1))
    1042 1069 
     	 (complex-acos number)
    1043 
    -	 (coerce (%acos (coerce number 'double-float)) 'single-float)))
    1044 
    -    (((foreach single-float double-float))
    1070 
    +	 (%acosf (coerce number 'single-float))))
    1071 
    +    ((single-float)
    1045 1072 
          (if (or (float-nan-p number)
    1046 1073 
     	     (and (<= number (coerce 1 '(dispatch-type number)))
    1047 1074 
     		  (>= number (coerce -1 '(dispatch-type number)))))
    1048 
    -	 (coerce (%acos (coerce number 'double-float))
    1049 
    -		 '(dispatch-type number))
    1075 
    +	 (%acosf number)
    1076 
    +	 (complex-acos number)))
    1077 
    +    ((double-float)
    1078 
    +     (if (or (float-nan-p number)
    1079 
    +	     (and (<= number (coerce 1 '(dispatch-type number)))
    1080 
    +		  (>= number (coerce -1 '(dispatch-type number)))))
    1081 
    +	 (%acos number)
    1050 1082 
     	 (complex-acos number)))
    1051 1083 
         #+double-double
    1052 1084 
         ((double-double-float)
    ... ... @@ -1138,12 +1170,15 @@
    1138 1170 
          ;; acosh is complex if number < 1
    1139 1171 
          (if (< number 1)
    1140 1172 
     	 (complex-acosh number)
    1141 
    -	 (coerce (%acosh (coerce number 'double-float)) 'single-float)))
    1142 
    -    (((foreach single-float double-float))
    1173 
    +	 (%acoshf (coerce number 'single-float))))
    1174 
    +    ((single-float)
    1143 1175 
          (if (< number (coerce 1 '(dispatch-type number)))
    1144 1176 
     	 (complex-acosh number)
    1145 
    -	 (coerce (%acosh (coerce number 'double-float))
    1146 
    -		 '(dispatch-type number))))
    1177 
    +	 (%acoshf number)))
    1178 
    +    ((double-float)
    1179 
    +     (if (< number (coerce 1 '(dispatch-type number)))
    1180 
    +	 (complex-acosh number)
    1181 
    +	 (%acosh number)))
    1147 1182 
         #+double-double
    1148 1183 
         ((double-double-float)
    1149 1184 
          (if (< number 1w0)
    ... ... @@ -1159,13 +1194,17 @@
    1159 1194 
          ;; atanh is complex if |number| > 1
    1160 1195 
          (if (or (> number 1) (< number -1))
    1161 1196 
     	 (complex-atanh number)
    1162 
    -	 (coerce (%atanh (coerce number 'double-float)) 'single-float)))
    1163 
    -    (((foreach single-float double-float))
    1197 
    +	 (%atanhf (coerce number 'single-float))))
    1198 
    +    ((single-float)
    1164 1199 
          (if (or (> number (coerce 1 '(dispatch-type number)))
    1165 1200 
     	     (< number (coerce -1 '(dispatch-type number))))
    1166 1201 
     	 (complex-atanh number)
    1167 
    -	 (coerce (%atanh (coerce number 'double-float))
    1168 
    -		 '(dispatch-type number))))
    1202 
    +	 (%atanhf number)))
    1203 
    +    ((double-float)
    1204 
    +     (if (or (> number (coerce 1 '(dispatch-type number)))
    1205 
    +	     (< number (coerce -1 '(dispatch-type number))))
    1206 
    +	 (complex-atanh number)
    1207 
    +	 (%atanh number)))
    1169 1208 
         #+double-double
    1170 1209 
         ((double-double-float)
    1171 1210 
          (if (or (> number 1w0)

  • src/compiler/float-tran.lisp
    ... ... @@ -683,25 +683,41 @@
    683 683 
     		 (asinh %asinh *)
    684 684 
     		 (acosh %acosh float)
    685 685 
     		 (atanh %atanh float)))
    686 
    +  (destructuring-bind (name prim rtype)
    687 
    +      stuff
    688 
    +    (let ((primf (intern (string (symbolicate prim "F"))
    689 
    +			 "KERNEL")))
    690 
    +    (deftransform name ((x) '(single-float) rtype :eval-name t)
    691 
    +      `(,primf x))
    692 
    +    (deftransform name ((x) '(double-float) rtype :eval-name t :when :both)
    693 
    +      `(,prim x)))))
    694 
    +
    695 
    +#-core-math
    696 
    +(dolist (stuff '((sqrt %sqrt float)))
    686 697 
       (destructuring-bind (name prim rtype) stuff
    687 698 
         (deftransform name ((x) '(single-float) rtype :eval-name t)
    688 699 
           `(coerce (,prim (coerce x 'double-float)) 'single-float))
    689 700 
         (deftransform name ((x) '(double-float) rtype :eval-name t :when :both)
    690 
    -      `(,prim x))))
    701 
    +		  `(,prim x))))
    691 702
    692 
    -(defknown (%sincos)
    693 
    -    (double-float) (values double-float double-float)
    703 
    +(defknown (kernel::%%sincos)
    704 
    +    (double-float) (values null double-float double-float)
    694 705 
         (movable foldable flushable))
    695 706
    696 
    -(deftransform cis ((x) (single-float) * :when :both)
    697 
    -  `(multiple-value-bind (s c)
    698 
    -       (%sincos (coerce x 'double-float))
    699 
    -     (complex (coerce c 'single-float)
    700 
    -	      (coerce s 'single-float))))
    707 
    +(defknown (kernel::%%sincosf)
    708 
    +    (single-float) (values null single-float single-float)
    709 
    +    (movable foldable flushable))
    701 710
    702 711 
     (deftransform cis ((x) (double-float) * :when :both)
    703 
    -  `(multiple-value-bind (s c)
    704 
    -       (%sincos x)
    712 
    +  `(multiple-value-bind (ign s c)
    713 
    +       (kernel::%%sincos x)
    714 
    +     (declare (ignore ign))
    715 
    +     (complex c s)))
    716 
    +
    717 
    +(deftransform cis ((x) (single-float) * :when :both)
    718 
    +  `(multiple-value-bind (ign s c)
    719 
    +       (kernel::%%sincosf x)
    720 
    +     (declare (ignore ign))
    705 721 
          (complex c s)))
    706 722
    707 723 
     ;;; The argument range is limited on the x86 FP trig. functions. A

  • src/lisp/fdlibm.h
    ... ... @@ -69,6 +69,7 @@ extern double __ieee754_log10(double x);
    69 69 
     extern double __ieee754_pow(double x, double y);
    70 70 
     extern double __ieee754_hypot(double x, double y);
    71 71 
     extern double fdlibm_scalbn(double x, int n);
    72 
    +extern double fdlibm_log2(double x);
    72 73
    73 74 
     enum FDLIBM_EXCEPTION {
    74 75 
       FDLIBM_DIVIDE_BY_ZERO,

  • src/lisp/irrat.c
    ... ... @@ -32,6 +32,7 @@ extern double cr_hypot(double, double);
    32 32 
     extern double cr_log1p(double);
    33 33 
     extern double cr_expm1(double);
    34 34 
     extern void cr_sincos(double, double *, double *);
    35 
    +extern double cr_log2(double);
    35 36
    36 37 
     extern float cr_sinf(float);
    37 38 
     extern float cr_cosf(float);
    ... ... @@ -54,6 +55,7 @@ extern float cr_hypotf(float, float);
    54 55 
     extern float cr_log1pf(float);
    55 56 
     extern float cr_expm1f(float);
    56 57 
     extern void cr_sincosf(float, float *, float *);
    58 
    +extern float cr_log2f(float);
    57 59 
     #else
    58 60 
     #include "openlibm_math.h"
    59 61 
     /*
    ... ... @@ -72,6 +74,7 @@ extern void openlibm_sincosf(float, float*, float*);
    72 74 
     extern float __ieee754_acosf(float);
    73 75 
     extern float __ieee754_acoshf(float);
    74 76 
     extern float __ieee754_logf(float);
    77 
    +extern float __ieee754_log2f(float);
    75 78 
     extern float __ieee754_atanhf(float);
    76 79 
     extern float __ieee754_asinf(float);
    77 80 
     extern float __ieee754_atan2f(float, float);
    ... ... @@ -102,7 +105,7 @@ extern float __ieee754_hypotf(float, float);
    102 105 
                 return fdlibm_setexception(x, FDLIBM_OVERFLOW); \
    103 106 
             }						    \
    104 107 
         } while (0)
    105 
    -
    108 
    +
    106 109
    107 110 
     double
    108 111 
     lisp_sin(double x)
    ... ... @@ -363,6 +366,16 @@ lisp_sincos(double x, double *s, double *c)
    363 366 
     #endif
    364 367 
     }
    365 368
    369 
    +double
    370 
    +lisp_log2(double x)
    371 
    +{
    372 
    +#ifdef FEATURE_CORE_MATH
    373 
    +    return cr_log2(x);
    374 
    +#else
    375 
    +    return fdlibm_log2(x);
    376 
    +#endif
    377 
    +}
    378 
    +
    366 379 
     /*
    367 380 
      * The single-float versions of the special functions.  When core-math
    368 381 
      * is set, we use the single-float core-math functions.  Otherwise, we
    ... ... @@ -592,3 +605,13 @@ lisp_sincosf(float x, float *s, float *c)
    592 605 
         openlibm_sincosf(x, s, c);
    593 606 
     #endif
    594 607 
     }
    608 
    +
    609 
    +float
    610 
    +lisp_log2f(float x)
    611 
    +{
    612 
    +#ifdef FEATURE_CORE_MATH
    613 
    +    return cr_log2f(x);
    614 
    +#else
    615 
    +    return __ieee754_log2f(x);
    616 
    +#endif
    617 
    +}

  • src/lisp/log2.c
    ... ... @@ -39,7 +39,7 @@ cp = 9.61796693925975554329e-01, /* 0x3FEEC709, 0xDC3A03FD =2/(3ln2) */
    39 39 
     cp_h  =  9.61796700954437255859e-01, /* 0x3FEEC709, 0xE0000000 =(float)cp */
    40 40 
     cp_l  = -7.02846165095275826516e-09; /* 0xBE3E2FE0, 0x145B01F5 =tail of cp_h*/
    41 41
    42 
    -double lisp_log2(double x)
    42 
    +double fdlibm_log2(double x)
    43 43 
     {
    44 44 
         double ax;
    45 45 
         int k, hx, lx, ix;

  • src/lisp/openlibm/e_expf.c
    ... ... @@ -58,7 +58,15 @@ __ieee754_expf(float x)
    58 58 
     		 return x+x;	 		/* NaN */
    59 59 
                 if(hx==0x7f800000)
    60 60 
     		return (xsb==0)? x:0.0;		/* exp(+-inf)={inf,0} */
    61 
    -	    if(x > o_threshold) return huge*huge; /* overflow */
    61 
    +	    /*
    62 
    +	     * Signal overflow.  This keeps the compiler from
    63 
    +	     * constant-folding the result that then no longer signals
    64 
    +	     * an overflow.
    65 
    +	     */
    66 
    +	    if(x > o_threshold) {
    67 
    +		volatile float fhuge = huge;
    68 
    +		return fhuge*fhuge; /* overflow */
    69 
    +	    }
    62 70 
     	    if(x < u_threshold) return twom100*twom100; /* underflow */
    63 71 
     	}
    64 72

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help Notification message regarding https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b767e8f7fb0e35c82a9b4452eb2b46e77a2de8d7...7be8841885c5b8e1f3a43bb99e3683a7d4cb779c at 1782868083