X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fmips%2Finsts.lisp;h=63332dbd729220cdf361aecdac9c6946b9ba4090;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=6ae9eb809d16307f4e5483b8da8ba21bb9687815;hpb=ed3bd9c7d61a3c1bf8ad81d82a671359117bd235;p=sbcl.git

diff --git a/src/compiler/mips/insts.lisp b/src/compiler/mips/insts.lisp
index 6ae9eb8..63332db 100644
--- a/src/compiler/mips/insts.lisp
+++ b/src/compiler/mips/insts.lisp
@@ -1,9 +1,18 @@
+;;; the instruction set definition for MIPS
+
+;;;; 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")
 
 (setf *assem-scheduler-p* t)
 (setf *assem-max-locations* 68)
-
-
 
 ;;;; Constants, types, conversion functions, some disassembler stuff.
 
@@ -592,19 +601,58 @@
 ;;;; 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)))))
+  (emit-chooser
+   segment 20 2
+      #'(lambda (segment posn magic-value)
+	  (declare (ignore magic-value))
+          (let ((delta (ash (- (label-position target) (+ posn 4)) -2)))
+	    (when (typep delta '(signed-byte 16))
+	      (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))))
+	      t)))
+      #'(lambda (segment posn)
+	  (declare (ignore posn))
+	  (let ((linked))
+	    ;; invert branch condition
+	    (if (or (= opcode bcond-op) (= opcode cop1-op))
+		(setf r2 (logxor r2 #b00001))
+		(setf opcode (logxor opcode #b00001)))
+	    ;; check link flag
+	    (if (= opcode bcond-op)
+		(if (logand r2 #b10000)
+		    (progn (setf r2 (logand r2 #b01111))
+			   (setf linked t))))
+	    (emit-immediate-inst segment
+				 opcode
+				 (if (fixnump r1) r1 (reg-tn-encoding r1))
+				 (if (fixnump r2) r2 (reg-tn-encoding r2))
+				 4)
+	    (emit-nop segment)
+	    (emit-back-patch segment 8
+	      #'(lambda (segment posn)
+		  (declare (ignore posn))
+		  (emit-immediate-inst segment #b001111 0
+				       (reg-tn-encoding lip-tn)
+				       (ldb (byte 16 16)
+					    (label-position target)))
+		  (emit-immediate-inst segment #b001101 0
+				       (reg-tn-encoding lip-tn)
+				       (ldb (byte 16 0)
+					    (label-position target)))))
+	    (emit-register-inst segment special-op (reg-tn-encoding lip-tn)
+				0 (if linked 31 0) 0
+				(if linked #b001001 #b001000))))))
 
 (define-instruction b (segment target)
   (:declare (type label target))
@@ -622,18 +670,18 @@
 		       (immediate nil :type 'relative-label))
 	    '(:name :tab immediate))
   (:attributes branch)
+  (:dependencies (writes :r31))
   (: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))
+  (:dependencies (reads r1) (if target (reads r2-or-target)))
   (:delay 1)
   (:emitter
    (unless target
@@ -647,7 +695,7 @@
 	    (type (or label null) target))
   (:printer immediate ((op #b000101) (immediate nil :type 'relative-label)))
   (:attributes branch)
-  (:dependencies (reads r1) (reads r2-or-target))
+  (:dependencies (reads r1) (if target (reads r2-or-target)))
   (:delay 1)
   (:emitter
    (unless target
@@ -977,10 +1025,8 @@
     (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))
+           (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
+                                                vector 0 length)
            (collect ((sc-offsets)
                      (lengths))
              (lengths 1)                ; the length byte