;;; -*- Mode: Lisp; Package: C; Log: code.log -*-

;;;
;;; **********************************************************************

;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment

  "$Header: src/compiler/float-tran.lisp $")

;;;

;;; **********************************************************************
;;;
;;; This file contains floating-point specific transforms, and may be somewhat
;;; implementation dependent in its assumptions of what the formats are.
;;;
;;; Author: Rob MacLachlan
;;; 
(in-package "C")

(intl:textdomain "cmucl")


;;;; Coercions:

(defknown %single-float (real) single-float (movable foldable flushable))
(defknown %double-float (real) double-float (movable foldable flushable))

(deftransform float ((n prototype) (* single-float) * :when :both)
  '(%single-float n))

(deftransform float ((n prototype) (* double-float) * :when :both)

  '(%double-float n))

(deftransform float ((n) *)
  `(if (floatp n) n (%single-float n)))

(deftransform %single-float ((n) (single-float) * :when :both)

  'n)

(deftransform %double-float ((n) (double-float) * :when :both)

  'n)

#+double-double
(progn
(defknown %double-double-float (real)
  double-double-float
  (movable foldable flushable))

(deftransform float ((n prototype) (* double-double-float) * :when :both)
  '(%double-double-float n))

(deftransform %double-float ((n) (double-double-float) * :when :both)
  '(double-double-hi n))

(deftransform %single-float ((n) (double-double-float) * :when :both)
  '(float (double-double-hi n) 1f0))

(deftransform %double-double-float ((n) (double-double-float) * :when :both)
  'n)

#+nil
(defun %double-double-float (n)
  (make-double-double-float (float n 1d0) 0d0))

;; Moved to code/float.lisp, because we need this relatively early in
;; the build process to handle float and real types.
#+nil

(defun %double-double-float (n)
  (typecase n
    (fixnum

     (%make-double-double-float (float n 1d0) 0d0))

    (single-float

     (%make-double-double-float (float n 1d0) 0d0))

    (double-float

     (%make-double-double-float (float n 1d0) 0d0))

    (double-double-float
     n)
    (bignum
     (bignum:bignum-to-float n 'double-double-float))
    (ratio
     (kernel::float-ratio n 'double-double-float))))
); progn

(defknown %complex-single-float (number) (complex single-float)
  (movable foldable flushable))
(defknown %complex-double-float (number) (complex double-float)
  (movable foldable flushable))

(defknown %complex-double-double-float (number) (complex double-double-float)

  (movable foldable flushable))

(macrolet
    ((frob (type)
       (let ((name (symbolicate "%COMPLEX-" type "-FLOAT"))
	     (convert (symbolicate "%" type "-FLOAT")))
	 `(progn
	    (defun ,name (n)

	      (declare (number n))
	      (etypecase n

		(real
		 (complex (,convert n)))
		(complex
		 (complex (,convert (realpart n))
			  (,convert (imagpart n))))))
	    (deftransform ,name ((n) ((complex ,(symbolicate type "-FLOAT"))) * :when :both)
	      'n)))))
  (frob single)
  (frob double)
  #+double-double
  (frob double-double))

(deftransform coerce ((n type) (* *) * :when :both)
  (unless (constant-continuation-p type)
    (give-up))
  `(the ,(continuation-value type)
	,(let ( (tspec (specifier-type (continuation-value type))) )

	   (cond #+double-double
		 ((csubtypep tspec (specifier-type 'double-double-float))
		  '(%double-double-float n))
		 ((csubtypep tspec (specifier-type 'double-float))	

		  '(%double-float n))	
		 ((csubtypep tspec (specifier-type 'float))
		  '(%single-float n))

		 #+double-double
		 ((csubtypep tspec (specifier-type '(complex double-double-float)))
		  '(%complex-double-double-float n))
		 ((csubtypep tspec (specifier-type '(complex double-float)))
		  '(%complex-double-float n))
		 ((csubtypep tspec (specifier-type '(complex single-float)))
		  '(%complex-single-float n))

		 (t
		  (give-up))))))

;;; Not strictly float functions, but primarily useful on floats:

;;;

(macrolet ((frob (fun ufun)
	     `(progn
		(defknown ,ufun (real) integer (movable foldable flushable))
		(deftransform ,fun ((x &optional by)
				    (* &optional
				       (constant-argument (member 1))))
		  '(let ((res (,ufun x)))
		     (values res (- x res)))))))
  (frob round %unary-round))

(defknown %unary-truncate (real) integer
	  (movable foldable flushable))

;; Convert (truncate x y) to the obvious implementation.  We only want
;; this when under certain conditions and let the generic truncate
;; handle the rest.  (Note: if y = 1, the divide and multiply by y
;; should be removed by other deftransforms.)

(deftransform truncate ((x &optional y)
			(float &optional (or float integer)))
  '(let ((res (%unary-truncate (/ x y))))
     (values res (- x (* y res)))))

