Commit cb786538 authored by rtoy's avatar rtoy
Browse files

Merge in SSE2 changes from sse2-packed-branch (tag

sse2-packed-2008-11-12).
parent 139b5ed6
;; Bootstrap file for cross-compiling SSE2 support for x86.
(in-package :cl-user)
;;; Rename the X86 package and backend so that new-backend does the
;;; right thing.
(rename-package "X86" "OLD-X86" '("OLD-VM"))
(setf (c:backend-name c:*native-backend*) "OLD-X86")
(c::new-backend "X86"
;; Features to add here. These are just examples. You may not
;; need to list anything here. We list them here anyway as a
;; record of typical features for all x86 ports.
'(:x86 :i486 :pentium
:stack-checking ; Catches stack overflow
:heap-overflow-check ; Catches heap overflows
:relative-package-names ; relative package names
:mp ; multiprocessing
:gencgc ; Generational GC
:conservative-float-type
:hash-new
:random-mt19937
:cmu :cmu19 :cmu19e ; Version features
:double-double ; double-double float support
:sse2 ; SSE2 support
:complex-fp-vops ; VOPs for complex arithmetic
)
;; Features to remove from current *features* here. Normally don't
;; need to list anything here unless you are trying to remove a
;; feature.
'(:x86-bootstrap
;; :alpha :osf1 :mips
:propagate-fun-type :propagate-float-type :constrain-float-type
;; :openbsd :freebsd :glibc2 :linux
:long-float :new-random :small))
;;; Compile the new backend.
(pushnew :bootstrap *features*)
(pushnew :building-cross-compiler *features*)
(pushnew :sse2 *features*)
(pushnew :complex-fp-vops *features*)
(load "target:tools/comcom")
;;; Load the new backend.
(setf (search-list "c:")
'("target:compiler/"))
(setf (search-list "vm:")
'("c:x86/" "c:generic/"))
(setf (search-list "assem:")
'("target:assembly/" "target:assembly/x86/"))
;; Load the backend of the compiler.
;; Why do it explicitly this way? Why not use loadbackend.lisp?
(in-package "C")
(load "vm:vm-macs")
(load "vm:parms")
(load "vm:objdef")
(load "vm:interr")
(load "assem:support")
(load "target:compiler/srctran")
(load "vm:vm-typetran")
(load "target:compiler/float-tran")
(load "target:compiler/saptran")
(load "vm:macros")
(load "vm:utils")
(load "vm:vm")
(load "vm:insts")
(load "vm:primtype")
(load "vm:move")
(load "vm:sap")
(when (target-featurep :sse2)
(load "vm:sse2-sap"))
(load "vm:system")
(load "vm:char")
(if (target-featurep :sse2)
(load "vm:float-sse2")
(load "vm:float"))
(load "vm:memory")
(load "vm:static-fn")
(load "vm:arith")
(load "vm:cell")
(load "vm:subprim")
(load "vm:debug")
(load "vm:c-call")
(when (target-featurep :sse2)
(load "vm:sse2-c-call"))
(load "vm:print")
(load "vm:alloc")
(load "vm:call")
(load "vm:nlx")
(load "vm:values")
;; These need to be loaded before array because array wants to use
;; some vops as templates.
(load (if (target-featurep :sse2)
"vm:sse2-array"
"vm:x87-array"))
(load "vm:array")
(load "vm:pred")
(load "vm:type-vops")
(load "assem:assem-rtns")
(load "assem:array")
(load "assem:arith")
(load "assem:alloc")
(load "c:pseudo-vops")
(check-move-function-consistency)
(load "vm:new-genesis")
;;; OK, the cross compiler backend is loaded.
(setf *features* (remove :building-cross-compiler *features*))
;;; Info environment hacks.
(macrolet ((frob (&rest syms)
`(progn ,@(mapcar #'(lambda (sym)
`(defconstant ,sym
(symbol-value
(find-symbol ,(symbol-name sym)
:vm))))
syms))))
(frob OLD-VM:BYTE-BITS OLD-VM:WORD-BITS
#+long-float OLD-VM:SIMPLE-ARRAY-LONG-FLOAT-TYPE
OLD-VM:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE
OLD-VM:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
#+long-float OLD-VM:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE
OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE
OLD-VM:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE
OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE
OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE
OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE
OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE
OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE
OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
OLD-VM:SIMPLE-BIT-VECTOR-TYPE
OLD-VM:SIMPLE-STRING-TYPE OLD-VM:SIMPLE-VECTOR-TYPE
OLD-VM:SIMPLE-ARRAY-TYPE OLD-VM:VECTOR-DATA-OFFSET
OLD-VM:DOUBLE-FLOAT-EXPONENT-BYTE
OLD-VM:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX
OLD-VM:DOUBLE-FLOAT-SIGNIFICAND-BYTE
OLD-VM:SINGLE-FLOAT-EXPONENT-BYTE
OLD-VM:SINGLE-FLOAT-NORMAL-EXPONENT-MAX
OLD-VM:SINGLE-FLOAT-SIGNIFICAND-BYTE
)
#+double-double
(frob OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE
OLD-VM:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE))
;; Modular arith hacks
(setf (fdefinition 'vm::ash-left-mod32) #'old-vm::ash-left-mod32)
(setf (fdefinition 'vm::lognot-mod32) #'old-vm::lognot-mod32)
;; End arith hacks
(let ((function (symbol-function 'kernel:error-number-or-lose)))
(let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
(setf (symbol-function 'kernel:error-number-or-lose) function)
(setf (info function kind 'kernel:error-number-or-lose) :function)
(setf (info function where-from 'kernel:error-number-or-lose) :defined)))
(defun fix-class (name)
(let* ((new-value (find-class name))
(new-layout (kernel::%class-layout new-value))
(new-cell (kernel::find-class-cell name))
(*info-environment* (c:backend-info-environment c:*target-backend*)))
(remhash name kernel::*forward-referenced-layouts*)
(kernel::%note-type-defined name)
(setf (info type kind name) :instance)
(setf (info type class name) new-cell)
(setf (info type compiler-layout name) new-layout)
new-value))
(fix-class 'c::vop-parse)
(fix-class 'c::operand-parse)
#+random-mt19937
(declaim (notinline kernel:random-chunk))
(setf c:*backend* c:*target-backend*)
;;; Extern-alien-name for the new backend.
(in-package :vm)
(defun extern-alien-name (name)
(declare (type simple-string name))
name)
(export 'extern-alien-name)
(export 'fixup-code-object)
(export 'sanctify-for-execution)
(in-package :cl-user)
;;; Don't load compiler parts from the target compilation
(defparameter *load-stuff* nil)
;; hack, hack, hack: Make old-vm::any-reg the same as
;; x86::any-reg as an SC. Do this by adding old-vm::any-reg
;; to the hash table with the same value as x86::any-reg.
(let ((ht (c::backend-sc-names c::*target-backend*)))
(setf (gethash 'old-vm::any-reg ht)
(gethash 'vm::any-reg ht)))
......@@ -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/commandline.lisp,v 1.15 2004/08/17 20:24:37 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/commandline.lisp,v 1.16 2008/11/12 15:04:23 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -206,3 +206,5 @@
(defswitch "lib")
(defswitch "quiet")
(defswitch "debug-lisp-search")
#+x86
(defswitch "fpu")
......@@ -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/error.lisp,v 1.85 2006/01/03 18:09:55 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.86 2008/11/12 15:04:23 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -908,7 +908,7 @@
(multiple-value-prog1
(progn ,@forms)
;; Wait for any float exceptions
#+x86 (float-wait))))
#+x87 (float-wait))))
;;;; Condition definitions.
......@@ -1172,8 +1172,8 @@
(go ,(car annotated-case)))))
annotated-cases)
(return-from ,tag
#-x86 ,form
#+x86 (multiple-value-prog1 ,form
#-x87 ,form
#+x87 (multiple-value-prog1 ,form
;; Need to catch FP errors here!
(kernel::float-wait))))
,@(mapcan
......
......@@ -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.272 2008/10/03 13:34:01 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.273 2008/11/12 15:04:23 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -2222,7 +2222,11 @@
"SIMPLE-UNDEFINED-FUNCTION" "SIMPLE-PARSE-ERROR" "SIMPLE-STREAM-ERROR"
"BYTE-FUNCTION-TYPE" "SLOT-CLASS-PRINT-FUNCTION"
"REDEFINE-LAYOUT-WARNING" "SLOT-CLASS" "INSURED-FIND-CLASS"
"CONDITION-FUNCTION-NAME")
"CONDITION-FUNCTION-NAME"
"%COMPLEX-SINGLE-FLOAT"
"%COMPLEX-DOUBLE-FLOAT"
"%COMPLEX-DOUBLE-DOUBLE-FLOAT")
#+heap-overflow-check
(:export "DYNAMIC-SPACE-OVERFLOW-WARNING-HIT"
"DYNAMIC-SPACE-OVERFLOW-ERROR-HIT"
......
......@@ -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/float-trap.lisp,v 1.32 2008/01/03 11:41:51 cshapiro Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.33 2008/11/12 15:04:23 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -54,9 +54,42 @@
;;; Interpreter stubs.
;;;
#-sse2
(progn
(defun floating-point-modes () (floating-point-modes))
(defun (setf floating-point-modes) (new) (setf (floating-point-modes) new))
)
#+sse2
(progn
(defun floating-point-modes ()
;; Combine the modes from the FPU and SSE2 units. Since the sse
;; mode contains all of the common information we want, we massage
;; the x87-modes to match, and then OR the x87 and sse2 modes
;; together. Note: We ignore the rounding control bits from the
;; FPU and only use the SSE2 rounding control bits.
(let* ((x87-modes (vm::x87-floating-point-modes))
(sse-modes (vm::sse2-floating-point-modes))
(final-mode (logior sse-modes
(ash (logand #x3f x87-modes) 7) ; control
(logand #x3f (ash x87-modes -16)))))
final-mode))
(defun (setf floating-point-modes) (new-mode)
(declare (type (unsigned-byte 24) new-mode))
;; Set the floating point modes for both X87 and SSE2. This
;; include the rounding control bits.
(let* ((rc (ldb float-rounding-mode new-mode))
(x87-modes
(logior (ash (logand #x3f new-mode) 16)
(ash rc 10)
(logand #x3f (ash new-mode -7))
;; Set precision control to be 64-bit, always.
(ash 3 8))))
(setf (vm::sse2-floating-point-modes) new-mode)
(setf (vm::x87-floating-point-modes) x87-modes))
new-mode)
)
;;; SET-FLOATING-POINT-MODES -- Public
;;;
......@@ -188,6 +221,20 @@
(setf (sigcontext-floating-point-modes
(alien:sap-alien scp (* unix:sigcontext)))
new-modes))
#+sse2
(let* ((new-modes modes)
(new-exceptions (logandc2 (ldb float-exceptions-byte new-modes)
traps)))
;; Clear out the status for any enabled traps. With SSE2, if
;; the current exception is enabled, the next FP instruction
;; will cause the exception to be signaled again. Hence, we
;; need to clear out the exceptions that we are handling here.
(setf (ldb float-exceptions-byte new-modes) new-exceptions)
;; XXX: This seems not right. Shouldn't we be setting the modes
;; in the sigcontext instead? This however seems to do what we
;; want.
(setf (vm:floating-point-modes) new-modes))
(multiple-value-bind (fop operands)
(let ((sym (find-symbol "GET-FP-OPERANDS" "VM")))
(if (fboundp sym)
......@@ -216,7 +263,6 @@
(t
(error "SIGFPE with no exceptions currently enabled?"))))))
;;; WITH-FLOAT-TRAPS-MASKED -- Public
;;;
(defmacro with-float-traps-masked (traps &body body)
......
......@@ -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/irrat.lisp,v 1.57 2008/10/22 14:02:27 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.58 2008/11/12 15:04:23 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -59,13 +59,18 @@
;;; Please refer to the Unix man pages for details about these routines.
;;; Trigonometric.
#-x86 (def-math-rtn "sin" 1)
#-x86 (def-math-rtn "cos" 1)
#-x86 (def-math-rtn "tan" 1)
#-(and x86 (not sse2))
(progn
;; For x86 (without sse2), we can use x87 instructions to implement
;; these. With sse2, we don't currently support that, so these
;; should be disabled.
(def-math-rtn "sin" 1)
(def-math-rtn "cos" 1)
(def-math-rtn "tan" 1)
(def-math-rtn "atan" 1)
(def-math-rtn "atan2" 2))
(def-math-rtn "asin" 1)
(def-math-rtn "acos" 1)
#-x86 (def-math-rtn "atan" 1)
#-x86 (def-math-rtn "atan2" 2)
(def-math-rtn "sinh" 1)
(def-math-rtn "cosh" 1)
(def-math-rtn "tanh" 1)
......@@ -74,15 +79,25 @@
(def-math-rtn "atanh" 1)
;;; Exponential and Logarithmic.
#-x86 (def-math-rtn "exp" 1)
#-x86 (def-math-rtn "log" 1)
#-x86 (def-math-rtn "log10" 1)
#-(and x86 (not sse2))
(progn
(def-math-rtn "exp" 1)
(def-math-rtn "log" 1)
(def-math-rtn "log10" 1))
(def-math-rtn "pow" 2)
#-(or x86 sparc-v7 sparc-v8 sparc-v9) (def-math-rtn "sqrt" 1)
#-(or x86 sparc-v7 sparc-v8 sparc-v9)
(def-math-rtn "sqrt" 1)
(def-math-rtn "hypot" 2)
#-(or hpux x86) (def-math-rtn "log1p" 1)
#+x86 ;; These are needed for use by byte-compiled files.
;; Don't want log1p to use the x87 instruction.
#-(or hpux (and x86 (not sse2)))
(def-math-rtn "log1p" 1)
;; These are needed for use by byte-compiled files. But don't use
;; these with sse2 since we don't support using the x87 instructions
;; here.
#+(and x86 (not sse2))
(progn
#+nil
(defun %sin (x)
......@@ -204,7 +219,7 @@
)
#+ppc
#+(or ppc sse2)
(progn
(declaim (inline %%sin %%cos %%tan))
(macrolet ((frob (alien-name lisp-name)
......@@ -266,9 +281,10 @@
(if (evenp n)
(,tan reduced)
(- (/ (,tan reduced)))))))))))
#+x86
;; Don't want %sin-quick and friends with sse2.
#+(and x86 (not sse2))
(frob %sin-quick %cos-quick %tan-quick)
#+ppc
#+(or ppc sse2)
(frob %%sin %%cos %%tan))
......
......@@ -5,7 +5,7 @@
;;; the Public domain, and is provided 'as is'.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/multi-proc.lisp,v 1.43 2005/07/05 13:12:50 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/multi-proc.lisp,v 1.44 2008/11/12 15:04:23 rtoy Rel $")
;;;
;;; **********************************************************************
;;;
......@@ -1305,7 +1305,7 @@
"Allow other processes to run."
(unless *inhibit-scheduling*
;; Catch any FP exceptions before entering the scheduler.
(kernel:float-wait)
#+x87 (kernel:float-wait)
;; Inhibit recursive entry of the scheduler.
(setf *inhibit-scheduling* t)
(assert (eq (first *remaining-processes*) *current-process*))
......
......@@ -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/sparc-svr4-vm.lisp,v 1.11 2008/09/16 19:19:53 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sparc-svr4-vm.lisp,v 1.12 2008/11/12 15:04:23 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -20,6 +20,8 @@
sigcontext-float-register sigcontext-floating-point-modes
extern-alien-name sanctify-for-execution))
#+complex-fp-vops
(sys:register-lisp-feature :complex-fp-vops)
;;;; The sigcontext structure.
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/x86-vm.lisp,v 1.29 2008/01/03 11:41:52 cshapiro Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/x86-vm.lisp,v 1.30 2008/11/12 15:04:23 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -29,6 +29,14 @@
sigcontext-float-register sigcontext-floating-point-modes
extern-alien-name sanctify-for-execution))
#+sse2
(sys:register-lisp-runtime-feature :sse2)
#+complex-fp-vops
(sys:register-lisp-feature :complex-fp-vops)
#+(or x87 (not :sse2))
(sys:register-lisp-feature :x87)
;;;; The sigcontext structure.
......@@ -270,6 +278,17 @@
(* sigcontext)))))
(alien-funcall fn scp)))
(defun %set-sigcontext-floating-point-modes (scp new-mode)
(declare (type (alien (* sigcontext)) scp))
(let ((fn (extern-alien "os_set_sigcontext_fpu_modes"
(function (integer 32)
(* sigcontext)
c-call:unsigned-int))))
(alien-funcall fn scp new-mode)
new-mode))
(defsetf sigcontext-floating-point-modes %set-sigcontext-floating-point-modes)
;;; EXTERN-ALIEN-NAME -- interface.
;;;
......
......@@ -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.121 2008/06/26 21:00:25 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.122 2008/11/12 15:04:23 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -75,6 +75,33 @@
(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-float)
(movable foldable flushable))
(macrolet
((frob (type)
(let ((name (symbolicate "%COMPLEX-" type "-FLOAT"))
(convert (symbolicate "%" type "-FLOAT")))
`(progn
(defun ,name (n)
(typecase 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))
......@@ -87,6 +114,13 @@
'(%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))))))
......@@ -420,6 +454,7 @@
(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)))
......@@ -428,6 +463,7 @@
(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)
......@@ -653,7 +689,8 @@
(destructuring-bind (name prim prim-quick limit)
stuff
(deftransform name ((x) '(single-float) '* :eval-name t)
(if (backend-featurep :x86)
(if (and (backend-featurep :x86)
(not (backend-featurep :sse2)))
(cond ((csubtypep (continuation-type x)
(specifier-type `(single-float
(,(- (expt 2f0 limit)))
......@@ -669,7 +706,8 @@
`(coerce (,prim (coerce x 'double-float)) 'single-float)))
`(coerce (,prim (coerce x 'double-float)) 'single-float)))
(deftransform name ((x) '(double-float) '* :eval-name t :when :both)
(if (backend-featurep :x86)
(if (and (backend-featurep :x86)
(not (backend-featurep :sse2)))
(cond ((csubtypep (continuation-type x)
(specifier-type `(double-float
(,(- (expt 2d0 limit)))
......@@ -1413,117 +1451,230 @@
;;; Define some transforms for complex operations. We do this in lieu
;;; of complex operation VOPs. Some architectures have vops, though.
;;;
#-(and (not double-double) complex-fp-vops)
(macrolet ((frob (type)
`(progn
;; Negation
(deftransform %negate ((z) ((complex ,type)) *)
'(complex (%negate (realpart z)) (%negate (imagpart z