GitLab

at 2016-12-11T10:01:42-08:00

Forgot to remove the original assembly/sparcv9 files.

These were moved to assembly/sparc64.

Default motif_variant for sparc64_sunc

Make motif variant default to solaris_sunc when sparc64_sunc is the
lisp variant.

		OpenBSD*) motif_variant=OpenBSD ;;

		*_darwin) motif_variant=Darwin ;;

		sun4_solaris_gcc|sparc_gcc) motif_variant=solaris ;;

		sun4_solaris_sunc|sparc_sunc|x86_solaris_sunc) motif_variant=solaris_sunc ;;

		sun4_solaris_sunc|sparc_sunc|x86_solaris_sunc|sparc64_sunc) motif_variant=solaris_sunc ;;

		sun4c*) motif_variant=sun4c_411 ;;

		hp700*) motif_variant=hpux_cc ;;

		pmax_mach) motif_variant=pmax_mach ;;

;;; -*- Package: SPARC -*-

;;;

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

;;; 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/assembly/sparc/alloc.lisp $")

;;;

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

;;;

;;; Stuff to handle allocating simple objects.

;;;

;;; Written by William Lott.

;;;

(in-package "SPARC")

;;; But we do everything inline now that we have a better pseudo-atomic.
;;; -*- Package: SPARC -*-

;;;

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

;;; 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/assembly/sparc/arith.lisp $")

;;;

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

;;;

