0.9.2.25:

[sbcl.git] / src / compiler / mips / macros.lisp

diff --git a/src/compiler/mips/macros.lisp b/src/compiler/mips/macros.lisp
index 63bd0c3..bfe1c9d 100644 (file)
--- a/src/compiler/mips/macros.lisp
+++ b/src/compiler/mips/macros.lisp
@@ -28,10 +28,10 @@
   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)))))
+    `(if (location= ,n-dst ,n-src)
+        (when ,always-emit-code-p
+          (inst nop))
+        (inst move ,n-dst ,n-src))))
 
 (defmacro def-mem-op (op inst shift load)
   `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
@@ -43,7 +43,8 @@
 (def-mem-op storew sw word-shift nil)
 
 (defmacro load-symbol (reg symbol)
-  `(inst addu ,reg null-tn (static-symbol-offset ,symbol)))
+  (once-only ((reg reg) (symbol symbol))
+    `(inst addu ,reg null-tn (static-symbol-offset ,symbol))))
 
 (defmacro load-symbol-value (reg symbol)
   `(progn
@@ -67,7 +68,7 @@
              (n-offset offset))
     (ecase *backend-byte-order*
       (:little-endian
-       `(inst lbu ,n-target ,n-source ,n-offset ))
+       `(inst lbu ,n-target ,n-source ,n-offset))
       (:big-endian
        `(inst lbu ,n-target ,n-source (+ ,n-offset 3))))))
 
@@ -81,7 +82,7 @@
      (inst addu ,lip ,function (- (ash simple-fun-code-offset word-shift)
                                   fun-pointer-lowtag))
      (inst j ,lip)
-     (move code-tn ,function)))
+     (move code-tn ,function t)))
 
 (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
   "Return to RETURN-PC.  LIP is an interior-reg temporary."
@@ -90,7 +91,7 @@
           (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
      (inst j ,lip)
      ,(if frob-code
-         `(move code-tn ,return-pc)
+         `(move code-tn ,return-pc t)
          '(inst nop))))
 
 
@@ -139,15 +140,17 @@
                                 &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-
+   Result-TN, Flag-Tn must be wired to NL4-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))
-
+  (unless body
+    (bug "empty &body in WITH-FIXED-ALLOCATION"))
+  (once-only ((result-tn result-tn) (temp-tn temp-tn) (size size))
+    `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
+       (inst or ,result-tn alloc-tn other-pointer-lowtag)
+       (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
+       (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
+       ,@body)))
 
 \f
 ;;;; Three Way Comparison
@@ -180,7 +183,7 @@
 
 \f
 ;;;; Error Code
-(eval-when (compile load eval)
+(eval-when (:compile-toplevel :load-toplevel :execute)
   (defun emit-error-break (vop kind code values)
     (let ((vector (gensym)))
       `((let ((vop ,vop))
@@ -250,9 +253,6 @@
      ,@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)
@@ -423,3 +423,12 @@
                 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
           (move result value))))))
 
+
+(defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
+  "Arrange with the garbage collector that the pages occupied by
+OBJECTS will not be moved in memory for the duration of BODY.
+Useful for e.g. foreign calls where another thread may trigger
+garbage collection.  This is currently implemented by disabling GC"
+  (declare (ignore objects))           ;should we eval these for side-effect?
+  `(without-gcing
+    ,@body))