X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fmacros.lisp;h=9db903d47ab78e531aaa22f81ce71a686d0e6391;hb=3d9d3088982414ca5617caf62bd37b4fecac29b6;hp=b82ca88006f525d3a05de4f6c33e67ec04030aaa;hpb=aa2dc9529460ea0d9c99998dc87283fc1a43e808;p=sbcl.git diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index b82ca88..9db903d 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -11,12 +11,12 @@ (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. +;;; 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. +;;; 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)) @@ -47,7 +47,7 @@ (inst mov ,n-dst ,n-src)))) (defmacro make-ea-for-object-slot (ptr slot lowtag) - `(make-ea :dword :base ,ptr :disp (- (* ,slot word-bytes) ,lowtag))) + `(make-ea :dword :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag))) (defmacro loadw (value ptr &optional (slot 0) (lowtag 0)) `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag))) @@ -73,7 +73,7 @@ :disp (+ nil-value (static-symbol-offset ',symbol) (ash symbol-value-slot word-shift) - (- other-pointer-type))))) + (- other-pointer-lowtag))))) (defmacro store-symbol-value (reg symbol) `(inst mov @@ -81,7 +81,7 @@ :disp (+ nil-value (static-symbol-offset ',symbol) (ash symbol-value-slot word-shift) - (- other-pointer-type))) + (- other-pointer-lowtag))) ,reg)) @@ -145,52 +145,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,38 +208,23 @@ (t (load-size edi-tn size) (inst call (make-fixup (extern-alien-name "alloc_to_edi") - :foreign))))))))) + :foreign)))))))) (values)) -(defmacro with-fixed-allocation ((result-tn type-code size &optional inline) +;;; Allocate an other-pointer object of fixed SIZE with a single word +;;; 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) - #!+sb-doc - "Allocate an other-pointer object of fixed Size with a single - word header having the specified Type-Code. The result is placed in - Result-TN." `(pseudo-atomic (allocation ,result-tn (pad-data-block ,size) ,inline) - (storew (logior (ash (1- ,size) sb!vm:type-bits) ,type-code) ,result-tn) + (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag) + ,result-tn) (inst lea ,result-tn - (make-ea :byte :base ,result-tn :disp other-pointer-type)) + (make-ea :byte :base ,result-tn :disp other-pointer-lowtag)) ,@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))) @@ -360,13 +299,6 @@ ;;;; 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 @@ -377,47 +309,47 @@ (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-type))) - 0) - (inst mov (make-ea :byte :disp (+ nil-value - (static-symbol-offset - '*pseudo-atomic-atomic*) - (ash symbol-value-slot word-shift) - (- other-pointer-type))) - (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-type))) - 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-type))) - 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 @@ -434,7 +366,8 @@ (:result-types ,el-type) (:generator 3 ; pw was 5 (inst mov value (make-ea :dword :base object :index index - :disp (- (* ,offset word-bytes) ,lowtag))))) + :disp (- (* ,offset n-word-bytes) + ,lowtag))))) (define-vop (,(symbolicate name "-C")) ,@(when translate `((:translate ,translate))) @@ -446,7 +379,7 @@ (:result-types ,el-type) (:generator 2 ; pw was 5 (inst mov value (make-ea :dword :base object - :disp (- (* (+ ,offset index) word-bytes) + :disp (- (* (+ ,offset index) n-word-bytes) ,lowtag))))))) (defmacro define-full-setter (name type offset lowtag scs el-type &optional translate) @@ -463,7 +396,7 @@ (:result-types ,el-type) (:generator 4 ; was 5 (inst mov (make-ea :dword :base object :index index - :disp (- (* ,offset word-bytes) ,lowtag)) + :disp (- (* ,offset n-word-bytes) ,lowtag)) value) (move result value))) (define-vop (,(symbolicate name "-C")) @@ -478,7 +411,8 @@ (:result-types ,el-type) (:generator 3 ; was 5 (inst mov (make-ea :dword :base object - :disp (- (* (+ ,offset index) word-bytes) ,lowtag)) + :disp (- (* (+ ,offset index) n-word-bytes) + ,lowtag)) value) (move result value)))))