(deftransform floor ((number &optional divisor)
		     (float &optional (or integer float)))
  '(multiple-value-bind (tru rem) (truncate number divisor)
    (if (and (not (zerop rem))
	     (if (minusp divisor)
		 (plusp number)
		 (minusp number)))
	(values (1- tru) (+ rem divisor))
	(values tru rem))))

(deftransform ceiling ((number &optional divisor)
		       (float &optional (or integer float)))
  '(multiple-value-bind (tru rem) (truncate number divisor)
    (if (and (not (zerop rem))
	     (if (minusp divisor)
		 (minusp number)
		 (plusp number)))
	(values (1+ tru) (- rem divisor))
	(values tru rem))))

(defknown %unary-ftruncate/single-float (single-float) single-float
	  (movable foldable flushable))
(defknown %unary-ftruncate/double-float (double-float) double-float
	  (movable foldable flushable))

(defknown %unary-ftruncate (real) float

	  (movable foldable flushable))

;; Convert (ftruncate x y) to the obvious implementation.  We only
;; want this under certain conditions and let the generic ftruncate
;; handle the rest.  (Note: if y = 1, the divide and multiply by y
;; should be removed by other deftransforms.)

(deftransform ftruncate ((x &optional (y 1))

			 (float &optional (or float integer)))

  '(let ((res (%unary-ftruncate (/ x y))))
     (values res (- x (* y res)))))

#+(or sparc (and x86 sse2))

(defknown fast-unary-ftruncate ((or single-float double-float))
  (or single-float double-float)
  (movable foldable flushable))

#+(or sparc (and x86 sse2))

