Update of /cvsroot/sbcl/sbcl/src/compiler/x86 In directory sc8-pr-cvs1:/tmp/cvs-serv16288/src/compiler/x86 Modified Files: Tag: dan_native_threads_branch c-call.lisp cell.lisp insts.lisp macros.lisp nlx.lisp parms.lisp system.lisp Log Message: 0.7.9.54.thread.5 This is the #-continued-will-to-live experimental native threads branch, whih in general is not expected to do anything useful. For this particular checkin, it runs as far as first GC and then dies Lots of seriously rewritten VOPs for supporting thread-local symbol values: set, bind, unbind, unbind-to-here Add code/late-symbol to work around some build order problems with the SET and %SET-SYMBOL-VALUE vops. %set-symbol-value is no longer created by define-primitive-object (symbol); it's not that simple any more New macros {load,store}-tl-symbol-value. The load-symbol-value and store-symbol-value macros act only on the global symbol values, so many backend changes (which will need identifying and reproducing on non-x86 backends) to call {load,store}-tl-symbol-value where referring to symbols which have thread-local bindings fast-symbol-value doesn't presently exist (and we don't know what it should do either), so for the moment we replace calls to it with symbol-value New versions of {de,}alloc-alien-stack-space which use thread-local *alien-stack* Add code/target-thread so that Lisp may access bits of the struct thread * - needed fur debug-int. Warning: this is appallingly brittle code Add *free-tls-index*, *current-thread-struct* to static symbols list And runtime changes too ... lisp_interrupt_contexts goes away in favour of thread->interrupt_contexts bind(), unbind(), unbind_to_here() changed to parallel the VOPs of the same name pseudo-atomic is now per-thread (which is just as wrong an answer as having it be global, actually) ALLOCATION_POINTER, READ_ONLY_SPACE_FREE_POINTER, STATIC_SPACE_FREE_POINTER, conversely, are now global. Some GC changes to do things like scavenge all binding stacks instead of just the first init_thread binds a whole pile of variables Index: c-call.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/c-call.lisp,v retrieving revision 1.12 retrieving revision 1.12.6.1 diff -u -d -r1.12 -r1.12.6.1 --- c-call.lisp 16 Jan 2002 15:40:15 -0000 1.12 +++ c-call.lisp 2 Dec 2002 15:57:50 -0000 1.12.6.1 @@ -209,27 +209,33 @@ (define-vop (alloc-alien-stack-space) (:info amount) + (:temporary (:sc unsigned-reg) temp) (:results (result :scs (sap-reg any-reg))) (:generator 0 (aver (not (location= result esp-tn))) (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) - (inst sub (make-ea :dword - :disp (+ nil-value - (static-symbol-offset '*alien-stack*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) - delta))) - (load-symbol-value result *alien-stack*))) + (inst mov temp + (make-ea :dword + :disp (+ nil-value + (static-symbol-offset '*alien-stack*) + (ash symbol-tls-index-slot word-shift) + (- other-pointer-lowtag)))) + (inst gs-segment-prefix) + (inst sub (make-ea :dword :scale 4 :index temp) delta))) + (load-tl-symbol-value result *alien-stack*))) (define-vop (dealloc-alien-stack-space) (:info amount) + (:temporary (:sc unsigned-reg) temp) (:generator 0 (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) - (inst add (make-ea :dword - :disp (+ nil-value - (static-symbol-offset '*alien-stack*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) - delta))))) + (inst mov temp + (make-ea :dword + :disp (+ nil-value + (static-symbol-offset '*alien-stack*) + (ash symbol-tls-index-slot word-shift) + (- other-pointer-lowtag)))) + (inst gs-segment-prefix) + (inst add (make-ea :dword :scale 4 :index temp) delta))))) Index: cell.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/cell.lisp,v retrieving revision 1.10.4.1 retrieving revision 1.10.4.2 diff -u -d -r1.10.4.1 -r1.10.4.2 --- cell.lisp 24 Nov 2002 02:36:43 -0000 1.10.4.1 +++ cell.lisp 2 Dec 2002 15:57:50 -0000 1.10.4.2 @@ -57,11 +57,32 @@ ;;; these next two cf the sparc version, by jrd. ;;; FIXME: Deref this ^ reference. + ;;; The compiler likes to be able to directly SET symbols. -(define-vop (set cell-set) - (:variant symbol-value-slot other-pointer-lowtag)) +(define-vop (set) + (:args (symbol :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:translate sb!kernel:%set-symbol-value) + (:temporary (:sc descriptor-reg ) tls) + ;;(:policy :fast-safe) + (:generator 4 + (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 gs-segment-prefix) + (inst cmp (make-ea :dword :scale 4 :index tls) unbound-marker-widetag) + (inst jmp :z global-val) + (inst gs-segment-prefix) + (inst mov (make-ea :dword :scale 4 :index tls) value) + (inst jmp done) + (emit-label global-val) + (storew value symbol symbol-value-slot other-pointer-lowtag) + (emit-label done)))) ;;; Do a cell ref with an error check for being unbound. +;;; XXX stil used? I can't see where -dan (define-vop (checked-cell-ref) (:args (object :scs (descriptor-reg) :target obj-temp)) (:results (value :scs (descriptor-reg any-reg))) @@ -84,7 +105,7 @@ (ret-lab (gen-label))) (loadw value object symbol-tls-index-slot other-pointer-lowtag) (inst gs-segment-prefix) - (inst mov value (make-ea :dword :base value)) + (inst mov value (make-ea :dword :index value :scale 4)) (inst cmp value unbound-marker-widetag) (inst jmp :ne ret-lab) (loadw value object symbol-value-slot other-pointer-lowtag) @@ -106,13 +127,16 @@ (inst cmp value unbound-marker-widetag) (inst jmp :e err-lab)))) - +#+nil (define-vop (fast-symbol-value cell-ref) (:variant symbol-value-slot other-pointer-lowtag) (:policy :fast) (:translate symbol-value)) +;;; like to know where this is useed too +#+nil (defknown fast-symbol-value-xadd (symbol fixnum) fixnum ()) +#+nil (define-vop (fast-symbol-value-xadd cell-xadd) (:variant symbol-value-slot other-pointer-lowtag) (:policy :fast) @@ -203,32 +227,52 @@ (define-vop (bind) (:args (val :scs (any-reg descriptor-reg)) (symbol :scs (descriptor-reg))) - (:temporary (:sc unsigned-reg) temp bsp) + (:temporary (:sc unsigned-reg) tls-index temp bsp) (:generator 5 - (load-symbol-value bsp *binding-stack-pointer*) - (loadw temp symbol symbol-value-slot other-pointer-lowtag) - (inst add bsp (* binding-size n-word-bytes)) - (store-symbol-value bsp *binding-stack-pointer*) - (storew temp bsp (- binding-value-slot binding-size)) - (storew symbol bsp (- binding-symbol-slot binding-size)) - (storew val symbol symbol-value-slot other-pointer-lowtag))) - + (let ((tls-index-valid (gen-label))) + (load-tl-symbol-value bsp *binding-stack-pointer*) + (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + (inst add bsp (* binding-size n-word-bytes)) + (store-tl-symbol-value bsp *binding-stack-pointer* temp) + + (inst or tls-index tls-index) + (inst jmp :ne tls-index-valid) + ;; allocate a new tls-index + (load-symbol-value tls-index *free-tls-index*) + (inst add tls-index 1) ;XXX surely we can do this more + (store-symbol-value tls-index *free-tls-index*) ;succintly + (inst sub tls-index 1) + (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + (emit-label tls-index-valid) + (inst gs-segment-prefix) + (inst mov temp (make-ea :dword :scale 4 :index tls-index)) + (storew temp bsp (- binding-value-slot binding-size)) + (storew symbol bsp (- binding-symbol-slot binding-size)) + (inst gs-segment-prefix) + (inst mov (make-ea :dword :scale 4 :index tls-index) val)))) + (define-vop (unbind) - (:temporary (:sc unsigned-reg) symbol value bsp) + ;; four temporaries? + (:temporary (:sc unsigned-reg) symbol value bsp tls-index) (:generator 0 - (load-symbol-value bsp *binding-stack-pointer*) + (load-tl-symbol-value bsp *binding-stack-pointer*) (loadw symbol bsp (- binding-symbol-slot binding-size)) (loadw value bsp (- binding-value-slot binding-size)) - (storew value symbol symbol-value-slot other-pointer-lowtag) + + (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + (inst gs-segment-prefix) + (inst mov (make-ea :dword :scale 4 :index tls-index) value) + (storew 0 bsp (- binding-symbol-slot binding-size)) (inst sub bsp (* binding-size n-word-bytes)) - (store-symbol-value bsp *binding-stack-pointer*))) + ;; we're done with value, so we can use it as a temp here + (store-tl-symbol-value bsp *binding-stack-pointer* value))) (define-vop (unbind-to-here) (:args (where :scs (descriptor-reg any-reg))) - (:temporary (:sc unsigned-reg) symbol value bsp) + (:temporary (:sc unsigned-reg) symbol value bsp tls-index) (:generator 0 - (load-symbol-value bsp *binding-stack-pointer*) + (load-tl-symbol-value bsp *binding-stack-pointer*) (inst cmp where bsp) (inst jmp :e done) @@ -237,16 +281,22 @@ (inst or symbol symbol) (inst jmp :z skip) (loadw value bsp (- binding-value-slot binding-size)) - (storew value symbol symbol-value-slot other-pointer-lowtag) + + (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + (inst gs-segment-prefix) + (inst mov (make-ea :dword :scale 4 :index tls-index) value) (storew 0 bsp (- binding-symbol-slot binding-size)) SKIP (inst sub bsp (* binding-size n-word-bytes)) (inst cmp where bsp) (inst jmp :ne loop) - (store-symbol-value bsp *binding-stack-pointer*) + ;; we're done with value, so can use it as a temporary + (store-tl-symbol-value bsp *binding-stack-pointer* value) DONE)) + + ;;;; closure indexing Index: insts.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/insts.lisp,v retrieving revision 1.21.2.1 retrieving revision 1.21.2.2 diff -u -d -r1.21.2.1 -r1.21.2.2 --- insts.lisp 24 Nov 2002 02:36:43 -0000 1.21.2.1 +++ insts.lisp 2 Dec 2002 15:57:50 -0000 1.21.2.2 @@ -1039,7 +1039,6 @@ (define-instruction gs-segment-prefix (segment) - (:printer byte ((op #x65))) (:emitter (emit-byte segment #x65))) Index: macros.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/macros.lisp,v retrieving revision 1.10 retrieving revision 1.10.2.1 diff -u -d -r1.10 -r1.10.2.1 --- macros.lisp 13 Sep 2002 16:28:41 -0000 1.10 +++ macros.lisp 2 Dec 2002 15:57:50 -0000 1.10.2.1 @@ -84,6 +84,27 @@ (- other-pointer-lowtag))) ,reg)) +(defmacro load-tl-symbol-value (reg symbol) + `(progn + (inst mov ,reg + (make-ea :dword + :disp (+ nil-value + (static-symbol-offset ',symbol) + (ash symbol-tls-index-slot word-shift) + (- other-pointer-lowtag)))) + (inst gs-segment-prefix) + (inst mov ,reg (make-ea :dword :scale 4 :index ,reg)))) + +(defmacro store-tl-symbol-value (reg symbol temp) + `(progn + (inst mov ,temp + (make-ea :dword + :disp (+ nil-value + (static-symbol-offset ',symbol) + (ash symbol-tls-index-slot word-shift) + (- other-pointer-lowtag)))) + (inst gs-segment-prefix) + (inst mov (make-ea :dword :scale 4 :index ,temp) ,reg))) (defmacro load-type (target source &optional (offset 0)) #!+sb-doc Index: nlx.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/nlx.lisp,v retrieving revision 1.13 retrieving revision 1.13.6.1 diff -u -d -r1.13 -r1.13.6.1 --- nlx.lisp 7 Jun 2002 12:14:56 -0000 1.13 +++ nlx.lisp 2 Dec 2002 15:57:51 -0000 1.13.6.1 @@ -49,15 +49,16 @@ (:results (catch :scs (descriptor-reg)) (alien-stack :scs (descriptor-reg))) (:generator 13 - (load-symbol-value catch *current-catch-block*) - (load-symbol-value alien-stack *alien-stack*))) + (load-tl-symbol-value catch *current-catch-block*) + (load-tl-symbol-value alien-stack *alien-stack*))) (define-vop (restore-dynamic-state) (:args (catch :scs (descriptor-reg)) (alien-stack :scs (descriptor-reg))) + (:temporary (:sc unsigned-reg) temp) (:generator 10 - (store-symbol-value catch *current-catch-block*) - (store-symbol-value alien-stack *alien-stack*))) + (store-tl-symbol-value catch *current-catch-block* temp) + (store-tl-symbol-value alien-stack *alien-stack* temp))) (define-vop (current-stack-pointer) (:results (res :scs (any-reg control-stack))) @@ -67,7 +68,7 @@ (define-vop (current-binding-pointer) (:results (res :scs (any-reg descriptor-reg))) (:generator 1 - (load-symbol-value res *binding-stack-pointer*))) + (load-tl-symbol-value res *binding-stack-pointer*))) ;;;; unwind block hackery @@ -80,7 +81,7 @@ (:results (block :scs (any-reg))) (:generator 22 (inst lea block (catch-block-ea tn)) - (load-symbol-value temp *current-unwind-protect-block*) + (load-tl-symbol-value temp *current-unwind-protect-block*) (storew temp block unwind-block-current-uwp-slot) (storew ebp-tn block unwind-block-current-cont-slot) (storew (make-fixup nil :code-object entry-label) @@ -96,42 +97,42 @@ (:temporary (:sc descriptor-reg) temp) (:generator 44 (inst lea block (catch-block-ea tn)) - (load-symbol-value temp *current-unwind-protect-block*) + (load-tl-symbol-value temp *current-unwind-protect-block*) (storew temp block unwind-block-current-uwp-slot) (storew ebp-tn block unwind-block-current-cont-slot) (storew (make-fixup nil :code-object entry-label) block catch-block-entry-pc-slot) (storew tag block catch-block-tag-slot) - (load-symbol-value temp *current-catch-block*) + (load-tl-symbol-value temp *current-catch-block*) (storew temp block catch-block-previous-catch-slot) - (store-symbol-value block *current-catch-block*))) + (store-tl-symbol-value block *current-catch-block* temp))) ;;; Just set the current unwind-protect to TN's address. This instantiates an ;;; unwind block as an unwind-protect. (define-vop (set-unwind-protect) (:args (tn)) - (:temporary (:sc unsigned-reg) new-uwp) + (:temporary (:sc unsigned-reg) new-uwp tls) (:generator 7 (inst lea new-uwp (catch-block-ea tn)) - (store-symbol-value new-uwp *current-unwind-protect-block*))) + (store-tl-symbol-value new-uwp *current-unwind-protect-block* tls))) (define-vop (unlink-catch-block) - (:temporary (:sc unsigned-reg) block) + (:temporary (:sc unsigned-reg) tls block) (:policy :fast-safe) (:translate %catch-breakup) (:generator 17 - (load-symbol-value block *current-catch-block*) + (load-tl-symbol-value block *current-catch-block*) (loadw block block catch-block-previous-catch-slot) - (store-symbol-value block *current-catch-block*))) + (store-tl-symbol-value block *current-catch-block* tls))) (define-vop (unlink-unwind-protect) - (:temporary (:sc unsigned-reg) block) + (:temporary (:sc unsigned-reg) block tls) (:policy :fast-safe) (:translate %unwind-protect-breakup) (:generator 17 - (load-symbol-value block *current-unwind-protect-block*) + (load-tl-symbol-value block *current-unwind-protect-block*) (loadw block block unwind-block-current-uwp-slot) - (store-symbol-value block *current-unwind-protect-block*))) + (store-tl-symbol-value block *current-unwind-protect-block* tls))) ;;;; NLX entry VOPs (define-vop (nlx-entry) Index: parms.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/parms.lisp,v retrieving revision 1.30.6.1 retrieving revision 1.30.6.2 diff -u -d -r1.30.6.1 -r1.30.6.2 --- parms.lisp 24 Nov 2002 13:14:16 -0000 1.30.6.1 +++ parms.lisp 2 Dec 2002 15:57:51 -0000 1.30.6.2 @@ -254,9 +254,13 @@ sb!unix::*interrupt-pending* *free-interrupt-context-index* + *free-tls-index* + *allocation-pointer* *binding-stack-pointer* + *current-thread-struct* + ;; the floating point constants *fp-constant-0d0* *fp-constant-1d0* Index: system.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/system.lisp,v retrieving revision 1.15 retrieving revision 1.15.6.1 diff -u -d -r1.15 -r1.15.6.1 --- system.lisp 15 Jan 2002 23:53:51 -0000 1.15 +++ system.lisp 2 Dec 2002 15:57:51 -0000 1.15.6.1 @@ -163,7 +163,7 @@ (:translate binding-stack-pointer-sap) (:policy :fast-safe) (:generator 1 - (load-symbol-value int *binding-stack-pointer*))) + (load-tl-symbol-value int *binding-stack-pointer*))) (defknown (setf binding-stack-pointer-sap) (system-area-pointer) system-area-pointer ()) @@ -173,10 +173,11 @@ (:arg-types system-area-pointer) (:results (int :scs (sap-reg))) (:result-types system-area-pointer) + (:temporary (:sc any-reg) temp) (:translate (setf binding-stack-pointer-sap)) (:policy :fast-safe) (:generator 1 - (store-symbol-value new-value *binding-stack-pointer*) + (store-tl-symbol-value new-value *binding-stack-pointer* temp) (move int new-value))) (define-vop (control-stack-pointer-sap) |