From 367fcfdf16bd50e67eb01cd9157b897560b502ec Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Thu, 22 Nov 1990 11:51:46 +0000
Subject: [PATCH] Initial revision

---
 assembly/sparc/alloc.lisp      |  89 ++++++++++
 assembly/sparc/arith.lisp      | 286 +++++++++++++++++++++++++++++++++
 assembly/sparc/array.lisp      | 171 ++++++++++++++++++++
 assembly/sparc/assem-rtns.lisp | 242 ++++++++++++++++++++++++++++
 assembly/sparc/support.lisp    |  79 +++++++++
 5 files changed, 867 insertions(+)
 create mode 100644 assembly/sparc/alloc.lisp
 create mode 100644 assembly/sparc/arith.lisp
 create mode 100644 assembly/sparc/array.lisp
 create mode 100644 assembly/sparc/assem-rtns.lisp
 create mode 100644 assembly/sparc/support.lisp

diff --git a/assembly/sparc/alloc.lisp b/assembly/sparc/alloc.lisp
new file mode 100644
index 000000000..d728770d0
--- /dev/null
+++ b/assembly/sparc/alloc.lisp
@@ -0,0 +1,89 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/alloc.lisp,v 1.1 1990/11/22 11:49:39 wlott Exp $
+;;;
+;;; Stuff to handle allocating simple objects.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "SPARC")
+
+(define-for-each-primitive-object (obj)
+  (let* ((options (primitive-object-options obj))
+	 (alloc-trans (getf options :alloc-trans))
+	 (alloc-vop (getf options :alloc-vop alloc-trans))
+	 (header (primitive-object-header obj))
+	 (lowtag (primitive-object-lowtag obj))
+	 (size (primitive-object-size obj))
+	 (variable-length (primitive-object-variable-length obj))
+	 (need-unbound-marker nil))
+    (collect ((args) (init-forms))
+      (when (and alloc-vop variable-length)
+	(args 'extra-words))
+      (dolist (slot (primitive-object-slots obj))
+	(let* ((name (slot-name slot))
+	       (offset (slot-offset slot)))
+	  (ecase (getf (slot-options slot) :init :zero)
+	    (:zero)
+	    (:null
+	     (init-forms `(storew null-tn result ,offset ,lowtag)))
+	    (:unbound
+	     (setf need-unbound-marker t)
+	     (init-forms `(storew temp result ,offset ,lowtag)))
+	    (:arg
+	     (args name)
+	     (init-forms `(storew ,name result ,offset ,lowtag))))))
+      (when (and (null alloc-vop) (args))
+	(error "Slots ~S want to be initialized, but there is no alloc vop ~
+	defined for ~S."
+	       (args) (primitive-object-name obj)))
+      (when alloc-vop
+	`(define-assembly-routine
+	     (,alloc-vop
+	      (:cost 35)
+	      ,@(when alloc-trans
+		  `((:translate ,alloc-trans)))
+	      (:policy :fast-safe))
+	     (,@(let ((arg-offsets (cdr register-arg-offsets)))
+		  (mapcar #'(lambda (name)
+			      (unless arg-offsets
+				(error "Too many args in ~S" alloc-vop))
+			      `(:arg ,name (descriptor-reg any-reg)
+				     ,(pop arg-offsets)))
+			  (args)))
+		(:temp ndescr non-descriptor-reg nl0-offset)
+		,@(when (or need-unbound-marker header variable-length)
+		    '((:temp temp non-descriptor-reg nl1-offset)))
+		(:res result descriptor-reg a0-offset))
+	   (pseudo-atomic (ndescr)
+	     (inst add result alloc-tn ,lowtag)
+	     ,@(cond ((and header variable-length)
+		      `((inst add temp extra-words (fixnum (1- ,size)))
+			(inst add alloc-tn alloc-tn temp)
+			(inst sll temp temp (- type-bits word-shift))
+			(inst or temp temp ,header)
+			(storew temp result 0 ,lowtag)
+			(inst add alloc-tn (+ (fixnum 1) lowtag-mask))
+			(inst and alloc-tn (lognot lowtag-mask))))
+		     (variable-length
+		      (error ":REST-P T with no header in ~S?"
+			     (primitive-object-name obj)))
+		     (header
+		      `((inst add alloc-tn (pad-data-block ,size))
+			(inst li temp
+			      ,(logior (ash (1- size) type-bits)
+				       (symbol-value header)))
+			(storew temp result 0 ,lowtag)))
+		     (t
+		      `((inst add alloc-tn (pad-data-block ,size)))))
+	     ,@(when need-unbound-marker
+		 `((inst li temp unbound-marker-type)))
+	     ,@(init-forms)))))))
diff --git a/assembly/sparc/arith.lisp b/assembly/sparc/arith.lisp
new file mode 100644
index 000000000..78ce6ad2c
--- /dev/null
+++ b/assembly/sparc/arith.lisp
@@ -0,0 +1,286 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/arith.lisp,v 1.1 1990/11/22 11:49:50 wlott Exp $
+;;;
+;;; Stuff to handle simple cases for generic arithmetic.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "SPARC")
+
+
+
+;;;; Addition and subtraction.
+
+(define-assembly-routine (generic-+
+			  (:cost 10)
+			  (:return-style :full-call)
+			  (:translate +)
+			  (:policy :safe)
+			  (:save-p t))
+			 ((:arg x (descriptor-reg any-reg) a0-offset)
+			  (:arg y (descriptor-reg any-reg) a1-offset)
+
+			  (:res res (descriptor-reg any-reg) a0-offset)
+
+			  (:temp temp non-descriptor-reg nl0-offset)
+			  (:temp temp2 non-descriptor-reg nl1-offset)
+			  (:temp lra descriptor-reg lra-offset)
+			  (:temp nargs any-reg nargs-offset)
+			  (:temp cname descriptor-reg cname-offset)
+			  (:temp ocfp any-reg ocfp-offset))
+  (inst andcc zero-tn x 3)
+  (inst b :ne DO-STATIC-FUN)
+  (inst andcc zero-tn y 3)
+  (inst b :ne DO-STATIC-FUN)
+  (inst nop)
+  (inst addcc temp x y)
+  (inst b :vc done)
+  (inst nop)
+
+  (inst sra temp x 2)
+  (inst sra temp2 y 2)
+  (inst add temp2 temp)
+  (with-fixed-allocation (res temp vm:bignum-type 1)
+    (storew temp2 res vm:bignum-digits-offset vm:other-pointer-type))
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FUN
+  (load-symbol cname 'two-arg-+)
+  (inst li nargs (fixnum 2))
+  (loadw code-tn cname vm:symbol-raw-function-addr-slot vm:other-pointer-type)
+  (inst move ocfp cfp-tn)
+  (inst j code-tn)
+  (inst move cfp-tn csp-tn)
+
+  DONE
+  (move res temp))
+
+
+(define-assembly-routine (generic--
+			  (:cost 10)
+			  (:return-style :full-call)
+			  (:translate -)
+			  (:policy :safe)
+			  (:save-p t))
+			 ((:arg x (descriptor-reg any-reg) a0-offset)
+			  (:arg y (descriptor-reg any-reg) a1-offset)
+
+			  (:res res (descriptor-reg any-reg) a0-offset)
+
+			  (:temp temp non-descriptor-reg nl0-offset)
+			  (:temp temp2 non-descriptor-reg nl1-offset)
+			  (:temp lra descriptor-reg lra-offset)
+			  (:temp nargs any-reg nargs-offset)
+			  (:temp cname descriptor-reg cname-offset)
+			  (:temp ocfp any-reg ocfp-offset))
+  (inst andcc zero-tn x 3)
+  (inst b :ne DO-STATIC-FUN)
+  (inst andcc zero-tn y 3)
+  (inst b :ne DO-STATIC-FUN)
+  (inst nop)
+  (inst subcc temp x y)
+  (inst b :vc done)
+  (inst nop)
+
+  (inst sra temp x 2)
+  (inst sra temp2 y 2)
+  (inst add temp2 temp)
+  (with-fixed-allocation (res temp vm:bignum-type 1)
+    (storew temp2 res vm:bignum-digits-offset vm:other-pointer-type))
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FUN
+  (load-symbol cname 'two-arg--)
+  (inst li nargs (fixnum 2))
+  (loadw code-tn cname vm:symbol-raw-function-addr-slot vm:other-pointer-type)
+  (inst move ocfp cfp-tn)
+  (inst j code-tn)
+  (inst move cfp-tn csp-tn)
+
+  DONE
+  (move res temp))
+
+
+
+;;;; Multiplication
+
+(define-assembly-routine (generic-*
+			  (:cost 50)
+			  (:return-style :full-call)
+			  (:translate *)
+			  (:policy :safe)
+			  (:save-p t))
+			 ((:arg x (descriptor-reg any-reg) a0-offset)
+			  (:arg y (descriptor-reg any-reg) a1-offset)
+
+			  (:res res (descriptor-reg any-reg) a0-offset)
+
+			  (:temp temp non-descriptor-reg nl0-offset)
+			  (:temp lo non-descriptor-reg nl1-offset)
+			  (:temp hi non-descriptor-reg nl2-offset)
+			  (:temp lra descriptor-reg lra-offset)
+			  (:temp nargs any-reg nargs-offset)
+			  (:temp cname descriptor-reg cname-offset)
+			  (:temp ocfp any-reg ocfp-offset))
+  ;; If either arg is not a fixnum, call the static function.
+  (inst andcc zero-tn x 3)
+  (inst b :ne DO-STATIC-FUN)
+  (inst andcc zero-tn y 3)
+  (inst b :ne DO-STATIC-FUN)
+  (inst nop)
+
+  ;; Remove the tag from one arg so that the result will have the correct
+  ;; fixnum tag.
+  (inst sra temp x 2)
+  (emit-multiply temp y hi res :signed)
+  ;; Check to see if the result will fit in a fixnum.  (I.e. the high word
+  ;; is just 32 copies of the sign bit of the low word).
+  (inst sra temp res 31)
+  (inst xorcc temp hi)
+  (inst b :eq DONE)
+  ;; Shift the double word hi:res down two bits into hi:low to get rid of the
+  ;; fixnum tag.
+  (inst srl lo res 2)
+  (inst sll temp hi 30)
+  (inst or lo temp)
+  (inst sra hi 2)
+  ;; Allocate a BIGNUM for the result.
+  (pseudo-atomic (temp)
+    (let ((one-word (gen-label)))
+      (inst add res alloc-tn other-pointer-type)
+      ;; Assume we need one word.
+      (inst add alloc-tn (pad-data-block (1+ bignum-digits-offset)))
+      ;; Is that correct?
+      (inst sra temp lo 31)
+      (inst xorcc temp hi)
+      (inst b :eq one-word)
+      (inst li temp (logior (ash 1 type-bits) bignum-type))
+      ;; Nope, we need two, so allocate the addition space.
+      (inst add alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset))
+			    (pad-data-block (1+ bignum-digits-offset))))
+      (inst li temp (logior (ash 2 type-bits) bignum-type))
+      (storew hi res (1+ bignum-digits-offset) other-pointer-type)
+      (emit-label one-word)
+      (storew temp res 0 other-pointer-type)
+      (storew lo res bignum-digits-offset other-pointer-type)))
+  ;; Out of here
+  (lisp-return lra :offset 2)
+
+  DO-STATIC-FUN
+  (load-symbol cname 'two-arg-*)
+  (inst li nargs (fixnum 2))
+  (loadw code-tn cname symbol-raw-function-addr-slot other-pointer-type)
+  (inst move ocfp cfp-tn)
+  (inst j code-tn)
+  (inst move cfp-tn csp-tn)
+
+  DONE)
+
+(macrolet
+    ((frob (name note cost type sc)
+       `(define-assembly-routine (,name
+				  (:note ,note)
+				  (:cost ,cost)
+				  (:translate *)
+				  (:policy :fast-safe)
+				  (:arg-types ,type ,type)
+				  (:result-types ,type))
+				 ((:arg x ,sc nl0-offset)
+				  (:arg y ,sc nl1-offset)
+				  (:res res ,sc nl0-offset)
+				  (:temp temp ,sc nl2-offset))
+	  ,@(when (eq type 'tagged-num)
+	      `((inst sra x 2)))
+	  (emit-multiply x y temp res :unsigned))))
+  (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg)
+  (frob signed-* "unsigned *" 41 signed-num signed-reg)
+  (frob fixnum-* "fixnum *" 30 tagged-num any-reg))
+
+
+
+;;;; Division.
+
+#+assembler
+(defun 32/32-restoring-divide (dividend divisor rem quo iter)
+  (let ((done-shifting (gen-label))
+	(not-big-dividend (gen-label)))
+
+    (inst addcc rem dividend 0)
+    (inst b :ge not-big-dividend)
+    (inst li iter (fixnum -1))
+
+    ;; The dividend is huge.  If we shift the divisor until it's negative.
+    (let ((loop (gen-label)))
+      (inst cmp divisor)
+      (inst b :lt done-shifting)
+      (inst li quo -1)
+      (emit-label loop)
+      (inst addcc divisor divisor)
+      (inst b :ge loop)
+      (inst add iter (fixnum 1))
+      (inst b done-shifting)
+      (inst nop))
+
+    ;; The dividend is not huge.  Keep shifting the divisor up until it's
+    ;; larger than the dividend.
+    (emit-label not-big-dividend)
+    (let ((loop (gen-lable)))
+      (inst cmp divisor rem)
+      (inst b :ge done-shifting)
+      (inst li quo -1)
+      (emit-label loop)
+      (inst sll divisor 1)
+      (inst cmp quo rem)
+      (inst b :nc loop)
+      (inst add iter (fixnum 1)))
+
+    (emit-label done-shifting)
+    (let ((loop-1 (gen-label))
+	  (loop-2 (gen-label))
+	  (finished (gen-label)))
+      (emit-label loop-1)
+      (inst subcc iter (fixnum 1))
+      (inst b :le finished)
+      (emit-label loop-2)
+      (inst sub temp rem divisor)
+      (inst slr divisor 1)
+      (inst b :cs loop)
+      (inst addcc quo quo)
+      (inst subcc iter (fixnum 1))
+      (inst b :gt loop-2)
+      (inst move rem temp)
+      (emit-label finished))
+
+    (inst not quo)))
+
+
+(macrolet
+    ((frob (name note cost prim-type sc)
+       `(define-assembly-routine (,name
+				  (:note ,note)
+				  (:cost ,cost)
+				  (:translate truncate)
+				  (:policy :fast-safe)
+				  (:arg-types ,prim-type ,prim-type)
+				  (:result-types ,prim-type ,prim-type))
+				 ((:arg dividend ,sc nl0-offset)
+				  (:arg divisor ,sc nl1-offset)
+
+				  (:res quo ,sc nl2-offset)
+				  (:res rem ,sc nl0-offset)
+
+				  (:temp iter any-reg nl3-offset)
+				  (:temp temp non-descriptor-reg nl4-offset))
+	  )))
+  (frob fixnum-truncate "fixnum truncate" 50 tagged-num any-reg)
+  (frob signed-truncate "fixnum truncate" 60 tagged-num any-reg)
+  (frob unsigned-truncate "fixnum truncate" 55 tagged-num any-reg))
diff --git a/assembly/sparc/array.lisp b/assembly/sparc/array.lisp
new file mode 100644
index 000000000..24ed08180
--- /dev/null
+++ b/assembly/sparc/array.lisp
@@ -0,0 +1,171 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.1 1990/11/22 11:50:40 wlott Exp $
+;;;
+;;;    This file contains the support routines for arrays and vectors.
+;;;
+;;; Written by William Lott.
+;;; 
+(in-package "SPARC")
+
+
+(define-assembly-routine (allocate-vector
+			  (:policy :fast-safe)
+			  (:translate allocate-vector)
+			  (:arg-types positive-fixnum
+				      positive-fixnum
+				      positive-fixnum))
+			 ((:arg type any-reg a0-offset)
+			  (:arg length any-reg a1-offset)
+			  (:arg words any-reg a2-offset)
+			  (:res result descriptor-reg a0-offset)
+
+			  (:temp ndescr non-descriptor-reg nl0-offset)
+			  (:temp vector descriptor-reg a3-offset))
+  (pseudo-atomic (ndescr)
+    (inst or vector alloc-tn vm:other-pointer-type)
+    (inst add alloc-tn alloc-tn (+ (1- (ash 1 vm:lowtag-bits))
+				   (* vm:vector-data-offset vm:word-bytes)))
+    (inst add alloc-tn alloc-tn words)
+    (inst and alloc-tn alloc-tn (lognot vm:lowtag-mask))
+    (inst srl ndescr type vm:word-shift)
+    (storew ndescr vector 0 vm:other-pointer-type)
+    (storew length vector vm:vector-length-slot vm:other-pointer-type))
+  (move result vector))
+
+
+
+;;;; Hash primitives
+
+#+assembler
+(defparameter sxhash-simple-substring-entry (gen-label))
+
+(define-assembly-routine (sxhash-simple-string
+			  (:translate %sxhash-simple-string)
+			  (:policy :fast-safe)
+			  (:result-types positive-fixnum))
+			 ((:arg string descriptor-reg a0-offset)
+			  (:res result any-reg a0-offset)
+
+			  (:temp lip interior-reg lip-offset)
+			  (:temp length any-reg a1-offset)
+			  (:temp accum non-descriptor-reg nl0-offset)
+			  (:temp data non-descriptor-reg nl1-offset)
+			  (:temp byte non-descriptor-reg nl2-offset)
+			  (:temp retaddr non-descriptor-reg nl3-offset))
+
+  (declare (ignore result lip accum data byte retaddr))
+
+  (loadw length string vm:vector-length-slot vm:other-pointer-type)
+  (inst b sxhash-simple-substring-entry)
+  (inst nop))
+
+
+(define-assembly-routine (sxhash-simple-substring
+			  (:translate %sxhash-simple-substring)
+			  (:policy :fast-safe)
+			  (:arg-types * positive-fixnum)
+			  (:result-types positive-fixnum))
+			 ((:arg string descriptor-reg a0-offset)
+			  (:arg length any-reg a1-offset)
+			  (:res result any-reg a0-offset)
+
+			  (:temp lip interior-reg lip-offset)
+			  (:temp accum non-descriptor-reg nl0-offset)
+			  (:temp data non-descriptor-reg nl1-offset)
+			  (:temp byte non-descriptor-reg nl2-offset)
+			  (:temp retaddr non-descriptor-reg nl3-offset))
+  (emit-label sxhash-simple-substring-entry)
+
+  ;; Save the return address.
+  (inst sub retaddr lip code-tn)
+
+  (inst add lip string
+	(- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type))
+  (inst b test)
+  (move accum zero-tn)
+
+  LOOP
+
+  (inst and byte data #xff)
+  (inst xor accum accum byte)
+  (inst sll byte accum 5)
+  (inst srl accum accum 27)
+  (inst or accum accum byte)
+
+  (inst srl byte data 8)
+  (inst and byte byte #xff)
+  (inst xor accum accum byte)
+  (inst sll byte accum 5)
+  (inst srl accum accum 27)
+  (inst or accum accum byte)
+
+  (inst srl byte data 16)
+  (inst and byte byte #xff)
+  (inst xor accum accum byte)
+  (inst sll byte accum 5)
+  (inst srl accum accum 27)
+  (inst or accum accum byte)
+
+  (inst srl byte data 24)
+  (inst xor accum accum byte)
+  (inst sll byte accum 5)
+  (inst srl accum accum 27)
+  (inst or accum accum byte)
+
+  (inst add lip lip 4)
+
+  TEST
+
+  (inst subcc length (fixnum 4))
+  (inst b :ge loop)
+  (inst ld data lip 0)
+
+  (inst addcc length (fixnum 3))
+  (inst b :eq one-more)
+  (inst subcc length (fixnum 1))
+  (inst b :eq two-more)
+  (inst subcc length (fixnum 1))
+  (inst b :ne done)
+  (inst nop)
+
+  (inst srl byte data 16)
+  (inst and byte byte #xff)
+  (inst xor accum accum byte)
+  (inst sll byte accum 5)
+  (inst srl accum accum 27)
+  (inst or accum accum byte)
+
+  TWO-MORE
+
+  (inst srl byte data 8)
+  (inst and byte byte #xff)
+  (inst xor accum accum byte)
+  (inst sll byte accum 5)
+  (inst srl accum accum 27)
+  (inst or accum accum byte)
+
+  ONE-MORE
+
+  (inst and byte data #xff)
+  (inst xor accum accum byte)
+  (inst sll byte accum 5)
+  (inst srl accum accum 27)
+  (inst or accum accum byte)
+
+  DONE
+
+  (inst sll result accum 5)
+  (inst srl result result 3)
+
+  ;; Restore the return address.
+  (inst add lip retaddr code-tn))
+
+
diff --git a/assembly/sparc/assem-rtns.lisp b/assembly/sparc/assem-rtns.lisp
new file mode 100644
index 000000000..32b1afd26
--- /dev/null
+++ b/assembly/sparc/assem-rtns.lisp
@@ -0,0 +1,242 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/assem-rtns.lisp,v 1.1 1990/11/22 11:51:05 wlott Exp $
+;;;
+;;;
+(in-package "SPARC")
+
+
+;;;; Return-multiple with other than one value
+
+#+assembler ;; we don't want a vop for this one.
+(define-assembly-routine
+    (return-multiple
+     (:return-style :none))
+
+     ;; These four are really arguments.
+    ((:temp nvals any-reg nargs-offset)
+     (:temp vals any-reg nl0-offset)
+     (:temp ocfp any-reg nl1-offset)
+     (:temp lra descriptor-reg lra-offset)
+
+     ;; These are just needed to facilitate the transfer
+     (:temp count any-reg nl2-offset)
+     (:temp src any-reg nl3-offset)
+     (:temp dst any-reg nl4-offset)
+     (:temp temp descriptor-reg l0-offset)
+
+     ;; These are needed so we can get at the register args.
+     (:temp a0 descriptor-reg a0-offset)
+     (:temp a1 descriptor-reg a1-offset)
+     (:temp a2 descriptor-reg a2-offset)
+     (:temp a3 descriptor-reg a3-offset)
+     (:temp a4 descriptor-reg a4-offset)
+     (:temp a5 descriptor-reg a5-offset))
+
+  ;; Note, because of the way the return-multiple vop is written, we can
+  ;; assume that we are never called with nvals == 1 and that a0 has already
+  ;; been loaded.
+  (inst cmp nvals)
+  (inst b :le default-a0-and-on)
+  (inst cmp nvals (fixnum 2))
+  (inst b :le default-a2-and-on)
+  (inst ld a1 vals (* 1 vm:word-bytes))
+  (inst cmp nvals (fixnum 3))
+  (inst b :le default-a3-and-on)
+  (inst ld a2 vals (* 2 vm:word-bytes))
+  (inst cmp nvals (fixnum 4))
+  (inst b :le default-a4-and-on)
+  (inst ld a3 vals (* 3 vm:word-bytes))
+  (inst cmp nvals (fixnum 5))
+  (inst b :le default-a5-and-on)
+  (inst ld a4 vals (* 4 vm:word-bytes))
+  (inst cmp nvals (fixnum 6))
+  (inst b :le done)
+  (inst ld a5 vals (* 5 vm:word-bytes))
+
+  ;; Copy the remaining args to the top of the stack.
+  (inst add src vals (* 6 vm:word-bytes))
+  (inst add dst cfp-tn (* 6 vm:word-bytes))
+  (inst subcc count nvals (fixnum 6))
+
+  LOOP
+  (inst ld temp src)
+  (inst add src vm:word-bytes)
+  (inst st temp dst)
+  (inst add dst vm:word-bytes)
+  (inst b :gt loop)
+  (inst subcc count (fixnum 1))
+		
+  (inst b done)
+  (inst nop)
+
+  DEFAULT-A0-AND-ON
+  (inst move a0 null-tn)
+  (inst move a1 null-tn)
+  DEFAULT-A2-AND-ON
+  (inst move a2 null-tn)
+  DEFAULT-A3-AND-ON
+  (inst move a3 null-tn)
+  DEFAULT-A4-AND-ON
+  (inst move a4 null-tn)
+  DEFAULT-A5-AND-ON
+  (inst move a5 null-tn)
+  DONE
+  
+  ;; Clear the stack.
+  (move ocfp-tn cfp-tn)
+  (move cfp-tn ocfp)
+  (inst add csp-tn ocfp-tn nvals)
+  
+  ;; Return.
+  (lisp-return lra))
+
+
+
+;;;; tail-call-variable.
+
+#+assembler ;; no vop for this one either.
+(define-assembly-routine
+    (tail-call-variable
+     (:return-style :none))
+
+    ;; These are really args.
+    ((:temp args any-reg nl0-offset)
+     (:temp lexenv descriptor-reg lexenv-offset)
+
+     ;; We need to compute this
+     (:temp nargs any-reg nargs-offset)
+
+     ;; These are needed by the blitting code.
+     (:temp src any-reg nl1-offset)
+     (:temp dst any-reg nl2-offset)
+     (:temp count any-reg nl3-offset)
+     (:temp temp descriptor-reg l0-offset)
+
+     ;; These are needed so we can get at the register args.
+     (:temp a0 descriptor-reg a0-offset)
+     (:temp a1 descriptor-reg a1-offset)
+     (:temp a2 descriptor-reg a2-offset)
+     (:temp a3 descriptor-reg a3-offset)
+     (:temp a4 descriptor-reg a4-offset)
+     (:temp a5 descriptor-reg a5-offset))
+
+
+  ;; Calculate NARGS (as a fixnum)
+  (inst sub nargs csp-tn args)
+     
+  ;; Load the argument regs (must do this now, 'cause the blt might
+  ;; trash these locations)
+  (inst ld a0 args (* 0 vm:word-bytes))
+  (inst ld a1 args (* 1 vm:word-bytes))
+  (inst ld a2 args (* 2 vm:word-bytes))
+  (inst ld a3 args (* 3 vm:word-bytes))
+  (inst ld a4 args (* 4 vm:word-bytes))
+  (inst ld a5 args (* 5 vm:word-bytes))
+
+  ;; Calc SRC, DST, and COUNT
+  (inst addcc count nargs (fixnum (- register-arg-count)))
+  (inst b :le done)
+  (inst add src args (* vm:word-bytes register-arg-count))
+  (inst add dst cfp-tn (* vm:word-bytes register-arg-count))
+	
+  LOOP
+  ;; Copy one arg.
+  (inst ld temp src)
+  (inst add src src vm:word-bytes)
+  (inst st temp dst)
+  (inst addcc count (fixnum -1))
+  (inst b :gt loop)
+  (inst add dst dst vm:word-bytes)
+	
+  DONE
+  ;; We are done.  Do the jump.
+  (loadw temp lexenv vm:closure-function-slot vm:function-pointer-type)
+  (lisp-jump temp))
+
+
+
+;;;; Non-local exit noise.
+
+(define-assembly-routine (unwind
+			  (:return-style :none)
+			  (:translate %continue-unwind)
+			  (:policy :fast-safe))
+			 ((:arg block (any-reg descriptor-reg) a0-offset)
+			  (:arg start (any-reg descriptor-reg) ocfp-offset)
+			  (:arg count (any-reg descriptor-reg) nargs-offset)
+			  (:temp lra descriptor-reg lra-offset)
+			  (:temp cur-uwp any-reg nl0-offset)
+			  (:temp next-uwp any-reg nl1-offset)
+			  (:temp target-uwp any-reg nl2-offset))
+  (declare (ignore start count))
+
+  (let ((error (generate-error-code nil invalid-unwind-error)))
+    (inst cmp block)
+    (inst b :eq error))
+  
+  (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*)
+  (loadw target-uwp block vm:unwind-block-current-uwp-slot)
+  (inst cmp cur-uwp target-uwp)
+  (inst b :ne do-uwp)
+  (inst nop)
+      
+  (move cur-uwp block)
+
+  DO-EXIT
+      
+  (loadw cfp-tn cur-uwp vm:unwind-block-current-cont-slot)
+  (loadw code-tn cur-uwp vm:unwind-block-current-code-slot)
+  (loadw lra cur-uwp vm:unwind-block-entry-pc-slot)
+  (lisp-return lra :frob-code nil)
+
+  DO-UWP
+
+  (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot)
+  (inst b do-exit)
+  (store-symbol-value next-uwp lisp::*current-unwind-protect-block*))
+
+
+(define-assembly-routine (throw
+			  (:return-style :none))
+			 ((:arg target descriptor-reg a0-offset)
+			  (:arg start any-reg ocfp-offset)
+			  (:arg count any-reg nargs-offset)
+			  (:temp catch any-reg a1-offset)
+			  (:temp tag descriptor-reg a2-offset)
+			  (:temp temp non-descriptor-reg nl0-offset))
+  
+  (declare (ignore start count))
+
+  (load-symbol-value catch lisp::*current-catch-block*)
+  
+  loop
+  
+  (let ((error (generate-error-code nil unseen-throw-tag-error target)))
+    (inst cmp catch)
+    (inst b :eq error)
+    (inst nop))
+  
+  (loadw tag catch vm:catch-block-tag-slot)
+  (inst cmp tag target)
+  (inst b :eq exit)
+  (inst nop)
+  (loadw catch catch vm:catch-block-previous-catch-slot)
+  (inst b loop)
+  (inst nop)
+  
+  exit
+  
+  (move target catch)
+  (inst li temp (make-fixup 'unwind :assembly-routine))
+  (inst j temp)
+  (inst nop))
+
+
diff --git a/assembly/sparc/support.lisp b/assembly/sparc/support.lisp
new file mode 100644
index 000000000..41e0ef25f
--- /dev/null
+++ b/assembly/sparc/support.lisp
@@ -0,0 +1,79 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/support.lisp,v 1.1 1990/11/22 11:51:46 wlott Exp $
+;;;
+;;; This file contains the machine specific support routines needed by
+;;; the file assembler.
+;;;
+(in-package "SPARC")
+
+(def-vm-support-routine generate-call-sequence (name style vop)
+  (ecase style
+    (:raw
+     (let ((temp (make-symbol "TEMP"))
+	   (lip (make-symbol "LIP")))
+       (values 
+	`((inst li ,temp (make-fixup ',name :assembly-routine))
+	  (inst jal ,lip ,temp)
+	  (inst nop))
+	`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
+		      ,temp)
+	  (:temporary (:scs (interior-reg) :from (:eval 0) :to (:eval 1))
+		      ,lip)))))
+    (:full-call
+     (let ((temp (make-symbol "TEMP"))
+	   (nfp-save (make-symbol "NFP-SAVE"))
+	   (lra (make-symbol "LRA")))
+       (values
+	`((let ((lra-label (gen-label))
+		(cur-nfp (current-nfp-tn ,vop)))
+	    (when cur-nfp
+	      (store-stack-tn ,nfp-save cur-nfp))
+	    (inst compute-lra-from-code ,lra code-tn lra-label ,temp)
+	    (inst li ,temp (make-fixup ',name :assembly-routine))
+	    (inst j ,temp)
+	    (inst nop)
+	    (emit-return-pc lra-label)
+	    (note-this-location ,vop :unknown-return)
+	    (move csp-tn ocfp-tn)
+	    (inst nop)
+	    (inst compute-code-from-lra code-tn code-tn
+		  lra-label ,temp)
+	    (when cur-nfp
+	      (load-stack-tn cur-nfp ,nfp-save))))
+	`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
+		      ,temp)
+	  (:temporary (:sc descriptor-reg :offset lra-offset
+			   :from (:eval 0) :to (:eval 1))
+		      ,lra)
+	  (:temporary (:scs (control-stack) :offset nfp-save-offset)
+		      ,nfp-save)))))
+    (:none
+     (let ((temp (make-symbol "TEMP")))
+       (values 
+	`((inst li ,temp (make-fixup ',name :assembly-routine))
+	  (inst j ,temp)
+	  (inst nop))
+	`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
+		      ,temp)))))))
+
+(def-vm-support-routine generate-return-sequence (style)
+  (ecase style
+    (:raw
+     `((inst j (make-random-tn :kind :normal
+			       :sc (sc-or-lose 'interior-reg *backend*)
+			       :offset lip-offset))
+       (inst nop)))
+    (:full-call
+     `((lisp-return (make-random-tn :kind :normal
+				    :sc (sc-or-lose 'descriptor-reg *backend*)
+				    :offset lra-offset)
+		    :offset 2)))
+    (:none)))
-- 
GitLab