X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fcell.lisp;h=92f43a1c3269a1fcdd4d5f8934f6571be149e544;hb=3fe0010d2777b41e01ea9b4a0f894cfa40f7df1b;hp=87c5e9c12a03529d119fba92c62b539556ea94dc;hpb=78fa16bf55be44cc16845be84d98023e83fb14bc;p=sbcl.git diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index 87c5e9c..92f43a1 100644 --- a/src/compiler/x86-64/cell.lisp +++ b/src/compiler/x86-64/cell.lisp @@ -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 @@ -261,9 +261,9 @@ :disp (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))) (inst cmp type simple-fun-header-widetag) - (inst jmp :e normal-fn) - (inst lea raw (make-fixup (extern-alien-name "closure_tramp") :foreign)) - NORMAL-FN + (inst jmp :e NORMAL-FUN) + (inst lea raw (make-fixup "closure_tramp" :foreign)) + NORMAL-FUN (storew function fdefn fdefn-fun-slot other-pointer-lowtag) (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag) (move result function))) @@ -275,7 +275,7 @@ (:results (result :scs (descriptor-reg))) (:generator 38 (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag) - (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign) + (storew (make-fixup "undefined_tramp" :foreign) fdefn fdefn-raw-addr-slot other-pointer-lowtag) (move result fdefn))) @@ -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,8 @@ (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)) @@ -365,25 +365,26 @@ (:generator 0 (load-tl-symbol-value bsp *binding-stack-pointer*) (inst cmp where bsp) - (inst jmp :e done) + (inst jmp :e DONE) LOOP (loadw symbol bsp (- binding-symbol-slot binding-size)) (inst or symbol symbol) - (inst jmp :z skip) + (inst jmp :z SKIP) (loadw value bsp (- binding-value-slot binding-size)) - #!-sb-thread (storew value symbol symbol-value-slot other-pointer-lowtag) - - #!+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 + (storew value symbol symbol-value-slot other-pointer-lowtag) + #!+sb-thread + (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + #!+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 (inst sub bsp (* binding-size n-word-bytes)) (inst cmp where bsp) - (inst jmp :ne loop) + (inst jmp :ne LOOP) ;; we're done with value, so can use it as a temporary (store-tl-symbol-value bsp *binding-stack-pointer* value) @@ -460,22 +461,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))) @@ -486,3 +487,282 @@ (define-full-setter code-header-set * 0 other-pointer-lowtag (any-reg descriptor-reg) * code-header-set) + + + +;;;; raw instance slot accessors + +(define-vop (raw-instance-ref/word) + (:translate %raw-instance-ref/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) + (:arg-types * tagged-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (inst mov + value + (make-ea :qword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))))) + +(define-vop (raw-instance-set/word) + (:translate %raw-instance-set/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (unsigned-reg) :target result)) + (:arg-types * tagged-num unsigned-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (inst mov + (make-ea :qword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + value) + (move result value))) + +(define-vop (raw-instance-ref/single) + (:translate %raw-instance-ref/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (inst movss + value + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))))) + +(define-vop (raw-instance-set/single) + (:translate %raw-instance-set/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (single-reg) :target result)) + (:arg-types * positive-fixnum single-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (inst movss + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + value) + (unless (location= result value) + (inst movss result value)))) + +(define-vop (raw-instance-ref/double) + (:translate %raw-instance-ref/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (double-reg))) + (:result-types double-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (inst movsd + value + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))))) + +(define-vop (raw-instance-set/double) + (:translate %raw-instance-set/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (double-reg) :target result)) + (:arg-types * positive-fixnum double-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (inst movsd + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + value) + (unless (location= result value) + (inst movsd result value)))) + +(define-vop (raw-instance-ref/complex-single) + (:translate %raw-instance-ref/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (let ((real-tn (complex-single-reg-real-tn value))) + (inst movss + real-tn + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)))) + (let ((imag-tn (complex-single-reg-imag-tn value))) + (inst movss + imag-tn + (make-ea :dword + :base object + :index tmp + :disp (+ (* (1- instance-slots-offset) n-word-bytes) + 4 + (- instance-pointer-lowtag))))))) + +(define-vop (raw-instance-set/complex-single) + (:translate %raw-instance-set/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-single-reg) :target result)) + (:arg-types * positive-fixnum complex-single-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (inst movss (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + value-real) + (unless (location= value-real result-real) + (inst movss result-real value-real))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst movss (make-ea :dword + :base object + :index tmp + :disp (+ (* (1- instance-slots-offset) n-word-bytes) + 4 + (- instance-pointer-lowtag))) + value-imag) + (unless (location= value-imag result-imag) + (inst movss result-imag value-imag))))) + +(define-vop (raw-instance-ref/complex-double) + (:translate %raw-instance-ref/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (let ((real-tn (complex-double-reg-real-tn value))) + (inst movsd + real-tn + (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)))) + (let ((imag-tn (complex-double-reg-imag-tn value))) + (inst movsd + imag-tn + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)))))) + +(define-vop (raw-instance-set/complex-double) + (:translate %raw-instance-set/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-double-reg) :target result)) + (:arg-types * positive-fixnum complex-double-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 3) + (inst sub tmp index) + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (inst movsd (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)) + value-real) + (unless (location= value-real result-real) + (inst movsd result-real value-real))) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst movsd (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + value-imag) + (unless (location= value-imag result-imag) + (inst movsd result-imag value-imag)))))