From cea63d21887f793750d26fd577b21f15b093e12b Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Wed, 21 Jan 1998 19:23:48 +0000
Subject: [PATCH] Complex-float support for the Alpha backend.

---
 compiler/alpha/array.lisp     | 122 +++++++++++++-
 compiler/alpha/float.lisp     | 302 +++++++++++++++++++++++++++++++++-
 compiler/alpha/type-vops.lisp |  98 ++++++++++-
 compiler/alpha/vm.lisp        |  22 ++-
 4 files changed, 532 insertions(+), 12 deletions(-)

diff --git a/compiler/alpha/array.lisp b/compiler/alpha/array.lisp
index f4fdf5c79..39f980837 100644
--- a/compiler/alpha/array.lisp
+++ b/compiler/alpha/array.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/alpha/array.lisp,v 1.2 1994/10/31 04:39:51 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/array.lisp,v 1.3 1998/01/21 19:23:48 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -13,6 +13,7 @@
 ;;;
 ;;; Written by William Lott
 ;;; Conversion by Sean Hallgren
+;;; Complex-float support by Douglas Crosher 1998.
 ;;;
 (in-package "ALPHA")
 
@@ -145,7 +146,10 @@
 (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
   unsigned-reg)
 
-
+#+signed-array
+(def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
+#+signed-array
+(def-full-data-vector-frobs simple-array-signed-byte-32 signed-num signed-reg)
 
 ;;; Integer vectors whos elements are smaller than a byte.  I.e. bit, 2-bit,
 ;;; and 4-bit vectors.
@@ -439,3 +443,117 @@
 (define-vop (get-vector-subtype get-header-data))
 (define-vop (set-vector-subtype set-header-data))
 
+
+;;; Complex float arrays.
+#+complex-float
+(progn
+
+(define-vop (data-vector-ref/simple-array-complex-single-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-single-float positive-fixnum)
+  (:results (value :scs (complex-single-reg)))
+  (:temporary (:scs (interior-reg)) lip)
+  (:result-types complex-single-float)
+  (:generator 5
+    (let ((real-tn (complex-single-reg-real-tn value)))
+      (inst addq object index lip)
+      (inst addq lip index lip)
+      (inst lds real-tn
+	    (- (* vector-data-offset word-bytes) other-pointer-type)
+	    lip))
+    (let ((imag-tn (complex-single-reg-imag-tn value)))
+      (inst lds imag-tn
+	    (- (* (1+ vector-data-offset) word-bytes) other-pointer-type)
+	    lip))))
+
+(define-vop (data-vector-set/simple-array-complex-single-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg))
+	 (value :scs (complex-single-reg) :target result))
+  (:arg-types simple-array-complex-single-float positive-fixnum
+	      complex-single-float)
+  (:results (result :scs (complex-single-reg)))
+  (:result-types complex-single-float)
+  (:temporary (:scs (interior-reg)) lip)
+  (:generator 5
+    (let ((value-real (complex-single-reg-real-tn value))
+	  (result-real (complex-single-reg-real-tn result)))
+      (inst addq object index lip)
+      (inst addq lip index lip)
+      (inst sts value-real
+	    (- (* vector-data-offset word-bytes) other-pointer-type)
+	    lip)
+      (unless (location= result-real value-real)
+	(inst fmove value-real result-real)))
+    (let ((value-imag (complex-single-reg-imag-tn value))
+	  (result-imag (complex-single-reg-imag-tn result)))
+      (inst sts value-imag
+	    (- (* (1+ vector-data-offset) word-bytes) other-pointer-type)
+	    lip)
+      (unless (location= result-imag value-imag)
+	(inst fmove value-imag result-imag)))))
+
+(define-vop (data-vector-ref/simple-array-complex-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-double-float positive-fixnum)
+  (:results (value :scs (complex-double-reg)))
+  (:result-types complex-double-float)
+  (:temporary (:scs (interior-reg)) lip)
+  (:generator 7
+    (let ((real-tn (complex-double-reg-real-tn value)))
+      (inst addq object index lip)
+      (inst addq lip index lip)
+      (inst addq lip index lip)
+      (inst addq lip index lip)
+      (inst ldt real-tn
+	    (- (* vector-data-offset word-bytes) other-pointer-type)
+	    lip))
+    (let ((imag-tn (complex-double-reg-imag-tn value)))
+      (inst ldt imag-tn
+	    (- (* (+ vector-data-offset 2) word-bytes) other-pointer-type)
+	    lip))))
+
+(define-vop (data-vector-set/simple-array-complex-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg))
+	 (value :scs (complex-double-reg) :target result))
+  (:arg-types simple-array-complex-double-float positive-fixnum
+	      complex-double-float)
+  (:results (result :scs (complex-double-reg)))
+  (:result-types complex-double-float)
+  (:temporary (:scs (interior-reg)) lip)
+  (:generator 20
+    (let ((value-real (complex-double-reg-real-tn value))
+	  (result-real (complex-double-reg-real-tn result)))
+      (inst addq object index lip)
+      (inst addq lip index lip)
+      (inst addq lip index lip)
+      (inst addq lip index lip)
+      (inst stt value-real
+	    (- (* vector-data-offset word-bytes) other-pointer-type)
+	    lip)
+      (unless (location= result-real value-real)
+	(inst fmove value-real result-real)))
+    (let ((value-imag (complex-double-reg-imag-tn value))
+	  (result-imag (complex-double-reg-imag-tn result)))
+      (inst stt value-imag
+	    (- (* (+ vector-data-offset 2) word-bytes) other-pointer-type)
+	    lip)
+      (unless (location= result-imag value-imag)
+	(inst fmove value-imag result-imag)))))
+
+) ; end progn complex-float
diff --git a/compiler/alpha/float.lisp b/compiler/alpha/float.lisp
index 5f8937515..ec1abb9c4 100644
--- a/compiler/alpha/float.lisp
+++ b/compiler/alpha/float.lisp
@@ -6,7 +6,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/float.lisp,v 1.3 1997/06/07 19:04:38 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/float.lisp,v 1.4 1998/01/21 19:23:47 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -15,6 +15,7 @@
 ;;; Written by Rob MacLachlan
 ;;; Conversion by Sean Hallgren
 ;;; IEEE variants by Paul Werkowski
