Skip to content
Snippets Groups Projects
Commit 2aed10fc authored by Raymond Toy's avatar Raymond Toy
Browse files

Rename sparcv9 to sparc64.

I keep typing sparc64, so let's make it sparc64 instead of sparcv9.

No other changes.
parent dc743457
No related branches found
No related tags found
No related merge requests found
Showing
with 941 additions and 0 deletions
;;; -*- 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)))
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
File moved
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment