X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fmacros.lisp;h=03da6d7df6a87881aedb28d954788bc12530d5d8;hb=cd12bb346dbbd1e077ed3e14a9db4e1cc227c244;hp=9857d1543137040a6464468cf7b24fe0cbe1346f;hpb=c6538bf61955a67d0145aa3e6c937f6dd03f9e51;p=sbcl.git

diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp
index 9857d15..03da6d7 100644
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -138,30 +138,31 @@
 ;;; node-var then it is used to make an appropriate speed vs size
 ;;; decision.
 
-(defun allocation-dynamic-extent (alloc-tn size)
+(defun allocation-dynamic-extent (alloc-tn size lowtag)
   (inst sub rsp-tn size)
   ;; see comment in x86/macros.lisp implementation of this
   (inst and rsp-tn #.(lognot lowtag-mask))
   (aver (not (location= alloc-tn rsp-tn)))
-  (inst mov alloc-tn rsp-tn)
+  (inst lea alloc-tn (make-ea :byte :base rsp-tn :disp lowtag))
   (values))
 
 ;;; This macro should only be used inside a pseudo-atomic section,
 ;;; which should also cover subsequent initialization of the
 ;;; object.
-(defun allocation-tramp (alloc-tn size &optional ignored)
-  (declare (ignore ignored))
+(defun allocation-tramp (alloc-tn size lowtag)
   (inst push size)
   (inst lea temp-reg-tn (make-ea :qword
                             :disp (make-fixup "alloc_tramp" :foreign)))
   (inst call temp-reg-tn)
   (inst pop alloc-tn)
+  (when lowtag
+    (inst lea alloc-tn (make-ea :byte :base alloc-tn :disp lowtag)))
   (values))
 
-(defun allocation (alloc-tn size &optional ignored dynamic-extent)
+(defun allocation (alloc-tn size &optional ignored dynamic-extent lowtag)
   (declare (ignore ignored))
   (when dynamic-extent
-    (allocation-dynamic-extent alloc-tn size)
+    (allocation-dynamic-extent alloc-tn size lowtag)
     (return-from allocation (values)))
   (let ((NOT-INLINE (gen-label))
         (DONE (gen-label))
@@ -188,7 +189,7 @@
                   :scale 1 :disp
                   (make-fixup "boxed_region" :foreign 8))))
     (cond (in-elsewhere
-           (allocation-tramp alloc-tn size))
+           (allocation-tramp alloc-tn size lowtag))
           (t
            (inst mov temp-reg-tn free-pointer)
            (if (tn-p size)
@@ -201,17 +202,19 @@
            (inst cmp end-addr alloc-tn)
            (inst jmp :be NOT-INLINE)
            (inst mov free-pointer alloc-tn)
-           (inst mov alloc-tn temp-reg-tn)
+           (if lowtag
+               (inst lea alloc-tn (make-ea :byte :base temp-reg-tn :disp lowtag))
+               (inst mov alloc-tn temp-reg-tn))
            (emit-label DONE)
            (assemble (*elsewhere*)
              (emit-label NOT-INLINE)
              (cond ((numberp size)
-                    (allocation-tramp alloc-tn size))
+                    (allocation-tramp alloc-tn size lowtag))
                    (t
                     (inst sub alloc-tn free-pointer)
-                    (allocation-tramp alloc-tn alloc-tn)))
-             (inst jmp DONE))
-           (values)))))
+                    (allocation-tramp alloc-tn alloc-tn lowtag)))
+             (inst jmp DONE))))
+    (values)))
 
 ;;; Allocate an other-pointer object of fixed SIZE with a single word
 ;;; header having the specified WIDETAG value. The result is placed in
@@ -222,11 +225,10 @@
     (bug "empty &body in WITH-FIXED-ALLOCATION"))
   (once-only ((result-tn result-tn) (size size) (stack-allocate-p stack-allocate-p))
     `(maybe-pseudo-atomic ,stack-allocate-p
-      (allocation ,result-tn (pad-data-block ,size) ,inline ,stack-allocate-p)
+      (allocation ,result-tn (pad-data-block ,size) ,inline ,stack-allocate-p
+                  other-pointer-lowtag)
       (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))
+              ,result-tn 0 other-pointer-lowtag)
       ,@forms)))
 
 ;;;; error code
@@ -354,11 +356,9 @@
        (:result-types ,el-type)
        (:generator 5
          (move rax old-value)
-         #!+sb-thread
-         (inst lock)
          (inst cmpxchg (make-ea :qword :base object :index index
                                 :disp (- (* ,offset n-word-bytes) ,lowtag))
-               new-value)
+               new-value :lock)
          (move value rax)))))
 
 (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)