X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmips%2Fmacros.lisp;h=1598bc6c89a8c8b727555e626de9a3e7ef965e07;hb=9b1fade83db8453b75b8c7380eb12ce41b5b889c;hp=ca9f3594fc87023ed8a89e39c0f827d2da827187;hpb=d294785c8e313384513208c1d93a44c3f22a0464;p=sbcl.git

diff --git a/src/compiler/mips/macros.lisp b/src/compiler/mips/macros.lisp
index ca9f359..1598bc6 100644
--- a/src/compiler/mips/macros.lisp
+++ b/src/compiler/mips/macros.lisp
@@ -24,8 +24,9 @@
 ;;; Instruction-like macros.
 
 (defmacro move (dst src &optional (always-emit-code-p nil))
+  #!+sb-doc
   "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P
-  is nil)."
+is nil)."
   (once-only ((n-dst dst)
               (n-src src))
     `(if (location= ,n-dst ,n-src)
@@ -61,8 +62,9 @@
             (- other-pointer-lowtag))))
 
 (defmacro load-type (target source &optional (offset 0))
+  #!+sb-doc
   "Loads the type bits of a pointer into target independent of
-  byte-ordering issues."
+byte-ordering issues."
   (once-only ((n-target target)
               (n-source source)
               (n-offset offset))
@@ -77,6 +79,7 @@
 ;;; return instructions.
 
 (defmacro lisp-jump (function lip)
+  #!+sb-doc
   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
   `(progn
      (inst addu ,lip ,function (- (ash simple-fun-code-offset word-shift)
@@ -85,6 +88,7 @@
      (move code-tn ,function t)))
 
 (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
+  #!+sb-doc
   "Return to RETURN-PC.  LIP is an interior-reg temporary."
   `(progn
      (inst addu ,lip ,return-pc
@@ -96,6 +100,7 @@
 
 
 (defmacro emit-return-pc (label)
+  #!+sb-doc
   "Emit a return-pc header word.  LABEL is the label to use for this return-pc."
   `(progn
      (align n-lowtag-bits)
@@ -124,6 +129,7 @@
           (storew reg cfp-tn offset))))))
 
 (defmacro maybe-load-stack-tn (reg reg-or-stack)
+  #!+sb-doc
   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
   (once-only ((n-reg reg)
               (n-stack reg-or-stack))
@@ -137,21 +143,39 @@
 
 
 ;;;; 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-
-   descriptor temp (which may be randomly used by the body.)  The body is
-   placed inside the PSEUDO-ATOMIC, and presumably initializes the object."
+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-
+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) (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 0 ,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
@@ -194,7 +218,7 @@
 
 
 ;;;; Error Code
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   (defun emit-error-break (vop kind code values)
     (let ((vector (gensym)))
       `((let ((vop ,vop))
@@ -216,12 +240,14 @@
         (align word-shift)))))
 
 (defmacro error-call (vop error-code &rest values)
+  #!+sb-doc
   "Cause an error.  ERROR-CODE is the error to cause."
   (cons 'progn
         (emit-error-break vop error-trap error-code values)))
 
 
 (defmacro cerror-call (vop label error-code &rest values)
+  #!+sb-doc
   "Cause a continuable error.  If the error is continued, execution resumes at
   LABEL."
   `(progn
@@ -230,6 +256,7 @@
        ,@(emit-error-break vop cerror-trap error-code values))))
 
 (defmacro generate-error-code (vop error-code &rest values)
+  #!+sb-doc
   "Generate-Error-Code Error-code Value*
   Emit code for an error with the specified Error-Code and context Values."
   `(assemble (*elsewhere*)
@@ -239,6 +266,7 @@
        start-lab)))
 
 (defmacro generate-cerror-code (vop error-code &rest values)
+  #!+sb-doc
   "Generate-CError-Code Error-code Value*
   Emit code for a continuable error with the specified Error-Code and
   context Values.  If the error is continued, execution resumes after