[Git][cmucl/cmucl][master] 2 commits: Forgot to remove the original assembly/sparcv9 files.
Raymond Toy
rtoy at common-lisp.net
Sun Dec 11 18:05:13 UTC 2016
Raymond Toy pushed to branch master at cmucl / cmucl
Commits:
e5c415bd by Raymond Toy at 2016-12-11T10:01:42-08:00
Forgot to remove the original assembly/sparcv9 files.
These were moved to assembly/sparc64.
- - - - -
0f4c649a by Raymond Toy at 2016-12-11T10:05:01-08:00
Default motif_variant for sparc64_sunc
Make motif variant default to solaris_sunc when sparc64_sunc is the
lisp variant.
- - - - -
6 changed files:
- bin/create-target.sh
- − src/assembly/sparcv9/alloc.lisp
- − src/assembly/sparcv9/arith.lisp
- − src/assembly/sparcv9/array.lisp
- − src/assembly/sparcv9/assem-rtns.lisp
- − src/assembly/sparcv9/support.lisp
Changes:
=====================================
bin/create-target.sh
=====================================
--- a/bin/create-target.sh
+++ b/bin/create-target.sh
@@ -78,7 +78,7 @@ case $uname_s in
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 ;;
=====================================
src/assembly/sparcv9/alloc.lisp deleted
=====================================
--- a/src/assembly/sparcv9/alloc.lisp
+++ /dev/null
@@ -1,19 +0,0 @@
-;;; -*- 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.
=====================================
src/assembly/sparcv9/arith.lisp deleted
=====================================
--- a/src/assembly/sparcv9/arith.lisp
+++ /dev/null
@@ -1,364 +0,0 @@
-;;; -*- 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))
=====================================
src/assembly/sparcv9/array.lisp deleted
=====================================
--- a/src/assembly/sparcv9/array.lisp
+++ /dev/null
@@ -1,169 +0,0 @@
-;;; -*- 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))
=====================================
src/assembly/sparcv9/assem-rtns.lisp deleted
=====================================
--- a/src/assembly/sparcv9/assem-rtns.lisp
+++ /dev/null
@@ -1,311 +0,0 @@
-;;; -*- 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)))
=====================================
src/assembly/sparcv9/support.lisp deleted
=====================================
--- a/src/assembly/sparcv9/support.lisp
+++ /dev/null
@@ -1,78 +0,0 @@
-;;; -*- 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)))
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/7f62ee97f9d815eeb37c5bfd5280e6e73d718fda...0f4c649aed834c542c5ea787f23096cb302a0b33
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20161211/4237d8aa/attachment-0001.html>
More information about the cmucl-cvs
mailing list