X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fmacros.lisp;h=aa6f1e707f7764acd09bd44b177b795c92314363;hb=4c400df29038a283e6b4df2d835d5b9c5201d0dd;hp=4c1fba68413d8239afb9796c16d7a08d88f00e4a;hpb=bbc19242c0683a6c8cb93146eab22e29aa453801;p=sbcl.git diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index 4c1fba6..aa6f1e7 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -31,10 +31,10 @@ ;;; 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) + (inst fstp ,tn) + ,@body + (unless (zerop (tn-offset ,tn)) + (inst fxch ,tn)))) ; save into new dest and restore st(0) ;;;; instruction-like macros @@ -112,8 +112,7 @@ (defmacro load-tl-symbol-value (reg symbol) `(progn (inst mov ,reg (make-ea-for-symbol-tls-index ,symbol)) - (inst fs-segment-prefix) - (inst mov ,reg (make-ea :dword :base ,reg)))) + (inst mov ,reg (make-ea :dword :base ,reg) :fs))) #!-sb-thread (defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol)) @@ -121,8 +120,7 @@ (defmacro store-tl-symbol-value (reg symbol temp) `(progn (inst mov ,temp (make-ea-for-symbol-tls-index ,symbol)) - (inst fs-segment-prefix) - (inst mov (make-ea :dword :base ,temp) ,reg))) + (inst mov (make-ea :dword :base ,temp) ,reg :fs))) #!-sb-thread (defmacro store-tl-symbol-value (reg symbol temp) (declare (ignore temp)) @@ -131,19 +129,18 @@ (defmacro load-binding-stack-pointer (reg) #!+sb-thread `(progn - (inst fs-segment-prefix) (inst mov ,reg (make-ea :dword - :disp (* 4 thread-binding-stack-pointer-slot)))) + :disp (* 4 thread-binding-stack-pointer-slot)) + :fs)) #!-sb-thread `(load-symbol-value ,reg *binding-stack-pointer*)) (defmacro store-binding-stack-pointer (reg) #!+sb-thread `(progn - (inst fs-segment-prefix) (inst mov (make-ea :dword :disp (* 4 thread-binding-stack-pointer-slot)) - ,reg)) + ,reg :fs)) #!-sb-thread `(store-symbol-value ,reg *binding-stack-pointer*)) @@ -177,7 +174,7 @@ ;;; the duration. Now we have pseudoatomic there's no need for that ;;; overhead. -(defun allocation-dynamic-extent (alloc-tn size) +(defun allocation-dynamic-extent (alloc-tn size lowtag) (inst sub esp-tn size) ;; FIXME: SIZE _should_ be double-word aligned (suggested but ;; unfortunately not enforced by PAD-DATA-BLOCK and @@ -187,7 +184,7 @@ ;; 2004-03-30 (inst and esp-tn (lognot lowtag-mask)) (aver (not (location= alloc-tn esp-tn))) - (inst mov alloc-tn esp-tn) + (inst lea alloc-tn (make-ea :byte :base esp-tn :disp lowtag)) (values)) (defun allocation-notinline (alloc-tn size) @@ -226,10 +223,8 @@ :scale 1))) ; thread->alloc_region.end_addr (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 alloc-tn end-addr) + (inst add alloc-tn free-pointer #!+sb-thread :fs) + (inst cmp alloc-tn end-addr #!+sb-thread :fs) (inst jmp :be ok) (let ((dst (ecase (tn-offset alloc-tn) (#.eax-offset "alloc_overflow_eax") @@ -244,16 +239,12 @@ ;; Swap ALLOC-TN and FREE-POINTER (cond ((and (tn-p size) (location= alloc-tn size)) ;; XCHG is extremely slow, use the xor swap trick - #!+sb-thread (inst fs-segment-prefix) - (inst xor alloc-tn free-pointer) - #!+sb-thread (inst fs-segment-prefix) - (inst xor free-pointer alloc-tn) - #!+sb-thread (inst fs-segment-prefix) - (inst xor alloc-tn free-pointer)) + (inst xor alloc-tn free-pointer #!+sb-thread :fs) + (inst xor free-pointer alloc-tn #!+sb-thread :fs) + (inst xor alloc-tn free-pointer #!+sb-thread :fs)) (t ;; It's easier if SIZE is still available. - #!+sb-thread (inst fs-segment-prefix) - (inst mov free-pointer alloc-tn) + (inst mov free-pointer alloc-tn #!+sb-thread :fs) (inst sub alloc-tn size))) (emit-label done)) (values)) @@ -269,12 +260,16 @@ ;;; (FIXME: so why aren't we asserting this?) -(defun allocation (alloc-tn size &optional inline dynamic-extent) +(defun allocation (alloc-tn size &optional inline dynamic-extent lowtag) (cond - (dynamic-extent (allocation-dynamic-extent alloc-tn size)) + (dynamic-extent + (allocation-dynamic-extent alloc-tn size lowtag)) ((or (null inline) (policy inline (>= speed space))) (allocation-inline alloc-tn size)) - (t (allocation-notinline alloc-tn size))) + (t + (allocation-notinline alloc-tn size))) + (when (and lowtag (not dynamic-extent)) + (inst lea alloc-tn (make-ea :byte :base alloc-tn :disp lowtag))) (values)) ;;; Allocate an other-pointer object of fixed SIZE with a single word @@ -286,63 +281,56 @@ (bug "empty &body in WITH-FIXED-ALLOCATION")) (once-only ((result-tn result-tn) (size size) (stack-allocate-p stack-allocate-p)) `(maybe-pseudo-atomic ,stack-allocate-p - (allocation ,result-tn (pad-data-block ,size) ,inline ,stack-allocate-p) - (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag) - ,result-tn) - (inst lea ,result-tn - (make-ea :byte :base ,result-tn :disp other-pointer-lowtag)) - ,@forms))) + (allocation ,result-tn (pad-data-block ,size) ,inline ,stack-allocate-p + other-pointer-lowtag) + (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag) + ,result-tn 0 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))) - `((progn - #-darwin (inst int 3) ; i386 breakpoint instruction - ;; CLH 20060314 - ;; On Darwin, we need to use #x0b0f instead of int3 in order - ;; to generate a SIGILL instead of a SIGTRAP as darwin/x86 - ;; doesn't seem to be reliably firing SIGTRAP - ;; handlers. Hopefully this will be fixed by Apple at a - ;; later date. - #+darwin (inst word #x0b0f)) - ;; 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) +(defun emit-error-break (vop kind code values) + (assemble () + #!-darwin + (inst int 3) ; i386 breakpoint instruction + ;; CLH 20060314 + ;; On Darwin, we need to use #x0b0f instead of int3 in order + ;; to generate a SIGILL instead of a SIGTRAP as darwin/x86 + ;; doesn't seem to be reliably firing SIGTRAP + ;; handlers. Hopefully this will be fixed by Apple at a + ;; later date. + #!+darwin + (inst word #x0b0f) + ;; The return PC points here; note the location for the debugger. + (when vop + (note-this-location vop :internal-error)) + (inst byte kind) ; e.g. trap_xyyy + (with-adjustable-vector (vector) ; interr arguments + (write-var-integer code vector) + (dolist (tn values) + ;; 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)) + (inst byte (length vector)) + (dotimes (i (length vector)) + (inst byte (aref vector i)))))) + +(defun 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-number-or-lose error-code) values)) -(defmacro generate-error-code (vop error-code &rest values) +(defun generate-error-code (vop error-code &rest values) #!+sb-doc "Generate-Error-Code Error-code Value* Emit code for an error with the specified Error-Code and context Values." - `(assemble (*elsewhere*) - (let ((start-lab (gen-label))) - (emit-label start-lab) - (error-call ,vop ,error-code ,@values) - start-lab))) + (assemble (*elsewhere*) + (let ((start-lab (gen-label))) + (emit-label start-lab) + (emit-error-break vop error-trap (error-number-or-lose error-code) values) + start-lab))) ;;;; PSEUDO-ATOMIC @@ -357,8 +345,8 @@ ;;; does not matter whether a signal occurs during construction of a ;;; dynamic-extent object, as the half-finished construction of the ;;; object will not cause any difficulty. We can therefore elide -(defmacro maybe-pseudo-atomic (really-p &body forms) - `(if ,really-p +(defmacro maybe-pseudo-atomic (not-really-p &body forms) + `(if ,not-really-p (progn ,@forms) (pseudo-atomic ,@forms))) @@ -366,16 +354,14 @@ (defmacro pseudo-atomic (&rest forms) (with-unique-names (label) `(let ((,label (gen-label))) - (inst fs-segment-prefix) - (inst or (make-ea :byte :disp (* 4 thread-pseudo-atomic-bits-slot)) - (fixnumize 1)) + (inst mov (make-ea :dword :disp (* 4 thread-pseudo-atomic-bits-slot)) + ebp-tn :fs) ,@forms - (inst fs-segment-prefix) - (inst xor (make-ea :byte :disp (* 4 thread-pseudo-atomic-bits-slot)) - (fixnumize 1)) + (inst xor (make-ea :dword :disp (* 4 thread-pseudo-atomic-bits-slot)) + ebp-tn :fs) (inst jmp :z ,label) - ;; if PAI was set, interrupts were disabled at the same - ;; time using the process signal mask. + ;; if PAI was set, interrupts were disabled at the same time + ;; using the process signal mask. (inst break pending-interrupt-trap) (emit-label ,label)))) @@ -383,14 +369,14 @@ (defmacro pseudo-atomic (&rest forms) (with-unique-names (label) `(let ((,label (gen-label))) - (inst or (make-ea-for-symbol-value *pseudo-atomic-bits* :byte) - (fixnumize 1)) + (inst mov (make-ea-for-symbol-value *pseudo-atomic-bits* :dword) + ebp-tn) ,@forms - (inst xor (make-ea-for-symbol-value *pseudo-atomic-bits* :byte) - (fixnumize 1)) + (inst xor (make-ea-for-symbol-value *pseudo-atomic-bits* :dword) + ebp-tn) (inst jmp :z ,label) - ;; if PAI was set, interrupts were disabled at the same - ;; time using the process signal mask. + ;; if PAI was set, interrupts were disabled at the same time + ;; using the process signal mask. (inst break pending-interrupt-trap) (emit-label ,label)))) @@ -413,8 +399,6 @@ (:result-types ,el-type) (:generator 5 (move eax old-value) - #!+sb-thread - (inst lock) (let ((ea (sc-case index (immediate (make-ea :dword :base object @@ -429,7 +413,7 @@ (make-ea :dword :base object :index index :disp (- (* ,offset n-word-bytes) ,lowtag)))))) - (inst cmpxchg ea new-value)) + (inst cmpxchg ea new-value :lock)) (move value eax))))) (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate) @@ -548,26 +532,30 @@ (move result value))))) ;;; helper for alien stuff. + (def!macro with-pinned-objects ((&rest objects) &body body) "Arrange with the garbage collector that the pages occupied by -OBJECTS will not be moved in memory for the duration of BODY. Useful -for e.g. foreign calls where another thread may trigger garbage -collection" +OBJECTS will not be moved in memory for the duration of BODY. +Useful for e.g. foreign calls where another thread may trigger +collection." (if objects - `(multiple-value-prog1 - (progn - ,@(loop for p in objects - collect - ;; There is no race here wrt to gc, because at every - ;; point during the execution there is a reference to - ;; P on the stack or in a register. - `(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 - ;; will get set appropriately from {a, the} frame pointer before it's - ;; next needed - (pop-words-from-c-stack ,(length objects))) + (let ((pins (make-gensym-list (length objects))) + (wpo (block-gensym "WPO"))) + ;; BODY is stuffed in a function to preserve the lexical + ;; environment. + `(flet ((,wpo () (progn ,@body))) + ;; PINS are dx-allocated in case the compiler for some + ;; unfathomable reason decides to allocate value-cells + ;; for them -- since we have DX value-cells on x86oid + ;; platforms this still forces them on the stack. + (dx-let ,(mapcar #'list pins objects) + (multiple-value-prog1 (,wpo) + ;; TOUCH-OBJECT has a VOP with an empty body: compiler + ;; thinks we're using the argument and doesn't flush + ;; the variable, but we don't have to pay any extra + ;; beyond that -- and MULTIPLE-VALUE-PROG1 keeps them + ;; live till the body has finished. *whew* + ,@(mapcar (lambda (pin) + `(touch-object ,pin)) + pins))))) `(progn ,@body)))