+;;; Complex-float support by Douglas Crosher 1998.
 ;;;
 (in-package "ALPHA")
 
@@ -134,9 +135,216 @@
   (frob move-single-float-argument single-reg single-stack nil)
   (frob move-double-float-argument double-reg double-stack t))
 
+
+;;;; Complex float move functions
+#+complex-float
+(progn
+
+(defun complex-single-reg-real-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg *backend*)
+		  :offset (tn-offset x)))
+(defun complex-single-reg-imag-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg *backend*)
+		  :offset (1+ (tn-offset x))))
+
+(defun complex-double-reg-real-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (tn-offset x)))
+(defun complex-double-reg-imag-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (1+ (tn-offset x))))
+
+
+(define-move-function (load-complex-single 2) (vop x y)
+  ((complex-single-stack) (complex-single-reg))
+  (let ((real-tn (complex-single-reg-real-tn y)))
+    (inst lds real-tn (* (tn-offset x) vm:word-bytes) (current-nfp-tn vop)))
+  (let ((imag-tn (complex-single-reg-imag-tn y)))
+    (inst lds imag-tn (* (1+ (tn-offset x)) vm:word-bytes)
+	  (current-nfp-tn vop))))
+
+(define-move-function (store-complex-single 2) (vop x y)
+  ((complex-single-reg) (complex-single-stack))
+  (let ((real-tn (complex-single-reg-real-tn x)))
+    (inst sts real-tn (* (tn-offset y) vm:word-bytes) (current-nfp-tn vop)))
+  (let ((imag-tn (complex-single-reg-imag-tn x)))
+    (inst sts imag-tn (* (1+ (tn-offset y)) vm:word-bytes)
+	  (current-nfp-tn vop))))
+
+
+(define-move-function (load-complex-double 4) (vop x y)
+  ((complex-double-stack) (complex-double-reg))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset x) vm:word-bytes)))
+    (let ((real-tn (complex-double-reg-real-tn y)))
+      (inst ldt real-tn offset nfp))
+    (let ((imag-tn (complex-double-reg-imag-tn y)))
+      (inst ldt imag-tn (+ offset (* 2 vm:word-bytes)) nfp))))
+
+(define-move-function (store-complex-double 4) (vop x y)
+  ((complex-double-reg) (complex-double-stack))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset y) vm:word-bytes)))
+    (let ((real-tn (complex-double-reg-real-tn x)))
+      (inst stt real-tn offset nfp))
+    (let ((imag-tn (complex-double-reg-imag-tn x)))
+      (inst stt imag-tn (+ offset (* 2 vm:word-bytes)) nfp))))
+
+;;;
+;;; Complex float register to register moves.
+;;;
+(define-vop (complex-single-move)
+  (:args (x :scs (complex-single-reg) :target y
+	    :load-if (not (location= x y))))
+  (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
+  (:note "complex single float move")
+  (:generator 0
+     (unless (location= x y)
+       ;; Note the complex-float-regs are aligned to every second
+       ;; float register so there is not need to worry about overlap.
+       (let ((x-real (complex-single-reg-real-tn x))
+	     (y-real (complex-single-reg-real-tn y)))
+	 (inst fmove x-real y-real))
+       (let ((x-imag (complex-single-reg-imag-tn x))
+	     (y-imag (complex-single-reg-imag-tn y)))
+	 (inst fmove x-imag y-imag)))))
+;;;
+(define-move-vop complex-single-move :move
+  (complex-single-reg) (complex-single-reg))
+
+(define-vop (complex-double-move)
+  (:args (x :scs (complex-double-reg)
+	    :target y :load-if (not (location= x y))))
+  (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
+  (:note "complex double float move")
+  (:generator 0
+     (unless (location= x y)
+       ;; Note the complex-float-regs are aligned to every second
+       ;; float register so there is not need to worry about overlap.
+       (let ((x-real (complex-double-reg-real-tn x))
+	     (y-real (complex-double-reg-real-tn y)))
+	 (inst fmove x-real y-real))
+       (let ((x-imag (complex-double-reg-imag-tn x))
+	     (y-imag (complex-double-reg-imag-tn y)))
+	 (inst fmove x-imag y-imag)))))
+;;;
+(define-move-vop complex-double-move :move
+  (complex-double-reg) (complex-double-reg))
+
+;;;
+;;; Move from a complex float to a descriptor register allocating a
+;;; new complex float object in the process.
+;;;
+(define-vop (move-from-complex-single)
+  (:args (x :scs (complex-single-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:note "complex single float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y ndescr vm:complex-single-float-type
+			       vm:complex-single-float-size)
+       (let ((real-tn (complex-single-reg-real-tn x)))
+	 (inst sts real-tn (- (* vm:complex-single-float-real-slot
+				 vm:word-bytes)
+			      vm:other-pointer-type)
+	       y))
+       (let ((imag-tn (complex-single-reg-imag-tn x)))
+	 (inst sts imag-tn (- (* vm:complex-single-float-imag-slot
+				 vm:word-bytes)
+			      vm:other-pointer-type)
+	       y)))))
+;;;
+(define-move-vop move-from-complex-single :move
+  (complex-single-reg) (descriptor-reg))
+
+(define-vop (move-from-complex-double)
+  (:args (x :scs (complex-double-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:note "complex double float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y ndescr vm:complex-double-float-type
+			       vm:complex-double-float-size)
+       (let ((real-tn (complex-double-reg-real-tn x)))
+	 (inst stt real-tn (- (* vm:complex-double-float-real-slot
+				 vm:word-bytes)
+			      vm:other-pointer-type)
+	       y))
+       (let ((imag-tn (complex-double-reg-imag-tn x)))
+	 (inst stt imag-tn (- (* vm:complex-double-float-imag-slot
+				 vm:word-bytes)
+			      vm:other-pointer-type)
+	       y)))))
+;;;
+(define-move-vop move-from-complex-double :move
+  (complex-double-reg) (descriptor-reg))
+
+;;;
+;;; Move from a descriptor to a complex float register
+;;;
+(macrolet ((frob (name sc double-p real-value imag-value)
+	     `(progn
+		(define-vop (,name)
+		  (:args (x :scs (descriptor-reg)))
+		  (:results (y :scs (,sc)))
+		  (:note "pointer to complex float coercion")
+		  (:generator 2
+		    (let ((real-tn (complex-double-reg-real-tn y)))
+		      (inst ,(if double-p 'ldt 'lds) real-tn
+			    (- (* ,real-value vm:word-bytes)
+			       vm:other-pointer-type)
+			    x))
+		    (let ((imag-tn (complex-double-reg-imag-tn y)))
+		      (inst ,(if double-p 'ldt 'lds) imag-tn
+			    (- (* ,imag-value vm:word-bytes)
+			       vm:other-pointer-type)
+			    x))))
+		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
+	  (frob move-to-complex-single complex-single-reg nil
+		complex-single-float-real-slot complex-single-float-imag-slot)
+	  (frob move-to-complex-double complex-double-reg t
+		complex-double-float-real-slot complex-double-float-imag-slot))
+;;;
+;;; Complex float move-argument vop
+;;;
+(macrolet ((frob (name sc stack-sc double-p)
+	     `(progn
+		(define-vop (,name)
+		  (:args (x :scs (,sc) :target y)
+			 (nfp :scs (any-reg)
+			      :load-if (not (sc-is y ,sc))))
+		  (:results (y))
+		  (:note "complex float argument move")
+		  (:generator ,(if double-p 2 1)
+		    (sc-case y
+		      (,sc
+		       (unless (location= x y)
+			 (let ((x-real (complex-double-reg-real-tn x))
+			       (y-real (complex-double-reg-real-tn y)))
+			   (inst fmove x-real y-real))
+			 (let ((x-imag (complex-double-reg-imag-tn x))
+			       (y-imag (complex-double-reg-imag-tn y)))
+			   (inst fmove x-imag y-imag))))
+		      (,stack-sc
+		       (let ((offset (* (tn-offset y) vm:word-bytes)))
+			 (let ((real-tn (complex-double-reg-real-tn x)))
+			   (inst ,(if double-p 'stt 'sts) real-tn offset nfp))
+			 (let ((imag-tn (complex-double-reg-imag-tn x)))
+			   (inst ,(if double-p 'stt 'sts) imag-tn offset nfp)))))))
+		(define-move-vop ,name :move-argument
+		  (,sc descriptor-reg) (,sc)))))
+  (frob move-complex-single-float-argument
+	complex-single-reg complex-single-stack nil)
+  (frob move-complex-double-float-argument
+	complex-double-reg complex-double-stack t))
+
+) ; progn complex-float
+
 
 (define-move-vop move-argument :move-argument
-  (single-reg double-reg) (descriptor-reg))
+  (single-reg double-reg
+   #+complex-float complex-single-reg #+complex-float complex-double-reg)
+  (descriptor-reg))
 
 
 ;;;; Arithmetic VOPs:
@@ -549,3 +757,93 @@
       (inst mt_fpcr temp1 temp1 temp1)
       (inst excb)
       (move res new))))