(defoptimizer (fast-unary-ftruncate derive-type) ((f))
  (one-arg-derive-type f
		       #'(lambda (n)
			   (ftruncate-derive-type-quot-aux n
							   (specifier-type '(integer 1 1))
							   nil))
		       #'ftruncate))

;; Convert %unary-ftruncate to unary-ftruncate/{single,double}-float

;; if x is known to be of the right type.  Also, if the result is
;; known to fit in the same range as a (signed-byte 32), convert this
;; to %unary-truncate, which might be a single instruction, and float
;; the result.  However, for sparc, we have a vop to do this so call
;; that, and for Sparc V9, we can actually handle a 64-bit integer
;; range.

(macrolet ((frob (ftype func)
	     `(deftransform %unary-ftruncate ((x) (,ftype))

	       (let* ((x-type (continuation-type x))
		      (lo (bound-value (numeric-type-low x-type)))
		      (hi (bound-value (numeric-type-high x-type)))
		      (limit-lo (- (ash 1 #-sparc-v9 31 #+sparc-v9 63)))
		      (limit-hi (ash 1 #-sparc-v9 31 #+sparc-v9 63)))
		 (if (and (numberp lo) (numberp hi)
			  (< limit-lo lo)
			  (< hi limit-hi))

		     #-(or sparc (and x86 sse2))
		     '(let ((result (coerce (%unary-truncate x) ',ftype)))
		       (if (zerop result)
			   (* result x)
			   result))
		     #+(or sparc (and x86 sse2))
		     '(let ((result (fast-unary-ftruncate x)))
		       (if (zerop result)
			   (* result x)
			   result))

		     '(,func x))))))

  (frob single-float %unary-ftruncate/single-float)
  (frob double-float %unary-ftruncate/double-float))

;;; FROUND
#-x87
(progn
(deftransform fround ((x &optional (y 1))
		      ((or single-float double-float)
		       &optional (or single-float double-float integer)))
  '(let ((res (%unary-fround (/ x y))))
    (values res (- x (* y res)))))

(defknown %unary-fround (real) float
  (movable foldable flushable))

(defknown %unary-fround/single-float (single-float) single-float
  (movable foldable flushable))

(defknown %unary-fround/double-float (double-float) double-float
  (movable foldable flushable))

(deftransform %unary-fround ((x) (single-float))
  '(%unary-fround/single-float x))

(deftransform %unary-fround ((x) (double-float))
  '(%unary-fround/double-float x))

); not x87

;;; Random:
;;;
(macrolet ((frob (fun type)
	     `(deftransform random ((num &optional state)

				    (,type &optional *) *
				    :when :both)

		"use inline float operations"

		'(,fun num (or state *random-state*)))))

  (frob %random-single-float single-float)
  (frob %random-double-float double-float))

#-(or new-random random-mt19937)

(deftransform random ((num &optional state)
		      ((integer 1 #.random-fixnum-max) &optional *))

  _N"use inline fixnum operations"

  '(rem (random-chunk (or state *random-state*)) num))

;;; With the latest propagate-float-type code the compiler can inline
;;; truncate (signed-byte 32) allowing 31 bits, and (unsigned-byte 32)
;;; 32 bits on the x86. When not using the propagate-float-type
;;; feature the best size that can be inlined is 29 bits.  The choice
;;; shouldn't cause bootstrap problems just slow code.

#+new-random
(deftransform random ((num &optional state)

		      ((integer 1

				#+x86 #xffffffff
				#-x86 #x7fffffff
				)

		       &optional *))

  #+x86 (intl:gettext "use inline (unsigned-byte 32) operations")
  #-x86 (intl:gettext "use inline (signed-byte 32) operations")

  '(values (truncate (%random-double-float (coerce num 'double-float)
		      (or state *random-state*)))))

#+random-mt19937
(deftransform random ((num &optional state)
		      ((integer 1 #.(expt 2 32)) &optional *))

  _N"use inline (unsigned-byte 32) operations"

  (let* ((num-type (continuation-type num))
	 (num-high (cond ((numeric-type-p num-type)
			  (numeric-type-high num-type))
			 ((union-type-p num-type)
			  ;; Find the maximum of the union type.  We
			  ;; know this works because if we're in this
			  ;; routine, NUM must be a subtype of
			  ;; (INTEGER 1 2^32), so each member of the
			  ;; union must be a subtype too.
			  (reduce #'max (union-type-types num-type)
				  :key #'numeric-type-high))
			 (t
			  (give-up)))))

    ;; Rather than doing (rem (random-chunk) num-high), we do,
    ;; essentially, (rem (* num-high (random-chunk)) #x100000000).  I
    ;; (rtoy) believe this approach doesn't have the bias issue with
    ;; doing rem.  This method works by treating (random-chunk) as if
    ;; it were a 32-bit fraction between 0 and 1, exclusive.  Multiply
    ;; this by num-high to get a random number between 0 and num-high,
    ;; This should have no bias.

    (cond ((constant-continuation-p num)

	   (if (= num-high (expt 2 32))
	       '(random-chunk (or state *random-state*))
	       '(values (bignum::%multiply 
			 (random-chunk (or state *random-state*))
			 num))))

	  ((< num-high (expt 2 32))
	   '(values (bignum::%multiply (random-chunk (or state *random-state*))
		     num)))

	  ((= num-high (expt 2 32))
	   '(if (= num (expt 2 32))
		(random-chunk (or state *random-state*))
		(values (bignum::%multiply (random-chunk (or state *random-state*))
					   num))))

	  (t

	   (error (intl:gettext "Shouldn't happen"))))))


;;;; Float accessors:

(defknown make-single-float ((signed-byte 32)) single-float
  (movable foldable flushable))

(defknown make-double-float ((signed-byte 32) (unsigned-byte 32)) double-float

  (movable foldable flushable))

(defknown single-float-bits (single-float) (signed-byte 32)
  (movable foldable flushable))

(defknown double-float-high-bits (double-float) (signed-byte 32)
  (movable foldable flushable))

(defknown double-float-low-bits (double-float) (unsigned-byte 32)
  (movable foldable flushable))

#+(or sparc ppc (and x86 sse2))

(defknown double-float-bits (double-float)
  (values (signed-byte 32) (unsigned-byte 32))
  (movable foldable flushable))

#+double-double
(progn
(defknown double-double-float-p (t)
  boolean
  (movable foldable flushable))

(defknown %make-double-double-float (double-float double-float)
  double-double-float
  (movable foldable flushable))


(defknown double-double-hi (double-double-float)
  double-float
  (movable foldable flushable))

(defknown double-double-lo (double-double-float)
  double-float
  (movable foldable flushable))

) ; progn

(deftransform float-sign ((float &optional float2)
			  (single-float &optional single-float) *)
  (if float2
      (let ((temp (gensym)))
	`(let ((,temp (abs float2)))
	  (if (minusp (single-float-bits float)) (- ,temp) ,temp)))
      '(if (minusp (single-float-bits float)) -1f0 1f0)))

(deftransform float-sign ((float &optional float2)
			  (double-float &optional double-float) *)
  (if float2
      (let ((temp (gensym)))
	`(let ((,temp (abs float2)))
	  (if (minusp (double-float-high-bits float)) (- ,temp) ,temp)))
      '(if (minusp (double-float-high-bits float)) -1d0 1d0)))

#+double-double

(deftransform float-sign ((float &optional float2)
			  (double-double-float &optional double-double-float) *)
  (if float2
      (let ((temp (gensym)))
	`(let ((,temp (abs float2)))
	   (if (minusp (float-sign (double-double-hi float)))
	       (- ,temp)
	       ,temp)))
      '(if (minusp (float-sign (double-double-hi float))) -1w0 1w0)))

  


;;;; DECODE-FLOAT, INTEGER-DECODE-FLOAT, SCALE-FLOAT:
;;;

;;;    Convert these operations to format specific versions when the format is

;;; known.
;;;

(deftype single-float-exponent ()

  `(integer ,(- vm:single-float-normal-exponent-min vm:single-float-bias
		vm:single-float-digits)
	    ,(- vm:single-float-normal-exponent-max vm:single-float-bias)))

(deftype double-float-exponent ()

  `(integer ,(- vm:double-float-normal-exponent-min vm:double-float-bias
		vm:double-float-digits)
	    ,(- vm:double-float-normal-exponent-max vm:double-float-bias)))

(deftype single-float-int-exponent ()

  `(integer ,(- vm:single-float-normal-exponent-min vm:single-float-bias
		(* vm:single-float-digits 2))
	    ,(- vm:single-float-normal-exponent-max vm:single-float-bias
		vm:single-float-digits)))

(deftype double-float-int-exponent ()

  `(integer ,(- vm:double-float-normal-exponent-min vm:double-float-bias
		(* vm:double-float-digits 2))
	    ,(- vm:double-float-normal-exponent-max vm:double-float-bias
		vm:double-float-digits)))

(deftype single-float-significand ()

  `(integer 0 (,(ash 1 vm:single-float-digits))))

(deftype double-float-significand ()

  `(integer 0 (,(ash 1 vm:double-float-digits))))

(defknown decode-single-float (single-float)

  (values (single-float 0.5f0 (1f0))
	  single-float-exponent
	  (member -1f0 1f0))

  (movable foldable flushable))

(defknown decode-double-float (double-float)

  (values (double-float 0.5d0 (1d0))
	  double-float-exponent
	  (member -1d0 1d0))

  (movable foldable flushable))

(defknown integer-decode-single-float (single-float)
  (values single-float-significand single-float-int-exponent (integer -1 1))
  (movable foldable flushable))

(defknown integer-decode-double-float (double-float)
  (values double-float-significand double-float-int-exponent (integer -1 1))

  (movable foldable flushable))

(defknown scale-single-float (single-float fixnum) single-float
  (movable foldable flushable))

(defknown scale-double-float (double-float fixnum) double-float
  (movable foldable flushable))

(deftransform decode-float ((x) (single-float) * :when :both)

  '(decode-single-float x))

(deftransform decode-float ((x) (double-float) * :when :both)

  '(decode-double-float x))

(deftransform integer-decode-float ((x) (single-float) * :when :both)

  '(integer-decode-single-float x))

(deftransform integer-decode-float ((x) (double-float) * :when :both)

  '(integer-decode-double-float x))

(deftransform scale-float ((f ex) (single-float *) * :when :both)

  (if (and (backend-featurep :x86)

	   (not (backend-featurep :sse2))

	   (csubtypep (continuation-type ex)
		      (specifier-type '(signed-byte 32)))
	   (not (byte-compiling)))
      '(coerce (%scalbn (coerce f 'double-float) ex) 'single-float)
      '(scale-single-float f ex)))

(deftransform scale-float ((f ex) (double-float *) * :when :both)

  (if (and (backend-featurep :x86)

	   (not (backend-featurep :sse2))

	   (csubtypep (continuation-type ex)
		      (specifier-type '(signed-byte 32))))
      '(%scalbn f ex)
      '(scale-double-float f ex)))

;;; toy@rtp.ericsson.se:
;;;
;;; Optimizers for scale-float.  If the float has bounds, new bounds
;;; are computed for the result, if possible.

(defun scale-float-derive-type-aux (f ex same-arg)
  (declare (ignore same-arg))
  (flet ((scale-bound (x n)
	   ;; We need to be a bit careful here and catch any overflows
	   ;; that might occur.  We can ignore underflows which become
	   ;; zeros.
	   (set-bound

	    (let ((value (handler-case
			     (scale-float (bound-value x) n)
			   (floating-point-overflow ()
			     nil))))
	      ;; This check is necessary for ppc because the current
	      ;; implementation on ppc doesn't signal floating-point
	      ;; overflow.  (How many other places do we need to check
	      ;; for this?)
	      (if (and (floatp value) (float-infinity-p value))
		  nil
		  value))

	    (consp x))))
    (when (and (numeric-type-p f) (numeric-type-p ex))
      (let ((f-lo (numeric-type-low f))
	    (f-hi (numeric-type-high f))
	    (ex-lo (numeric-type-low ex))
	    (ex-hi (numeric-type-high ex))
	    (new-lo nil)
	    (new-hi nil))
	(when (and f-hi ex-hi)
	  (setf new-hi (scale-bound f-hi ex-hi)))
	(when (and f-lo ex-lo)
	  (setf new-lo (scale-bound f-lo ex-lo)))

	;; We're computing bounds for scale-float.  Assume the bounds
	;; on f are fl and fh, and the bounds on ex are nl and nh.
	;; The resulting bound should be fl*2^nl and fh*2^nh.
	;; However, if fh is negative, and we get an underflow, we
	;; might get bounds like 0 and fh*2^nh < 0.  Our bounds are
	;; backwards.  Thus, swap the bounds to get the correct
	;; bounds.

	(when (and new-lo new-hi (< (bound-value new-hi)
				    (bound-value new-lo)))

	  (rotatef new-lo new-hi))

	(make-numeric-type :class (numeric-type-class f)
			   :format (numeric-type-format f)
			   :complexp :real
			   :low new-lo
			   :high new-hi)))))
;;;

(defoptimizer (scale-float derive-type) ((f ex))

  (two-arg-derive-type f ex #'scale-float-derive-type-aux

		       #'scale-float))

;;; toy@rtp.ericsson.se:
;;;

;;; Defoptimizers for %single-float and %double-float.  This makes the
;;; FLOAT function return the correct ranges if the input has some

;;; defined range.  Quite useful if we want to convert some type of

;;; bounded integer into a float.

(macrolet
    ((frob (fun type)

       (let ((aux-name (symbolicate fun "-DERIVE-TYPE-AUX")))

	 `(progn

	   (defun ,aux-name (num)

	     ;; When converting a number to a float, the limits are

	     ;; the "same."  

	     (let* ((lo (bound-func #'(lambda (x)

					;; If we can't coerce it, we
					;; return a NIL for the bound.
					;; (Is IGNORE-ERRORS too
					;; heavy-handed?  Should we
					;; try to do something more
					;; fine-grained?)
					(ignore-errors (coerce x ',type)))

				    (numeric-type-low num)))
		    (hi (bound-func #'(lambda (x)

					(ignore-errors (coerce x ',type)))

				    (numeric-type-high num))))
	       (specifier-type `(,',type ,(or lo '*) ,(or hi '*)))))
	   
	   (defoptimizer (,fun derive-type) ((num))

	     (one-arg-derive-type num #',aux-name #',fun))))))

  (frob %single-float single-float)
  (frob %double-float double-float))

;;;; Float contagion:

;;; FLOAT-CONTAGION-ARG1, ARG2  --  Internal
;;;

;;;    Do some stuff to recognize when the loser is doing mixed float and

;;; rational arithmetic, or different float types, and fix it up.  If we don't,
;;; he won't even get so much as an efficency note.

;;;
(deftransform float-contagion-arg1 ((x y) * * :defun-only t :node node)
  `(,(continuation-function-name (basic-combination-fun node))
    (float x y) y))
;;;
(deftransform float-contagion-arg2 ((x y) * * :defun-only t :node node)
  `(,(continuation-function-name (basic-combination-fun node))
    x (float y x)))

(dolist (x '(+ * / -))
  (%deftransform x '(function (rational float) *) #'float-contagion-arg1)
  (%deftransform x '(function (float rational) *) #'float-contagion-arg2))

(dolist (x '(= < > + * / -))
  (%deftransform x '(function (single-float double-float) *)
		 #'float-contagion-arg1)
  (%deftransform x '(function (double-float single-float) *)
		 #'float-contagion-arg2))


;;; Prevent zerop, plusp, minusp from losing horribly.  We can't in general
;;; float rational args to comparison, since Common Lisp semantics says we are
;;; supposed to compare as rationals, but we can do it for any rational that
;;; has a precise representation as a float (such as 0).

;;;
(macrolet ((frob (op)

	     `(deftransform ,op ((x y) (float rational) * :when :both)

		(unless (constant-continuation-p y)

		  (give-up (intl:gettext "Can't open-code float to rational comparison.")))

		(let ((val (continuation-value y)))
		  (unless (eql (rational (float val)) val)

		    (give-up (intl:gettext "~S doesn't have a precise float representation.")

			     val)))
		`(,',op x (float y x)))))

  (frob <)
  (frob >)
  (frob =))

;; Convert (/ x n) to (* x (/ n)) when x is a float and n is a power
;; of two, because (/ n) can be reprsented exactly.
(deftransform / ((x y) (float float) * :when :both)
  (unless (constant-continuation-p y)
    (give-up))
  (let ((val (continuation-value y)))

    (unless (= (decode-float val) 0.5)
      (give-up))
    `(* x (float (/ ,val) x))))

;; Convert 2*x to x+x.
(deftransform * ((x y) (float real) * :when :both)
  (unless (constant-continuation-p y)
    (give-up))
  (let ((val (continuation-value y)))
    (unless (= val 2)
      (give-up))
    '(+ x x)))

	      


;;;; Irrational transforms:

(defknown (%tan %sinh %asinh %atanh %log %logb %log10 #+x87 %tan-quick)

	  (double-float) double-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 (%asin %atan)
    (double-float) (double-float #.(- (/ pi 2)) #.(/ pi 2))
    (movable foldable flushable))
    
(defknown (%acos)
    (double-float) (double-float 0.0d0 #.pi)
    (movable foldable flushable))
    
(defknown (%cosh)
    (double-float) (double-float 1.0d0)
    (movable foldable flushable))

(defknown (%acosh %exp %sqrt)
    (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))

(defknown (%pow)
    (double-float double-float) double-float
  (movable foldable flushable))

(defknown (%atan2)
    (double-float double-float) (double-float #.(- pi) #.pi)
  (movable foldable flushable))

(defknown (%scalb)
    (double-float double-float) double-float
  (movable foldable flushable))

(defknown (%scalbn)
    (double-float (signed-byte 32)) double-float
    (movable foldable flushable))

(defknown (%log1p)

    (double-float) double-float
    (movable foldable flushable))

(dolist (stuff '((exp %exp *)
		 (log %log float)
		 (sqrt %sqrt float)
		 (asin %asin float)
		 (acos %acos float)
		 (atan %atan *)
		 (sinh %sinh *)
		 (cosh %cosh *)
		 (tanh %tanh *)
		 (asinh %asinh *)
		 (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))))