Commit 7f62ee97 authored by Raymond Toy's avatar Raymond Toy
Browse files

Merge branch 'rtoy-rename-to-sparc64' into 'master'

Rename sparcv9 to sparc64

*  Rename directories from sparcv9 to sparc64. 
*  Rename sparcv9-assem.S to sparc64-assem.S.
* Rename Config.sparcv9_sunc to Config.sparc64_sunc.
* Update files to refer to sparc64 instead of sparcv9.

See merge request !20
parents dc743457 0c7901b6
;;; -*- 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