+
+
+;;;; Complex float VOPs
+
+#+complex-float
+(progn
+
+(define-vop (make-complex-single-float)
+  (:translate complex)
+  (:args (x :scs (single-reg) :target r)
+	 (y :scs (single-reg) :to :save))
+  (:arg-types single-float single-float)
+  (:results (r :scs (complex-single-reg) :from (:argument 0)))
+  (:result-types complex-single-float)
+  (:note "inline complex single-float creation")
+  (:policy :fast-safe)
+  (:generator 5
+    (let ((r-real (complex-single-reg-real-tn r)))
+      (unless (location= x r-real)
+	(inst fmove x r-real)))
+    (let ((r-imag (complex-single-reg-imag-tn r)))
+      (unless (location= y r-imag)
+	(inst fmove y r-imag)))))
+
+(define-vop (make-complex-double-float)
+  (:translate complex)
+  (:args (x :scs (double-reg) :target r)
+	 (y :scs (double-reg) :to :save))
+  (:arg-types double-float double-float)
+  (:results (r :scs (complex-double-reg) :from (:argument 0)))
+  (:result-types complex-double-float)
+  (:note "inline complex double-float creation")
+  (:policy :fast-safe)
+  (:generator 5
+    (let ((r-real (complex-double-reg-real-tn r)))
+      (unless (location= x r-real)
+	(inst fmove x r-real)))
+    (let ((r-imag (complex-double-reg-imag-tn r)))
+      (unless (location= y r-imag)
+	(inst fmove y r-imag)))))
+
+(define-vop (complex-single-float-value)
+  (:args (x :scs (complex-single-reg) :target r))
+  (:arg-types complex-single-float)
+  (:results (r :scs (single-reg)))
+  (:result-types single-float)
+  (:variant-vars offset)
+  (:policy :fast-safe)
+  (:generator 3
+     (let ((value-tn (make-random-tn :kind :normal
+				     :sc (sc-or-lose 'single-reg *backend*)
+				     :offset (+ offset (tn-offset x)))))
+       (unless (location= value-tn r)
+	 (inst fmove value-tn r)))))
+
+(define-vop (realpart/complex-single-float complex-single-float-value)
+  (:translate realpart)
+  (:note "complex single float realpart")
+  (:variant 0))
+
+(define-vop (imagpart/complex-single-float complex-single-float-value)
+  (:translate imagpart)
+  (:note "complex single float imagpart")
+  (:variant 1))
+
+(define-vop (complex-double-float-value)
+  (:args (x :scs (complex-double-reg) :target r))
+  (:arg-types complex-double-float)
+  (:results (r :scs (double-reg)))
+  (:result-types double-float)
+  (:variant-vars offset)
+  (:policy :fast-safe)
+  (:generator 3
+     (let ((value-tn (make-random-tn :kind :normal
+				     :sc (sc-or-lose 'double-reg *backend*)
+				     :offset (+ offset (tn-offset x)))))
+       (unless (location= value-tn r)
+	 (inst fmove value-tn r)))))
+
+(define-vop (realpart/complex-double-float complex-double-float-value)
+  (:translate realpart)
+  (:note "complex double float realpart")
+  (:variant 0))
+
+(define-vop (imagpart/complex-double-float complex-double-float-value)
+  (:translate imagpart)
+  (:note "complex double float imagpart")
+  (:variant 1))
+
+) ; progn complex-float
diff --git a/compiler/alpha/type-vops.lisp b/compiler/alpha/type-vops.lisp
index aa7c2f951..1c51aa45e 100644
--- a/compiler/alpha/type-vops.lisp
+++ b/compiler/alpha/type-vops.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/alpha/type-vops.lisp,v 1.2 1994/10/31 04:39:51 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/type-vops.lisp,v 1.3 1998/01/21 19:23:46 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -15,6 +15,7 @@
 ;;; Written by William Lott
 ;;; Earlier versions by Rob MacLachlan and Christopher Hoover.
 ;;; Alpha conversion by Sean Hallgren
+;;; Complex-float support by Douglas Crosher 1998.
 ;;;
 (in-package "ALPHA")
 
@@ -255,7 +256,28 @@
   object-not-ratio-error ratio-type)
 
 (def-type-vops complexp check-complex complex
-  object-not-complex-error complex-type)
+  object-not-complex-error complex-type
+  #+complex-float complex-single-float-type
+  #+complex-float complex-double-float-type)
+
+#+complex-float
+(def-type-vops complex-rational-p check-complex-rational nil
+  object-not-complex-rational-error complex-type)
+
+#+complex-float
+(def-type-vops complex-float-p check-complex-float nil
+  object-not-complex-float-error
+  complex-single-float-type complex-double-float-type)
+
+#+complex-float
+(def-type-vops complex-single-float-p check-complex-single-float
+  complex-single-float object-not-complex-single-float-error
+  complex-single-float-type)
+
+#+complex-float
+(def-type-vops complex-double-float-p check-complex-double-float
+  complex-double-float object-not-complex-double-float-error
+  complex-double-float-type)
 
 (def-type-vops single-float-p check-single-float single-float
   object-not-single-float-error single-float-type)
@@ -302,6 +324,34 @@
   object-not-simple-array-unsigned-byte-32-error
   simple-array-unsigned-byte-32-type)
 
+#+signed-array
+(def-type-vops simple-array-signed-byte-8-p
+  check-simple-array-signed-byte-8
+  simple-array-signed-byte-8
+  object-not-simple-array-signed-byte-8-error
+  simple-array-signed-byte-8-type)
+
+#+signed-array
+(def-type-vops simple-array-signed-byte-16-p
+  check-simple-array-signed-byte-16
+  simple-array-signed-byte-16
+  object-not-simple-array-signed-byte-16-error
+  simple-array-signed-byte-16-type)
+
+#+signed-array
+(def-type-vops simple-array-signed-byte-30-p
+  check-simple-array-signed-byte-30
+  simple-array-signed-byte-30
+  object-not-simple-array-signed-byte-30-error
+  simple-array-signed-byte-30-type)
+
+#+signed-array
+(def-type-vops simple-array-signed-byte-32-p
+  check-simple-array-signed-byte-32
+  simple-array-signed-byte-32
+  object-not-simple-array-signed-byte-32-error
+  simple-array-signed-byte-32-type)
+
 (def-type-vops simple-array-single-float-p check-simple-array-single-float
   simple-array-single-float object-not-simple-array-single-float-error
   simple-array-single-float-type)
@@ -310,6 +360,20 @@
   simple-array-double-float object-not-simple-array-double-float-error
   simple-array-double-float-type)
 
+#+complex-float
+(def-type-vops simple-array-complex-single-float-p
+  check-simple-array-complex-single-float
+  simple-array-complex-single-float
+  object-not-simple-array-complex-single-float-error
+  simple-array-complex-single-float-type)
+
+#+complex-float
+(def-type-vops simple-array-complex-double-float-p
+  check-simple-array-complex-double-float
+  simple-array-complex-double-float
+  object-not-simple-array-complex-double-float-error
+  simple-array-complex-double-float-type)
+
 (def-type-vops base-char-p check-base-char base-char
   object-not-base-char-error base-char-type)
 
@@ -355,29 +419,49 @@
   simple-string-type simple-bit-vector-type simple-vector-type
   simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type
   simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type
-  simple-array-unsigned-byte-32-type simple-array-single-float-type
-  simple-array-double-float-type complex-string-type
-  complex-bit-vector-type complex-vector-type)
+  simple-array-unsigned-byte-32-type
+  #+signed-array simple-array-signed-byte-8-type
+  #+signed-array simple-array-signed-byte-16-type
+  #+signed-array simple-array-signed-byte-30-type
+  #+signed-array simple-array-signed-byte-32-type
+  simple-array-single-float-type simple-array-double-float-type
+  #+complex-float simple-array-complex-single-float-type
+  #+complex-float simple-array-complex-double-float-type
+  complex-string-type complex-bit-vector-type complex-vector-type)
 
 (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
   simple-array-type simple-string-type simple-bit-vector-type
   simple-vector-type simple-array-unsigned-byte-2-type
   simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
   simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
-  simple-array-single-float-type simple-array-double-float-type)
+  #+signed-array simple-array-signed-byte-8-type
+  #+signed-array simple-array-signed-byte-16-type
+  #+signed-array simple-array-signed-byte-30-type
+  #+signed-array simple-array-signed-byte-32-type
+  simple-array-single-float-type simple-array-double-float-type
+  #+complex-float simple-array-complex-single-float-type
+  #+complex-float simple-array-complex-double-float-type)
 
 (def-type-vops arrayp check-array nil object-not-array-error
   simple-array-type simple-string-type simple-bit-vector-type
   simple-vector-type simple-array-unsigned-byte-2-type
   simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
   simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
+  #+signed-array simple-array-signed-byte-8-type
+  #+signed-array simple-array-signed-byte-16-type
+  #+signed-array simple-array-signed-byte-30-type
+  #+signed-array simple-array-signed-byte-32-type
   simple-array-single-float-type simple-array-double-float-type
+  #+complex-float simple-array-complex-single-float-type
+  #+complex-float simple-array-complex-double-float-type
   complex-string-type complex-bit-vector-type complex-vector-type
   complex-array-type)
 
 (def-type-vops numberp check-number nil object-not-number-error
   even-fixnum-type odd-fixnum-type bignum-type ratio-type
-  single-float-type double-float-type complex-type)
+  single-float-type double-float-type complex-type
+  #+complex-float complex-single-float-type
+  #+complex-float complex-double-float-type)
 
 (def-type-vops rationalp check-rational nil object-not-rational-error
   even-fixnum-type odd-fixnum-type ratio-type bignum-type)
