Simplify (and robustify) regular PACKing

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

diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp
index c84757d..1905a7f 100644 (file)
--- a/src/compiler/ppc/macros.lisp
+++ b/src/compiler/ppc/macros.lisp
@@ -265,7 +265,8 @@
        (inst ori ,result-tn ,result-tn ,lowtag)))
 
 (defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size
-                                            &key (lowtag other-pointer-lowtag))
+                                            &key (lowtag other-pointer-lowtag)
+                                                 stack-allocate-p)
                                  &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
@@ -275,9 +276,14 @@
   (once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn)
               (type-code type-code) (size size) (lowtag lowtag))
     `(pseudo-atomic (,flag-tn)
-       (allocation ,result-tn (pad-data-block ,size) ,lowtag
-                   :temp-tn ,temp-tn
-                   :flag-tn ,flag-tn)
+       (if ,stack-allocate-p
+           (progn
+             (align-csp ,temp-tn)
+             (inst ori ,result-tn csp-tn ,lowtag)
+             (inst addi csp-tn csp-tn (pad-data-block ,size)))
+         (allocation ,result-tn (pad-data-block ,size) ,lowtag
+                     :temp-tn ,temp-tn
+                     :flag-tn ,flag-tn))
        (when ,type-code
          (inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
          (storew ,temp-tn ,result-tn 0 ,lowtag))
@@ -336,6 +342,9 @@
 ;;; trap if ALLOC-TN's negative (handling the deferred interrupt) and
 ;;; using FLAG-TN - minus the large constant - to correct ALLOC-TN.
 (defmacro pseudo-atomic ((flag-tn) &body forms)
+  #!+sb-safepoint-strictly
+  `(progn ,flag-tn ,@forms (emit-safepoint))
+  #!-sb-safepoint-strictly
   `(progn
      (without-scheduling ()
        ;; Extra debugging stuff:
@@ -345,6 +354,7 @@
          (inst twi :ne ,flag-tn 0))
        (inst ori alloc-tn alloc-tn pseudo-atomic-flag))
      ,@forms
+     (inst sync)
      (without-scheduling ()
        (inst subi alloc-tn alloc-tn pseudo-atomic-flag)
        ;; Now test to see if the pseudo-atomic interrupted bit is set.
@@ -353,7 +363,13 @@
      #+debug
      (progn
        (inst andi. ,flag-tn alloc-tn lowtag-mask)
-       (inst twi :ne ,flag-tn 0))))
+       (inst twi :ne ,flag-tn 0))
+     #!+sb-safepoint
+     (emit-safepoint)))
+
+#!+sb-safepoint
+(defun emit-safepoint ()
+  (inst lwz zero-tn null-tn (- (+ 4096 4 other-pointer-lowtag))))
 
 (def!macro with-pinned-objects ((&rest objects) &body body)
   "Arrange with the garbage collector that the pages occupied by
@@ -367,4 +383,5 @@ garbage collection.  This is currently implemented by disabling GC"
     ,@body)
   #!+gencgc
   `(let ((*pinned-objects* (list* ,@objects *pinned-objects*)))
+     (declare (truly-dynamic-extent *pinned-objects*))
      ,@body))