X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fcell.lisp;h=3d85b6b441969e1ff764551abcf6c082c11b81d2;hb=038ecde3e0386e347550709a199c7f856052c0cd;hp=5adb018c6d82c2f436d6241f2cad97d01679b396;hpb=ea3a2433c72ee97c5691c29d882a63e4d86f0a32;p=sbcl.git diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index 5adb018..3d85b6b 100644 --- a/src/compiler/x86-64/cell.lisp +++ b/src/compiler/x86-64/cell.lisp @@ -46,11 +46,67 @@ temp)) ;; Else, value not immediate. (storew value object offset lowtag)))) - - +(define-vop (compare-and-swap-slot) + (:args (object :scs (descriptor-reg) :to :eval) + (old :scs (descriptor-reg any-reg) :target rax) + (new :scs (descriptor-reg any-reg))) + (:temporary (:sc descriptor-reg :offset rax-offset + :from (:argument 1) :to :result :target result) + rax) + (:info name offset lowtag) + (:ignore name) + (: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) + (move result rax))) + ;;;; symbol hacking VOPs +(define-vop (%compare-and-swap-symbol-value) + (:translate %compare-and-swap-symbol-value) + (:args (symbol :scs (descriptor-reg) :to (:result 1)) + (old :scs (descriptor-reg any-reg) :target rax) + (new :scs (descriptor-reg any-reg))) + (:temporary (:sc descriptor-reg :offset rax-offset) rax) + #!+sb-thread + (:temporary (:sc descriptor-reg) tls) + (:results (result :scs (descriptor-reg any-reg))) + (:policy :fast-safe) + (:vop-var vop) + (:generator 15 + ;; This code has to pathological cases: NO-TLS-VALUE-MARKER + ;; or UNBOUND-MARKER as NEW: in either case we would end up + ;; doing possible damage with CMPXCHG -- so don't do that! + (let ((unbound (generate-error-code vop unbound-symbol-error symbol)) + (check (gen-label))) + (move rax old) + #!+sb-thread + (progn + (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag) + ;; Thread-local area, no LOCK needed. + (inst cmpxchg (make-ea :qword :base thread-base-tn + :index tls :scale 1) + new) + (inst cmp rax no-tls-value-marker-widetag) + (inst jmp :ne check) + (move rax old) + (inst lock)) + (inst cmpxchg (make-ea :qword :base symbol + :disp (- (* symbol-value-slot n-word-bytes) + other-pointer-lowtag) + :scale 1) + new) + (emit-label check) + (move result rax) + (inst cmp result unbound-marker-widetag) + (inst jmp :e unbound)))) + ;;; these next two cf the sparc version, by jrd. ;;; FIXME: Deref this ^ reference. @@ -66,8 +122,6 @@ (let ((global-val (gen-label)) (done (gen-label))) (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag) - (inst or tls tls) - (inst jmp :z global-val) (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls) no-tls-value-marker-widetag) (inst jmp :z global-val) @@ -274,7 +328,7 @@ (:args (val :scs (any-reg descriptor-reg)) (symbol :scs (descriptor-reg))) (:temporary (:sc descriptor-reg :offset rax-offset) rax) - (:temporary (:sc unsigned-reg) tls-index temp bsp) + (:temporary (:sc unsigned-reg) tls-index bsp) (:generator 10 (let ((tls-index-valid (gen-label)) (get-tls-index-lock (gen-label)) @@ -286,12 +340,17 @@ (inst or tls-index tls-index) (inst jmp :ne tls-index-valid) + ;; FIXME: + ;; * We should ensure the existence of TLS index for LET-bound specials + ;; at compile/load time, and use write a FAST-BIND for use with those. + ;; * PROGV will need to do this, but even there this should not be inline. + ;; This is probably best moved to C, since dynbind.c also needs to do this. (pseudo-atomic (emit-label get-tls-index-lock) - (inst mov temp 1) + (inst mov tls-index 1) (zeroize rax) (inst lock) - (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) temp) + (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) tls-index) (inst jmp :ne get-tls-index-lock) ;; now with the lock held, see if the symbol's tls index has ;; been set in the meantime @@ -300,17 +359,14 @@ (inst jmp :ne release-tls-index-lock) ;; allocate a new tls-index (load-symbol-value tls-index *free-tls-index*) - (inst add tls-index 8) ;XXX surely we can do this more - (store-symbol-value tls-index *free-tls-index*) ;succintly - (inst sub tls-index 8) + (inst add (make-ea-for-symbol-value *free-tls-index*) 8) ; fixnum + 1 (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag) (emit-label release-tls-index-lock) (store-symbol-value 0 *tls-index-lock*)) (emit-label tls-index-valid) - (inst mov temp - (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)) - (storew temp bsp (- binding-value-slot binding-size)) + (inst mov rax (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)) + (storew rax bsp (- binding-value-slot binding-size)) (storew symbol bsp (- binding-symbol-slot binding-size)) (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index) val)))) @@ -374,6 +430,9 @@ (loadw symbol bsp (- binding-symbol-slot binding-size)) (inst or symbol symbol) (inst jmp :z SKIP) + ;; Bind stack debug sentinels have the unbound marker in the symbol slot + (inst cmp symbol unbound-marker-widetag) + (inst jmp :eq SKIP) (loadw value bsp (- binding-value-slot binding-size)) #!-sb-thread (storew value symbol symbol-value-slot other-pointer-lowtag) @@ -392,6 +451,25 @@ (store-binding-stack-pointer bsp) DONE)) + +(define-vop (bind-sentinel) + (:temporary (:sc unsigned-reg) bsp) + (:generator 1 + (load-binding-stack-pointer bsp) + (inst add bsp (* binding-size n-word-bytes)) + (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size)) + (storew rbp-tn bsp (- binding-value-slot binding-size)) + (store-binding-stack-pointer bsp))) + +(define-vop (unbind-sentinel) + (:temporary (:sc unsigned-reg) bsp) + (:generator 1 + (load-binding-stack-pointer bsp) + (storew 0 bsp (- binding-value-slot binding-size)) + (storew 0 bsp (- binding-symbol-slot binding-size)) + (inst sub bsp (* binding-size n-word-bytes)) + (store-binding-stack-pointer bsp))) + @@ -441,9 +519,10 @@ (define-full-setter instance-index-set * instance-slots-offset instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set) -(define-full-compare-and-swap instance-compare-and-swap instance - instance-slots-offset instance-pointer-lowtag (any-reg descriptor-reg) - * %instance-compare-and-swap) +(define-full-compare-and-swap %compare-and-swap-instance-ref instance + instance-slots-offset instance-pointer-lowtag + (any-reg descriptor-reg) * + %compare-and-swap-instance-ref) ;;;; code object frobbing