diff --git a/compiler/alpha/vm.lisp b/compiler/alpha/vm.lisp
index 518d5241c..db5698b44 100644
--- a/compiler/alpha/vm.lisp
+++ b/compiler/alpha/vm.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/alpha/vm.lisp,v 1.2 1994/10/31 04:39:51 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/vm.lisp,v 1.3 1998/01/21 19:23:45 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -156,6 +156,10 @@
   (single-stack non-descriptor-stack) ; single-floats
   (double-stack non-descriptor-stack
 		:element-size 2 :alignment 2) ; double floats.
+  #+complex-float
+  (complex-single-stack non-descriptor-stack :element-size 2)
+  #+complex-float
+  (complex-double-stack non-descriptor-stack :element-size 2)
 
 
   ;; **** Things that can go in the integer registers.
@@ -227,6 +231,22 @@
    :save-p t
    :alternate-scs (double-stack))
 
+  #+complex-float
+  (complex-single-reg float-registers
+   :locations #.(loop for i from 4 to 31 by 2 collect i)
+   :element-size 2
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (complex-single-stack))
+
+  #+complex-float
+  (complex-double-reg float-registers
+   :locations #.(loop for i from 4 to 31 by 2 collect i)
+   :element-size 2
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (complex-double-stack))
+
   ;; A catch or unwind block.
   (catch-block control-stack :element-size vm:catch-block-size))
 
-- 
GitLab