(emit-label get-tls-index-lock)
(inst mov target 1)
(zeroize rax-tn)
- (inst lock)
- (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) target)
+ (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) target :lock)
(inst jmp :ne get-tls-index-lock)
;; The symbol is now in OTHER.
(inst pop other)
(emit-label get-tls-index-lock)
(inst mov target 1)
(inst xor eax-tn eax-tn)
- (inst lock)
- (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) target)
+ (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) target :lock)
(inst jmp :ne get-tls-index-lock)
;; The symbol is now in OTHER.
(inst pop other)
(when (and cloop
(sb!c::loop-tail cloop)
(not (sb!c::loop-info cloop)))
- (sb!assem:align sb!vm:n-lowtag-bits #x90)
+ (sb!assem:emit-alignment sb!vm:n-lowtag-bits #x90)
;; Mark the loop as aligned by saving the IR1 block aligned.
(setf (sb!c::loop-info cloop) 1block)))
(sb!assem:emit-label (block-label 1block)))
(:results (result :scs (descriptor-reg any-reg)))
(:generator 5
(move rax old)
- #!+sb-thread
- (inst lock)
(inst cmpxchg (make-ea :qword :base object
:disp (- (* offset n-word-bytes) lowtag))
- new)
+ new :lock)
(move result rax)))
\f
;;;; symbol hacking VOPs
new)
(inst cmp rax no-tls-value-marker-widetag)
(inst jmp :ne check)
- (move rax old)
- (inst lock))
+ (move rax old))
(inst cmpxchg (make-ea :qword :base symbol
:disp (- (* symbol-value-slot n-word-bytes)
other-pointer-lowtag)
:scale 1)
- new)
+ new :lock)
(emit-label check)
(move result rax)
(inst cmp result unbound-marker-widetag)
(:policy :fast-safe)
(:generator 4
(move result value)
- (inst lock)
(inst add (make-ea :qword :base object
:disp (- (* symbol-value-slot n-word-bytes)
other-pointer-lowtag))
- value)))
+ value :lock)))
#!+sb-thread
(define-vop (boundp)
(:generator 4
(loadw tmp object 0 instance-pointer-lowtag)
(inst shr tmp n-widetag-bits)
- #!+sb-thread
- (inst lock)
- (inst xadd (make-ea-for-raw-slot object index tmp) diff)
+ (inst xadd (make-ea-for-raw-slot object index tmp) diff :lock)
(move result diff)))
(define-vop (raw-instance-ref/single)
(emit-byte segment #b10001101)
(emit-ea segment src (reg-tn-encoding dst))))
-(define-instruction cmpxchg (segment dst src)
+(define-instruction cmpxchg (segment dst src &optional prefix)
;; Register/Memory with Register.
(:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
(:emitter
(aver (register-p src))
+ (emit-prefix segment prefix)
(let ((size (matching-operand-size src dst)))
(maybe-emit-operand-size-prefix segment size)
(maybe-emit-rex-for-ea segment dst src)
(emit-ea segment dst (reg-tn-encoding src)))))
\f
-
-(define-instruction fs-segment-prefix (segment)
- (:emitter
- (emit-byte segment #x64)))
-
;;;; flag control instructions
;;; CLC -- Clear Carry Flag.
(rex-reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
)
-(define-instruction add (segment dst src)
+(define-instruction add (segment dst src &optional prefix)
(:printer-list (arith-inst-printer-list #b000))
- (:emitter (emit-random-arith-inst "ADD" segment dst src #b000)))
+ (:emitter
+ (emit-prefix segment prefix)
+ (emit-random-arith-inst "ADD" segment dst src #b000)))
(define-instruction adc (segment dst src)
(:printer-list (arith-inst-printer-list #b010))
(maybe-emit-rex-prefix segment :qword nil nil nil)
(emit-byte segment #b10011001)))
-(define-instruction xadd (segment dst src)
+(define-instruction xadd (segment dst src &optional prefix)
;; Register/Memory with Register.
(:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
(:emitter
(aver (register-p src))
+ (emit-prefix segment prefix)
(let ((size (matching-operand-size src dst)))
(maybe-emit-operand-size-prefix segment size)
(maybe-emit-rex-for-ea segment dst src)
(:emitter
(emit-byte segment #b10011011)))
+(defun emit-prefix (segment name)
+ (declare (ignorable segment))
+ (ecase name
+ ((nil))
+ (:lock
+ #!+sb-thread
+ (emit-byte segment #xf0))))
+
+;;; FIXME: It would be better to make the disassembler understand the prefix as part
+;;; of the instructions...
(define-instruction lock (segment)
(:printer byte ((op #b11110000)))
(:emitter
- (emit-byte segment #b11110000)))
+ (bug "LOCK prefix used as a standalone instruction")))
\f
;;;; miscellaneous hackery
(: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)
(let ((delta (logandc2 (+ amount 3) 3)))
(inst mov temp
(make-ea-for-symbol-tls-index *alien-stack*))
- (inst fs-segment-prefix)
- (inst sub (make-ea :dword :base temp) delta)))
+ (inst sub (make-ea :dword :base temp) delta :fs)))
(load-tl-symbol-value result *alien-stack*))
#!-sb-thread
(:generator 0
(let ((delta (logandc2 (+ amount 3) 3)))
(inst mov temp
(make-ea-for-symbol-tls-index *alien-stack*))
- (inst fs-segment-prefix)
- (inst add (make-ea :dword :base temp) delta))))
+ (inst add (make-ea :dword :base temp) delta :fs))))
#!-sb-thread
(:generator 0
(unless (zerop amount)
;; register on -SB-THREAD.
#!+sb-thread
(progn
- (inst fs-segment-prefix)
(inst cmp (make-ea :dword
:disp (* thread-stepping-slot n-word-bytes))
- nil-value))
+ nil-value :fs))
#!-sb-thread
(inst cmp (make-ea-for-symbol-value sb!impl::*stepping*)
nil-value))
(:results (result :scs (descriptor-reg any-reg)))
(:generator 5
(move eax old)
- #!+sb-thread
- (inst lock)
(inst cmpxchg (make-ea :dword :base object
:disp (- (* offset n-word-bytes) lowtag))
- new)
+ new :lock)
(move result eax)))
\f
;;;; symbol hacking VOPs
(progn
(loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
;; Thread-local area, no LOCK needed.
- (inst fs-segment-prefix)
- (inst cmpxchg (make-ea :dword :base tls) new)
+ (inst cmpxchg (make-ea :dword :base tls) new :fs)
(inst cmp eax no-tls-value-marker-widetag)
(inst jmp :ne check)
- (move eax old)
- (inst lock))
+ (move eax old))
(inst cmpxchg (make-ea :dword :base symbol
:disp (- (* symbol-value-slot n-word-bytes)
other-pointer-lowtag))
- new)
+ new :lock)
(emit-label check)
(move result eax)
(inst cmp result unbound-marker-widetag)
(let ((global-val (gen-label))
(done (gen-label)))
(loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
- (inst fs-segment-prefix)
- (inst cmp (make-ea :dword :base tls) no-tls-value-marker-widetag)
+ (inst cmp (make-ea :dword :base tls) no-tls-value-marker-widetag :fs)
(inst jmp :z global-val)
- (inst fs-segment-prefix)
- (inst mov (make-ea :dword :base tls) value)
+ (inst mov (make-ea :dword :base tls) value :fs)
(inst jmp done)
(emit-label global-val)
(storew value symbol symbol-value-slot other-pointer-lowtag)
(err-lab (generate-error-code vop 'unbound-symbol-error object))
(ret-lab (gen-label)))
(loadw value object symbol-tls-index-slot other-pointer-lowtag)
- (inst fs-segment-prefix)
- (inst mov value (make-ea :dword :base value))
+ (inst mov value (make-ea :dword :base value) :fs)
(inst cmp value no-tls-value-marker-widetag)
(inst jmp :ne check-unbound-label)
(loadw value object symbol-value-slot other-pointer-lowtag)
(:generator 8
(let ((ret-lab (gen-label)))
(loadw value object symbol-tls-index-slot other-pointer-lowtag)
- (inst fs-segment-prefix)
- (inst mov value (make-ea :dword :base value))
+ (inst mov value (make-ea :dword :base value) :fs)
(inst cmp value no-tls-value-marker-widetag)
(inst jmp :ne ret-lab)
(loadw value object symbol-value-slot other-pointer-lowtag)
(:policy :fast-safe)
(:generator 4
(move result value)
- (inst lock)
(inst add (make-ea-for-object-slot object symbol-value-slot
other-pointer-lowtag)
- value)))
+ value :lock)))
#!+sb-thread
(define-vop (boundp)
(:generator 9
(let ((check-unbound-label (gen-label)))
(loadw value object symbol-tls-index-slot other-pointer-lowtag)
- (inst fs-segment-prefix)
- (inst mov value (make-ea :dword :base value))
+ (inst mov value (make-ea :dword :base value) :fs)
(inst cmp value no-tls-value-marker-widetag)
(inst jmp :ne check-unbound-label)
(loadw value object symbol-value-slot other-pointer-lowtag)
(#.esi-offset 'alloc-tls-index-in-esi))
:assembly-routine))
(emit-label tls-index-valid)
- (inst fs-segment-prefix)
- (inst push (make-ea :dword :base tls-index))
+ (inst push (make-ea :dword :base tls-index) :fs)
(popw bsp (- binding-value-slot binding-size))
(storew symbol bsp (- binding-symbol-slot binding-size))
- (inst fs-segment-prefix)
- (inst mov (make-ea :dword :base tls-index) val))))
+ (inst mov (make-ea :dword :base tls-index) val :fs))))
#!-sb-thread
(define-vop (bind)
(loadw tls-index temp symbol-tls-index-slot other-pointer-lowtag)
;; Load VALUE from stack, then restore it to the TLS area.
(loadw temp bsp (- binding-value-slot binding-size))
- (inst fs-segment-prefix)
- (inst mov (make-ea :dword :base tls-index) temp)
+ (inst mov (make-ea :dword :base tls-index) temp :fs)
;; Zero out the stack.
(storew 0 bsp (- binding-symbol-slot binding-size))
(storew 0 bsp (- binding-value-slot binding-size))
#!+sb-thread (loadw
tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
- #!+sb-thread (inst fs-segment-prefix)
- #!+sb-thread (inst mov (make-ea :dword :base tls-index) value)
+ #!+sb-thread (inst mov (make-ea :dword :base tls-index) value :fs)
(storew 0 bsp (- binding-symbol-slot binding-size))
SKIP
(when (sc-is index any-reg)
(inst shl tmp 2)
(inst sub tmp index))
- #!+sb-thread
- (inst lock)
- (inst xadd (make-ea-for-raw-slot object index tmp 1) diff)
+ (inst xadd (make-ea-for-raw-slot object index tmp 1) diff :lock)
(move result diff)))
(define-vop (raw-instance-ref/single)
\f
;;;; general data transfer
-(define-instruction mov (segment dst src)
+(define-instruction mov (segment dst src &optional prefix)
;; immediate to register
(:printer reg ((op #b1011) (imm nil :type 'imm-data))
'(:name :tab reg ", " imm))
(:printer reg/mem-imm ((op '(#b1100011 #b000))))
(:emitter
+ (emit-prefix segment prefix)
(let ((size (matching-operand-size dst src)))
(maybe-emit-operand-size-prefix segment size)
(cond ((register-p dst)
(:printer ext-reg-reg/mem ((op #b1011011) (reg nil :type 'word-reg)))
(:emitter (emit-move-with-extension segment dst src #b10110110)))
-(define-instruction push (segment src)
+(define-instruction push (segment src &optional prefix)
;; register
(:printer reg-no-width ((op #b01010)))
;; register/memory
;; ### segment registers?
(:emitter
+ (emit-prefix segment prefix)
(cond ((integerp src)
(cond ((<= -128 src 127)
(emit-byte segment #b01101010)
(emit-byte segment #b10001101)
(emit-ea segment src (reg-tn-encoding dst))))
-(define-instruction cmpxchg (segment dst src)
+(define-instruction cmpxchg (segment dst src &optional prefix)
;; Register/Memory with Register.
(:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
(:emitter
(aver (register-p src))
+ (emit-prefix segment prefix)
(let ((size (matching-operand-size src dst)))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment #b00001111)
(emit-ea segment dst (reg-tn-encoding src)))))
\f
+(defun emit-prefix (segment name)
+ (ecase name
+ ((nil))
+ (:lock
+ #!+sb-thread
+ (emit-byte segment #xf0))
+ (:fs
+ (emit-byte segment #x64))
+ (:gs
+ (emit-byte segment #x65))))
(define-instruction fs-segment-prefix (segment)
(:printer byte ((op #b01100100)))
(:emitter
- (emit-byte segment #x64)))
+ (bug "FS emitted as a separate instruction!")))
(define-instruction gs-segment-prefix (segment)
(:printer byte ((op #b01100101)))
(:emitter
- (emit-byte segment #x65)))
+ (bug "GS emitted as a separate instruction!")))
;;;; flag control instructions
;;;; arithmetic
(defun emit-random-arith-inst (name segment dst src opcode
- &optional allow-constants)
+ &optional allow-constants)
(let ((size (matching-operand-size dst src)))
(maybe-emit-operand-size-prefix segment size)
(cond
(reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
)
-(define-instruction add (segment dst src)
+(define-instruction add (segment dst src &optional prefix)
(:printer-list (arith-inst-printer-list #b000))
- (:emitter (emit-random-arith-inst "ADD" segment dst src #b000)))
+ (:emitter
+ (emit-prefix segment prefix)
+ (emit-random-arith-inst "ADD" segment dst src #b000)))
(define-instruction adc (segment dst src)
(:printer-list (arith-inst-printer-list #b010))
(:emitter (emit-random-arith-inst "ADC" segment dst src #b010)))
-(define-instruction sub (segment dst src)
+(define-instruction sub (segment dst src &optional prefix)
(:printer-list (arith-inst-printer-list #b101))
- (:emitter (emit-random-arith-inst "SUB" segment dst src #b101)))
+ (:emitter
+ (emit-prefix segment prefix)
+ (emit-random-arith-inst "SUB" segment dst src #b101)))
(define-instruction sbb (segment dst src)
(:printer-list (arith-inst-printer-list #b011))
(:emitter (emit-random-arith-inst "SBB" segment dst src #b011)))
-(define-instruction cmp (segment dst src)
+(define-instruction cmp (segment dst src &optional prefix)
(:printer-list (arith-inst-printer-list #b111))
- (:emitter (emit-random-arith-inst "CMP" segment dst src #b111 t)))
+ (:emitter
+ (emit-prefix segment prefix)
+ (emit-random-arith-inst "CMP" segment dst src #b111 t)))
(define-instruction inc (segment dst)
;; Register.
(maybe-emit-operand-size-prefix segment :dword)
(emit-byte segment #b10011001)))
-(define-instruction xadd (segment dst src)
+(define-instruction xadd (segment dst src &optional prefix)
;; Register/Memory with Register.
(:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
(:emitter
(aver (register-p src))
+ (emit-prefix segment prefix)
(let ((size (matching-operand-size src dst)))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment #b00001111)
(t
(inst test x y))))
-(define-instruction or (segment dst src)
+(define-instruction or (segment dst src &optional prefix)
(:printer-list
(arith-inst-printer-list #b001))
(:emitter
+ (emit-prefix segment prefix)
(emit-random-arith-inst "OR" segment dst src #b001)))
-(define-instruction xor (segment dst src)
+(define-instruction xor (segment dst src &optional prefix)
(:printer-list
(arith-inst-printer-list #b110))
(:emitter
+ (emit-prefix segment prefix)
(emit-random-arith-inst "XOR" segment dst src #b110)))
(define-instruction not (segment dst)
(:emitter
(emit-byte segment #b10011011)))
+;;; FIXME: It would be better to make the disassembler understand the prefix as part
+;;; of the instructions...
(define-instruction lock (segment)
(:printer byte ((op #b11110000)))
(:emitter
- (emit-byte segment #b11110000)))
+ (bug "LOCK prefix used as a standalone instruction")))
\f
;;;; miscellaneous hackery
(defmacro load-tl-symbol-value (reg symbol)
`(progn
(inst mov ,reg (make-ea-for-symbol-tls-index ,symbol))
- (inst fs-segment-prefix)
- (inst mov ,reg (make-ea :dword :base ,reg))))
+ (inst mov ,reg (make-ea :dword :base ,reg) :fs)))
#!-sb-thread
(defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol))
(defmacro store-tl-symbol-value (reg symbol temp)
`(progn
(inst mov ,temp (make-ea-for-symbol-tls-index ,symbol))
- (inst fs-segment-prefix)
- (inst mov (make-ea :dword :base ,temp) ,reg)))
+ (inst mov (make-ea :dword :base ,temp) ,reg :fs)))
#!-sb-thread
(defmacro store-tl-symbol-value (reg symbol temp)
(declare (ignore temp))
(defmacro load-binding-stack-pointer (reg)
#!+sb-thread
`(progn
- (inst fs-segment-prefix)
(inst mov ,reg (make-ea :dword
- :disp (* 4 thread-binding-stack-pointer-slot))))
+ :disp (* 4 thread-binding-stack-pointer-slot))
+ :fs))
#!-sb-thread
`(load-symbol-value ,reg *binding-stack-pointer*))
(defmacro store-binding-stack-pointer (reg)
#!+sb-thread
`(progn
- (inst fs-segment-prefix)
(inst mov (make-ea :dword
:disp (* 4 thread-binding-stack-pointer-slot))
- ,reg))
+ ,reg :fs))
#!-sb-thread
`(store-symbol-value ,reg *binding-stack-pointer*))
:scale 1))) ; thread->alloc_region.end_addr
(unless (and (tn-p size) (location= alloc-tn size))
(inst mov alloc-tn size))
- #!+sb-thread (inst fs-segment-prefix)
- (inst add alloc-tn free-pointer)
- #!+sb-thread (inst fs-segment-prefix)
- (inst cmp alloc-tn end-addr)
+ (inst add alloc-tn free-pointer #!+sb-thread :fs)
+ (inst cmp alloc-tn end-addr #!+sb-thread :fs)
(inst jmp :be ok)
(let ((dst (ecase (tn-offset alloc-tn)
(#.eax-offset "alloc_overflow_eax")
;; Swap ALLOC-TN and FREE-POINTER
(cond ((and (tn-p size) (location= alloc-tn size))
;; XCHG is extremely slow, use the xor swap trick
- #!+sb-thread (inst fs-segment-prefix)
- (inst xor alloc-tn free-pointer)
- #!+sb-thread (inst fs-segment-prefix)
- (inst xor free-pointer alloc-tn)
- #!+sb-thread (inst fs-segment-prefix)
- (inst xor alloc-tn free-pointer))
+ (inst xor alloc-tn free-pointer #!+sb-thread :fs)
+ (inst xor free-pointer alloc-tn #!+sb-thread :fs)
+ (inst xor alloc-tn free-pointer #!+sb-thread :fs))
(t
;; It's easier if SIZE is still available.
- #!+sb-thread (inst fs-segment-prefix)
- (inst mov free-pointer alloc-tn)
+ (inst mov free-pointer alloc-tn #!+sb-thread :fs)
(inst sub alloc-tn size)))
(emit-label done))
(values))
(defmacro pseudo-atomic (&rest forms)
(with-unique-names (label)
`(let ((,label (gen-label)))
- (inst fs-segment-prefix)
(inst or (make-ea :byte :disp (* 4 thread-pseudo-atomic-bits-slot))
- (fixnumize 1))
+ (fixnumize 1) :fs)
,@forms
- (inst fs-segment-prefix)
(inst xor (make-ea :byte :disp (* 4 thread-pseudo-atomic-bits-slot))
- (fixnumize 1))
+ (fixnumize 1) :fs)
(inst jmp :z ,label)
;; if PAI was set, interrupts were disabled at the same
;; time using the process signal mask.
(:result-types ,el-type)
(:generator 5
(move eax old-value)
- #!+sb-thread
- (inst lock)
(let ((ea (sc-case index
(immediate
(make-ea :dword :base object
(make-ea :dword :base object :index index
:disp (- (* ,offset n-word-bytes)
,lowtag))))))
- (inst cmpxchg ea new-value))
+ (inst cmpxchg ea new-value :lock))
(move value eax)))))
(defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
block catch-block-entry-pc-slot)
#!+win32
(progn
- (inst fs-segment-prefix)
- (inst mov temp (make-ea :dword :disp 0))
+ (inst mov temp (make-ea :dword :disp 0) :fs)
(storew temp block unwind-block-next-seh-frame-slot))))
;;; like MAKE-UNWIND-BLOCK, except that we also store in the specified
block catch-block-entry-pc-slot)
#!+win32
(progn
- (inst fs-segment-prefix)
- (inst mov temp (make-ea :dword :disp 0))
+ (inst mov temp (make-ea :dword :disp 0) :fs)
(storew temp block unwind-block-next-seh-frame-slot))
(storew tag block catch-block-tag-slot)
(load-tl-symbol-value temp *current-catch-block*)
(inst lea seh-frame
(make-ea-for-object-slot new-uwp
unwind-block-next-seh-frame-slot 0))
- (inst fs-segment-prefix)
- (inst mov (make-ea :dword :disp 0) seh-frame))
+ (inst mov (make-ea :dword :disp 0) seh-frame :fs))
(store-tl-symbol-value new-uwp *current-unwind-protect-block* tls)))
(define-vop (unlink-catch-block)
#!+win32
(progn
(loadw seh-frame block unwind-block-next-seh-frame-slot)
- (inst fs-segment-prefix)
- (inst mov (make-ea :dword :disp 0) seh-frame))
+ (inst mov (make-ea :dword :disp 0) seh-frame :fs))
(loadw block block unwind-block-current-uwp-slot)
(store-tl-symbol-value block *current-unwind-protect-block* tls)))
\f
(:arg-types unsigned-num)
(:policy :fast-safe)
(:generator 2
- (inst fs-segment-prefix)
- (inst mov sap (make-ea :dword :disp 0 :index n :scale 4))))
+ (inst mov sap (make-ea :dword :disp 0 :index n :scale 4) :fs)))
(define-vop (halt)
(:generator 1
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.20.15"
+"1.0.20.16"
projects / sbcl.git / commitdiff