Raymond Toy pushed to branch issue-466-c-wrapper-specfun at cmucl / cmucl Commits: c970737c by Raymond Toy at 2026-01-26T12:58:33-08:00 Support single-float versions of the special functions Define C wrapper for the single-float versions of the special functions. This just converts the arg to a double and then converts the result to a single. Update `def-math-rtn` to generate the single-float interface by appending an "f" to the the lisp name as well as the C name. Export all the new single-float functions. Finally, update the deftransfrom to call the single-float version and add defknowns for the new single-float functions. - - - - - 4 changed files: - src/code/exports.lisp - src/code/irrat.lisp - src/compiler/float-tran.lisp - src/lisp/irrat.c Changes: ===================================== src/code/exports.lisp ===================================== @@ -2184,7 +2184,28 @@ "STANDARD-PPRINT-DISPATCH-TABLE-MODIFIED-ERROR" "%IEEE754-REM-PI/2" - "%SINCOS") + "%SINCOS" + "%SINF" + "%COSF" + "%TANF" + "%ATANF" + "%ATAN2F" + "%ASINF" + "%ACOSF" + "%SINHF" + "%COSHF" + "%TANHF" + "%ASINHF" + "%ACOSHF" + "%ATANHF" + "%EXPF" + "%LOGF" + "%LOG10F" + "%LOG2F" + "%POWF" + "%HYPOTF" + "%LOG1PF" + "%EXPM1F") #+heap-overflow-check (:export "DYNAMIC-SPACE-OVERFLOW-WARNING-HIT" "DYNAMIC-SPACE-OVERFLOW-ERROR-HIT" ===================================== src/code/irrat.lisp ===================================== @@ -47,21 +47,29 @@ (intern (concatenate 'simple-string "%" (string-upcase name))))) + (let ((c-name-f (concatenate 'simple-string c-name "f")) + (lisp-name-f (symbolicate lisp-name "F"))) `(progn - (declaim (inline ,lisp-name)) - (export ',lisp-name) + (declaim (inline ,lisp-name ,lisp-name-f)) + (export '(,lisp-name ,lisp-name-f)) (alien:def-alien-routine (,c-name ,lisp-name) double-float ,@(let ((results nil)) (dotimes (i num-args (nreverse results)) (push (list (intern (format nil "ARG-~D" i)) 'double-float) - results))))))) + results)))) + (alien:def-alien-routine (,c-name-f ,lisp-name-f) single-float + ,@(let ((results nil)) + (dotimes (i num-args (nreverse results)) + (push (list (intern (format nil "ARG-~D" i)) + 'single-float) + results)))))))) (eval-when (compile load eval) (defun handle-reals (function var) `((((foreach fixnum single-float bignum ratio)) - (coerce (,function (coerce ,var 'double-float)) 'single-float)) + (,(symbolicate function "F") (coerce ,var 'single-float))) ((double-float) (,function ,var)) #+double-double ===================================== src/compiler/float-tran.lisp ===================================== @@ -620,42 +620,84 @@ (double-float) double-float (movable foldable flushable)) +(defknown (%tanf %sinhf %asinhf %atanhf %logf %log10f) + (single-float) single-float + (movable foldable flushable)) + (defknown (%sin %cos %tanh #+x87 %sin-quick #+x87 %cos-quick) (double-float) (double-float -1.0d0 1.0d0) (movable foldable flushable)) +(defknown (%sinf %cosf %tanhf) + (single-float) (single-float -1.0f0 1.0f0) + (movable foldable flushable)) + (defknown (%asin %atan) (double-float) (double-float #.(- (/ pi 2)) #.(/ pi 2)) (movable foldable flushable)) +(defknown (%asinf %atanf) + (single-float) (single-float #.(coerce (- (/ pi 2)) 'single-float) + #.(coerce (/ pi 2) 'single-float)) + (movable foldable flushable)) + (defknown (%acos) (double-float) (double-float 0.0d0 #.pi) (movable foldable flushable)) +(defknown (%acosf) + (single-float) (single-float 0.0f0 #.(coerce pi 'single-float)) + (movable foldable flushable)) + (defknown (%cosh) (double-float) (double-float 1.0d0) (movable foldable flushable)) +(defknown (%coshf) + (single-float) (single-float 1.0f0) + (movable foldable flushable)) + (defknown (%acosh %exp %sqrt) (double-float) (double-float 0.0d0) (movable foldable flushable)) +(defknown (%acoshf %expf) + (single-float) (single-float 0.0f0) + (movable foldable flushable)) + (defknown %expm1 (double-float) (double-float -1d0) (movable foldable flushable)) +(defknown %expm1f + (single-float) (single-float -1f0) + (movable foldable flushable)) + (defknown (%hypot) (double-float double-float) (double-float 0d0) (movable foldable flushable)) +(defknown (%hypotf) + (single-float single-float) (single-float 0f0) + (movable foldable flushable)) + (defknown (%pow) (double-float double-float) double-float (movable foldable flushable)) +(defknown (%powf) + (single-float single-float) single-float + (movable foldable flushable)) + (defknown (%atan2) (double-float double-float) (double-float #.(- pi) #.pi) (movable foldable flushable)) +(defknown (%atan2f) + (single-float single-float) (single-float #.(coerce (- pi) 'single-float) + #.(coerce pi 'single-float)) + (movable foldable flushable)) + (defknown (%scalb) (double-float double-float) double-float (movable foldable flushable)) @@ -668,6 +710,10 @@ (double-float) double-float (movable foldable flushable)) +(defknown (%log1pf) + (single-float) single-float + (movable foldable flushable)) + (dolist (stuff '((exp %exp *) (log %log float) (sqrt %sqrt float) @@ -684,10 +730,11 @@ (acosh %acosh float) (atanh %atanh float))) (destructuring-bind (name prim rtype) stuff - (deftransform name ((x) '(single-float) rtype :eval-name t) - `(coerce (,prim (coerce x 'double-float)) 'single-float)) - (deftransform name ((x) '(double-float) rtype :eval-name t :when :both) - `(,prim x)))) + (let ((primf (symbolicate prim "F"))) + (deftransform name ((x) '(single-float) rtype :eval-name t) + `(,primf x)) + (deftransform name ((x) '(double-float) rtype :eval-name t :when :both) + `(,prim x))))) (defknown (%sincos) (double-float) (values double-float double-float) ===================================== src/lisp/irrat.c ===================================== @@ -136,3 +136,126 @@ lisp_scalbn(double x, int n) { return fdlibm_scalbn(x, n); } + +/* + * Wrappers for the single-float versions + */ +float +lisp_sinf(float x) +{ + return (float) fdlibm_sin((double) x); +} + +float +lisp_cosf(float x) +{ + return (float) fdlibm_cos((double) x); +} + +float +lisp_tanf(float x) +{ + return (float) fdlibm_tan((double) x); +} + +float +lisp_atanf(float x) +{ + return (float) fdlibm_atan((double) x); +} + +float +lisp_atan2f(float y, float x) +{ + return (float) __ieee754_atan2((double) y, (double) x); +} + +float +lisp_asinf(float x) +{ + return (float) __ieee754_asin((double) x); +} + +float +lisp_acosf(float x) +{ + return (float) __ieee754_acos((double) x); +} + +float +lisp_sinhf(float x) +{ + return (float) __ieee754_sinh((double) x); +} + +float +lisp_coshf(float x) +{ + return (float) __ieee754_cosh((double) x); +} + +float +lisp_tanhf(float x) +{ + return (float) fdlibm_tanh((double) x); +} + +float +lisp_asinhf(float x) +{ + return (float) fdlibm_asinh((double) x); +} + +float +lisp_acoshf(float x) +{ + return (float) __ieee754_acosh((double) x); +} + +float +lisp_atanhf(float x) +{ + return (float) __ieee754_atanh((double) x); +} + +float +lisp_expf(float x) +{ + return (float) __ieee754_exp((double) x); +} + +float +lisp_logf(float x) +{ + return (float) __ieee754_log((double) x); +} + +float +lisp_log10f(float x) +{ + return (float) __ieee754_log10((double) x); +} + +float +lisp_powf(float x, float y) +{ + return (float) __ieee754_pow((double) x, (double) y); +} + +float +lisp_hypotf(float x, float y) +{ + return (float) __ieee754_hypot((double) x, (double) y); +} + +float +lisp_log1pf(float x) +{ + return (float) fdlibm_log1p((double) x); +} + +float +lisp_expm1f(float x) +{ + return (float) fdlibm_expm1((double) x); +} View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/c970737c75c9273bf89cfb86... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/c970737c75c9273bf89cfb86... You're receiving this email because of your account on gitlab.common-lisp.net.