X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fmacros.lisp;h=bedd2743ac18441632986b1b1318e3f0860f978a;hb=3b0127f4fc07a0ced81303b3b5ffe2ac603be87d;hp=50c4322576ec430f67b2567bcb0e48e8b4a1959b;hpb=50305b602c3953440af716137a56f50cd204375d;p=sbcl.git diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index 50c4322..bedd274 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -84,7 +84,35 @@ (- other-pointer-lowtag))) ,reg)) - +#!+sb-thread +(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 fs-segment-prefix) + (inst mov ,reg (make-ea :dword :scale 1 :index ,reg)))) +#!-sb-thread +(defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol)) + +#!+sb-thread +(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 fs-segment-prefix) + (inst mov (make-ea :dword :scale 1 :index ,temp) ,reg))) +#!-sb-thread +(defmacro store-tl-symbol-value (reg symbol 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 @@ -145,52 +173,6 @@ (unless (and (tn-p size) (location= alloc-tn size)) (inst mov dst-tn size)))) (let ((alloc-tn-offset (tn-offset alloc-tn))) - ;; FIXME: All these (MAKE-FIXUP (EXTERN-ALIEN-NAME "foo") :FOREIGN) - ;; expressions should be moved into MACROLET ((ALIEN-FIXUP ..)), - ;; and INST CALL (MAKE-FIXUP ..) should become CALL-ALIEN-FIXUP. - (if (and #!+gencgc t #!-gencgc nil - *maybe-use-inline-allocation* - (or (null inline) (policy inline (>= speed space)))) - ;; Inline allocation with GENCGC. - (let ((ok (gen-label))) - ;; Load the size first so that the size can be in the same - ;; register as alloc-tn. - (load-size alloc-tn size) - (inst add alloc-tn - (make-fixup (extern-alien-name "current_region_free_pointer") - :foreign)) - (inst cmp alloc-tn - (make-fixup (extern-alien-name "current_region_end_addr") - :foreign)) - (inst jmp :be OK) - ;; Dispatch to the appropriate overflow routine. There is a - ;; routine for each destination. - ;; FIXME: Could we use an alist here instead of an ECASE with lots - ;; of duplicate code? (and similar question for next ECASE, too) - (ecase alloc-tn-offset - (#.eax-offset ;; FIXME: Why the #\# #\.? - (inst call (make-fixup (extern-alien-name "alloc_overflow_eax") - :foreign))) - (#.ecx-offset - (inst call (make-fixup (extern-alien-name "alloc_overflow_ecx") - :foreign))) - (#.edx-offset - (inst call (make-fixup (extern-alien-name "alloc_overflow_edx") - :foreign))) - (#.ebx-offset - (inst call (make-fixup (extern-alien-name "alloc_overflow_ebx") - :foreign))) - (#.esi-offset - (inst call (make-fixup (extern-alien-name "alloc_overflow_esi") - :foreign))) - (#.edi-offset - (inst call (make-fixup (extern-alien-name "alloc_overflow_edi") - :foreign)))) - (emit-label ok) - (inst xchg (make-fixup - (extern-alien-name "current_region_free_pointer") - :foreign) - alloc-tn)) ;; C call to allocate via dispatch routines. Each ;; destination has a special entry point. The size may be a ;; register or a constant. @@ -254,7 +236,7 @@ (t (load-size edi-tn size) (inst call (make-fixup (extern-alien-name "alloc_to_edi") - :foreign))))))))) + :foreign)))))))) (values)) ;;; Allocate an other-pointer object of fixed SIZE with a single word @@ -271,21 +253,6 @@ ,@forms)) ;;;; error code - -(defvar *adjustable-vectors* nil) - -(defmacro with-adjustable-vector ((var) &rest body) - `(let ((,var (or (pop *adjustable-vectors*) - (make-array 16 - :element-type '(unsigned-byte 8) - :fill-pointer 0 - :adjustable t)))) - (setf (fill-pointer ,var) 0) - (unwind-protect - (progn - ,@body) - (push ,var *adjustable-vectors*)))) - (eval-when (:compile-toplevel :load-toplevel :execute) (defun emit-error-break (vop kind code values) (let ((vector (gensym))) @@ -318,17 +285,6 @@ (cons 'progn (emit-error-break vop error-trap error-code values))) -;;; not used in SBCL -#| -(defmacro cerror-call (vop label error-code &rest values) - #!+sb-doc - "Cause a continuable error. If the error is continued, execution resumes - at LABEL." - `(progn - ,@(emit-error-break vop cerror-trap error-code values) - (inst jmp ,label))) -|# - (defmacro generate-error-code (vop error-code &rest values) #!+sb-doc "Generate-Error-Code Error-code Value* @@ -339,34 +295,9 @@ (error-call ,vop ,error-code ,@values) start-lab))) -;;; not used in SBCL -#| -(defmacro generate-cerror-code (vop error-code &rest values) - #!+sb-doc - "Generate-CError-Code Error-code Value* - Emit code for a continuable error with the specified Error-Code and - context Values. If the error is continued, execution resumes after - the GENERATE-CERROR-CODE form." - (let ((continue (gensym "CONTINUE-LABEL-")) - (error (gensym "ERROR-LABEL-"))) - `(let ((,continue (gen-label)) - (,error (gen-label))) - (emit-label ,continue) - (assemble (*elsewhere*) - (emit-label ,error) - (cerror-call ,vop ,continue ,error-code ,@values)) - ,error))) -|# ;;;; PSEUDO-ATOMIC -;;; FIXME: This should be a compile-time option, not a runtime option. Doing it -;;; at runtime is bizarre. As I understand it, the default should definitely be -;;; to have pseudo-atomic behavior, but for a performance-critical program -;;; which is guaranteed not to have asynchronous exceptions, it could be worth -;;; something to compile with :SB-NO-PSEUDO-ATOMIC. -(defvar *enable-pseudo-atomic* t) - ;;; 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 @@ -374,50 +305,74 @@ ;;; FIXME: It appears that PSEUDO-ATOMIC is used to wrap operations which leave ;;; untagged memory lying around, but some documentation would be nice. +#!+sb-thread +(defmacro pseudo-atomic (&rest forms) + (let ((label (gensym "LABEL-"))) + `(let ((,label (gen-label))) + (inst fs-segment-prefix) + (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 1) + (inst fs-segment-prefix) + (inst mov (make-ea :byte + :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0) + ,@forms + (inst fs-segment-prefix) + (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 0) + (inst fs-segment-prefix) + (inst cmp (make-ea :byte + :disp (* 4 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) (let ((label (gensym "LABEL-"))) `(let ((,label (gen-label))) - (when *enable-pseudo-atomic* - ;; FIXME: The MAKE-EA noise should become a MACROLET macro or - ;; something. (perhaps SVLB, for static variable low byte) - (inst mov (make-ea :byte :disp (+ nil-value - (static-symbol-offset - '*pseudo-atomic-interrupted*) - (ash symbol-value-slot word-shift) - ;; FIXME: Use mask, not minus, to - ;; take out type bits. - (- other-pointer-lowtag))) - 0) - (inst mov (make-ea :byte :disp (+ nil-value - (static-symbol-offset - '*pseudo-atomic-atomic*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) - (fixnumize 1))) - ,@forms - (when *enable-pseudo-atomic* - (inst mov (make-ea :byte :disp (+ nil-value - (static-symbol-offset - '*pseudo-atomic-atomic*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) - 0) - ;; KLUDGE: Is there any requirement for interrupts to be - ;; handled in order? It seems as though an interrupt coming - ;; in at this point will be executed before any pending interrupts. - ;; Or do incoming interrupts check to see whether any interrupts - ;; are pending? I wish I could find the documentation for - ;; pseudo-atomics.. -- WHN 19991130 - (inst cmp (make-ea :byte - :disp (+ nil-value - (static-symbol-offset - '*pseudo-atomic-interrupted*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) - 0) - (inst jmp :eq ,label) - (inst break pending-interrupt-trap) - (emit-label ,label))))) + ;; FIXME: The MAKE-EA noise should become a MACROLET macro or + ;; something. (perhaps SVLB, for static variable low byte) + (inst mov (make-ea :byte :disp (+ nil-value + (static-symbol-offset + '*pseudo-atomic-interrupted*) + (ash symbol-value-slot word-shift) + ;; FIXME: Use mask, not minus, to + ;; take out type bits. + (- other-pointer-lowtag))) + 0) + (inst mov (make-ea :byte :disp (+ nil-value + (static-symbol-offset + '*pseudo-atomic-atomic*) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag))) + (fixnumize 1)) + ,@forms + (inst mov (make-ea :byte :disp (+ nil-value + (static-symbol-offset + '*pseudo-atomic-atomic*) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag))) + 0) + ;; KLUDGE: Is there any requirement for interrupts to be + ;; handled in order? It seems as though an interrupt coming + ;; in at this point will be executed before any pending interrupts. + ;; Or do incoming interrupts check to see whether any interrupts + ;; are pending? I wish I could find the documentation for + ;; pseudo-atomics.. -- WHN 19991130 + (inst cmp (make-ea :byte + :disp (+ nil-value + (static-symbol-offset + '*pseudo-atomic-interrupted*) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag))) + 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)))) + + ;;;; indexed references