diff --git a/src/assembly/sparcv9/alloc.lisp b/src/assembly/sparcv9/alloc.lisp new file mode 100644 index 0000000000000000000000000000000000000000..dc87046ae126a9b9cd174df5fea2d117a3f07bd9 --- /dev/null +++ b/src/assembly/sparcv9/alloc.lisp @@ -0,0 +1,19 @@ +;;; -*- 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. diff --git a/src/assembly/sparcv9/arith.lisp b/src/assembly/sparcv9/arith.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a49b1c1fe5c3c7dcb90bc54308ed426ec4d5d8a9 --- /dev/null +++ b/src/assembly/sparcv9/arith.lisp @@ -0,0 +1,364 @@ +;;; -*- 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)) diff --git a/src/assembly/sparcv9/array.lisp b/src/assembly/sparcv9/array.lisp new file mode 100644 index 0000000000000000000000000000000000000000..21a5b4a9801eefb1e3ef53f5c6efc6de5dfe4f62 --- /dev/null +++ b/src/assembly/sparcv9/array.lisp @@ -0,0 +1,169 @@ +;;; -*- 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)) diff --git a/src/assembly/sparcv9/assem-rtns.lisp b/src/assembly/sparcv9/assem-rtns.lisp new file mode 100644 index 0000000000000000000000000000000000000000..9fe07c2cbcc68237d0516292ccf9c755eaf760e4 --- /dev/null +++ b/src/assembly/sparcv9/assem-rtns.lisp @@ -0,0 +1,311 @@ +;;; -*- 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))) diff --git a/src/assembly/sparcv9/support.lisp b/src/assembly/sparcv9/support.lisp new file mode 100644 index 0000000000000000000000000000000000000000..8940f23d50986a7b55c67a3bb963c1e37bc9202b --- /dev/null +++ b/src/assembly/sparcv9/support.lisp @@ -0,0 +1,78 @@ +;;; -*- 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))) diff --git a/src/compiler/sparcv9/alloc.lisp b/src/compiler/sparcv9/alloc.lisp new file mode 100644 index 0000000000000000000000000000000000000000..0a448da923d62dc25f965c52c85e97cd7391d3b9 --- /dev/null +++ b/src/compiler/sparcv9/alloc.lisp @@ -0,0 +1,214 @@ +;;; -*- 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/compiler/sparc/alloc.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; Allocation VOPs for the SPARC port. +;;; +;;; Written by William Lott. +;;; + +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") + +;;;; Dynamic-Extent. + +;;; +;;; Take an arg where to move the stack pointer instead of returning +;;; it via :results, because the former generates a single move. +;;; +(define-vop (%dynamic-extent-start) + (:args (saved-stack-pointer :scs (any-reg control-stack))) + (:results) + (:policy :safe) + (:generator 0 + (sc-case saved-stack-pointer + (control-stack + (let ((offset (tn-offset saved-stack-pointer))) + (storew csp-tn cfp-tn offset))) + (any-reg + (move saved-stack-pointer csp-tn))))) + +(define-vop (%dynamic-extent-end) + (:args (saved-stack-pointer :scs (any-reg control-stack))) + (:results) + (:policy :safe) + (:generator 0 + (sc-case saved-stack-pointer + (control-stack + (let ((offset (tn-offset saved-stack-pointer))) + (loadw csp-tn cfp-tn offset))) + (any-reg + (move csp-tn saved-stack-pointer))))) + +;;;; LIST and LIST* + +(define-vop (list-or-list*) + (:args (things :more t)) + (:temporary (:scs (descriptor-reg) :type list) ptr) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result) + res) + (:temporary (:scs (non-descriptor-reg)) alloc-temp) + (:info num dynamic-extent) + (:results (result :scs (descriptor-reg))) + (:variant-vars star) + (:policy :safe) + (:generator 0 + (cond ((zerop num) + (move result null-tn)) + ((and star (= num 1)) + (move result (tn-ref-tn things))) + (t + (macrolet + ((maybe-load (tn) + (once-only ((tn tn)) + `(sc-case ,tn + ((any-reg descriptor-reg zero null) + ,tn) + (control-stack + (load-stack-tn temp ,tn) + temp))))) + (let* ((cons-cells (if star (1- num) num)) + (alloc (* (pad-data-block cons-size) cons-cells))) + (pseudo-atomic () + (allocation res alloc list-pointer-type + :stack-p dynamic-extent + :temp-tn alloc-temp) + (move ptr res) + (dotimes (i (1- cons-cells)) + (storew (maybe-load (tn-ref-tn things)) ptr + cons-car-slot list-pointer-type) + (setf things (tn-ref-across things)) + (inst add ptr ptr (pad-data-block cons-size)) + (storew ptr ptr + (- cons-cdr-slot cons-size) + list-pointer-type)) + (storew (maybe-load (tn-ref-tn things)) ptr + cons-car-slot list-pointer-type) + (storew (if star + (maybe-load (tn-ref-tn (tn-ref-across things))) + null-tn) + ptr cons-cdr-slot list-pointer-type)) + (move result res))))))) + +(define-vop (list list-or-list*) + (:variant nil)) + +(define-vop (list* list-or-list*) + (:variant t)) + + +;;;; Special purpose inline allocators. + +(define-vop (allocate-code-object) + (:args (boxed-arg :scs (any-reg)) + (unboxed-arg :scs (any-reg))) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:scs (non-descriptor-reg)) size) + (:temporary (:scs (any-reg) :from (:argument 0)) boxed) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) + (:generator 100 + (inst add boxed boxed-arg (fixnumize (1+ code-trace-table-offset-slot))) + (inst and boxed (lognot lowtag-mask)) + (inst srln unboxed unboxed-arg word-shift) + (inst add unboxed lowtag-mask) + (inst and unboxed (lognot lowtag-mask)) + (pseudo-atomic () + ;; Figure out how much space we really need and allocate it. + (inst add size boxed unboxed) + (allocation result size other-pointer-type :temp-tn ndescr) + (inst slln ndescr boxed (- type-bits word-shift)) + (inst or ndescr code-header-type) + (storew ndescr result 0 other-pointer-type) + (storew unboxed result code-code-size-slot other-pointer-type) + (storew null-tn result code-entry-points-slot other-pointer-type) + (storew null-tn result code-debug-info-slot other-pointer-type)))) + +(define-vop (make-fdefn) + (:args (name :scs (descriptor-reg) :to :eval)) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (result :scs (descriptor-reg) :from :argument)) + (:policy :fast-safe) + (:translate make-fdefn) + (:generator 37 + (with-fixed-allocation (result temp fdefn-type fdefn-size) + ;; For the linkage-table stuff, we need to look up the address + ;; of undefined_tramp from the linkage table instead of using + ;; the address directly. + (inst li temp (make-fixup 'undefined-tramp + :assembly-routine)) + (storew name result fdefn-name-slot other-pointer-type) + (storew null-tn result fdefn-function-slot other-pointer-type) + (storew temp result fdefn-raw-addr-slot other-pointer-type)))) + + +(define-vop (make-closure) + (:args (function :to :save :scs (descriptor-reg))) + (:info length dynamic-extent) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (result :scs (descriptor-reg))) + (:generator 10 + (let ((size (+ length closure-info-offset))) + (with-fixed-allocation (result temp closure-header-type size + :lowtag function-pointer-type + :stack-p dynamic-extent) + (storew function result closure-function-slot function-pointer-type))))) + +;;; The compiler likes to be able to directly make value cells. +;;; +(define-vop (make-value-cell) + (:args (value :to :save :scs (descriptor-reg any-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (result :scs (descriptor-reg))) + (:generator 10 + (with-fixed-allocation + (result temp value-cell-header-type value-cell-size) + (storew value result value-cell-value-slot other-pointer-type)))) + + + +;;;; Automatic allocators for primitive objects. + +(define-vop (make-unbound-marker) + (:args) + (:results (result :scs (any-reg))) + (:generator 1 + (inst li result unbound-marker-type))) + +(define-vop (fixed-alloc) + (:args) + (:info name words type lowtag dynamic-extent) + (:ignore name) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 4 + (with-fixed-allocation (result temp type words :lowtag lowtag :stack-p dynamic-extent) + ))) + +(define-vop (var-alloc) + (:args (extra :scs (any-reg))) + (:arg-types positive-fixnum) + (:info name words type lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (any-reg)) bytes) + (:temporary (:scs (non-descriptor-reg)) header) + (:temporary (:scs (any-reg)) temp) + (:generator 6 + (inst add bytes extra (* (1+ words) word-bytes)) + (inst slln header bytes (- type-bits vm:fixnum-tag-bits)) ; because bytes is already a fixnum + (inst add header header (+ (ash -2 type-bits) type)) + (inst and bytes (lognot lowtag-mask)) + (pseudo-atomic () + ;; Need to be careful if the lowtag and the pseudo-atomic flag + ;; are not compatible + (allocation result bytes lowtag :temp-tn temp) + (storew header result 0 lowtag)))) diff --git a/src/compiler/sparcv9/arith.lisp b/src/compiler/sparcv9/arith.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a4d36f6da81d910c4579f60cdbb0915fb96653b6 --- /dev/null +++ b/src/compiler/sparcv9/arith.lisp @@ -0,0 +1,2590 @@ +;;; -*- 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/compiler/sparc/arith.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition arithmetic VOPs for the SPARC. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted by William Lott. +;;; +;;; Enhancements/debugging by Raymond Toy 1999, 2000 + +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") + + +;;;; Unary operations. + +(define-vop (fast-safe-arith-op) + (:policy :fast-safe) + (:effects) + (:affected)) + + +(define-vop (fixnum-unop fast-safe-arith-op) + (:args (x :scs (any-reg))) + (:results (res :scs (any-reg))) + (:note _N"inline fixnum arithmetic") + (:arg-types tagged-num) + (:result-types tagged-num)) + +(define-vop (signed-unop fast-safe-arith-op) + (:args (x :scs (signed-reg))) + (:results (res :scs (signed-reg))) + (:note _N"inline (signed-byte 32) arithmetic") + (:arg-types signed-num) + (:result-types signed-num)) + +(define-vop (fast-negate/fixnum fixnum-unop) + (:translate %negate) + (:generator 1 + (inst neg res x))) + +(define-vop (fast-negate/signed signed-unop) + (:translate %negate) + (:generator 2 + (inst neg res x))) + +(define-vop (fast-lognot/fixnum fixnum-unop) + (:translate lognot) + (:generator 2 + (inst xor res x (fixnumize -1)))) + +(define-vop (fast-lognot/signed signed-unop) + (:translate lognot) + (:generator 1 + (inst not res x))) + + +;;;; Binary fixnum operations. + +;;; Assume that any constant operand is the second arg... + +(define-vop (fast-fixnum-binop fast-safe-arith-op) + (:args (x :target r :scs (any-reg zero)) + (y :target r :scs (any-reg zero))) + (:arg-types tagged-num tagged-num) + (:results (r :scs (any-reg))) + (:result-types tagged-num) + (:note _N"inline fixnum arithmetic")) + +(define-vop (fast-unsigned-binop fast-safe-arith-op) + (:args (x :target r :scs (unsigned-reg zero)) + (y :target r :scs (unsigned-reg zero))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:note _N"inline (unsigned-byte 32) arithmetic")) + +(define-vop (fast-signed-binop fast-safe-arith-op) + (:args (x :target r :scs (signed-reg zero)) + (y :target r :scs (signed-reg zero))) + (:arg-types signed-num signed-num) + (:results (r :scs (signed-reg))) + (:result-types signed-num) + (:note _N"inline (signed-byte 32) arithmetic")) + +(define-vop (fast-fixnum-binop-c fast-safe-arith-op) + (:args (x :target r :scs (any-reg zero))) + (:info y) + (:arg-types tagged-num + (:constant (and (signed-byte #.(- 13 vm:fixnum-tag-bits)) (not (integer 0 0))))) + (:results (r :scs (any-reg))) + (:result-types tagged-num) + (:note _N"inline fixnum arithmetic")) + +(define-vop (fast-unsigned-binop-c fast-safe-arith-op) + (:args (x :target r :scs (unsigned-reg zero))) + (:info y) + (:arg-types unsigned-num + (:constant (and (signed-byte 13) (not (integer 0 0))))) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:note _N"inline (unsigned-byte 32) arithmetic")) + +(define-vop (fast-signed-binop-c fast-safe-arith-op) + (:args (x :target r :scs (signed-reg zero))) + (:info y) + (:arg-types signed-num + (:constant (and (signed-byte 13) (not (integer 0 0))))) + (:results (r :scs (signed-reg))) + (:result-types signed-num) + (:note _N"inline (signed-byte 32) arithmetic")) + +(eval-when (compile load eval) + +(defmacro define-binop (translate untagged-penalty op + &optional arg-swap restore-fixnum-mask) + `(progn + (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") + fast-fixnum-binop) + (:translate ,translate) + ,@(when restore-fixnum-mask + `((:temporary (:sc non-descriptor-reg) temp))) + (:generator 2 + ,(if arg-swap + `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x) + `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y)) + ,@(when restore-fixnum-mask + ``(inst andn r temp fixnum-tag-mask)))) + ,@(unless arg-swap + `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM") + fast-fixnum-binop-c) + (:translate ,translate) + ,@(when restore-fixnum-mask + `((:temporary (:sc non-descriptor-reg) temp))) + (:generator 1 + (inst ,op ,(if restore-fixnum-mask 'temp 'r) x (fixnumize y)) + ,@(when restore-fixnum-mask + `((inst andn r temp fixnum-tag-mask))))))) + (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") + fast-signed-binop) + (:translate ,translate) + (:generator ,(1+ untagged-penalty) + ,(if arg-swap + `(inst ,op r y x) + `(inst ,op r x y)))) + ,@(unless arg-swap + `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED") + fast-signed-binop-c) + (:translate ,translate) + (:generator ,untagged-penalty + (inst ,op r x y))))) + (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") + fast-unsigned-binop) + (:translate ,translate) + (:generator ,(1+ untagged-penalty) + ,(if arg-swap + `(inst ,op r y x) + `(inst ,op r x y)))) + ,@(unless arg-swap + `((define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED") + fast-unsigned-binop-c) + (:translate ,translate) + (:generator ,untagged-penalty + (inst ,op r x y))))))) + +); eval-when + +(define-binop + 4 add) +(define-binop - 4 sub) +(define-binop logand 2 and) +(define-binop logandc1 2 andn t) +(define-binop logandc2 2 andn) +(define-binop logior 2 or) +(define-binop logorc1 2 orn t t) +(define-binop logorc2 2 orn nil t) +(define-binop logxor 2 xor) +(define-binop logeqv 2 xnor nil t) + +;;; Special logand cases: (logand signed unsigned) => unsigned + +(define-vop (fast-logand/signed-unsigned=>unsigned + fast-logand/unsigned=>unsigned) + (:args (x :scs (signed-reg)) + (y :target r :scs (unsigned-reg))) + (:arg-types signed-num unsigned-num)) + +(define-vop (fast-logand/unsigned-signed=>unsigned + fast-logand/unsigned=>unsigned) + (:args (x :target r :scs (unsigned-reg)) + (y :scs (signed-reg))) + (:arg-types unsigned-num signed-num)) + +;; This vop is intended to handle the case (logand x #xffffffff) when +;; x is a (signed-byte 32). We can just do a register move instead of +;; and'ing with #xffffffff. Some other special cases are handled too +;; when the constant can fit inside the immediate operaand of the and +;; instruction. +(define-vop (fast-logand-c/signed-unsigned=>unsigned fast-unsigned-binop-c) + (:args (x :scs (signed-reg))) + (:translate logand) + (:arg-types signed-num + (:constant (or (and (unsigned-byte 12) (not (integer 0 0))) + (integer #xfffff000 #xffffffff)))) + (:generator 2 ; Needs to be low to give this vop a chance. + (cond ((= y #xffffffff) + (move r x)) + ((typep y '(unsigned-byte 13)) + (inst and r x y)) + (t + ;; The constant operand is really a (signed-byte 13), so convert it + ;; to a negative number so the immediate operand gets + ;; signed extended to the right bits. + (inst and r x (- y #x100000000)) + )))) + +(define-vop (fast-abs/signed fast-safe-arith-op) + (:args (x :scs (signed-reg))) + (:arg-types signed-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate abs) + (:note _N"inline 32-bit abs") + (:temporary (:scs (signed-reg)) y) + (:generator 1 + ;; From Hacker's Delight + ;; + ;; abs(x) = (x ^ y) - y, where y = x >> 31 (signed shift) + (inst sran y x (1- vm:word-bits)) + (inst xor r y x) + (inst sub r y))) + +;;; Special case fixnum + and - that trap on overflow. Useful when we +;;; don't know that the output type is a fixnum. + +;;; I (toy@rtp.ericsson.se) took these out. They don't seem to be +;;; used anywhere at all. +#+nil +(progn +(define-vop (+/fixnum fast-+/fixnum=>fixnum) + (:policy :safe) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types tagged-num) + (:note _N"safe inline fixnum arithmetic") + (:generator 4 + (inst taddcctv r x y))) + +(define-vop (+-c/fixnum fast-+-c/fixnum=>fixnum) + (:policy :safe) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types tagged-num) + (:note _N"safe inline fixnum arithmetic") + (:generator 3 + (inst taddcctv r x (fixnumize y)))) + +(define-vop (-/fixnum fast--/fixnum=>fixnum) + (:policy :safe) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types tagged-num) + (:note _N"safe inline fixnum arithmetic") + (:generator 4 + (inst tsubcctv r x y))) + +(define-vop (--c/fixnum fast---c/fixnum=>fixnum) + (:policy :safe) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types tagged-num) + (:note _N"safe inline fixnum arithmetic") + (:generator 3 + (inst tsubcctv r x (fixnumize y)))) + +) + +;;; Truncate + +;; This doesn't work for some reason. +#+nil +(define-vop (fast-v8-truncate/fixnum=>fixnum fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (any-reg)) + (y :scs (any-reg))) + (:arg-types tagged-num tagged-num) + (:results (quo :scs (any-reg)) + (rem :scs (any-reg))) + (:result-types tagged-num tagged-num) + (:note _N"inline fixnum arithmetic") + (:temporary (:scs (any-reg) :target quo) q) + (:temporary (:scs (any-reg)) r) + (:temporary (:scs (signed-reg)) y-int) + (:vop-var vop) + (:save-p :compute-only) + (:guard (or (backend-featurep :sparc-v8) + (and (backend-featurep :sparc-v9) + (not (backend-featurep :sparc-64))))) + (:generator 12 + (let ((zero (generate-error-code vop division-by-zero-error x y))) + (inst cmp y zero-tn) + (inst b :eq zero) + ;; Extend the sign of X into the Y register + (inst sra r x 31) + (inst wry r) + ;; Remove tag bits so Q and R will be tagged correctly. + (inst sra y-int y fixnum-tag-bits) + (inst nop) + (inst nop) + + (inst sdiv q x y-int) ; Q is tagged. + ;; We have the quotient so we need to compute the remainder + (inst smul r q y-int) ; R is tagged + (inst sub rem x r) + (unless (location= quo q) + (move quo q))))) + +(define-vop (fast-v8-truncate/signed=>signed fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (signed-reg)) + (y :scs (signed-reg))) + (:arg-types signed-num signed-num) + (:results (quo :scs (signed-reg)) + (rem :scs (signed-reg))) + (:result-types signed-num signed-num) + (:note _N"inline (signed-byte 32) arithmetic") + (:temporary (:scs (signed-reg) :target quo) q) + (:temporary (:scs (signed-reg)) r) + (:vop-var vop) + (:save-p :compute-only) + (:guard (or (backend-featurep :sparc-v8) + (and (backend-featurep :sparc-v9) + (not (backend-featurep :sparc-64))))) + (:generator 12 + (let ((zero (generate-error-code vop division-by-zero-error x y))) + (inst cmp y zero-tn) + (inst b :eq zero #+sparc-v9 :pn) + ;; Extend the sign of X into the Y register + (inst sra r x 31) + (inst wry r) + (inst nop) + (inst nop) + (inst nop) + + (inst sdiv q x y) + ;; We have the quotient so we need to compue the remainder + (inst smul r q y) ; rem + (inst sub rem x r) + (unless (location= quo q) + (move quo q))))) + +(define-vop (fast-v8-truncate/unsigned=>unsigned fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (unsigned-reg)) + (y :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num) + (:results (quo :scs (unsigned-reg)) + (rem :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:note _N"inline (unsigned-byte 32) arithmetic") + (:temporary (:scs (unsigned-reg) :target quo) q) + (:temporary (:scs (unsigned-reg)) r) + (:vop-var vop) + (:save-p :compute-only) + (:guard (or (backend-featurep :sparc-v8) + (and (backend-featurep :sparc-v9) + (not (backend-featurep :sparc-64))))) + (:generator 8 + (let ((zero (generate-error-code vop division-by-zero-error x y))) + (inst cmp y zero-tn) + (inst b :eq zero #+sparc-v9 :pn) + (inst wry zero-tn) ; Clear out high part + (inst nop) + (inst nop) + (inst nop) + + (inst udiv q x y) + ;; Compute remainder + (inst umul r q y) + (inst sub rem x r) + (unless (location= quo q) + (inst move quo q))))) + +(define-vop (fast-v9-truncate/signed=>signed fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (signed-reg)) + (y :scs (signed-reg))) + (:arg-types signed-num signed-num) + (:results (quo :scs (signed-reg)) + (rem :scs (signed-reg))) + (:result-types signed-num signed-num) + (:note _N"inline (signed-byte 32) arithmetic") + (:temporary (:scs (signed-reg) :target quo) q) + (:temporary (:scs (signed-reg)) r) + (:vop-var vop) + (:save-p :compute-only) + (:guard (backend-featurep :sparc-64)) + (:generator 8 + (let ((zero (generate-error-code vop division-by-zero-error x y))) + (inst cmp y zero-tn) + (inst b :eq zero :pn) + ;; Sign extend the numbers, just in case. + (inst signx x) + (inst signx y) + (inst sdivx q x y) + ;; Compute remainder + (inst mulx r q y) + (inst sub rem x r) + (unless (location= quo q) + (inst move quo q))))) + +#+nil +(define-vop (fast-v9-truncate/signed64=>signed64 fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (signed64-reg)) + (y :scs (signed64-reg))) + (:arg-types signed64-num signed64-num) + (:results (quo :scs (signed64-reg)) + (rem :scs (signed64-reg))) + (:result-types signed64-num signed64-num) + (:note _N"inline (signed-byte 32) arithmetic") + (:temporary (:scs (signed64-reg) :target quo) q) + (:temporary (:scs (signed64-reg)) r) + (:vop-var vop) + (:save-p :compute-only) + (:guard (backend-featurep :sparc-v9)) + (:generator 8 + (let ((zero (generate-error-code vop division-by-zero-error x y))) + (inst cmp y zero-tn) + (inst b :eq zero :pn :xcc) + (inst nop) + + (inst sdivx q x y) + ;; Compute remainder + (inst mulx r q y) + (inst sub rem x r) + (unless (location= quo q) + (inst move quo q))))) + +(define-vop (fast-v9-truncate/unsigned=>unsigned fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (unsigned-reg)) + (y :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num) + (:results (quo :scs (unsigned-reg)) + (rem :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:note _N"inline (unsigned-byte 32) arithmetic") + (:temporary (:scs (unsigned-reg) :target quo) q) + (:temporary (:scs (unsigned-reg)) r) + (:vop-var vop) + (:save-p :compute-only) + (:guard (backend-featurep :sparc-64)) + (:generator 8 + (let ((zero (generate-error-code vop division-by-zero-error x y))) + (inst cmp y zero-tn) + (inst b :eq zero :pn) + ;; Zap the higher 32 bits, just in case + (inst clruw x) + (inst clruw y) + (inst udivx q x y) + ;; Compute remainder + (inst mulx r q y) + (inst sub rem x r) + (unless (location= quo q) + (inst move quo q))))) + +;;; Shifting + +(define-vop (fast-ash/signed=>signed) + (:note _N"inline (signed-byte 32) ASH") + (:args (number :scs (signed-reg) :to :save) + (amount :scs (signed-reg immediate) :to :save)) + (:arg-types signed-num signed-num) + (:results (result :scs (signed-reg))) + (:result-types signed-num) + (:translate ash) + (:policy :fast-safe) + (:temporary (:sc non-descriptor-reg) ndesc) + (:generator 5 + (sc-case amount + (signed-reg + (cond ((backend-featurep :sparc-v9) + (let ((done (gen-label))) + (inst cmp amount) + (inst b :ge done) + ;; The result-type assures us that this shift will not + ;; overflow. + (inst slln result number amount) + (inst neg ndesc amount) + ;; ndesc = max(-amount, 31) + (inst cmp ndesc 31) + (inst cmove :ge ndesc 31) + (inst sran result number ndesc) + (emit-label done))) + (t + (let ((done (gen-label))) + (inst cmp amount) + (inst b :ge done) + ;; The result-type assures us that this shift will not overflow. + (inst slln result number amount) + + ;; Handle right shifts here. + (inst neg ndesc amount) + (inst cmp ndesc 31) + (inst b :le done) + (inst sran result number ndesc) + ;; Right shift of greater than 31 bits is the same as a shift + ;; of 31 bits for signed 32-bit numbers. + (inst sran result number 31) + + (emit-label done))))) + + (immediate + (let ((amount (tn-value amount))) + (cond ((< amount -31) + (inst li result -1)) + ((< amount 0) + (inst sran result number (- amount))) + ((> amount 0) + (inst slln result number amount)) + (t + ;; amount = 0. Shouldn't happen because of a + ;; deftransform, but it's easy. + (move result number)))))))) + +(define-vop (fast-ash/unsigned=>unsigned) + (:note _N"inline (unsigned-byte 32) ASH") + (:args (number :scs (unsigned-reg) :to :save) + (amount :scs (signed-reg immediate) :to :save)) + (:arg-types unsigned-num signed-num) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate ash) + (:policy :fast-safe) + (:temporary (:sc non-descriptor-reg) ndesc) + (:generator 5 + (sc-case amount + (signed-reg + (cond ((backend-featurep :sparc-v9) + (let ((done (gen-label))) + (inst cmp amount) + (inst b :ge done) + ;; The result-type assures us that this shift will not + ;; overflow. + (inst slln result number amount) + (inst neg ndesc amount) + ;; A right shift of 32 or more results in zero. + (inst cmp ndesc 32) + (inst srln result number ndesc) + (inst cmove :ge result zero-tn) + (emit-label done))) + (t + (let ((done (gen-label))) + (inst cmp amount) + (inst b :ge done) + ;; The result-type assures us that this shift will not + ;; overflow. + (inst slln result number amount) + (inst neg ndesc amount) + (inst cmp ndesc 32) + (inst b :lt done) + (inst srln result number ndesc) + ;; Right shift of 32 or more is the same as zero for unsigned + ;; 32-bit numbers. + (move result zero-tn) + + (emit-label done))))) + + (immediate + (let ((amount (tn-value amount))) + (cond ((< amount -31) + (move result zero-tn)) + ((< amount 0) + (inst srln result number (- amount))) + ((> amount 0) + (inst slln result number amount)) + (t + ;; amount = 0. Shouldn't happen because of a + ;; deftransform, but it's easy. + (move result number)))))))) + +(define-vop (fast-ash-c/unsigned=>unsigned) + (:note _N"inline constant ASH") + (:args (number :scs (unsigned-reg))) + (:info count) + (:arg-types unsigned-num (:constant integer)) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate ash) + (:policy :fast-safe) + (:generator 4 + (cond + ((< count -31) (move result zero-tn)) + ((< count 0) (inst srl result number (min (- count) 31))) + ((> count 0) (inst sll result number (min count 31))) + (t (error (intl:gettext "identity ASH not transformed away")))))) + +;; Some special cases where we know we want a left shift. Just do the +;; shift, instead of checking for the sign of the shift. +(macrolet + ((frob (name sc-type type result-type cost) + `(define-vop (,name) + (:note _N"inline ASH") + (:translate ash) + (:args (number :scs (,sc-type)) + (amount :scs (signed-reg unsigned-reg immediate))) + (:arg-types ,type positive-fixnum) + (:results (result :scs (,result-type))) + (:result-types ,type) + (:policy :fast-safe) + (:generator ,cost + ;; The result-type assures us that this shift will not + ;; overflow. And for fixnum's, the zero bits that get + ;; shifted in are just fine for the fixnum tag. + (sc-case amount + ((signed-reg unsigned-reg) + (inst slln result number amount)) + (immediate + (let ((amount (tn-value amount))) + (assert (>= amount 0)) + (inst slln result number amount)))))))) + (frob fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3) + (frob fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2) + (frob fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3)) + +;; Constant left shift +(macrolet + ((frob (name sc-type type result-type cost) + `(define-vop (,name) + (:note _N"inline ASH") + (:translate ash) + (:args (number :scs (,sc-type))) + (:info amount) + (:arg-types ,type + (:constant (integer 0 31))) + (:results (result :scs (,result-type))) + (:result-types ,type) + (:policy :fast-safe) + (:generator ,cost + ;; The result-type assures us that this shift will not + ;; overflow. And for fixnum's, the zero bits that get + ;; shifted in are just fine for the fixnum tag. + (if (zerop amount) + (move result number) + (inst slln result number amount)))))) + (frob fast-ash-left-c/signed=>signed signed-reg signed-num signed-reg 3) + (frob fast-ash-left-c/fixnum=>fixnum any-reg tagged-num any-reg 2) + (frob fast-ash-left-c/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3)) + +;;#+sparc-v9 +#+nil +(define-vop (fast-ash-left/signed64=>signed64) + (:note _N"inline ASH") + (:translate ash) + (:args (number :scs (signed64-reg)) + (amount :scs (signed-reg unsigned-reg immediate))) + (:arg-types signed64-num positive-fixnum) + (:results (result :scs (signed64-reg))) + (:result-types ,type) + (:policy :fast-safe) + (:generator ,cost + ;; The result-type assures us that this shift will not + ;; overflow. And for fixnum's, the zero bits that get shifted in + ;; are just fine for the fixnum tag. + (sc-case amount + ((signed-reg unsigned-reg) + (inst sllx result number amount)) + (immediate + (let ((amount (tn-value amount))) + (assert (>= amount 0)) + (inst sllx result number amount)))))) + +#-(and sparc-v9 sparc-v8plus) +(defknown ash-right-signed ((signed-byte #.vm:word-bits) + (and fixnum unsigned-byte)) + (signed-byte #.vm:word-bits) + (movable foldable flushable)) + +#-(and sparc-v9 sparc-v8plus) +(defknown ash-right-unsigned ((unsigned-byte #.vm:word-bits) + (and fixnum unsigned-byte)) + (unsigned-byte #.vm:word-bits) + (movable foldable flushable)) + +#+(and sparc-v9 sparc-v8plus) +(defknown ash-right-signed ((signed-byte #.(* 2 vm:word-bits)) + (and fixnum unsigned-byte)) + (signed-byte #.(* 2 vm:word-bits)) + (movable foldable flushable)) + +#+(and sparc-v9 sparc-v8plus) +(defknown ash-right-unsigned ((unsigned-byte #.(* 2 vm:word-bits)) + (and fixnum unsigned-byte)) + (unsigned-byte #.(* 2 vm:word-bits)) + (movable foldable flushable)) + + + +;; Some special cases where we want a right shift. Just do the shift. +;; (Needs appropriate deftransforms to call these, though.) + +(macrolet + ((frob (trans name sc-type type shift-inst cost) + `(define-vop (,name) + (:note _N"inline right ASH") + (:translate ,trans) + (:args (number :scs (,sc-type)) + (amount :scs (signed-reg unsigned-reg immediate))) + (:arg-types ,type positive-fixnum) + (:results (result :scs (,sc-type))) + (:result-types ,type) + (:policy :fast-safe) + (:generator ,cost + (sc-case amount + ((signed-reg unsigned-reg) + (inst ,shift-inst result number amount)) + (immediate + (let ((amt (tn-value amount))) + (inst ,shift-inst result number amt)))))))) + (frob ash-right-signed fast-ash-right/signed=>signed + signed-reg signed-num sra 3) + (frob ash-right-unsigned fast-ash-right/unsigned=>unsigned + unsigned-reg unsigned-num srl 3) + #+(and sparc-v9 sparc-v8plus) + (frob ash-right-signed fast-ash-right/signed64=>signed64 + signed64-reg signed64-num srax 3) + #+(and sparc-v9 sparc-v8plus) + (frob ash-right-unsigned fast-ash-right/unsigned64=>unsigned64 + unsigned64-reg unsigned64-num srlx 3) + ) + +;; Constant right shift. +(macrolet + ((frob (trans name sc-type type shift-inst cost max-shift) + `(define-vop (,name) + (:note _N"inline right ASH") + (:translate ,trans) + (:args (number :target result :scs (,sc-type))) + (:info amount) + (:arg-types ,type + (:constant (integer 0 ,max-shift))) + (:results (result :scs (,sc-type))) + (:result-types ,type) + (:policy :fast-safe) + (:generator ,cost + (if (zerop amount) + (move result number) + (inst ,shift-inst result number amount)))))) + (frob ash-right-signed fast-ash-right-c/signed=>signed + signed-reg signed-num sra 1 31) + (frob ash-right-unsigned fast-ash-right-c/unsigned=>unsigned + unsigned-reg unsigned-num srl 1 31) + #+(and sparc-v9 sparc-v8plus) + (frob ash-right-signed fast-ash-right-c/signed64=>signed64 + signed64-reg signed64-num srax 1 63) + #+(and sparc-v9 sparc-v8plus) + (frob ash-right-unsigned fast-ash-right-c/unsigned64=>unsigned64 + unsigned64-reg unsigned64-num srlx 1 63) + ) + +#+nil +(define-vop (fash-ash-right-c/signed=>signed fast-signed-binop-c) + (:args (x :target r :scs (signed-reg zero))) + (:arg-types signed-num + (:constant (integer 0 31))) + (:results (r :scs (signed-reg))) + (:result-types signed-num) + (:translate ash-right-signed) + (:note _N"inline (signed-byte 32) arithmetic") + (:generator 1 + (if (zerop y) + (move r x) + (inst srln r x y)))) + + +(define-vop (fast-ash-right/fixnum=>fixnum) + (:note _N"inline right ASH") + (:translate ash-right-signed) + (:args (number :scs (any-reg)) + (amount :scs (signed-reg unsigned-reg immediate))) + (:arg-types tagged-num positive-fixnum) + (:results (result :scs (any-reg))) + (:result-types tagged-num) + (:temporary (:sc non-descriptor-reg :target result) temp) + (:policy :fast-safe) + (:generator 2 + ;; Shift the fixnum right by the desired amount. Then zap out the + ;; 2 LSBs to make it a fixnum again. (Those bits are junk.) + (sc-case amount + ((signed-reg unsigned-reg) + (inst sran temp number amount)) + (immediate + (inst sran temp number (tn-value amount)))) + (inst andn result temp fixnum-tag-mask))) + + + + +(define-vop (signed-byte-32-len) + (:translate integer-length) + (:note _N"inline (signed-byte 32) integer-length") + (:policy :fast-safe) + (:args (arg :scs (signed-reg) :target shift)) + (:arg-types signed-num) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift) + (:generator 30 + (let ((loop (gen-label)) + (test (gen-label))) + (inst addcc shift zero-tn arg) + (inst b :ge test) + (move res zero-tn) + (inst b test) + (inst not shift) + + (emit-label loop) + (inst add res (fixnumize 1)) + + (emit-label test) + (inst cmp shift) + (inst b :ne loop) + (inst srln shift 1)))) + +(define-vop (unsigned-byte-32-len) + (:translate integer-length) + (:note _N"inline (unsigned-byte 32) integer-length") + (:policy :fast-safe) + (:args (arg :scs (unsigned-reg) :target shift)) + (:arg-types unsigned-num) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift) + (:generator 30 + (let ((loop (gen-label)) + (test (gen-label))) + (move shift arg) + (inst b test) + (move res zero-tn) + + (emit-label loop) + (inst add res (fixnumize 1)) + + (emit-label test) + (inst cmp shift) + (inst b :ne loop) + (inst srln shift 1)))) + + +(define-vop (unsigned-byte-32-count) + (:translate logcount) + (:note _N"inline (unsigned-byte 32) logcount") + (:policy :fast-safe) + (:args (arg :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) mask temp) + (:generator 35 + (move res arg) + + (dolist (stuff '((1 #x55555555) (2 #x33333333) (4 #x0f0f0f0f) + (8 #x00ff00ff) (16 #x0000ffff))) + (destructuring-bind (shift bit-mask) + stuff + ;; Set mask + (inst li mask bit-mask) + + (inst and temp res mask) + (inst srln res shift) + (inst and res mask) + (inst add res temp))))) + + +;;; Multiply and Divide. + +(define-vop (fast-v8-*/fixnum=>fixnum fast-fixnum-binop) + (:temporary (:scs (non-descriptor-reg)) temp) + (:translate *) + (:guard (or (backend-featurep :sparc-v8) + (and (backend-featurep :sparc-v9) + (not (backend-featurep :sparc-64))))) + (:generator 2 + ;; The cost here should be less than the cost for + ;; */signed=>signed. Why? A fixnum product using signed=>signed + ;; has to convert both args to signed-nums. But using this, we + ;; don't have to and that saves an instruction. + (inst sran temp y fixnum-tag-bits) + (inst smul r x temp))) + +;; Multiplication by a constant. +(define-vop (fast-v8-*-c/unsigned=>unsigned fast-unsigned-binop-c) + (:translate *) + (:guard (or (backend-featurep :sparc-v8) + (and (backend-featurep :sparc-v9) + (not (backend-featurep :sparc-64))))) + (:generator 2 + (inst umul r x y))) + +(define-vop (fast-v8-*-c/signed=>signed fast-signed-binop-c) + (:translate *) + (:guard (or (backend-featurep :sparc-v8) + (and (backend-featurep :sparc-v9) + (not (backend-featurep :sparc-64))))) + (:generator 2 + (inst smul r x y))) + +(define-vop (fast-v8-*-c/fixnum=>fixnum fast-safe-arith-op) + (:args (x :target r :scs (any-reg zero))) + (:info y) + (:arg-types tagged-num + (:constant (and (signed-byte 13) (not (integer 0 0))))) + (:results (r :scs (any-reg))) + (:result-types tagged-num) + (:note _N"inline fixnum arithmetic") + (:translate *) + (:guard (or (backend-featurep :sparc-v8) + (and (backend-featurep :sparc-v9) + (not (backend-featurep :sparc-64))))) + (:generator 1 + (inst smul r x y))) + + +(define-vop (fast-v8-*/signed=>signed fast-signed-binop) + (:translate *) + (:guard (or (backend-featurep :sparc-v8) + (and (backend-featurep :sparc-v9) + (not (backend-featurep :sparc-64))))) + (:generator 3 + (inst smul r x y))) + +(define-vop (fast-v8-*/unsigned=>unsigned fast-unsigned-binop) + (:translate *) + (:guard (or (backend-featurep :sparc-v8) + (and (backend-featurep :sparc-v9) + (not (backend-featurep :sparc-64))))) + (:generator 3 + (inst umul r x y))) + +;; The smul and umul instructions are deprecated on the Sparc V9. Use +;; mulx instead. +(define-vop (fast-v9-*/fixnum=>fixnum fast-fixnum-binop) + (:temporary (:scs (non-descriptor-reg)) temp) + (:translate *) + (:guard (backend-featurep :sparc-64)) + (:generator 4 + (inst sran temp y fixnum-tag-bits) + (inst mulx r x temp))) + +(define-vop (fast-v9-*/signed=>signed fast-signed-binop) + (:translate *) + (:guard (backend-featurep :sparc-64)) + (:generator 3 + (inst mulx r x y))) + +(define-vop (fast-v9-*/unsigned=>unsigned fast-unsigned-binop) + (:translate *) + (:guard (backend-featurep :sparc-64)) + (:generator 3 + (inst mulx r x y))) + + +;;;; Binary conditional VOPs: + +(define-vop (fast-conditional) + (:conditional) + (:info target not-p) + (:effects) + (:affected) + (:policy :fast-safe)) + +(deftype integer-with-a-bite-out (s bite) + (cond ((eq s '*) 'integer) + ((and (integerp s) (> s 1)) + (let ((bound (ash 1 (1- s)))) + `(integer ,(- bound) ,(- bound bite 1)))) + (t + (error (intl:gettext "Bad size specified for SIGNED-BYTE type specifier: ~S.") s)))) + +(define-vop (fast-conditional/fixnum fast-conditional) + (:args (x :scs (any-reg zero)) + (y :scs (any-reg zero))) + (:arg-types tagged-num tagged-num) + (:note _N"inline fixnum comparison")) + +(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg zero))) + (:arg-types tagged-num (:constant (signed-byte #.(- 13 vm:fixnum-tag-bits)))) + (:info target not-p y)) + +(define-vop (fast-conditional/signed fast-conditional) + (:args (x :scs (signed-reg zero)) + (y :scs (signed-reg zero))) + (:arg-types signed-num signed-num) + (:note _N"inline (signed-byte 32) comparison")) + +(define-vop (fast-conditional-c/signed fast-conditional/signed) + (:args (x :scs (signed-reg zero))) + (:arg-types signed-num (:constant (signed-byte 13))) + (:info target not-p y)) + +(define-vop (fast-conditional/unsigned fast-conditional) + (:args (x :scs (unsigned-reg zero)) + (y :scs (unsigned-reg zero))) + (:arg-types unsigned-num unsigned-num) + (:note _N"inline (unsigned-byte 32) comparison")) + +(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) + (:args (x :scs (unsigned-reg zero))) + (:arg-types unsigned-num (:constant (unsigned-byte 12))) + (:info target not-p y)) + + +(defmacro define-conditional-vop (tran cond unsigned not-cond not-unsigned) + `(progn + ,@(mapcar #'(lambda (suffix cost signed) + (unless (and (member suffix '(/fixnum -c/fixnum)) + (eq tran 'eql)) + `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" + tran suffix)) + ,(intern + (format nil "~:@(FAST-CONDITIONAL~A~)" + suffix))) + (:translate ,tran) + (:generator ,cost + (inst cmp x + ,(if (eq suffix '-c/fixnum) '(fixnumize y) 'y)) + (inst b (if not-p + ,(if signed not-cond not-unsigned) + ,(if signed cond unsigned)) + target) + (inst nop))))) + '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) + '(4 3 6 5 6 5) + '(t t t t nil nil)))) + +(define-conditional-vop < :lt :ltu :ge :geu) + +(define-conditional-vop > :gt :gtu :le :leu) + +(define-conditional-vop eql :eq :eq :ne :ne) + +;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a +;;; known fixnum. + +;;; These versions specify a fixnum restriction on their first arg. We have +;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on +;;; the first arg and a higher cost. The reason for doing this is to prevent +;;; fixnum specific operations from being used on word integers, spuriously +;;; consing the argument. +;;; + +(define-vop (fast-eql/fixnum fast-conditional) + (:args (x :scs (any-reg descriptor-reg zero)) + (y :scs (any-reg zero))) + (:arg-types tagged-num tagged-num) + (:note _N"inline fixnum comparison") + (:translate eql) + (:generator 4 + (inst cmp x y) + (inst b (if not-p :ne :eq) target) + (inst nop))) +;;; +(define-vop (generic-eql/fixnum fast-eql/fixnum) + (:arg-types * tagged-num) + (:variant-cost 7)) + +(define-vop (fast-eql-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg descriptor-reg zero))) + ;; This is a signed-byte 11 because after fixnum shifting, we get a + ;; 13-bit number, and that's the largest immediate allowed. + (:arg-types tagged-num (:constant (signed-byte #.(- 13 vm:fixnum-tag-bits)))) + (:info target not-p y) + (:translate eql) + (:generator 2 + (inst cmp x (fixnumize y)) + (inst b (if not-p :ne :eq) target) + (inst nop))) +;;; +(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) + ;; This is a signed-byte 11 because after fixnum shifting, we get a + ;; 13-bit number, and that's the largest immediate allowed. + (:arg-types * (:constant (signed-byte #.(- 13 vm:fixnum-tag-bits)))) + (:variant-cost 6)) + + +;;;; 32-bit logical operations + +(define-vop (merge-bits) + (:translate merge-bits) + (:args (shift :scs (signed-reg unsigned-reg)) + (prev :scs (unsigned-reg)) + (next :scs (unsigned-reg))) + (:arg-types tagged-num unsigned-num unsigned-num) + (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) + (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 4 + (let ((done (gen-label))) + (inst cmp shift) + (inst b :eq done) + (inst srln res next shift) + (inst sub temp zero-tn shift) + (inst slln temp prev temp) + (inst or res temp) + (emit-label done) + (move result res)))) + + +(define-vop (32bit-logical) + (:args (x :scs (unsigned-reg zero)) + (y :scs (unsigned-reg zero))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:policy :fast-safe)) + +(define-vop (32bit-logical-not 32bit-logical) + (:translate 32bit-logical-not) + (:args (x :scs (unsigned-reg zero))) + (:arg-types unsigned-num) + (:generator 1 + (inst not r x))) + +(define-vop (32bit-logical-and 32bit-logical) + (:translate 32bit-logical-and) + (:generator 1 + (inst and r x y))) + +(deftransform 32bit-logical-nand ((x y) (* *)) + '(32bit-logical-not (32bit-logical-and x y))) + +(define-vop (32bit-logical-or 32bit-logical) + (:translate 32bit-logical-or) + (:generator 1 + (inst or r x y))) + +(deftransform 32bit-logical-nor ((x y) (* *)) + '(32bit-logical-not (32bit-logical-or x y))) + +(define-vop (32bit-logical-xor 32bit-logical) + (:translate 32bit-logical-xor) + (:generator 1 + (inst xor r x y))) + +(define-vop (32bit-logical-eqv 32bit-logical) + (:translate 32bit-logical-eqv) + (:generator 1 + (inst xnor r x y))) + +(define-vop (32bit-logical-orc2 32bit-logical) + (:translate 32bit-logical-orc2) + (:generator 1 + (inst orn r x y))) + +(deftransform 32bit-logical-orc1 ((x y) (* *)) + '(32bit-logical-orc2 y x)) + +(define-vop (32bit-logical-andc2 32bit-logical) + (:translate 32bit-logical-andc2) + (:generator 1 + (inst andn r x y))) + +(deftransform 32bit-logical-andc1 ((x y) (* *)) + '(32bit-logical-andc2 y x)) + + +(define-vop (shift-towards-someplace) + (:policy :fast-safe) + (:args (num :scs (unsigned-reg)) + (amount :scs (signed-reg))) + (:arg-types unsigned-num tagged-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num)) + +(define-vop (shift-towards-start shift-towards-someplace) + (:translate shift-towards-start) + (:note _N"shift-towards-start") + (:generator 1 + (inst slln r num amount))) + +(define-vop (shift-towards-end shift-towards-someplace) + (:translate shift-towards-end) + (:note _N"shift-towards-end") + (:generator 1 + (inst srln r num amount))) + + + + +;;;; Bignum stuff. + +(define-vop (bignum-length get-header-data) + (:translate bignum::%bignum-length) + (:policy :fast-safe)) + +(define-vop (bignum-set-length set-header-data) + (:translate bignum::%bignum-set-length) + (:policy :fast-safe)) + +(define-vop (bignum-ref word-index-ref) + (:variant vm:bignum-digits-offset vm:other-pointer-type) + (:translate bignum::%bignum-ref) + (:results (value :scs (unsigned-reg))) + (:result-types unsigned-num)) + +(define-vop (bignum-set word-index-set) + (:variant vm:bignum-digits-offset vm:other-pointer-type) + (:translate bignum::%bignum-set) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate zero)) + (value :scs (unsigned-reg))) + (:arg-types t positive-fixnum unsigned-num) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num)) + +(define-vop (digit-0-or-plus) + (:translate bignum::%digit-0-or-plusp) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (result :scs (descriptor-reg))) + (:guard (not (backend-featurep :sparc-v9))) + (:generator 3 + (let ((done (gen-label))) + (inst cmp digit) + (inst b :lt done) + (move result null-tn) + (load-symbol result t) + (emit-label done)))) + +(define-vop (v9-digit-0-or-plus-cmove) + (:translate bignum::%digit-0-or-plusp) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (result :scs (descriptor-reg))) + (:guard (backend-featurep :sparc-v9)) + (:generator 3 + (inst cmp digit) + (load-symbol result t) + (inst cmove :lt result null-tn))) + +;; This doesn't work? +#+nil +(define-vop (v9-digit-0-or-plus-movr) + (:translate bignum::%digit-0-or-plusp) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (descriptor-reg)) temp) + (:guard (backend-featurep :sparc-v9)) + (:generator 2 + (load-symbol temp t) + (inst movr result null-tn digit :lz) + (inst movr result temp digit :gez))) + + +(define-vop (add-w/carry) + (:translate bignum::%add-with-carry) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg)) + (b :scs (unsigned-reg)) + (c :scs (any-reg))) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg)) + (carry :scs (unsigned-reg))) + (:result-types unsigned-num positive-fixnum) + (:generator 3 + (inst addcc zero-tn c -1) + (inst addxcc result a b) + (inst addx carry zero-tn zero-tn))) + +(define-vop (sub-w/borrow) + (:translate bignum::%subtract-with-borrow) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg)) + (b :scs (unsigned-reg)) + (c :scs (any-reg))) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg)) + (borrow :scs (unsigned-reg))) + (:result-types unsigned-num positive-fixnum) + (:generator 4 + (inst subcc zero-tn c 1) + (inst subxcc result a b) + (inst addx borrow zero-tn zero-tn) + (inst xor borrow 1))) + +;;; EMIT-MULTIPLY -- This is used both for bignum stuff and in assembly +;;; routines. +;;; +(defun emit-multiply (multiplier multiplicand result-high result-low) + "Emit code to multiply MULTIPLIER with MULTIPLICAND, putting the result + in RESULT-HIGH and RESULT-LOW. KIND is either :signed or :unsigned. + Note: the lifetimes of MULTIPLICAND and RESULT-HIGH overlap." + (declare (type tn multiplier result-high result-low) + (type (or tn (signed-byte 13)) multiplicand)) + ;; It seems that emit-multiply is only used to do an unsigned + ;; multiply, so the code only does an unsigned multiply. + (cond ((backend-featurep :sparc-64) + ;; Take advantage of V9's 64-bit multiplier. + ;; + ;; Make sure the multiplier and multiplicand are really + ;; unsigned 64-bit numbers. + (inst clruw multiplier) + (inst clruw multiplicand) + + ;; Multiply the two numbers and put the result in + ;; result-high. Copy the low 32-bits to result-low. Then + ;; shift result-high so the high 32-bits end up in the low + ;; 32-bits. + (inst mulx result-high multiplier multiplicand) + (inst move result-low result-high) + (inst srax result-high 32)) + ((or (backend-featurep :sparc-v8) + (backend-featurep :sparc-v9)) + ;; V8 has a multiply instruction. This should also work for + ;; the V9, but umul and the Y register is deprecated on the + ;; V9. + (inst umul result-low multiplier multiplicand) + (inst rdy result-high)) + (t + (let ((label (gen-label))) + (inst wry multiplier) + (inst andcc result-high zero-tn) + ;; Note: we can't use the Y register until three insts + ;; after it's written. + (inst nop) + (inst nop) + (dotimes (i 32) + (inst mulscc result-high multiplicand)) + (inst mulscc result-high zero-tn) + (inst cmp multiplicand) + (inst b :ge label) + (inst nop) + (inst add result-high multiplier) + (emit-label label) + (inst rdy result-low))))) + +(define-vop (bignum-mult-and-add-3-arg) + (:translate bignum::%multiply-and-add) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg) :to (:eval 1)) + (y :scs (unsigned-reg) :to (:eval 1)) + (carry-in :scs (unsigned-reg) :to (:eval 2))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:results (hi :scs (unsigned-reg) :from (:eval 0)) + (lo :scs (unsigned-reg) :from (:eval 1))) + (:result-types unsigned-num unsigned-num) + (:generator 40 + (emit-multiply x y hi lo) + (inst addcc lo carry-in) + (inst addx hi zero-tn))) + +(define-vop (bignum-mult-and-add-4-arg) + (:translate bignum::%multiply-and-add) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg) :to (:eval 1)) + (y :scs (unsigned-reg) :to (:eval 1)) + (prev :scs (unsigned-reg) :to (:eval 2)) + (carry-in :scs (unsigned-reg) :to (:eval 2))) + (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num) + (:results (hi :scs (unsigned-reg) :from (:eval 0)) + (lo :scs (unsigned-reg) :from (:eval 1))) + (:result-types unsigned-num unsigned-num) + (:generator 40 + (emit-multiply x y hi lo) + (inst addcc lo carry-in) + (inst addx hi zero-tn) + (inst addcc lo prev) + (inst addx hi zero-tn))) + +(define-vop (bignum-mult) + (:translate bignum::%multiply) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg) :to (:result 1)) + (y :scs (unsigned-reg) :to (:result 1))) + (:arg-types unsigned-num unsigned-num) + (:results (hi :scs (unsigned-reg)) + (lo :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 40 + (emit-multiply x y hi lo))) + +(define-vop (bignum-lognot) + (:translate bignum::%lognot) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (inst not r x))) + +(define-vop (fixnum-to-digit) + (:translate bignum::%fixnum-to-digit) + (:policy :fast-safe) + (:args (fixnum :scs (any-reg))) + (:arg-types tagged-num) + (:results (digit :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (inst sran digit fixnum fixnum-tag-bits))) + +(define-vop (bignum-floor) + (:translate bignum::%floor) + (:policy :fast-safe) + (:args (div-high :scs (unsigned-reg) :target rem) + (div-low :scs (unsigned-reg) :target quo) + (divisor :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:results (quo :scs (unsigned-reg) :from (:argument 1)) + (rem :scs (unsigned-reg) :from (:argument 0))) + (:result-types unsigned-num unsigned-num) + (:guard (not (or (backend-featurep :sparc-v8) + (backend-featurep :sparc-v9)))) + (:generator 300 + (move rem div-high) + (move quo div-low) + (dotimes (i 33) + (let ((label (gen-label))) + (inst cmp rem divisor) + (inst b :ltu label) + (inst addxcc quo quo) + (inst sub rem divisor) + (emit-label label) + (unless (= i 32) + (inst addx rem rem)))) + (inst not quo))) + +(define-vop (bignum-floor-v8) + (:translate bignum::%floor) + (:policy :fast-safe) + (:args (div-high :scs (unsigned-reg) :target rem) + (div-low :scs (unsigned-reg) :target quo) + (divisor :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:results (quo :scs (unsigned-reg) :from (:argument 1)) + (rem :scs (unsigned-reg) :from (:argument 0))) + (:result-types unsigned-num unsigned-num) + (:temporary (:scs (unsigned-reg) :target quo) q) + ;; This vop is for a v8 or v9, provided we're also not using + ;; sparc-64, for which there a special sparc-64 vop. + (:guard (or (backend-featurep :sparc-v8) + (and (backend-featurep :sparc-v9) + (not (backend-featurep :sparc-64))))) + (:generator 15 + (inst wry div-high) + (inst nop) + (inst nop) + (inst nop) + ;; Compute the quotient [Y, div-low] / divisor + (inst udiv q div-low divisor) + ;; Compute the remainder. The high part of the result is in the Y + ;; register. + (inst umul rem q divisor) + (inst sub rem div-low rem) + (unless (location= quo q) + (move quo q)))) + +(define-vop (bignum-floor-v9) + (:translate bignum::%floor) + (:policy :fast-safe) + (:args (div-high :scs (unsigned-reg)) + (div-low :scs (unsigned-reg)) + (divisor :scs (unsigned-reg) :to (:result 1))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :from (:argument 0)) dividend) + (:results (quo :scs (unsigned-reg)) + (rem :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:guard (backend-featurep :sparc-64)) + (:generator 5 + ;; Set dividend to be div-high and div-low + (inst sllx dividend div-high 32) + (inst add dividend div-low) + ;; Compute quotient + (inst udivx quo dividend divisor) + ;; Compute the remainder + (inst mulx rem quo divisor) + (inst sub rem dividend rem))) + +(define-vop (signify-digit) + (:translate bignum::%fixnum-digit-with-correct-sign) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg) :target res)) + (:arg-types unsigned-num) + (:results (res :scs (any-reg signed-reg))) + (:result-types signed-num) + (:generator 1 + (sc-case res + (any-reg + (inst slln res digit fixnum-tag-bits)) + (signed-reg + (move res digit))))) + + +(define-vop (digit-ashr) + (:translate bignum::%ashr) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg)) + (count :scs (signed-reg unsigned-reg immediate))) + (:arg-types unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (sc-case count + ((signed-reg unsigned-reg) + (inst sran result digit count)) + (immediate + (inst sran result digit (tn-value count)))))) + +(define-vop (digit-lshr digit-ashr) + (:translate bignum::%digit-logical-shift-right) + (:generator 1 + (sc-case count + ((signed-reg unsigned-reg) + (inst srln result digit count)) + (immediate + (inst srln result digit (tn-value count)))))) + +(define-vop (digit-ashl digit-ashr) + (:translate bignum::%ashl) + (:generator 1 + (sc-case count + ((signed-reg unsigned-reg) + (inst slln result digit count)) + (immediate + (inst slln result digit (tn-value count)))))) + + +;;;; Static functions. + +(define-static-function two-arg-gcd (x y) :translate gcd) +(define-static-function two-arg-lcm (x y) :translate lcm) + +(define-static-function two-arg-+ (x y) :translate +) +(define-static-function two-arg-- (x y) :translate -) +(define-static-function two-arg-* (x y) :translate *) +(define-static-function two-arg-/ (x y) :translate /) + +(define-static-function two-arg-< (x y) :translate <) +(define-static-function two-arg-<= (x y) :translate <=) +(define-static-function two-arg-> (x y) :translate >) +(define-static-function two-arg->= (x y) :translate >=) +(define-static-function two-arg-= (x y) :translate =) +(define-static-function two-arg-/= (x y) :translate /=) + +(define-static-function %negate (x) :translate %negate) + +(define-static-function two-arg-and (x y) :translate logand) +(define-static-function two-arg-ior (x y) :translate logior) +(define-static-function two-arg-xor (x y) :translate logxor) + + +;; Truncation by a constant can be done by multiplication with the +;; appropriate constant. +;; +;; See generic/vm-tran.lisp for the algorithm. + +(define-vop (signed-truncate-by-mult fast-signed-binop) + (:translate truncate) + (:args (x :scs (signed-reg))) + (:info y) + (:arg-types signed-num (:constant (integer 2 #.(1- (ash 1 vm:word-bits))))) + (:results (quo :scs (signed-reg)) + (rem :scs (signed-reg))) + (:result-types signed-num signed-num) + (:note _N"inline (signed-byte 32) arithmetic") + (:guard (or (backend-featurep :sparc-v8) + (and (backend-featurep :sparc-v9) + (not (backend-featurep :sparc-64))))) + (:temporary (:scs (signed-reg)) q) + (:temporary (:scs (signed-reg)) r) + (:temporary (:scs (signed-reg)) temp) + (:generator 6 + (multiple-value-bind (recip shift) + (c::find-signed-reciprocal y vm:word-bits) + ;; Compute q = floor(M*n/2^32). That is, the high half of the + ;; product. + (inst li temp recip) + (inst smul r x temp) + (inst rdy q) + ;; Adjust if the M is negative. + (when (minusp recip) + (inst add q x)) + ;; Shift quotient as needed. + (unless (zerop shift) + (inst sran q shift)) + ;; Add one to quotient if X is negative. This is done by right + ;; shifting X to give either -1 or 0. Then subtract this from + ;; the quotient. (NOTE: in the book, the sample code has this + ;; wrong and ADDS instead of SUBTRACTS.) + (inst sran temp x 31) + (inst sub q q temp) + ;; Now compute remainder via r = x - q*d + (cond ((typep y '(signed-byte 13)) + (inst smul r q y)) + (t + (inst li temp y) + (inst smul r q temp))) + (inst sub rem x r) + (unless (location= quo q) + (move quo q))))) + +(define-vop (unsigned-truncate-by-mult fast-signed-binop) + (:translate truncate) + (:args (x :scs (unsigned-reg))) + (:info y) + (:arg-types unsigned-num (:constant (integer 2 #.(1- (ash 1 vm:word-bits))))) + (:results (quo :scs (unsigned-reg)) + (rem :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:note _N"inline (unsigned-byte 32) arithmetic") + (:guard (or (backend-featurep :sparc-v8) + (and (backend-featurep :sparc-v9) + (not (backend-featurep :sparc-64))))) + (:temporary (:scs (unsigned-reg)) q) + (:temporary (:scs (unsigned-reg)) r) + (:temporary (:scs (unsigned-reg)) temp) + (:generator 6 + (multiple-value-bind (recip shift overflowp) + (c::find-unsigned-reciprocal y vm:word-bits) + ;; q = floor(M*x/2^32) + (inst li temp recip) + (inst umul r x temp) + (inst rdy q) + (cond (overflowp + ;; The complicated case. Sparc does not have a + ;; shift-with-carry instruction, so we use idea above. + ;; (But we could also do this by putting the carry flag + ;; into a register, shifting it left some amount, + ;; shifting the quotient right, and adding the two + ;; results together.) + (inst sub temp x q) + (inst srln temp 1) + (inst add temp q) + (inst srln q temp (1- shift))) + (t + ;; The easy case + (unless (zerop shift) + (inst srln q shift)))) + ;; Compute the remainder + (cond ((typep y '(signed-byte 13)) + (inst umul r q y)) + (t + (inst li temp y) + (inst umul r q temp))) + (inst sub rem x r) + (unless (location= quo q) + (move quo q))))) + +;; Need these so constant folding works with the deftransform. + +#-(and sparc-v9 sparc-v8plus) +(progn +(defun ash-right-signed (num shift) + (declare (type (signed-byte #.vm:word-bits) num) + (type (integer 0 #.(1- vm:word-bits)) shift)) + (ash num (- shift))) + +(defun ash-right-unsigned (num shift) + (declare (type (unsigned-byte #.vm:word-bits) num) + (type (integer 0 #.(1- vm:word-bits)) shift)) + (ash num (- shift))) +) + +#+(and sparc-v9 sparc-v8plus) +(progn +(defun ash-right-signed (num shift) + (declare (type (signed-byte #.(* 2 vm:word-bits)) num) + (type (integer 0 #.(1- (* 2 vm:word-bits))) shift)) + (ash num (- shift))) + +(defun ash-right-unsigned (num shift) + (declare (type (unsigned-byte #.(* 2 vm:word-bits)) num) + (type (integer 0 #.(1- (* 2 vm:word-bits))) shift)) + (ash num (- shift))) +) + +;; If we can prove that we have a right shift, just do the right shift +;; instead of calling the inline ASH which has to check for the +;; direction of the shift at run-time. +(in-package "C") + +#-(and sparc-v9 sparc-v8plus) +(deftransform ash ((num shift) (integer integer)) + (let ((num-type (continuation-type num)) + (shift-type (continuation-type shift))) + ;; Can only handle right shifts + (unless (csubtypep shift-type (specifier-type '(integer * 0))) + (give-up)) + + ;; If we can prove the shift is so large that all bits are shifted + ;; out, return the appropriate constant. If the shift is small + ;; enough, call the VOP. Otherwise, check for the shift size and + ;; do the appropriate thing. (Hmm, could we just leave the IF + ;; s-expr and depend on other parts of the compiler to delete the + ;; unreachable parts, if any?) + (cond ((csubtypep num-type (specifier-type '(signed-byte #.vm:word-bits))) + ;; A right shift by 31 is the same as a right shift by + ;; larger amount. We get just the sign. + (if (csubtypep shift-type (specifier-type '(integer #.(- 1 vm:word-bits) 0))) + `(sparc::ash-right-signed num (- shift)) + `(sparc::ash-right-signed num (min (- shift) #.(1- vm:word-bits))))) + ((csubtypep num-type (specifier-type '(unsigned-byte #.vm:word-bits))) + (if (csubtypep shift-type (specifier-type '(integer #.(- 1 vm:word-bits) 0))) + `(sparc::ash-right-unsigned num (- shift)) + `(if (<= shift #.(- vm:word-bits)) + 0 + (sparc::ash-right-unsigned num (- shift))))) + (t + (give-up))))) + +#+(and later sparc-v9 sparc-v8plus) +(deftransform ash ((num shift) (integer integer)) + (let ((num-type (continuation-type num)) + (shift-type (continuation-type shift))) + ;; Can only handle right shifts + (unless (csubtypep shift-type (specifier-type '(integer * 0))) + (give-up)) + + ;; If we can prove the shift is so large that all bits are shifted + ;; out, return the appropriate constant. If the shift is small + ;; enough, call the VOP. Otherwise, check for the shift size and + ;; do the appropriate thing. (Hmm, could we just leave the IF + ;; s-expr and depend on other parts of the compiler to delete the + ;; unreachable parts, if any?) + (cond ((csubtypep num-type (specifier-type '(signed-byte #.(* 2 vm:word-bits)))) + ;; A right shift by 31 is the same as a right shift by + ;; larger amount. We get just the sign. + (if (csubtypep shift-type (specifier-type '(integer #.(- 1 (* 2 vm:word-bits)) 0))) + `(sparc::ash-right-signed num (- shift)) + `(sparc::ash-right-signed num (min (- shift) #.(1- (* 2 vm:word-bits)))))) + ((csubtypep num-type (specifier-type '(unsigned-byte #.(* 2 vm:word-bits)))) + (if (csubtypep shift-type (specifier-type '(integer #.(- 1 (* 2 vm:word-bits)) 0))) + `(sparc::ash-right-unsigned num (- shift)) + `(if (<= shift #.(- vm:word-bits)) + 0 + (sparc::ash-right-unsigned num (- shift))))) + (t + (give-up))))) + + +;;; 64-bit integer operations +(in-package "SPARC") + +;; Unary operations + +#+(and sparc-v9 sparc-v8plus) +(progn + +;;; The vops for the 64-bit operations are written this way because I +;;; (RLT) can't figure out how to get representation selection to +;;; convert signed-num and unsigned-num to signed64-num when +;;; needed. (Actually, I don't even know how representation selection +;;; works.) +;;; +;;; Thus, any arg that is a 64-bit register defines the SCS to include +;;; the 64-bit reg and well as the 32-bit regs. Then the generators +;;; will have to dispatch on the sc type that is actually used. This +;;; probably generates lots of redundant moves, but we still win big +;;; by not having to do bignum arithmetic. +;;; +;;; I think the dispatch could be simplified if we just sign or zero +;;; extended the 32-bit registers in place. However, we can't do that +;;; in general because not all of the 32-bit regs preserve all 64-bits +;;; on task switches. If we constrain the 32-bit regs to be the same +;;; 6 regs used for the 64-bit regs, we run out of regs when do +;;; foreign function calls because we need 6 regs for that and we +;;; don't have any more non-descriptor regs for temps. + + +(define-vop (signed64-unop fast-safe-arith-op) + (:args (x :target res :scs (signed64-reg signed-reg unsigned-reg zero))) + (:results (res :scs (signed64-reg))) + (:arg-types (:or signed64-num signed-num unsigned-num)) + (:result-types signed64-num) + (:temporary (:scs (signed64-reg)) x64) + (:note _N"inline (signed-byte 64) arithmetic")) + +(define-vop (fast-signed64-binop fast-safe-arith-op) + (:args (x :target r :scs (signed64-reg unsigned-reg signed-reg zero)) + (y :target r :scs (signed64-reg unsigned-reg signed-reg zero))) + (:arg-types (:or signed64-num signed-num unsigned-num) + (:or signed64-num signed-num unsigned-num)) + (:results (r :scs (signed64-reg))) + (:result-types signed64-num) + (:note _N"inline (signed-byte 64) arithmetic")) + +(define-vop (fast-signed64-binop-c fast-safe-arith-op) + (:args (x :target r :scs (signed64-reg unsigned-reg signed-reg zero))) + (:info y) + (:arg-types (:or signed64-num signed-num unsigned-num) + (:constant (and (signed-byte 13) (not (integer 0 0))))) + (:results (r :scs (signed64-reg))) + (:result-types signed64-num) + (:note _N"inline (signed-byte 64) arithmetic")) + +(define-vop (fast-unsigned64-binop fast-safe-arith-op) + (:args (x :target r :scs (unsigned64-reg unsigned-reg zero)) + (y :target r :scs (unsigned64-reg unsigned-reg zero))) + (:arg-types (:or unsigned64-num unsigned-num) + (:or unsigned64-num unsigned-num)) + (:results (r :scs (unsigned64-reg))) + (:result-types unsigned64-num) + (:note _N"inline (unsigned-byte 64) arithmetic")) + +(define-vop (fast-unsigned64-binop-c fast-safe-arith-op) + (:args (x :target r :scs (unsigned64-reg unsigned-reg zero))) + (:info y) + (:arg-types (:or unsigned64-num unsigned-num) + (:constant (and (signed-byte 13) (not (integer 0 0))))) + (:results (r :scs (unsigned64-reg))) + (:result-types unsigned64-num) + (:note _N"inline (unsigned-byte 64) arithmetic")) + +;; Extend the sign of Y appropriately and perform the desired +;; operation. R is where the result should go, X is the first arg, Y +;; is the second, and Y64 is a 64-bit temp reg for us to use. +(defmacro sc-case-64 (r x y y64 op) + `(if (tn-p ,y) + (sc-case ,y + ((signed64-reg unsigned64-reg) + (inst ,op ,r ,x ,y)) + (signed-reg + ;; Sign-extend Y + (inst signx ,y64 ,y) + (inst ,op ,r ,x ,y64)) + (unsigned-reg + ;; Zero-extend Y + (inst clruw ,y64 ,y) + (inst ,op ,r ,x ,y64)) + (immediate + (inst ,op ,r ,x ,y))) + (inst ,op ,r ,x ,y))) + +;; Same as above, but we only have one arg. +(defmacro sc-case-64-one-arg (r x x64 op) + `(sc-case ,x + ((signed64-reg unsigned64-reg) + (inst ,op ,r ,x)) + (signed-reg + ;; Sign-extend X + (inst signx ,x64 ,x) + (inst ,op ,r ,x64)) + (unsigned-reg + ;; Zero-extend X + (inst clruw ,x64 ,x) + (inst ,op ,r ,x64)))) + +;; Try all possible combinations of signed64-reg, signed-reg, and +;; unsigned-reg and appropriately extend the sign of the shorter +;; operand and perform the desired operation on the 64-bit operands +;; with a 64-bit result. +;; +;; FIXME: This should be more like numeric-dispatch so it can be used +;; in other places. +(defmacro sc-dispatch (r x y x64 y64 op) + `(sc-case x + ((signed64-reg unsigned64-reg) + ;; X is 64-bits + (sc-case-64 ,r ,x ,y ,y64 ,op)) + (signed-reg + ;; Sign-extend X + (inst signx ,x64 ,x) + (sc-case-64 ,r ,x64 ,y ,y64 ,op)) + (unsigned-reg + ;; Zero-extend X + (inst clruw ,x64 ,x) + (sc-case-64 ,r ,x64 ,y ,y64 ,op)))) + +;; Operations that result in 64-bit results. + +(defmacro define-binop-64 (translate op) + `(progn + (define-vop (,(symbolicate "FAST-" translate "/SIGNED64") + fast-signed64-binop) + (:translate ,translate) + (:temporary (:scs (signed64-reg)) x64 y64) + (:generator 2 + (sc-dispatch r x y x64 y64 ,op))) + (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED64") + fast-unsigned64-binop) + (:translate ,translate) + (:temporary (:scs (signed64-reg)) x64 y64) + (:generator 2 + (sc-dispatch r x y x64 y64 ,op))) + (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED64") + fast-signed64-binop-c) + (:translate ,translate) + (:temporary (:scs (signed64-reg)) x64 y64) + (:generator 2 + (sc-dispatch r x y x64 y64 ,op))) + (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED64") + fast-unsigned64-binop-c) + (:translate ,translate) + (:temporary (:scs (signed64-reg)) x64 y64) + (:generator 2 + (sc-dispatch r x y x64 y64 ,op))) + )) + +(define-binop-64 + add) +(define-binop-64 - sub) +(define-binop-64 logand and) +(define-binop-64 logandc2 andn) +(define-binop-64 logior or) +(define-binop-64 logorc2 orn) +(define-binop-64 logxor xor) +(define-binop-64 logeqv xnor) + +;; Some special cases for logand. +(define-vop (fast-logand/signed64 fast-safe-arith-op) + (:args (x :target r :scs (signed64-reg signed-reg zero)) + (y :target r :scs (signed64-reg signed-reg zero))) + (:arg-types (:or signed64-num signed-num) + (:or signed64-num signed-num)) + (:results (r :scs (signed64-reg))) + (:result-types signed64-num) + (:translate logand) + (:temporary (:scs (signed64-reg)) x64 y64) + (:generator 2 + (sc-dispatch r x y x64 y64 and))) + +(define-vop (fast-logand/u32-64=>signed fast-safe-arith-op) + (:args (x :target r :scs (unsigned-reg zero)) + (y :target r :scs (signed64-reg unsigned64-reg signed-reg zero))) + (:arg-types (:or unsigned-num) + (:or signed64-num unsigned64-num signed-num)) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate logand) + (:generator 2 + (sc-case y + ((signed64-reg unsigned64-reg) + (inst clruw r x) ; Zero-extend, just in case + (inst and r y) + (inst clruw r) ; Zero-extend, just in case + ) + (signed-reg + (inst and r x y) + )))) + + +(define-vop (fast-logand/64-u32=>signed fast-safe-arith-op) + (:args (x :target r :scs (signed64-reg unsigned64-reg signed-reg zero)) + (y :target r :scs (unsigned-reg zero))) + (:arg-types (:or signed64-num unsigned64-num signed-num) + (:or unsigned-num)) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate logand) + (:generator 2 + (sc-case x + ((signed64-reg unsigned64-reg) + (inst clruw r y) ; Zero-extend, just in case + (inst and r x y) + (inst clruw r) ; Zero-extend, just in case + ) + (signed-reg + (inst and r x y) + )))) + +(define-vop (fast-lognot/signed64 signed64-unop) + (:translate lognot) + (:generator 2 + (sc-case-64-one-arg res x x64 not))) + +(define-vop (fast-negate/signed64 signed64-unop) + (:args (x :target res :scs (signed64-reg zero))) + (:arg-types signed64-num) + (:results (res :scs (signed64-reg))) + (:result-types signed64-num) + (:translate %negate) + (:generator 1 + (inst neg res x))) + +(define-vop (fast-negate/unsigned=>signed64 fast-safe-arith-op) + (:args (x :target res :scs (unsigned-reg zero))) + (:arg-types unsigned-num) + (:results (res :scs (signed64-reg))) + (:result-types signed64-num) + (:translate %negate) + (:generator 1 + ;; Zero-extend + (inst clruw res x) + (inst neg res))) + +(define-vop (fast-negate/signed=>signed64 fast-safe-arith-op) + (:args (x :target res :scs (signed-reg zero))) + (:arg-types signed-num) + (:results (res :scs (signed64-reg))) + (:result-types signed64-num) + (:translate %negate) + (:generator 1 + ;; Sign-extend + (inst signx res x) + (inst neg res))) + +;; Signed 64x64->64 bit multiply +(define-vop (fast-*/signed64 fast-safe-arith-op) + (:args (x :target r :scs (signed64-reg unsigned64-reg unsigned-reg signed-reg zero)) + (y :target r :scs (signed64-reg unsigned64-reg unsigned-reg signed-reg zero))) + (:arg-types (:or signed64-num unsigned64-num signed-num unsigned-num) + (:or signed64-num unsigned64-num signed-num unsigned-num)) + (:results (r :scs (signed64-reg unsigned64-reg))) + (:result-types signed64-num) + (:temporary (:scs (signed64-reg)) x64 y64) + (:translate *) + (:note _N"inline (signed-byte 64) arithmetic") + (:guard (backend-featurep :sparc-v9)) + (:generator 3 + (sc-dispatch r x y x64 y64 mulx))) + +(define-vop (fast-*/unsigned64 fast-safe-arith-op) + (:args (x :target r :scs (signed64-reg unsigned64-reg unsigned-reg signed-reg zero)) + (y :target r :scs (signed64-reg unsigned64-reg unsigned-reg signed-reg zero))) + (:arg-types (:or signed64-num unsigned64-num signed-num unsigned-num) + (:or signed64-num unsigned64-num signed-num unsigned-num)) + (:results (r :scs (signed64-reg unsigned64-reg))) + (:result-types unsigned64-num) + (:temporary (:scs (signed64-reg)) x64 y64) + (:translate *) + (:note _N"inline (signed-byte 64) arithmetic") + (:guard (backend-featurep :sparc-v9)) + (:generator 3 + (sc-dispatch r x y x64 y64 mulx))) + + +;; Signed 32x32->64 multiply +(define-vop (fast-*/signed=>signed64 fast-safe-arith-op) + (:args (x :target r :scs (signed-reg unsigned-reg zero)) + (y :target r :scs (signed-reg unsigned-reg zero))) + (:arg-types (:or signed-num unsigned-num) + (:or signed-num unsigned-num)) + (:results (r :scs (signed64-reg unsigned64-reg))) + (:result-types signed64-num) + (:temporary (:scs (signed64-reg)) x64 y64) + (:translate *) + (:note _N"inline (signed-byte 64) arithmetic") + (:guard (backend-featurep :sparc-v9)) + (:generator 3 + (sc-dispatch r x y x64 y64 mulx))) + +;; Unsigned 32x32->64 multiply +(define-vop (fast-*/u32=>unsigned64 fast-safe-arith-op) + (:args (x :target r :scs (unsigned-reg zero)) + (y :target r :scs (unsigned-reg zero))) + (:arg-types (:or unsigned-num) + (:or unsigned-num)) + (:results (r :scs (signed64-reg unsigned64-reg))) + (:result-types unsigned64-num) + (:temporary (:scs (unsigned64-reg)) x64 y64) + (:translate *) + (:note _N"inline (unsigned-byte 64) arithmetic") + (:guard (backend-featurep :sparc-v9)) + (:generator 3 + (sc-dispatch r x y x64 y64 mulx))) + +(define-vop (fast-ash/signed64=>signed64) + (:note _N"inline (signed-byte 64) ASH") + (:args (number :scs (signed64-reg unsigned-reg signed-reg) :to :save) + (amount :scs (signed64-reg signed-reg unsigned-reg) :to :save)) + (:arg-types (:or signed64-num signed-num unsigned-num) + (:or signed64-num signed-num unsigned-num)) + (:results (result :scs (signed64-reg))) + (:result-types signed64-num) + (:translate ash) + (:policy :fast-safe) + (:temporary (:sc signed64-reg) ndesc) + (:temporary (:scs (signed64-reg)) num64) + (:guard (and (backend-featurep :sparc-v9) + (backend-featurep :sparc-v8plus) + (not (backend-featurep :sparc-64)))) + (:generator 5 + (sc-case number + (signed64-reg + (move num64 number)) + (signed-reg + (inst signx num64 number)) + (unsigned-reg + (inst clruw num64 number))) + (sc-case amount + (signed64-reg + (let ((done (gen-label))) + (inst cmp amount) + (inst b :ge done :pt :xcc) + ;; The result-type assures us that this shift will not + ;; overflow. + (inst sllx result num64 amount) + (inst neg ndesc amount) + ;; ndesc = max(-amount, 31) + (inst cmp ndesc 31) + (inst cmove :ge ndesc 31 :xcc) + (inst srax result num64 ndesc) + (emit-label done))) + (signed-reg + (let ((done (gen-label))) + (inst cmp amount) + (inst b :ge done :pt) + ;; The result-type assures us that this shift will not + ;; overflow. + (inst sllx result num64 amount) + (inst neg ndesc amount) + ;; ndesc = max(-amount, 31) + (inst cmp ndesc 31) + (inst cmove :ge ndesc 31) + (inst srax result num64 ndesc) + (emit-label done))) + (unsigned-reg + (inst sllx result num64 amount)) + + (immediate + (let ((amount (tn-value amount))) + (cond ((< amount -63) + (inst li result -1)) + ((< amount 0) + (inst srax result num64 (- amount))) + ((> amount 0) + (inst sllx result num64 amount)) + (t + ;; amount = 0. Shouldn't happen because of a + ;; deftransform, but it's easy. + (move result num64)))))))) + +(define-vop (fast-ash/unsigned64=>unsigned64) + (:note _N"inline (signed-byte 64) ASH") + (:args (number :scs (unsigned64-reg unsigned-reg) :to :save) + (amount :scs (signed64-reg signed-reg unsigned-reg immediate) :to :save)) + (:arg-types (:or unsigned64-num unsigned-num) + (:or signed64-num signed-num unsigned-num)) + (:results (result :scs (unsigned64-reg))) + (:result-types unsigned64-num) + (:translate ash) + (:policy :fast-safe) + (:temporary (:scs (unsigned64-reg)) ndesc num64) + (:guard (and (backend-featurep :sparc-v9) + (backend-featurep :sparc-v8plus) + (not (backend-featurep :sparc-64)))) + (:generator 5 + (sc-case number + (unsigned64-reg + (move num64 number)) + (unsigned-reg + (inst clruw num64 number))) + (sc-case amount + (signed64-reg + (let ((done (gen-label))) + (inst cmp amount) + (inst b :ge done :pt :xcc) + ;; The result-type assures us that this shift will not + ;; overflow. + (inst sllx result num64 amount) + (inst neg ndesc amount) + ;; ndesc = max(-amount, 31) + (inst cmp ndesc 31) + (inst cmove :ge ndesc 31 :xcc) + (inst srlx result num64 ndesc) + (emit-label done))) + (signed-reg + (let ((done (gen-label))) + (inst cmp amount) + (inst b :ge done :pt) + ;; The result-type assures us that this shift will not + ;; overflow. + (inst sllx result num64 amount) + (inst neg ndesc amount) + ;; ndesc = max(-amount, 31) + (inst cmp ndesc 31) + (inst cmove :ge ndesc 31) + (inst srlx result num64 ndesc) + (emit-label done))) + (unsigned-reg + (inst sllx result num64 amount)) + + (immediate + (let ((amount (tn-value amount))) + (cond ((< amount -63) + (inst li result -1)) + ((< amount 0) + (inst srlx result num64 (- amount))) + ((> amount 0) + (inst sllx result num64 amount)) + (t + ;; amount = 0. Shouldn't happen because of a + ;; deftransform, but it's easy. + (move result num64)))))))) + + + +;;; Conditional operations on 64-bit numbers + +(define-vop (fast-conditional-c/64-fixnum fast-conditional) + (:args (x :scs (signed64-reg unsigned-reg signed-reg zero))) + (:arg-types (:or signed64-num unsigned-num signed-num) + (:constant (signed-byte #.(- 13 vm:fixnum-tag-bits)))) + (:info target not-p y)) + +(define-vop (fast-conditional/signed64 fast-conditional) + (:args (x :scs (signed64-reg unsigned-reg signed-reg zero)) + (y :scs (signed64-reg unsigned-reg signed-reg zero))) + (:arg-types (:or signed64-num unsigned-num signed-num) + (:or signed64-num unsigned-num signed-num)) + (:note _N"inline (signed-byte 64) comparison")) + +(define-vop (fast-conditional-c/signed64 fast-conditional) + (:args (x :scs (signed64-reg unsigned-reg signed-reg zero))) + (:arg-types (:or signed64-num unsigned-num signed-num) + (:constant (signed-byte 13))) + (:info target not-p y) + (:note _N"inline (signed-byte 64) comparison")) + +(define-vop (fast-conditional/unsigned64 fast-conditional) + (:args (x :scs (unsigned64-reg zero)) + (y :scs (unsigned64-reg zero))) + (:arg-types (:or unsigned64-num) + (:or unsigned64-num)) + (:note _N"inline (unsigned-byte 64) comparison")) + +(define-vop (fast-conditional-c/unsigned64 fast-conditional) + (:args (x :scs (unsigned64-reg zero))) + (:arg-types (:or unsigned64-num) + (:constant (unsigned-byte 12))) + (:info target not-p y) + (:note _N"inline (signed-byte 64) comparison")) + +;; If I were smarter, This would be a macro like it is for the 32-bit +;; versions. It's easier this way to see what's happening, though. +;; +(define-vop (fast-if-</signed64 fast-conditional/signed64) + (:translate <) + (:temporary (:scs (signed64-reg)) x64 y64) + (:generator 6 + (sc-case x + (signed-reg + (inst signx x64 x)) + (unsigned-reg + (inst clruw x64 x)) + (t + (move x64 x))) + (sc-case y + (signed-reg + (inst signx y64 y)) + (unsigned-reg + (inst clruw y64 y)) + ((signed64-reg unsigned64-reg zero) + (move y64 y))) + + (inst cmp x64 y64) + (inst b (if not-p :ge :lt) + target :pt :xcc) + (inst nop))) + +(define-vop (fast-if->/signed64 fast-conditional/signed64) + (:translate >) + (:temporary (:scs (signed64-reg)) x64 y64) + (:generator 6 + (sc-case x + (signed-reg + (inst signx x64 x)) + (unsigned-reg + (inst clruw x64 x)) + (t + (move x64 x))) + (sc-case y + (signed-reg + (inst signx y64 y)) + (unsigned-reg + (inst clruw y64 y)) + ((signed64-reg unsigned64-reg zero) + (move y64 y))) + + (inst cmp x64 y64) + (inst b (if not-p :le :gt) + target :pt :xcc) + (inst nop))) + +(define-vop (fast-if-eql/signed64 fast-conditional/signed64) + (:translate eql) + (:temporary (:scs (signed64-reg)) x64 y64) + (:generator 6 + (sc-case x + (signed-reg + (inst signx x64 x)) + (unsigned-reg + (inst clruw x64 x)) + (t + (move x64 x))) + (sc-case y + (signed-reg + (inst signx y64 y)) + (unsigned-reg + (inst clruw y64 y)) + ((signed64-reg unsigned64-reg zero) + (move y64 y))) + + (inst cmp x64 y64) + (inst b (if not-p :ne :eq) + target :pt :xcc) + (inst nop))) + +(define-vop (fast-if-eql-c/signed64 fast-conditional-c/signed64) + (:translate eql) + (:temporary (:scs (signed64-reg)) x64) + (:generator 6 + (sc-case x + (signed-reg + (inst signx x64 x)) + (unsigned-reg + (inst clruw x64 x)) + (t + (move x64 x))) + (inst cmp x64 y) + (inst b (if not-p :ne :eq) + target :pt :xcc) + (inst nop))) + +(define-vop (fast-if-</unsigned64 fast-conditional/unsigned64) + (:translate <) + (:temporary (:scs (unsigned64-reg)) x64 y64) + (:generator 6 + (sc-case x + (unsigned-reg + (inst clruw x64 x)) + (t + (move x64 x))) + (sc-case y + (unsigned-reg + (inst clruw y64 y)) + ((signed64-reg unsigned64-reg zero) + (move y64 y))) + + (inst cmp x64 y64) + (inst b (if not-p :geu :ltu) + target :pt :xcc) + (inst nop))) + +(define-vop (fast-if->/unsigned64 fast-conditional/unsigned64) + (:translate >) + (:temporary (:scs (unsigned64-reg)) x64 y64) + (:generator 6 + (sc-case x + (unsigned-reg + (inst clruw x64 x)) + (t + (move x64 x))) + (sc-case y + (unsigned-reg + (inst clruw y64 y)) + ((signed64-reg unsigned64-reg zero) + (move y64 y))) + + (inst cmp x64 y64) + (inst b (if not-p :leu :gtu) + target :pt :xcc) + (inst nop))) + +(define-vop (fast-if-eql/unsigned64 fast-conditional/unsigned64) + (:translate eql) + (:temporary (:scs (unsigned64-reg)) x64 y64) + (:generator 6 + (sc-case x + (unsigned-reg + (inst clruw x64 x)) + (t + (move x64 x))) + (sc-case y + (unsigned-reg + (inst clruw y64 y)) + ((signed64-reg unsigned64-reg zero) + (move y64 y))) + + (inst cmp x64 y64) + (inst b (if not-p :ne :eq) + target :pt :xcc) + (inst nop))) + +(define-vop (fast-if-eql-c/unsigned64 fast-conditional-c/unsigned64) + (:translate eql) + (:temporary (:scs (unsigned64-reg)) x64) + (:generator 6 + (sc-case x + (unsigned-reg + (inst clruw x64 x)) + (t + (move x64 x))) + (inst cmp x64 y) + (inst b (if not-p :ne :eq) + target :pt :xcc) + (inst nop))) + +) + +;;; Sparc implementation of modular arithmetic. +#+modular-arith +(progn +(c::define-modular-fun lognot-mod32 (x) lognot 32) + +(define-vop (lognot-mod32/unsigned=>unsigned) + (:translate lognot-mod32) + (:args (x :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 1 + (inst not res x))) + +(define-vop (lognot-mod32/signed=>unsigned) + (:translate lognot-mod32) + (:args (x :scs (signed-reg))) + (:arg-types signed-num) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 1 + (inst not res x))) + +;; Handle (ldb (byte 32 0) (- x)). The (- x) gets converted to +;; (%negate x), so we build modular functions for %negate. + +(c::define-modular-fun %negate-mod32 (x) kernel:%negate 32) + +(define-vop (%negate-mod32/unsigned=>unsigned fast-safe-arith-op) + (:translate %negate-mod32) + (:args (x :scs (unsigned-reg) :target res)) + (:arg-types unsigned-num) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (inst neg res x))) + +(define-vop (%negate-mod32/signed=>unsigned fast-safe-arith-op) + (:translate %negate-mod32) + (:args (x :scs (signed-reg))) + (:arg-types signed-num) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (inst neg res x))) + +;; Define a bunch of vops for converting signed to unsigned. +(macrolet + ((frob (op &optional trans) + (let ((name (symbolicate "FAST-" op "/SIGNED=>UNSIGNED")) + (vop (symbolicate "FAST-" op "/SIGNED=>SIGNED")) + (trans (symbolicate (or trans op) "-MOD32"))) + `(progn + (defknown ,trans ((signed-byte 32) (signed-byte 32)) + (unsigned-byte 32) + (movable foldable flushable)) + (define-vop (,name ,vop) + (:translate ,trans) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num)))))) + (frob +) + (frob -) + (frob logxor) + (frob logeqv) + (frob logandc1) + (frob logandc2) + (frob logorc1) + (frob logorc2) + (frob v8-* *)) + +(defmacro define-modular-backend (fun &optional constantp derived) + (let ((mfun-name (symbolicate fun '-mod32)) + (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned)) + (modcvop (symbolicate 'fast- fun '-mod32-c/unsigned=>unsigned)) + (vop (symbolicate 'fast- (or derived fun) '/unsigned=>unsigned)) + (cvop (symbolicate 'fast- (or derived fun) '-c/unsigned=>unsigned)) + (smodvop (symbolicate 'fast- (or derived fun) '-mod32/signed=>unsigned)) + (svop (symbolicate 'fast- (or derived fun) '/signed=>unsigned))) + `(progn + (c::define-modular-fun ,mfun-name (x y) ,fun 32) + (define-vop (,modvop ,vop) + (:translate ,mfun-name)) + ,@(when constantp + `((define-vop (,modcvop ,cvop) + (:translate ,mfun-name)))) + (define-vop (,smodvop ,svop) + (:translate ,mfun-name))))) + +(define-modular-backend + t) +(define-modular-backend - t) +(define-modular-backend logxor t) +(define-modular-backend logeqv t) +(define-modular-backend logandc1) +(define-modular-backend logandc2 t) +(define-modular-backend logorc1) +(define-modular-backend logorc2 t) +(define-modular-backend * t v8-*) + +(def-source-transform lognand (x y) + `(lognot (logand ,x ,y))) +(def-source-transform lognor (x y) + `(lognot (logior ,x ,y))) + +(defknown vm::ash-left-mod32 (integer (integer 0)) + (unsigned-byte 32) + (foldable flushable movable)) + +(defknown vm::ash-mod32 (integer integer) + (unsigned-byte 32) + (foldable flushable movable)) + +(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned + digit-ashl) + (:translate ash-left-mod32)) + +(define-vop (fast-ash-mod32/unsigned=>unsigned + fast-ash/unsigned=>unsigned) + (:translate ash-mod32)) + +) + +(in-package :c) + +#+modular-arith +(define-modular-fun-optimizer ash ((integer count) :width width) + ;; The count needs to be (mod 32) because the Sparc shift + ;; instruction takes the count modulo 32. (NOTE: Should we make + ;; this work on Ultrasparcs? We could then use the sllx instruction + ;; which takes the count mod 64. Then a left shift of 32 or more + ;; will produce 0 in the lower 32 bits of the register, which is + ;; what we want.) + (when (<= width 32) + ;; We can do a modular shift. If the shift is known to be a left + ;; shift, we can use the left shift vop to get a left shift + ;; instruction. Otherwise, we can use the regular fast-ash vop to + ;; get the shift. + (let ((count-type (continuation-type count))) + (cond ((csubtypep count-type (specifier-type '(unsigned-byte 5))) + (cut-to-width integer width) + 'vm::ash-left-mod32) + ((csubtypep count-type (specifier-type '(integer -31 31))) + (cut-to-width integer width) + 'vm::ash-mod32) + (t + ;; Return NIL to say we can't do anything special. + nil))))) + +;;; If both arguments and the result are (unsigned-byte 32), try to come up +;;; with a ``better'' multiplication using multiplier recoding. There are two +;;; different ways the multiplier can be recoded. The more obvious is to shift +;;; X by the correct amount for each bit set in Y and to sum the results. But +;;; if there is a string of bits that are all set, you can add X shifted by +;;; one more then the bit position of the first set bit and subtract X shifted +;;; by the bit position of the last set bit. We can't use this second method +;;; when the high order bit is bit 31 because shifting by 32 doesn't work +;;; too well. +;;; + + +(defun *-transformer (y) + (let ((y (continuation-value y))) + (multiple-value-bind (result adds shifts) + (strength-reduce-constant-multiply 'x y) + (cond + ((c::backend-featurep '(or :sparc-v9 :sparc-v8)) + ;; This is an approximate break-even point. It's pretty + ;; rough. + (when (> (+ adds shifts) 9) + (give-up))) + (t + (give-up))) + (or result 0)))) + +#+modular-arith +(deftransform * ((x y) + ((unsigned-byte 32) (constant-argument (unsigned-byte 32))) + (unsigned-byte 32)) + "recode as shifts and adds" + (*-transformer y)) + +#+modular-arith +(deftransform vm::*-mod32 ((x y) + ((unsigned-byte 32) (constant-argument (unsigned-byte 32))) + (unsigned-byte 32)) + "recode as shifts and adds" + (*-transformer y)) diff --git a/src/compiler/sparcv9/array.lisp b/src/compiler/sparcv9/array.lisp new file mode 100644 index 0000000000000000000000000000000000000000..71313285594af47c546da670ec54c98bba29c429 --- /dev/null +++ b/src/compiler/sparcv9/array.lisp @@ -0,0 +1,1272 @@ +;;; -*- 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/compiler/sparc/array.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the SPARC definitions for array operations. +;;; +;;; Written by William Lott +;;; Signed-array support by Douglas Crosher 1997. +;;; Complex-float and long-float support by Douglas Crosher 1998. +;;; +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") + + +;;;; Allocator for the array header. + +(define-vop (make-array-header) + (:translate make-array-header) + (:policy :fast-safe) + (:args (type :scs (any-reg)) + (rank :scs (any-reg))) + (:arg-types tagged-num tagged-num) + (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:scs (non-descriptor-reg)) gc-temp) ; gencgc + (:results (result :scs (descriptor-reg))) + (:generator 0 + (pseudo-atomic () + (inst add ndescr rank (* (1+ array-dimensions-offset) vm:word-bytes)) + (inst andn ndescr 4) + (allocation header ndescr other-pointer-type :temp-tn gc-temp) + (inst add ndescr rank (fixnumize (1- vm:array-dimensions-offset))) + (inst slln ndescr ndescr vm:type-bits) + (inst or ndescr ndescr type) + ;; Remove the extraneous fixnum tag bits because TYPE and RANK + ;; were fixnums + (inst srln ndescr ndescr fixnum-tag-bits) + (storew ndescr header 0 vm:other-pointer-type)) + (move result header))) + + +;;;; Additional accessors and setters for the array header. + +(defknown lisp::%array-dimension (t fixnum) fixnum + (flushable)) +(defknown lisp::%set-array-dimension (t fixnum fixnum) fixnum + ()) + +(define-vop (%array-dimension word-index-ref) + (:translate lisp::%array-dimension) + (:policy :fast-safe) + (:variant vm:array-dimensions-offset vm:other-pointer-type)) + +(define-vop (%set-array-dimension word-index-set) + (:translate lisp::%set-array-dimension) + (:policy :fast-safe) + (:variant vm:array-dimensions-offset vm:other-pointer-type)) + + + +(defknown lisp::%array-rank (t) fixnum (flushable)) + +(define-vop (array-rank-vop) + (:translate lisp::%array-rank) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 6 + (loadw temp x 0 vm:other-pointer-type) + (inst sra temp vm:type-bits) + (inst sub temp (1- vm:array-dimensions-offset)) + (inst slln res temp fixnum-tag-bits))) + + + +;;;; Bounds checking routine. + + +(define-vop (check-bound) + (:translate %check-bound) + (:policy :fast-safe) + (:args (array :scs (descriptor-reg)) + (bound :scs (any-reg descriptor-reg)) + (index :scs (any-reg descriptor-reg) :target result)) + (:results (result :scs (any-reg descriptor-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (let ((error (generate-error-code vop invalid-array-index-error + array bound index))) + (inst cmp index bound) + (inst b :geu error) + (inst nop) + (move result index)))) + + + +;;;; Accessors/Setters + +;;; Variants built on top of word-index-ref, etc. I.e. those vectors whose +;;; elements are represented in integer registers and are built out of +;;; 8, 16, or 32 bit elements. + +(defmacro def-data-vector-frobs (type variant element-type &rest scs) + `(progn + (define-vop (,(intern (concatenate 'simple-string + "DATA-VECTOR-REF/" + (string type))) + ,(intern (concatenate 'simple-string + (string variant) + "-REF"))) + (:note _N"inline array access") + (:variant vm:vector-data-offset vm:other-pointer-type) + (:translate data-vector-ref) + (:arg-types ,type positive-fixnum) + (:results (value :scs ,scs)) + (:result-types ,element-type)) + (define-vop (,(intern (concatenate 'simple-string + "DATA-VECTOR-SET/" + (string type))) + ,(intern (concatenate 'simple-string + (string variant) + "-SET"))) + (:note _N"inline array store") + (:variant vm:vector-data-offset vm:other-pointer-type) + (:translate data-vector-set) + (:arg-types ,type positive-fixnum ,element-type) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg zero immediate)) + (value :scs ,scs)) + (:results (result :scs ,scs)) + (:result-types ,element-type)))) + +#-unicode +(def-data-vector-frobs simple-string byte-index + base-char base-char-reg) +#+unicode +(def-data-vector-frobs simple-string halfword-index + base-char base-char-reg) + +(def-data-vector-frobs simple-vector word-index + * descriptor-reg any-reg) + +(def-data-vector-frobs simple-array-unsigned-byte-8 byte-index + positive-fixnum unsigned-reg) +(def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index + positive-fixnum unsigned-reg) +(def-data-vector-frobs simple-array-unsigned-byte-32 word-index + unsigned-num unsigned-reg) + +(def-data-vector-frobs simple-array-signed-byte-30 word-index + tagged-num any-reg) +(def-data-vector-frobs simple-array-signed-byte-32 word-index + signed-num signed-reg) + +;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit, +;;; and 4-bit vectors. +;;; +;;; The elements are stored in the word with the first element in the +;;; most-significant parts of the word. +;;; + +(eval-when (compile eval) + +(defmacro def-small-data-vector-frobs (type bits) + (let* ((elements-per-word (floor vm:word-bits bits)) + (bit-shift (1- (integer-length elements-per-word)))) + `(progn + (define-vop (,(symbolicate 'data-vector-ref/ type)) + (:note _N"inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types ,type positive-fixnum) + (:results (value :scs (any-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result) + (:generator 20 + ;; temp = floor(index bit-shift), to get address of word + ;; containing our bits. + (inst srln temp index ,bit-shift) + (inst slln temp fixnum-tag-bits) + (inst add temp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst ldn result object temp) + ;; temp = mod(index, bit-shift) to figure out what part of + ;; word we want. (XOR is a quick way of computing + ;; elements-per-word minus temp.) + (inst and temp index ,(1- elements-per-word)) + (inst xor temp ,(1- elements-per-word)) + ,@(unless (= bits 1) + `((inst slln temp ,(1- (integer-length bits))))) + (inst srln result temp) + (inst and result ,(1- (ash 1 bits))) + (inst slln value result vm:fixnum-tag-bits))) + (define-vop (,(symbolicate 'data-vector-ref-c/ type)) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types ,type (:constant index)) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 15 + (multiple-value-bind (word extra) + (floor index ,elements-per-word) + ;; Compute how many "units" we need to right shift to get + ;; the bits we want. + (setf extra (- ,(1- elements-per-word) extra)) + (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes) + vm:other-pointer-type))) + (cond ((typep offset '(signed-byte 13)) + (inst ldn result object offset)) + (t + (inst li temp offset) + (inst ldn result object temp)))) + (unless (zerop extra) + (inst srln result (* ,bits extra))) + ;; Always need the mask unless the bits we wanted were the + ;; most significant bits of the word. + (unless (= extra ,(1- elements-per-word)) + (inst and result ,(1- (ash 1 bits))))))) + (define-vop (,(symbolicate 'data-vector-set/ type)) + (:note _N"inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg) :target shift) + (value :scs (unsigned-reg zero immediate) :target result)) + (:arg-types ,type positive-fixnum positive-fixnum) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) temp old offset) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift) + (:generator 25 + (inst srln offset index ,bit-shift) + (inst slln offset fixnum-tag-bits) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst ldn old object offset) + (inst and shift index ,(1- elements-per-word)) + (inst xor shift ,(1- elements-per-word)) + ,@(unless (= bits 1) + `((inst slln shift ,(1- (integer-length bits))))) + (unless (and (sc-is value immediate) + (= (tn-value value) ,(1- (ash 1 bits)))) + (inst li temp ,(1- (ash 1 bits))) + (inst slln temp shift) + (inst not temp) + (inst and old temp)) + (unless (sc-is value zero) + (sc-case value + (immediate + (inst li temp (logand (tn-value value) ,(1- (ash 1 bits))))) + (unsigned-reg + (inst and temp value ,(1- (ash 1 bits))))) + (inst slln temp shift) + (inst or old temp)) + (inst stn old object offset) + (sc-case value + (immediate + (inst li result (tn-value value))) + (t + (move result value))))) + (define-vop (,(symbolicate 'data-vector-set-c/ type)) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (unsigned-reg zero immediate) :target result)) + (:arg-types ,type + (:constant index) + positive-fixnum) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) offset-reg temp old) + (:generator 20 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes) + vm:other-pointer-type))) + (cond ((typep offset '(signed-byte 13)) + (inst ldn old object offset)) + (t + (inst li offset-reg offset) + (inst ldn old object offset-reg))) + (unless (and (sc-is value immediate) + (= (tn-value value) ,(1- (ash 1 bits)))) + (cond ((zerop extra) + (inst slln old ,bits) + (inst srln old ,bits)) + (t + (inst li temp + (lognot (ash ,(1- (ash 1 bits)) + (* (logxor extra + ,(1- elements-per-word)) + ,bits)))) + (inst and old temp)))) + (sc-case value + (zero) + (immediate + (let ((value (ash (logand (tn-value value) + ,(1- (ash 1 bits))) + (* (logxor extra + ,(1- elements-per-word)) + ,bits)))) + (cond ((typep value '(signed-byte 13)) + (inst or old value)) + (t + (inst li temp value) + (inst or old temp))))) + (unsigned-reg + (inst slln temp value + (* (logxor extra ,(1- elements-per-word)) ,bits)) + (inst or old temp))) + (if (typep offset '(signed-byte 13)) + (inst stn old object offset) + (inst stn old object offset-reg))) + (sc-case value + (immediate + (inst li result (tn-value value))) + (t + (move result value))))))))) + +); eval-when (compile eval) + +(def-small-data-vector-frobs simple-bit-vector 1) +(def-small-data-vector-frobs simple-array-unsigned-byte-2 2) +(def-small-data-vector-frobs simple-array-unsigned-byte-4 4) + + +;;; And the float variants. +;;; + +(define-vop (data-vector-ref/simple-array-single-float) + (:note _N"inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types simple-array-single-float positive-fixnum) + (:results (value :scs (single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types single-float) + (:generator 5 + (inst add offset index (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst ldf value object offset))) + +(define-vop (data-vector-ref-c/simple-array-single-float) + (:note _N"inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types simple-array-single-float (:constant index)) + (:info index) + (:results (value :scs (single-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:result-types single-float) + (:generator 3 + (let ((offset (+ (fixnumize index) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))) + (if (typep offset '(signed-byte 13)) + (inst ldf value object offset) + (progn + (inst li temp offset) + (inst ldf value object temp)))))) + + +(define-vop (data-vector-set/simple-array-single-float) + (:note _N"inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (single-reg) :target result)) + (:arg-types simple-array-single-float positive-fixnum single-float) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 5 + (inst add offset index + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst stf value object offset) + (unless (location= result value) + (inst fmovs result value)))) + +(define-vop (data-vector-set-c/simple-array-single-float) + (:note _N"inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (single-reg) :target result)) + (:arg-types simple-array-single-float + (:constant index) + single-float) + (:info index) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 2 + (let ((offset (+ (fixnumize index) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))) + (if (typep offset '(signed-byte 13)) + (inst stf value object offset) + (progn + (inst li temp offset) + (inst stf value object temp))) + (unless (location= result value) + (inst fmovs result value))))) + +(define-vop (data-vector-ref/simple-array-double-float) + (:note _N"inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types simple-array-double-float positive-fixnum) + (:results (value :scs (double-reg))) + (:result-types double-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 7 + (inst slln offset index (- 3 fixnum-tag-bits)) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst lddf value object offset))) + +(define-vop (data-vector-ref-c/simple-array-double-float) + (:note _N"inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types simple-array-double-float (:constant index)) + (:info index) + (:results (value :scs (double-reg))) + (:result-types double-float) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 3 + (let ((offset (+ (* index double-float-bytes) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))) + (if (typep offset '(signed-byte 13)) + (inst lddf value object offset) + (progn + (inst li temp offset) + (inst lddf value object temp)))))) + +(define-vop (data-vector-set/simple-array-double-float) + (:note _N"inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (double-reg) :target result)) + (:arg-types simple-array-double-float positive-fixnum double-float) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 20 + (inst slln offset index (- 3 fixnum-tag-bits)) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst stdf value object offset) + (unless (location= result value) + (move-double-reg result value)))) + +(define-vop (data-vector-set-c/simple-array-double-float) + (:note _N"inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (double-reg) :target result)) + (:arg-types simple-array-double-float + (:constant index) + double-float) + (:info index) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 10 + (let ((offset (+ (* index double-float-bytes) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))) + (if (typep offset '(signed-byte 13)) + (inst stdf value object offset) + (progn + (inst li temp offset) + (inst stdf value object temp))) + (unless (location= result value) + (move-double-reg result value))))) + +#+long-float +(define-vop (data-vector-ref/simple-array-long-float) + (:note _N"inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types simple-array-long-float positive-fixnum) + (:results (value :scs (long-reg))) + (:result-types long-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 7 + (inst slln offset index 2) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (load-long-reg value object offset nil))) + +#+long-float +(define-vop (data-vector-set/simple-array-long-float) + (:note _N"inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (long-reg) :target result)) + (:arg-types simple-array-long-float positive-fixnum long-float) + (:results (result :scs (long-reg))) + (:result-types long-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 20 + (inst slln offset index 2) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (store-long-reg value object offset nil) + (unless (location= result value) + (move-long-reg result value)))) + + +;;;; Misc. Array VOPs. + + +#+nil +(define-vop (vector-word-length) + (:args (vec :scs (descriptor-reg))) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 6 + (loadw res vec clc::g-vector-header-words) + (inst niuo res res clc::g-vector-words-mask-16))) + +(define-vop (get-vector-subtype get-header-data)) +(define-vop (set-vector-subtype set-header-data)) + + +;;; +(define-vop (data-vector-ref/simple-array-signed-byte-8 signed-byte-index-ref) + (:note _N"inline array access") + (:variant vm:vector-data-offset vm:other-pointer-type) + (:translate data-vector-ref) + (:arg-types simple-array-signed-byte-8 positive-fixnum) + (:results (value :scs (signed-reg))) + (:result-types tagged-num)) + +(define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set) + (:note _N"inline array store") + (:variant vm:vector-data-offset vm:other-pointer-type) + (:translate data-vector-set) + (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg zero immediate)) + (value :scs (signed-reg))) + (:results (result :scs (signed-reg))) + (:result-types tagged-num)) + + +(define-vop (data-vector-ref/simple-array-signed-byte-16 + signed-halfword-index-ref) + (:note _N"inline array access") + (:variant vm:vector-data-offset vm:other-pointer-type) + (:translate data-vector-ref) + (:arg-types simple-array-signed-byte-16 positive-fixnum) + (:results (value :scs (signed-reg))) + (:result-types tagged-num)) + +(define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set) + (:note _N"inline array store") + (:variant vm:vector-data-offset vm:other-pointer-type) + (:translate data-vector-set) + (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg zero immediate)) + (value :scs (signed-reg))) + (:results (result :scs (signed-reg))) + (:result-types tagged-num)) + + +;;; Complex float arrays. + +(define-vop (data-vector-ref/simple-array-complex-single-float) + (:note _N"inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-complex-single-float positive-fixnum) + (:results (value :scs (complex-single-reg))) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:result-types complex-single-float) + (:generator 5 + (let ((real-tn (complex-single-reg-real-tn value))) + (inst slln offset index (- 3 fixnum-tag-bits)) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst ldf real-tn object offset)) + (let ((imag-tn (complex-single-reg-imag-tn value))) + (inst add offset single-float-bytes) + (inst ldf imag-tn object offset)))) + +(define-vop (data-vector-ref-c/simple-array-complex-single-float) + (:note _N"inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result)) + (:arg-types simple-array-complex-single-float + (:constant index)) + (:info index) + (:results (value :scs (complex-single-reg))) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:result-types complex-single-float) + (:generator 3 + (let ((offset (+ (* index (* 2 single-float-bytes)) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (real-tn (complex-single-reg-real-tn value)) + (imag-tn (complex-single-reg-imag-tn value))) + (cond ((typep (+ offset single-float-bytes) '(signed-byte 13)) + (inst ldf real-tn object offset) + (inst ldf imag-tn object (+ offset single-float-bytes))) + (t + (inst li temp offset) + (inst ldf real-tn object temp) + (inst add temp single-float-bytes) + (inst ldf imag-tn object temp)))))) + +(define-vop (data-vector-set/simple-array-complex-single-float) + (:note _N"inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg)) + (value :scs (complex-single-reg) :target result)) + (:arg-types simple-array-complex-single-float positive-fixnum + complex-single-float) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 5 + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (inst slln offset index (- 3 fixnum-tag-bits)) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst stf value-real object offset) + (unless (location= result-real value-real) + (inst fmovs result-real value-real))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst add offset single-float-bytes) + (inst stf value-imag object offset) + (unless (location= result-imag value-imag) + (inst fmovs result-imag value-imag))))) + +(define-vop (data-vector-set-c/simple-array-complex-single-float) + (:note _N"inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (value :scs (complex-single-reg) :target result)) + (:arg-types simple-array-complex-single-float + (:constant index) + complex-single-float) + (:info index) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:generator 3 + (let ((offset (+ (* index (* 2 single-float-bytes)) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result)) + (value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (cond ((typep (+ offset single-float-bytes) '(signed-byte 13)) + (inst stf value-real object offset) + (inst stf value-imag object (+ offset single-float-bytes))) + (t + (inst li temp offset) + (inst stf value-real object temp) + (inst add temp single-float-bytes) + (inst stf value-imag object temp))) + (unless (location= result-real value-real) + (inst fmovs result-real value-real)) + (unless (location= result-imag value-imag) + (inst fmovs result-imag value-imag))))) + +(define-vop (data-vector-ref/simple-array-complex-double-float) + (:note _N"inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-complex-double-float positive-fixnum) + (:results (value :scs (complex-double-reg))) + (:result-types complex-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 7 + (let ((real-tn (complex-double-reg-real-tn value))) + (inst slln offset index (- 4 fixnum-tag-bits)) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst lddf real-tn object offset)) + (let ((imag-tn (complex-double-reg-imag-tn value))) + (inst add offset double-float-bytes) + (inst lddf imag-tn object offset)))) + +(define-vop (data-vector-ref-c/simple-array-complex-double-float) + (:note _N"inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result)) + (:arg-types simple-array-complex-double-float (:constant index)) + (:info index) + (:results (value :scs (complex-double-reg))) + (:result-types complex-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:generator 5 + (let ((offset (+ (* index (* 2 double-float-bytes)) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (real-tn (complex-double-reg-real-tn value)) + (imag-tn (complex-double-reg-imag-tn value))) + (cond ((typep (+ offset double-float-bytes) '(signed-byte 13)) + (inst lddf real-tn object offset) + (inst lddf imag-tn object (+ offset double-float-bytes))) + (t + (inst li temp offset) + (inst lddf real-tn object temp) + (inst add temp double-float-bytes) + (inst lddf imag-tn object temp)))))) + +(define-vop (data-vector-set/simple-array-complex-double-float) + (:note _N"inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg)) + (value :scs (complex-double-reg) :target result)) + (:arg-types simple-array-complex-double-float positive-fixnum + complex-double-float) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 20 + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (inst slln offset index (- 4 fixnum-tag-bits)) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst stdf value-real object offset) + (unless (location= result-real value-real) + (move-double-reg result-real value-real))) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst add offset double-float-bytes) + (inst stdf value-imag object offset) + (unless (location= result-imag value-imag) + (move-double-reg result-imag value-imag))))) + +(define-vop (data-vector-set-c/simple-array-complex-double-float) + (:note _N"inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (value :scs (complex-double-reg) :target result)) + (:arg-types simple-array-complex-double-float + (:constant index) + complex-double-float) + (:info index) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:generator 15 + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result)) + (value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result)) + (offset (+ (* index (* 2 double-float-bytes)) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))) + ;; There's a possible optimization here if the offset for the + ;; real part fits in a signed-byte 13 but the imag part doesn't. + ;; We don't do this because it can't happen with the current + ;; values of vm:other-pointer-type and vm:vector-data-offset. + (cond ((typep (+ offset double-float-bytes) '(signed-byte 13)) + (inst stdf value-real object offset) + (inst stdf value-imag object (+ offset double-float-bytes))) + (t + (inst li temp offset) + (inst stdf value-real object temp) + (inst add temp double-float-bytes) + (inst stdf value-imag object temp))) + (unless (location= result-real value-real) + (move-double-reg result-real value-real)) + (unless (location= result-imag value-imag) + (move-double-reg result-imag value-imag))))) + +#+long-float +(define-vop (data-vector-ref/simple-array-complex-long-float) + (:note _N"inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-complex-long-float positive-fixnum) + (:results (value :scs (complex-long-reg))) + (:result-types complex-long-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 7 + (let ((real-tn (complex-long-reg-real-tn value))) + (inst slln offset index 3) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (load-long-reg real-tn object offset nil)) + (let ((imag-tn (complex-long-reg-imag-tn value))) + (inst add offset (* 4 vm:word-bytes)) + (load-long-reg imag-tn object offset nil)))) + +#+long-float +(define-vop (data-vector-set/simple-array-complex-long-float) + (:note _N"inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg)) + (value :scs (complex-long-reg) :target result)) + (:arg-types simple-array-complex-long-float positive-fixnum + complex-long-float) + (:results (result :scs (complex-long-reg))) + (:result-types complex-long-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 20 + (let ((value-real (complex-long-reg-real-tn value)) + (result-real (complex-long-reg-real-tn result))) + (inst slln offset index 3) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (store-long-reg value-real object offset nil) + (unless (location= result-real value-real) + (move-long-reg result-real value-real))) + (let ((value-imag (complex-long-reg-imag-tn value)) + (result-imag (complex-long-reg-imag-tn result))) + (inst add offset (* 4 vm:word-bytes)) + (store-long-reg value-imag object offset nil) + (unless (location= result-imag value-imag) + (move-long-reg result-imag value-imag))))) + + +;;; These VOPs are used for implementing float slots in structures (whose raw +;;; data is an unsigned-32 vector. +;;; +(define-vop (raw-ref-single data-vector-ref/simple-array-single-float) + (:translate %raw-ref-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-single data-vector-set/simple-array-single-float) + (:translate %raw-set-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float)) +;;; +(define-vop (raw-ref-double data-vector-ref/simple-array-double-float) + (:translate %raw-ref-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-double data-vector-set/simple-array-double-float) + (:translate %raw-set-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float)) + +;; Versions with constant offsets +(define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float) + (:translate %raw-ref-single) + (:arg-types simple-array-unsigned-byte-32 (:constant index))) +;;; +(define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float) + (:translate %raw-set-single) + (:arg-types simple-array-unsigned-byte-32 (:constant index) single-float)) +(define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float) + (:translate %raw-ref-double) + (:arg-types simple-array-unsigned-byte-32 (:constant index))) + +(define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float) + (:translate %raw-set-double) + (:arg-types simple-array-unsigned-byte-32 (:constant index) double-float)) + +;;; +#+long-float +(define-vop (raw-ref-long data-vector-ref/simple-array-long-float) + (:translate %raw-ref-long) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +#+long-float +(define-vop (raw-set-double data-vector-set/simple-array-long-float) + (:translate %raw-set-long) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum long-float)) + +(define-vop (raw-ref-complex-single + data-vector-ref/simple-array-complex-single-float) + (:translate %raw-ref-complex-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-complex-single + data-vector-set/simple-array-complex-single-float) + (:translate %raw-set-complex-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum + complex-single-float)) +;;; +(define-vop (raw-ref-complex-double + data-vector-ref/simple-array-complex-double-float) + (:translate %raw-ref-complex-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-complex-double + data-vector-set/simple-array-complex-double-float) + (:translate %raw-set-complex-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum + complex-double-float)) + +(define-vop (raw-ref-complex-single-c + data-vector-ref-c/simple-array-complex-single-float) + (:translate %raw-ref-complex-single) + (:arg-types simple-array-unsigned-byte-32 (:constant index))) +;;; +(define-vop (raw-set-complex-single-c + data-vector-set-c/simple-array-complex-single-float) + (:translate %raw-set-complex-single) + (:arg-types simple-array-unsigned-byte-32 (:constant index) + complex-single-float)) +;;; +(define-vop (raw-ref-complex-double-c + data-vector-ref-c/simple-array-complex-double-float) + (:translate %raw-ref-complex-double) + (:arg-types simple-array-unsigned-byte-32 (:constant index))) +;;; +(define-vop (raw-set-complex-double-c + data-vector-set-c/simple-array-complex-double-float) + (:translate %raw-set-complex-double) + (:arg-types simple-array-unsigned-byte-32 (:constant index) + complex-double-float)) +;;; +#+long-float +(define-vop (raw-ref-complex-long + data-vector-ref/simple-array-complex-long-float) + (:translate %raw-ref-complex-long) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +#+long-float +(define-vop (raw-set-complex-long + data-vector-set/simple-array-complex-long-float) + (:translate %raw-set-complex-long) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum + complex-long-float)) + + +;;; These vops are useful for accessing the bits of a vector irrespective of +;;; what type of vector it is. +;;; + +(define-vop (raw-bits word-index-ref) + (:note _N"raw-bits VOP") + (:translate %raw-bits) + (:results (value :scs (unsigned-reg))) + (:result-types unsigned-num) + (:variant 0 vm:other-pointer-type)) + +(define-vop (set-raw-bits word-index-set) + (:note _N"setf raw-bits VOP") + (:translate %set-raw-bits) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg zero immediate)) + (value :scs (unsigned-reg))) + (:arg-types * tagged-num unsigned-num) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:variant 0 vm:other-pointer-type)) + + +#+double-double +(progn +(define-vop (data-vector-ref/simple-array-double-double-float) + (:note _N"inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-double-double-float positive-fixnum) + (:results (value :scs (double-double-reg))) + (:result-types double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 7 + (let ((hi-tn (double-double-reg-hi-tn value))) + (inst slln offset index (- 4 fixnum-tag-bits)) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst lddf hi-tn object offset)) + (let ((lo-tn (double-double-reg-lo-tn value))) + (inst add offset double-float-bytes) + (inst lddf lo-tn object offset)))) + +(define-vop (data-vector-ref-c/simple-array-double-double-float) + (:note _N"inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result)) + (:arg-types simple-array-double-double-float (:constant index)) + (:info index) + (:results (value :scs (double-double-reg))) + (:result-types double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:generator 5 + (let ((offset (+ (* index (* 2 double-float-bytes)) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (hi-tn (double-double-reg-hi-tn value)) + (lo-tn (double-double-reg-lo-tn value))) + (cond ((typep (+ offset double-float-bytes) '(signed-byte 13)) + (inst lddf hi-tn object offset) + (inst lddf lo-tn object (+ offset double-float-bytes))) + (t + (inst li temp offset) + (inst lddf hi-tn object temp) + (inst add temp double-float-bytes) + (inst lddf lo-tn object temp)))))) + +(define-vop (data-vector-set/simple-array-double-double-float) + (:note _N"inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg)) + (value :scs (double-double-reg) :target result)) + (:arg-types simple-array-double-double-float positive-fixnum + double-double-float) + (:results (result :scs (double-double-reg))) + (:result-types double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 20 + (let ((value-hi (double-double-reg-hi-tn value)) + (result-hi (double-double-reg-hi-tn result))) + (inst slln offset index (- 4 fixnum-tag-bits)) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst stdf value-hi object offset) + (unless (location= result-hi value-hi) + (move-double-reg result-hi value-hi))) + (let ((value-lo (double-double-reg-lo-tn value)) + (result-lo (double-double-reg-lo-tn result))) + (inst add offset double-float-bytes) + (inst stdf value-lo object offset) + (unless (location= result-lo value-lo) + (move-double-reg result-lo value-lo))))) + +(define-vop (data-vector-set-c/simple-array-double-double-float) + (:note _N"inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (value :scs (double-double-reg) :target result)) + (:arg-types simple-array-double-double-float + (:constant index) + double-double-float) + (:info index) + (:results (result :scs (double-double-reg))) + (:result-types double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:generator 15 + (let ((value-hi (double-double-reg-hi-tn value)) + (result-hi (double-double-reg-hi-tn result)) + (value-lo (double-double-reg-lo-tn value)) + (result-lo (double-double-reg-lo-tn result)) + (offset (+ (* index (* 2 double-float-bytes)) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))) + ;; There's a possible optimization here if the offset for the + ;; real part fits in a signed-byte 13 but the imag part doesn't. + ;; We don't do this because it can't happen with the current + ;; values of vm:other-pointer-type and vm:vector-data-offset. + (cond ((typep (+ offset double-float-bytes) '(signed-byte 13)) + (inst stdf value-hi object offset) + (inst stdf value-lo object (+ offset double-float-bytes))) + (t + (inst li temp offset) + (inst stdf value-hi object temp) + (inst add temp double-float-bytes) + (inst stdf value-lo object temp))) + (unless (location= result-hi value-hi) + (move-double-reg result-hi value-hi)) + (unless (location= result-lo value-lo) + (move-double-reg result-lo value-lo))))) + +(define-vop (data-vector-ref/simple-array-complex-double-double-float) + (:note _N"inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-complex-double-double-float positive-fixnum) + (:results (value :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 7 + (let ((real-tn (complex-double-double-reg-real-hi-tn value))) + (inst slln offset index (- 5 fixnum-tag-bits)) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst lddf real-tn object offset)) + (let ((real-tn (complex-double-double-reg-real-lo-tn value))) + (inst add offset double-float-bytes) + (inst lddf real-tn object offset)) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn value))) + (inst add offset double-float-bytes) + (inst lddf imag-tn object offset)) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn value))) + (inst add offset double-float-bytes) + (inst lddf imag-tn object offset)))) + +(define-vop (data-vector-ref-c/simple-array-complex-double-double-float) + (:note _N"inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result)) + (:arg-types simple-array-complex-double-double-float (:constant index)) + (:info index) + (:results (value :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:generator 5 + (let ((offset (+ (* index (* 2 double-float-bytes)) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (real-hi-tn (complex-double-double-reg-real-hi-tn value)) + (imag-hi-tn (complex-double-double-reg-imag-hi-tn value)) + (real-lo-tn (complex-double-double-reg-real-lo-tn value)) + (imag-lo-tn (complex-double-double-reg-imag-lo-tn value))) + (cond ((typep (+ offset (* 3 double-float-bytes)) '(signed-byte 13)) + (inst lddf real-hi-tn object offset) + (inst lddf real-lo-tn object (+ offset double-float-bytes)) + (inst lddf imag-hi-tn object (+ offset (* 2 double-float-bytes))) + (inst lddf imag-lo-tn object (+ offset (* 3 double-float-bytes)))) + (t + (inst li temp offset) + (inst lddf real-hi-tn object temp) + (inst add temp double-float-bytes) + (inst lddf real-lo-tn object temp) + (inst add temp double-float-bytes) + (inst lddf imag-hi-tn object temp) + (inst add temp double-float-bytes) + (inst lddf imag-lo-tn object temp)))))) + +(define-vop (data-vector-set/simple-array-complex-double-double-float) + (:note _N"inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg)) + (value :scs (complex-double-double-reg) :target result)) + (:arg-types simple-array-complex-double-double-float positive-fixnum + complex-double-double-float) + (:results (result :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 20 + (let ((value-real (complex-double-double-reg-real-hi-tn value)) + (result-real (complex-double-double-reg-real-hi-tn result))) + (inst slln offset index (- 5 fixnum-tag-bits)) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst stdf value-real object offset) + (unless (location= result-real value-real) + (move-double-reg result-real value-real))) + (let ((value-real (complex-double-double-reg-real-lo-tn value)) + (result-real (complex-double-double-reg-real-lo-tn result))) + (inst add offset double-float-bytes) + (inst stdf value-real object offset) + (unless (location= result-real value-real) + (move-double-reg result-real value-real))) + (let ((value-imag (complex-double-double-reg-imag-hi-tn value)) + (result-imag (complex-double-double-reg-imag-hi-tn result))) + (inst add offset double-float-bytes) + (inst stdf value-imag object offset) + (unless (location= result-imag value-imag) + (move-double-reg result-imag value-imag))) + (let ((value-imag (complex-double-double-reg-imag-lo-tn value)) + (result-imag (complex-double-double-reg-imag-lo-tn result))) + (inst add offset double-float-bytes) + (inst stdf value-imag object offset) + (unless (location= result-imag value-imag) + (move-double-reg result-imag value-imag))))) + +(define-vop (data-vector-set-c/simple-array-complex-double-double-float) + (:note _N"inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (value :scs (complex-double-double-reg) :target result)) + (:arg-types simple-array-complex-double-double-float + (:constant index) + complex-double-double-float) + (:info index) + (:results (result :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp) + (:generator 15 + (let ((value-real (complex-double-double-reg-real-hi-tn value)) + (result-real (complex-double-double-reg-real-hi-tn result)) + (value-imag (complex-double-double-reg-imag-hi-tn value)) + (result-imag (complex-double-double-reg-imag-hi-tn result)) + (offset (+ (* index (* 2 double-float-bytes)) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))) + ;; There's a possible optimization here if the offset for the + ;; real part fits in a signed-byte 13 but the imag part doesn't. + ;; We don't do this because it can't happen with the current + ;; values of vm:other-pointer-type and vm:vector-data-offset. + (cond ((typep (+ offset double-float-bytes) '(signed-byte 13)) + (inst stdf value-real object offset) + (inst stdf value-imag object (+ offset double-float-bytes))) + (t + (inst li temp offset) + (inst stdf value-real object temp) + (inst add temp double-float-bytes) + (inst stdf value-imag object temp))) + (unless (location= result-real value-real) + (move-double-reg result-real value-real)) + (unless (location= result-imag value-imag) + (move-double-reg result-imag value-imag))) + (let ((value-real (complex-double-double-reg-real-lo-tn value)) + (result-real (complex-double-double-reg-real-lo-tn result)) + (value-imag (complex-double-double-reg-imag-lo-tn value)) + (result-imag (complex-double-double-reg-imag-lo-tn result)) + (offset (+ (* index (* 2 double-float-bytes)) + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))) + ;; There's a possible optimization here if the offset for the + ;; real part fits in a signed-byte 13 but the imag part doesn't. + ;; We don't do this because it can't happen with the current + ;; values of vm:other-pointer-type and vm:vector-data-offset. + (cond ((typep (+ offset (* 3 double-float-bytes)) '(signed-byte 13)) + (inst stdf value-real object (+ offset (* 2 double-float-bytes))) + (inst stdf value-imag object (+ offset (* 3 double-float-bytes)))) + (t + (inst add temp double-float-bytes) + (inst stdf value-real object temp) + (inst add temp double-float-bytes) + (inst stdf value-imag object temp))) + (unless (location= result-real value-real) + (move-double-reg result-real value-real)) + (unless (location= result-imag value-imag) + (move-double-reg result-imag value-imag))))) + + +) diff --git a/src/compiler/sparcv9/c-call.lisp b/src/compiler/sparcv9/c-call.lisp new file mode 100644 index 0000000000000000000000000000000000000000..c3a18becbf89abfab16597bf5802208561a4d8e8 --- /dev/null +++ b/src/compiler/sparcv9/c-call.lisp @@ -0,0 +1,314 @@ +;;; -*- 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/compiler/sparc/c-call.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VOPs and other necessary machine specific support +;;; routines for call-out to C. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") +(use-package "ALIEN") +(use-package "ALIEN-INTERNALS") + +(defun my-make-wired-tn (prim-type-name sc-name offset) + (make-wired-tn (primitive-type-or-lose prim-type-name *backend*) + (sc-number-or-lose sc-name *backend*) + offset)) + +(defstruct arg-state + (register-args 0) + ;; No matter what we have to allocate at least 7 stack frame slots. One + ;; because the C call convention requries it, and 6 because whoever we call + ;; is going to expect to be able to save his 6 register arguments there. + (stack-frame-size 7)) + +(defun int-arg (state prim-type reg-sc stack-sc) + (let ((reg-args (arg-state-register-args state))) + (cond ((< reg-args 6) + (setf (arg-state-register-args state) (1+ reg-args)) + (my-make-wired-tn prim-type reg-sc (+ reg-args nl0-offset))) + (t + (let ((frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (1+ frame-size)) + (my-make-wired-tn prim-type stack-sc (+ frame-size 16))))))) + +(def-alien-type-method (integer :arg-tn) (type state) + (if (alien-integer-type-signed type) + (int-arg state 'signed-byte-32 'signed-reg 'signed-stack) + (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))) + +(def-alien-type-method (system-area-pointer :arg-tn) (type state) + (declare (ignore type)) + (int-arg state 'system-area-pointer 'sap-reg 'sap-stack)) + +(defstruct result-state + (num-results 0)) + +(defun result-reg-offset (slot) + (ecase slot + (0 nl0-offset) + (1 nl1-offset))) + +(def-alien-type-method (integer :result-tn) (type state) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (multiple-value-bind (ptype reg-sc) + (if (alien-integer-type-signed type) + (values 'signed-byte-32 'signed-reg) + (values 'unsigned-byte-32 'unsigned-reg)) + (my-make-wired-tn ptype reg-sc (result-reg-offset num-results))))) + +(def-alien-type-method (system-area-pointer :result-tn) (type state) + (declare (ignore type)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (my-make-wired-tn 'system-area-pointer 'sap-reg + (result-reg-offset num-results)))) + +(def-alien-type-method (double-float :result-tn) (type state) + (declare (ignore type state)) + (my-make-wired-tn 'double-float 'double-reg 0)) + +(def-alien-type-method (single-float :result-tn) (type state) + (declare (ignore type state)) + (my-make-wired-tn 'single-float 'single-reg 0)) + +#+long-float +(def-alien-type-method (long-float :result-tn) (type) + (declare (ignore type)) + (my-make-wired-tn 'long-float 'long-reg 0)) + +(def-alien-type-method (values :result-tn) (type state) + (let ((values (alien-values-type-values type))) + (when (> (length values) 2) + (error (intl:gettext "Too many result values from c-call."))) + (mapcar #'(lambda (type) + (invoke-alien-type-method :result-tn type state)) + values))) + +(def-vm-support-routine make-call-out-tns (type) + (declare (type alien-function-type type)) + (let ((arg-state (make-arg-state))) + (collect ((arg-tns)) + (dolist (arg-type (alien-function-type-arg-types type)) + (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) + (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset) + (* (arg-state-stack-frame-size arg-state) word-bytes) + (arg-tns) + (invoke-alien-type-method + :result-tn + (alien-function-type-result-type type) + (make-result-state)))))) + +(deftransform %alien-funcall ((function type &rest args)) + (assert (c::constant-continuation-p type)) + (let* ((type (c::continuation-value type)) + (arg-types (alien-function-type-arg-types type)) + (result-type (alien-function-type-result-type type))) + (assert (= (length arg-types) (length args))) + ;; We need to do something special for the following argument + ;; types: single-float, double-float, and 64-bit integers. For + ;; results, we need something special for 64-bit integer results. + (if (or (some #'alien-single-float-type-p arg-types) + (some #'alien-double-float-type-p arg-types) + (some #'(lambda (type) + (and (alien-integer-type-p type) + (> (alien::alien-integer-type-bits type) 32))) + arg-types) + #+long-float (some #'alien-long-float-type-p arg-types) + (and (alien-integer-type-p result-type) + (> (alien::alien-integer-type-bits result-type) 32))) + (collect ((new-args) (lambda-vars) (new-arg-types) (mv-vars) (mv-form)) + (dolist (type arg-types) + (let ((arg (gensym))) + (lambda-vars arg) + (cond ((and (alien-integer-type-p type) + (> (alien::alien-integer-type-bits type) 32)) + ;; 64-bit long long types are stored in + ;; consecutive locations, most significant word + ;; first (big-endian). + (new-args `(ash ,arg -32)) + (new-args `(logand ,arg #xffffffff)) + (if (alien-integer-type-signed type) + (new-arg-types (parse-alien-type '(signed 32))) + (new-arg-types (parse-alien-type '(unsigned 32)))) + (new-arg-types (parse-alien-type '(unsigned 32)))) + ((alien-single-float-type-p type) + (new-args `(single-float-bits ,arg)) + (new-arg-types (parse-alien-type '(signed 32)))) + ((alien-double-float-type-p type) + ;; Use double-float-bits instead of + ;; double-float-hi/lo-bits to get the bits + ;; out. This gives a some improvement + ;; because there's only store of the FP value. + ;; + ;; Sparc calling conventions say floats must be + ;; passed in the integer registers. + (let ((mvarg1 (gensym)) + (mvarg2 (gensym))) + (mv-vars `(,mvarg1 ,mvarg2)) + (mv-form `(double-float-bits ,arg)) + (new-args mvarg1) + (new-args mvarg2) + (new-arg-types (parse-alien-type '(signed 32))) + (new-arg-types (parse-alien-type '(unsigned 32))))) + #+long-float + ((alien-long-float-type-p type) + (new-args `(long-float-exp-bits ,arg)) + (new-args `(long-float-high-bits ,arg)) + (new-args `(long-float-mid-bits ,arg)) + (new-args `(long-float-low-bits ,arg)) + (new-arg-types (parse-alien-type '(signed 32))) + (new-arg-types (parse-alien-type '(unsigned 32))) + (new-arg-types (parse-alien-type '(unsigned 32))) + (new-arg-types (parse-alien-type '(unsigned 32)))) + (t + (new-args arg) + (new-arg-types type))))) + (flet ((mv (vars forms body) + ;; Create the set of nested mv-binds + (let ((res body)) + (do ((v (reverse vars) (cdr v)) + (f (reverse forms) (cdr f))) + ((null v)) + (setf res `(multiple-value-bind ,(car v) + ,(car f) + ,res))) + res))) + (cond ((and (alien-integer-type-p result-type) + (> (alien::alien-integer-type-bits result-type) 32)) + (let* ((new-result-type + (let ((alien::*values-type-okay* t)) + (parse-alien-type + (if (alien-integer-type-signed result-type) + '(values (signed 32) (unsigned 32)) + '(values (unsigned 32) (unsigned 32)))))) + (body (mv (mv-vars) + (mv-form) + `(multiple-value-bind (high low) + (%alien-funcall function + ',(make-alien-function-type + :arg-types (new-arg-types) + :result-type new-result-type) + ,@(new-args)) + (logior low (ash high 32)))))) + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + ,body))) + (t + (let ((body (mv (mv-vars) + (mv-form) + `(%alien-funcall function + ',(make-alien-function-type + :arg-types (new-arg-types) + :result-type result-type) + ,@(new-args))))) + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + ,body)))))) + (c::give-up)))) + + +#-linkage-table +(define-vop (foreign-symbol-address) + (:translate foreign-symbol-address) + (:policy :fast-safe) + (:args) + (:arg-types (:constant simple-string)) + (:info foreign-symbol) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (inst li res (make-fixup (extern-alien-name foreign-symbol) + :foreign)))) + +(define-vop (foreign-symbol-code-address) + (:translate #+linkage-table foreign-symbol-code-address + #-linkage-table foreign-symbol-address) + (:policy :fast-safe) + (:args) + (:arg-types (:constant simple-string)) + (:info foreign-symbol) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (inst li res (make-fixup (extern-alien-name foreign-symbol) + :foreign)))) + +(define-vop (foreign-symbol-data-address) + (:translate foreign-symbol-data-address) + (:policy :fast-safe) + (:args) + (:arg-types (:constant simple-string)) + (:info foreign-symbol) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:temporary (:scs (non-descriptor-reg)) addr) + (:generator 2 + (inst li addr (make-fixup (extern-alien-name foreign-symbol) + :foreign-data)) + (loadw res addr))) + +(define-vop (call-out) + (:args (function :scs (sap-reg) :target cfunc) + (args :more t)) + (:results (results :more t)) + (:ignore args results) + (:save-p t) + (:temporary (:sc any-reg :offset cfunc-offset + :from (:argument 0) :to (:result 0)) cfunc) + (:temporary (:sc interior-reg :offset lip-offset) lip) + (:temporary (:scs (any-reg) :to (:result 0)) temp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:vop-var vop) + (:generator 0 + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (move cfunc function) + (inst li temp (make-fixup (extern-alien-name "call_into_c") :foreign)) + (inst jal lip temp) + (inst nop) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))))) + + +(define-vop (alloc-number-stack-space) + (:info amount) + (:results (result :scs (sap-reg any-reg))) + (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) + (:generator 0 + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 7) 7))) + (cond ((< delta (ash 1 12)) + (inst sub nsp-tn delta)) + (t + (inst li temp delta) + (inst sub nsp-tn temp))))) + (unless (location= result nsp-tn) + ;; They are only location= when the result tn was allocated by + ;; make-call-out-tns above, which takes the number-stack-displacement + ;; into account itself. + (inst add result nsp-tn number-stack-displacement)))) + +(define-vop (dealloc-number-stack-space) + (:info amount) + (:policy :fast-safe) + (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) + (:generator 0 + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 7) 7))) + (cond ((< delta (ash 1 12)) + (inst add nsp-tn delta)) + (t + (inst li temp delta) + (inst add nsp-tn temp))))))) diff --git a/src/compiler/sparcv9/c-callback.lisp b/src/compiler/sparcv9/c-callback.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b1fa10cd47dfac5ba3a432b26b8b3fb80b4ca002 --- /dev/null +++ b/src/compiler/sparcv9/c-callback.lisp @@ -0,0 +1,217 @@ +;;; -*- 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/compiler/sparc/c-callback.lisp $") + +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") +(use-package "ALIEN") +(use-package "ALIEN-INTERNALS") + +;;; Support for callbacks to Lisp. +(eval-when (:compile-toplevel :load-toplevel :execute) +(export '(make-callback-trampoline callback-accessor-form + compatible-function-types-p)) +) + +(defun callback-accessor-form (type sp offset) + (let ((parsed-type (alien::parse-alien-type type))) + (typecase parsed-type + (alien::double$ + ;; Due to sparc calling conventions, a double arg doesn't have to + ;; be aligned on a double word boundary. We have to get the two + ;; words separately and create the double from them. Doubles are + ;; stored in big-endian order, naturally. + `(kernel:make-double-float + (alien:deref (sap-alien (sys:sap+ ,sp ,offset) (* c-call:int))) + (alien:deref (sap-alien (sys:sap+ ,sp (+ ,offset vm:word-bytes)) + (* c-call:unsigned-int))))) + (alien::integer-64$ + ;; Same as for double, above + `(let ((hi (alien:deref (sap-alien (sys:sap+ ,sp ,offset) + ,(if (alien-integer-type-signed parsed-type) + '(* c-call:int) + '(* c-call:unsigned-int))))) + (lo (alien:deref (sap-alien (sys:sap+ ,sp + (+ ,offset vm:word-bytes)) + (* c-call:unsigned-int))))) + (+ (ash hi vm:word-bits) lo))) + (alien::integer$ + ;; All other objects can be accessed directly. But we need to + ;; get the offset right, since the offset we're given is the + ;; start of the object, and we're a big-endian machine. + (let ((byte-offset + (- vm:word-bytes + (ceiling (alien::alien-integer-type-bits parsed-type) + vm:byte-bits)))) + `(deref (sap-alien (sys:sap+ ,sp ,(+ byte-offset offset)) + (* ,type))))) + (t + `(deref (sap-alien (sys:sap+ ,sp ,offset) + (* ,type))))))) + +(defun compatible-function-types-p (type1 type2) + (flet ((machine-rep (type) + (etypecase type + (alien::integer-64$ :dword) + ((or alien::integer$ alien::pointer$ alien::sap$) :word) + (alien::single$ :single) + (alien::double$ :double) + (alien::void$ :void)))) + (let ((type1 (alien-function-type-result-type type1)) + (type2 (alien-function-type-result-type type2))) + (eq (machine-rep type1) (machine-rep type2))))) + +(defun make-callback-trampoline (index fn-type) + "Cons up a piece of code which calls call-callback with INDEX and a +pointer to the arguments." + (let ((return-type (alien-function-type-result-type fn-type))) + (flet ((def-reg-tn (offset) + (c:make-random-tn :kind :normal + :sc (c:sc-or-lose 'vm::unsigned-reg) + :offset offset))) + (let* ((segment (make-segment)) + ;; Window save area (16 registers) + (window-save-size (* 16 vm:word-bytes)) + ;; Structure return pointer area (1 register) + (struct-return-size vm:word-bytes) + ;; Register save area (6 registers) + (reg-save-area-size (* 6 vm:word-bytes)) + ;; Local var. Should be large enough to hold a double-float or long + (return-value-size (* 2 vm:word-bytes)) + ;; Frame size: the register window, the arg save area, the + ;; structure return area, and return-value-area, all + ;; rounded to a multiple of eight. + (framesize (* 8 (ceiling (+ window-save-size struct-return-size + reg-save-area-size + return-value-size) + 8))) + ;; Offset from FP where the first arg is located. + (arg0-save-offset (+ window-save-size struct-return-size)) + ;; Establish the registers we need + (%g0 (def-reg-tn vm::zero-offset)) + (%o0 (def-reg-tn vm::nl0-offset)) + (%o1 (def-reg-tn vm::nl1-offset)) + (%o2 (def-reg-tn vm::nl2-offset)) + (%o3 (def-reg-tn vm::nl3-offset)) + (%o7 (def-reg-tn vm::nargs-offset)) + (%sp (def-reg-tn vm::nsp-offset)) ; aka %o6 + (%l0 (def-reg-tn vm::a0-offset)) + (%i0 (def-reg-tn vm::cname-offset)) + (%i1 (def-reg-tn vm::lexenv-offset)) + (%i2 (def-reg-tn 26)) + (%i3 (def-reg-tn vm::nfp-offset)) + (%i4 (def-reg-tn vm::cfunc-offset)) + (%i5 (def-reg-tn vm::code-offset)) + (%fp (def-reg-tn 30)) + (%i7 (def-reg-tn vm::lip-offset)) + (f0-s (c:make-random-tn :kind :normal + :sc (c:sc-or-lose 'vm::single-reg) + :offset 0)) + (f0-d (c:make-random-tn :kind :normal + :sc (c:sc-or-lose 'vm::double-reg) + :offset 0)) + ) + ;; The generated assembly roughly corresponds to this C code: + ;; + ;; tramp(int a0, int a1, int a2, int a3, int a4, int a5, ...) + ;; { + ;; double result; + ;; funcall3(call-callback, <index>, &a0, &result); + ;; return <cast> result; + ;; } + ;; + ;; Except, of course, the result is the appropriate result type + ;; for the trampoline. + ;; + (assemble (segment) + ;; Save old %fp, etc. establish our call frame with local vars + ;; %i contains the input args + (inst save %sp %sp (- framesize)) + ;; The stack frame now looks like + ;; + ;; TOP (high memory) + ;; + ;; argn + ;; ... + ;; arg6 + ;; arg5 + ;; arg4 + ;; arg3 + ;; arg2 + ;; arg1 + ;; arg0 + ;; struct_return + ;; window-save-area <- %fp + 64 + ;; <- %fp + ;; local-vars-extra-args (8-bytes) + ;; arg5-save + ;; arg4-save + ;; arg3-save + ;; arg2-save + ;; arg1-save + ;; arg0-save + ;; struct_return + ;; window-save-area + ;; <- %sp + + ;; Save all %i arg register values on the stack. (We + ;; might not always need to save all, but this is safe + ;; and easy.) + (inst st %i0 %fp (+ arg0-save-offset (* 0 vm:word-bytes))) + (inst st %i1 %fp (+ arg0-save-offset (* 1 vm:word-bytes))) + (inst st %i2 %fp (+ arg0-save-offset (* 2 vm:word-bytes))) + (inst st %i3 %fp (+ arg0-save-offset (* 3 vm:word-bytes))) + (inst st %i4 %fp (+ arg0-save-offset (* 4 vm:word-bytes))) + (inst st %i5 %fp (+ arg0-save-offset (* 5 vm:word-bytes))) + + ;; Set up our args to call funcall3 + ;; + ;; %o0 = address of call-callback + ;; %o1 = index + ;; %o2 = pointer to the arguments of the caller (address + ;; of arg0 above) + ;; %o3 = pointer to return area + + (inst li %o0 (alien::address-of-call-callback)) + (inst li %o1 (ash index vm:fixnum-tag-bits)) + (inst add %o2 %fp arg0-save-offset) + (inst add %o3 %fp (- return-value-size)) + + ;; And away we go to funcall3! + (let ((addr (alien::address-of-funcall3))) + (inst sethi %l0 (ldb (byte 22 10) addr)) + (inst jal %o7 %l0 (ldb (byte 10 0) addr)) + (inst nop)) + + ;; Ok, we're back. The value returned is actually + ;; stored in the return area. Need to get that into + ;; the right registers for return. + (etypecase return-type + (alien::integer-64$ + ;; A 64-bit bignum, stored big-endian + (inst ld %i0 %fp (- return-value-size)) + (inst ld %i1 %fp (- (- return-value-size vm:word-bytes)))) + ((or alien::integer$ alien::pointer$ alien::sap$) + (inst ld %i0 %fp (- return-value-size))) + (alien::single$ + ;; Get the FP value into F0 + (inst ldf f0-s %fp (- return-value-size)) + ) + (alien::double$ + (inst lddf f0-d %fp (- return-value-size))) + (alien::void$ + )) + + (inst jal %g0 %i7 8) + (inst restore %g0 %g0 %g0) + ) + (let ((length (finalize-segment segment))) + (prog1 (alien::segment-to-trampoline segment length) + (release-segment segment))))))) + + diff --git a/src/compiler/sparcv9/call.lisp b/src/compiler/sparcv9/call.lisp new file mode 100644 index 0000000000000000000000000000000000000000..6c8b2f2467877bbfd96725b5e5ee2e8d40f17426 --- /dev/null +++ b/src/compiler/sparcv9/call.lisp @@ -0,0 +1,1300 @@ +;;; -*- 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/compiler/sparc/call.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of function call for the SPARC. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") + + +;;;; Interfaces to IR2 conversion: + +;;; Standard-Argument-Location -- Interface +;;; +;;; Return a wired TN describing the N'th full call argument passing +;;; location. +;;; +(def-vm-support-routine standard-argument-location (n) + (declare (type unsigned-byte n)) + (if (< n register-arg-count) + (make-wired-tn *any-primitive-type* register-arg-scn + (elt register-arg-offsets n)) + (make-wired-tn *any-primitive-type* control-stack-arg-scn n))) + + +;;; Make-Return-PC-Passing-Location -- Interface +;;; +;;; Make a passing location TN for a local call return PC. If standard is +;;; true, then use the standard (full call) location, otherwise use any legal +;;; location. Even in the non-standard case, this may be restricted by a +;;; desire to use a subroutine call instruction. +;;; +(def-vm-support-routine make-return-pc-passing-location (standard) + (if standard + (make-wired-tn *any-primitive-type* register-arg-scn lra-offset) + (make-restricted-tn *any-primitive-type* register-arg-scn))) + +;;; Make-Old-FP-Passing-Location -- Interface +;;; +;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass +;;; Old-FP in. This is (obviously) wired in the standard convention, but is +;;; totally unrestricted in non-standard conventions, since we can always fetch +;;; it off of the stack using the arg pointer. +;;; +(def-vm-support-routine make-old-fp-passing-location (standard) + (if standard + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset) + (make-normal-tn *fixnum-primitive-type*))) + +;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location -- Interface +;;; +;;; Make the TNs used to hold Old-FP and Return-PC within the current +;;; function. We treat these specially so that the debugger can find them at a +;;; known location. +;;; +(def-vm-support-routine make-old-fp-save-location (env) + (specify-save-tn + (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) + (make-wired-tn *fixnum-primitive-type* + control-stack-arg-scn + ocfp-save-offset))) +;;; +(def-vm-support-routine make-return-pc-save-location (env) + (specify-save-tn + (environment-debug-live-tn (make-normal-tn *any-primitive-type*) env) + (make-wired-tn *any-primitive-type* + control-stack-arg-scn + lra-save-offset))) + +;;; Make-Argument-Count-Location -- Interface +;;; +;;; Make a TN for the standard argument count passing location. We only +;;; need to make the standard location, since a count is never passed when we +;;; are using non-standard conventions. +;;; +(def-vm-support-routine make-argument-count-location () + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset)) + + +;;; MAKE-NFP-TN -- Interface +;;; +;;; Make a TN to hold the number-stack frame pointer. This is allocated +;;; once per component, and is component-live. +;;; +(def-vm-support-routine make-nfp-tn () + (component-live-tn + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nfp-offset))) + +;;; MAKE-STACK-POINTER-TN () +;;; +(def-vm-support-routine make-stack-pointer-tn () + (make-normal-tn *fixnum-primitive-type*)) + +;;; MAKE-NUMBER-STACK-POINTER-TN () +;;; +(def-vm-support-routine make-number-stack-pointer-tn () + (make-normal-tn *fixnum-primitive-type*)) + +;;; Make-Unknown-Values-Locations -- Interface +;;; +;;; Return a list of TNs that can be used to represent an unknown-values +;;; continuation within a function. +;;; +(def-vm-support-routine make-unknown-values-locations () + (list (make-stack-pointer-tn) + (make-normal-tn *fixnum-primitive-type*))) + + +;;; Select-Component-Format -- Interface +;;; +;;; This function is called by the Entry-Analyze phase, allowing +;;; VM-dependent initialization of the IR2-Component structure. We push +;;; placeholder entries in the Constants to leave room for additional +;;; noise in the code object header. +;;; +(def-vm-support-routine select-component-format (component) + (declare (type component component)) + (dotimes (i code-constants-offset) + (vector-push-extend nil + (ir2-component-constants (component-info component)))) + (undefined-value)) + + +;;;; Frame hackery: + +;;; BYTES-NEEDED-FOR-NON-DESCRIPTOR-STACK-FRAME -- internal +;;; +;;; Return the number of bytes needed for the current non-descriptor stack +;;; frame. Non-descriptor stack frames must be multiples of 8 bytes on +;;; the PMAX. +;;; +(defun bytes-needed-for-non-descriptor-stack-frame () + (* (logandc2 (1+ (sb-allocated-size 'non-descriptor-stack)) 1) + vm:word-bytes)) + + +;;; Used for setting up the Old-FP in local call. +;;; +(define-vop (current-fp) + (:results (val :scs (any-reg))) + (:generator 1 + (move val cfp-tn))) + +;;; Used for computing the caller's NFP for use in known-values return. Only +;;; works assuming there is no variable size stuff on the nstack. +;;; +(define-vop (compute-old-nfp) + (:results (val :scs (any-reg))) + (:vop-var vop) + (:generator 1 + (let ((nfp (current-nfp-tn vop))) + (when nfp + (inst add val nfp (bytes-needed-for-non-descriptor-stack-frame)))))) + + +(define-vop (xep-allocate-frame) + (:info start-lab copy-more-arg-follows clear-memory-p) + (:ignore copy-more-arg-follows) + (:vop-var vop) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 1 + ;; Make sure the function is aligned, and drop a label pointing to this + ;; function header. + (align vm:lowtag-bits) + (trace-table-entry trace-table-function-prologue) + (emit-label start-lab) + ;; Allocate function header. + (inst function-header-word) + (dotimes (i (1- vm:function-code-offset)) + (inst word 0)) + ;; The start of the actual code. + ;; Fix CODE, cause the function object was passed in. + (inst compute-code-from-fn code-tn code-tn start-lab temp) + ;; Rob says we should zero out the words that are allocated for + ;; the args that are passed in registers and also zero out the + ;; words from CSP to CFP+size. + (when clear-memory-p + + ;; Zero out the args that correspond to register args + (dotimes (k register-arg-count) + (inst stn zero-tn cfp-tn (* k vm:word-bytes))) + + ;; Zero out memory from CSP to CFP+size + (let ((zero-out-mem (gen-label)) + (loop-test (gen-label))) + + (inst b loop-test) + (inst add temp cfp-tn + (* vm:word-bytes (1- (sb-allocated-size 'control-stack)))) + + (emit-label zero-out-mem) + (inst stn zero-tn csp-tn (- vm:word-bytes)) + (emit-label loop-test) + (inst cmp csp-tn temp) + (inst b :lt zero-out-mem) + (inst add csp-tn vm:word-bytes)) + ) + ;; Build our stack frames. + (let ((size (* vm:word-bytes (sb-allocated-size 'control-stack)))) + (cond ((typep size '(signed-byte 13)) + (inst add csp-tn cfp-tn size)) + (t + (inst li temp size) + (inst add csp-tn cfp-tn temp)))) + (let ((nfp-tn (current-nfp-tn vop))) + (when nfp-tn + (inst sub nsp-tn (bytes-needed-for-non-descriptor-stack-frame)) + (inst add nfp-tn nsp-tn number-stack-displacement))) + (trace-table-entry trace-table-normal))) + +(define-vop (allocate-frame) + (:results (res :scs (any-reg)) + (nfp :scs (any-reg))) + (:info callee clear-memory-p) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 2 + (trace-table-entry trace-table-function-prologue) + (move res csp-tn) + (when clear-memory-p + ;; Rob Maclaclan says we should zero out this memory. + (let ((zero-out-loop (gen-label)) + (zero-out-test (gen-label))) + (inst b zero-out-test) + (inst li temp (* vm:word-bytes (sb-allocated-size 'control-stack))) + + (emit-label zero-out-loop) + (emit-label zero-out-test) + (inst subcc temp vm:word-bytes) + (inst b :gt zero-out-loop) + (inst stn zero-tn csp-tn temp) + )) + (let ((size (* vm:word-bytes (sb-allocated-size 'control-stack)))) + (cond ((typep size '(signed-byte 13)) + (inst add csp-tn csp-tn size)) + (t + (inst li temp size) + (inst add csp-tn csp-tn temp)))) + (when (ir2-environment-number-stack-p callee) + (inst sub nsp-tn (bytes-needed-for-non-descriptor-stack-frame)) + (inst add nfp nsp-tn number-stack-displacement)) + (trace-table-entry trace-table-normal))) + +;;; Allocate a partial frame for passing stack arguments in a full call. Nargs +;;; is the number of arguments passed. If no stack arguments are passed, then +;;; we don't have to do anything. +;;; +(define-vop (allocate-full-call-frame) + (:info nargs) + (:results (res :scs (any-reg))) + (:generator 2 + (when (> nargs register-arg-count) + (move res csp-tn) + (inst add csp-tn csp-tn (* nargs vm:word-bytes))))) + + + + +;;; Default-Unknown-Values -- Internal +;;; +;;; Emit code needed at the return-point from an unknown-values call for a +;;; fixed number of values. Values is the head of the TN-Ref list for the +;;; locations that the values are to be received into. Nvals is the number of +;;; values that are to be received (should equal the length of Values). +;;; +;;; Move-Temp is a Descriptor-Reg TN used as a temporary. +;;; +;;; This code exploits the fact that in the unknown-values convention, a +;;; single value return returns at the return PC + 8, whereas a return of other +;;; than one value returns directly at the return PC. +;;; +;;; If 0 or 1 values are expected, then we just emit an instruction to reset +;;; the SP (which will only be executed when other than 1 value is returned.) +;;; +;;; In the general case, we have to do three things: +;;; -- Default unsupplied register values. This need only be done when a +;;; single value is returned, since register values are defaulted by the +;;; called in the non-single case. +;;; -- Default unsupplied stack values. This needs to be done whenever there +;;; are stack values. +;;; -- Reset SP. This must be done whenever other than 1 value is returned, +;;; regardless of the number of values desired. +;;; +;;; The general-case code looks like this: +#| + b regs-defaulted ; Skip if MVs + nop + + move a1 null-tn ; Default register values + ... + loadi nargs 1 ; Force defaulting of stack values + move old-fp csp ; Set up args for SP resetting + +regs-defaulted + subcc temp nargs register-arg-count + + b :lt default-value-7 ; jump to default code + loadw move-temp ocfp-tn 6 ; Move value to correct location. + subcc temp 1 + store-stack-tn val4-tn move-temp + + b :lt default-value-8 + loadw move-temp ocfp-tn 7 + subcc temp 1 + store-stack-tn val5-tn move-temp + + ... + +defaulting-done + move csp ocfp ; Reset SP. +<end of code> + +<elsewhere> +default-value-7 + store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack) + +default-value-8 + store-stack-tn val5-tn null-tn ; Nil out 8'th value. + + ... + + br defaulting-done + nop +|# +;;; +(defun default-unknown-values (vop values nvals move-temp temp lra-label) + (declare (type (or tn-ref null) values) + (type unsigned-byte nvals) (type tn move-temp temp)) + (if (<= nvals 1) + (progn + (new-assem:without-scheduling () + (note-this-location vop :single-value-return) + (move csp-tn ocfp-tn) + (inst nop)) + (inst compute-code-from-lra code-tn code-tn lra-label temp)) + (let ((regs-defaulted (gen-label)) + (defaulting-done (gen-label)) + (default-stack-vals (gen-label))) + ;; Branch off to the MV case. + (new-assem:without-scheduling () + (note-this-location vop :unknown-return) + (inst b regs-defaulted) + (if (> nvals register-arg-count) + (inst subcc temp nargs-tn (fixnumize register-arg-count)) + (move csp-tn ocfp-tn))) + + ;; Do the single value calse. + (do ((i 1 (1+ i)) + (val (tn-ref-across values) (tn-ref-across val))) + ((= i (min nvals register-arg-count))) + (move (tn-ref-tn val) null-tn)) + (when (> nvals register-arg-count) + (inst b default-stack-vals) + (move ocfp-tn csp-tn)) + + (emit-label regs-defaulted) + (when (> nvals register-arg-count) + (collect ((defaults)) + (do ((i register-arg-count (1+ i)) + (val (do ((i 0 (1+ i)) + (val values (tn-ref-across val))) + ((= i register-arg-count) val)) + (tn-ref-across val))) + ((null val)) + + (let ((default-lab (gen-label)) + (tn (tn-ref-tn val))) + (defaults (cons default-lab tn)) + + (inst b :le default-lab) + (inst ldn move-temp ocfp-tn (* i vm:word-bytes)) + (inst subcc temp (fixnumize 1)) + (store-stack-tn tn move-temp))) + + (emit-label defaulting-done) + (move csp-tn ocfp-tn) + + (let ((defaults (defaults))) + (when defaults + (assemble (*elsewhere*) + (emit-label default-stack-vals) + (trace-table-entry trace-table-function-prologue) + (do ((remaining defaults (cdr remaining))) + ((null remaining)) + (let ((def (car remaining))) + (emit-label (car def)) + (when (null (cdr remaining)) + (inst b defaulting-done)) + (store-stack-tn (cdr def) null-tn))) + (trace-table-entry trace-table-normal)))))) + + (inst compute-code-from-lra code-tn code-tn lra-label temp))) + (undefined-value)) + + +;;;; Unknown values receiving: + +;;; Receive-Unknown-Values -- Internal +;;; +;;; Emit code needed at the return point for an unknown-values call for an +;;; arbitrary number of values. +;;; +;;; We do the single and non-single cases with no shared code: there doesn't +;;; seem to be any potential overlap, and receiving a single value is more +;;; important efficiency-wise. +;;; +;;; When there is a single value, we just push it on the stack, returning +;;; the old SP and 1. +;;; +;;; When there is a variable number of values, we move all of the argument +;;; registers onto the stack, and return Args and Nargs. +;;; +;;; Args and Nargs are TNs wired to the named locations. We must +;;; explicitly allocate these TNs, since their lifetimes overlap with the +;;; results Start and Count (also, it's nice to be able to target them). +;;; +(defun receive-unknown-values (args nargs start count lra-label temp) + (declare (type tn args nargs start count temp)) + (let ((variable-values (gen-label)) + (done (gen-label))) + (new-assem:without-scheduling () + (inst b variable-values) + (inst nop)) + + (inst compute-code-from-lra code-tn code-tn lra-label temp) + (inst add csp-tn 4) + (storew (first register-arg-tns) csp-tn -1) + (inst sub start csp-tn 4) + (inst li count (fixnumize 1)) + + (emit-label done) + + (assemble (*elsewhere*) + (trace-table-entry trace-table-function-prologue) + (emit-label variable-values) + (inst compute-code-from-lra code-tn code-tn lra-label temp) + (do ((arg register-arg-tns (rest arg)) + (i 0 (1+ i))) + ((null arg)) + (storew (first arg) args i)) + (move start args) + (move count nargs) + (inst b done) + (inst nop) + (trace-table-entry trace-table-normal))) + (undefined-value)) + + +;;; VOP that can be inherited by unknown values receivers. The main thing this +;;; handles is allocation of the result temporaries. +;;; +(define-vop (unknown-values-receiver) + (:results + (start :scs (any-reg)) + (count :scs (any-reg))) + (:temporary (:sc descriptor-reg :offset ocfp-offset + :from :eval :to (:result 0)) + values-start) + (:temporary (:sc any-reg :offset nargs-offset + :from :eval :to (:result 1)) + nvals) + (:temporary (:scs (non-descriptor-reg)) temp)) + + + +;;;; Local call with unknown values convention return: + +;;; Non-TR local call for a fixed number of values passed according to the +;;; unknown values convention. +;;; +;;; Args are the argument passing locations, which are specified only to +;;; terminate their lifetimes in the caller. +;;; +;;; Values are the return value locations (wired to the standard passing +;;; locations). +;;; +;;; Save is the save info, which we can ignore since saving has been done. +;;; Return-PC is the TN that the return PC should be passed in. +;;; Target is a continuation pointing to the start of the called function. +;;; Nvals is the number of values received. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (call-local) + (:args (fp) + (nfp) + (args :more t)) + (:results (values :more t)) + (:save-p t) + (:move-args :local-call) + (:info arg-locs callee target nvals) + (:vop-var vop) + (:temporary (:scs (descriptor-reg) :from (:eval 0)) move-temp) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:temporary (:sc any-reg :offset ocfp-offset :from (:eval 0)) ocfp) + (:ignore arg-locs args ocfp) + (:generator 5 + (trace-table-entry trace-table-call-site) + (let ((label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (let ((callee-nfp (callee-nfp-tn callee))) + (when callee-nfp + (maybe-load-stack-tn callee-nfp nfp))) + (maybe-load-stack-tn cfp-tn fp) + (inst compute-lra-from-code + (callee-return-pc-tn callee) code-tn label temp) + (note-this-location vop :call-site) + (inst b target) + (inst nop) + (emit-return-pc label) + (default-unknown-values vop values nvals move-temp temp label) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))) + (trace-table-entry trace-table-normal))) + + +;;; Non-TR local call for a variable number of return values passed according +;;; to the unknown values convention. The results are the start of the values +;;; glob and the number of values received. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (multiple-call-local unknown-values-receiver) + (:args (fp) + (nfp) + (args :more t)) + (:save-p t) + (:move-args :local-call) + (:info save callee target) + (:ignore args save) + (:vop-var vop) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:generator 20 + (trace-table-entry trace-table-call-site) + (let ((label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (let ((callee-nfp (callee-nfp-tn callee))) + (when callee-nfp + (maybe-load-stack-tn callee-nfp nfp))) + (maybe-load-stack-tn cfp-tn fp) + (inst compute-lra-from-code + (callee-return-pc-tn callee) code-tn label temp) + (note-this-location vop :call-site) + (inst b target) + (inst nop) + (emit-return-pc label) + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count label temp) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))) + (trace-table-entry trace-table-normal))) + + +;;;; Local call with known values return: + +;;; Non-TR local call with known return locations. Known-value return works +;;; just like argument passing in local call. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (known-call-local) + (:args (fp) + (nfp) + (args :more t)) + (:results (res :more t)) + (:move-args :local-call) + (:save-p t) + (:info save callee target) + (:ignore args res save) + (:vop-var vop) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 5 + (trace-table-entry trace-table-call-site) + (let ((label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (let ((callee-nfp (callee-nfp-tn callee))) + (when callee-nfp + (maybe-load-stack-tn callee-nfp nfp))) + (maybe-load-stack-tn cfp-tn fp) + (inst compute-lra-from-code + (callee-return-pc-tn callee) code-tn label temp) + (note-this-location vop :call-site) + (inst b target) + (inst nop) + (emit-return-pc label) + (note-this-location vop :known-return) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))) + (trace-table-entry trace-table-normal))) + +;;; Return from known values call. We receive the return locations as +;;; arguments to terminate their lifetimes in the returning function. We +;;; restore FP and CSP and jump to the Return-PC. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (known-return) + (:args (old-fp :target old-fp-temp) + (return-pc :target return-pc-temp) + (vals :more t)) + (:temporary (:sc any-reg :from (:argument 0)) old-fp-temp) + (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp) + (:move-args :known-return) + (:info val-locs) + (:ignore val-locs vals) + (:vop-var vop) + (:generator 6 + (trace-table-entry trace-table-function-epilogue) + (maybe-load-stack-tn old-fp-temp old-fp) + (maybe-load-stack-tn return-pc-temp return-pc) + (move csp-tn cfp-tn) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst add nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + (inst j return-pc-temp (- vm:word-bytes vm:other-pointer-type)) + (move cfp-tn old-fp-temp) + (trace-table-entry trace-table-normal))) + + +;;;; Full call: +;;; +;;; There is something of a cross-product effect with full calls. Different +;;; versions are used depending on whether we know the number of arguments or +;;; the name of the called function, and whether we want fixed values, unknown +;;; values, or a tail call. +;;; +;;; In full call, the arguments are passed creating a partial frame on the +;;; stack top and storing stack arguments into that frame. On entry to the +;;; callee, this partial frame is pointed to by FP. If there are no stack +;;; arguments, we don't bother allocating a partial frame, and instead set FP +;;; to SP just before the call. + +;;; Define-Full-Call -- Internal +;;; +;;; This macro helps in the definition of full call VOPs by avoiding code +;;; replication in defining the cross-product VOPs. +;;; +;;; Name is the name of the VOP to define. +;;; +;;; Named is true if the first argument is a symbol whose global function +;;; definition is to be called. +;;; +;;; Return is either :Fixed, :Unknown or :Tail: +;;; -- If :Fixed, then the call is for a fixed number of values, returned in +;;; the standard passing locations (passed as result operands). +;;; -- If :Unknown, then the result values are pushed on the stack, and the +;;; result values are specified by the Start and Count as in the +;;; unknown-values continuation representation. +;;; -- If :Tail, then do a tail-recursive call. No values are returned. +;;; The Old-Fp and Return-PC are passed as the second and third arguments. +;;; +;;; In non-tail calls, the pointer to the stack arguments is passed as the last +;;; fixed argument. If Variable is false, then the passing locations are +;;; passed as a more arg. Variable is true if there are a variable number of +;;; arguments passed on the stack. Variable cannot be specified with :Tail +;;; return. TR variable argument call is implemented separately. +;;; +;;; In tail call with fixed arguments, the passing locations are passed as a +;;; more arg, but there is no new-FP, since the arguments have been set up in +;;; the current frame. +;;; +(defmacro define-full-call (name named return variable) + (assert (not (and variable (eq return :tail)))) + `(define-vop (,name + ,@(when (eq return :unknown) + '(unknown-values-receiver))) + (:args + ,@(unless (eq return :tail) + '((new-fp :scs (any-reg) :to :eval))) + + ,(if named + '(name :target name-pass) + '(arg-fun :target lexenv)) + + ,@(when (eq return :tail) + '((old-fp :target old-fp-pass) + (return-pc :target return-pc-pass))) + + ,@(unless variable '((args :more t :scs (descriptor-reg))))) + + ,@(when (eq return :fixed) + '((:results (values :more t)))) + + (:save-p ,(if (eq return :tail) :compute-only t)) + + ,@(unless (or (eq return :tail) variable) + '((:move-args :full-call))) + + (:vop-var vop) + (:info ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(nargs)) + ,@(when (eq return :fixed) '(nvals))) + + (:ignore + ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(args))) + + (:temporary (:sc descriptor-reg + :offset ocfp-offset + :from (:argument 1) + ,@(unless (eq return :fixed) + '(:to :eval))) + old-fp-pass) + + (:temporary (:sc descriptor-reg + :offset lra-offset + :from (:argument ,(if (eq return :tail) 2 1)) + :to :eval) + return-pc-pass) + + ,(if named + `(:temporary (:sc descriptor-reg :offset cname-offset + :from (:argument ,(if (eq return :tail) 0 1)) + :to :eval) + name-pass) + `(:temporary (:sc descriptor-reg :offset lexenv-offset + :from (:argument ,(if (eq return :tail) 0 1)) + :to :eval) + lexenv)) + + (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval) + function) + (:temporary (:sc any-reg :offset nargs-offset :to :eval) + nargs-pass) + (:temporary (:scs (non-descriptor-reg)) temp) + + ,@(when variable + (mapcar #'(lambda (name offset) + `(:temporary (:sc descriptor-reg + :offset ,offset + :to :eval) + ,name)) + register-arg-names register-arg-offsets)) + ,@(when (eq return :fixed) + '((:temporary (:scs (descriptor-reg) :from :eval) move-temp))) + + ,@(unless (eq return :tail) + '((:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))) + + (:generator ,(+ (if named 5 0) + (if variable 19 1) + (if (eq return :tail) 0 10) + 15 + (if (eq return :unknown) 25 0)) + (trace-table-entry trace-table-call-site) + (let* ((cur-nfp (current-nfp-tn vop)) + ,@(unless (eq return :tail) + '((lra-label (gen-label)))) + (filler + (remove nil + (list :load-nargs + ,@(if (eq return :tail) + '((unless (location= old-fp old-fp-pass) + :load-old-fp) + (unless (location= return-pc + return-pc-pass) + :load-return-pc) + (when cur-nfp + :frob-nfp)) + '(:comp-lra + (when cur-nfp + :frob-nfp) + :save-fp + :load-fp)))))) + (flet ((do-next-filler () + (let* ((next (pop filler)) + (what (if (consp next) (car next) next))) + (ecase what + (:load-nargs + ,@(if variable + `((inst sub nargs-pass csp-tn new-fp) + ,@(let ((index -1)) + (mapcar #'(lambda (name) + `(loadw ,name new-fp + ,(incf index))) + register-arg-names))) + '((inst li nargs-pass (fixnumize nargs))))) + ,@(if (eq return :tail) + '((:load-old-fp + (sc-case old-fp + (any-reg + (inst move old-fp-pass old-fp)) + (control-stack + (loadw old-fp-pass cfp-tn + (tn-offset old-fp) 0 temp)))) + (:load-return-pc + (sc-case return-pc + (descriptor-reg + (inst move return-pc-pass return-pc)) + (control-stack + (loadw return-pc-pass cfp-tn + (tn-offset return-pc) 0 temp)))) + (:frob-nfp + (inst add nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + `((:comp-lra + (inst compute-lra-from-code + return-pc-pass code-tn lra-label temp)) + (:frob-nfp + (store-stack-tn nfp-save cur-nfp)) + (:save-fp + (inst move old-fp-pass cfp-tn)) + (:load-fp + ,(if variable + '(move cfp-tn new-fp) + '(if (> nargs register-arg-count) + (move cfp-tn new-fp) + (move cfp-tn csp-tn)))))) + ((nil)))))) + + ,@(if named + `((sc-case name + (descriptor-reg (move name-pass name)) + (control-stack + (loadw name-pass cfp-tn (tn-offset name) 0 temp) + (do-next-filler)) + (constant + (loadw name-pass code-tn (tn-offset name) + vm:other-pointer-type temp) + (do-next-filler))) + (loadw function name-pass fdefn-raw-addr-slot + other-pointer-type) + (do-next-filler)) + `((sc-case arg-fun + (descriptor-reg (move lexenv arg-fun)) + (control-stack + (loadw lexenv cfp-tn (tn-offset arg-fun) 0 temp) + (do-next-filler)) + (constant + (loadw lexenv code-tn (tn-offset arg-fun) + vm:other-pointer-type) + (do-next-filler))) + (loadw function lexenv vm:closure-function-slot + vm:function-pointer-type) + (do-next-filler))) + (loop + (if filler + (do-next-filler) + (return))) + + (note-this-location vop :call-site) + (inst j function + (- (ash vm:function-code-offset vm:word-shift) + vm:function-pointer-type)) + (inst move code-tn function)) + + ,@(ecase return + (:fixed + '((emit-return-pc lra-label) + (default-unknown-values vop values nvals move-temp + temp lra-label) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)))) + (:unknown + '((emit-return-pc lra-label) + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count + lra-label temp) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)))) + (:tail))) + (trace-table-entry trace-table-normal)))) + + +(define-full-call call nil :fixed nil) +(define-full-call call-named t :fixed nil) +(define-full-call multiple-call nil :unknown nil) +(define-full-call multiple-call-named t :unknown nil) +(define-full-call tail-call nil :tail nil) +(define-full-call tail-call-named t :tail nil) + +(define-full-call call-variable nil :fixed t) +(define-full-call multiple-call-variable nil :unknown t) + + +;;; Defined separately, since needs special code that BLT's the arguments +;;; down. +;;; +(define-vop (tail-call-variable) + (:args + (args-arg :scs (any-reg) :target args) + (function-arg :scs (descriptor-reg) :target lexenv) + (old-fp-arg :scs (any-reg) :target old-fp) + (lra-arg :scs (descriptor-reg) :target lra)) + + (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args) + (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv) + (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) old-fp) + (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra) + + (:temporary (:scs (any-reg) :from :eval) temp) + + (:vop-var vop) + + (:generator 75 + + ;; Move these into the passing locations if they are not already there. + (move args args-arg) + (move lexenv function-arg) + (move old-fp old-fp-arg) + (move lra lra-arg) + + ;; Clear the number stack if anything is there. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst add nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + + ;; And jump to the assembly-routine that does the bliting. + (inst ji temp (make-fixup 'tail-call-variable :assembly-routine)) + (inst nop))) + + +;;;; Unknown values return: + + +;;; Return a single value using the unknown-values convention. +;;; +(define-vop (return-single) + (:args (old-fp :scs (any-reg)) + (return-pc :scs (descriptor-reg)) + (value)) + (:ignore value) + (:vop-var vop) + (:generator 6 + (trace-table-entry trace-table-function-epilogue) + ;; Clear the number stack. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst add nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + ;; Clear the control stack, and restore the frame pointer. + (move csp-tn cfp-tn) + (move cfp-tn old-fp) + ;; Out of here. + (lisp-return return-pc :offset 2) + (trace-table-entry trace-table-normal))) + +;;; Do unknown-values return of a fixed number of values. The Values are +;;; required to be set up in the standard passing locations. Nvals is the +;;; number of values returned. +;;; +;;; If returning a single value, then deallocate the current frame, restore +;;; FP and jump to the single-value entry at Return-PC + 8. +;;; +;;; If returning other than one value, then load the number of values returned, +;;; NIL out unsupplied values registers, restore FP and return at Return-PC. +;;; When there are stack values, we must initialize the argument pointer to +;;; point to the beginning of the values block (which is the beginning of the +;;; current frame.) +;;; +(define-vop (return) + (:args + (old-fp :scs (any-reg)) + (return-pc :scs (descriptor-reg) :to (:eval 1)) + (values :more t)) + (:ignore values) + (:info nvals) + (:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0) + (:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1) + (:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2) + (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3) + (:temporary (:sc descriptor-reg :offset a4-offset :from (:eval 0)) a4) + (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5) + (:temporary (:sc any-reg :offset nargs-offset) nargs) + (:temporary (:sc any-reg :offset ocfp-offset) val-ptr) + (:vop-var vop) + (:generator 6 + (trace-table-entry trace-table-function-epilogue) + ;; Clear the number stack. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst add nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + (cond ((= nvals 1) + ;; Clear the control stack, and restore the frame pointer. + (move csp-tn cfp-tn) + (move cfp-tn old-fp) + ;; Out of here. + (lisp-return return-pc :offset 2)) + (t + ;; Establish the values pointer and values count. + (move val-ptr cfp-tn) + (inst li nargs (fixnumize nvals)) + ;; restore the frame pointer and clear as much of the control + ;; stack as possible. + (move cfp-tn old-fp) + (inst add csp-tn val-ptr (* nvals word-bytes)) + ;; pre-default any argument register that need it. + (when (< nvals register-arg-count) + (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals)) + (move reg null-tn))) + ;; And away we go. + (lisp-return return-pc))) + (trace-table-entry trace-table-normal))) + +;;; Do unknown-values return of an arbitrary number of values (passed on the +;;; stack.) We check for the common case of a single return value, and do that +;;; inline using the normal single value return convention. Otherwise, we +;;; branch off to code that calls an assembly-routine. +;;; +(define-vop (return-multiple) + (:args + (old-fp-arg :scs (any-reg) :to (:eval 1)) + (lra-arg :scs (descriptor-reg) :to (:eval 1)) + (vals-arg :scs (any-reg) :target vals) + (nvals-arg :scs (any-reg) :target nvals)) + + (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) old-fp) + (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra) + (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals) + (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals) + (:temporary (:sc descriptor-reg :offset a0-offset) a0) + + (:temporary (:scs (any-reg) :from (:eval 1)) temp) + + (:vop-var vop) + + (:generator 13 + (trace-table-entry trace-table-function-epilogue) + (let ((not-single (gen-label))) + ;; Clear the number stack. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst add nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + + ;; Check for the single case. + (inst cmp nvals-arg (fixnumize 1)) + (inst b :ne not-single) + (inst ldn a0 vals-arg) + + ;; Return with one value. + (move csp-tn cfp-tn) + (move cfp-tn old-fp-arg) + (lisp-return lra-arg :offset 2) + + ;; Nope, not the single case. + (emit-label not-single) + (move old-fp old-fp-arg) + (move lra lra-arg) + (move vals vals-arg) + (move nvals nvals-arg) + (inst ji temp (make-fixup 'return-multiple :assembly-routine)) + (inst nop)) + (trace-table-entry trace-table-normal))) + + + +;;;; XEP hackery: + + +;;; We don't need to do anything special for regular functions. +;;; +(define-vop (setup-environment) + (:info label) + (:ignore label) + (:generator 0 + ;; Don't bother doing anything. + )) + +;;; Get the lexical environment from it's passing location. +;;; +(define-vop (setup-closure-environment) + (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure + :to (:result 0)) + lexenv) + (:results (closure :scs (descriptor-reg))) + (:info label) + (:ignore label) + (:generator 6 + ;; Get result. + (move closure lexenv))) + +;;; Copy a more arg from the argument area to the end of the current frame. +;;; Fixed is the number of non-more arguments. +;;; +(define-vop (copy-more-arg) + (:temporary (:sc any-reg :offset nl0-offset) result) + (:temporary (:sc any-reg :offset nl1-offset) count) + (:temporary (:sc any-reg :offset nl2-offset) src) + (:temporary (:sc any-reg :offset nl3-offset) dst) + (:temporary (:sc descriptor-reg :offset cname-offset) temp) + (:info fixed) + (:generator 20 + (let ((loop (gen-label)) + (do-regs (gen-label)) + (done (gen-label))) + (when (< fixed register-arg-count) + ;; Save a pointer to the results so we can fill in register args. + ;; We don't need this if there are more fixed args than reg args. + (move result csp-tn)) + ;; Allocate the space on the stack. + (cond ((zerop fixed) + (inst cmp nargs-tn) + (inst b :eq done) + (inst add csp-tn csp-tn nargs-tn)) + (t + (inst subcc count nargs-tn (fixnumize fixed)) + (inst b :le done) + (inst nop) + (inst add csp-tn csp-tn count))) + (when (< fixed register-arg-count) + ;; We must stop when we run out of stack args, not when we run out of + ;; more args. + (inst subcc count nargs-tn (fixnumize register-arg-count)) + ;; Everything of interest in registers. + (inst b :le do-regs)) + ;; Initialize dst to be end of stack. + (move dst csp-tn) + ;; Initialize src to be end of args. + (inst add src cfp-tn nargs-tn) + + (emit-label loop) + ;; *--dst = *--src, --count + (inst add src src (- vm:word-bytes)) + (inst subcc count count (fixnumize 1)) + (loadw temp src) + (inst add dst dst (- vm:word-bytes)) + (inst b :gt loop) + (storew temp dst) + + (emit-label do-regs) + (when (< fixed register-arg-count) + ;; Now we have to deposit any more args that showed up in registers. + (inst subcc count nargs-tn (fixnumize fixed)) + (do ((i fixed (1+ i))) + ((>= i register-arg-count)) + ;; Don't deposit any more than there are. + (inst b :eq done) + (inst subcc count (fixnumize 1)) + ;; Store it relative to the pointer saved at the start. + (storew (nth i register-arg-tns) result (- i fixed)))) + (emit-label done)))) + + +;;; More args are stored consequtively on the stack, starting immediately at +;;; the context pointer. The context pointer is not typed, so the lowtag is 0. +;;; +(define-vop (more-arg word-index-ref) + (:variant 0 0) + (:translate %more-arg)) + + +;;; Turn more arg (context, count) into a list. +;;; +(define-vop (listify-rest-args) + (:args (context-arg :target context :scs (descriptor-reg)) + (count-arg :target count :scs (any-reg))) + (:arg-types * tagged-num (:constant t)) + (:info dynamic-extent) + (:temporary (:scs (any-reg) :from (:argument 0)) context) + (:temporary (:scs (any-reg) :from (:argument 1)) count) + (:temporary (:scs (descriptor-reg) :from :eval) temp) + (:temporary (:scs (non-descriptor-reg) :from :eval) dst) + (:results (result :scs (descriptor-reg))) + (:translate %listify-rest-args) + (:policy :safe) + (:generator 20 + (move context context-arg) + (move count count-arg) + ;; Check to see if there are any arguments. + (inst cmp count) + (inst b :eq done) + (move result null-tn) + + ;; We need to do this atomically. + (pseudo-atomic () + (assemble () + ;; Allocate a cons (2 words) for each item. + (inst slln temp count 1) + (allocation result temp list-pointer-type + :stack-p dynamic-extent + :temp-tn dst) + (inst b enter) + (move dst result) + + + ;; Compute the next cons and store it in the current one. + LOOP + (inst add dst dst (* 2 vm:word-bytes)) + (storew dst dst -1 vm:list-pointer-type) + + ;; Grab one value. + ENTER + (loadw temp context) + (inst add context context vm:word-bytes) + + ;; Dec count, and if != zero, go back for more. + (inst subcc count (fixnumize 1)) + (inst b :gt loop) + + ;; Store the value into the car of the current cons (in the delay + ;; slot). + (storew temp dst 0 vm:list-pointer-type) + + ;; NIL out the last cons. + (storew null-tn dst 1 vm:list-pointer-type))) + DONE)) + + +;;; Return the location and size of the more arg glob created by Copy-More-Arg. +;;; Supplied is the total number of arguments supplied (originally passed in +;;; NARGS.) Fixed is the number of non-rest arguments. +;;; +;;; We must duplicate some of the work done by Copy-More-Arg, since at that +;;; time the environment is in a pretty brain-damaged state, preventing this +;;; info from being returned as values. What we do is compute +;;; supplied - fixed, and return a pointer that many words below the current +;;; stack top. +;;; +(define-vop (more-arg-context) + (:policy :fast-safe) + (:translate c::%more-arg-context) + (:args (supplied :scs (any-reg))) + (:arg-types tagged-num (:constant fixnum)) + (:info fixed) + (:results (context :scs (descriptor-reg)) + (count :scs (any-reg))) + (:result-types t tagged-num) + (:note _N"more-arg-context") + (:generator 5 + (inst sub count supplied (fixnumize fixed)) + (inst sub context csp-tn count))) + + +;;; Signal wrong argument count error if Nargs isn't = to Count. +;;; +(define-vop (verify-argument-count) + (:policy :fast-safe) + (:translate c::%verify-argument-count) + (:args (nargs :scs (any-reg))) + (:arg-types positive-fixnum (:constant t)) + (:info count) + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + (let ((err-lab + (generate-error-code vop invalid-argument-count-error nargs))) + (inst cmp nargs (fixnumize count)) + ;; Assume we don't take the branch + (inst b :ne err-lab #+sparc-v9 :pn) + (inst nop)))) + +;;; Signal various errors. +;;; +(macrolet ((frob (name error translate &rest args) + `(define-vop (,name) + ,@(when translate + `((:policy :fast-safe) + (:translate ,translate))) + (:args ,@(mapcar #'(lambda (arg) + `(,arg :scs (any-reg descriptor-reg))) + args)) + (:vop-var vop) + (:save-p :compute-only) + (:generator 1000 + (error-call vop ,error ,@args))))) + (frob argument-count-error invalid-argument-count-error + c::%argument-count-error nargs) + (frob type-check-error object-not-type-error c::%type-check-error + object type) + (frob layout-invalid-error layout-invalid-error c::%layout-invalid-error + object layout) + (frob odd-keyword-arguments-error odd-keyword-arguments-error + c::%odd-keyword-arguments-error) + (frob unknown-keyword-argument-error unknown-keyword-argument-error + c::%unknown-keyword-argument-error key) + (frob nil-function-returned-error nil-function-returned-error nil fun)) diff --git a/src/compiler/sparcv9/cell.lisp b/src/compiler/sparcv9/cell.lisp new file mode 100644 index 0000000000000000000000000000000000000000..448775c9084f039fa0f2f94e7a7cbd5ff733686e --- /dev/null +++ b/src/compiler/sparcv9/cell.lisp @@ -0,0 +1,319 @@ +;;; -*- 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/compiler/sparc/cell.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of various primitive memory access +;;; VOPs for the SPARC. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted by William Lott. +;;; + +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") + + +;;;; Data object ref/set stuff. + +(define-vop (slot) + (:args (object :scs (descriptor-reg))) + (:info name offset lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg any-reg))) + (:generator 1 + (loadw result object offset lowtag))) + +(define-vop (set-slot) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:info name offset lowtag) + (:ignore name) + (:results) + (:generator 1 + (storew value object offset lowtag))) + + + +;;;; Symbol hacking VOPs: + +;;; The compiler likes to be able to directly SET symbols. +;;; +(define-vop (set cell-set) + (:variant symbol-value-slot other-pointer-type)) + +;;; Do a cell ref with an error check for being unbound. +;;; +(define-vop (checked-cell-ref) + (:args (object :scs (descriptor-reg) :target obj-temp)) + (:results (value :scs (descriptor-reg any-reg))) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)) + +;;; With Symbol-Value, we check that the value isn't the trap object. So +;;; Symbol-Value of NIL is NIL. +;;; +(define-vop (symbol-value checked-cell-ref) + (:translate symbol-value) + (:generator 9 + (move obj-temp object) + (loadw value obj-temp vm:symbol-value-slot vm:other-pointer-type) + (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp))) + (inst cmp value vm:unbound-marker-type) + (inst b :eq err-lab) + (inst nop)))) + +;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound. +(define-vop (boundp-frob) + (:args (object :scs (descriptor-reg))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:temporary (:scs (descriptor-reg)) value)) + +(define-vop (boundp boundp-frob) + (:translate boundp) + (:generator 9 + (loadw value object vm:symbol-value-slot vm:other-pointer-type) + (inst cmp value vm:unbound-marker-type) + (inst b (if not-p :eq :ne) target) + (inst nop))) + +(define-vop (fast-symbol-value cell-ref) + (:variant vm:symbol-value-slot vm:other-pointer-type) + (:policy :fast) + (:translate symbol-value)) + +(define-vop (symbol-hash) + (:policy :fast-safe) + (:translate symbol-hash) + (:args (symbol :scs (descriptor-reg null))) + (:results (res :scs (any-reg))) + (:result-types tagged-num) + (:generator 2 + ;; the symbol-hash slot of NIL holds NIL because it is also the cdr + ;; slot, so we have to strip off the two low bits to make sure it is + ;; a fixnum. + (loadw res symbol symbol-hash-slot other-pointer-type) + (inst andn res vm:fixnum-tag-mask))) + +(define-vop (%set-symbol-hash cell-set) + (:translate %set-symbol-hash) + (:variant symbol-hash-slot other-pointer-type)) + + +;;;; Fdefinition (fdefn) objects. + +(define-vop (fdefn-function cell-ref) + (:variant fdefn-function-slot other-pointer-type)) + +(define-vop (safe-fdefn-function) + (:args (object :scs (descriptor-reg) :target obj-temp)) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp) + (:generator 10 + (move obj-temp object) + (loadw value obj-temp fdefn-function-slot other-pointer-type) + (inst cmp value null-tn) + (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp))) + (inst b :eq err-lab)) + (inst nop))) + +(define-vop (set-fdefn-function) + (:policy :fast-safe) + (:translate (setf fdefn-function)) + (:args (function :scs (descriptor-reg) :target result) + (fdefn :scs (descriptor-reg))) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (non-descriptor-reg)) type) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (let ((normal-fn (gen-label))) + (load-type type function (- function-pointer-type)) + (inst cmp type function-header-type) + (inst b :eq normal-fn) + (inst move temp function) + (inst li temp (make-fixup 'closure-tramp + :assembly-routine)) + (emit-label normal-fn) + (storew function fdefn fdefn-function-slot other-pointer-type) + (storew temp fdefn fdefn-raw-addr-slot other-pointer-type) + (move result function)))) + +(define-vop (fdefn-makunbound) + (:policy :fast-safe) + (:translate fdefn-makunbound) + (:args (fdefn :scs (descriptor-reg) :target result)) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (storew null-tn fdefn fdefn-function-slot other-pointer-type) + (inst li temp (make-fixup 'undefined-tramp + :assembly-routine)) + (storew temp fdefn fdefn-raw-addr-slot other-pointer-type) + (move result fdefn))) + + + +;;;; Binding and Unbinding. + +;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and +;;; the symbol on the binding stack and stuff the new value into the +;;; symbol. + +(define-vop (bind) + (:args (val :scs (any-reg descriptor-reg)) + (symbol :scs (descriptor-reg))) + (:temporary (:scs (descriptor-reg)) temp) + (:generator 5 + (loadw temp symbol vm:symbol-value-slot vm:other-pointer-type) + (inst add bsp-tn bsp-tn (* 2 vm:word-bytes)) + (storew temp bsp-tn (- vm:binding-value-slot vm:binding-size)) + (storew symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size)) + (storew val symbol vm:symbol-value-slot vm:other-pointer-type))) + + +(define-vop (unbind) + (:temporary (:scs (descriptor-reg)) symbol value) + (:generator 0 + (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size)) + (loadw value bsp-tn (- vm:binding-value-slot vm:binding-size)) + (storew value symbol vm:symbol-value-slot vm:other-pointer-type) + (storew zero-tn bsp-tn (- vm:binding-symbol-slot vm:binding-size)) + (inst sub bsp-tn bsp-tn (* 2 vm:word-bytes)))) + + +(define-vop (unbind-to-here) + (:args (arg :scs (descriptor-reg any-reg) :target where)) + (:temporary (:scs (any-reg) :from (:argument 0)) where) + (:temporary (:scs (descriptor-reg)) symbol value) + (:generator 0 + (let ((loop (gen-label)) + (skip (gen-label)) + (done (gen-label))) + (move where arg) + (inst cmp where bsp-tn) + (inst b :eq done) + (inst nop) + + (emit-label loop) + (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size)) + (inst cmp symbol) + (inst b :eq skip) + (loadw value bsp-tn (- vm:binding-value-slot vm:binding-size)) + (storew value symbol vm:symbol-value-slot vm:other-pointer-type) + (storew zero-tn bsp-tn (- vm:binding-symbol-slot vm:binding-size)) + + (emit-label skip) + (inst sub bsp-tn bsp-tn (* 2 vm:word-bytes)) + (inst cmp where bsp-tn) + (inst b :ne loop) + (inst nop) + + (emit-label done)))) + + + +;;;; Closure indexing. + +(define-vop (closure-index-ref word-index-ref) + (:variant vm:closure-info-offset vm:function-pointer-type) + (:translate %closure-index-ref)) + +(define-vop (funcallable-instance-info word-index-ref) + (:variant funcallable-instance-info-offset vm:function-pointer-type) + (:translate %funcallable-instance-info)) + +(define-vop (set-funcallable-instance-info word-index-set) + (:variant funcallable-instance-info-offset function-pointer-type) + (:translate %set-funcallable-instance-info)) + +(define-vop (funcallable-instance-lexenv cell-ref) + (:variant funcallable-instance-lexenv-slot function-pointer-type)) + + +(define-vop (closure-ref slot-ref) + (:variant closure-info-offset function-pointer-type)) + +(define-vop (closure-init slot-set) + (:variant closure-info-offset function-pointer-type)) + + +;;;; Value Cell hackery. + +(define-vop (value-cell-ref cell-ref) + (:variant value-cell-value-slot other-pointer-type)) + +(define-vop (value-cell-set cell-set) + (:variant value-cell-value-slot other-pointer-type)) + + + +;;;; Instance hackery: + +(define-vop (instance-length) + (:policy :fast-safe) + (:translate %instance-length) + (:args (struct :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 4 + (loadw temp struct 0 instance-pointer-type) + (inst srln res temp vm:type-bits))) + +(define-vop (instance-ref slot-ref) + (:variant instance-slots-offset instance-pointer-type) + (:policy :fast-safe) + (:translate %instance-ref) + (:arg-types instance (:constant index))) + +(define-vop (instance-set slot-set) + (:policy :fast-safe) + ;; This is an invalid translation because %instance-set needs a + ;; return value, and this VOP doesn't return anything. I (RLT) + ;; don't know how to fix this so that this VOP returns a value and + ;; still works correctly when it is called directly by the compiler. + ;; However, disabling the translation works around the bug. + + ;;(:translate %instance-set) + (:variant instance-slots-offset instance-pointer-type) + (:arg-types instance (:constant index) *)) + +(define-vop (instance-index-ref word-index-ref) + (:policy :fast-safe) + (:translate %instance-ref) + (:variant instance-slots-offset instance-pointer-type) + (:arg-types instance positive-fixnum)) + +(define-vop (instance-index-set word-index-set) + (:policy :fast-safe) + (:translate %instance-set) + (:variant instance-slots-offset instance-pointer-type) + (:arg-types instance positive-fixnum *)) + + + +;;;; Code object frobbing. + +(define-vop (code-header-ref word-index-ref) + (:translate code-header-ref) + (:policy :fast-safe) + (:variant 0 other-pointer-type)) + +(define-vop (code-header-set word-index-set) + (:translate code-header-set) + (:policy :fast-safe) + (:variant 0 other-pointer-type)) + diff --git a/src/compiler/sparcv9/char.lisp b/src/compiler/sparcv9/char.lisp new file mode 100644 index 0000000000000000000000000000000000000000..5ab27789f9c1969cd53f8c533950233c20b002c2 --- /dev/null +++ b/src/compiler/sparcv9/char.lisp @@ -0,0 +1,173 @@ +;;; -*- 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/compiler/sparc/char.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the SPARC VM definition of character operations. +;;; +;;; Written by Rob MacLachlan +;;; Converted for the MIPS R2000 by Christopher Hoover. +;;; And then to the SPARC by William Lott. +;;; +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") + + + +;;;; Moves and coercions: + +;;; Move a tagged char to an untagged representation. +;;; +(define-vop (move-to-base-char) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (base-char-reg))) + (:note _N"character untagging") + (:generator 1 + (inst srln y x vm:type-bits))) +;;; +(define-move-vop move-to-base-char :move + (any-reg descriptor-reg) (base-char-reg)) + + +;;; Move an untagged char to a tagged representation. +;;; +(define-vop (move-from-base-char) + (:args (x :scs (base-char-reg))) + (:results (y :scs (any-reg descriptor-reg))) + (:note _N"character tagging") + (:generator 1 + (inst slln y x vm:type-bits) + (inst or y vm:base-char-type))) +;;; +(define-move-vop move-from-base-char :move + (base-char-reg) (any-reg descriptor-reg)) + +;;; Move untagged base-char values. +;;; +(define-vop (base-char-move) + (:args (x :target y + :scs (base-char-reg) + :load-if (not (location= x y)))) + (:results (y :scs (base-char-reg) + :load-if (not (location= x y)))) + (:note _N"character move") + (:effects) + (:affected) + (:generator 0 + (move y x))) +;;; +(define-move-vop base-char-move :move + (base-char-reg) (base-char-reg)) + + +;;; Move untagged base-char arguments/return-values. +;;; +(define-vop (move-base-char-argument) + (:args (x :target y + :scs (base-char-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y base-char-reg)))) + (:results (y)) + (:temporary (:sc non-descriptor-reg) temp) + (:note _N"character arg move") + (:generator 0 + (sc-case y + (base-char-reg + (move y x)) + (base-char-stack + (storew x fp (tn-offset y) 0 temp))))) +;;; +(define-move-vop move-base-char-argument :move-argument + (any-reg base-char-reg) (base-char-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char +;;; to a descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (base-char-reg) (any-reg descriptor-reg)) + + + +;;;; Other operations: + +(define-vop (char-code) + (:translate char-code) + (:policy :fast-safe) + (:args (ch :scs (base-char-reg) :target res)) + (:arg-types base-char) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:generator 1 + (inst slln res ch fixnum-tag-bits))) + +(define-vop (code-char) + (:translate code-char) + (:policy :fast-safe) + (:args (code :scs (any-reg) :target res)) + (:arg-types positive-fixnum) + (:results (res :scs (base-char-reg))) + (:result-types base-char) + (:generator 1 + (inst srln res code fixnum-tag-bits))) + + +;;; Comparison of base-chars. +;;; +(define-vop (base-char-compare) + (:args (x :scs (base-char-reg)) + (y :scs (base-char-reg))) + (:arg-types base-char base-char) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note _N"inline comparison") + (:variant-vars condition not-condition) + (:generator 3 + (inst cmp x y) + (inst b (if not-p not-condition condition) target) + (inst nop))) + +(define-vop (fast-char=/base-char base-char-compare) + (:translate char=) + (:variant :eq :ne)) + +(define-vop (fast-char</base-char base-char-compare) + (:translate char<) + (:variant :ltu :geu)) + +(define-vop (fast-char>/base-char base-char-compare) + (:translate char>) + (:variant :gtu :leu)) + +(define-vop (base-char-compare-c) + (:args (x :scs (base-char-reg))) + (:arg-types base-char (:constant base-char)) + (:conditional) + (:info target not-p y) + (:policy :fast-safe) + (:note _N"inline comparison") + (:variant-vars condition not-condition) + (:generator 2 + (inst cmp x (char-code y)) + (inst b (if not-p not-condition condition) target) + (inst nop))) + +(define-vop (fast-char=-c/base-char base-char-compare-c) + (:translate char=) + (:variant :eq :ne)) + +(define-vop (fast-char<-c/base-char base-char-compare-c) + (:translate char<) + (:variant :ltu :geu)) + +(define-vop (fast-char>-c/base-char base-char-compare-c) + (:translate char>) + (:variant :gtu :leu)) + diff --git a/src/compiler/sparcv9/debug.lisp b/src/compiler/sparcv9/debug.lisp new file mode 100644 index 0000000000000000000000000000000000000000..fe18d015ed74db4358604ad8c7131506a0820d2b --- /dev/null +++ b/src/compiler/sparcv9/debug.lisp @@ -0,0 +1,127 @@ +;;; -*- 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/compiler/sparc/debug.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; Compiler support for the new whizzy debugger. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") + +(defknown di::current-sp () system-area-pointer (movable flushable)) +(defknown di::current-fp () system-area-pointer (movable flushable)) +(defknown di::stack-ref (system-area-pointer index) t (flushable)) +(defknown di::%set-stack-ref (system-area-pointer index t) t (unsafe)) +(defknown di::lra-code-header (t) t (movable flushable)) +(defknown di::function-code-header (t) t (movable flushable)) +(defknown di::make-lisp-obj ((unsigned-byte 32)) t (movable flushable)) +(defknown di::get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable)) +(defknown di::function-word-offset (function) index (movable flushable)) + +(define-vop (debug-cur-sp) + (:translate di::current-sp) + (:policy :fast-safe) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 1 + (move res csp-tn))) + +(define-vop (debug-cur-fp) + (:translate di::current-fp) + (:policy :fast-safe) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 1 + (move res cfp-tn))) + +(define-vop (read-control-stack) + (:translate kernel:stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (any-reg))) + (:arg-types system-area-pointer positive-fixnum) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 5 + (inst ldn result sap offset))) + +(define-vop (write-control-stack) + (:translate kernel:%set-stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (any-reg)) + (value :scs (descriptor-reg) :target result)) + (:arg-types system-area-pointer positive-fixnum *) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 5 + (inst stn value sap offset) + (move result value))) + +(define-vop (code-from-mumble) + (:policy :fast-safe) + (:args (thing :scs (descriptor-reg))) + (:results (code :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:variant-vars lowtag) + (:generator 5 + (let ((bogus (gen-label)) + (done (gen-label))) + (loadw temp thing 0 lowtag) + (inst srln temp vm:type-bits) + (inst cmp temp) + (inst b :eq bogus) + (inst slln temp (1- (integer-length vm:word-bytes))) + (unless (= lowtag vm:other-pointer-type) + (inst add temp (- lowtag vm:other-pointer-type))) + (inst sub code thing temp) + (emit-label done) + (assemble (*elsewhere*) + (emit-label bogus) + (inst b done) + (move code null-tn))))) + +(define-vop (code-from-lra code-from-mumble) + (:translate di::lra-code-header) + (:variant vm:other-pointer-type)) + +(define-vop (code-from-function code-from-mumble) + (:translate di::function-code-header) + (:variant vm:function-pointer-type)) + +(define-vop (make-lisp-obj) + (:policy :fast-safe) + (:translate di::make-lisp-obj) + (:args (value :scs (unsigned-reg) :target result)) + (:arg-types unsigned-num) + (:results (result :scs (descriptor-reg))) + (:generator 1 + (move result value))) + +(define-vop (get-lisp-obj-address) + (:policy :fast-safe) + (:translate di::get-lisp-obj-address) + (:args (thing :scs (descriptor-reg) :target result)) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (move result thing))) + + +(define-vop (function-word-offset) + (:policy :fast-safe) + (:translate di::function-word-offset) + (:args (fun :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 5 + (loadw res fun 0 function-pointer-type) + (inst srln res vm:type-bits))) diff --git a/src/compiler/sparcv9/float.lisp b/src/compiler/sparcv9/float.lisp new file mode 100644 index 0000000000000000000000000000000000000000..dcdbda7d5fd5b68d0a444eb0c804e652649713e9 --- /dev/null +++ b/src/compiler/sparcv9/float.lisp @@ -0,0 +1,3188 @@ +;;; -*- 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/compiler/sparc/float.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains floating point support for the MIPS. +;;; +;;; Written by Rob MacLachlan +;;; Sparc conversion by William Lott. +;;; Complex-float and long-float support by Douglas Crosher 1998. +;;; +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") + + +;;;; Move functions: + +(define-move-function (load-single 1) (vop x y) + ((single-stack) (single-reg)) + (inst ldf y (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))) + +(define-move-function (store-single 1) (vop x y) + ((single-reg) (single-stack)) + (inst stf x (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))) + + +(define-move-function (load-double 2) (vop x y) + ((double-stack) (double-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) vm:word-bytes))) + (inst lddf y nfp offset))) + +(define-move-function (store-double 2) (vop x y) + ((double-reg) (double-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) vm:word-bytes))) + (inst stdf x nfp offset))) + +;;; The offset may be an integer or a TN in which case it will be +;;; temporarily modified but is restored if restore-offset is true. +;;; +(defun load-long-reg (reg base offset &optional (restore-offset t)) + (if (backend-featurep :sparc-v9) + (inst ldqf reg base offset) + (let ((reg0 (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset reg))) + (reg2 (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 2 (tn-offset reg))))) + (cond ((integerp offset) + (inst lddf reg0 base offset) + (inst lddf reg2 base (+ offset (* 2 vm:word-bytes)))) + (t + (inst lddf reg0 base offset) + (inst add offset (* 2 vm:word-bytes)) + (inst lddf reg2 base offset) + (when restore-offset + (inst sub offset (* 2 vm:word-bytes)))))))) + +#+long-float +(define-move-function (load-long 2) (vop x y) + ((long-stack) (long-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) vm:word-bytes))) + (load-long-reg y nfp offset))) + +;;; The offset may be an integer or a TN in which case it will be +;;; temporarily modified but is restored if restore-offset is true. +;;; +(defun store-long-reg (reg base offset &optional (restore-offset t)) + (if (backend-featurep :sparc-v9) + (inst stqf reg base offset) + (let ((reg0 (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset reg))) + (reg2 (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 2 (tn-offset reg))))) + (cond ((integerp offset) + (inst stdf reg0 base offset) + (inst stdf reg2 base (+ offset (* 2 vm:word-bytes)))) + (t + (inst stdf reg0 base offset) + (inst add offset (* 2 vm:word-bytes)) + (inst stdf reg2 base offset) + (when restore-offset + (inst sub offset (* 2 vm:word-bytes)))))))) + +#+long-float +(define-move-function (store-long 2) (vop x y) + ((long-reg) (long-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) vm:word-bytes))) + (store-long-reg x nfp offset))) + + +;;;; Move VOPs: + +;;; Exploit the V9 double-float move instruction. This is conditional +;;; on the :sparc-v9 feature. +(defun move-double-reg (dst src) + (cond ((backend-featurep :sparc-v9) + (unless (location= dst src) + (inst fmovd dst src))) + (t + (dotimes (i 2) + (let ((dst (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ i (tn-offset dst)))) + (src (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ i (tn-offset src))))) + (inst fmovs dst src)))))) + +;;; Exploit the V9 long-float move instruction. This is conditional +;;; on the :sparc-v9 feature. +(defun move-long-reg (dst src) + (cond ((backend-featurep :sparc-v9) + (inst fmovq dst src)) + (t + (dotimes (i 4) + (let ((dst (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ i (tn-offset dst)))) + (src (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ i (tn-offset src))))) + (inst fmovs dst src)))))) + +(macrolet ((frob (vop sc format) + `(progn + (define-vop (,vop) + (:args (x :scs (,sc) + :target y + :load-if (not (location= x y)))) + (:results (y :scs (,sc) + :load-if (not (location= x y)))) + (:note _N"float move") + (:generator 0 + (unless (location= y x) + ,@(ecase format + (:single `((inst fmovs y x))) + (:double `((move-double-reg y x))) + (:long `((move-long-reg y x))))))) + (define-move-vop ,vop :move (,sc) (,sc))))) + (frob single-move single-reg :single) + (frob double-move double-reg :double) + #+long-float + (frob long-move long-reg :long)) + + +(define-vop (move-from-float) + (:args (x :to :save)) + (:results (y)) + (:note _N"float to pointer coercion") + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:variant-vars format size type data) + (:generator 13 + (with-fixed-allocation (y ndescr type size)) + (ecase format + (:single + (inst stf x y (- (* data vm:word-bytes) vm:other-pointer-type))) + (:double + (inst stdf x y (- (* data vm:word-bytes) vm:other-pointer-type))) + (:long + (store-long-reg x y (- (* data vm:word-bytes) + vm:other-pointer-type)))))) + +(macrolet ((frob (name sc &rest args) + `(progn + (define-vop (,name move-from-float) + (:args (x :scs (,sc) :to :save)) + (:results (y :scs (descriptor-reg))) + (:variant ,@args)) + (define-move-vop ,name :move (,sc) (descriptor-reg))))) + (frob move-from-single single-reg :single + vm:single-float-size vm:single-float-type vm:single-float-value-slot) + (frob move-from-double double-reg :double + vm:double-float-size vm:double-float-type vm:double-float-value-slot) + #+long-float + (frob move-from-long long-reg :long + vm:long-float-size vm:long-float-type vm:long-float-value-slot)) + +(macrolet ((frob (name sc format value) + `(progn + (define-vop (,name) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (,sc))) + (:note _N"pointer to float coercion") + (:generator 2 + (inst ,(ecase format + (:single 'ldf) + (:double 'lddf)) + y x + (- (* ,value vm:word-bytes) vm:other-pointer-type)))) + (define-move-vop ,name :move (descriptor-reg) (,sc))))) + (frob move-to-single single-reg :single vm:single-float-value-slot) + (frob move-to-double double-reg :double vm:double-float-value-slot)) + +#+long-float +(define-vop (move-to-long) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (long-reg))) + (:note _N"pointer to float coercion") + (:generator 2 + (load-long-reg y x (- (* vm:long-float-value-slot vm:word-bytes) + vm:other-pointer-type)))) +#+long-float +(define-move-vop move-to-long :move (descriptor-reg) (long-reg)) + +(macrolet ((frob (name sc stack-sc format) + `(progn + (define-vop (,name) + (:args (x :scs (,sc) :target y) + (nfp :scs (any-reg) + :load-if (not (sc-is y ,sc)))) + (:results (y)) + (:note _N"float argument move") + (:generator ,(ecase format (:single 1) (:double 2)) + (sc-case y + (,sc + (unless (location= x y) + ,@(ecase format + (:single '((inst fmovs y x))) + (:double '((move-double-reg y x)))))) + (,stack-sc + (let ((offset (* (tn-offset y) vm:word-bytes))) + (inst ,(ecase format + (:single 'stf) + (:double 'stdf)) + x nfp offset)))))) + (define-move-vop ,name :move-argument + (,sc descriptor-reg) (,sc))))) + (frob move-single-float-argument single-reg single-stack :single) + (frob move-double-float-argument double-reg double-stack :double)) + +#+long-float +(define-vop (move-long-float-argument) + (:args (x :scs (long-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y long-reg)))) + (:results (y)) + (:note _N"float argument move") + (:generator 3 + (sc-case y + (long-reg + (unless (location= x y) + (move-long-reg y x))) + (long-stack + (let ((offset (* (tn-offset y) vm:word-bytes))) + (store-long-reg x nfp offset)))))) +;;; +#+long-float +(define-move-vop move-long-float-argument :move-argument + (long-reg descriptor-reg) (long-reg)) + + +;;;; Complex float move functions + +(defun complex-single-reg-real-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg *backend*) + :offset (tn-offset x))) +(defun complex-single-reg-imag-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg *backend*) + :offset (1+ (tn-offset x)))) + +(defun complex-double-reg-real-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset x))) +(defun complex-double-reg-imag-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ (tn-offset x) 2))) + +#+long-float +(defun complex-long-reg-real-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*) + :offset (tn-offset x))) +#+long-float +(defun complex-long-reg-imag-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*) + :offset (+ (tn-offset x) 4))) + +#+double-double +(progn +(defun complex-double-double-reg-real-hi-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset x))) +(defun complex-double-double-reg-real-lo-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 2 (tn-offset x)))) +(defun complex-double-double-reg-imag-hi-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 4 (tn-offset x)))) +(defun complex-double-double-reg-imag-lo-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 6 (tn-offset x)))) +) + +(define-move-function (load-complex-single 2) (vop x y) + ((complex-single-stack) (complex-single-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) vm:word-bytes))) + (let ((real-tn (complex-single-reg-real-tn y))) + (inst ldf real-tn nfp offset)) + (let ((imag-tn (complex-single-reg-imag-tn y))) + (inst ldf imag-tn nfp (+ offset vm:word-bytes))))) + +(define-move-function (store-complex-single 2) (vop x y) + ((complex-single-reg) (complex-single-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) vm:word-bytes))) + (let ((real-tn (complex-single-reg-real-tn x))) + (inst stf real-tn nfp offset)) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (inst stf imag-tn nfp (+ offset vm:word-bytes))))) + + +(define-move-function (load-complex-double 4) (vop x y) + ((complex-double-stack) (complex-double-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) vm:word-bytes))) + (let ((real-tn (complex-double-reg-real-tn y))) + (inst lddf real-tn nfp offset)) + (let ((imag-tn (complex-double-reg-imag-tn y))) + (inst lddf imag-tn nfp (+ offset (* 2 vm:word-bytes)))))) + +(define-move-function (store-complex-double 4) (vop x y) + ((complex-double-reg) (complex-double-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) vm:word-bytes))) + (let ((real-tn (complex-double-reg-real-tn x))) + (inst stdf real-tn nfp offset)) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (inst stdf imag-tn nfp (+ offset (* 2 vm:word-bytes)))))) + + +#+long-float +(define-move-function (load-complex-long 5) (vop x y) + ((complex-long-stack) (complex-long-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) vm:word-bytes))) + (let ((real-tn (complex-long-reg-real-tn y))) + (load-long-reg real-tn nfp offset)) + (let ((imag-tn (complex-long-reg-imag-tn y))) + (load-long-reg imag-tn nfp (+ offset (* 4 vm:word-bytes)))))) + +#+long-float +(define-move-function (store-complex-long 5) (vop x y) + ((complex-long-reg) (complex-long-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) vm:word-bytes))) + (let ((real-tn (complex-long-reg-real-tn x))) + (store-long-reg real-tn nfp offset)) + (let ((imag-tn (complex-long-reg-imag-tn x))) + (store-long-reg imag-tn nfp (+ offset (* 4 vm:word-bytes)))))) + +#+double-double +(progn +(define-move-function (load-complex-double-double 4) (vop x y) + ((complex-double-double-stack) (complex-double-double-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) vm:word-bytes))) + (let ((value-tn (complex-double-double-reg-real-hi-tn y))) + (inst lddf value-tn nfp offset)) + (let ((value-tn (complex-double-double-reg-real-lo-tn y))) + (inst lddf value-tn nfp (+ offset (* 2 vm:word-bytes)))) + (let ((value-tn (complex-double-double-reg-imag-hi-tn y))) + (inst lddf value-tn nfp (+ offset (* 4 vm:word-bytes)))) + (let ((value-tn (complex-double-double-reg-imag-lo-tn y))) + (inst lddf value-tn nfp (+ offset (* 6 vm:word-bytes)))))) + +(define-move-function (store-complex-double-double 4) (vop x y) + ((complex-double-double-reg) (complex-double-double-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) vm:word-bytes))) + (let ((value-tn (complex-double-double-reg-real-hi-tn x))) + (inst stdf value-tn nfp offset)) + (let ((value-tn (complex-double-double-reg-real-lo-tn x))) + (inst stdf value-tn nfp (+ offset (* 2 vm:word-bytes)))) + (let ((value-tn (complex-double-double-reg-imag-hi-tn x))) + (inst stdf value-tn nfp (+ offset (* 4 vm:word-bytes)))) + (let ((value-tn (complex-double-double-reg-imag-lo-tn x))) + (inst stdf value-tn nfp (+ offset (* 6 vm:word-bytes)))))) + +) + +;;; +;;; Complex float register to register moves. +;;; +(define-vop (complex-single-move) + (:args (x :scs (complex-single-reg) :target y + :load-if (not (location= x y)))) + (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))) + (:note _N"complex single float move") + (:generator 0 + (unless (location= x y) + ;; Note the complex-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-real (complex-single-reg-real-tn x)) + (y-real (complex-single-reg-real-tn y))) + (inst fmovs y-real x-real)) + (let ((x-imag (complex-single-reg-imag-tn x)) + (y-imag (complex-single-reg-imag-tn y))) + (inst fmovs y-imag x-imag))))) +;;; +(define-move-vop complex-single-move :move + (complex-single-reg) (complex-single-reg)) + +(define-vop (complex-double-move) + (:args (x :scs (complex-double-reg) + :target y :load-if (not (location= x y)))) + (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))) + (:note _N"complex double float move") + (:generator 0 + (unless (location= x y) + ;; Note the complex-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-real (complex-double-reg-real-tn x)) + (y-real (complex-double-reg-real-tn y))) + (move-double-reg y-real x-real)) + (let ((x-imag (complex-double-reg-imag-tn x)) + (y-imag (complex-double-reg-imag-tn y))) + (move-double-reg y-imag x-imag))))) +;;; +(define-move-vop complex-double-move :move + (complex-double-reg) (complex-double-reg)) + +#+long-float +(define-vop (complex-long-move) + (:args (x :scs (complex-long-reg) + :target y :load-if (not (location= x y)))) + (:results (y :scs (complex-long-reg) :load-if (not (location= x y)))) + (:note _N"complex long float move") + (:generator 0 + (unless (location= x y) + ;; Note the complex-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-real (complex-long-reg-real-tn x)) + (y-real (complex-long-reg-real-tn y))) + (move-long-reg y-real x-real)) + (let ((x-imag (complex-long-reg-imag-tn x)) + (y-imag (complex-long-reg-imag-tn y))) + (move-long-reg y-imag x-imag))))) +;;; +#+long-float +(define-move-vop complex-long-move :move + (complex-long-reg) (complex-long-reg)) + +#+double-double +(define-vop (complex-double-double-move) + (:args (x :scs (complex-double-double-reg) + :target y :load-if (not (location= x y)))) + (:results (y :scs (complex-double-double-reg) :load-if (not (location= x y)))) + (:note _N"complex double-double float move") + (:generator 0 + (unless (location= x y) + ;; Note the complex-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-real (complex-double-double-reg-real-hi-tn x)) + (y-real (complex-double-double-reg-real-hi-tn y))) + (move-double-reg y-real x-real)) + (let ((x-real (complex-double-double-reg-real-lo-tn x)) + (y-real (complex-double-double-reg-real-lo-tn y))) + (move-double-reg y-real x-real)) + (let ((x-real (complex-double-double-reg-imag-hi-tn x)) + (y-real (complex-double-double-reg-imag-hi-tn y))) + (move-double-reg y-real x-real)) + (let ((x-imag (complex-double-double-reg-imag-lo-tn x)) + (y-imag (complex-double-double-reg-imag-lo-tn y))) + (move-double-reg y-imag x-imag))))) +;;; +#+double-double +(define-move-vop complex-double-double-move :move + (complex-double-double-reg) (complex-double-double-reg)) + +;;; +;;; Move from a complex float to a descriptor register allocating a +;;; new complex float object in the process. +;;; +(define-vop (move-from-complex-single) + (:args (x :scs (complex-single-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:note _N"complex single float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y ndescr vm:complex-single-float-type + vm:complex-single-float-size)) + (let ((real-tn (complex-single-reg-real-tn x))) + (inst stf real-tn y (- (* vm:complex-single-float-real-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (inst stf imag-tn y (- (* vm:complex-single-float-imag-slot + vm:word-bytes) + vm:other-pointer-type))))) +;;; +(define-move-vop move-from-complex-single :move + (complex-single-reg) (descriptor-reg)) + +(define-vop (move-from-complex-double) + (:args (x :scs (complex-double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:note _N"complex double float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y ndescr vm:complex-double-float-type + vm:complex-double-float-size)) + (let ((real-tn (complex-double-reg-real-tn x))) + (inst stdf real-tn y (- (* vm:complex-double-float-real-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (inst stdf imag-tn y (- (* vm:complex-double-float-imag-slot + vm:word-bytes) + vm:other-pointer-type))))) +;;; +(define-move-vop move-from-complex-double :move + (complex-double-reg) (descriptor-reg)) + +#+long-float +(define-vop (move-from-complex-long) + (:args (x :scs (complex-long-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:note _N"complex long float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y ndescr vm:complex-long-float-type + vm:complex-long-float-size)) + (let ((real-tn (complex-long-reg-real-tn x))) + (store-long-reg real-tn y (- (* vm:complex-long-float-real-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((imag-tn (complex-long-reg-imag-tn x))) + (store-long-reg imag-tn y (- (* vm:complex-long-float-imag-slot + vm:word-bytes) + vm:other-pointer-type))))) +;;; +#+long-float +(define-move-vop move-from-complex-long :move + (complex-long-reg) (descriptor-reg)) + +#+double-double +(define-vop (move-from-complex-double-double) + (:args (x :scs (complex-double-double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:note _N"complex double-double float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y ndescr vm::complex-double-double-float-type + vm::complex-double-double-float-size)) + (let ((real-tn (complex-double-double-reg-real-hi-tn x))) + (inst stdf real-tn y (- (* vm::complex-double-double-float-real-hi-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((real-tn (complex-double-double-reg-real-lo-tn x))) + (inst stdf real-tn y (- (* vm::complex-double-double-float-real-lo-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn x))) + (inst stdf imag-tn y (- (* vm::complex-double-double-float-imag-hi-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn x))) + (inst stdf imag-tn y (- (* vm::complex-double-double-float-imag-lo-slot + vm:word-bytes) + vm:other-pointer-type))))) +;;; +#+double-double +(define-move-vop move-from-complex-double-double :move + (complex-double-double-reg) (descriptor-reg)) + +;;; +;;; Move from a descriptor to a complex float register +;;; +(define-vop (move-to-complex-single) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (complex-single-reg))) + (:note _N"pointer to complex float coercion") + (:generator 2 + (let ((real-tn (complex-single-reg-real-tn y))) + (inst ldf real-tn x (- (* complex-single-float-real-slot word-bytes) + other-pointer-type))) + (let ((imag-tn (complex-single-reg-imag-tn y))) + (inst ldf imag-tn x (- (* complex-single-float-imag-slot word-bytes) + other-pointer-type))))) +(define-move-vop move-to-complex-single :move + (descriptor-reg) (complex-single-reg)) + +(define-vop (move-to-complex-double) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (complex-double-reg))) + (:note _N"pointer to complex float coercion") + (:generator 2 + (let ((real-tn (complex-double-reg-real-tn y))) + (inst lddf real-tn x (- (* complex-double-float-real-slot word-bytes) + other-pointer-type))) + (let ((imag-tn (complex-double-reg-imag-tn y))) + (inst lddf imag-tn x (- (* complex-double-float-imag-slot word-bytes) + other-pointer-type))))) +(define-move-vop move-to-complex-double :move + (descriptor-reg) (complex-double-reg)) + +#+long-float +(define-vop (move-to-complex-long) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (complex-long-reg))) + (:note _N"pointer to complex float coercion") + (:generator 2 + (let ((real-tn (complex-long-reg-real-tn y))) + (load-long-reg real-tn x (- (* complex-long-float-real-slot word-bytes) + other-pointer-type))) + (let ((imag-tn (complex-long-reg-imag-tn y))) + (load-long-reg imag-tn x (- (* complex-long-float-imag-slot word-bytes) + other-pointer-type))))) +#+long-float +(define-move-vop move-to-complex-long :move + (descriptor-reg) (complex-long-reg)) + +#+double-double +(define-vop (move-to-complex-double-double) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (complex-double-double-reg))) + (:note _N"pointer to complex double-double float coercion") + (:generator 2 + (let ((real-tn (complex-double-double-reg-real-hi-tn y))) + (inst lddf real-tn x (- (* complex-double-double-float-real-hi-slot word-bytes) + other-pointer-type))) + (let ((real-tn (complex-double-double-reg-real-lo-tn y))) + (inst lddf real-tn x (- (* complex-double-double-float-real-lo-slot word-bytes) + other-pointer-type))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn y))) + (inst lddf imag-tn x (- (* complex-double-double-float-imag-hi-slot word-bytes) + other-pointer-type))) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn y))) + (inst lddf imag-tn x (- (* complex-double-double-float-imag-lo-slot word-bytes) + other-pointer-type))))) +#+double-double +(define-move-vop move-to-complex-double-double :move + (descriptor-reg) (complex-double-double-reg)) + +;;; +;;; Complex float move-argument vop +;;; +(define-vop (move-complex-single-float-argument) + (:args (x :scs (complex-single-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg)))) + (:results (y)) + (:note _N"complex single-float argument move") + (:generator 1 + (sc-case y + (complex-single-reg + (unless (location= x y) + (let ((x-real (complex-single-reg-real-tn x)) + (y-real (complex-single-reg-real-tn y))) + (inst fmovs y-real x-real)) + (let ((x-imag (complex-single-reg-imag-tn x)) + (y-imag (complex-single-reg-imag-tn y))) + (inst fmovs y-imag x-imag)))) + (complex-single-stack + (let ((offset (* (tn-offset y) word-bytes))) + (let ((real-tn (complex-single-reg-real-tn x))) + (inst stf real-tn nfp offset)) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (inst stf imag-tn nfp (+ offset word-bytes)))))))) +(define-move-vop move-complex-single-float-argument :move-argument + (complex-single-reg descriptor-reg) (complex-single-reg)) + +(define-vop (move-complex-double-float-argument) + (:args (x :scs (complex-double-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg)))) + (:results (y)) + (:note _N"complex double-float argument move") + (:generator 2 + (sc-case y + (complex-double-reg + (unless (location= x y) + (let ((x-real (complex-double-reg-real-tn x)) + (y-real (complex-double-reg-real-tn y))) + (move-double-reg y-real x-real)) + (let ((x-imag (complex-double-reg-imag-tn x)) + (y-imag (complex-double-reg-imag-tn y))) + (move-double-reg y-imag x-imag)))) + (complex-double-stack + (let ((offset (* (tn-offset y) word-bytes))) + (let ((real-tn (complex-double-reg-real-tn x))) + (inst stdf real-tn nfp offset)) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (inst stdf imag-tn nfp (+ offset (* 2 word-bytes))))))))) +(define-move-vop move-complex-double-float-argument :move-argument + (complex-double-reg descriptor-reg) (complex-double-reg)) + +#+long-float +(define-vop (move-complex-long-float-argument) + (:args (x :scs (complex-long-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-long-reg)))) + (:results (y)) + (:note _N"complex long-float argument move") + (:generator 2 + (sc-case y + (complex-long-reg + (unless (location= x y) + (let ((x-real (complex-long-reg-real-tn x)) + (y-real (complex-long-reg-real-tn y))) + (move-long-reg y-real x-real)) + (let ((x-imag (complex-long-reg-imag-tn x)) + (y-imag (complex-long-reg-imag-tn y))) + (move-long-reg y-imag x-imag)))) + (complex-long-stack + (let ((offset (* (tn-offset y) word-bytes))) + (let ((real-tn (complex-long-reg-real-tn x))) + (store-long-reg real-tn nfp offset)) + (let ((imag-tn (complex-long-reg-imag-tn x))) + (store-long-reg imag-tn nfp (+ offset (* 4 word-bytes))))))))) + +#+long-float +(define-move-vop move-complex-long-float-argument :move-argument + (complex-long-reg descriptor-reg) (complex-long-reg)) + +#+double-double +(define-vop (move-complex-double-double-float-argument) + (:args (x :scs (complex-double-double-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-double-reg)))) + (:results (y)) + (:note _N"complex double-double float argument move") + (:generator 2 + (sc-case y + (complex-double-double-reg + (unless (location= x y) + (let ((x-real (complex-double-double-reg-real-hi-tn x)) + (y-real (complex-double-double-reg-real-hi-tn y))) + (move-double-reg y-real x-real)) + (let ((x-real (complex-double-double-reg-real-lo-tn x)) + (y-real (complex-double-double-reg-real-lo-tn y))) + (move-double-reg y-real x-real)) + (let ((x-imag (complex-double-double-reg-imag-hi-tn x)) + (y-imag (complex-double-double-reg-imag-hi-tn y))) + (move-long-reg y-imag x-imag)) + (let ((x-imag (complex-double-double-reg-imag-lo-tn x)) + (y-imag (complex-double-double-reg-imag-lo-tn y))) + (move-long-reg y-imag x-imag)))) + (complex-double-double-stack + (let ((offset (* (tn-offset y) word-bytes))) + (let ((real-tn (complex-double-double-reg-real-hi-tn x))) + (inst stdf real-tn nfp offset)) + (let ((real-tn (complex-double-double-reg-real-lo-tn x))) + (inst stdf real-tn nfp (+ offset (* 2 word-bytes)))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn x))) + (inst stdf imag-tn nfp (+ offset (* 4 word-bytes)))) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn x))) + (inst stdf imag-tn nfp (+ offset (* 6 word-bytes))))))))) + +#+double-double +(define-move-vop move-complex-double-double-float-argument :move-argument + (complex-double-double-reg descriptor-reg) (complex-double-double-reg)) + +(define-move-vop move-argument :move-argument + (single-reg double-reg #+long-float long-reg #+double-double double-double-reg + complex-single-reg complex-double-reg #+long-float complex-long-reg + #+double-double complex-double-double-reg) + (descriptor-reg)) + + +;;;; Arithmetic VOPs: + +(define-vop (float-op) + (:args (x) (y)) + (:results (r)) + (:policy :fast-safe) + (:note _N"inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only)) + +(macrolet ((frob (name sc ptype) + `(define-vop (,name float-op) + (:args (x :scs (,sc)) + (y :scs (,sc))) + (:results (r :scs (,sc))) + (:arg-types ,ptype ,ptype) + (:result-types ,ptype)))) + (frob single-float-op single-reg single-float) + (frob double-float-op double-reg double-float) + #+long-float + (frob long-float-op long-reg long-float)) + +(macrolet ((frob (op sinst sname scost dinst dname dcost) + `(progn + (define-vop (,sname single-float-op) + (:translate ,op) + (:generator ,scost + (inst ,sinst r x y))) + (define-vop (,dname double-float-op) + (:translate ,op) + (:generator ,dcost + (inst ,dinst r x y)))))) + (frob + fadds +/single-float 2 faddd +/double-float 2) + (frob - fsubs -/single-float 2 fsubd -/double-float 2) + (frob * fmuls */single-float 4 fmuld */double-float 5) + (frob / fdivs //single-float 12 fdivd //double-float 19)) + +#+long-float +(macrolet ((frob (op linst lname lcost) + `(define-vop (,lname long-float-op) + (:translate ,op) + (:generator ,lcost + (inst ,linst r x y))))) + (frob + faddq +/long-float 2) + (frob - fsubq -/long-float 2) + (frob * fmulq */long-float 6) + (frob / fdivq //long-float 20)) + + +(macrolet ((frob (name inst translate sc type) + `(define-vop (,name) + (:args (x :scs (,sc))) + (:results (y :scs (,sc))) + (:translate ,translate) + (:policy :fast-safe) + (:arg-types ,type) + (:result-types ,type) + (:note _N"inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (inst ,inst y x))))) + (frob abs/single-float fabss abs single-reg single-float) + (frob %negate/single-float fnegs %negate single-reg single-float)) + +(defun negate-double-reg (dst src) + (cond ((backend-featurep :sparc-v9) + (inst fnegd dst src)) + (t + ;; Negate the MS part of the numbers, then copy over the rest + ;; of the bits. + (inst fnegs dst src) + (let ((dst-odd (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ 1 (tn-offset dst)))) + (src-odd (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ 1 (tn-offset src))))) + (inst fmovs dst-odd src-odd))))) + +(defun abs-double-reg (dst src) + (cond ((backend-featurep :sparc-v9) + (inst fabsd dst src)) + (t + ;; Abs the MS part of the numbers, then copy over the rest + ;; of the bits. + (inst fabss dst src) + (let ((dst-2 (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ 1 (tn-offset dst)))) + (src-2 (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ 1 (tn-offset src))))) + (inst fmovs dst-2 src-2))))) + +(define-vop (abs/double-float) + (:args (x :scs (double-reg))) + (:results (y :scs (double-reg))) + (:translate abs) + (:policy :fast-safe) + (:arg-types double-float) + (:result-types double-float) + (:note _N"inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (abs-double-reg y x))) + +(define-vop (%negate/double-float) + (:args (x :scs (double-reg))) + (:results (y :scs (double-reg))) + (:translate %negate) + (:policy :fast-safe) + (:arg-types double-float) + (:result-types double-float) + (:note _N"inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (negate-double-reg y x))) + +#+long-float +(define-vop (abs/long-float) + (:args (x :scs (long-reg))) + (:results (y :scs (long-reg))) + (:translate abs) + (:policy :fast-safe) + (:arg-types long-float) + (:result-types long-float) + (:note _N"inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (cond ((backend-featurep :sparc-v9) + (inst fabsq y x)) + (t + (inst fabss y x) + (dotimes (i 3) + (let ((y-odd (make-random-tn + :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ i 1 (tn-offset y)))) + (x-odd (make-random-tn + :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ i 1 (tn-offset x))))) + (inst fmovs y-odd x-odd))))))) + +#+long-float +(define-vop (%negate/long-float) + (:args (x :scs (long-reg))) + (:results (y :scs (long-reg))) + (:translate %negate) + (:policy :fast-safe) + (:arg-types long-float) + (:result-types long-float) + (:note _N"inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (cond ((backend-featurep :sparc-v9) + (inst fnegq y x)) + (t + (inst fnegs y x) + (dotimes (i 3) + (let ((y-odd (make-random-tn + :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ i 1 (tn-offset y)))) + (x-odd (make-random-tn + :kind :normal + :sc (sc-or-lose 'single-reg *backend*) + :offset (+ i 1 (tn-offset x))))) + (inst fmovs y-odd x-odd))))))) + + +;;;; Comparison: + +(define-vop (float-compare) + (:args (x) (y)) + (:conditional) + (:info target not-p) + (:variant-vars format yep nope) + (:policy :fast-safe) + (:note _N"inline float comparison") + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + (note-this-location vop :internal-error) + (ecase format + (:single (inst fcmps x y)) + (:double (inst fcmpd x y)) + (:long (inst fcmpq x y))) + ;; The SPARC V9 doesn't need an instruction between a + ;; floating-point compare and a floating-point branch. + (unless (backend-featurep :sparc-v9) + (inst nop)) + (inst fb (if not-p nope yep) target) + (inst nop))) + +(macrolet ((frob (name sc ptype) + `(define-vop (,name float-compare) + (:args (x :scs (,sc)) + (y :scs (,sc))) + (:arg-types ,ptype ,ptype)))) + (frob single-float-compare single-reg single-float) + (frob double-float-compare double-reg double-float) + #+long-float + (frob long-float-compare long-reg long-float)) + +(macrolet ((frob (translate yep nope sname dname #+long-float lname) + `(progn + (define-vop (,sname single-float-compare) + (:translate ,translate) + (:variant :single ,yep ,nope)) + (define-vop (,dname double-float-compare) + (:translate ,translate) + (:variant :double ,yep ,nope)) + #+long-float + (define-vop (,lname long-float-compare) + (:translate ,translate) + (:variant :long ,yep ,nope))))) + (frob < :l :ge </single-float </double-float #+long-float </long-float) + (frob > :g :le >/single-float >/double-float #+long-float >/long-float) + (frob = :eq :ne eql/single-float eql/double-float #+long-float eql/long-float)) + +#+long-float +(deftransform eql ((x y) (long-float long-float)) + '(and (= (long-float-low-bits x) (long-float-low-bits y)) + (= (long-float-mid-bits x) (long-float-mid-bits y)) + (= (long-float-high-bits x) (long-float-high-bits y)) + (= (long-float-exp-bits x) (long-float-exp-bits y)))) + +#+double-double +(deftransform eql ((x y) (double-double-float double-double-float)) + '(and (eql (double-double-hi x) (double-double-hi y)) + (eql (double-double-lo x) (double-double-lo y)))) + + +;;;; Conversion: + +;; Tell the compiler about %%single-float and %%double-float. Add +;; functions for byte-compiled code. +(macrolet + ((frob (name type) + `(progn + (defknown ,name ((signed-byte 32)) + ,type) + (defun ,name (n) + (declare (type (signed-byte 32) n)) + (,name n))))) + (frob %%single-float single-float) + (frob %%double-float double-float)) + +;; Sparc doesn't have an instruction to convert a 32-bit unsigned +;; integer to a float, but does have one for a 32-bit signed integer. +;; What we do here is break up the 32-bit number into 2 smaller +;; pieces. Each of these are converted to a float, and the higher +;; order piece is scaled appropriately, and finally everything is +;; summed together. The pieces are done in a way such that no +;; roundoff occurs. The scaling should not produce any roundoff +;; either, since the scale factor is an exact power of two. The final +;; sum will produce the correct rounded result. (I think,) +;; +;; But need to be careful because we still want to call the VOP for +;; the small pieces, so we need the transform to give up if it's known +;; that the argument is smaller than a 32-bit unsigned integer. +(macrolet ((frob (name vop-trans limit unit) + `(progn + (deftransform ,name ((n) ((unsigned-byte 32))) + ;; Should this be extended to a (unsigned-byte 53)? We could. Just + ;; take the low 31 bits, and the rest, and float them and combine + ;; them as before. + (when (csubtypep (c::continuation-type n) + (c::specifier-type '(unsigned-byte 31))) + ;; We want to give-up if we know the number can't have the + ;; MSB set. The signed 32-bit vop can handle that. + (c::give-up)) + `(+ (,',vop-trans (ldb (byte ,',limit 0) n)) + (* (,',vop-trans (ldb (byte ,',(- 32 limit) ,',limit) n)) + (scale-float ,',unit ,',limit)))) + ;; Always convert %foo to %%foo for 32-bit signed values. + (deftransform ,name ((n) ((signed-byte 32))) + `(,',vop-trans n))))) + ;; If we break up the numbers into the low 12 bits and the high 20 + ;; bits, we can use a single AND instruction to get the low 12 bits. + ;; This is a microoptimization for Sparc. Otherwise, the only + ;; constraint is that the pieces must be small enough to fit in the + ;; desired float format without rounding. + (frob %single-float %%single-float 12 1f0) + (frob %double-float %%double-float 12 1d0)) + + +(macrolet ((frob (name translate inst to-sc to-type) + `(define-vop (,name) + (:args (x :scs (signed-reg) :target stack-temp + :load-if (not (sc-is x signed-stack)))) + (:temporary (:scs (single-stack) :from :argument) stack-temp) + (:temporary (:scs (single-reg) :to :result :target y) temp) + (:results (y :scs (,to-sc))) + (:arg-types signed-num) + (:result-types ,to-type) + (:policy :fast-safe) + (:note _N"inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (let ((stack-tn + (sc-case x + (signed-reg + (inst st x + (current-nfp-tn vop) + (* (tn-offset temp) vm:word-bytes)) + stack-temp) + (signed-stack + x)))) + (inst ldf temp + (current-nfp-tn vop) + (* (tn-offset stack-tn) vm:word-bytes)) + (note-this-location vop :internal-error) + (inst ,inst y temp)))))) + (frob %single-float/signed %%single-float fitos single-reg single-float) + (frob %double-float/signed %%double-float fitod double-reg double-float) + #+long-float + (frob %long-float/signed %long-float fitoq long-reg long-float)) + +;; Sparc doesn't have an instruction to convert a 32-bit unsigned +;; integer to a float, but does have one for a 32-bit signed integer. +;; What we do here is break up the 32-bit number into 2 smaller +;; pieces. Each of these are converted to a float, and the higher +;; order piece is scaled appropriately, and finally everything is +;; summed together. The pieces are done in a way such that no +;; roundoff occurs. The scaling should not produce any roundoff +;; either, since the scale factor is an exact power of two. The final +;; sum will produce the correct rounded result. (I think,) +;; +;; But need to be careful because we still want to call the VOP for +;; the small pieces, so we need the transform to give up if it's known +;; that the argument is smaller than a 32-bit unsigned integer. +(macrolet ((frob (name limit unit) + `(deftransform ,name ((n) ((unsigned-byte 32))) + ;; Should this be extended to a (unsigned-byte 53)? We could. Just + ;; take the low 31 bits, and the rest, and float them and combine + ;; them as before. + (when (csubtypep (c::continuation-type n) + (c::specifier-type '(unsigned-byte 31))) + ;; We want to give-up if we know the number can't have the + ;; MSB set. The signed 32-bit vop can handle that. + (c::give-up)) + `(+ (,',name (ldb (byte ,',limit 0) n)) + (* (,',name (ldb (byte ,',(- 32 limit) ,',limit) n)) + (scale-float ,',unit ,',limit)))))) + ;; If we break up the numbers into the low 12 bits and the high 20 + ;; bits, we can use a single AND instruction to get the low 12 bits. + ;; This is a microoptimization for Sparc. Otherwise, the only + ;; constraint is that the pieces must be small enough to fit in the + ;; desired float format without rounding. + (frob %single-float 12 1f0) + (frob %double-float 12 1f0)) + +(macrolet ((frob (name translate inst from-sc from-type to-sc to-type) + `(define-vop (,name) + (:args (x :scs (,from-sc))) + (:results (y :scs (,to-sc))) + (:arg-types ,from-type) + (:result-types ,to-type) + (:policy :fast-safe) + (:note _N"inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 2 + (note-this-location vop :internal-error) + (inst ,inst y x))))) + (frob %single-float/double-float %single-float fdtos + double-reg double-float single-reg single-float) + #+long-float + (frob %single-float/long-float %single-float fqtos + long-reg long-float single-reg single-float) + (frob %double-float/single-float %double-float fstod + single-reg single-float double-reg double-float) + #+long-float + (frob %double-float/long-float %double-float fqtod + long-reg long-float double-reg double-float) + #+long-float + (frob %long-float/single-float %long-float fstoq + single-reg single-float long-reg long-float) + #+long-float + (frob %long-float/double-float %long-float fdtoq + double-reg double-float long-reg long-float)) + +(macrolet ((frob (trans from-sc from-type inst) + `(define-vop (,(symbolicate trans "/" from-type)) + (:args (x :scs (,from-sc) :target temp)) + (:temporary (:from (:argument 0) :sc single-reg) temp) + (:temporary (:scs (signed-stack)) stack-temp) + (:results (y :scs (signed-reg) + :load-if (not (sc-is y signed-stack)))) + (:arg-types ,from-type) + (:result-types signed-num) + (:translate ,trans) + (:policy :fast-safe) + (:note _N"inline float truncate") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (inst ,inst temp x) + (sc-case y + (signed-stack + (inst stf temp (current-nfp-tn vop) + (* (tn-offset y) vm:word-bytes))) + (signed-reg + (inst stf temp (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst ldsw y (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)))))))) + (frob %unary-truncate single-reg single-float fstoi) + (frob %unary-truncate double-reg double-float fdtoi) + #+long-float + (frob %unary-truncate long-reg long-float fqtoi) + #-sun4 + (frob %unary-round single-reg single-float fstoir) + #-sun4 + (frob %unary-round double-reg double-float fdtoir)) + +(define-vop (fast-unary-ftruncate/single-float) + (:args (x :scs (single-reg))) + (:arg-types single-float) + (:results (r :scs (single-reg))) + (:result-types single-float) + (:policy :fast-safe) + (:translate c::fast-unary-ftruncate) + (:guard (not (backend-featurep :sparc-v9))) + (:note _N"inline ftruncate") + (:generator 2 + (inst fstoi r x) + (inst fitos r r))) + +(define-vop (fast-unary-ftruncate/double-float) + (:args (x :scs (double-reg) :target r)) + (:arg-types double-float) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:policy :fast-safe) + (:translate c::fast-unary-ftruncate) + (:guard (not (backend-featurep :sparc-v9))) + (:note _N"inline ftruncate") + (:generator 2 + (inst fdtoi r x) + (inst fitod r r))) + +;; The V9 architecture can convert 64-bit integers. +(define-vop (v9-fast-unary-ftruncate/single-float) + (:args (x :scs (single-reg))) + (:arg-types single-float) + (:results (r :scs (single-reg))) + (:result-types single-float) + (:temporary (:scs (double-reg)) temp) + (:policy :fast-safe) + (:translate c::fast-unary-ftruncate) + (:guard (backend-featurep :sparc-v9)) + (:note _N"inline ftruncate") + (:generator 2 + (inst fstox temp x) + (inst fxtos r temp))) + +(define-vop (v9-fast-unary-ftruncate/double-float) + (:args (x :scs (double-reg) :target r)) + (:arg-types double-float) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:policy :fast-safe) + (:translate c::fast-unary-ftruncate) + (:guard (backend-featurep :sparc-v9)) + (:note _N"inline ftruncate") + (:generator 2 + (inst fdtox r x) + (inst fxtod r r))) + +;; See Listing 2.2: Conversion from FP to int in in "CR-LIBM: A +;; library of correctly rounded elementary functions in +;; double-precision". +#+sun4 +(deftransform %unary-round ((x) (float) (signed-byte 32)) + '(kernel:double-float-low-bits (+ x (+ (scale-float 1d0 52) + (scale-float 1d0 51))))) + +(define-vop (make-single-float) + (:args (bits :scs (signed-reg) :target res + :load-if (not (sc-is bits signed-stack)))) + (:results (res :scs (single-reg) + :load-if (not (sc-is res single-stack)))) + (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp) + (:temporary (:scs (signed-stack)) stack-temp) + (:arg-types signed-num) + (:result-types single-float) + (:translate make-single-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 4 + (sc-case bits + (signed-reg + (sc-case res + (single-reg + (inst st bits (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst ldf res (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (single-stack + (inst st bits (current-nfp-tn vop) + (* (tn-offset res) vm:word-bytes))))) + (signed-stack + (sc-case res + (single-reg + (inst ldf res (current-nfp-tn vop) + (* (tn-offset bits) vm:word-bytes))) + (single-stack + (unless (location= bits res) + (inst ldsw temp (current-nfp-tn vop) + (* (tn-offset bits) vm:word-bytes)) + (inst st temp (current-nfp-tn vop) + (* (tn-offset res) vm:word-bytes))))))))) + +(define-vop (make-double-float) + (:args (hi-bits :scs (signed-reg)) + (lo-bits :scs (unsigned-reg))) + (:results (res :scs (double-reg) + :load-if (not (sc-is res double-stack)))) + (:temporary (:scs (double-stack)) temp) + (:arg-types signed-num unsigned-num) + (:result-types double-float) + (:translate make-double-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 2 + (let ((stack-tn (sc-case res + (double-stack res) + (double-reg temp)))) + (inst st hi-bits (current-nfp-tn vop) + (* (tn-offset stack-tn) vm:word-bytes)) + (inst st lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset stack-tn)) vm:word-bytes))) + (when (sc-is res double-reg) + (inst lddf res (current-nfp-tn vop) + (* (tn-offset temp) vm:word-bytes))))) + +#+long-float +(define-vop (make-long-float) + (:args (hi-bits :scs (signed-reg)) + (lo1-bits :scs (unsigned-reg)) + (lo2-bits :scs (unsigned-reg)) + (lo3-bits :scs (unsigned-reg))) + (:results (res :scs (long-reg) + :load-if (not (sc-is res long-stack)))) + (:temporary (:scs (long-stack)) temp) + (:arg-types signed-num unsigned-num unsigned-num unsigned-num) + (:result-types long-float) + (:translate make-long-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 2 + (let ((stack-tn (sc-case res + (long-stack res) + (long-reg temp)))) + (inst st hi-bits (current-nfp-tn vop) + (* (tn-offset stack-tn) vm:word-bytes)) + (inst st lo1-bits (current-nfp-tn vop) + (* (1+ (tn-offset stack-tn)) vm:word-bytes)) + (inst st lo2-bits (current-nfp-tn vop) + (* (+ 2 (tn-offset stack-tn)) vm:word-bytes)) + (inst st lo3-bits (current-nfp-tn vop) + (* (+ 3 (tn-offset stack-tn)) vm:word-bytes))) + (when (sc-is res long-reg) + (load-long-reg res (current-nfp-tn vop) + (* (tn-offset temp) vm:word-bytes))))) + +(define-vop (single-float-bits) + (:args (float :scs (single-reg descriptor-reg) + :load-if (not (sc-is float single-stack)))) + (:results (bits :scs (signed-reg) + :load-if (or (sc-is float descriptor-reg single-stack) + (not (sc-is bits signed-stack))))) + (:temporary (:scs (signed-stack)) stack-temp) + (:arg-types single-float) + (:result-types signed-num) + (:translate single-float-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 4 + (sc-case bits + (signed-reg + (sc-case float + (single-reg + (inst stf float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst ldsw bits (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (single-stack + (inst ldsw bits (current-nfp-tn vop) + (* (tn-offset float) vm:word-bytes))) + (descriptor-reg + (loadw bits float vm:single-float-value-slot + vm:other-pointer-type)))) + (signed-stack + (sc-case float + (single-reg + (inst stf float (current-nfp-tn vop) + (* (tn-offset bits) vm:word-bytes)))))))) + +(define-vop (double-float-high-bits) + (:args (float :scs (double-reg descriptor-reg) + :load-if (not (sc-is float double-stack)))) + (:results (hi-bits :scs (signed-reg))) + (:temporary (:scs (double-stack)) stack-temp) + (:arg-types double-float) + (:result-types signed-num) + (:translate double-float-high-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (double-reg + (inst stdf float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst ldsw hi-bits (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (double-stack + (inst ldsw hi-bits (current-nfp-tn vop) + (* (tn-offset float) vm:word-bytes))) + (descriptor-reg + (loadw hi-bits float vm:double-float-value-slot + vm:other-pointer-type))))) + +(define-vop (double-float-low-bits) + (:args (float :scs (double-reg descriptor-reg) + :load-if (not (sc-is float double-stack)))) + (:results (lo-bits :scs (unsigned-reg))) + (:temporary (:scs (double-stack)) stack-temp) + (:arg-types double-float) + (:result-types unsigned-num) + (:translate double-float-low-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (double-reg + (inst stdf float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst ldsw lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset stack-temp)) vm:word-bytes))) + (double-stack + (inst ldsw lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset float)) vm:word-bytes))) + (descriptor-reg + (loadw lo-bits float (1+ vm:double-float-value-slot) + vm:other-pointer-type))))) + +(define-vop (double-float-bits) + (:args (float :scs (double-reg descriptor-reg) + :load-if (not (sc-is float double-stack)))) + (:results (hi-bits :scs (signed-reg)) + (lo-bits :scs (unsigned-reg))) + (:temporary (:scs (double-stack)) stack-temp) + (:arg-types double-float) + (:result-types signed-num unsigned-num) + (:translate kernel::double-float-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (double-reg + (inst stdf float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst ldsw hi-bits (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst ld lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset stack-temp)) vm:word-bytes))) + (double-stack + (inst ldsw hi-bits (current-nfp-tn vop) + (* (tn-offset float) vm:word-bytes)) + (inst ld lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset float)) vm:word-bytes))) + (descriptor-reg + (loadw hi-bits float vm:double-float-value-slot + vm:other-pointer-type) + (loadw lo-bits float (1+ vm:double-float-value-slot) + vm:other-pointer-type))))) + +#+long-float +(define-vop (long-float-exp-bits) + (:args (float :scs (long-reg descriptor-reg) + :load-if (not (sc-is float long-stack)))) + (:results (exp-bits :scs (signed-reg))) + (:temporary (:scs (double-stack)) stack-temp) + (:arg-types long-float) + (:result-types signed-num) + (:translate long-float-exp-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (long-reg + (let ((float (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset float)))) + (inst stdf float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (inst ld exp-bits (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (long-stack + (inst ld exp-bits (current-nfp-tn vop) + (* (tn-offset float) vm:word-bytes))) + (descriptor-reg + (loadw exp-bits float vm:long-float-value-slot + vm:other-pointer-type))))) + +#+long-float +(define-vop (long-float-high-bits) + (:args (float :scs (long-reg descriptor-reg) + :load-if (not (sc-is float long-stack)))) + (:results (high-bits :scs (unsigned-reg))) + (:temporary (:scs (double-stack)) stack-temp) + (:arg-types long-float) + (:result-types unsigned-num) + (:translate long-float-high-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (long-reg + (let ((float (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset float)))) + (inst stdf float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (inst ld high-bits (current-nfp-tn vop) + (* (1+ (tn-offset stack-temp)) vm:word-bytes))) + (long-stack + (inst ld high-bits (current-nfp-tn vop) + (* (1+ (tn-offset float)) vm:word-bytes))) + (descriptor-reg + (loadw high-bits float (1+ vm:long-float-value-slot) + vm:other-pointer-type))))) + +#+long-float +(define-vop (long-float-mid-bits) + (:args (float :scs (long-reg descriptor-reg) + :load-if (not (sc-is float long-stack)))) + (:results (mid-bits :scs (unsigned-reg))) + (:temporary (:scs (double-stack)) stack-temp) + (:arg-types long-float) + (:result-types unsigned-num) + (:translate long-float-mid-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (long-reg + (let ((float (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 2 (tn-offset float))))) + (inst stdf float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (inst ld mid-bits (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (long-stack + (inst ld mid-bits (current-nfp-tn vop) + (* (+ 2 (tn-offset float)) vm:word-bytes))) + (descriptor-reg + (loadw mid-bits float (+ 2 vm:long-float-value-slot) + vm:other-pointer-type))))) + +#+long-float +(define-vop (long-float-low-bits) + (:args (float :scs (long-reg descriptor-reg) + :load-if (not (sc-is float long-stack)))) + (:results (lo-bits :scs (unsigned-reg))) + (:temporary (:scs (double-stack)) stack-temp) + (:arg-types long-float) + (:result-types unsigned-num) + (:translate long-float-low-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (long-reg + (let ((float (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 2 (tn-offset float))))) + (inst stdf float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (inst ld lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset stack-temp)) vm:word-bytes))) + (long-stack + (inst ld lo-bits (current-nfp-tn vop) + (* (+ 3 (tn-offset float)) vm:word-bytes))) + (descriptor-reg + (loadw lo-bits float (+ 3 vm:long-float-value-slot) + vm:other-pointer-type))))) + + +;;;; Float mode hackery: + +(deftype float-modes () '(unsigned-byte 32)) +(defknown floating-point-modes () float-modes (flushable)) +(defknown ((setf floating-point-modes)) (float-modes) + float-modes) + +(define-vop (floating-point-modes) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate floating-point-modes) + (:policy :fast-safe) + (:vop-var vop) + (:temporary (:sc unsigned-stack) temp) + (:generator 3 + (let ((nfp (current-nfp-tn vop))) + (inst stfsr nfp (* word-bytes (tn-offset temp))) + (loadw res nfp (tn-offset temp)) + (inst nop)))) + +#+nil +(define-vop (floating-point-modes) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate floating-point-modes) + (:policy :fast-safe) + (:vop-var vop) + (:temporary (:sc double-stack) temp) + (:generator 3 + (let* ((nfp (current-nfp-tn vop)) + (offset (* 4 (tn-offset temp)))) + (inst stxfsr nfp offset) + ;; The desired FP mode data is in the least significant 32 + ;; bits, which is stored at the next higher word in memory. + (loadw res nfp (+ offset 4)) + ;; Is this nop needed? (toy@rtp.ericsson.se) + (inst nop)))) + +(define-vop (set-floating-point-modes) + (:args (new :scs (unsigned-reg) :target res)) + (:results (res :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:result-types unsigned-num) + (:translate (setf floating-point-modes)) + (:policy :fast-safe) + (:temporary (:sc unsigned-stack) temp) + (:vop-var vop) + (:generator 3 + (let ((nfp (current-nfp-tn vop))) + (storew new nfp (tn-offset temp)) + (inst ldfsr nfp (* word-bytes (tn-offset temp))) + (move res new)))) + +#+nil +(define-vop (set-floating-point-modes) + (:args (new :scs (unsigned-reg) :target res)) + (:results (res :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:result-types unsigned-num) + (:translate (setf floating-point-modes)) + (:policy :fast-safe) + (:temporary (:sc double-stack) temp) + (:temporary (:sc unsigned-reg) my-fsr) + (:vop-var vop) + (:generator 3 + (let ((nfp (current-nfp-tn vop)) + (offset (* word-bytes (tn-offset temp)))) + (pseudo-atomic () + ;; Get the current FSR, so we can get the new %fcc's + (inst stxfsr nfp offset) + (inst ldx my-fsr nfp offset) + ;; Carefully merge in the new mode bits with the rest of the + ;; FSR. This is only needed if we care about preserving the + ;; high 32 bits of the FSR, which contain the additional + ;; %fcc's on the sparc V9. If not, we don't need this, but we + ;; do need to make sure that the unused bits are written as + ;; zeroes, according the the V9 architecture manual. + (inst signx new) + (inst srlx my-fsr 32) + (inst sllx my-fsr 32) + (inst or my-fsr new) + ;; Save it back and load it into the fsr register + (inst stx my-fsr nfp offset) + (inst ldxfsr nfp offset) + (move res new))))) + +#+nil +(define-vop (set-floating-point-modes) + (:args (new :scs (unsigned-reg) :target res)) + (:results (res :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:result-types unsigned-num) + (:translate (setf floating-point-modes)) + (:policy :fast-safe) + (:temporary (:sc double-stack) temp) + (:temporary (:sc unsigned-reg) my-fsr) + (:vop-var vop) + (:generator 3 + (let ((nfp (current-nfp-tn vop)) + (offset (* word-bytes (tn-offset temp)))) + (inst stx new nfp offset) + (inst ldxfsr nfp offset) + (move res new)))) + + +;;;; Special functions. + +#-long-float +(define-vop (fsqrt) + (:args (x :scs (double-reg))) + (:results (y :scs (double-reg))) + (:translate %sqrt) + (:policy :fast-safe) + (:guard (or (backend-featurep :sparc-v7) + (backend-featurep :sparc-v8) + (backend-featurep :sparc-v9))) + (:arg-types double-float) + (:result-types double-float) + (:note _N"inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (inst fsqrtd y x))) + +#+long-float +(define-vop (fsqrt-long) + (:args (x :scs (long-reg))) + (:results (y :scs (long-reg))) + (:translate %sqrt) + (:policy :fast-safe) + (:arg-types long-float) + (:result-types long-float) + (:note _N"inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (inst fsqrtq y x))) + + +;;;; Complex float VOPs + +(define-vop (make-complex-single-float) + (:translate complex) + (:args (real :scs (single-reg) :target r + :load-if (not (location= real r))) + (imag :scs (single-reg) :to :save)) + (:arg-types single-float single-float) + (:results (r :scs (complex-single-reg) :from (:argument 0) + :load-if (not (sc-is r complex-single-stack)))) + (:result-types complex-single-float) + (:note _N"inline complex single-float creation") + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case r + (complex-single-reg + (let ((r-real (complex-single-reg-real-tn r))) + (unless (location= real r-real) + (inst fmovs r-real real))) + (let ((r-imag (complex-single-reg-imag-tn r))) + (unless (location= imag r-imag) + (inst fmovs r-imag imag)))) + (complex-single-stack + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset r) vm:word-bytes))) + (unless (location= real r) + (inst stf real nfp offset)) + (inst stf imag nfp (+ offset vm:word-bytes))))))) + +(define-vop (make-complex-double-float) + (:translate complex) + (:args (real :scs (double-reg) :target r + :load-if (not (location= real r))) + (imag :scs (double-reg) :to :save)) + (:arg-types double-float double-float) + (:results (r :scs (complex-double-reg) :from (:argument 0) + :load-if (not (sc-is r complex-double-stack)))) + (:result-types complex-double-float) + (:note _N"inline complex double-float creation") + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case r + (complex-double-reg + (let ((r-real (complex-double-reg-real-tn r))) + (unless (location= real r-real) + (move-double-reg r-real real))) + (let ((r-imag (complex-double-reg-imag-tn r))) + (unless (location= imag r-imag) + (move-double-reg r-imag imag)))) + (complex-double-stack + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset r) vm:word-bytes))) + (unless (location= real r) + (inst stdf real nfp offset)) + (inst stdf imag nfp (+ offset (* 2 vm:word-bytes)))))))) + +#+long-float +(define-vop (make-complex-long-float) + (:translate complex) + (:args (real :scs (long-reg) :target r + :load-if (not (location= real r))) + (imag :scs (long-reg) :to :save)) + (:arg-types long-float long-float) + (:results (r :scs (complex-long-reg) :from (:argument 0) + :load-if (not (sc-is r complex-long-stack)))) + (:result-types complex-long-float) + (:note _N"inline complex long-float creation") + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case r + (complex-long-reg + (let ((r-real (complex-long-reg-real-tn r))) + (unless (location= real r-real) + (move-long-reg r-real real))) + (let ((r-imag (complex-long-reg-imag-tn r))) + (unless (location= imag r-imag) + (move-long-reg r-imag imag)))) + (complex-long-stack + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset r) vm:word-bytes))) + (unless (location= real r) + (store-long-reg real nfp offset)) + (store-long-reg imag nfp (+ offset (* 4 vm:word-bytes)))))))) + +(define-vop (complex-single-float-value) + (:args (x :scs (complex-single-reg descriptor-reg) :target r + :load-if (not (sc-is x complex-single-stack)))) + (:arg-types complex-single-float) + (:results (r :scs (single-reg))) + (:result-types single-float) + (:variant-vars slot) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (sc-case x + (complex-single-reg + (let ((value-tn (ecase slot + (:real (complex-single-reg-real-tn x)) + (:imag (complex-single-reg-imag-tn x))))) + (unless (location= value-tn r) + (inst fmovs r value-tn)))) + (complex-single-stack + (inst ldf r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1)) + (tn-offset x)) + vm:word-bytes))) + (descriptor-reg + (inst ldf r x (- (* (ecase slot + (:real vm::complex-single-float-real-slot) + (:imag vm::complex-single-float-imag-slot)) + vm:word-bytes) + vm:other-pointer-type)))))) + +(define-vop (realpart/complex-single-float complex-single-float-value) + (:translate realpart) + (:note _N"complex single float realpart") + (:variant :real)) + +(define-vop (imagpart/complex-single-float complex-single-float-value) + (:translate imagpart) + (:note _N"complex single float imagpart") + (:variant :imag)) + +(define-vop (complex-double-float-value) + (:args (x :scs (complex-double-reg descriptor-reg) :target r + :load-if (not (sc-is x complex-double-stack)))) + (:arg-types complex-double-float) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:variant-vars slot) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (sc-case x + (complex-double-reg + (let ((value-tn (ecase slot + (:real (complex-double-reg-real-tn x)) + (:imag (complex-double-reg-imag-tn x))))) + (unless (location= value-tn r) + (move-double-reg r value-tn)))) + (complex-double-stack + (inst lddf r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2)) + (tn-offset x)) + vm:word-bytes))) + (descriptor-reg + (inst lddf r x (- (* (ecase slot + (:real vm::complex-double-float-real-slot) + (:imag vm::complex-double-float-imag-slot)) + vm:word-bytes) + vm:other-pointer-type)))))) + +(define-vop (realpart/complex-double-float complex-double-float-value) + (:translate realpart) + (:note _N"complex double float realpart") + (:variant :real)) + +(define-vop (imagpart/complex-double-float complex-double-float-value) + (:translate imagpart) + (:note _N"complex double float imagpart") + (:variant :imag)) + +#+long-float +(define-vop (complex-long-float-value) + (:args (x :scs (complex-long-reg) :target r + :load-if (not (sc-is x complex-long-stack)))) + (:arg-types complex-long-float) + (:results (r :scs (long-reg))) + (:result-types long-float) + (:variant-vars slot) + (:policy :fast-safe) + (:vop-var vop) + (:generator 4 + (sc-case x + (complex-long-reg + (let ((value-tn (ecase slot + (:real (complex-long-reg-real-tn x)) + (:imag (complex-long-reg-imag-tn x))))) + (unless (location= value-tn r) + (move-long-reg r value-tn)))) + (complex-long-stack + (load-long-reg r (current-nfp-tn vop) + (* (+ (ecase slot (:real 0) (:imag 4)) (tn-offset x)) + vm:word-bytes)))))) + +#+long-float +(define-vop (realpart/complex-long-float complex-long-float-value) + (:translate realpart) + (:note _N"complex long float realpart") + (:variant :real)) + +#+long-float +(define-vop (imagpart/complex-long-float complex-long-float-value) + (:translate imagpart) + (:note _N"complex long float imagpart") + (:variant :imag)) + + + +;;;; Complex float arithmetic + +;;; These vops are intended to optimize some complex float arithmetic +;;; by removing lots of redundant moves that the compiler currently +;;; inserts. It seems the moves are generated because of the way +;;; unboxed complex floats are represented as pairs of registers. The +;;; compiler doesn't think we can use the parts directly and therefore +;;; copies the parts to another register before operating on them. +;;; +;;; If we had a peephole optimizer, we could make it remove the +;;; redundant moves instead. + +#+complex-fp-vops +(progn + +;; Negate a complex +(macrolet + ((frob (float-type fneg cost) + (let* ((vop-name (symbolicate "%NEGATE/COMPLEX-" float-type)) + (c-type (symbolicate "COMPLEX-" float-type "-FLOAT")) + (complex-reg (symbolicate "COMPLEX-" float-type "-REG")) + (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN")) + (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN"))) + `(define-vop (,vop-name) + (:args (x :scs (,complex-reg))) + (:arg-types ,c-type) + (:results (r :scs (,complex-reg))) + (:result-types ,c-type) + (:policy :fast-safe) + (:note _N"inline complex float arithmetic") + (:translate %negate) + (:generator ,cost + (let ((xr (,real-tn x)) + (xi (,imag-tn x)) + (rr (,real-tn r)) + (ri (,imag-tn r))) + (,@fneg rr xr) + (,@fneg ri xi))))))) + (frob single (inst fnegs) 4) + (frob double (negate-double-reg) 4)) + +;; Add and subtract for two complex arguments +(macrolet + ((frob (op inst float-type cost) + (let* ((vop-name (symbolicate (symbol-name op) "/COMPLEX-" float-type "-FLOAT")) + (c-type (symbolicate "COMPLEX-" float-type "-FLOAT")) + (complex-reg (symbolicate "COMPLEX-" float-type "-REG")) + (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN")) + (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN"))) + `(define-vop (,vop-name) + (:args (x :scs (,complex-reg)) (y :scs (,complex-reg))) + (:results (r :scs (,complex-reg))) + (:arg-types ,c-type ,c-type) + (:result-types ,c-type) + (:policy :fast-safe) + (:note _N"inline complex float arithmetic") + (:translate ,op) + (:generator ,cost + (let ((xr (,real-part x)) + (xi (,imag-part x)) + (yr (,real-part y)) + (yi (,imag-part y)) + (rr (,real-part r)) + (ri (,imag-part r))) + (inst ,inst rr xr yr) + (inst ,inst ri xi yi))))))) + (frob + fadds single 4) + (frob + faddd double 4) + (frob - fsubs single 4) + (frob - fsubd double 4)) + +;; Add and subtract a complex and a float + +(macrolet + ((frob (size op fop cost) + (let ((vop-name (symbolicate "COMPLEX-" size "-FLOAT-" + op + "-" size "-FLOAT")) + (complex-reg (symbolicate "COMPLEX-" size "-REG")) + (real-reg (symbolicate size "-REG")) + (c-type (symbolicate "COMPLEX-" size "-FLOAT")) + (r-type (symbolicate size "-FLOAT")) + (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN")) + (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")) + (load (ecase size + (single 'ldf) + (double 'lddf))) + (zero-sym (ecase size + (single '*fp-constant-0f0*) + (double '*fp-constant-0d0*))) + (slot (ecase size + (single vm:single-float-value-slot) + (double vm:double-float-value-slot)))) + `(define-vop (,vop-name) + (:args (x :scs (,complex-reg)) + (y :scs (,real-reg))) + (:results (r :scs (,complex-reg))) + (:arg-types ,c-type ,r-type) + (:result-types ,c-type) + (:policy :fast-safe) + (:temporary (:scs (,real-reg)) zero) + (:temporary (:scs (descriptor-reg)) zero-val) + (:note _N"inline complex float/float arithmetic") + (:translate ,op) + (:generator ,cost + (let ((xr (,real-part x)) + (xi (,imag-part x)) + (rr (,real-part r)) + (ri (,imag-part r))) + ;; Load up the necessary floating-point zero that we + ;; need. It would be nice if we could do something + ;; like xr-xr to get a floating-point zero, but that + ;; can cause spurious signals if xr is an infinity or + ;; NaN. + (load-symbol-value zero-val ,zero-sym) + (inst ,load zero zero-val (- (* ,slot vm:word-bytes) + vm:other-pointer-type)) + (inst ,fop rr xr y) + (inst ,fop ri xi zero))))))) + + (frob single + fadds 2) + (frob single - fsubs 2) + (frob double + faddd 4) + (frob double - fsubd 4)) + +;; Add a float and a complex +(macrolet + ((frob (size fop cost) + (let ((vop-name + (symbolicate size "-FLOAT-+-COMPLEX-" size "-FLOAT")) + (complex-reg (symbolicate "COMPLEX-" size "-REG")) + (real-reg (symbolicate size "-REG")) + (c-type (symbolicate "COMPLEX-" size "-FLOAT")) + (r-type (symbolicate size "-FLOAT")) + (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN")) + (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")) + (load (ecase size + (single 'ldf) + (double 'lddf))) + (zero-sym (ecase size + (single '*fp-constant-0f0*) + (double '*fp-constant-0d0*))) + (slot (ecase size + (single vm:single-float-value-slot) + (double vm:double-float-value-slot)))) + `(define-vop (,vop-name) + (:args (y :scs (,real-reg)) + (x :scs (,complex-reg))) + (:results (r :scs (,complex-reg))) + (:arg-types ,r-type ,c-type) + (:result-types ,c-type) + (:temporary (:scs (,real-reg)) zero) + (:temporary (:scs (descriptor-reg)) zero-val) + (:policy :fast-safe) + (:note _N"inline complex float/float arithmetic") + (:translate +) + (:generator ,cost + (let ((xr (,real-part x)) + (xi (,imag-part x)) + (rr (,real-part r)) + (ri (,imag-part r))) + (load-symbol-value zero-val ,zero-sym) + (inst ,load zero zero-val (- (* ,slot vm:word-bytes) + vm:other-pointer-type)) + (inst ,fop rr xr y) + (inst ,fop ri xi zero))))))) + (frob single fadds 1) + (frob double faddd 2)) + +;; Subtract a complex from a float. +;; +(macrolet + ((frob (size fop cost) + (let ((vop-name (symbolicate size "-FLOAT---COMPLEX-" size "-FLOAT")) + (complex-reg (symbolicate "COMPLEX-" size "-REG")) + (real-reg (symbolicate size "-REG")) + (c-type (symbolicate "COMPLEX-" size "-FLOAT")) + (r-type (symbolicate size "-FLOAT")) + (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN")) + (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")) + (load (ecase size + (single 'ldf) + (double 'lddf))) + (zero-sym (ecase size + (single '*fp-constant-0f0*) + (double '*fp-constant-0d0*))) + (slot (ecase size + (single vm:single-float-value-slot) + (double vm:double-float-value-slot)))) + `(define-vop (,vop-name) + (:args (x :scs (,real-reg)) (y :scs (,complex-reg))) + (:results (r :scs (,complex-reg))) + (:arg-types ,r-type ,c-type) + (:result-types ,c-type) + (:temporary (:scs (,real-reg)) zero) + (:temporary (:scs (descriptor-reg)) zero-val) + (:policy :fast-safe) + (:note _N"inline complex float/float arithmetic") + (:translate -) + (:generator ,cost + (let ((yr (,real-part y)) + (yi (,imag-part y)) + (rr (,real-part r)) + (ri (,imag-part r))) + (load-symbol-value zero-val ,zero-sym) + (inst ,load zero zero-val (- (* ,slot vm:word-bytes) + vm:other-pointer-type)) + (inst ,fop rr x yr) + (inst ,fop ri zero yi))))))) + + (frob single fsubs 2) + (frob double fsubd 2)) + +;; Multiply two complex numbers +(macrolet + ((frob (size fmul fadd fsub mov cost) + (let ((vop-name (symbolicate "*/COMPLEX-" size "-FLOAT")) + (complex-reg (symbolicate "COMPLEX-" size "-REG")) + (real-reg (symbolicate size "-REG")) + (c-type (symbolicate "COMPLEX-" size "-FLOAT")) + (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN")) + (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN"))) + `(define-vop (,vop-name) + (:args (x :scs (,complex-reg)) + (y :scs (,complex-reg))) + (:results (r :scs (,complex-reg))) + (:arg-types ,c-type ,c-type) + (:result-types ,c-type) + (:policy :fast-safe) + (:note _N"inline complex float multiplication") + (:translate *) + (:temporary (:scs (,real-reg)) p1 p2) + (:generator ,cost + (let ((xr (,real-part x)) + (xi (,imag-part x)) + (yr (,real-part y)) + (yi (,imag-part y)) + (rr (,real-part r)) + (ri (,imag-part r))) + ;; Be careful because r might be packed into the same + ;; location as either x or y. We have to be careful + ;; not to modify either x or y until all uses of x or + ;; y. + (inst ,fmul p1 yr xr) ; p1 = xr*yr + (inst ,fmul p2 xi yi) ; p2 = xi*yi + (inst ,fsub p2 p1 p2) ; p2 = xr*yr - xi*yi + (inst ,fmul p1 xr yi) ; p1 = xr*yi + (inst ,fmul ri xi yr) ; ri = xi*yr + (inst ,fadd ri ri p1) ; ri = xi*yr + xr*yi + (,@mov rr p2))))))) + + (frob single fmuls fadds fsubs (inst fmovs) 6) + (frob double fmuld faddd fsubd (move-double-reg) 6)) + +;; Multiply a complex by a float. The case of float * complex is +;; handled by a deftransform to convert it to the complex*float case. +(macrolet + ((frob (float-type fmul mov cost) + (let* ((vop-name (symbolicate "COMPLEX-" + float-type + "-FLOAT-*-" + float-type + "-FLOAT")) + (vop-name-r (symbolicate float-type + "-FLOAT-*-COMPLEX-" + float-type + "-FLOAT")) + (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG")) + (real-sc-type (symbolicate float-type "-REG")) + (c-type (symbolicate "COMPLEX-" float-type "-FLOAT")) + (r-type (symbolicate float-type "-FLOAT")) + (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN")) + (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN"))) + `(progn + ;; Complex * float + (define-vop (,vop-name) + (:args (x :scs (,complex-sc-type)) + (y :scs (,real-sc-type))) + (:results (r :scs (,complex-sc-type))) + (:arg-types ,c-type ,r-type) + (:result-types ,c-type) + (:policy :fast-safe) + (:note _N"inline complex float arithmetic") + (:translate *) + (:temporary (:scs (,real-sc-type)) temp) + (:generator ,cost + (let ((xr (,real-part x)) + (xi (,imag-part x)) + (rr (,real-part r)) + (ri (,imag-part r))) + (cond ((location= y rr) + (inst ,fmul temp xr y) ; xr * y + (inst ,fmul ri xi y) ; xi * yi + (,@mov rr temp)) + (t + (inst ,fmul rr xr y) + (inst ,fmul ri xi y)))))) + ;; Float * complex + (define-vop (,vop-name-r) + (:args (y :scs (,real-sc-type)) + (x :scs (,complex-sc-type))) + (:results (r :scs (,complex-sc-type))) + (:arg-types ,r-type ,c-type) + (:result-types ,c-type) + (:policy :fast-safe) + (:note _N"inline complex float arithmetic") + (:translate *) + (:temporary (:scs (,real-sc-type)) temp) + (:generator ,cost + (let ((xr (,real-part x)) + (xi (,imag-part x)) + (rr (,real-part r)) + (ri (,imag-part r))) + (cond ((location= y rr) + (inst ,fmul temp xr y) ; xr * y + (inst ,fmul ri xi y) ; xi * yi + (,@mov rr temp)) + (t + (inst ,fmul rr xr y) + (inst ,fmul ri xi y)))))))))) + (frob single fmuls (inst fmovs) 4) + (frob double fmuld (move-double-reg) 4)) + + +;; Divide a complex by a complex + +;; Here's how we do a complex division +;; +;; Compute (xr + i*xi)/(yr + i*yi) +;; +;; Assume |yi| < |yr|. Then +;; +;; (xr + i*xi) (xr + i*xi) +;; ----------- = ----------------- +;; (yr + i*yi) yr*(1 + i*(yi/yr)) +;; +;; (xr + i*xi)*(1 - i*(yi/yr)) +;; = --------------------------- +;; yr*(1 + (yi/yr)^2) +;; +;; (xr + (yi/yr)*xi) + i*(xi - (yi/yr)*xr) +;; = -------------------------------------- +;; yr + (yi/yr)*yi +;; +;; +;; We do the similar thing when |yi| > |yr|. The result is +;; +;; +;; (xr + i*xi) (xr + i*xi) +;; ----------- = ----------------- +;; (yr + i*yi) yi*((yr/yi) + i) +;; +;; (xr + i*xi)*((yr/yi) - i) +;; = ------------------------- +;; yi*((yr/yi)^2 + 1) +;; +;; (xr*(yr/yi) + xi) + i*(xi*(yr/yi) - xr) +;; = --------------------------------------- +;; yi + (yr/yi)*yr +;; + +(macrolet + ((frob (float-type fcmp fadd fsub fmul fdiv fabs cost) + (let ((vop-name (symbolicate "//COMPLEX-" float-type "-FLOAT")) + (complex-reg (symbolicate "COMPLEX-" float-type "-REG")) + (real-reg (symbolicate float-type "-REG")) + (c-type (symbolicate "COMPLEX-" float-type "-FLOAT")) + (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN")) + (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN"))) + `(define-vop (,vop-name) + (:args (x :scs (,complex-reg)) + (y :scs (,complex-reg))) + (:results (r :scs (,complex-reg))) + (:arg-types ,c-type ,c-type) + (:result-types ,c-type) + (:policy :fast-safe) + (:note _N"inline complex float division") + (:translate /) + (:temporary (:sc ,real-reg) ratio) + (:temporary (:sc ,real-reg) den) + (:temporary (:sc ,real-reg) temp-r) + (:temporary (:sc ,real-reg) temp-i) + (:generator ,cost + (let ((xr (,real-part x)) + (xi (,imag-part x)) + (yr (,real-part y)) + (yi (,imag-part y)) + (rr (,real-part r)) + (ri (,imag-part r)) + (bigger (gen-label)) + (done (gen-label))) + (,@fabs ratio yr) + (,@fabs den yi) + (inst ,fcmp den ratio) + (unless (backend-featurep :sparc-v9) + (inst nop)) + (inst fb :ge bigger) + (inst nop) + ;; The case of |yi| <= |yr| + (inst ,fdiv ratio yi yr) ; ratio = yi/yr + (inst ,fmul den ratio yi) + (inst ,fmul temp-r ratio xi) + (inst ,fmul temp-i ratio xr) + + (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi + (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi + (inst b done) + (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr + + + (emit-label bigger) + ;; The case of |yi| > |yr| + (inst ,fdiv ratio yr yi) ; ratio = yr/yi + (inst ,fmul den ratio yr) + (inst ,fmul temp-r ratio xr) + (inst ,fmul temp-i ratio xi) + + (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr + (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi) + + (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr + + (emit-label done) + + (inst ,fdiv rr temp-r den) + (inst ,fdiv ri temp-i den) + )))))) + + (frob single fcmps fadds fsubs fmuls fdivs (inst fabss) 15) + (frob double fcmpd faddd fsubd fmuld fdivd (abs-double-reg) 15)) + + +;; Divide a complex by a real +(macrolet + ((frob (float-type fdiv fmov cost) + (let* ((vop-name (symbolicate "COMPLEX-" float-type "-FLOAT-/-" float-type "-FLOAT")) + (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG")) + (real-sc-type (symbolicate float-type "-REG")) + (c-type (symbolicate "COMPLEX-" float-type "-FLOAT")) + (r-type (symbolicate float-type "-FLOAT")) + (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN")) + (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN"))) + `(define-vop (,vop-name) + (:args (x :scs (,complex-sc-type)) (y :scs (,real-sc-type))) + (:results (r :scs (,complex-sc-type))) + (:arg-types ,c-type ,r-type) + (:result-types ,c-type) + (:policy :fast-safe) + (:note _N"inline complex float arithmetic") + (:translate /) + (:temporary (:sc ,real-sc-type) tmp) + (:generator ,cost + (let ((xr (,real-part x)) + (xi (,imag-part x)) + (rr (,real-part r)) + (ri (,imag-part r))) + (cond ((location= r y) + (inst ,fdiv tmp xr y) + (inst ,fdiv ri xi y) + (,@fmov rr tmp)) + (t + (inst ,fdiv rr xr y) ; xr * y + (inst ,fdiv ri xi y) ; xi * yi + )))))))) + (frob single fdivs (inst fmovs) 2) + (frob double fdivd (move-double-reg) 2)) + +;; Divide a real by a complex + +(macrolet + ((frob (float-type fcmp fadd fmul fdiv fneg fabs cost) + (let ((vop-name (symbolicate float-type "-FLOAT-/-COMPLEX-" float-type "-FLOAT")) + (complex-reg (symbolicate "COMPLEX-" float-type "-REG")) + (real-reg (symbolicate float-type "-REG")) + (r-type (symbolicate float-type "-FLOAT")) + (c-type (symbolicate "COMPLEX-" float-type "-FLOAT")) + (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN")) + (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN"))) + `(define-vop (,vop-name) + (:args (x :scs (,real-reg)) + (y :scs (,complex-reg))) + (:results (r :scs (,complex-reg))) + (:arg-types ,r-type ,c-type) + (:result-types ,c-type) + (:policy :fast-safe) + (:note _N"inline complex float division") + (:translate /) + (:temporary (:sc ,real-reg) ratio) + (:temporary (:sc ,real-reg) den) + (:generator ,cost + (let ((yr (,real-tn y)) + (yi (,imag-tn y)) + (rr (,real-tn r)) + (ri (,imag-tn r)) + (bigger (gen-label)) + (done (gen-label))) + (,@fabs ratio yr) + (,@fabs den yi) + (inst ,fcmp den ratio) + (unless (backend-featurep :sparc-v9) + (inst nop)) + (inst fb :ge bigger) + (inst nop) + ;; The case of |yi| <= |yr| + (inst ,fdiv ratio yi yr) ; ratio = yi/yr + (inst ,fmul den ratio yi) + (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi + + (inst ,fmul ri ratio x) ; ri = (yi/yr)*x + (inst ,fdiv rr x den) ; rr = x/den + (inst b done) + (inst ,fdiv ri ri den) ; ri = (yi/yr)*x/den + + (emit-label bigger) + ;; The case of |yi| > |yr| + (inst ,fdiv ratio yr yi) ; ratio = yr/yi + (inst ,fmul den ratio yr) + (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr + + (inst ,fmul ri ratio x) ; ri = (yr/yi)*x + (inst ,fdiv rr ri den) ; rr = (yr/yi)*x/den + (inst ,fdiv ri x den) ; ri = x/den + (emit-label done) + + (,@fneg ri ri))))))) + + (frob single fcmps fadds fmuls fdivs (inst fnegs) (inst fabss) 10) + (frob double fcmpd faddd fmuld fdivd (negate-double-reg) (abs-double-reg) 10)) + +;; Conjugate of a complex number + +(macrolet + ((frob (float-type fneg fmov cost) + (let ((vop-name (symbolicate "CONJUGATE/COMPLEX-" float-type "-FLOAT")) + (complex-reg (symbolicate "COMPLEX-" float-type "-REG")) + (c-type (symbolicate "COMPLEX-" float-type "-FLOAT")) + (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN")) + (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN"))) + `(define-vop (,vop-name) + (:args (x :scs (,complex-reg))) + (:results (r :scs (,complex-reg))) + (:arg-types ,c-type) + (:result-types ,c-type) + (:policy :fast-safe) + (:note _N"inline complex conjugate") + (:translate conjugate) + (:generator ,cost + (let ((xr (,real-part x)) + (xi (,imag-part x)) + (rr (,real-part r)) + (ri (,imag-part r))) + (,@fneg ri xi) + (unless (location= rr xr) + (,@fmov rr xr)))))))) + + (frob single (inst fnegs) (inst fmovs) 4) + (frob double (negate-double-reg) (move-double-reg) 4)) + +;; Compare a float with a complex or a complex with a float +#+nil +(macrolet + ((frob (name name-r f-type c-type) + `(progn + (defknown ,name (,f-type ,c-type) t) + (defknown ,name-r (,c-type ,f-type) t) + (defun ,name (x y) + (declare (type ,f-type x) + (type ,c-type y)) + (,name x y)) + (defun ,name-r (x y) + (declare (type ,c-type x) + (type ,f-type y)) + (,name-r x y)) + ))) + (frob %compare-complex-single-single %compare-single-complex-single + single-float (complex single-float)) + (frob %compare-complex-double-double %compare-double-complex-double + double-float (complex double-float))) + +#+nil +(macrolet + ((frob (trans-1 trans-2 float-type fcmp fsub) + (let ((vop-name + (symbolicate "COMPLEX-" float-type "-FLOAT-" + float-type "-FLOAT-COMPARE")) + (vop-name-r + (symbolicate float-type "-FLOAT-COMPLEX-" + float-type "-FLOAT-COMPARE")) + (complex-reg (symbolicate "COMPLEX-" float-type "-REG")) + (real-reg (symbolicate float-type "-REG")) + (c-type (symbolicate "COMPLEX-" float-type "-FLOAT")) + (r-type (symbolicate float-type "-FLOAT")) + (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN")) + (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN"))) + `(progn + ;; (= float complex) + (define-vop (,vop-name) + (:args (x :scs (,real-reg)) + (y :scs (,complex-reg))) + (:arg-types ,r-type ,c-type) + (:translate ,trans-1) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note _N"inline complex float/float comparison") + (:vop-var vop) + (:save-p :compute-only) + (:temporary (:sc ,real-reg) fp-zero) + (:guard (not (backend-featurep :sparc-v9))) + (:generator 6 + (note-this-location vop :internal-error) + (let ((yr (,real-part y)) + (yi (,imag-part y))) + ;; Set fp-zero to zero + (inst ,fsub fp-zero fp-zero fp-zero) + (inst ,fcmp x yr) + (inst nop) + (inst fb (if not-p :ne :eq) target #+sparc-v9 :fcc0 #+sparc-v9 :pn) + (inst ,fcmp yi fp-zero) + (inst nop) + (inst fb (if not-p :ne :eq) target #+sparc-v9 :fcc0 #+sparc-v9 :pn) + (inst nop)))) + ;; (= complex float) + (define-vop (,vop-name-r) + (:args (y :scs (,complex-reg)) + (x :scs (,real-reg))) + (:arg-types ,c-type ,r-type) + (:translate ,trans-2) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note _N"inline complex float/float comparison") + (:vop-var vop) + (:save-p :compute-only) + (:temporary (:sc ,real-reg) fp-zero) + (:guard (not (backend-featurep :sparc-v9))) + (:generator 6 + (note-this-location vop :internal-error) + (let ((yr (,real-part y)) + (yi (,imag-part y))) + ;; Set fp-zero to zero + (inst ,fsub fp-zero fp-zero fp-zero) + (inst ,fcmp x yr) + (inst nop) + (inst fb (if not-p :ne :eq) target #+sparc-v9 :fcc0 #+sparc-v9 :pn) + (inst ,fcmp yi fp-zero) + (inst nop) + (inst fb (if not-p :ne :eq) target #+sparc-v9 :fcc0 #+sparc-v9 :pn) + (inst nop)))))))) + (frob %compare-complex-single-single %compare-single-complex-single + single fcmps fsubs) + (frob %compare-complex-double-double %compare-double-complex-double + double fcmpd fsubd)) + +;; Compare two complex numbers for equality +(macrolet + ((frob (float-type fcmp) + (let ((vop-name + (symbolicate "COMPLEX-" float-type "-FLOAT-COMPARE")) + (complex-reg (symbolicate "COMPLEX-" float-type "-REG")) + (c-type (symbolicate "COMPLEX-" float-type "-FLOAT")) + (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN")) + (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN"))) + `(define-vop (,vop-name) + (:args (x :scs (,complex-reg)) + (y :scs (,complex-reg))) + (:arg-types ,c-type ,c-type) + (:translate =) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note _N"inline complex float comparison") + (:vop-var vop) + (:save-p :compute-only) + (:guard (not (backend-featurep :sparc-v9))) + (:generator 6 + (note-this-location vop :internal-error) + (let ((xr (,real-part x)) + (xi (,imag-part x)) + (yr (,real-part y)) + (yi (,imag-part y))) + (inst ,fcmp xr yr) + (inst nop) + (inst fb (if not-p :ne :eq) target #+sparc-v9 :fcc0 #+sparc-v9 :pn) + (inst ,fcmp xi yi) + (inst nop) + (inst fb (if not-p :ne :eq) target #+sparc-v9 :fcc0 #+sparc-v9 :pn) + (inst nop))))))) + (frob single fcmps) + (frob double fcmpd)) + +;; Compare a complex with a complex, for V9 +(macrolet + ((frob (float-type fcmp) + (let ((vop-name + (symbolicate "V9-COMPLEX-" float-type "-FLOAT-COMPARE")) + (complex-reg (symbolicate "COMPLEX-" float-type "-REG")) + (c-type (symbolicate "COMPLEX-" float-type "-FLOAT")) + (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN")) + (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN"))) + `(define-vop (,vop-name) + (:args (x :scs (,complex-reg)) + (y :scs (,complex-reg))) + (:arg-types ,c-type ,c-type) + (:translate =) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note _N"inline complex float comparison") + (:vop-var vop) + (:save-p :compute-only) + (:temporary (:sc descriptor-reg) true) + (:guard (backend-featurep :sparc-v9)) + (:generator 6 + (note-this-location vop :internal-error) + (let ((xr (,real-part x)) + (xi (,imag-part x)) + (yr (,real-part y)) + (yi (,imag-part y))) + ;; Assume comparison is true + (load-symbol true t) + (inst ,fcmp xr yr) + (inst cmove (if not-p :eq :ne) true null-tn :fcc0) + (inst ,fcmp xi yi) + (inst cmove (if not-p :eq :ne) true null-tn :fcc0) + (inst cmp true null-tn) + (inst b (if not-p :eq :ne) target :pt) + (inst nop))))))) + (frob single fcmps) + (frob double fcmpd)) + + +;; Instead of providing vops, we just transform these to the obvious +;; implementation. There are probably a few unnecessary moves. + +(macrolet + ((cvt (name prototype) + `(progn + (deftransform ,name ((n) (real) * :when :both) + '(complex (float n ,prototype))) + (deftransform ,name ((n) (complex) * :when :both) + '(complex (float (realpart n) ,prototype) + (float (imagpart n) ,prototype)))))) + (cvt %complex-single-float 1f0) + (cvt %complex-double-float 1d0)) + + +) ; end progn complex-fp-vops + +#+sparc-v9 +(progn + +;; Vops to take advantage of the conditional move instruction +;; available on the Sparc V9 + +(defknown (%%max %%min) ((or (unsigned-byte #.vm:word-bits) + (signed-byte #.vm:word-bits) + single-float double-float) + (or (unsigned-byte #.vm:word-bits) + (signed-byte #.vm:word-bits) + single-float double-float)) + (or (unsigned-byte #.vm:word-bits) + (signed-byte #.vm:word-bits) + single-float double-float) + (movable foldable flushable)) + +;; We need these definitions for byte-compiled code +(defun %%min (x y) + (declare (type (or (unsigned-byte 32) (signed-byte 32) + single-float double-float) x y)) + (if (<= x y) + x y)) + +(defun %%max (x y) + (declare (type (or (unsigned-byte 32) (signed-byte 32) + single-float double-float) x y)) + (if (>= x y) + x y)) + +(macrolet + ((frob (name sc-type type compare cmov cost cc max min note) + (let ((vop-name (symbolicate name "-" type "=>" type)) + (trans-name (symbolicate "%%" name))) + `(define-vop (,vop-name) + (:args (x :scs (,sc-type)) + (y :scs (,sc-type))) + (:results (r :scs (,sc-type))) + (:arg-types ,type ,type) + (:result-types ,type) + (:policy :fast-safe) + (:note ,note) + (:translate ,trans-name) + (:guard (backend-featurep :sparc-v9)) + (:generator ,cost + (inst ,compare x y) + (cond ((location= r x) + ;; If x < y, need to move y to r, otherwise r already has + ;; the max. + (inst ,cmov ,min r y ,cc)) + ((location= r y) + ;; If x > y, need to move x to r, otherwise r already has + ;; the max. + (inst ,cmov ,max r x ,cc)) + (t + ;; It doesn't matter what R is, just copy the min to R. + (inst ,cmov ,max r x ,cc) + (inst ,cmov ,min r y ,cc)))))))) + (frob max single-reg single-float fcmps cfmovs 3 + :fcc0 :ge :l _N"inline float max") + (frob max double-reg double-float fcmpd cfmovd 3 + :fcc0 :ge :l _N"inline float max") + (frob min single-reg single-float fcmps cfmovs 3 + :fcc0 :l :ge _N"inline float min") + (frob min double-reg double-float fcmpd cfmovd 3 + :fcc0 :l :ge _N"inline float min") + ;; Strictly speaking these aren't float ops, but it's convenient to + ;; do them here. + ;; + ;; The cost is here is the worst case number of instructions. For + ;; 32-bit integer operands, we add 2 more to account for the + ;; untagging of fixnums, if necessary. + (frob max signed-reg signed-num cmp cmove 5 + :icc :ge :lt _N"inline (signed-byte 32) max") + (frob max unsigned-reg unsigned-num cmp cmove 5 + :icc :ge :lt _N"inline (unsigned-byte 32) max") + ;; For fixnums, make the cost lower so we don't have to untag the + ;; numbers. + (frob max any-reg tagged-num cmp cmove 3 + :icc :ge :lt _N"inline fixnum max") + (frob min signed-reg signed-num cmp cmove 5 + :icc :lt :ge _N"inline (signed-byte 32) min") + (frob min unsigned-reg unsigned-num cmp cmove 5 + :icc :lt :ge _N"inline (unsigned-byte 32) min") + ;; For fixnums, make the cost lower so we don't have to untag the + ;; numbers. + (frob min any-reg tagged-num cmp cmove 3 + :icc :lt :ge _N"inline fixnum min")) + +#+nil +(define-vop (max-boxed-double-float=>boxed-double-float) + (:args (x :scs (descriptor-reg)) + (y :scs (descriptor-reg))) + (:results (r :scs (descriptor-reg))) + (:arg-types double-float double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note _N"inline float max/min") + (:translate %max-double-float) + (:temporary (:scs (double-reg)) xval) + (:temporary (:scs (double-reg)) yval) + (:guard (backend-featurep :sparc-v9)) + (:vop-var vop) + (:generator 3 + (let ((offset (- (* vm:double-float-value-slot vm:word-bytes) + vm:other-pointer-type))) + (inst lddf xval x offset) + (inst lddf yval y offset) + (inst fcmpd xval yval) + (cond ((location= r x) + ;; If x < y, need to move y to r, otherwise r already has + ;; the max. + (inst cmove :l r y :fcc0)) + ((location= r y) + ;; If x > y, need to move x to r, otherwise r already has + ;; the max. + (inst cmove :ge r x :fcc0)) + (t + ;; It doesn't matter what R is, just copy the min to R. + (inst cmove :ge r x :fcc0) + (inst cmove :l r y :fcc0)))))) + +) + +(in-package "C") +#+sparc-v9 +(progn +;;; The sparc-v9 architecture has conditional move instructions that +;;; can be used. This should be faster than using the obvious if +;;; expression since we don't have to do branches. + +(def-source-transform min (&rest args) + (case (length args) + ((0 2) (values nil t)) + (1 `(values (the real ,(first args)))) + (t (c::associate-arguments 'min (first args) (rest args))))) + +(def-source-transform max (&rest args) + (case (length args) + ((0 2) (values nil t)) + (1 `(values (the real ,(first args)))) + (t (c::associate-arguments 'max (first args) (rest args))))) + +;; Derive the types of max and min +(defoptimizer (max derive-type) ((x y)) + ;; It's Y < X instead of X < Y because that's how the + ;; source-transform, the deftransform and the max function do the + ;; comparisons. This is important if the types of X and Y are + ;; different types, like integer vs double-float because CMUCL + ;; returns the actual arg, instead of applying float-contagion to + ;; the result. + (multiple-value-bind (definitely-< definitely->=) + (ir1-transform-<-helper y x) + (cond (definitely-< + (continuation-type x)) + (definitely->= + (continuation-type y)) + (t + (make-canonical-union-type (list (continuation-type x) + (continuation-type y))))))) + +(defoptimizer (min derive-type) ((x y)) + (multiple-value-bind (definitely-> definitely-<=) + (ir1-transform-<-helper y x) + (cond (definitely-<= + (continuation-type x)) + (definitely-> + (continuation-type y)) + (t + (make-canonical-union-type (list (continuation-type x) + (continuation-type y))))))) + +(deftransform max ((x y) (number number) * :when :both) + (let ((x-type (continuation-type x)) + (y-type (continuation-type y)) + (signed (specifier-type '(signed-byte #.vm:word-bits))) + (unsigned (specifier-type '(unsigned-byte #.vm:word-bits))) + (d-float (specifier-type 'double-float)) + (s-float (specifier-type 'single-float))) + ;; Use %%max if both args are good types of the same type. As a + ;; last resort, use the obvious comparison to select the desired + ;; element. + (cond ((and (csubtypep x-type signed) + (csubtypep y-type signed)) + `(sparc::%%max x y)) + ((and (csubtypep x-type unsigned) + (csubtypep y-type unsigned)) + `(sparc::%%max x y)) + ((and (csubtypep x-type d-float) + (csubtypep y-type d-float)) + `(sparc::%%max x y)) + ((and (csubtypep x-type s-float) + (csubtypep y-type s-float)) + `(sparc::%%max x y)) + (t + (let ((arg1 (gensym)) + (arg2 (gensym))) + `(let ((,arg1 x) + (,arg2 y)) + (if (> ,arg1 ,arg2) + ,arg1 ,arg2))))))) + +(deftransform min ((x y) (real real) * :when :both) + (let ((x-type (continuation-type x)) + (y-type (continuation-type y)) + (signed (specifier-type '(signed-byte #.vm:word-bits))) + (unsigned (specifier-type '(unsigned-byte #.vm:word-bits))) + (d-float (specifier-type 'double-float)) + (s-float (specifier-type 'single-float))) + (cond ((and (csubtypep x-type signed) + (csubtypep y-type signed)) + `(sparc::%%min x y)) + ((and (csubtypep x-type unsigned) + (csubtypep y-type unsigned)) + `(sparc::%%min x y)) + ((and (csubtypep x-type d-float) + (csubtypep y-type d-float)) + `(sparc::%%min x y)) + ((and (csubtypep x-type s-float) + (csubtypep y-type s-float)) + `(sparc::%%min x y)) + (t + (let ((arg1 (gensym)) + (arg2 (gensym))) + `(let ((,arg1 x) + (,arg2 y)) + (if (< ,arg1 ,arg2) + ,arg1 ,arg2))))))) + +) + + + +(in-package "SPARC") + + +;;; Support for double-double floats + +#+double-double +(progn +(defun double-double-reg-hi-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset x))) + +(defun double-double-reg-lo-tn (x) + ;; The low tn is 2 more than the offset because double regs are + ;; even. + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 2 (tn-offset x)))) + +(define-move-function (load-double-double 4) (vop x y) + ((double-double-stack) (double-double-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) vm:word-bytes))) + (let ((hi-tn (double-double-reg-hi-tn y))) + (inst lddf hi-tn nfp offset)) + (let ((lo-tn (double-double-reg-lo-tn y))) + (inst lddf lo-tn nfp (+ offset (* 2 vm:word-bytes)))))) + +(define-move-function (store-double-double 4) (vop x y) + ((double-double-reg) (double-double-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) vm:word-bytes))) + (let ((hi-tn (double-double-reg-hi-tn x))) + (inst stdf hi-tn nfp offset)) + (let ((lo-tn (double-double-reg-lo-tn x))) + (inst stdf lo-tn nfp (+ offset (* 2 vm:word-bytes)))))) + +;;; Double-double float register to register moves + +(define-vop (double-double-move) + (:args (x :scs (double-double-reg) + :target y :load-if (not (location= x y)))) + (:results (y :scs (double-double-reg) :load-if (not (location= x y)))) + (:note _N"double-double float move") + (:generator 0 + (unless (location= x y) + ;; Note the double-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-hi (double-double-reg-hi-tn x)) + (y-hi (double-double-reg-hi-tn y))) + (move-double-reg y-hi x-hi)) + (let ((x-lo (double-double-reg-lo-tn x)) + (y-lo (double-double-reg-lo-tn y))) + (move-double-reg y-lo x-lo))))) +;;; +(define-move-vop double-double-move :move + (double-double-reg) (double-double-reg)) + +;;; Move from a complex float to a descriptor register allocating a +;;; new complex float object in the process. + +(define-vop (move-from-double-double) + (:args (x :scs (double-double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:note _N"double-double float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y ndescr vm::double-double-float-type + vm::double-double-float-size)) + (let ((hi-tn (double-double-reg-hi-tn x))) + (inst stdf hi-tn y (- (* vm::double-double-float-hi-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((lo-tn (double-double-reg-lo-tn x))) + (inst stdf lo-tn y (- (* vm::double-double-float-lo-slot + vm:word-bytes) + vm:other-pointer-type))))) +;;; +(define-move-vop move-from-double-double :move + (double-double-reg) (descriptor-reg)) + +;;; Move from a descriptor to a double-double float register + +(define-vop (move-to-double-double) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (double-double-reg))) + (:note _N"pointer to double-double float coercion") + (:generator 2 + (let ((hi-tn (double-double-reg-hi-tn y))) + (inst lddf hi-tn x (- (* double-double-float-hi-slot word-bytes) + other-pointer-type))) + (let ((lo-tn (double-double-reg-lo-tn y))) + (inst lddf lo-tn x (- (* double-double-float-lo-slot word-bytes) + other-pointer-type))))) + +(define-move-vop move-to-double-double :move + (descriptor-reg) (double-double-reg)) + +;;; double-double float move-argument vop + +(define-vop (move-double-double-float-argument) + (:args (x :scs (double-double-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y double-double-reg)))) + (:results (y)) + (:note _N"double-double float argument move") + (:generator 2 + (sc-case y + (double-double-reg + (unless (location= x y) + (let ((x-hi (double-double-reg-hi-tn x)) + (y-hi (double-double-reg-hi-tn y))) + (move-double-reg y-hi x-hi)) + (let ((x-lo (double-double-reg-lo-tn x)) + (y-lo (double-double-reg-lo-tn y))) + (move-double-reg y-lo x-lo)))) + (double-double-stack + (let ((offset (* (tn-offset y) word-bytes))) + (let ((hi-tn (double-double-reg-hi-tn x))) + (inst stdf hi-tn nfp offset)) + (let ((lo-tn (double-double-reg-lo-tn x))) + (inst stdf lo-tn nfp (+ offset (* 2 word-bytes))))))))) + +(define-move-vop move-double-double-float-argument :move-argument + (double-double-reg descriptor-reg) (double-double-reg)) + + +(define-vop (make/double-double-float) + (:args (hi :scs (double-reg) :target res + :load-if (not (location= hi res))) + (lo :scs (double-reg) :to :save)) + (:results (res :scs (double-double-reg) :from (:argument 0) + :load-if (not (sc-is res double-double-stack)))) + (:arg-types double-float double-float) + (:result-types double-double-float) + (:translate kernel::%make-double-double-float) + (:note _N"inline double-double float creation") + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case res + (double-double-reg + (let ((res-hi (double-double-reg-hi-tn res))) + (unless (location= res-hi hi) + (move-double-reg res-hi hi))) + (let ((res-lo (double-double-reg-lo-tn res))) + (unless (location= res-lo lo) + (move-double-reg res-lo lo)))) + (double-double-stack + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset res) vm:word-bytes))) + (unless (location= hi res) + (inst stdf hi nfp offset)) + (inst stdf lo nfp (+ offset (* 2 vm:word-bytes)))))))) + +(define-vop (double-double-float-value) + (:args (x :scs (double-double-reg descriptor-reg) :target r + :load-if (not (sc-is x double-double-stack)))) + (:arg-types double-double-float) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:variant-vars slot) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (sc-case x + (double-double-reg + (let ((value-tn (ecase slot + (:hi (double-double-reg-hi-tn x)) + (:lo (double-double-reg-lo-tn x))))) + (unless (location= value-tn r) + (move-double-reg r value-tn)))) + (double-double-stack + (inst lddf r (current-nfp-tn vop) (* (+ (ecase slot (:hi 0) (:lo 2)) + (tn-offset x)) + vm:word-bytes))) + (descriptor-reg + (inst lddf r x (- (* vm:word-bytes + (ecase slot + (:hi vm:double-double-float-hi-slot) + (:lo vm:double-double-float-lo-slot))) + vm:other-pointer-type)))))) + +(define-vop (hi/double-double-value double-double-float-value) + (:translate kernel::double-double-hi) + (:note _N"double-double high part") + (:variant :hi)) + +(define-vop (lo/double-double-value double-double-float-value) + (:translate kernel::double-double-lo) + (:note _N"double-double low part") + (:variant :lo)) + + +(define-vop (make-complex-double-double-float) + (:translate complex) + (:args (real :scs (double-double-reg) :target r + :load-if (not (location= real r))) + (imag :scs (double-double-reg) :to :save)) + (:arg-types double-double-float double-double-float) + (:results (r :scs (complex-double-double-reg) :from (:argument 0) + :load-if (not (sc-is r complex-double-double-stack)))) + (:result-types complex-double-double-float) + (:note _N"inline complex double-double float creation") + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case r + (complex-double-double-reg + (let ((r-real (complex-double-double-reg-real-hi-tn r)) + (real-hi (double-double-reg-hi-tn real))) + (move-double-reg r-real real-hi)) + (let ((r-real (complex-double-double-reg-real-lo-tn r)) + (real-lo (double-double-reg-lo-tn real))) + (move-double-reg r-real real-lo)) + (let ((r-imag (complex-double-double-reg-imag-hi-tn r)) + (imag-hi (double-double-reg-hi-tn imag))) + (move-double-reg r-imag imag-hi)) + (let ((r-imag (complex-double-double-reg-imag-lo-tn r)) + (imag-lo (double-double-reg-lo-tn imag))) + (move-double-reg r-imag imag-lo))) + (complex-double-double-stack + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset r) vm:word-bytes))) + (let ((r-real (double-double-reg-hi-tn real))) + (inst stdf r-real nfp offset)) + (let ((r-real (double-double-reg-lo-tn real))) + (inst stdf r-real nfp (+ offset (* 2 vm:word-bytes)))) + (let ((r-imag (double-double-reg-hi-tn imag))) + (inst stdf r-imag nfp (+ offset (* 4 vm:word-bytes)))) + (let ((r-imag (double-double-reg-lo-tn imag))) + (inst stdf r-imag nfp (+ offset (* 6 vm:word-bytes))))))))) + +(define-vop (complex-double-double-float-value) + (:args (x :scs (complex-double-double-reg descriptor-reg) + :load-if (not (or (sc-is x complex-double-double-stack))))) + (:arg-types complex-double-double-float) + (:results (r :scs (double-double-reg))) + (:result-types double-double-float) + (:variant-vars slot) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (sc-case x + (complex-double-double-reg + (let ((value-tn (ecase slot + (:real (complex-double-double-reg-real-hi-tn x)) + (:imag (complex-double-double-reg-imag-hi-tn x)))) + (r-hi (double-double-reg-hi-tn r))) + (unless (location= value-tn r-hi) + (move-double-reg r-hi value-tn))) + (let ((value-tn (ecase slot + (:real (complex-double-double-reg-real-lo-tn x)) + (:imag (complex-double-double-reg-imag-lo-tn x)))) + (r-lo (double-double-reg-lo-tn r))) + (unless (location= value-tn r-lo) + (move-double-reg r-lo value-tn)))) + (complex-double-double-stack + (let ((r-hi (double-double-reg-hi-tn r))) + (inst lddf r-hi (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 4)) + (tn-offset x)) + vm:word-bytes))) + (let ((r-lo (double-double-reg-lo-tn r))) + (inst lddf r-lo (current-nfp-tn vop) (* (+ (ecase slot (:real 2) (:imag 6)) + (tn-offset x)) + vm:word-bytes)))) + (descriptor-reg + (let ((r-hi (double-double-reg-hi-tn r))) + (inst lddf r-hi x (- (* (ecase slot + (:real vm::complex-double-double-float-real-hi-slot) + (:imag vm::complex-double-double-float-imag-hi-slot)) + vm:word-bytes) + vm:other-pointer-type)) + (let ((r-lo (double-double-reg-lo-tn r))) + (inst lddf r-lo x (- (* (ecase slot + (:real vm::complex-double-double-float-real-lo-slot) + (:imag vm::complex-double-double-float-imag-lo-slot)) + vm:word-bytes) + vm:other-pointer-type)))))))) + +(define-vop (realpart/complex-double-double-float complex-double-double-float-value) + (:translate realpart) + (:note _N"complex double-double float realpart") + (:variant :real)) + +(define-vop (imagpart/complex-double-double-float complex-double-double-float-value) + (:translate imagpart) + (:note _N"complex double-double float imagpart") + (:variant :imag)) + +); progn + diff --git a/src/compiler/sparcv9/insts.lisp b/src/compiler/sparcv9/insts.lisp new file mode 100644 index 0000000000000000000000000000000000000000..ac0cee59815841bf8d3752241a89b524fce8cd21 --- /dev/null +++ b/src/compiler/sparcv9/insts.lisp @@ -0,0 +1,2591 @@ +;;; -*- 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/compiler/sparc/insts.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; Description of the SPARC architecture. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") + +(use-package "NEW-ASSEM") +(use-package "EXT") +(use-package "C") + +(def-assembler-params + :scheduler-p t + :max-locations 101) + + +;;;; Constants, types, conversion functions, some disassembler stuff. + +(defun reg-tn-encoding (tn) + (declare (type tn tn)) + (sc-case tn + (zero zero-offset) + (null null-offset) + (t + (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers) + (tn-offset tn) + (error (intl:gettext "~S isn't a register.") tn))))) + +(defun fp-reg-tn-encoding (tn) + (declare (type tn tn)) + (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers) + (error (intl:gettext "~S isn't a floating-point register.") tn)) + (let ((offset (tn-offset tn))) + (cond ((> offset 31) + ;; Use the sparc v9 double float register encoding. + (assert (backend-featurep :sparc-v9)) + ;; No single register encoding greater than reg 31. + (assert (zerop (mod offset 2))) + ;; Upper bit of the register number is encoded in the low bit. + (1+ (- offset 32))) + (t + (tn-offset tn))))) + +(disassem:set-disassem-params :instruction-alignment 32 + :opcode-column-width 11) + +(defvar *disassem-use-lisp-reg-names* t + "If non-NIL, print registers using the Lisp register names. +Otherwise, use the Sparc register names") + +(def-vm-support-routine location-number (loc) + (etypecase loc + (null) + (number) + (fixup) + (tn + (ecase (sb-name (sc-sb (tn-sc loc))) + (registers + (unless (zerop (tn-offset loc)) + (tn-offset loc))) + (float-registers + (sc-case loc + (single-reg + (+ (tn-offset loc) 32)) + (double-reg + (let ((offset (tn-offset loc))) + (assert (zerop (mod offset 2))) + (values (+ offset 32) 2))) + #+long-float + (long-reg + (let ((offset (tn-offset loc))) + (assert (zerop (mod offset 4))) + (values (+ offset 32) 4))))) + (control-registers + 96) + (immediate-constant + nil))) + (symbol + (ecase loc + (:memory 0) + (:psr 97) + (:fsr 98) + (:y 99) + (:tick 100))))) + +;;; symbols used for disassembly printing +;;; +(defparameter reg-symbols + (map 'vector + #'(lambda (name) + (cond ((null name) nil) + (t (make-symbol (concatenate 'string "%" name))))) + sparc::*register-names*) + "The Lisp names for the Sparc integer registers") + +(defparameter sparc-reg-symbols + (map 'vector + #'(lambda (name) + (cond ((null name) nil) + (t (make-symbol (concatenate 'string "%" name))))) + #("G0" "G1" "G2" "G3" "G4" "G5" "G6" "G7" + "O0" "O1" "O2" "O3" "O4" "O5" "O6" "O7" + "L0" "L1" "L2" "L3" "L4" "L5" "L6" "L7" + "I0" "I1" "I2" "I3" "I4" "I5" "I6" "I7")) + "The standard names for the Sparc integer registers") + +(defun get-reg-name (index) + (if *disassem-use-lisp-reg-names* + (aref reg-symbols index) + (aref sparc-reg-symbols index))) + +(defvar *note-sethi-inst* nil + "An alist for the disassembler indicating the target register and +value used in a SETHI instruction. This is used to make annotations +about function addresses and register values.") + +(defvar *pseudo-atomic-set* nil) + +(defun sign-extend-immed-value (val) + ;; val is a 13-bit signed number. Extend the sign appropriately. + (if (logbitp 12 val) + (- val (ash 1 13)) + val)) + +(defmacro frob-names (names) + `(mapcar #'(lambda (n) + (list (eval n) n)) + ,names)) + +(defmacro frob-names (names) + `(mapcar #'(lambda (n) + `(,(eval n) ,n)) + ,names)) + +(macrolet + ((frob (&rest names) + (let ((results (mapcar #'(lambda (n) + (let ((nn (intern (concatenate 'string (string n) + "-TYPE")))) + `(,(eval nn) ,nn))) + names))) + `(eval-when (compile load eval) + (defconstant header-word-type-alist + ',results))))) + ;; This is the same list as in objdefs. + (frob bignum + ratio + single-float + double-float + #+long-float long-float + #+double-double double-double-float + complex + complex-single-float + complex-double-float + #+long-float complex-long-float + #+double-double complex-double-double-float + + simple-array + simple-string + simple-bit-vector + simple-vector + simple-array-unsigned-byte-2 + simple-array-unsigned-byte-4 + simple-array-unsigned-byte-8 + simple-array-unsigned-byte-16 + simple-array-unsigned-byte-32 + simple-array-signed-byte-8 + simple-array-signed-byte-16 + simple-array-signed-byte-30 + simple-array-signed-byte-32 + simple-array-single-float + simple-array-double-float + #+long-float simple-array-long-float + #+double-double simple-array-double-double-float + simple-array-complex-single-float + simple-array-complex-double-float + #+long-float simple-array-complex-long-float + #+double-double simple-array-complex-double-double-float + complex-string + complex-bit-vector + complex-vector + complex-array + + code-header + function-header + closure-header + funcallable-instance-header + byte-code-function + byte-code-closure + #-double-double dylan-function-header + closure-function-header + #-gengc return-pc-header + #+gengc forwarding-pointer + value-cell-header + symbol-header + base-char + sap + unbound-marker + weak-pointer + instance-header + fdefn + #+(or gengc gencgc) scavenger-hook)) + +;; Look at the current instruction and see if we can't add some notes +;; about what's happening. + +(defun maybe-add-notes (reg dstate) + (let* ((word (disassem::sap-ref-int (disassem:dstate-segment-sap dstate) + (disassem:dstate-cur-offs dstate) + vm:word-bytes + (disassem::dstate-byte-order dstate))) + (format (ldb (byte 2 30) word)) + (op3 (ldb (byte 6 19) word)) + (rs1 (ldb (byte 5 14) word)) + (rd (ldb (byte 5 25) word)) + (immed-p (not (zerop (ldb (byte 1 13) word)))) + (immed-val (sign-extend-immed-value (ldb (byte 13 0) word)))) + ;; Only the value of format and rd are guaranteed to be correct + ;; because the disassembler is trying to print out the value of a + ;; register. The other values may not be right. + (case format + (2 + (case op3 + (#b000000 + (when (= reg rs1) + (handle-add-inst rs1 immed-val rd dstate immed-p))) + (#b000010 + (when (= reg rs1) + (handle-or-inst rs1 immed-val rd dstate immed-p))) + (#b000101 + (when (= reg rs1) + (handle-andn-inst rs1 immed-val rd dstate immed-p))) + (#b111000 + (when (= reg rs1) + (handle-jmpl-inst rs1 immed-val rd dstate))) + (#b010001 + (when (= reg rs1) + (handle-andcc-inst rs1 immed-val rd dstate))))) + (3 + (case op3 + ((#b000000 #b000100) + (when (= reg rs1) + (handle-ld/st-inst rs1 immed-val rd dstate)))))) + ;; If this is not a SETHI instruction, and RD is the same as some + ;; register used by SETHI, we delete the entry. (In case we have + ;; a SETHI without any additional instruction because the low bits + ;; were zero.) + (unless (and (zerop format) (= #b100 (ldb (byte 3 22) word))) + (let ((sethi (assoc rd *note-sethi-inst*))) + (when sethi + (setf *note-sethi-inst* (delete sethi *note-sethi-inst*))))))) + +(defun handle-add-inst (rs1 immed-val rd dstate immed-p) + (let* ((sethi (assoc rs1 *note-sethi-inst*))) + (cond + (sethi + ;; RS1 was used in a SETHI instruction. Assume that + ;; this is the offset part of the SETHI instruction for + ;; a full 32-bit address of something. Make a note + ;; about this usage as a Lisp assembly routine or + ;; foreign routine, if possible. If not, just note the + ;; final value. + (let ((addr (+ immed-val (ash (cdr sethi) 10)))) + (or (disassem::note-code-constant-absolute addr dstate) + (disassem::maybe-note-assembler-routine addr t dstate) + (disassem::note (format nil "~A = #x~8,'0X" + (get-reg-name rd) addr) + dstate))) + (setf *note-sethi-inst* (delete sethi *note-sethi-inst*))) + ((and (= rs1 null-offset) immed-p) + ;; We have an ADD %NULL, <n>, RD instruction. This is a + ;; reference to a static symbol. + (disassem:maybe-note-nil-indexed-object immed-val + dstate)) + ((= rs1 alloc-offset) + ;; ADD %ALLOC, n. This must be some allocation or + ;; pseudo-atomic stuff + (cond ((and immed-p + (= immed-val 4) + (= rd alloc-offset) + (not *pseudo-atomic-set*)) + ;; "ADD 4, %ALLOC" sets the flag + (disassem:note (intl:gettext "Set pseudo-atomic flag") dstate) + (setf *pseudo-atomic-set* t)) + ((= rd alloc-offset) + ;; "ADD n, %ALLOC" is either allocating space or + ;; resetting the flag. + (cond (immed-p + (cond ((= immed-val -4) + (disassem:note + (format nil (intl:gettext "Reset pseudo-atomic")) + dstate) + (setf *pseudo-atomic-set* nil)) + (t + (disassem:note + (format nil (intl:gettext "Allocating ~D bytes") immed-val) + dstate)))) + (t + ;; Some other allocation + (disassem:note + (format nil (intl:gettext "Allocating bytes")) + dstate)))))) + ((and (= rs1 zero-offset) *pseudo-atomic-set*) + ;; "ADD %ZERO, num, RD" inside a pseudo-atomic is very + ;; likely loading up a header word. Make a note to that + ;; effect. + (let ((type (second (assoc (logand immed-val #xff) header-word-type-alist))) + (size (ldb (byte 24 8) immed-val))) + (when type + (disassem:note (format nil (intl:gettext "Header word ~A, size ~D?") type size) + dstate))))))) + +(defun handle-or-inst (rs1 immed-val rd dstate immed-p) + (cond + ((= rs1 alloc-offset) + ;; OR %ALLOC, n. This must be some allocation or + ;; pseudo-atomic stuff + (cond ((and immed-p + (= immed-val pseudo-atomic-value) + (= rd alloc-offset) + (not *pseudo-atomic-set*)) + ;; "OR 4, %ALLOC" sets the flag + (disassem:note (intl:gettext "Set pseudo-atomic flag") dstate) + (setf *pseudo-atomic-set* t)))))) + +(defun handle-andn-inst (rs1 immed-val rd dstate immed-p) + (cond + ((= rs1 alloc-offset) + ;; ANDN %ALLOC, n. Resetting pseudo-atomic + (cond ((and immed-p + (= immed-val pseudo-atomic-value) + (= rd alloc-offset) + *pseudo-atomic-set*) + ;; "ANDN 4, %ALLOC" resets the flag + ;;(format t "Got reset~%") + (disassem:note (intl:gettext "Reset pseudo-atomic flag") dstate) + (setf *pseudo-atomic-set* nil)))))) + +(defun handle-jmpl-inst (rs1 immed-val rd dstate) + (declare (ignore rd)) + (let* ((sethi (assoc rs1 *note-sethi-inst*))) + (when sethi + ;; RS1 was used in a SETHI instruction. Assume that + ;; this is the offset part of the SETHI instruction for + ;; a full 32-bit address of something. Make a note + ;; about this usage as a Lisp assembly routine or + ;; foreign routine, if possible. If not, just note the + ;; final value. + (let ((addr (+ immed-val (ash (cdr sethi) 10)))) + (disassem::maybe-note-assembler-routine addr t dstate) + (setf *note-sethi-inst* (delete sethi *note-sethi-inst*)))))) + +(defun handle-ld/st-inst (rs1 immed-val rd dstate) + (declare (ignore rd)) + ;; Got an LDUW/LD or STW instruction, with immediate offset. + (case rs1 + (29 + ;; A reference to a code constant (reg = %CODE) + (disassem:note-code-constant immed-val dstate)) + (2 + ;; A reference to a static symbol or static function (reg = + ;; %NULL) + (or (disassem:maybe-note-nil-indexed-symbol-slot-ref immed-val + dstate) + (disassem:maybe-note-static-function immed-val dstate))) + (t + (let ((sethi (assoc rs1 *note-sethi-inst*))) + (when sethi + (let ((addr (+ immed-val (ash (cdr sethi) 10)))) + (disassem::maybe-note-assembler-routine addr nil dstate) + (setf *note-sethi-inst* (delete sethi *note-sethi-inst*)))))))) + +(defun handle-andcc-inst (rs1 immed-val rd dstate) + ;; ANDCC %ALLOC, 3, %ZERO instruction + (when (and (= rs1 alloc-offset) (= rd zero-offset) (= immed-val 3)) + (disassem:note (intl:gettext "pseudo-atomic interrupted?") dstate))) + +(eval-when (compile load eval) +(defun reg-arg-printer (value stream dstate) + (declare (stream stream) (fixnum value)) + (let ((regname (get-reg-name value))) + (princ regname stream) + (disassem:maybe-note-associated-storage-ref value + 'registers + regname + dstate) + (maybe-add-notes value dstate))) +) ; eval-when + +(disassem:define-argument-type reg + :printer #'reg-arg-printer) + +(defparameter float-reg-symbols + (coerce + (loop for n from 0 to 63 collect (make-symbol (format nil "%F~d" n))) + 'vector)) + +(disassem:define-argument-type fp-reg + :printer #'(lambda (value stream dstate) + (declare (stream stream) (fixnum value)) + (let ((regname (aref float-reg-symbols value))) + (princ regname stream) + (disassem:maybe-note-associated-storage-ref + value + 'float-registers + regname + dstate)))) + +;;; The extended 6 bit floating point register encoding for the double +;;; and long instructions of the sparc v9. +(disassem:define-argument-type fp-ext-reg + :printer #'(lambda (value stream dstate) + (declare (stream stream) (fixnum value)) + (let* (;; Decode the register number. + (value (if (oddp value) (+ value 31) value)) + (regname (aref float-reg-symbols value))) + (princ regname stream) + (disassem:maybe-note-associated-storage-ref + value + 'float-registers + regname + dstate)))) + +(disassem:define-argument-type relative-label + :sign-extend t + :use-label #'(lambda (value dstate) + (declare (type (signed-byte 22) value) + (type disassem:disassem-state dstate)) + (+ (ash value 2) (disassem:dstate-cur-addr dstate)))) + +(defconstant branch-conditions + '(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc)) + +;;; Note that these aren't the standard names for branch-conditions, I think +;;; they're a bit more readable (e.g., "eq" instead of "e"). You could just +;;; put a vector of the normal ones here too. +(defconstant branch-cond-name-vec + (coerce branch-conditions 'vector)) + +(disassem:define-argument-type branch-condition + :printer branch-cond-name-vec) + +(deftype branch-condition () + `(member ,@branch-conditions)) + +(defun branch-condition (condition) + (or (position condition branch-conditions) + (error (intl:gettext "Unknown branch condition: ~S~%Must be one of: ~S") + condition branch-conditions))) + +(defconstant branch-cond-true + #b1000) + +(defconstant branch-fp-conditions + '(:f :ne :lg :ul :l :ug :g :u :t :eq :ue :ge :uge :le :ule :o)) + +(defconstant branch-fp-cond-name-vec + (coerce branch-fp-conditions 'vector)) + +(disassem:define-argument-type branch-fp-condition + :printer branch-fp-cond-name-vec) + +(disassem:define-argument-type call-fixup :use-label t) + +(deftype fp-branch-condition () + `(member ,@branch-fp-conditions)) + +(defun fp-branch-condition (condition) + (or (position condition branch-fp-conditions) + (error (intl:gettext "Unknown fp-branch condition: ~S~%Must be one of: ~S") + condition branch-fp-conditions))) + + +;;;; dissassem:define-instruction-formats + +(disassem:define-instruction-format + (format-1 32 :default-printer '(:name :tab disp)) + (op :field (byte 2 30) :value 1) + (disp :field (byte 30 0))) + +(disassem:define-instruction-format + (format-2-immed 32 :default-printer '(:name :tab immed ", " rd)) + (op :field (byte 2 30) :value 0) + (rd :field (byte 5 25) :type 'reg) + (op2 :field (byte 3 22)) + (immed :field (byte 22 0))) + +(defconstant branch-printer + `(:name (:unless (:constant ,branch-cond-true) cond) + (:unless (a :constant 0) "," 'A) + :tab + disp)) + +(disassem:define-instruction-format + (format-2-branch 32 :default-printer branch-printer) + (op :field (byte 2 30) :value 0) + (a :field (byte 1 29) :value 0) + (cond :field (byte 4 25) :type 'branch-condition) + (op2 :field (byte 3 22)) + (disp :field (byte 22 0) :type 'relative-label)) + +;; Branch with prediction instruction for V9 + +;; Currently only %icc and %xcc are used of the four possible values + +(defconstant integer-condition-registers + '(:icc :reserved :xcc :reserved)) + +(defconstant integer-cond-reg-name-vec + (coerce integer-condition-registers 'vector)) + +(deftype integer-condition-register () + `(member ,@(remove :reserved integer-condition-registers))) + +(defparameter integer-condition-reg-symbols + (map 'vector + #'(lambda (name) + (make-symbol (concatenate 'string "%" (string name)))) + integer-condition-registers)) + +(disassem:define-argument-type integer-condition-register + :printer #'(lambda (value stream dstate) + (declare (stream stream) (fixnum value) (ignore dstate)) + (let ((regname (aref integer-condition-reg-symbols value))) + (princ regname stream)))) + +(defconstant branch-predictions + '(:pn :pt)) + +(defconstant branch-predictions-name-vec + (coerce branch-predictions 'vector)) + +(disassem:define-argument-type branch-prediction + :printer branch-predictions-name-vec) + +(defun integer-condition (condition-reg) + (declare (type (member :icc :xcc) condition-reg)) + (or (position condition-reg integer-condition-registers) + (error (intl:gettext "Unknown integer condition register: ~S~%") + condition-reg))) + +(defun branch-prediction (pred) + (or (position pred branch-predictions) + (error (intl:gettext "Unknown branch prediction: ~S~%Must be one of: ~S~%") + pred branch-predictions))) + +(defconstant branch-pred-printer + `(:name (:unless (:constant ,branch-cond-true) cond) + (:unless (a :constant 0) "," 'A) + (:unless (p :constant 1) "," 'pn) + :tab + cc + ", " + disp)) + +(disassem:define-instruction-format + (format-2-branch-pred 32 :default-printer branch-pred-printer) + (op :field (byte 2 30) :value 0) + (a :field (byte 1 29) :value 0) + (cond :field (byte 4 25) :type 'branch-condition) + (op2 :field (byte 3 22)) + (cc :field (byte 2 20) :type 'integer-condition-register) + (p :field (byte 1 19)) + (disp :field (byte 19 0) :type 'relative-label)) + +(defconstant fp-condition-registers + '(:fcc0 :fcc1 :fcc2 :fcc3)) + +(defconstant fp-cond-reg-name-vec + (coerce fp-condition-registers 'vector)) + +(defparameter fp-condition-reg-symbols + (map 'vector + #'(lambda (name) + (make-symbol (concatenate 'string "%" (string name)))) + fp-condition-registers)) + +(disassem:define-argument-type fp-condition-register + :printer #'(lambda (value stream dstate) + (declare (stream stream) (fixnum value) (ignore dstate)) + (let ((regname (aref fp-condition-reg-symbols value))) + (princ regname stream)))) + +(disassem:define-argument-type fp-condition-register-shifted + :printer #'(lambda (value stream dstate) + (declare (stream stream) (fixnum value) (ignore dstate)) + (let ((regname (aref fp-condition-reg-symbols (ash value -1)))) + (princ regname stream)))) + +(defun fp-condition (condition-reg) + (or (position condition-reg fp-condition-registers) + (error "Unknown integer condition register: ~S~%" + condition-reg))) + +(defconstant fp-branch-pred-printer + `(:name (:unless (:constant ,branch-cond-true) cond) + (:unless (a :constant 0) "," 'A) + (:unless (p :constant 1) "," 'pn) + :tab + fcc + ", " + disp)) + +(disassem:define-instruction-format + (format-2-fp-branch-pred 32 :default-printer fp-branch-pred-printer) + (op :field (byte 2 30) :value 0) + (a :field (byte 1 29) :value 0) + (cond :field (byte 4 25) :type 'branch-fp-condition) + (op2 :field (byte 3 22)) + (fcc :field (byte 2 20) :type 'fp-condition-register) + (p :field (byte 1 19)) + (disp :field (byte 19 0) :type 'relative-label)) + + + +(disassem:define-instruction-format + (format-2-unimp 32 :default-printer '(:name :tab data)) + (op :field (byte 2 30) :value 0) + (ignore :field (byte 5 25) :value 0) + (op2 :field (byte 3 22) :value 0) + (data :field (byte 22 0))) + +(defconstant f3-printer + '(:name :tab + (:unless (:same-as rd) rs1 ", ") + (:choose rs2 immed) ", " + rd)) + +(disassem:define-instruction-format + (format-3-reg 32 :default-printer f3-printer) + (op :field (byte 2 30)) + (rd :field (byte 5 25) :type 'reg) + (op3 :field (byte 6 19)) + (rs1 :field (byte 5 14) :type 'reg) + (i :field (byte 1 13) :value 0) + (asi :field (byte 8 5) :value 0) + (rs2 :field (byte 5 0) :type 'reg)) + +(disassem:define-instruction-format + (format-3-immed 32 :default-printer f3-printer) + (op :field (byte 2 30)) + (rd :field (byte 5 25) :type 'reg) + (op3 :field (byte 6 19)) + (rs1 :field (byte 5 14) :type 'reg) + (i :field (byte 1 13) :value 1) + (immed :field (byte 13 0) :sign-extend t)) ; usually sign extended + +(disassem:define-instruction-format + (format-binary-fpop 32 + :default-printer '(:name :tab rs1 ", " rs2 ", " rd)) + (op :field (byte 2 30)) + (rd :field (byte 5 25) :type 'fp-reg) + (op3 :field (byte 6 19)) + (rs1 :field (byte 5 14) :type 'fp-reg) + (opf :field (byte 9 5)) + (rs2 :field (byte 5 0) :type 'fp-reg)) + +;;; Floating point load/save instructions encoding. +(disassem:define-instruction-format + (format-unary-fpop 32 :default-printer '(:name :tab rs2 ", " rd)) + (op :field (byte 2 30)) + (rd :field (byte 5 25) :type 'fp-reg) + (op3 :field (byte 6 19)) + (rs1 :field (byte 5 14) :value 0) + (opf :field (byte 9 5)) + (rs2 :field (byte 5 0) :type 'fp-reg)) + +;;; Floating point comparison instructions encoding. + +;; This is a merge of the instructions for FP comparison and FP +;; conditional moves available in the Sparc V9. The main problem is +;; that the new instructions use part of the opcode space used by the +;; comparison instructions. In particular, the OPF field is arranged +;; as so: +;; +;; Bit 1 0 +;; 3 5 +;; FMOVcc 0nn0000xx %fccn +;; 1000000xx %icc +;; 1100000xx %xcc +;; FMOVR 0ccc001yy +;; FCMP 001010zzz +;; +;; So we see that if we break up the OPF field into 4 pieces, opf0, +;; opf1, opf2, and opf3, we can distinguish between these +;; instructions. So bit 9 (opf2) can be used to distinguish between +;; FCMP and the rest. Also note that the nn field overlaps with the +;; ccc. We need to take this into account as well. +;; +(disassem:define-instruction-format + (format-fpop2 32 + :default-printer #-sparc-v9 '(:name :tab rs1 ", " rs2) + #+sparc-v9 '(:name :tab rd ", " rs1 ", " rs2)) + (op :field (byte 2 30)) + (rd :field (byte 5 25) :value 0) + (op3 :field (byte 6 19)) + (rs1 :field (byte 5 14)) + (opf0 :field (byte 1 13)) + (opf1 :field (byte 3 10)) + (opf2 :field (byte 1 9)) + (opf3 :field (byte 4 5)) + (rs2 :field (byte 5 0) :type 'fp-reg)) + +;;; Shift instructions +(disassem:define-instruction-format + (format-3-shift-reg 32 :default-printer f3-printer) + (op :field (byte 2 30)) + (rd :field (byte 5 25) :type 'reg) + (op3 :field (byte 6 19)) + (rs1 :field (byte 5 14) :type 'reg) + (i :field (byte 1 13) :value 0) + (x :field (byte 1 12)) + (asi :field (byte 7 5) :value 0) + (rs2 :field (byte 5 0) :type 'reg)) + +(disassem:define-instruction-format + (format-3-shift-immed 32 :default-printer f3-printer) + (op :field (byte 2 30)) + (rd :field (byte 5 25) :type 'reg) + (op3 :field (byte 6 19)) + (rs1 :field (byte 5 14) :type 'reg) + (i :field (byte 1 13) :value 1) + (x :field (byte 1 12)) + (immed :field (byte 12 0) :sign-extend nil)) + + +;;; Conditional moves (only available for Sparc V9 architectures) + +;; The names of all of the condition registers on the V9: 4 FP +;; conditions, the original integer condition register and the new +;; extended register. The :reserved register is reserved on the V9. + +(defconstant cond-move-condition-registers + '(:fcc0 :fcc1 :fcc2 :fcc3 :icc :reserved :xcc :reserved)) +(defconstant cond-move-cond-reg-name-vec + (coerce cond-move-condition-registers 'vector)) + +(deftype cond-move-condition-register () + `(member ,@(remove :reserved cond-move-condition-registers))) + +(defparameter cond-move-condition-reg-symbols + (map 'vector + #'(lambda (name) + (make-symbol (concatenate 'string "%" (string name)))) + cond-move-condition-registers)) + +(disassem:define-argument-type cond-move-condition-register + :printer #'(lambda (value stream dstate) + (declare (stream stream) (fixnum value) (ignore dstate)) + (let ((regname (aref cond-move-condition-reg-symbols value))) + (princ regname stream)))) + +;; From the given condition register, figure out what the cc2, cc1, +;; and cc0 bits should be. Return cc2 and cc1/cc0 concatenated. +(defun cond-move-condition-parts (condition-reg) + (let ((posn (position condition-reg cond-move-condition-registers))) + (if posn + (truncate posn 4) + (error (intl:gettext "Unknown conditional move condition register: ~S~%") + condition-reg)))) + +(defun cond-move-condition (condition-reg) + (or (position condition-reg cond-move-condition-registers) + (error (intl:gettext "Unknown conditional move condition register: ~S~%") condition-reg))) + +(defconstant cond-move-printer + `(:name cond :tab + cc ", " (:choose immed rs2) ", " rd)) + +;; Conditional move integer register on integer or FP condition code +(disassem:define-instruction-format + (format-4-cond-move 32 :default-printer cond-move-printer) + (op :field (byte 2 30)) + (rd :field (byte 5 25) :type 'reg) + (op3 :field (byte 6 19)) + (cc2 :field (byte 1 18) :value 1) + (cond :field (byte 4 14) :type 'branch-condition) + (i :field (byte 1 13) :value 0) + (cc :field (byte 2 11) :type 'integer-condition-register) + (empty :field (byte 6 5) :value 0) + (rs2 :field (byte 5 0) :type 'reg)) + +(disassem:define-instruction-format + (format-4-cond-move-immed 32 :default-printer cond-move-printer) + (op :field (byte 2 30)) + (rd :field (byte 5 25) :type 'reg) + (op3 :field (byte 6 19)) + (cc2 :field (byte 1 18) :value 1) + (cond :field (byte 4 14) :type 'branch-condition) + (i :field (byte 1 13) :value 1) + (cc :field (byte 2 11) :type 'integer-condition-register) + (immed :field (byte 11 0) :sign-extend t)) + +;; Floating-point versions of the above integer conditional moves +(defconstant cond-fp-move-printer + `(:name rs1 :tab opf1 ", " rs2 ", " rd)) + +;;; Conditional move on integer register condition (only on Sparc +;;; V9). That is, move an integer register if some other integer +;;; register satisfies some condition. + +(defconstant cond-move-integer-conditions + '(:reserved :z :lez :lz :reserved :nz :gz :gez)) +(defconstant cond-move-integer-condition-vec + (coerce cond-move-integer-conditions 'vector)) + +(deftype cond-move-integer-condition () + `(member ,@(remove :reserved cond-move-integer-conditions))) + +(disassem:define-argument-type register-condition + :printer #'(lambda (value stream dstate) + (declare (stream stream) (fixnum value) (ignore dstate)) + (let ((regname (aref cond-move-integer-condition-vec value))) + (princ regname stream)))) + +(defconstant cond-move-integer-printer + `(:name rcond :tab rs1 ", " (:choose immed rs2) ", " rd)) + +(defun register-condition (rcond) + (or (position rcond cond-move-integer-conditions) + (error (intl:gettext "Unknown register condition: ~S~%") rcond))) + +(disassem:define-instruction-format + (format-4-cond-move-integer 32 :default-printer cond-move-integer-printer) + (op :field (byte 2 30)) + (rd :field (byte 5 25) :type 'reg) + (op3 :field (byte 6 19)) + (rs1 :field (byte 5 14) :type 'reg) + (i :field (byte 1 13) :value 0) + (rcond :field (byte 3 10) :type 'register-condition) + (opf :field (byte 5 5)) + (rs2 :field (byte 5 0) :type 'reg)) + +(disassem:define-instruction-format + (format-4-cond-move-integer-immed 32 :default-printer cond-move-integer-printer) + (op :field (byte 2 30)) + (rd :field (byte 5 25) :type 'reg) + (op3 :field (byte 6 19)) + (rs1 :field (byte 5 14) :type 'reg) + (i :field (byte 1 13) :value 1) + (rcond :field (byte 3 10) :type 'register-condition) + (immed :field (byte 10 0) :sign-extend t)) + +(defconstant trap-printer + `(:name rd :tab cc ", " rs1 "+" rs2)) + +(defconstant trap-immed-printer + `(:name rd :tab cc ", " (:unless (rs1 :constant 0) rs1 "+") immed)) + + +(disassem:define-instruction-format + (format-4-trap-immed 32 :default-printer trap-immed-printer) + (op :field (byte 2 30)) + (rd :field (byte 5 25) :type 'reg) + (op3 :field (byte 6 19)) + (rs1 :field (byte 5 14) :type 'reg) + (i :field (byte 1 13) :value 1) + (cc :field (byte 2 11) :type 'integer-condition-register) + (immed :field (byte 11 0))) + + +(disassem:define-instruction-format + (format-4-trap 32 :default-printer trap-printer) + (op :field (byte 2 30)) + (rd :field (byte 5 25) :type 'reg) + (op3 :field (byte 6 19)) + (rs1 :field (byte 5 14) :type 'reg) + (i :field (byte 1 13) :value 0) + (cc :field (byte 2 11) :type 'integer-condition-register) + (rs2 :field (byte 11 0) :type 'reg)) + + +(defconstant cond-fp-move-integer-printer + `(:name opf1 :tab rs1 ", " rs2 ", " rd)) + + +;;;; Primitive emitters. + +(define-emitter emit-word 32 + (byte 32 0)) + +(define-emitter emit-short 16 + (byte 16 0)) + +(define-emitter emit-format-1 32 + (byte 2 30) (byte 30 0)) + +(define-emitter emit-format-2-immed 32 + (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0)) + +(define-emitter emit-format-2-branch 32 + (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 22 0)) + +;; Integer and FP branches with prediction for V9 +(define-emitter emit-format-2-branch-pred 32 + (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 2 20) (byte 1 19) (byte 19 0)) +(define-emitter emit-format-2-fp-branch-pred 32 + (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 2 20) (byte 1 19) (byte 19 0)) + +(define-emitter emit-format-2-unimp 32 + (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0)) + +(define-emitter emit-format-3-reg 32 + (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 8 5) + (byte 5 0)) + +(define-emitter emit-format-3-immed 32 + (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 13 0)) + +(define-emitter emit-format-3-fpop 32 + (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 9 5) (byte 5 0)) + +(define-emitter emit-format-3-fpop2 32 + (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) + (byte 1 13) (byte 3 10) (byte 1 9) (byte 4 5) + (byte 5 0)) + +;;; Shift instructions + +(define-emitter emit-format-3-shift-reg 32 + (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 1 12) (byte 7 5) + (byte 5 0)) + +(define-emitter emit-format-3-shift-immed 32 + (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 1 12) (byte 12 0)) + +;;; Conditional moves + +;; Conditional move in condition code +(define-emitter emit-format-4-cond-move 32 + (byte 2 30) (byte 5 25) (byte 6 19) (byte 1 18) (byte 4 14) (byte 1 13) (byte 2 11) + (byte 11 0)) + +;; Conditional move on integer condition +(define-emitter emit-format-4-cond-move-integer 32 + (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 3 10) (byte 5 5) + (byte 5 0)) + +(define-emitter emit-format-4-cond-move-integer-immed 32 + (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 3 10) + (byte 10 0)) + +(define-emitter emit-format-4-trap 32 + (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 2 11) + (byte 11 0)) + + +;;;; Most of the format-3-instructions. + +(defun emit-format-3-inst (segment op op3 dst src1 src2 + &key load-store fixup dest-kind) + (unless src2 + (cond ((and (typep src1 'tn) load-store) + (setf src2 0)) + (t + (setf src2 src1) + (setf src1 dst)))) + (etypecase src2 + (tn + (emit-format-3-reg segment op + (if dest-kind + (fp-reg-tn-encoding dst) + (reg-tn-encoding dst)) + op3 (reg-tn-encoding src1) 0 0 (reg-tn-encoding src2))) + (integer + (emit-format-3-immed segment op + (if dest-kind + (fp-reg-tn-encoding dst) + (reg-tn-encoding dst)) + op3 (reg-tn-encoding src1) 1 src2)) + (fixup + (unless (or load-store fixup) + (error (intl:gettext "Fixups aren't allowed."))) + (note-fixup segment :add src2) + (emit-format-3-immed segment op + (if dest-kind + (fp-reg-tn-encoding dst) + (reg-tn-encoding dst)) + op3 (reg-tn-encoding src1) 1 0)))) + +;;; Shift instructions because an extra bit is used in Sparc V9's to +;;; indicate whether the shift is a 32-bit or 64-bit shift. +;;; +(defun emit-format-3-shift-inst (segment op op3 dst src1 src2 &key extended) + (unless src2 + (setf src2 src1) + (setf src1 dst)) + (etypecase src2 + (tn + (emit-format-3-shift-reg segment op (reg-tn-encoding dst) + op3 (reg-tn-encoding src1) 0 (if extended 1 0) + 0 (reg-tn-encoding src2))) + (integer + (emit-format-3-shift-immed segment op (reg-tn-encoding dst) + op3 (reg-tn-encoding src1) 1 + (if extended 1 0) src2)))) + + +(eval-when (compile eval) + +;;; have to do this because defconstant is evalutated in the null lex env. +(defmacro with-ref-format (printer) + `(let* ((addend + '(:choose (:plus-integer immed) ("+" rs2))) + (ref-format + `("[" rs1 (:unless (:constant 0) ,addend) "]" + (:choose (:unless (:constant 0) asi) nil)))) + ,printer)) + +(defconstant load-printer + (with-ref-format `(:NAME :TAB ,ref-format ", " rd))) + +(defconstant store-printer + (with-ref-format `(:NAME :TAB rd ", " ,ref-format))) + +(defmacro define-f3-inst (name op op3 &key fixup load-store (dest-kind 'reg) + (printer :default) reads writes flushable print-name) + (let ((printer + (if (eq printer :default) + (case load-store + ((nil) :default) + ((:load t) 'load-printer) + (:store 'store-printer)) + printer))) + (when (and (atom reads) (not (null reads))) + (setf reads (list reads))) + (when (and (atom writes) (not (null writes))) + (setf writes (list writes))) + `(define-instruction ,name (segment dst src1 &optional src2) + (:declare (type tn dst) + ,(if (or fixup load-store) + '(type (or tn (signed-byte 13) null fixup) src1 src2) + '(type (or tn (signed-byte 13) null) src1 src2))) + (:printer format-3-reg + ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind)) + ,printer + ,@(when print-name `(:print-name ,print-name))) + (:printer format-3-immed + ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind)) + ,printer + ,@(when print-name `(:print-name ,print-name))) + ,@(when flushable + '((:attributes flushable))) + (:dependencies + (reads src1) + ,@(let ((reads-list nil)) + (dolist (read reads) + (push (list 'reads read) reads-list)) + reads-list) + ,@(cond ((eq load-store :store) + '((reads dst) + (if src2 (reads src2)))) + ((eq load-store t) + '((reads :memory) + (reads dst) + (if src2 (reads src2)))) + ((eq load-store :load) + '((reads :memory) + (if src2 (reads src2) (reads dst)))) + (t + '((if src2 (reads src2) (reads dst))))) + ,@(let ((writes-list nil)) + (dolist (write writes) + (push (list 'writes write) writes-list)) + writes-list) + ,@(cond ((eq load-store :store) + '((writes :memory :partially t))) + ((eq load-store t) + '((writes :memory :partially t) + (writes dst))) + ((eq load-store :load) + '((writes dst))) + (t + '((writes dst))))) + (:delay 0) + (:emitter (emit-format-3-inst segment ,op ,op3 dst src1 src2 + :load-store ,load-store + :fixup ,fixup + :dest-kind (not (eq ',dest-kind 'reg))))))) + +(defmacro define-f3-shift-inst (name op op3 &key extended) + `(define-instruction ,name (segment dst src1 &optional src2) + (:declare (type tn dst) + (type (or tn (unsigned-byte 6) null) src1 src2)) + (:printer format-3-shift-reg + ((op ,op) (op3 ,op3) (x ,(if extended 1 0)) (i 0))) + (:printer format-3-shift-immed + ((op ,op) (op3 ,op3) (x ,(if extended 1 0)) (i 1))) + (:dependencies + (reads src1) + (if src2 (reads src2) (reads dst)) + (writes dst)) + (:delay 0) + (:emitter (emit-format-3-shift-inst segment ,op ,op3 dst src1 src2 + :extended ,extended)))) + +) ; eval-when (compile eval) + +(define-f3-inst ldsb #b11 #b001001 :load-store :load) +(define-f3-inst ldsh #b11 #b001010 :load-store :load) +(define-f3-inst ldub #b11 #b000001 :load-store :load) +(define-f3-inst lduh #b11 #b000010 :load-store :load) + +;; This instruction is called lduw for V9 , but looks exactly like ld +;; on previous architectures. +(define-f3-inst ld #b11 #b000000 :load-store :load + #+sparc-v9 :print-name #+sparc-v9 'lduw) + +;; The code sometimes uses ldsw and lduw. LDSW is a real instruction +;; for V9 that sign-extends a 32-bit load. LDUW is the same as LD. +;; For non-V9, we define macros to replace these with the equivalent +;; instruction (LD) since sign-extending and zero-extending a 32-bit +;; value in a 32-bit register is the same. +#+sparc-v9 +(progn + (define-f3-inst ldsw #b11 #b001000 :load-store :load) ; v9 + (define-instruction-macro lduw (&rest args) + `(inst ld ,@args))) + +#-sparc-v9 +(progn + (define-instruction-macro ldsw (&rest args) + `(inst ld ,@args)) + (define-instruction-macro lduw (&rest args) + `(inst ld ,@args))) + + +;; ldd is deprecated on the Sparc V9. +(define-f3-inst ldd #b11 #b000011 :load-store :load) + +(define-f3-inst ldx #b11 #b001011 :load-store :load) ; v9 + +(define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store :load) +(define-f3-inst lddf #b11 #b100011 :dest-kind fp-ext-reg :load-store :load ) +(define-f3-inst ldqf #b11 #b100010 :dest-kind fp-ext-reg :load-store :load) ; v9 +(define-f3-inst stb #b11 #b000101 :load-store :store) +(define-f3-inst sth #b11 #b000110 :load-store :store) +(define-f3-inst st #b11 #b000100 :load-store :store) + +;; std is deprecated on the Sparc V9. +(define-f3-inst std #b11 #b000111 :load-store :store) + +(define-f3-inst stx #b11 #b001110 :load-store :store) ; v9 + +(define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store :store) +(define-f3-inst stdf #b11 #b100111 :dest-kind fp-ext-reg :load-store :store) +(define-f3-inst stqf #b11 #b100110 :dest-kind fp-ext-reg :load-store :store) ; v9 +(define-f3-inst ldstub #b11 #b001101 :load-store t) + +;; swap is deprecated on the Sparc V9 +(define-f3-inst swap #b11 #b001111 :load-store t) + +(define-f3-inst add #b10 #b000000 :fixup t) +(define-f3-inst addcc #b10 #b010000 :writes :psr) +(define-f3-inst addx #b10 #b001000 :reads :psr) +(define-f3-inst addxcc #b10 #b011000 :reads :psr :writes :psr) +(define-f3-inst taddcc #b10 #b100000 :writes :psr) + +;; taddcctv is deprecated on the Sparc V9. Use taddcc and bpvs or +;; taddcc and trap to get a similar effect. (Requires changing the C +;; code though!) +;;(define-f3-inst taddcctv #b10 #b100010 :writes :psr) + +(define-f3-inst sub #b10 #b000100) +(define-f3-inst subcc #b10 #b010100 :writes :psr) +(define-f3-inst subx #b10 #b001100 :reads :psr) +(define-f3-inst subxcc #b10 #b011100 :reads :psr :writes :psr) +(define-f3-inst tsubcc #b10 #b100001 :writes :psr) + +;; tsubcctv is deprecated on the Sparc V9. Use tsubcc and bpvs or +;; tsubcc and trap to get a similar effect. (Requires changing the C +;; code though!) +;;(define-f3-inst tsubcctv #b10 #b100011 :writes :psr) + +(define-f3-inst mulscc #b10 #b100100 :reads :y :writes (:psr :y)) +(define-f3-inst and #b10 #b000001) +(define-f3-inst andcc #b10 #b010001 :writes :psr) +(define-f3-inst andn #b10 #b000101) +(define-f3-inst andncc #b10 #b010101 :writes :psr) +(define-f3-inst or #b10 #b000010) +(define-f3-inst orcc #b10 #b010010 :writes :psr) +(define-f3-inst orn #b10 #b000110) +(define-f3-inst orncc #b10 #b010110 :writes :psr) +(define-f3-inst xor #b10 #b000011) +(define-f3-inst xorcc #b10 #b010011 :writes :psr) +(define-f3-inst xnor #b10 #b000111) +(define-f3-inst xnorcc #b10 #b010111 :writes :psr) + +(define-f3-shift-inst sll #b10 #b100101) +(define-f3-shift-inst srl #b10 #b100110) +(define-f3-shift-inst sra #b10 #b100111) +(define-f3-shift-inst sllx #b10 #b100101 :extended t) ; v9 +(define-f3-shift-inst srlx #b10 #b100110 :extended t) ; v9 +(define-f3-shift-inst srax #b10 #b100111 :extended t) ; v9 + +(define-f3-inst save #b10 #b111100 :reads :psr :writes :psr) +(define-f3-inst restore #b10 #b111101 :reads :psr :writes :psr) + +;; smul, smulcc, umul, umulcc, sdiv, sdivcc, udiv, and udivcc are +;; deprecated on the Sparc V9. Use mulx, sdivx, and udivx instead. +(define-f3-inst smul #b10 #b001011 :writes :y) ; v8 +(define-f3-inst smulcc #b10 #b011011 :writes (:psr :y)) ; v8 +(define-f3-inst umul #b10 #b001010 :writes :y) ; v8 +(define-f3-inst umulcc #b10 #b011010 :writes (:psr :y)) ; v8 +(define-f3-inst sdiv #b10 #b001111 :reads :y) ; v8 +(define-f3-inst sdivcc #b10 #b011111 :reads :y :writes :psr) ; v8 +(define-f3-inst udiv #b10 #b001110 :reads :y) ; v8 +(define-f3-inst udivcc #b10 #b011110 :reads :y :writes :psr) ; v8 + +(define-f3-inst mulx #b10 #b001001) ; v9 for both signed and unsigned +(define-f3-inst sdivx #b10 #b101101) ; v9 +(define-f3-inst udivx #b10 #b001101) ; v9 + +(define-f3-inst popc #b10 #b101110) ; v9: count one bits + + +;;;; Random instructions. + +;; ldfsr is deprecated on the Sparc V9. Use ldxfsr instead +(define-instruction ldfsr (segment src1 src2) + (:declare (type tn src1) (type (signed-byte 13) src2)) + (:printer format-3-immed ((op #b11) (op3 #b100001) (rd 0))) + :pinned + (:delay 0) + (:emitter (emit-format-3-immed segment #b11 0 #b100001 + (reg-tn-encoding src1) 1 src2))) + +#+sparc-64 +(define-instruction ldxfsr (segment src1 src2) + (:declare (type tn src1) (type (signed-byte 13) src2)) + (:printer format-3-immed ((op #b11) (op3 #b100001) (rd 1)) + '(:name :tab "[" rs1 (:unless (:constant 0) "+" immed) "], %FSR") + :print-name 'ldx) + :pinned + (:delay 0) + (:emitter (emit-format-3-immed segment #b11 1 #b100001 + (reg-tn-encoding src1) 1 src2))) + +;; stfsr is deprecated on the Sparc V9. Use stxfsr instead. +(define-instruction stfsr (segment src1 src2) + (:declare (type tn src1) (type (signed-byte 13) src2)) + (:printer format-3-immed ((op #b11) (op3 #b100101) (rd 0))) + :pinned + (:delay 0) + (:emitter (emit-format-3-immed segment #b11 0 #b100101 + (reg-tn-encoding src1) 1 src2))) + +#+sparc-64 +(define-instruction stxfsr (segment src1 src2) + (:declare (type tn src1) (type (signed-byte 13) src2)) + (:printer format-3-immed ((op #b11) (op3 #b100101) (rd 1)) + '(:name :tab "%FSR, [" rs1 "+" (:unless (:constant 0) "+" immed) "]") + :print-name 'stx) + :pinned + (:delay 0) + (:emitter (emit-format-3-immed segment #b11 1 #b100101 + (reg-tn-encoding src1) 1 src2))) + +(eval-when (compile load eval) + (defun sethi-arg-printer (value stream dstate) + (format stream "%hi(#x~8,'0x)" (ash value 10)) + ;; Save the immediate value and the destination register from this + ;; sethi instruction. This is used later to print some possible + ;; notes about the value loaded by sethi. + (let* ((word (disassem::sap-ref-int (disassem:dstate-segment-sap dstate) + (disassem:dstate-cur-offs dstate) + vm:word-bytes + (disassem::dstate-byte-order dstate))) + (imm22 (ldb (byte 22 0) word)) + (rd (ldb (byte 5 25) word))) + (push (cons rd imm22) *note-sethi-inst*) + )) +) ; eval-when (compile load eval) + +(define-instruction sethi (segment dst src1) + (:declare (type tn dst) + (type (or (signed-byte 22) (unsigned-byte 22) fixup) src1)) + (:printer format-2-immed + ((op2 #b100) (immed nil :printer #'sethi-arg-printer))) + (:dependencies (writes dst)) + (:delay 0) + (:emitter + (etypecase src1 + (integer + (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100 + src1)) + (fixup + (note-fixup segment :sethi src1) + (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100 0))))) + +;; rdy is deprecated on the Sparc V9. It's not needed with 64-bit +;; registers. +(define-instruction rdy (segment dst) + (:declare (type tn dst)) + (:printer format-3-reg ((op #b10) (op3 #b101000) (rs1 0) (rs2 0)) + '('RD :tab '%Y ", " rd)) + (:dependencies (reads :y) (writes dst)) + (:delay 0) + (:emitter (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b101000 + 0 0 0))) + +(defconstant wry-printer + '('WR :tab rs1 (:unless (:constant 0) ", " (:choose immed rs2)) ", " '%Y)) + +;; wry is deprecated on the Sparc V9. It's not needed with 64-bit +;; registers. +(define-instruction wry (segment src1 &optional src2) + (:declare (type tn src1) (type (or (signed-byte 13) tn null) src2)) + (:printer format-3-reg ((op #b10) (op3 #b110000) (rd 0)) wry-printer) + (:printer format-3-immed ((op #b10) (op3 #b110000) (rd 0)) wry-printer) + (:dependencies (reads src1) (if src2 (reads src2)) (writes :y)) + (:delay 3) + (:emitter + (etypecase src2 + (null + (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0 0)) + (tn + (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0 + (reg-tn-encoding src2))) + (integer + (emit-format-3-immed segment #b10 0 #b110000 (reg-tn-encoding src1) 1 + src2))))) + +;; Read the tick register available on sparc v9 +(define-instruction rdtick (segment dst) + (:declare (type tn dst)) + (:printer format-3-reg ((op #b10) (op3 #b101000) (rs1 4) (rs2 0)) + '('RD :tab '%TICK ", " rd)) + (:dependencies (reads :tick) (writes dst)) + (:delay 0) + (:emitter (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b101000 + 4 0 0))) + +;; Sparc-v9 Compare and Swap instructions + +(defconstant immediate-asi-alist + '((:asi_aiup . #x10) ; ASI_AS_IF_USER_PRIMARY + (:asi_aius . #x11) ; ASI_AS_IF_USER_SECONDARY + (:asi_aiup_l . #x18) ; ASI_AS_IF_USER_PRIMARY_LITTLE + (:asi_aius_l . #x19) ; ASI_AS_IF_USER_SECONDARY_LITTLE + (:asi_p . #x80) ; ASI_PRIMARY + (:asi_s . #x81) ; ASI_SECONDARY + (:asi_pnf . #x82) ; ASI_PRIMARY_NOFAULT + (:asi_snf . #x83) ; ASI_SECONDARY_NOFAULT + (:asi_p_l . #x88) ; ASI_PRIMARY_LITTLE + (:asi_s_l . #x89) ; ASI_SECONDARY_LITTLE + (:asi_pnf_l . #x8a) ; ASI_PRIMARY_NOFAULT_LITTLE + (:asi_snf_l . #x8b))) ; ASI_SECONDARY_NOFAULT_LITTLE + +(deftype immediate-asi () + `(member ,@(mapcar #'car immediate-asi-alist))) + +(disassem:define-argument-type immediate-asi + :printer #'(lambda (value stream dstate) + (declare (stream stream) (fixnum value) (ignore dstate)) + (let ((symbolic (rassoc value immediate-asi-alist))) + (if symbolic + (format stream "#~A" (car symbolic)) + (format stream "~D" value))))) + +(defconstant compare-swap-asi-printer + `(:name :tab "[" rs1 "]" '%asi + ", " + rs2 + ", " + rd)) + +(defconstant compare-swap-immed-asi-printer + `(:name :tab "[" rs1 "]" + asi + ", " + rs2 + ", " + rd)) + +(macrolet + ((cas (name op3) + `(define-instruction ,name (segment dst src1 src2 &key immed-asi) + (:declare (type tn dst src1 src2) + (type (or null (unsigned-byte 8) immediate-asi) immed-asi)) + (:printer format-3-reg + ((op #b11) (op3 ,op3) (i 1) (asi nil)) + compare-swap-asi-printer + ) + (:printer format-3-reg + ((op #b11) (op3 ,op3) (i 0) (asi nil :type 'immediate-asi)) + compare-swap-immed-asi-printer + ) + (:dependencies (reads src1) + (reads src2) + (reads dst) + (reads :memory) + (writes dst) + (writes :memory)) + (:delay 0) + (:emitter + (let ((asi-value (if immed-asi + (if (integerp immed-asi) + immed-asi + (cdr (assoc immed-asi immediate-asi-alist)))))) + (emit-format-3-reg segment #b11 (reg-tn-encoding dst) ,op3 + (reg-tn-encoding src1) + (if immed-asi 0 1) + (or asi-value 0) + (reg-tn-encoding src2))))))) + ;; 32-bit compre and swap + (cas casa #b111100) + ;; 64-bit compare and swap + (cas casxa #b111110)) + +;; Prefetch +(defconstant prefetch-type-alist + '((:n_reads . 0) + (:one_read . 1) + (:n_writes . 2) + (:one_write . 3) + (:page . 4))) + +(deftype prefetch-type () + `(member ,@(mapcar #'car prefetch-type-alist))) + +(disassem:define-argument-type prefetch-fcn + :printer #'(lambda (value stream dstate) + (declare (stream stream) (fixnum value) (ignore dstate)) + (let ((symbolic (rassoc value prefetch-type-alist))) + (if symbolic + (format stream "#~A" (car symbolic)) + (format stream "~D" value))))) + +(define-instruction prefetch (segment fcn src1 src2) + (:declare (type tn src1) + (type (or tn (signed-byte 13)) src2) + (type (or (unsigned-byte 5) prefetch-type) fcn)) + (:printer format-3-reg + ((op #b11) (op3 #b101101) (i 0) (rd nil :type 'prefetch-fcn)) + load-printer) + (:printer format-3-immed + ((op #b11) (op3 #b101101) (i 1) (rd nil :type 'prefetch-fcn)) + load-printer) + (:delay 0) + (:emitter + (let ((fcn-type (if (integerp fcn) + fcn + (cdr (assoc fcn prefetch-type-alist))))) + (etypecase src2 + (tn + (emit-format-3-reg segment #b11 fcn-type #b101101 + (reg-tn-encoding src1) + 0 0 + (reg-tn-encoding src2))) + (integer + (emit-format-3-immed segment #b11 fcn-type #b101101 + (reg-tn-encoding src1) + 1 + src2)))))) + +;;; Some synthetic instructions + +;; Sign-extend a 32-bit number to 64 bits. (Basically sra rs1, %g0, +;; rd). +(define-instruction signx (segment dst &optional src) + (:declare (type tn dst) + (type (or null tn) src)) + (:printer format-3-shift-reg + ((op #b10) (op3 #b100111) (x 0) (i 0) (rs2 0)) + '(:name :tab (:unless (:same-as rd) rs1 ", ") rd)) + (:dependencies + (if src (reads src) (reads dst)) + (writes dst)) + (:delay 0) + (:emitter + (unless src + (setf src dst)) + (emit-format-3-shift-inst segment #b10 #b100111 dst src zero-tn)) + ) + +;; Zero-extend (clear upper part of word) a 32-bit number to 64 bits. +;; (Basically srl rs1, %g0, rd) +(define-instruction clruw (segment dst &optional src) + (:declare (type tn dst) + (type (or null tn) src)) + (:printer format-3-shift-reg + ((op #b10) (op3 #b100110) (x 0) (i 0) (rs2 0)) + '(:name :tab (:unless (:same-as rd) rs1 ", ") rd)) + (:dependencies + (if src (reads src) (reads dst)) + (writes dst)) + (:delay 0) + (:emitter + (unless src + (setf src dst)) + (emit-format-3-shift-inst segment #b10 #b100110 dst src zero-tn)) + ) + + +(defun snarf-error-junk (sap offset &optional length-only) + (let* ((length (system:sap-ref-8 sap offset)) + (vector (make-array length :element-type '(unsigned-byte 8)))) + (declare (type system:system-area-pointer sap) + (type (unsigned-byte 8) length) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (cond (length-only + (values 0 (1+ length) nil nil)) + (t + (kernel:copy-from-system-area sap (* sparc:byte-bits (1+ offset)) + vector (* sparc:word-bits + sparc:vector-data-offset) + (* length sparc:byte-bits)) + (collect ((sc-offsets) + (lengths)) + (lengths 1) ; the length byte + (let* ((index 0) + (error-number (c::read-var-integer vector index))) + (lengths index) + (loop + (when (>= index length) + (return)) + (let ((old-index index)) + (sc-offsets (c::read-var-integer vector index)) + (lengths (- index old-index)))) + (values error-number + (1+ length) + (sc-offsets) + (lengths)))))))) + +(defun unimp-control (chunk inst stream dstate) + (declare (ignore inst)) + (flet ((nt (x) (if stream (disassem:note x dstate)))) + (case (format-2-unimp-data chunk dstate) + (#.vm:error-trap + (nt "Error trap") + (disassem:handle-break-args #'snarf-error-junk stream dstate)) + (#.vm:cerror-trap + (nt "Cerror trap") + (disassem:handle-break-args #'snarf-error-junk stream dstate)) + (#.vm:object-not-list-trap + (nt "Object not list trap")) + (#.vm:breakpoint-trap + (nt "Breakpoint trap")) + (#.vm:pending-interrupt-trap + (nt "Pending interrupt trap")) + (#.vm:halt-trap + (nt "Halt trap")) + (#.vm:function-end-breakpoint-trap + (nt "Function end breakpoint trap")) + (#.vm:object-not-instance-trap + (nt "Object not instance trap")) + ))) + +(eval-when (compile load eval) + ;; Print Value as a Lisp hex number + (defun hex-data-printer (value stream dstate) + (declare (ignore dstate)) + (format stream "#x~X" value))) + +(define-instruction unimp (segment data) + (:declare (type (unsigned-byte 22) data)) + (:printer format-2-unimp ((data nil :printer #'hex-data-printer)) + :default :control #'unimp-control + :print-name #-sparc-v9 'unimp #+sparc-v9 'illtrap) + (:delay 0) + (:emitter (emit-format-2-unimp segment 0 0 0 data))) + + + +;;;; Branch instructions. + +;; The branch instruction is deprecated on the Sparc V9. Use the +;; branch with prediction instructions instead. +(defun emit-relative-branch (segment a op2 cond-or-target target &optional fp) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (unless target + (setf target cond-or-target) + (setf cond-or-target :t)) + (emit-format-2-branch + segment #b00 a + (if fp + (fp-branch-condition cond-or-target) + (branch-condition cond-or-target)) + op2 + (let ((offset (ash (- (label-position target) posn) -2))) + (when (and (= a 1) (> 0 offset)) + (error "Offset of BA must be positive")) + offset))))) + +#+sparc-v9 +(defun emit-relative-branch-integer (segment a op2 cond-or-target target &optional (cc :icc) (pred :pt)) + (declare (type integer-condition-register cc)) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (unless target + (setf target cond-or-target) + (setf cond-or-target :t)) + (emit-format-2-branch-pred + segment #b00 a + (branch-condition cond-or-target) + op2 + (integer-condition cc) + (branch-prediction pred) + (let ((offset (ash (- (label-position target) posn) -2))) + (when (and (= a 1) (> 0 offset)) + (error "Offset of BA must be positive")) + offset))))) + +#+sparc-v9 +(defun emit-relative-branch-fp (segment a op2 cond-or-target target &optional (cc :fcc0) (pred :pt)) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (unless target + (setf target cond-or-target) + (setf cond-or-target :t)) + (emit-format-2-branch-pred + segment #b00 a + (fp-branch-condition cond-or-target) + op2 + (fp-condition cc) + (branch-prediction pred) + (let ((offset (ash (- (label-position target) posn) -2))) + (when (and (= a 1) (> 0 offset)) + (error "Offset of BA must be positive")) + offset))))) + +;; So that I don't have to go change the syntax of every single use of +;; branches, I'm keeping the Lisp instruction names the same. They +;; just get translated to the branch with prediction +;; instructions. However, the disassembler uses the correct V9 +;; mnemonic. +#-sparc-v9 +(define-instruction b (segment cond-or-target &optional target &rest ignored) + (:declare (type (or label branch-condition) cond-or-target) + (type (or label null) target) + (ignore ignored)) + (:printer format-2-branch ((op #b00) (op2 #b010))) + (:attributes branch) + (:dependencies (reads :psr)) + (:delay 1) + (:emitter + (emit-relative-branch segment 0 #b010 cond-or-target target))) + +#+sparc-v9 +(define-instruction b (segment cond-or-target &optional target pred cc) + (:declare (type (or label branch-condition) cond-or-target) + (type (or label null) target) + (type (or null (member :icc :xcc)) cc) + (type (or null (member :pt :pn)) pred)) + (:printer format-2-branch-pred ((op #b00) (op2 #b001)) + branch-pred-printer + :print-name 'bp) + (:attributes branch) + (:dependencies (reads :psr)) + (:delay 1) + (:emitter + (emit-relative-branch-integer segment 0 #b001 cond-or-target target (or cc :icc) (or pred :pt)))) + +#-sparc-v9 +(define-instruction ba (segment cond-or-target &optional target) + (:declare (type (or label branch-condition) cond-or-target) + (type (or label null) target)) + (:printer format-2-branch ((op #b00) (op2 #b010) (a 1)) + branch-printer + :print-name 'b) + (:attributes branch) + (:dependencies (reads :psr)) + (:delay 0) + (:emitter + (emit-relative-branch segment 1 #b010 cond-or-target target))) + +#+sparc-v9 +(define-instruction ba (segment cond-or-target &optional target pred cc) + (:declare (type (or label branch-condition) cond-or-target) + (type (or label null) target) + (type (or null (member :icc :xcc)) cc) + (type (or null (member :pt :pn)) pred)) + (:printer format-2-branch-pred ((op #b00) (op2 #b001) (a 1)) + branch-pred-printer + :print-name 'bp) + (:attributes branch) + (:dependencies (reads :psr)) + (:delay 0) + (:emitter + (emit-relative-branch-integer segment 1 #b001 cond-or-target target (or cc :icc) (or pred :pt)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun trap-arg-printer (value stream dstate) + ;; We just print a note, if it's one of our recognized traps + (let ((*package* (find-package :vm))) + (case value + (#.pseudo-atomic-trap + (disassem:note (intl:gettext "Pseudo atomic interrupted trap?") dstate)) + (#.allocation-trap + (disassem:note (intl:gettext "Allocation trap") dstate))) + (format stream "~A" value)))) + +;; The Sparc Compliance Definition 2.4.1 says only trap numbers 16-31 +;; are allowed for user code. All other trap numbers have other +;; uses. The restriction on target will prevent us from using bad trap +;; numbers by mistake. +;; +;; Note that the V9 architecture only allows 7 bits for the immediate +;; trap number. Previous architectures allowed 13 bits. CMUCL doesn't +;; need all 13 bits, and the SCD only allows 16-31, so we only allow +;; for those now. +(define-instruction t (segment condition src1-or-imm &optional src2 + #+sparc-v9 (cc #-sparc-64 :icc #+sparc-64 :xcc)) + (:declare (type branch-condition condition) + (type (or tn (unsigned-byte 8)) src1-or-imm) + (type (or null tn (unsigned-byte 8)) src2) + #+sparc-v9 + (type integer-condition-register cc)) + (:printer format-4-trap-immed ((op #b10) + (rd nil :type 'branch-condition) + (op3 #b111010) + (i 1) + (immed nil :printer #'trap-arg-printer)) + trap-immed-printer) + (:printer format-4-trap ((op #b10) + (rd nil :type 'branch-condition) + (op3 #b111010) + (i 0) + (rs2 nil :type 'reg)) + trap-printer) + (:attributes branch) + (:dependencies (reads :psr)) + (:delay 0) + (:emitter + (let ((cc-reg #+sparc-v9 (integer-condition cc) + #-sparc-v9 0)) + (etypecase src1-or-imm + (integer + ;; src2 shouldn't be given (or should be NIL) in this case. + (assert (null src2)) + (unless (typep src1-or-imm '(integer 16 31)) + (cerror (intl:gettext "Use it anyway") + (intl:gettext "Immediate trap number ~A specified, but only trap numbers + 16 to 31 are available to the application") + src1-or-imm)) + (emit-format-4-trap segment + #b10 + (branch-condition condition) + #b111010 0 1 + cc-reg + src1-or-imm)) + (tn + ;; src1 is a register. src2 must be given. + (etypecase src2 + (integer + (emit-format-4-trap segment + #b10 + (branch-condition condition) + #b111010 + (reg-tn-encoding src1-or-imm) + 1 + cc-reg + src2)) + (tn + (emit-format-4-trap segment + #b10 + (branch-condition condition) + #b111010 + (reg-tn-encoding src1-or-imm) + 0 + cc-reg + (reg-tn-encoding src2)))))))) + ) + +;; Same as for the branch instructions. On the Sparc V9, we will use +;; the FP branch with prediction instructions instead. +#-sparc-v9 +(define-instruction fb (segment condition target) + (:declare (type fp-branch-condition condition) (type label target)) + (:printer format-2-branch ((op #B00) + (cond nil :type 'branch-fp-condition) + (op2 #b110))) + (:attributes branch) + (:dependencies (reads :fsr)) + (:delay 1) + (:emitter + (emit-relative-branch segment 0 #b110 condition target t))) + +#+sparc-v9 +(define-instruction fb (segment condition target &optional fcc pred) + (:declare (type fp-branch-condition condition) (type label target)) + (:printer format-2-fp-branch-pred ((op #b00) (op2 #b101)) + fp-branch-pred-printer + :print-name 'fbp) + (:attributes branch) + (:dependencies (reads :fsr)) + (:delay 1) + (:emitter + (emit-relative-branch-fp segment 0 #b101 condition target (or fcc :fcc0) (or pred :pt)))) + +(defconstant jal-printer + '(:name :tab + (:choose (rs1 (:unless (:constant 0) (:plus-integer immed))) + (:cond ((rs2 :constant 0) rs1) + ((rs1 :constant 0) rs2) + (t rs1 "+" rs2))) + (:unless (:constant 0) ", " rd))) + +(define-instruction jal (segment dst src1 &optional src2) + (:declare (type tn dst) + (type (or tn integer) src1) + (type (or null fixup tn (signed-byte 13)) src2)) + (:printer format-3-reg ((op #b10) (op3 #b111000)) jal-printer :print-name 'jmpl) + (:printer format-3-immed ((op #b10) (op3 #b111000)) jal-printer :print-name 'jmpl) + (:attributes branch) + (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst)) + (:delay 1) + (:emitter + (unless src2 + (setf src2 src1) + (setf src1 0)) + (etypecase src2 + (tn + (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b111000 + (if (integerp src1) + src1 + (reg-tn-encoding src1)) + 0 0 (reg-tn-encoding src2))) + (integer + (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b111000 + (reg-tn-encoding src1) 1 src2)) + (fixup + (note-fixup segment :add src2) + (emit-format-3-immed segment #b10 (reg-tn-encoding dst) + #b111000 (reg-tn-encoding src1) 1 0))))) + +(define-instruction j (segment src1 &optional src2) + (:declare (type tn src1) (type (or tn (signed-byte 13) fixup null) src2)) + (:printer format-3-reg ((op #b10) (op3 #b111000) (rd 0)) jal-printer) + (:printer format-3-immed ((op #b10) (op3 #b111000) (rd 0)) jal-printer) + (:attributes branch) + (:dependencies (reads src1) (if src2 (reads src2))) + (:delay 1) + (:emitter + (etypecase src2 + (null + (emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0 0)) + (tn + (emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0 + (reg-tn-encoding src2))) + (integer + (emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1 + src2)) + (fixup + (note-fixup segment :add src2) + (emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1 + 0))))) + + + +;;;; Unary and binary fp insts. + +(eval-when (compile eval) + +(defmacro define-unary-fp-inst (name opf &key reads extended) + `(define-instruction ,name (segment dst src) + (:declare (type tn dst src)) + (:printer format-unary-fpop + ((op #b10) (op3 #b110100) (opf ,opf) + (rs1 0) + (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg)) + (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg)))) + (:dependencies + ,@(when reads + `((reads ,reads))) + (reads dst) + (reads src) + (writes dst)) + (:delay 0) + (:emitter (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst) + #b110100 0 ,opf (fp-reg-tn-encoding src))))) + +(defmacro define-binary-fp-inst (name opf &key (op3 #b110100) + reads writes delay extended) + `(define-instruction ,name (segment dst src1 src2) + (:declare (type tn dst src1 src2)) + (:printer format-binary-fpop + ((op #b10) (op3 ,op3) (opf ,opf) + (rs1 nil :type ',(if extended 'fp-ext-reg 'fp-reg)) + (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg)) + (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg)) + )) + (:dependencies + ,@(when reads + `((reads ,reads))) + (reads src1) + (reads src2) + ,@(when writes + `((writes ,writes))) + (writes dst)) + ,@(if delay + `((:delay ,delay)) + '((:delay 0))) + (:emitter (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst) + ,op3 (fp-reg-tn-encoding src1) ,opf + (fp-reg-tn-encoding src2))))) + +(defmacro define-cmp-fp-inst (name opf &key extended) + (let ((opf0 #b0) + (opf1 #b010) + (opf2 #b1)) + `(define-instruction ,name (segment src1 src2 &optional (fcc :fcc0)) + (:declare (type tn src1 src2) + (type (member :fcc0 :fcc1 :fcc2 :fcc3) fcc)) + (:printer format-fpop2 + ((op #b10) + (op3 #b110101) + (opf0 ,opf0) + (opf1 ,opf1) + (opf2 ,opf2) + (opf3 ,opf) + (rs1 nil :type ',(if extended 'fp-ext-reg 'fp-reg)) + (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg)) + #-sparc-v9 + (rd 0) + #+sparc-v9 + (rd nil :type 'fp-condition-register)) + ) + (:dependencies + (reads src1) + (reads src2) + (writes :fsr)) + ;; The Sparc V9 doesn't need a delay after a FP compare. + (:delay #-sparc-v9 1 #+sparc-v9 0) + (:emitter + (emit-format-3-fpop2 segment #b10 + (or (position fcc '(:fcc0 :fcc1 :fcc2 :fcc3)) + 0) + #b110101 + (fp-reg-tn-encoding src1) + ,opf0 ,opf1 ,opf2 ,opf + (fp-reg-tn-encoding src2)))))) + +); eval-when (compile eval) + + +(define-unary-fp-inst fitos #b011000100 :reads :fsr) +(define-unary-fp-inst fitod #b011001000 :reads :fsr :extended t) +(define-unary-fp-inst fitoq #b011001100 :reads :fsr :extended t) ; v8 + +(define-unary-fp-inst fxtos #b010000100 :reads :fsr) ; v9 +(define-unary-fp-inst fxtod #b010001000 :reads :fsr :extended t) ; v9 +(define-unary-fp-inst fxtoq #b010001100 :reads :fsr :extended t) ; v9 + + +;; I (toy@rtp.ericsson.se) don't think these f{sd}toir instructions +;; exist on any Ultrasparc, but I only have a V9 manual. The code in +;; float.lisp seems to indicate that they only existed on non-sun4 +;; machines (sun3 68K machines?). +#-sparc +(progn + (define-unary-fp-inst fstoir #b011000001 :reads :fsr) + (define-unary-fp-inst fdtoir #b011000010 :reads :fsr) +) + +(define-unary-fp-inst fstoi #b011010001) +(define-unary-fp-inst fdtoi #b011010010 :extended t) +(define-unary-fp-inst fqtoi #b011010011 :extended t) ; v8 + +(define-unary-fp-inst fstox #b010000001) ; v9 +(define-unary-fp-inst fdtox #b010000010 :extended t) ; v9 +(define-unary-fp-inst fqtox #b010000011 :extended t) ; v9 + +(define-unary-fp-inst fstod #b011001001 :reads :fsr) +(define-unary-fp-inst fstoq #b011001101 :reads :fsr) ; v8 +(define-unary-fp-inst fdtos #b011000110 :reads :fsr) +(define-unary-fp-inst fdtoq #b011001110 :reads :fsr) ; v8 +(define-unary-fp-inst fqtos #b011000111 :reads :fsr) ; v8 +(define-unary-fp-inst fqtod #b011001011 :reads :fsr) ; v8 + +(define-unary-fp-inst fmovs #b000000001) +(define-unary-fp-inst fmovd #b000000010 :extended t) ; v9 +(define-unary-fp-inst fmovq #b000000011 :extended t) ; v9 + +(define-unary-fp-inst fnegs #b000000101) +(define-unary-fp-inst fnegd #b000000110 :extended t) ; v9 +(define-unary-fp-inst fnegq #b000000111 :extended t) ; v9 + +(define-unary-fp-inst fabss #b000001001) +(define-unary-fp-inst fabsd #b000001010 :extended t) ; v9 +(define-unary-fp-inst fabsq #b000001011 :extended t) ; v9 + +(define-unary-fp-inst fsqrts #b000101001 :reads :fsr) ; V7 +(define-unary-fp-inst fsqrtd #b000101010 :reads :fsr :extended t) ; V7 +(define-unary-fp-inst fsqrtq #b000101011 :reads :fsr :extended t) ; v8 + +(define-binary-fp-inst fadds #b001000001) +(define-binary-fp-inst faddd #b001000010 :extended t) +(define-binary-fp-inst faddq #b001000011 :extended t) ; v8 +(define-binary-fp-inst fsubs #b001000101) +(define-binary-fp-inst fsubd #b001000110 :extended t) +(define-binary-fp-inst fsubq #b001000111 :extended t) ; v8 + +(define-binary-fp-inst fmuls #b001001001) +(define-binary-fp-inst fmuld #b001001010 :extended t) +(define-binary-fp-inst fmulq #b001001011 :extended t) ; v8 +(define-binary-fp-inst fdivs #b001001101) +(define-binary-fp-inst fdivd #b001001110 :extended t) +(define-binary-fp-inst fdivq #b001001111 :extended t) ; v8 + +;;; Float comparison instructions. +;;; +(define-cmp-fp-inst fcmps #b0001) +(define-cmp-fp-inst fcmpd #b0010 :extended t) +(define-cmp-fp-inst fcmpq #b0011 :extended t) ;v8 +(define-cmp-fp-inst fcmpes #b0101) +(define-cmp-fp-inst fcmped #b0110 :extended t) +(define-cmp-fp-inst fcmpeq #b0111 :extended t) ; v8 + + + +;;;; li, jali, ji, nop, cmp, not, neg, move, and more + +#-sparc-v9 +(defun %li (reg value) + (etypecase value + ((signed-byte 13) + (inst add reg zero-tn value)) + ((or (signed-byte 32) (unsigned-byte 32)) + (let ((hi (ldb (byte 22 10) value)) + (lo (ldb (byte 10 0) value))) + (inst sethi reg hi) + (unless (zerop lo) + (inst add reg lo)))) + (fixup + (inst sethi reg value) + (inst add reg value)))) + +#+sparc-v9 +(defun %li (reg value) + (etypecase value + ((signed-byte 13) + (inst add reg zero-tn value)) + ((unsigned-byte 32) + (let ((hi (ldb (byte 22 10) value)) + (lo (ldb (byte 10 0) value))) + ;; Sethi sets the top 32-bits to zero. + (inst sethi reg hi) + (unless (zerop lo) + (inst add reg lo)))) + ((signed-byte 32) + (let ((hi (ldb (byte 22 10) value)) + (lo (ldb (byte 10 0) value))) + ;; Sethi sets the top 32-bits to zero. + (inst sethi reg hi) + (unless (zerop lo) + (inst add reg lo)) + ;; Sign-extend the result + (inst signx reg))) + (fixup + (inst sethi reg value) + (inst add reg value)))) + +(define-instruction-macro li (reg value) + `(%li ,reg ,value)) + +#+sparc-v9 +(progn +(defun %li64 (reg value &optional temp) + (etypecase value + ((signed-byte 13) + (inst add reg zero-tn value)) + ((unsigned-byte 32) + (let ((hi (ldb (byte 22 10) value)) + (lo (ldb (byte 10 0) value))) + (inst sethi reg hi) + (unless (zerop lo) + (inst add reg lo)))) + ((signed-byte 32) + (let ((hi (ldb (byte 22 10) value)) + (lo (ldb (byte 10 0) value))) + ;; Sethi sets the top 32-bits to zero. + (inst sethi reg hi) + (unless (zerop lo) + (inst add reg lo)) + ;; Sign-extend the result + (inst signx reg))) + ((unsigned-byte 32) + (let ((hi (ldb (byte 22 10) value)) + (lo (ldb (byte 10 0) value))) + ;; Sethi sets the top 32-bits to zero. + (inst sethi reg hi) + (unless (zerop lo) + (inst add reg lo)))) + ((or (signed-byte 64) (unsigned-byte 64)) + (cond (temp + ;; If we have a temp register to use, we can use this + ;; shorter sequence + (let ((hh (ldb (byte 22 42) value)) + (lm (ldb (byte 22 32) value)) + (hm (ldb (byte 22 10) value)) + (lo (ldb (byte 10 0) value))) + (inst sethi temp hh) + (inst sethi reg lm) + (inst or temp hm) + (inst or reg lo) + (inst sllx temp 32) + (inst or reg temp))) + (t + ;; Hmm, no temp register given, so we have to use the + ;; following longer sequence. + (let ((bits-63-48 (ldb (byte 16 48) value)) + (bits-47-36 (ldb (byte 12 36) value)) + (bits-35-24 (ldb (byte 12 24) value)) + (bits-23-12 (ldb (byte 12 12) value)) + (bits-11-00 (ldb (byte 12 0) value))) + (inst sethi reg bits-63-48) + (inst or reg bits-47-36) + (inst sllx reg 12) + (inst or reg bits-35-24) + (inst sllx reg 12) + (inst or reg bits-23-12) + (inst sllx reg 12) + (inst or reg bits-11-00))))) + (fixup + (inst sethi reg value) + (inst add reg value)))) + +(define-instruction-macro li64 (reg value &optional temp) + `(%li64 ,reg ,value ,temp)) + +) + +;; Define LDN/STN synthetic instructions to do "natural" loads and +;; stores for 32-bit or 64-bit objects depending on whether this is a +;; 32-bit or 64-bit build. Change these to use ldx/stx/sllx/srlx/srax +;; for 64-bit build. +(macrolet ((frob (name inst) + `(define-instruction-macro ,name (dst src1 &optional src2) + `(inst ,',inst ,dst ,src1 ,src2)))) + (frob ldn ld) + (frob stn st) + (frob slln sll) + (frob srln srl) + (frob sran sra)) + +;;; Jal to a full 32-bit address. Tmpreg is trashed. +(define-instruction jali (segment link tmpreg value) + (:declare (type tn link tmpreg) + (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32) + fixup) value)) + (:attributes variable-length) + (:vop-var vop) + (:attributes branch) + (:dependencies (writes link) (writes tmpreg)) + (:delay 1) + (:emitter + (assemble (segment vop) + (etypecase value + ((signed-byte 13) + (inst jal link zero-tn value)) + ((or (signed-byte 32) (unsigned-byte 32)) + (let ((hi (ldb (byte 22 10) value)) + (lo (ldb (byte 10 0) value))) + (inst sethi tmpreg hi) + (inst jal link tmpreg lo))) + (fixup + (inst sethi tmpreg value) + (inst jal link tmpreg value)))))) + +;;; Jump to a full 32-bit address. Tmpreg is trashed. +(define-instruction ji (segment tmpreg value) + (:declare (type tn tmpreg) + (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32) + fixup) value)) + (:attributes variable-length) + (:vop-var vop) + (:attributes branch) + (:dependencies (writes tmpreg)) + (:delay 1) + (:emitter + (assemble (segment vop) + (inst jali zero-tn tmpreg value)))) + +(define-instruction nop (segment) + (:printer format-2-immed ((rd 0) (op2 #b100) (immed 0)) '(:name)) + (:attributes flushable) + (:delay 0) + (:emitter (emit-format-2-immed segment 0 0 #b100 0))) + +(def-vm-support-routine emit-nop (segment) + (emit-format-2-immed segment 0 0 #b100 0)) + +(define-instruction cmp (segment src1 &optional src2) + (:declare (type tn src1) (type (or null tn (signed-byte 13)) src2)) + (:printer format-3-reg ((op #b10) (op3 #b010100) (rd 0)) + '(:name :tab rs1 ", " rs2)) + (:printer format-3-immed ((op #b10) (op3 #b010100) (rd 0)) + '(:name :tab rs1 ", " immed)) + (:dependencies (reads src1) (if src2 (reads src2)) (writes :psr)) + (:delay 0) + (:emitter + (etypecase src2 + (null + (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0 0)) + (tn + (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0 + (reg-tn-encoding src2))) + (integer + (emit-format-3-immed segment #b10 0 #b010100 (reg-tn-encoding src1) 1 + src2))))) + +(define-instruction not (segment dst &optional src1) + (:declare (type tn dst) (type (or tn null) src1)) + (:printer format-3-reg ((op #b10) (op3 #b000111) (rs2 0)) + '(:name :tab (:unless (:same-as rd) rs1 ", " ) rd)) + (:dependencies (if src1 (reads src1) (reads dst)) (writes dst)) + (:delay 0) + (:emitter + (unless src1 + (setf src1 dst)) + (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000111 + (reg-tn-encoding src1) 0 0 0))) + +(define-instruction neg (segment dst &optional src1) + (:declare (type tn dst) (type (or tn null) src1)) + (:printer format-3-reg ((op #b10) (op3 #b000100) (rs1 0)) + '(:name :tab (:unless (:same-as rd) rs2 ", " ) rd)) + (:dependencies (if src1 (reads src1) (reads dst)) (writes dst)) + (:delay 0) + (:emitter + (unless src1 + (setf src1 dst)) + (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000100 + 0 0 0 (reg-tn-encoding src1)))) + +;; As in the suggested synthetic instructions, a register move is +;; really just or'ing the src register with %g0. +(define-instruction move (segment dst src1) + (:declare (type tn dst src1)) + (:printer format-3-reg ((op #b10) (op3 #b000010) (rs1 0)) + '(:name :tab rs2 ", " rd) + :print-name 'mov) + (:attributes flushable) + (:dependencies (reads src1) (writes dst)) + (:delay 0) + (:emitter (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000010 + 0 0 0 (reg-tn-encoding src1)))) + + + +;;;; Instructions for dumping data and header objects. + +(define-instruction word (segment word) + (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word)) + :pinned + (:delay 0) + (:emitter + (emit-word segment word))) + +(define-instruction short (segment short) + (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short)) + :pinned + (:delay 0) + (:emitter + (emit-short segment short))) + +(define-instruction byte (segment byte) + (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte)) + :pinned + (:delay 0) + (:emitter + (emit-byte segment byte))) + +(define-emitter emit-header-object 32 + (byte 24 8) (byte 8 0)) + +(defun emit-header-data (segment type) + (emit-back-patch + segment 4 + #'(lambda (segment posn) + (emit-word segment + (logior type + (ash (+ posn (component-header-length)) + (- type-bits word-shift))))))) + +(define-instruction function-header-word (segment) + :pinned + (:delay 0) + (:emitter + (emit-header-data segment function-header-type))) + +(define-instruction lra-header-word (segment) + :pinned + (:delay 0) + (:emitter + (emit-header-data segment return-pc-header-type))) + + +;;;; Instructions for converting between code objects, functions, and lras. + +(defun emit-compute-inst (segment vop dst src label temp calc) + (emit-chooser + ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments. + segment 12 3 + #'(lambda (segment posn delta-if-after) + (let ((delta (funcall calc label posn delta-if-after))) + (when (<= (- (ash 1 12)) delta (1- (ash 1 12))) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (assemble (segment vop) + (inst add dst src + (funcall calc label posn 0))))) + t))) + #'(lambda (segment posn) + (let ((delta (funcall calc label posn 0))) + (assemble (segment vop) + (inst sethi temp (ldb (byte 22 10) delta)) + (inst or temp (ldb (byte 10 0) delta)) + (inst add dst src temp)))))) + +;; code = fn - fn-ptr-type - header - label-offset + other-pointer-tag +(define-instruction compute-code-from-fn (segment dst src label temp) + (:declare (type tn dst src temp) (type label label)) + (:attributes variable-length) + (:dependencies (reads src) (writes dst) (writes temp)) + (:delay 0) + (:vop-var vop) + (:emitter + (emit-compute-inst segment vop dst src label temp + #'(lambda (label posn delta-if-after) + (- other-pointer-type + function-pointer-type + (label-position label posn delta-if-after) + (component-header-length)))))) + +;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag +(define-instruction compute-code-from-lra (segment dst src label temp) + (:declare (type tn dst src temp) (type label label)) + (:attributes variable-length) + (:dependencies (reads src) (writes dst) (writes temp)) + (:delay 0) + (:vop-var vop) + (:emitter + (emit-compute-inst segment vop dst src label temp + #'(lambda (label posn delta-if-after) + (- (+ (label-position label posn delta-if-after) + (component-header-length))))))) + +;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag +(define-instruction compute-lra-from-code (segment dst src label temp) + (:declare (type tn dst src temp) (type label label)) + (:attributes variable-length) + (:dependencies (reads src) (writes dst) (writes temp)) + (:delay 0) + (:vop-var vop) + (:emitter + (emit-compute-inst segment vop dst src label temp + #'(lambda (label posn delta-if-after) + (+ (label-position label posn delta-if-after) + (component-header-length)))))) + +;;; Sparc V9 additions + + + +;; Conditional move integer on condition code +(define-instruction cmove (segment condition dst src &optional (ccreg :icc)) + (:declare (type (or branch-condition fp-branch-condition) condition) + (type cond-move-condition-register ccreg) + (type tn dst) + (type (or (signed-byte 13) tn) src)) + (:printer format-4-cond-move + ((op #b10) + (op3 #b101100) + (cc2 #b1) + (i 0) + (cc nil :type 'integer-condition-register)) + cond-move-printer + :print-name 'mov) + (:printer format-4-cond-move-immed + ((op #b10) + (op3 #b101100) + (cc2 #b1) + (i 1) + (cc nil :type 'integer-condition-register)) + cond-move-printer + :print-name 'mov) + (:printer format-4-cond-move + ((op #b10) + (op3 #b101100) + (cc2 #b0) + (cond nil :type 'branch-fp-condition) + (i 0) + (cc nil :type 'fp-condition-register)) + cond-move-printer + :print-name 'mov) + (:printer format-4-cond-move-immed + ((op #b10) + (op3 #b101100) + (cc2 #b0) + (cond nil :type 'branch-fp-condition) + (i 1) + (cc nil :type 'fp-condition-register)) + cond-move-printer + :print-name 'mov) + (:delay 0) + (:dependencies + (if (member ccreg '(:icc :xcc)) + (reads :psr) + (reads :fsr)) + (reads src) + (reads dst) + (writes dst)) + (:emitter + (let ((op #b10) + (op3 #b101100)) + (multiple-value-bind (cc2 cc01) + (cond-move-condition-parts ccreg) + (etypecase src + (tn + (emit-format-4-cond-move segment + op + (reg-tn-encoding dst) + op3 + cc2 + (if (member ccreg '(:icc :xcc)) + (branch-condition condition) + (fp-branch-condition condition)) + 0 + cc01 + (reg-tn-encoding src))) + (integer + (emit-format-4-cond-move segment + op + (reg-tn-encoding dst) + op3 + cc2 + (if (member ccreg '(:icc :xcc)) + (branch-condition condition) + (fp-branch-condition condition)) + 1 + cc01 + src))))))) + +;; Conditional move floating-point on condition codes +(defmacro define-cond-fp-move (name print-name op op3 opf_low &key extended) + `(define-instruction ,name (segment condition dst src &optional (ccreg :fcc0)) + (:declare (type (or branch-condition fp-branch-condition) condition) + (type cond-move-condition-register ccreg) + (type tn dst src)) + (:printer format-fpop2 + ((op ,op) + (op3 ,op3) + (opf0 0) + (opf1 nil :type 'fp-condition-register-shifted) + (opf2 0) + (opf3 ,opf_low) + (rs1 nil :type 'branch-fp-condition) + (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg)) + (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))) + cond-fp-move-printer + :print-name ',print-name) + (:printer format-fpop2 + ((op ,op) + (op3 ,op3) + (opf0 1) + (opf1 nil :type 'integer-condition-register) + (opf2 0) + (rs1 nil :type 'branch-condition) + (opf3 ,opf_low) + (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg)) + (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))) + cond-fp-move-printer + :print-name ',print-name) + (:delay 0) + (:dependencies + (if (member ccreg '(:icc :xcc)) + (reads :psr) + (reads :fsr)) + (reads src) + (reads dst) + (writes dst)) + (:emitter + (multiple-value-bind (opf_cc2 opf_cc01) + (cond-move-condition-parts ccreg) + (emit-format-3-fpop2 segment + ,op + (fp-reg-tn-encoding dst) + ,op3 + (if (member ccreg '(:icc :xcc)) + (branch-condition condition) + (fp-branch-condition condition)) + opf_cc2 + (ash opf_cc01 1) + 0 + ,opf_low + (fp-reg-tn-encoding src)))))) + +(define-cond-fp-move cfmovs fmovs #b10 #b110101 #b0001) +(define-cond-fp-move cfmovd fmovd #b10 #b110101 #b0010 :extended t) +(define-cond-fp-move cfmovq fmovq #b10 #b110101 #b0011 :extended t) + + +;; Move on integer register condition +;; +;; movr dst src reg reg-cond +;; +;; This means if reg satisfies reg-cond, src is copied to dst. If the +;; condition is not satisfied, nothing is done. +;; +(define-instruction movr (segment dst src2 src1 reg-condition) + (:declare (type cond-move-integer-condition reg-condition) + (type tn dst src1) + (type (or (signed-byte 10) tn) src2)) + (:printer format-4-cond-move-integer + ((op #b10) + (op3 #b101111) + (i 0))) + (:printer format-4-cond-move-integer-immed + ((op #b10) + (op3 #b101111) + (i 1))) + (:delay 0) + (:dependencies + (reads :psr) + (reads src2) + (reads src1) + (reads dst) + (writes dst)) + (:emitter + (etypecase src2 + (tn + (emit-format-4-cond-move-integer + segment #b10 (reg-tn-encoding dst) #b101111 (reg-tn-encoding src1) + 0 (register-condition reg-condition) + 0 (reg-tn-encoding src2))) + (integer + (emit-format-4-cond-move-integer-immed + segment #b10 (reg-tn-encoding dst) #b101111 (reg-tn-encoding src1) + 1 (register-condition reg-condition) src2))))) + + +;; Same as MOVR, except we move FP registers depending on the value of +;; an integer register. +;; +;; fmovr dst src reg cond +;; +;; This means if REG satifies COND, SRC is COPIED to DST. Nothing +;; happens if the condition is not satisfied. +(defmacro define-cond-fp-move-integer (name opf_low &key extended) + `(define-instruction ,name (segment dst src2 src1 reg-condition) + (:declare (type cond-move-integer-condition reg-condition) + (type tn dst src1 src2)) + (:printer format-fpop2 + ((op #b10) + (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg)) + (op3 #b110101) + (rs1 nil :type 'reg) + (opf0 0) + (opf1 nil :type 'register-condition) + (opf2 0) + (opf3 ,opf_low) + (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg)) + ) + cond-fp-move-integer-printer) + (:delay 0) + (:dependencies + (reads src2) + (reads src1) + (reads dst) + (writes dst)) + (:emitter + (emit-format-3-fpop2 + segment + #b10 + (fp-reg-tn-encoding dst) + #b110101 + (reg-tn-encoding src1) + 0 + (register-condition reg-condition) + 0 + ,opf_low + (fp-reg-tn-encoding src2))))) + +(define-cond-fp-move-integer fmovrs #b0101) +(define-cond-fp-move-integer fmovrd #b0110 :extended t) +(define-cond-fp-move-integer fmovrq #b0111 :extended t) diff --git a/src/compiler/sparcv9/macros.lisp b/src/compiler/sparcv9/macros.lisp new file mode 100644 index 0000000000000000000000000000000000000000..332508a1e04a7d7d3123af5fb23bbeca4f9cdafb --- /dev/null +++ b/src/compiler/sparcv9/macros.lisp @@ -0,0 +1,606 @@ +;;; -*- 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/compiler/sparc/macros.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; $Header: src/compiler/sparc/macros.lisp $ +;;; +;;; This file contains various useful macros for generating SPARC code. +;;; +;;; Written by William Lott. +;;; + +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") + + +;;; Instruction-like macros. + +(defmacro move (dst src) + "Move SRC into DST unless they are location=." + (once-only ((n-dst dst) + (n-src src)) + `(unless (location= ,n-dst ,n-src) + (inst move ,n-dst ,n-src)))) + +;; (loadw object base &optional (offset 0) (lowtag 0) temp) +;; +;; Load a word at a given address into the register OBJECT. The +;; address of the word is in register BASE, plus an offset given by +;; OFFSET, which is in words. LOWTAG is an adjustment to OFFSET to +;; account for any tag bits used in the BASE descriptor register. +;; +;; In some situations, the offset may be so large that it cannot fit +;; into the offset field of the LD instruction (a 13-bit signed +;; quantity). In this situation, the TEMP non-descriptor register, if +;; supplied, is used to compute the correct offset. If TEMP is not +;; given, the offset is assumed to fit. (TEMP must be a +;; non-descriptor because we store random values into it. If OBJECT +;; were always a non-descriptor, we wouldn't need the TEMP register.) +;; +;; Samething for storew, except we store OBJECT at the given address. +(macrolet + ((frob (op inst shift) + `(defmacro ,op (object base &optional (offset 0) (lowtag 0) temp) + (if temp + (let ((offs (gensym))) + `(let ((,offs (- (ash ,offset ,',shift) ,lowtag))) + (if (typep ,offs '(signed-byte 13)) + (inst ,',inst ,object ,base ,offs) + (progn + (inst li ,temp ,offs) + (inst ,',inst ,object ,base ,temp))))) + `(inst ,',inst ,object ,base (- (ash ,offset ,',shift) ,lowtag)))))) + (frob loadw ldn word-shift) + #+(and sparc-v9 sparc-v8plus) + (frob loadsw ldsw word-shift) + (frob storew stn word-shift)) + +#+(and sparc-v9 sparc-v8plus) +(macrolet + ((frob (op inst shift) + `(defmacro ,op (object base &optional (offset 0) (lowtag 0) temp) + (if temp + (let ((offs (gensym))) + `(let ((,offs (- (ash ,offset ,',shift) ,lowtag))) + (if (typep ,offs '(signed-byte 13)) + (inst ,',inst ,object ,base ,offs) + (progn + (inst li ,temp ,offs) + (inst ,',inst ,object ,base ,temp))))) + `(inst ,',inst ,object ,base (- (ash ,offset ,',shift) ,lowtag)))))) + (frob load64 ldx (* 2 word-shift)) + (frob store64 stx (* 2 word-shift))) + +(defmacro load-symbol (reg symbol) + `(inst add ,reg null-tn (static-symbol-offset ,symbol))) + +(macrolet + ((frob (slot) + (let ((loader (intern (concatenate 'simple-string + "LOAD-SYMBOL-" + (string slot)))) + (storer (intern (concatenate 'simple-string + "STORE-SYMBOL-" + (string slot)))) + (offset (intern (concatenate 'simple-string + "SYMBOL-" + (string slot) + "-SLOT") + (find-package "VM")))) + `(progn + (defmacro ,loader (reg symbol) + `(inst ldn ,reg null-tn + (+ (static-symbol-offset ',symbol) + (ash ,',offset word-shift) + (- other-pointer-type)))) + (defmacro ,storer (reg symbol) + `(inst stn ,reg null-tn + (+ (static-symbol-offset ',symbol) + (ash ,',offset word-shift) + (- other-pointer-type)))))))) + (frob value) + (frob function)) + +(defmacro load-type (target source &optional (offset 0)) + "Loads the type bits of a pointer into target independent of + byte-ordering issues." + (once-only ((n-target target) + (n-source source) + (n-offset offset)) + (ecase (backend-byte-order *target-backend*) + (:little-endian + `(inst ldub ,n-target ,n-source ,n-offset)) + (:big-endian + `(inst ldub ,n-target ,n-source (+ ,n-offset 3)))))) + +;;; Macros to handle the fact that we cannot use the machine native call and +;;; return instructions. + +(defmacro lisp-jump (function) + "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." + `(progn + (inst j ,function + (- (ash function-code-offset word-shift) vm:function-pointer-type)) + (move code-tn ,function))) + +(defmacro lisp-return (return-pc &key (offset 0) (frob-code t)) + "Return to RETURN-PC." + `(progn + (inst j ,return-pc + (- (* (1+ ,offset) word-bytes) other-pointer-type)) + ,(if frob-code + `(move code-tn ,return-pc) + '(inst nop)))) + +(defmacro emit-return-pc (label) + "Emit a return-pc header word. LABEL is the label to use for this return-pc." + `(progn + (align lowtag-bits) + (emit-label ,label) + (inst lra-header-word))) + + + +;;;; Stack TN's + +;;; Load-Stack-TN, Store-Stack-TN -- Interface +;;; +;;; Move a stack TN to a register and vice-versa. +;;; +(defmacro load-stack-tn (reg stack) + `(let ((reg ,reg) + (stack ,stack)) + (let ((offset (tn-offset stack))) + (sc-case stack + ((control-stack) + (loadw reg cfp-tn offset 0 gtemp-tn)))))) + +(defmacro store-stack-tn (stack reg) + `(let ((stack ,stack) + (reg ,reg)) + (let ((offset (tn-offset stack))) + (sc-case stack + ((control-stack) + (storew reg cfp-tn offset 0 gtemp-tn)))))) + + +;;; MAYBE-LOAD-STACK-TN -- Interface +;;; +(defmacro maybe-load-stack-tn (reg reg-or-stack) + "Move the TN Reg-Or-Stack into Reg if it isn't already there." + (once-only ((n-reg reg) + (n-stack reg-or-stack)) + `(sc-case ,n-reg + ((any-reg descriptor-reg) + (sc-case ,n-stack + ((any-reg descriptor-reg) + (move ,n-reg ,n-stack)) + ((control-stack) + (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) + + +;;;; Storage allocation: + +;; Allocation macro +;; +;; This macro does the appropriate stuff to allocate space. +;; +;; The allocated space is stored in RESULT-TN with the lowtag LOWTAG +;; applied. The amount of space to be allocated is SIZE bytes (which +;; must be a multiple of the lisp object size). +;; +;; If STACK-P is given, then allocation occurs on the control stack +;; (for dynamic-extent). In this case, you MUST also specify NODE, so +;; that the appropriate compiler policy can be used, and TEMP-TN, +;; which is needed for work-space. TEMP-TN MUST be a non-descriptor +;; reg. +;; +;; If generational GC is enabled, you MUST supply a value for TEMP-TN +;; because a temp register is needed to do inline allocation. +;; TEMP-TN, in this case, can be any register, since it holds a +;; double-word aligned address (essentially a fixnum). +(defmacro allocation (result-tn size lowtag &key stack-p temp-tn) + ;; We assume we're in a pseudo-atomic so the pseudo-atomic bit is + ;; set. + `(cond (,stack-p + ;; Stack allocation + ;; + ;; The control stack grows up, so round up CSP to a + ;; multiple of 8 (lispobj size). Use that as the + ;; allocation pointer. Then add SIZE bytes to the + ;; allocation and set CSP to that, so we have the desired + ;; space. + + ;; Make sure the temp-tn is a non-descriptor register! + (assert (and ,temp-tn (sc-is ,temp-tn non-descriptor-reg))) + + ;; temp-tn is csp-tn rounded up to a multiple of 8 (lispobj size) + (inst add ,temp-tn csp-tn vm:lowtag-mask) + (inst andn ,temp-tn vm:lowtag-mask) + ;; Set the result to temp-tn, with appropriate lowtag + (inst or ,result-tn ,temp-tn ,lowtag) + + ;; Allocate the desired space on the stack. + ;; + ;; FIXME: Can't allocate on stack if SIZE is too large. + ;; Need to rearrange this code. + (inst add csp-tn ,temp-tn ,size) + ) + #-gencgc + (t + ;; Normal allocation to the heap. + (if (logbitp (1- lowtag-bits) ,lowtag) + (progn + (inst or ,result-tn alloc-tn ,lowtag) + (inst add alloc-tn ,size)) + (progn + (inst andn ,result-tn alloc-tn lowtag-mask) + (inst or ,result-tn ,lowtag) + (inst add alloc-tn ,size)))) + #+gencgc + (t + ;; See if we can do an inline allocation. The updated + ;; free pointer should not point past the end of the + ;; current region. If it does, a full alloc needs to be + ;; done. + (load-symbol-value ,result-tn *current-region-end-addr*) + + ;; Sometimes the size is an known constant, but won't fit in + ;; the immediate field of an instruction. Hence we have to + ;; do this to get it. + (cond ((and (tn-p ,temp-tn) + (numberp ,size) + (not (typep ,size '(signed-byte 13)))) + (inst li ,temp-tn ,size) + (inst add alloc-tn ,temp-tn)) + (t + (inst add alloc-tn ,size))) + + (inst andn ,temp-tn alloc-tn lowtag-mask) ; Zap PA bits + + ;; temp-tn points to the new end of region. Did we go + ;; past the actual end of the region? If so, we need a + ;; full alloc. + (inst cmp ,temp-tn ,result-tn) + (without-scheduling () + ;; NOTE: alloc-tn has been updated to point to the new + ;; end. But the allocation routines expect alloc-tn + ;; points to original free region. Thus, the allocation + ;; trap handler MUST subtract SIZE from alloc-tn before + ;; calling the alloc routine. This allows for + ;; (slightly) faster code for inline allocation. + + ;; As above, SIZE might not fit in the immediate field of + ;; an instruction. Need to do this complicated thing. + + (cond ((and (tn-p ,temp-tn) + (numberp ,size) + (not (typep ,size '(signed-byte 13)))) + (inst li ,result-tn ,size) + (inst sub ,result-tn ,temp-tn ,result-tn)) + (t + (inst sub ,result-tn ,temp-tn ,size))) + (inst t :gt allocation-trap)) + ;; Set lowtag appropriately + (inst or ,result-tn ,lowtag)))) + +(defmacro with-fixed-allocation ((result-tn temp-tn type-code size + &key (lowtag other-pointer-type) + stack-p) + &body body) + "Do stuff to allocate an other-pointer object of fixed Size with a single + word header having the specified Type-Code. The result is placed in + Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used + by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably + initializes the object." + (once-only ((result-tn result-tn) (temp-tn temp-tn) + (type-code type-code) (size size) + (lowtag lowtag)) + `(pseudo-atomic () + (allocation ,result-tn (pad-data-block ,size) ,lowtag + :temp-tn ,temp-tn + :stack-p ,stack-p) + (when ,type-code + (inst li ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code)) + (storew ,temp-tn ,result-tn 0 ,lowtag)) + ,@body))) + + +;;;; Type testing noise. + +;;; GEN-RANGE-TEST -- internal +;;; +;;; Generate code that branches to TARGET iff REG contains one of VALUES. +;;; If NOT-P is true, invert the test. Jumping to NOT-TARGET is the same +;;; as falling out the bottom. +;;; +(defun gen-range-test (reg target not-target not-p min seperation max values) + (let ((tests nil) + (start nil) + (end nil) + (insts nil)) + (multiple-value-bind (equal less-or-equal greater-or-equal label) + (if not-p + (values :ne :gt :lt not-target) + (values :eq :le :ge target)) + (flet ((emit-test () + (if (= start end) + (push start tests) + (push (cons start end) tests)))) + (dolist (value values) + (cond ((< value min) + (error (intl:gettext "~S is less than the specified minimum of ~S") + value min)) + ((> value max) + (error (intl:gettext "~S is greater than the specified maximum of ~S") + value max)) + ((not (zerop (rem (- value min) seperation))) + (error (intl:gettext "~S isn't an even multiple of ~S from ~S") + value seperation min)) + ((null start) + (setf start value)) + ((> value (+ end seperation)) + (emit-test) + (setf start value))) + (setf end value)) + (emit-test)) + (macrolet ((inst (name &rest args) + `(push (list 'inst ',name ,@args) insts))) + (do ((remaining (nreverse tests) (cdr remaining))) + ((null remaining)) + (let ((test (car remaining)) + (last (null (cdr remaining)))) + (if (atom test) + (progn + (inst cmp reg test) + (if last + (inst b equal target) + (inst b :eq label))) + (let ((start (car test)) + (end (cdr test))) + (cond ((and (= start min) (= end max)) + (warn (intl:gettext "The values ~S cover the entire range from ~ + ~S to ~S [step ~S].") + values min max seperation) + (push `(unless ,not-p (inst b ,target)) insts)) + ((= start min) + (inst cmp reg end) + (if last + (inst b less-or-equal target) + (inst b :le label))) + ((= end max) + (inst cmp reg start) + (if last + (inst b greater-or-equal target) + (inst b :ge label))) + (t + (inst cmp reg start) + (inst b :lt (if not-p target not-target)) + (inst cmp reg end) + (if last + (inst b less-or-equal target) + (inst b :le label)))))))))) + (nreverse insts))) + +(defun gen-other-immediate-test (reg target not-target not-p values) + (gen-range-test reg target not-target not-p + (+ other-immediate-0-type lowtag-limit) + (- other-immediate-1-type other-immediate-0-type) + (ash 1 type-bits) + values)) + + +(defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs + function-p) + (let* ((fixnump (and (member even-fixnum-type lowtags :test #'eql) + (member odd-fixnum-type lowtags :test #'eql))) + (lowtags (sort (if fixnump + (delete even-fixnum-type + (remove odd-fixnum-type lowtags + :test #'eql) + :test #'eql) + (copy-list lowtags)) + #'<)) + (lowtag (if function-p + vm:function-pointer-type + vm:other-pointer-type)) + (hdrs (sort (copy-list hdrs) #'<)) + (immed (sort (copy-list immed) #'<))) + (append + (when immed + `((inst and ,temp ,reg type-mask) + ,@(if (or fixnump lowtags hdrs) + (let ((fall-through (gensym))) + `((let (,fall-through (gen-label)) + ,@(gen-other-immediate-test + temp (if not-p not-target target) + fall-through nil immed) + (emit-label ,fall-through)))) + (gen-other-immediate-test temp target not-target not-p immed)))) + (when fixnump + `((inst andcc zero-tn ,reg fixnum-tag-mask) + ,(if (or lowtags hdrs) + `(inst b :eq ,(if not-p not-target target) + #+sparc-v9 ,(if not-p :pn :pt)) + `(inst b ,(if not-p :ne :eq) ,target + #+sparc-v9 ,(if not-p :pn :pt))))) + (when (or lowtags hdrs) + `((inst and ,temp ,reg lowtag-mask))) + (when lowtags + (if hdrs + (let ((fall-through (gensym))) + `((let ((,fall-through (gen-label))) + ,@(gen-range-test temp (if not-p not-target target) + fall-through nil + 0 1 (1- lowtag-limit) lowtags) + (emit-label ,fall-through)))) + (gen-range-test temp target not-target not-p 0 1 + (1- lowtag-limit) lowtags))) + (when hdrs + `((inst cmp ,temp ,lowtag) + (inst b :ne ,(if not-p target not-target) + #+sparc-v9 ,(if not-p :pn :pt)) + (inst nop) + (load-type ,temp ,reg (- ,lowtag)) + ,@(gen-other-immediate-test temp target not-target not-p hdrs)))))) + +(defconstant immediate-types + (list base-char-type unbound-marker-type)) + +(defconstant function-subtypes + (list funcallable-instance-header-type + #-double-double dylan-function-header-type + function-header-type closure-function-header-type + closure-header-type)) + +(defmacro test-type (register temp target not-p &rest type-codes) + (let* ((type-codes (mapcar #'eval type-codes)) + (lowtags (remove lowtag-limit type-codes :test #'<)) + (extended (remove lowtag-limit type-codes :test #'>)) + (immediates (intersection extended immediate-types :test #'eql)) + (headers (set-difference extended immediate-types :test #'eql)) + (function-p nil)) + (unless type-codes + (error (intl:gettext "Must supply at least on type for test-type."))) + (when (and headers (member other-pointer-type lowtags)) + (warn (intl:gettext "OTHER-POINTER-TYPE supersedes the use of ~S") headers) + (setf headers nil)) + (when (and immediates + (or (member other-immediate-0-type lowtags) + (member other-immediate-1-type lowtags))) + (warn (intl:gettext "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S") immediates) + (setf immediates nil)) + (when (intersection headers function-subtypes) + (unless (subsetp headers function-subtypes) + (error (intl:gettext "Can't test for mix of function subtypes and normal ~ + header types."))) + (setq function-p t)) + + (let ((n-reg (gensym)) + (n-temp (gensym)) + (n-target (gensym)) + (not-target (gensym))) + `(let ((,n-reg ,register) + (,n-temp ,temp) + (,n-target ,target) + (,not-target (gen-label))) + (declare (ignorable ,n-temp)) + ,@(if (constantp not-p) + (test-type-aux n-reg n-temp n-target not-target + (eval not-p) lowtags immediates headers + function-p) + `((cond (,not-p + ,@(test-type-aux n-reg n-temp n-target not-target t + lowtags immediates headers + function-p)) + (t + ,@(test-type-aux n-reg n-temp n-target not-target nil + lowtags immediates headers + function-p))))) + (inst nop) + (emit-label ,not-target))))) + + +;;;; Error Code + +(defvar *adjustable-vectors* nil) + +(defmacro with-adjustable-vector ((var) &rest body) + `(let ((,var (or (pop *adjustable-vectors*) + (make-array 16 + :element-type '(unsigned-byte 8) + :fill-pointer 0 + :adjustable t)))) + (setf (fill-pointer ,var) 0) + (unwind-protect + (progn + ,@body) + (push ,var *adjustable-vectors*)))) + +(eval-when (compile load eval) + (defun emit-error-break (vop kind code values) + (let ((vector (gensym))) + `((let ((vop ,vop)) + (when vop + (note-this-location vop :internal-error))) + (inst unimp ,kind) + (with-adjustable-vector (,vector) + (write-var-integer (error-number-or-lose ',code) ,vector) + ,@(mapcar #'(lambda (tn) + `(let ((tn ,tn)) + (write-var-integer (make-sc-offset (sc-number + (tn-sc tn)) + (tn-offset tn)) + ,vector))) + values) + (inst byte (length ,vector)) + (dotimes (i (length ,vector)) + (inst byte (aref ,vector i)))) + (align word-shift))))) + +(defmacro error-call (vop error-code &rest values) + "Cause an error. ERROR-CODE is the error to cause." + (cons 'progn + (emit-error-break vop error-trap error-code values))) + + +(defmacro cerror-call (vop label error-code &rest values) + "Cause a continuable error. If the error is continued, execution resumes at + LABEL." + `(progn + (inst b ,label) + ,@(emit-error-break vop cerror-trap error-code values))) + +(defmacro generate-error-code (vop error-code &rest values) + "Generate-Error-Code Error-code Value* + Emit code for an error with the specified Error-Code and context Values." + `(assemble (*elsewhere*) + (let ((start-lab (gen-label))) + (emit-label start-lab) + (error-call ,vop ,error-code ,@values) + start-lab))) + +(defmacro generate-cerror-code (vop error-code &rest values) + "Generate-CError-Code Error-code Value* + Emit code for a continuable error with the specified Error-Code and + context Values. If the error is continued, execution resumes after + the GENERATE-CERROR-CODE form." + (let ((continue (gensym "CONTINUE-LABEL-")) + (error (gensym "ERROR-LABEL-"))) + `(let ((,continue (gen-label))) + (emit-label ,continue) + (assemble (*elsewhere*) + (let ((,error (gen-label))) + (emit-label ,error) + (cerror-call ,vop ,continue ,error-code ,@values) + ,error))))) + + + +;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic. +;;; +(defmacro pseudo-atomic ((&key (extra 0)) &rest forms) + (declare (ignore extra)) + `(progn + ;; Set the pseudo-atomic flag + (without-scheduling () + (inst or alloc-tn pseudo-atomic-value)) + ,@forms + ;; Reset the pseudo-atomic flag + (without-scheduling () + ;; Remove the pseudo-atomic flag. (Could do subtraction here, + ;; but the disassembler prints some notes based on the add + ;; instruction.) + (inst andn alloc-tn pseudo-atomic-value) + ;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1) + (inst andcc zero-tn alloc-tn pseudo-atomic-interrupted-value) + ;; The C code needs to process this correctly and fixup alloc-tn. + (inst t :ne pseudo-atomic-trap) + ))) diff --git a/src/compiler/sparcv9/memory.lisp b/src/compiler/sparcv9/memory.lisp new file mode 100644 index 0000000000000000000000000000000000000000..3830309614818191c2589dabf95bda90cbc11b63 --- /dev/null +++ b/src/compiler/sparcv9/memory.lisp @@ -0,0 +1,118 @@ +;;; -*- 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/compiler/sparc/memory.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the SPARC definitions of some general purpose memory +;;; reference VOPs inherited by basic memory reference operations. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted by William Lott. +;;; + +(in-package "SPARC") + +;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to +;;; be read or written is a property of the VOP used. +;;; +(define-vop (cell-ref) + (:args (object :scs (descriptor-reg))) + (:results (value :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (loadw value object offset lowtag))) +;;; +(define-vop (cell-set) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag))) + +;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the +;;; offset is constant at compile time, but varies for different uses. We add +;;; in the stardard g-vector overhead. +;;; +(define-vop (slot-ref) + (:args (object :scs (descriptor-reg))) + (:results (value :scs (descriptor-reg any-reg))) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (loadw value object (+ base offset) lowtag))) +;;; +(define-vop (slot-set) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (storew value object (+ base offset) lowtag))) + + + +;;;; Indexed references: + +;;; Define-Indexer -- Internal +;;; +;;; Define some VOPs for indexed memory reference. +;;; +(defmacro define-indexer (name write-p op shift) + `(define-vop (,name) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg zero immediate)) + ,@(when write-p + '((value :scs (any-reg descriptor-reg) :target result)))) + (:arg-types * tagged-num ,@(when write-p '(*))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (,(if write-p 'result 'value) + :scs (any-reg descriptor-reg))) + (:result-types *) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 5 + (sc-case index + ((immediate zero) + (let ((offset (- (+ (if (sc-is index zero) + 0 + (ash (tn-value index) + (- vm:word-shift ,shift))) + (ash offset vm:word-shift)) + lowtag))) + (etypecase offset + ((signed-byte 13) + (inst ,op value object offset)) + ((or (unsigned-byte 32) (signed-byte 32)) + (inst li temp offset) + (inst ,op value object temp))))) + (t + ,@(unless (zerop shift) + `((inst srln temp index ,shift))) + (inst add temp ,(if (zerop shift) 'index 'temp) + (- (ash offset vm:word-shift) lowtag)) + (inst ,op value object temp))) + ,@(when write-p + '((move result value)))))) + +#+sparc-v9 +(define-indexer signed-word-index-ref nil ldsw 0) +#+sparc-v9 +(define-indexer signed-word-index-set nil st 0) +(define-indexer word-index-ref nil ld 0) +(define-indexer word-index-set t st 0) +(define-indexer halfword-index-ref nil lduh 1) +(define-indexer signed-halfword-index-ref nil ldsh 1) +(define-indexer halfword-index-set t sth 1) +(define-indexer byte-index-ref nil ldub 2) +(define-indexer signed-byte-index-ref nil ldsb 2) +(define-indexer byte-index-set t stb 2) + diff --git a/src/compiler/sparcv9/move.lisp b/src/compiler/sparcv9/move.lisp new file mode 100644 index 0000000000000000000000000000000000000000..7b683b5c0dae594be7a27bbef0f99ce426797549 --- /dev/null +++ b/src/compiler/sparcv9/move.lisp @@ -0,0 +1,680 @@ +;;; -*- 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/compiler/sparc/move.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; $Header: src/compiler/sparc/move.lisp $ +;;; +;;; This file contains the SPARC VM definition of operand loading/saving and +;;; the Move VOP. +;;; +;;; Written by Rob MacLachlan. +;;; SPARC conversion by William Lott. +;;; +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") + + +(define-move-function (load-immediate 1) (vop x y) + ((null immediate zero) + (any-reg descriptor-reg)) + (let ((val (tn-value x))) + (etypecase val + (integer + (inst li y (fixnumize val))) + (null + (move y null-tn)) + (symbol + (load-symbol y val)) + (character + (inst li y (logior (ash (char-code val) type-bits) + base-char-type)))))) + +#-(and sparc-v9 sparc-v8plus) +(define-move-function (load-number 1) (vop x y) + ((immediate zero) + (signed-reg unsigned-reg)) + (inst li y (tn-value x))) + +#+(and sparc-v9 sparc-v8plus) +(define-move-function (load-number 1) (vop x y) + ((immediate zero) + (signed-reg unsigned-reg signed64-reg unsigned64-reg)) + (inst li64 y (tn-value x))) + +(define-move-function (load-base-char 1) (vop x y) + ((immediate) (base-char-reg)) + (inst li y (char-code (tn-value x)))) + +(define-move-function (load-system-area-pointer 1) (vop x y) + ((immediate) (sap-reg)) + (inst li y (sap-int (tn-value x)))) + +(define-move-function (load-constant 5) (vop x y) + ((constant) (descriptor-reg)) + (loadw y code-tn (tn-offset x) other-pointer-type gtemp-tn)) + +(define-move-function (load-stack 5) (vop x y) + ((control-stack) (any-reg descriptor-reg)) + (load-stack-tn y x)) + +(define-move-function (load-number-stack 5) (vop x y) + ((base-char-stack) (base-char-reg) + (sap-stack) (sap-reg) + (signed-stack) (signed-reg) + (unsigned-stack) (unsigned-reg)) + (let ((nfp (current-nfp-tn vop))) + (loadw y nfp (tn-offset x)))) + +(define-move-function (store-stack 5) (vop x y) + ((any-reg descriptor-reg) (control-stack)) + (store-stack-tn y x)) + +(define-move-function (store-number-stack 5) (vop x y) + ((base-char-reg) (base-char-stack) + (sap-reg) (sap-stack) + (signed-reg) (signed-stack) + (unsigned-reg) (unsigned-stack)) + (let ((nfp (current-nfp-tn vop))) + (storew x nfp (tn-offset y)))) + + + +;;;; The Move VOP: +;;; +(define-vop (move) + (:args (x :target y + :scs (any-reg descriptor-reg zero null) + :load-if (not (location= x y)))) + (:results (y :scs (any-reg descriptor-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:generator 0 + (move y x))) + +(define-move-vop move :move + (any-reg descriptor-reg) + (any-reg descriptor-reg)) + +;;; Make Move the check VOP for T so that type check generation doesn't think +;;; it is a hairy type. This also allows checking of a few of the values in a +;;; continuation to fall out. +;;; +(primitive-type-vop move (:check) t) + +;;; The Move-Argument VOP is used for moving descriptor values into another +;;; frame for argument or known value passing. +;;; +(define-vop (move-argument) + (:args (x :target y + :scs (any-reg descriptor-reg zero null)) + (fp :scs (any-reg) + :load-if (not (sc-is y any-reg descriptor-reg)))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (y)) + (:generator 0 + (sc-case y + ((any-reg descriptor-reg) + (move y x)) + (control-stack + (storew x fp (tn-offset y) 0 temp))))) +;;; +(define-move-vop move-argument :move-argument + (any-reg descriptor-reg) + (any-reg descriptor-reg)) + + + +;;;; ILLEGAL-MOVE + +;;; This VOP exists just to begin the lifetime of a TN that couldn't be written +;;; legally due to a type error. An error is signalled before this VOP is +;;; so we don't need to do anything (not that there would be anything sensible +;;; to do anyway.) +;;; +(define-vop (illegal-move) + (:args (x) (type)) + (:results (y)) + (:ignore y) + (:vop-var vop) + (:save-p :compute-only) + (:generator 666 + (error-call vop object-not-type-error x type))) + + + +;;;; Moves and coercions: + +;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word +;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer +;;; to a tagged bignum or fixnum. + +;;; Arg is a fixnum, so just shift it. We need a type restriction because some +;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs. +;;; +(define-vop (move-to-word/fixnum) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (signed-reg unsigned-reg))) + (:arg-types tagged-num) + (:note _N"fixnum untagging") + (:generator 1 + (inst sran y x fixnum-tag-bits))) + +;;; +(define-move-vop move-to-word/fixnum :move + (any-reg descriptor-reg) (signed-reg unsigned-reg)) + +;;; Arg is a non-immediate constant, load it. +(define-vop (move-to-word-c) + (:args (x :scs (constant))) + (:results (y :scs (signed-reg unsigned-reg))) + (:note _N"constant load") + (:generator 1 + (inst li y (tn-value x)))) + +;;; +(define-move-vop move-to-word-c :move + (constant) (signed-reg unsigned-reg)) + +;;; Arg is a fixnum or bignum, figure out which and load if necessary. +#-(and sparc-v9 sparc-v8plus) +(define-vop (move-to-word/integer) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (signed-reg unsigned-reg))) + (:note _N"integer to untagged word coercion") + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 4 + (let ((done (gen-label))) + (inst andcc temp x fixnum-tag-mask) + (inst b :eq done) + (inst sran y x fixnum-tag-bits) + + (loadw y x bignum-digits-offset other-pointer-type) + + (emit-label done)))) + +;; Same as above, but the number is sign-extended to a full 64-bit +;; length. Not really needed, I suppose. +#+(and sparc-v9 sparc-v8plus) +(define-vop (move-to-word/integer) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (signed-reg unsigned-reg))) + (:note _N"integer to untagged word coercion") + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 4 + (let ((done (gen-label))) + (inst andcc temp x fixnum-tag-mask) + (inst signx temp x) ; sign-extend x to temp + (inst b :eq done) + (inst srax y temp fixnum-tag-bits) + + (loadsw y x bignum-digits-offset other-pointer-type) + + (emit-label done)))) + +;;; +(define-move-vop move-to-word/integer :move + (descriptor-reg) (signed-reg unsigned-reg)) + + + +;;; Result is a fixnum, so we can just shift. We need the result type +;;; restriction because of the control-stack ambiguity noted above. +;;; +(define-vop (move-from-word/fixnum) + (:args (x :scs (signed-reg unsigned-reg))) + (:results (y :scs (any-reg descriptor-reg))) + (:result-types tagged-num) + (:note _N"fixnum tagging") + (:generator 1 + (inst slln y x fixnum-tag-bits))) +;;; +(define-move-vop move-from-word/fixnum :move + (signed-reg unsigned-reg) (any-reg descriptor-reg)) + + +;;; Result may be a bignum, so we have to check. Use a worst-case cost to make +;;; sure people know they may be number consing. +;;; +(define-vop (move-from-signed) + (:args (arg :scs (signed-reg unsigned-reg) :target x)) + (:results (y :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) + (:note _N"signed word to integer coercion") + (:generator 20 + (move x arg) + (let ((done (gen-label))) + ;; Need to figure out if we have a fixnum or not, so look at the + ;; top 3 bits of the 32-bit int. If these 3 bits are 0 or 7, + ;; then we have a fixnum. Otherwise we need to allocate a + ;; bignum. + ;; + ;; A simple way to tell if those 3 bits are 0 or 7 was given by + ;; Frode Vatvedt Fjeld: (zerop (logand #b110 (1+ temp))) + (inst srln temp x positive-fixnum-bits) + (inst add temp 1) + (inst andcc temp #b110) + (inst b :eq done) + (inst slln y x fixnum-tag-bits) + + (with-fixed-allocation + (y temp bignum-type (1+ bignum-digits-offset)) + (storew x y bignum-digits-offset other-pointer-type)) + (emit-label done)))) +;;; +(define-move-vop move-from-signed :move + (signed-reg) (descriptor-reg)) + +;;; Result may be a bignum, so we have to check. Use a worst-case cost to make +;;; sure people know they may be number consing. +;;; + +;;; Check for fixnum, and possibly allocate one or two word bignum result. Use +;;; a worst-case cost to make sure people know they may be number consing. +;;; +#-sparc-v9 +(define-vop (move-from-unsigned) + (:args (arg :scs (signed-reg unsigned-reg) :target x)) + (:results (y :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) + (:note _N"unsigned word to integer coercion") + (:generator 20 + (move x arg) + (let ((done (gen-label)) + (one-word (gen-label))) + (inst sran temp x positive-fixnum-bits) + (inst cmp temp) + (inst b :eq done) + (inst slln y x fixnum-tag-bits) + + ;; We always allocate 2 words even if we don't need it. (The + ;; copying GC will take care of freeing the unused extra word.) + (with-fixed-allocation + (y temp bignum-type (+ 2 bignum-digits-offset)) + (inst cmp x) + (inst b :ge one-word) + (inst li temp (logior (ash 1 type-bits) bignum-type)) + (inst li temp (logior (ash 2 type-bits) bignum-type)) + (emit-label one-word) + ;; Set the header word, then the actual digit. The extra + ;; digit, if any, is automatically set to zero, so we don't + ;; have to. + (storew temp y 0 other-pointer-type) + (storew x y bignum-digits-offset other-pointer-type)) + (emit-label done)))) + +#+sparc-v9 +(define-vop (move-from-unsigned) + (:args (arg :scs (signed-reg unsigned-reg) :target x)) + (:results (y :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) + (:note _N"unsigned word to integer coercion") + (:generator 20 + (move x arg) + (let ((done (gen-label))) + (inst sran temp x positive-fixnum-bits) + (inst cmp temp) + (inst b :eq done) + (inst slln y x fixnum-tag-bits) + + ;; We always allocate 2 words even if we don't need it. (The + ;; copying GC will take care of freeing the unused extra word.) + (with-fixed-allocation (y temp nil (+ 2 bignum-digits-offset)) + (inst cmp x) + (inst li temp (logior (ash 2 type-bits) bignum-type)) + (inst cmove :ge temp (logior (ash 1 type-bits) bignum-type)) + ;; Set the header word, then the actual digit. The extra + ;; digit, if any, is automatically set to zero, so we don't + ;; have to. + (storew temp y 0 other-pointer-type) + (storew x y bignum-digits-offset other-pointer-type)) + (emit-label done)))) +;;; +(define-move-vop move-from-unsigned :move + (unsigned-reg) (descriptor-reg)) + + +;;; Move untagged numbers. +;;; +(define-vop (word-move) + (:args (x :target y + :scs (signed-reg unsigned-reg) + :load-if (not (location= x y)))) + (:results (y :scs (signed-reg unsigned-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:note _N"word integer move") + (:generator 0 + (move y x))) +;;; +(define-move-vop word-move :move + (signed-reg unsigned-reg) (signed-reg unsigned-reg)) + +;;; Move untagged number arguments/return-values. +;;; +(define-vop (move-word-argument) + (:args (x :target y + :scs (signed-reg unsigned-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:temporary (:scs (non-descriptor-reg)) temp) + (:note _N"word integer argument move") + (:generator 0 + (sc-case y + ((signed-reg unsigned-reg) + (move y x)) + ((signed-stack unsigned-stack) + (storew x fp (tn-offset y) 0 temp))))) +;;; +(define-move-vop move-word-argument :move-argument + (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg)) + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a +;;; descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (signed-reg unsigned-reg) (any-reg descriptor-reg)) + +;; 64-bit stuff +#+(and sparc-v9 sparc-v8plus) +(progn + +;; Move a signed-reg to a signed64-reg by sign-extending. (Is this +;; needed?) +(define-move-function (load-signed64-signed 1) (vop x y) + ((signed-reg) (signed64-reg unsigned64-reg)) + (inst signx y x)) + +;; Move a signed64-reg to signed-reg by setting the high 32 bits to be +;; the sign. (Is this needed and will this do the right thing when +;; that signed64-reg actually has more than 32 significant bits?) +#+nil +(define-move-function (load-signed-signed64 1) (vop x y) + ((signed64-reg) (signed-reg)) + (inst signx y x)) + +;; Load a 64-bit number from the stack +(define-move-function (load-number-stack-64 5) (vop x y) + ((signed64-stack) (signed64-reg) + (unsigned64-stack) (unsigned64-reg)) + (let ((nfp (current-nfp-tn vop))) + (load64 y nfp (tn-offset x)))) + +;; Save a 64-bit number to the stack +(define-move-function (store-number-stack-64 5) (vop x y) + ((signed64-reg) (signed64-stack) + (unsigned64-reg) (unsigned64-stack)) + (let ((nfp (current-nfp-tn vop))) + (store64 x nfp (tn-offset y)))) + +;; Move a tagged integer to a raw double-word representation. +(define-vop (move-to-64bit-word/fixnum) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (signed64-reg unsigned64-reg))) + (:arg-types tagged-num) + (:note _N"fixnum untagging") + (:generator 0 + ;; Sign-extend the fixnum and then remove the tag. (Can't just + ;; remove the tag because we don't know for sure if X has been + ;; sign-extended to 64-bits. Let's be safe.) + (inst signx y x) + (inst srax y y fixnum-tag-bits))) + +(define-move-vop move-to-64bit-word/fixnum :move + (any-reg descriptor-reg) (signed64-reg unsigned64-reg)) + +;; Arg is a non-immediate constant, load it. +(define-vop (move-to-64bit-word-c) + (:args (x :scs (constant))) + (:results (y :scs (signed64-reg unsigned64-reg))) + (:note _N"constant load") + (:generator 1 + (inst li64 y (tn-value x)))) + +(define-move-vop move-to-64bit-word-c :move + (constant) (signed64-reg unsigned64-reg)) + +;; Arg is a fixnum or bignum. Figure out which and load if necessary +(define-vop (move-to-64bit-word/integer) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (signed64-reg))) + (:note _N"integer to untagged word coercion") + (:temporary (:scs (signed64-reg)) temp) + (:generator 4 + (let ((done (gen-label))) + (inst andcc temp x fixnum-tag-mask) + (inst signx temp x) ; sign-extend X to TEMP + (inst b :eq done :pt :xcc) + (inst sran y temp fixnum-tag-bits) ; Zap the tag bits + + ;; We have a bignum. We need to check the length. If the + ;; length is 1, just get the one word. If it's 2, we need to + ;; get both words. + + (loadw temp x 0 other-pointer-type) + (inst srln temp 8) + (inst cmp temp 1) + (inst b :eq done) + ;; Get the low word and sign-extend it + (loadsw y x bignum-digits-offset other-pointer-type) + + + ;; Get the high word and then the low word. Merge them + ;; together. (If we knew that bignum digits started on an 8-byte + ;; boundary, we could do an 8-byte load and them manipulate the + ;; pieces to get the order we want. I think this would require + ;; adding a filler word to the bignum type in objdef.lisp. But + ;; then every bignum has a wasted word. Is that ok?) + (loadw temp x (1+ bignum-digits-offset) other-pointer-type) + (inst sllx temp temp 32) + (loadw y x bignum-digits-offset other-pointer-type) + (inst or y temp) + + (emit-label done) + + ))) + +(define-move-vop move-to-64bit-word/integer :move + (descriptor-reg) (signed64-reg)) + +;; Move a signed-byte 32 to a signed-byte 64. (Is this ever called? +;; I don't think so.) +(define-vop (move-to-64bit-word/signed) + (:args (x :scs (signed-reg))) + (:results (y :scs (signed64-reg))) + (:arg-types signed-num) + (:generator 0 + ;; Sign-extend the 32-bit number + (inst signx y x))) + +(define-move-vop move-to-64bit-word/signed :move + (signed-reg) (signed64-reg unsigned64-reg)) + +;; Move an unsigned-byte 32 to signed-byte 64. (I don't think this +;; ever gets called.) +(define-vop (move-to-64bit-word/unsigned) + (:args (x :scs (unsigned-reg))) + (:results (y :scs (signed64-reg))) + (:arg-types unsigned-num) + (:generator 1 + ;; Zero-extend the 32-bit number + (inst clruw y x))) + +(define-move-vop move-to-64bit-word/unsigned :move + (unsigned-reg) (signed64-reg unsigned64-reg)) + +;; Save a 64-bit int to a bignum. +(define-vop (move-from-signed64) + (:args (arg :scs (signed64-reg) :target x)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (signed64-reg) :from (:argument 0)) x temp) + (:note _N"signed 64-bit word to integer coercion") + (:generator 20 + (move x arg) + (let ((fixnum (gen-label)) + (done (gen-label))) + ;; See if the result will fit in a fixnum. + (inst srax temp x positive-fixnum-bits) + (inst cmp temp) + ;; If result is all zeroes, we have a positive fixnum. + (inst b :eq fixnum :pt :xcc) + (inst orncc temp zero-tn temp) + ;; If result is all zeroes, we have a negative fixnum. + (inst b :eq done :pt :xcc) + (inst slln y x fixnum-tag-bits) + + ;; A 64-bit signed integer takes exactly 2 bignum digits + (with-fixed-allocation + (y temp bignum-type (+ 2 bignum-digits-offset)) + ;; Store the low word at the low address, the high word at the + ;; higher address. (Like move-to-64bit-word/integer, if we knew + ;; the first bignum digit was on a 8-byte boundary, we could + ;; just do a single 8-byte store instead of 2 stores here.) + (storew x y bignum-digits-offset other-pointer-type) + (inst srax x x 32) + (storew x y (1+ bignum-digits-offset) other-pointer-type)) + (inst b done) + (inst nop) + + (emit-label fixnum) + (inst slln y x fixnum-tag-bits) + (emit-label done)))) + +(define-move-vop move-from-signed64 :move + (signed64-reg) (descriptor-reg)) + +;; Save an unsigned 64-bit int to a bignum. +(define-vop (move-from-unsigned64) + (:args (arg :scs (unsigned64-reg) :target x)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (unsigned64-reg) :from (:argument 0)) x temp) + (:note _N"unsigned 64-bit word to integer coercion") + (:generator 20 + (move x arg) + (let ((two-words (gen-label)) + (done (gen-label))) + ;; See if the result will fit in a fixnum. + (inst srax temp x positive-fixnum-bits) + (inst cmp temp) + ;; If result is all zeroes, we have a positive fixnum. + (inst b :eq done :pt :xcc) + (inst slln y x fixnum-tag-bits) + + ;; A unsigned 64-bit signed integer takes exactly 2 or 3 bignum + ;; digits. We always allocate 3. (The copying GC will take + ;; care of freeing the unused extra word, if any.) + (with-fixed-allocation + (y temp bignum-type (+ 3 bignum-digits-offset)) + (inst cmp x) + (inst b :ge two-words :pn :xcc) + (inst li temp (logior (ash 2 type-bits) bignum-type)) + (inst li temp (logior (ash 3 type-bits) bignum-type)) + (emit-label two-words) + ;; Set the header word with the correct bignum length. + (storew temp y 0 other-pointer-type) + ;; Store the low word at the low address, the high word at the + ;; higher address. (Like move-to-64bit-word/integer, if we knew + ;; the first bignum digit was on a 8-byte boundary, we could + ;; just do a single 8-byte store instead of 2 stores here.) + (storew x y bignum-digits-offset other-pointer-type) + (inst srax x x 32) + (storew x y (1+ bignum-digits-offset) other-pointer-type)) + (emit-label done)))) + +(define-move-vop move-from-unsigned64 :move + (unsigned64-reg) (descriptor-reg)) + +(define-vop (move-to-unsigned-64bit-word/integer) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (unsigned64-reg))) + (:note _N"integer to untagged word coercion") + (:temporary (:scs (unsigned64-reg)) temp) + (:generator 4 + (let ((done (gen-label))) + (inst andcc temp x fixnum-tag-mask) + (inst signx temp x) ; sign-extend X to TEMP + (inst b :eq done :pt :xcc) + (inst sran y temp fixnum-tag-bits) ; Zap the tag bits + + ;; We have a bignum. We need to check the length. If the + ;; length is 1, just get the one word. If it's 2, we need to + ;; get both words. + + (loadw temp x 0 other-pointer-type) + (inst srln temp 8) + (inst cmp temp 1) + (inst b :eq done) + ;; Get the low word and zero-extend it and we're done. + (loadw y x bignum-digits-offset other-pointer-type) + + + ;; Get the high word and then the low word. Merge them + ;; together. (If we knew that bignum digits started on an 8-byte + ;; boundary, we could do an 8-byte load and them manipulate the + ;; pieces to get the order we want. I think this would require + ;; adding a filler word to the bignum type in objdef.lisp. But + ;; then every bignum has a wasted word. Is that ok?) + (loadw temp x (1+ bignum-digits-offset) other-pointer-type) + (inst sllx temp temp 32) + (loadw y x bignum-digits-offset other-pointer-type) + (inst or y temp) + + (emit-label done) + + ))) + +(define-move-vop move-to-unsigned-64bit-word/integer :move + (descriptor-reg) (unsigned64-reg)) + +(define-vop (64bit-word-move) + (:args (x :target y + :scs (signed64-reg unsigned64-reg) + :load-if (not (location= x y)))) + (:results (y :scs (signed64-reg unsigned64-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:note _N"word integer move") + (:generator 0 + (move y x))) + +(define-move-vop 64bit-word-move :move + (signed64-reg unsigned64-reg) (signed64-reg unsigned64-reg)) + +;; Move untagged number arguments/return-values. +(define-vop (move-64bit-word-argument) + (:args (x :target y + :scs (signed-reg signed64-reg unsigned64-reg immediate)) + (fp :scs (any-reg) + :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:note _N"word integer argument move") + (:generator 0 + (sc-case y + ((signed64-reg unsigned64-reg) + (sc-case x + ((signed64-reg unsigned64-reg) + (move y x)) + (signed-reg + (inst signx y x)) + (immediate + (inst li64 y (tn-value x))))) + ((signed64-stack unsigned64-stack) + (store64 x fp (tn-offset y)))))) + +(define-move-vop move-64bit-word-argument :move-argument + (descriptor-reg signed64-reg unsigned64-reg) (signed64-reg unsigned64-reg)) + +(define-move-vop move-argument :move-argument + (signed64-reg unsigned64-reg) (descriptor-reg)) + +) diff --git a/src/compiler/sparcv9/nlx.lisp b/src/compiler/sparcv9/nlx.lisp new file mode 100644 index 0000000000000000000000000000000000000000..d8a5b8b94eeb5f62f5a52487d2cdd58bd5979dc1 --- /dev/null +++ b/src/compiler/sparcv9/nlx.lisp @@ -0,0 +1,303 @@ +;;; -*- 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/compiler/sparc/nlx.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; +;;; This file contains the definitions of VOPs used for non-local exit +;;; (throw, lexical exit, etc.) +;;; +;;; Written by Rob MacLachlan +;;; +(in-package "SPARC") + +;;; MAKE-NLX-SP-TN -- Interface +;;; +;;; Make an environment-live stack TN for saving the SP for NLX entry. +;;; +(def-vm-support-routine make-nlx-sp-tn (env) + (environment-live-tn + (make-representation-tn *fixnum-primitive-type* immediate-arg-scn) + env)) + +;;; Make-NLX-Entry-Argument-Start-Location -- Interface +;;; +;;; Make a TN for the argument count passing location for a +;;; non-local entry. +;;; +(def-vm-support-routine make-nlx-entry-argument-start-location () + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)) + + +;;; Save and restore dynamic environment. +;;; +;;; These VOPs are used in the reentered function to restore the appropriate +;;; dynamic environment. Currently we only save the Current-Catch and binding +;;; stack pointer. We don't need to save/restore the current unwind-protect, +;;; since unwind-protects are implicitly processed during unwinding. If there +;;; were any additional stacks, then this would be the place to restore the top +;;; pointers. + + +;;; Make-Dynamic-State-TNs -- Interface +;;; +;;; Return a list of TNs that can be used to snapshot the dynamic state for +;;; use with the Save/Restore-Dynamic-Environment VOPs. +;;; +(def-vm-support-routine make-dynamic-state-tns () + (make-n-tns 4 *any-primitive-type*)) + +(define-vop (save-dynamic-state) + (:results (catch :scs (descriptor-reg)) + (nfp :scs (descriptor-reg)) + (nsp :scs (descriptor-reg)) + (eval :scs (descriptor-reg))) + (:vop-var vop) + (:generator 13 + (load-symbol-value catch lisp::*current-catch-block*) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (move nfp cur-nfp))) + (move nsp nsp-tn) + (load-symbol-value eval lisp::*eval-stack-top*))) + +(define-vop (restore-dynamic-state) + (:args (catch :scs (descriptor-reg)) + (nfp :scs (descriptor-reg)) + (nsp :scs (descriptor-reg)) + (eval :scs (descriptor-reg))) + (:vop-var vop) + (:generator 10 + (store-symbol-value catch lisp::*current-catch-block*) + (store-symbol-value eval lisp::*eval-stack-top*) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (move cur-nfp nfp))) + (move nsp-tn nsp))) + +(define-vop (current-stack-pointer) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + (move res csp-tn))) + +(define-vop (current-binding-pointer) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + (move res bsp-tn))) + + + +;;;; Unwind block hackery: + +;;; Compute the address of the catch block from its TN, then store into the +;;; block the current Fp, Env, Unwind-Protect, and the entry PC. +;;; +(define-vop (make-unwind-block) + (:args (tn)) + (:info entry-label) + (:results (block :scs (any-reg))) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:generator 22 + (let ((byte-offset (* (tn-offset tn) vm:word-bytes))) + (if (typep byte-offset '(signed-byte 13)) + (inst add block cfp-tn byte-offset) + (progn + (inst li ndescr byte-offset) + (inst add block cfp-tn ndescr)))) + (load-symbol-value temp lisp::*current-unwind-protect-block*) + (storew temp block vm:unwind-block-current-uwp-slot) + (storew cfp-tn block vm:unwind-block-current-cont-slot) + (storew code-tn block vm:unwind-block-current-code-slot) + (inst compute-lra-from-code temp code-tn entry-label ndescr) + (storew temp block vm:catch-block-entry-pc-slot))) + + +;;; Like Make-Unwind-Block, except that we also store in the specified tag, and +;;; link the block into the Current-Catch list. +;;; +(define-vop (make-catch-block) + (:args (tn) + (tag :scs (descriptor-reg any-reg))) + (:info entry-label) + (:results (block :scs (any-reg))) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:generator 44 + (let ((byte-offset (* (tn-offset tn) vm:word-bytes))) + (if (typep byte-offset '(signed-byte 13)) + (inst add result cfp-tn byte-offset) + (progn + (inst li ndescr byte-offset) + (inst add result cfp-tn ndescr)))) + (load-symbol-value temp lisp::*current-unwind-protect-block*) + (storew temp result vm:catch-block-current-uwp-slot) + (storew cfp-tn result vm:catch-block-current-cont-slot) + (storew code-tn result vm:catch-block-current-code-slot) + (inst compute-lra-from-code temp code-tn entry-label ndescr) + (storew temp result vm:catch-block-entry-pc-slot) + + (storew tag result vm:catch-block-tag-slot) + (load-symbol-value temp lisp::*current-catch-block*) + (storew temp result vm:catch-block-previous-catch-slot) + (store-symbol-value result lisp::*current-catch-block*) + + (move block result))) + + +;;; Just set the current unwind-protect to TN's address. This instantiates an +;;; unwind block as an unwind-protect. +;;; +(define-vop (set-unwind-protect) + (:args (tn)) + (:temporary (:scs (descriptor-reg)) new-uwp) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:generator 7 + (let ((byte-offset (* (tn-offset tn) vm:word-bytes))) + (if (typep byte-offset '(signed-byte 13)) + (inst add new-uwp cfp-tn (* (tn-offset tn) vm:word-bytes)) + (progn + (inst li ndescr byte-offset) + (inst add new-uwp cfp-tn ndescr)))) + (store-symbol-value new-uwp lisp::*current-unwind-protect-block*))) + + +(define-vop (unlink-catch-block) + (:temporary (:scs (any-reg)) block) + (:policy :fast-safe) + (:translate %catch-breakup) + (:generator 17 + (load-symbol-value block lisp::*current-catch-block*) + (loadw block block vm:catch-block-previous-catch-slot) + (store-symbol-value block lisp::*current-catch-block*))) + +(define-vop (unlink-unwind-protect) + (:temporary (:scs (any-reg)) block) + (:policy :fast-safe) + (:translate %unwind-protect-breakup) + (:generator 17 + (load-symbol-value block lisp::*current-unwind-protect-block*) + (loadw block block vm:unwind-block-current-uwp-slot) + (store-symbol-value block lisp::*current-unwind-protect-block*))) + + +;;;; NLX entry VOPs: + + +(define-vop (nlx-entry) + (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops + ; would be inserted before the LRA. + (start) + (count)) + (:results (values :more t)) + (:temporary (:scs (descriptor-reg)) move-temp) + (:info label nvals) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-return-pc label) + (note-this-location vop :non-local-entry) + (cond ((zerop nvals)) + ((= nvals 1) + (let ((no-values (gen-label))) + (inst cmp count) + (inst b :eq no-values) + (move (tn-ref-tn values) null-tn) + (loadw (tn-ref-tn values) start) + (emit-label no-values))) + (t + (collect ((defaults)) + (inst subcc count (fixnumize 1)) + (do ((i 0 (1+ i)) + (tn-ref values (tn-ref-across tn-ref))) + ((null tn-ref)) + (let ((default-lab (gen-label)) + (tn (tn-ref-tn tn-ref))) + (defaults (cons default-lab tn)) + + (inst b :lt default-lab) + (inst subcc count (fixnumize 1)) + (sc-case tn + ((descriptor-reg any-reg) + (loadw tn start i)) + (control-stack + (loadw move-temp start i) + (store-stack-tn tn move-temp))))) + + (let ((defaulting-done (gen-label))) + + (emit-label defaulting-done) + + (assemble (*elsewhere*) + (dolist (def (defaults)) + (emit-label (car def)) + (let ((tn (cdr def))) + (sc-case tn + ((descriptor-reg any-reg) + (move tn null-tn)) + (control-stack + (store-stack-tn tn null-tn))))) + (inst b defaulting-done) + (inst nop)))))) + (load-stack-tn csp-tn sp))) + + +(define-vop (nlx-entry-multiple) + (:args (top :target result) (src) (count)) + ;; Again, no SC restrictions for the args, 'cause the loading would + ;; happen before the entry label. + (:info label) + (:temporary (:scs (any-reg)) dst) + (:temporary (:scs (descriptor-reg)) temp) + (:results (result :scs (any-reg) :from (:argument 0)) + (num :scs (any-reg) :from (:argument 0))) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-return-pc label) + (note-this-location vop :non-local-entry) + (let ((loop (gen-label)) + (done (gen-label))) + + ;; Setup results, and test for the zero value case. + (load-stack-tn result top) + (inst cmp count) + (inst b :eq done) + (inst li num 0) + + ;; Compute dst as one slot down from result, because we inc the index + ;; before we use it. + (inst sub dst result 4) + + ;; Copy stuff down the stack. + (emit-label loop) + (inst ldn temp src num) + (inst add num (fixnumize 1)) + (inst cmp num count) + (inst b :ne loop) + (inst stn temp dst num) + + ;; Reset the CSP. + (emit-label done) + (inst add csp-tn result num)))) + + +;;; This VOP is just to force the TNs used in the cleanup onto the stack. +;;; +(define-vop (uwp-entry) + (:info label) + (:save-p :force-to-stack) + (:results (block) (start) (count)) + (:ignore block start count) + (:vop-var vop) + (:generator 0 + (emit-return-pc label) + (note-this-location vop :non-local-entry))) + diff --git a/src/compiler/sparcv9/parms.lisp b/src/compiler/sparcv9/parms.lisp new file mode 100644 index 0000000000000000000000000000000000000000..ec151f4197a8741d7634a44fa09b76c38d116a4b --- /dev/null +++ b/src/compiler/sparcv9/parms.lisp @@ -0,0 +1,425 @@ +;;; -*- 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/compiler/sparc/parms.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains some parameterizations of various VM +;;; attributes for the SPARC. This file is separate from other stuff so +;;; that it can be compiled and loaded earlier. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted to MIPS by William Lott. +;;; + +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") +(use-package "C") + + +;;;; Compiler constants. + +(eval-when (compile eval load) + +#+svr4 +(adjoin :svr4 (backend-features *target-backend*)) +#+svr4 +(adjoin :solaris (backend-features *target-backend*)) +(setf (backend-name *target-backend*) "SPARC") +#+svr4 +(setf (backend-version *target-backend*) + #-sparc-v9 "SPARCstation/Solaris 2.x" + #+sparc-v9 "UltraSPARC/Solaris") +#-svr4 +(setf (backend-version *target-backend*) "SPARCstation/Sun 4") +(setf (backend-fasl-file-type *target-backend*) "sparcf") +(setf (backend-fasl-file-implementation *target-backend*) + sparc-fasl-file-implementation) +(setf (backend-fasl-file-version *target-backend*) byte-fasl-file-version) +(setf (backend-register-save-penalty *target-backend*) 3) +(setf (backend-byte-order *target-backend*) :big-endian) +(setf (backend-page-size *target-backend*) + #+mach 4096 #+sunos 8192) + +(setf (c::backend-foreign-linkage-space-start *target-backend*) + ;; This better match the value in sparc-validate.h! + #x0f800000 + (c::backend-foreign-linkage-entry-size *target-backend*) + ;; This better agree with what sparc-arch.c thinks it is! Right now, + ;; it's 4 instructions, so 16 bytes. + 16) +); eval-when + +(pushnew :new-assembler *features*) + + +;;;; Machine Architecture parameters: + +(eval-when (:compile-toplevel :load-toplevel :execute) +(export '(word-bits byte-bits char-bits word-shift word-bytes char-bytes + fixnum-tag-bits fixnum-tag-mask positive-fixnum-bits + + float-sign-shift + + single-float-bytes + single-float-bias single-float-exponent-byte + single-float-significand-byte single-float-normal-exponent-min + single-float-normal-exponent-max single-float-hidden-bit + single-float-trapping-nan-bit single-float-digits + + double-float-bytes + double-float-bias double-float-exponent-byte + double-float-significand-byte double-float-normal-exponent-min + double-float-normal-exponent-max double-float-hidden-bit + double-float-trapping-nan-bit double-float-digits + + long-float-bias long-float-exponent-byte + long-float-significand-byte long-float-normal-exponent-min + long-float-normal-exponent-max long-float-hidden-bit + long-float-trapping-nan-bit long-float-digits + + float-underflow-trap-bit float-overflow-trap-bit + float-imprecise-trap-bit float-invalid-trap-bit + float-divide-by-zero-trap-bit)) + +#+double-double +(export '(double-double-float-digits)) +) ; eval-when + + +(eval-when (compile load eval) + +(defconstant word-bits 32 + "Number of bits per word where a word holds one lisp descriptor.") + +(defconstant byte-bits 8 + "Number of bits per byte where a byte is the smallest addressable object.") + +(defconstant char-bits #-unicode 8 #+unicode 16 + "Number of bits needed to represent a character") + +(defconstant char-bytes (truncate char-bits byte-bits) + "Number of bytes needed to represent a character") + +(defconstant word-shift (1- (integer-length (/ word-bits byte-bits))) + "Number of bits to shift between word addresses and byte addresses.") + +(defconstant word-bytes (/ word-bits byte-bits) + "Number of bytes in a word.") + +(defconstant lowtag-bits 3 + "Number of bits at the low end of a pointer used for type information.") + +(defconstant lowtag-mask (1- (ash 1 lowtag-bits)) + "Mask to extract the low tag bits from a pointer.") + +(defconstant lowtag-limit (ash 1 lowtag-bits) + "Exclusive upper bound on the value of the low tag bits from a + pointer.") + +(defconstant fixnum-tag-bits (1- lowtag-bits) + "Number of tag bits used for a fixnum") + +(defconstant fixnum-tag-mask (1- (ash 1 fixnum-tag-bits)) + "Mask to get the fixnum tag") + +(defconstant positive-fixnum-bits (- word-bits fixnum-tag-bits 1) + "Maximum number of bits in a positive fixnum") + +(defconstant float-sign-shift 31) + +(defconstant single-float-bytes 4) ; Bytes to hold a single-float +(defconstant single-float-bias 126) +(defconstant single-float-exponent-byte (byte 8 23)) +(defconstant single-float-significand-byte (byte 23 0)) +(defconstant single-float-normal-exponent-min 1) +(defconstant single-float-normal-exponent-max 254) +(defconstant single-float-hidden-bit (ash 1 23)) +(defconstant single-float-trapping-nan-bit (ash 1 22)) + +(defconstant double-float-bytes 8) ; Bytes to hold a double-float +(defconstant double-float-bias 1022) +(defconstant double-float-exponent-byte (byte 11 20)) +(defconstant double-float-significand-byte (byte 20 0)) +(defconstant double-float-normal-exponent-min 1) +(defconstant double-float-normal-exponent-max #x7FE) +(defconstant double-float-hidden-bit (ash 1 20)) +(defconstant double-float-trapping-nan-bit (ash 1 19)) + +;;; X These values are for the x86 80 bit format and are no doubt +;;; incorrect for the sparc. +(defconstant long-float-bias 16382) +(defconstant long-float-exponent-byte (byte 15 0)) +(defconstant long-float-significand-byte (byte 31 0)) +(defconstant long-float-normal-exponent-min 1) +(defconstant long-float-normal-exponent-max #x7FFE) +(defconstant long-float-hidden-bit (ash 1 31)) +(defconstant long-float-trapping-nan-bit (ash 1 30)) + +(defconstant single-float-digits + (+ (byte-size single-float-significand-byte) 1)) + +(defconstant double-float-digits + (+ (byte-size double-float-significand-byte) word-bits 1)) + +(defconstant long-float-digits + (+ (byte-size long-float-significand-byte) word-bits 1)) + +#+double-double +(defconstant double-double-float-digits + (* 2 double-float-digits)) + +(defconstant float-inexact-trap-bit (ash 1 0)) +(defconstant float-divide-by-zero-trap-bit (ash 1 1)) +(defconstant float-underflow-trap-bit (ash 1 2)) +(defconstant float-overflow-trap-bit (ash 1 3)) +(defconstant float-invalid-trap-bit (ash 1 4)) + +(defconstant float-round-to-nearest 0) +(defconstant float-round-to-zero 1) +(defconstant float-round-to-positive 2) +(defconstant float-round-to-negative 3) + +(defconstant float-rounding-mode (byte 2 30)) ; RD +(defconstant float-sticky-bits (byte 5 5)) ; aexc +(defconstant float-traps-byte (byte 5 23)) ; TEM +(defconstant float-exceptions-byte (byte 5 0)) ; cexc + +;;; According to the SPARC doc (as opposed to FPU doc), the fast mode +;;; bit (EFM) is "reserved", and should always be zero. However, for +;;; sparc-V8 and sparc-V9, it appears to work, causing denormals to +;;; be truncated to 0 silently. +(defconstant float-fast-bit (ash 1 22)) + +); eval-when + +;;; NUMBER-STACK-DISPLACEMENT +;;; +;;; The number of bytes reserved above the number stack pointer. These +;;; slots are required by architecture for a place to spill register windows. +;;; +(defconstant number-stack-displacement + (* 16 vm:word-bytes)) + + +;;;; Description of the target address space. + +(eval-when (:compile-toplevel :load-toplevel :execute) +(export '(target-read-only-space-start + target-static-space-start + target-dynamic-space-start + target-foreign-linkage-space-start + target-foreign-linkage-entry-size)) +) + +;;; Where to put the different spaces. Must match the C code! +;;; +(defconstant target-read-only-space-start #x10000000) +(defconstant target-static-space-start #x28000000) +(defconstant target-dynamic-space-start #x40000000) + +(defconstant target-foreign-linkage-space-start + (c:backend-foreign-linkage-space-start *target-backend*)) +(defconstant target-foreign-linkage-entry-size + (c:backend-foreign-linkage-entry-size *target-backend*)) + + +;;;; Other random constants. + +(eval-when (:compile-toplevel :load-toplevel :execute) +(export '(halt-trap pending-interrupt-trap error-trap cerror-trap + breakpoint-trap function-end-breakpoint-trap + after-breakpoint-trap allocation-trap + pseudo-atomic-trap + object-not-list-trap object-not-instance-trap + trace-table-normal trace-table-call-site + trace-table-function-prologue trace-table-function-epilogue)) + +#+heap-overflow-check +(export '(dynamic-space-overflow-error-trap + dynamic-space-overflow-warning-trap)) +) + +(defenum (:suffix -trap :start 8) + halt + pending-interrupt + error + cerror + breakpoint + function-end-breakpoint + after-breakpoint + #+heap-overflow-check + dynamic-space-overflow-warning + #+heap-overflow-check + dynamic-space-overflow-error + ) + +;; Make sure this starts AFTER the last element of the above enum! +(defenum (:prefix object-not- :suffix -trap :start 16) + list + instance) + +(defenum (:prefix trace-table-) + normal + call-site + function-prologue + function-epilogue) + + +;;;; Static symbols. + +(eval-when (:compile-toplevel :load-toplevel :execute) +(export '(static-symbols static-functions)) +) + +;;; These symbols are loaded into static space directly after NIL so +;;; that the system can compute their address by adding a constant +;;; amount to NIL. +;;; +;;; The fdefn objects for the static functions are loaded into static +;;; space directly after the static symbols. That way, the raw-addr +;;; can be loaded directly out of them by indirecting relative to NIL. +;;; +(defparameter static-symbols + '(t + + ;; The C startup code must fill these in. + lisp::lisp-environment-list + lisp::lisp-command-line-list + ext::*batch-mode* + lisp::*initial-fdefn-objects* + + ;; Functions that the C code needs to call + lisp::%initial-function + lisp::maybe-gc + kernel::internal-error + #+stack-checking kernel::yellow-zone-hit + #+stack-checking kernel::red-zone-hit + #+heap-overflow-check kernel::dynamic-space-overflow-warning-hit + #+heap-overflow-check kernel::dynamic-space-overflow-error-hit + di::handle-breakpoint + lisp::fdefinition-object + + ;; Free Pointers. + lisp::*read-only-space-free-pointer* + lisp::*static-space-free-pointer* + lisp::*initial-dynamic-space-free-pointer* + + ;; Things needed for non-local-exit. + lisp::*current-catch-block* + lisp::*current-unwind-protect-block* + *eval-stack-top* + + ;; Interrupt Handling + lisp::*free-interrupt-context-index* + unix::*interrupts-enabled* + unix::*interrupt-pending* + + ;; Foreign linkage stuff + #+linkage-table + lisp::*linkage-table-data* + + ;; + lisp::*cmucl-lib* + lisp::*cmucl-core-path* + + ;; Gencgc + ;; + ;; Sparc doesn't use current-region-free-pointer, but we leave it + ;; here anyway. + #+gencgc + *current-region-free-pointer* + ;; current-region-end-addr is a 32-bit physical address, but when + ;; printed from Lisp, it's a fixnum, so it's too small by a factor + ;; of 4. Remember to multiply by 4 to get the actual region end + ;; address. + #+gencgc + *current-region-end-addr* + #+gencgc + *scavenge-read-only-space* + + ;; Types of weak hash tables + :key + :value + :key-and-value + :key-or-value + + ;; FP constants + *fp-constant-0d0* + *fp-constant-0f0* + + lisp::*unidata-path* + + ;; Some spare static symbols. Useful for adding another static + ;; symbol without having to do a cross-compile. Just rename one + ;; of these to the desired name. + spare-9 + spare-8 + spare-7 + spare-6 + spare-5 + spare-4 + spare-3 + spare-2 + spare-1 + spare-0 + )) + +(defparameter static-functions + '(length + two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= + two-arg-<= two-arg->= two-arg-/= eql %negate + two-arg-and two-arg-ior two-arg-xor + two-arg-gcd two-arg-lcm + )) + + + +;;;; Assembler parameters: + +;;; The number of bits per element in the assemblers code vector. +;;; +(defparameter *assembly-unit-length* 8) + + +(eval-when (:compile-toplevel :load-toplevel :execute) +(export '(pseudo-atomic-trap allocation-trap + pseudo-atomic-value pseudo-atomic-interrupted-value)) +) +;;;; Pseudo-atomic trap number. +;;;; +;;;; This is the trap number to use when a pseudo-atomic section has +;;;; been interrupted. +;;;; +;;;; This should be any valid trap number. According to the Sparc +;;;; Compliance Definition 2.4.1, only traps 16-31 are allowed for +;;;; user applications. All others are reserved. It's ok if this +;;;; number matches any of the other trap enums above because those +;;;; are only used in an illtrap instruction, not the trap +;;;; instruction. This needs to be coordinated with the C code. +(defconstant pseudo-atomic-trap 16) + +;;;; Allocation trap number. +;;;; +;;;; This is the trap number to use when we need to allocate memory. +;;;; This must match the C runtime code +(defconstant allocation-trap 31) + +;;;; Pseudo-atomic flag +;;;; +;;;; This value is added to alloc-tn to indicate a pseudo-atomic +;;;; section. +(defconstant pseudo-atomic-value (ash 1 (1- vm::lowtag-bits))) + +;;;; Pseudo-atomic-interrupted-mask +;;;; +;;;; This is a mask used to check if a pseudo-atomic section was +;;;; interrupted. On sparc, this is indicated by least-significant +;;;; bit of alloc-tn being 1. +(defconstant pseudo-atomic-interrupted-value 1) diff --git a/src/compiler/sparcv9/pred.lisp b/src/compiler/sparcv9/pred.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b9daba0bb6f9d0f0a437698291ac5dbe70595131 --- /dev/null +++ b/src/compiler/sparcv9/pred.lisp @@ -0,0 +1,48 @@ +;;; -*- 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/compiler/sparc/pred.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; $Header: src/compiler/sparc/pred.lisp $ +;;; +;;; This file contains the VM definition of predicate VOPs for the SPARC. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted by William Lott. +;;; + +(in-package "SPARC") + + +;;;; The Branch VOP. + +;;; The unconditional branch, emitted when we can't drop through to the desired +;;; destination. Dest is the continuation we transfer control to. +;;; +(define-vop (branch) + (:info dest) + (:generator 5 + (inst b dest) + (inst nop))) + + +;;;; Conditional VOPs: + +(define-vop (if-eq) + (:args (x :scs (any-reg descriptor-reg zero null)) + (y :scs (any-reg descriptor-reg zero null))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:translate eq) + (:generator 3 + (inst cmp x y) + (inst b (if not-p :ne :eq) target) + (inst nop))) diff --git a/src/compiler/sparcv9/print.lisp b/src/compiler/sparcv9/print.lisp new file mode 100644 index 0000000000000000000000000000000000000000..c4e106ec67840463bd4b7bd0759e5fd349a719a8 --- /dev/null +++ b/src/compiler/sparcv9/print.lisp @@ -0,0 +1,43 @@ +;;; -*- 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/compiler/sparc/print.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; $Header: src/compiler/sparc/print.lisp $ +;;; +;;; This file contains VOPs for things like printing during %initial-function +;;; before the world is initialized. +;;; +;;; Written by William Lott. + +(in-package "SPARC") + + +(define-vop (print) + (:args (object :scs (descriptor-reg any-reg) :target nl0)) + (:results (result :scs (descriptor-reg))) + (:save-p t) + (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) nl0) + (:temporary (:sc any-reg :offset cfunc-offset) cfunc) + (:temporary (:sc interior-reg :offset lip-offset) lip) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:vop-var vop) + (:generator 100 + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (move nl0 object) + (inst li cfunc (make-fixup (extern-alien-name "debug_print") :foreign)) + (inst li temp (make-fixup (extern-alien-name "call_into_c") :foreign)) + (inst jal lip temp) + (inst nop) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)) + (move result nl0)))) diff --git a/src/compiler/sparcv9/sap.lisp b/src/compiler/sparcv9/sap.lisp new file mode 100644 index 0000000000000000000000000000000000000000..4c403017e60a802728fb3ced6e3584c565e0cc32 --- /dev/null +++ b/src/compiler/sparcv9/sap.lisp @@ -0,0 +1,320 @@ +;;; -*- 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/compiler/sparc/sap.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the SPARC VM definition of SAP operations. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") + + +;;;; Moves and coercions: + +;;; Move a tagged SAP to an untagged representation. +;;; +(define-vop (move-to-sap) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (sap-reg))) + (:note _N"pointer to SAP coercion") + (:generator 1 + (loadw y x sap-pointer-slot other-pointer-type))) + +;;; +(define-move-vop move-to-sap :move + (descriptor-reg) (sap-reg)) + + +;;; Move an untagged SAP to a tagged representation. +;;; +(define-vop (move-from-sap) + (:args (sap :scs (sap-reg) :to :save)) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:results (res :scs (descriptor-reg))) + (:note _N"SAP to pointer coercion") + (:generator 20 + (with-fixed-allocation (res ndescr sap-type sap-size) + (storew sap res sap-pointer-slot other-pointer-type)))) +;;; +(define-move-vop move-from-sap :move + (sap-reg) (descriptor-reg)) + + +;;; Move untagged sap values. +;;; +(define-vop (sap-move) + (:args (x :target y + :scs (sap-reg) + :load-if (not (location= x y)))) + (:results (y :scs (sap-reg) + :load-if (not (location= x y)))) + (:note _N"SAP move") + (:effects) + (:affected) + (:generator 0 + (move y x))) +;;; +(define-move-vop sap-move :move + (sap-reg) (sap-reg)) + + +;;; Move untagged sap arguments/return-values. +;;; +(define-vop (move-sap-argument) + (:args (x :target y + :scs (sap-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:note _N"SAP argument move") + (:generator 0 + (sc-case y + (sap-reg + (move y x)) + (sap-stack + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-sap-argument :move-argument + (descriptor-reg sap-reg) (sap-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a +;;; descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (sap-reg) (descriptor-reg)) + + + +;;;; SAP-INT and INT-SAP + +(define-vop (sap-int) + (:args (sap :scs (sap-reg) :target int)) + (:arg-types system-area-pointer) + (:results (int :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate sap-int) + (:policy :fast-safe) + (:generator 1 + (move int sap))) + +(define-vop (int-sap) + (:args (int :scs (unsigned-reg) :target sap)) + (:arg-types unsigned-num) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate int-sap) + (:policy :fast-safe) + (:generator 1 + (move sap int))) + + + +;;;; POINTER+ and POINTER- + +(define-vop (pointer+) + (:translate sap+) + (:args (ptr :scs (sap-reg)) + (offset :scs (signed-reg))) + (:arg-types system-area-pointer signed-num) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:policy :fast-safe) + (:generator 2 + (inst add res ptr offset))) + +(define-vop (pointer+-c) + (:translate sap+) + (:args (ptr :scs (sap-reg))) + (:info offset) + (:arg-types system-area-pointer (:constant (signed-byte 13))) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:policy :fast-safe) + (:generator 1 + (inst add res ptr offset))) + +(define-vop (pointer-) + (:translate sap-) + (:args (ptr1 :scs (sap-reg)) + (ptr2 :scs (sap-reg))) + (:arg-types system-area-pointer system-area-pointer) + (:policy :fast-safe) + (:results (res :scs (signed-reg))) + (:result-types signed-num) + (:generator 1 + (inst sub res ptr1 ptr2))) + + + +;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET + +(eval-when (compile eval) + +(defmacro def-system-ref-and-set + (ref-name set-name sc type size &optional signed) + (let ((ref-name-c (symbolicate ref-name "-C")) + (set-name-c (symbolicate set-name "-C"))) + `(progn + (define-vop (,ref-name) + (:translate ,ref-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (signed-reg))) + (:arg-types system-area-pointer signed-num) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 5 + ,@(if (eql size :long-float) + '((load-long-reg result sap offset t)) + `((inst ,(ecase size + (:byte (if signed 'ldsb 'ldub)) + (:short (if signed 'ldsh 'lduh)) + (:long 'ld) + (:single 'ldf) + (:double 'lddf)) + result sap offset))))) + (define-vop (,ref-name-c) + (:translate ,ref-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 13))) + (:info offset) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 4 + ,@(if (eql size :long-float) + '((load-long-reg result sap offset t)) + `((inst ,(ecase size + (:byte (if signed 'ldsb 'ldub)) + (:short (if signed 'ldsh 'lduh)) + (:long 'ld) + (:single 'ldf) + (:double 'lddf)) + result sap offset))))) + (define-vop (,set-name) + (:translate ,set-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (signed-reg)) + (value :scs (,sc) :target result)) + (:arg-types system-area-pointer signed-num ,type) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 5 + ,@(if (eql size :long-float) + '((store-long-reg value sap offset t)) + `((inst ,(ecase size + (:byte 'stb) + (:short 'sth) + (:long 'st) + (:single 'stf) + (:double 'stdf)) + value sap offset))) + (unless (location= result value) + ,@(case size + (:single + '((inst fmovs result value))) + (:double + '((move-double-reg result value))) + (:long-float + '((move-long-reg result value))) + (t + '((inst move result value))))))) + (define-vop (,set-name-c) + (:translate ,set-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (value :scs (,sc) :target result)) + (:arg-types system-area-pointer (:constant (signed-byte 13)) ,type) + (:info offset) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 4 + ,@(if (eql size :long-float) + '((store-long-reg value sap offset t)) + `((inst ,(ecase size + (:byte 'stb) + (:short 'sth) + (:long 'st) + (:single 'stf) + (:double 'stdf)) + value sap offset))) + (unless (location= result value) + ,@(case size + (:single + '((inst fmovs result value))) + (:double + '((move-double-reg result value))) + (:long-float + '((move-long-reg result value))) + (t + '((inst move result value)))))))))) + +); eval-when (compile eval) + +(def-system-ref-and-set sap-ref-8 %set-sap-ref-8 + unsigned-reg positive-fixnum :byte nil) +(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8 + signed-reg tagged-num :byte t) +(def-system-ref-and-set sap-ref-16 %set-sap-ref-16 + unsigned-reg positive-fixnum :short nil) +(def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16 + signed-reg tagged-num :short t) +(def-system-ref-and-set sap-ref-32 %set-sap-ref-32 + unsigned-reg unsigned-num :long nil) +(def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32 + signed-reg signed-num :long t) +(def-system-ref-and-set sap-ref-sap %set-sap-ref-sap + sap-reg system-area-pointer :long) +(def-system-ref-and-set sap-ref-single %set-sap-ref-single + single-reg single-float :single) +(def-system-ref-and-set sap-ref-double %set-sap-ref-double + double-reg double-float :double) +#+long-float +(def-system-ref-and-set sap-ref-long %set-sap-ref-long + long-reg long-float :long-float) + + + +;;; Noise to convert normal lisp data objects into SAPs. + +(define-vop (vector-sap) + (:translate vector-sap) + (:policy :fast-safe) + (:args (vector :scs (descriptor-reg))) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (inst add sap vector + (- (* vector-data-offset word-bytes) other-pointer-type)))) + + + +;;; Transforms for 64-bit SAP accessors. + +(deftransform sap-ref-64 ((sap offset) (* *)) + '(logior (ash (sap-ref-32 sap offset) 32) + (sap-ref-32 sap (+ offset 4)))) + +(deftransform signed-sap-ref-64 ((sap offset) (* *)) + '(logior (ash (signed-sap-ref-32 sap offset) 32) + (sap-ref-32 sap (+ 4 offset)))) + +(deftransform %set-sap-ref-64 ((sap offset value) (* * *)) + '(progn + (%set-sap-ref-32 sap offset (ash value -32)) + (%set-sap-ref-32 sap (+ offset 4) (logand value #xffffffff)))) + +(deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *)) + '(progn + (%set-signed-sap-ref-32 sap offset (ash value -32)) + (%set-sap-ref-32 sap (+ 4 offset) (logand value #xffffffff)))) diff --git a/src/compiler/sparcv9/static-fn.lisp b/src/compiler/sparcv9/static-fn.lisp new file mode 100644 index 0000000000000000000000000000000000000000..82cd106fa603803d7901e23a7f0fb619803efd8a --- /dev/null +++ b/src/compiler/sparcv9/static-fn.lisp @@ -0,0 +1,153 @@ +;;; -*- 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/compiler/sparc/static-fn.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; $Header: src/compiler/sparc/static-fn.lisp $ +;;; +;;; This file contains the VOPs and macro magic necessary to call static +;;; functions. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") + + + +(define-vop (static-function-template) + (:save-p t) + (:policy :safe) + (:variant-vars symbol) + (:vop-var vop) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:scs (descriptor-reg)) move-temp) + (:temporary (:sc descriptor-reg :offset lra-offset) lra) + (:temporary (:scs (descriptor-reg)) func) + (:temporary (:sc any-reg :offset nargs-offset) nargs) + (:temporary (:sc any-reg :offset ocfp-offset) old-fp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)) + + +(eval-when (compile load eval) + + +(defun static-function-template-name (num-args num-results) + (intern (format nil "~:@(~R-arg-~R-result-static-function~)" + num-args num-results))) + + +(defun moves (dst src) + (collect ((moves)) + (do ((dst dst (cdr dst)) + (src src (cdr src))) + ((or (null dst) (null src))) + (moves `(move ,(car dst) ,(car src)))) + (moves))) + +(defun static-function-template-vop (num-args num-results) + (assert (and (<= num-args register-arg-count) + (<= num-results register-arg-count)) + (num-args num-results) + (intl:gettext "Either too many args (~D) or too many results (~D). Max = ~D") + num-args num-results register-arg-count) + (let ((num-temps (max num-args num-results))) + (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results)) + (dotimes (i num-results) + (let ((result-name (intern (format nil "RESULT-~D" i)))) + (result-names result-name) + (results `(,result-name :scs (any-reg descriptor-reg))))) + (dotimes (i num-temps) + (let ((temp-name (intern (format nil "TEMP-~D" i)))) + (temp-names temp-name) + (temps `(:temporary (:sc descriptor-reg + :offset ,(nth i register-arg-offsets) + ,@(when (< i num-args) + `(:from (:argument ,i))) + ,@(when (< i num-results) + `(:to (:result ,i) + :target ,(nth i (result-names))))) + ,temp-name)))) + (dotimes (i num-args) + (let ((arg-name (intern (format nil "ARG-~D" i)))) + (arg-names arg-name) + (args `(,arg-name + :scs (any-reg descriptor-reg) + :target ,(nth i (temp-names)))))) + `(define-vop (,(static-function-template-name num-args num-results) + static-function-template) + (:args ,@(args)) + ,@(temps) + (:results ,@(results)) + (:generator ,(+ 50 num-args num-results) + (let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + ,@(moves (temp-names) (arg-names)) + (inst ldn func null-tn (static-function-offset symbol)) + (inst li nargs (fixnumize ,num-args)) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (inst move old-fp cfp-tn) + (inst move cfp-tn csp-tn) + (inst compute-lra-from-code lra code-tn lra-label temp) + (note-this-location vop :call-site) + (inst j func (- (ash function-code-offset word-shift) + function-pointer-type)) + (inst move code-tn func) + (emit-return-pc lra-label) + ,(collect ((bindings) (links)) + (do ((temp (temp-names) (cdr temp)) + (name 'values (gensym)) + (prev nil name) + (i 0 (1+ i))) + ((= i num-results)) + (bindings `(,name + (make-tn-ref ,(car temp) nil))) + (when prev + (links `(setf (tn-ref-across ,prev) ,name)))) + `(let ,(bindings) + ,@(links) + (default-unknown-values vop + ,(if (zerop num-results) nil 'values) + ,num-results move-temp temp lra-label))) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)) + ,@(moves (result-names) (temp-names)))))))) + + +) ; eval-when (compile load eval) + + +(macrolet ((frob (num-args num-res) + (static-function-template-vop (eval num-args) (eval num-res)))) + (frob 0 1) + (frob 1 1) + (frob 2 1) + (frob 3 1) + (frob 4 1) + (frob 5 1)) + + +(defmacro define-static-function (name args &key (results '(x)) translate + policy cost arg-types result-types) + `(define-vop (,name + ,(static-function-template-name (length args) + (length results))) + (:variant ',name) + (:note ,(format nil "static-function ~@(~S~)" name)) + ,@(when translate + `((:translate ,translate))) + ,@(when policy + `((:policy ,policy))) + ,@(when cost + `((:generator-cost ,cost))) + ,@(when arg-types + `((:arg-types ,@arg-types))) + ,@(when result-types + `((:result-types ,@result-types))))) diff --git a/src/compiler/sparcv9/subprim.lisp b/src/compiler/sparcv9/subprim.lisp new file mode 100644 index 0000000000000000000000000000000000000000..89cbc66703f9ac8bb45a1d105c7fbc285c45ee29 --- /dev/null +++ b/src/compiler/sparcv9/subprim.lisp @@ -0,0 +1,60 @@ +;;; -*- 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/compiler/sparc/subprim.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; Linkage information for standard static functions, and random vops. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") + + + +;;;; Length + +(define-vop (length/list) + (:translate length) + (:args (object :scs (descriptor-reg) :target ptr)) + (:arg-types list) + (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result) + count) + (:results (result :scs (any-reg descriptor-reg))) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:generator 50 + (let ((done (gen-label)) + (loop (gen-label)) + (not-list (generate-cerror-code vop object-not-list-error object))) + (move ptr object) + (move count zero-tn) + + (emit-label loop) + + (inst cmp ptr null-tn) + (inst b :eq done) + (inst nop) + + (test-type ptr temp not-list t vm:list-pointer-type) + + (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type) + (inst add count count (fixnumize 1)) + (test-type ptr temp loop nil vm:list-pointer-type) + + (cerror-call vop done object-not-list-error ptr) + + (emit-label done) + (move result count)))) + + +(define-static-function length (object) :translate length) + diff --git a/src/compiler/sparcv9/system.lisp b/src/compiler/sparcv9/system.lisp new file mode 100644 index 0000000000000000000000000000000000000000..dba4b6d78387c092081bae84e0b8e09786662bfa --- /dev/null +++ b/src/compiler/sparcv9/system.lisp @@ -0,0 +1,304 @@ +;;; -*- 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/compiler/sparc/system.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; MIPS VM definitions of various system hacking operations. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Mips conversion by William Lott and Christopher Hoover. +;;; +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") + + + +;;;; Type frobbing VOPs + +(define-vop (get-lowtag) + (:translate get-lowtag) + (:policy :fast-safe) + (:args (object :scs (any-reg descriptor-reg))) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 1 + (inst and result object vm:lowtag-mask))) + +(define-vop (get-type) + (:translate get-type) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 1))) + (:results (result :scs (unsigned-reg) :from (:eval 0))) + (:result-types positive-fixnum) + (:generator 6 + ;; Grab the lowtag. + (inst andcc result object lowtag-mask) + ;; Check for various pointer types. + (inst cmp result list-pointer-type) + (inst b :eq done) + (inst cmp result other-pointer-type) + (inst b :eq other-pointer) + (inst cmp result function-pointer-type) + (inst b :eq function-pointer) + (inst cmp result instance-pointer-type) + (inst b :eq done) + ;; Okay, it is an immediate. If fixnum, we want zero. Otherwise, + ;; we want the low 8 bits. + (inst andcc zero-tn object vm:fixnum-tag-mask) + (inst b :eq done) + (inst li result 0) ; Watch out! LI in branch delay slot! + ;; It wasn't a fixnum, so get the low 8 bits. + (inst b done) + (inst and result object type-mask) + + FUNCTION-POINTER + (inst b done) + (load-type result object (- function-pointer-type)) + + OTHER-POINTER + (load-type result object (- other-pointer-type)) + + DONE)) + + +(define-vop (function-subtype) + (:translate function-subtype) + (:policy :fast-safe) + (:args (function :scs (descriptor-reg))) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (load-type result function (- vm:function-pointer-type)))) + +(define-vop (set-function-subtype) + (:translate (setf function-subtype)) + (:policy :fast-safe) + (:args (type :scs (unsigned-reg) :target result) + (function :scs (descriptor-reg))) + (:arg-types positive-fixnum *) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + ;; Sparc is big-endian, and the type bits are in the least + ;; significant byte of the word, which means the type bits are at + ;; the highest byte. + (inst stb type function (- (- vm:word-bytes 1) function-pointer-type)) + (move result type))) + +(define-vop (get-header-data) + (:translate get-header-data) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (loadw res x 0 vm:other-pointer-type) + (inst srln res res vm:type-bits))) + +(define-vop (get-closure-length) + (:translate get-closure-length) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (loadw res x 0 vm:function-pointer-type) + (inst srln res res vm:type-bits))) + +(define-vop (set-header-data) + (:translate set-header-data) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg) :target res) + (data :scs (any-reg immediate zero))) + (:arg-types * positive-fixnum) + (:results (res :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) t1 t2) + (:generator 6 + (loadw t1 x 0 vm:other-pointer-type) + (inst and t1 vm:type-mask) + (sc-case data + (any-reg + (inst slln t2 data (- vm:type-bits vm:fixnum-tag-bits)) + (inst or t1 t2)) + (immediate + (inst or t1 (ash (tn-value data) vm:type-bits))) + (zero)) + (storew t1 x 0 vm:other-pointer-type) + (move res x))) + + +(define-vop (make-fixnum) + (:args (ptr :scs (any-reg descriptor-reg))) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + ;; + ;; Some code (the hash table code) depends on this returning a + ;; positive number so make sure it does. + (inst slln res ptr vm:lowtag-bits) + (inst srln res res 1))) + +(define-vop (make-other-immediate-type) + (:args (val :scs (any-reg descriptor-reg)) + (type :scs (any-reg descriptor-reg immediate) + :target temp)) + (:results (res :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 2 + (sc-case type + (immediate + (inst slln temp val vm:type-bits) + (inst or res temp (tn-value type))) + (t + (inst sran temp type vm:fixnum-tag-bits) + (inst slln res val (- vm:type-bits vm:fixnum-tag-bits)) + (inst or res res temp))))) + + +;;;; Allocation + +(define-vop (dynamic-space-free-pointer) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate dynamic-space-free-pointer) + (:policy :fast-safe) + (:generator 1 + (move int alloc-tn))) + +(define-vop (binding-stack-pointer-sap) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate binding-stack-pointer-sap) + (:policy :fast-safe) + (:generator 1 + (move int bsp-tn))) + +(define-vop (control-stack-pointer-sap) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate control-stack-pointer-sap) + (:policy :fast-safe) + (:generator 1 + (move int csp-tn))) + + +;;;; Code object frobbing. + +(define-vop (code-instructions) + (:translate code-instructions) + (:policy :fast-safe) + (:args (code :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 10 + (loadw ndescr code 0 vm:other-pointer-type) + (inst srln ndescr vm:type-bits) + (inst slln ndescr vm:word-shift) + (inst sub ndescr vm:other-pointer-type) + (inst add sap code ndescr))) + +(define-vop (compute-function) + (:args (code :scs (descriptor-reg)) + (offset :scs (signed-reg unsigned-reg))) + (:arg-types * positive-fixnum) + (:results (func :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:generator 10 + (loadw ndescr code 0 vm:other-pointer-type) + (inst srln ndescr vm:type-bits) + (inst slln ndescr vm:word-shift) + (inst add ndescr offset) + (inst add ndescr (- vm:function-pointer-type vm:other-pointer-type)) + (inst add func code ndescr))) + + + +;;;; Other random VOPs. + + +(defknown unix::do-pending-interrupt () (values)) +(define-vop (unix::do-pending-interrupt) + (:policy :fast-safe) + (:translate unix::do-pending-interrupt) + (:generator 1 + (inst unimp pending-interrupt-trap))) + + +(define-vop (halt) + (:generator 1 + (inst unimp halt-trap))) + + + +;;;; Dynamic vop count collection support + +(define-vop (count-me) + (:args (count-vector :scs (descriptor-reg))) + (:info index) + (:temporary (:scs (non-descriptor-reg)) count) + (:generator 1 + (let ((offset + (- (* (+ index vector-data-offset) word-bytes) other-pointer-type))) + (assert (typep offset '(signed-byte 13))) + (inst ldn count count-vector offset) + (inst add count 1) + (inst stn count count-vector offset)))) + +;; The RDTICK instruction on Sparc V9s allows access to a 63-bit cycle +;; counter. + +(defknown read-cycle-counter () + (values (unsigned-byte 32) (unsigned-byte 32))) + +;; Note: This should probably really only be used sparc-v8plus because +;; the tick counter is returned in a 64-bit register. +(define-vop (read-cycle-counter) + (:translate read-cycle-counter) + (:guard (backend-featurep :sparc-v9)) + (:args) + (:policy :fast-safe) + (:results (lo :scs (unsigned-reg)) + (hi :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + ;; The temporary can be any of the 64-bit non-descriptor regs. It + ;; can't be any non-descriptor reg because they might not get saved + ;; on a task switch, since we're still a 32-bit app. Arbitrarily + ;; select nl5. + (:temporary (:sc unsigned-reg :offset nl5-offset) tick) + (:generator 3 + (inst rdtick tick) + ;; Get the hi and low parts of the counter into the results. + (inst srlx hi tick 32) + (inst clruw lo tick))) + +#+sparc-v9 +(defun read-cycle-counter () + _N"Read the instruction cycle counter available on UltraSparcs. The +64-bit counter is returned as two 32-bit unsigned integers. The low 32-bit +result is the first value." + (read-cycle-counter)) + +(defmacro with-cycle-counter (&body body) + "Returns the primary value of BODY as the primary value, and the + number of CPU cycles elapsed as secondary value." + (let ((hi0 (gensym)) + (hi1 (gensym)) + (lo0 (gensym)) + (lo1 (gensym))) + `(multiple-value-bind (,lo0 ,hi0) + (read-cycle-counter) + (values (locally ,@body) + (multiple-value-bind (,lo1 ,hi1) + (read-cycle-counter) + ;; Can't do anything about the notes about generic + ;; arithmetic, so silence the notes.. + (declare (optimize (inhibit-warnings 3))) + (+ (ash (- ,hi1 ,hi0) 32) + (- ,lo1 ,lo0))))))) diff --git a/src/compiler/sparcv9/type-vops.lisp b/src/compiler/sparcv9/type-vops.lisp new file mode 100644 index 0000000000000000000000000000000000000000..1be97e8fd571a2e187bba09fa0ac702a72f9b13b --- /dev/null +++ b/src/compiler/sparcv9/type-vops.lisp @@ -0,0 +1,529 @@ +;;; -*- 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/compiler/sparc/type-vops.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of type testing and checking VOPs +;;; for the SPARC. +;;; +;;; Written by William Lott. +;;; Signed-array support by Douglas Crosher 1997. +;;; Complex-float and long-float support by Douglas Crosher 1998. +;;; +(in-package "SPARC") + + +;;;; Simple type checking and testing: +;;; +;;; These types are represented by a single type code, so are easily +;;; open-coded as a mask and compare. + +(define-vop (check-type) + (:args (value :target result :scs (any-reg descriptor-reg))) + (:results (result :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:vop-var vop) + (:save-p :compute-only)) + +(define-vop (type-predicate) + (:args (value :scs (any-reg descriptor-reg))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:temporary (:scs (non-descriptor-reg)) temp)) + +(eval-when (compile eval) + +(defun cost-to-test-types (type-codes) + (+ (* 2 (length type-codes)) + (if (> (apply #'max type-codes) vm:lowtag-limit) 7 2))) + +(defmacro def-type-vops (pred-name check-name ptype error-code + &rest type-codes) + (let ((cost (cost-to-test-types (mapcar #'eval type-codes)))) + `(progn + ,@(when pred-name + `((define-vop (,pred-name type-predicate) + (:translate ,pred-name) + (:generator ,cost + (test-type value temp target not-p ,@type-codes))))) + ,@(when check-name + `((define-vop (,check-name check-type) + (:generator ,cost + (let ((err-lab + (generate-error-code vop ,error-code value))) + (test-type value temp err-lab t ,@type-codes) + (move result value)))))) + ,@(when ptype + `((primitive-type-vop ,check-name (:check) ,ptype)))))) + +); eval-when (compile eval) + +(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error + vm:even-fixnum-type vm:odd-fixnum-type) + +(def-type-vops functionp check-function function + object-not-function-error vm:function-pointer-type) + +(def-type-vops listp check-list list object-not-list-error + vm:list-pointer-type) +(def-type-vops %instancep check-instance instance object-not-instance-error + vm:instance-pointer-type) + +(def-type-vops bignump check-bignum bignum + object-not-bignum-error vm:bignum-type) + +(def-type-vops ratiop check-ratio ratio + object-not-ratio-error vm:ratio-type) + +(def-type-vops complexp check-complex complex object-not-complex-error + vm:complex-type vm:complex-single-float-type + vm:complex-double-float-type #+long-float vm:complex-long-float-type + #+double-double vm::complex-double-double-float-type) + +(def-type-vops complex-rational-p check-complex-rational nil + object-not-complex-rational-error vm:complex-type) + +(def-type-vops complex-float-p check-complex-float nil + object-not-complex-float-error + vm:complex-single-float-type vm:complex-double-float-type + #+long-float vm:complex-long-float-type + #+double-double vm::complex-double-double-float-type) + +(def-type-vops complex-single-float-p check-complex-single-float + complex-single-float object-not-complex-single-float-error + vm:complex-single-float-type) + +(def-type-vops complex-double-float-p check-complex-double-float + complex-double-float object-not-complex-double-float-error + vm:complex-double-float-type) + +#+long-float +(def-type-vops complex-long-float-p check-complex-long-float + complex-long-float object-not-complex-long-float-error + vm:complex-long-float-type) + +#+double-double +(def-type-vops complex-double-double-float-p check-complex-double-double-float + complex-double-double-float object-not-complex-double-double-float-error + vm::complex-double-double-float-type) + +(def-type-vops single-float-p check-single-float single-float + object-not-single-float-error vm:single-float-type) + +(def-type-vops double-float-p check-double-float double-float + object-not-double-float-error vm:double-float-type) + +#+long-float +(def-type-vops long-float-p check-long-float long-float + object-not-long-float-error vm:long-float-type) + +#+double-double +(def-type-vops double-double-float-p check-double-double-float + double-double-float object-not-double-double-float-error + vm:double-double-float-type) + +(def-type-vops simple-string-p check-simple-string simple-string + object-not-simple-string-error vm:simple-string-type) + +(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector + object-not-simple-bit-vector-error vm:simple-bit-vector-type) + +(def-type-vops simple-vector-p check-simple-vector simple-vector + object-not-simple-vector-error vm:simple-vector-type) + +(def-type-vops simple-array-unsigned-byte-2-p + check-simple-array-unsigned-byte-2 + simple-array-unsigned-byte-2 + object-not-simple-array-unsigned-byte-2-error + vm:simple-array-unsigned-byte-2-type) + +(def-type-vops simple-array-unsigned-byte-4-p + check-simple-array-unsigned-byte-4 + simple-array-unsigned-byte-4 + object-not-simple-array-unsigned-byte-4-error + vm:simple-array-unsigned-byte-4-type) + +(def-type-vops simple-array-unsigned-byte-8-p + check-simple-array-unsigned-byte-8 + simple-array-unsigned-byte-8 + object-not-simple-array-unsigned-byte-8-error + vm:simple-array-unsigned-byte-8-type) + +(def-type-vops simple-array-unsigned-byte-16-p + check-simple-array-unsigned-byte-16 + simple-array-unsigned-byte-16 + object-not-simple-array-unsigned-byte-16-error + vm:simple-array-unsigned-byte-16-type) + +(def-type-vops simple-array-unsigned-byte-32-p + check-simple-array-unsigned-byte-32 + simple-array-unsigned-byte-32 + object-not-simple-array-unsigned-byte-32-error + vm:simple-array-unsigned-byte-32-type) + +(def-type-vops simple-array-signed-byte-8-p + check-simple-array-signed-byte-8 + simple-array-signed-byte-8 + object-not-simple-array-signed-byte-8-error + simple-array-signed-byte-8-type) + +(def-type-vops simple-array-signed-byte-16-p + check-simple-array-signed-byte-16 + simple-array-signed-byte-16 + object-not-simple-array-signed-byte-16-error + simple-array-signed-byte-16-type) + +(def-type-vops simple-array-signed-byte-30-p + check-simple-array-signed-byte-30 + simple-array-signed-byte-30 + object-not-simple-array-signed-byte-30-error + simple-array-signed-byte-30-type) + +(def-type-vops simple-array-signed-byte-32-p + check-simple-array-signed-byte-32 + simple-array-signed-byte-32 + object-not-simple-array-signed-byte-32-error + simple-array-signed-byte-32-type) + +(def-type-vops simple-array-single-float-p check-simple-array-single-float + simple-array-single-float object-not-simple-array-single-float-error + vm:simple-array-single-float-type) + +(def-type-vops simple-array-double-float-p check-simple-array-double-float + simple-array-double-float object-not-simple-array-double-float-error + vm:simple-array-double-float-type) + +#+long-float +(def-type-vops simple-array-long-float-p check-simple-array-long-float + simple-array-long-float object-not-simple-array-long-float-error + vm:simple-array-long-float-type) + +#+double-double +(def-type-vops simple-array-double-double-float-p check-simple-array-double-double-float + simple-array-double-double-float object-not-simple-array-double-double-float-error + vm::simple-array-double-double-float-type) + +(def-type-vops simple-array-complex-single-float-p + check-simple-array-complex-single-float + simple-array-complex-single-float + object-not-simple-array-complex-single-float-error + vm:simple-array-complex-single-float-type) + +(def-type-vops simple-array-complex-double-float-p + check-simple-array-complex-double-float + simple-array-complex-double-float + object-not-simple-array-complex-double-float-error + vm:simple-array-complex-double-float-type) + +#+long-float +(def-type-vops simple-array-complex-long-float-p + check-simple-array-complex-long-float + simple-array-complex-long-float + object-not-simple-array-complex-long-float-error + vm:simple-array-complex-long-float-type) + +#+double-double +(def-type-vops simple-array-complex-double-double-float-p + check-simple-array-complex-double-double-float + simple-array-complex-double-double-float + object-not-simple-array-complex-double-double-float-error + vm::simple-array-complex-double-double-float-type) + +(def-type-vops base-char-p check-base-char base-char + object-not-base-char-error vm:base-char-type) + +(def-type-vops system-area-pointer-p check-system-area-pointer + system-area-pointer object-not-sap-error vm:sap-type) + +(def-type-vops weak-pointer-p check-weak-pointer weak-pointer + object-not-weak-pointer-error vm:weak-pointer-type) + +(def-type-vops scavenger-hook-p nil nil nil + #-gencgc 0 #+gencgc scavenger-hook-type) + +(def-type-vops code-component-p nil nil nil + vm:code-header-type) + +(def-type-vops lra-p nil nil nil + vm:return-pc-header-type) + +(def-type-vops fdefn-p nil nil nil + vm:fdefn-type) + +(def-type-vops funcallable-instance-p nil nil nil + vm:funcallable-instance-header-type) + +(def-type-vops array-header-p nil nil nil + vm:simple-array-type vm:complex-string-type vm:complex-bit-vector-type + vm:complex-vector-type vm:complex-array-type) + +(def-type-vops nil check-function-or-symbol nil object-not-function-or-symbol-error + vm:function-pointer-type vm:symbol-header-type) + +(def-type-vops stringp check-string nil object-not-string-error + vm:simple-string-type vm:complex-string-type) + +(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error + vm:simple-bit-vector-type vm:complex-bit-vector-type) + +(def-type-vops vectorp check-vector nil object-not-vector-error + vm:simple-string-type vm:simple-bit-vector-type vm:simple-vector-type + vm:simple-array-unsigned-byte-2-type vm:simple-array-unsigned-byte-4-type + vm:simple-array-unsigned-byte-8-type vm:simple-array-unsigned-byte-16-type + vm:simple-array-unsigned-byte-32-type + simple-array-signed-byte-8-type simple-array-signed-byte-16-type + simple-array-signed-byte-30-type simple-array-signed-byte-32-type + vm:simple-array-single-float-type vm:simple-array-double-float-type + #+long-float vm:simple-array-long-float-type + #+double-double vm::simple-array-double-double-float-type + vm:simple-array-complex-single-float-type + vm:simple-array-complex-double-float-type + #+long-float vm:simple-array-complex-long-float-type + #+double-double vm::simple-array-complex-double-double-float-type + vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type) + +(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error + vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type + vm:simple-vector-type vm:simple-array-unsigned-byte-2-type + vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type + vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type + simple-array-signed-byte-8-type simple-array-signed-byte-16-type + simple-array-signed-byte-30-type simple-array-signed-byte-32-type + vm:simple-array-single-float-type vm:simple-array-double-float-type + #+long-float vm:simple-array-long-float-type + #+double-double vm::simple-array-double-double-float-type + vm:simple-array-complex-single-float-type + vm:simple-array-complex-double-float-type + #+long-float vm:simple-array-complex-long-float-type + #+double-double vm::simple-array-complex-double-double-float-type + ) + +(def-type-vops arrayp check-array nil object-not-array-error + vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type + vm:simple-vector-type vm:simple-array-unsigned-byte-2-type + vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type + vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type + simple-array-signed-byte-8-type simple-array-signed-byte-16-type + simple-array-signed-byte-30-type simple-array-signed-byte-32-type + vm:simple-array-single-float-type vm:simple-array-double-float-type + #+long-float vm:simple-array-long-float-type + #+double-double vm::simple-array-double-double-float-type + vm:simple-array-complex-single-float-type + vm:simple-array-complex-double-float-type + #+long-float vm:simple-array-complex-long-float-type + #+double-double vm::simple-array-complex-double-double-float-type + vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type + vm:complex-array-type) + +(def-type-vops numberp check-number nil object-not-number-error + vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type + vm:single-float-type vm:double-float-type #+long-float vm:long-float-type + #+double-double vm:double-double-float-type + vm:complex-type vm:complex-single-float-type vm:complex-double-float-type + #+long-float vm:complex-long-float-type + #+double-double vm::complex-double-double-float-type) + +(def-type-vops rationalp check-rational nil object-not-rational-error + vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type) + +(def-type-vops integerp check-integer nil object-not-integer-error + vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type) + +(def-type-vops floatp check-float nil object-not-float-error + vm:single-float-type vm:double-float-type #+long-float vm:long-float-type + #+double-double vm:double-double-float-type) + +(def-type-vops realp check-real nil object-not-real-error + vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type + vm:single-float-type vm:double-float-type #+long-float vm:long-float-type + #+double-double vm:double-double-float-type) + + +;;;; Other integer ranges. + +;;; A (signed-byte 32) can be represented with either fixnum or a bignum with +;;; exactly one digit. + +(define-vop (signed-byte-32-p type-predicate) + (:translate signed-byte-32-p) + (:generator 45 + (let ((not-target (gen-label))) + (multiple-value-bind + (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + (inst andcc zero-tn value fixnum-tag-mask) + (inst b :eq yep) + (test-type value temp nope t vm:other-pointer-type) + (loadw temp value 0 vm:other-pointer-type) + (inst cmp temp (+ (ash 1 vm:type-bits) + vm:bignum-type)) + (inst b (if not-p :ne :eq) target) + (inst nop) + (emit-label not-target))))) + +(define-vop (check-signed-byte-32 check-type) + (:generator 45 + (let ((nope (generate-error-code vop object-not-signed-byte-32-error value)) + (yep (gen-label))) + (inst andcc temp value fixnum-tag-mask) + (inst b :eq yep) + (test-type value temp nope t vm:other-pointer-type) + (loadw temp value 0 vm:other-pointer-type) + (inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type)) + (inst b :ne nope) + (inst nop) + (emit-label yep) + (move result value)))) + + +;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a +;;; bignum with exactly one positive digit, or a bignum with exactly two digits +;;; and the second digit all zeros. + +(define-vop (unsigned-byte-32-p type-predicate) + (:translate unsigned-byte-32-p) + (:generator 45 + (let ((not-target (gen-label)) + (single-word (gen-label)) + (fixnum (gen-label))) + (multiple-value-bind + (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + ;; Is it a fixnum? + (inst andcc temp value fixnum-tag-mask) + (inst b :eq fixnum) + (inst cmp value) + + ;; If not, is it an other pointer? + (test-type value temp nope t vm:other-pointer-type) + ;; Get the header. + (loadw temp value 0 vm:other-pointer-type) + ;; Is it one? + (inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type)) + (inst b :eq single-word) + ;; If it's other than two, we can't be an (unsigned-byte 32) + (inst cmp temp (+ (ash 2 vm:type-bits) vm:bignum-type)) + (inst b :ne nope) + ;; Get the second digit. + (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type) + ;; All zeros, its an (unsigned-byte 32). + (inst cmp temp) + (inst b :eq yep) + (inst nop) + ;; Otherwise, it isn't. + (inst b nope) + (inst nop) + + (emit-label single-word) + ;; Get the single digit. + (loadw temp value vm:bignum-digits-offset vm:other-pointer-type) + (inst cmp temp) + + ;; positive implies (unsigned-byte 32). + (emit-label fixnum) + (inst b (if not-p :lt :ge) target) + (inst nop) + + (emit-label not-target))))) + +(define-vop (check-unsigned-byte-32 check-type) + (:generator 45 + (let ((nope + (generate-error-code vop object-not-unsigned-byte-32-error value)) + (yep (gen-label)) + (fixnum (gen-label)) + (single-word (gen-label))) + ;; Is it a fixnum? + (inst andcc temp value fixnum-tag-mask) + (inst b :eq fixnum) + (inst cmp value) + + ;; If not, is it an other pointer? + (test-type value temp nope t vm:other-pointer-type) + ;; Get the number of digits. + (loadw temp value 0 vm:other-pointer-type) + ;; Is it one? + (inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type)) + (inst b :eq single-word) + ;; If it's other than two, we can't be an (unsigned-byte 32) + (inst cmp temp (+ (ash 2 vm:type-bits) vm:bignum-type)) + (inst b :ne nope) + ;; Get the second digit. + (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type) + ;; All zeros, its an (unsigned-byte 32). + (inst cmp temp) + (inst b :eq yep) + ;; Otherwise, it isn't. + (inst b :ne nope) + (inst nop) + + (emit-label single-word) + ;; Get the single digit. + (loadw temp value vm:bignum-digits-offset vm:other-pointer-type) + ;; positive implies (unsigned-byte 32). + (inst cmp temp) + + (emit-label fixnum) + (inst b :lt nope) + (inst nop) + + (emit-label yep) + (move result value)))) + + + + +;;;; List/symbol types: +;;; +;;; symbolp (or symbol (eq nil)) +;;; consp (and list (not (eq nil))) + +(define-vop (symbolp type-predicate) + (:translate symbolp) + (:generator 12 + (let* ((drop-thru (gen-label)) + (is-symbol-label (if not-p drop-thru target))) + (inst cmp value null-tn) + (inst b :eq is-symbol-label) + (test-type value temp target not-p vm:symbol-header-type) + (emit-label drop-thru)))) + +(define-vop (check-symbol check-type) + (:generator 12 + (let ((drop-thru (gen-label)) + (error (generate-error-code vop object-not-symbol-error value))) + (inst cmp value null-tn) + (inst b :eq drop-thru) + (test-type value temp error t vm:symbol-header-type) + (emit-label drop-thru) + (move result value)))) + +(define-vop (consp type-predicate) + (:translate consp) + (:generator 8 + (let* ((drop-thru (gen-label)) + (is-not-cons-label (if not-p target drop-thru))) + (inst cmp value null-tn) + (inst b :eq is-not-cons-label) + (test-type value temp target not-p vm:list-pointer-type) + (emit-label drop-thru)))) + +(define-vop (check-cons check-type) + (:generator 8 + (let ((error (generate-error-code vop object-not-cons-error value))) + (inst cmp value null-tn) + (inst b :eq error) + (test-type value temp error t vm:list-pointer-type) + (move result value)))) + diff --git a/src/compiler/sparcv9/values.lisp b/src/compiler/sparcv9/values.lisp new file mode 100644 index 0000000000000000000000000000000000000000..089e4d3c2f3be1d754fadc44cab3eb1042f5385e --- /dev/null +++ b/src/compiler/sparcv9/values.lisp @@ -0,0 +1,125 @@ +;;; -*- 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/compiler/sparc/values.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the implementation of unknown-values VOPs. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted for SPARC by William Lott. +;;; + +(in-package "SPARC") + +(define-vop (reset-stack-pointer) + (:args (ptr :scs (any-reg))) + (:generator 1 + (move csp-tn ptr))) + + +;;; Push some values onto the stack, returning the start and number of values +;;; pushed as results. It is assumed that the Vals are wired to the standard +;;; argument locations. Nvals is the number of values to push. +;;; +;;; The generator cost is pseudo-random. We could get it right by defining a +;;; bogus SC that reflects the costs of the memory-to-memory moves for each +;;; operand, but this seems unworthwhile. +;;; +(define-vop (push-values) + (:args (vals :more t)) + (:results (start :scs (any-reg) :from :load) + (count :scs (any-reg))) + (:info nvals) + (:temporary (:scs (descriptor-reg)) temp) + (:generator 20 + (inst move start csp-tn) + (inst add csp-tn csp-tn (* nvals vm:word-bytes)) + (do ((val vals (tn-ref-across val)) + (i 0 (1+ i))) + ((null val)) + (let ((tn (tn-ref-tn val))) + (sc-case tn + (descriptor-reg + (storew tn start i)) + (control-stack + (load-stack-tn temp tn) + (storew temp start i))))) + (inst li count (fixnumize nvals)))) + +;;; Push a list of values on the stack, returning Start and Count as used in +;;; unknown values continuations. +;;; +(define-vop (values-list) + (:args (arg :scs (descriptor-reg) :target list)) + (:arg-types list) + (:policy :fast-safe) + (:results (start :scs (any-reg)) + (count :scs (any-reg))) + (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:vop-var vop) + (:save-p :compute-only) + (:generator 0 + (let ((loop (gen-label)) + (done (gen-label))) + + (move list arg) + (move start csp-tn) + + (emit-label loop) + (inst cmp list null-tn) + (inst b :eq done) + (loadw temp list vm:cons-car-slot vm:list-pointer-type) + (loadw list list vm:cons-cdr-slot vm:list-pointer-type) + (inst add csp-tn csp-tn vm:word-bytes) + (storew temp csp-tn -1) + (test-type list ndescr loop nil vm:list-pointer-type) + (error-call vop bogus-argument-to-values-list-error list) + + (emit-label done) + (inst sub count csp-tn start)))) + + + +;;; Copy the more arg block to the top of the stack so we can use them +;;; as function arguments. +;;; +(define-vop (%more-arg-values) + (:args (context :scs (descriptor-reg any-reg) :target src) + (skip :scs (any-reg zero immediate)) + (num :scs (any-reg) :target count)) + (:arg-types * positive-fixnum positive-fixnum) + (:temporary (:sc any-reg :from (:argument 0)) src) + (:temporary (:sc any-reg :from (:argument 2)) dst) + (:temporary (:sc descriptor-reg :from (:argument 1)) temp) + (:temporary (:sc any-reg) i) + (:results (start :scs (any-reg)) + (count :scs (any-reg))) + (:generator 20 + (sc-case skip + (zero + (move src context)) + (immediate + (inst add src context (* (tn-value skip) word-bytes))) + (any-reg + (inst add src context skip))) + (inst orcc count zero-tn num) + (inst b :eq done) + (inst move start csp-tn) + (inst move dst csp-tn) + (inst add csp-tn count) + (inst move i count) + LOOP + (inst subcc i 4) + (inst ldn temp src i) + (inst b :ne loop) + (inst stn temp dst i) + DONE)) diff --git a/src/compiler/sparcv9/vm.lisp b/src/compiler/sparcv9/vm.lisp new file mode 100644 index 0000000000000000000000000000000000000000..17c20ee2f6c22e0f173ffb1a7f7284c6abc60b66 --- /dev/null +++ b/src/compiler/sparcv9/vm.lisp @@ -0,0 +1,472 @@ +;;; -*- 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/compiler/sparc/vm.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition for the SPARC. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") + + +;;;; Define the registers + +(eval-when (compile eval) + +(defmacro defreg (name offset) + (let ((offset-sym (symbolicate name "-OFFSET"))) + `(eval-when (compile eval load) + (defconstant ,offset-sym ,offset) + (setf (svref *register-names* ,offset-sym) ,(symbol-name name))))) + +(defmacro defregset (name &rest regs) + `(eval-when (compile eval load) + (defconstant ,name + (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs))))) + +); eval-when (compile eval) + + +(eval-when (compile load eval) + +(defvar *register-names* (make-array 32 :initial-element nil)) + +); eval-when (compile load eval) + + +;; Globals. These are difficult to extract from a sigcontext. +(defreg zero 0) ; %g0 +(defreg alloc 1) ; %g1 +(defreg null 2) ; %g2 +(defreg csp 3) ; %g3 +(defreg cfp 4) ; %g4 +(defreg bsp 5) ; %g5 +;; %g6 and %g7 are supposed to be reserved for the system. %g7 is +;; apparently used by thread libraries, and on Solaris 10, is always +;; used, even for apps that aren't threaded. %g6 doesn't seem to be +;; currently used. + +;; NOTE: We need some otherwise unused register for the +;; define-move-function functions so we can access things where the +;; offset of the object is too large to fit in the offset part of an +;; instruction. It needs to be fixed because these move functions +;; don't have any other args to use. And since the register allocator +;; doesn't know about such uses, we can't use it for anything else. +(defreg gtemp 26) ; %i2, aka L0 + +;; Outs. These get clobbered when we call into C. +(defreg nl0 8) ; %o0 +(defreg nl1 9) ; %o1 +(defreg nl2 10) ; %o2 +(defreg nl3 11) ; %o3 +(defreg nl4 12) ; %o4 +(defreg nl5 13) ; %o5 +(defreg nsp 14) ; %o6, aka %sp +(defreg nargs 15) ; %o7 + +;; Locals. These are preserved when we call into C. +(defreg a0 16) ; %l0 +(defreg a1 17) ; %l1 +(defreg a2 18) ; %l2 +(defreg a3 19) ; %l3 +(defreg a4 20) ; %l4 +(defreg a5 21) ; %l5 +(defreg ocfp 22) ; %l6 +(defreg lra 23) ; %l7 + +;; Ins. These are preserved just like locals. +(defreg cname 24) ; %i0 +(defreg lexenv 25) ; %i1 +;; WARNING: Register L0 is used as a global temp for +;; define-move-functions to access stack variables when needed. We +;; can't use it for anything else! +#+nil +(defreg l0 26) ; %i2 + +(defreg nfp 27) ; %i3 +(defreg cfunc 28) ; %i4 +(defreg code 29) ; %i5 +;; We can't touch reg 30 (aka %i6, aka %fp) if we ever want to return +(defreg lip 31) ; %i7 + +(eval-when (compile load eval) + ;; Registers %g6, %g7, and %fp are not defined above so we can't + ;; access them by accident. However, it's useful to be able to + ;; disassemble code that uses these registers. (Callbacks use %fp). + ;; So manually give names to these registers + (setf (aref *register-names* 6) "G6") + (setf (aref *register-names* 7) "G7") + (setf (aref *register-names* 26) "L0") + (setf (aref *register-names* 30) "FP") + ) + +(defregset non-descriptor-regs + nl0 nl1 nl2 nl3 nl4 nl5 cfunc nargs nfp) + +;; These are the non-descriptor-regs that can be used to hold 64-bit +;; integers in v8plus mode. Basically any %o register, except we +;; don't want NSP. +#+(and sparc-v9 sparc-v8plus) +(defregset non-descriptor64-regs + nl0 nl1 nl2 nl3 nl4 nl5 nargs) + +(defregset descriptor-regs + a0 a1 a2 a3 a4 a5 ocfp lra cname lexenv) + +(defregset register-arg-offsets + a0 a1 a2 a3 a4 a5) + + + +;;;; SB and SC definition: + +(define-storage-base registers :finite :size 32) +(define-storage-base float-registers :finite :size 64) +(define-storage-base control-stack :unbounded :size 8) +(define-storage-base non-descriptor-stack :unbounded :size 0) +(define-storage-base constant :non-packed) +(define-storage-base immediate-constant :non-packed) + +;;; +;;; Handy macro so we don't have to keep changing all the numbers whenever +;;; we insert a new storage class. +;;; +(defmacro define-storage-classes (&rest classes) + (do ((forms (list 'progn) + (let* ((class (car classes)) + (sc-name (car class)) + (constant-name (intern (concatenate 'simple-string + (string sc-name) + "-SC-NUMBER")))) + (list* `(define-storage-class ,sc-name ,index + ,@(cdr class)) + `(defconstant ,constant-name ,index) + `(export ',constant-name) + forms))) + (index 0 (1+ index)) + (classes classes (cdr classes))) + ((null classes) + (nreverse forms)))) + +(define-storage-classes + + ;; Non-immediate contstants in the constant pool + (constant constant) + + ;; ZERO and NULL are in registers. + (zero immediate-constant) + (null immediate-constant) + + ;; Anything else that can be an immediate. + (immediate immediate-constant) + + + ;; **** The stacks. + + ;; The control stack. (Scanned by GC) + (control-stack control-stack) + + ;; The non-descriptor stacks. + (signed-stack non-descriptor-stack) ; (signed-byte 32) + (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32) + (base-char-stack non-descriptor-stack) ; non-descriptor characters. + (sap-stack non-descriptor-stack) ; System area pointers. + (single-stack non-descriptor-stack) ; single-floats + (double-stack non-descriptor-stack + :element-size 2 :alignment 2) ; double floats. + #+long-float + (long-stack non-descriptor-stack :element-size 4 :alignment 4) ; long floats. + #+double-double + (double-double-stack non-descriptor-stack :element-size 4 :alignment 2) + ;; complex-single-floats + (complex-single-stack non-descriptor-stack :element-size 2) + ;; complex-double-floats. + (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2) + #+long-float + ;; complex-long-floats. + (complex-long-stack non-descriptor-stack :element-size 8 :alignment 4) + + #+double-double + (complex-double-double-stack non-descriptor-stack :element-size 8 :alignment 4) + + ;; **** Things that can go in the integer registers. + + ;; Immediate descriptor objects. Don't have to be seen by GC, but nothing + ;; bad will happen if they are. (fixnums, characters, header values, etc). + (any-reg + registers + :locations #.(append non-descriptor-regs descriptor-regs) + :constant-scs (zero immediate) + :save-p t + :alternate-scs (control-stack)) + + ;; Pointer descriptor objects. Must be seen by GC. + (descriptor-reg registers + :locations #.descriptor-regs + :constant-scs (constant null immediate) + :save-p t + :alternate-scs (control-stack)) + + ;; Non-Descriptor characters + (base-char-reg registers + :locations #.non-descriptor-regs + :constant-scs (immediate) + :save-p t + :alternate-scs (base-char-stack)) + + ;; Non-Descriptor SAP's (arbitrary pointers into address space) + (sap-reg registers + :locations #.non-descriptor-regs + :constant-scs (immediate) + :save-p t + :alternate-scs (sap-stack)) + + ;; Non-Descriptor (signed or unsigned) numbers. + (signed-reg registers + :locations #.non-descriptor-regs + :constant-scs (zero immediate) + :save-p t + :alternate-scs (signed-stack)) + (unsigned-reg registers + :locations #.non-descriptor-regs + :constant-scs (zero immediate) + :save-p t + :alternate-scs (unsigned-stack)) + + ;; Random objects that must not be seen by GC. Used only as temporaries. + (non-descriptor-reg registers + :locations #.non-descriptor-regs) + + ;; 64-bit signed and unsigned integers + + #+(and sparc-v9 sparc-v8plus) + (signed64-stack non-descriptor-stack :element-size 2 :alignment 2) + #+(and sparc-v9 sparc-v8plus) + (unsigned64-stack non-descriptor-stack :element-size 2 :alignment 2) + + ;; 64-bit signed or unsigned integers. Since CMUCL is still a + ;; 32-bit app, the v8plus ABI says that only the global and out + ;; registers can be 64-bit. (Because task switches will only + ;; preserve all 64 bits of these registers. The other registers get + ;; stored on the stack and thus only preserve 32 bits.) Since the + ;; globals are already spoken for, only the out registers are + ;; available. + #+(and sparc-v9 sparc-v8plus) + (signed64-reg registers + :locations #.non-descriptor64-regs + :constant-scs (zero immediate) + :save-p t + :alternate-scs (signed64-stack)) + #+(and sparc-v9 sparc-v8plus) + (unsigned64-reg registers + :locations #.non-descriptor64-regs + :constant-scs (zero immediate) + :save-p t + :alternate-scs (unsigned64-stack)) + + ;; Pointers to the interior of objects. Used only as an temporary. + (interior-reg registers + :locations (#.lip-offset)) + + + ;; **** Things that can go in the floating point registers. + + ;; Non-Descriptor single-floats. + (single-reg float-registers + :locations #.(loop for i from 0 to 31 collect i) + :reserve-locations (28 29 30 31) + :constant-scs () + :save-p t + :alternate-scs (single-stack)) + + ;; Non-Descriptor double-floats. + (double-reg float-registers + :locations #.(loop for i from 0 to #-sparc-v9 31 #+sparc-v9 63 + by 2 collect i) + :element-size 2 :alignment 2 + :reserve-locations (28 30) + :constant-scs () + :save-p t + :alternate-scs (double-stack)) + + ;; Non-Descriptor double-floats. + #+long-float + (long-reg float-registers + :locations #.(loop for i from 0 to #-sparc-v9 31 #+sparc-v9 63 + by 4 collect i) + :element-size 4 :alignment 4 + :reserve-locations (28) + :constant-scs () + :save-p t + :alternate-scs (long-stack)) + + ;; Non-descriptor double-double floats + #+double-double + (double-double-reg float-registers + :locations #.(loop for i from 0 below #-sparc-v9 32 #+sparc-v9 64 + by 4 collect i) + :element-size 4 :alignment 4 + :constant-scs () + :save-p t + :alternate-scs (double-double-stack)) + + (complex-single-reg float-registers + :locations #.(loop for i from 0 to 31 by 2 collect i) + :element-size 2 :alignment 2 + :reserve-locations (28 30) + :constant-scs () + :save-p t + :alternate-scs (complex-single-stack)) + + (complex-double-reg float-registers + :locations #.(loop for i from 0 to #-sparc-v9 31 #+sparc-v9 63 + by 4 collect i) + :element-size 4 :alignment 4 + :reserve-locations (28) + :constant-scs () + :save-p t + :alternate-scs (complex-double-stack)) + + #+long-float + (complex-long-reg float-registers + :locations #.(loop for i from 0 to #-sparc-v9 31 #+sparc-v9 63 + by 8 collect i) + :element-size 8 :alignment 8 + :constant-scs () + :save-p t + :alternate-scs (complex-long-stack)) + + #+double-double + (complex-double-double-reg float-registers + :locations #.(loop for i from 0 below #-sparc-v9 32 #+sparc-v9 64 + by 8 collect i) + :element-size 8 :alignment 8 + :constant-scs () + :save-p t + :alternate-scs (complex-double-double-stack)) + + + ;; A catch or unwind block. + (catch-block control-stack :element-size vm:catch-block-size) + + ) + + + +;;;; Make some random tns for important registers. + +(eval-when (compile eval) + +(defmacro defregtn (name sc) + (let ((offset-sym (symbolicate name "-OFFSET")) + (tn-sym (symbolicate name "-TN"))) + `(defparameter ,tn-sym + (make-random-tn :kind :normal + :sc (sc-or-lose ',sc) + :offset ,offset-sym)))) + +); eval-when (compile eval) + +(defregtn zero any-reg) +(defregtn null descriptor-reg) +(defregtn code descriptor-reg) +(defregtn alloc any-reg) + +(defregtn nargs any-reg) +(defregtn bsp any-reg) +(defregtn csp any-reg) +(defregtn cfp any-reg) +(defregtn ocfp any-reg) +(defregtn nsp any-reg) +(defregtn gtemp any-reg) + +(defregtn lexenv descriptor-reg) +(defregtn cname descriptor-reg) + + +;;; Immediate-Constant-SC -- Interface +;;; +;;; If value can be represented as an immediate constant, then return the +;;; appropriate SC number, otherwise return NIL. +;;; +(def-vm-support-routine immediate-constant-sc (value) + (typecase value + ((integer 0 0) + (sc-number-or-lose 'zero *backend*)) + (null + (sc-number-or-lose 'null *backend*)) + ((or fixnum system-area-pointer character) + (sc-number-or-lose 'immediate *backend*)) + (symbol + (if (static-symbol-p value) + (sc-number-or-lose 'immediate *backend*) + nil)))) + + +;;;; Function Call Parameters + +;;; The SC numbers for register and stack arguments/return values. +;;; +(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg)) +(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg)) +(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack)) + +(eval-when (compile load eval) + +;;; Offsets of special stack frame locations +(defconstant ocfp-save-offset 0) +(defconstant lra-save-offset 1) +(defconstant nfp-save-offset 2) + +;;; The number of arguments/return values passed in registers. +;;; +(defconstant register-arg-count 6) + +;;; Names to use for the argument registers. +;;; +(defconstant register-arg-names '(a0 a1 a2 a3 a4 a5)) + +); Eval-When (Compile Load Eval) + + +;;; A list of TN's describing the register arguments. +;;; +(defparameter register-arg-tns + (mapcar #'(lambda (n) + (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg) + :offset n)) + register-arg-offsets)) + +;;; SINGLE-VALUE-RETURN-BYTE-OFFSET +;;; +;;; This is used by the debugger. +;;; +(export 'single-value-return-byte-offset) +(defconstant single-value-return-byte-offset 8) + + +;;; LOCATION-PRINT-NAME -- Interface +;;; +;;; This function is called by debug output routines that want a pretty name +;;; for a TN's location. It returns a thing that can be printed with PRINC. +;;; +(def-vm-support-routine location-print-name (tn) + (declare (type tn tn)) + (let ((sb (sb-name (sc-sb (tn-sc tn)))) + (offset (tn-offset tn))) + (ecase sb + (registers (or (svref *register-names* offset) + (format nil "R~D" offset))) + (float-registers (format nil "F~D" offset)) + (control-stack (format nil "CS~D" offset)) + (non-descriptor-stack (format nil "NS~D" offset)) + (constant (format nil "Const~D" offset)) + (immediate-constant "Immed")))) diff --git a/src/lisp/sparcv9-assem.S b/src/lisp/sparcv9-assem.S new file mode 100644 index 0000000000000000000000000000000000000000..d4b96cb5ecde7d97f9fbffd7cc5064f713bd0592 --- /dev/null +++ b/src/lisp/sparcv9-assem.S @@ -0,0 +1,565 @@ + +#ifdef SOLARIS +#define _ASM +#include <sys/asm_linkage.h> +#include <sys/psw.h> +#include <sys/trap.h> +#ifdef __STDC__ +#define FUNCDEF(x) .type x, \#function +#else +#define FUNCDEF(x) .type x, #function +#endif +#else +#endif + +#define LANGUAGE_ASSEMBLY +#include "lispregs.h" +#include "internals.h" +#include "globals.h" + +#define load(sym, reg) \ + sethi %hi(sym), reg; ld [reg+%lo(sym)], reg +#define store(reg, sym) \ + sethi %hi(sym), reg_L0; st reg, [reg_L0+%lo(sym)] + +/* + * Our frame size needs to be large enough to hold our window, + * the structure return pointer, and some temp space. The temp space + * is to hold the 64-bit %o registers that might be converted to %i + * registers. A task switch will will not preserve all 64 bits of the + * %i registers, so we need to save our %o registers before entering C. + * Since %o0 and %o1 contain the return results, we do not have to save + * these. + */ +#ifdef v8plus +#define FRAMESIZE (SA(WINDOWSIZE+4 + 6*8)) +#else +#define FRAMESIZE (SA(MINFRAME)) +#endif + .seg "text" + .global call_into_lisp + FUNCDEF(call_into_lisp) +call_into_lisp: + save %sp, -FRAMESIZE, %sp + /* Flush all of C's register windows to the stack. */ + ta ST_FLUSH_WINDOWS + + /* Save the return address. */ + st %i7, [%fp-4] + + /* Clear the descriptor regs. (See sparc/vm.lisp) */ + mov reg_ZERO, reg_A0 + mov reg_ZERO, reg_A1 + mov reg_ZERO, reg_A2 + mov reg_ZERO, reg_A3 + mov reg_ZERO, reg_A4 + mov reg_ZERO, reg_A5 + mov reg_ZERO, reg_OCFP + mov reg_ZERO, reg_LRA + mov reg_ZERO, reg_CODE + + /* Establish NIL */ + set NIL, reg_NIL + + /* Set the pseudo-atomic flag. */ + set pseudo_atomic_Value, reg_ALLOC + + /* Turn off foreign function call. */ + sethi %hi(foreign_function_call_active), reg_NL0 + st reg_ZERO, [reg_NL0+%lo(foreign_function_call_active)] + + /* Load the rest of lisp state. */ + load(current_dynamic_space_free_pointer, reg_NL0) + add reg_NL0, reg_ALLOC, reg_ALLOC + load(current_binding_stack_pointer, reg_BSP) + load(current_control_stack_pointer, reg_CSP) + load(current_control_frame_pointer, reg_OCFP) + + /* No longer atomic, and check for interrupt. */ + andn reg_ALLOC, pseudo_atomic_Value, reg_ALLOC + andcc reg_ALLOC, pseudo_atomic_InterruptedValue, reg_ZERO + tne trap_PseudoAtomic + + /* Pass in the args. */ + sll %i2, 2, reg_NARGS + mov %i1, reg_CFP + mov %i0, reg_LEXENV + ld [reg_CFP+0], reg_A0 + ld [reg_CFP+4], reg_A1 + ld [reg_CFP+8], reg_A2 + ld [reg_CFP+12], reg_A3 + ld [reg_CFP+16], reg_A4 + ld [reg_CFP+20], reg_A5 + + /* Calculate LRA */ + set lra + type_OtherPointer, reg_LRA + + /* Indirect closure */ + ld [reg_LEXENV+CLOSURE_FUNCTION_OFFSET], reg_CODE + + jmp reg_CODE+FUNCTION_CODE_OFFSET + nop + + .align 8 +lra: + .word type_ReturnPcHeader + + /* Blow off any extra values. */ + mov reg_OCFP, reg_CSP + nop + + /* Return the one value. */ + mov reg_A0, %i0 + + /* Turn on pseudo_atomic */ + or reg_ALLOC, pseudo_atomic_Value, reg_ALLOC + + /* Store LISP state */ + andn reg_ALLOC, lowtag_Mask, reg_NL1 + store(reg_NL1,current_dynamic_space_free_pointer) + store(reg_BSP,current_binding_stack_pointer) + store(reg_CSP,current_control_stack_pointer) + store(reg_CFP,current_control_frame_pointer) + + /* No longer in Lisp. */ + store(reg_NL1,foreign_function_call_active) + + /* Were we interrupted? */ + andn reg_ALLOC, pseudo_atomic_Value, reg_ALLOC + andcc reg_ALLOC, pseudo_atomic_InterruptedValue, reg_ZERO + tne trap_PseudoAtomic + + /* Back to C we go. */ + ld [%sp+FRAMESIZE-4], %i7 + ret + restore %sp, FRAMESIZE, %sp + SET_SIZE(call_into_lisp) + + + + .global call_into_c + FUNCDEF(call_into_c) +call_into_c: +#ifdef v8plus + stx %o2, [%fp - 8 - 1*8] + stx %o3, [%fp - 8 - 2*8] + stx %o4, [%fp - 8 - 3*8] + stx %o5, [%fp - 8 - 4*8] + stx %o6, [%fp - 8 - 5*8] + stx %o7, [%fp - 8 - 6*8] +#endif + /* Build a lisp stack frame */ + mov reg_CFP, reg_OCFP + mov reg_CSP, reg_CFP + add reg_CSP, 32, reg_CSP + st reg_OCFP, [reg_CFP] + st reg_CODE, [reg_CFP+8] + + /* Turn on pseudo-atomic. */ + or reg_ALLOC, pseudo_atomic_Value, reg_ALLOC + + /* Convert the return address to an offset and save it on the stack. */ + sub reg_LIP, reg_CODE, reg_L0 + add reg_L0, type_OtherPointer, reg_L0 + st reg_L0, [reg_CFP+4] + + /* Store LISP state */ + store(reg_BSP,current_binding_stack_pointer) + store(reg_CSP,current_control_stack_pointer) + store(reg_CFP,current_control_frame_pointer) + + /* Use reg_CFP as a work register, and restore it */ + andn reg_ALLOC, lowtag_Mask, reg_CFP + store(reg_CFP,current_dynamic_space_free_pointer) + load(current_control_frame_pointer, reg_CFP) + + /* No longer in Lisp. */ + store(reg_CSP,foreign_function_call_active) + + /* Were we interrupted? */ + andn reg_ALLOC, pseudo_atomic_Value, reg_ALLOC + andcc reg_ALLOC, pseudo_atomic_InterruptedValue, reg_ZERO + tne trap_PseudoAtomic + + /* Into C we go. */ + call reg_CFUNC + nop + + /* + * Note: C calling conventions (32-bit) say that %o0 and %o1 + * are used to return function results. In particular 64-bit + * results are in %o0 (hi) and %o1 (low). + */ + + /* Re-establish NIL */ + set NIL, reg_NIL + + /* Atomic. */ + set pseudo_atomic_Value, reg_ALLOC + + /* No longer in foreign function call. */ + sethi %hi(foreign_function_call_active), reg_NL2 + st reg_ZERO, [reg_NL2+%lo(foreign_function_call_active)] + + /* Load the rest of lisp state. */ + load(current_dynamic_space_free_pointer, reg_NL2) + add reg_NL2, reg_ALLOC, reg_ALLOC + load(current_binding_stack_pointer, reg_BSP) + load(current_control_stack_pointer, reg_CSP) + load(current_control_frame_pointer, reg_CFP) + + /* Get the return address back. */ + ld [reg_CFP+4], reg_LIP + ld [reg_CFP+8], reg_CODE + add reg_LIP, reg_CODE, reg_LIP + sub reg_LIP, type_OtherPointer, reg_LIP + + /* No longer atomic. */ + andn reg_ALLOC, pseudo_atomic_Value, reg_ALLOC + andcc reg_ALLOC, pseudo_atomic_InterruptedValue, reg_ZERO + tne trap_PseudoAtomic + + /* Reset the lisp stack. */ + /* Note: OCFP is in one of the locals, it gets preserved across C. */ + mov reg_CFP, reg_CSP + mov reg_OCFP, reg_CFP + +#ifdef v8plus + ldx [%fp - 8 - 1*8], %o2 + ldx [%fp - 8 - 2*8], %o3 + ldx [%fp - 8 - 3*8], %o4 + ldx [%fp - 8 - 4*8], %o5 + ldx [%fp - 8 - 5*8], %o6 + ldx [%fp - 8 - 6*8], %o7 +#endif + /* And back into lisp. */ + ret + nop + + SET_SIZE(call_into_c) + +#if 0 +/* undefined_tramp and closure_tramp are now Lisp assembly routines. + * so we don't need these anymore. Leave them here for a bit so + * we can look at the "real" versions for a while. But eventually, + * remove these. + */ + .global _undefined_tramp + FUNCDEF(_undefined_tramp) + .align 8 + .byte 0 +_undefined_tramp: + .byte 0, 0, type_FunctionHeader + .word _undefined_tramp + .word NIL + .word NIL + .word NIL + .word NIL + + b 1f + unimp trap_Cerror + /* Number of argument bytes */ + .byte 4 + .byte UNDEFINED_SYMBOL_ERROR + /* Escape to create 16bit number from following two bytes, + in little-endian order */ + .byte 254 + /* SC_OFFSET(sc_DescriptorReg,reg_FDEFN) */ + .byte SC_OFFSET_LO(sc_DescriptorReg,reg_FDEFN_NUM) + .byte SC_OFFSET_HI(sc_DescriptorReg,reg_FDEFN_NUM) + + .align 4 +1: + ld [reg_FDEFN+FDEFN_RAW_ADDR_OFFSET], reg_CODE + jmp reg_CODE+FUNCTION_CODE_OFFSET + nop + SET_SIZE(_undefined_tramp) + + .global _closure_tramp + FUNCDEF(_closure_tramp) + .align 8 + .byte 0 +_closure_tramp: + .byte 0, 0, type_FunctionHeader + .word _closure_tramp + .word NIL + .word NIL + .word NIL + .word NIL + + ld [reg_FDEFN+FDEFN_FUNCTION_OFFSET], reg_LEXENV + ld [reg_LEXENV+CLOSURE_FUNCTION_OFFSET], reg_CODE + jmp reg_CODE+FUNCTION_CODE_OFFSET + nop + SET_SIZE(_closure_tramp) +#endif + + +/* + * Function-end breakpoint magic. + */ + + .text + .align 8 + .global function_end_breakpoint_guts +function_end_breakpoint_guts: + .word type_ReturnPcHeader + b 1f + nop + mov reg_CSP, reg_OCFP + add 4, reg_CSP, reg_CSP + mov 4, reg_NARGS + mov reg_NIL, reg_A1 + mov reg_NIL, reg_A2 + mov reg_NIL, reg_A3 + mov reg_NIL, reg_A4 + mov reg_NIL, reg_A5 +1: + + .global function_end_breakpoint_trap +function_end_breakpoint_trap: + unimp trap_FunctionEndBreakpoint + b 1b + nop + + .global function_end_breakpoint_end +function_end_breakpoint_end: + + .global flush_icache + FUNCDEF(flush_icache) +flush_icache: + add %o0,%o1,%o2 +1: iflush %o0 ! flush instruction cache + add %o0,8,%o0 + cmp %o0,%o2 + blt 1b + nop + retl ! return from leaf routine + nop + SET_SIZE(flush_icache) + + .global do_pending_interrupt + FUNCDEF(do_pending_interrupt) +do_pending_interrupt: + unimp trap_PendingInterrupt + retl + nop + SET_SIZE(do_pending_interrupt) + +#ifdef trap_DynamicSpaceOverflowError + .global do_dynamic_space_overflow_error + FUNCDEF(do_dynamic_space_overflow_error) +do_dynamic_space_overflow_error: + unimp trap_DynamicSpaceOverflowError + retl + nop + SET_SIZE(do_dynamic_space_overflow_error) +#endif + +#ifdef trap_DynamicSpaceOverflowWarning + .global do_dynamic_space_overflow_warning + FUNCDEF(do_dynamic_space_overflow_warning) +do_dynamic_space_overflow_warning: + unimp trap_DynamicSpaceOverflowWarning + retl + nop + SET_SIZE(do_dynamic_space_overflow_warning) +#endif + +#ifdef LINKAGE_TABLE +/* + * Call into C code to resolve a linkage entry. + * + * We get here by Lisp calling call_into_c with an address of the + * desired function which is contained in the register reg_CFUNC (aka + * %i4, aka %r28). This is the address of the entry in the linkage + * table, which is what we need to figure out what function we really + * wanted. + * + * Note that because we get here from call_into_c, all necessary live + * registers have been saved, including FP registers. Hence, no need + * to save them. + */ + .global lazy_resolve_linkage + .global resolve_linkage_tramp + FUNCDEF(resolve_linkage_tramp) +resolve_linkage_tramp: + /* + * At this point, all of the global %g registers have been + * saved by call_into_c, so we can use them as temps. %g2, + * aka reg_NIL, aka null-tn is a good choice. reg_L0 contains + * the address of the jmpl instruction in the linkage jump + * table. (See sparc-arch.c.) + */ + + mov reg_L0, reg_NIL + + /* + * New stack frame so the %o regs become %i. We can't touch + * the original %o because they contain the parameters to the + * function! + */ + save %sp, -FRAMESIZE, %sp + + /* %g2 tells where we came from in the linkage table */ + call lazy_resolve_linkage + mov reg_NIL, %o0 ! in the delay slot + + mov %o0, reg_NIL + restore %sp, FRAMESIZE, %sp + + /* And away we go! */ + jmp reg_NIL + nop + + SET_SIZE(resolve_linkage_tramp) + + .global undefined_foreign_symbol_trap + FUNCDEF(undefined_foreign_symbol_trap) +/* + * When we get called, %o0 contains the address of the data_vector object + * which is a string naming the bad symbol. + */ +undefined_foreign_symbol_trap: + /* + Need to restore all the global registers with the Lisp values that + were saved away in call_into_c. (This routine is only called from + os_link_one_symbol, which is called from resolve_linkage_tramp, which + is called from call_into_c.) + + The global registers are volatile across function calls, so who + knows what values have been they contain now! + + */ + + load(current_dynamic_space_free_pointer, reg_ALLOC) + load(current_binding_stack_pointer, reg_BSP) + load(current_control_stack_pointer, reg_CSP) + load(current_control_frame_pointer, reg_CFP) + + set NIL, reg_NIL + + mov %o0, reg_A0 + unimp trap_Error + .byte 4 /* Number of argument bytes */ + .byte UNDEFINED_FOREIGN_SYMBOL_ERROR + /* Escape to create 16bit number from following two bytes, in + little-endian order */ + .byte 254 + .byte SC_OFFSET_LO(sc_DescriptorReg, reg_A0_NUM) + .byte SC_OFFSET_HI(sc_DescriptorReg, reg_A0_NUM) + .align 4 + +#endif +/* + * Save the FPU state. %o0 contains a pointer to where we can + * store our state. + */ + +/* + * Note we only save the 16 double-float registers (which saves + * the 32 single-float values too, I think). If we're compiling for + * a sparc v9, the Lisp code can actually use all 32 double-float + * registers. For later. + */ + .global fpu_save + FUNCDEF(fpu_save) +fpu_save: + std %f0, [%o0 + 4*0] + std %f2, [%o0 + 4*2] + std %f4, [%o0 + 4*4] + std %f6, [%o0 + 4*6] + std %f8, [%o0 + 4*8] + std %f10, [%o0 + 4*10] + std %f12, [%o0 + 4*12] + std %f14, [%o0 + 4*14] + std %f16, [%o0 + 4*16] + std %f18, [%o0 + 4*18] + std %f20, [%o0 + 4*20] + std %f22, [%o0 + 4*22] + std %f24, [%o0 + 4*24] + std %f26, [%o0 + 4*26] + std %f28, [%o0 + 4*28] + std %f30, [%o0 + 4*30] +#ifdef FEATURE_SPARC_V9 + std %f32, [%o0 + 4*32] + std %f34, [%o0 + 4*34] + std %f36, [%o0 + 4*36] + std %f38, [%o0 + 4*38] + std %f40, [%o0 + 4*40] + std %f42, [%o0 + 4*42] + std %f44, [%o0 + 4*44] + std %f46, [%o0 + 4*46] + std %f48, [%o0 + 4*48] + std %f50, [%o0 + 4*50] + std %f52, [%o0 + 4*52] + std %f54, [%o0 + 4*54] + std %f56, [%o0 + 4*56] + std %f58, [%o0 + 4*58] + std %f60, [%o0 + 4*60] + std %f62, [%o0 + 4*62] + st %fsr, [%o0 + 4*64] +#else + st %fsr, [%o0 + 4*32] +#endif + retl + nop + SET_SIZE(fpu_save) + + .global fpu_restore + FUNCDEF(fpu_restore) +fpu_restore: + ldd [%o0 + 4*0], %f0 + ldd [%o0 + 4*2], %f2 + ldd [%o0 + 4*4], %f4 + ldd [%o0 + 4*6], %f6 + ldd [%o0 + 4*8], %f8 + ldd [%o0 + 4*10], %f10 + ldd [%o0 + 4*12], %f12 + ldd [%o0 + 4*14], %f14 + ldd [%o0 + 4*16], %f16 + ldd [%o0 + 4*18], %f18 + ldd [%o0 + 4*20], %f20 + ldd [%o0 + 4*22], %f22 + ldd [%o0 + 4*24], %f24 + ldd [%o0 + 4*26], %f26 + ldd [%o0 + 4*28], %f28 + ldd [%o0 + 4*30], %f30 +#ifdef FEATURE_SPARC_V9 + ldd [%o0 + 4*32], %f32 + ldd [%o0 + 4*34], %f34 + ldd [%o0 + 4*36], %f36 + ldd [%o0 + 4*38], %f38 + ldd [%o0 + 4*40], %f40 + ldd [%o0 + 4*42], %f42 + ldd [%o0 + 4*44], %f44 + ldd [%o0 + 4*46], %f46 + ldd [%o0 + 4*48], %f48 + ldd [%o0 + 4*50], %f50 + ldd [%o0 + 4*52], %f52 + ldd [%o0 + 4*54], %f54 + ldd [%o0 + 4*56], %f56 + ldd [%o0 + 4*58], %f58 + ldd [%o0 + 4*60], %f60 + ldd [%o0 + 4*62], %f62 + ld [%o0 + 4*64], %fsr +#else + ld [%o0 + 4*32], %fsr +#endif + retl + nop + SET_SIZE(fpu_restore) + + .global save_context + FUNCDEF(save_context) +save_context: + ta ST_FLUSH_WINDOWS ! flush register windows + retl ! return from leaf routine + nop + SET_SIZE(save_context) +/* + * Local variables: + * tab-width: 8 + * End: + */ +