;;; 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 ocfp any-reg ocfp-offset))

  (inst andcc zero-tn x fixnum-tag-mask)

  (inst b :ne DO-STATIC-FUN)

  (inst andcc zero-tn y fixnum-tag-mask)

  (inst b :ne DO-STATIC-FUN)

  (inst nop)

  (inst addcc temp x y)

  (inst b :vc done)

  (inst nop)

  (inst sra temp x fixnum-tag-bits)

  (inst sra temp2 y fixnum-tag-bits)

  (inst add temp2 temp)

  (with-fixed-allocation (res temp bignum-type (1+ bignum-digits-offset))

    (storew temp2 res bignum-digits-offset other-pointer-type))

  (lisp-return lra :offset 2)

  DO-STATIC-FUN

  (inst ld code-tn null-tn (static-function-offset 'two-arg-+))

  (inst li nargs (fixnumize 2))

  (inst move ocfp cfp-tn)

  (inst j code-tn

	(- (* function-code-offset word-bytes) function-pointer-type))

  (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 ocfp any-reg ocfp-offset))

  (inst andcc zero-tn x fixnum-tag-mask)

  (inst b :ne DO-STATIC-FUN)

  (inst andcc zero-tn y fixnum-tag-mask)

  (inst b :ne DO-STATIC-FUN)

  (inst nop)

  (inst subcc temp x y)

  (inst b :vc done)

  (inst nop)

  (inst sra temp x fixnum-tag-bits)

  (inst sra temp2 y fixnum-tag-bits)

  (inst sub temp2 temp temp2)

  (with-fixed-allocation (res temp bignum-type (1+ bignum-digits-offset))

    (storew temp2 res bignum-digits-offset other-pointer-type))

  (lisp-return lra :offset 2)

  DO-STATIC-FUN

  (inst ld code-tn null-tn (static-function-offset 'two-arg--))

  (inst li nargs (fixnumize 2))

  (inst move ocfp cfp-tn)

  (inst j code-tn

	(- (* function-code-offset word-bytes) function-pointer-type))

  (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 ocfp any-reg ocfp-offset))

  ;; If either arg is not a fixnum, call the static function.

  (inst andcc zero-tn x fixnum-tag-mask)

  (inst b :ne DO-STATIC-FUN)

  (inst andcc zero-tn y fixnum-tag-mask)

  (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 fixnum-tag-bits)

  ;; Compute the produce temp * y and return the double-word product

  ;; in hi:lo.

  (cond ((backend-featurep :sparc-64)

	 ;; Sign extend y to a full 64-bits.  temp was already

	 ;; sign-extended by the sra instruction above.

	 (inst sra y 0)

	 (inst mulx hi temp y)

	 (inst move lo hi)

	 (inst srax hi 32))

	((or (backend-featurep :sparc-v8)

	     (backend-featurep :sparc-v9))

	 (inst smul lo temp y)

	 (inst rdy hi))

	(t

	 (let ((MULTIPLIER-POSITIVE (gen-label)))

	   (inst wry temp)

	   (inst andcc hi zero-tn)

	   (inst nop)

	   (inst nop)

	   (dotimes (i 32)

	     (inst mulscc hi y))

	   (inst mulscc hi zero-tn)

	   (inst cmp x)

	   (inst b :ge MULTIPLIER-POSITIVE)

	   (inst nop)

	   (inst sub hi y)

	   (emit-label MULTIPLIER-POSITIVE)

	   (inst rdy lo))))

  ;; 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 lo 31)

  (inst xorcc temp hi)

  (inst b :eq LOW-FITS-IN-FIXNUM)

  ;; Shift the double word hi:lo down two bits to get rid of the fixnum tag.

  (inst sll temp hi 30)

  (inst srl lo fixnum-tag-bits)

  (inst or lo temp)

  (inst sra hi fixnum-tag-bits)

  ;; Allocate a BIGNUM for the result. We always allocate 2 words for

  ;; the bignum result, even if we only need one.  The copying GC will

  ;; take care of the extra word if it isn't needed.

  (with-fixed-allocation

      (res temp bignum-type (+ 2 bignum-digits-offset))

    (let ((one-word (gen-label)))

      ;; We start out assuming that we need one word.  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))

      ;; Need 2 words.  Set the header appropriately, and save the

      ;; high and low parts.

      (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

  (inst ld code-tn null-tn (static-function-offset 'two-arg-*))

  (inst li nargs (fixnumize 2))

  (inst move ocfp cfp-tn)

  (inst j code-tn

	(- (* function-code-offset word-bytes) function-pointer-type))

  (inst move cfp-tn csp-tn)

  LOW-FITS-IN-FIXNUM

  (move res lo))

;;;; Comparison

(macrolet

    ((define-cond-assem-rtn (name translate static-fn cmp)

       `(define-assembly-routine (,name

				  (:cost 10)

				  (:return-style :full-call)

				  (:policy :safe)

				  (:translate ,translate)

				  (:save-p t))

				 ((:arg x (descriptor-reg any-reg) a0-offset)

				  (:arg y (descriptor-reg any-reg) a1-offset)

				  (:res res descriptor-reg a0-offset)

				  (:temp nargs any-reg nargs-offset)

				  (:temp ocfp any-reg ocfp-offset))

	  (inst andcc zero-tn x fixnum-tag-mask)

	  (inst b :ne DO-STATIC-FN)

	  (inst andcc zero-tn y fixnum-tag-mask)

	  (inst b :eq DO-COMPARE)

	  (inst cmp x y)

	  DO-STATIC-FN

	  (inst ld code-tn null-tn (static-function-offset ',static-fn))

	  (inst li nargs (fixnumize 2))

	  (inst move ocfp cfp-tn)

	  (inst j code-tn

		(- (* function-code-offset word-bytes) function-pointer-type))

	  (inst move cfp-tn csp-tn)

	  DO-COMPARE

	  (inst b ,cmp done)

	  (load-symbol res t)

	  (inst move res null-tn)

	  DONE)))

  (define-cond-assem-rtn generic-< < two-arg-< :lt)

  (define-cond-assem-rtn generic-<= <= two-arg-<= :le)

  (define-cond-assem-rtn generic-> > two-arg-> :gt)

  (define-cond-assem-rtn generic->= >= two-arg->= :ge))

(define-assembly-routine (generic-eql

			  (:cost 10)

			  (:return-style :full-call)

			  (:policy :safe)

			  (:translate eql)

			  (:save-p t))

			 ((:arg x (descriptor-reg any-reg) a0-offset)

			  (:arg y (descriptor-reg any-reg) a1-offset)

			  (:res res descriptor-reg a0-offset)

			  (:temp lra descriptor-reg lra-offset)

			  (:temp nargs any-reg nargs-offset)

			  (:temp ocfp any-reg ocfp-offset))

  (inst cmp x y)

  (inst b :eq RETURN-T)

  (inst andcc zero-tn x fixnum-tag-mask)

  (inst b :eq RETURN-NIL)

  (inst andcc zero-tn y fixnum-tag-mask)

  (inst b :ne DO-STATIC-FN)

  (inst nop)

  RETURN-NIL

  (inst move res null-tn)

  (lisp-return lra :offset 2)

  DO-STATIC-FN

  (inst ld code-tn null-tn (static-function-offset 'eql))

  (inst li nargs (fixnumize 2))

  (inst move ocfp cfp-tn)

  (inst j code-tn

	(- (* function-code-offset word-bytes) function-pointer-type))

  (inst move cfp-tn csp-tn)

  RETURN-T

  (load-symbol res t))

(define-assembly-routine (generic-=

			  (:cost 10)

			  (:return-style :full-call)

			  (:policy :safe)

			  (:translate =)

			  (:save-p t))

			 ((:arg x (descriptor-reg any-reg) a0-offset)

			  (:arg y (descriptor-reg any-reg) a1-offset)

			  (:res res descriptor-reg a0-offset)

			  (:temp lra descriptor-reg lra-offset)

			  (:temp nargs any-reg nargs-offset)

			  (:temp ocfp any-reg ocfp-offset))

  (inst andcc zero-tn x fixnum-tag-mask)

  (inst b :ne DO-STATIC-FN)

  (inst andcc zero-tn y fixnum-tag-mask)

  (inst b :ne DO-STATIC-FN)

  (inst cmp x y)

  (inst b :eq RETURN-T)

  (inst nop)

  (inst move res null-tn)

  (lisp-return lra :offset 2)

  DO-STATIC-FN

  (inst ld code-tn null-tn (static-function-offset 'two-arg-=))

  (inst li nargs (fixnumize 2))

  (inst move ocfp cfp-tn)

  (inst j code-tn

	(- (* function-code-offset word-bytes) function-pointer-type))

  (inst move cfp-tn csp-tn)

  RETURN-T

  (load-symbol res t))

(define-assembly-routine (generic-/=

			  (:cost 10)

			  (:return-style :full-call)

			  (:policy :safe)

			  (:translate /=)

			  (:save-p t))

			 ((:arg x (descriptor-reg any-reg) a0-offset)

			  (:arg y (descriptor-reg any-reg) a1-offset)

			  (:res res descriptor-reg a0-offset)

			  (:temp lra descriptor-reg lra-offset)

			  (:temp nargs any-reg nargs-offset)

			  (:temp ocfp any-reg ocfp-offset))

  (inst cmp x y)

  (inst b :eq RETURN-NIL)

  (inst andcc zero-tn x fixnum-tag-mask)

  (inst b :ne DO-STATIC-FN)

  (inst andcc zero-tn y fixnum-tag-mask)

  (inst b :ne DO-STATIC-FN)

  (inst nop)

  (load-symbol res t)

  (lisp-return lra :offset 2)

  DO-STATIC-FN

  (inst ld code-tn null-tn (static-function-offset 'two-arg-=))

  (inst li nargs (fixnumize 2))

  (inst move ocfp cfp-tn)

  (inst j code-tn

	(- (* function-code-offset word-bytes) function-pointer-type))

  (inst move cfp-tn csp-tn)

  RETURN-NIL

  (inst move res null-tn))
;;; -*- Package: SPARC -*-

;;;

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

;;; 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/assembly/sparc/array.lisp $")

;;;

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

;;;

;;; $Header: src/assembly/sparc/array.lisp $

;;;

;;;    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 gc-temp non-descriptor-reg nl1-offset)

			  (:temp vector descriptor-reg a3-offset))

  (pseudo-atomic ()

    (inst add ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes))

    (inst andn ndescr vm:lowtag-mask)

    (allocation vector ndescr other-pointer-type :temp-tn gc-temp)

    #+gencgc

    (progn

      ;; ndescr points to one word past the end of the allocated

      ;; space.  Fill the last word with a zero.

      (inst add ndescr vector)

      (storew zero-tn ndescr -1 vm:other-pointer-type))

    (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))

  ;; This makes sure the zero byte at the end of a string is paged in so

  ;; the kernel doesn't bitch if we pass it the string.

  ;;

  ;; This used to write to the word after the last allocated word.  I

  ;; (RLT) made it write to the last allocated word, which is where

  ;; the zero-byte of the string is.  Look at the deftransform for

  ;; make-array in array-tran.lisp.  For strings we always allocate

  ;; enough space to hold the zero-byte.

  #-gencgc

  (storew zero-tn alloc-tn -1)

  (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 length any-reg a1-offset)

			  (:temp accum non-descriptor-reg nl0-offset)

			  (:temp data non-descriptor-reg nl1-offset)

			  (:temp temp non-descriptor-reg nl2-offset)

			  (:temp offset non-descriptor-reg nl3-offset))

  (declare (ignore result accum data temp offset))

  (inst b sxhash-simple-substring-entry)

  (loadw length string vm:vector-length-slot vm:other-pointer-type))

;; Implement the one-at-a-time algorithm designed by Bob Jenkins

;; (see <http://burtleburtle.net/bob/hash/doobs.html> for some

;; more information).

;;

;; For completeness, here is the hash function, in C, from that web

;; page.  ub4 is an unsigned 32-bit integer.

#||

ub4 one_at_a_time(char *key, ub4 len)

{

  ub4   hash, i;

  for (hash=0, i=0; i<len; ++i)

  {

    hash += key[i];

    hash += (hash << 10);

    hash ^= (hash >> 6);

  }

  hash += (hash << 3);

  hash ^= (hash >> 11);

  hash += (hash << 15);

  return (hash & mask);

} 

||#

(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 accum non-descriptor-reg nl0-offset)

			  (:temp data non-descriptor-reg nl1-offset)

			  (:temp temp non-descriptor-reg nl2-offset)

			  (:temp offset non-descriptor-reg nl3-offset))

  (emit-label sxhash-simple-substring-entry)

  #+unicode

  (inst sll length 1)		  ; Number of bytes = twice the length

  (inst li offset (- (* vector-data-offset word-bytes) other-pointer-type))

  (inst b test)

  (move accum zero-tn)

  LOOP

  ;; hash += key[i]

  (inst add accum data)

  ;; hash += (hash << 10)

  (inst slln temp accum 10)

  (inst add accum temp)

  ;; hash ^= (hash >> 6)

  (inst srln temp accum 6)

  (inst xor accum temp)

  (inst add offset 1)

  TEST

  (inst subcc length (fixnumize 1))

  (inst b :ge loop)

  (inst ldub data string offset)

  ;; hash += (hash << 3)

  (inst slln temp accum 3)

  (inst add accum temp)

  ;; hash ^= (hash >> 11)

  (inst srln temp accum 11)

  (inst xor accum temp)

  ;; hash += (hash << 15)

  (inst slln temp accum 15)

  (inst add accum temp)

  ;;(inst li temp most-positive-fixnum)

  ;;(inst and accum temp)

  ;; Make it a fixnum result

  ;; Make the result a positive fixnum.  Shifting it left, then right

  ;; does what we want, and extracts the bits we need.

  (inst slln accum (1+ vm:fixnum-tag-bits))

  (inst srln result accum 1))
;;; -*- Package: SPARC -*-

;;;

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

;;; 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/assembly/sparc/assem-rtns.lisp $")

;;;

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

;;;

;;; $Header: src/assembly/sparc/assem-rtns.lisp $

;;;

;;;

(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 cname-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 (fixnumize 2))

  (inst b :le default-a2-and-on)

  (inst ld a1 vals (* 1 vm:word-bytes))

  (inst cmp nvals (fixnumize 3))

  (inst b :le default-a3-and-on)

  (inst ld a2 vals (* 2 vm:word-bytes))

  (inst cmp nvals (fixnumize 4))

  (inst b :le default-a4-and-on)

  (inst ld a3 vals (* 3 vm:word-bytes))

  (inst cmp nvals (fixnumize 5))

  (inst b :le default-a5-and-on)

  (inst ld a4 vals (* 4 vm:word-bytes))

  (inst cmp nvals (fixnumize 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 (fixnumize 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 (fixnumize 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 cname-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 (fixnumize (- 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 (fixnumize -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))

;; Assembly routines for undefined_tramp and closure_tramp

#+assembler

(define-assembly-routine (closure-tramp-function-alignment

			  (:return-style :none))

                         ()

  ;; Align to a dualword and put in the magic function header stuff so

  ;; that closure-tramp looks like a normal function with a function

  ;; tag.

  (align vm:lowtag-bits)

  (inst byte 0))

#+assembler

(define-assembly-routine (closure-tramp

			  (:return-style :none))

                         ()

  (inst byte 0)

  (inst byte 0)

  (inst byte vm:function-header-type)

  ;; This is supposed to be closure-tramp, not 0.

  (inst word 0)

  (inst word (kernel:get-lisp-obj-address nil))

  (inst word (kernel:get-lisp-obj-address nil))

  (inst word (kernel:get-lisp-obj-address nil))

  (inst word (kernel:get-lisp-obj-address nil))

  (loadw lexenv-tn cname-tn fdefn-function-slot other-pointer-type)

  (loadw code-tn lexenv-tn closure-function-slot function-pointer-type)

  (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type))

  (inst nop)

  ;; Make sure following routine is dual-word aligned

  (align vm:lowtag-bits))

#+assembler

(define-assembly-routine (undefined-tramp-function-alignment

			  (:return-style :none))

                         ()

  ;; Align to a dualword and put in the magic function header stuff so

  ;; that closure-tramp looks like a normal function with a function

  ;; tag.

  (align vm:lowtag-bits)

  (inst byte 0))

#+assembler

(define-assembly-routine (undefined-tramp

			  (:return-style :none))

                         ()

  (inst byte 0)

  (inst byte 0)

  (inst byte vm:function-header-type)

  ;; This is supposed to be undefined-tramp, not 0.

  (inst word 0)

  (inst word (kernel:get-lisp-obj-address nil))

  (inst word (kernel:get-lisp-obj-address nil))

  (inst word (kernel:get-lisp-obj-address nil))

  (inst word (kernel:get-lisp-obj-address nil))

  (let ((error (generate-cerror-code nil undefined-symbol-error cname-tn)))

    (inst b error)

    (inst nop)

    ;; I don't think we ever return from the undefined-symbol-error

    ;; handler, but the assembly code did this so we'll do it too.

    (loadw code-tn cname-tn fdefn-raw-addr-slot other-pointer-type)

    (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type))

    (inst nop)))
;;; -*- Package: SPARC -*-

;;;

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

;;; 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/assembly/sparc/support.lisp $")

;;;

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

;;;

(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 jali ,lip ,temp (make-fixup ',name :assembly-routine))

	  (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)

	    (note-next-instruction ,vop :call-site)

	    (inst ji ,temp (make-fixup ',name :assembly-routine))

	    (inst nop)

	    (emit-return-pc lra-label)

	    (note-this-location ,vop :single-value-return)

	    (without-scheduling ()

	      (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)

	  (:save-p :compute-only)))))

    (:none

     (let ((temp (make-symbol "TEMP")))

       (values 

	`((inst ji ,temp (make-fixup ',name :assembly-routine))

	  (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)

	     8)

       (inst nop)))

    (:full-call

     `((lisp-return (make-random-tn :kind :normal

				    :sc (sc-or-lose 'descriptor-reg *backend*)

				    :offset lra-offset)

		    :offset 2)))

    (:none)))

Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

6 changed files:

Changes: