;; 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)
- #!+(and sparc svr4) ("src/code/sparc-svr4-vm" :not-host)
- #!+(and sparc (not svr4)) ("src/code/sparc-vm" :not-host)
- #!+rt ("src/code/rt-vm" :not-host)
+ #!+sparc ("src/code/sparc-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)
+ #!+mips ("src/code/mips-vm" :not-host)
+
+ ;; FIXME: do we really want to keep this? -- CSR, 2002-08-31
+ #!+rt ("src/code/rt-vm" :not-host)
("src/code/target-signal" :not-host) ; needs OS-CONTEXT-T from x86-vm
sun*) guessed_sbcl_arch=sparc ;;
ppc) guessed_sbcl_arch=ppc ;;
parisc) guessed_sbcl_arch=hppa ;;
+ mips) guessed_sbcl_arch=mips ;;
+ mipsel) guessed_sbcl_arch=mips; little_endian=yes ;;
*)
# If we're not building on a supported target architecture, we
# we have no guess, but it's not an error yet, since maybe
# similar with :STACK-GROWS-FOOWARD, too. -- WHN 2002-03-03
if [ "$sbcl_arch" = "x86" ] ; then
printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack' >> $ltf
+elif [ "$sbcl_arch" = "mips" -a "$little_endian" = "yes" ] ; then
+ printf ' :little-endian' >> $ltf
else
# Nothing need be done in this case, but sh syntax wants a placeholder.
echo > /dev/null
;; ..and DEFTYPEs..
"INDEX" "LOAD/STORE-INDEX"
+ "SIGNED-BYTE-WITH-A-BITE-OUT"
"UNSIGNED-BYTE-WITH-A-BITE-OUT"
;; ..and type predicates
"INSTANCEP"
--- /dev/null
+(in-package "SB!VM")
+
+
--- /dev/null
+(in-package "SB!VM")
+
+
+(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 lip interior-reg lip-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst b DO-STATIC-FUN)
+ (inst nop)
+ #+nil
+ (progn
+ (inst and temp x 3)
+ (inst bne temp DO-STATIC-FUN)
+ (inst and temp y 3)
+ (inst bne temp DO-STATIC-FUN)
+ (inst nop)
+ (inst add res x y)
+ (lisp-return lra lip :offset 2))
+
+ DO-STATIC-FUN
+ (inst lw lip null-tn (static-fun-offset 'two-arg-+))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j lip)
+ (inst move cfp-tn csp-tn))
+
+
+(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 lip interior-reg lip-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst b DO-STATIC-FUN)
+ (inst nop)
+ #+nil
+ (progn
+ (inst and temp x 3)
+ (inst bne temp DO-STATIC-FUN)
+ (inst and temp y 3)
+ (inst bne temp DO-STATIC-FUN)
+ (inst nop)
+ (inst sub res x y)
+ (lisp-return lra lip :offset 2))
+
+ DO-STATIC-FUN
+ (inst lw lip null-tn (static-fun-offset 'two-arg--))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j lip)
+ (inst move cfp-tn csp-tn))
+
+
+(define-assembly-routine (generic-*
+ (:cost 25)
+ (: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 pa-flag non-descriptor-reg nl4-offset)
+ (:temp lip interior-reg lip-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 and temp x 3)
+ (inst bne temp DO-STATIC-FUN)
+ (inst and temp y 3)
+ (inst bne temp 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 2)
+ (inst mult temp y)
+ (inst mflo res)
+ (inst mfhi hi)
+ ;; 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 res 31)
+ (inst xor temp hi)
+ (inst beq temp DONE)
+ ;; Shift the double word hi:res down two bits into hi:low to get rid of the
+ ;; fixnum tag.
+ (inst srl lo res 2)
+ (inst sll temp hi 30)
+ (inst or lo temp)
+ (inst sra hi 2)
+
+ ;; Do we need one word or two? Assume two.
+ (inst sra temp lo 31)
+ (inst xor temp hi)
+ (inst bne temp two-words)
+ ;; Assume a two word header.
+ (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
+
+ ;; Only need one word, fix the header.
+ (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
+
+ (pseudo-atomic (pa-flag :extra (pad-data-block (+ 1 bignum-digits-offset)))
+ (inst or res alloc-tn other-pointer-lowtag)
+ (storew temp res 0 other-pointer-lowtag))
+
+ (storew lo res bignum-digits-offset other-pointer-lowtag)
+
+ ;; Out of here
+ (lisp-return lra lip :offset 2)
+
+
+ TWO-WORDS
+ (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset)))
+ (inst or res alloc-tn other-pointer-lowtag)
+ (storew temp res 0 other-pointer-lowtag))
+
+ (storew lo res bignum-digits-offset other-pointer-lowtag)
+ (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
+
+ ;; Out of here
+ (lisp-return lra lip :offset 2)
+
+
+ DO-STATIC-FUN
+ (inst lw lip null-tn (static-fun-offset 'two-arg-*))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j lip)
+ (inst move cfp-tn csp-tn)
+
+ DONE)
+
+
+\f
+;;;; Comparison routines.
+
+(macrolet
+ ((define-cond-assem-rtn (name translate static-fn cmp not-p)
+ `(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 temp non-descriptor-reg nl0-offset)
+ (:temp lip interior-reg lip-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst and temp x 3)
+ (inst bne temp DO-STATIC-FN)
+ (inst and temp y 3)
+ (inst beq temp DO-COMPARE)
+ ,cmp
+
+ DO-STATIC-FN
+ (inst lw lip null-tn (static-fun-offset ',static-fn))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j lip)
+ (inst move cfp-tn csp-tn)
+
+ DO-COMPARE
+ (inst ,(if not-p 'bne 'beq) temp done)
+ (inst move res null-tn)
+ (load-symbol res t)
+ DONE)))
+
+ (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y) nil)
+ (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x) nil))
+
+
+(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 temp non-descriptor-reg nl0-offset)
+ (:temp lip interior-reg lip-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst beq x y RETURN-T)
+ (inst and temp x 3)
+ (inst beq temp RETURN-NIL)
+ (inst and temp y 3)
+ (inst bne temp DO-STATIC-FN)
+ (inst nop)
+
+ RETURN-NIL
+ (inst move res null-tn)
+ (lisp-return lra lip :offset 2)
+
+ DO-STATIC-FN
+ (inst lw lip null-tn (static-fun-offset 'eql))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j lip)
+ (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 temp non-descriptor-reg nl0-offset)
+ (:temp lip interior-reg lip-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst and temp x 3)
+ (inst bne temp DO-STATIC-FN)
+ (inst and temp y 3)
+ (inst bne temp DO-STATIC-FN)
+ (inst nop)
+ (inst beq x y RETURN-T)
+
+ (inst move res null-tn)
+ (lisp-return lra lip :offset 2)
+
+ DO-STATIC-FN
+ (inst lw lip null-tn (static-fun-offset 'two-arg-=))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j lip)
+ (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 temp non-descriptor-reg nl0-offset)
+ (:temp lip interior-reg lip-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst and temp x 3)
+ (inst bne temp DO-STATIC-FN)
+ (inst and temp y 3)
+ (inst bne temp DO-STATIC-FN)
+ (inst nop)
+ (inst beq x y RETURN-NIL)
+
+ (load-symbol res t)
+ (lisp-return lra lip :offset 2)
+
+ DO-STATIC-FN
+ (inst lw lip null-tn (static-fun-offset 'two-arg-=))
+ (inst li nargs (fixnumize 2))
+ (inst move ocfp cfp-tn)
+ (inst j lip)
+ (inst move cfp-tn csp-tn)
+
+ RETURN-NIL
+ (inst move res null-tn))
--- /dev/null
+(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 pa-flag non-descriptor-reg nl4-offset))
+ ;; This is kinda sleezy, changing words like this. But we can because
+ ;; the vop thinks it is temporary.
+ (inst addu words (+ (1- (ash 1 n-lowtag-bits))
+ (* vector-data-offset n-word-bytes)))
+ (inst li ndescr (lognot lowtag-mask))
+ (inst and words ndescr)
+ (inst srl ndescr type word-shift)
+
+ (pseudo-atomic (pa-flag)
+ (inst or result alloc-tn other-pointer-lowtag)
+ (inst addu alloc-tn words)
+ (storew ndescr result 0 other-pointer-lowtag)
+ (storew length result vector-length-slot other-pointer-lowtag)))
+
+\f
+;;;; Hash primitives
+
+(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 lip interior-reg lip-offset)
+ (:temp accum non-descriptor-reg nl0-offset)
+ (:temp data non-descriptor-reg nl1-offset)
+ (:temp byte non-descriptor-reg nl2-offset)
+ (:temp retaddr non-descriptor-reg nl3-offset))
+
+ ;; These are needed after we jump into sxhash-simple-substring.
+ ;;
+ ;; FIXME: *BOGGLE* -- CSR, 2002-08-22
+ (progn result lip accum data byte retaddr)
+
+ (inst j (make-fixup 'sxhash-simple-substring :assembly-routine))
+ (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 lip interior-reg lip-offset)
+ (:temp accum non-descriptor-reg nl0-offset)
+ (:temp data non-descriptor-reg nl1-offset)
+ (:temp byte non-descriptor-reg nl2-offset)
+ (:temp retaddr non-descriptor-reg nl3-offset))
+
+ ;; Save the return address
+ (inst subu retaddr lip code-tn)
+
+ ;; Get a pointer to the data.
+ (inst addu lip string
+ (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))
+ (inst b test)
+ (move accum zero-tn)
+
+ loop
+
+ (inst and byte data #xff)
+ (inst xor accum accum byte)
+ (inst sll byte accum 5)
+ (inst srl accum accum 27)
+ (inst or accum accum byte)
+
+ (inst srl byte data 8)
+ (inst and byte byte #xff)
+ (inst xor accum accum byte)
+ (inst sll byte accum 5)
+ (inst srl accum accum 27)
+ (inst or accum accum byte)
+
+ (inst srl byte data 16)
+ (inst and byte byte #xff)
+ (inst xor accum accum byte)
+ (inst sll byte accum 5)
+ (inst srl accum accum 27)
+ (inst or accum accum byte)
+
+ (inst srl byte data 24)
+ (inst xor accum accum byte)
+ (inst sll byte accum 5)
+ (inst srl accum accum 27)
+ (inst or accum accum byte)
+
+ (inst addu lip lip 4)
+
+ test
+
+ (inst addu length length (fixnumize -4))
+ (inst lw data lip 0)
+ (inst bgez length loop)
+ (inst nop)
+
+ (inst addu length length (fixnumize 3))
+ (inst beq length zero-tn one-more)
+ (inst addu length length (fixnumize -1))
+ (inst beq length zero-tn two-more)
+ (inst addu length length (fixnumize -1))
+ (inst bne length zero-tn done)
+ (inst nop)
+
+ (ecase *backend-byte-order*
+ (:big-endian (inst srl byte data 8))
+ (:little-endian (inst srl byte data 16)))
+ (inst and byte byte #xff)
+ (inst xor accum accum byte)
+ (inst sll byte accum 5)
+ (inst srl accum accum 27)
+ (inst or accum accum byte)
+
+ two-more
+
+ (ecase *backend-byte-order*
+ (:big-endian (inst srl byte data 16))
+ (:little-endian (inst srl byte data 8)))
+ (inst and byte byte #xff)
+ (inst xor accum accum byte)
+ (inst sll byte accum 5)
+ (inst srl accum accum 27)
+ (inst or accum accum byte)
+
+ one-more
+
+ (when (eq *backend-byte-order* :big-endian)
+ (inst srl data data 24))
+ (inst and byte data #xff)
+ (inst xor accum accum byte)
+ (inst sll byte accum 5)
+ (inst srl accum accum 27)
+ (inst or accum accum byte)
+
+ done
+
+ (inst sll result accum 5)
+ (inst srl result result 3)
+
+ ;; Restore the return address.
+ (inst addu lip code-tn retaddr))
--- /dev/null
+(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 lip interior-reg lip-offset)
+ (:temp count any-reg nl2-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 blez nvals default-a0-and-on)
+ (inst subu count nvals (fixnumize 2))
+ (inst blez count default-a2-and-on)
+ (inst lw a1 vals (* 1 n-word-bytes))
+ (inst subu count (fixnumize 1))
+ (inst blez count default-a3-and-on)
+ (inst lw a2 vals (* 2 n-word-bytes))
+ (inst subu count (fixnumize 1))
+ (inst blez count default-a4-and-on)
+ (inst lw a3 vals (* 3 n-word-bytes))
+ (inst subu count (fixnumize 1))
+ (inst blez count default-a5-and-on)
+ (inst lw a4 vals (* 4 n-word-bytes))
+ (inst subu count (fixnumize 1))
+ (inst blez count done)
+ (inst lw a5 vals (* 5 n-word-bytes))
+
+ ;; Copy the remaining args to the top of the stack.
+ (inst addu vals vals (* 6 n-word-bytes))
+ (inst addu dst cfp-tn (* 6 n-word-bytes))
+
+ LOOP
+ (inst lw temp vals)
+ (inst addu vals n-word-bytes)
+ (inst sw temp dst)
+ (inst subu count (fixnumize 1))
+ (inst bne count zero-tn loop)
+ (inst addu dst n-word-bytes)
+
+ (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 addu csp-tn ocfp-tn nvals)
+
+ ;; Return.
+ (lisp-return lra lip))
+
+\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 cfunc-offset)
+ (:temp temp descriptor-reg l0-offset)
+
+ ;; Needed for the jump
+ (:temp lip interior-reg lip-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 subu nargs csp-tn args)
+
+ ;; Load the argument regs (must do this now, 'cause the blt might
+ ;; trash these locations)
+ (inst lw a0 args (* 0 n-word-bytes))
+ (inst lw a1 args (* 1 n-word-bytes))
+ (inst lw a2 args (* 2 n-word-bytes))
+ (inst lw a3 args (* 3 n-word-bytes))
+ (inst lw a4 args (* 4 n-word-bytes))
+ (inst lw a5 args (* 5 n-word-bytes))
+
+ ;; Calc SRC, DST, and COUNT
+ (inst addu count nargs (fixnumize (- register-arg-count)))
+ (inst blez count done)
+ (inst addu src args (* n-word-bytes register-arg-count))
+ (inst addu dst cfp-tn (* n-word-bytes register-arg-count))
+
+ LOOP
+ ;; Copy one arg.
+ (inst lw temp src)
+ (inst addu src src n-word-bytes)
+ (inst sw temp dst)
+ (inst addu count (fixnumize -1))
+ (inst bgtz count loop)
+ (inst addu dst dst n-word-bytes)
+
+ DONE
+ ;; We are done. Do the jump.
+ (progn
+ (loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
+ (lisp-jump temp lip)))
+
+\f
+;;;; Non-local exit noise.
+
+(define-assembly-routine
+ (unwind
+ (: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 lip interior-reg lip-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 beq block zero-tn error))
+
+ (load-symbol-value cur-uwp *current-unwind-protect-block*)
+ (loadw target-uwp block unwind-block-current-uwp-slot)
+ (inst bne cur-uwp target-uwp 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)
+ (progn
+ (loadw lra cur-uwp unwind-block-entry-pc-slot)
+ (lisp-return lra lip :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
+ ((: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))
+
+ (progn start count) ; We just need them in the registers.
+
+ (load-symbol-value catch *current-catch-block*)
+
+ loop
+
+ (let ((error (generate-error-code nil unseen-throw-tag-error target)))
+ (inst beq catch zero-tn error)
+ (inst nop))
+
+ (loadw tag catch catch-block-tag-slot)
+ (inst beq tag target exit)
+ (inst nop)
+ (loadw catch catch catch-block-previous-catch-slot)
+ (inst b loop)
+ (inst nop)
+
+ exit
+
+ (move target catch)
+ (inst j (make-fixup 'unwind :assembly-routine))
+ (inst nop))
--- /dev/null
+(in-package "SB!VM")
+
+(!def-vm-support-routine generate-call-sequence (name style vop)
+ (ecase style
+ (:raw
+ (values
+ `((inst jal (make-fixup ',name :assembly-routine))
+ (inst nop))
+ `()))
+ (: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 j (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 t)))))
+ (:none
+ (values
+ `((inst j (make-fixup ',name :assembly-routine))
+ (inst nop))
+ nil))))
+
+
+(!def-vm-support-routine generate-return-sequence (style)
+ (ecase style
+ (:raw
+ `((inst j lip-tn)
+ (inst nop)))
+ (:full-call
+ `((lisp-return (make-random-tn :kind :normal
+ :sc (sc-or-lose
+ 'descriptor-reg)
+ :offset lra-offset)
+ lip-tn :offset 2)))
+ (:none)))
;;; alpha platform. -- CSR, 2002-06-24
(def!type unsigned-byte-with-a-bite-out (s bite)
(cond ((eq s '*) 'integer)
- ((and (integerp s) (> s 1))
+ ((and (integerp s) (> s 0))
(let ((bound (ash 1 s)))
`(integer 0 ,(- bound bite 1))))
(t
- (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
+ (error "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s))))
+
+;;; Motivated by the mips port. -- CSR, 2002-08-22
+(def!type signed-byte-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))))
(def!type load/store-index (scale lowtag min-offset
&optional (max-offset min-offset))
--- /dev/null
+(in-package "SB!VM")
+\f
+(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."
+ "MIPS")
+
+(defun machine-version ()
+ "Returns a string describing the version of the local machine."
+ #!+little-endian "little-endian"
+ #!-little-endian "big-endian")
+
+\f
+;;; FIXUP-CODE-OBJECT -- Interface
+;;;
+(defun fixup-code-object (code offset value kind)
+ (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!c::code-instructions code))))
+ (ecase kind
+ (:jump
+ (assert (zerop (ash value -28)))
+ (setf (ldb (byte 26 0) (sap-ref-32 sap offset))
+ (ash value -2)))
+ (:lui
+ (setf (sap-ref-16 sap
+ #!+little-endian offset
+ #!-little-endian (+ offset 2))
+ (+ (ash value -16)
+ (if (logbitp 15 value) 1 0))))
+ (:addi
+ (setf (sap-ref-16 sap
+ #!+little-endian offset
+ #!-little-endian (+ offset 2))
+ (ldb (byte 16 0) value)))))))
+
+\f
+(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))
+ ;; KLUDGE: this sucks, and furthermore will break on either of (a)
+ ;; porting back to IRIX or (b) running on proper 64-bit support.
+ ;; Linux on the MIPS defines its registers in the sigcontext as
+ ;; 64-bit quantities ("unsigned long long"), presumably to be
+ ;; binary-compatible with 64-bit mode. Since there appears not to
+ ;; be ALIEN support for 64-bit return values, we have to do the
+ ;; hacky pointer arithmetic thing. -- CSR, 2002-09-01
+ (int-sap (deref (context-pc-addr context)
+ #!-little-endian 1
+ ;; Untested
+ #!+little-endian 0)))
+
+(define-alien-routine ("os_context_register_addr" context-register-addr)
+ (* unsigned-int)
+ (context (* os-context-t))
+ (index int))
+
+(define-alien-routine ("os_context_bd_cause" context-bd-cause-int)
+ (unsigned 32)
+ (context (* os-context-t)))
+
+;;; 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)
+ #!-little-endian 1
+ #!+little-endian 0))
+
+(defun %set-context-register (context index new)
+ (declare (type (alien (* os-context-t)) context))
+ (setf (deref (context-register-addr context index)
+ #!-little-endian 1
+ #!+little-endian 0)
+ new))
+
+#!+linux
+;;; For now.
+(defun context-floating-point-modes (context)
+ (declare (ignore context))
+ (warn "stub CONTEXT-FLOATING-POINT-MODES")
+ 0)
+
+;;;; Internal-error-arguments.
+
+;;; INTERNAL-ERROR-ARGUMENTS -- interface.
+;;;
+;;; Given the sigcontext, extract the internal error arguments from the
+;;; instruction stream.
+;;;
+(defun internal-error-args (context)
+ (declare (type (alien (* os-context-t)) context))
+ (/show0 "entering INTERNAL-ERROR-ARGS, CONTEXT=..")
+ (/hexstr context)
+ (let ((pc (context-pc context))
+ (cause (context-bd-cause-int context)))
+ (declare (type system-area-pointer pc))
+ (/show0 "got PC=..")
+ (/hexstr (sap-int pc))
+ ;; KLUDGE: This exposure of the branch delay mechanism hurts.
+ (when (logbitp 31 cause)
+ (setf pc (sap+ pc 4)))
+ (when (= (sap-ref-8 pc 4) 255)
+ (setf pc (sap+ pc 1)))
+ (/show0 "now PC=..")
+ (/hexstr (sap-int pc))
+ (let* ((length (sap-ref-8 pc 4))
+ (vector (make-array length :element-type '(unsigned-byte 8))))
+ (declare (type (unsigned-byte 8) length)
+ (type (simple-array (unsigned-byte 8) (*)) vector))
+ (/show0 "LENGTH,VECTOR,ERROR-NUMBER=..")
+ (/hexstr length)
+ (/hexstr 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)))
+ (/hexstr error-number)
+ (collect ((sc-offsets))
+ (loop
+ (/show0 "INDEX=..")
+ (/hexstr index)
+ (when (>= index length)
+ (return))
+ (sc-offsets (sb!c::read-var-integer vector index)))
+ (values error-number (sc-offsets)))))))
+
+
+
+
+
symbol)
;;; Return the built-in hash value for SYMBOL.
-#!+(or x86 mips) ;; only backends for which a SYMBOL-HASH vop exists
+
+;;; only backends for which a SYMBOL-HASH vop exists. In the past,
+;;; when the MIPS backend supported (or nearly did) a generational
+;;; (non-conservative) garbage collector, this read (OR X86 MIPS).
+;;; Having excised the vestigial support for GENGC, this now only
+;;; applies for the x86 port, but if someone were to rework the GENGC
+;;; support, this might change again. -- CSR, 2002-08-26
+#!+x86
(defun symbol-hash (symbol)
(symbol-hash symbol))
;;; Compute the hash value for SYMBOL.
-#!-(or x86 mips)
+#!-x86
(defun symbol-hash (symbol)
(%sxhash-simple-string (symbol-name symbol)))
(logior (ash bits 3)
(logand (bvref-32 gspace-bytes gspace-byte-offset)
#xffe0e002)))))))
- (:ppc
+ (:mips
+ (ecase kind
+ (:jump
+ (assert (zerop (ash value -28)))
+ (setf (ldb (byte 26 0)
+ (bvref-32 gspace-bytes gspace-byte-offset))
+ (ash value -2)))
+ (:lui
+ (setf (bvref-32 gspace-bytes gspace-byte-offset)
+ (logior (mask-field (byte 16 16) (bvref-32 gspace-bytes gspace-byte-offset))
+ (+ (ash value -16)
+ (if (logbitp 15 value) 1 0)))))
+ (:addi
+ (setf (bvref-32 gspace-bytes gspace-byte-offset)
+ (logior (mask-field (byte 16 16) (bvref-32 gspace-bytes gspace-byte-offset))
+ (ldb (byte 16 0) value))))))
+ (:ppc
(ecase kind
(:ba
(setf (bvref-32 gspace-bytes gspace-byte-offset)
--- /dev/null
+(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)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+ (: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
+ ((store-car (tn list &optional (slot cons-car-slot))
+ `(let ((reg
+ (sc-case ,tn
+ ((any-reg descriptor-reg) ,tn)
+ (zero zero-tn)
+ (null null-tn)
+ (control-stack
+ (load-stack-tn temp ,tn)
+ temp))))
+ (storew reg ,list ,slot list-pointer-lowtag))))
+ (let ((cons-cells (if star (1- num) num)))
+ (pseudo-atomic (pa-flag
+ :extra (* (pad-data-block cons-size)
+ cons-cells))
+ (inst or res alloc-tn list-pointer-lowtag)
+ (move ptr res)
+ (dotimes (i (1- cons-cells))
+ (store-car (tn-ref-tn things) ptr)
+ (setf things (tn-ref-across things))
+ (inst addu ptr ptr (pad-data-block cons-size))
+ (storew ptr ptr
+ (- cons-cdr-slot cons-size)
+ list-pointer-lowtag))
+ (store-car (tn-ref-tn things) ptr)
+ (cond (star
+ (setf things (tn-ref-across things))
+ (store-car (tn-ref-tn things) ptr cons-cdr-slot))
+ (t
+ (storew null-tn ptr
+ cons-cdr-slot list-pointer-lowtag)))
+ (assert (null (tn-ref-across things)))
+ (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)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+ (:generator 100
+ (inst li ndescr (lognot lowtag-mask))
+ (inst addu boxed boxed-arg
+ (fixnumize (1+ code-trace-table-offset-slot)))
+ (inst and boxed ndescr)
+ (inst srl unboxed unboxed-arg word-shift)
+ (inst addu unboxed unboxed lowtag-mask)
+ (inst and unboxed ndescr)
+ (inst sll ndescr boxed (- n-widetag-bits word-shift))
+ (inst or ndescr code-header-widetag)
+
+ (pseudo-atomic (pa-flag)
+ (inst or result alloc-tn other-pointer-lowtag)
+ (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)
+ (inst addu alloc-tn boxed)
+ (inst addu alloc-tn unboxed))
+
+ (storew null-tn result code-debug-info-slot other-pointer-lowtag)))
+
+(define-vop (make-fdefn)
+ (:policy :fast-safe)
+ (:translate make-fdefn)
+ (:args (name :scs (descriptor-reg) :to :eval))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+ (:results (result :scs (descriptor-reg) :from :argument))
+ (:generator 37
+ (with-fixed-allocation (result pa-flag temp fdefn-widetag fdefn-size)
+ (storew name result fdefn-name-slot other-pointer-lowtag)
+ (storew null-tn result fdefn-fun-slot other-pointer-lowtag)
+ (inst li temp (make-fixup "undefined_tramp" :foreign))
+ (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)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 10
+ (let ((size (+ length closure-info-offset)))
+ (inst li temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
+ (pseudo-atomic (pa-flag :extra (pad-data-block size))
+ (inst or result alloc-tn fun-pointer-lowtag)
+ (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 null zero)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 10
+ (with-fixed-allocation
+ (result pa-flag 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)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+ (:generator 4
+ (pseudo-atomic (pa-flag :extra (pad-data-block words))
+ (inst or result alloc-tn 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)) header)
+ (:temporary (:scs (non-descriptor-reg)) bytes)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+ (:generator 6
+ (inst addu bytes extra (* (1+ words) n-word-bytes))
+ (inst sll header bytes (- n-widetag-bits 2))
+ (inst addu header header (+ (ash -2 n-widetag-bits) type))
+ (inst srl bytes bytes n-lowtag-bits)
+ (inst sll bytes bytes n-lowtag-bits)
+ (pseudo-atomic (pa-flag)
+ (inst or result alloc-tn lowtag)
+ (storew header result 0 lowtag)
+ (inst addu alloc-tn alloc-tn bytes))))
+
--- /dev/null
+(in-package "SB!VM")
+
+
+\f
+;;;; Unary operations.
+
+(define-vop (fixnum-unop)
+ (:args (x :scs (any-reg)))
+ (:results (res :scs (any-reg)))
+ (:note "inline fixnum arithmetic")
+ (:arg-types tagged-num)
+ (:result-types tagged-num)
+ (:policy :fast-safe))
+
+(define-vop (signed-unop)
+ (:args (x :scs (signed-reg)))
+ (:results (res :scs (signed-reg)))
+ (:note "inline (signed-byte 32) arithmetic")
+ (:arg-types signed-num)
+ (:result-types signed-num)
+ (:policy :fast-safe))
+
+(define-vop (fast-negate/fixnum fixnum-unop)
+ (:translate %negate)
+ (:generator 1
+ (inst subu res zero-tn x)))
+
+(define-vop (fast-negate/signed signed-unop)
+ (:translate %negate)
+ (:generator 2
+ (inst subu res zero-tn x)))
+
+(define-vop (fast-lognot/fixnum fixnum-unop)
+ (:temporary (:scs (any-reg) :type fixnum :to (:result 0))
+ temp)
+ (:translate lognot)
+ (:generator 2
+ (inst li temp (fixnumize -1))
+ (inst xor res x temp)))
+
+(define-vop (fast-lognot/signed signed-unop)
+ (:translate lognot)
+ (:generator 1
+ (inst nor res x zero-tn)))
+
+
+\f
+;;;; Binary fixnum operations.
+
+;;; Assume that any constant operand is the second arg...
+
+(define-vop (fast-fixnum-binop)
+ (:args (x :target r :scs (any-reg))
+ (y :target r :scs (any-reg)))
+ (:arg-types tagged-num tagged-num)
+ (:results (r :scs (any-reg)))
+ (:result-types tagged-num)
+ (:note "inline fixnum arithmetic")
+ (:effects)
+ (:affected)
+ (:policy :fast-safe))
+
+(define-vop (fast-unsigned-binop)
+ (:args (x :target r :scs (unsigned-reg))
+ (y :target r :scs (unsigned-reg)))
+ (:arg-types unsigned-num unsigned-num)
+ (:results (r :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:note "inline (unsigned-byte 32) arithmetic")
+ (:effects)
+ (:affected)
+ (:policy :fast-safe))
+
+(define-vop (fast-signed-binop)
+ (:args (x :target r :scs (signed-reg))
+ (y :target r :scs (signed-reg)))
+ (:arg-types signed-num signed-num)
+ (:results (r :scs (signed-reg)))
+ (:result-types signed-num)
+ (:note "inline (signed-byte 32) arithmetic")
+ (:effects)
+ (:affected)
+ (:policy :fast-safe))
+
+(define-vop (fast-fixnum-c-binop fast-fixnum-binop)
+ (:args (x :target r :scs (any-reg)))
+ (:info y)
+ (:arg-types tagged-num (:constant integer)))
+
+(define-vop (fast-signed-c-binop fast-signed-binop)
+ (:args (x :target r :scs (signed-reg)))
+ (:info y)
+ (:arg-types tagged-num (:constant integer)))
+
+(define-vop (fast-unsigned-c-binop fast-unsigned-binop)
+ (:args (x :target r :scs (unsigned-reg)))
+ (:info y)
+ (:arg-types tagged-num (:constant integer)))
+
+(defmacro define-binop (translate cost untagged-cost op
+ tagged-type untagged-type)
+ `(progn
+ (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
+ fast-fixnum-binop)
+ (:args (x :target r :scs (any-reg))
+ (y :target r :scs (any-reg)))
+ (:translate ,translate)
+ (:generator ,(1+ cost)
+ (inst ,op r x y)))
+ (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
+ fast-signed-binop)
+ (:args (x :target r :scs (signed-reg))
+ (y :target r :scs (signed-reg)))
+ (:translate ,translate)
+ (:generator ,(1+ untagged-cost)
+ (inst ,op r x y)))
+ (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
+ fast-unsigned-binop)
+ (:args (x :target r :scs (unsigned-reg))
+ (y :target r :scs (unsigned-reg)))
+ (:translate ,translate)
+ (:generator ,(1+ untagged-cost)
+ (inst ,op r x y)))
+ ,@(when tagged-type
+ `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
+ fast-fixnum-c-binop)
+ (:arg-types tagged-num (:constant ,tagged-type))
+ (:translate ,translate)
+ (:generator ,cost
+ (inst ,op r x (fixnumize y))))))
+ ,@(when untagged-type
+ `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
+ fast-signed-c-binop)
+ (:arg-types signed-num (:constant ,untagged-type))
+ (:translate ,translate)
+ (:generator ,untagged-cost
+ (inst ,op r x y)))
+ (define-vop (,(symbolicate "FAST-" translate
+ "-C/UNSIGNED=>UNSIGNED")
+ fast-unsigned-c-binop)
+ (:arg-types unsigned-num (:constant ,untagged-type))
+ (:translate ,translate)
+ (:generator ,untagged-cost
+ (inst ,op r x y)))))))
+
+(define-binop + 1 5 addu (signed-byte 14) (signed-byte 16))
+(define-binop - 1 5 subu
+ (integer #.(- (1- (ash 1 14))) #.(ash 1 14))
+ (integer #.(- (1- (ash 1 16))) #.(ash 1 16)))
+(define-binop logior 1 3 or (unsigned-byte 14) (unsigned-byte 16))
+(define-binop lognor 1 3 nor nil nil)
+(define-binop logand 1 3 and (unsigned-byte 14) (unsigned-byte 16))
+(define-binop logxor 1 3 xor (unsigned-byte 14) (unsigned-byte 16))
+
+;;; Special case fixnum + and - that trap on overflow. Useful when we don't
+;;; know that the result is going to be a fixnum.
+#+nil
+(progn
+ (define-vop (fast-+/fixnum fast-+/fixnum=>fixnum)
+ (:results (r :scs (any-reg descriptor-reg)))
+ (:result-types (:or signed-num unsigned-num))
+ (:note nil)
+ (:generator 4
+ (inst add r x y)))
+
+ (define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum)
+ (:results (r :scs (any-reg descriptor-reg)))
+ (:result-types (:or signed-num unsigned-num))
+ (:note nil)
+ (:generator 3
+ (inst add r x (fixnumize y))))
+
+ (define-vop (fast--/fixnum fast--/fixnum=>fixnum)
+ (:results (r :scs (any-reg descriptor-reg)))
+ (:result-types (:or signed-num unsigned-num))
+ (:note nil)
+ (:generator 4
+ (inst sub r x y)))
+
+ (define-vop (fast---c/fixnum fast---c/fixnum=>fixnum)
+ (:results (r :scs (any-reg descriptor-reg)))
+ (:result-types (:or signed-num unsigned-num))
+ (:note nil)
+ (:generator 3
+ (inst sub r x (fixnumize y))))
+) ; bogus trap-to-c-land +/-
+
+;;; Shifting
+
+(define-vop (fast-ash/unsigned=>unsigned)
+ (:note "inline ASH")
+ (:args (number :scs (unsigned-reg) :to :save)
+ (amount :scs (signed-reg)))
+ (:arg-types unsigned-num signed-num)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:translate ash)
+ (:policy :fast-safe)
+ (:temporary (:sc non-descriptor-reg) ndesc)
+ (:temporary (:sc non-descriptor-reg :to :eval) temp)
+ (:generator 3
+ (inst bgez amount positive)
+ (inst subu ndesc zero-tn amount)
+ (inst slt temp ndesc 31)
+ (inst bne temp zero-tn done)
+ (inst srl result number ndesc)
+ (inst b done)
+ (inst srl result number 31)
+
+ POSITIVE
+ ;; The result-type assures us that this shift will not overflow.
+ (inst sll result number amount)
+
+ DONE))
+
+(define-vop (fast-ash/signed=>signed)
+ (:note "inline ASH")
+ (:args (number :scs (signed-reg) :to :save)
+ (amount :scs (signed-reg)))
+ (:arg-types signed-num signed-num)
+ (:results (result :scs (signed-reg)))
+ (:result-types signed-num)
+ (:translate ash)
+ (:policy :fast-safe)
+ (:temporary (:sc non-descriptor-reg) ndesc)
+ (:temporary (:sc non-descriptor-reg :to :eval) temp)
+ (:generator 3
+ (inst bgez amount positive)
+ (inst subu ndesc zero-tn amount)
+ (inst slt temp ndesc 31)
+ (inst bne temp zero-tn done)
+ (inst sra result number ndesc)
+ (inst b done)
+ (inst sra result number 31)
+
+ POSITIVE
+ ;; The result-type assures us that this shift will not overflow.
+ (inst sll result number amount)
+
+ DONE))
+
+
+(define-vop (fast-ash-c/unsigned=>unsigned)
+ (:policy :fast-safe)
+ (:translate ash)
+ (:note "inline ASH")
+ (:args (number :scs (unsigned-reg)))
+ (:info count)
+ (:arg-types unsigned-num (:constant integer))
+ (:results (result :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:generator 1
+ (cond ((< count 0)
+ ;; It is a right shift.
+ (inst srl result number (min (- count) 31)))
+ ((> count 0)
+ ;; It is a left shift.
+ (inst sll result number (min count 31)))
+ (t
+ ;; Count=0? Shouldn't happen, but it's easy:
+ (move result number)))))
+
+(define-vop (fast-ash-c/signed=>signed)
+ (:policy :fast-safe)
+ (:translate ash)
+ (:note "inline ASH")
+ (:args (number :scs (signed-reg)))
+ (:info count)
+ (:arg-types signed-num (:constant integer))
+ (:results (result :scs (signed-reg)))
+ (:result-types signed-num)
+ (:generator 1
+ (cond ((< count 0)
+ ;; It is a right shift.
+ (inst sra result number (min (- count) 31)))
+ ((> count 0)
+ ;; It is a left shift.
+ (inst sll result number (min count 31)))
+ (t
+ ;; Count=0? Shouldn't happen, but it's easy:
+ (move result number)))))
+
+(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)))
+ (move shift arg)
+ (inst bgez shift test)
+ (move res zero-tn)
+ (inst b test)
+ (inst nor shift shift)
+
+ (emit-label loop)
+ (inst add res (fixnumize 1))
+
+ (emit-label test)
+ (inst bne shift 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) :target num))
+ (:arg-types unsigned-num)
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
+ :target res) num)
+ (:temporary (:scs (non-descriptor-reg)) mask temp)
+ (:generator 30
+ (inst li mask #x55555555)
+ (inst srl temp arg 1)
+ (inst and num arg mask)
+ (inst and temp mask)
+ (inst addu num temp)
+ (inst li mask #x33333333)
+ (inst srl temp num 2)
+ (inst and num mask)
+ (inst and temp mask)
+ (inst addu num temp)
+ (inst li mask #x0f0f0f0f)
+ (inst srl temp num 4)
+ (inst and num mask)
+ (inst and temp mask)
+ (inst addu num temp)
+ (inst li mask #x00ff00ff)
+ (inst srl temp num 8)
+ (inst and num mask)
+ (inst and temp mask)
+ (inst addu num temp)
+ (inst li mask #x0000ffff)
+ (inst srl temp num 16)
+ (inst and num mask)
+ (inst and temp mask)
+ (inst addu res num temp)))
+
+
+;;; Multiply and Divide.
+
+(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:translate *)
+ (:generator 4
+ (inst sra temp y 2)
+ (inst mult x temp)
+ (inst mflo r)))
+
+(define-vop (fast-*/signed=>signed fast-signed-binop)
+ (:translate *)
+ (:generator 3
+ (inst mult x y)
+ (inst mflo r)))
+
+(define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop)
+ (:translate *)
+ (:generator 3
+ (inst multu x y)
+ (inst mflo r)))
+
+
+
+(define-vop (fast-truncate/fixnum fast-fixnum-binop)
+ (:translate truncate)
+ (:results (q :scs (any-reg))
+ (r :scs (any-reg)))
+ (:result-types tagged-num tagged-num)
+ (:temporary (:scs (non-descriptor-reg) :to :eval) temp)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 11
+ (let ((zero (generate-error-code vop division-by-zero-error x y)))
+ (inst beq y zero-tn zero))
+ (inst nop)
+ (inst div x y)
+ (inst mflo temp)
+ (inst sll q temp 2)
+ (inst mfhi r)))
+
+(define-vop (fast-truncate/unsigned fast-unsigned-binop)
+ (:translate truncate)
+ (:results (q :scs (unsigned-reg))
+ (r :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-num)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 12
+ (let ((zero (generate-error-code vop division-by-zero-error x y)))
+ (inst beq y zero-tn zero))
+ (inst nop)
+ (inst divu x y)
+ (inst mflo q)
+ (inst mfhi r)))
+
+(define-vop (fast-truncate/signed fast-signed-binop)
+ (:translate truncate)
+ (:results (q :scs (signed-reg))
+ (r :scs (signed-reg)))
+ (:result-types signed-num signed-num)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 12
+ (let ((zero (generate-error-code vop division-by-zero-error x y)))
+ (inst beq y zero-tn zero))
+ (inst nop)
+ (inst div x y)
+ (inst mflo q)
+ (inst mfhi r)))
+
+
+\f
+;;;; Binary conditional VOPs:
+
+(define-vop (fast-conditional)
+ (:conditional)
+ (:info target not-p)
+ (:effects)
+ (:affected)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:policy :fast-safe))
+
+(define-vop (fast-conditional/fixnum fast-conditional)
+ (:args (x :scs (any-reg))
+ (y :scs (any-reg)))
+ (:arg-types tagged-num tagged-num)
+ (:note "inline fixnum comparison"))
+
+(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
+ (:args (x :scs (any-reg)))
+ (:arg-types tagged-num (:constant (signed-byte-with-a-bite-out 14 4)))
+ (:info target not-p y))
+
+(define-vop (fast-conditional/signed fast-conditional)
+ (:args (x :scs (signed-reg))
+ (y :scs (signed-reg)))
+ (: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)))
+ (:arg-types signed-num (:constant (signed-byte-with-a-bite-out 16 1)))
+ (:info target not-p y))
+
+(define-vop (fast-conditional/unsigned fast-conditional)
+ (:args (x :scs (unsigned-reg))
+ (y :scs (unsigned-reg)))
+ (: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)))
+ (:arg-types unsigned-num (:constant (and (signed-byte-with-a-bite-out 16 1)
+ unsigned-byte)))
+ (:info target not-p y))
+
+
+(defmacro define-conditional-vop (translate &rest generator)
+ `(progn
+ ,@(mapcar #'(lambda (suffix cost signed)
+ (unless (and (member suffix '(/fixnum -c/fixnum))
+ (eq translate 'eql))
+ `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
+ translate suffix))
+ ,(intern
+ (format nil "~:@(FAST-CONDITIONAL~A~)"
+ suffix)))
+ (:translate ,translate)
+ (:generator ,cost
+ (let* ((signed ,signed)
+ (-c/fixnum ,(eq suffix '-c/fixnum))
+ (y (if -c/fixnum (fixnumize y) y)))
+ (declare (ignorable signed -c/fixnum y))
+ ,@generator)))))
+ '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
+ '(3 2 5 4 5 4)
+ '(t t t t nil nil))))
+
+(define-conditional-vop <
+ (cond ((and signed (eql y 0))
+ (if not-p
+ (inst bgez x target)
+ (inst bltz x target)))
+ (t
+ (if signed
+ (inst slt temp x y)
+ (inst sltu temp x y))
+ (if not-p
+ (inst beq temp zero-tn target)
+ (inst bne temp zero-tn target))))
+ (inst nop))
+
+(define-conditional-vop >
+ (cond ((and signed (eql y 0))
+ (if not-p
+ (inst blez x target)
+ (inst bgtz x target)))
+ ((integerp y)
+ (let ((y (+ y (if -c/fixnum (fixnumize 1) 1))))
+ (if signed
+ (inst slt temp x y)
+ (inst sltu temp x y))
+ (if not-p
+ (inst bne temp zero-tn target)
+ (inst beq temp zero-tn target))))
+ (t
+ (if signed
+ (inst slt temp y x)
+ (inst sltu temp y x))
+ (if not-p
+ (inst beq temp zero-tn target)
+ (inst bne temp zero-tn target))))
+ (inst nop))
+
+;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
+;;; known fixnum.
+
+(define-conditional-vop eql
+ (declare (ignore signed))
+ (when (integerp y)
+ (inst li temp y)
+ (setf y temp))
+ (if not-p
+ (inst bne x y target)
+ (inst beq x y target))
+ (inst nop))
+
+;;; 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))
+ (y :scs (any-reg)))
+ (:arg-types tagged-num tagged-num)
+ (:note "inline fixnum comparison")
+ (:translate eql)
+ (:ignore temp)
+ (:generator 3
+ (if not-p
+ (inst bne x y target)
+ (inst beq x y target))
+ (inst nop)))
+;;;
+(define-vop (generic-eql/fixnum fast-eql/fixnum)
+ (:args (x :scs (any-reg descriptor-reg))
+ (y :scs (any-reg)))
+ (:arg-types * tagged-num)
+ (:variant-cost 7))
+
+(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
+ (:args (x :scs (any-reg)))
+ (:arg-types tagged-num (:constant (signed-byte 14)))
+ (:info target not-p y)
+ (:translate eql)
+ (:generator 2
+ (let ((y (cond ((eql y 0) zero-tn)
+ (t
+ (inst li temp (fixnumize y))
+ temp))))
+ (if not-p
+ (inst bne x y target)
+ (inst beq x y target))
+ (inst nop))))
+;;;
+(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
+ (:args (x :scs (any-reg descriptor-reg)))
+ (:arg-types * (:constant (signed-byte 14)))
+ (: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 beq shift done)
+ (inst srl res next shift)
+ (inst subu temp zero-tn shift)
+ (inst sll temp prev temp)
+ (inst or res res temp)
+ (emit-label done)
+ (move result res))))
+
+
+(define-vop (32bit-logical)
+ (:args (x :scs (unsigned-reg))
+ (y :scs (unsigned-reg)))
+ (: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)))
+ (:arg-types unsigned-num)
+ (:generator 1
+ (inst nor r x zero-tn)))
+
+(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)))
+
+(define-vop (32bit-logical-nor 32bit-logical)
+ (:translate 32bit-logical-nor)
+ (:generator 1
+ (inst nor r x y)))
+
+(define-vop (32bit-logical-xor 32bit-logical)
+ (:translate 32bit-logical-xor)
+ (:generator 1
+ (inst xor r x y)))
+
+(deftransform 32bit-logical-eqv ((x y) (* *))
+ '(32bit-logical-not (32bit-logical-xor x y)))
+
+(deftransform 32bit-logical-andc1 ((x y) (* *))
+ '(32bit-logical-and (32bit-logical-not x) y))
+
+(deftransform 32bit-logical-andc2 ((x y) (* *))
+ '(32bit-logical-and x (32bit-logical-not y)))
+
+(deftransform 32bit-logical-orc1 ((x y) (* *))
+ '(32bit-logical-or (32bit-logical-not x) y))
+
+(deftransform 32bit-logical-orc2 ((x y) (* *))
+ '(32bit-logical-or x (32bit-logical-not y)))
+
+
+(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
+ (ecase *backend-byte-order*
+ (:big-endian
+ (inst sll r num amount))
+ (:little-endian
+ (inst srl r num amount)))))
+
+(define-vop (shift-towards-end shift-towards-someplace)
+ (:translate shift-towards-end)
+ (:note "SHIFT-TOWARDS-END")
+ (:generator 1
+ (ecase *backend-byte-order*
+ (:big-endian
+ (inst srl r num amount))
+ (:little-endian
+ (inst sll 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-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
+ (unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
+
+(define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
+ (unsigned-reg) unsigned-num sb!bignum::%bignum-set)
+
+(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)
+ (:conditional)
+ (:info target not-p)
+ (:generator 2
+ (if not-p
+ (inst bltz digit target)
+ (inst bgez digit target))
+ (inst nop)))
+
+(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)
+ (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
+ (:results (result :scs (unsigned-reg))
+ (carry :scs (unsigned-reg) :from :eval))
+ (:result-types unsigned-num positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 5
+ (let ((carry-in (gen-label))
+ (done (gen-label)))
+ (inst bne c carry-in)
+ (inst addu res a b)
+
+ (inst b done)
+ (inst sltu carry res b)
+
+ (emit-label carry-in)
+ (inst addu res 1)
+ (inst nor temp a zero-tn)
+ (inst sltu carry b temp)
+ (inst xor carry 1)
+
+ (emit-label done)
+ (move result res))))
+
+(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)
+ (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
+ (:results (result :scs (unsigned-reg))
+ (borrow :scs (unsigned-reg) :from :eval))
+ (:result-types unsigned-num positive-fixnum)
+ (:generator 4
+ (let ((no-borrow-in (gen-label))
+ (done (gen-label)))
+
+ (inst bne c no-borrow-in)
+ (inst subu res a b)
+
+ (inst subu res 1)
+ (inst b done)
+ (inst sltu borrow b a)
+
+ (emit-label no-borrow-in)
+ (inst sltu borrow a b)
+ (inst xor borrow 1)
+
+ (emit-label done)
+ (move result res))))
+
+(define-vop (bignum-mult-and-add-3-arg)
+ (:translate sb!bignum::%multiply-and-add)
+ (:policy :fast-safe)
+ (:args (x :scs (unsigned-reg))
+ (y :scs (unsigned-reg))
+ (carry-in :scs (unsigned-reg) :to :save))
+ (:arg-types unsigned-num unsigned-num unsigned-num)
+ (:temporary (:scs (unsigned-reg) :from (:argument 1)) temp)
+ (:results (hi :scs (unsigned-reg))
+ (lo :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-num)
+ (:generator 6
+ (inst multu x y)
+ (inst mflo temp)
+ (inst addu lo temp carry-in)
+ (inst sltu temp lo carry-in)
+ (inst mfhi hi)
+ (inst addu hi temp)))
+
+(define-vop (bignum-mult-and-add-4-arg)
+ (:translate sb!bignum::%multiply-and-add)
+ (:policy :fast-safe)
+ (:args (x :scs (unsigned-reg))
+ (y :scs (unsigned-reg))
+ (prev :scs (unsigned-reg))
+ (carry-in :scs (unsigned-reg) :to :save))
+ (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
+ (:temporary (:scs (unsigned-reg) :from (:argument 2)) temp)
+ (:results (hi :scs (unsigned-reg))
+ (lo :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-num)
+ (:generator 9
+ (inst multu x y)
+ (inst addu lo prev carry-in)
+ (inst sltu temp lo carry-in)
+ (inst mfhi hi)
+ (inst addu hi temp)
+ (inst mflo temp)
+ (inst addu lo temp)
+ (inst sltu temp lo temp)
+ (inst addu hi temp)))
+
+(define-vop (bignum-mult)
+ (:translate sb!bignum::%multiply)
+ (:policy :fast-safe)
+ (:args (x :scs (unsigned-reg))
+ (y :scs (unsigned-reg)))
+ (:arg-types unsigned-num unsigned-num)
+ (:results (hi :scs (unsigned-reg))
+ (lo :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-num)
+ (:generator 3
+ (inst multu x y)
+ (inst mflo lo)
+ (inst mfhi hi)))
+
+(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 nor r x zero-tn)))
+
+(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 2)))
+
+(define-vop (bignum-floor)
+ (:translate sb!bignum::%floor)
+ (:policy :fast-safe)
+ (:args (num-high :scs (unsigned-reg) :target rem)
+ (num-low :scs (unsigned-reg) :target rem-low)
+ (denom :scs (unsigned-reg) :to (:eval 1)))
+ (:arg-types unsigned-num unsigned-num unsigned-num)
+ (:temporary (:scs (unsigned-reg) :from (:argument 1)) rem-low)
+ (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
+ (:results (quo :scs (unsigned-reg) :from (:eval 0))
+ (rem :scs (unsigned-reg) :from (:argument 0)))
+ (:result-types unsigned-num unsigned-num)
+ (:generator 325 ; number of inst assuming targeting works.
+ (move rem num-high)
+ (move rem-low num-low)
+ (flet ((maybe-subtract (&optional (guess temp))
+ (inst subu temp guess 1)
+ (inst and temp denom)
+ (inst subu rem temp)))
+ (inst sltu quo rem denom)
+ (maybe-subtract quo)
+ (dotimes (i 32)
+ (inst sll rem 1)
+ (inst srl temp rem-low 31)
+ (inst or rem temp)
+ (inst sll rem-low 1)
+ (inst sltu temp rem denom)
+ (inst sll quo 1)
+ (inst or quo temp)
+ (maybe-subtract)))
+ (inst nor quo zero-tn)))
+
+(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 2))
+ (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)
--- /dev/null
+(in-package "SB!VM")
+
+\f
+;;;; Allocator for the array header.
+
+(define-vop (make-array-header)
+ (:policy :fast-safe)
+ (:translate make-array-header)
+ (:args (type :scs (any-reg))
+ (rank :scs (any-reg)))
+ (:arg-types positive-fixnum positive-fixnum)
+ (:temporary (:scs (any-reg)) bytes)
+ (:temporary (:scs (non-descriptor-reg)) header)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 13
+ (inst addu bytes rank (+ (* array-dimensions-offset n-word-bytes)
+ lowtag-mask))
+ (inst li header (lognot lowtag-mask))
+ (inst and bytes header)
+ (inst addu header rank (fixnumize (1- array-dimensions-offset)))
+ (inst sll header n-widetag-bits)
+ (inst or header header type)
+ (inst srl header 2)
+ (pseudo-atomic (pa-flag)
+ (inst or result alloc-tn other-pointer-lowtag)
+ (storew header result 0 other-pointer-lowtag)
+ (inst addu alloc-tn bytes))))
+
+\f
+;;;; Additional accessors and setters for the array header.
+
+(defknown sb!impl::%array-dimension (t index) index
+ (flushable))
+(defknown sb!impl::%set-array-dimension (t index index) index
+ ())
+
+(define-full-reffer %array-dimension *
+ array-dimensions-offset other-pointer-lowtag
+ (any-reg) positive-fixnum sb!impl::%array-dimension)
+
+(define-full-setter %set-array-dimension *
+ array-dimensions-offset other-pointer-lowtag
+ (any-reg) positive-fixnum sb!impl::%set-array-dimension)
+
+
+(defknown sb!impl::%array-rank (t) index (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 subu temp (1- array-dimensions-offset))
+ (inst sll res temp 2)))
+
+
+\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)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (let ((error (generate-error-code vop invalid-array-index-error
+ array bound index)))
+ (inst sltu temp index bound)
+ (inst beq temp zero-tn 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-full-data-vector-frobs (type element-type &rest scs)
+ `(progn
+ (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
+ vector-data-offset other-pointer-lowtag
+ ,(remove-if #'(lambda (x) (member x '(null zero))) scs)
+ ,element-type
+ data-vector-ref)
+ (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
+ vector-data-offset other-pointer-lowtag ,scs ,element-type
+ data-vector-set)))
+
+ (def-partial-data-vector-frobs (type element-type size signed &rest scs)
+ `(progn
+ (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
+ ,size ,signed vector-data-offset other-pointer-lowtag ,scs
+ ,element-type data-vector-ref)
+ (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
+ ,size vector-data-offset other-pointer-lowtag ,scs
+ ,element-type data-vector-set))))
+
+ (def-full-data-vector-frobs simple-vector *
+ descriptor-reg any-reg null zero)
+
+ (def-partial-data-vector-frobs simple-string base-char
+ :byte nil base-char-reg)
+
+ (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
+ :byte nil unsigned-reg signed-reg)
+
+ (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
+ :short nil unsigned-reg signed-reg)
+
+ (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
+ unsigned-reg)
+
+ (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
+ :byte t signed-reg)
+
+ (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
+ :short t signed-reg)
+
+ (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num
+ any-reg)
+
+ (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
+ signed-reg))
+
+
+
+;;; 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 (interior-reg)) lip)
+ (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
+ (:generator 20
+ (inst srl temp index ,bit-shift)
+ (inst sll temp 2)
+ (inst addu lip object temp)
+ (inst lw result lip
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst and temp index ,(1- elements-per-word))
+ ,@(when (eq *backend-byte-order* :big-endian)
+ `((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
+ (integer 0
+ ,(1- (* (1+ (- (floor (+ #x7fff
+ other-pointer-lowtag)
+ n-word-bytes)
+ vector-data-offset))
+ elements-per-word)))))
+ (:info index)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 15
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ ,@(when (eq *backend-byte-order* :big-endian)
+ `((setf extra (logxor extra (1- ,elements-per-word)))))
+ (loadw result object (+ word vector-data-offset)
+ other-pointer-lowtag)
+ (unless (zerop extra)
+ (inst srl result (* extra ,bits)))
+ (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 (interior-reg)) lip)
+ (:temporary (:scs (non-descriptor-reg)) temp old)
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
+ (:generator 25
+ (inst srl temp index ,bit-shift)
+ (inst sll temp 2)
+ (inst addu lip object temp)
+ (inst lw old lip
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst and shift index ,(1- elements-per-word))
+ ,@(when (eq *backend-byte-order* :big-endian)
+ `((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 nor temp temp zero-tn)
+ (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 sw old lip
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (sc-case value
+ (immediate
+ (inst li result (tn-value value)))
+ (zero
+ (move result zero-tn))
+ (unsigned-reg
+ (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
+ (integer 0
+ ,(1- (* (1+ (- (floor (+ #x7fff
+ other-pointer-lowtag)
+ n-word-bytes)
+ vector-data-offset))
+ elements-per-word))))
+ positive-fixnum)
+ (:info index)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg)) temp old)
+ (:generator 20
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ ,@(when (eq *backend-byte-order* :big-endian)
+ `((setf extra (logxor extra (1- ,elements-per-word)))))
+ (inst lw old object
+ (- (* (+ word vector-data-offset) n-word-bytes)
+ other-pointer-lowtag))
+ (unless (and (sc-is value immediate)
+ (= (tn-value value) ,(1- (ash 1 bits))))
+ (cond ((= extra ,(1- elements-per-word))
+ (inst sll old ,bits)
+ (inst srl old ,bits))
+ (t
+ (inst li temp
+ (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits))))
+ (inst and old temp))))
+ (sc-case value
+ (zero)
+ (immediate
+ (let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits)))
+ (* extra ,bits))))
+ (cond ((< value #x10000)
+ (inst or old value))
+ (t
+ (inst li temp value)
+ (inst or old temp)))))
+ (unsigned-reg
+ (inst sll temp value (* extra ,bits))
+ (inst or old temp)))
+ (inst sw old object
+ (- (* (+ word vector-data-offset) n-word-bytes)
+ other-pointer-lowtag))
+ (sc-case value
+ (immediate
+ (inst li result (tn-value value)))
+ (zero
+ (move result zero-tn))
+ (unsigned-reg
+ (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))
+
+
+;;; 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)))
+ (:result-types single-float)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 20
+ (inst addu lip object index)
+ (inst lwc1 value lip
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst nop)))
+
+(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 (interior-reg)) lip)
+ (:generator 20
+ (inst addu lip object index)
+ (inst swc1 value lip
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (unless (location= result value)
+ (inst fmove :single 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 (interior-reg)) lip)
+ (:generator 20
+ (inst addu lip object index)
+ (inst addu lip index)
+ (ecase *backend-byte-order*
+ (:big-endian
+ (inst lwc1 value lip
+ (+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)
+ n-word-bytes))
+ (inst lwc1-odd value lip
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))
+ (:little-endian
+ (inst lwc1 value lip
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst lwc1-odd value lip
+ (+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)
+ n-word-bytes))))
+ (inst nop)))
+
+(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 (interior-reg)) lip)
+ (:generator 20
+ (inst addu lip object index)
+ (inst addu lip index)
+ (ecase *backend-byte-order*
+ (:big-endian
+ (inst swc1 value lip
+ (+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)
+ n-word-bytes))
+ (inst swc1-odd value lip
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))
+ (:little-endian
+ (inst swc1 value lip
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst swc1-odd value lip
+ (+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)
+ n-word-bytes))))
+ (unless (location= result value)
+ (inst fmove :double result value))))
+
+\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))
+ (index :scs (any-reg)))
+ (:arg-types simple-array-complex-single-float positive-fixnum)
+ (:results (value :scs (complex-single-reg)))
+ (:temporary (:scs (interior-reg)) lip)
+ (:result-types complex-single-float)
+ (:generator 5
+ (inst addu lip object index)
+ (inst addu lip index)
+ (let ((real-tn (complex-single-reg-real-tn value)))
+ (inst lwc1 real-tn lip (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))
+ (let ((imag-tn (complex-single-reg-imag-tn value)))
+ (inst lwc1 imag-tn lip (- (* (1+ vector-data-offset) n-word-bytes)
+ other-pointer-lowtag)))
+ (inst nop)))
+
+
+(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))
+ (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 (interior-reg)) lip)
+ (:generator 5
+ (inst addu lip object index)
+ (inst addu lip index)
+ (let ((value-real (complex-single-reg-real-tn value))
+ (result-real (complex-single-reg-real-tn result)))
+ (inst swc1 value-real lip (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (unless (location= result-real value-real)
+ (inst fmove :single result-real value-real)))
+ (let ((value-imag (complex-single-reg-imag-tn value))
+ (result-imag (complex-single-reg-imag-tn result)))
+ (inst swc1 value-imag lip (- (* (1+ vector-data-offset) n-word-bytes)
+ other-pointer-lowtag))
+ (unless (location= result-imag value-imag)
+ (inst fmove :single 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))
+ (index :scs (any-reg) :target shift))
+ (:arg-types simple-array-complex-double-float positive-fixnum)
+ (:results (value :scs (complex-double-reg)))
+ (:result-types complex-double-float)
+ (:temporary (:scs (interior-reg)) lip)
+ (:temporary (:scs (any-reg) :from (:argument 1)) shift)
+ (:generator 6
+ (inst sll shift index 2)
+ (inst addu lip object shift)
+ (let ((real-tn (complex-double-reg-real-tn value)))
+ (ld-double real-tn lip (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))
+ (let ((imag-tn (complex-double-reg-imag-tn value)))
+ (ld-double imag-tn lip (- (* (+ vector-data-offset 2) n-word-bytes)
+ other-pointer-lowtag)))
+ (inst nop)))
+
+(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))
+ (index :scs (any-reg) :target shift)
+ (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 (interior-reg)) lip)
+ (:temporary (:scs (any-reg) :from (:argument 1)) shift)
+ (:generator 6
+ (inst sll shift index 2)
+ (inst addu lip object shift)
+ (let ((value-real (complex-double-reg-real-tn value))
+ (result-real (complex-double-reg-real-tn result)))
+ (str-double value-real lip (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (unless (location= result-real value-real)
+ (inst fmove :double result-real value-real)))
+ (let ((value-imag (complex-double-reg-imag-tn value))
+ (result-imag (complex-double-reg-imag-tn result)))
+ (str-double value-imag lip (- (* (+ vector-data-offset 2) n-word-bytes)
+ other-pointer-lowtag))
+ (unless (location= result-imag value-imag)
+ (inst fmove :double 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))
+
+(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))
+
+;;; These vops are useful for accessing the bits of a vector irrespective of
+;;; what type of vector it is.
+;;;
+
+(define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg) unsigned-num
+ %raw-bits)
+(define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
+ unsigned-num %set-raw-bits)
+
+
+\f
+;;;; Misc. Array VOPs.
+
+(define-vop (get-vector-subtype get-header-data))
+(define-vop (set-vector-subtype set-header-data))
+
--- /dev/null
+(in-package "SB!VM")
+
+;;; FIXME: Do I need a different one for little-endian? :spim,
+;;; perhaps?
+(def!constant +backend-fasl-file-implementation+ :mips)
+(setf *backend-register-save-penalty* 3)
+(setf *backend-byte-order*
+ #!+little-endian :little-endian
+ #!-little-endian :big-endian)
+;;; FIXME: Check this. Where is it used?
+(setf *backend-page-size* 4096)
--- /dev/null
+(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
+ (stack-frame-size 0)
+ (did-int-arg nil)
+ (float-args 0))
+
+(define-alien-type-method (integer :arg-tn) (type state)
+ (let ((stack-frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+ (setf (arg-state-did-int-arg state) t)
+ (multiple-value-bind
+ (ptype reg-sc stack-sc)
+ (if (alien-integer-type-signed type)
+ (values 'signed-byte-32 'signed-reg 'signed-stack)
+ (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))
+ (if (< stack-frame-size 4)
+ (my-make-wired-tn ptype reg-sc (+ stack-frame-size 4))
+ (my-make-wired-tn ptype stack-sc stack-frame-size)))))
+
+(define-alien-type-method (system-area-pointer :arg-tn) (type state)
+ (declare (ignore type))
+ (let ((stack-frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+ (setf (arg-state-did-int-arg state) t)
+ (if (< stack-frame-size 4)
+ (my-make-wired-tn 'system-area-pointer
+ 'sap-reg
+ (+ stack-frame-size 4))
+ (my-make-wired-tn 'system-area-pointer
+ 'sap-stack
+ stack-frame-size))))
+
+(define-alien-type-method (double-float :arg-tn) (type state)
+ (declare (ignore type))
+ (let ((stack-frame-size (logandc2 (1+ (arg-state-stack-frame-size state)) 1))
+ (float-args (arg-state-float-args state)))
+ (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
+ (setf (arg-state-float-args state) (1+ float-args))
+ (cond ((>= stack-frame-size 4)
+ (my-make-wired-tn 'double-float
+ 'double-stack
+ stack-frame-size))
+ ((and (not (arg-state-did-int-arg state))
+ (< float-args 2))
+ (my-make-wired-tn 'double-float
+ 'double-reg
+ (+ (* float-args 2) 12)))
+ (t
+ (my-make-wired-tn 'double-float
+ 'double-int-carg-reg
+ (+ stack-frame-size 4))))))
+
+(define-alien-type-method (single-float :arg-tn) (type state)
+ (declare (ignore type))
+ (let ((stack-frame-size (arg-state-stack-frame-size state))
+ (float-args (arg-state-float-args state)))
+ (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+ (setf (arg-state-float-args state) (1+ float-args))
+ (cond ((>= stack-frame-size 4)
+ (my-make-wired-tn 'single-float
+ 'single-stack
+ stack-frame-size))
+ ((and (not (arg-state-did-int-arg state))
+ (< float-args 2))
+ (my-make-wired-tn 'single-float
+ 'single-reg
+ (+ (* float-args 2) 12)))
+ (t
+ (my-make-wired-tn 'single-float
+ 'single-int-carg-reg
+ (+ stack-frame-size 4))))))
+
+
+(defstruct result-state
+ (num-results 0))
+
+(defun offset-for-result (n)
+ (+ n 2)
+ #+nil
+ (if (= n 0)
+ cfunc-offset
+ (+ n 2)))
+
+(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 (offset-for-result 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 (offset-for-result num-results))))
+
+;;; FIXME: do these still work? -- CSR, 2002-08-28
+(define-alien-type-method (double-float :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 'double-float 'double-reg (* num-results 2))))
+
+(define-alien-type-method (single-float :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 'single-float 'single-reg (* num-results 2))))
+
+(define-alien-type-method (values :result-tn) (type state)
+ (mapcar #'(lambda (type)
+ (invoke-alien-type-method :result-tn type state))
+ (alien-values-type-values type)))
+
+(!def-vm-support-routine make-call-out-tns (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)
+ (* (max (arg-state-stack-frame-size arg-state) 4) n-word-bytes)
+ (arg-tns)
+ (invoke-alien-type-method :result-tn
+ (alien-fun-type-result-type type)
+ (make-result-state))))))
+
+
+(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 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 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 jal (make-fixup "call_into_c" :foreign))
+ (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 15))
+ (inst subu nsp-tn delta))
+ (t
+ (inst li temp delta)
+ (inst subu nsp-tn temp)))))
+ (move result nsp-tn)))
+
+(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 15))
+ (inst addu nsp-tn delta))
+ (t
+ (inst li temp delta)
+ (inst addu nsp-tn temp)))))))
--- /dev/null
+(in-package "SB!VM")
+
+\f
+;;;; Interfaces to IR2 conversion:
+
+;;; Standard-Argument-Location -- Interface
+;;;
+;;; Return a wired TN describing the N'th full call argument passing
+;;; location.
+;;;
+(!def-vm-support-routine standard-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-Return-PC-Passing-Location -- Interface
+;;;
+;;; Make a passing location TN for a local call return PC. If standard is
+;;; true, then use the standard (full call) location, otherwise use any legal
+;;; location. Even in the non-standard case, this may be restricted by a
+;;; desire to use a subroutine call instruction.
+;;;
+(!def-vm-support-routine make-return-pc-passing-location (standard)
+ (if standard
+ (make-wired-tn *backend-t-primitive-type* register-arg-scn lra-offset)
+ (make-restricted-tn *backend-t-primitive-type* register-arg-scn)))
+
+;;; Make-Old-FP-Passing-Location -- Interface
+;;;
+;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass
+;;; Old-FP in. This is (obviously) wired in the standard convention, but is
+;;; totally unrestricted in non-standard conventions, since we can always fetch
+;;; it off of the stack using the arg pointer.
+;;;
+(!def-vm-support-routine make-old-fp-passing-location (standard)
+ (if standard
+ (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)
+ (make-normal-tn *fixnum-primitive-type*)))
+
+;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location -- Interface
+;;;
+;;; Make the TNs used to hold Old-FP and Return-PC within the current
+;;; function. We treat these specially so that the debugger can find them at a
+;;; known location.
+;;;
+(!def-vm-support-routine make-old-fp-save-location (env)
+ (specify-save-tn
+ (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)
+ (let ((ptype *backend-t-primitive-type*))
+ (specify-save-tn
+ (physenv-debug-live-tn (make-normal-tn ptype) env)
+ (make-wired-tn ptype control-stack-arg-scn lra-save-offset))))
+
+;;; Make-Argument-Count-Location -- Interface
+;;;
+;;; Make a TN for the standard argument count passing location. We only
+;;; need to make the standard location, since a count is never passed when we
+;;; are using non-standard conventions.
+;;;
+(!def-vm-support-routine make-arg-count-location ()
+ (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset))
+
+
+;;; MAKE-NFP-TN -- Interface
+;;;
+;;; Make a TN to hold the number-stack frame pointer. This is allocated
+;;; once per component, and is component-live.
+;;;
+(!def-vm-support-routine make-nfp-tn ()
+ (component-live-tn
+ (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nfp-offset)))
+
+;;; MAKE-STACK-POINTER-TN ()
+;;;
+(!def-vm-support-routine make-stack-pointer-tn ()
+ (make-normal-tn *fixnum-primitive-type*))
+
+;;; MAKE-NUMBER-STACK-POINTER-TN ()
+;;;
+(!def-vm-support-routine make-number-stack-pointer-tn ()
+ (make-normal-tn *fixnum-primitive-type*))
+
+;;; Make-Unknown-Values-Locations -- Interface
+;;;
+;;; Return a list of TNs that can be used to represent an unknown-values
+;;; continuation within a function.
+;;;
+(!def-vm-support-routine make-unknown-values-locations ()
+ (list (make-stack-pointer-tn)
+ (make-normal-tn *fixnum-primitive-type*)))
+
+
+;;; Select-Component-Format -- Interface
+;;;
+;;; This function is called by the Entry-Analyze phase, allowing
+;;; VM-dependent initialization of the IR2-Component structure. We push
+;;; placeholder entries in the Constants to leave room for additional
+;;; noise in the code object header.
+;;;
+(!def-vm-support-routine select-component-format (component)
+ (declare (type component component))
+ (dotimes (i code-constants-offset)
+ (vector-push-extend nil
+ (ir2-component-constants (component-info component))))
+ (values))
+
+\f
+;;;; Frame hackery:
+
+;;; BYTES-NEEDED-FOR-NON-DESCRIPTOR-STACK-FRAME -- internal
+;;;
+;;; Return the number of bytes needed for the current non-descriptor stack
+;;; frame. Non-descriptor stack frames must be multiples of 8 bytes on
+;;; the PMAX.
+;;;
+(defun bytes-needed-for-non-descriptor-stack-frame ()
+ (* (logandc2 (1+ (sb-allocated-size 'non-descriptor-stack)) 1)
+ 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 addu 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 fun-header-word)
+ (dotimes (i (1- simple-fun-code-offset))
+ (inst word 0))
+ ;; The start of the actual code.
+ ;; Compute CODE from the address of this entry point.
+ (let ((entry-point (gen-label)))
+ (emit-label entry-point)
+ (inst compute-code-from-fn code-tn lip-tn entry-point temp)
+ ;; ### We should also save it on the stack so that the garbage collector
+ ;; won't forget about us if we call anyone else.
+ )
+ ;; Build our stack frames.
+ (inst addu csp-tn cfp-tn
+ (* n-word-bytes (sb-allocated-size 'control-stack)))
+ (let ((nfp (current-nfp-tn vop)))
+ (when nfp
+ (inst addu nsp-tn nsp-tn
+ (- (bytes-needed-for-non-descriptor-stack-frame)))
+ (move nfp nsp-tn)))
+ (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 addu csp-tn csp-tn
+ (* n-word-bytes (sb-allocated-size 'control-stack)))
+ (when (ir2-physenv-number-stack-p callee)
+ (inst addu nsp-tn nsp-tn
+ (- (bytes-needed-for-non-descriptor-stack-frame)))
+ (move nfp nsp-tn))
+ (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 addu csp-tn csp-tn (* nargs n-word-bytes)))))
+
+
+
+\f
+;;; Default-Unknown-Values -- Internal
+;;;
+;;; Emit code needed at the return-point from an unknown-values call for a
+;;; fixed number of values. Values is the head of the TN-Ref list for the
+;;; locations that the values are to be received into. Nvals is the number of
+;;; values that are to be received (should equal the length of Values).
+;;;
+;;; Move-Temp is a Descriptor-Reg TN used as a temporary.
+;;;
+;;; This code exploits the fact that in the unknown-values convention, a
+;;; single value return returns at the return PC + 8, whereas a return of other
+;;; than one value returns directly at the return PC.
+;;;
+;;; If 0 or 1 values are expected, then we just emit an instruction to reset
+;;; the SP (which will only be executed when other than 1 value is returned.)
+;;;
+;;; In the general case, we have to do three things:
+;;; -- Default unsupplied register values. This need only be done when a
+;;; single value is returned, since register values are defaulted by the
+;;; called in the non-single case.
+;;; -- Default unsupplied stack values. This needs to be done whenever there
+;;; are stack values.
+;;; -- Reset SP. This must be done whenever other than 1 value is returned,
+;;; regardless of the number of values desired.
+;;;
+;;; The general-case code looks like this:
+#|
+ b regs-defaulted ; Skip if MVs
+ nop
+
+ move a1 null-tn ; Default register values
+ ...
+ loadi nargs 1 ; Force defaulting of stack values
+ move ocfp csp ; Set up args for SP resetting
+
+regs-defaulted
+ subu temp nargs register-arg-count
+
+ bltz temp default-value-7 ; jump to default code
+ addu temp temp -1
+ loadw move-temp ocfp-tn 6 ; Move value to correct location.
+ store-stack-tn val4-tn move-temp
+
+ bltz temp default-value-8
+ addu temp temp -1
+ loadw move-temp ocfp-tn 7
+ store-stack-tn val5-tn move-temp
+
+ ...
+
+defaulting-done
+ move sp 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
+ ;; Note that this is a single-value return point. This is actually
+ ;; the multiple-value entry point for a single desired value, but
+ ;; the code location has to be here, or the debugger backtrace
+ ;; gets confused.
+ (without-scheduling ()
+ (note-this-location vop :single-value-return)
+ (move csp-tn ocfp-tn)
+ (inst nop))
+ (when lra-label
+ (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)))
+ (without-scheduling ()
+ ;; Note that this is an unknown-values return point.
+ (note-this-location vop :unknown-return)
+ ;; Branch off to the MV case.
+ (inst b regs-defaulted)
+ ;; If there are no stack results, clear the stack now.
+ (if (> nvals register-arg-count)
+ (inst addu 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)
+ ;; If there are stack results, we have to default them
+ ;; and clear the stack.
+ (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 blez temp default-lab)
+ (inst lw move-temp ocfp-tn (* i n-word-bytes))
+ (inst addu temp temp (fixnumize -1))
+ (store-stack-tn tn move-temp)))
+
+ (emit-label defaulting-done)
+ (move csp-tn ocfp-tn)
+
+ (let ((defaults (defaults)))
+ (assert defaults)
+ (assemble (*elsewhere*)
+ (emit-label default-stack-vals)
+ (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)))))))
+
+ (when lra-label
+ (inst compute-code-from-lra code-tn code-tn lra-label temp))))
+ (values))
+
+\f
+;;;; Unknown values receiving:
+
+;;; Receive-Unknown-Values -- Internal
+;;;
+;;; Emit code needed at the return point for an unknown-values call for an
+;;; arbitrary number of values.
+;;;
+;;; We do the single and non-single cases with no shared code: there doesn't
+;;; seem to be any potential overlap, and receiving a single value is more
+;;; important efficiency-wise.
+;;;
+;;; When there is a single value, we just push it on the stack, returning
+;;; the old SP and 1.
+;;;
+;;; When there is a variable number of values, we move all of the argument
+;;; registers onto the stack, and return Args and Nargs.
+;;;
+;;; Args and Nargs are TNs wired to the named locations. We must
+;;; explicitly allocate these TNs, since their lifetimes overlap with the
+;;; results Start and Count (also, it's nice to be able to target them).
+;;;
+(defun receive-unknown-values (args nargs start count lra-label temp)
+ (declare (type tn args nargs start count temp))
+ (let ((variable-values (gen-label))
+ (done (gen-label)))
+ (without-scheduling ()
+ (inst b variable-values)
+ (inst nop))
+
+ (when lra-label
+ (inst compute-code-from-lra code-tn code-tn lra-label temp))
+ (inst addu csp-tn csp-tn 4)
+ (storew (first register-arg-tns) csp-tn -1)
+ (inst addu start csp-tn -4)
+ (inst li count (fixnumize 1))
+
+ (emit-label done)
+
+ (assemble (*elsewhere*)
+ (emit-label variable-values)
+ (when lra-label
+ (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)))
+ (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) 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) ocfp)
+ (:ignore arg-locs args ocfp)
+ (:generator 5
+ (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)
+ (trace-table-entry trace-table-call-site)
+ (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)
+ (trace-table-entry trace-table-normal)
+ (emit-return-pc label)
+ (default-unknown-values vop values nvals move-temp temp label)
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save)))))
+
+
+;;; 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
+ (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)
+ (trace-table-entry trace-table-call-site)
+ (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)
+ (trace-table-entry trace-table-normal)
+ (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)))))
+
+\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
+ (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)
+ (trace-table-entry trace-table-call-site)
+ (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)
+ (trace-table-entry trace-table-normal)
+ (emit-return-pc label)
+ (note-this-location vop :known-return)
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save)))))
+
+;;; 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 (ocfp :target ocfp-temp)
+ (return-pc :target return-pc-temp)
+ (vals :more t))
+ (:temporary (:sc any-reg :from (:argument 0)) ocfp-temp)
+ (:temporary (:sc descriptor-reg :from (:argument 1))
+ return-pc-temp)
+ (:temporary (:scs (interior-reg)) lip)
+ (: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 ocfp-temp ocfp)
+ (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 addu nsp-tn cur-nfp
+ (bytes-needed-for-non-descriptor-stack-frame))))
+ (inst addu lip return-pc-temp (- n-word-bytes other-pointer-lowtag))
+ (inst j lip)
+ (move cfp-tn ocfp-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.
+
+;;; Define-Full-Call -- Internal
+;;;
+;;; This macro helps in the definition of full call VOPs by avoiding code
+;;; replication in defining the cross-product VOPs.
+;;;
+;;; Name is the name of the VOP to define.
+;;;
+;;; Named is true if the first argument is a symbol whose global function
+;;; definition is to be called.
+;;;
+;;; Return is either :Fixed, :Unknown or :Tail:
+;;; -- If :Fixed, then the call is for a fixed number of values, returned in
+;;; the standard passing locations (passed as result operands).
+;;; -- If :Unknown, then the result values are pushed on the stack, and the
+;;; result values are specified by the Start and Count as in the
+;;; unknown-values continuation representation.
+;;; -- If :Tail, then do a tail-recursive call. No values are returned.
+;;; The Ocfp 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)
+ '((ocfp :target ocfp-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)))
+ ocfp-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 fdefn-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)))
+
+ (:temporary (:sc interior-reg :offset lip-offset) entry-point)
+
+ (:generator ,(+ (if named 5 0)
+ (if variable 19 1)
+ (if (eq return :tail) 0 10)
+ 15
+ (if (eq return :unknown) 25 0))
+ (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= ocfp ocfp-pass)
+ :load-ocfp)
+ (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 subu nargs-pass csp-tn new-fp)
+ ,@(let ((index -1))
+ (mapcar #'(lambda (name)
+ `(inst lw ,name new-fp
+ ,(ash (incf index)
+ word-shift)))
+ register-arg-names)))
+ '((inst li nargs-pass (fixnumize nargs)))))
+ ,@(if (eq return :tail)
+ '((:load-ocfp
+ (sc-case ocfp
+ (any-reg
+ (inst move ocfp-pass ocfp))
+ (control-stack
+ (inst lw ocfp-pass cfp-tn
+ (ash (tn-offset ocfp)
+ word-shift)))))
+ (:load-return-pc
+ (sc-case return-pc
+ (descriptor-reg
+ (inst move return-pc-pass return-pc))
+ (control-stack
+ (inst lw return-pc-pass cfp-tn
+ (ash (tn-offset return-pc)
+ word-shift)))))
+ (:frob-nfp
+ (inst addu nsp-tn cur-nfp
+ (bytes-needed-for-non-descriptor-stack-frame))))
+ `((: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 ocfp-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)))
+ (trace-table-entry trace-table-call-site))))
+ ((nil)
+ (inst nop))))))
+
+ ,@(if named
+ `((sc-case name
+ (descriptor-reg (move name-pass name))
+ (control-stack
+ (inst lw name-pass cfp-tn
+ (ash (tn-offset name) word-shift))
+ (do-next-filler))
+ (constant
+ (inst lw name-pass code-tn
+ (- (ash (tn-offset name) word-shift)
+ other-pointer-lowtag))
+ (do-next-filler)))
+ (inst lw entry-point name-pass
+ (- (ash fdefn-raw-addr-slot word-shift)
+ other-pointer-lowtag))
+ (do-next-filler))
+ `((sc-case arg-fun
+ (descriptor-reg (move lexenv arg-fun))
+ (control-stack
+ (inst lw lexenv cfp-tn
+ (ash (tn-offset arg-fun) word-shift))
+ (do-next-filler))
+ (constant
+ (inst lw lexenv code-tn
+ (- (ash (tn-offset arg-fun) word-shift)
+ other-pointer-lowtag))
+ (do-next-filler)))
+ (inst lw function lexenv
+ (- (ash closure-fun-slot word-shift)
+ fun-pointer-lowtag))
+ (do-next-filler)
+ (inst addu entry-point function
+ (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-lowtag))))
+ (loop
+ (if (cdr filler)
+ (do-next-filler)
+ (return)))
+
+ (note-this-location vop :call-site)
+ (inst j entry-point)
+ (do-next-filler))
+
+ ,@(ecase return
+ (:fixed
+ '((trace-table-entry trace-table-normal)
+ (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
+ '((trace-table-entry trace-table-normal)
+ (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))))))
+
+
+(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)
+ (ocfp-arg :scs (any-reg) :target ocfp)
+ (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)) ocfp)
+ (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra)
+
+ (: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 ocfp ocfp-arg)
+ (move lra lra-arg)
+
+ ;; Clear the number stack if anything is there.
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (inst addu nsp-tn cur-nfp
+ (bytes-needed-for-non-descriptor-stack-frame))))
+
+ ;; And jump to the assembly-routine that does the bliting.
+ (inst j (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 (ocfp :scs (any-reg))
+ (return-pc :scs (descriptor-reg))
+ (value))
+ (:ignore value)
+ (:temporary (:scs (interior-reg)) lip)
+ (:vop-var vop)
+ (:generator 6
+ ;; Clear the number stack.
+ (trace-table-entry trace-table-fun-epilogue)
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (inst addu nsp-tn cur-nfp
+ (bytes-needed-for-non-descriptor-stack-frame))))
+ ;; Clear the control stack, and restore the frame pointer.
+ (move csp-tn cfp-tn)
+ (move cfp-tn ocfp)
+ ;; Out of here.
+ (lisp-return return-pc lip :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 (ocfp :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)
+ (:temporary (:scs (interior-reg)) lip)
+ (:vop-var vop)
+ (:generator 6
+ ;; Clear the number stack.
+ (trace-table-entry trace-table-fun-epilogue)
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (inst addu nsp-tn cur-nfp
+ (bytes-needed-for-non-descriptor-stack-frame))))
+ ;; 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 ocfp)
+ (inst addu 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 lip)
+ (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 (ocfp-arg :scs (any-reg) :target ocfp)
+ (lra-arg :scs (descriptor-reg) :target lra)
+ (vals-arg :scs (any-reg) :target vals)
+ (nvals-arg :scs (any-reg) :target nvals))
+
+ (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) ocfp)
+ (: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 (interior-reg)) lip)
+
+ (: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 addu nsp-tn cur-nfp
+ (bytes-needed-for-non-descriptor-stack-frame))))
+
+ ;; Check for the single case.
+ (inst li a0 (fixnumize 1))
+ (inst bne nvals-arg a0 not-single)
+ (inst lw a0 vals-arg)
+
+ ;; Return with one value.
+ (move csp-tn cfp-tn)
+ (move cfp-tn ocfp-arg)
+ (lisp-return lra-arg lip :offset 2)
+
+ ;; Nope, not the single case.
+ (emit-label not-single)
+ (move ocfp ocfp-arg)
+ (move lra lra-arg)
+ (move vals vals-arg)
+ (move nvals nvals-arg)
+ (inst j (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 nl4-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 beq nargs-tn done)
+ (inst addu csp-tn csp-tn nargs-tn))
+ (t
+ (inst addu count nargs-tn (fixnumize (- fixed)))
+ (inst blez count done)
+ (inst nop)
+ (inst addu 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 addu count nargs-tn (fixnumize (- register-arg-count))))
+ ;; Everything of interest in registers.
+ (inst blez count do-regs)
+ ;; Initialize dst to be end of stack.
+ (move dst csp-tn)
+ ;; Initialize src to be end of args.
+ (inst addu src cfp-tn nargs-tn)
+
+ (emit-label loop)
+ ;; *--dst = *--src, --count
+ (inst addu src src (- n-word-bytes))
+ (inst addu count count (fixnumize -1))
+ (loadw temp src)
+ (inst addu dst dst (- n-word-bytes))
+ (inst bgtz count 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.
+ ;; We know there is at least one more arg, otherwise we would have
+ ;; branched to done up at the top.
+ (inst subu count nargs-tn (fixnumize (1+ fixed)))
+ (do ((i fixed (1+ i)))
+ ((>= i register-arg-count))
+ ;; Is this the last one?
+ (inst beq count done)
+ ;; Store it relative to the pointer saved at the start.
+ (storew (nth i register-arg-tns) result (- i fixed))
+ ;; Decrement count.
+ (inst subu count (fixnumize 1))))
+ (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-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %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 dst)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+ (:results (result :scs (descriptor-reg)))
+ (:translate %listify-rest-args)
+ (:policy :safe)
+ (:generator 20
+ (let ((enter (gen-label))
+ (loop (gen-label))
+ (done (gen-label)))
+ (move context context-arg)
+ (move count count-arg)
+ ;; Check to see if there are any arguments.
+ (inst beq count zero-tn done)
+ (move result null-tn)
+
+ ;; We need to do this atomically.
+ (pseudo-atomic (pa-flag)
+ ;; Allocate a cons (2 words) for each item.
+ (inst or result alloc-tn list-pointer-lowtag)
+ (move dst result)
+ (inst sll temp count 1)
+ (inst b enter)
+ (inst addu alloc-tn alloc-tn temp)
+
+ ;; Store the current cons in the cdr of the previous cons.
+ (emit-label loop)
+ (inst addu dst dst (* 2 n-word-bytes))
+ (storew dst dst -1 list-pointer-lowtag)
+
+ (emit-label enter)
+ ;; Grab one value.
+ (loadw temp context)
+ (inst addu context context n-word-bytes)
+
+ ;; Dec count, and if != zero, go back for more.
+ (inst addu count count (fixnumize -1))
+ (inst bne count zero-tn loop)
+
+ ;; Store the value in the car (in delay slot)
+ (storew temp dst 0 list-pointer-lowtag)
+
+ ;; NIL out the last cons.
+ (storew null-tn dst 1 list-pointer-lowtag))
+ (emit-label 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 addu count supplied (fixnumize (- fixed)))
+ (inst subu 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))
+ (:temporary (:scs (any-reg) :type fixnum) temp)
+ (:info count)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 3
+ (let ((err-lab
+ (generate-error-code vop invalid-arg-count-error nargs)))
+ (cond ((zerop count)
+ (inst bne nargs zero-tn err-lab)
+ (inst nop))
+ (t
+ (inst li temp (fixnumize count))
+ (inst bne nargs temp err-lab)
+ (inst nop))))))
+
+;;; Various other error signalers.
+;;;
+(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
+(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 null zero)))
+ (: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 (non-descriptor-reg)) temp)
+ (: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 xor temp value unbound-marker-widetag)
+ (inst beq temp zero-tn 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)
+ (:temporary (:scs (non-descriptor-reg)) temp))
+
+(define-vop (boundp boundp-frob)
+ (:translate boundp)
+ (:generator 9
+ (loadw value object symbol-value-slot other-pointer-lowtag)
+ (inst xor temp value unbound-marker-widetag)
+ (if not-p
+ (inst beq temp zero-tn target)
+ (inst bne temp zero-tn 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)
+ (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp)))
+ (inst beq value null-tn 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 nop)
+ (inst xor type simple-fun-header-widetag)
+ (inst beq type zero-tn normal-fn)
+ (inst addu lip function
+ (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-lowtag))
+ (inst li lip (make-fixup "closure_tramp" :foreign))
+ (emit-label normal-fn)
+ (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
+ (storew function fdefn fdefn-fun-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 "undefined_tramp" :foreign))
+ (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
+ (move result fdefn)))
+
+
+\f
+;;;; Binding and Unbinding.
+
+;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
+;;; the symbol on the binding stack and stuff the new value into the
+;;; symbol.
+
+(define-vop (bind)
+ (:args (val :scs (any-reg descriptor-reg))
+ (symbol :scs (descriptor-reg)))
+ (:temporary (:scs (descriptor-reg)) temp)
+ (:generator 5
+ (loadw temp symbol symbol-value-slot other-pointer-lowtag)
+ (inst addu 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 addu 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 beq where bsp-tn done)
+ (inst nop)
+
+ (emit-label loop)
+ (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
+ (inst beq symbol zero-tn 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 addu bsp-tn bsp-tn (* -2 n-word-bytes))
+ (inst bne where bsp-tn loop)
+ (inst nop)
+
+ (emit-label done))))
+
+
+\f
+;;;; Closure indexing.
+
+(define-full-reffer closure-index-ref *
+ closure-info-offset fun-pointer-lowtag
+ (descriptor-reg any-reg) * %closure-index-ref)
+
+(define-full-setter set-funcallable-instance-info *
+ funcallable-instance-info-offset fun-pointer-lowtag
+ (descriptor-reg any-reg null zero) * %set-funcallable-instance-info)
+
+(define-full-reffer funcallable-instance-info *
+ funcallable-instance-info-offset fun-pointer-lowtag
+ (descriptor-reg any-reg) * %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)))
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 4
+ (loadw res struct 0 instance-pointer-lowtag)
+ (inst srl res n-widetag-bits)))
+
+(define-vop (instance-ref slot-ref)
+ (:variant instance-slots-offset instance-pointer-lowtag)
+ (:policy :fast-safe)
+ (:translate %instance-ref)
+ (:arg-types instance (:constant index)))
+
+#+nil
+(define-vop (instance-set slot-set)
+ (:policy :fast-safe)
+ (:translate %instance-set)
+ (:variant instance-slots-offset instance-pointer-lowtag)
+ (:arg-types instance (:constant index) *))
+
+(define-full-reffer instance-index-ref * instance-slots-offset
+ instance-pointer-lowtag (descriptor-reg any-reg) * %instance-ref)
+
+(define-full-setter instance-index-set * instance-slots-offset
+ instance-pointer-lowtag (descriptor-reg any-reg null zero) * %instance-set)
+
+
+\f
+;;;; Code object frobbing.
+
+(define-full-reffer code-header-ref * 0 other-pointer-lowtag
+ (descriptor-reg any-reg) * code-header-ref)
+
+(define-full-setter code-header-set * 0 other-pointer-lowtag
+ (descriptor-reg any-reg null zero) * code-header-set)
+
+
+
--- /dev/null
+(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)))
+ (: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)))
+ (:generator 1
+ (inst sll y x n-widetag-bits)
+ (inst or y 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))))
+ (: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))
+ (: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-ARGUMENT + 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 2)))
+
+(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 2)))
+
+\f
+;;; Comparison of base-chars.
+;;;
+(define-vop (base-char-compare pointer-compare)
+ (:args (x :scs (base-char-reg))
+ (y :scs (base-char-reg)))
+ (:arg-types base-char base-char))
+
+(define-vop (fast-char=/base-char base-char-compare)
+ (:translate char=)
+ (:variant :eq))
+
+(define-vop (fast-char</base-char base-char-compare)
+ (:translate char<)
+ (:variant :lt))
+
+(define-vop (fast-char>/base-char base-char-compare)
+ (:translate char>)
+ (:variant :gt))
+
--- /dev/null
+(in-package "SB!VM")
+
+
+(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 stack-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg) :target sap)
+ (offset :scs (any-reg)))
+ (:arg-types system-area-pointer positive-fixnum)
+ (:temporary (:scs (sap-reg) :from :eval) sap)
+ (:results (result :scs (descriptor-reg)))
+ (:result-types *)
+ (:generator 5
+ (inst add sap object offset)
+ (inst lw result sap 0)
+ (inst nop)))
+
+(define-vop (read-control-stack-c)
+ (:translate stack-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg)))
+ (:info offset)
+ (:arg-types system-area-pointer (:constant (signed-byte 14)))
+ (:results (result :scs (descriptor-reg)))
+ (:result-types *)
+ (:generator 4
+ (inst lw result object (* offset n-word-bytes))
+ (inst nop)))
+
+(define-vop (write-control-stack)
+ (:translate %set-stack-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg) :target sap)
+ (offset :scs (any-reg))
+ (value :scs (descriptor-reg) :target result))
+ (:arg-types system-area-pointer positive-fixnum *)
+ (:results (result :scs (descriptor-reg)))
+ (:result-types *)
+ (:temporary (:scs (sap-reg) :from (:argument 1)) sap)
+ (:generator 2
+ (inst add sap object offset)
+ (inst sw value sap 0)
+ (move result value)))
+
+(define-vop (write-control-stack-c)
+ (:translate %set-stack-ref)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (value :scs (descriptor-reg) :target result))
+ (:info offset)
+ (:arg-types system-area-pointer (:constant (signed-byte 14)) *)
+ (:results (result :scs (descriptor-reg)))
+ (:result-types *)
+ (:generator 1
+ (inst sw value sap (* offset n-word-bytes))
+ (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 beq temp bogus)
+ (inst sll temp (1- (integer-length n-word-bytes)))
+ (unless (= lowtag other-pointer-lowtag)
+ (inst addu temp (- lowtag other-pointer-lowtag)))
+ (inst subu 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-fun 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
+(in-package "SB!VM")
+
+\f
+;;;; Move functions:
+
+
+(define-move-fun (load-single 1) (vop x y)
+ ((single-stack) (single-reg))
+ (inst lwc1 y (current-nfp-tn vop) (* (tn-offset x) n-word-bytes))
+ (inst nop))
+
+(define-move-fun (store-single 1) (vop x y)
+ ((single-reg) (single-stack))
+ (inst swc1 x (current-nfp-tn vop) (* (tn-offset y) n-word-bytes)))
+
+
+(defun ld-double (r base offset)
+ (ecase *backend-byte-order*
+ (:big-endian
+ (inst lwc1 r base (+ offset n-word-bytes))
+ (inst lwc1-odd r base offset))
+ (:little-endian
+ (inst lwc1 r base offset)
+ (inst lwc1-odd r base (+ offset 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)))
+ (ld-double y nfp offset))
+ (inst nop))
+
+(defun str-double (x base offset)
+ (ecase *backend-byte-order*
+ (:big-endian
+ (inst swc1 x base (+ offset n-word-bytes))
+ (inst swc1-odd x base offset))
+ (:little-endian
+ (inst swc1 x base offset)
+ (inst swc1-odd x base (+ offset n-word-bytes)))))
+
+(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)))
+ (str-double x nfp offset)))
+
+
+\f
+;;;; Move VOPs:
+
+(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)
+ (inst fmove ,format y x))))
+ (define-move-vop ,vop :move (,sc) (,sc)))))
+ (frob single-move single-reg :single)
+ (frob double-move double-reg :double))
+
+
+(define-vop (move-from-float)
+ (:args (x :to :save))
+ (:results (y))
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+ (:variant-vars double-p size type data)
+ (:note "float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y pa-flag ndescr type size)
+ (if double-p
+ (str-double x y (- (* data n-word-bytes) other-pointer-lowtag))
+ (inst swc1 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
+ nil single-float-size single-float-widetag single-float-value-slot)
+ (frob move-from-double double-reg
+ t double-float-size double-float-widetag double-float-value-slot))
+
+
+(macrolet ((frob (name sc double-p value)
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (,sc)))
+ (:note "pointer to float coercion")
+ (:generator 2
+ ,@(ecase *backend-byte-order*
+ (:big-endian
+ (cond
+ (double-p
+ `((inst lwc1 y x (- (* (1+ ,value) n-word-bytes)
+ other-pointer-lowtag))
+ (inst lwc1-odd y x (- (* ,value n-word-bytes)
+ other-pointer-lowtag))))
+ (t
+ `((inst lwc1 y x (- (* ,value n-word-bytes)
+ other-pointer-lowtag))))))
+ (:little-endian
+ `((inst lwc1 y x (- (* ,value n-word-bytes)
+ other-pointer-lowtag))
+ ,@(when double-p
+ `((inst lwc1-odd y x
+ (- (* (1+ ,value) n-word-bytes)
+ other-pointer-lowtag)))))))
+ (inst nop)))
+ (define-move-vop ,name :move (descriptor-reg) (,sc)))))
+ (frob move-to-single single-reg nil single-float-value-slot)
+ (frob move-to-double double-reg t double-float-value-slot))
+
+
+(macrolet ((frob (name sc stack-sc format double-p)
+ `(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 ,(if double-p 2 1)
+ (sc-case y
+ (,sc
+ (unless (location= x y)
+ (inst fmove ,format y x)))
+ (,stack-sc
+ (let ((offset (* (tn-offset y) n-word-bytes)))
+ ,@(ecase *backend-byte-order*
+ (:big-endian
+ (cond
+ (double-p
+ '((inst swc1 x nfp (+ offset n-word-bytes))
+ (inst swc1-odd x nfp offset)))
+ (t
+ '((inst swc1 x nfp offset)))))
+ (:little-endian
+ `((inst swc1 x nfp offset)
+ ,@(when double-p
+ '((inst swc1-odd x nfp
+ (+ offset n-word-bytes))))))))))))
+ (define-move-vop ,name :move-arg
+ (,sc descriptor-reg) (,sc)))))
+ (frob move-single-float-arg single-reg single-stack :single nil)
+ (frob move-double-float-arg double-reg double-stack :double t))
+
+\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 (+ (tn-offset x) 2)))
+
+(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)))
+
+
+(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 lwc1 real-tn nfp offset))
+ (let ((imag-tn (complex-single-reg-imag-tn y)))
+ (inst lwc1 imag-tn nfp (+ offset n-word-bytes))))
+ (inst nop))
+
+(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 swc1 real-tn nfp offset))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (inst swc1 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)))
+ (ld-double real-tn nfp offset))
+ (let ((imag-tn (complex-double-reg-imag-tn y)))
+ (ld-double imag-tn nfp (+ offset (* 2 n-word-bytes))))
+ (inst nop)))
+
+(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)))
+ (str-double real-tn nfp offset))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (str-double imag-tn nfp (+ offset (* 2 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 fmove :single y-real x-real))
+ (let ((x-imag (complex-single-reg-imag-tn x))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst fmove :single 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)))
+ (inst fmove :double y-real x-real))
+ (let ((x-imag (complex-double-reg-imag-tn x))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst fmove :double y-imag x-imag)))))
+;;;
+(define-move-vop complex-double-move :move
+ (complex-double-reg) (complex-double-reg))
+
+;;;
+;;; Move from a complex float to a descriptor register allocating a
+;;; new complex float object in the process.
+;;;
+(define-vop (move-from-complex-single)
+ (:args (x :scs (complex-single-reg) :to :save))
+ (:results (y :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+ (:note "complex single float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y pa-flag ndescr complex-single-float-widetag
+ complex-single-float-size)
+ (let ((real-tn (complex-single-reg-real-tn x)))
+ (inst swc1 real-tn y (- (* complex-single-float-real-slot
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (inst swc1 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)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+ (:note "complex double float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y pa-flag ndescr complex-double-float-widetag
+ complex-double-float-size)
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (str-double real-tn y (- (* complex-double-float-real-slot
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (str-double 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))
+
+;;;
+;;; 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 lwc1 real-tn x (- (* complex-single-float-real-slot n-word-bytes)
+ other-pointer-lowtag)))
+ (let ((imag-tn (complex-single-reg-imag-tn y)))
+ (inst lwc1 imag-tn x (- (* complex-single-float-imag-slot n-word-bytes)
+ other-pointer-lowtag)))
+ (inst nop)))
+(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)))
+ (ld-double real-tn x (- (* complex-double-float-real-slot n-word-bytes)
+ other-pointer-lowtag)))
+ (let ((imag-tn (complex-double-reg-imag-tn y)))
+ (ld-double imag-tn x (- (* complex-double-float-imag-slot n-word-bytes)
+ other-pointer-lowtag)))
+ (inst nop)))
+(define-move-vop move-to-complex-double :move
+ (descriptor-reg) (complex-double-reg))
+
+;;;
+;;; Complex float move-argument 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 fmove :single y-real x-real))
+ (let ((x-imag (complex-single-reg-imag-tn x))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst fmove :single 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 swc1 real-tn nfp offset))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (inst swc1 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)))
+ (inst fmove :double y-real x-real))
+ (let ((x-imag (complex-double-reg-imag-tn x))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst fmove :double y-imag x-imag))))
+ (complex-double-stack
+ (let ((offset (* (tn-offset y) n-word-bytes)))
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (str-double real-tn nfp offset))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (str-double 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))
+
+
+(define-move-vop move-arg :move-arg
+ (single-reg double-reg complex-single-reg complex-double-reg)
+ (descriptor-reg))
+
+\f
+;;;; stuff for c-call float-in-int-register arguments
+
+(define-vop (move-to-single-int-reg)
+ (:args (x :scs (single-reg descriptor-reg)))
+ (:results (y :scs (single-int-carg-reg) :load-if nil))
+ (:note "pointer to float-in-int coercion")
+ (:generator 1
+ (sc-case x
+ (single-reg
+ (inst mfc1 y x))
+ (descriptor-reg
+ (inst lw y x (- (* single-float-value-slot n-word-bytes)
+ other-pointer-lowtag))))
+ (inst nop))) ;nop needed here?
+(define-move-vop move-to-single-int-reg
+ :move (single-reg descriptor-reg) (single-int-carg-reg))
+
+(define-vop (move-single-int-reg)
+ (:args (x :target y :scs (single-int-carg-reg) :load-if nil)
+ (fp :scs (any-reg) :load-if (not (sc-is y single-int-carg-reg))))
+ (:results (y :scs (single-int-carg-reg) :load-if nil))
+ (:generator 1
+ (unless (location= x y)
+ (error "Huh? why did it do that?"))))
+(define-move-vop move-single-int-reg :move-arg
+ (single-int-carg-reg) (single-int-carg-reg))
+
+(define-vop (move-to-double-int-reg)
+ (:args (x :scs (double-reg descriptor-reg)))
+ (:results (y :scs (double-int-carg-reg) :load-if nil))
+ (:note "pointer to float-in-int coercion")
+ (:generator 2
+ (sc-case x
+ (double-reg
+ (ecase *backend-byte-order*
+ (:big-endian
+ (inst mfc1-odd2 y x)
+ (inst mfc1-odd y x))
+ (:little-endian
+ (inst mfc1 y x)
+ (inst mfc1-odd3 y x))))
+ (descriptor-reg
+ (inst lw y x (- (* double-float-value-slot n-word-bytes)
+ other-pointer-lowtag))
+ (inst lw-odd y x (- (* (1+ double-float-value-slot) n-word-bytes)
+ other-pointer-lowtag))))
+ (inst nop))) ;nop needed here?
+(define-move-vop move-to-double-int-reg
+ :move (double-reg descriptor-reg) (double-int-carg-reg))
+
+(define-vop (move-double-int-reg)
+ (:args (x :target y :scs (double-int-carg-reg) :load-if nil)
+ (fp :scs (any-reg) :load-if (not (sc-is y double-int-carg-reg))))
+ (:results (y :scs (double-int-carg-reg) :load-if nil))
+ (:generator 2
+ (unless (location= x y)
+ (error "Huh? why did it do that?"))))
+(define-move-vop move-double-int-reg :move-arg
+ (double-int-carg-reg) (double-int-carg-reg))
+
+\f
+;;;; Arithmetic VOPs:
+
+(define-vop (float-op)
+ (:args (x) (y))
+ (:results (r))
+ (:variant-vars format operation)
+ (:policy :fast-safe)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 0
+ (note-this-location vop :internal-error)
+ (inst float-op operation format r x y)))
+
+(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))
+
+(macrolet ((frob (op sname scost dname dcost)
+ `(progn
+ (define-vop (,sname single-float-op)
+ (:translate ,op)
+ (:variant :single ',op)
+ (:variant-cost ,scost))
+ (define-vop (,dname double-float-op)
+ (:translate ,op)
+ (:variant :double ',op)
+ (:variant-cost ,dcost)))))
+ (frob + +/single-float 2 +/double-float 2)
+ (frob - -/single-float 2 -/double-float 2)
+ (frob * */single-float 4 */double-float 5)
+ (frob / //single-float 12 //double-float 19))
+
+(macrolet ((frob (name inst translate format 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 ,format y x)))))
+ (frob abs/single-float fabs abs :single single-reg single-float)
+ (frob abs/double-float fabs abs :double double-reg double-float)
+ (frob %negate/single-float fneg %negate :single single-reg single-float)
+ (frob %negate/double-float fneg %negate :double double-reg double-float))
+
+\f
+;;;; Comparison:
+
+(define-vop (float-compare)
+ (:args (x) (y))
+ (:conditional)
+ (:info target not-p)
+ (:variant-vars format operation complement)
+ (:policy :fast-safe)
+ (:note "inline float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 3
+ (note-this-location vop :internal-error)
+ (inst fcmp operation format x y)
+ (inst nop)
+ (if (if complement (not not-p) not-p)
+ (inst bc1f target)
+ (inst bc1t 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))
+
+(macrolet ((frob (translate op complement sname dname)
+ `(progn
+ (define-vop (,sname single-float-compare)
+ (:translate ,translate)
+ (:variant :single ,op ,complement))
+ (define-vop (,dname double-float-compare)
+ (:translate ,translate)
+ (:variant :double ,op ,complement)))))
+ (frob < :lt nil </single-float </double-float)
+ (frob > :ngt t >/single-float >/double-float)
+ (frob = :seq nil =/single-float =/double-float))
+
+\f
+;;;; Conversion:
+
+(macrolet ((frob (name translate
+ from-sc from-type from-format
+ to-sc to-type to-format)
+ (let ((word-p (eq from-format :word)))
+ `(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 ,(if word-p 3 2)
+ ,@(if word-p
+ `((inst mtc1 y x)
+ (inst nop)
+ (note-this-location vop :internal-error)
+ (inst fcvt ,to-format :word y y))
+ `((note-this-location vop :internal-error)
+ (inst fcvt ,to-format ,from-format y x))))))))
+ (frob %single-float/signed %single-float
+ signed-reg signed-num :word
+ single-reg single-float :single)
+ (frob %double-float/signed %double-float
+ signed-reg signed-num :word
+ double-reg double-float :double)
+ (frob %single-float/double-float %single-float
+ double-reg double-float :double
+ single-reg single-float :single)
+ (frob %double-float/single-float %double-float
+ single-reg single-float :single
+ double-reg double-float :double))
+
+
+(macrolet ((frob (name from-sc from-type from-format)
+ `(define-vop (,name)
+ (:args (x :scs (,from-sc)))
+ (:results (y :scs (signed-reg)))
+ (:temporary (:from (:argument 0) :sc ,from-sc) temp)
+ (:arg-types ,from-type)
+ (:result-types signed-num)
+ (:translate %unary-round)
+ (:policy :fast-safe)
+ (:note "inline float round")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 3
+ (note-this-location vop :internal-error)
+ (inst fcvt :word ,from-format temp x)
+ (inst mfc1 y temp)
+ (inst nop)))))
+ (frob %unary-round/single-float single-reg single-float :single)
+ (frob %unary-round/double-float double-reg double-float :double))
+
+
+;;; These VOPs have to uninterruptibly frob the rounding mode in order to get
+;;; the desired round-to-zero behavior.
+;;;
+(macrolet ((frob (name from-sc from-type from-format)
+ `(define-vop (,name)
+ (:args (x :scs (,from-sc)))
+ (:results (y :scs (signed-reg)))
+ (:temporary (:from (:argument 0) :sc ,from-sc) temp)
+ (:temporary (:sc non-descriptor-reg) status-save new-status)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset)
+ pa-flag)
+ (:arg-types ,from-type)
+ (:result-types signed-num)
+ (:translate %unary-truncate)
+ (:policy :fast-safe)
+ (:note "inline float truncate")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 16
+ (pseudo-atomic (pa-flag)
+ (inst cfc1 status-save 31)
+ (inst li new-status (lognot 3))
+ (inst and new-status status-save)
+ (inst or new-status float-round-to-zero)
+ (inst ctc1 new-status 31)
+
+ ;; These instructions seem to be necessary to ensure that
+ ;; the new modes affect the fcvt instruction.
+ (inst nop)
+ (inst cfc1 new-status 31)
+
+ (note-this-location vop :internal-error)
+ (inst fcvt :word ,from-format temp x)
+ (inst mfc1 y temp)
+ (inst nop)
+ (inst ctc1 status-save 31))))))
+ (frob %unary-truncate/single-float single-reg single-float :single)
+ (frob %unary-truncate/double-float double-reg double-float :double))
+
+
+(define-vop (make-single-float)
+ (:args (bits :scs (signed-reg)))
+ (:results (res :scs (single-reg)))
+ (:arg-types signed-num)
+ (:result-types single-float)
+ (:translate make-single-float)
+ (:policy :fast-safe)
+ (:generator 2
+ (inst mtc1 res bits)
+ (inst nop)))
+
+(define-vop (make-double-float)
+ (:args (hi-bits :scs (signed-reg))
+ (lo-bits :scs (unsigned-reg)))
+ (:results (res :scs (double-reg)))
+ (:arg-types signed-num unsigned-num)
+ (:result-types double-float)
+ (:translate make-double-float)
+ (:policy :fast-safe)
+ (:generator 2
+ (inst mtc1 res lo-bits)
+ (inst mtc1-odd res hi-bits)
+ (inst nop)))
+
+(define-vop (single-float-bits)
+ (:args (float :scs (single-reg)))
+ (:results (bits :scs (signed-reg)))
+ (:arg-types single-float)
+ (:result-types signed-num)
+ (:translate single-float-bits)
+ (:policy :fast-safe)
+ (:generator 2
+ (inst mfc1 bits float)
+ (inst nop)))
+
+(define-vop (double-float-high-bits)
+ (:args (float :scs (double-reg)))
+ (:results (hi-bits :scs (signed-reg)))
+ (:arg-types double-float)
+ (:result-types signed-num)
+ (:translate double-float-high-bits)
+ (:policy :fast-safe)
+ (:generator 2
+ (inst mfc1-odd hi-bits float)
+ (inst nop)))
+
+(define-vop (double-float-low-bits)
+ (:args (float :scs (double-reg)))
+ (:results (lo-bits :scs (unsigned-reg)))
+ (:arg-types double-float)
+ (:result-types unsigned-num)
+ (:translate double-float-low-bits)
+ (:policy :fast-safe)
+ (:generator 2
+ (inst mfc1 lo-bits float)
+ (inst nop)))
+
+\f
+;;;; Float mode hackery:
+
+(sb!xc:deftype float-modes () '(unsigned-byte 24))
+(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)
+ (:generator 3
+ (inst cfc1 res 31)
+ (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)
+ (:generator 3
+ (inst ctc1 res 31)
+ (move res new)))
+
+\f
+;;;; Complex float VOPs
+
+(define-vop (make-complex-single-float)
+ (:translate complex)
+ (:args (real :scs (single-reg) :target 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 fmove :single r-real real)))
+ (let ((r-imag (complex-single-reg-imag-tn r)))
+ (unless (location= imag r-imag)
+ (inst fmove :single r-imag imag))))
+ (complex-single-stack
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset r) n-word-bytes)))
+ (inst swc1 real nfp offset)
+ (inst swc1 imag nfp (+ offset n-word-bytes)))))))
+
+(define-vop (make-complex-double-float)
+ (:translate complex)
+ (:args (real :scs (double-reg) :target 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)
+ (inst fmove :double r-real real)))
+ (let ((r-imag (complex-double-reg-imag-tn r)))
+ (unless (location= imag r-imag)
+ (inst fmove :double r-imag imag))))
+ (complex-double-stack
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset r) n-word-bytes)))
+ (str-double real nfp offset)
+ (str-double imag nfp (+ offset (* 2 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 fmove :single r value-tn))))
+ (complex-single-stack
+ (inst lwc1 r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
+ (tn-offset x))
+ n-word-bytes))
+ (inst nop)))))
+
+(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)
+ (inst fmove :double r value-tn))))
+ (complex-double-stack
+ (ld-double r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
+ (tn-offset x))
+ n-word-bytes))
+ (inst nop)))))
+
+(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))
--- /dev/null
+(in-package "SB!VM")
+
+(setf *assem-scheduler-p* t)
+(setf *assem-max-locations* 68)
+
+
+\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))
+ (tn-offset tn))
+
+;;;(sb!disassem:set-disassem-params :instruction-alignment 32)
+
+(defvar *disassem-use-lisp-reg-names* t)
+
+(!def-vm-support-routine location-number (loc)
+ (etypecase loc
+ (null)
+ (number)
+ (label)
+ (fixup)
+ (tn
+ (ecase (sb-name (sc-sb (tn-sc loc)))
+ (immediate-constant
+ ;; Can happen if $ZERO or $NULL are passed in.
+ nil)
+ (registers
+ (unless (zerop (tn-offset loc))
+ (tn-offset loc)))
+ (float-registers
+ (+ (tn-offset loc) 32))))
+ (symbol
+ (ecase loc
+ (:memory 0)
+ (:hi-reg 64)
+ (:low-reg 65)
+ (:float-status 66)
+ (:ctrl-stat-reg 67)
+ (:r31 31)))))
+
+(defparameter reg-symbols
+ (map 'vector
+ #'(lambda (name)
+ (cond ((null name) nil)
+ (t (make-symbol (concatenate 'string "$" name)))))
+ *register-names*))
+
+(sb!disassem:define-arg-type reg
+ :printer #'(lambda (value stream dstate)
+ (declare (stream stream) (fixnum value))
+ (let ((regname (aref reg-symbols value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref
+ value
+ 'registers
+ regname
+ dstate))))
+
+(defparameter float-reg-symbols
+ (coerce
+ (loop for n from 0 to 31 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))))
+
+(sb!disassem:define-arg-type control-reg
+ :printer "(CR:#x~X)")
+
+(sb!disassem:define-arg-type relative-label
+ :sign-extend t
+ :use-label #'(lambda (value dstate)
+ (declare (type (signed-byte 16) value)
+ (type sb!disassem:disassem-state dstate))
+ (+ (ash (1+ value) 2) (sb!disassem:dstate-cur-addr dstate))))
+
+(deftype float-format ()
+ '(member :s :single :d :double :w :word))
+
+(defun float-format-value (format)
+ (ecase format
+ ((:s :single) 0)
+ ((:d :double) 1)
+ ((:w :word) 4)))
+
+(sb!disassem:define-arg-type float-format
+ :printer #'(lambda (value stream dstate)
+ (declare (ignore dstate)
+ (stream stream)
+ (fixnum value))
+ (princ (case value
+ (0 's)
+ (1 'd)
+ (4 'w)
+ (t '?))
+ stream)))
+
+(defconstant-eqx compare-kinds
+ '(:f :un :eq :ueq :olt :ult :ole :ule :sf :ngle :seq :ngl :lt :nge :le :ngt)
+ #'equalp)
+
+(defconstant-eqx compare-kinds-vec
+ (apply #'vector compare-kinds)
+ #'equalp)
+
+(deftype compare-kind ()
+ `(member ,@compare-kinds))
+
+(defun compare-kind (kind)
+ (or (position kind compare-kinds)
+ (error "Unknown floating point compare kind: ~S~%Must be one of: ~S"
+ kind
+ compare-kinds)))
+
+(sb!disassem:define-arg-type compare-kind
+ :printer compare-kinds-vec)
+
+(defconstant-eqx float-operations '(+ - * /) #'equalp)
+
+(deftype float-operation ()
+ `(member ,@float-operations))
+
+(defconstant-eqx float-operation-names
+ ;; this gets used for output only
+ #(add sub mul div)
+ #'equalp)
+
+(defun float-operation (op)
+ (or (position op float-operations)
+ (error "Unknown floating point operation: ~S~%Must be one of: ~S"
+ op
+ float-operations)))
+
+(sb!disassem:define-arg-type float-operation
+ :printer float-operation-names)
+
+
+\f
+;;;; Constants used by instruction emitters.
+
+(defconstant special-op #b000000)
+(defconstant bcond-op #b000001)
+(defconstant cop0-op #b010000)
+(defconstant cop1-op #b010001)
+(defconstant cop2-op #b010010)
+(defconstant cop3-op #b010011)
+
+
+\f
+;;;; dissassem:define-instruction-formats
+
+(defconstant-eqx immed-printer
+ '(:name :tab rt (:unless (:same-as rt) ", " rs) ", " immediate)
+ #'equalp)
+
+;;; for things that use rt=0 as a nop
+(defconstant-eqx immed-zero-printer
+ '(:name :tab rt (:unless (:constant 0) ", " rs) ", " immediate)
+ #'equalp)
+
+(sb!disassem:define-instruction-format
+ (immediate 32 :default-printer immed-printer)
+ (op :field (byte 6 26))
+ (rs :field (byte 5 21) :type 'reg)
+ (rt :field (byte 5 16) :type 'reg)
+ (immediate :field (byte 16 0) :sign-extend t))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter jump-printer
+ #'(lambda (value stream dstate)
+ (let ((addr (ash value 2)))
+ (sb!disassem:maybe-note-assembler-routine addr t dstate)
+ (write addr :base 16 :radix t :stream stream)))))
+
+(sb!disassem:define-instruction-format
+ (jump 32 :default-printer '(:name :tab target))
+ (op :field (byte 6 26))
+ (target :field (byte 26 0) :printer jump-printer))
+
+(defconstant-eqx reg-printer
+ '(:name :tab rd (:unless (:same-as rd) ", " rs) ", " rt)
+ #'equalp)
+
+(sb!disassem:define-instruction-format
+ (register 32 :default-printer reg-printer)
+ (op :field (byte 6 26))
+ (rs :field (byte 5 21) :type 'reg)
+ (rt :field (byte 5 16) :type 'reg)
+ (rd :field (byte 5 11) :type 'reg)
+ (shamt :field (byte 5 6) :value 0)
+ (funct :field (byte 6 0)))
+
+(sb!disassem:define-instruction-format
+ (break 32 :default-printer
+ '(:name :tab code (:unless (:constant 0) subcode)))
+ (op :field (byte 6 26) :value special-op)
+ (code :field (byte 10 16))
+ (subcode :field (byte 10 6) :value 0)
+ (funct :field (byte 6 0) :value #b001101))
+
+(sb!disassem:define-instruction-format
+ (coproc-branch 32 :default-printer '(:name :tab offset))
+ (op :field (byte 6 26))
+ (funct :field (byte 10 16))
+ (offset :field (byte 16 0)))
+
+(defconstant-eqx float-fmt-printer
+ '((:unless :constant funct)
+ (:choose (:unless :constant sub-funct) nil)
+ "." format)
+ #'equalp)
+
+(defconstant-eqx float-printer
+ `(:name ,@float-fmt-printer
+ :tab
+ fd
+ (:unless (:same-as fd) ", " fs)
+ ", " ft)
+ #'equalp)
+
+(sb!disassem:define-instruction-format
+ (float 32 :default-printer float-printer)
+ (op :field (byte 6 26) :value cop1-op)
+ (filler :field (byte 1 25) :value 1)
+ (format :field (byte 4 21) :type 'float-format)
+ (ft :field (byte 5 16) :value 0)
+ (fs :field (byte 5 11) :type 'fp-reg)
+ (fd :field (byte 5 6) :type 'fp-reg)
+ (funct :field (byte 6 0)))
+
+(sb!disassem:define-instruction-format
+ (float-aux 32 :default-printer float-printer)
+ (op :field (byte 6 26) :value cop1-op)
+ (filler-1 :field (byte 1 25) :value 1)
+ (format :field (byte 4 21) :type 'float-format)
+ (ft :field (byte 5 16) :type 'fp-reg)
+ (fs :field (byte 5 11) :type 'fp-reg)
+ (fd :field (byte 5 6) :type 'fp-reg)
+ (funct :field (byte 2 4))
+ (sub-funct :field (byte 4 0)))
+
+(sb!disassem:define-instruction-format
+ (float-op 32
+ :include 'float
+ :default-printer
+ '('f funct "." format
+ :tab
+ fd
+ (:unless (:same-as fd) ", " fs)
+ ", " ft))
+ (funct :field (byte 2 0) :type 'float-operation)
+ (funct-filler :field (byte 4 2) :value 0)
+ (ft :value nil :type 'fp-reg))
+
+\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-immediate-inst 32
+ (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0))
+
+(define-bitfield-emitter emit-jump-inst 32
+ (byte 6 26) (byte 26 0))
+
+(define-bitfield-emitter emit-register-inst 32
+ (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 5 6) (byte 6 0))
+
+(define-bitfield-emitter emit-break-inst 32
+ (byte 6 26) (byte 10 16) (byte 10 6) (byte 6 0))
+
+(define-bitfield-emitter emit-float-inst 32
+ (byte 6 26) (byte 1 25) (byte 4 21) (byte 5 16)
+ (byte 5 11) (byte 5 6) (byte 6 0))
+
+
+\f
+;;;; Math instructions.
+
+(defun emit-math-inst (segment dst src1 src2 reg-opcode immed-opcode
+ &optional allow-fixups)
+ (unless src2
+ (setf src2 src1)
+ (setf src1 dst))
+ (etypecase src2
+ (tn
+ (emit-register-inst segment special-op (reg-tn-encoding src1)
+ (reg-tn-encoding src2) (reg-tn-encoding dst)
+ 0 reg-opcode))
+ (integer
+ (emit-immediate-inst segment immed-opcode (reg-tn-encoding src1)
+ (reg-tn-encoding dst) src2))
+ (fixup
+ (unless allow-fixups
+ (error "Fixups aren't allowed."))
+ (note-fixup segment :addi src2)
+ (emit-immediate-inst segment immed-opcode (reg-tn-encoding src1)
+ (reg-tn-encoding dst) 0))))
+
+(define-instruction add (segment dst src1 &optional src2)
+ (:declare (type tn dst)
+ (type (or tn (signed-byte 16) null) src1 src2))
+ (:printer register ((op special-op) (funct #b100000)))
+ (:printer immediate ((op #b001000)))
+ (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-math-inst segment dst src1 src2 #b100000 #b001000)))
+
+(define-instruction addu (segment dst src1 &optional src2)
+ (:declare (type tn dst)
+ (type (or tn (signed-byte 16) fixup null) src1 src2))
+ (:printer register ((op special-op) (funct #b100001)))
+ (:printer immediate ((op #b001001)))
+ (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-math-inst segment dst src1 src2 #b100001 #b001001 t)))
+
+(define-instruction sub (segment dst src1 &optional src2)
+ (:declare
+ (type tn dst)
+ (type (or tn (integer #.(- 1 (ash 1 15)) #.(ash 1 15)) null) src1 src2))
+ (:printer register ((op special-op) (funct #b100010)))
+ (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
+ (:delay 0)
+ (:emitter
+ (unless src2
+ (setf src2 src1)
+ (setf src1 dst))
+ (emit-math-inst segment dst src1
+ (if (integerp src2) (- src2) src2)
+ #b100010 #b001000)))
+
+(define-instruction subu (segment dst src1 &optional src2)
+ (:declare
+ (type tn dst)
+ (type
+ (or tn (integer #.(- 1 (ash 1 15)) #.(ash 1 15)) fixup null) src1 src2))
+ (:printer register ((op special-op) (funct #b100011)))
+ (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
+ (:delay 0)
+ (:emitter
+ (unless src2
+ (setf src2 src1)
+ (setf src1 dst))
+ (emit-math-inst segment dst src1
+ (if (integerp src2) (- src2) src2)
+ #b100011 #b001001 t)))
+
+(define-instruction and (segment dst src1 &optional src2)
+ (:declare (type tn dst)
+ (type (or tn (unsigned-byte 16) null) src1 src2))
+ (:printer register ((op special-op) (funct #b100100)))
+ (:printer immediate ((op #b001100) (immediate nil :sign-extend nil)))
+ (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-math-inst segment dst src1 src2 #b100100 #b001100)))
+
+(define-instruction or (segment dst src1 &optional src2)
+ (:declare (type tn dst)
+ (type (or tn (unsigned-byte 16) null) src1 src2))
+ (:printer register ((op special-op) (funct #b100101)))
+ (:printer immediate ((op #b001101)))
+ (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-math-inst segment dst src1 src2 #b100101 #b001101)))
+
+(define-instruction xor (segment dst src1 &optional src2)
+ (:declare (type tn dst)
+ (type (or tn (unsigned-byte 16) null) src1 src2))
+ (:printer register ((op special-op) (funct #b100110)))
+ (:printer immediate ((op #b001110)))
+ (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-math-inst segment dst src1 src2 #b100110 #b001110)))
+
+(define-instruction nor (segment dst src1 &optional src2)
+ (:declare (type tn dst src1) (type (or tn null) src2))
+ (:printer register ((op special-op) (funct #b100111)))
+ (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-math-inst segment dst src1 src2 #b100111 #b000000)))
+
+(define-instruction slt (segment dst src1 &optional src2)
+ (:declare (type tn dst)
+ (type (or tn (signed-byte 16) null) src1 src2))
+ (:printer register ((op special-op) (funct #b101010)))
+ (:printer immediate ((op #b001010)))
+ (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-math-inst segment dst src1 src2 #b101010 #b001010)))
+
+(define-instruction sltu (segment dst src1 &optional src2)
+ (:declare (type tn dst)
+ (type (or tn (signed-byte 16) null) src1 src2))
+ (:printer register ((op special-op) (funct #b101011)))
+ (:printer immediate ((op #b001011)))
+ (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-math-inst segment dst src1 src2 #b101011 #b001011)))
+
+(defconstant-eqx divmul-printer '(:name :tab rs ", " rt) #'equalp)
+
+(define-instruction div (segment src1 src2)
+ (:declare (type tn src1 src2))
+ (:printer register ((op special-op) (rd 0) (funct #b011010)) divmul-printer)
+ (:dependencies (reads src1) (reads src2) (writes :hi-reg) (writes :low-reg))
+ (:delay 1)
+ (:emitter
+ (emit-register-inst segment special-op (reg-tn-encoding src1)
+ (reg-tn-encoding src2) 0 0 #b011010)))
+
+(define-instruction divu (segment src1 src2)
+ (:declare (type tn src1 src2))
+ (:printer register ((op special-op) (rd 0) (funct #b011011))
+ divmul-printer)
+ (:dependencies (reads src1) (reads src2) (writes :hi-reg) (writes :low-reg))
+ (:delay 1)
+ (:emitter
+ (emit-register-inst segment special-op (reg-tn-encoding src1)
+ (reg-tn-encoding src2) 0 0 #b011011)))
+
+(define-instruction mult (segment src1 src2)
+ (:declare (type tn src1 src2))
+ (:printer register ((op special-op) (rd 0) (funct #b011000)) divmul-printer)
+ (:dependencies (reads src1) (reads src2) (writes :hi-reg) (writes :low-reg))
+ (:delay 1)
+ (:emitter
+ (emit-register-inst segment special-op (reg-tn-encoding src1)
+ (reg-tn-encoding src2) 0 0 #b011000)))
+
+(define-instruction multu (segment src1 src2)
+ (:declare (type tn src1 src2))
+ (:printer register ((op special-op) (rd 0) (funct #b011001)))
+ (:dependencies (reads src1) (reads src2) (writes :hi-reg) (writes :low-reg))
+ (:delay 1)
+ (:emitter
+ (emit-register-inst segment special-op (reg-tn-encoding src1)
+ (reg-tn-encoding src2) 0 0 #b011001)))
+
+(defun emit-shift-inst (segment opcode dst src1 src2)
+ (unless src2
+ (setf src2 src1)
+ (setf src1 dst))
+ (etypecase src2
+ (tn
+ (emit-register-inst segment special-op (reg-tn-encoding src2)
+ (reg-tn-encoding src1) (reg-tn-encoding dst)
+ 0 (logior #b000100 opcode)))
+ ((unsigned-byte 5)
+ (emit-register-inst segment special-op 0 (reg-tn-encoding src1)
+ (reg-tn-encoding dst) src2 opcode))))
+
+(defconstant-eqx shift-printer
+ '(:name :tab
+ rd
+ (:unless (:same-as rd) ", " rt)
+ ", " (:cond ((rs :constant 0) shamt)
+ (t rs)))
+ #'equalp)
+
+(define-instruction sll (segment dst src1 &optional src2)
+ (:declare (type tn dst)
+ (type (or tn (unsigned-byte 5) null) src1 src2))
+ (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000000))
+ shift-printer)
+ (:printer register ((op special-op) (funct #b000100)) shift-printer)
+ (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-shift-inst segment #b00 dst src1 src2)))
+
+(define-instruction sra (segment dst src1 &optional src2)
+ (:declare (type tn dst)
+ (type (or tn (unsigned-byte 5) null) src1 src2))
+ (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000011))
+ shift-printer)
+ (:printer register ((op special-op) (funct #b000111)) shift-printer)
+ (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-shift-inst segment #b11 dst src1 src2)))
+
+(define-instruction srl (segment dst src1 &optional src2)
+ (:declare (type tn dst)
+ (type (or tn (unsigned-byte 5) null) src1 src2))
+ (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000010))
+ shift-printer)
+ (:printer register ((op special-op) (funct #b000110)) shift-printer)
+ (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-shift-inst segment #b10 dst src1 src2)))
+
+\f
+;;;; Floating point math.
+
+(define-instruction float-op (segment operation format dst src1 src2)
+ (:declare (type float-operation operation)
+ (type float-format format)
+ (type tn dst src1 src2))
+ (:printer float-op ())
+ (:dependencies (reads src1) (reads src2) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-float-inst segment cop1-op 1 (float-format-value format)
+ (fp-reg-tn-encoding src2) (fp-reg-tn-encoding src1)
+ (fp-reg-tn-encoding dst) (float-operation operation))))
+
+(defconstant-eqx float-unop-printer
+ `(:name ,@float-fmt-printer :tab fd (:unless (:same-as fd) ", " fs))
+ #'equalp)
+
+(define-instruction fabs (segment format dst &optional (src dst))
+ (:declare (type float-format format) (type tn dst src))
+ (:printer float ((funct #b000101)) float-unop-printer)
+ (:dependencies (reads src) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-float-inst segment cop1-op 1 (float-format-value format)
+ 0 (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
+ #b000101)))
+
+(define-instruction fneg (segment format dst &optional (src dst))
+ (:declare (type float-format format) (type tn dst src))
+ (:printer float ((funct #b000111)) float-unop-printer)
+ (:dependencies (reads src) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-float-inst segment cop1-op 1 (float-format-value format)
+ 0 (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
+ #b000111)))
+
+(define-instruction fcvt (segment format1 format2 dst src)
+ (:declare (type float-format format1 format2) (type tn dst src))
+ (:printer float-aux ((funct #b10) (sub-funct nil :type 'float-format))
+ `(:name "." sub-funct "." format :tab fd ", " fs))
+ (:dependencies (reads src) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-float-inst segment cop1-op 1 (float-format-value format2) 0
+ (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
+ (logior #b100000 (float-format-value format1)))))
+
+(define-instruction fcmp (segment operation format fs ft)
+ (:declare (type compare-kind operation)
+ (type float-format format)
+ (type tn fs ft))
+ (:printer float-aux ((fd 0) (funct #b11) (sub-funct nil :type 'compare-kind))
+ `(:name "-" sub-funct "." format :tab fs ", " ft))
+ (:dependencies (reads fs) (reads ft) (writes :float-status))
+ (:delay 1)
+ (:emitter
+ (emit-float-inst segment cop1-op 1 (float-format-value format)
+ (fp-reg-tn-encoding ft) (fp-reg-tn-encoding fs) 0
+ (logior #b110000 (compare-kind operation)))))
+
+\f
+;;;; Branch/Jump instructions.
+
+(defun emit-relative-branch (segment opcode r1 r2 target)
+ (emit-back-patch segment 4
+ #'(lambda (segment posn)
+ (emit-immediate-inst segment
+ opcode
+ (if (fixnump r1)
+ r1
+ (reg-tn-encoding r1))
+ (if (fixnump r2)
+ r2
+ (reg-tn-encoding r2))
+ (ash (- (label-position target)
+ (+ posn 4))
+ -2)))))
+
+(define-instruction b (segment target)
+ (:declare (type label target))
+ (:printer immediate ((op #b000100) (rs 0) (rt 0)
+ (immediate nil :type 'relative-label))
+ '(:name :tab immediate))
+ (:attributes branch)
+ (:delay 1)
+ (:emitter
+ (emit-relative-branch segment #b000100 0 0 target)))
+
+(define-instruction bal (segment target)
+ (:declare (type label target))
+ (:printer immediate ((op bcond-op) (rs 0) (rt #b01001)
+ (immediate nil :type 'relative-label))
+ '(:name :tab immediate))
+ (:attributes branch)
+ (:delay 1)
+ (:emitter
+ (emit-relative-branch segment bcond-op 0 #b10001 target)))
+
+
+(define-instruction beq (segment r1 r2-or-target &optional target)
+ (:declare (type tn r1)
+ (type (or tn fixnum label) r2-or-target)
+ (type (or label null) target))
+ (:printer immediate ((op #b000100) (immediate nil :type 'relative-label)))
+ (:attributes branch)
+ (:dependencies (reads r1) (reads r2-or-target))
+ (:delay 1)
+ (:emitter
+ (unless target
+ (setf target r2-or-target)
+ (setf r2-or-target 0))
+ (emit-relative-branch segment #b000100 r1 r2-or-target target)))
+
+(define-instruction bne (segment r1 r2-or-target &optional target)
+ (:declare (type tn r1)
+ (type (or tn fixnum label) r2-or-target)
+ (type (or label null) target))
+ (:printer immediate ((op #b000101) (immediate nil :type 'relative-label)))
+ (:attributes branch)
+ (:dependencies (reads r1) (reads r2-or-target))
+ (:delay 1)
+ (:emitter
+ (unless target
+ (setf target r2-or-target)
+ (setf r2-or-target 0))
+ (emit-relative-branch segment #b000101 r1 r2-or-target target)))
+
+(defconstant-eqx cond-branch-printer
+ '(:name :tab rs ", " immediate)
+ #'equalp)
+
+(define-instruction blez (segment reg target)
+ (:declare (type label target) (type tn reg))
+ (:printer
+ immediate ((op #b000110) (rt 0) (immediate nil :type 'relative-label))
+ cond-branch-printer)
+ (:attributes branch)
+ (:dependencies (reads reg))
+ (:delay 1)
+ (:emitter
+ (emit-relative-branch segment #b000110 reg 0 target)))
+
+(define-instruction bgtz (segment reg target)
+ (:declare (type label target) (type tn reg))
+ (:printer
+ immediate ((op #b000111) (rt 0) (immediate nil :type 'relative-label))
+ cond-branch-printer)
+ (:attributes branch)
+ (:dependencies (reads reg))
+ (:delay 1)
+ (:emitter
+ (emit-relative-branch segment #b000111 reg 0 target)))
+
+(define-instruction bltz (segment reg target)
+ (:declare (type label target) (type tn reg))
+ (:printer
+ immediate ((op bcond-op) (rt 0) (immediate nil :type 'relative-label))
+ cond-branch-printer)
+ (:attributes branch)
+ (:dependencies (reads reg))
+ (:delay 1)
+ (:emitter
+ (emit-relative-branch segment bcond-op reg #b00000 target)))
+
+(define-instruction bgez (segment reg target)
+ (:declare (type label target) (type tn reg))
+ (:printer
+ immediate ((op bcond-op) (rt 1) (immediate nil :type 'relative-label))
+ cond-branch-printer)
+ (:attributes branch)
+ (:dependencies (reads reg))
+ (:delay 1)
+ (:emitter
+ (emit-relative-branch segment bcond-op reg #b00001 target)))
+
+(define-instruction bltzal (segment reg target)
+ (:declare (type label target) (type tn reg))
+ (:printer
+ immediate ((op bcond-op) (rt #b01000) (immediate nil :type 'relative-label))
+ cond-branch-printer)
+ (:attributes branch)
+ (:dependencies (reads reg) (writes :r31))
+ (:delay 1)
+ (:emitter
+ (emit-relative-branch segment bcond-op reg #b10000 target)))
+
+(define-instruction bgezal (segment reg target)
+ (:declare (type label target) (type tn reg))
+ (:printer
+ immediate ((op bcond-op) (rt #b01001) (immediate nil :type 'relative-label))
+ cond-branch-printer)
+ (:attributes branch)
+ (:delay 1)
+ (:dependencies (reads reg) (writes :r31))
+ (:emitter
+ (emit-relative-branch segment bcond-op reg #b10001 target)))
+
+(defconstant-eqx j-printer
+ '(:name :tab (:choose rs target))
+ #'equalp)
+
+(define-instruction j (segment target)
+ (:declare (type (or tn fixup) target))
+ (:printer register ((op special-op) (rt 0) (rd 0) (funct #b001000))
+ j-printer)
+ (:printer jump ((op #b000010)) j-printer)
+ (:attributes branch)
+ (:dependencies (reads target))
+ (:delay 1)
+ (:emitter
+ (etypecase target
+ (tn
+ (emit-register-inst segment special-op (reg-tn-encoding target)
+ 0 0 0 #b001000))
+ (fixup
+ (note-fixup segment :jump target)
+ (emit-jump-inst segment #b000010 0)))))
+
+(define-instruction jal (segment reg-or-target &optional target)
+ (:declare (type (or null tn fixup) target)
+ (type (or tn fixup (integer -16 31)) reg-or-target))
+ (:printer register ((op special-op) (rt 0) (funct #b001001)) j-printer)
+ (:printer jump ((op #b000011)) j-printer)
+ (:attributes branch)
+ (:dependencies (if target (writes reg-or-target) (writes :r31)))
+ (:delay 1)
+ (:emitter
+ (unless target
+ (setf target reg-or-target)
+ (setf reg-or-target 31))
+ (etypecase target
+ (tn
+ (emit-register-inst segment special-op (reg-tn-encoding target) 0
+ reg-or-target 0 #b001001))
+ (fixup
+ (note-fixup segment :jump target)
+ (emit-jump-inst segment #b000011 0)))))
+
+(define-instruction bc1f (segment target)
+ (:declare (type label target))
+ (:printer coproc-branch ((op cop1-op) (funct #x100)
+ (offset nil :type 'relative-label)))
+ (:attributes branch)
+ (:dependencies (reads :float-status))
+ (:delay 1)
+ (:emitter
+ (emit-relative-branch segment cop1-op #b01000 #b00000 target)))
+
+(define-instruction bc1t (segment target)
+ (:declare (type label target))
+ (:printer coproc-branch ((op cop1-op) (funct #x101)
+ (offset nil :type 'relative-label)))
+ (:attributes branch)
+ (:dependencies (reads :float-status))
+ (:delay 1)
+ (:emitter
+ (emit-relative-branch segment cop1-op #b01000 #b00001 target)))
+
+
+\f
+;;;; Random movement instructions.
+
+(define-instruction lui (segment reg value)
+ (:declare (type tn reg)
+ (type (or fixup (signed-byte 16) (unsigned-byte 16)) value))
+ (:printer immediate ((op #b001111)
+ (immediate nil :sign-extend nil :printer "#x~4,'0X")))
+ (:dependencies (writes reg))
+ (:delay 0)
+ (:emitter
+ (when (fixup-p value)
+ (note-fixup segment :lui value)
+ (setf value 0))
+ (emit-immediate-inst segment #b001111 0 (reg-tn-encoding reg) value)))
+
+(defconstant-eqx mvsreg-printer '(:name :tab rd)
+ #'equalp)
+
+(define-instruction mfhi (segment reg)
+ (:declare (type tn reg))
+ (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010000))
+ mvsreg-printer)
+ (:dependencies (reads :hi-reg) (writes reg))
+ (:delay 2)
+ (:emitter
+ (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
+ #b010000)))
+
+(define-instruction mthi (segment reg)
+ (:declare (type tn reg))
+ (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010001))
+ mvsreg-printer)
+ (:dependencies (reads reg) (writes :hi-reg))
+ (:delay 0)
+ (:emitter
+ (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
+ #b010001)))
+
+(define-instruction mflo (segment reg)
+ (:declare (type tn reg))
+ (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010010))
+ mvsreg-printer)
+ (:dependencies (reads :low-reg) (writes reg))
+ (:delay 2)
+ (:emitter
+ (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
+ #b010010)))
+
+(define-instruction mtlo (segment reg)
+ (:declare (type tn reg))
+ (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010011))
+ mvsreg-printer)
+ (:dependencies (reads reg) (writes :low-reg))
+ (:delay 0)
+ (:emitter
+ (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
+ #b010011)))
+
+(define-instruction move (segment dst src)
+ (:declare (type tn dst src))
+ (:printer register ((op special-op) (rt 0) (funct #b100001))
+ '(:name :tab rd ", " rs))
+ (:attributes flushable)
+ (:dependencies (reads src) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-register-inst segment special-op (reg-tn-encoding src) 0
+ (reg-tn-encoding dst) 0 #b100001)))
+
+(define-instruction fmove (segment format dst src)
+ (:declare (type float-format format) (type tn dst src))
+ (:printer float ((funct #b000110)) '(:name "." format :tab fd ", " fs))
+ (:attributes flushable)
+ (:dependencies (reads src) (writes dst))
+ (:delay 0)
+ (:emitter
+ (emit-float-inst segment cop1-op 1 (float-format-value format) 0
+ (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
+ #b000110)))
+
+(defun %li (reg value)
+ (etypecase value
+ ((unsigned-byte 16)
+ (inst or reg zero-tn value))
+ ((signed-byte 16)
+ (inst addu reg zero-tn value))
+ ((or (signed-byte 32) (unsigned-byte 32))
+ (inst lui reg (ldb (byte 16 16) value))
+ (inst or reg (ldb (byte 16 0) value)))
+ (fixup
+ (inst lui reg value)
+ (inst addu reg value))))
+
+(define-instruction-macro li (reg value)
+ `(%li ,reg ,value))
+
+(defconstant-eqx sub-op-printer '(:name :tab rd ", " rt) #'equalp)
+
+(define-instruction mtc1 (segment to from)
+ (:declare (type tn to from))
+ (:printer register ((op cop1-op) (rs #b00100) (funct 0)) sub-op-printer)
+ (:dependencies (reads from) (writes to))
+ (:delay 1)
+ (:emitter
+ (emit-register-inst segment cop1-op #b00100 (reg-tn-encoding from)
+ (fp-reg-tn-encoding to) 0 0)))
+
+(define-instruction mtc1-odd (segment to from)
+ (:declare (type tn to from))
+ (:dependencies (reads from) (writes to))
+ (:delay 1)
+ (:emitter
+ (emit-register-inst segment cop1-op #b00100 (reg-tn-encoding from)
+ (1+ (fp-reg-tn-encoding to)) 0 0)))
+
+(define-instruction mfc1 (segment to from)
+ (:declare (type tn to from))
+ (:printer register ((op cop1-op) (rs 0) (rd nil :type 'fp-reg) (funct 0))
+ sub-op-printer)
+ (:dependencies (reads from) (writes to))
+ (:delay 1)
+ (:emitter
+ (emit-register-inst segment cop1-op #b00000 (reg-tn-encoding to)
+ (fp-reg-tn-encoding from) 0 0)))
+
+(define-instruction mfc1-odd (segment to from)
+ (:declare (type tn to from))
+ (:dependencies (reads from) (writes to))
+ (:delay 1)
+ (:emitter
+ (emit-register-inst segment cop1-op #b00000 (reg-tn-encoding to)
+ (1+ (fp-reg-tn-encoding from)) 0 0)))
+
+(define-instruction mfc1-odd2 (segment to from)
+ (:declare (type tn to from))
+ (:dependencies (reads from) (writes to))
+ (:delay 1)
+ (:emitter
+ (emit-register-inst segment cop1-op #b00000 (1+ (reg-tn-encoding to))
+ (fp-reg-tn-encoding from) 0 0)))
+
+(define-instruction mfc1-odd3 (segment to from)
+ (:declare (type tn to from))
+ (:dependencies (reads from) (writes to))
+ (:delay 1)
+ (:emitter
+ (emit-register-inst segment cop1-op #b00000 (1+ (reg-tn-encoding to))
+ (1+ (fp-reg-tn-encoding from)) 0 0)))
+
+(define-instruction cfc1 (segment reg cr)
+ (:declare (type tn reg) (type (unsigned-byte 5) cr))
+ (:printer register ((op cop1-op) (rs #b00010) (rd nil :type 'control-reg)
+ (funct 0)) sub-op-printer)
+ (:dependencies (reads :ctrl-stat-reg) (writes reg))
+ (:delay 1)
+ (:emitter
+ (emit-register-inst segment cop1-op #b00010 (reg-tn-encoding reg)
+ cr 0 0)))
+
+(define-instruction ctc1 (segment reg cr)
+ (:declare (type tn reg) (type (unsigned-byte 5) cr))
+ (:printer register ((op cop1-op) (rs #b00110) (rd nil :type 'control-reg)
+ (funct 0)) sub-op-printer)
+ (:dependencies (reads reg) (writes :ctrl-stat-reg))
+ (:delay 1)
+ (:emitter
+ (emit-register-inst segment cop1-op #b00110 (reg-tn-encoding reg)
+ cr 0 0)))
+
+
+\f
+;;;; Random system hackery and other noise
+
+(define-instruction-macro entry-point ()
+ nil)
+
+#+nil
+(define-bitfield-emitter emit-break-inst 32
+ (byte 6 26) (byte 10 16) (byte 10 6) (byte 6 0))
+
+(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))))))))
+
+(defmacro break-cases (breaknum &body cases)
+ (let ((bn-temp (gensym)))
+ (collect ((clauses))
+ (dolist (case cases)
+ (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
+ `(let ((,bn-temp ,breaknum))
+ (cond ,@(clauses))))))
+
+(defun break-control (chunk inst stream dstate)
+ (declare (ignore inst))
+ (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
+ (case (break-code 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))
+ (#.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"))
+ )))
+
+(define-instruction break (segment code &optional (subcode 0))
+ (:declare (type (unsigned-byte 10) code subcode))
+ (:printer break ((op special-op) (funct #b001101))
+ '(:name :tab code (:unless (:constant 0) subcode))
+ :control #'break-control )
+ :pinned
+ (:cost 0)
+ (:delay 0)
+ (:emitter
+ (emit-break-inst segment special-op code subcode #b001101)))
+
+(define-instruction syscall (segment)
+ (:printer register ((op special-op) (rd 0) (rt 0) (rs 0) (funct #b001100))
+ '(:name))
+ :pinned
+ (:delay 0)
+ (:emitter
+ (emit-register-inst segment special-op 0 0 0 0 #b001100)))
+
+(define-instruction nop (segment)
+ (:printer register ((op 0) (rd 0) (rd 0) (rs 0) (funct 0)) '(:name))
+ (:attributes flushable)
+ (:delay 0)
+ (:emitter
+ (emit-word segment 0)))
+
+(!def-vm-support-routine emit-nop (segment)
+ (emit-word segment 0))
+
+(define-instruction word (segment word)
+ (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word))
+ :pinned
+ (:cost 0)
+ (:delay 0)
+ (:emitter
+ (emit-word segment word)))
+
+(define-instruction short (segment short)
+ (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short))
+ :pinned
+ (:cost 0)
+ (:delay 0)
+ (:emitter
+ (emit-short segment short)))
+
+(define-instruction byte (segment byte)
+ (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
+ :pinned
+ (:cost 0)
+ (:delay 0)
+ (:emitter
+ (emit-byte segment byte)))
+
+
+(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 fun-header-word (segment)
+ :pinned
+ (:cost 0)
+ (:delay 0)
+ (:emitter
+ (emit-header-data segment simple-fun-header-widetag)))
+
+(define-instruction lra-header-word (segment)
+ :pinned
+ (:cost 0)
+ (:delay 0)
+ (:emitter
+ (emit-header-data segment return-pc-header-widetag)))
+
+
+(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 15)) delta (1- (ash 1 15)))
+ (emit-back-patch segment 4
+ #'(lambda (segment posn)
+ (assemble (segment vop)
+ (inst addu dst src
+ (funcall calc label posn 0)))))
+ t)))
+ #'(lambda (segment posn)
+ (let ((delta (funcall calc label posn 0)))
+ (assemble (segment vop)
+ (inst lui temp (ldb (byte 16 16) delta))
+ (inst or temp (ldb (byte 16 0) delta))
+ (inst addu dst src temp))))))
+
+;; code = fn - 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
+ (label-position label posn delta-if-after)
+ (component-header-length))))))
+
+;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
+;; = lra - (header + label-offset)
+(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
+;;;; Loads and Stores
+
+(defun emit-load/store-inst (segment opcode reg base index
+ &optional (oddhack 0))
+ (when (fixup-p index)
+ (note-fixup segment :addi index)
+ (setf index 0))
+ (emit-immediate-inst segment opcode (reg-tn-encoding reg)
+ (+ (reg-tn-encoding base) oddhack) index))
+
+(defconstant-eqx load-store-printer
+ '(:name :tab
+ rt ", "
+ rs
+ (:unless (:constant 0) "[" immediate "]"))
+ #'equalp)
+
+(define-instruction lb (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:printer immediate ((op #b100000)) load-store-printer)
+ (:dependencies (reads base) (reads :memory) (writes reg))
+ (:delay 1)
+ (:emitter
+ (emit-load/store-inst segment #b100000 base reg index)))
+
+(define-instruction lh (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:printer immediate ((op #b100001)) load-store-printer)
+ (:dependencies (reads base) (reads :memory) (writes reg))
+ (:delay 1)
+ (:emitter
+ (emit-load/store-inst segment #b100001 base reg index)))
+
+(define-instruction lwl (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:printer immediate ((op #b100010)) load-store-printer)
+ (:dependencies (reads base) (reads :memory) (writes reg))
+ (:delay 1)
+ (:emitter
+ (emit-load/store-inst segment #b100010 base reg index)))
+
+(define-instruction lw (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:printer immediate ((op #b100011)) load-store-printer)
+ (:dependencies (reads base) (reads :memory) (writes reg))
+ (:delay 1)
+ (:emitter
+ (emit-load/store-inst segment #b100011 base reg index)))
+
+;; next is just for ease of coding double-in-int c-call convention
+(define-instruction lw-odd (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:dependencies (reads base) (reads :memory) (writes reg))
+ (:delay 1)
+ (:emitter
+ (emit-load/store-inst segment #b100011 base reg index 1)))
+
+(define-instruction lbu (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:printer immediate ((op #b100100)) load-store-printer)
+ (:dependencies (reads base) (reads :memory) (writes reg))
+ (:delay 1)
+ (:emitter
+ (emit-load/store-inst segment #b100100 base reg index)))
+
+(define-instruction lhu (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:printer immediate ((op #b100101)) load-store-printer)
+ (:dependencies (reads base) (reads :memory) (writes reg))
+ (:delay 1)
+ (:emitter
+ (emit-load/store-inst segment #b100101 base reg index)))
+
+(define-instruction lwr (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:printer immediate ((op #b100110)) load-store-printer)
+ (:dependencies (reads base) (reads :memory) (writes reg))
+ (:delay 1)
+ (:emitter
+ (emit-load/store-inst segment #b100110 base reg index)))
+
+(define-instruction sb (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:printer immediate ((op #b101000)) load-store-printer)
+ (:dependencies (reads base) (reads reg) (writes :memory))
+ (:delay 0)
+ (:emitter
+ (emit-load/store-inst segment #b101000 base reg index)))
+
+(define-instruction sh (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:printer immediate ((op #b101001)) load-store-printer)
+ (:dependencies (reads base) (reads reg) (writes :memory))
+ (:delay 0)
+ (:emitter
+ (emit-load/store-inst segment #b101001 base reg index)))
+
+(define-instruction swl (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:printer immediate ((op #b101010)) load-store-printer)
+ (:dependencies (reads base) (reads reg) (writes :memory))
+ (:delay 0)
+ (:emitter
+ (emit-load/store-inst segment #b101010 base reg index)))
+
+(define-instruction sw (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:printer immediate ((op #b101011)) load-store-printer)
+ (:dependencies (reads base) (reads reg) (writes :memory))
+ (:delay 0)
+ (:emitter
+ (emit-load/store-inst segment #b101011 base reg index)))
+
+(define-instruction swr (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:printer immediate ((op #b101110)) load-store-printer)
+ (:dependencies (reads base) (reads reg) (writes :memory))
+ (:delay 0)
+ (:emitter
+ (emit-load/store-inst segment #b101110 base reg index)))
+
+
+(defun emit-fp-load/store-inst (segment opcode reg odd base index)
+ (when (fixup-p index)
+ (note-fixup segment :addi index)
+ (setf index 0))
+ (emit-immediate-inst segment opcode (reg-tn-encoding base)
+ (+ (fp-reg-tn-encoding reg) odd) index))
+
+(define-instruction lwc1 (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:printer immediate ((op #b110001) (rt nil :type 'fp-reg)) load-store-printer)
+ (:dependencies (reads base) (reads :memory) (writes reg))
+ (:delay 1)
+ (:emitter
+ (emit-fp-load/store-inst segment #b110001 reg 0 base index)))
+
+(define-instruction lwc1-odd (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:dependencies (reads base) (reads :memory) (writes reg))
+ (:delay 1)
+ (:emitter
+ (emit-fp-load/store-inst segment #b110001 reg 1 base index)))
+
+(define-instruction swc1 (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:printer immediate ((op #b111001) (rt nil :type 'fp-reg)) load-store-printer)
+ (:dependencies (reads base) (reads reg) (writes :memory))
+ (:delay 0)
+ (:emitter
+ (emit-fp-load/store-inst segment #b111001 reg 0 base index)))
+
+(define-instruction swc1-odd (segment reg base &optional (index 0))
+ (:declare (type tn reg base)
+ (type (or (signed-byte 16) fixup) index))
+ (:dependencies (reads base) (reads reg) (writes :memory))
+ (:delay 0)
+ (:emitter
+ (emit-fp-load/store-inst segment #b111001 reg 1 base index)))
+
--- /dev/null
+(in-package "SB!VM")
+
+;;; Handy macro for defining top-level forms that depend on the compile
+;;; environment.
+
+(defmacro expand (expr)
+ (let ((gensym (gensym)))
+ `(macrolet
+ ((,gensym ()
+ ,expr))
+ (,gensym))))
+
+\f
+;;; Instruction-like macros.
+
+(defmacro move (dst src &optional (always-emit-code-p nil))
+ "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P
+ is nil)."
+ (once-only ((n-dst dst)
+ (n-src src))
+ (if always-emit-code-p
+ `(inst move ,n-dst ,n-src)
+ `(unless (location= ,n-dst ,n-src)
+ (inst move ,n-dst ,n-src)))))
+
+(defmacro def-mem-op (op inst shift load)
+ `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
+ `(progn
+ (inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))
+ ,,@(when load '('(inst nop))))))
+;;;
+(def-mem-op loadw lw word-shift t)
+(def-mem-op storew sw word-shift nil)
+
+(defmacro load-symbol (reg symbol)
+ `(inst addu ,reg null-tn (static-symbol-offset ,symbol)))
+
+(defmacro load-symbol-value (reg symbol)
+ `(progn
+ (inst lw ,reg null-tn
+ (+ (static-symbol-offset ',symbol)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag)))
+ (inst nop)))
+
+(defmacro store-symbol-value (reg symbol)
+ `(inst sw ,reg null-tn
+ (+ (static-symbol-offset ',symbol)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag))))
+
+(defmacro load-type (target source &optional (offset 0))
+ "Loads the type bits of a pointer into target independent of
+ byte-ordering issues."
+ (once-only ((n-target target)
+ (n-source source)
+ (n-offset offset))
+ (ecase *backend-byte-order*
+ (:little-endian
+ `(inst lbu ,n-target ,n-source ,n-offset ))
+ (:big-endian
+ `(inst lbu ,n-target ,n-source (+ ,n-offset 3))))))
+
+
+;;; Macros to handle the fact that we cannot use the machine native call and
+;;; return instructions.
+
+(defmacro lisp-jump (function lip)
+ "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
+ `(progn
+ (inst addu ,lip ,function (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-lowtag))
+ (inst j ,lip)
+ (move code-tn ,function)))
+
+(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
+ "Return to RETURN-PC. LIP is an interior-reg temporary."
+ `(progn
+ (inst addu ,lip ,return-pc
+ (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
+ (inst j ,lip)
+ ,(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 flag-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, Flag-Tn must be wired to NL3-OFFSET, 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."
+ `(pseudo-atomic (,flag-tn :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
+;;;; Three Way Comparison
+
+(defun three-way-comparison (x y condition flavor not-p target temp)
+ (ecase condition
+ (:eq
+ (if not-p
+ (inst bne x y target)
+ (inst beq x y target)))
+ (:lt
+ (ecase flavor
+ (:unsigned
+ (inst sltu temp x y))
+ (:signed
+ (inst slt temp x y)))
+ (if not-p
+ (inst beq temp zero-tn target)
+ (inst bne temp zero-tn target)))
+ (:gt
+ (ecase flavor
+ (:unsigned
+ (inst sltu temp y x))
+ (:signed
+ (inst slt temp y x)))
+ (if not-p
+ (inst beq temp zero-tn target)
+ (inst bne temp zero-tn target))))
+ (inst nop))
+
+
+\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 load eval)
+ (defun emit-error-break (vop kind code values)
+ (let ((vector (gensym)))
+ `((let ((vop ,vop))
+ (when vop
+ (note-this-location vop :internal-error)))
+ (inst break ,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 ((flag-tn &key (extra 0)) &rest forms)
+ `(progn
+ (aver (= (tn-offset ,flag-tn) nl4-offset))
+ (aver (not (minusp ,extra)))
+ (without-scheduling ()
+ (inst li ,flag-tn ,extra)
+ (inst addu alloc-tn 1))
+ ,@forms
+ (without-scheduling ()
+ (let ((label (gen-label)))
+ (inst nop)
+ (inst nop)
+ (inst nop)
+ (inst bgez ,flag-tn label)
+ (inst addu alloc-tn (1- ,extra))
+ (inst break 16)
+ (emit-label label)))))
+
+
+\f
+;;;; Memory accessor vop generators
+
+(deftype load/store-index (scale lowtag min-offset
+ &optional (max-offset min-offset))
+ `(integer ,(- (truncate (+ (ash 1 16)
+ (* min-offset n-word-bytes)
+ (- lowtag))
+ scale))
+ ,(truncate (- (+ (1- (ash 1 16)) lowtag)
+ (* max-offset n-word-bytes))
+ scale)))
+
+(defmacro define-full-reffer (name type offset lowtag scs el-type
+ &optional translate)
+ `(progn
+ (define-vop (,name)
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg)))
+ (:arg-types ,type tagged-num)
+ (:temporary (:scs (interior-reg)) lip)
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (inst add lip object index)
+ (inst lw value lip (- (* ,offset n-word-bytes) ,lowtag))
+ (inst nop)))
+ (define-vop (,(symbolicate name "-C"))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types ,type
+ (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
+ ,(eval offset))))
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 4
+ (inst lw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
+ (inst nop)))))
+
+(defmacro define-full-setter (name type offset lowtag scs el-type
+ &optional translate)
+ `(progn
+ (define-vop (,name)
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg))
+ (value :scs ,scs :target result))
+ (:arg-types ,type tagged-num ,el-type)
+ (:temporary (:scs (interior-reg)) lip)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 2
+ (inst add lip object index)
+ (inst sw value lip (- (* ,offset n-word-bytes) ,lowtag))
+ (move result value)))
+ (define-vop (,(symbolicate name "-C"))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs ,scs))
+ (:info index)
+ (:arg-types ,type
+ (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
+ ,(eval offset)))
+ ,el-type)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 1
+ (inst sw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
+ (move result value)))))
+
+
+(defmacro define-partial-reffer (name type size signed offset lowtag scs
+ el-type &optional translate)
+ (let ((scale (ecase size (:byte 1) (:short 2))))
+ `(progn
+ (define-vop (,name)
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types ,type positive-fixnum)
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 5
+ (inst addu lip object index)
+ ,@(when (eq size :short)
+ '((inst addu lip index)))
+ (inst ,(ecase size
+ (:byte (if signed 'lb 'lbu))
+ (:short (if signed 'lh 'lhu)))
+ value lip (- (* ,offset n-word-bytes) ,lowtag))
+ (inst nop)))
+ (define-vop (,(symbolicate name "-C"))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types ,type
+ (:constant (load/store-index ,scale
+ ,(eval lowtag)
+ ,(eval offset))))
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (inst ,(ecase size
+ (:byte (if signed 'lb 'lbu))
+ (:short (if signed 'lh 'lhu)))
+ value object
+ (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
+ (inst nop))))))
+
+(defmacro define-partial-setter (name type size offset lowtag scs el-type
+ &optional translate)
+ (let ((scale (ecase size (:byte 1) (:short 2))))
+ `(progn
+ (define-vop (,name)
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg))
+ (value :scs ,scs :target result))
+ (:arg-types ,type positive-fixnum ,el-type)
+ (:temporary (:scs (interior-reg)) lip)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (inst addu lip object index)
+ ,@(when (eq size :short)
+ '((inst addu lip index)))
+ (inst ,(ecase size (:byte 'sb) (:short 'sh))
+ value lip (- (* ,offset n-word-bytes) ,lowtag))
+ (move result value)))
+ (define-vop (,(symbolicate name "-C"))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs ,scs :target result))
+ (:info index)
+ (:arg-types ,type
+ (:constant (load/store-index ,scale
+ ,(eval lowtag)
+ ,(eval offset)))
+ ,el-type)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (inst ,(ecase size (:byte 'sb) (:short 'sh))
+ value object
+ (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag))
+ (move result value))))))
+
--- /dev/null
+(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 null zero)))
+ (: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 null zero)))
+ (:variant-vars base lowtag)
+ (:info offset)
+ (:generator 4
+ (storew value object (+ base offset) lowtag)))
--- /dev/null
+(in-package "SB!VM")
+
+
+(define-move-fun (load-immediate 1) (vop x y)
+ ((null zero immediate)
+ (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)
+ ((zero immediate)
+ (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 any-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 null zero) (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 control-stack)
+ :load-if (not (location= x y))))
+ (:effects)
+ (:affected)
+ (:generator 0
+ (unless (location= x y)
+ (sc-case y
+ ((any-reg descriptor-reg)
+ (inst move y x))
+ (control-stack
+ (store-stack-tn y x))))))
+
+(define-move-vop move :move
+ (any-reg descriptor-reg zero null)
+ (any-reg descriptor-reg))
+
+;;; Make Move the check VOP for T so that type check generation doesn't think
+;;; it is a hairy type. This also allows checking of a few of the values in a
+;;; continuation to fall out.
+;;;
+(primitive-type-vop move (:check) t)
+
+;;; The Move-Argument VOP is used for moving descriptor values into another
+;;; frame for argument or known value passing.
+;;;
+(define-vop (move-arg)
+ (:args (x :target y
+ :scs (any-reg descriptor-reg null zero))
+ (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 null zero)
+ (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 2)))
+;;;
+(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 3
+ (let ((done (gen-label)))
+ (inst and temp x 3)
+ (inst beq temp done)
+ (inst sra y x 2)
+
+ (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 2)))
+;;;
+(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)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+ (:note "signed word to integer coercion")
+ (:generator 18
+ (move x arg)
+ (let ((fixnum (gen-label))
+ (done (gen-label)))
+ (inst sra temp x 29)
+ (inst beq temp fixnum)
+ (inst nor temp zero-tn)
+ (inst beq temp done)
+ (inst sll y x 2)
+
+ (with-fixed-allocation
+ (y pa-flag 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 2)
+ (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)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+ (:note "unsigned word to integer coercion")
+ (:generator 20
+ (move x arg)
+ (inst srl temp x 29)
+ (inst beq temp done)
+ (inst sll y x 2)
+
+ (pseudo-atomic
+ (pa-flag :extra (pad-data-block (+ bignum-digits-offset 2)))
+ (inst or y alloc-tn other-pointer-lowtag)
+ (inst slt temp x zero-tn)
+ (inst sll temp n-widetag-bits)
+ (inst addu temp (logior (ash 1 n-widetag-bits) bignum-widetag))
+ (storew temp y 0 other-pointer-lowtag))
+
+ (storew x y bignum-digits-offset other-pointer-lowtag)
+ 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
+(in-package "SB!VM")
+
+;;; MAKE-NLX-SP-TN -- Interface
+;;;
+;;; Make an environment-live stack TN for saving the SP for NLX entry.
+;;;
+(!def-vm-support-routine make-nlx-sp-tn (env)
+ (physenv-live-tn
+ (make-representation-tn *fixnum-primitive-type* immediate-arg-scn)
+ env))
+
+;;; Make-NLX-Entry-Argument-Start-Location -- Interface
+;;;
+;;; Make a TN for the argument count passing location for a
+;;; non-local entry.
+;;;
+(!def-vm-support-routine make-nlx-entry-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.
+
+
+;;; Make-Dynamic-State-TNs -- Interface
+;;;
+;;; Return a list of TNs that can be used to snapshot the dynamic state for
+;;; use with the Save/Restore-Dynamic-Environment VOPs.
+;;;
+(!def-vm-support-routine make-dynamic-state-tns ()
+ (make-n-tns 4 *backend-t-primitive-type*))
+
+(define-vop (save-dynamic-state)
+ (:results (catch :scs (descriptor-reg))
+ (nfp :scs (descriptor-reg))
+ (nsp :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)))
+ (: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 addu 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 (any-reg 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 addu 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 addu 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 beq count zero-tn no-values)
+ (move (tn-ref-tn values) null-tn)
+ (loadw (tn-ref-tn values) start)
+ (emit-label no-values)))
+ (t
+ (collect ((defaults))
+ (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 beq count zero-tn default-lab)
+ (inst addu count 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 dst) (start :target src) (count :target num))
+ ;; Again, no SC restrictions for the args, 'cause the loading would
+ ;; happen before the entry label.
+ (:info label)
+ (:temporary (:scs (any-reg) :from (:argument 0)) dst)
+ (:temporary (:scs (any-reg) :from (:argument 1)) src)
+ (:temporary (:scs (any-reg) :from (:argument 2)) num)
+ (:temporary (:scs (descriptor-reg)) temp)
+ (:results (new-start) (new-count))
+ (: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)))
+
+ ;; Copy args.
+ (load-stack-tn dst top)
+ (move src start)
+ (move num count)
+
+ ;; Establish results.
+ (sc-case new-start
+ (any-reg (move new-start dst))
+ (control-stack (store-stack-tn new-start dst)))
+ (inst beq num zero-tn done)
+ (sc-case new-count
+ (any-reg (inst move new-count num))
+ (control-stack (store-stack-tn new-count num)))
+
+ ;; Copy stuff on stack.
+ (emit-label loop)
+ (loadw temp src)
+ (inst addu src src n-word-bytes)
+ (storew temp dst)
+ (inst addu num num (fixnumize -1))
+ (inst bne num zero-tn loop)
+ (inst addu dst dst n-word-bytes)
+
+ (emit-label done)
+ (inst move csp-tn dst))))
+
+
+;;; 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
+(in-package "SB!VM")
+
+(def!constant n-word-bits 32
+ "Number of bits per word where a word holds one lisp descriptor.")
+
+(def!constant n-byte-bits 8
+ "Number of bits per byte where a byte is the smallest addressable object.")
+
+(def!constant word-shift (1- (integer-length (/ n-word-bits n-byte-bits)))
+ "Number of bits to shift between word addresses and byte addresses.")
+
+(def!constant n-word-bytes (/ n-word-bits n-byte-bits)
+ "Number of bytes in a word.")
+
+
+(def!constant float-sign-shift 31)
+
+(def!constant single-float-bias 126)
+(defconstant-eqx single-float-exponent-byte (byte 8 23) #'equalp)
+(defconstant-eqx single-float-significand-byte (byte 23 0) #'equalp)
+(def!constant single-float-normal-exponent-min 1)
+(def!constant single-float-normal-exponent-max 254)
+(def!constant single-float-hidden-bit (ash 1 23))
+(def!constant single-float-trapping-nan-bit (ash 1 22))
+
+(def!constant double-float-bias 1022)
+(defconstant-eqx double-float-exponent-byte (byte 11 20) #'equalp)
+(defconstant-eqx double-float-significand-byte (byte 20 0) #'equalp)
+(def!constant double-float-normal-exponent-min 1)
+(def!constant double-float-normal-exponent-max #x7FE)
+(def!constant double-float-hidden-bit (ash 1 20))
+(def!constant double-float-trapping-nan-bit (ash 1 19))
+
+(def!constant single-float-digits
+ (+ (byte-size single-float-significand-byte) 1))
+
+(def!constant double-float-digits
+ (+ (byte-size double-float-significand-byte) n-word-bits 1))
+
+(def!constant float-inexact-trap-bit (ash 1 0))
+(def!constant float-underflow-trap-bit (ash 1 1))
+(def!constant float-overflow-trap-bit (ash 1 2))
+(def!constant float-divide-by-zero-trap-bit (ash 1 3))
+(def!constant float-invalid-trap-bit (ash 1 4))
+
+(def!constant float-round-to-nearest 0)
+(def!constant float-round-to-zero 1)
+(def!constant float-round-to-positive 2)
+(def!constant float-round-to-negative 3)
+
+(defconstant-eqx float-rounding-mode (byte 2 0) #'equalp)
+(defconstant-eqx float-sticky-bits (byte 5 2) #'equalp)
+(defconstant-eqx float-traps-byte (byte 5 7) #'equalp)
+(defconstant-eqx float-exceptions-byte (byte 5 12) #'equalp)
+(defconstant-eqx float-condition-bit (ash 1 23) #'equalp)
+(def!constant float-fast-bit 0) ; No fast mode on PMAX.
+
+\f
+;;;; Description of the target address space.
+
+;;; Where to put the different spaces.
+;;;
+(def!constant read-only-space-start #x01000000)
+(def!constant read-only-space-end #x05000000)
+
+(def!constant binding-stack-start #x05000000)
+(def!constant binding-stack-end #x05800000)
+
+(def!constant control-stack-start #x05800000)
+(def!constant control-stack-end #x06000000)
+
+(def!constant static-space-start #x06000000)
+(def!constant static-space-end #x08000000)
+
+(def!constant dynamic-space-start #x08000000)
+(def!constant dynamic-space-end #x0c000000)
+
+(def!constant dynamic-0-space-start #x08000000)
+(def!constant dynamic-0-space-end #x0c000000)
+(def!constant dynamic-1-space-start #x0c000000)
+(def!constant dynamic-1-space-end #x10000000)
+
+\f
+;;;; Other non-type constants.
+
+(defenum (:suffix -flag)
+ atomic
+ interrupted)
+
+(defenum (:suffix -trap :start 8)
+ halt
+ pending-interrupt
+ error
+ cerror
+ breakpoint
+ fun-end-breakpoint
+ after-breakpoint)
+
+(defenum (:prefix trace-table-)
+ normal
+ call-site
+ fun-prologue
+ fun-epilogue)
+\f
+;;;; Static symbols.
+
+;;; Static 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
+
+ *posix-argv*
+
+ sb!impl::maybe-gc
+ sb!kernel::internal-error
+ sb!kernel::control-stack-exhausted-error
+ sb!di::handle-breakpoint
+ sb!impl::fdefinition-object
+
+ ;; 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*
+ '(sb!kernel:two-arg-+
+ sb!kernel:two-arg--
+ sb!kernel:two-arg-*
+ sb!kernel:two-arg-/
+ sb!kernel:two-arg-<
+ sb!kernel:two-arg->
+ sb!kernel:two-arg-=
+ sb!kernel:two-arg-<=
+ sb!kernel:two-arg->=
+ sb!kernel:two-arg-/=
+ eql
+ sb!kernel:%negate
+ sb!kernel:two-arg-and
+ sb!kernel:two-arg-ior
+ sb!kernel:two-arg-xor
+ length
+ sb!kernel:two-arg-gcd
+ sb!kernel:two-arg-lcm))
--- /dev/null
+(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
+ (if not-p
+ (inst bne x y target)
+ (inst beq x y target))
+ (inst nop)))
+
+
--- /dev/null
+;;;; Do whatever is necessary to make the given code component
+;;;; executable.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This 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: Is this right?
+(defun sanctify-for-execution (component)
+ (without-gcing
+ (alien-funcall (extern-alien "os_flush_icache"
+ (function void
+ system-area-pointer
+ unsigned-long))
+ (code-instructions component)
+ (* (code-header-ref component code-code-size-slot)
+ n-word-bytes)))
+ nil)
--- /dev/null
+(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 "system area pointer indirection")
+ (: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 (x :scs (sap-reg) :target sap))
+ (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+ (:results (y :scs (descriptor-reg)))
+ (:note "system area pointer allocation")
+ (:generator 20
+ (move sap x)
+ (with-fixed-allocation (y pa-flag ndescr sap-widetag sap-size)
+ (storew sap y 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))))
+ (: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))
+ (: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-ARGUMENT + 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 immediate)))
+ (:arg-types system-area-pointer signed-num)
+ (:results (res :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:policy :fast-safe)
+ (:generator 1
+ (sc-case offset
+ (signed-reg
+ (inst addu res ptr offset))
+ (immediate
+ (inst addu res ptr (tn-value 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 subu 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 (object :scs (sap-reg) :target sap)
+ (offset :scs (signed-reg)))
+ (:arg-types system-area-pointer signed-num)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
+ (:generator 5
+ (inst addu sap object offset)
+ ,@(ecase size
+ (:byte
+ (if signed
+ '((inst lb result sap 0))
+ '((inst lbu result sap 0))))
+ (:short
+ (if signed
+ '((inst lh result sap 0))
+ '((inst lhu result sap 0))))
+ (:long
+ '((inst lw result sap 0)))
+ (:single
+ '((inst lwc1 result sap 0)))
+ (:double
+ (ecase *backend-byte-order*
+ (:big-endian
+ '((inst lwc1 result sap n-word-bytes)
+ (inst lwc1-odd result sap 0)))
+ (:little-endian
+ '((inst lwc1 result sap 0)
+ (inst lwc1-odd result sap n-word-bytes))))))
+ (inst nop)))
+ (define-vop (,ref-name-c)
+ (:translate ,ref-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg)))
+ (:arg-types system-area-pointer
+ (:constant ,(if (eq size :double)
+ ;; We need to be able to add 4.
+ `(integer ,(- (ash 1 16))
+ ,(- (ash 1 16) 5))
+ '(signed-byte 16))))
+ (:info offset)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 4
+ ,@(ecase size
+ (:byte
+ (if signed
+ '((inst lb result object offset))
+ '((inst lbu result object offset))))
+ (:short
+ (if signed
+ '((inst lh result object offset))
+ '((inst lhu result object offset))))
+ (:long
+ '((inst lw result object offset)))
+ (:single
+ '((inst lwc1 result object offset)))
+ (:double
+ (ecase *backend-byte-order*
+ (:big-endian
+ '((inst lwc1 result object (+ offset n-word-bytes))
+ (inst lwc1-odd result object offset)))
+ (:little-endian
+ '((inst lwc1 result object offset)
+ (inst lwc1-odd result object (+ offset n-word-bytes)))))))
+ (inst nop)))
+ (define-vop (,set-name)
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg) :target sap)
+ (offset :scs (signed-reg))
+ (value :scs (,sc) :target result))
+ (:arg-types system-area-pointer signed-num ,type)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
+ (:generator 5
+ (inst addu sap object offset)
+ ,@(ecase size
+ (:byte
+ '((inst sb value sap 0)
+ (move result value)))
+ (:short
+ '((inst sh value sap 0)
+ (move result value)))
+ (:long
+ '((inst sw value sap 0)
+ (move result value)))
+ (:single
+ '((inst swc1 value sap 0)
+ (unless (location= result value)
+ (inst fmove :single result value))))
+ (:double
+ (ecase *backend-byte-order*
+ (:big-endian
+ '((inst swc1 value sap n-word-bytes)
+ (inst swc1-odd value sap 0)
+ (unless (location= result value)
+ (inst fmove :double result value))))
+ (:little-endian
+ '((inst swc1 value sap 0)
+ (inst swc1-odd value sap n-word-bytes)
+ (unless (location= result value)
+ (inst fmove :double result value)))))))))
+ (define-vop (,set-name-c)
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg))
+ (value :scs (,sc) :target result))
+ (:arg-types system-area-pointer
+ (:constant ,(if (eq size :double)
+ ;; We need to be able to add 4.
+ `(integer ,(- (ash 1 16))
+ ,(- (ash 1 16) 5))
+ '(signed-byte 16)))
+ ,type)
+ (:info offset)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 5
+ ,@(ecase size
+ (:byte
+ '((inst sb value object offset)
+ (move result value)))
+ (:short
+ '((inst sh value object offset)
+ (move result value)))
+ (:long
+ '((inst sw value object offset)
+ (move result value)))
+ (:single
+ '((inst swc1 value object offset)
+ (unless (location= result value)
+ (inst fmove :single result value))))
+ (:double
+ (ecase *backend-byte-order*
+ (:big-endian
+ '((inst swc1 value object (+ offset n-word-bytes))
+ (inst swc1-odd value object (+ offset n-word-bytes))
+ (unless (location= result value)
+ (inst fmove :double result value))))
+ (:little-endian
+ '((inst swc1 value object offset)
+ (inst swc1-odd value object (+ offset n-word-bytes))
+ (unless (location= result value)
+ (inst fmove :double 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)
+ (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))
+
+\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 addu sap vector
+ (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))
+
--- /dev/null
+(in-package "SB!VM")
+
+
+(define-vop (print)
+ (:args (object :scs (descriptor-reg) :target a0))
+ (:results (result :scs (descriptor-reg)))
+ (:save-p t)
+ (:temporary (:sc any-reg :offset cfunc-offset :target result :to (:result 0))
+ cfunc)
+ (:temporary (:sc descriptor-reg :offset 4 :from (:argument 0)) a0)
+ (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+ (:vop-var vop)
+ (:generator 0
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (move a0 object)
+ (when cur-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (inst li cfunc (make-fixup "debug_print" :foreign))
+ (inst jal (make-fixup "call_into_c" :foreign))
+ (inst addu nsp-tn nsp-tn -16)
+ (inst addu nsp-tn nsp-tn 16)
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))
+ (move result cfunc))))
--- /dev/null
+(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 (:sc interior-reg :offset lip-offset) entry-point)
+ (:temporary (:sc any-reg :offset nargs-offset) nargs)
+ (:temporary (:sc any-reg :offset ocfp-offset) ocfp)
+ (: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 (~D) or too many results (~D). Max = ~D"
+ num-args num-results register-arg-count)
+ (let ((num-temps (max num-args num-results)))
+ (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
+ (dotimes (i num-results)
+ (let ((result-name (intern (format nil "RESULT-~D" i))))
+ (result-names result-name)
+ (results `(,result-name :scs (any-reg descriptor-reg)))))
+ (dotimes (i num-temps)
+ (let ((temp-name (intern (format nil "TEMP-~D" i))))
+ (temp-names temp-name)
+ (temps `(:temporary (:sc descriptor-reg
+ :offset ,(nth i *register-arg-offsets*)
+ ,@(when (< i num-args)
+ `(:from (:argument ,i)))
+ ,@(when (< i num-results)
+ `(:to (:result ,i)
+ :target ,(nth i (result-names)))))
+ ,temp-name))))
+ (dotimes (i num-args)
+ (let ((arg-name (intern (format nil "ARG-~D" i))))
+ (arg-names arg-name)
+ (args `(,arg-name
+ :scs (any-reg descriptor-reg null zero)
+ :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 li nargs (fixnumize ,num-args))
+ (inst lw entry-point null-tn (static-fun-offset symbol))
+ (when cur-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (inst move ocfp cfp-tn)
+ (inst compute-lra-from-code lra code-tn lra-label temp)
+ (note-this-location vop :call-site)
+ (inst j entry-point)
+ (inst move cfp-tn csp-tn)
+ (emit-return-pc lra-label)
+ ,(collect ((bindings) (links))
+ (do ((temp (temp-names) (cdr temp))
+ (name 'values (gensym))
+ (prev nil name)
+ (i 0 (1+ i)))
+ ((= i num-results))
+ (bindings `(,name
+ (make-tn-ref ,(car temp) nil)))
+ (when prev
+ (links `(setf (tn-ref-across ,prev) ,name))))
+ `(let ,(bindings)
+ ,@(links)
+ (default-unknown-values vop
+ ,(if (zerop num-results) nil 'values)
+ ,num-results move-temp temp lra-label)))
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))
+ ,@(moves (result-names) (temp-names))))))))
+
+
+) ; eval-when (compile load eval)
+
+
+(expand
+ (collect ((templates (list 'progn)))
+ (dotimes (i register-arg-count)
+ (templates (static-fun-template-vop i 1)))
+ (templates)))
+
+
+(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
+(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
+ (move ptr object)
+ (move count zero-tn)
+
+ LOOP
+
+ (inst beq ptr null-tn done)
+ (inst nop)
+
+ (inst and temp ptr lowtag-mask)
+ (inst xor temp list-pointer-lowtag)
+ (inst bne temp zero-tn not-list)
+ (inst nop)
+
+ (loadw ptr ptr cons-cdr-slot list-pointer-lowtag)
+ (inst b loop)
+ (inst addu count count (fixnumize 1))
+
+ NOT-LIST
+ (cerror-call vop done object-not-list-error ptr)
+
+ DONE
+ (move result count)))
+
+
+(define-static-fun length (object) :translate length)
+
+
+
--- /dev/null
+(in-package "SB!VM")
+
+\f
+;;;; Random pointer comparison VOPs
+
+(define-vop (pointer-compare)
+ (:args (x :scs (sap-reg))
+ (y :scs (sap-reg)))
+ (:arg-types system-area-pointer system-area-pointer)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline comparison")
+ (:variant-vars condition)
+ (:generator 3
+ (three-way-comparison x y condition :unsigned not-p target temp)))
+
+#+nil
+(macrolet ((frob (name cond)
+ `(progn
+ (def-primitive-translator ,name (x y) `(,',name ,x ,y))
+ (defknown ,name (t t) boolean (movable foldable flushable))
+ (define-vop (,name pointer-compare)
+ (:translate ,name)
+ (:variant ,cond)))))
+ (frob pointer< :lt)
+ (frob pointer> :gt))
+
+
+\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)))
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 6
+ ;; Pick off objects with headers.
+ (inst and ndescr object lowtag-mask)
+ (inst xor ndescr other-pointer-lowtag)
+ (inst beq ndescr other-ptr)
+ (inst xor ndescr (logxor other-pointer-lowtag fun-pointer-lowtag))
+ (inst beq ndescr function-ptr)
+
+ ;; Pick off fixnums.
+ (inst and result object 3)
+ (inst beq result done)
+
+ ;; Pick off structure and list pointers.
+ (inst and result object 1)
+ (inst bne result lowtag-only)
+ (inst nop)
+
+ ;; Must be an other immediate.
+ (inst b done)
+ (inst and result object widetag-mask)
+
+ FUNCTION-PTR
+ (load-type result object (- fun-pointer-lowtag))
+ (inst b done)
+ (inst nop)
+
+ LOWTAG-ONLY
+ (inst b done)
+ (inst and result object lowtag-mask)
+
+ OTHER-PTR
+ (load-type result object (- other-pointer-lowtag))
+ (inst nop)
+
+ 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))
+ (inst nop)))
+
+(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
+ (inst sb type function (- 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
+ ;;
+ ;; 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 subu ndescr other-pointer-lowtag)
+ (inst addu 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 addu ndescr offset)
+ (inst addu ndescr (- fun-pointer-lowtag other-pointer-lowtag))
+ (inst addu func code ndescr)))
+
+\f
+;;;; Other random VOPs.
+
+
+(defknown sb!unix::do-pending-interrupt () (values))
+(define-vop (sb!unix::do-pending-interrupt)
+ (:policy :fast-safe)
+ (:translate sb!unix::do-pending-interrupt)
+ (:generator 1
+ (inst break pending-interrupt-trap)))
+
+
+(define-vop (halt)
+ (:generator 1
+ (inst break 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)))
+ (inst lw count count-vector offset)
+ (inst nop)
+ (inst addu count 1)
+ (inst sw 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
+(in-package "SB!VM")
+
+
+\f
+;;;; Test generation utilities.
+
+(eval-when (:compile-toplevel :execute)
+ (defparameter *immediate-types*
+ (list unbound-marker-widetag base-char-widetag))
+
+ (defparameter *fun-header-widetags*
+ (list funcallable-instance-header-widetag
+ simple-fun-header-widetag
+ closure-fun-header-widetag
+ closure-header-widetag))
+
+ (defun canonicalize-headers (headers)
+ (collect ((results))
+ (let ((start nil)
+ (prev nil)
+ (delta (- other-immediate-1-lowtag other-immediate-0-lowtag)))
+ (flet ((emit-test ()
+ (results (if (= start prev)
+ start
+ (cons start prev)))))
+ (dolist (header (sort headers #'<))
+ (cond ((null start)
+ (setf start header)
+ (setf prev header))
+ ((= header (+ prev delta))
+ (setf prev header))
+ (t
+ (emit-test)
+ (setf start header)
+ (setf prev header))))
+ (emit-test)))
+ (results))))
+
+
+(macrolet ((test-type (value temp target not-p &rest type-codes)
+ ;; Determine what interesting combinations we need to test for.
+ (let* ((type-codes (mapcar #'eval type-codes))
+ (fixnump (and (member even-fixnum-lowtag type-codes)
+ (member odd-fixnum-lowtag type-codes)
+ t))
+ (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 (if (intersection headers *fun-header-widetags*)
+ (if (subsetp headers *fun-header-widetags*)
+ t
+ (error "Can't test for mix of function subtypes ~
+ and normal header types."))
+ nil)))
+ (unless type-codes
+ (error "Must supply at least on type for test-type."))
+ (cond
+ (fixnump
+ (when (remove-if #'(lambda (x)
+ (or (= x even-fixnum-lowtag)
+ (= x odd-fixnum-lowtag)))
+ lowtags)
+ (error "Can't mix fixnum testing with other lowtags."))
+ (when function-p
+ (error "Can't mix fixnum testing with function subtype testing."))
+ (when immediates
+ (error "Can't mix fixnum testing with other immediates."))
+ (if headers
+ `(%test-fixnum-and-headers ,value ,temp ,target ,not-p
+ ',(canonicalize-headers headers))
+ `(%test-fixnum ,value ,temp ,target ,not-p)))
+ (immediates
+ (when headers
+ (error "Can't mix testing of immediates with testing of headers."))
+ (when lowtags
+ (error "Can't mix testing of immediates with testing of lowtags."))
+ (when (cdr immediates)
+ (error "Can't test multiple immediates at the same time."))
+ `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates)))
+ (lowtags
+ (when (cdr lowtags)
+ (error "Can't test multiple lowtags at the same time."))
+ (if headers
+ `(%test-lowtag-and-headers
+ ,value ,temp ,target ,not-p ,(car lowtags)
+ ,function-p ',(canonicalize-headers headers))
+ `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags))))
+ (headers
+ `(%test-headers ,value ,temp ,target ,not-p ,function-p
+ ',(canonicalize-headers headers)))
+ (t
+ (error "Nothing to test?"))))))
+
+(defun %test-fixnum (value temp target not-p)
+ (assemble ()
+ (inst and temp value 3)
+ (if not-p
+ (inst bne temp zero-tn target)
+ (inst beq temp zero-tn target))
+ (inst nop)))
+
+(defun %test-fixnum-and-headers (value temp target not-p headers)
+ (let ((drop-through (gen-label)))
+ (assemble ()
+ (inst and temp value 3)
+ (inst beq temp zero-tn (if not-p drop-through target)))
+ (%test-headers value temp target not-p nil headers drop-through)))
+
+(defun %test-immediate (value temp target not-p immediate)
+ (assemble ()
+ (inst and temp value 255)
+ (inst xor temp immediate)
+ (if not-p
+ (inst bne temp zero-tn target)
+ (inst beq temp zero-tn target))
+ (inst nop)))
+
+(defun %test-lowtag (value temp target not-p lowtag &optional skip-nop)
+ (assemble ()
+ (inst and temp value lowtag-mask)
+ (inst xor temp lowtag)
+ (if not-p
+ (inst bne temp zero-tn target)
+ (inst beq temp zero-tn target))
+ (unless skip-nop
+ (inst nop))))
+
+(defun %test-lowtag-and-headers (value temp target not-p lowtag
+ function-p headers)
+ (let ((drop-through (gen-label)))
+ (%test-lowtag value temp (if not-p drop-through target) nil lowtag t)
+ (%test-headers value temp target not-p function-p headers drop-through)))
+
+(defun %test-headers (value temp target not-p function-p headers
+ &optional (drop-through (gen-label)))
+ (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
+ (multiple-value-bind
+ (when-true when-false)
+ ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when
+ ;; we know it's true and when we know it's false respectively.
+ (if not-p
+ (values drop-through target)
+ (values target drop-through))
+ (assemble ()
+ (%test-lowtag value temp when-false t lowtag)
+ (load-type temp value (- lowtag))
+ (inst nop)
+ (let ((delta 0))
+ (do ((remaining headers (cdr remaining)))
+ ((null remaining))
+ (let ((header (car remaining))
+ (last (null (cdr remaining))))
+ (cond
+ ((atom header)
+ (inst subu temp (- header delta))
+ (setf delta header)
+ (if last
+ (if not-p
+ (inst bne temp zero-tn target)
+ (inst beq temp zero-tn target))
+ (inst beq temp zero-tn when-true)))
+ (t
+ (let ((start (car header))
+ (end (cdr header)))
+ (unless (= start bignum-widetag)
+ (inst subu temp (- start delta))
+ (setf delta start)
+ (inst bltz temp when-false))
+ (inst subu temp (- end delta))
+ (setf delta end)
+ (if last
+ (if not-p
+ (inst bgtz temp target)
+ (inst blez temp target))
+ (inst blez temp when-true))))))))
+ (inst nop)
+ (emit-label drop-through)))))
+
+
+\f
+;;;; Type checking and testing:
+
+(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) :to (:result 0)) temp)
+ (:vop-var vop)
+ (:save-p :compute-only))
+
+(define-vop (type-predicate)
+ (:args (value :scs (any-reg descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe))
+
+(eval-when (:compile-toplevel :execute)
+ (defun cost-to-test-types (type-codes)
+ (+ (* 2 (length type-codes))
+ (if (> (apply #'max type-codes) lowtag-limit) 7 2))))
+
+(defmacro def-type-vops (pred-name check-name ptype error-code
+ &rest type-codes)
+ (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
+ `(progn
+ ,@(when pred-name
+ `((define-vop (,pred-name type-predicate)
+ (:translate ,pred-name)
+ (:generator ,cost
+ (test-type value temp target not-p ,@type-codes)))))
+ ,@(when check-name
+ `((define-vop (,check-name check-type)
+ (:generator ,cost
+ (let ((err-lab
+ (generate-error-code vop ,error-code value)))
+ (test-type value temp err-lab t ,@type-codes)
+ (move result value))))))
+ ,@(when ptype
+ `((primitive-type-vop ,check-name (:check) ,ptype))))))
+
+(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)
+
+(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)
+
+(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)
+
+(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)
+
+(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)
+
+(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)
+
+(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)
+
+(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)
+
+(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)
+
+(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
+ simple-array-complex-single-float-widetag
+ simple-array-complex-double-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
+ simple-array-complex-single-float-widetag
+ simple-array-complex-double-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
+ simple-array-complex-single-float-widetag
+ simple-array-complex-double-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 complex-widetag
+ complex-single-float-widetag complex-double-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)
+
+(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)
+
+\f
+;;;; Other integer ranges.
+
+;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
+;;; exactly one digit.
+
+(defun signed-byte-32-test (value temp not-p target not-target)
+ (multiple-value-bind
+ (yep nope)
+ (if not-p
+ (values not-target target)
+ (values target not-target))
+ (assemble ()
+ (inst and temp value 3)
+ (inst beq temp zero-tn yep)
+ (inst and temp value lowtag-mask)
+ (inst xor temp other-pointer-lowtag)
+ (inst bne temp zero-tn nope)
+ (inst nop)
+ (loadw temp value 0 other-pointer-lowtag)
+ (inst xor temp (+ (ash 1 n-widetag-bits) bignum-widetag))
+ (if not-p
+ (inst bne temp zero-tn target)
+ (inst beq temp zero-tn target))
+ (inst nop)))
+ (values))
+
+(define-vop (signed-byte-32-p type-predicate)
+ (:translate signed-byte-32-p)
+ (:generator 45
+ (signed-byte-32-test value temp not-p target not-target)
+ NOT-TARGET))
+
+(define-vop (check-signed-byte-32 check-type)
+ (:generator 45
+ (let ((loose (generate-error-code vop object-not-signed-byte-32-error
+ value)))
+ (signed-byte-32-test value temp t loose okay))
+ OKAY
+ (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.
+
+(defun unsigned-byte-32-test (value temp not-p target not-target)
+ (multiple-value-bind (yep nope)
+ (if not-p
+ (values not-target target)
+ (values target not-target))
+ (assemble ()
+ ;; Is it a fixnum?
+ (inst and temp value 3)
+ (inst beq temp zero-tn fixnum)
+ (inst move temp value)
+
+ ;; If not, is it an other pointer?
+ (inst and temp value lowtag-mask)
+ (inst xor temp other-pointer-lowtag)
+ (inst bne temp zero-tn nope)
+ (inst nop)
+ ;; Get the header.
+ (loadw temp value 0 other-pointer-lowtag)
+ ;; Is it one?
+ (inst xor temp (+ (ash 1 n-widetag-bits) bignum-widetag))
+ (inst beq temp zero-tn single-word)
+ ;; If it's other than two, we can't be an (unsigned-byte 32)
+ (inst xor temp (logxor (+ (ash 1 n-widetag-bits) bignum-widetag)
+ (+ (ash 2 n-widetag-bits) bignum-widetag)))
+ (inst bne temp zero-tn nope)
+ ;; Get the second digit.
+ (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
+ ;; All zeros, its an (unsigned-byte 32).
+ (inst beq temp zero-tn yep)
+ (inst nop)
+ (inst b nope)
+
+ SINGLE-WORD
+ ;; Get the single digit.
+ (loadw temp value bignum-digits-offset other-pointer-lowtag)
+
+ ;; positive implies (unsigned-byte 32).
+ FIXNUM
+ (if not-p
+ (inst bltz temp target)
+ (inst bgez temp target))
+ (inst nop)))
+ (values))
+
+(define-vop (unsigned-byte-32-p type-predicate)
+ (:translate unsigned-byte-32-p)
+ (:generator 45
+ (unsigned-byte-32-test value temp not-p target not-target)
+ NOT-TARGET))
+
+(define-vop (check-unsigned-byte-32 check-type)
+ (:generator 45
+ (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
+ value)))
+ (unsigned-byte-32-test value temp t loose okay))
+ OKAY
+ (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
+ (inst beq value null-tn (if not-p drop-thru target))
+ (test-type value temp target not-p symbol-header-widetag)
+ DROP-THRU))
+
+(define-vop (check-symbol check-type)
+ (:generator 12
+ (inst beq value null-tn drop-thru)
+ (let ((error (generate-error-code vop object-not-symbol-error value)))
+ (test-type value temp error t symbol-header-widetag))
+ DROP-THRU
+ (move result value)))
+
+(define-vop (consp type-predicate)
+ (:translate consp)
+ (:generator 8
+ (inst beq value null-tn (if not-p target drop-thru))
+ (test-type value temp target not-p list-pointer-lowtag)
+ DROP-THRU))
+
+(define-vop (check-cons check-type)
+ (:generator 8
+ (let ((error (generate-error-code vop object-not-cons-error value)))
+ (inst beq value null-tn error)
+ (test-type value temp error t list-pointer-lowtag))
+ (move result value)))
+
+) ; MACROLET
\ No newline at end of file
--- /dev/null
+(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))
+ (count :scs (any-reg)))
+ (:info nvals)
+ (:temporary (:scs (descriptor-reg)) temp)
+ (:temporary (:scs (descriptor-reg)
+ :to (:result 0)
+ :target start)
+ start-temp)
+ (:generator 20
+ (move start-temp csp-tn)
+ (inst addu 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-temp i))
+ (control-stack
+ (load-stack-tn temp tn)
+ (storew temp start-temp i)))))
+ (move start start-temp)
+ (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
+ (move list arg)
+ (move start csp-tn)
+
+ LOOP
+ (inst beq list null-tn done)
+ (loadw temp list cons-car-slot list-pointer-lowtag)
+ (loadw list list cons-cdr-slot list-pointer-lowtag)
+ (inst addu csp-tn csp-tn n-word-bytes)
+ (storew temp csp-tn -1)
+ (inst and ndescr list lowtag-mask)
+ (inst xor ndescr list-pointer-lowtag)
+ (inst beq ndescr zero-tn loop)
+ (inst nop)
+ (error-call vop bogus-arg-to-values-list-error list)
+
+ DONE
+ (inst subu 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)
+ (:results (start :scs (any-reg))
+ (count :scs (any-reg)))
+ (:generator 20
+ (sc-case skip
+ (zero
+ (move src context))
+ (immediate
+ (inst addu src context (* (tn-value skip) n-word-bytes)))
+ (any-reg
+ (inst addu src context skip)))
+ (move count num)
+ (inst beq num zero-tn done)
+ (inst move start csp-tn)
+ (inst move dst csp-tn)
+ (inst addu csp-tn count)
+ LOOP
+ (inst lw temp src)
+ (inst addu src 4)
+ (inst addu dst 4)
+ (inst bne dst csp-tn loop)
+ (inst sw temp dst -4)
+ DONE))
--- /dev/null
+(in-package "SB!VM")
+
+\f
+;;;; 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))))))
+ (defreg zero 0)
+ (defreg nl3 1)
+ (defreg cfunc 2)
+ (defreg nl4 3)
+ (defreg nl0 4) ; First C argument reg.
+ (defreg nl1 5)
+ (defreg nl2 6)
+ (defreg nargs 7)
+ (defreg a0 8)
+ (defreg a1 9)
+ (defreg a2 10)
+ (defreg a3 11)
+ (defreg a4 12)
+ (defreg a5 13)
+ (defreg fdefn 14)
+ (defreg lexenv 15)
+ ;; First saved reg
+ (defreg nfp 16)
+ (defreg ocfp 17)
+ (defreg lra 18)
+ (defreg l0 19)
+ (defreg null 20)
+ (defreg bsp 21)
+ (defreg cfp 22)
+ (defreg csp 23)
+ (defreg l1 24)
+ (defreg alloc 25)
+ (defreg nsp 29)
+ (defreg code 30)
+ (defreg lip 31)
+
+ (defregset non-descriptor-regs
+ nl0 nl1 nl2 nl3 nl4 cfunc nargs)
+
+ (defregset descriptor-regs
+ a0 a1 a2 a3 a4 a5 fdefn lexenv nfp ocfp lra l0 l1)
+
+ (defregset *register-arg-offsets*
+ a0 a1 a2 a3 a4 a5)
+
+ (defregset reserve-descriptor-regs
+ fdefn lexenv)
+
+ (defregset reserve-non-descriptor-regs
+ nl4 cfunc))
+
+\f
+;;;; SB and SC definition:
+
+(define-storage-base registers :finite :size 32)
+(define-storage-base float-registers :finite :size 32)
+(define-storage-base control-stack :unbounded :size 8)
+(define-storage-base non-descriptor-stack :unbounded :size 0)
+(define-storage-base constant :non-packed)
+(define-storage-base immediate-constant :non-packed)
+
+;;;
+;;; Handy macro so we don't have to keep changing all the numbers whenever
+;;; we insert a new storage class.
+;;;
+(defmacro !define-storage-classes (&rest classes)
+ (do ((forms (list 'progn)
+ (let* ((class (car classes))
+ (sc-name (car class))
+ (constant-name (intern (concatenate 'simple-string
+ (string sc-name)
+ "-SC-NUMBER"))))
+ (list* `(define-storage-class ,sc-name ,index
+ ,@(cdr class))
+ `(defconstant ,constant-name ,index)
+ `(export ',constant-name)
+ forms)))
+ (index 0 (1+ index))
+ (classes classes (cdr classes)))
+ ((null classes)
+ (nreverse forms))))
+
+(def!constant sb!vm::kludge-nondeterministic-catch-block-size 7)
+
+(!define-storage-classes
+
+ ;; Non-immediate constants in the constant pool
+ (constant constant)
+
+ ;; Immediate constant.
+ (null immediate-constant)
+ (zero immediate-constant)
+ (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) ; double 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)
+
+
+ ;; **** 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)
+ :reserve-locations #.(append reserve-non-descriptor-regs
+ reserve-descriptor-regs)
+ :constant-scs (constant zero immediate)
+ :save-p t
+ :alternate-scs (control-stack))
+
+ ;; Pointer descriptor objects. Must be seen by GC.
+ (descriptor-reg registers
+ :locations #.descriptor-regs
+ :reserve-locations #.reserve-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
+ :reserve-locations #.reserve-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
+ :reserve-locations #.reserve-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
+ :reserve-locations #.reserve-non-descriptor-regs
+ :constant-scs (zero immediate)
+ :save-p t
+ :alternate-scs (signed-stack))
+ (unsigned-reg registers
+ :locations #.non-descriptor-regs
+ :reserve-locations #.reserve-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 (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
+ :reserve-locations (26 28 30)
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (single-stack))
+
+ ;; Non-Descriptor double-floats.
+ (double-reg float-registers
+ :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
+ :reserve-locations (26 28 30)
+ ;; Note: we don't bother with the element size, 'cause nothing can be
+ ;; allocated in the odd fp regs anyway.
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (double-stack))
+
+ (complex-single-reg float-registers
+ :locations (0 4 8 12 16 20 24 28)
+ :element-size 4
+ :reserve-locations (24 28)
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (complex-single-stack))
+
+ (complex-double-reg float-registers
+ :locations (0 4 8 12 16 20 24 28)
+ :element-size 4
+ :reserve-locations (24 28)
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (complex-double-stack))
+
+ ;; A catch or unwind block.
+ (catch-block control-stack :element-size sb!vm::kludge-nondeterministic-catch-block-size)
+
+ ;; floating point numbers temporarily stuck in integer registers for c-call
+ (single-int-carg-reg registers
+ :locations (4 5 6 7)
+ :alternate-scs ()
+ :constant-scs ())
+ (double-int-carg-reg registers
+ :locations (4 6)
+ :constant-scs ()
+ :alternate-scs ()
+ :alignment 2 ;is this needed?
+ :element-size 2))
+
+
+
+\f
+;;;; Random TNs for interesting 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 lip interior-reg)
+ (defregtn code descriptor-reg)
+ (defregtn alloc any-reg)
+ (defregtn null descriptor-reg)
+
+ (defregtn nargs any-reg)
+ (defregtn fdefn descriptor-reg)
+ (defregtn lexenv descriptor-reg)
+
+ (defregtn bsp any-reg)
+ (defregtn csp any-reg)
+ (defregtn cfp any-reg)
+ (defregtn ocfp any-reg)
+ (defregtn nsp any-reg)
+ (defregtn nfp any-reg))
+\f
+;;;
+;;; Immediate-Constant-SC -- Interface
+;;;
+;;; If value can be represented as an immediate constant, then return the
+;;; appropriate SC number, otherwise return NIL.
+;;;
+(!def-vm-support-routine immediate-constant-sc (value)
+ (typecase value
+ ((integer 0 0)
+ (sc-number-or-lose 'zero))
+ (null
+ (sc-number-or-lose 'null))
+ (symbol
+ (if (static-symbol-p value)
+ (sc-number-or-lose 'immediate)
+ nil))
+ ((signed-byte 30)
+ (sc-number-or-lose 'immediate))
+ (system-area-pointer
+ (sc-number-or-lose 'immediate))
+ (character
+ (sc-number-or-lose 'immediate))))
+
+\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)
+
+;;; The offsets within the register-arg SC that we pass values in, first
+;;; value first.
+;;;
+
+;;; Names to use for the argument registers.
+;;;
+(defconstant-eqx register-arg-names '(a0 a1 a2 a3 a4 a5) #'equal)
+
+); Eval-When (Compile Load Eval)
+
+
+;;; A list of TN's describing the register arguments.
+;;;
+(defparameter register-arg-tns
+ (mapcar #'(lambda (n)
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'descriptor-reg)
+ :offset n))
+ *register-arg-offsets*))
+
+;;; SINGLE-VALUE-RETURN-BYTE-OFFSET
+;;;
+;;; This is used by the debugger.
+;;;
+(defconstant single-value-return-byte-offset 8)
+
+\f
+;;; LOCATION-PRINT-NAME -- Interface
+;;;
+;;; This function is called by debug output routines that want a pretty name
+;;; for a TN's location. It returns a thing that can be printed with PRINC.
+;;;
+(!def-vm-support-routine location-print-name (tn)
+ (declare (type tn tn))
+ (let ((sb (sb-name (sc-sb (tn-sc tn))))
+ (offset (tn-offset tn)))
+ (ecase sb
+ (registers (or (svref *register-names* offset)
+ (format nil "R~D" offset)))
+ (float-registers (format nil "F~D" offset))
+ (control-stack (format nil "CS~D" offset))
+ (non-descriptor-stack (format nil "NS~D" offset))
+ (constant (format nil "Const~D" offset))
+ (immediate-constant "Immed"))))
+
+(defun extern-alien-name (name)
+ (declare (type simple-base-string name))
+ 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.
+
+CFLAGS += -g -O0
+LD = ld
+LINKFLAGS = -v -g
+NM = nm -p
+
+ASSEM_SRC = mips-assem.S #hppa-linux-stubs.S
+ARCH_SRC = mips-arch.c undefineds.c
+
+OS_SRC = linux-os.c mips-linux-os.c os-common.c
+LINKFLAGS+=-static
+OS_LIBS= -ldl
+
+GC_SRC= cheneygc.c
#define _ALPHA_LINUX_OS_H
typedef struct ucontext os_context_t;
+typedef long os_context_register_t;
static inline os_context_t *arch_os_get_context(void **void_context) {
return (os_context_t *) *void_context;
#define _HPPA_LINUX_OS_H
typedef struct ucontext os_context_t;
+/* FIXME: This will change if the parisc-linux people implement
+ wide-sigcontext for 32-bit kernels */
+typedef unsigned long os_context_register_t;
static inline os_context_t *arch_os_get_context(void **void_context) {
return (os_context_t *) *void_context;
#define SIG_MEMORY_FAULT SIGSEGV
-/* /usr/include/asm/sigcontext.h */
-typedef long os_context_register_t ;
--- /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"
+
+void arch_init()
+{
+ return;
+}
+
+os_vm_address_t arch_get_bad_addr(int signam, siginfo_t *siginfo, os_context_t *context)
+{
+ /* Classic CMUCL comment:
+
+ Finding the bad address on the mips is easy. */
+ return (os_vm_address_t) siginfo->si_addr;
+}
+
+unsigned long
+emulate_branch(os_context_t *context, unsigned long inst)
+{
+ long opcode = inst >> 26;
+ long r1 = (inst >> 21) & 0x1f;
+ long r2 = (inst >> 16) & 0x1f;
+ long bdisp = (inst&(1<<15)) ? inst | (-1 << 16) : inst&0xffff;
+ long jdisp = (inst&(1<<25)) ? inst | (-1 << 26) : inst&0xffff;
+ long disp = 0;
+
+ switch(opcode) {
+ case 0x1: /* bltz, bgez, bltzal, bgezal */
+ switch((inst >> 16) & 0x1f) {
+ case 0x00: /* bltz */
+ if(*os_context_register_addr(context, r1) < 0)
+ disp = bdisp;
+ break;
+ case 0x01: /* bgez */
+ if(*os_context_register_addr(context, r1) >= 0)
+ disp = bdisp;
+ break;
+ case 0x10: /* bltzal */
+ if(*os_context_register_addr(context, r1) < 0)
+ disp = bdisp;
+ *os_context_register_addr(context, 31) = *os_context_pc_addr(context) + 4;
+ break;
+ case 0x11: /* bgezal */
+ if(*os_context_register_addr(context, r1) >= 0)
+ disp = bdisp;
+ *os_context_register_addr(context, 31) = *os_context_pc_addr(context) + 4;
+ break;
+ }
+ break;
+ case 0x4: /* beq */
+ if(*os_context_register_addr(context, r1)
+ == *os_context_register_addr(context, r2))
+ disp = bdisp;
+ break;
+ case 0x5: /* bne */
+ if(*os_context_register_addr(context, r1)
+ != *os_context_register_addr(context, r2))
+ disp = bdisp;
+ break;
+ case 0x6: /* ble */
+ if(*os_context_register_addr(context, r1)
+ /* FIXME: One has to assume that the CMUCL gods of old have
+ got the sign issues right... but it might be worth
+ checking, someday */
+ <= *os_context_register_addr(context, r2))
+ disp = bdisp;
+ break;
+ case 0x7: /* bgtz */
+ if(*os_context_register_addr(context, r1)
+ >= *os_context_register_addr(context, r2))
+ disp = bdisp;
+ break;
+ case 0x2: /* j */
+ disp = jdisp;
+ break;
+ case 0x3: /* jal */
+ disp = jdisp;
+ *os_context_register_addr(context, 31) = *os_context_pc_addr(context) + 4;
+ break;
+ }
+ return (*os_context_pc_addr(context) + disp * 4);
+}
+
+void arch_skip_instruction(os_context_t *context)
+{
+ /* Skip the offending instruction */
+ if (os_context_bd_cause(context))
+ *os_context_pc_addr(context) =
+ emulate_branch(context,
+ *(unsigned long *) *os_context_pc_addr(context));
+ else
+ *os_context_pc_addr(context) += 4;
+
+ os_flush_icache((os_vm_address_t) *os_context_pc_addr(context), sizeof(unsigned long));
+}
+
+unsigned char *arch_internal_error_arguments(os_context_t *context)
+{
+ if (os_context_bd_cause(context))
+ return (unsigned char *)(*os_context_pc_addr(context) + 8);
+ else
+ 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) & 1;
+}
+
+#define PSEUDO_ATOMIC_INTERRUPTED_BIAS 0x7f000000
+
+void arch_set_pseudo_atomic_interrupted(os_context_t *context)
+{
+ *os_context_register_addr(context, reg_NL4) |= 1<<31;
+}
+
+unsigned long arch_install_breakpoint(void *pc)
+{
+ unsigned long *ptr = (unsigned long *)pc;
+ unsigned long result = *ptr;
+ *ptr = (trap_Breakpoint << 16) | 0xd;
+
+ os_flush_icache((os_vm_address_t)ptr, 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);
+ unsigned long *break_pc, *next_pc;
+ unsigned long next_inst;
+ int opcode;
+
+ orig_sigmask = *os_context_sigmask_addr(context);
+ sigaddset_blockable(os_context_sigmask_addr(context));
+
+ /* Figure out where the breakpoint is, and what happens next. */
+ if (os_context_bd_cause(context)) {
+ break_pc = pc+1;
+ next_inst = *pc;
+ }
+ else {
+ break_pc = pc;
+ next_inst = orig_inst;
+ }
+
+ /* Put the original instruction back. */
+ *break_pc = orig_inst;
+ os_flush_icache((os_vm_address_t)break_pc, sizeof(unsigned long));
+ skipped_break_addr = break_pc;
+
+ /* Figure out where it goes. */
+ opcode = next_inst >> 26;
+ if (opcode == 1 || ((opcode & 0x3c) == 0x4) || ((next_inst & 0xf00e0000) == 0x80000000)) {
+
+ next_pc = emulate_branch(context, next_inst);
+ }
+ else
+ next_pc = pc+1;
+
+ displaced_after_inst = *next_pc;
+ *next_pc = (trap_AfterBreakpoint << 16) | 0xd;
+ os_flush_icache((os_vm_address_t)next_pc, sizeof(unsigned long));
+}
+
+static void sigtrap_handler(int signal, siginfo_t *info, void *void_context)
+{
+ os_context_t *context = arch_os_get_context(&void_context);
+ sigset_t *mask;
+ int code;
+ /* Don't disallow recursive breakpoint traps. Otherwise, we can't */
+ /* use debugger breakpoints anywhere in here. */
+ mask = os_context_sigmask_addr(context);
+ sigsetmask(mask);
+ code = ((*(int *) (*os_context_pc_addr(context))) >> 16) & 0x1f;
+
+ switch (code) {
+ 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, info, context, code==trap_Cerror);
+ break;
+
+ case trap_Breakpoint:
+ handle_breakpoint(signal, info, context);
+ break;
+
+ case trap_FunEndBreakpoint:
+ *os_context_pc_addr(context) = (int)handle_fun_end_breakpoint(signal, info, context);
+ break;
+
+ case trap_AfterBreakpoint:
+ *skipped_break_addr = (trap_Breakpoint << 16) | 0xd;
+ os_flush_icache((os_vm_address_t)skipped_break_addr,
+ sizeof(unsigned long));
+ skipped_break_addr = NULL;
+ *(unsigned long *)(*os_context_pc_addr(context)) = displaced_after_inst;
+ os_flush_icache((os_vm_address_t) *os_context_pc_addr(context), sizeof(unsigned long));
+ *os_context_sigmask_addr(context) = orig_sigmask;
+ break;
+
+ case 0x10:
+ /* Clear the flag */
+ *os_context_register_addr(context, reg_NL4) &= 0x7fffffff;
+ arch_skip_instruction(context);
+ interrupt_handle_pending(context);
+ return;
+
+ default:
+ interrupt_handle_now(signal, info, context);
+ break;
+ }
+}
+
+/* FIXME: We must have one of these somewhere. Also, export
+ N-FIXNUM-TAG-BITS from Lispland and use it rather than 2 here. */
+#define FIXNUM_VALUE(lispobj) (((int)lispobj)>>2)
+
+void sigfpe_handler(int signal, siginfo_t *info, void *void_context)
+{
+ unsigned long bad_inst;
+ unsigned int op, rs, rt, rd, funct, dest;
+ int immed;
+ long result;
+ os_context_t *context = arch_os_get_context(&void_context);
+
+ if (os_context_bd_cause(context))
+ bad_inst = *(unsigned long *)(*os_context_pc_addr(context) + 4);
+ else
+ bad_inst = *(unsigned long *)(*os_context_pc_addr(context));
+
+ op = (bad_inst >> 26) & 0x3f;
+ rs = (bad_inst >> 21) & 0x1f;
+ rt = (bad_inst >> 16) & 0x1f;
+ rd = (bad_inst >> 11) & 0x1f;
+ funct = bad_inst & 0x3f;
+ immed = (((int)(bad_inst & 0xffff)) << 16) >> 16;
+
+ switch (op) {
+ case 0x0: /* SPECIAL */
+ switch (funct) {
+ case 0x20: /* ADD */
+ /* FIXME: Hopefully, this whole section can just go away,
+ with the rewrite of pseudo-atomic and the deletion of
+ overflow VOPs */
+ /* Check to see if this is really a pa_interrupted hit */
+ if (rs == reg_ALLOC && rt == reg_NL4) {
+ *os_context_register_addr(context, reg_ALLOC)
+ += (*os_context_register_addr(context, reg_NL4)
+ - PSEUDO_ATOMIC_INTERRUPTED_BIAS);
+ arch_skip_instruction(context);
+ interrupt_handle_pending(context);
+ return;
+ }
+ result = FIXNUM_VALUE(*os_context_register_addr(context, rs))
+ + FIXNUM_VALUE(*os_context_register_addr(context, rt));
+ dest = rd;
+ break;
+
+ case 0x22: /* SUB */
+ result = FIXNUM_VALUE(*os_context_register_addr(context, rs))
+ - FIXNUM_VALUE(*os_context_register_addr(context, rt));
+ dest = rd;
+ break;
+
+ default:
+ dest = 32;
+ break;
+ }
+ break;
+
+ case 0x8: /* ADDI */
+ result = FIXNUM_VALUE(*os_context_register_addr(context,rs)) + (immed>>2);
+ dest = rt;
+ break;
+
+ default:
+ dest = 32;
+ break;
+ }
+
+ if (dest < 32) {
+ dynamic_space_free_pointer =
+ (lispobj *) *os_context_register_addr(context,reg_ALLOC);
+
+ *os_context_register_addr(context,dest) = alloc_number(result);
+
+ *os_context_register_addr(context, reg_ALLOC) =
+ (unsigned long) dynamic_space_free_pointer;
+
+ arch_skip_instruction(context);
+
+ }
+ else
+ interrupt_handle_now(signal, info, context);
+}
+
+void arch_install_interrupt_handlers()
+{
+ undoably_install_low_level_interrupt_handler(SIGTRAP,sigtrap_handler);
+ undoably_install_low_level_interrupt_handler(SIGFPE,sigfpe_handler);
+}
+
+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 _MIPS_ARCH_H
+#define _MIPS_ARCH_H
+
+#endif /* _MIPS_ARCH_H */
--- /dev/null
+#define LANGUAGE_ASSEMBLY
+
+#include "sbcl.h"
+#include "lispregs.h"
+
+#define zero $0
+#define at $1
+#define v0 $2
+#define v1 $3
+#define a0 $4
+#define a1 $5
+#define a2 $6
+#define a3 $7
+#define t0 $8
+#define t1 $9
+#define t2 $10
+#define t3 $11
+#define t4 $12
+#define t5 $13
+#define t6 $14
+#define t7 $15
+#define s0 $16
+#define s1 $17
+#define s2 $18
+#define s3 $19
+#define s4 $20
+#define s5 $21
+#define s6 $22
+#define s7 $23
+#define t8 $24
+#define t9 $25
+#define k0 $26
+#define k1 $27
+#define gp $28
+#define sp $29
+#define s8 $30
+#define ra $31
+
+
+/*
+ * Function to transfer control into lisp.
+ */
+ .text
+ .globl call_into_lisp
+ .ent call_into_lisp
+call_into_lisp:
+#define framesize 12*4
+ subu sp, framesize
+ .frame sp, framesize, ra
+ /* Save all the C regs. */
+ .mask 0xc0ff0000, 0
+ sw ra, framesize(sp)
+ sw s8, framesize-4(sp)
+ sw s7, framesize-12(sp)
+ sw s6, framesize-16(sp)
+ sw s5, framesize-20(sp)
+ sw s4, framesize-24(sp)
+ sw s3, framesize-28(sp)
+ sw s2, framesize-32(sp)
+ sw s1, framesize-36(sp)
+ sw s0, framesize-40(sp)
+
+ /* Clear descriptor regs */
+ move t0, zero
+ move t1, zero
+ move t2, zero
+ move t3, zero
+ move t4, zero
+ move t5, zero
+ move t6, zero
+ move t7, zero
+ move t8, zero
+ move s0, zero
+ move s1, zero
+ move s2, zero
+ move s3, zero
+ move ra, zero
+
+ li reg_NIL, NIL
+
+ /* Start pseudo-atomic. */
+ .set noreorder
+ li reg_NL4, 0
+ li reg_ALLOC, 1
+ .set reorder
+
+ /* No longer in foreign call. */
+ sw zero, foreign_function_call_active
+
+ /* Load the allocation pointer, preserving the low-bit of alloc */
+ lw reg_BSP, dynamic_space_free_pointer
+ add reg_ALLOC, reg_BSP
+
+ /* Load the rest of the LISP state. */
+ lw reg_BSP, current_binding_stack_pointer
+ lw reg_CSP, current_control_stack_pointer
+ lw reg_OCFP, current_control_frame_pointer
+
+ /* Check for interrupt */
+ .set noreorder
+ bgez reg_NL4, pa1
+ nop
+ break 0x10
+pa1:
+ subu reg_ALLOC, 1
+ .set reorder
+
+ /* Pass in args */
+ move reg_LEXENV, $4
+ move reg_CFP, $5
+ sll reg_NARGS, $6, 2
+ lw reg_A0, 0(reg_CFP)
+ lw reg_A1, 4(reg_CFP)
+ lw reg_A2, 8(reg_CFP)
+ lw reg_A3, 12(reg_CFP)
+ lw reg_A4, 16(reg_CFP)
+ lw reg_A5, 20(reg_CFP)
+
+ /* Calculate LRA */
+ la reg_LRA, lra + OTHER_POINTER_LOWTAG
+
+ /* Indirect closure */
+ lw reg_CODE, -1(reg_LEXENV)
+
+ /* Jump into lisp land. */
+ addu reg_LIP, reg_CODE, 6*4 - FUN_POINTER_LOWTAG
+ j reg_LIP
+
+ .set noreorder
+ .align 3
+#ifdef irix
+ /* This particular KLUDGE is kept here as a reminder; for more
+ details, see irix-asm-munge.c from CMUCL's lisp directory.
+ Other examples have been deleted from later in the file in the
+ hope that they will not be needed. */
+.globl mipsmungelra /* for our munging afterwards in irix-asm-munge */
+mipsmungelra:
+#endif
+lra:
+ .word RETURN_PC_HEADER_WIDETAG
+
+ /* Multiple value return spot, clear stack */
+ move reg_CSP, reg_OCFP
+ nop
+
+ /* Set pseudo-atomic flag. */
+ li reg_NL4, 0
+ addu reg_ALLOC, 1
+ .set reorder
+
+ /* Save LISP registers. */
+ subu reg_NL0, reg_ALLOC, 1
+ sw reg_NL0, dynamic_space_free_pointer
+ sw reg_BSP, current_binding_stack_pointer
+ sw reg_CSP, current_control_stack_pointer
+ sw reg_CFP, current_control_frame_pointer
+
+ /* Pass one return value back to C land. */
+ /* v0 is reg_ALLOC in this new world, so do this after saving
+ reg_ALLOC in dynamic_space_free_pointer */
+ move v0, reg_A0
+
+ /* Back in foreign function call */
+ sw reg_CFP, foreign_function_call_active
+
+ /* Check for interrupt */
+ .set noreorder
+ bgez reg_NL4, pa2
+ nop
+ break 0x10
+pa2:
+ subu reg_ALLOC, 1
+ .set reorder
+
+ /* Restore C regs */
+ lw ra, framesize(sp)
+ lw s8, framesize-4(sp)
+ lw s7, framesize-12(sp)
+ lw s6, framesize-16(sp)
+ lw s5, framesize-20(sp)
+ lw s4, framesize-24(sp)
+ lw s3, framesize-28(sp)
+ lw s2, framesize-32(sp)
+ lw s1, framesize-36(sp)
+ lw s0, framesize-40(sp)
+
+ /* Restore C stack. */
+ addu sp, framesize
+
+ /* Back we go. */
+ j ra
+
+ .end call_into_lisp
+
+/*
+ * Transfering control from Lisp into C
+ */
+ .text
+ .globl call_into_c
+ .ent call_into_c
+call_into_c:
+ /* Set up a stack frame. */
+ move reg_OCFP, reg_CFP
+ move reg_CFP, reg_CSP
+ addu reg_CSP, reg_CFP, 32
+ sw reg_OCFP, 0(reg_CFP)
+ subu reg_NL4, reg_LIP, reg_CODE
+ addu reg_NL4, OTHER_POINTER_LOWTAG
+ sw reg_NL4, 4(reg_CFP)
+ sw reg_CODE, 8(reg_CFP)
+ sw gp, 12(reg_CFP)
+
+ /* Note: the C stack is already set up. */
+
+ /* Set the pseudo-atomic flag. */
+ .set noreorder
+ li reg_NL4, 0
+ addu reg_ALLOC, 1
+ .set reorder
+
+ /* Save lisp state. */
+ subu t0, reg_ALLOC, 1
+ sw t0, dynamic_space_free_pointer
+ sw reg_BSP, current_binding_stack_pointer
+ sw reg_CSP, current_control_stack_pointer
+ sw reg_CFP, current_control_frame_pointer
+
+ /* Mark us as in C land. */
+ sw reg_CSP, foreign_function_call_active
+
+ /* Were we interrupted? */
+ .set noreorder
+ bgez reg_NL4, pa3
+ nop
+ break 0x10
+pa3:
+ subu reg_ALLOC, 1
+ .set reorder
+
+ /* Into C land we go. */
+ move t9, reg_CFUNC
+ jal t9
+ nop
+
+ lw gp, 12(reg_CFP)
+
+ /* Clear unsaved descriptor regs */
+ move t0, zero
+ move t1, zero
+ move t2, zero
+ move t3, zero
+ move t4, zero
+ move t5, zero
+ move t6, zero
+ move t7, zero
+ move t8, zero
+ move s0, zero
+ move s2, zero
+ move s3, zero
+ move ra, zero
+
+ /* Turn on pseudo-atomic. */
+ .set noreorder
+ li reg_NL4, 0
+ li reg_ALLOC, 1
+ .set reorder
+
+ /* Mark us at in Lisp land. */
+ sw zero, foreign_function_call_active
+
+ /* Restore ALLOC, preserving pseudo-atomic-atomic */
+ lw a0, dynamic_space_free_pointer
+ addu reg_ALLOC, a0
+
+ /* Check for interrupt */
+ .set noreorder
+ bgez reg_NL4, pa4
+ nop
+ break 0x10
+pa4:
+ subu reg_ALLOC, 1
+ .set reorder
+
+ /* Restore LRA & CODE (they may have been GC'ed) */
+ lw reg_CODE, 8(reg_CFP)
+ lw a0, 4(reg_CFP)
+ subu a0, OTHER_POINTER_LOWTAG
+ addu reg_LIP, reg_CODE, a0
+
+ /* Reset the lisp stack. */
+ /* Note: OCFP and CFP are in saved regs. */
+ move reg_CSP, reg_CFP
+ move reg_CFP, reg_OCFP
+
+ /* Return to LISP. */
+ j reg_LIP
+
+ .end call_into_c
+
+ .text
+ .globl start_of_tramps
+start_of_tramps:
+
+/*
+ * The undefined-function trampoline.
+ */
+ .text
+ .globl undefined_tramp
+ .ent undefined_tramp
+undefined_tramp:
+ break 10
+ .byte 4
+ .byte UNDEFINED_FUN_ERROR
+ .byte 254
+ .byte (0xc0 + sc_DescriptorReg)
+ .byte 1
+ .align 2
+ .end undefined_tramp
+
+/*
+ * The closure trampoline.
+ */
+ .text
+ .globl closure_tramp
+ .ent closure_tramp
+closure_tramp:
+ lw reg_LEXENV, FDEFN_FUN_OFFSET(reg_FDEFN)
+ lw reg_L0, CLOSURE_FUN_OFFSET(reg_LEXENV)
+ addu reg_LIP, reg_L0, SIMPLE_FUN_CODE_OFFSET
+ j reg_LIP
+ .end closure_tramp
+
+ .text
+ .globl end_of_tramps
+end_of_tramps:
+
+
+/*
+ * Function-end breakpoint magic.
+ */
+
+ .text
+ .align 2
+ .set noreorder
+ .globl function_end_breakpoint_guts
+fun_end_breakpoint_guts:
+ .word RETURN_PC_HEADER_WIDETAG
+
+ beq zero, zero, 1f
+ nop
+ move reg_OCFP, reg_CSP
+ addu reg_CSP, 4
+ li reg_NARGS, 4
+ move reg_A1, reg_NIL
+ move reg_A2, reg_NIL
+ move reg_A3, reg_NIL
+ move reg_A4, reg_NIL
+ move reg_A5, reg_NIL
+1:
+
+ .globl fun_end_breakpoint_trap
+fun_end_breakpoint_trap:
+ break trap_FunEndBreakpoint
+ beq zero, zero, 1b
+ nop
+
+ .globl fun_end_breakpoint_end
+fun_end_breakpoint_end:
+ .set reorder
+
+/* FIXME: I don't think the below are actually used anywhere */
+ .text
+ .align 2
+ .globl call_on_stack
+ .ent call_on_stack
+call_on_stack:
+ subu sp, a1, 16
+ jal a0
+ break 0
+ .end call_on_stack
+
+ .globl save_state
+ .ent save_state
+save_state:
+ subu sp, 40
+ .frame sp, 40, ra
+ /* Save all the C regs. */
+ .mask 0xc0ff0000, 0
+ sw ra, 40(sp)
+ sw s8, 40-4(sp)
+ sw s7, 40-8(sp)
+ sw s6, 40-12(sp)
+ sw s5, 40-16(sp)
+ sw s4, 40-20(sp)
+ sw s3, 40-24(sp)
+ sw s2, 40-28(sp)
+ sw s1, 40-32(sp)
+ sw s0, 40-36(sp)
+
+ /* Should also save the floating point state. */
+
+ move t0, a0
+ move a0, sp
+
+ jal t0
+
+_restore_state:
+
+ lw ra, 40(sp)
+ lw s8, 40-4(sp)
+ lw s7, 40-8(sp)
+ lw s6, 40-12(sp)
+ lw s5, 40-16(sp)
+ lw s4, 40-20(sp)
+ lw s3, 40-24(sp)
+ lw s2, 40-28(sp)
+ lw s1, 40-32(sp)
+ lw s0, 40-36(sp)
+
+ addu sp, 40
+ j ra
+
+ .globl restore_state
+restore_state:
+ move sp, a0
+ move v0, a1
+ j _restore_state
+ .end save_state
+
+
+
+
+
--- /dev/null
+/*
+ * This is the MIPS 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/time.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+#include "validate.h"
+/* for cacheflush() */
+#include <asm/cachectl.h>
+
+/* FIXME: For CAUSEF_BD */
+#include <asm/mipsregs.h>
+size_t os_vm_page_size;
+
+
+os_context_register_t *
+os_context_register_addr(os_context_t *context, int offset)
+{
+ if (offset == 0) {
+ /* KLUDGE: I'm not sure, but it's possible that Linux puts the
+ contents of the Processor Status Word in the (wired-zero)
+ slot in the mcontext. In any case, the following is
+ unlikely to do any harm: */
+ static unsigned long long zero;
+ zero = 0;
+ return &zero;
+ } else {
+ return &(((struct sigcontext *) &(context->uc_mcontext))->sc_regs[offset]);
+ }
+}
+
+os_context_register_t *
+os_context_pc_addr(os_context_t *context)
+{
+ /* Why do I get all the silly ports? -- CSR, 2002-08-11 */
+ return &(((struct sigcontext *) &(context->uc_mcontext))->sc_pc);
+}
+
+sigset_t *
+os_context_sigmask_addr(os_context_t *context)
+{
+ return &(context->uc_sigmask);
+}
+
+void
+os_restore_fp_control(os_context_t *context)
+{
+ /* FIXME: Probably do something. */
+}
+
+unsigned int
+os_context_bd_cause(os_context_t *context)
+{
+ /* We need to see if whatever happened, happened because of a
+ branch delay event */
+ return (((struct sigcontext *) &(context->uc_mcontext))->sc_cause
+ & CAUSEF_BD);
+}
+
+void
+os_flush_icache(os_vm_address_t address, os_vm_size_t length)
+{
+ if (cacheflush(address, length, ICACHE) == -1)
+ perror("cacheflush");
+}
--- /dev/null
+#ifndef _MIPS_LINUX_OS_H
+#define _MIPS_LINUX_OS_H
+
+typedef struct ucontext os_context_t;
+typedef unsigned long long os_context_register_t;
+
+static inline os_context_t *arch_os_get_context(void **void_context) {
+ return (os_context_t *) *void_context;
+}
+
+unsigned long os_context_fp_control(os_context_t *context);
+void os_restore_fp_control(os_context_t *context);
+unsigned int os_context_bd_cause(os_context_t *context);
+
+#endif /* _MIPS_LINUX_OS_H */
--- /dev/null
+/* $Header$ */
+
+#ifdef LANGUAGE_ASSEMBLY
+#define REG(num) $ ## num
+#else
+#define REG(num) num
+#endif
+
+#define NREGS (32)
+
+#define reg_ZERO REG(0)
+#define reg_NL3 REG(1)
+#define reg_CFUNC REG(2)
+#define reg_NL4 REG(3)
+#define reg_NL0 REG(4)
+#define reg_NL1 REG(5)
+#define reg_NL2 REG(6)
+#define reg_NARGS REG(7)
+#define reg_A0 REG(8)
+#define reg_A1 REG(9)
+#define reg_A2 REG(10)
+#define reg_A3 REG(11)
+#define reg_A4 REG(12)
+#define reg_A5 REG(13)
+#define reg_FDEFN REG(14)
+#define reg_LEXENV REG(15)
+#define reg_NFP REG(16)
+#define reg_OCFP REG(17)
+#define reg_LRA REG(18)
+#define reg_L0 REG(19)
+#define reg_NIL REG(20)
+#define reg_BSP REG(21)
+#define reg_CFP REG(22)
+#define reg_CSP REG(23)
+#define reg_L1 REG(24)
+#define reg_ALLOC REG(25)
+#define reg_NSP REG(29)
+#define reg_CODE REG(30)
+#define reg_LIP REG(31)
+
+#define REGNAMES \
+ "ZERO", "NL3", "CFUNC", "NL4", \
+ "NL0", "NL1", "NL2", "NARGS", \
+ "A0", "A1", "A2", "A3", \
+ "A4", "A5", "FDEFN", "LEXENV", \
+ "NFP", "OCFP", "LRA", "L0", \
+ "NIL", "BSP", "CFP", "CSP", \
+ "L1", "ALLOC", "K0", "K1", \
+ "GP", "NSP", "CODE", "LIP"
+
+
+#define BOXED_REGISTERS { \
+ reg_A0, reg_A1, reg_A2, reg_A3, reg_A4, reg_A5, reg_FDEFN, reg_LEXENV, \
+ reg_NFP, reg_OCFP, reg_LRA, reg_L0, reg_L1, reg_CODE \
+}
+
+#define SC_REG(sc, n) ((sc)->sc_regs[n])
+#define SC_PC(sc) ((sc)->sc_pc)
#define _PPC_LINUX_OS_H
typedef struct ucontext os_context_t;
+typedef long os_context_register_t;
static inline os_context_t *arch_os_get_context(void **void_context) {
return (os_context_t *) *void_context;
#define _SPARC_LINUX_OS_H
typedef struct sigcontext os_context_t;
+typedef unsigned long os_context_register_t;
static inline os_context_t *arch_os_get_context(void **void_context) {
asm volatile ("ta 0x03"); /* ta ST_FLUSH_WINDOWS */
#define _X86_LINUX_OS_H
typedef struct ucontext os_context_t;
+typedef long os_context_register_t;
static inline os_context_t *arch_os_get_context(void **void_context) {
return (os_context_t *) *void_context;
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.7.8"
+"0.7.7.9"
projects / sbcl.git / commitdiff