X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fmacros.lisp;h=0a1ae74cd72b2d541e2b37460991fe0733e1d79f;hb=0d871fd7a98fc4af92a8b942a1154761466ad8c9;hp=62d00c9cbeb3a880892d0f53f7d17a618a4eb4f2;hpb=5cc68148d1a5f9bacf4eb12e396b680d992fc2c2;p=sbcl.git diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp index 62d00c9..0a1ae74 100644 --- a/src/compiler/x86-64/macros.lisp +++ b/src/compiler/x86-64/macros.lisp @@ -11,38 +11,13 @@ (in-package "SB!VM") -;;; We can load/store into fp registers through the top of stack -;;; %st(0) (fr0 here). Loads imply a push to an empty register which -;;; then changes all the reg numbers. These macros help manage that. - -;;; Use this when we don't have to load anything. It preserves old tos -;;; value, but probably destroys tn with operation. -(defmacro with-tn@fp-top((tn) &body body) - `(progn - (unless (zerop (tn-offset ,tn)) - (inst fxch ,tn)) - ,@body - (unless (zerop (tn-offset ,tn)) - (inst fxch ,tn)))) - -;;; Use this to prepare for load of new value from memory. This -;;; changes the register numbering so the next instruction had better -;;; be a FP load from memory; a register load from another register -;;; will probably be loading the wrong register! -(defmacro with-empty-tn@fp-top((tn) &body body) - `(progn - (inst fstp ,tn) - ,@body - (unless (zerop (tn-offset ,tn)) - (inst fxch ,tn)))) ; save into new dest and restore st(0) - ;;;; instruction-like macros (defmacro move (dst src) #!+sb-doc "Move SRC into DST unless they are location=." (once-only ((n-dst dst) - (n-src src)) + (n-src src)) `(unless (location= ,n-dst ,n-src) (inst mov ,n-dst ,n-src)))) @@ -56,15 +31,15 @@ (defmacro storew (value ptr &optional (slot 0) (lowtag 0)) (once-only ((value value)) - `(cond ((and (integerp ,value) - (not (typep ,value '(signed-byte 32)))) - (multiple-value-bind (lo hi) (dwords-for-quad ,value) - (inst mov (make-ea-for-object-slot-half - ,ptr ,slot ,lowtag) lo) - (inst mov (make-ea-for-object-slot-half - ,ptr (+ ,slot 1/2) ,lowtag) hi))) - (t - (inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value))))) + `(cond ((and (integerp ,value) + (not (typep ,value '(signed-byte 32)))) + (multiple-value-bind (lo hi) (dwords-for-quad ,value) + (inst mov (make-ea-for-object-slot-half + ,ptr ,slot ,lowtag) lo) + (inst mov (make-ea-for-object-slot-half + ,ptr (+ ,slot 1/2) ,lowtag) hi))) + (t + (inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value))))) (defmacro pushw (ptr &optional (slot 0) (lowtag 0)) `(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag))) @@ -79,20 +54,20 @@ (defmacro load-symbol-value (reg symbol) `(inst mov ,reg - (make-ea :qword - :disp (+ nil-value - (static-symbol-offset ',symbol) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))))) + (make-ea :qword + :disp (+ nil-value + (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag))))) (defmacro store-symbol-value (reg symbol) `(inst mov - (make-ea :qword - :disp (+ nil-value - (static-symbol-offset ',symbol) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) - ,reg)) + (make-ea :qword + :disp (+ nil-value + (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag))) + ,reg)) #!+sb-thread (defmacro load-tl-symbol-value (reg symbol) @@ -100,11 +75,10 @@ (inst mov ,reg (make-ea :qword :disp (+ nil-value - (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)))) + (static-symbol-offset ',symbol) + (ash symbol-tls-index-slot word-shift) + (- other-pointer-lowtag)))) + (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)) @@ -114,30 +88,29 @@ (inst mov ,temp (make-ea :qword :disp (+ nil-value - (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))) + (static-symbol-offset ',symbol) + (ash symbol-tls-index-slot word-shift) + (- other-pointer-lowtag)))) + (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)) `(store-symbol-value ,reg ,symbol)) - + (defmacro load-type (target source &optional (offset 0)) #!+sb-doc "Loads the type bits of a pointer into target independent of byte-ordering issues." (once-only ((n-target target) - (n-source source) - (n-offset offset)) + (n-source source) + (n-offset offset)) (ecase *backend-byte-order* (:little-endian `(inst mov ,n-target - (make-ea :byte :base ,n-source :disp ,n-offset))) + (make-ea :byte :base ,n-source :disp ,n-offset))) (:big-endian `(inst mov ,n-target - (make-ea :byte :base ,n-source :disp (+ ,n-offset 4))))))) + (make-ea :byte :base ,n-source :disp (+ ,n-offset 4))))))) ;;;; allocation helpers @@ -149,6 +122,14 @@ ;;; node-var then it is used to make an appropriate speed vs size ;;; decision. +(defun allocation-dynamic-extent (alloc-tn size) + (inst sub rsp-tn size) + ;; see comment in x86/macros.lisp implementation of this + (inst and rsp-tn #.(lognot lowtag-mask)) + (aver (not (location= alloc-tn rsp-tn))) + (inst mov alloc-tn rsp-tn) + (values)) + ;;; This macro should only be used inside a pseudo-atomic section, ;;; which should also cover subsequent initialization of the ;;; object. @@ -156,60 +137,66 @@ (declare (ignore ignored)) (inst push size) (inst lea r13-tn (make-ea :qword - :disp (make-fixup (extern-alien-name "alloc_tramp") - :foreign))) + :disp (make-fixup "alloc_tramp" :foreign))) (inst call r13-tn) (inst pop alloc-tn) (values)) -(defun allocation (alloc-tn size &optional ignored) +(defun allocation (alloc-tn size &optional ignored dynamic-extent) (declare (ignore ignored)) - (let ((not-inline (gen-label)) - (done (gen-label)) - ;; 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 - (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 + (when dynamic-extent + (allocation-dynamic-extent alloc-tn size) + (return-from allocation (values))) + (let ((NOT-INLINE (gen-label)) + (DONE (gen-label)) + ;; Yuck. + (in-elsewhere (eq *elsewhere* sb!assem::**current-segment**)) + ;; thread->alloc_region.free_pointer + (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.end_addr + (end-addr + #!+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)))) (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*) - (emit-label NOT-INLINE) - (cond ((numberp size) - (allocation-tramp alloc-tn size)) - (t - (inst sub alloc-tn free-pointer) - (allocation-tramp alloc-tn alloc-tn))) - (inst jmp DONE)) - (values))))) + (allocation-tramp alloc-tn size)) + (t + (unless (and (tn-p size) (location= alloc-tn size)) + (inst mov alloc-tn size)) + (inst add alloc-tn free-pointer) + (inst cmp end-addr alloc-tn) + (inst jmp :be NOT-INLINE) + (inst xchg free-pointer alloc-tn) + (emit-label DONE) + (assemble (*elsewhere*) + (emit-label NOT-INLINE) + (cond ((numberp size) + (allocation-tramp alloc-tn size)) + (t + (inst sub alloc-tn free-pointer) + (allocation-tramp alloc-tn alloc-tn))) + (inst jmp DONE)) + (values))))) #+nil (defun allocation (alloc-tn size &optional ignored) (declare (ignore ignored)) (inst push size) (inst lea r13-tn (make-ea :qword - :disp (make-fixup (extern-alien-name "alloc_tramp") - :foreign))) + :disp (make-fixup "alloc_tramp" :foreign))) (inst call r13-tn) (inst pop alloc-tn) (values)) @@ -218,47 +205,50 @@ ;;; header having the specified WIDETAG value. The result is placed in ;;; RESULT-TN. (defmacro with-fixed-allocation ((result-tn widetag size &optional inline) - &rest forms) - `(pseudo-atomic - (allocation ,result-tn (pad-data-block ,size) ,inline) - (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag) - ,result-tn) - (inst lea ,result-tn - (make-ea :qword :base ,result-tn :disp other-pointer-lowtag)) - ,@forms)) + &body forms) + (unless forms + (bug "empty &body in WITH-FIXED-ALLOCATION")) + (once-only ((result-tn result-tn) (size size)) + `(pseudo-atomic + (allocation ,result-tn (pad-data-block ,size) ,inline) + (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag) + ,result-tn) + (inst lea ,result-tn + (make-ea :qword :base ,result-tn :disp other-pointer-lowtag)) + ,@forms))) ;;;; error code (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun emit-error-break (vop kind code values) (let ((vector (gensym))) - `((inst int 3) ; i386 breakpoint instruction - ;; The return PC points here; note the location for the debugger. - (let ((vop ,vop)) - (when vop - (note-this-location vop :internal-error))) - (inst byte ,kind) ; eg trap_Xyyy - (with-adjustable-vector (,vector) ; interr arguments - (write-var-integer (error-number-or-lose ',code) ,vector) - ,@(mapcar (lambda (tn) - `(let ((tn ,tn)) - ;; classic CMU CL comment: - ;; zzzzz jrd here. tn-offset is zero for constant - ;; tns. - (write-var-integer (make-sc-offset (sc-number - (tn-sc tn)) - (or (tn-offset tn) - 0)) - ,vector))) - values) - (inst byte (length ,vector)) - (dotimes (i (length ,vector)) - (inst byte (aref ,vector i)))))))) + `((inst int 3) ; i386 breakpoint instruction + ;; The return PC points here; note the location for the debugger. + (let ((vop ,vop)) + (when vop + (note-this-location vop :internal-error))) + (inst byte ,kind) ; eg trap_Xyyy + (with-adjustable-vector (,vector) ; interr arguments + (write-var-integer (error-number-or-lose ',code) ,vector) + ,@(mapcar (lambda (tn) + `(let ((tn ,tn)) + ;; classic CMU CL comment: + ;; zzzzz jrd here. tn-offset is zero for constant + ;; tns. + (write-var-integer (make-sc-offset (sc-number + (tn-sc tn)) + (or (tn-offset tn) + 0)) + ,vector))) + values) + (inst byte (length ,vector)) + (dotimes (i (length ,vector)) + (inst byte (aref ,vector i)))))))) (defmacro error-call (vop error-code &rest values) #!+sb-doc "Cause an error. ERROR-CODE is the error to cause." (cons 'progn - (emit-error-break vop error-trap error-code values))) + (emit-error-break vop error-trap error-code values))) (defmacro generate-error-code (vop error-code &rest values) #!+sb-doc @@ -277,13 +267,45 @@ ;;; around. It's an operation which the AOP weenies would describe as ;;; having "cross-cutting concerns", meaning it appears all over the ;;; place and there's no logical single place to attach documentation. -;;; grep (mostly in src/runtime) is your friend +;;; grep (mostly in src/runtime) is your friend ;;; FIXME: *PSEUDO-ATOMIC-FOO* could be made into *PSEUDO-ATOMIC-BITS*, ;;; set with a single operation and cleared with SHR *PSEUDO-ATOMIC-BITS*,-2; ;;; 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. +;;; FIXME: THIS NAME IS BACKWARDS! +(defmacro maybe-pseudo-atomic (really-p &body body) + `(if ,really-p + (progn ,@body) + (pseudo-atomic ,@body))) + +#!+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)) + (fixnumize 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))) @@ -325,7 +347,7 @@ 0) (inst jmp :eq ,label) ;; if PAI was set, interrupts were disabled at the same time - ;; using the process signal mask. + ;; using the process signal mask. (inst break pending-interrupt-trap) (emit-label ,label)))) @@ -337,69 +359,69 @@ `(progn (define-vop (,name) ,@(when translate - `((:translate ,translate))) + `((:translate ,translate))) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg))) (:arg-types ,type tagged-num) (:results (value :scs ,scs)) (:result-types ,el-type) - (:generator 3 ; pw was 5 - (inst mov value (make-ea :qword :base object :index index - :disp (- (* ,offset n-word-bytes) - ,lowtag))))) + (:generator 3 ; pw was 5 + (inst mov value (make-ea :qword :base object :index index + :disp (- (* ,offset n-word-bytes) + ,lowtag))))) (define-vop (,(symbolicate name "-C")) ,@(when translate - `((:translate ,translate))) + `((:translate ,translate))) (:policy :fast-safe) (:args (object :scs (descriptor-reg))) (:info index) (:arg-types ,type - (:constant (load/store-index ,n-word-bytes ,(eval lowtag) - ,(eval offset)))) + (:constant (load/store-index ,n-word-bytes ,(eval lowtag) + ,(eval offset)))) (:results (value :scs ,scs)) (:result-types ,el-type) - (:generator 2 ; pw was 5 - (inst mov value (make-ea :qword :base object - :disp (- (* (+ ,offset index) n-word-bytes) - ,lowtag))))))) + (:generator 2 ; pw was 5 + (inst mov value (make-ea :qword :base object + :disp (- (* (+ ,offset index) n-word-bytes) + ,lowtag))))))) (defmacro define-full-setter (name type offset lowtag scs el-type &optional translate) `(progn (define-vop (,name) ,@(when translate - `((:translate ,translate))) + `((:translate ,translate))) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs ,scs :target result)) + (index :scs (any-reg)) + (value :scs ,scs :target result)) (:arg-types ,type tagged-num ,el-type) (:results (result :scs ,scs)) (:result-types ,el-type) - (:generator 4 ; was 5 - (inst mov (make-ea :qword :base object :index index - :disp (- (* ,offset n-word-bytes) ,lowtag)) - value) - (move result value))) + (:generator 4 ; was 5 + (inst mov (make-ea :qword :base object :index index + :disp (- (* ,offset n-word-bytes) ,lowtag)) + value) + (move result value))) (define-vop (,(symbolicate name "-C")) ,@(when translate - `((:translate ,translate))) + `((:translate ,translate))) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (value :scs ,scs :target result)) + (value :scs ,scs :target result)) (:info index) (:arg-types ,type - (:constant (load/store-index ,n-word-bytes ,(eval lowtag) - ,(eval offset))) - ,el-type) + (:constant (load/store-index ,n-word-bytes ,(eval lowtag) + ,(eval offset))) + ,el-type) (:results (result :scs ,scs)) (:result-types ,el-type) - (:generator 3 ; was 5 - (inst mov (make-ea :qword :base object - :disp (- (* (+ ,offset index) n-word-bytes) - ,lowtag)) - value) - (move result value))))) + (:generator 3 ; was 5 + (inst mov (make-ea :qword :base object + :disp (- (* (+ ,offset index) n-word-bytes) + ,lowtag)) + value) + (move result value))))) ;;; helper for alien stuff. (defmacro with-pinned-objects ((&rest objects) &body body) @@ -409,10 +431,10 @@ Useful for e.g. foreign calls where another thread may trigger garbage collection" `(multiple-value-prog1 (progn - ,@(loop for p in objects - collect `(push-word-on-c-stack - (int-sap (sb!kernel:get-lisp-obj-address ,p)))) - ,@body) + ,@(loop for p in objects + collect `(push-word-on-c-stack + (int-sap (sb!kernel:get-lisp-obj-address ,p)))) + ,@body) ;; If the body returned normally, we should restore the stack pointer ;; for the benefit of any following code in the same function. If ;; there's a non-local exit in the body, sp is garbage anyway and