-;;;; a bunch of handy macros for the x86
+;;;; a bunch of handy macros for x86-64
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;; instruction-like macros
-(defmacro move (dst src)
+;;; This used to be a macro (and still is on the other platforms) but
+;;; the support for SC-dependent move instructions needed here makes
+;;; that expand into so large an expression that the resulting code
+;;; bloat is not justifiable.
+(defun move (dst src)
#!+sb-doc
"Move SRC into DST unless they are location=."
- (once-only ((n-dst dst)
- (n-src src))
- `(unless (location= ,n-dst ,n-src)
- (sc-case ,n-dst
- ((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))))))
+ (unless (location= dst src)
+ (sc-case dst
+ ((single-reg complex-single-reg)
+ (aver (xmm-register-p src))
+ (inst movaps dst src))
+ ((double-reg complex-double-reg)
+ (aver (xmm-register-p src))
+ (inst movapd dst src))
+ #!+sb-simd-pack
+ ((int-sse-reg sse-reg)
+ (aver (xmm-register-p src))
+ (inst movdqa dst src))
+ #!+sb-simd-pack
+ ((single-sse-reg double-sse-reg)
+ (aver (xmm-register-p src))
+ (inst movaps dst src))
+ (t
+ (inst mov dst src)))))
(defmacro make-ea-for-object-slot (ptr slot lowtag)
`(make-ea :qword :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
(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)))))
(defmacro popw (ptr &optional (slot 0) (lowtag 0))
`(inst pop (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
+
+(defun call-indirect (offset)
+ (let ((ea (make-ea :qword :disp offset)))
+ (cond ((immediate32-p offset)
+ (inst call ea))
+ (t
+ (inst mov temp-reg-tn ea)
+ (inst call temp-reg-tn)))))
\f
;;;; macros to generate useful values
(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*))
(n-offset offset))
(ecase *backend-byte-order*
(:little-endian
- `(inst mov ,n-target
+ `(inst movzx ,n-target
(make-ea :byte :base ,n-source :disp ,n-offset)))
(:big-endian
- `(inst mov ,n-target
+ `(inst movzx ,n-target
(make-ea :byte :base ,n-source
:disp (+ ,n-offset (1- n-word-bytes))))))))
\f
#!+sb-thread
(defmacro %clear-pseudo-atomic ()
'(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))
0))
+#!+sb-safepoint
+(defun emit-safepoint ()
+ (inst test al-tn (make-ea :byte :disp sb!vm::gc-safepoint-page-addr)))
+
#!+sb-thread
(defmacro pseudo-atomic (&rest forms)
+ #!+sb-safepoint-strictly
+ `(progn ,@forms (emit-safepoint))
+ #!-sb-safepoint-strictly
(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
;; using the process signal mask.
(inst break pending-interrupt-trap)
- (emit-label ,label))))
+ (emit-label ,label)
+ #!+sb-safepoint
+ ;; In this case, when allocation thinks a GC should be done, it
+ ;; does not mark PA as interrupted, but schedules a safepoint
+ ;; trap instead. Let's take the opportunity to trigger that
+ ;; safepoint right now.
+ (emit-safepoint))))
#!-sb-thread
(: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)))))
(: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"))
(: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"))
(: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)))
(: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)))
collection."
(if objects
(let ((pins (make-gensym-list (length objects)))
- (wpo (block-gensym "WPO")))
+ (wpo (sb!xc:gensym "WITH-PINNED-OBJECTS-THUNK")))
;; BODY is stuffed in a function to preserve the lexical
;; environment.
`(flet ((,wpo () (progn ,@body)))
projects / sbcl.git / blobdiff