1.0.9.22: Dynamic-extent value-cells for MIPS.

diff --git a/src/compiler/mips/alloc.lisp b/src/compiler/mips/alloc.lisp
index 8b1cff9..fdeb152 100644 (file)
--- a/src/compiler/mips/alloc.lisp
+++ b/src/compiler/mips/alloc.lisp
@@ -118,7 +118,7 @@
   (: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)
+    (with-fixed-allocation (result pa-flag temp fdefn-widetag fdefn-size nil)
       (inst li temp (make-fixup "undefined_tramp" :foreign))
       (storew name result fdefn-name-slot other-pointer-lowtag)
       (storew null-tn result fdefn-fun-slot other-pointer-lowtag)
@@ -153,12 +153,11 @@
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
   (:info stack-allocate-p)
-  (:ignore stack-allocate-p)
   (:results (result :scs (descriptor-reg)))
   (:generator 10
-    (with-fixed-allocation (result pa-flag temp value-cell-header-widetag value-cell-size)
+    (with-fixed-allocation (result pa-flag temp value-cell-header-widetag
+                            value-cell-size stack-allocate-p)
       (storew value result value-cell-value-slot other-pointer-lowtag))))
-
 \f
 ;;;; Automatic allocators for primitive objects.
 

diff --git a/src/compiler/mips/float.lisp b/src/compiler/mips/float.lisp
index 1f406c5..56323bb 100644 (file)
--- a/src/compiler/mips/float.lisp
+++ b/src/compiler/mips/float.lisp
@@ -78,7 +78,7 @@
   (:variant-vars double-p size type data)
   (:note "float to pointer coercion")
   (:generator 13
-    (with-fixed-allocation (y pa-flag ndescr type size)
+    (with-fixed-allocation (y pa-flag ndescr type size nil)
       (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))))))
@@ -259,7 +259,7 @@
   (:note "complex single float to pointer coercion")
   (:generator 13
     (with-fixed-allocation (y pa-flag ndescr complex-single-float-widetag
-                              complex-single-float-size)
+                              complex-single-float-size nil)
       (let ((real-tn (complex-single-reg-real-tn x)))
         (inst swc1 real-tn y (- (* complex-single-float-real-slot
                                    n-word-bytes)
@@ -279,7 +279,7 @@
   (:note "complex double float to pointer coercion")
   (:generator 13
     (with-fixed-allocation (y pa-flag ndescr complex-double-float-widetag
-                              complex-double-float-size)
+                              complex-double-float-size nil)
       (let ((real-tn (complex-double-reg-real-tn x)))
         (str-double real-tn y (- (* complex-double-float-real-slot
                                     n-word-bytes)

diff --git a/src/compiler/mips/macros.lisp b/src/compiler/mips/macros.lisp
index 161f4fe..9c60db9 100644 (file)
--- a/src/compiler/mips/macros.lisp
+++ b/src/compiler/mips/macros.lisp
@@ -143,8 +143,11 @@
 
 \f
 ;;;; Storage allocation:
-(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
+(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code
+                                  size dynamic-extent-p
+                                  &key (lowtag other-pointer-lowtag))
                                  &body body)
+  #!+sb-doc
   "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 NL4-OFFSET, and Temp-TN is a non-
@@ -152,12 +155,28 @@
    placed inside the PSEUDO-ATOMIC, and presumably initializes the object."
   (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)))
+  (once-only ((result-tn result-tn) (flag-tn flag-tn) (temp-tn temp-tn)
+              (type-code type-code) (size size)
+              (dynamic-extent-p dynamic-extent-p)
+              (lowtag lowtag))
+    `(if ,dynamic-extent-p
+         (pseudo-atomic (,flag-tn)
+           (align-csp ,temp-tn)
+           (inst or ,result-tn csp-tn ,lowtag)
+           (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
+           (inst addu csp-tn (pad-data-block ,size))
+           (storew ,temp-tn ,result-tn 0 ,lowtag)
+           ,@body)
+         (pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
+           ;; The pseudo-atomic bit in alloc-tn is set.  If the lowtag also
+           ;; has a 1 bit in the same position, we're all set.  Otherwise,
+           ;; we need to subtract the pseudo-atomic bit.
+           (inst or ,result-tn alloc-tn ,lowtag)
+           (unless (logbitp (1- n-lowtag-bits) ,lowtag)
+                   (inst sub ,result-tn 1))
+           (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
+           (storew ,temp-tn ,result-tn 0 ,lowtag)
+           ,@body))))
 
 (defun align-csp (temp)
   ;; is used for stack allocation of dynamic-extent objects

diff --git a/src/compiler/mips/move.lisp b/src/compiler/mips/move.lisp
index dcaae73..b839199 100644 (file)
--- a/src/compiler/mips/move.lisp
+++ b/src/compiler/mips/move.lisp
@@ -210,7 +210,7 @@
       (inst sll y x 2)
 
       (with-fixed-allocation
-          (y pa-flag temp bignum-widetag (1+ bignum-digits-offset))
+          (y pa-flag temp bignum-widetag (1+ bignum-digits-offset) nil)
         (storew x y bignum-digits-offset other-pointer-lowtag))
       (inst b done)
       (inst nop)

diff --git a/src/compiler/mips/sap.lisp b/src/compiler/mips/sap.lisp
index ad72a85..144e618 100644 (file)
--- a/src/compiler/mips/sap.lisp
+++ b/src/compiler/mips/sap.lisp
@@ -32,7 +32,7 @@
   (:results (res :scs (descriptor-reg)))
   (:note "SAP to pointer coercion")
   (:generator 20
-    (with-fixed-allocation (res pa-flag ndescr sap-widetag sap-size)
+    (with-fixed-allocation (res pa-flag ndescr sap-widetag sap-size nil)
       (storew sap res sap-pointer-slot other-pointer-lowtag))))
 
 (define-move-vop move-from-sap :move

diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 3ac193f..8579383 100644 (file)
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -130,7 +130,7 @@
 
 (defun-with-dx dx-value-cell (x)
   ;; Not implemented everywhere, yet.
-  #+(or x86 x86-64)
+  #+(or x86 x86-64 mips)
   (let ((cell x))
     (declare (dynamic-extent cell))
     (flet ((f ()

diff --git a/version.lisp-expr b/version.lisp-expr
index bb36821..485c50d 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.9.21"
+"1.0.9.22"