0.9.0.22: more fixed allocation

 * fix remaining WITH-FIXED-ALLOCATIONS with empty bodies. NB: there
    seems to be some doubt whether this is actually the right thing to
    do, as CMUCL has at least in sparc/float.lisp in MOVE-FOO-FLOAT a
    commit message by William Lott indicating that this was
    intentional "to avoid handling a trap within P-A". Which trap that
    would be is unclear, but hopefully we will eventually rediscover
    the cases where this is intentional.
 * make WITH-FIXED-ALLOCATION signal a BUG if body is empty to catch
    this in the future.
 * sprinkle WITH-FIXED-ALLOCATION with FAIRY-D^WONCE-ONLY on platforms
    that didn't have it yet.

diff --git a/src/compiler/alpha/macros.lisp b/src/compiler/alpha/macros.lisp
index a251501..b964659 100644 (file)
--- a/src/compiler/alpha/macros.lisp
+++ b/src/compiler/alpha/macros.lisp
@@ -169,11 +169,14 @@
 ;;; presumably initializes the object.
 (defmacro with-fixed-allocation ((result-tn temp-tn widetag size)
                                 &body body)
-  `(pseudo-atomic (:extra (pad-data-block ,size))
-     (inst bis alloc-tn other-pointer-lowtag ,result-tn)
-     (inst li (logior (ash (1- ,size) n-widetag-bits) ,widetag) ,temp-tn)
-     (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 (:extra (pad-data-block ,size))
+       (inst bis alloc-tn other-pointer-lowtag ,result-tn)
+       (inst li (logior (ash (1- ,size) n-widetag-bits) ,widetag) ,temp-tn)
+       (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
+       ,@body)))
 \f
 ;;;; error code
 (eval-when (:compile-toplevel :load-toplevel :execute) 

diff --git a/src/compiler/hppa/macros.lisp b/src/compiler/hppa/macros.lisp
index d0bebfc..b0ceb5a 100644 (file)
--- a/src/compiler/hppa/macros.lisp
+++ b/src/compiler/hppa/macros.lisp
@@ -125,6 +125,8 @@
   Result-TN, 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."
+  (unless body
+    (bug "empty &body in WITH-FIXED-ALLOCATION"))
   (once-only ((result-tn result-tn) (temp-tn temp-tn)
              (type-code type-code) (size size))
     `(pseudo-atomic (:extra (pad-data-block ,size))

diff --git a/src/compiler/mips/alloc.lisp b/src/compiler/mips/alloc.lisp
index 784a469..9592288 100644 (file)
--- a/src/compiler/mips/alloc.lisp
+++ b/src/compiler/mips/alloc.lisp
@@ -129,9 +129,8 @@
   (: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)))
+    (with-fixed-allocation (result pa-flag temp value-cell-header-widetag value-cell-size)
+      (storew value result value-cell-value-slot other-pointer-lowtag))))
 
 \f
 ;;;; Automatic allocators for primitive objects.

diff --git a/src/compiler/mips/macros.lisp b/src/compiler/mips/macros.lisp
index 04d697f..e582930 100644 (file)
--- a/src/compiler/mips/macros.lisp
+++ b/src/compiler/mips/macros.lisp
@@ -142,12 +142,14 @@
    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

diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp
index 5bb91bf..713e6a3 100644 (file)
--- a/src/compiler/ppc/alloc.lisp
+++ b/src/compiler/ppc/alloc.lisp
@@ -133,9 +133,8 @@
   (:temporary (:sc non-descriptor-reg :offset nl3-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)))
+    (with-fixed-allocation (result pa-flag temp value-cell-header-widetag value-cell-size)
+      (storew value result value-cell-value-slot other-pointer-lowtag))))
 
 
 \f

diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp
index a4da8d3..a4293d2 100644 (file)
--- a/src/compiler/ppc/macros.lisp
+++ b/src/compiler/ppc/macros.lisp
@@ -139,6 +139,8 @@
   Result-TN, 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."
+  (unless body
+    (bug "empty &body in WITH-FIXED-ALLOCATION"))
   (once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn)
              (type-code type-code) (size size))
     `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))

diff --git a/src/compiler/sparc/macros.lisp b/src/compiler/sparc/macros.lisp
index 70e1fbd..5ca6733 100644 (file)
--- a/src/compiler/sparc/macros.lisp
+++ b/src/compiler/sparc/macros.lisp
@@ -140,6 +140,8 @@
   Result-TN, 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."
+  (unless body
+    (bug "empty &body in WITH-FIXED-ALLOCATION"))
   (once-only ((result-tn result-tn) (temp-tn temp-tn)
              (type-code type-code) (size size))
     `(pseudo-atomic (:extra (pad-data-block ,size))

diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp
index dc0247f..ff53bf9 100644 (file)
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -214,14 +214,17 @@
 ;;; header having the specified WIDETAG value. The result is placed in
 ;;; RESULT-TN.
 (defmacro with-fixed-allocation ((result-tn widetag size &optional inline)
-                                &rest forms)
-  `(pseudo-atomic
-    (allocation ,result-tn (pad-data-block ,size) ,inline)
-    (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
-           ,result-tn)
-    (inst lea ,result-tn
-         (make-ea :qword :base ,result-tn :disp other-pointer-lowtag))
-    ,@forms))
+                                &body forms)
+  (unless forms
+    (bug "empty &body in WITH-FIXED-ALLOCATION"))
+  (once-only ((result-tn result-tn) (size size))
+    `(pseudo-atomic
+      (allocation ,result-tn (pad-data-block ,size) ,inline)
+      (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
+             ,result-tn)
+      (inst lea ,result-tn
+           (make-ea :qword :base ,result-tn :disp other-pointer-lowtag))
+      ,@forms)))
 \f
 ;;;; error code
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp
index d252203..378ba2d 100644 (file)
--- a/src/compiler/x86/macros.lisp
+++ b/src/compiler/x86/macros.lisp
@@ -240,14 +240,17 @@
 ;;; header having the specified WIDETAG value. The result is placed in
 ;;; RESULT-TN.
 (defmacro with-fixed-allocation ((result-tn widetag size &optional inline)
-                                &rest forms)
-  `(pseudo-atomic
-    (allocation ,result-tn (pad-data-block ,size) ,inline)
-    (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
-           ,result-tn)
-    (inst lea ,result-tn
-     (make-ea :byte :base ,result-tn :disp other-pointer-lowtag))
-    ,@forms))
+                                &body forms)
+  (unless forms
+    (bug "empty &body in WITH-FIXED-ALLOCATION"))
+  (once-only ((result-tn result-tn) (size size))
+    `(pseudo-atomic
+      (allocation ,result-tn (pad-data-block ,size) ,inline)
+      (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
+             ,result-tn)
+      (inst lea ,result-tn
+           (make-ea :byte :base ,result-tn :disp other-pointer-lowtag))
+      ,@forms)))
 \f
 ;;;; error code
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

diff --git a/version.lisp-expr b/version.lisp-expr
index 2010f31..0f2355c 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".)
-"0.9.0.21"
+"0.9.0.22"