1.0.24.12: adding and fixing the HPUX/HPPA build target

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

diff --git a/src/compiler/hppa/macros.lisp b/src/compiler/hppa/macros.lisp
index 95f7563..0360de0 100644 (file)
--- a/src/compiler/hppa/macros.lisp
+++ b/src/compiler/hppa/macros.lisp
@@ -54,6 +54,11 @@
     (:big-endian
      `(inst ldb (+ ,offset (1- n-word-bytes)) ,source ,target))))
 
+(defmacro set-lowtag (tag src dst)
+  `(progn
+     (inst move ,src ,dst)
+     (inst dep ,tag 31 n-lowtag-bits ,dst)))
+
 ;;; Macros to handle the fact that we cannot use the machine native call and
 ;;; return instructions.
 
@@ -80,7 +85,7 @@
   "Emit a return-pc header word.  LABEL is the label to use for this
    return-pc."
   `(progn
-     (align n-lowtag-bits)
+     (emit-alignment n-lowtag-bits)
      (emit-label ,label)
      (inst lra-header-word)))
 
@@ -118,23 +123,49 @@
 \f
 ;;;; Storage allocation:
 
-(defmacro with-fixed-allocation ((result-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)
+                                       maybe-write)
                                  &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, 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"))
+word header having the specified Type-Code.  The result is placed in
+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."
+  (declare (ignore flag-tn))
   (once-only ((result-tn result-tn) (temp-tn temp-tn)
-              (type-code type-code) (size size))
-    `(pseudo-atomic (:extra (pad-data-block ,size))
-       (inst move alloc-tn ,result-tn)
-       (inst dep other-pointer-lowtag 31 3 ,result-tn)
-       (inst li (logior (ash (1- ,size) n-widetag-bits) ,type-code) ,temp-tn)
-       (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
-       ,@body)))
+              (type-code type-code) (size size)
+              (lowtag lowtag))
+    (let ((write-body `((inst li (logior (ash (1- ,size) n-widetag-bits) ,type-code) ,temp-tn)
+                        (storew ,temp-tn ,result-tn 0 ,lowtag))))
+      `(if ,dynamic-extent-p
+         (pseudo-atomic ()
+           (align-csp ,temp-tn)
+           (set-lowtag ,lowtag csp-tn ,result-tn)
+           (inst addi (pad-data-block ,size) csp-tn csp-tn)
+           ,@(if maybe-write
+               `((when ,type-code ,@write-body))
+               write-body)
+           ,@body)
+         (pseudo-atomic (:extra (pad-data-block ,size))
+           (set-lowtag ,lowtag alloc-tn ,result-tn)
+           ,@(if maybe-write
+               `((when ,type-code ,@write-body))
+               write-body)
+           ,@body)))))
+
+;; is used for stack allocation of dynamic-extent objects
+; FIX-lav, if using defun, atleast surround in assembly-form ? macro better ?
+(defun align-csp (temp)
+  (declare (ignore temp))
+  (let ((aligned (gen-label)))
+    (inst extru csp-tn 31 n-lowtag-bits zero-tn :<>)
+    (inst b aligned :nullify t)
+    (inst addi n-word-bytes csp-tn csp-tn)
+    (storew zero-tn csp-tn -1)
+    (emit-label aligned)))
 
 \f
 ;;;; Error Code
@@ -157,7 +188,7 @@
           (inst byte (length ,vector))
           (dotimes (i (length ,vector))
             (inst byte (aref ,vector i))))
-        (align word-shift)))))
+        (emit-alignment word-shift)))))
 
 (defmacro error-call (vop error-code &rest values)
   "Cause an error.  ERROR-CODE is the error to cause."
@@ -367,7 +398,7 @@
            (move value result))))))
 
 
-(defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
+(def!macro 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