X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fmacros.lisp;h=801c905da76b1ec4ee29b82014f9c5dc01806e56;hb=37b93fe46f304244d1c69c06b82a22252e393630;hp=7711130233df5a81669984467467cbfe9140fede;hpb=4c400df29038a283e6b4df2d835d5b9c5201d0dd;p=sbcl.git

diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp
index 7711130..801c905 100644
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -20,10 +20,12 @@
               (n-src src))
     `(unless (location= ,n-dst ,n-src)
        (sc-case ,n-dst
-         (single-reg
-          (inst movss ,n-dst ,n-src))
-         (double-reg
-          (inst movsd ,n-dst ,n-src))
+         ((single-reg complex-single-reg)
+          (aver (xmm-register-p ,n-src))
+          (inst movaps ,n-dst ,n-src))
+         ((double-reg complex-double-reg)
+          (aver (xmm-register-p ,n-src))
+          (inst movapd ,n-dst ,n-src))
          (t
           (inst mov ,n-dst ,n-src))))))
 
@@ -39,11 +41,8 @@
   (once-only ((value value))
     `(cond ((and (integerp ,value)
                  (not (typep ,value '(signed-byte 32))))
-            (multiple-value-bind (lo hi) (dwords-for-quad ,value)
-              (inst mov (make-ea-for-object-slot-half
-                         ,ptr ,slot ,lowtag) lo)
-              (inst mov (make-ea-for-object-slot-half
-                         ,ptr (+ ,slot 1/2) ,lowtag) hi)))
+            (inst mov temp-reg-tn ,value)
+            (inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) temp-reg-tn))
            (t
             (inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value)))))
 
@@ -100,14 +99,14 @@
 (defmacro load-binding-stack-pointer (reg)
   #!+sb-thread
   `(inst mov ,reg (make-ea :qword :base thread-base-tn
-                   :disp (* 8 thread-binding-stack-pointer-slot)))
+                   :disp (* n-word-bytes thread-binding-stack-pointer-slot)))
   #!-sb-thread
   `(load-symbol-value ,reg *binding-stack-pointer*))
 
 (defmacro store-binding-stack-pointer (reg)
   #!+sb-thread
   `(inst mov (make-ea :qword :base thread-base-tn
-              :disp (* 8 thread-binding-stack-pointer-slot))
+              :disp (* n-word-bytes thread-binding-stack-pointer-slot))
     ,reg)
   #!-sb-thread
   `(store-symbol-value ,reg *binding-stack-pointer*))
@@ -234,7 +233,7 @@
 ;;;; error code
 (defun emit-error-break (vop kind code values)
   (assemble ()
-    #!-darwin
+    #!-ud2-breakpoints
     (inst int 3)                  ; i386 breakpoint instruction
     ;; On Darwin, we need to use #x0b0f instead of int3 in order
     ;; to generate a SIGILL instead of a SIGTRAP as darwin/x86
@@ -242,7 +241,7 @@
     ;; handlers. Hopefully this will be fixed by Apple at a
     ;; later date. Do the same on x86-64 as we do on x86 until this gets
     ;; sorted out.
-    #!+darwin
+    #!+ud2-breakpoints
     (inst word #x0b0f)
     ;; The return PC points here; note the location for the debugger.
     (when vop
@@ -290,18 +289,26 @@
        (progn ,@body)
        (pseudo-atomic ,@body)))
 
+;;; Unsafely clear pa flags so that the image can properly lose in a
+;;; pa section.
+#!+sb-thread
+(defmacro %clear-pseudo-atomic ()
+  '(inst mov (make-ea :qword :base thread-base-tn
+              :disp (* n-word-bytes thread-pseudo-atomic-bits-slot))
+    0))
+
 #!+sb-thread
 (defmacro pseudo-atomic (&rest forms)
   (with-unique-names (label)
     `(let ((,label (gen-label)))
        (inst mov (make-ea :qword
                           :base thread-base-tn
-                          :disp (* 8 thread-pseudo-atomic-bits-slot))
+                          :disp (* n-word-bytes thread-pseudo-atomic-bits-slot))
              rbp-tn)
        ,@forms
        (inst xor (make-ea :qword
                           :base thread-base-tn
-                          :disp (* 8 thread-pseudo-atomic-bits-slot))
+                          :disp (* n-word-bytes thread-pseudo-atomic-bits-slot))
              rbp-tn)
        (inst jmp :z ,label)
        ;; if PAI was set, interrupts were disabled at the same time
@@ -355,6 +362,7 @@
        (:generator 5
          (move rax old-value)
          (inst cmpxchg (make-ea :qword :base object :index index
+                                :scale (ash 1 (- word-shift n-fixnum-tag-bits))
                                 :disp (- (* ,offset n-word-bytes) ,lowtag))
                new-value :lock)
          (move value rax)))))
@@ -372,6 +380,7 @@
        (:result-types ,el-type)
        (:generator 3                    ; pw was 5
          (inst mov value (make-ea :qword :base object :index index
+                                  :scale (ash 1 (- word-shift n-fixnum-tag-bits))
                                   :disp (- (* ,offset n-word-bytes)
                                            ,lowtag)))))
      (define-vop (,(symbolicate name "-C"))
@@ -406,6 +415,7 @@
        (:result-types ,el-type)
        (:generator 3                    ; pw was 5
          (inst mov value (make-ea :qword :base object :index index
+                                  :scale (ash 1 (- word-shift n-fixnum-tag-bits))
                                   :disp (- (* (+ ,offset offset) n-word-bytes)
                                            ,lowtag)))))
      (define-vop (,(symbolicate name "-C"))
@@ -440,6 +450,7 @@
        (:result-types ,el-type)
        (:generator 4                    ; was 5
          (inst mov (make-ea :qword :base object :index index
+                            :scale (ash 1 (- word-shift n-fixnum-tag-bits))
                             :disp (- (* ,offset n-word-bytes) ,lowtag))
                value)
          (move result value)))
@@ -482,6 +493,7 @@
        (:result-types ,el-type)
        (:generator 4                    ; was 5
          (inst mov (make-ea :qword :base object :index index
+                            :scale (ash 1 (- word-shift n-fixnum-tag-bits))
                             :disp (- (* (+ ,offset offset) n-word-bytes) ,lowtag))
                value)
          (move result value)))
@@ -517,10 +529,11 @@ Useful for e.g. foreign calls where another thread may trigger
 collection."
   (if objects
       (let ((pins (make-gensym-list (length objects)))
-            (wpo (block-gensym "WPO")))
+            (wpo (gensym "WITH-PINNED-OBJECTS-THUNK")))
         ;; BODY is stuffed in a function to preserve the lexical
         ;; environment.
         `(flet ((,wpo () (progn ,@body)))
+           (declare (muffle-conditions compiler-note))
            ;; PINS are dx-allocated in case the compiler for some
            ;; unfathomable reason decides to allocate value-cells
            ;; for them -- since we have DX value-cells on x86oid