From: Daniel B. <da...@us...> - 2005-02-06 00:00:50
|
Update of /cvsroot/sbcl/sbcl/src/compiler/x86-64 In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2569/src/compiler/x86-64 Modified Files: Tag: amd64-pthread-branch c-call.lisp cell.lisp macros.lisp system.lisp vm.lisp Log Message: beginnings of amd64 thread support Index: c-call.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/c-call.lisp,v retrieving revision 1.4 retrieving revision 1.4.2.1 diff -u -d -r1.4 -r1.4.2.1 --- c-call.lisp 20 Jan 2005 20:02:29 -0000 1.4 +++ c-call.lisp 6 Feb 2005 00:00:29 -0000 1.4.2.1 @@ -274,13 +274,13 @@ (unless (zerop amount) (let ((delta (logandc2 (+ amount 7) 7))) (inst mov temp - (make-ea :dword + (make-ea :qword :disp (+ nil-value (static-symbol-offset '*alien-stack*) (ash symbol-tls-index-slot word-shift) (- other-pointer-lowtag)))) - (inst fs-segment-prefix) - (inst sub (make-ea :dword :scale 1 :index temp) delta))) + (inst sub (make-ea :qword :base thread-base-tn + :scale 1 :index temp) delta))) (load-tl-symbol-value result *alien-stack*)) #!-sb-thread (:generator 0 @@ -303,13 +303,13 @@ (unless (zerop amount) (let ((delta (logandc2 (+ amount 7) 7))) (inst mov temp - (make-ea :dword + (make-ea :qword :disp (+ nil-value (static-symbol-offset '*alien-stack*) (ash symbol-tls-index-slot word-shift) (- other-pointer-lowtag)))) - (inst fs-segment-prefix) - (inst add (make-ea :dword :scale 1 :index temp) delta)))) + (inst add (make-ea :qword :base thread-base-tn :scale 1 :index temp) + delta)))) #!-sb-thread (:generator 0 (unless (zerop amount) Index: cell.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/cell.lisp,v retrieving revision 1.2 retrieving revision 1.2.6.1 diff -u -d -r1.2 -r1.2.6.1 --- cell.lisp 6 Jan 2005 12:48:02 -0000 1.2 +++ cell.lisp 6 Feb 2005 00:00:29 -0000 1.2.6.1 @@ -68,11 +68,11 @@ (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag) (inst or tls tls) (inst jmp :z global-val) - (inst fs-segment-prefix) - (inst cmp (make-ea :dword :scale 1 :index tls) unbound-marker-widetag) + (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls) + unbound-marker-widetag) (inst jmp :z global-val) - (inst fs-segment-prefix) - (inst mov (make-ea :dword :scale 1 :index tls) value) + (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls) + value) (inst jmp done) (emit-label global-val) (storew value symbol symbol-value-slot other-pointer-lowtag) @@ -107,8 +107,8 @@ (let* ((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 :index value :scale 1)) + (inst mov value (make-ea :qword :base thread-base-tn + :index value :scale 1)) (inst cmp value unbound-marker-widetag) (inst jmp :ne ret-lab) (loadw value object symbol-value-slot other-pointer-lowtag) @@ -128,8 +128,8 @@ (: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 :index value :scale 1)) + (inst mov value + (make-ea :qword :base thread-base-tn :index value :scale 1)) (inst cmp value unbound-marker-widetag) (inst jmp :ne ret-lab) (loadw value object symbol-value-slot other-pointer-lowtag) @@ -169,7 +169,7 @@ (:generator 4 (move result value) (inst lock) - (inst add (make-ea :dword :base object + (inst add (make-ea :qword :base object :disp (- (* symbol-value-slot n-word-bytes) other-pointer-lowtag)) value))) @@ -189,8 +189,8 @@ (inst cmp value unbound-marker-widetag) (inst jmp :ne not-target) (loadw value object symbol-tls-index-slot other-pointer-lowtag) - (inst fs-segment-prefix) - (inst cmp (make-ea :dword :index value :scale 1) unbound-marker-widetag) + (inst cmp (make-ea :qword :base thread-base-tn + :index value :scale 1) unbound-marker-widetag) (inst jmp :e target) (emit-label not-target)) (progn @@ -198,8 +198,8 @@ (inst cmp value unbound-marker-widetag) (inst jmp :ne target) (loadw value object symbol-tls-index-slot other-pointer-lowtag) - (inst fs-segment-prefix) - (inst cmp (make-ea :dword :index value :scale 1) unbound-marker-widetag) + (inst cmp (make-ea :qword :base thread-base-tn :index value :scale 1) + unbound-marker-widetag) (inst jmp :ne target))))) #!-sb-thread @@ -301,17 +301,17 @@ (inst jmp :ne tls-index-valid) ;; allocate a new tls-index (load-symbol-value tls-index *free-tls-index*) - (inst add tls-index 4) ;XXX surely we can do this more + (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 4) + (inst sub tls-index 8) (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag) (emit-label tls-index-valid) - (inst fs-segment-prefix) - (inst mov temp (make-ea :dword :scale 1 :index tls-index)) + (inst mov temp + (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)) (storew temp bsp (- binding-value-slot binding-size)) (storew symbol bsp (- binding-symbol-slot binding-size)) - (inst fs-segment-prefix) - (inst mov (make-ea :dword :scale 1 :index tls-index) val)))) + (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index) + val)))) #!-sb-thread (define-vop (bind) @@ -338,8 +338,7 @@ (loadw value bsp (- binding-value-slot binding-size)) (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) - (inst fs-segment-prefix) - (inst mov (make-ea :dword :scale 1 :index tls-index) value) + (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index) value) (storew 0 bsp (- binding-symbol-slot binding-size)) (inst sub bsp (* binding-size n-word-bytes)) @@ -376,8 +375,7 @@ #!+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 :scale 1 :index tls-index) value) + #!+sb-thread (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index) value) (storew 0 bsp (- binding-symbol-slot binding-size)) SKIP @@ -460,22 +458,22 @@ (:translate %instance-set-conditional) (:args (object :scs (descriptor-reg) :to :eval) (slot :scs (any-reg) :to :result) - (old-value :scs (descriptor-reg any-reg) :target eax) + (old-value :scs (descriptor-reg any-reg) :target rax) (new-value :scs (descriptor-reg any-reg))) (:arg-types instance positive-fixnum * *) - (:temporary (:sc descriptor-reg :offset eax-offset - :from (:argument 2) :to :result :target result) eax) + (:temporary (:sc descriptor-reg :offset rax-offset + :from (:argument 2) :to :result :target result) rax) (:results (result :scs (descriptor-reg any-reg))) ;(:guard (backend-featurep :i486)) (:policy :fast-safe) (:generator 5 - (move eax old-value) + (move rax old-value) (inst lock) - (inst cmpxchg (make-ea :dword :base object :index slot :scale 1 + (inst cmpxchg (make-ea :qword :base object :index slot :scale 1 :disp (- (* instance-slots-offset n-word-bytes) instance-pointer-lowtag)) new-value) - (move result eax))) + (move result rax))) Index: macros.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/macros.lisp,v retrieving revision 1.2 retrieving revision 1.2.6.1 diff -u -d -r1.2 -r1.2.6.1 --- macros.lisp 6 Jan 2005 12:48:02 -0000 1.2 +++ macros.lisp 6 Feb 2005 00:00:29 -0000 1.2.6.1 @@ -104,8 +104,7 @@ (static-symbol-offset ',symbol) (ash symbol-tls-index-slot word-shift) (- other-pointer-lowtag)))) - (inst fs-segment-prefix) - (inst mov ,reg (make-ea :qword :scale 1 :index ,reg)))) + (inst mov ,reg (make-ea :qword :base thread-base-tn :scale 1 :index ,reg)))) #!-sb-thread (defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol)) @@ -118,8 +117,7 @@ (static-symbol-offset ',symbol) (ash symbol-tls-index-slot word-shift) (- other-pointer-lowtag)))) - (inst fs-segment-prefix) - (inst mov (make-ea :qword :scale 1 :index ,temp) ,reg))) + (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index ,temp) ,reg))) #!-sb-thread (defmacro store-tl-symbol-value (reg symbol temp) (declare (ignore temp)) @@ -170,28 +168,33 @@ ;; Yuck. (in-elsewhere (eq *elsewhere* sb!assem::**current-segment**)) (free-pointer - (make-ea :qword :disp - #!+sb-thread (* n-word-bytes thread-alloc-region-slot) - #!-sb-thread (make-fixup (extern-alien-name "boxed_region") - :foreign) - :scale 1)) ; thread->alloc_region.free_pointer + #!+sb-thread + (make-ea :qword + :base thread-base-tn :scale 1 + :disp (* n-word-bytes thread-alloc-region-slot)) + #!-sb-thread + (make-ea :qword + :scale 1 :disp + (make-fixup (extern-alien-name "boxed_region") :foreign) + )) ; thread->alloc_region.free_pointer (end-addr - (make-ea :qword :disp - #!+sb-thread (* n-word-bytes (1+ thread-alloc-region-slot)) - #!-sb-thread (make-fixup (extern-alien-name "boxed_region") - :foreign 8) - :scale 1))) ; thread->alloc_region.end_addr - (cond (in-elsewhere + #!+sb-thread + (make-ea :qword + :base thread-base-tn :scale 1 + :disp (* n-word-bytes (1+ thread-alloc-region-slot))) + #!-sb-thread + (make-ea :qword + :scale 1 :disp + (make-fixup (extern-alien-name "boxed_region") :foreign 8) + ))) ; thread->alloc_region.free_pointer + (cond (in-elsewhere (allocation-tramp alloc-tn size)) (t (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 end-addr alloc-tn) (inst jmp :be NOT-INLINE) - #!+sb-thread (inst fs-segment-prefix) (inst xchg free-pointer alloc-tn) (emit-label DONE) (assemble (*elsewhere*) @@ -285,6 +288,31 @@ ;;; the ATOMIC bit is bit 0, the INTERRUPTED bit is bit 1, and you check ;;; the C flag after the shift to see whether you were interrupted. +#!+sb-thread +(defmacro pseudo-atomic (&rest forms) + (with-unique-names (label) + `(let ((,label (gen-label))) + (inst mov (make-ea :byte + :base thread-base-tn + :disp (* 8 thread-pseudo-atomic-interrupted-slot)) 0) + (inst mov (make-ea :byte + :base thread-base-tn + :disp (* 8 thread-pseudo-atomic-atomic-slot)) 1) + ,@forms + (inst mov (make-ea :byte + :base thread-base-tn + :disp (* 8 thread-pseudo-atomic-atomic-slot)) 0) + (inst cmp (make-ea :byte + :base thread-base-tn + :disp (* 8 thread-pseudo-atomic-interrupted-slot)) 0) + (inst jmp :eq ,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)))) + + +#!-sb-thread (defmacro pseudo-atomic (&rest forms) (with-unique-names (label) `(let ((,label (gen-label))) Index: system.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/system.lisp,v retrieving revision 1.2 retrieving revision 1.2.6.1 diff -u -d -r1.2 -r1.2.6.1 --- system.lisp 6 Jan 2005 12:48:03 -0000 1.2 +++ system.lisp 6 Feb 2005 00:00:29 -0000 1.2.6.1 @@ -277,7 +277,7 @@ (inst break pending-interrupt-trap))) #!+sb-thread -(defknown current-thread-offset-sap ((unsigned-byte 32)) +(defknown current-thread-offset-sap ((unsigned-byte 64)) system-area-pointer (flushable)) #!+sb-thread @@ -289,8 +289,8 @@ (: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 :qword :base thread-base-tn :disp 0 :index n :scale 8)))) (define-vop (halt) (:generator 1 Index: vm.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/vm.lisp,v retrieving revision 1.3 retrieving revision 1.3.6.1 diff -u -d -r1.3 -r1.3.6.1 --- vm.lisp 6 Jan 2005 12:48:03 -0000 1.3 +++ vm.lisp 6 Feb 2005 00:00:36 -0000 1.3.6.1 @@ -112,8 +112,12 @@ (defreg r13 26 :qword) (defreg r14 28 :qword) (defreg r15 30 :qword) + ;; for no good reason at the time, r12 and r13 were missed from the + ;; list of qword registers. However + ;; <jsnell> r13 is already used as temporary [#lisp irc 2005/01/30] + ;; and we're now going to use r12 for the struct thread* (defregset *qword-regs* rax rcx rdx rbx rsi rdi - r8 r9 r10 r11 #+nil r12 #+nil r13 r14 r15) + r8 r9 r10 r11 r14 r15) ;; floating point registers (defreg float0 0 :float) @@ -362,6 +366,7 @@ ;;;; miscellaneous TNs for the various registers + (macrolet ((def-misc-reg-tns (sc-name &rest reg-names) (collect ((forms)) (dolist (reg-name reg-names) @@ -393,6 +398,9 @@ (symbol-value (symbolicate register-arg-name "-TN"))) *register-arg-names*)) +(defparameter thread-base-tn + (make-random-tn :kind :normal :sc (sc-or-lose 'unsigned-reg ) + :offset r12-offset)) (defparameter fp-single-zero-tn (make-random-tn :kind :normal |