From: Christophe Rhodes Date: Sun, 1 Sep 2002 22:34:13 +0000 (+0000) Subject: 0.7.7.9: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=4ae1b794a5d6a90794468cf8017f5307f2c30dfe;p=sbcl.git 0.7.7.9: Commit MIPS backend ... one or two modifications to extant code, as per CSR sbcl-devel 2002-08-31 ... lots of new files --- diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 86e1c98..6733168 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -207,15 +207,15 @@ ;; 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 diff --git a/make-config.sh b/make-config.sh index 47ed7b5..d146852 100644 --- a/make-config.sh +++ b/make-config.sh @@ -36,6 +36,8 @@ case `uname -m` in 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 @@ -62,6 +64,8 @@ printf ":%s" "$sbcl_arch" >> $ltf # 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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index d0861fc..966d3b2 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -750,6 +750,7 @@ retained, possibly temporariliy, because it might be used internally." ;; ..and DEFTYPEs.. "INDEX" "LOAD/STORE-INDEX" + "SIGNED-BYTE-WITH-A-BITE-OUT" "UNSIGNED-BYTE-WITH-A-BITE-OUT" ;; ..and type predicates "INSTANCEP" diff --git a/src/assembly/mips/alloc.lisp b/src/assembly/mips/alloc.lisp new file mode 100644 index 0000000..a2c4fa5 --- /dev/null +++ b/src/assembly/mips/alloc.lisp @@ -0,0 +1,3 @@ +(in-package "SB!VM") + + diff --git a/src/assembly/mips/arith.lisp b/src/assembly/mips/arith.lisp new file mode 100644 index 0000000..1b9d039 --- /dev/null +++ b/src/assembly/mips/arith.lisp @@ -0,0 +1,312 @@ +(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) + + + +;;;; 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)) diff --git a/src/assembly/mips/array.lisp b/src/assembly/mips/array.lisp new file mode 100644 index 0000000..d59d5ee --- /dev/null +++ b/src/assembly/mips/array.lisp @@ -0,0 +1,161 @@ +(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))) + + +;;;; 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)) diff --git a/src/assembly/mips/assem-rtns.lisp b/src/assembly/mips/assem-rtns.lisp new file mode 100644 index 0000000..c172655 --- /dev/null +++ b/src/assembly/mips/assem-rtns.lisp @@ -0,0 +1,223 @@ +(in-package "SB!VM") + + +;;;; 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)) + + +;;;; 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))) + + +;;;; 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)) diff --git a/src/assembly/mips/support.lisp b/src/assembly/mips/support.lisp new file mode 100644 index 0000000..c91d8c7 --- /dev/null +++ b/src/assembly/mips/support.lisp @@ -0,0 +1,58 @@ +(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))) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 75ec633..e4fa9c5 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -40,11 +40,20 @@ ;;; 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)) diff --git a/src/code/mips-vm.lisp b/src/code/mips-vm.lisp new file mode 100644 index 0000000..6b0664e --- /dev/null +++ b/src/code/mips-vm.lisp @@ -0,0 +1,140 @@ +(in-package "SB!VM") + +(define-alien-type os-context-t (struct os-context-t-struct)) + +;;;; 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") + + +;;; 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))))))) + + +(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))))))) + + + + + diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp index dadd1a0..437e199 100644 --- a/src/code/symbol.lisp +++ b/src/code/symbol.lisp @@ -48,12 +48,19 @@ 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))) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 6ef6c4a..4bff913 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1740,7 +1740,23 @@ (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) diff --git a/src/compiler/mips/alloc.lisp b/src/compiler/mips/alloc.lisp new file mode 100644 index 0000000..f067f63 --- /dev/null +++ b/src/compiler/mips/alloc.lisp @@ -0,0 +1,177 @@ +(in-package "SB!VM") + + +;;;; 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)) + + +;;;; 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))) + + +;;;; 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)))) + diff --git a/src/compiler/mips/arith.lisp b/src/compiler/mips/arith.lisp new file mode 100644 index 0000000..05a47b5 --- /dev/null +++ b/src/compiler/mips/arith.lisp @@ -0,0 +1,943 @@ +(in-package "SB!VM") + + + +;;;; 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))) + + + +;;;; 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))) + + + +;;;; 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)) + + +;;;; 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))))) + + + +;;;; 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))) + + +;;;; 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) diff --git a/src/compiler/mips/array.lisp b/src/compiler/mips/array.lisp new file mode 100644 index 0000000..2e59dbe --- /dev/null +++ b/src/compiler/mips/array.lisp @@ -0,0 +1,577 @@ +(in-package "SB!VM") + + +;;;; 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)))) + + +;;;; 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))) + + + +;;;; 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)))) + + + +;;;; 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)))) + + +;;; 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))))) + + +;;; 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) + + + +;;;; Misc. Array VOPs. + +(define-vop (get-vector-subtype get-header-data)) +(define-vop (set-vector-subtype set-header-data)) + diff --git a/src/compiler/mips/backend-parms.lisp b/src/compiler/mips/backend-parms.lisp new file mode 100644 index 0000000..1b212c4 --- /dev/null +++ b/src/compiler/mips/backend-parms.lisp @@ -0,0 +1,11 @@ +(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) diff --git a/src/compiler/mips/c-call.lisp b/src/compiler/mips/c-call.lisp new file mode 100644 index 0000000..af0d2f8 --- /dev/null +++ b/src/compiler/mips/c-call.lisp @@ -0,0 +1,193 @@ +(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))))))) diff --git a/src/compiler/mips/call.lisp b/src/compiler/mips/call.lisp new file mode 100644 index 0000000..eae7209 --- /dev/null +++ b/src/compiler/mips/call.lisp @@ -0,0 +1,1255 @@ +(in-package "SB!VM") + + +;;;; Interfaces to IR2 conversion: + +;;; Standard-Argument-Location -- Interface +;;; +;;; Return a wired TN describing the N'th full call argument passing +;;; location. +;;; +(!def-vm-support-routine standard-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)) + + +;;;; 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))))) + + + + +;;; 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. + + + +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)) + + +;;;; 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)) + + + +;;;; 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))))) + + +;;;; 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))) + + +;;;; 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))) + + +;;;; 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))) + + + +;;;; 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)) diff --git a/src/compiler/mips/cell.lisp b/src/compiler/mips/cell.lisp new file mode 100644 index 0000000..1151b6c --- /dev/null +++ b/src/compiler/mips/cell.lisp @@ -0,0 +1,267 @@ +(in-package "SB!VM") + + +;;;; Data object ref/set stuff. + +(define-vop (slot) + (:args (object :scs (descriptor-reg))) + (:info name offset lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg any-reg))) + (:generator 1 + (loadw result object offset lowtag))) + +(define-vop (set-slot) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg null zero))) + (:info name offset lowtag) + (:ignore name) + (:results) + (:generator 1 + (storew value object offset lowtag))) + + +;;;; Symbol hacking VOPs: + +;;; The compiler likes to be able to directly SET symbols. +;;; +(define-vop (set cell-set) + (:variant symbol-value-slot other-pointer-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)) + + +;;;; 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))) + + + +;;;; 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)))) + + + +;;;; 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)) + + +;;;; 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)) + + + +;;;; 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) + + + +;;;; 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) + + + diff --git a/src/compiler/mips/char.lisp b/src/compiler/mips/char.lisp new file mode 100644 index 0000000..acfef9e --- /dev/null +++ b/src/compiler/mips/char.lisp @@ -0,0 +1,116 @@ +(in-package "SB!VM") + + + +;;;; Moves and coercions: + +;;; Move a tagged char to an untagged representation. +;;; +(define-vop (move-to-base-char) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (base-char-reg))) + (: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)) + + + +;;;; 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))) + + +;;; 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 :gt)) + diff --git a/src/compiler/mips/debug.lisp b/src/compiler/mips/debug.lisp new file mode 100644 index 0000000..7883ec1 --- /dev/null +++ b/src/compiler/mips/debug.lisp @@ -0,0 +1,131 @@ +(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))) diff --git a/src/compiler/mips/float.lisp b/src/compiler/mips/float.lisp new file mode 100644 index 0000000..0f4c07b --- /dev/null +++ b/src/compiler/mips/float.lisp @@ -0,0 +1,858 @@ +(in-package "SB!VM") + + +;;;; 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))) + + + +;;;; 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)) + + +;;;; 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)) + + +;;;; 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)) + + +;;;; 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)) + + +;;;; 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 :ngt t >/single-float >/double-float) + (frob = :seq nil =/single-float =/double-float)) + + +;;;; 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))) + + +;;;; 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))) + + +;;;; 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)) diff --git a/src/compiler/mips/insts.lisp b/src/compiler/mips/insts.lisp new file mode 100644 index 0000000..a5c90ca --- /dev/null +++ b/src/compiler/mips/insts.lisp @@ -0,0 +1,1344 @@ +(in-package "SB!VM") + +(setf *assem-scheduler-p* t) +(setf *assem-max-locations* 68) + + + +;;;; 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) + + + +;;;; 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) + + + +;;;; 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)) + + +;;;; 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)) + + + +;;;; 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))) + + +;;;; 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))))) + + +;;;; 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))) + + + +;;;; 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))) + + + +;;;; 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)))))) + + +;;;; 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))) + diff --git a/src/compiler/mips/macros.lisp b/src/compiler/mips/macros.lisp new file mode 100644 index 0000000..7f8f077 --- /dev/null +++ b/src/compiler/mips/macros.lisp @@ -0,0 +1,442 @@ +(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)))) + + +;;; 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))) + + + +;;;; 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)))))))) + + +;;;; 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)) + + + +;;;; 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)) + + + +;;;; 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))))) + + +;;; 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))))) + + + +;;;; 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)))))) + diff --git a/src/compiler/mips/memory.lisp b/src/compiler/mips/memory.lisp new file mode 100644 index 0000000..d22ddc2 --- /dev/null +++ b/src/compiler/mips/memory.lisp @@ -0,0 +1,41 @@ +(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))) diff --git a/src/compiler/mips/move.lisp b/src/compiler/mips/move.lisp new file mode 100644 index 0000000..da67e2b --- /dev/null +++ b/src/compiler/mips/move.lisp @@ -0,0 +1,298 @@ +(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)))) + + +;;;; 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)) + + + +;;;; ILLEGAL-MOVE + +;;; This VOP exists just to begin the lifetime of a TN that couldn't be written +;;; legally due to a type error. An error is signalled before this VOP is +;;; so we don't need to do anything (not that there would be anything sensible +;;; to do anyway.) +;;; +(define-vop (illegal-move) + (:args (x) (type)) + (:results (y)) + (:ignore y) + (:vop-var vop) + (:save-p :compute-only) + (:generator 666 + (error-call vop object-not-type-error x type))) + + + +;;;; Moves and coercions: + +;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word +;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer +;;; to a tagged bignum or fixnum. + +;;; Arg is a fixnum, so just shift it. We need a type restriction because some +;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs. +;;; +(define-vop (move-to-word/fixnum) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (signed-reg unsigned-reg))) + (:arg-types tagged-num) + (:note "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)) diff --git a/src/compiler/mips/nlx.lisp b/src/compiler/mips/nlx.lisp new file mode 100644 index 0000000..45286b1 --- /dev/null +++ b/src/compiler/mips/nlx.lisp @@ -0,0 +1,268 @@ +(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)) + + +;;; 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))) + + + +;;;; 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*))) + + +;;;; 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))) diff --git a/src/compiler/mips/parms.lisp b/src/compiler/mips/parms.lisp new file mode 100644 index 0000000..2fd09ce --- /dev/null +++ b/src/compiler/mips/parms.lisp @@ -0,0 +1,159 @@ +(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. + + +;;;; 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) + + +;;;; 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) + +;;;; 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)) diff --git a/src/compiler/mips/pred.lisp b/src/compiler/mips/pred.lisp new file mode 100644 index 0000000..2d9a9c2 --- /dev/null +++ b/src/compiler/mips/pred.lisp @@ -0,0 +1,31 @@ +(in-package "SB!VM") + + +;;;; The Branch VOP. + +;;; The unconditional branch, emitted when we can't drop through to the desired +;;; destination. Dest is the continuation we transfer control to. +;;; +(define-vop (branch) + (:info dest) + (:generator 5 + (inst b dest) + (inst nop))) + + +;;;; Conditional VOPs: + +(define-vop (if-eq) + (:args (x :scs (any-reg descriptor-reg zero null)) + (y :scs (any-reg descriptor-reg zero null))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:translate eq) + (:generator 3 + (if not-p + (inst bne x y target) + (inst beq x y target)) + (inst nop))) + + diff --git a/src/compiler/mips/sanctify.lisp b/src/compiler/mips/sanctify.lisp new file mode 100644 index 0000000..c7ddf94 --- /dev/null +++ b/src/compiler/mips/sanctify.lisp @@ -0,0 +1,27 @@ +;;;; 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) diff --git a/src/compiler/mips/sap.lisp b/src/compiler/mips/sap.lisp new file mode 100644 index 0000000..c8df069 --- /dev/null +++ b/src/compiler/mips/sap.lisp @@ -0,0 +1,323 @@ +(in-package "SB!VM") + + +;;;; Moves and coercions: + +;;; Move a tagged SAP to an untagged representation. +;;; +(define-vop (move-to-sap) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (sap-reg))) + (:note "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)) + + + +;;;; SAP-INT and INT-SAP + +(define-vop (sap-int) + (:args (sap :scs (sap-reg) :target int)) + (:arg-types system-area-pointer) + (:results (int :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate sap-int) + (:policy :fast-safe) + (:generator 1 + (move int sap))) + +(define-vop (int-sap) + (:args (int :scs (unsigned-reg) :target sap)) + (:arg-types unsigned-num) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate int-sap) + (:policy :fast-safe) + (:generator 1 + (move sap int))) + + + +;;;; POINTER+ and POINTER- + +(define-vop (pointer+) + (:translate sap+) + (:args (ptr :scs (sap-reg)) + (offset :scs (signed-reg 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))) + + + +;;;; 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)) + + +;;; 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)))) + diff --git a/src/compiler/mips/show.lisp b/src/compiler/mips/show.lisp new file mode 100644 index 0000000..847d551 --- /dev/null +++ b/src/compiler/mips/show.lisp @@ -0,0 +1,24 @@ +(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)))) diff --git a/src/compiler/mips/static-fn.lisp b/src/compiler/mips/static-fn.lisp new file mode 100644 index 0000000..3cc774d --- /dev/null +++ b/src/compiler/mips/static-fn.lisp @@ -0,0 +1,127 @@ +(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))))) diff --git a/src/compiler/mips/subprim.lisp b/src/compiler/mips/subprim.lisp new file mode 100644 index 0000000..91fef15 --- /dev/null +++ b/src/compiler/mips/subprim.lisp @@ -0,0 +1,47 @@ +(in-package "SB!VM") + + + +;;;; 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) + + + diff --git a/src/compiler/mips/system.lisp b/src/compiler/mips/system.lisp new file mode 100644 index 0000000..8bc6987 --- /dev/null +++ b/src/compiler/mips/system.lisp @@ -0,0 +1,263 @@ +(in-package "SB!VM") + + +;;;; 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)) + + + +;;;; 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))))) + + +;;;; Allocation + +(define-vop (dynamic-space-free-pointer) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate dynamic-space-free-pointer) + (:policy :fast-safe) + (:generator 1 + (move int alloc-tn))) + +(define-vop (binding-stack-pointer-sap) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate binding-stack-pointer-sap) + (:policy :fast-safe) + (:generator 1 + (move int bsp-tn))) + +(define-vop (control-stack-pointer-sap) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate control-stack-pointer-sap) + (:policy :fast-safe) + (:generator 1 + (move int csp-tn))) + + +;;;; Code object frobbing. + +(define-vop (code-instructions) + (:translate code-instructions) + (:policy :fast-safe) + (:args (code :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 10 + (loadw ndescr code 0 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))) + + +;;;; 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))) + + +;;;; 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)))) diff --git a/src/compiler/mips/target-insts.lisp b/src/compiler/mips/target-insts.lisp new file mode 100644 index 0000000..422aa7e --- /dev/null +++ b/src/compiler/mips/target-insts.lisp @@ -0,0 +1,15 @@ +;;;; 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") + diff --git a/src/compiler/mips/type-vops.lisp b/src/compiler/mips/type-vops.lisp new file mode 100644 index 0000000..b5a618e --- /dev/null +++ b/src/compiler/mips/type-vops.lisp @@ -0,0 +1,574 @@ +(in-package "SB!VM") + + + +;;;; 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))))) + + + +;;;; 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) + + +;;;; 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))) + + + +;;;; 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 diff --git a/src/compiler/mips/values.lisp b/src/compiler/mips/values.lisp new file mode 100644 index 0000000..c9427a1 --- /dev/null +++ b/src/compiler/mips/values.lisp @@ -0,0 +1,112 @@ +(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)) diff --git a/src/compiler/mips/vm.lisp b/src/compiler/mips/vm.lisp new file mode 100644 index 0000000..fb2eeb3 --- /dev/null +++ b/src/compiler/mips/vm.lisp @@ -0,0 +1,356 @@ +(in-package "SB!VM") + + +;;;; 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)) + + +;;;; 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)) + + + + +;;;; 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)) + +;;; +;;; 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)))) + + +;;;; 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) + + +;;; 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) diff --git a/src/runtime/Config.mips-linux b/src/runtime/Config.mips-linux new file mode 100644 index 0000000..6f42f33 --- /dev/null +++ b/src/runtime/Config.mips-linux @@ -0,0 +1,22 @@ +# 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 diff --git a/src/runtime/alpha-linux-os.h b/src/runtime/alpha-linux-os.h index c765e08..d428042 100644 --- a/src/runtime/alpha-linux-os.h +++ b/src/runtime/alpha-linux-os.h @@ -2,6 +2,7 @@ #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; diff --git a/src/runtime/hppa-linux-os.h b/src/runtime/hppa-linux-os.h index 97711b6..f0c23ac 100644 --- a/src/runtime/hppa-linux-os.h +++ b/src/runtime/hppa-linux-os.h @@ -2,6 +2,9 @@ #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; diff --git a/src/runtime/linux-os.h b/src/runtime/linux-os.h index 8d05e0b..de53fc0 100644 --- a/src/runtime/linux-os.h +++ b/src/runtime/linux-os.h @@ -38,5 +38,3 @@ typedef int os_vm_prot_t; #define SIG_MEMORY_FAULT SIGSEGV -/* /usr/include/asm/sigcontext.h */ -typedef long os_context_register_t ; diff --git a/src/runtime/mips-arch.c b/src/runtime/mips-arch.c new file mode 100644 index 0000000..a65a381 --- /dev/null +++ b/src/runtime/mips-arch.c @@ -0,0 +1,387 @@ +/* + + $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 + +#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); +} + diff --git a/src/runtime/mips-arch.h b/src/runtime/mips-arch.h new file mode 100644 index 0000000..17c1886 --- /dev/null +++ b/src/runtime/mips-arch.h @@ -0,0 +1,4 @@ +#ifndef _MIPS_ARCH_H +#define _MIPS_ARCH_H + +#endif /* _MIPS_ARCH_H */ diff --git a/src/runtime/mips-assem.S b/src/runtime/mips-assem.S new file mode 100644 index 0000000..2282a91 --- /dev/null +++ b/src/runtime/mips-assem.S @@ -0,0 +1,433 @@ +#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 + + + + + diff --git a/src/runtime/mips-linux-os.c b/src/runtime/mips-linux-os.c new file mode 100644 index 0000000..f92a232 --- /dev/null +++ b/src/runtime/mips-linux-os.c @@ -0,0 +1,95 @@ +/* + * 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 +#include +#include +#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 +#include + +#include +#include +#include +#include +#include + +#include "validate.h" +/* for cacheflush() */ +#include + +/* FIXME: For CAUSEF_BD */ +#include +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"); +} diff --git a/src/runtime/mips-linux-os.h b/src/runtime/mips-linux-os.h new file mode 100644 index 0000000..02d53f0 --- /dev/null +++ b/src/runtime/mips-linux-os.h @@ -0,0 +1,15 @@ +#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 */ diff --git a/src/runtime/mips-lispregs.h b/src/runtime/mips-lispregs.h new file mode 100644 index 0000000..ff9b78a --- /dev/null +++ b/src/runtime/mips-lispregs.h @@ -0,0 +1,58 @@ +/* $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) diff --git a/src/runtime/ppc-linux-os.h b/src/runtime/ppc-linux-os.h index 9c8d319..4f65e16 100644 --- a/src/runtime/ppc-linux-os.h +++ b/src/runtime/ppc-linux-os.h @@ -2,6 +2,7 @@ #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; diff --git a/src/runtime/sparc-linux-os.h b/src/runtime/sparc-linux-os.h index f4f677c..76d9eb6 100644 --- a/src/runtime/sparc-linux-os.h +++ b/src/runtime/sparc-linux-os.h @@ -2,6 +2,7 @@ #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 */ diff --git a/src/runtime/x86-linux-os.h b/src/runtime/x86-linux-os.h index dfd38bd..90b34c0 100644 --- a/src/runtime/x86-linux-os.h +++ b/src/runtime/x86-linux-os.h @@ -2,6 +2,7 @@ #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; diff --git a/version.lisp-expr b/version.lisp-expr index 8257144..5f9fce7 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; 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"