(> SPEED DEBUG). (This is an incompatible change because there are
programs which relied on the old CMU-CL-style behavior to optimize
away their unbounded recursion which will now die of stack overflow.)
+ * SBCL runs on SPARC systems now. (thanks to Christophe Rhodes' port
+ of CMU CL's support for SPARC, and various endianness and other
+ SBCL portability fixes due to Christophe Rhodes and Dan Barlow)
* new syntactic sugar for the Unix command line: --load foo.bar is now
an alternate notation for --eval '(load "foo.bar")'.
* bug fixes:
for early 0.7.x:
-* building with CLISP (or explaining why not). This will likely involve
- a rearrangement of the build system so that it never renames
- the output from COMPILE-FILE, because CLISP's COMPILE-FILE
- outputs two (!) files and as far as I can tell LOAD uses both
- of them. Since I have other motivations for this rearrangement
- besides CLISPiosyncrasies, I'm reasonably motivated to do it.
+* building with CLISP (or explaining why not)
* urgent EVAL/EVAL-WHEN/%COMPILE/DEFUN/DEFSTRUCT cleanup:
** made inlining DEFUN inside MACROLET work again
** (also, while working on INLINE anyway, it might be easy
#!+bsd ("src/code/bsd-os" :not-host)
#!+linux ("src/code/linux-os" :not-host)
+ ;; sparc-vm and ppc-vm need sc-offset defined to get at internal
+ ;; error args. This file contains stuff previously in
+ ;; debug-info.lisp. Should it therefore be :not-host? -- CSR,
+ ;; 2002-02-05
+ ("src/code/sc-offset")
+
;; KLUDGE: I'd prefer to have this done with a "code/target" softlink
;; instead of a bunch of reader macros. -- WHN 19990308
#!+pmax ("src/code/pmax-vm" :not-host)
#!+rt ("src/code/rt-vm" :not-host)
#!+hppa ("src/code/hppa-vm" :not-host)
#!+x86 ("src/code/x86-vm" :not-host)
+ #!+ppc ("src/code/ppc-vm" :not-host)
#!+alpha ("src/code/alpha-vm" :not-host)
#!+sgi ("src/code/sgi-vm" :not-host)
("src/compiler/target/char")
("src/compiler/target/memory")
("src/compiler/target/static-fn")
- ("src/compiler/target/arith")
+ ("src/compiler/target/arith"
+ ;; KLUDGE: for ppc and sparc this appears to be necessary -- see the
+ ;; comment below regarding src/compiler/target/array -- CSR,
+ ;; 2002-05-05
+ :ignore-failure-p)
("src/compiler/target/subprim")
("src/compiler/target/debug")
+ ;; src/compiler/sparc/c-call contains a deftransform for
+ ;; %ALIEN-FUNCALL -- CSR
+ ("src/compiler/early-aliencomp")
("src/compiler/target/c-call")
("src/compiler/target/cell")
("src/compiler/target/values")
.SH SYSTEM REQUIREMENTS
-Unlike its distinguished ancestor CMU CL, SBCL currently runs only on X86
-(Linux, FreeBSD, and OpenBSD) and Alpha (Linux). For information on
-other ongoing ports, see the sbcl-devel mailing list, and/or the
-web site.
+Unlike its distinguished ancestor CMU CL, SBCL currently runs only on
+X86 (Linux, FreeBSD, and OpenBSD), Alpha (Linux), and SPARC (Linux).
+For information on other ongoing and possible ports, see the
+sbcl-devel mailing list, and/or the web site.
SBCL requires on the order of 16Mb RAM to run on X86 systems.
case `uname -m` in
*86) guessed_sbcl_arch=x86 ;;
[Aa]lpha) guessed_sbcl_arch=alpha ;;
+ sparc*) guessed_sbcl_arch=sparc ;;
+ ppc) guessed_sbcl_arch=ppc ;;
*)
# If we're not building on a supported target architecture, we
# we have no guess, but it's not an error yet, since maybe
echo //setting up OS-dependent information
original_dir=`pwd`
cd src/runtime/
-rm -f Config
+rm -f Config target-arch-os.h target-arch.h target-os.h target-lispregs.h
+# KLUDGE: these two logically belong in the previous section
+# ("architecture-dependent"); it seems silly to enforce this in terms
+# of the shell script, though. -- CSR, 2002-02-03
+ln -s $sbcl_arch-arch.h target-arch.h
+ln -s $sbcl_arch-lispregs.h target-lispregs.h
case `uname` in
Linux)
echo -n ' :linux' >> $ltf
ln -s Config.$sbcl_arch-linux Config
+ ln -s $sbcl_arch-linux-os.h target-arch-os.h
+ ln -s linux-os.h target-os.h
;;
*BSD)
echo -n ' :bsd' >> $ltf
+ ln -s $sbcl_arch-bsd-os.h target-arch-os.h
+ ln -s bsd-os.h target-os.h
case `uname` in
FreeBSD)
echo -n ' :freebsd' >> $ltf
--- /dev/null
+;;;; stuff to handle allocation of stuff we don't want to do inline
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+;;; (Given that the pseudo-atomic sequence is so short, there is
+;;; nothing that qualifies. But we want to keep the file around
+;;; in case we decide to add something later.)
--- /dev/null
+;;;; Stuff to handle simple cases for generic arithmetic.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; 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-widetag (1+ bignum-digits-offset))
+ (storew temp2 res bignum-digits-offset other-pointer-lowtag))
+ (lisp-return lra :offset 2)
+
+ DO-STATIC-FUN
+ (inst ld code-tn null-tn (static-fun-offset 'two-arg-+))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j code-tn
+ (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
+ (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-widetag (1+ bignum-digits-offset))
+ (storew temp2 res bignum-digits-offset other-pointer-lowtag))
+ (lisp-return lra :offset 2)
+
+ DO-STATIC-FUN
+ (inst ld code-tn null-tn (static-fun-offset 'two-arg--))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j code-tn
+ (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
+ (inst move cfp-tn csp-tn)
+
+ DONE
+ (move res temp))
+
+
+\f
+;;;; 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.
+ ;;
+ ;; FIXME: Note that the below shebang read-time conditionals aren't
+ ;; actually shebang. This is because the assembly files are also
+ ;; built in warm-init, when #! is not a defined read-macro. This
+ ;; problem will actually go away when we rewrite these low-level
+ ;; bits and pieces to use the backend-subfeatures machinery, as we
+ ;; will then conditionalize at code-emission time or assembly time
+ ;; for the VOP and the assembly routine respectively. - CSR,
+ ;; 2002-02-11
+ #+:sparc-64
+ ;; Sign extend y to a full 64-bits. temp was already
+ ;; sign-extended by the sra instruction above.
+ (progn
+ (inst sra y 0)
+ (inst mulx hi temp y)
+ (inst move lo hi)
+ (inst srax hi 32))
+ #+(and (not :sparc-64) (or :sparc-v8 :sparc-v9))
+ (progn
+ (inst smul lo temp y)
+ (inst rdy hi))
+ #+(and (not :sparc-64) (not (or :sparc-v8 :sparc-v9)))
+ (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.
+ #+nil
+ (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
+ (let ((one-word (gen-label)))
+ (inst or res alloc-tn other-pointer-lowtag)
+ ;; 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 n-widetag-bits) bignum-widetag))
+ ;; Nope, we need two, so allocate the addition space.
+ (inst add alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset))
+ (pad-data-block (1+ bignum-digits-offset))))
+ (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
+ (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
+ (emit-label one-word)
+ (storew temp res 0 other-pointer-lowtag)
+ (storew lo res bignum-digits-offset other-pointer-lowtag)))
+ ;; 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-widetag (+ 2 bignum-digits-offset))
+ (let ((one-word (gen-label)))
+ (inst or res alloc-tn other-pointer-lowtag)
+ ;; 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 n-widetag-bits) bignum-widetag))
+ ;; Need 2 words. Set the header appropriately, and save the
+ ;; high and low parts.
+ (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
+ (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
+ (emit-label one-word)
+ (storew temp res 0 other-pointer-lowtag)
+ (storew lo res bignum-digits-offset other-pointer-lowtag)))
+ ;; Out of here
+ (lisp-return lra :offset 2)
+
+ DO-STATIC-FUN
+ (inst ld code-tn null-tn (static-fun-offset 'two-arg-*))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j code-tn
+ (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
+ (inst move cfp-tn csp-tn)
+
+ LOW-FITS-IN-FIXNUM
+ (move res lo))
+
+(macrolet
+ ((frob (name note cost type sc)
+ `(define-assembly-routine (,name
+ (:note ,note)
+ (:cost ,cost)
+ (:translate *)
+ (:policy :fast-safe)
+ (:arg-types ,type ,type)
+ (:result-types ,type))
+ ((:arg x ,sc nl0-offset)
+ (:arg y ,sc nl1-offset)
+ (:res res ,sc nl0-offset)
+ (:temp temp ,sc nl2-offset))
+ ,@(when (eq type 'tagged-num)
+ `((inst sra x 2)))
+ #+:sparc-64
+ ;; Sign extend, then multiply
+ (progn
+ (inst sra x 0)
+ (inst sra y 0)
+ (inst mulx res x y))
+ #+(and (not :sparc-64) (or :sparc-v8 :sparc-v9))
+ (inst smul res x y)
+ #+(and (not :sparc-64) (not (or :sparc-v8 :sparc-v9)))
+ (progn
+ (inst wry x)
+ (inst andcc temp zero-tn)
+ (inst nop)
+ (inst nop)
+ (dotimes (i 32)
+ (inst mulscc temp y))
+ (inst mulscc temp zero-tn)
+ (inst rdy res)))))
+ (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg)
+ (frob signed-* "unsigned *" 41 signed-num signed-reg)
+ (frob fixnum-* "fixnum *" 30 tagged-num any-reg))
+
+
+\f
+;;;; Division.
+
+#+sb-assembling
+(defun emit-divide-loop (divisor rem quo tagged)
+ (inst li quo 0)
+ (labels
+ ((do-loop (depth)
+ (cond
+ ((zerop depth)
+ (inst unimp 0))
+ (t
+ (let ((label-1 (gen-label))
+ (label-2 (gen-label)))
+ (inst cmp divisor rem)
+ (inst b :geu label-1)
+ (inst nop)
+ (inst sll divisor 1)
+ (do-loop (1- depth))
+ (inst srl divisor 1)
+ (inst cmp divisor rem)
+ (emit-label label-1)
+ (inst b :gtu label-2)
+ (inst sll quo 1)
+ (inst add quo (if tagged (fixnumize 1) 1))
+ (inst sub rem divisor)
+ (emit-label label-2))))))
+ (do-loop (if tagged 30 32))))
+
+(define-assembly-routine (positive-fixnum-truncate
+ (:note "unsigned fixnum truncate")
+ (:cost 45)
+ (:translate truncate)
+ (:policy :fast-safe)
+ (:arg-types positive-fixnum positive-fixnum)
+ (:result-types positive-fixnum positive-fixnum))
+ ((:arg dividend any-reg nl0-offset)
+ (:arg divisor any-reg nl1-offset)
+
+ (:res quo any-reg nl2-offset)
+ (:res rem any-reg nl0-offset))
+
+ (let ((error (generate-error-code nil division-by-zero-error
+ dividend divisor)))
+ (inst cmp divisor)
+ (inst b :eq error))
+
+ (move rem dividend)
+ (emit-divide-loop divisor rem quo t))
+
+
+(define-assembly-routine (fixnum-truncate
+ (:note "fixnum truncate")
+ (:cost 50)
+ (:policy :fast-safe)
+ (:translate truncate)
+ (:arg-types tagged-num tagged-num)
+ (:result-types tagged-num tagged-num))
+ ((:arg dividend any-reg nl0-offset)
+ (:arg divisor any-reg nl1-offset)
+
+ (:res quo any-reg nl2-offset)
+ (:res rem any-reg nl0-offset)
+
+ (:temp quo-sign any-reg nl5-offset)
+ (:temp rem-sign any-reg nargs-offset))
+
+ (let ((error (generate-error-code nil division-by-zero-error
+ dividend divisor)))
+ (inst cmp divisor)
+ (inst b :eq error))
+
+ (inst xor quo-sign dividend divisor)
+ (inst move rem-sign dividend)
+ (let ((label (gen-label)))
+ (inst cmp dividend)
+ (inst ba :lt label)
+ (inst neg dividend)
+ (emit-label label))
+ (let ((label (gen-label)))
+ (inst cmp divisor)
+ (inst ba :lt label)
+ (inst neg divisor)
+ (emit-label label))
+ (move rem dividend)
+ (emit-divide-loop divisor rem quo t)
+ (let ((label (gen-label)))
+ ;; If the quo-sign is negative, we need to negate quo.
+ (inst cmp quo-sign)
+ (inst ba :lt label)
+ (inst neg quo)
+ (emit-label label))
+ (let ((label (gen-label)))
+ ;; If the rem-sign is negative, we need to negate rem.
+ (inst cmp rem-sign)
+ (inst ba :lt label)
+ (inst neg rem)
+ (emit-label label)))
+
+
+(define-assembly-routine (signed-truncate
+ (:note "(signed-byte 32) truncate")
+ (:cost 60)
+ (:policy :fast-safe)
+ (:translate truncate)
+ (:arg-types signed-num signed-num)
+ (:result-types signed-num signed-num))
+
+ ((:arg dividend signed-reg nl0-offset)
+ (:arg divisor signed-reg nl1-offset)
+
+ (:res quo signed-reg nl2-offset)
+ (:res rem signed-reg nl0-offset)
+
+ (:temp quo-sign signed-reg nl5-offset)
+ (:temp rem-sign signed-reg nargs-offset))
+
+ (let ((error (generate-error-code nil division-by-zero-error
+ dividend divisor)))
+ (inst cmp divisor)
+ (inst b :eq error))
+
+ (inst xor quo-sign dividend divisor)
+ (inst move rem-sign dividend)
+ (let ((label (gen-label)))
+ (inst cmp dividend)
+ (inst ba :lt label)
+ (inst neg dividend)
+ (emit-label label))
+ (let ((label (gen-label)))
+ (inst cmp divisor)
+ (inst ba :lt label)
+ (inst neg divisor)
+ (emit-label label))
+ (move rem dividend)
+ (emit-divide-loop divisor rem quo nil)
+ (let ((label (gen-label)))
+ ;; If the quo-sign is negative, we need to negate quo.
+ (inst cmp quo-sign)
+ (inst ba :lt label)
+ (inst neg quo)
+ (emit-label label))
+ (let ((label (gen-label)))
+ ;; If the rem-sign is negative, we need to negate rem.
+ (inst cmp rem-sign)
+ (inst ba :lt label)
+ (inst neg rem)
+ (emit-label label)))
+
+\f
+;;;; 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-fun-offset ',static-fn))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j code-tn
+ (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
+ (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-fun-offset 'eql))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j code-tn
+ (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
+ (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-fun-offset 'two-arg-=))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j code-tn
+ (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
+ (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-fun-offset 'two-arg-=))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j code-tn
+ (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
+ (inst move cfp-tn csp-tn)
+
+ RETURN-NIL
+ (inst move res null-tn))
--- /dev/null
+;;;; support routines for arrays and vectors
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(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 vector descriptor-reg a3-offset))
+ (pseudo-atomic ()
+ (inst or vector alloc-tn other-pointer-lowtag)
+ (inst add ndescr words (* (1+ vector-data-offset) n-word-bytes))
+ (inst andn ndescr 7)
+ (inst add alloc-tn ndescr)
+ (inst srl ndescr type word-shift)
+ (storew ndescr vector 0 other-pointer-lowtag)
+ (storew length vector vector-length-slot other-pointer-lowtag))
+ ;; 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.
+ (storew zero-tn alloc-tn 0)
+ (move result vector))
+
+
+\f
+;;;; Hash primitives
+
+;;; this is commented out in the alpha port. I'm therefore going to
+;;; comment it out here pending explanation -- CSR, 2001-08-31.
+
+#|
+#+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 vector-length-slot other-pointer-lowtag))
+
+
+(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)
+
+ (inst li offset (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))
+ (inst b test)
+ (move accum zero-tn)
+
+ LOOP
+
+ (inst xor accum data)
+ (inst sll temp accum 27)
+ (inst srl accum 5)
+ (inst or accum temp)
+ (inst add offset 4)
+
+ TEST
+
+ (inst subcc length (fixnumize 4))
+ (inst b :ge loop)
+ (inst ld data string offset)
+
+ (inst addcc length (fixnumize 4))
+ (inst b :eq done)
+ (inst neg length)
+ (inst sll length 1)
+ (inst srl data length)
+ (inst xor accum data)
+
+ DONE
+
+ (inst sll result accum 5)
+ (inst srl result result 3))
+|#
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; Return-multiple with other than one value
+
+#+sb-assembling ;; 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 l0-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 n-word-bytes))
+ (inst cmp nvals (fixnumize 3))
+ (inst b :le default-a3-and-on)
+ (inst ld a2 vals (* 2 n-word-bytes))
+ (inst cmp nvals (fixnumize 4))
+ (inst b :le default-a4-and-on)
+ (inst ld a3 vals (* 3 n-word-bytes))
+ (inst cmp nvals (fixnumize 5))
+ (inst b :le default-a5-and-on)
+ (inst ld a4 vals (* 4 n-word-bytes))
+ (inst cmp nvals (fixnumize 6))
+ (inst b :le done)
+ (inst ld a5 vals (* 5 n-word-bytes))
+
+ ;; Copy the remaining args to the top of the stack.
+ (inst add src vals (* 6 n-word-bytes))
+ (inst add dst cfp-tn (* 6 n-word-bytes))
+ (inst subcc count nvals (fixnumize 6))
+
+ LOOP
+ (inst ld temp src)
+ (inst add src n-word-bytes)
+ (inst st temp dst)
+ (inst add dst n-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))
+
+
+\f
+;;;; tail-call-variable.
+
+#+sb-assembling ;; 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 l0-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 n-word-bytes))
+ (inst ld a1 args (* 1 n-word-bytes))
+ (inst ld a2 args (* 2 n-word-bytes))
+ (inst ld a3 args (* 3 n-word-bytes))
+ (inst ld a4 args (* 4 n-word-bytes))
+ (inst ld a5 args (* 5 n-word-bytes))
+
+ ;; Calc SRC, DST, and COUNT
+ (inst addcc count nargs (fixnumize (- register-arg-count)))
+ (inst b :le done)
+ (inst add src args (* n-word-bytes register-arg-count))
+ (inst add dst cfp-tn (* n-word-bytes register-arg-count))
+
+ LOOP
+ ;; Copy one arg.
+ (inst ld temp src)
+ (inst add src src n-word-bytes)
+ (inst st temp dst)
+ (inst addcc count (fixnumize -1))
+ (inst b :gt loop)
+ (inst add dst dst n-word-bytes)
+
+ DONE
+ ;; We are done. Do the jump.
+ (loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
+ (lisp-jump temp))
+
+
+\f
+;;;; 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 *current-unwind-protect-block*)
+ (loadw target-uwp block 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 unwind-block-current-cont-slot)
+ (loadw code-tn cur-uwp unwind-block-current-code-slot)
+ (loadw lra cur-uwp unwind-block-entry-pc-slot)
+ (lisp-return lra :frob-code nil)
+
+ DO-UWP
+
+ (loadw next-uwp cur-uwp unwind-block-current-uwp-slot)
+ (inst b do-exit)
+ (store-symbol-value next-uwp *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 *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 catch-block-tag-slot)
+ (inst cmp tag target)
+ (inst b :eq exit)
+ (inst nop)
+ (loadw catch catch 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))
+
+
--- /dev/null
+;;;; the machine-specific support routines needed by the file assembler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(!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)
+ :offset lip-offset)
+ 8)
+ (inst nop)))
+ (:full-call
+ `((lisp-return (make-random-tn :kind :normal
+ :sc (sc-or-lose 'descriptor-reg)
+ :offset lra-offset)
+ :offset 2)))
+ (:none)))
;;; FIXME: Whether COERCE actually knows how to make a float out of a
;;; long is another question. This stuff still needs testing.
-(define-alien-routine ("os_context_fpregister_addr"
+(define-alien-routine ("os_context_float_register_addr"
context-float-register-addr)
(* long)
(context (* os-context-t))
;; Barlow's Alpha patches suppress it for Alpha. Why the difference?
#!+alpha
(set-floating-point-modes :traps '(:overflow
- #!-x86 :underflow
+ #!+alpha :underflow
:invalid
:divide-by-zero))
;; disabled by default. Joe User can
;; explicitly enable them if
;; desired.
- #!-x86 :underflow))
+ #!+alpha :underflow))
;; Clear pseudo atomic in case this core wasn't compiled with
;; support.
;;
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+;;; SC-OFFSETs are needed by sparc-vm.lisp
+
+(in-package "SB!C")
+\f
+;;;; SC-OFFSETs
+;;;;
+;;;; We represent the place where some value is stored with a SC-OFFSET,
+;;;; which is the SC number and offset encoded as an integer.
+
+(defconstant-eqx sc-offset-scn-byte (byte 5 0) #'equalp)
+(defconstant-eqx sc-offset-offset-byte (byte 22 5) #'equalp)
+(def!type sc-offset () '(unsigned-byte 27))
+
+(defmacro make-sc-offset (scn offset)
+ `(dpb ,scn sc-offset-scn-byte
+ (dpb ,offset sc-offset-offset-byte 0)))
+
+(defmacro sc-offset-scn (sco) `(ldb sc-offset-scn-byte ,sco))
+(defmacro sc-offset-offset (sco) `(ldb sc-offset-offset-byte ,sco))
--- /dev/null
+;;;; SPARC-specific runtime stuff
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+(in-package "SB!VM")
+
+\f
+
+;;; See x86-vm.lisp for a description of this.
+(define-alien-type os-context-t (struct os-context-t-struct))
+
+
+\f
+;;;; MACHINE-TYPE and MACHINE-VERSION
+
+(defun machine-type ()
+ "Returns a string describing the type of the local machine."
+ "SPARC")
+
+(defun machine-version ()
+ "Returns a string describing the version of the local machine."
+ "SPARC")
+
+\f
+(defun fixup-code-object (code offset fixup kind)
+ (declare (type index offset))
+ (unless (zerop (rem offset n-word-bytes))
+ (error "Unaligned instruction? offset=#x~X." offset))
+ (sb!sys:without-gcing
+ (let ((sap (truly-the system-area-pointer
+ (%primitive sb!kernel::code-instructions code))))
+ (ecase kind
+ (:call
+ (error "Can't deal with CALL fixups, yet."))
+ (:sethi
+ (setf (ldb (byte 22 0) (sap-ref-32 sap offset))
+ (ldb (byte 22 10) fixup)))
+ (:add
+ (setf (ldb (byte 10 0) (sap-ref-32 sap offset))
+ (ldb (byte 10 0) fixup)))))))
+
+\f
+;;;; "Sigcontext" access functions, cut & pasted from alpha-vm.lisp.
+;;;;
+;;;; See also x86-vm for commentary on signed vs unsigned.
+
+(define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int)
+ (context (* os-context-t)))
+
+(defun context-pc (context)
+ (declare (type (alien (* os-context-t)) context))
+ (int-sap (deref (context-pc-addr context))))
+
+(define-alien-routine ("os_context_register_addr" context-register-addr)
+ (* unsigned-int)
+ (context (* os-context-t))
+ (index int))
+
+;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
+;;; (Are they used in anything time-critical, or just the debugger?)
+(defun context-register (context index)
+ (declare (type (alien (* os-context-t)) context))
+ (deref (context-register-addr context index)))
+
+(defun %set-context-register (context index new)
+(declare (type (alien (* os-context-t)) context))
+(setf (deref (context-register-addr context index))
+ new))
+
+;;; This is like CONTEXT-REGISTER, but returns the value of a float
+;;; register. FORMAT is the type of float to return.
+
+;;; FIXME: Whether COERCE actually knows how to make a float out of a
+;;; long is another question. This stuff still needs testing.
+#+nil
+(define-alien-routine ("os_context_float_register_addr" context-float-register-addr)
+ (* long)
+ (context (* os-context-t))
+ (index int))
+#+nil
+(defun context-float-register (context index format)
+ (declare (type (alien (* os-context-t)) context))
+ (coerce (deref (context-float-register-addr context index)) format))
+#+nil
+(defun %set-context-float-register (context index format new)
+ (declare (type (alien (* os-context-t)) context))
+ (setf (deref (context-float-register-addr context index))
+ (coerce new format)))
+
+;;; Given a signal context, return the floating point modes word in
+;;; the same format as returned by FLOATING-POINT-MODES.
+(defun context-floating-point-modes (context)
+ ;; FIXME: As of sbcl-0.6.7 and the big rewrite of signal handling for
+ ;; POSIXness and (at the Lisp level) opaque signal contexts,
+ ;; this is stubified. It needs to be rewritten as an
+ ;; alien function.
+ (warn "stub CONTEXT-FLOATING-POINT-MODES")
+ ;; old code for Linux:
+ #+nil
+ (let ((cw (slot (deref (slot context 'fpstate) 0) 'cw))
+ (sw (slot (deref (slot context 'fpstate) 0) 'sw)))
+ ;;(format t "cw = ~4X~%sw = ~4X~%" cw sw)
+ ;; NOT TESTED -- Clear sticky bits to clear interrupt condition.
+ (setf (slot (deref (slot context 'fpstate) 0) 'sw) (logandc2 sw #x3f))
+ ;;(format t "new sw = ~X~%" (slot (deref (slot context 'fpstate) 0) 'sw))
+ ;; Simulate floating-point-modes VOP.
+ (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f)))
+
+ 0)
+\f
+;;;; INTERNAL-ERROR-ARGS.
+
+;;; Given a (POSIX) signal context, extract the internal error
+;;; arguments from the instruction stream. This is e.g.
+;;; 4 23 254 240 2 0 0 0
+;;; | ~~~~~~~~~~~~~~~~~~~~~~~~~
+;;; length data (everything is an octet)
+;;; (pc)
+(defun internal-error-args (context)
+ (declare (type (alien (* os-context-t)) context))
+ (sb!int::/show0 "entering INTERNAL-ERROR-ARGS")
+ (let* ((pc (context-pc context))
+ (bad-inst (sap-ref-32 pc 0))
+ (op (ldb (byte 2 30) bad-inst))
+ (op2 (ldb (byte 3 22) bad-inst))
+ (op3 (ldb (byte 6 19) bad-inst)))
+ (declare (type system-area-pointer pc))
+ (cond ((and (= op #b00) (= op2 #b000))
+ (args-for-unimp-inst context))
+ ((and (= op #b10) (= (ldb (byte 4 2) op3) #b1000))
+ (args-for-tagged-add-inst context bad-inst))
+ ((and (= op #b10) (= op3 #b111010))
+ (args-for-tcc-inst bad-inst))
+ (t
+ (values #.(error-number-or-lose 'unknown-error) nil)))))
+
+(defun args-for-unimp-inst (context)
+ (declare (type (alien (* os-context-t)) context))
+ (let* ((pc (context-pc context))
+ (length (sap-ref-8 pc 4))
+ (vector (make-array length :element-type '(unsigned-byte 8))))
+ (declare (type system-area-pointer pc)
+ (type (unsigned-byte 8) length)
+ (type (simple-array (unsigned-byte 8) (*)) vector))
+ (copy-from-system-area pc (* n-byte-bits 5)
+ vector (* n-word-bits
+ vector-data-offset)
+ (* length n-byte-bits))
+ (let* ((index 0)
+ (error-number (sb!c::read-var-integer vector index)))
+ (collect ((sc-offsets))
+ (loop
+ (when (>= index length)
+ (return))
+ (sc-offsets (sb!c::read-var-integer vector index)))
+ (values error-number (sc-offsets))))))
+
+(defun args-for-tagged-add-inst (context bad-inst)
+ (declare (type (alien (* os-context-t)) context))
+ (let* ((rs1 (ldb (byte 5 14) bad-inst))
+ (op1 (sb!kernel:make-lisp-obj (context-register context rs1))))
+ (if (fixnump op1)
+ (if (zerop (ldb (byte 1 13) bad-inst))
+ (let* ((rs2 (ldb (byte 5 0) bad-inst))
+ (op2 (sb!kernel:make-lisp-obj (context-register context rs2))))
+ (if (fixnump op2)
+ (values #.(error-number-or-lose 'unknown-error) nil)
+ (values #.(error-number-or-lose 'object-not-fixnum-error)
+ (list (sb!c::make-sc-offset
+ descriptor-reg-sc-number
+ rs2)))))
+ (values #.(error-number-or-lose 'unknown-error) nil))
+ (values #.(error-number-or-lose 'object-not-fixnum-error)
+ (list (sb!c::make-sc-offset descriptor-reg-sc-number
+ rs1))))))
+
+(defun args-for-tcc-inst (bad-inst)
+ (let* ((trap-number (ldb (byte 8 0) bad-inst))
+ (reg (ldb (byte 5 8) bad-inst)))
+ (values (case trap-number
+ (#.object-not-list-trap
+ #.(error-number-or-lose 'object-not-list-error))
+ (#.object-not-instance-trap
+ #.(error-number-or-lose 'object-not-instance-error))
+ (t
+ #.(error-number-or-lose 'unknown-error)))
+ (list (sb!c::make-sc-offset descriptor-reg-sc-number reg)))))
+
+\f
+;;; Do whatever is necessary to make the given code component
+;;; executable. On the sparc, we don't need to do anything, because
+;;; the i and d caches are unified.
+(defun sanctify-for-execution (component)
+ (declare (ignore component))
+ nil)
;; boxing.
(rehash-threshold (float rehash-threshold 1.0))
(size+1 (1+ size)) ; The first element is not usable.
- (scaled-size (round (/ (float size+1) rehash-threshold)))
+ ;; KLUDGE: The most natural way of expressing the below is
+ ;; (round (/ (float size+1) rehash-threshold)), and indeed
+ ;; it was expressed like that until 0.7.0. However,
+ ;; MAKE-HASH-TABLE is called very early in cold-init, and
+ ;; the SPARC has no primitive instructions for rounding,
+ ;; but only for truncating; therefore, we fudge this issue
+ ;; a little. The other uses of truncate, below, similarly
+ ;; used to be round. -- CSR, 2002-10-01
+ ;;
+ ;; Note that this has not yet been audited for
+ ;; correctness. It just seems to work. -- CSR, 2002-11-02
+ (scaled-size (truncate (/ (float size+1) rehash-threshold)))
(length (almost-primify (max scaled-size
(1+ +min-hash-table-size+))))
(index-vector (make-array length
(fixnum
(+ rehash-size old-size))
(float
- (the index (round (* rehash-size old-size)))))))
+ (the index (truncate (* rehash-size old-size)))))))
(new-kv-vector (make-array (* 2 new-size)
:initial-element +empty-ht-slot+))
(new-next-vector (make-array new-size
:initial-element #x80000000)))
(old-index-vector (hash-table-index-vector table))
(new-length (almost-primify
- (round (/ (float new-size)
+ (truncate (/ (float new-size)
(hash-table-rehash-threshold table)))))
(new-index-vector (make-array new-length
:element-type '(unsigned-byte 32)
\f
;;;; general warm init compilation policy
+;;; Without generational GC, GC gets really slow unless we collect in
+;;; large chunks. For small chunks, efficiency tends to grow roughly
+;;; linearly with chunk size. Later we hit diminishing returns as we
+;;; approach the total amount of RAM we use, or we can even get into
+;;; performance trouble by clobbering cache and VM systems too hard.
+;;; But modern machines tend to think of 20 Mb as a moderate amount of
+;;; memory, and it's of the same order of magnitude as the amount of
+;;; RAM we need for the build, so it seems like a plausible chunk size.
+#-gencgc
+(progn
+ (sb!ext:gc-off)
+ (setf (sb!ext:bytes-consed-between-gcs) (* 20 (expt 10 6)))
+ (sb!ext:gc-on))
+
(proclaim '(optimize (compilation-speed 1)
(debug #+sb-show 2 #-sb-show 1)
(inhibit-warnings 2)
(defknown alien-funcall (alien-value &rest *) *
(any recursive))
-(defknown %alien-funcall (system-area-pointer alien-type &rest *) *)
\f
;;;; cosmetic transforms
(t
(sub-dump-object obj file))))))
+;;; In the grand scheme of things I don't pretend to understand any
+;;; more how this works, or indeed whether. But to write out specialized
+;;; vectors in the same format as fop-int-vector expects to read them
+;;; we need to be target-endian. dump-integer-as-n-bytes always writes
+;;; little-endian (which is correct for all other integers) so for a bigendian
+;;; target we need to swap octets -- CSR, after DB
+
+(defun octet-swap (word bits)
+ "BITS must be a multiple of 8"
+ (do ((input word (ash input -8))
+ (output 0 (logior (ash output 8) (logand input #xff)))
+ (bits bits (- bits 8)))
+ ((<= bits 0) output)))
+
(defun dump-i-vector (vec file &key data-only)
(declare (type (simple-array * (*)) vec))
(let ((len (length vec)))
(multiple-value-bind (floor rem) (floor size 8)
(aver (zerop rem))
(dovector (i vec)
- (dump-integer-as-n-bytes i floor file))))
+ (dump-integer-as-n-bytes
+ (ecase sb!c:*backend-byte-order*
+ (:little-endian i)
+ (:big-endian (octet-swap i size)))
+ floor file))))
(t ; harder cases, not supported in cross-compiler
(dump-raw-bytes vec bytes file))))
(dump-signed-vector (size bytes)
--- /dev/null
+(in-package "SB!C")
+
+(defknown %alien-funcall (system-area-pointer alien-type &rest *) *)
(n)
(let* ((name (intern (format nil "BYTE-VECTOR-REF-~A" n)))
(number-octets (/ n 8))
- (ash-list
+ (ash-list-le
(loop for i from 0 to (1- number-octets)
collect `(ash (aref byte-vector (+ byte-index ,i))
,(* i 8))))
- (setf-list
+ (ash-list-be
+ (loop for i from 0 to (1- number-octets)
+ collect `(ash (aref byte-vector (+ byte-index
+ ,(- number-octets 1 i)))
+ ,(* i 8))))
+ (setf-list-le
(loop for i from 0 to (1- number-octets)
append
`((aref byte-vector (+ byte-index ,i))
- (ldb (byte 8 ,(* i 8)) new-value)))))
+ (ldb (byte 8 ,(* i 8)) new-value))))
+ (setf-list-be
+ (loop for i from 0 to (1- number-octets)
+ append
+ `((aref byte-vector (+ byte-index ,i))
+ (ldb (byte 8 ,(- n 8 (* i 8))) new-value)))))
`(progn
(defun ,name (byte-vector byte-index)
- (aver (= sb!vm:n-word-bits 32))
- (aver (= sb!vm:n-byte-bits 8))
- (ecase sb!c:*backend-byte-order*
- (:little-endian
- (logior ,@ash-list))
- (:big-endian
- (error "stub: no big-endian ports of SBCL (yet?)"))))
- (defun (setf ,name) (new-value byte-vector byte-index)
- (aver (= sb!vm:n-word-bits 32))
- (aver (= sb!vm:n-byte-bits 8))
- (ecase sb!c:*backend-byte-order*
- (:little-endian
- (setf ,@setf-list))
- (:big-endian
- (error "stub: no big-endian ports of SBCL (yet?)"))))))))
+ (aver (= sb!vm:n-word-bits 32))
+ (aver (= sb!vm:n-byte-bits 8))
+ (logior ,@(ecase sb!c:*backend-byte-order*
+ (:little-endian ash-list-le)
+ (:big-endian ash-list-be))))
+ (defun (setf ,name) (new-value byte-vector byte-index)
+ (aver (= sb!vm:n-word-bits 32))
+ (aver (= sb!vm:n-byte-bits 8))
+ (setf ,@(ecase sb!c:*backend-byte-order*
+ (:little-endian setf-list-le)
+ (:big-endian setf-list-be))))))))
(make-byte-vector-ref-n 8)
(make-byte-vector-ref-n 16)
(make-byte-vector-ref-n 32))
(ldb (byte 8 0) value)
(byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset))
(ldb (byte 8 8) value)))))
+ (:sparc
+ (ecase kind
+ (:call
+ (error "Can't deal with call fixups yet."))
+ (:sethi
+ (setf (byte-vector-ref-32 gspace-bytes gspace-byte-offset)
+ (dpb (ldb (byte 22 10) value)
+ (byte 22 0)
+ (byte-vector-ref-32 gspace-bytes gspace-byte-offset))))
+ (:add
+ (setf (byte-vector-ref-32 gspace-bytes gspace-byte-offset)
+ (dpb (ldb (byte 10 0) value)
+ (byte 10 0)
+ (byte-vector-ref-32 gspace-bytes gspace-byte-offset))))))
(:x86
(let* ((un-fixed-up (byte-vector-ref-32 gspace-bytes
gspace-byte-offset))
sb!vm:static-space-start))
(*dynamic* (make-gspace :dynamic
dynamic-space-id
- sb!vm:dynamic-space-start))
+ #!+gencgc sb!vm:dynamic-space-start
+ #!-gencgc sb!vm:dynamic-0-space-start))
(*nil-descriptor* (make-nil-descriptor))
(*current-reversed-cold-toplevels* *nil-descriptor*)
(*unbound-marker* (make-other-immediate-descriptor
--- /dev/null
+;;;; allocation VOPs for the Sparc port
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; 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)
+ (:info num)
+ (: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 (:extra alloc)
+ (inst andn res alloc-tn lowtag-mask)
+ (inst or res list-pointer-lowtag)
+ (move ptr res)
+ (dotimes (i (1- cons-cells))
+ (storew (maybe-load (tn-ref-tn things)) ptr
+ cons-car-slot list-pointer-lowtag)
+ (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-lowtag))
+ (storew (maybe-load (tn-ref-tn things)) ptr
+ cons-car-slot list-pointer-lowtag)
+ (storew (if star
+ (maybe-load (tn-ref-tn (tn-ref-across things)))
+ null-tn)
+ ptr cons-cdr-slot list-pointer-lowtag))
+ (move result res)))))))
+
+(define-vop (list list-or-list*)
+ (:variant nil))
+
+(define-vop (list* list-or-list*)
+ (:variant t))
+
+\f
+;;;; 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 (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 srl unboxed unboxed-arg word-shift)
+ (inst add unboxed lowtag-mask)
+ (inst and unboxed (lognot lowtag-mask))
+ (pseudo-atomic ()
+ ;; CMUCL Comment:
+ ;; Note: we don't have to subtract off the 4 that was added by
+ ;; pseudo-atomic, because oring in other-pointer-lowtag just adds
+ ;; it right back.
+ ;;
+ ;; This looks like another dreadful type pun. CSR - 2002-02-06
+ (inst or result alloc-tn other-pointer-lowtag)
+ (inst add alloc-tn boxed)
+ (inst add alloc-tn unboxed)
+ (inst sll ndescr boxed (- n-widetag-bits word-shift))
+ (inst or ndescr code-header-widetag)
+ (storew ndescr result 0 other-pointer-lowtag)
+ (storew unboxed result code-code-size-slot other-pointer-lowtag)
+ (storew null-tn result code-entry-points-slot other-pointer-lowtag)
+ (storew null-tn result code-debug-info-slot other-pointer-lowtag))))
+
+(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-widetag fdefn-size)
+ (inst li temp (make-fixup (extern-alien-name "undefined_tramp") :foreign))
+ (storew name result fdefn-name-slot other-pointer-lowtag)
+ (storew null-tn result fdefn-fun-slot other-pointer-lowtag)
+ (storew temp result fdefn-raw-addr-slot other-pointer-lowtag))))
+
+
+(define-vop (make-closure)
+ (:args (function :to :save :scs (descriptor-reg)))
+ (:info length)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 10
+ (let ((size (+ length closure-info-offset)))
+ (pseudo-atomic (:extra (pad-data-block size))
+ (inst andn result alloc-tn lowtag-mask)
+ (inst or result fun-pointer-lowtag)
+ (inst li temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
+ (storew temp result 0 fun-pointer-lowtag)))
+ (storew function result closure-fun-slot fun-pointer-lowtag)))
+
+;;; 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-widetag value-cell-size))
+ (storew value result value-cell-value-slot other-pointer-lowtag)))
+
+
+\f
+;;;; Automatic allocators for primitive objects.
+
+(define-vop (make-unbound-marker)
+ (:args)
+ (:results (result :scs (any-reg)))
+ (:generator 1
+ (inst li result unbound-marker-widetag)))
+
+(define-vop (fixed-alloc)
+ (:args)
+ (:info name words type lowtag)
+ (:ignore name)
+ (:results (result :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 4
+ (pseudo-atomic (:extra (pad-data-block words))
+ (cond ((logbitp (1- n-lowtag-bits) lowtag)
+ (inst or result alloc-tn lowtag))
+ (t
+ (inst andn result alloc-tn lowtag-mask)
+ (inst or result lowtag)))
+ (when type
+ (inst li temp (logior (ash (1- words) n-widetag-bits) type))
+ (storew temp result 0 lowtag)))))
+
+(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 header)
+ (:generator 6
+ (inst add bytes extra (* (1+ words) n-word-bytes))
+ (inst sll header bytes (- n-widetag-bits 2))
+ (inst add header header (+ (ash -2 n-widetag-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.
+ (cond ((logbitp (1- n-lowtag-bits) lowtag)
+ (inst or result alloc-tn lowtag))
+ (t
+ (inst andn result alloc-tn lowtag-mask)
+ (inst or result lowtag)))
+ (storew header result 0 lowtag)
+ (inst add alloc-tn alloc-tn bytes))))
--- /dev/null
+;;;; the VM definition arithmetic VOPs for the Alpha
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; 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 "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 "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)))
+\f
+;;;; 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 "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 "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 "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 11) (not (integer 0 0)))))
+ (:results (r :scs (any-reg)))
+ (:result-types tagged-num)
+ (:note "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 "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 "inline (signed-byte 32) arithmetic"))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defmacro define-binop (translate untagged-penalty op)
+ `(progn
+ (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
+ fast-fixnum-binop)
+ (:translate ,translate)
+ (:generator 2
+ (inst ,op r x y)))
+ (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
+ fast-fixnum-binop-c)
+ (:translate ,translate)
+ (:generator 1
+ (inst ,op r x (fixnumize y))))
+ (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
+ fast-signed-binop)
+ (:translate ,translate)
+ (:generator ,(1+ untagged-penalty)
+ (inst ,op r x y)))
+ (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)
+ (inst ,op r x y)))
+ (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 logandc2 2 andn)
+(define-binop logior 2 or)
+(define-binop logorc2 2 orn)
+(define-binop logxor 2 xor)
+(define-binop logeqv 2 xnor)
+
+;;; Special logand cases: (logand signed unsigned) => unsigned
+
+(define-vop (fast-logand/signed-unsigned=>unsigned
+ fast-logand/unsigned=>unsigned)
+ (:args (x :target r :scs (signed-reg))
+ (y :scs (unsigned-reg unsigned-stack)))
+ (: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 signed-stack)))
+ (:arg-types unsigned-num signed-num))
+
+;;; 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 "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 "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 "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 "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 "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 :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
+ #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
+ (: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 "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 :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
+ #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
+ (: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 "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 :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
+ #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
+ (: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)))))
+
+#!+:sparc-v9
+(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 "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 #!+:sparc-64 t #!-:sparc-64 nil)
+ (: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)
+ ;; Sign extend the numbers, just in case.
+ (inst sra x 0)
+ (inst sra y 0)
+ (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 "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 #!+:sparc-64 t #!-:sparc-64 nil)
+ (: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)
+ ;; Zap the higher 32 bits, just in case
+ (inst srl x 0)
+ (inst srl y 0)
+ (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
+
+(macrolet
+ ((frob (name sc-type type shift-right-inst)
+ `(define-vop (,name)
+ (:note "inline ASH")
+ (:args (number :scs (,sc-type) :to :save)
+ (amount :scs (signed-reg immediate)))
+ (:arg-types ,type signed-num)
+ (:results (result :scs (,sc-type)))
+ (:result-types ,type)
+ (:translate ash)
+ (:policy :fast-safe)
+ (:temporary (:sc non-descriptor-reg) ndesc)
+ (:generator 5
+ (sc-case amount
+ #!+:sparc-v9
+ (signed-reg
+ (let ((done (gen-label))
+ (positive (gen-label)))
+ (inst cmp amount)
+ (inst b :ge positive)
+ (inst neg ndesc amount)
+ ;; ndesc = max(-amount, 31)
+ (inst cmp ndesc 31)
+ (inst cmove :ge ndesc 31)
+ (inst b done)
+ (inst ,shift-right-inst result number ndesc)
+ (emit-label positive)
+ ;; The result-type assures us that this shift will not
+ ;; overflow.
+ (inst sll result number amount)
+ ;; We want a right shift of the appropriate size.
+ (emit-label done)))
+ #!-:sparc-v9
+ (signed-reg
+ (let ((positive (gen-label))
+ (done (gen-label)))
+ (inst cmp amount)
+ (inst b :ge positive)
+ (inst neg ndesc amount)
+ (inst cmp ndesc 31)
+ (inst b :le done)
+ (inst ,shift-right-inst result number ndesc)
+ (inst b done)
+ (inst ,shift-right-inst result number 31)
+
+ (emit-label positive)
+ ;; The result-type assures us that this shift will not overflow.
+ (inst sll result number amount)
+
+ (emit-label done)))
+ (immediate
+ (let ((amount (tn-value amount)))
+ (if (minusp amount)
+ (let ((amount (min 31 (- amount))))
+ (inst ,shift-right-inst result number amount))
+ (inst sll result number amount)))))))))
+ (frob fast-ash/signed=>signed signed-reg signed-num sra)
+ (frob fast-ash/unsigned=>unsigned unsigned-reg unsigned-num srl))
+
+;; 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 "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 sll result number amount))
+ (immediate
+ (let ((amount (tn-value amount)))
+ (assert (>= amount 0))
+ (inst sll 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))
+
+(defknown ash-right-signed ((signed-byte #.sb!vm:n-word-bits)
+ (and fixnum unsigned-byte))
+ (signed-byte #.sb!vm:n-word-bits)
+ (movable foldable flushable))
+
+(defknown ash-right-unsigned ((unsigned-byte #.sb!vm:n-word-bits)
+ (and fixnum unsigned-byte))
+ (unsigned-byte #.sb!vm:n-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 "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))
+
+(define-vop (fast-ash-right/fixnum=>fixnum)
+ (:note "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 sra temp number amount))
+ (immediate
+ (inst sra temp number (tn-value amount))))
+ (inst andn result temp fixnum-tag-mask)))
+
+
+
+\f
+(define-vop (signed-byte-32-len)
+ (:translate integer-length)
+ (:note "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 srl shift 1))))
+
+(define-vop (unsigned-byte-32-count)
+ (:translate logcount)
+ (:note "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 sethi mask (ldb (byte 22 10) bit-mask))
+ (inst add mask (ldb (byte 10 0) bit-mask))
+
+ (inst and temp res mask)
+ (inst srl 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 :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
+ #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
+ (: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 sra temp y fixnum-tag-bits)
+ (inst smul r x temp)))
+
+(define-vop (fast-v8-*/signed=>signed fast-signed-binop)
+ (:translate *)
+ (:guard #!+(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
+ #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
+ (:generator 3
+ (inst smul r x y)))
+
+(define-vop (fast-v8-*/unsigned=>unsigned fast-unsigned-binop)
+ (:translate *)
+ (:guard #!+(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
+ #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
+ (: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 #!+:sparc-64 t #!-:sparc-64 nil)
+ (:generator 4
+ (inst sra temp y fixnum-tag-bits)
+ (inst mulx r x temp)))
+
+(define-vop (fast-v9-*/signed=>signed fast-signed-binop)
+ (:translate *)
+ (:guard #!+:sparc-64 t #!-:sparc-64 nil)
+ (:generator 3
+ (inst mulx r x y)))
+
+(define-vop (fast-v9-*/unsigned=>unsigned fast-unsigned-binop)
+ (:translate *)
+ (:guard #!+:sparc-64 t #!-:sparc-64 nil)
+ (:generator 3
+ (inst mulx r x y)))
+
+\f
+;;;; 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 "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 "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 11)))
+ (: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 "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 "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 "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)))
+ (:arg-types tagged-num (:constant (signed-byte 11)))
+ (: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)
+ (:arg-types * (:constant (signed-byte 11)))
+ (:variant-cost 6))
+
+\f
+;;;; 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 srl res next shift)
+ (inst sub temp zero-tn shift)
+ (inst sll 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 "shift-towards-start")
+ (:generator 1
+ (inst sll r num amount)))
+
+(define-vop (shift-towards-end shift-towards-someplace)
+ (:translate shift-towards-end)
+ (:note "shift-towards-end")
+ (:generator 1
+ (inst srl r num amount)))
+
+
+
+\f
+;;;; Bignum stuff.
+
+(define-vop (bignum-length get-header-data)
+ (:translate sb!bignum::%bignum-length)
+ (:policy :fast-safe))
+
+(define-vop (bignum-set-length set-header-data)
+ (:translate sb!bignum::%bignum-set-length)
+ (:policy :fast-safe))
+
+(define-vop (bignum-ref word-index-ref)
+ (:variant bignum-digits-offset other-pointer-lowtag)
+ (:translate sb!bignum::%bignum-ref)
+ (:results (value :scs (unsigned-reg)))
+ (:result-types unsigned-num))
+
+(define-vop (bignum-set word-index-set)
+ (:variant bignum-digits-offset other-pointer-lowtag)
+ (:translate sb!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 sb!bignum::%digit-0-or-plusp)
+ (:policy :fast-safe)
+ (:args (digit :scs (unsigned-reg)))
+ (:arg-types unsigned-num)
+ (:results (result :scs (descriptor-reg)))
+ (:guard #!-:sparc-v9 t #!+:sparc-v9 nil)
+ (: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 sb!bignum::%digit-0-or-plusp)
+ (:policy :fast-safe)
+ (:args (digit :scs (unsigned-reg)))
+ (:arg-types unsigned-num)
+ (:results (result :scs (descriptor-reg)))
+ (:guard #!+:sparc-v9 t #!-:sparc-v9 nil)
+ (: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 sb!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 #!+:sparc-v9 t #!-:sparc-v9 nil)
+ (: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 sb!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 sb!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.
+ #!+:sparc-64
+ (progn
+ ;; Take advantage of V9's 64-bit multiplier.
+ ;;
+ ;; Make sure the multiplier and multiplicand are really
+ ;; unsigned 64-bit numbers.
+ (inst srl multiplier 0)
+ (inst srl multiplicand 0)
+
+ ;; 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))
+ #!+(and (not :sparc-64) (or :sparc-v8 :sparc-v9))
+ (progn
+ ;; 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))
+ #!+(and (not :sparc-64) (not (or :sparc-v8 :sparc-v9)))
+ (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 sb!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 sb!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 sb!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 sb!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 sb!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 sra digit fixnum fixnum-tag-bits)))
+
+(define-vop (bignum-floor)
+ (:translate sb!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 :sparc-v8 :sparc-v9)) t
+ #!-(not (or :sparc-v8 :sparc-v9)) nil)
+ (: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 sb!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 :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
+ #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
+ (: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 sb!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 #!+:sparc-64 t #!-:sparc-64 nil)
+ (: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 sb!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 sll res digit fixnum-tag-bits))
+ (signed-reg
+ (move res digit)))))
+
+
+(define-vop (digit-ashr)
+ (:translate sb!bignum::%ashr)
+ (:policy :fast-safe)
+ (:args (digit :scs (unsigned-reg))
+ (count :scs (unsigned-reg)))
+ (:arg-types unsigned-num positive-fixnum)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:generator 1
+ (inst sra result digit count)))
+
+(define-vop (digit-lshr digit-ashr)
+ (:translate sb!bignum::%digit-logical-shift-right)
+ (:generator 1
+ (inst srl result digit count)))
+
+(define-vop (digit-ashl digit-ashr)
+ (:translate sb!bignum::%ashl)
+ (:generator 1
+ (inst sll result digit count)))
+
+\f
+;;;; Static functions.
+
+(define-static-fun two-arg-gcd (x y) :translate gcd)
+(define-static-fun two-arg-lcm (x y) :translate lcm)
+
+(define-static-fun two-arg-+ (x y) :translate +)
+(define-static-fun two-arg-- (x y) :translate -)
+(define-static-fun two-arg-* (x y) :translate *)
+(define-static-fun two-arg-/ (x y) :translate /)
+
+(define-static-fun two-arg-< (x y) :translate <)
+(define-static-fun two-arg-<= (x y) :translate <=)
+(define-static-fun two-arg-> (x y) :translate >)
+(define-static-fun two-arg->= (x y) :translate >=)
+(define-static-fun two-arg-= (x y) :translate =)
+(define-static-fun two-arg-/= (x y) :translate /=)
+
+(define-static-fun %negate (x) :translate %negate)
+
+(define-static-fun two-arg-and (x y) :translate logand)
+(define-static-fun two-arg-ior (x y) :translate logior)
+(define-static-fun two-arg-xor (x y) :translate logxor)
+
+\f
+;; Need these so constant folding works with the deftransform.
+
+(defun ash-right-signed (num shift)
+ (declare (type (signed-byte #.sb!vm:n-word-bits) num)
+ (type (integer 0 #.(1- sb!vm:n-word-bits)) shift))
+ (ash-right-signed num shift))
+
+(defun ash-right-unsigned (num shift)
+ (declare (type (unsigned-byte #.sb!vm:n-word-bits) num)
+ (type (integer 0 #.(1- sb!vm:n-word-bits)) shift))
+ (ash-right-unsigned 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 "SB!C")
+
+(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-ir1-transform))
+
+ ;; 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 #.sb!vm:n-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 sb!vm:n-word-bits) 0)))
+ ;; FIXME: ash-right-{un,}signed package problems
+ `(sb!vm::ash-right-signed num (- shift))
+ `(sb!vm::ash-right-signed num (min (- shift) #.(1- sb!vm:n-word-bits)))))
+ ((csubtypep num-type (specifier-type '(unsigned-byte #.sb!vm:n-word-bits)))
+ (if (csubtypep shift-type (specifier-type '(integer #.(- 1 sb!vm:n-word-bits) 0)))
+ `(sb!vm::ash-right-unsigned num (- shift))
+ `(if (<= shift #.(- sb!vm:n-word-bits))
+ 0
+ (sb!vm::ash-right-unsigned num (- shift)))))
+ (t
+ (give-up-ir1-transform)))))
+
--- /dev/null
+;;;; the Sparc definitions for array operations
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; 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)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 0
+ (pseudo-atomic ()
+ (inst or header alloc-tn other-pointer-lowtag)
+ (inst add ndescr rank (* (1+ array-dimensions-offset) n-word-bytes))
+ (inst andn ndescr 4)
+ (inst add alloc-tn ndescr)
+ (inst add ndescr rank (fixnumize (1- array-dimensions-offset)))
+ (inst sll ndescr ndescr n-widetag-bits)
+ (inst or ndescr ndescr type)
+ ;; Remove the extraneous fixnum tag bits because TYPE and RANK
+ ;; were fixnums
+ (inst srl ndescr ndescr fixnum-tag-bits)
+ (storew ndescr header 0 other-pointer-lowtag))
+ (move result header)))
+
+\f
+;;;; Additional accessors and setters for the array header.
+
+(defknown sb!impl::%array-dimension (t fixnum) fixnum
+ (flushable))
+(defknown sb!impl::%set-array-dimension (t fixnum fixnum) fixnum
+ ())
+
+(define-vop (%array-dimension word-index-ref)
+ (:translate sb!impl::%array-dimension)
+ (:policy :fast-safe)
+ (:variant array-dimensions-offset other-pointer-lowtag))
+
+(define-vop (%set-array-dimension word-index-set)
+ (:translate sb!impl::%set-array-dimension)
+ (:policy :fast-safe)
+ (:variant array-dimensions-offset other-pointer-lowtag))
+
+
+
+(defknown sb!impl::%array-rank (t) fixnum (flushable))
+
+(define-vop (array-rank-vop)
+ (:translate sb!impl::%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 other-pointer-lowtag)
+ (inst sra temp n-widetag-bits)
+ (inst sub temp (1- array-dimensions-offset))
+ (inst sll res temp fixnum-tag-bits)))
+
+
+\f
+;;;; 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))))
+
+
+\f
+;;;; Accessors/Setters
+
+;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos
+;;; elements are represented in integer registers and are built out of
+;;; 8, 16, or 32 bit elements.
+
+(macrolet ((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 "inline array access")
+ (:variant vector-data-offset other-pointer-lowtag)
+ (: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 "inline array store")
+ (:variant vector-data-offset other-pointer-lowtag)
+ (: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)))))
+
+ (def-data-vector-frobs simple-string byte-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)
+) ; MACROLET
+;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit,
+;;; and 4-bit vectors.
+;;;
+
+(macrolet ((def-small-data-vector-frobs (type bits)
+ (let* ((elements-per-word (floor n-word-bits bits))
+ (bit-shift (1- (integer-length elements-per-word))))
+ `(progn
+ (define-vop (,(symbolicate 'data-vector-ref/ type))
+ (:note "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
+ (inst srl temp index ,bit-shift)
+ (inst sll temp fixnum-tag-bits)
+ (inst add temp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst ld result object temp)
+ (inst and temp index ,(1- elements-per-word))
+ (inst xor temp ,(1- elements-per-word))
+ ,@(unless (= bits 1)
+ `((inst sll temp ,(1- (integer-length bits)))))
+ (inst srl result temp)
+ (inst and result ,(1- (ash 1 bits)))
+ (inst sll value result 2)))
+ (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)
+ (setf extra (logxor extra (1- ,elements-per-word)))
+ (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
+ other-pointer-lowtag)))
+ (cond ((typep offset '(signed-byte 13))
+ (inst ld result object offset))
+ (t
+ (inst li temp offset)
+ (inst ld result object temp))))
+ (unless (zerop extra)
+ (inst srl result
+ (logxor (* extra ,bits) ,(1- elements-per-word))))
+ (unless (= extra ,(1- elements-per-word))
+ (inst and result ,(1- (ash 1 bits)))))))
+ (define-vop (,(symbolicate 'data-vector-set/ type))
+ (:note "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 srl offset index ,bit-shift)
+ (inst sll offset fixnum-tag-bits)
+ (inst add offset (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst ld old object offset)
+ (inst and shift index ,(1- elements-per-word))
+ (inst xor shift ,(1- elements-per-word))
+ ,@(unless (= bits 1)
+ `((inst sll 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 sll 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 sll temp shift)
+ (inst or old temp))
+ (inst st 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 vector-data-offset) n-word-bytes)
+ other-pointer-lowtag)))
+ (cond ((typep offset '(signed-byte 13))
+ (inst ld old object offset))
+ (t
+ (inst li offset-reg offset)
+ (inst ld old object offset-reg)))
+ (unless (and (sc-is value immediate)
+ (= (tn-value value) ,(1- (ash 1 bits))))
+ (cond ((zerop extra)
+ (inst sll old ,bits)
+ (inst srl 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 sll temp value
+ (* (logxor extra ,(1- elements-per-word)) ,bits))
+ (inst or old temp)))
+ (if (typep offset '(signed-byte 13))
+ (inst st old object offset)
+ (inst st old object offset-reg)))
+ (sc-case value
+ (immediate
+ (inst li result (tn-value value)))
+ (t
+ (move result value))))))))))
+
+ (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)
+
+) ; MACROLET
+
+
+;;; And the float variants.
+;;;
+
+(define-vop (data-vector-ref/simple-array-single-float)
+ (:note "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 (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst ldf value object offset)))
+
+
+(define-vop (data-vector-set/simple-array-single-float)
+ (:note "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
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst stf value object offset)
+ (unless (location= result value)
+ (inst fmovs result value))))
+
+(define-vop (data-vector-ref/simple-array-double-float)
+ (:note "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 sll offset index 1)
+ (inst add offset (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst lddf value object offset)))
+
+(define-vop (data-vector-set/simple-array-double-float)
+ (:note "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 sll offset index 1)
+ (inst add offset (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst stdf value object offset)
+ (unless (location= result value)
+ (move-double-reg result value))))
+
+#!+long-float
+(define-vop (data-vector-ref/simple-array-long-float)
+ (:note "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 sll offset index 2)
+ (inst add offset (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (load-long-reg value object offset nil)))
+
+#!+long-float
+(define-vop (data-vector-set/simple-array-long-float)
+ (:note "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 sll offset index 2)
+ (inst add offset (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (store-long-reg value object offset nil)
+ (unless (location= result value)
+ (move-long-reg result value))))
+
+\f
+;;;; 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))
+
+\f
+;;;
+(define-vop (data-vector-ref/simple-array-signed-byte-8 signed-byte-index-ref)
+ (:note "inline array access")
+ (:variant vector-data-offset other-pointer-lowtag)
+ (: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 "inline array store")
+ (:variant vector-data-offset other-pointer-lowtag)
+ (: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 "inline array access")
+ (:variant vector-data-offset other-pointer-lowtag)
+ (: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 "inline array store")
+ (:variant vector-data-offset other-pointer-lowtag)
+ (: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))
+
+\f
+;;; Complex float arrays.
+
+(define-vop (data-vector-ref/simple-array-complex-single-float)
+ (:note "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 sll offset index 1)
+ (inst add offset (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst ldf real-tn object offset))
+ (let ((imag-tn (complex-single-reg-imag-tn value)))
+ (inst add offset n-word-bytes)
+ (inst ldf imag-tn object offset))))
+
+(define-vop (data-vector-set/simple-array-complex-single-float)
+ (:note "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 sll offset index 1)
+ (inst add offset (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (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 n-word-bytes)
+ (inst stf value-imag object offset)
+ (unless (location= result-imag value-imag)
+ (inst fmovs result-imag value-imag)))))
+
+(define-vop (data-vector-ref/simple-array-complex-double-float)
+ (:note "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 sll offset index 2)
+ (inst add offset (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst lddf real-tn object offset))
+ (let ((imag-tn (complex-double-reg-imag-tn value)))
+ (inst add offset (* 2 n-word-bytes))
+ (inst lddf imag-tn object offset))))
+
+(define-vop (data-vector-set/simple-array-complex-double-float)
+ (:note "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 sll offset index 2)
+ (inst add offset (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (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 (* 2 n-word-bytes))
+ (inst stdf value-imag object offset)
+ (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 "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 sll offset index 3)
+ (inst add offset (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (load-long-reg real-tn object offset nil))
+ (let ((imag-tn (complex-long-reg-imag-tn value)))
+ (inst add offset (* 4 n-word-bytes))
+ (load-long-reg imag-tn object offset nil))))
+
+#!+long-float
+(define-vop (data-vector-set/simple-array-complex-long-float)
+ (:note "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 sll offset index 3)
+ (inst add offset (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (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 n-word-bytes))
+ (store-long-reg value-imag object offset nil)
+ (unless (location= result-imag value-imag)
+ (move-long-reg result-imag value-imag)))))
+
+\f
+;;; 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))
+;;;
+#!+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))
+;;;
+#!+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 "raw-bits VOP")
+ (:translate %raw-bits)
+ (:results (value :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:variant 0 other-pointer-lowtag))
+
+(define-vop (set-raw-bits word-index-set)
+ (:note "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 other-pointer-lowtag))
--- /dev/null
+;;;; that part of the parms.lisp file from original CMU CL which is
+;;;; defined in terms of the BACKEND structure
+;;;;
+;;;; FIXME: Now that the BACKEND structure has been broken up, this
+;;;; might be mergeable back into the parms.lisp file.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; compiler constants
+
+(defconstant +backend-fasl-file-implementation+ :sparc)
+
+(setf *backend-register-save-penalty* 3)
+
+(setf *backend-byte-order* :big-endian)
+
+(setf *backend-page-size* 8192)
+
--- /dev/null
+;;;; VOPs and other machine-specific support routines for call-out to C
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(defun my-make-wired-tn (prim-type-name sc-name offset)
+ (make-wired-tn (primitive-type-or-lose prim-type-name)
+ (sc-number-or-lose sc-name)
+ 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)))))))
+
+(define-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)))
+
+(define-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)))
+
+(define-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)))))
+
+(define-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))))
+
+(define-alien-type-method (double-float :result-tn) (type state)
+ (declare (ignore type state))
+ (my-make-wired-tn 'double-float 'double-reg 0))
+
+(define-alien-type-method (single-float :result-tn) (type state)
+ (declare (ignore type state))
+ (my-make-wired-tn 'single-float 'single-reg 0))
+
+#!+long-float
+(define-alien-type-method (long-float :result-tn) (type)
+ (declare (ignore type))
+ (my-make-wired-tn 'long-float 'long-reg 0))
+
+(define-alien-type-method (values :result-tn) (type state)
+ (let ((values (alien-values-type-values type)))
+ (when (> (length values) 2)
+ (error "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-fun-type type))
+ (let ((arg-state (make-arg-state)))
+ (collect ((arg-tns))
+ (dolist (arg-type (alien-fun-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) n-word-bytes)
+ (arg-tns)
+ (invoke-alien-type-method
+ :result-tn
+ (alien-fun-type-result-type type)
+ (make-result-state))))))
+
+(deftransform %alien-funcall ((function type &rest args))
+ (assert (sb!c::constant-continuation-p type))
+ (let* ((type (sb!c::continuation-value type))
+ (arg-types (alien-fun-type-arg-types type))
+ (result-type (alien-fun-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)
+ (> (sb!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)
+ (> (sb!alien::alien-integer-type-bits result-type) 32)))
+ (collect ((new-args) (lambda-vars) (new-arg-types))
+ (dolist (type arg-types)
+ (let ((arg (gensym)))
+ (lambda-vars arg)
+ (cond ((and (alien-integer-type-p type)
+ (> (sb!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) (sb!kernel:make-null-lexenv)))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
+ ((alien-single-float-type-p type)
+ (new-args `(single-float-bits ,arg))
+ (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv))))
+ ((alien-double-float-type-p type)
+ (new-args `(double-float-high-bits ,arg))
+ (new-args `(double-float-low-bits ,arg))
+ (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
+ #!+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) (sb!kernel:make-null-lexenv)))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv)))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv)))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
+ (t
+ (new-args arg)
+ (new-arg-types type)))))
+ (cond ((and (alien-integer-type-p result-type)
+ (> (sb!alien::alien-integer-type-bits result-type) 32))
+ (let ((new-result-type
+ (let ((sb!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)))
+ (sb!kernel:make-null-lexenv)))))
+ `(lambda (function type ,@(lambda-vars))
+ (declare (ignore type))
+ (multiple-value-bind (high low)
+ (%alien-funcall function
+ ',(make-alien-fun-type
+ :arg-types (new-arg-types)
+ :result-type new-result-type)
+ ,@(new-args))
+ (logior low (ash high 32))))))
+ (t
+ `(lambda (function type ,@(lambda-vars))
+ (declare (ignore type))
+ (%alien-funcall function
+ ',(make-alien-fun-type
+ :arg-types (new-arg-types)
+ :result-type result-type)
+ ,@(new-args))))))
+ (sb!c::give-up-ir1-transform))))
+
+
+(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 (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)))))))
--- /dev/null
+;;;; the VM definition of function call for the Sparc
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+\f
+;;;; Interfaces to IR2 conversion:
+
+;;; Return a wired TN describing the N'th full call argument passing
+;;; location.
+(!def-vm-support-routine standard-arg-location (n)
+ (declare (type unsigned-byte n))
+ (if (< n register-arg-count)
+ (make-wired-tn *backend-t-primitive-type* register-arg-scn
+ (elt *register-arg-offsets* n))
+ (make-wired-tn *backend-t-primitive-type* control-stack-arg-scn n)))
+
+
+;;; 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 *backend-t-primitive-type* register-arg-scn lra-offset)
+ (make-restricted-tn *backend-t-primitive-type* register-arg-scn)))
+
+;;; 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 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
+ (physenv-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
+ (physenv-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env)
+ (make-wired-tn *backend-t-primitive-type*
+ control-stack-arg-scn
+ lra-save-offset)))
+
+;;; 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-arg-count-location ()
+ (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset))
+
+
+;;; 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)))
+
+(!def-vm-support-routine make-stack-pointer-tn ()
+ (make-normal-tn *fixnum-primitive-type*))
+
+(!def-vm-support-routine make-number-stack-pointer-tn ()
+ (make-normal-tn *fixnum-primitive-type*))
+
+;;; 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*)))
+
+
+;;; 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))))
+ (values))
+\f
+;;;; Frame hackery:
+
+;;; 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)
+ n-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)
+ (: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 n-lowtag-bits)
+ (trace-table-entry trace-table-fun-prologue)
+ (emit-label start-lab)
+ ;; Allocate function header.
+ (inst simple-fun-header-word)
+ (dotimes (i (1- simple-fun-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)
+ ;; Build our stack frames.
+ (inst add csp-tn cfp-tn
+ (* n-word-bytes (sb-allocated-size 'control-stack)))
+ (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)
+ (:generator 2
+ (trace-table-entry trace-table-fun-prologue)
+ (move res csp-tn)
+ (inst add csp-tn csp-tn
+ (* n-word-bytes (sb-allocated-size 'control-stack)))
+ (when (ir2-physenv-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 n-word-bytes)))))
+
+
+
+\f
+;;; 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
+ (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.
+ (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 ld move-temp ocfp-tn (* i n-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-fun-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)))
+ (values))
+
+\f
+;;; 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)))
+ (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-fun-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)))
+ (values))
+
+
+;;; 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))
+
+
+\f
+;;;; 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)))
+
+\f
+;;;; 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-fun-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 (- n-word-bytes other-pointer-lowtag))
+ (move cfp-tn old-fp-temp)
+ (trace-table-entry trace-table-normal)))
+
+\f
+;;;; 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.
+
+;;; 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)
+
+ ,@(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 (:scs (non-descriptor-reg)) temp)
+ (: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)))))
+ (: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)))))
+ (: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))
+ (do-next-filler))
+ (constant
+ (loadw name-pass code-tn (tn-offset name)
+ other-pointer-lowtag)
+ (do-next-filler)))
+ (loadw function name-pass fdefn-raw-addr-slot
+ other-pointer-lowtag)
+ (do-next-filler))
+ `((sc-case arg-fun
+ (descriptor-reg (move lexenv arg-fun))
+ (control-stack
+ (loadw lexenv cfp-tn (tn-offset arg-fun))
+ (do-next-filler))
+ (constant
+ (loadw lexenv code-tn (tn-offset arg-fun)
+ other-pointer-lowtag)
+ (do-next-filler)))
+ (loadw function lexenv closure-fun-slot
+ fun-pointer-lowtag)
+ (do-next-filler)))
+ (loop
+ (if filler
+ (do-next-filler)
+ (return)))
+
+ (note-this-location vop :call-site)
+ (inst j function
+ (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-lowtag))
+ (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)))
+
+\f
+;;;; 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-fun-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-fun-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 n-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-fun-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 ld 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)))
+
+
+\f
+;;;; 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 l0-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 (- n-word-bytes))
+ (inst subcc count count (fixnumize 1))
+ (loadw temp src)
+ (inst add dst dst (- n-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)
+ (: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 andn result alloc-tn lowtag-mask)
+ (inst or result list-pointer-lowtag)
+ (move dst result)
+ (inst sll temp count 1)
+ (inst b enter)
+ (inst add alloc-tn temp)
+
+ ;; Compute the next cons and store it in the current one.
+ LOOP
+ (inst add dst dst (* 2 n-word-bytes))
+ (storew dst dst -1 list-pointer-lowtag)
+
+ ;; Grab one value.
+ ENTER
+ (loadw temp context)
+ (inst add context context n-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 list-pointer-lowtag)
+
+ ;; NIL out the last cons.
+ (storew null-tn dst 1 list-pointer-lowtag)))
+ 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 sb!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 "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-arg-count)
+ (:policy :fast-safe)
+ (:translate sb!c::%verify-arg-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-arg-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 arg-count-error invalid-arg-count-error
+ sb!c::%arg-count-error nargs)
+ (frob type-check-error object-not-type-error sb!c::%type-check-error
+ object type)
+ (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error
+ object layout)
+ (frob odd-key-args-error odd-key-args-error
+ sb!c::%odd-key-args-error)
+ (frob unknown-key-arg-error unknown-key-arg-error
+ sb!c::%unknown-key-arg-error key)
+ (frob nil-fun-returned-error nil-fun-returned-error nil fun))
--- /dev/null
+;;;; the VM definition of various primitive memory access VOPs for the
+;;;; Sparc
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; 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)))
+\f
+;;;; Symbol hacking VOPs:
+
+;;; The compiler likes to be able to directly SET symbols.
+(define-vop (set cell-set)
+ (:variant symbol-value-slot other-pointer-lowtag))
+
+;;; 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 symbol-value-slot other-pointer-lowtag)
+ (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
+ (inst cmp value unbound-marker-widetag)
+ (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 symbol-value-slot other-pointer-lowtag)
+ (inst cmp value unbound-marker-widetag)
+ (inst b (if not-p :eq :ne) target)
+ (inst nop)))
+
+(define-vop (fast-symbol-value cell-ref)
+ (:variant symbol-value-slot other-pointer-lowtag)
+ (:policy :fast)
+ (:translate symbol-value))
+
+\f
+;;;; FDEFINITION (fdefn) objects.
+(define-vop (fdefn-fun cell-ref)
+ (:variant fdefn-fun-slot other-pointer-lowtag))
+
+(define-vop (safe-fdefn-fun)
+ (: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-fun-slot other-pointer-lowtag)
+ (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-fun)
+ (:policy :fast-safe)
+ (:translate (setf fdefn-fun))
+ (:args (function :scs (descriptor-reg) :target result)
+ (fdefn :scs (descriptor-reg)))
+ (:temporary (:scs (interior-reg)) lip)
+ (:temporary (:scs (non-descriptor-reg)) type)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 38
+ (let ((normal-fn (gen-label)))
+ (load-type type function (- fun-pointer-lowtag))
+ (inst cmp type simple-fun-header-widetag)
+ (inst b :eq normal-fn)
+ (inst move lip function)
+ (inst li lip (make-fixup (extern-alien-name "closure_tramp") :foreign))
+ (emit-label normal-fn)
+ (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
+ (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
+ (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-fun-slot other-pointer-lowtag)
+ (inst li temp (make-fixup (extern-alien-name "undefined_tramp") :foreign))
+ (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
+ (move result fdefn)))
+
+
+\f
+;;;; Binding and Unbinding.
+
+;;; 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 symbol-value-slot other-pointer-lowtag)
+ (inst add bsp-tn bsp-tn (* 2 n-word-bytes))
+ (storew temp bsp-tn (- binding-value-slot binding-size))
+ (storew symbol bsp-tn (- binding-symbol-slot binding-size))
+ (storew val symbol symbol-value-slot other-pointer-lowtag)))
+
+(define-vop (unbind)
+ (:temporary (:scs (descriptor-reg)) symbol value)
+ (:generator 0
+ (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
+ (loadw value bsp-tn (- binding-value-slot binding-size))
+ (storew value symbol symbol-value-slot other-pointer-lowtag)
+ (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+ (inst sub bsp-tn bsp-tn (* 2 n-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 (- binding-symbol-slot binding-size))
+ (inst cmp symbol)
+ (inst b :eq skip)
+ (loadw value bsp-tn (- binding-value-slot binding-size))
+ (storew value symbol symbol-value-slot other-pointer-lowtag)
+ (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+
+ (emit-label skip)
+ (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))
+ (inst cmp where bsp-tn)
+ (inst b :ne loop)
+ (inst nop)
+
+ (emit-label done))))
+\f
+;;;; closure indexing.
+
+(define-vop (closure-index-ref word-index-ref)
+ (:variant closure-info-offset fun-pointer-lowtag)
+ (:translate %closure-index-ref))
+
+(define-vop (funcallable-instance-info word-index-ref)
+ (:variant funcallable-instance-info-offset fun-pointer-lowtag)
+ (:translate %funcallable-instance-info))
+
+(define-vop (set-funcallable-instance-info word-index-set)
+ (:variant funcallable-instance-info-offset fun-pointer-lowtag)
+ (:translate %set-funcallable-instance-info))
+
+(define-vop (funcallable-instance-lexenv cell-ref)
+ (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
+
+
+(define-vop (closure-ref slot-ref)
+ (:variant closure-info-offset fun-pointer-lowtag))
+
+(define-vop (closure-init slot-set)
+ (:variant closure-info-offset fun-pointer-lowtag))
+\f
+;;;; value cell hackery.
+
+(define-vop (value-cell-ref cell-ref)
+ (:variant value-cell-value-slot other-pointer-lowtag))
+
+(define-vop (value-cell-set cell-set)
+ (:variant value-cell-value-slot other-pointer-lowtag))
+\f
+;;;; 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-lowtag)
+ (inst srl res temp n-widetag-bits)))
+
+(define-vop (instance-ref slot-ref)
+ (:variant instance-slots-offset instance-pointer-lowtag)
+ (:policy :fast-safe)
+ (:translate %instance-ref)
+ (:arg-types * (:constant index)))
+
+;;; This VOP has no :results; however, %instance-set must return a
+;;; value. This caused, in the forward port to 0.7.x, an error in
+;;; !fdefn-cold-init: "argument X is not a REAL: NIL". This VOP is
+;;; commented out for now, pending the addition of checking code to
+;;; the define-vop machinery to ascertain that this was indeed the
+;;; problem. -- CSR, 2002-02-12
+#+nil
+(define-vop (instance-set slot-set)
+ (:policy :fast-safe)
+ (:translate %instance-set)
+ (:variant instance-slots-offset instance-pointer-lowtag)
+ (:arg-types * (:constant index) *))
+
+(define-vop (instance-index-ref word-index-ref)
+ (:policy :fast-safe)
+ (:translate %instance-ref)
+ (:variant instance-slots-offset instance-pointer-lowtag)
+ (:arg-types * positive-fixnum))
+
+(define-vop (instance-index-set word-index-set)
+ (:policy :fast-safe)
+ (:translate %instance-set)
+ (:variant instance-slots-offset instance-pointer-lowtag)
+ (:arg-types * positive-fixnum *))
+\f
+;;;; Code object frobbing.
+
+(define-vop (code-header-ref word-index-ref)
+ (:translate code-header-ref)
+ (:policy :fast-safe)
+ (:variant 0 other-pointer-lowtag))
+
+(define-vop (code-header-set word-index-set)
+ (:translate code-header-set)
+ (:policy :fast-safe)
+ (:variant 0 other-pointer-lowtag))
+
--- /dev/null
+;;;; the Sparc VM definition of character operations
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; 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 "character untagging")
+ (:generator 1
+ (inst srl y x n-widetag-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 "character tagging")
+ (:generator 1
+ (inst sll y x n-widetag-bits)
+ (inst or y base-char-widetag)))
+
+(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 "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-arg)
+ (:args (x :target y
+ :scs (base-char-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y base-char-reg))))
+ (:results (y))
+ (:note "character arg move")
+ (:generator 0
+ (sc-case y
+ (base-char-reg
+ (move y x))
+ (base-char-stack
+ (storew x fp (tn-offset y))))))
+
+(define-move-vop move-base-char-arg :move-arg
+ (any-reg base-char-reg) (base-char-reg))
+
+
+;;; Use standard MOVE-ARG + coercion to move an untagged base-char
+;;; to a descriptor passing location.
+(define-move-vop move-arg :move-arg
+ (base-char-reg) (any-reg descriptor-reg))
+
+
+\f
+;;;; 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 sll 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 srl res code fixnum-tag-bits)))
+
+\f
+;;; 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 "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))
--- /dev/null
+;;;; Sparc compiler support for the new whizzy debugger
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!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 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 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 sb!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 ld result sap offset)))
+
+(define-vop (write-control-stack)
+ (:translate sb!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 st 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 srl temp n-widetag-bits)
+ (inst cmp temp)
+ (inst b :eq bogus)
+ (inst sll temp (1- (integer-length n-word-bytes)))
+ (unless (= lowtag other-pointer-lowtag)
+ (inst add temp (- lowtag other-pointer-lowtag)))
+ (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 lra-code-header)
+ (:variant other-pointer-lowtag))
+
+(define-vop (code-from-function code-from-mumble)
+ (:translate fun-code-header)
+ (:variant fun-pointer-lowtag))
+
+(define-vop (make-lisp-obj)
+ (:policy :fast-safe)
+ (:translate 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 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 (fun-word-offset)
+ (:policy :fast-safe)
+ (:translate fun-word-offset)
+ (:args (fun :scs (descriptor-reg)))
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 5
+ (loadw res fun 0 fun-pointer-lowtag)
+ (inst srl res n-widetag-bits)))
--- /dev/null
+;;;; floating point support for the Sparc
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; float move functions
+
+(define-move-fun (load-single 1) (vop x y)
+ ((single-stack) (single-reg))
+ (inst ldf y (current-nfp-tn vop) (* (tn-offset x) n-word-bytes)))
+
+(define-move-fun (store-single 1) (vop x y)
+ ((single-reg) (single-stack))
+ (inst stf x (current-nfp-tn vop) (* (tn-offset y) n-word-bytes)))
+
+
+(define-move-fun (load-double 2) (vop x y)
+ ((double-stack) (double-reg))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset x) n-word-bytes)))
+ (inst lddf y nfp offset)))
+
+(define-move-fun (store-double 2) (vop x y)
+ ((double-reg) (double-stack))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset y) n-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))
+ #!+:sparc-v9
+ (inst ldqf reg base offset)
+ #!-:sparc-v9
+ (let ((reg0 (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (tn-offset reg)))
+ (reg2 (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (+ 2 (tn-offset reg)))))
+ (cond ((integerp offset)
+ (inst lddf reg0 base offset)
+ (inst lddf reg2 base (+ offset (* 2 n-word-bytes))))
+ (t
+ (inst lddf reg0 base offset)
+ (inst add offset (* 2 n-word-bytes))
+ (inst lddf reg2 base offset)
+ (when restore-offset
+ (inst sub offset (* 2 n-word-bytes)))))))
+
+#!+long-float
+(define-move-fun (load-long 2) (vop x y)
+ ((long-stack) (long-reg))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset x) n-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))
+ #!+:sparc-v9
+ (inst stqf reg base offset)
+ #!-:sparc-v9
+ (let ((reg0 (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (tn-offset reg)))
+ (reg2 (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (+ 2 (tn-offset reg)))))
+ (cond ((integerp offset)
+ (inst stdf reg0 base offset)
+ (inst stdf reg2 base (+ offset (* 2 n-word-bytes))))
+ (t
+ (inst stdf reg0 base offset)
+ (inst add offset (* 2 n-word-bytes))
+ (inst stdf reg2 base offset)
+ (when restore-offset
+ (inst sub offset (* 2 n-word-bytes)))))))
+
+#!+long-float
+(define-move-fun (store-long 2) (vop x y)
+ ((long-reg) (long-stack))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset y) n-word-bytes)))
+ (store-long-reg x nfp offset)))
+
+\f
+;;;; Move VOPs:
+
+;;; Exploit the V9 double-float move instruction. This is conditional
+;;; on the :sparc-v9 feature.
+(defun move-double-reg (dst src)
+ #!+:sparc-v9
+ (inst fmovd dst src)
+ #!-:sparc-v9
+ (dotimes (i 2)
+ (let ((dst (make-random-tn :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i (tn-offset dst))))
+ (src (make-random-tn :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :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)
+ #!+:sparc-v9
+ (inst fmovq dst src)
+ #!-:sparc-v9
+ (dotimes (i 4)
+ (let ((dst (make-random-tn :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i (tn-offset dst))))
+ (src (make-random-tn :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :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 "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 "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 n-word-bytes) other-pointer-lowtag)))
+ (:double
+ (inst stdf x y (- (* data n-word-bytes) other-pointer-lowtag)))
+ (:long
+ (store-long-reg x y (- (* data n-word-bytes)
+ other-pointer-lowtag))))))
+
+(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
+ single-float-size single-float-widetag single-float-value-slot)
+ (frob move-from-double double-reg :double
+ double-float-size double-float-widetag double-float-value-slot)
+ #!+long-float
+ (frob move-from-long long-reg :long
+ long-float-size long-float-widetag long-float-value-slot))
+
+(macrolet ((frob (name sc format value)
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (,sc)))
+ (:note "pointer to float coercion")
+ (:generator 2
+ (inst ,(ecase format
+ (:single 'ldf)
+ (:double 'lddf))
+ y x
+ (- (* ,value n-word-bytes) other-pointer-lowtag))))
+ (define-move-vop ,name :move (descriptor-reg) (,sc)))))
+ (frob move-to-single single-reg :single single-float-value-slot)
+ (frob move-to-double double-reg :double double-float-value-slot))
+
+#!+long-float
+(define-vop (move-to-long)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (long-reg)))
+ (:note "pointer to float coercion")
+ (:generator 2
+ (load-long-reg y x (- (* long-float-value-slot n-word-bytes)
+ other-pointer-lowtag))))
+#!+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 "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) n-word-bytes)))
+ (inst ,(ecase format
+ (:single 'stf)
+ (:double 'stdf))
+ x nfp offset))))))
+ (define-move-vop ,name :move-arg
+ (,sc descriptor-reg) (,sc)))))
+ (frob move-single-float-arg single-reg single-stack :single)
+ (frob move-double-float-arg double-reg double-stack :double))
+
+#!+long-float
+(define-vop (move-long-float-arg)
+ (:args (x :scs (long-reg) :target y)
+ (nfp :scs (any-reg) :load-if (not (sc-is y long-reg))))
+ (:results (y))
+ (:note "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) n-word-bytes)))
+ (store-long-reg x nfp offset))))))
+;;;
+#!+long-float
+(define-move-vop move-long-float-arg :move-arg
+ (long-reg descriptor-reg) (long-reg))
+
+\f
+;;;; Complex float move functions
+
+(defun complex-single-reg-real-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
+ :offset (tn-offset x)))
+(defun complex-single-reg-imag-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
+ :offset (1+ (tn-offset x))))
+
+(defun complex-double-reg-real-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
+ :offset (tn-offset x)))
+(defun complex-double-reg-imag-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
+ :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)
+ :offset (tn-offset x)))
+#!+long-float
+(defun complex-long-reg-imag-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
+ :offset (+ (tn-offset x) 4)))
+
+
+(define-move-fun (load-complex-single 2) (vop x y)
+ ((complex-single-stack) (complex-single-reg))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset x) n-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 n-word-bytes)))))
+
+(define-move-fun (store-complex-single 2) (vop x y)
+ ((complex-single-reg) (complex-single-stack))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset y) n-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 n-word-bytes)))))
+
+
+(define-move-fun (load-complex-double 4) (vop x y)
+ ((complex-double-stack) (complex-double-reg))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset x) n-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 n-word-bytes))))))
+
+(define-move-fun (store-complex-double 4) (vop x y)
+ ((complex-double-reg) (complex-double-stack))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset y) n-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 n-word-bytes))))))
+
+
+#!+long-float
+(define-move-fun (load-complex-long 5) (vop x y)
+ ((complex-long-stack) (complex-long-reg))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset x) n-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 n-word-bytes))))))
+
+#!+long-float
+(define-move-fun (store-complex-long 5) (vop x y)
+ ((complex-long-reg) (complex-long-stack))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset y) n-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 n-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 "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 "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 "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))
+
+;;;
+;;; 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 "complex single float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y ndescr complex-single-float-widetag
+ complex-single-float-size))
+ (let ((real-tn (complex-single-reg-real-tn x)))
+ (inst stf real-tn y (- (* complex-single-float-real-slot
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (inst stf imag-tn y (- (* complex-single-float-imag-slot
+ n-word-bytes)
+ other-pointer-lowtag)))))
+;;;
+(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 "complex double float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y ndescr complex-double-float-widetag
+ complex-double-float-size))
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (inst stdf real-tn y (- (* complex-double-float-real-slot
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (inst stdf imag-tn y (- (* complex-double-float-imag-slot
+ n-word-bytes)
+ other-pointer-lowtag)))))
+;;;
+(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 "complex long float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y ndescr complex-long-float-widetag
+ complex-long-float-size))
+ (let ((real-tn (complex-long-reg-real-tn x)))
+ (store-long-reg real-tn y (- (* complex-long-float-real-slot
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (let ((imag-tn (complex-long-reg-imag-tn x)))
+ (store-long-reg imag-tn y (- (* complex-long-float-imag-slot
+ n-word-bytes)
+ other-pointer-lowtag)))))
+;;;
+#!+long-float
+(define-move-vop move-from-complex-long :move
+ (complex-long-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 "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 n-word-bytes)
+ other-pointer-lowtag)))
+ (let ((imag-tn (complex-single-reg-imag-tn y)))
+ (inst ldf imag-tn x (- (* complex-single-float-imag-slot n-word-bytes)
+ other-pointer-lowtag)))))
+(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 "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 n-word-bytes)
+ other-pointer-lowtag)))
+ (let ((imag-tn (complex-double-reg-imag-tn y)))
+ (inst lddf imag-tn x (- (* complex-double-float-imag-slot n-word-bytes)
+ other-pointer-lowtag)))))
+(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 "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 n-word-bytes)
+ other-pointer-lowtag)))
+ (let ((imag-tn (complex-long-reg-imag-tn y)))
+ (load-long-reg imag-tn x (- (* complex-long-float-imag-slot n-word-bytes)
+ other-pointer-lowtag)))))
+#!+long-float
+(define-move-vop move-to-complex-long :move
+ (descriptor-reg) (complex-long-reg))
+
+;;;
+;;; Complex float move-arg vop
+;;;
+(define-vop (move-complex-single-float-arg)
+ (:args (x :scs (complex-single-reg) :target y)
+ (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
+ (:results (y))
+ (:note "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) n-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 n-word-bytes))))))))
+(define-move-vop move-complex-single-float-arg :move-arg
+ (complex-single-reg descriptor-reg) (complex-single-reg))
+
+(define-vop (move-complex-double-float-arg)
+ (:args (x :scs (complex-double-reg) :target y)
+ (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
+ (:results (y))
+ (:note "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) n-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 n-word-bytes)))))))))
+(define-move-vop move-complex-double-float-arg :move-arg
+ (complex-double-reg descriptor-reg) (complex-double-reg))
+
+#!+long-float
+(define-vop (move-complex-long-float-arg)
+ (:args (x :scs (complex-long-reg) :target y)
+ (nfp :scs (any-reg) :load-if (not (sc-is y complex-long-reg))))
+ (:results (y))
+ (:note "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) n-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 n-word-bytes)))))))))
+#!+long-float
+(define-move-vop move-complex-long-float-arg :move-arg
+ (complex-long-reg descriptor-reg) (complex-long-reg))
+
+
+(define-move-vop move-arg :move-arg
+ (single-reg double-reg #!+long-float long-reg
+ complex-single-reg complex-double-reg #!+long-float complex-long-reg)
+ (descriptor-reg))
+
+\f
+;;;; Arithmetic VOPs:
+
+(define-vop (float-op)
+ (:args (x) (y))
+ (:results (r))
+ (:policy :fast-safe)
+ (:note "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))
+
+\f
+(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 "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)
+ #!+:sparc-v9
+ (inst fnegd dst src)
+ #!-:sparc-v9
+ ;; 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)
+ :offset (+ 1 (tn-offset dst))))
+ (src-odd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ 1 (tn-offset src)))))
+ (inst fmovs dst-odd src-odd)))
+
+(defun abs-double-reg (dst src)
+ #!+:sparc-v9
+ (inst fabsd dst src)
+ #!-:sparc-v9
+ ;; 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)
+ :offset (+ 1 (tn-offset dst))))
+ (src-2 (make-random-tn :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :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 "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 "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 "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 1
+ (note-this-location vop :internal-error)
+ #!+:sparc-v9
+ (inst fabsq y x)
+ #!-:sparc-v9
+ (inst fabss y x)
+ (dotimes (i 3)
+ (let ((y-odd (make-random-tn
+ :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i 1 (tn-offset y))))
+ (x-odd (make-random-tn
+ :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :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 "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 1
+ (note-this-location vop :internal-error)
+ #!+:sparc-v9
+ (inst fnegq y x)
+ #!-:sparc-v9
+ (inst fnegs y x)
+ (dotimes (i 3)
+ (let ((y-odd (make-random-tn
+ :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i 1 (tn-offset y))))
+ (x-odd (make-random-tn
+ :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i 1 (tn-offset x)))))
+ (inst fmovs y-odd x-odd)))))
+
+\f
+;;;; Comparison:
+
+(define-vop (float-compare)
+ (:args (x) (y))
+ (:conditional)
+ (:info target not-p)
+ (:variant-vars format yep nope)
+ (:policy :fast-safe)
+ (:note "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.
+ #!-: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))))
+
+\f
+;;;; Conversion:
+
+(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 "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) n-word-bytes))
+ stack-temp)
+ (signed-stack
+ x))))
+ (inst ldf temp
+ (current-nfp-tn vop)
+ (* (tn-offset stack-tn) n-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))
+
+(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 "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 "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) n-word-bytes)))
+ (signed-reg
+ (inst stf temp (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes))
+ (inst ld y (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-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)
+ ;; KLUDGE -- these two forms were protected by #-sun4.
+ ;; (frob %unary-round single-reg single-float fstoir)
+ ;; (frob %unary-round double-reg double-float fdtoir)
+)
+
+(deftransform %unary-round ((x) (float) (signed-byte 32))
+ '(let* ((trunc (truly-the (signed-byte 32) (%unary-truncate x)))
+ (extra (- x trunc))
+ (absx (abs extra))
+ (one-half (float 1/2 x)))
+ (if (if (oddp trunc)
+ (>= absx one-half)
+ (> absx one-half))
+ (truly-the (signed-byte 32) (%unary-truncate (+ x extra)))
+ trunc)))
+
+(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) n-word-bytes))
+ (inst ldf res (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
+ (single-stack
+ (inst st bits (current-nfp-tn vop)
+ (* (tn-offset res) n-word-bytes)))))
+ (signed-stack
+ (sc-case res
+ (single-reg
+ (inst ldf res (current-nfp-tn vop)
+ (* (tn-offset bits) n-word-bytes)))
+ (single-stack
+ (unless (location= bits res)
+ (inst ld temp (current-nfp-tn vop)
+ (* (tn-offset bits) n-word-bytes))
+ (inst st temp (current-nfp-tn vop)
+ (* (tn-offset res) n-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) n-word-bytes))
+ (inst st lo-bits (current-nfp-tn vop)
+ (* (1+ (tn-offset stack-tn)) n-word-bytes)))
+ (when (sc-is res double-reg)
+ (inst lddf res (current-nfp-tn vop)
+ (* (tn-offset temp) n-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) n-word-bytes))
+ (inst st lo1-bits (current-nfp-tn vop)
+ (* (1+ (tn-offset stack-tn)) n-word-bytes))
+ (inst st lo2-bits (current-nfp-tn vop)
+ (* (+ 2 (tn-offset stack-tn)) n-word-bytes))
+ (inst st lo3-bits (current-nfp-tn vop)
+ (* (+ 3 (tn-offset stack-tn)) n-word-bytes)))
+ (when (sc-is res long-reg)
+ (load-long-reg res (current-nfp-tn vop)
+ (* (tn-offset temp) n-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) n-word-bytes))
+ (inst ld bits (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
+ (single-stack
+ (inst ld bits (current-nfp-tn vop)
+ (* (tn-offset float) n-word-bytes)))
+ (descriptor-reg
+ (loadw bits float single-float-value-slot
+ other-pointer-lowtag))))
+ (signed-stack
+ (sc-case float
+ (single-reg
+ (inst stf float (current-nfp-tn vop)
+ (* (tn-offset bits) n-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) n-word-bytes))
+ (inst ld hi-bits (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
+ (double-stack
+ (inst ld hi-bits (current-nfp-tn vop)
+ (* (tn-offset float) n-word-bytes)))
+ (descriptor-reg
+ (loadw hi-bits float double-float-value-slot
+ other-pointer-lowtag)))))
+
+(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) n-word-bytes))
+ (inst ld lo-bits (current-nfp-tn vop)
+ (* (1+ (tn-offset stack-temp)) n-word-bytes)))
+ (double-stack
+ (inst ld lo-bits (current-nfp-tn vop)
+ (* (1+ (tn-offset float)) n-word-bytes)))
+ (descriptor-reg
+ (loadw lo-bits float (1+ double-float-value-slot)
+ other-pointer-lowtag)))))
+
+#!+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)
+ :offset (tn-offset float))))
+ (inst stdf float (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
+ (inst ld exp-bits (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
+ (long-stack
+ (inst ld exp-bits (current-nfp-tn vop)
+ (* (tn-offset float) n-word-bytes)))
+ (descriptor-reg
+ (loadw exp-bits float long-float-value-slot
+ other-pointer-lowtag)))))
+
+#!+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)
+ :offset (tn-offset float))))
+ (inst stdf float (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
+ (inst ld high-bits (current-nfp-tn vop)
+ (* (1+ (tn-offset stack-temp)) n-word-bytes)))
+ (long-stack
+ (inst ld high-bits (current-nfp-tn vop)
+ (* (1+ (tn-offset float)) n-word-bytes)))
+ (descriptor-reg
+ (loadw high-bits float (1+ long-float-value-slot)
+ other-pointer-lowtag)))))
+
+#!+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)
+ :offset (+ 2 (tn-offset float)))))
+ (inst stdf float (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
+ (inst ld mid-bits (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
+ (long-stack
+ (inst ld mid-bits (current-nfp-tn vop)
+ (* (+ 2 (tn-offset float)) n-word-bytes)))
+ (descriptor-reg
+ (loadw mid-bits float (+ 2 long-float-value-slot)
+ other-pointer-lowtag)))))
+
+#!+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)
+ :offset (+ 2 (tn-offset float)))))
+ (inst stdf float (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
+ (inst ld lo-bits (current-nfp-tn vop)
+ (* (1+ (tn-offset stack-temp)) n-word-bytes)))
+ (long-stack
+ (inst ld lo-bits (current-nfp-tn vop)
+ (* (+ 3 (tn-offset float)) n-word-bytes)))
+ (descriptor-reg
+ (loadw lo-bits float (+ 3 long-float-value-slot)
+ other-pointer-lowtag)))))
+
+\f
+;;;; Float mode hackery:
+
+(sb!xc: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 (* n-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 (* n-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 (* n-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 sra new 0)
+ (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 (* n-word-bytes (tn-offset temp))))
+ (inst stx new nfp offset)
+ (inst ldxfsr nfp offset)
+ (move res new))))
+
+\f
+;;;; Special functions.
+
+#!-long-float
+(define-vop (fsqrt)
+ (:args (x :scs (double-reg)))
+ (:results (y :scs (double-reg)))
+ (:translate %sqrt)
+ (:policy :fast-safe)
+ (:guard #!+(or :sparc-v7 :sparc-v8 :sparc-v9) t
+ #!-(or :sparc-v7 :sparc-v8 :sparc-v9) nil)
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:note "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 "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 1
+ (note-this-location vop :internal-error)
+ (inst fsqrtq y x)))
+
+\f
+;;;; 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 "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) n-word-bytes)))
+ (unless (location= real r)
+ (inst stf real nfp offset))
+ (inst stf imag nfp (+ offset n-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 "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) n-word-bytes)))
+ (unless (location= real r)
+ (inst stdf real nfp offset))
+ (inst stdf imag nfp (+ offset (* 2 n-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 "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) n-word-bytes)))
+ (unless (location= real r)
+ (store-long-reg real nfp offset))
+ (store-long-reg imag nfp (+ offset (* 4 n-word-bytes))))))))
+
+(define-vop (complex-single-float-value)
+ (:args (x :scs (complex-single-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))
+ n-word-bytes))))))
+
+(define-vop (realpart/complex-single-float complex-single-float-value)
+ (:translate realpart)
+ (:note "complex single float realpart")
+ (:variant :real))
+
+(define-vop (imagpart/complex-single-float complex-single-float-value)
+ (:translate imagpart)
+ (:note "complex single float imagpart")
+ (:variant :imag))
+
+(define-vop (complex-double-float-value)
+ (:args (x :scs (complex-double-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))
+ n-word-bytes))))))
+
+(define-vop (realpart/complex-double-float complex-double-float-value)
+ (:translate realpart)
+ (:note "complex double float realpart")
+ (:variant :real))
+
+(define-vop (imagpart/complex-double-float complex-double-float-value)
+ (:translate imagpart)
+ (:note "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))
+ n-word-bytes))))))
+
+#!+long-float
+(define-vop (realpart/complex-long-float complex-long-float-value)
+ (:translate realpart)
+ (:note "complex long float realpart")
+ (:variant :real))
+
+#!+long-float
+(define-vop (imagpart/complex-long-float complex-long-float-value)
+ (:translate imagpart)
+ (:note "complex long float imagpart")
+ (:variant :imag))
+
+\f
+
+;;;; Complex float arithmetic
+
+#!+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 "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 "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 fmov 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")))
+ `(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)
+ (:note "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)))
+ (inst ,fop rr xr y)
+ (unless (location= ri xi)
+ (,@fmov ri xi))))))))
+
+ (frob single + fadds (inst fmovs) 2)
+ (frob single - fsubs (inst fmovs) 2)
+ (frob double + faddd (move-double-reg) 4)
+ (frob double - fsubd (move-double-reg) 4))
+
+;; Add a float and a complex
+(macrolet
+ ((frob (size fop fmov 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")))
+ `(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)
+ (:policy :fast-safe)
+ (:note "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)))
+ (inst ,fop rr xr y)
+ (unless (location= ri xi)
+ (,@fmov ri xi))))))))
+ (frob single fadds (inst fmovs) 1)
+ (frob double faddd (move-double-reg) 2))
+
+;; Subtract a complex from a float
+
+(macrolet
+ ((frob (size fop fneg 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")))
+ `(define-vop (single-float---complex-single-float)
+ (: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 "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)))
+ (inst ,fop rr x yr)
+ (,@fneg ri yi))))
+ ))
+
+ (frob single fsubs (inst fnegs) 2)
+ (frob double fsubd (negate-double-reg) 2)))
+
+;; Multiply two complex numbers
+
+#+nil
+(macrolet
+ ((frob (size fmul fadd fsub 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 "inline complex float multiplication")
+ (:translate *)
+ (:temporary (:scs (,real-reg)) prod-1 prod-2 prod-3 prod-4)
+ (: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)))
+ ;; All of the temps are needed in case the result TN happens to
+ ;; be the same as one of the arg TN's
+ (inst ,fmul prod-1 xr yr)
+ (inst ,fmul prod-2 xi yi)
+ (inst ,fmul prod-3 xr yi)
+ (inst ,fmul prod-4 xi yr)
+ (inst ,fsub rr prod-1 prod-2)
+ (inst ,fadd ri prod-3 prod-4)))))))
+
+ (frob single fmuls fadds fsubs 6)
+ (frob double fmuld faddd fsubd 6))
+
+(macrolet
+ ((frob (size fmul fadd fsub 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 "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)))
+ (cond ((location= r x)
+ (inst ,fmul p1 xr yr)
+ (inst ,fmul p2 xr yi)
+ (inst ,fmul rr xi yi)
+ (inst ,fsub rr p1 xr)
+ (inst ,fmul p1 xi yr)
+ (inst ,fadd ri p2 p1))
+ ((location= r y)
+ (inst ,fmul p1 yr xr)
+ (inst ,fmul p2 yr xi)
+ (inst ,fmul rr yi xi)
+ (inst ,fsub rr p1 rr)
+ (inst ,fmul p1 yi xr)
+ (inst ,fadd ri p2 p1))
+ (t
+ (inst ,fmul rr yr xr)
+ (inst ,fmul ri xi yi)
+ (inst ,fsub rr rr ri)
+ (inst ,fmul p1 xr yi)
+ (inst ,fmul ri xi yr)
+ (inst ,fadd ri ri p1)))))))))
+
+ (frob single fmuls fadds fsubs 6)
+ (frob double fmuld faddd fsubd 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 "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 "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
+;;
+
+#+nil
+(macrolet
+ ((frob (float-type fcmp fadd fsub fmul fdiv fabs fmov 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 "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 ratio den)
+ #!-: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 temp-r ratio xi)
+ (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
+ (inst ,fdiv temp-r temp-r den)
+
+ (inst ,fmul temp-i ratio xr)
+ (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
+ (inst b done)
+ (inst ,fdiv temp-i temp-i 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 temp-r ratio xr)
+ (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
+ (inst ,fdiv temp-r temp-r den)
+
+ (inst ,fmul temp-i ratio xi)
+ (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
+ (inst ,fdiv temp-i temp-i den)
+
+ (emit-label done)
+ (unless (location= temp-r rr)
+ (,@fmov rr temp-r))
+ (unless (location= temp-i ri)
+ (,@fmov ri temp-i))
+ ))))))
+
+ (frob single fcmps fadds fsubs fmuls fdivs (inst fabss) (inst fmovs) 15)
+ (frob double fcmpd faddd fsubd fmuld fdivd (abs-double-reg) (move-double-reg) 15))
+
+(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 "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 ratio den)
+ #!-: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 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 "inline complex float arithmetic")
+ (:translate /)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (inst ,fdiv rr xr y) ; xr * y
+ (inst ,fdiv ri xi y) ; xi * yi
+ ))))))
+ (frob single fdivs 2)
+ (frob double fdivd 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 "inline complex float division")
+ (:translate /)
+ (:temporary (:sc ,real-reg) ratio)
+ (:temporary (:sc ,real-reg) den)
+ (:temporary (:sc ,real-reg) temp)
+ (: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 ratio den)
+ #!-: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 temp ratio x) ; temp = (yi/yr)*x
+ (inst ,fdiv rr x den) ; rr = x/den
+ (inst b done)
+ (inst ,fdiv temp temp den) ; temp = (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 temp ratio x) ; temp = (yr/yi)*x
+ (inst ,fdiv rr temp den) ; rr = (yr/yi)*x/den
+ (inst ,fdiv temp x den) ; temp = x/den
+ (emit-label done)
+
+ (,@fneg ri temp)))))))
+
+ (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 "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 "inline complex float/float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:sc ,real-reg) fp-zero)
+ (:guard #!-:sparc-v9 nil #!+:sparc-v9 t)
+ (: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 "inline complex float/float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:sc ,real-reg) fp-zero)
+ (:guard #!-:sparc-v9 t #!+:sparc-v9 nil)
+ (: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 "inline complex float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:guard #!-:sparc-v9 t #!+:sparc-v9 nil)
+ (: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 "inline complex float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:sc descriptor-reg) true)
+ (:guard #!+:sparc-v9 t #!-:sparc-v9 nil)
+ (: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))
+
+) ; 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 #.n-word-bits)
+ (signed-byte #.n-word-bits)
+ single-float double-float)
+ (or (unsigned-byte #.n-word-bits)
+ (signed-byte #.n-word-bits)
+ single-float double-float))
+ (or (unsigned-byte #.n-word-bits)
+ (signed-byte #.n-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 #!+:sparc-v9 t #!-:sparc-v9 nil)
+ (: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 "inline float max")
+ (frob max double-reg double-float fcmpd cfmovd 3
+ :fcc0 :ge :l "inline float max")
+ (frob min single-reg single-float fcmps cfmovs 3
+ :fcc0 :l :ge "inline float min")
+ (frob min double-reg double-float fcmpd cfmovd 3
+ :fcc0 :l :ge "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 "inline (signed-byte 32) max")
+ (frob max unsigned-reg unsigned-num cmp cmove 5
+ :icc :ge :lt "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 "inline fixnum max")
+ (frob min signed-reg signed-num cmp cmove 5
+ :icc :lt :ge "inline (signed-byte 32) min")
+ (frob min unsigned-reg unsigned-num cmp cmove 5
+ :icc :lt :ge "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 "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 "inline float max/min")
+ (:translate %max-double-float)
+ (:temporary (:scs (double-reg)) xval)
+ (:temporary (:scs (double-reg)) yval)
+ (:guard #!+:sparc-v9 t #!-:sparc-v9 nil)
+ (:vop-var vop)
+ (:generator 3
+ (let ((offset (- (* double-float-value-slot n-word-bytes)
+ other-pointer-lowtag)))
+ (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))))))
+
+) ; PROGN
+
+(in-package "SB!C")
+;;; FIXME
+#| #!+sparc-v9 |#
+#+nil
+(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 ,(first args)))
+ (t (sb!c::associate-arguments 'min (first args) (rest args)))))
+
+(def-source-transform max (&rest args)
+ (case (length args)
+ ((0 2) (values nil t))
+ (1 `(values ,(first args)))
+ (t (sb!c::associate-arguments 'max (first args) (rest args)))))
+
+;; Derive the types of max and min
+(defoptimizer (max derive-type) ((x y))
+ (multiple-value-bind (definitely-< definitely->=)
+ (ir1-transform-<-helper x y)
+ (cond (definitely-<
+ (continuation-type y))
+ (definitely->=
+ (continuation-type x))
+ (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 x y)
+ (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 #.sb!vm:n-word-bits)))
+ (unsigned (specifier-type '(unsigned-byte #.sb!vm:n-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))
+ `(%%max x y))
+ ((and (csubtypep x-type unsigned)
+ (csubtypep y-type unsigned))
+ `(%%max x y))
+ ((and (csubtypep x-type d-float)
+ (csubtypep y-type d-float))
+ `(%%max x y))
+ ((and (csubtypep x-type s-float)
+ (csubtypep y-type s-float))
+ `(%%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 #.sb!vm:n-word-bits)))
+ (unsigned (specifier-type '(unsigned-byte #.sb!vm:n-word-bits)))
+ (d-float (specifier-type 'double-float))
+ (s-float (specifier-type 'single-float)))
+ (cond ((and (csubtypep x-type signed)
+ (csubtypep y-type signed))
+ `(%%min x y))
+ ((and (csubtypep x-type unsigned)
+ (csubtypep y-type unsigned))
+ `(%%min x y))
+ ((and (csubtypep x-type d-float)
+ (csubtypep y-type d-float))
+ `(%%min x y))
+ ((and (csubtypep x-type s-float)
+ (csubtypep y-type s-float))
+ `(%%min x y))
+ (t
+ (let ((arg1 (gensym))
+ (arg2 (gensym)))
+ `(let ((,arg1 x)
+ (,arg2 y))
+ (if (< ,arg1 ,arg2)
+ ,arg1 ,arg2)))))))
+
+) ; PROGN
+
--- /dev/null
+;;;; the instruction set definition for the Sparc
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+;;;FIXME: the analogue is commented out in alpha/insts.lisp
+;;;(def-assembler-params
+;;; :scheduler-p t
+;;; :max-locations 100)
+\f
+;;; 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 "~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 "~S isn't a floating-point register." tn))
+ (let ((offset (tn-offset tn)))
+ (cond ((> offset 31)
+ ;; Use the sparc v9 double float register encoding.
+ #!-:sparc-v9 (error ":sparc-v9 should be on the target features")
+ ;; (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)))))
+
+;;;(sb!disassem:set-disassem-params :instruction-alignment 32
+;;; :opcode-column-width 11)
+
+(defvar *disassem-use-lisp-reg-names* t
+ #!+sb-doc
+ "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)))))
+
+;;; symbols used for disassembly printing
+(defparameter reg-symbols
+ (map 'vector
+ (lambda (name)
+ (cond ((null name) nil)
+ (t (make-symbol (concatenate 'string "%" name)))))
+ *register-names*)
+ #!+sb-doc "The Lisp names for the Sparc integer registers")
+
+(defparameter sparc-reg-symbols
+ #("%G0" "%G1" "%G2" "%G3" "%G4" "%G5" NIL NIL
+ "%O0" "%O1" "%O2" "%O3" "%O4" "%O5" "%O6" "%O7"
+ "%L0" "%L1" "%L2" "%L3" "%L4" "%L5" "%L6" "%L7"
+ "%I0" "%I1" "%I2" "%I3" "%I4" "%I5" NIL "%I7")
+ #!+sb-doc "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))
+
+;;; Oh, come on, this is ridiculous. I'm not going to solve
+;;; bootstrapping issues for a disassembly note. Does this make me
+;;; lazy? Christophe, 2001-09-02. FIXME
+#+nil
+(macrolet
+ ((frob (&rest names)
+ (let ((results (mapcar (lambda (n)
+ (let ((nn (intern (concatenate 'string (string n)
+ "-TYPE"))))
+ `(,(eval nn) ,nn)))
+ names)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (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
+ complex
+ complex-single-float
+ complex-double-float
+ #!+long-float complex-long-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
+ simple-array-complex-single-float
+ simple-array-complex-double-float
+ #!+long-float simple-array-complex-long-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
+ 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 (sb!disassem::sap-ref-int (sb!disassem::dstate-segment-sap dstate)
+ (sb!disassem::dstate-cur-offs dstate)
+ n-word-bytes
+ (sb!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)))
+ (#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)
+ (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 (sb!disassem::note-code-constant-absolute addr dstate)
+ (sb!disassem:maybe-note-assembler-routine addr t dstate)
+ (sb!disassem:note (format nil "~A = #x~8,'0X"
+ (get-reg-name rd) addr)
+ dstate)))
+ (setf *note-sethi-inst* (delete sethi *note-sethi-inst*)))
+ ((= rs1 null-offset)
+ ;; We have an ADD %NULL, <n>, RD instruction. This is a
+ ;; reference to a static symbol.
+ (sb!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-val 4) (= rd alloc-offset)
+ (not *pseudo-atomic-set*))
+ ;; "ADD 4, %ALLOC" sets the flag
+ (sb!disassem::note "Set pseudo-atomic flag" dstate)
+ (setf *pseudo-atomic-set* t))
+ ((= rd alloc-offset)
+ ;; "ADD n, %ALLOC" is reseting the flag, with extra
+ ;; allocation.
+ (sb!disassem:note
+ (format nil "Reset pseudo-atomic, allocated ~D bytes"
+ (+ immed-val 4)) dstate)
+ (setf *pseudo-atomic-set* nil))))
+ #+nil ((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
+ (sb!disassem:note (format nil "Header word ~A, size ~D?" type size)
+ dstate)))))))
+
+(defun handle-jmpl-inst (rs1 immed-val rd dstate)
+ (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))))
+ (sb!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)
+ (sb!disassem:note-code-constant immed-val dstate))
+ (2
+ ;; A reference to a static symbol or static function (reg =
+ ;; %NULL)
+ (or (sb!disassem:maybe-note-nil-indexed-symbol-slot-ref immed-val
+ dstate)
+ #+nil (sb!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))))
+ (sb!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))
+ (sb!disassem:note "pseudo-atomic interrupted?" dstate)))
+
+(sb!disassem:define-arg-type reg
+ :printer (lambda (value stream dstate)
+ (declare (stream stream) (fixnum value))
+ (let ((regname (get-reg-name value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref value
+ 'registers
+ regname
+ dstate)
+ (maybe-add-notes value dstate))))
+
+(defparameter float-reg-symbols
+ (coerce
+ (loop for n from 0 to 63 collect (make-symbol (format nil "%F~d" n)))
+ 'vector))
+
+(sb!disassem:define-arg-type fp-reg
+ :printer (lambda (value stream dstate)
+ (declare (stream stream) (fixnum value))
+ (let ((regname (aref float-reg-symbols value)))
+ (princ regname stream)
+ (sb!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.
+(sb!disassem:define-arg-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)
+ (sb!disassem:maybe-note-associated-storage-ref
+ value
+ 'float-registers
+ regname
+ dstate))))
+
+(sb!disassem:define-arg-type relative-label
+ :sign-extend t
+ :use-label (lambda (value dstate)
+ (declare (type (signed-byte 13) value)
+ (type sb!disassem:disassem-state dstate))
+ (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
+
+(defconstant-eqx branch-conditions
+ '(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc)
+ #'equalp)
+
+;;; 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.
+
+(sb!disassem:define-arg-type branch-condition
+ :printer (coerce branch-conditions 'vector))
+
+(deftype branch-condition ()
+ `(member ,@branch-conditions))
+
+(defun branch-condition (condition)
+ (or (position condition branch-conditions)
+ (error "Unknown branch condition: ~S~%Must be one of: ~S"
+ condition branch-conditions)))
+
+(defconstant branch-cond-true
+ #b1000)
+
+(defconstant-eqx branch-fp-conditions
+ '(:f :ne :lg :ul :l :ug :g :u :t :eq :ue :ge :uge :le :ule :o)
+ #'equalp)
+
+(sb!disassem:define-arg-type branch-fp-condition
+ :printer (coerce branch-fp-conditions 'vector))
+
+(sb!disassem:define-arg-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 "Unknown fp-branch condition: ~S~%Must be one of: ~S"
+ condition branch-fp-conditions)))
+
+\f
+;;;; dissassem:define-instruction-formats
+
+(sb!disassem:define-instruction-format
+ (format-1 32 :default-printer '(:name :tab disp))
+ (op :field (byte 2 30) :value 1)
+ (disp :field (byte 30 0)))
+
+(sb!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)))
+
+
+
+(sb!disassem:define-instruction-format
+ (format-2-branch 32 :default-printer `(:name (:unless (:constant ,branch-cond-true) cond)
+ (:unless (a :constant 0) "," 'A)
+ :tab
+ disp))
+ (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-eqx integer-condition-registers
+ '(:icc :reserved :xcc :reserved)
+ #'equalp)
+
+(defconstant-eqx integer-cond-reg-name-vec
+ (coerce integer-condition-registers 'vector)
+ #'equalp)
+
+(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))
+
+(sb!disassem:define-arg-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-eqx branch-predictions
+ '(:pn :pt)
+ #'equalp)
+
+(sb!disassem:define-arg-type branch-prediction
+ :printer (coerce branch-predictions 'vector))
+
+(defun integer-condition (condition-reg)
+ (declare (type (member :icc :xcc) condition-reg))
+ (or (position condition-reg integer-condition-registers)
+ (error "Unknown integer condition register: ~S~%"
+ condition-reg)))
+
+(defun branch-prediction (pred)
+ (or (position pred branch-predictions)
+ (error "Unknown branch prediction: ~S~%Must be one of: ~S~%"
+ pred branch-predictions)))
+
+(defconstant-eqx branch-pred-printer
+ `(:name (:unless (:constant ,branch-cond-true) cond)
+ (:unless (a :constant 0) "," 'A)
+ (:unless (p :constant 1) "," 'pn)
+ :tab
+ cc
+ ", "
+ disp)
+ #'equalp)
+
+(sb!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-eqx fp-condition-registers
+ '(:fcc0 :fcc1 :fcc2 :fcc3)
+ #'equalp)
+
+(defconstant-eqx fp-cond-reg-name-vec
+ (coerce fp-condition-registers 'vector)
+ #'equalp)
+
+(defparameter fp-condition-reg-symbols
+ (map 'vector
+ (lambda (name)
+ (make-symbol (concatenate 'string "%" (string name))))
+ fp-condition-registers))
+
+(sb!disassem:define-arg-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))))
+
+(sb!disassem:define-arg-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-eqx fp-branch-pred-printer
+ `(:name (:unless (:constant ,branch-cond-true) cond)
+ (:unless (a :constant 0) "," 'A)
+ (:unless (p :constant 1) "," 'pn)
+ :tab
+ fcc
+ ", "
+ disp)
+ #'equalp)
+
+(sb!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))
+
+
+
+(sb!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-eqx f3-printer
+ '(:name :tab
+ (:unless (:same-as rd) rs1 ", ")
+ (:choose rs2 immed) ", "
+ rd)
+ #'equalp)
+
+(sb!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))
+
+(sb!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
+
+(sb!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.
+(sb!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.
+;;
+(sb!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
+(sb!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))
+
+(sb!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))
+
+\f
+;;; 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-eqx cond-move-condition-registers
+ '(:fcc0 :fcc1 :fcc2 :fcc3 :icc :reserved :xcc :reserved)
+ #'equalp)
+
+(defconstant-eqx cond-move-cond-reg-name-vec
+ (coerce cond-move-condition-registers 'vector)
+ #'equalp)
+
+(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))
+
+(sb!disassem:define-arg-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 "Unknown conditional move condition register: ~S~%"
+ condition-reg))))
+
+(defun cond-move-condition (condition-reg)
+ (or (position condition-reg cond-move-condition-registers)
+ (error "Unknown conditional move condition register: ~S~%")))
+
+(defconstant-eqx cond-move-printer
+ `(:name cond :tab
+ cc ", " (:choose immed rs2) ", " rd)
+ #'equalp)
+
+;; Conditional move integer register on integer or FP condition code
+(sb!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))
+
+(sb!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-eqx cond-fp-move-printer
+ `(:name rs1 :tab opf1 ", " rs2 ", " rd)
+ #'equalp)
+
+;;; 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-eqx cond-move-integer-conditions
+ '(:reserved :z :lez :lz :reserved :nz :gz :gez)
+ #'equalp)
+
+(defconstant-eqx cond-move-integer-condition-vec
+ (coerce cond-move-integer-conditions 'vector)
+ #'equalp)
+
+(deftype cond-move-integer-condition ()
+ `(member ,@(remove :reserved cond-move-integer-conditions)))
+
+(sb!disassem:define-arg-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-eqx cond-move-integer-printer
+ `(:name rcond :tab rs1 ", " (:choose immed rs2) ", " rd)
+ #'equalp)
+
+(defun register-condition (rcond)
+ (or (position rcond cond-move-integer-conditions)
+ (error "Unknown register condition: ~S~%")))
+
+(sb!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))
+
+(sb!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-eqx trap-printer
+ `(:name rd :tab cc ", " immed)
+ #'equalp)
+
+(sb!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 1)
+ (cc :field (byte 2 11) :type 'integer-condition-register)
+ (immed :field (byte 11 0) :sign-extend t)) ; usually sign extended
+
+
+(defconstant-eqx cond-fp-move-integer-printer
+ `(:name opf1 :tab rs1 ", " rs2 ", " rd)
+ #'equalp)
+
+\f
+;;;; Primitive emitters.
+
+(define-bitfield-emitter emit-word 32
+ (byte 32 0))
+
+(define-bitfield-emitter emit-short 16
+ (byte 16 0))
+
+(define-bitfield-emitter emit-format-1 32
+ (byte 2 30) (byte 30 0))
+
+(define-bitfield-emitter emit-format-2-immed 32
+ (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))
+
+(define-bitfield-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-bitfield-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-bitfield-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-bitfield-emitter emit-format-2-unimp 32
+ (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))
+
+(define-bitfield-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-bitfield-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-bitfield-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-bitfield-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-bitfield-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-bitfield-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-bitfield-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-bitfield-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-bitfield-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-bitfield-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))
+
+\f
+;;;; 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 "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-toplevel :execute)
+
+;;; 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-eqx load-printer
+ (with-ref-format `(:NAME :TAB ,ref-format ", " rd))
+ #'equalp)
+
+(defconstant-eqx store-printer
+ (with-ref-format `(:NAME :TAB rd ", " ,ref-format))
+ #'equalp)
+
+) ; eval-when (compile eval)
+
+(macrolet ((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)))))))
+
+ (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)))))
+
+ (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)
+
+ (define-f3-inst ldsw #b11 #b001000 :load-store :load) ; v9
+
+ ;; 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-reg :load-store :load)
+ (define-f3-inst ldqf #b11 #b100010 :dest-kind fp-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-reg :load-store :store)
+ (define-f3-inst stqf #b11 #b100110 :dest-kind fp-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
+
+) ; MACROLET
+
+\f
+;;;; 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 (#-sb-xc :compile-toplevel :load-toplevel :execute)
+ (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 (sb!disassem::sap-ref-int (sb!disassem::dstate-segment-sap dstate)
+ (sb!disassem::dstate-cur-offs dstate)
+ n-word-bytes
+ (sb!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
+
+
+(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-immed ((op #b10) (op3 #b101000) (rs1 0) (immed 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-eqx wry-printer
+ '('WR :tab rs1 (:unless (:constant 0) ", " (:choose immed rs2)) ", " '%Y)
+ #'equalp)
+
+;; 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)))))
+
+(defun snarf-error-junk (sap offset &optional length-only)
+ (let* ((length (sb!sys:sap-ref-8 sap offset))
+ (vector (make-array length :element-type '(unsigned-byte 8))))
+ (declare (type sb!sys: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
+ (sb!kernel:copy-from-system-area sap (* n-byte-bits (1+ offset))
+ vector (* n-word-bits
+ vector-data-offset)
+ (* length n-byte-bits))
+ (collect ((sc-offsets)
+ (lengths))
+ (lengths 1) ; the length byte
+ (let* ((index 0)
+ (error-number (sb!c:read-var-integer vector index)))
+ (lengths index)
+ (loop
+ (when (>= index length)
+ (return))
+ (let ((old-index index))
+ (sc-offsets (sb!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 (sb!disassem:note x dstate))))
+ (case (format-2-unimp-data chunk dstate)
+ (#.error-trap
+ (nt "Error trap")
+ (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
+ (#.cerror-trap
+ (nt "Cerror trap")
+ (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
+ (#.object-not-list-trap
+ (nt "Object not list trap"))
+ (#.breakpoint-trap
+ (nt "Breakpoint trap"))
+ (#.pending-interrupt-trap
+ (nt "Pending interrupt trap"))
+ (#.halt-trap
+ (nt "Halt trap"))
+ (#.fun-end-breakpoint-trap
+ (nt "Function end breakpoint trap"))
+ (#.object-not-instance-trap
+ (nt "Object not instance trap"))
+ )))
+
+(define-instruction unimp (segment data)
+ (:declare (type (unsigned-byte 22) data))
+ (:printer format-2-unimp () :default :control #'unimp-control
+ :print-name #!-sparc-v9 'unimp #!+sparc-v9 'illtrap)
+ (:delay 0)
+ (:emitter (emit-format-2-unimp segment 0 0 0 data)))
+
+
+\f
+;;;; 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)
+ (:declare (type (or label branch-condition) cond-or-target)
+ (type (or label null) target))
+ (: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))
+ (: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))
+ nil
+ :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))
+ (:printer format-2-branch ((op #b00) (op2 #b001) (a 1))
+ nil
+ :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))))
+
+;; This doesn't cover all of the possible formats for the trap
+;; instruction. We really only want a trap with a immediate trap
+;; value and with RS1 = register 0. Also, 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.
+#!-sparc-v9
+(define-instruction t (segment condition target)
+ (:declare (type branch-condition condition)
+ ;; KLUDGE
+ #!-linux
+ (type (integer 16 31) target))
+ (:printer format-3-immed ((op #b10)
+ (rd nil :type 'branch-condition)
+ (op3 #b111010)
+ (rs1 0))
+ '(:name rd :tab immed))
+ (:attributes branch)
+ (:dependencies (reads :psr))
+ (:delay 0)
+ (:emitter (emit-format-3-immed segment #b10 (branch-condition condition)
+ #b111010 0 1 target)))
+
+#!+sparc-v9
+(define-instruction t (segment condition target &optional (cc #!-sparc-64 :icc #!+sparc-64 :xcc))
+ (:declare (type branch-condition condition)
+ #!-linux
+ (type (integer 16 31) target)
+ (type integer-condition-register cc))
+ (:printer format-4-trap ((op #b10)
+ (rd nil :type 'branch-condition)
+ (op3 #b111010)
+ (rs1 0))
+ trap-printer)
+ (:attributes branch)
+ (:dependencies (reads :psr))
+ (:delay 0)
+ (:emitter (emit-format-4-trap segment
+ #b10
+ (branch-condition condition)
+ #b111010 0 1
+ (integer-condition cc)
+ target)))
+
+;; 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-eqx 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))
+ #'equalp)
+
+(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)
+ (:printer format-3-immed ((op #b10) (op3 #b111000)) jal-printer)
+ (: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)))))
+
+
+\f
+;;;; Unary and binary fp insts.
+
+(macrolet ((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)))))
+
+ (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)))))
+
+ (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)))))))
+
+ (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?).
+ (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
+
+) ; MACROLET
+\f
+;;;; li, jali, ji, nop, cmp, not, neg, move, and more
+
+(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))))
+
+(define-instruction-macro li (reg value)
+ `(%li ,reg ,value))
+
+;;; 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))))
+
+(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))))
+
+
+\f
+;;;; 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-bitfield-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))
+ (- n-widetag-bits word-shift)))))))
+
+(define-instruction simple-fun-header-word (segment)
+ :pinned
+ (:delay 0)
+ (:emitter
+ (emit-header-data segment simple-fun-header-widetag)))
+
+(define-instruction lra-header-word (segment)
+ :pinned
+ (:delay 0)
+ (:emitter
+ (emit-header-data segment return-pc-header-widetag)))
+
+\f
+;;;; 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-lowtag
+ fun-pointer-lowtag
+ (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))))))
+\f
+;;; 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
+(macrolet ((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.
+(macrolet ((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))
--- /dev/null
+;;;; various useful macros for generating Sparc code
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;; 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))))
+
+(macrolet
+ ((frob (op inst shift)
+ `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
+ `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
+ (frob loadw ld word-shift)
+ (frob storew st 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 "SB!VM"))))
+ `(progn
+ (defmacro ,loader (reg symbol)
+ `(inst ld ,reg null-tn
+ (+ (static-symbol-offset ',symbol)
+ (ash ,',offset word-shift)
+ (- other-pointer-lowtag))))
+ (defmacro ,storer (reg symbol)
+ `(inst st ,reg null-tn
+ (+ (static-symbol-offset ',symbol)
+ (ash ,',offset word-shift)
+ (- other-pointer-lowtag))))))))
+ (frob value)
+ (frob function))
+
+(defmacro load-type (target source &optional (offset 0))
+ #!+sb-doc
+ "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))
+ ;; FIXME: although I don't understand entirely, I'm going to do
+ ;; what whn does in x86/macros.lisp -- Christophe
+ (ecase *backend-byte-order*
+ (: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 (fun)
+ "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
+ `(progn
+ (inst j ,fun
+ (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag))
+ (move code-tn ,fun)))
+
+(defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
+ "Return to RETURN-PC."
+ `(progn
+ (inst j ,return-pc
+ (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
+ ,(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 n-lowtag-bits)
+ (emit-label ,label)
+ (inst lra-header-word)))
+
+
+\f
+;;;; 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))))))
+
+(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))))))
+
+
+;;; 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))))))))
+
+\f
+;;;; Storage allocation:
+
+(defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
+ &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))
+ `(pseudo-atomic (:extra (pad-data-block ,size))
+ (inst or ,result-tn alloc-tn other-pointer-lowtag)
+ (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
+ (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
+ ,@body)))
+
+\f
+;;;; 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-toplevel :load-toplevel :execute)
+ (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)))))
+
+
+\f
+;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
+;;;
+(defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
+ (let ((n-extra (gensym)))
+ `(let ((,n-extra ,extra))
+ ;; Set the pseudo-atomic flag
+ (without-scheduling ()
+ (inst add alloc-tn 4))
+ ,@forms
+ ;; Reset the pseudo-atomic flag
+ (without-scheduling ()
+ #+nil (inst taddcctv alloc-tn (- ,n-extra 4))
+ ;; Remove the pseudo-atomic flag
+ (inst add alloc-tn (- ,n-extra 4))
+ ;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1)
+ (inst andcc zero-tn alloc-tn 3)
+ ;; The C code needs to process this correctly and fixup alloc-tn.
+ (inst t :ne pseudo-atomic-trap)
+ ))))
+
+;;; FIXME: test typing macros. Should(?) be in type-vops.lisp, except
+;;; that they're also used in subprim.lisp
+
+(defun cost-to-test-types (type-codes)
+ (+ (* 2 (length type-codes))
+ (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
+
+(defparameter *immediate-types*
+ (list base-char-widetag unbound-marker-widetag))
+
+(defparameter *fun-header-widetags*
+ (list funcallable-instance-header-widetag
+ simple-fun-header-widetag
+ closure-fun-header-widetag
+ closure-header-widetag))
+
+(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 "~S is less than the specified minimum of ~S"
+ value min))
+ ((> value max)
+ (error "~S is greater than the specified maximum of ~S"
+ value max))
+ ((not (zerop (rem (- value min) seperation)))
+ (error "~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 "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-lowtag lowtag-limit)
+ (- other-immediate-1-lowtag other-immediate-0-lowtag)
+ (ash 1 n-widetag-bits)
+ values))
+
+(defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs
+ function-p)
+ (let* ((fixnump (and (member even-fixnum-lowtag lowtags :test #'eql)
+ (member odd-fixnum-lowtag lowtags :test #'eql)))
+ (lowtags (sort (if fixnump
+ (delete even-fixnum-lowtag
+ (remove odd-fixnum-lowtag lowtags
+ :test #'eql)
+ :test #'eql)
+ (copy-list lowtags))
+ #'<))
+ (lowtag (if function-p
+ fun-pointer-lowtag
+ other-pointer-lowtag))
+ (hdrs (sort (copy-list hdrs) #'<))
+ (immed (sort (copy-list immed) #'<)))
+ (append
+ (when immed
+ `((inst and ,temp ,reg widetag-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))))))
+
+(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 "Must supply at least on type for test-type."))
+ (when (and headers (member other-pointer-lowtag lowtags))
+ (warn "OTHER-POINTER-TYPE supersedes the use of ~S" headers)
+ (setf headers nil))
+ (when (and immediates
+ (or (member other-immediate-0-lowtag lowtags)
+ (member other-immediate-1-lowtag lowtags)))
+ (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates)
+ (setf immediates nil))
+ (when (intersection headers *fun-header-widetags*)
+ (unless (subsetp headers *fun-header-widetags*)
+ (error "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)))))
--- /dev/null
+;;;; the Sparc definitions of some general purpose memory reference
+;;;; VOPs inherited by basic memory reference operations
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+;;; 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)))
+\f
+;;;; Indexed references:
+
+;;; Define some VOPs for indexed memory reference.
+(macrolet ((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)
+ (- word-shift ,shift)))
+ (ash offset 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 srl temp index ,shift)))
+ (inst add temp ,(if (zerop shift) 'index 'temp)
+ (- (ash offset word-shift) lowtag))
+ (inst ,op value object temp)))
+ ,@(when write-p
+ '((move result value)))))))
+ (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))
+
--- /dev/null
+;;;; the Sparc VM definition of operand loading/saving and the Move VOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(define-move-fun (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) n-widetag-bits)
+ base-char-widetag))))))
+
+(define-move-fun (load-number 1) (vop x y)
+ ((immediate zero)
+ (signed-reg unsigned-reg))
+ (inst li y (tn-value x)))
+
+(define-move-fun (load-base-char 1) (vop x y)
+ ((immediate) (base-char-reg))
+ (inst li y (char-code (tn-value x))))
+
+(define-move-fun (load-system-area-pointer 1) (vop x y)
+ ((immediate) (sap-reg))
+ (inst li y (sap-int (tn-value x))))
+
+(define-move-fun (load-constant 5) (vop x y)
+ ((constant) (descriptor-reg))
+ (loadw y code-tn (tn-offset x) other-pointer-lowtag))
+
+(define-move-fun (load-stack 5) (vop x y)
+ ((control-stack) (any-reg descriptor-reg))
+ (load-stack-tn y x))
+
+(define-move-fun (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-fun (store-stack 5) (vop x y)
+ ((any-reg descriptor-reg) (control-stack))
+ (store-stack-tn y x))
+
+(define-move-fun (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))))
+
+\f
+;;;; 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-Arg VOP is used for moving descriptor values into
+;;; another frame for argument or known value passing.
+(define-vop (move-arg)
+ (: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))))
+ (:results (y))
+ (:generator 0
+ (sc-case y
+ ((any-reg descriptor-reg)
+ (move y x))
+ (control-stack
+ (storew x fp (tn-offset y))))))
+
+(define-move-vop move-arg :move-arg
+ (any-reg descriptor-reg)
+ (any-reg descriptor-reg))
+\f
+;;;; 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)))
+\f
+;;;; 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 "fixnum untagging")
+ (:generator 1
+ (inst sra 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 "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.
+(define-vop (move-to-word/integer)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (signed-reg unsigned-reg)))
+ (:note "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 sra y x fixnum-tag-bits)
+
+ (loadw y x bignum-digits-offset other-pointer-lowtag)
+
+ (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 "fixnum tagging")
+ (:generator 1
+ (inst sll 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 "signed word to integer coercion")
+ (:generator 20
+ (move x arg)
+ (let ((fixnum (gen-label))
+ (done (gen-label)))
+ (inst sra temp x positive-fixnum-bits)
+ (inst cmp temp)
+ (inst b :eq fixnum)
+ (inst orncc temp zero-tn temp)
+ (inst b :eq done)
+ (inst sll y x fixnum-tag-bits)
+
+ (with-fixed-allocation
+ (y temp bignum-widetag (1+ bignum-digits-offset))
+ (storew x y bignum-digits-offset other-pointer-lowtag))
+ (inst b done)
+ (inst nop)
+
+ (emit-label fixnum)
+ (inst sll y x fixnum-tag-bits)
+ (emit-label done))))
+
+(define-move-vop move-from-signed :move
+ (signed-reg) (descriptor-reg))
+
+
+;;; 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.
+(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 "unsigned word to integer coercion")
+ (:generator 20
+ (move x arg)
+ (let ((done (gen-label))
+ (one-word (gen-label))
+ (initial-alloc (pad-data-block (1+ bignum-digits-offset))))
+ (inst sra temp x positive-fixnum-bits)
+ (inst cmp temp)
+ (inst b :eq done)
+ (inst sll 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-widetag (+ 2 bignum-digits-offset))
+ (inst cmp x)
+ (inst b :ge one-word)
+ (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
+ (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
+ (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-lowtag)
+ (storew x y bignum-digits-offset other-pointer-lowtag))
+ (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 "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-arg)
+ (:args (x :target y
+ :scs (signed-reg unsigned-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y sap-reg))))
+ (:results (y))
+ (:note "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))))))
+
+(define-move-vop move-word-arg :move-arg
+ (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-arg :move-arg
+ (signed-reg unsigned-reg) (any-reg descriptor-reg))
--- /dev/null
+;;;; the definitions of VOPs used for non-local exit (throw, lexical
+;;;; exit, etc.)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+;;; Make an environment-live stack TN for saving the SP for NLX entry.
+(!def-vm-support-routine make-nlx-sp-tn (env)
+ (physenv-live-tn
+ (make-representation-tn *fixnum-primitive-type* immediate-arg-scn)
+ env))
+
+;;; Make a TN for the argument count passing location for a non-local
+;;; entry.
+(!def-vm-support-routine make-nlx-entry-arg-start-location ()
+ (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset))
+\f
+;;; 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.
+
+
+;;; 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 *backend-t-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 *current-catch-block*)
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (move nfp cur-nfp)))
+ (move nsp nsp-tn)))
+
+(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 *current-catch-block*)
+ (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)))
+
+\f
+;;;; 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
+ (inst add block cfp-tn (* (tn-offset tn) n-word-bytes))
+ (load-symbol-value temp *current-unwind-protect-block*)
+ (storew temp block unwind-block-current-uwp-slot)
+ (storew cfp-tn block unwind-block-current-cont-slot)
+ (storew code-tn block unwind-block-current-code-slot)
+ (inst compute-lra-from-code temp code-tn entry-label ndescr)
+ (storew temp block 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)))
+ (: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
+ (inst add result cfp-tn (* (tn-offset tn) n-word-bytes))
+ (load-symbol-value temp *current-unwind-protect-block*)
+ (storew temp result catch-block-current-uwp-slot)
+ (storew cfp-tn result catch-block-current-cont-slot)
+ (storew code-tn result catch-block-current-code-slot)
+ (inst compute-lra-from-code temp code-tn entry-label ndescr)
+ (storew temp result catch-block-entry-pc-slot)
+
+ (storew tag result catch-block-tag-slot)
+ (load-symbol-value temp *current-catch-block*)
+ (storew temp result catch-block-previous-catch-slot)
+ (store-symbol-value result *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)
+ (:generator 7
+ (inst add new-uwp cfp-tn (* (tn-offset tn) n-word-bytes))
+ (store-symbol-value new-uwp *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 *current-catch-block*)
+ (loadw block block catch-block-previous-catch-slot)
+ (store-symbol-value block *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 *current-unwind-protect-block*)
+ (loadw block block unwind-block-current-uwp-slot)
+ (store-symbol-value block *current-unwind-protect-block*)))
+
+\f
+;;;; 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 ld temp src num)
+ (inst add num (fixnumize 1))
+ (inst cmp num count)
+ (inst b :ne loop)
+ (inst st 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)))
+
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; Machine Architecture parameters:
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defconstant n-word-bits 32
+ #!+sb-doc
+ "Number of bits per word where a word holds one lisp descriptor.")
+
+(defconstant n-byte-bits 8
+ #!+sb-doc
+ "Number of bits per byte where a byte is the smallest addressable object.")
+
+(defconstant word-shift (1- (integer-length (/ n-word-bits n-byte-bits)))
+ #!+sb-doc
+ "Number of bits to shift between word addresses and byte addresses.")
+
+(defconstant n-word-bytes (/ n-word-bits n-byte-bits)
+ #!+sb-doc
+ "Number of bytes in a word.")
+
+;;; FIXME: The following three should probably be rationalized or at
+;;; least prefixed with n- where applicable
+(defconstant fixnum-tag-bits (1- n-lowtag-bits)
+ #!+sb-doc
+ "Number of tag bits used for a fixnum")
+
+(defconstant fixnum-tag-mask (1- (ash 1 fixnum-tag-bits))
+ #!+sb-doc
+ "Mask to get the fixnum tag")
+
+(defconstant positive-fixnum-bits (- n-word-bits fixnum-tag-bits 1)
+ #!+sb-doc
+ "Maximum number of bits in a positive fixnum")
+
+(defconstant float-sign-shift 31)
+
+(defconstant single-float-bias 126)
+(defconstant-eqx single-float-exponent-byte (byte 8 23) #'equalp)
+(defconstant-eqx single-float-significand-byte (byte 23 0) #'equalp)
+(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-bias 1022)
+(defconstant-eqx double-float-exponent-byte (byte 11 20) #'equalp)
+(defconstant-eqx double-float-significand-byte (byte 20 0) #'equalp)
+(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))
+
+;;; CMUCL COMMENT:
+;;; X These values are for the x86 80 bit format and are no doubt
+;;; incorrect for the sparc.
+;;; FIXME
+(defconstant long-float-bias 16382)
+(defconstant-eqx long-float-exponent-byte (byte 15 0) #'equalp)
+(defconstant-eqx long-float-significand-byte (byte 31 0) #'equalp)
+(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) n-word-bits 1))
+
+;;; This looks wrong - CSR
+(defconstant long-float-digits
+ (+ (byte-size long-float-significand-byte) n-word-bits 1))
+
+(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-eqx float-rounding-mode (byte 2 30) #'equalp) ; RD
+(defconstant-eqx float-sticky-bits (byte 5 5) #'equalp) ; aexc
+(defconstant-eqx float-traps-byte (byte 5 23) #'equalp) ; TEM
+(defconstant-eqx float-exceptions-byte (byte 5 0) #'equalp) ; 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.
+;;;
+;;; FIXME: Where is this used?
+(defconstant number-stack-displacement
+ (* 16 n-word-bytes))
+
+\f
+;;;; Description of the target address space.
+
+;;; Where to put the different spaces. Must match the C code!
+#!+linux
+(progn
+ (defconstant read-only-space-start #x10000000)
+ (defconstant read-only-space-end #x15000000)
+
+ (defconstant static-space-start #x28000000)
+ (defconstant static-space-end #x2c000000)
+
+ ;; From alpha/parms.lisp:
+ ;; this is used in PURIFY as part of a sloppy check to see if a pointer
+ ;; is in dynamic space. Chocolate brownie for the first person to fix it
+ ;; -dan 20010502
+ (defconstant dynamic-space-start #x30000000)
+ (defconstant dynamic-space-end #x38000000)
+
+ (defconstant dynamic-0-space-start #x30000000)
+ (defconstant dynamic-0-space-end #x38000000)
+
+ (defconstant dynamic-1-space-start #x40000000)
+ (defconstant dynamic-1-space-end #x48000000)
+
+ (defconstant control-stack-start #x50000000)
+ (defconstant control-stack-end #x51000000)
+
+ (defconstant binding-stack-start #x60000000)
+ (defconstant binding-stack-end #x61000000))
+
+#!+solaris ; maybe someday.
+(progn
+ (defparameter target-read-only-space-start #x10000000)
+ (defparameter target-static-space-start #x28000000)
+ (defparameter target-dynamic-space-start #x40000000))
+\f
+;;;; other random constants.
+
+(defenum (:suffix -trap :start 8)
+ halt
+ pending-interrupt
+ error
+ cerror
+ breakpoint
+ fun-end-breakpoint
+ after-breakpoint)
+
+(defenum (:prefix object-not- :suffix -trap :start 16)
+ list
+ instance)
+
+(defenum (:prefix trace-table-)
+ normal
+ call-site
+ fun-prologue
+ fun-epilogue)
+\f
+;;;; static symbols.
+
+;;; 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.
+ *posix-argv*
+ ;;lisp::lisp-environment-list
+ ;;lisp::lisp-command-line-list
+ sb!impl::*!initial-fdefn-objects*
+
+ ;; Functions that the C code needs to call
+ maybe-gc
+ sb!kernel::internal-error
+ sb!di::handle-breakpoint
+ sb!di::handle-fun-end-breakpoint
+
+ ;; Free Pointers.
+ *read-only-space-free-pointer*
+ *static-space-free-pointer*
+ *initial-dynamic-space-free-pointer*
+
+ ;; Things needed for non-local-exit.
+ *current-catch-block*
+ *current-unwind-protect-block*
+
+ ;; Interrupt Handling
+ *free-interrupt-context-index*
+ sb!unix::*interrupts-enabled*
+ sb!unix::*interrupt-pending*
+ ))
+
+(defparameter *static-funs*
+ '(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
+ ))
+\f
+;;;; Assembler parameters:
+
+;;; The number of bits per element in the assemblers code vector.
+;;;
+(defparameter *assembly-unit-length* 8)
+
+\f
+;;;; Pseudo-atomic trap number
+;;; KLUDGE
+#!-linux
+(defconstant pseudo-atomic-trap 16)
+#!+linux
+(defconstant pseudo-atomic-trap #x40)
--- /dev/null
+;;;; the VM definition of predicate VOPs for the Sparc
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; 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)))
+\f
+;;;; 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)))
+
--- /dev/null
+;;;; the Alpha VM definition of SAP operations
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; 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 "pointer to SAP coercion")
+ (:generator 1
+ (loadw y x sap-pointer-slot other-pointer-lowtag)))
+
+(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 "SAP to pointer coercion")
+ (:generator 20
+ (with-fixed-allocation (res ndescr sap-widetag sap-size)
+ (storew sap res sap-pointer-slot other-pointer-lowtag))))
+
+(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 "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-arg)
+ (:args (x :target y
+ :scs (sap-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y sap-reg))))
+ (:results (y))
+ (:note "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-arg :move-arg
+ (descriptor-reg sap-reg) (sap-reg))
+
+
+;;; Use standard MOVE-ARG + coercion to move an untagged SAP to a
+;;; descriptor passing location.
+(define-move-vop move-arg :move-arg
+ (sap-reg) (descriptor-reg))
+\f
+;;;; 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)))
+\f
+;;;; 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)))
+\f
+;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
+
+(macrolet ((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)))))))))))
+
+ (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)
+ ;; FIXME
+ #+ignore
+ (def-system-ref-and-set sap-ref-64 %set-sap-ref-64
+ unsigned-reg unsigned-num :quad nil)
+ #+ignore
+ (def-system-ref-and-set signed-sap-ref-64 %set-signed-sap-ref-64
+ signed-reg signed-num :quad 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)
+) ; MACROLET
+\f
+;;; 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 n-word-bytes) other-pointer-lowtag))))
+\f
+;;; Transforms for 64-bit SAP accessors.
+#+ignore
+(deftransform sap-ref-64 ((sap offset) (* *))
+ '(logior (ash (sap-ref-32 sap offset) 32)
+ (sap-ref-32 sap (+ offset 4))))
+
+#+ignore
+(deftransform signed-sap-ref-64 ((sap offset) (* *))
+ '(logior (ash (signed-sap-ref-32 sap offset) 32)
+ (sap-ref-32 sap (+ 4 offset))))
+
+#+ignore
+(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))))
+
+#+ignore
+(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))))
--- /dev/null
+;;;; temporary printing utilities and similar noise
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(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))))
--- /dev/null
+;;;; VOPs and macro magic for calling static functions
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(define-vop (static-fun-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-toplevel :load-toplevel :execute)
+
+(defun static-fun-template-name (num-args num-results)
+ (intern (format nil "~:@(~R-arg-~R-result-static-fun~)"
+ 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-fun-template-vop (num-args num-results)
+ (assert (and (<= num-args register-arg-count)
+ (<= num-results register-arg-count))
+ (num-args num-results)
+ "Either too many args (~W) or too many results (~W). Max = ~W"
+ 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-fun-template-name num-args num-results)
+ static-fun-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 ld func null-tn (static-fun-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 simple-fun-code-offset word-shift)
+ fun-pointer-lowtag))
+ (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
+
+
+;;; FIXME! This looks like a candidate for a dotimes to
+;;; register-arg-count.
+(macrolet ((frob (num-args num-res)
+ (static-fun-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-fun (name args &key (results '(x)) translate
+ policy cost arg-types result-types)
+ `(define-vop (,name
+ ,(static-fun-template-name (length args)
+ (length results)))
+ (:variant ',name)
+ (:note ,(format nil "static-fun ~@(~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)))))
--- /dev/null
+;;;; linkage information for standard static functions, and random vops
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; 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 list-pointer-lowtag)
+
+ (loadw ptr ptr cons-cdr-slot list-pointer-lowtag)
+ (inst add count count (fixnumize 1))
+ (test-type ptr temp loop nil list-pointer-lowtag)
+
+ (cerror-call vop done object-not-list-error ptr)
+
+ (emit-label done)
+ (move result count))))
+
+
+(define-static-fun length (object) :translate length)
+
--- /dev/null
+;;;; Sparc VM definitions of various system hacking operations
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; type frobbing VOPs
+
+(define-vop (lowtag-of)
+ (:translate lowtag-of)
+ (: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 lowtag-mask)))
+
+(define-vop (widetag-of)
+ (:translate widetag-of)
+ (: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-lowtag)
+ (inst b :eq done)
+ (inst cmp result other-pointer-lowtag)
+ (inst b :eq other-pointer)
+ (inst cmp result fun-pointer-lowtag)
+ (inst b :eq function-pointer)
+ (inst cmp result instance-pointer-lowtag)
+ (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 #b11)
+ (inst b :eq done)
+ (inst li result 0)
+ ;; It wasn't a fixnum, so get the low 8 bits.
+ (inst b done)
+ (inst and result object widetag-mask)
+
+ FUNCTION-POINTER
+ (inst b done)
+ (load-type result object (- fun-pointer-lowtag))
+
+ OTHER-POINTER
+ (load-type result object (- other-pointer-lowtag))
+
+ DONE))
+
+
+(define-vop (fun-subtype)
+ (:translate fun-subtype)
+ (:policy :fast-safe)
+ (:args (function :scs (descriptor-reg)))
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 6
+ (load-type result function (- fun-pointer-lowtag))))
+
+(define-vop (set-fun-subtype)
+ (:translate (setf fun-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
+ ;; FIXME: I don't understand what this hardcoded 3 is doing
+ ;; here. -- CSR, 2002-02-08
+ (inst stb type function (- 3 fun-pointer-lowtag))
+ (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 other-pointer-lowtag)
+ (inst srl res res n-widetag-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 fun-pointer-lowtag)
+ (inst srl res res n-widetag-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 other-pointer-lowtag)
+ (inst and t1 widetag-mask)
+ (sc-case data
+ (any-reg
+ (inst sll t2 data (- n-widetag-bits 2))
+ (inst or t1 t2))
+ (immediate
+ (inst or t1 (ash (tn-value data) n-widetag-bits)))
+ (zero))
+ (storew t1 x 0 other-pointer-lowtag)
+ (move res x)))
+
+
+(define-vop (make-fixnum)
+ (:args (ptr :scs (any-reg descriptor-reg)))
+ (:results (res :scs (any-reg descriptor-reg)))
+ (:generator 1
+ ;; FIXME: CMUCL comment:
+ ;; Some code (the hash table code) depends on this returning a
+ ;; positive number so make sure it does.
+ (inst sll res ptr 3)
+ (inst srl 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 sll temp val n-widetag-bits)
+ (inst or res temp (tn-value type)))
+ (t
+ (inst sra temp type 2)
+ (inst sll res val (- n-widetag-bits 2))
+ (inst or res res temp)))))
+
+\f
+;;;; 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)))
+
+\f
+;;;; 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 other-pointer-lowtag)
+ (inst srl ndescr n-widetag-bits)
+ (inst sll ndescr word-shift)
+ (inst sub ndescr other-pointer-lowtag)
+ (inst add sap code ndescr)))
+
+(define-vop (compute-fun)
+ (: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 other-pointer-lowtag)
+ (inst srl ndescr n-widetag-bits)
+ (inst sll ndescr word-shift)
+ (inst add ndescr offset)
+ (inst add ndescr (- fun-pointer-lowtag other-pointer-lowtag))
+ (inst add func code ndescr)))
+
+
+\f
+;;;; other random VOPs.
+
+
+(defknown sb!unix::receive-pending-interrupt () (values))
+(define-vop (sb!unix::receive-pending-interrupt)
+ (:policy :fast-safe)
+ (:translate sb!unix::receive-pending-interrupt)
+ (:generator 1
+ (inst unimp pending-interrupt-trap)))
+
+
+(define-vop (halt)
+ (:generator 1
+ (inst unimp halt-trap)))
+
+
+\f
+;;;; 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) n-word-bytes)
+ other-pointer-lowtag)))
+ (assert (typep offset '(signed-byte 13)))
+ (inst ld count count-vector offset)
+ (inst add count 1)
+ (inst st count count-vector offset))))
--- /dev/null
+;;;; This file is for stuff which was in CMU CL's insts.lisp
+;;;; file, but which in the SBCL build process can't be compiled
+;;;; into code for the cross-compilation host.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
--- /dev/null
+;;;; type testing and checking VOPs for the Sparc VM
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; 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))
+
+;;; moved to macros. FIXME.
+;;;(defun cost-to-test-types (type-codes)
+;;; (+ (* 2 (length type-codes))
+;;; (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
+;;;
+;;;(defparameter immediate-types
+;;; (list base-char-type unbound-marker-type))
+;;;
+;;;(defparameter function-header-types
+;;; (list funcallable-instance-header-type
+;;; byte-code-function-type byte-code-closure-type
+;;; function-header-type closure-function-header-type
+;;; closure-header-type))
+;;;
+;; FIXME: there's a canonicalize-headers in alpha/ and x86/
+
+(defmacro def-type-vops (pred-name check-name ptype error-code
+ &rest type-codes)
+ ;;; FIXME: #+sb-xc-host?
+ (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))))))
+
+;;; This is a direct translation of the code in CMUCL
+;;; compiler/sparc/macros.lisp. Don't blame me if it doesn't work.
+
+;;; moved test-type back to macros.lisp, as other bits of code use it
+;;; too. FIXME.
+
+
+
+
+
+;; Don't use this because it uses the deprecated taddcctv instruction.
+#+ignore
+(progn
+ (def-type-vops fixnump nil nil nil even-fixnum-lowtag odd-fixnum-lowtag)
+ (define-vop (check-fixnum check-type)
+ (:ignore temp)
+ (:generator 1
+ (inst taddcctv result value zero-tn)))
+ (primitive-type-vop check-fixnum (:check) fixnum))
+
+;; This avoids the taddcctv instruction
+(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
+ even-fixnum-lowtag odd-fixnum-lowtag)
+(def-type-vops functionp check-fun function
+ object-not-fun-error fun-pointer-lowtag)
+
+ ;; The following encode the error type and register in the trap
+ ;; instruction, however this breaks on the later sparc Ultra.
+ #+ignore
+ (progn
+ (def-type-vops listp nil nil nil list-pointer-lowtag)
+ (define-vop (check-list check-type)
+ (:generator 3
+ (inst and temp value lowtag-mask)
+ (inst cmp temp list-pointer-lowtag)
+ (inst t :ne (logior (ash (tn-offset value) 8) object-not-list-trap))
+ (move result value)))
+ (primitive-type-vop check-list (:check) list)
+
+ (def-type-vops %instancep nil nil nil instance-pointer-lowtag)
+ (define-vop (check-instance check-type)
+ (:generator 3
+ (inst and temp value lowtag-mask)
+ (inst cmp temp instance-pointer-lowtag)
+ (inst t :ne (logior (ash (tn-offset value) 8) object-not-instance-trap))
+ (move result value)))
+ (primitive-type-vop check-instance (:check) instance))
+
+ ;; These avoid the trap instruction.
+ (def-type-vops listp check-list list object-not-list-error
+ list-pointer-lowtag)
+ (def-type-vops %instancep check-instance instance object-not-instance-error
+ instance-pointer-lowtag)
+
+ (def-type-vops bignump check-bignum bignum
+ object-not-bignum-error bignum-widetag)
+
+ (def-type-vops ratiop check-ratio ratio
+ object-not-ratio-error ratio-widetag)
+
+ (def-type-vops complexp check-complex complex object-not-complex-error
+ complex-widetag complex-single-float-widetag
+ complex-double-float-widetag #!+long-float complex-long-float-widetag)
+
+ (def-type-vops complex-rational-p check-complex-rational nil
+ object-not-complex-rational-error complex-widetag)
+
+ (def-type-vops complex-float-p check-complex-float nil
+ object-not-complex-float-error
+ complex-single-float-widetag complex-double-float-widetag
+ #!+long-float complex-long-float-widetag)
+
+ (def-type-vops complex-single-float-p check-complex-single-float
+ complex-single-float object-not-complex-single-float-error
+ complex-single-float-widetag)
+
+ (def-type-vops complex-double-float-p check-complex-double-float
+ complex-double-float object-not-complex-double-float-error
+ complex-double-float-widetag)
+
+ #!+long-float
+ (def-type-vops complex-long-float-p check-complex-long-float
+ complex-long-float object-not-complex-long-float-error
+ complex-long-float-widetag)
+
+ (def-type-vops single-float-p check-single-float single-float
+ object-not-single-float-error single-float-widetag)
+
+ (def-type-vops double-float-p check-double-float double-float
+ object-not-double-float-error double-float-widetag)
+
+ #!+long-float
+ (def-type-vops long-float-p check-long-float long-float
+ object-not-long-float-error long-float-widetag)
+
+ (def-type-vops simple-string-p check-simple-string simple-string
+ object-not-simple-string-error simple-string-widetag)
+
+ (def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
+ object-not-simple-bit-vector-error simple-bit-vector-widetag)
+
+ (def-type-vops simple-vector-p check-simple-vector simple-vector
+ object-not-simple-vector-error simple-vector-widetag)
+
+ (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
+ simple-array-unsigned-byte-2-widetag)
+
+ (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
+ simple-array-unsigned-byte-4-widetag)
+
+ (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
+ simple-array-unsigned-byte-8-widetag)
+
+ (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
+ simple-array-unsigned-byte-16-widetag)
+
+ (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
+ simple-array-unsigned-byte-32-widetag)
+
+ (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-widetag)
+
+ (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-widetag)
+
+ (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-widetag)
+
+ (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-widetag)
+
+ (def-type-vops simple-array-single-float-p check-simple-array-single-float
+ simple-array-single-float object-not-simple-array-single-float-error
+ simple-array-single-float-widetag)
+
+ (def-type-vops simple-array-double-float-p check-simple-array-double-float
+ simple-array-double-float object-not-simple-array-double-float-error
+ simple-array-double-float-widetag)
+
+ #!+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
+ simple-array-long-float-widetag)
+
+ (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
+ simple-array-complex-single-float-widetag)
+
+ (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
+ simple-array-complex-double-float-widetag)
+
+ #!+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
+ simple-array-complex-long-float-widetag)
+
+ (def-type-vops base-char-p check-base-char base-char
+ object-not-base-char-error base-char-widetag)
+
+ (def-type-vops system-area-pointer-p check-system-area-pointer
+ system-area-pointer object-not-sap-error sap-widetag)
+
+ (def-type-vops weak-pointer-p check-weak-pointer weak-pointer
+ object-not-weak-pointer-error weak-pointer-widetag)
+ ;; FIXME
+#|
+ (def-type-vops scavenger-hook-p nil nil nil
+ 0)
+|#
+ (def-type-vops code-component-p nil nil nil
+ code-header-widetag)
+
+ (def-type-vops lra-p nil nil nil
+ return-pc-header-widetag)
+
+ (def-type-vops fdefn-p nil nil nil
+ fdefn-widetag)
+
+ (def-type-vops funcallable-instance-p nil nil nil
+ funcallable-instance-header-widetag)
+
+ (def-type-vops array-header-p nil nil nil
+ simple-array-widetag complex-string-widetag complex-bit-vector-widetag
+ complex-vector-widetag complex-array-widetag)
+
+ ;; This appears to have disappeared. FIXME -- CSR
+ (def-type-vops nil check-fun-or-symbol nil object-not-fun-or-symbol-error
+ fun-pointer-lowtag symbol-header-widetag)
+
+ (def-type-vops stringp check-string nil object-not-string-error
+ simple-string-widetag complex-string-widetag)
+
+ (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
+ simple-bit-vector-widetag complex-bit-vector-widetag)
+
+ (def-type-vops vectorp check-vector nil object-not-vector-error
+ simple-string-widetag simple-bit-vector-widetag simple-vector-widetag
+ simple-array-unsigned-byte-2-widetag simple-array-unsigned-byte-4-widetag
+ simple-array-unsigned-byte-8-widetag simple-array-unsigned-byte-16-widetag
+ simple-array-unsigned-byte-32-widetag
+ simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
+ simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
+ simple-array-single-float-widetag simple-array-double-float-widetag
+ #!+long-float simple-array-long-float-widetag
+ simple-array-complex-single-float-widetag
+ simple-array-complex-double-float-widetag
+ #!+long-float simple-array-complex-long-float-widetag
+ complex-string-widetag complex-bit-vector-widetag complex-vector-widetag)
+
+(def-type-vops complex-vector-p check-complex-vector nil object-not-complex-vector-error
+ complex-vector-widetag)
+
+ (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
+ simple-array-widetag simple-string-widetag simple-bit-vector-widetag
+ simple-vector-widetag simple-array-unsigned-byte-2-widetag
+ simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag
+ simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag
+ simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
+ simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
+ simple-array-single-float-widetag simple-array-double-float-widetag
+ #!+long-float simple-array-long-float-widetag
+ simple-array-complex-single-float-widetag
+ simple-array-complex-double-float-widetag
+ #!+long-float simple-array-complex-long-float-widetag)
+
+ (def-type-vops arrayp check-array nil object-not-array-error
+ simple-array-widetag simple-string-widetag simple-bit-vector-widetag
+ simple-vector-widetag simple-array-unsigned-byte-2-widetag
+ simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag
+ simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag
+ simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
+ simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
+ simple-array-single-float-widetag simple-array-double-float-widetag
+ #!+long-float simple-array-long-float-widetag
+ simple-array-complex-single-float-widetag
+ simple-array-complex-double-float-widetag
+ #!+long-float simple-array-complex-long-float-widetag
+ complex-string-widetag complex-bit-vector-widetag complex-vector-widetag
+ complex-array-widetag)
+
+ (def-type-vops numberp check-number nil object-not-number-error
+ even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag ratio-widetag
+ single-float-widetag double-float-widetag #!+long-float long-float-widetag
+ complex-widetag complex-single-float-widetag complex-double-float-widetag
+ #!+long-float complex-long-float-widetag)
+
+ (def-type-vops rationalp check-rational nil object-not-rational-error
+ even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag)
+
+ (def-type-vops integerp check-integer nil object-not-integer-error
+ even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag)
+
+ (def-type-vops floatp check-float nil object-not-float-error
+ single-float-widetag double-float-widetag #!+long-float long-float-widetag)
+
+ (def-type-vops realp check-real nil object-not-real-error
+ even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag
+ single-float-widetag double-float-widetag #!+long-float long-float-widetag)
+
+ \f
+;;;; 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 #x3)
+ (inst b :eq yep)
+ (test-type value temp nope t other-pointer-lowtag)
+ (loadw temp value 0 other-pointer-lowtag)
+ (inst cmp temp (+ (ash 1 n-widetag-bits)
+ bignum-widetag))
+ (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 #x3)
+ (inst b :eq yep)
+ (test-type value temp nope t other-pointer-lowtag)
+ (loadw temp value 0 other-pointer-lowtag)
+ (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
+ (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 #x3)
+ (inst b :eq fixnum)
+ (inst cmp value)
+
+ ;; If not, is it an other pointer?
+ (test-type value temp nope t other-pointer-lowtag)
+ ;; Get the header.
+ (loadw temp value 0 other-pointer-lowtag)
+ ;; Is it one?
+ (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
+ (inst b :eq single-word)
+ ;; If it's other than two, we can't be an
+ ;; (unsigned-byte 32)
+ (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag))
+ (inst b :ne nope)
+ ;; Get the second digit.
+ (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
+ ;; 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 bignum-digits-offset other-pointer-lowtag)
+ (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 #x3)
+ (inst b :eq fixnum)
+ (inst cmp value)
+
+ ;; If not, is it an other pointer?
+ (test-type value temp nope t other-pointer-lowtag)
+ ;; Get the number of digits.
+ (loadw temp value 0 other-pointer-lowtag)
+ ;; Is it one?
+ (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
+ (inst b :eq single-word)
+ ;; If it's other than two, we can't be an (unsigned-byte 32)
+ (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag))
+ (inst b :ne nope)
+ ;; Get the second digit.
+ (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
+ ;; 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 bignum-digits-offset other-pointer-lowtag)
+ ;; positive implies (unsigned-byte 32).
+ (inst cmp temp)
+
+ (emit-label fixnum)
+ (inst b :lt nope)
+ (inst nop)
+
+ (emit-label yep)
+ (move result value))))
+
+
+ \f
+;;;; 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 symbol-header-widetag)
+ (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 symbol-header-widetag)
+ (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 list-pointer-lowtag)
+ (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 list-pointer-lowtag)
+ (move result value))))
--- /dev/null
+;;;; the sparc implementation of unknown-values VOPs
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(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 n-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 cons-car-slot list-pointer-lowtag)
+ (loadw list list cons-cdr-slot list-pointer-lowtag)
+ (inst add csp-tn csp-tn n-word-bytes)
+ (storew temp csp-tn -1)
+ (test-type list ndescr loop nil list-pointer-lowtag)
+ (error-call vop bogus-arg-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) n-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 ld temp src i)
+ (inst b :ne loop)
+ (inst st temp dst i)
+ DONE))
--- /dev/null
+;;;; miscellaneous VM definition noise for the Sparc
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; Define the registers
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *register-names* (make-array 32 :initial-element nil)))
+
+(macrolet ((defreg (name offset)
+ (let ((offset-sym (symbolicate name "-OFFSET")))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant ,offset-sym ,offset)
+ (setf (svref *register-names* ,offset-sym)
+ ,(symbol-name name)))))
+
+ (defregset (name &rest regs)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter ,name
+ (list ,@(mapcar (lambda (name)
+ (symbolicate name "-OFFSET"))
+ regs))))))
+ ;; "c.f. src/runtime/sparc-lispregs.h
+
+ ;; 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.
+
+ ;; 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
+ (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
+ (defreg l0 26) ; %i2
+ (defreg nfp 27) ; %i3
+ (defreg cfunc 28) ; %i4
+ (defreg code 29) ; %i5
+ ;; we can't touch reg 30 if we ever want to return
+ (defreg lip 31) ; %i7
+
+ (defregset non-descriptor-regs
+ nl0 nl1 nl2 nl3 nl4 nl5 cfunc nargs nfp)
+
+ (defregset descriptor-regs
+ a0 a1 a2 a3 a4 a5 ocfp lra cname lexenv l0)
+
+ (defregset *register-arg-offsets*
+ a0 a1 a2 a3 a4 a5))
+\f
+;;;; 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.
+;;;
+;;; FIXME: This macro is not needed in the runtime target.
+(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)
+ ;; (The CMU CL version of this macro did
+ ;; `(EXPORT ',CONSTANT-NAME)
+ ;; here, but in SBCL we try to have package
+ ;; structure described statically in one
+ ;; master source file, instead of building it
+ ;; dynamically by letting all the system code
+ ;; modify it as the system boots.)
+ forms)))
+ (index 0 (1+ index))
+ (classes classes (cdr classes)))
+ ((null classes)
+ (nreverse forms))))
+
+;;; see comment in ../x86/vm.lisp. The value of 7 was taken from
+;;; vm:catch-block-size in a cmucl that I happened to have around
+;;; and seems to be working so far -dan
+;;;
+;;; arbitrarily taken for alpha, too. - Christophe
+(defconstant sb!vm::kludge-nondeterministic-catch-block-size 7)
+
+(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.
+ ;; 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)
+
+
+ ;; **** 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)
+
+ ;; 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-64 31 #!+sparc-64 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-64 31 #!+sparc-64 63
+ by 4 collect i)
+ :element-size 4 :alignment 4
+ :reserve-locations (28)
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (long-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-64 31 #!+sparc-64 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-64 31 #!+sparc-64 63
+ by 8 collect i)
+ :element-size 8 :alignment 8
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (complex-long-stack))
+
+
+ ;; A catch or unwind block.
+ (catch-block control-stack :element-size sb!vm::kludge-nondeterministic-catch-block-size))
+
+
+\f
+;;;; Make some random tns for important registers.
+
+(macrolet ((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)))))
+ (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))
+
+
+\f
+;;; 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))
+ (null
+ (sc-number-or-lose 'null))
+ ((or fixnum system-area-pointer character)
+ (sc-number-or-lose 'immediate))
+ (symbol
+ (if (static-symbol-p value)
+ (sc-number-or-lose 'immediate)
+ nil))))
+
+\f
+;;;; 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-toplevel :load-toplevel :execute)
+
+ ;; 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.
+ ;;
+ (defparameter register-arg-names '(a0 a1 a2 a3 a4 a5))
+); eval-when (:compile-toplevel :load-toplevel :execute)
+
+
+;;; 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*))
+
+;;; This is used by the debugger.
+(defconstant single-value-return-byte-offset 8)
+
+\f
+;;; 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)) ; FIXME: commented out on alpha
+ (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"))))
+
+\f
+;;; The loader uses this to convert alien names to the form they
+;;; occure in the symbol table (for example, prepending an
+;;; underscore). On the SPARC, we don't prepend an underscore.
+(defun extern-alien-name (name)
+ (declare (type simple-base-string name))
+ (concatenate 'string #+nil "_" name))
--- /dev/null
+# This software is part of the SBCL system. See the README file for
+# more information.
+#
+# This software is derived from the CMU CL system, which was
+# written at Carnegie Mellon University and released into the
+# public domain. The software is in the public domain and is
+# provided with absolutely no warranty. See the COPYING and CREDITS
+# files for more information.
+
+# -mcpu=pca56 makes _my_ alpha go fast, I'm told. Yours may do something
+# else.
+CFLAGS = -g -Wall -Dsparc
+ASFLAGS = -g -Wall -Dsparc
+LD = ld
+LINKFLAGS = -v -g
+NM = nm -p
+
+ASSEM_SRC = sparc-assem.S
+ARCH_SRC = sparc-arch.c undefineds.c
+#ARCH_SRC = sparc-arch.c ldso-stubs.S
+
+OS_SRC = linux-os.c sparc-linux-os.c os-common.c
+LINKFLAGS+=-static
+#LINKFLAGS+=-rdynamic
+OS_LIBS= -ldl
+
+GC_SRC= gc.c
void
arch_init(void)
{
- /* This must be called _after_ os_init, so we know what the page
- * size is. */
- if(mmap((os_vm_address_t) call_into_lisp_LRA_page,os_vm_page_size,
- OS_VM_PROT_ALL,MAP_PRIVATE|MAP_ANONYMOUS|MAP_FIXED,-1,0)
- == (os_vm_address_t) -1)
+ /* This must be called _after_ os_init(), so that we know what the
+ * page size is. */
+ if (mmap((os_vm_address_t) call_into_lisp_LRA_page,os_vm_page_size,
+ OS_VM_PROT_ALL,MAP_PRIVATE|MAP_ANONYMOUS|MAP_FIXED,-1,0)
+ == (os_vm_address_t) -1)
perror("mmap");
/* call_into_lisp_LRA is a collection of trampolines written in asm -
sig, code, context); */
pc= (unsigned int *)(*os_context_pc_addr(context));
- if(((unsigned long)pc) & 3) {
+ if (((unsigned long)pc) & 3) {
return NULL; /* In what case would pc be unaligned?? */
}
- if( (pc < READ_ONLY_SPACE_START ||
- pc >= READ_ONLY_SPACE_START+READ_ONLY_SPACE_SIZE) &&
- (pc < current_dynamic_space ||
- pc >= current_dynamic_space + DYNAMIC_SPACE_SIZE))
+ if ( (pc < READ_ONLY_SPACE_START ||
+ pc >= READ_ONLY_SPACE_START+READ_ONLY_SPACE_SIZE) &&
+ (pc < current_dynamic_space ||
+ pc >= current_dynamic_space + DYNAMIC_SPACE_SIZE))
return NULL;
badinst = *pc;
- if(((badinst>>27)!=0x16) /* STL or STQ */
- && ((badinst>>27)!=0x13)) /* STS or STT */
- return NULL; /* Otherwise forget about address. */
+ if (((badinst>>27)!=0x16) /* STL or STQ */
+ && ((badinst>>27)!=0x13)) /* STS or STT */
+ return NULL; /* Otherwise forget about address. */
return (os_vm_address_t)
(*os_context_register_addr(context,((badinst>>16)&0x1f))
branch = 1;
break;
case 0x31: /* fbeq */
- if(*(os_context_fpregister_addr(context,reg_a))==0) branch = 1;
+ if (*(os_context_float_register_addr(context,reg_a))==0) branch = 1;
break;
case 0x32: /* fblt */
- if(*os_context_fpregister_addr(context,reg_a)<0) branch = 1;
+ if (*os_context_float_register_addr(context,reg_a)<0) branch = 1;
break;
case 0x33: /* fble */
- if(*os_context_fpregister_addr(context,reg_a)<=0) branch = 1;
+ if (*os_context_float_register_addr(context,reg_a)<=0) branch = 1;
break;
case 0x34: /* bsr */
*os_context_register_addr(context,reg_a)=*os_context_pc_addr(context);
branch = 1;
break;
case 0x35: /* fbne */
- if(*os_context_register_addr(context,reg_a)!=0) branch = 1;
+ if (*os_context_register_addr(context,reg_a)!=0) branch = 1;
break;
case 0x36: /* fbge */
- if(*os_context_fpregister_addr(context,reg_a)>=0) branch = 1;
+ if (*os_context_float_register_addr(context,reg_a)>=0) branch = 1;
break;
case 0x37: /* fbgt */
- if(*os_context_fpregister_addr(context,reg_a)>0) branch = 1;
+ if (*os_context_float_register_addr(context,reg_a)>0) branch = 1;
break;
case 0x38: /* blbc */
- if((*os_context_register_addr(context,reg_a)&1) == 0) branch = 1;
+ if ((*os_context_register_addr(context,reg_a)&1) == 0) branch = 1;
break;
case 0x39: /* beq */
- if(*os_context_register_addr(context,reg_a)==0) branch = 1;
+ if (*os_context_register_addr(context,reg_a)==0) branch = 1;
break;
case 0x3a: /* blt */
- if(*os_context_register_addr(context,reg_a)<0) branch = 1;
+ if (*os_context_register_addr(context,reg_a)<0) branch = 1;
break;
case 0x3b: /* ble */
- if(*os_context_register_addr(context,reg_a)<=0) branch = 1;
+ if (*os_context_register_addr(context,reg_a)<=0) branch = 1;
break;
case 0x3c: /* blbs */
- if((*os_context_register_addr(context,reg_a)&1)!=0) branch = 1;
+ if ((*os_context_register_addr(context,reg_a)&1)!=0) branch = 1;
break;
case 0x3d: /* bne */
- if(*os_context_register_addr(context,reg_a)!=0) branch = 1;
+ if (*os_context_register_addr(context,reg_a)!=0) branch = 1;
break;
case 0x3e: /* bge */
- if(*os_context_register_addr(context,reg_a)>=0) branch = 1;
+ if (*os_context_register_addr(context,reg_a)>=0) branch = 1;
break;
case 0x3f: /* bgt */
- if(*os_context_register_addr(context,reg_a)>0) branch = 1;
+ if (*os_context_register_addr(context,reg_a)>0) branch = 1;
break;
}
if (branch)
/* Figure out where we will end up after running the displaced
* instruction */
- if(op == 0x1a || (op&0xf) == 0x30) /* a branch */
+ if (op == 0x1a || (op&0xf) == 0x30) /* a branch */
/* The cast to long is just to shut gcc up. */
next_pc = (unsigned int *)((long)emulate_branch(context,orig_inst));
else
* different opcode so we can test whether we're dealing with a
* breakpoint or a "system service" */
- if((*(unsigned int*)(*os_context_pc_addr(context)-4))== BREAKPOINT_INST) {
- if(after_breakpoint) {
+ if ((*(unsigned int*)(*os_context_pc_addr(context)-4))==BREAKPOINT_INST) {
+ if (after_breakpoint) {
/* see comments above arch_do_displaced_inst. This is where
* we reinsert the breakpoint that we removed earlier */
--- /dev/null
+#ifndef _ALPHA_ARCH_H
+#define _ALPHA_ARCH_H
+
+#define ARCH_HAS_FLOAT_REGISTERS
+
+#endif /* _ALPHA_ARCH_H */
#include "gencgc.h"
#endif
-sigcontext_register_t *
+os_context_register_t *
os_context_register_addr(os_context_t *context, int offset)
{
return &context->uc_mcontext.sc_regs[offset];
}
-sigcontext_register_t *
-os_context_fpregister_addr(os_context_t *context, int offset)
+os_context_register_t *
+os_context_float_register_addr(os_context_t *context, int offset)
{
return &context->uc_mcontext.sc_fpregs[offset];
}
-sigcontext_register_t *
+os_context_register_t *
os_context_pc_addr(os_context_t *context)
{
return &((context->uc_mcontext).sc_pc);
}
-sigcontext_register_t *
-os_context_sp_addr(os_context_t *context)
-{
- lose("This was supposed to be an x86-only operation");
- return 0;
-}
sigset_t *
os_context_sigmask_addr(os_context_t *context)
--- /dev/null
+#ifndef _ALPHA_LINUX_OS_H
+#define _ALPHA_LINUX_OS_H
+
+typedef struct ucontext os_context_t;
+
+static inline os_context_t *arch_os_get_context(void **void_context) {
+ return (os_context_t *) *void_context;
+}
+
+#endif /* _ALPHA_LINUX_OS_H */
typedef vm_size_t os_vm_size_t;
typedef off_t os_vm_offset_t;
typedef int os_vm_prot_t;
+typedef int os_context_register_t;
#if defined __FreeBSD__
/* Note: The man page for sigaction(2) in FreeBSD 4.0 says that this
#error unsupported BSD variant
#endif
+#include "target-arch-os.h"
+#include "target-arch.h"
+
#define OS_VM_PROT_READ PROT_READ
#define OS_VM_PROT_WRITE PROT_WRITE
#define OS_VM_PROT_EXECUTE PROT_EXEC
#include "interr.h"
/* So you need to debug? */
-#if 0
#define PRINTNOISE
#define DEBUG_SPACE_PREDICATES
+#if 0
+#define DEBUG_SPACE_PREDICATES
#define DEBUG_SCAVENGE_VERBOSE
#define DEBUG_COPY_VERBOSE
#define DEBUG_CODE_GC
lose("GC lossage. Current dynamic space is bogus!\n");
}
new_space_free_pointer = new_space;
-
+#if 0
+ /* at one time we had the bright idea of using mprotect() to
+ * hide the semispace that we're not using at the moment, so
+ * we'd see immediately if anyone had a pointer to it.
+ * Unfortunately, if we gc during a call to an assembler
+ * routine with a "raw" return style, at least on PPC we are
+ * expected to return into oldspace because we can't easily
+ * update the link register - it's not tagged, and we can't do
+ * it as an offset of reg_CODE because the calling routine
+ * might be nowhere near our code vector. We hope that we
+ * don't run very far in oldspace before it catapults us into
+ * newspace by either calling something else or returning
+ */
+
+ /* write-enable */
+ os_protect(new_space,DYNAMIC_SPACE_SIZE,OS_VM_PROT_ALL);
+#endif
/* Initialize the weak pointer list. */
weak_pointers = (struct weak_pointer *) NULL;
#endif
gc_rate = ((float) size_retained / (float) (1<<20)) / real_time;
-
+
printf("%10.2f M bytes/sec collected.\n", gc_rate);
#endif
+ /* os_flush_icache((os_vm_address_t) 0, sizeof(unsigned long)); */
+
+#if 0
+ /* see comment above about mprotecting oldspace */
+
+ /* zero the from space now, to make it easier to find stale
+ pointers to it */
+
+ /* pray that both dynamic spaces are the same size ... */
+ memset(from_space,(DYNAMIC_0_SPACE_END-DYNAMIC_0_SPACE_START-1),0);
+ os_protect(from_space,DYNAMIC_SPACE_SIZE,0); /* write-protect */
+#endif
}
\f
words_scavenged = 1;
}
}
- else if(nwords==1) {
+ else if (nwords==1) {
/* there are some situations where an
other-immediate may end up in a descriptor
register. I'm not sure whether this is
other than a pointer, just hush it up */
words_scavenged=1;
- if((scavtab[type]==scav_lose) ||
+ if ((scavtab[type]==scav_lose) ||
(((scavtab[type])(start,object))>1)) {
fprintf(stderr,"warning: attempted to scavenge non-descriptor value %x at %p. If you can\nreproduce this warning, send a test case to sbcl-devel@lists.sourceforge.net\n",
object,start);
int lip_register_pair;
#endif
unsigned long pc_code_offset;
-#ifdef SC_NPC
+#ifdef ARCH_HAS_LINK_REGISTER
+ unsigned long lr_code_offset;
+#endif
+#ifdef ARCH_HAS_NPC_REGISTER
unsigned long npc_code_offset;
#endif
-
+ fprintf(stderr, "Scavenging interrupt context at 0x%x\n",context);
/* Find the LIP's register pair and calculate its offset */
/* before we scavenge the context. */
#ifdef reg_LIP
/* Compute the PC's offset from the start of the CODE */
/* register. */
- pc_code_offset = *os_context_pc_addr(context) -
+ pc_code_offset =
+ *os_context_pc_addr(context) -
+ *os_context_register_addr(context, reg_CODE);
+#ifdef ARCH_HAS_NPC_REGISTER
+ npc_code_offset =
+ *os_context_npc_addr(context) -
*os_context_register_addr(context, reg_CODE);
-#ifdef SC_NPC
- npc_code_offset = SC_NPC(context) - SC_REG(context, reg_CODE);
-#endif SC_NPC
+#endif
+#ifdef ARCH_HAS_LINK_REGISTER
+ lr_code_offset =
+ *os_context_lr_addr(context) -
+ *os_context_register_addr(context, reg_CODE);
+#endif
- /* Scanvenge all boxed registers in the context. */
+ /* Scavenge all boxed registers in the context. */
for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
int index;
lispobj foo;
if (from_space_p(*os_context_pc_addr(context)))
*os_context_pc_addr(context) =
*os_context_register_addr(context, reg_CODE) + pc_code_offset;
-#ifdef SC_NPC
- if (from_space_p(SC_NPC(context)))
- SC_NPC(context) = SC_REG(context, reg_CODE) + npc_code_offset;
-#endif SC_NPC
+#ifdef ARCH_HAS_LINK_REGISTER
+ /* Fix the LR ditto; important if we're being called from
+ * an assembly routine that expects to return using blr, otherwise
+ * harmless */
+ if (from_space_p(*os_context_lr_addr(context)))
+ *os_context_lr_addr(context) =
+ *os_context_register_addr(context, reg_CODE) + lr_code_offset;
+#endif
+
+#ifdef ARCH_HAS_NPC_REGISTER
+ if (from_space_p(*os_context_npc_addr(context)))
+ *os_context_npc_addr(context) =
+ *os_context_register_addr(context, reg_CODE) + npc_code_offset;
+#endif
}
void scavenge_interrupt_contexts(void)
index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
+ fprintf(stderr, "%d interrupt contexts to scan\n",index);
for (i = 0; i < index; i++) {
context = lisp_interrupt_contexts[i];
scavenge_interrupt_context(context);
printf("trans_return_pc_header object=%x, code=%lx\n",object,code);
#endif
ncode = trans_code(code);
- if(object==0x304748d7) {
+ if (object==0x304748d7) {
/* monitor_or_something(); */
}
ret= ((lispobj) LOW_WORD(ncode) + offset) | OTHER_POINTER_LOWTAG;
long length =
DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
- if(addr < (os_vm_address_t)dynamic_space_free_pointer) {
+ if (addr < (os_vm_address_t)dynamic_space_free_pointer) {
fprintf(stderr,
"set_auto_gc_trigger: tried to set gc trigger too low! (%d < %p)\n",
(unsigned int)dynamic_usage,
void clear_auto_gc_trigger(void)
{
- if(current_auto_gc_trigger!=NULL){
+ if (current_auto_gc_trigger!=NULL){
#if defined(SUNOS) || defined(SOLARIS)/* don't want to force whole space into swapping mode... */
os_vm_address_t addr=(os_vm_address_t)current_auto_gc_trigger;
os_vm_size_t length=
#include <stdlib.h>
#include <signal.h>
-#ifdef mach /* KLUDGE: #ifdef on lowercase symbols? Ick. -- WHN 19990904 */
-#ifdef mips
-#include <mips/cpu.h>
-#endif
-#endif
#include "runtime.h"
#include "arch.h"
{
undo_fake_foreign_function_call(context);
}
+ fprintf(stderr,"interrupt-handle-pending: back from MAYBE_GC\n");
}
/* FIXME: This isn't very clear. It would be good to reverse
* anyway. Why we still need to copy the pending_mask into the
* context given that we're now done with the context anyway, I
* couldn't say. */
- memcpy(os_context_sigmask_addr(context), &pending_mask, sizeof(sigset_t));
+#if 0
+ memcpy(os_context_sigmask_addr(context), &pending_mask,
+ 4 /* sizeof(sigset_t) */ );
+#endif
sigemptyset(&pending_mask);
if (pending_signal) {
int signal = pending_signal;
if (ARE_SAME_HANDLER(handler.c, SIG_IGN)) {
return;
}
-
+
#ifndef __i386__
were_in_lisp = !foreign_function_call_active;
if (were_in_lisp)
#include "gencgc.h"
#endif
\f
+
+#ifdef sparc
+int early_kernel = 0;
+#endif
void os_init(void)
{
/* Early versions of Linux don't support the mmap(..) functionality
{
struct utsname name;
int major_version;
+#ifdef sparc
+ int minor_version;
+#endif
uname(&name);
major_version = atoi(name.release);
if (major_version < 2) {
lose("linux major version=%d (can't run in version < 2.0.0)",
major_version);
}
+#ifdef sparc
+ /* KLUDGE: This will break if Linux moves to a uname() version number
+ * that has more than one digit initially -- CSR, 2002-02-12 */
+ minor_version = atoi(name.release+2);
+ if (minor_version < 4) {
+ fprintf(stderr,"linux minor version=%d;\n enabling workarounds for SPARC kernel bugs in signal handling.\n", minor_version);
+ early_kernel = 1;
+ }
+#endif
}
os_vm_page_size = getpagesize();
MAP_PRIVATE | MAP_FILE | MAP_FIXED,
fd, (off_t) offset);
- if(addr == MAP_FAILED) {
+ if (addr == MAP_FAILED) {
perror("mmap");
lose("unexpected mmap(..) failure");
}
void
sigsegv_handler(int signal, siginfo_t *info, void* void_context)
{
- os_context_t *context = (os_context_t*)void_context;
+ os_context_t *context = arch_os_get_context(&void_context);
void* fault_addr = (void*)context->uc_mcontext.cr2;
if (!gencgc_handle_wp_violation(fault_addr)) {
interrupt_handle_now(signal, info, void_context);
static void
sigsegv_handler(int signal, siginfo_t *info, void* void_context)
{
- os_context_t *context = (os_context_t*)void_context;
+ os_context_t *context = arch_os_get_context(&void_context);
os_vm_address_t addr;
#ifdef __i386__
addr = arch_get_bad_addr(signal,info,context);
- if(addr != NULL &&
+ if (addr != NULL &&
*os_context_register_addr(context,reg_ALLOC) & (1L<<63)){
/* This is the end of a pseudo-atomic section during which
* a signal was received. We must deal with the pending interrupt
#include <sys/syscall.h>
#include <asm/unistd.h>
#include <linux/version.h>
+#include "target-arch-os.h"
+#include "target-arch.h"
#define linuxversion(a, b, c) (((a)<<16)+((b)<<8)+(c))
typedef off_t os_vm_offset_t;
typedef int os_vm_prot_t;
-typedef struct ucontext os_context_t;
+/* typedef struct ucontext os_context_t;*/
#define OS_VM_PROT_READ PROT_READ
#define OS_VM_PROT_WRITE PROT_WRITE
#define SET_FPU_CONTROL_WORD(cw) asm("fldcw %0" : : "m" (cw))
/* /usr/include/asm/sigcontext.h */
-typedef long sigcontext_register_t ;
+typedef long os_context_register_t ;
* files for more information.
*/
-#if defined(mips) || defined(irix)
-#include "mips-lispregs.h"
-#endif
-
-#ifdef sparc
-#include "sparc-lispregs.h"
-#endif
-
-#ifdef __i386__
-#include "x86-lispregs.h"
-#endif
-
-#ifdef parisc
-#include "hppa-lispregs.h"
-#endif
-
-#ifdef alpha
-#include "alpha-lispregs.h"
-#endif
+#include "target-lispregs.h"
#ifndef LANGUAGE_ASSEMBLY
extern char *lisp_register_names[];
os_invalidate(block_start, block_size);
addr = os_validate(block_start, block_size);
- if(addr == NULL || addr != block_start)
+ if (addr == NULL || addr != block_start)
lose("os_zero: block moved! 0x%08x ==> 0x%08x",
block_start,
addr);
len=os_round_up_size_to_page(len);
old_len=os_round_up_size_to_page(old_len);
- if(addr==NULL)
+ if (addr==NULL)
return os_allocate(len);
else{
long len_diff=len-old_len;
- if(len_diff<0)
+ if (len_diff<0)
os_invalidate(addr+len,-len_diff);
else{
- if(len_diff!=0){
+ if (len_diff!=0) {
os_vm_address_t new=os_allocate(len);
if(new!=NULL){
* the type used to represent context in a POSIX sigaction SA_SIGACTION
* handler, i.e. the actual type of the thing pointed to by the
* void* third argument of a handler */
-#if defined __FreeBSD__
-#include "bsd-os.h"
-#elif defined __OpenBSD__
-#include "bsd-os.h"
-#elif defined __linux__
-#include "linux-os.h"
-#else
-#error unsupported OS
-#endif
+
+/*
+ #if defined __FreeBSD__
+ #include "bsd-os.h"
+ #elif defined __OpenBSD__
+ #include "bsd-os.h"
+ #elif defined __linux__
+ #include "linux-os.h"
+ #else
+ #error unsupported OS
+ #endif
+*/
+
+#include "target-os.h"
+
#define OS_VM_PROT_ALL \
(OS_VM_PROT_READ | OS_VM_PROT_WRITE | OS_VM_PROT_EXECUTE)
* register, of the specified offset, for that context. The offset is
* defined in the storage class (SC) defined in the Lisp virtual
* machine (i.e. the file "vm.lisp" for the appropriate architecture). */
-register_t *os_context_register_addr(os_context_t *context, int offset);
+os_context_register_t *
+os_context_register_addr(os_context_t *context, int offset);
+
+/* FIXME: Pending investigation, this #ifdef stays as alpha. If it
+ * turns out that the alpha truly requires this, it can change to
+ * ARCH_HAS_FLOAT_REGISTERS (currently #defined in alpha-arch.h -- CSR
+ * 2002-02-04 */
#ifdef alpha
-register_t *os_context_fpregister_addr(os_context_t *context, int offset);
+os_context_register_t *
+os_context_float_register_addr(os_context_t *context, int offset);
#endif
/* Given a signal context, return the address for storage of the
* program counter for that context. */
-register_t *os_context_pc_addr(os_context_t *context);
+os_context_register_t *os_context_pc_addr(os_context_t *context);
+#ifdef ARCH_HAS_NPC_REGISTER
+os_context_register_t *os_context_npc_addr(os_context_t *context);
+#endif
+#ifdef ARCH_HAS_LINK_REGISTER
+os_context_register_t *os_context_lr_addr(os_context_t *context);
+#endif
/* Given a signal context, return the address for storage of the
* system stack pointer for that context. */
-register_t *os_context_sp_addr(os_context_t *context);
-
+#ifdef ARCH_HAS_STACK_POINTER
+os_context_register_t *os_context_sp_addr(os_context_t *context);
+#endif
/* Given a signal context, return the address for storage of the
* signal mask for that context. */
sigset_t *os_context_sigmask_addr(os_context_t *context);
/* This file can be skipped if we're not supporting LDB. */
#if defined(LISP_FEATURE_SB_LDB)
-#include "sbcl.h"
#include "monitor.h"
#include "vars.h"
#include "os.h"
char *lowtag_Names[] = {
"even fixnum",
- "function pointer",
+ "instance pointer",
"other immediate [0]",
"list pointer",
"odd fixnum",
- "instance pointer",
+ "function pointer",
"other immediate [1]",
"other pointer"
};
static char *ratio_slots[] = {"numer: ", "denom: ", NULL};
static char *complex_slots[] = {"real: ", "imag: ", NULL};
static char *code_slots[] = {"words: ", "entry: ", "debug: ", NULL};
-static char *fn_slots[] = {"self: ", "next: ", "name: ", "arglist: ", "type: ", NULL};
+static char *fn_slots[] = {
+ "self: ", "next: ", "name: ", "arglist: ", "type: ", NULL};
static char *closure_slots[] = {"fn: ", NULL};
static char *funcallable_instance_slots[] = {"fn: ", "lexenv: ", "layout: ", NULL};
static char *weak_pointer_slots[] = {"value: ", NULL};
static void print_obj(char *prefix, lispobj obj)
{
static void (*verbose_fns[])(lispobj obj)
- = {print_fixnum, print_otherptr, print_otherimm, print_list,
- print_fixnum, print_struct, print_otherimm, print_otherptr};
+ = {print_fixnum, print_struct, print_otherimm, print_list,
+ print_fixnum, print_otherptr, print_otherimm, print_otherptr};
static void (*brief_fns[])(lispobj obj)
- = {brief_fixnum, brief_otherptr, brief_otherimm, brief_list,
- brief_fixnum, brief_struct, brief_otherimm, brief_otherptr};
+ = {brief_fixnum, brief_struct, brief_otherimm, brief_list,
+ brief_fixnum, brief_otherptr, brief_otherimm, brief_otherptr};
int type = lowtag_of(obj);
struct var *var = lookup_by_obj(obj);
char buffer[256];
dynamic_pointer_p(lispobj ptr)
{
#ifndef __i386__
- /* KLUDGE: This has an implicit dependence on the ordering of
- * address spaces, and is therefore basically wrong. I'd fix it,
- * but I don't have a non-386 port to test it on. Porters are
- * encouraged to fix it. -- WHN 2000-10-17 */
- return (ptr >= (lispobj)DYNAMIC_SPACE_START);
+ return (ptr >= (lispobj)current_dynamic_space
+ &&
+ ptr < (lispobj)dynamic_space_free_pointer);
#else
/* Be more conservative, and remember, this is a maybe. */
return (ptr >= (lispobj)DYNAMIC_SPACE_START
return 0;
}
/* Is it plausible cons? */
- if((is_lisp_pointer(start_addr[0])
+ if ((is_lisp_pointer(start_addr[0])
|| ((start_addr[0] & 3) == 0) /* fixnum */
|| (widetag_of(start_addr[0]) == BASE_CHAR_WIDETAG)
|| (widetag_of(start_addr[0]) == UNBOUND_MARKER_WIDETAG))
}
return 0;
}
- /* Is it plausible? Not a cons. X should check the headers. */
- if(is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
+ /* Is it plausible? Not a cons. XXX should check the headers. */
+ if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
if (pointer_filter_verbose) {
fprintf(stderr,"*Wo2: %x %x %x\n", (unsigned int) pointer,
(unsigned int) start_addr, *start_addr);
/* Arrange to scavenge the debug info later. */
pscav_later(&new->debug_info, 1);
- if(new->trace_table_offset & 0x3)
+ if (new->trace_table_offset & 0x3)
#if 0
pscav(&new->trace_table_offset, 1, 0);
#else
--- /dev/null
+/*
+
+ $Header$
+
+ This code was written as part of the CMU Common Lisp project at
+ Carnegie Mellon University, and has been placed in the public domain.
+
+*/
+
+#include <stdio.h>
+
+#include "runtime.h"
+#include "arch.h"
+#include "sbcl.h"
+#include "globals.h"
+#include "validate.h"
+#include "os.h"
+#include "lispregs.h"
+#include "signal.h"
+#include "alloc.h"
+#include "interrupt.h"
+#include "interr.h"
+#include "breakpoint.h"
+#include "monitor.h"
+
+#ifdef linux
+extern int early_kernel;
+#endif
+
+void arch_init(void)
+{
+ return;
+}
+
+os_vm_address_t arch_get_bad_addr(int sig, siginfo_t *code, os_context_t *context)
+{
+ unsigned long badinst;
+ unsigned long *pc;
+ int rs1;
+
+ pc = (unsigned long *)(*os_context_pc_addr(context));
+
+ /* On the sparc, we have to decode the instruction. */
+
+ /* Make sure it's not the pc thats bogus, and that it was lisp code */
+ /* that caused the fault. */
+ if ((unsigned long) pc & 3) {
+ /* Unaligned */
+ return NULL;
+ }
+ if ((pc < READ_ONLY_SPACE_START ||
+ pc >= READ_ONLY_SPACE_START+READ_ONLY_SPACE_SIZE) &&
+ (pc < current_dynamic_space ||
+ pc >= current_dynamic_space + DYNAMIC_SPACE_SIZE)) {
+ return NULL;
+ }
+
+ badinst = *pc;
+
+ if ((badinst >> 30) != 3)
+ /* All load/store instructions have op = 11 (binary) */
+ return 0;
+
+ rs1 = (badinst>>14)&0x1f;
+
+ if (badinst & (1<<13)) {
+ /* r[rs1] + simm(13) */
+ int simm13 = badinst & 0x1fff;
+
+ if (simm13 & (1<<12))
+ simm13 |= -1<<13;
+
+ return (os_vm_address_t)
+ (*os_context_register_addr(context, rs1)+simm13);
+ }
+ else {
+ /* r[rs1] + r[rs2] */
+ int rs2 = badinst & 0x1f;
+
+ return (os_vm_address_t)
+ (*os_context_register_addr(context, rs1) +
+ *os_context_register_addr(context, rs2));
+ }
+}
+
+void arch_skip_instruction(os_context_t *context)
+{
+ ((char *) *os_context_pc_addr(context)) = ((char *) *os_context_npc_addr(context));
+ context->si_regs.npc += 4;
+}
+
+unsigned char *arch_internal_error_arguments(os_context_t *context)
+{
+ return (unsigned char *)(*os_context_pc_addr(context) + 4);
+}
+
+boolean arch_pseudo_atomic_atomic(os_context_t *context)
+{
+ return ((*os_context_register_addr(context,reg_ALLOC)) & 4);
+}
+
+void arch_set_pseudo_atomic_interrupted(os_context_t *context)
+{
+ *os_context_register_addr(context,reg_ALLOC) |= 1;
+}
+
+unsigned long arch_install_breakpoint(void *pc)
+{
+ unsigned long *ptr = (unsigned long *)pc;
+ unsigned long result = *ptr;
+ *ptr = trap_Breakpoint;
+
+ os_flush_icache((os_vm_address_t) pc, sizeof(unsigned long));
+
+ return result;
+}
+
+void arch_remove_breakpoint(void *pc, unsigned long orig_inst)
+{
+ *(unsigned long *)pc = orig_inst;
+ os_flush_icache((os_vm_address_t) pc, sizeof(unsigned long));
+}
+
+static unsigned long *skipped_break_addr, displaced_after_inst;
+static sigset_t orig_sigmask;
+
+void arch_do_displaced_inst(os_context_t *context, unsigned int orig_inst)
+{
+ unsigned long *pc = (unsigned long *)(*os_context_pc_addr(context));
+ /* FIXME */
+ unsigned long *npc = &context->si_regs.npc;
+
+ /* orig_sigmask = context->sigmask;
+ sigemptyset(&context->sigmask); */
+ /* FIXME!!! */
+ /* FILLBLOCKSET(&context->uc_sigmask);*/
+
+ *pc = orig_inst;
+ os_flush_icache((os_vm_address_t) pc, sizeof(unsigned long));
+ skipped_break_addr = pc;
+ displaced_after_inst = *npc;
+ *npc = trap_AfterBreakpoint;
+ os_flush_icache((os_vm_address_t) npc, sizeof(unsigned long));
+
+ /* How much is this not going to work? */
+ sigreturn(context);
+}
+
+static int pseudo_atomic_trap_p(os_context_t *context)
+{
+ unsigned int* pc;
+ unsigned int badinst;
+ int result;
+
+
+ pc = (unsigned int*) *os_context_pc_addr(context);
+ badinst = *pc;
+ result = 0;
+
+ /* Check to see if the current instruction is a trap #x40 */
+ /* FIXME: As written, this will not work when someone comes to port
+ this to Solaris. We have chosen trap 0x40 on SPARC Linux because
+ trap 0x10, used in CMUCL/Solaris, generates a sigtrap rather than
+ a sigill. This number should not be hardcoded, but should come,
+ if possible, from src/compiler/target/parms.lisp via sbcl.h --
+ CSR */
+ if (((badinst >> 30) == 2) && (((badinst >> 19) & 0x3f) == 0x3a)
+ && (((badinst >> 13) & 1) == 1) && ((badinst & 0x7f) == 0x40))
+ {
+ unsigned int previnst;
+ previnst = pc[-1];
+ /*
+ * Check to see if the previous instruction was an andcc alloc-tn,
+ * 3, zero-tn instruction.
+ */
+ if (((previnst >> 30) == 2) && (((previnst >> 19) & 0x3f) == 0x11)
+ && (((previnst >> 14) & 0x1f) == reg_ALLOC)
+ && (((previnst >> 25) & 0x1f) == reg_ZERO)
+ && (((previnst >> 13) & 1) == 1)
+ && ((previnst & 0x1fff) == 3))
+ {
+ result = 1;
+ }
+ else
+ {
+ /* FIXME: in the light of the comment above, this fprintf is
+ bogus. CSR */
+ fprintf(stderr, "Oops! Got a trap 16 without a preceeding andcc!\n");
+ }
+ }
+ return result;
+}
+
+static void sigill_handler(int signal, siginfo_t *siginfo, void *void_context)
+{
+ os_context_t *context = arch_os_get_context(&void_context);
+
+ sigprocmask(SIG_SETMASK, &context->si_mask, 0);
+
+ if ((siginfo->si_code) == ILL_ILLOPC
+#ifdef linux
+ || (early_kernel && (siginfo->si_code == 2))
+#endif
+ ) {
+ int trap;
+ unsigned int inst;
+ unsigned int* pc = (unsigned int*) siginfo->si_addr;
+
+ inst = *pc;
+ trap = inst & 0x3fffff;
+
+ switch (trap) {
+ case trap_PendingInterrupt:
+ arch_skip_instruction(context);
+ interrupt_handle_pending(context);
+ break;
+
+ case trap_Halt:
+ fake_foreign_function_call(context);
+ lose("%%primitive halt called; the party is over.\n");
+
+ case trap_Error:
+ case trap_Cerror:
+ interrupt_internal_error(signal, siginfo, context, trap == trap_Cerror);
+ break;
+
+ case trap_Breakpoint:
+ handle_breakpoint(signal, siginfo, context);
+ break;
+
+ case trap_FunEndBreakpoint:
+ *os_context_pc_addr(context) = (int) handle_fun_end_breakpoint(signal, siginfo, context);
+ context->si_regs.npc = *os_context_pc_addr(context) + 4;
+ break;
+
+ case trap_AfterBreakpoint:
+ *skipped_break_addr = trap_Breakpoint;
+ skipped_break_addr = NULL;
+ *(unsigned long *) os_context_pc_addr(context) = displaced_after_inst;
+ /* context->sigmask = orig_sigmask; */
+ os_flush_icache((os_vm_address_t) os_context_pc_addr(context), sizeof(unsigned long));
+ break;
+
+ default:
+ interrupt_handle_now(signal, siginfo, context);
+ break;
+ }
+ }
+ else if ((siginfo->si_code) == ILL_ILLTRP
+#ifdef linux
+ || (early_kernel && (siginfo->si_code) == 192)
+#endif
+ ) {
+ if (pseudo_atomic_trap_p(context)) {
+ /* A trap instruction from a pseudo-atomic. We just need
+ to fixup up alloc-tn to remove the interrupted flag,
+ skip over the trap instruction, and then handle the
+ pending interrupt(s). */
+ *os_context_register_addr(context, reg_ALLOC) &= ~7;
+ arch_skip_instruction(context);
+ interrupt_handle_pending(context);
+ }
+ else {
+ interrupt_internal_error(signal, siginfo, context, 0);
+ }
+ }
+ else {
+ interrupt_handle_now(signal, siginfo, context);
+ }
+}
+
+static void sigemt_handler(int signal, siginfo_t *siginfo, void *void_context)
+{
+ unsigned long badinst;
+ boolean subtract, immed;
+ int rd, rs1, op1, rs2, op2, result;
+ os_context_t *context = arch_os_get_context(&void_context);
+
+ badinst = *(unsigned long *)os_context_pc_addr(context);
+ if ((badinst >> 30) != 2 || ((badinst >> 20) & 0x1f) != 0x11) {
+ /* It wasn't a tagged add. Pass the signal into lisp. */
+ interrupt_handle_now(signal, siginfo, context);
+ return;
+ }
+
+ fprintf(stderr, "SIGEMT trap handler with tagged op instruction!\n");
+
+ /* Extract the parts of the inst. */
+ subtract = badinst & (1<<19);
+ rs1 = (badinst>>14) & 0x1f;
+ op1 = *os_context_register_addr(context, rs1);
+
+ /* If the first arg is $ALLOC then it is really a signal-pending note */
+ /* for the pseudo-atomic noise. */
+ if (rs1 == reg_ALLOC) {
+ /* Perform the op anyway. */
+ op2 = badinst & 0x1fff;
+ if (op2 & (1<<12))
+ op2 |= -1<<13;
+ if (subtract)
+ result = op1 - op2;
+ else
+ result = op1 + op2;
+ *os_context_register_addr(context, reg_ALLOC) = result & ~7;
+ arch_skip_instruction(context);
+ interrupt_handle_pending(context);
+ return;
+ }
+
+ if ((op1 & 3) != 0) {
+ /* The first arg wan't a fixnum. */
+ interrupt_internal_error(signal, siginfo, context, 0);
+ return;
+ }
+
+ if (immed = badinst & (1<<13)) {
+ op2 = badinst & 0x1fff;
+ if (op2 & (1<<12))
+ op2 |= -1<<13;
+ }
+ else {
+ rs2 = badinst & 0x1f;
+ op2 = *os_context_register_addr(context, rs2);
+ }
+
+ if ((op2 & 3) != 0) {
+ /* The second arg wan't a fixnum. */
+ interrupt_internal_error(signal, siginfo, context, 0);
+ return;
+ }
+
+ rd = (badinst>>25) & 0x1f;
+ if (rd != 0) {
+ /* Don't bother computing the result unless we are going to use it. */
+ if (subtract)
+ result = (op1>>2) - (op2>>2);
+ else
+ result = (op1>>2) + (op2>>2);
+
+ dynamic_space_free_pointer =
+ (lispobj *) *os_context_register_addr(context, reg_ALLOC);
+
+ *os_context_register_addr(context, rd) = alloc_number(result);
+
+ *os_context_register_addr(context, reg_ALLOC) =
+ (unsigned long) dynamic_space_free_pointer;
+ }
+
+ arch_skip_instruction(context);
+}
+
+void arch_install_interrupt_handlers()
+{
+ undoably_install_low_level_interrupt_handler(SIGILL , sigill_handler);
+ undoably_install_low_level_interrupt_handler(SIGEMT, sigemt_handler);
+}
+
+\f
+extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs);
+
+lispobj funcall0(lispobj function)
+{
+ lispobj *args = current_control_stack_pointer;
+
+ return call_into_lisp(function, args, 0);
+}
+
+lispobj funcall1(lispobj function, lispobj arg0)
+{
+ lispobj *args = current_control_stack_pointer;
+
+ current_control_stack_pointer += 1;
+ args[0] = arg0;
+
+ return call_into_lisp(function, args, 1);
+}
+
+lispobj funcall2(lispobj function, lispobj arg0, lispobj arg1)
+{
+ lispobj *args = current_control_stack_pointer;
+
+ current_control_stack_pointer += 2;
+ args[0] = arg0;
+ args[1] = arg1;
+
+ return call_into_lisp(function, args, 2);
+}
+
+lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2)
+{
+ lispobj *args = current_control_stack_pointer;
+
+ current_control_stack_pointer += 3;
+ args[0] = arg0;
+ args[1] = arg1;
+ args[2] = arg2;
+
+ return call_into_lisp(function, args, 3);
+}
--- /dev/null
+#ifndef _SPARC_ARCH_H
+#define _SPARC_ARCH_H
+
+#define ARCH_HAS_NPC_REGISTER
+
+#endif /* _SPARC_ARCH_H */
--- /dev/null
+#define _ASM
+
+#define FUNCDEF(x) .type x,@function
+
+#define LANGUAGE_ASSEMBLY
+#include "lispregs.h"
+#include "globals.h"
+#include "sbcl.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)]
+
+/* FIXME */
+#define FRAMESIZE 0x48
+#define ST_FLUSH_WINDOWS 0x03
+#define PSEUDO_ATOMIC_TRAP_NUMBER 64
+ .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 4, 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(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. */
+ sub reg_ALLOC, 4, reg_ALLOC
+ andcc reg_ALLOC, 3, reg_ZERO
+
+ /* OK, this is ridiculous. We badly urgently need this to be
+ centralized, because that's now _three_ places where this
+ number is used. CSR, 2002-02-09 */
+
+ tne 64
+ /* 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 + OTHER_POINTER_LOWTAG, reg_LRA
+
+ /* Indirect closure */
+ ld [reg_LEXENV+CLOSURE_FUN_OFFSET], reg_CODE
+
+ jmp reg_CODE+SIMPLE_FUN_CODE_OFFSET
+ nop
+
+ .align 8
+lra:
+ .word RETURN_PC_HEADER_WIDETAG
+
+ /* Blow off any extra values. */
+ mov reg_OCFP, reg_CSP
+ nop
+
+ /* Return the one value. */
+ mov reg_A0, %i0
+
+ /* Turn on pseudo_atomic */
+ add reg_ALLOC, 4, reg_ALLOC
+
+ /* Store LISP state */
+ andn reg_ALLOC, 7, reg_NL1
+ store(reg_NL1,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? */
+ sub reg_ALLOC, 4, reg_ALLOC
+ andcc reg_ALLOC, 3, reg_ZERO
+ tne PSEUDO_ATOMIC_TRAP_NUMBER
+
+ /* Back to C we go. */
+ ld [%sp+FRAMESIZE-4], %i7
+ ret
+ restore %sp, FRAMESIZE, %sp
+
+ .global call_into_c
+ FUNCDEF(call_into_c)
+call_into_c:
+ /* 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. */
+ add reg_ALLOC, 4, 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, OTHER_POINTER_LOWTAG, 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, 7, reg_CFP
+ store(reg_CFP,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? */
+ sub reg_ALLOC, 4, reg_ALLOC
+ andcc reg_ALLOC, 3, reg_ZERO
+ tne PSEUDO_ATOMIC_TRAP_NUMBER
+
+ /* 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 4, 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(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, OTHER_POINTER_LOWTAG, reg_LIP
+
+ /* No longer atomic. */
+ sub reg_ALLOC, 4, reg_ALLOC
+ andcc reg_ALLOC, 3, reg_ZERO
+ tne PSEUDO_ATOMIC_TRAP_NUMBER
+
+ /* 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
+
+ /* And back into lisp. */
+ ret
+ nop
+
+ .global undefined_tramp
+ FUNCDEF(undefined_tramp)
+ .align 8
+ .byte 0, 0, 0, SIMPLE_FUN_HEADER_WIDETAG
+undefined_tramp = . + 1
+ .word undefined_tramp
+ .word NIL
+ .word NIL
+ .word NIL
+ .word NIL
+
+ b 1f
+ unimp trap_Cerror
+ .byte 4
+#ifdef type_LongFloat
+ .byte 24
+#else
+ .byte 23
+#endif
+ .byte 254, sc_DescriptorReg, 3
+ .align 4
+1:
+ ld [reg_FDEFN+FDEFN_RAW_ADDR_OFFSET], reg_CODE
+ jmp reg_CODE+SIMPLE_FUN_CODE_OFFSET
+ nop
+
+ .global closure_tramp
+ FUNCDEF(closure_tramp)
+ .align 8
+ .byte 0, 0, 0, SIMPLE_FUN_HEADER_WIDETAG
+closure_tramp = . + 1
+ .word closure_tramp
+ .word NIL
+ .word NIL
+ .word NIL
+ .word NIL
+
+ ld [reg_FDEFN+FDEFN_FUN_OFFSET], reg_LEXENV
+ ld [reg_LEXENV+CLOSURE_FUN_OFFSET], reg_CODE
+ jmp reg_CODE+SIMPLE_FUN_CODE_OFFSET
+ nop
+
+
+/*
+ * Function-end breakpoint magic.
+ */
+
+ .text
+ .align 8
+ .global fun_end_breakpoint_guts
+fun_end_breakpoint_guts:
+ .word RETURN_PC_HEADER_WIDETAG
+ 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 fun_end_breakpoint_trap
+fun_end_breakpoint_trap:
+ unimp trap_FunEndBreakpoint
+ b 1b
+ nop
+
+ .global fun_end_breakpoint_end
+fun_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
+
+ .global save_context
+ FUNCDEF(save_context)
+save_context:
+ ta ST_FLUSH_WINDOWS ! flush register windows
+ retl ! return from leaf routine
+ nop
--- /dev/null
+/*
+ * This is the SPARC Linux incarnation of arch-dependent OS-dependent
+ * routines. See also "linux-os.c".
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+#include <stdio.h>
+#include <sys/param.h>
+#include <sys/file.h>
+#include "./signal.h"
+#include "os.h"
+#include "arch.h"
+#include "globals.h"
+#include "interrupt.h"
+#include "interr.h"
+#include "lispregs.h"
+#include "sbcl.h"
+#include <sys/socket.h>
+#include <sys/utsname.h>
+
+#include <sys/types.h>
+#include <signal.h>
+/* #include <sys/sysinfo.h> */
+#include <sys/time.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+#include "validate.h"
+size_t os_vm_page_size;
+
+#if defined GENCGC /* unlikely ... */
+#include "gencgc.h"
+#endif
+
+os_context_register_t *
+os_context_register_addr(os_context_t *context, int offset)
+{
+ /* printf("Offset: %d,", offset);
+ printf("Context: %p\n", context);
+ printf("PC: %x,", context->si_regs.pc);
+ printf("NPC: %x\n", context->si_regs.npc); */
+ if (offset == 0) {
+ static int zero;
+ zero = 0;
+ /* printf("Returning: %p pointing to %p\n", &zero, zero); */
+ return &zero;
+ } else if (offset < 16) {
+ /* printf("Returning: %p pointing to %p\n", &context->si_regs.u_regs[offset], context->si_regs.u_regs[offset]); */
+ return &context->si_regs.u_regs[offset];
+ } else if (offset < 32) {
+ int *sp = (int*) context->si_regs.u_regs[14]; /* Stack Pointer ?? */
+ /* printf("SP: %p\n", sp);
+ printf("Returning: %p pointing to %p\n", &(sp[offset-16]), sp[offset-16]); */
+ return &(sp[offset-16]);
+ } else
+ return 0;
+}
+
+os_context_register_t *
+os_context_pc_addr(os_context_t *context)
+{
+ return &(context->si_regs.pc);
+}
+
+os_context_register_t *
+os_context_npc_addr(os_context_t *context)
+{
+ return &(context->si_regs.npc);
+}
+
+sigset_t *
+os_context_sigmask_addr(os_context_t *context)
+{
+ return &(context->si_mask);
+}
+
+void os_flush_icache(os_vm_address_t address, os_vm_size_t length)
+{
+ /* FIXME. There's a bit of stuff in the CMUCL version. It may or
+ may not be needed */
+}
--- /dev/null
+#ifndef _SPARC_LINUX_OS_H
+#define _SPARC_LINUX_OS_H
+
+typedef struct sigcontext os_context_t;
+
+static inline os_context_t *arch_os_get_context(void **void_context) {
+ asm volatile ("ta 0x03"); /* ta ST_FLUSH_WINDOWS */
+ return (os_context_t *) (void_context + 37);
+}
+
+#endif /* _SPARC_LINUX_OS_H */
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+
+#define NREGS (32)
+
+#ifdef LANGUAGE_ASSEMBLY
+#define GREG(num) %g##num
+#define OREG(num) %o##num
+#define LREG(num) %l##num
+#define IREG(num) %i##num
+
+#else
+
+#define GREG(num) (num)
+#define OREG(num) ((num)+8)
+#define LREG(num) ((num)+16)
+#define IREG(num) ((num)+24)
+
+#endif
+
+#define reg_ZERO GREG(0)
+#define reg_ALLOC GREG(1)
+#define reg_NIL GREG(2)
+#define reg_CSP GREG(3)
+#define reg_CFP GREG(4)
+#define reg_BSP GREG(5)
+/* %g6 and %g7 are supposed to be reserved for the system */
+
+#define reg_NL0 OREG(0)
+#define reg_NL1 OREG(1)
+#define reg_NL2 OREG(2)
+#define reg_NL3 OREG(3)
+#define reg_NL4 OREG(4)
+#define reg_NL5 OREG(5)
+#define reg_NSP OREG(6)
+#define reg_NARGS OREG(7)
+
+#define reg_A0 LREG(0)
+#define reg_A1 LREG(1)
+#define reg_A2 LREG(2)
+#define reg_A3 LREG(3)
+#define reg_A4 LREG(4)
+#define reg_A5 LREG(5)
+#define reg_OCFP LREG(6)
+#define reg_LRA LREG(7)
+
+#define reg_FDEFN IREG(0)
+#define reg_LEXENV IREG(1)
+#define reg_L0 IREG(2)
+#define reg_NFP IREG(3)
+#define reg_CFUNC IREG(4)
+#define reg_CODE IREG(5)
+#define reg_LIP IREG(7)
+
+#define REGNAMES \
+ "ZERO", "ALLOC", "NULL", "CSP", \
+ "CFP", "BSP", "%g6", "%g7", \
+ "NL0", "NL1", "NL2", "NL3", \
+ "NL4", "NL5", "NSP", "NARGS", \
+ "A0", "A1", "A2", "A3", \
+ "A4", "A5", "OCFP", "LRA", \
+ "FDEFN", "LEXENV", "L0", "NFP", \
+ "CFUNC", "CODE", "???", "LIP"
+
+#define BOXED_REGISTERS { \
+ reg_A0, reg_A1, reg_A2, reg_A3, reg_A4, reg_A5, reg_FDEFN, reg_LEXENV, \
+ reg_OCFP, reg_LRA, reg_L0, reg_CODE \
+}
--- /dev/null
+/* FIXME: Aren't preprocessor symbols with underscore prefixes
+ * reserved for the system libraries? If so, it would be tidy to
+ * rename flags like _X86_ARCH_H so their names are in a part of the
+ * namespace that we control. */
+#ifndef _X86_ARCH_H
+#define _X86_ARCH_H
+
+#define ARCH_HAS_STACK_POINTER
+
+/* FIXME: Do we also want
+ * #define ARCH_HAS_FLOAT_REGISTERS
+ * here? (The answer wasn't obvious to me when merging the
+ * architecture-abstracting patches for CSR's SPARC port. -- WHN 2002-02-15) */
+
+#endif /* _X86_ARCH_H */
--- /dev/null
+#ifndef _X86_LINUX_OS_H
+#define _X86_LINUX_OS_H
+
+static inline os_context_t *arch_os_get_context(void **void_context) {
+ return (os_context_t *) *void_context;
+}
+
+#endif /* _X86_LINUX_OS_H */
* gregs[], but it's conditional on __USE_GNU and not defined, so
* we need to do this nasty absolute index magic number thing
* instead. */
-register_t *
+os_context_register_t *
os_context_register_addr(os_context_t *context, int offset)
{
switch(offset) {
}
return &context->uc_mcontext.gregs[offset];
}
-register_t *
+
+os_context_register_t *
os_context_pc_addr(os_context_t *context)
{
return &context->uc_mcontext.gregs[14];
}
-register_t *
+
+os_context_register_t *
os_context_sp_addr(os_context_t *context)
{
return &context->uc_mcontext.gregs[17];
--- /dev/null
+#ifndef _X86_LINUX_OS_H
+#define _X86_LINUX_OS_H
+
+typedef struct ucontext os_context_t;
+
+static inline os_context_t *arch_os_get_context(void **void_context) {
+ return (os_context_t *) *void_context;
+}
+
+#endif /* _X86_LINUX_OS_H */
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.1.19"
+"0.7.1.20"
projects / sbcl.git / commitdiff