src/compiler/x86/macros.lisp

   1 ;;;; a bunch of handy macros for the x86
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13
  14 ;;; We can load/store into fp registers through the top of stack
  15 ;;; %st(0) (fr0 here). Loads imply a push to an empty register which
  16 ;;; then changes all the reg numbers. These macros help manage that.
  17
  18 ;;; Use this when we don't have to load anything. It preserves old tos
  19 ;;; value, but probably destroys tn with operation.
  20 (defmacro with-tn@fp-top((tn) &body body)
  21   `(progn
  22     (unless (zerop (tn-offset ,tn))
  23       (inst fxch ,tn))
  24     ,@body
  25     (unless (zerop (tn-offset ,tn))
  26       (inst fxch ,tn))))
  27
  28 ;;; Use this to prepare for load of new value from memory. This
  29 ;;; changes the register numbering so the next instruction had better
  30 ;;; be a FP load from memory; a register load from another register
  31 ;;; will probably be loading the wrong register!
  32 (defmacro with-empty-tn@fp-top((tn) &body body)
  33   `(progn
  34     (inst fstp ,tn)
  35     ,@body
  36     (unless (zerop (tn-offset ,tn))
  37       (inst fxch ,tn))))                ; save into new dest and restore st(0)
  38 \f
  39 ;;;; instruction-like macros
  40
  41 (defmacro move (dst src)
  42   #!+sb-doc
  43   "Move SRC into DST unless they are location=."
  44   (once-only ((n-dst dst)
  45               (n-src src))
  46     `(unless (location= ,n-dst ,n-src)
  47        (inst mov ,n-dst ,n-src))))
  48
  49 (defmacro make-ea-for-object-slot (ptr slot lowtag)
  50   `(make-ea :dword :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
  51
  52 (defmacro loadw (value ptr &optional (slot 0) (lowtag 0))
  53   `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
  54
  55 (defmacro storew (value ptr &optional (slot 0) (lowtag 0))
  56   (once-only ((value value))
  57     `(inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value)))
  58
  59 (defmacro pushw (ptr &optional (slot 0) (lowtag 0))
  60   `(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
  61
  62 (defmacro popw (ptr &optional (slot 0) (lowtag 0))
  63   `(inst pop (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
  64 \f
  65 ;;;; macros to generate useful values
  66
  67 (defmacro load-symbol (reg symbol)
  68   `(inst mov ,reg (+ nil-value (static-symbol-offset ,symbol))))
  69
  70 (defmacro load-symbol-value (reg symbol)
  71   `(inst mov ,reg
  72          (make-ea :dword
  73                   :disp (+ nil-value
  74                            (static-symbol-offset ',symbol)
  75                            (ash symbol-value-slot word-shift)
  76                            (- other-pointer-lowtag)))))
  77
  78 (defmacro store-symbol-value (reg symbol)
  79   `(inst mov
  80          (make-ea :dword
  81                   :disp (+ nil-value
  82                            (static-symbol-offset ',symbol)
  83                            (ash symbol-value-slot word-shift)
  84                            (- other-pointer-lowtag)))
  85          ,reg))
  86
  87
  88 (defmacro load-type (target source &optional (offset 0))
  89   #!+sb-doc
  90   "Loads the type bits of a pointer into target independent of
  91    byte-ordering issues."
  92   (once-only ((n-target target)
  93               (n-source source)
  94               (n-offset offset))
  95     (ecase *backend-byte-order*
  96       (:little-endian
  97        `(inst mov ,n-target
  98               (make-ea :byte :base ,n-source :disp ,n-offset)))
  99       (:big-endian
 100        `(inst mov ,n-target
 101               (make-ea :byte :base ,n-source :disp (+ ,n-offset 3)))))))
 102 \f
 103 ;;;; allocation helpers
 104
 105 ;;; Two allocation approaches are implemented. A call into C can be
 106 ;;; used, and in that case special care can be taken to disable
 107 ;;; interrupts. Alternatively with gencgc inline allocation is possible
 108 ;;; although it isn't interrupt safe.
 109
 110 ;;; For GENCGC it is possible to inline object allocation, to permit
 111 ;;; this set the following variable to True.
 112 ;;;
 113 ;;; FIXME: The comment above says that this isn't interrupt safe. Is that
 114 ;;; right? If so, do we want to do this? And surely we don't want to do this by
 115 ;;; default? How much time does it save to do this? Is it any different in the
 116 ;;; current CMU CL version instead of the one that I grabbed in 1998?
 117 ;;; (Later observation: In order to be interrupt safe, it'd probably
 118 ;;; have to use PSEUDO-ATOMIC, so it's probably not -- yuck. Try benchmarks
 119 ;;; with and without inline allocation, and unless the inline allocation
 120 ;;; wins by a whole lot, it's not likely to be worth messing with. If
 121 ;;; we want to hack up memory allocation for performance, effort spent
 122 ;;; on DYNAMIC-EXTENT would probably give a better payoff.)
 123 (defvar *maybe-use-inline-allocation* t)
 124
 125 ;;; Emit code to allocate an object with a size in bytes given by
 126 ;;; Size. The size may be an integer of a TN. If Inline is a VOP
 127 ;;; node-var then it is used to make an appropriate speed vs size
 128 ;;; decision.
 129 ;;;
 130 ;;; FIXME: We call into C.. except when inline allocation is enabled..?
 131 ;;;
 132 ;;; FIXME: Also, calls to
 133 ;;; ALLOCATION are always wrapped with PSEUDO-ATOMIC -- why? Is it to
 134 ;;; make sure that no GC happens between the time of allocation and the
 135 ;;; time that the allocated memory has its tag bits set correctly?
 136 ;;; If so, then ALLOCATION itself might as well set the PSEUDO-ATOMIC
 137 ;;; bits, so that the caller need only clear them. Check whether it's
 138 ;;; true that every ALLOCATION is surrounded by PSEUDO-ATOMIC, and
 139 ;;; that every PSEUDO-ATOMIC contains a single ALLOCATION, which is
 140 ;;; its first instruction. If so, the connection should probably be
 141 ;;; formalized, in documentation and in macro definition,
 142 ;;; with the macro becoming e.g. PSEUDO-ATOMIC-ALLOCATION.
 143 (defun allocation (alloc-tn size &optional inline)
 144   (flet ((load-size (dst-tn size)
 145            (unless (and (tn-p size) (location= alloc-tn size))
 146              (inst mov dst-tn size))))
 147     (let ((alloc-tn-offset (tn-offset alloc-tn)))
 148       ;; FIXME: All these (MAKE-FIXUP (EXTERN-ALIEN-NAME "foo") :FOREIGN)
 149       ;; expressions should be moved into MACROLET ((ALIEN-FIXUP ..)),
 150       ;; and INST CALL (MAKE-FIXUP ..) should become CALL-ALIEN-FIXUP.
 151       (if (and #!+gencgc t #!-gencgc nil
 152                *maybe-use-inline-allocation*
 153                (or (null inline) (policy inline (>= speed space))))
 154           ;; Inline allocation with GENCGC.
 155           (let ((ok (gen-label)))
 156             ;; Load the size first so that the size can be in the same
 157             ;; register as alloc-tn.
 158             (load-size alloc-tn size)
 159             (inst add alloc-tn
 160                   (make-fixup (extern-alien-name "current_region_free_pointer")
 161                               :foreign))
 162             (inst cmp alloc-tn
 163                   (make-fixup (extern-alien-name "current_region_end_addr")
 164                               :foreign))
 165             (inst jmp :be OK)
 166             ;; Dispatch to the appropriate overflow routine. There is a
 167             ;; routine for each destination.
 168             ;; FIXME: Could we use an alist here instead of an ECASE with lots
 169             ;; of duplicate code? (and similar question for next ECASE, too)
 170             (ecase alloc-tn-offset
 171               (#.eax-offset ;; FIXME: Why the #\# #\.?
 172                (inst call (make-fixup (extern-alien-name "alloc_overflow_eax")
 173                                       :foreign)))
 174               (#.ecx-offset
 175                (inst call (make-fixup (extern-alien-name "alloc_overflow_ecx")
 176                                       :foreign)))
 177               (#.edx-offset
 178                (inst call (make-fixup (extern-alien-name "alloc_overflow_edx")
 179                                       :foreign)))
 180               (#.ebx-offset
 181                (inst call (make-fixup (extern-alien-name "alloc_overflow_ebx")
 182                                       :foreign)))
 183               (#.esi-offset
 184                (inst call (make-fixup (extern-alien-name "alloc_overflow_esi")
 185                                       :foreign)))
 186               (#.edi-offset
 187                (inst call (make-fixup (extern-alien-name "alloc_overflow_edi")
 188                                       :foreign))))
 189             (emit-label ok)
 190             (inst xchg (make-fixup
 191                         (extern-alien-name "current_region_free_pointer")
 192                         :foreign)
 193                   alloc-tn))
 194           ;; C call to allocate via dispatch routines. Each
 195           ;; destination has a special entry point. The size may be a
 196           ;; register or a constant.
 197           (ecase alloc-tn-offset
 198             (#.eax-offset
 199              (case size
 200                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_eax")
 201                                          :foreign)))
 202                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_eax")
 203                                           :foreign)))
 204                (t
 205                 (load-size eax-tn size)
 206                 (inst call (make-fixup (extern-alien-name "alloc_to_eax")
 207                                        :foreign)))))
 208             (#.ecx-offset
 209              (case size
 210                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ecx")
 211                                          :foreign)))
 212                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ecx")
 213                                           :foreign)))
 214                (t
 215                 (load-size ecx-tn size)
 216                 (inst call (make-fixup (extern-alien-name "alloc_to_ecx")
 217                                        :foreign)))))
 218             (#.edx-offset
 219              (case size
 220                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edx")
 221                                          :foreign)))
 222                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edx")
 223                                           :foreign)))
 224                (t
 225                 (load-size edx-tn size)
 226                 (inst call (make-fixup (extern-alien-name "alloc_to_edx")
 227                                        :foreign)))))
 228             (#.ebx-offset
 229              (case size
 230                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ebx")
 231                                          :foreign)))
 232                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ebx")
 233                                           :foreign)))
 234                (t
 235                 (load-size ebx-tn size)
 236                 (inst call (make-fixup (extern-alien-name "alloc_to_ebx")
 237                                        :foreign)))))
 238             (#.esi-offset
 239              (case size
 240                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_esi")
 241                                          :foreign)))
 242                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_esi")
 243                                           :foreign)))
 244                (t
 245                 (load-size esi-tn size)
 246                 (inst call (make-fixup (extern-alien-name "alloc_to_esi")
 247                                        :foreign)))))
 248             (#.edi-offset
 249              (case size
 250                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edi")
 251                                          :foreign)))
 252                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edi")
 253                                           :foreign)))
 254                (t
 255                 (load-size edi-tn size)
 256                 (inst call (make-fixup (extern-alien-name "alloc_to_edi")
 257                                        :foreign)))))))))
 258   (values))
 259
 260 ;;; Allocate an other-pointer object of fixed SIZE with a single word
 261 ;;; header having the specified WIDETAG value. The result is placed in
 262 ;;; RESULT-TN.
 263 (defmacro with-fixed-allocation ((result-tn widetag size &optional inline)
 264                                  &rest forms)
 265   `(pseudo-atomic
 266     (allocation ,result-tn (pad-data-block ,size) ,inline)
 267     (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
 268             ,result-tn)
 269     (inst lea ,result-tn
 270      (make-ea :byte :base ,result-tn :disp other-pointer-lowtag))
 271     ,@forms))
 272 \f
 273 ;;;; error code
 274
 275 (defvar *adjustable-vectors* nil)
 276
 277 (defmacro with-adjustable-vector ((var) &rest body)
 278   `(let ((,var (or (pop *adjustable-vectors*)
 279                    (make-array 16
 280                                :element-type '(unsigned-byte 8)
 281                                :fill-pointer 0
 282                                :adjustable t))))
 283      (declare (type (vector (unsigned-byte 8) 16) ,var))
 284      (setf (fill-pointer ,var) 0)
 285      (unwind-protect
 286          (progn
 287            ,@body)
 288        (push ,var *adjustable-vectors*))))
 289
 290 (eval-when (:compile-toplevel :load-toplevel :execute)
 291   (defun emit-error-break (vop kind code values)
 292     (let ((vector (gensym)))
 293       `((inst int 3)                            ; i386 breakpoint instruction
 294         ;; The return PC points here; note the location for the debugger.
 295         (let ((vop ,vop))
 296           (when vop
 297                 (note-this-location vop :internal-error)))
 298         (inst byte ,kind)                       ; eg trap_Xyyy
 299         (with-adjustable-vector (,vector)       ; interr arguments
 300           (write-var-integer (error-number-or-lose ',code) ,vector)
 301           ,@(mapcar (lambda (tn)
 302                       `(let ((tn ,tn))
 303                          ;; classic CMU CL comment:
 304                          ;;   zzzzz jrd here. tn-offset is zero for constant
 305                          ;;   tns.
 306                          (write-var-integer (make-sc-offset (sc-number
 307                                                              (tn-sc tn))
 308                                                             (or (tn-offset tn)
 309                                                                 0))
 310                                             ,vector)))
 311                     values)
 312           (inst byte (length ,vector))
 313           (dotimes (i (length ,vector))
 314             (inst byte (aref ,vector i))))))))
 315
 316 (defmacro error-call (vop error-code &rest values)
 317   #!+sb-doc
 318   "Cause an error. ERROR-CODE is the error to cause."
 319   (cons 'progn
 320         (emit-error-break vop error-trap error-code values)))
 321
 322 ;;; not used in SBCL
 323 #|
 324 (defmacro cerror-call (vop label error-code &rest values)
 325   #!+sb-doc
 326   "Cause a continuable error. If the error is continued, execution resumes
 327   at LABEL."
 328   `(progn
 329      ,@(emit-error-break vop cerror-trap error-code values)
 330      (inst jmp ,label)))
 331 |#
 332
 333 (defmacro generate-error-code (vop error-code &rest values)
 334   #!+sb-doc
 335   "Generate-Error-Code Error-code Value*
 336   Emit code for an error with the specified Error-Code and context Values."
 337   `(assemble (*elsewhere*)
 338      (let ((start-lab (gen-label)))
 339        (emit-label start-lab)
 340        (error-call ,vop ,error-code ,@values)
 341        start-lab)))
 342
 343 ;;; not used in SBCL
 344 #|
 345 (defmacro generate-cerror-code (vop error-code &rest values)
 346   #!+sb-doc
 347   "Generate-CError-Code Error-code Value*
 348   Emit code for a continuable error with the specified Error-Code and
 349   context Values. If the error is continued, execution resumes after
 350   the GENERATE-CERROR-CODE form."
 351   (let ((continue (gensym "CONTINUE-LABEL-"))
 352         (error (gensym "ERROR-LABEL-")))
 353     `(let ((,continue (gen-label))
 354            (,error (gen-label)))
 355        (emit-label ,continue)
 356        (assemble (*elsewhere*)
 357          (emit-label ,error)
 358          (cerror-call ,vop ,continue ,error-code ,@values))
 359        ,error)))
 360 |#
 361 \f
 362 ;;;; PSEUDO-ATOMIC
 363
 364 ;;; FIXME: This should be a compile-time option, not a runtime option. Doing it
 365 ;;; at runtime is bizarre. As I understand it, the default should definitely be
 366 ;;; to have pseudo-atomic behavior, but for a performance-critical program
 367 ;;; which is guaranteed not to have asynchronous exceptions, it could be worth
 368 ;;; something to compile with :SB-NO-PSEUDO-ATOMIC.
 369 (defvar *enable-pseudo-atomic* t)
 370
 371 ;;; FIXME: *PSEUDO-ATOMIC-FOO* could be made into *PSEUDO-ATOMIC-BITS*,
 372 ;;; set with a single operation and cleared with SHR *PSEUDO-ATOMIC-BITS*,-2;
 373 ;;; the ATOMIC bit is bit 0, the INTERRUPTED bit is bit 1, and you check
 374 ;;; the C flag after the shift to see whether you were interrupted.
 375
 376 ;;; FIXME: It appears that PSEUDO-ATOMIC is used to wrap operations which leave
 377 ;;; untagged memory lying around, but some documentation would be nice.
 378 (defmacro pseudo-atomic (&rest forms)
 379   (let ((label (gensym "LABEL-")))
 380     `(let ((,label (gen-label)))
 381        (when *enable-pseudo-atomic*
 382          ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
 383          ;; something. (perhaps SVLB, for static variable low byte)
 384          (inst mov (make-ea :byte :disp (+ nil-value
 385                                            (static-symbol-offset
 386                                             '*pseudo-atomic-interrupted*)
 387                                            (ash symbol-value-slot word-shift)
 388                                            ;; FIXME: Use mask, not minus, to
 389                                            ;; take out type bits.
 390                                            (- other-pointer-lowtag)))
 391                0)
 392          (inst mov (make-ea :byte :disp (+ nil-value
 393                                            (static-symbol-offset
 394                                             '*pseudo-atomic-atomic*)
 395                                            (ash symbol-value-slot word-shift)
 396                                            (- other-pointer-lowtag)))
 397                (fixnumize 1)))
 398        ,@forms
 399        (when *enable-pseudo-atomic*
 400          (inst mov (make-ea :byte :disp (+ nil-value
 401                                            (static-symbol-offset
 402                                             '*pseudo-atomic-atomic*)
 403                                            (ash symbol-value-slot word-shift)
 404                                            (- other-pointer-lowtag)))
 405                0)
 406          ;; KLUDGE: Is there any requirement for interrupts to be
 407          ;; handled in order? It seems as though an interrupt coming
 408          ;; in at this point will be executed before any pending interrupts.
 409          ;; Or do incoming interrupts check to see whether any interrupts
 410          ;; are pending? I wish I could find the documentation for
 411          ;; pseudo-atomics.. -- WHN 19991130
 412          (inst cmp (make-ea :byte
 413                             :disp (+ nil-value
 414                                      (static-symbol-offset
 415                                       '*pseudo-atomic-interrupted*)
 416                                      (ash symbol-value-slot word-shift)
 417                                      (- other-pointer-lowtag)))
 418                0)
 419          (inst jmp :eq ,label)
 420          (inst break pending-interrupt-trap)
 421          (emit-label ,label)))))
 422 \f
 423 ;;;; indexed references
 424
 425 (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
 426   `(progn
 427      (define-vop (,name)
 428        ,@(when translate
 429            `((:translate ,translate)))
 430        (:policy :fast-safe)
 431        (:args (object :scs (descriptor-reg))
 432               (index :scs (any-reg)))
 433        (:arg-types ,type tagged-num)
 434        (:results (value :scs ,scs))
 435        (:result-types ,el-type)
 436        (:generator 3                    ; pw was 5
 437          (inst mov value (make-ea :dword :base object :index index
 438                                   :disp (- (* ,offset n-word-bytes)
 439                                            ,lowtag)))))
 440      (define-vop (,(symbolicate name "-C"))
 441        ,@(when translate
 442            `((:translate ,translate)))
 443        (:policy :fast-safe)
 444        (:args (object :scs (descriptor-reg)))
 445        (:info index)
 446        (:arg-types ,type (:constant (signed-byte 30)))
 447        (:results (value :scs ,scs))
 448        (:result-types ,el-type)
 449        (:generator 2                    ; pw was 5
 450          (inst mov value (make-ea :dword :base object
 451                                   :disp (- (* (+ ,offset index) n-word-bytes)
 452                                            ,lowtag)))))))
 453
 454 (defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
 455   `(progn
 456      (define-vop (,name)
 457        ,@(when translate
 458            `((:translate ,translate)))
 459        (:policy :fast-safe)
 460        (:args (object :scs (descriptor-reg))
 461               (index :scs (any-reg))
 462               (value :scs ,scs :target result))
 463        (:arg-types ,type tagged-num ,el-type)
 464        (:results (result :scs ,scs))
 465        (:result-types ,el-type)
 466        (:generator 4                    ; was 5
 467          (inst mov (make-ea :dword :base object :index index
 468                             :disp (- (* ,offset n-word-bytes) ,lowtag))
 469                value)
 470          (move result value)))
 471      (define-vop (,(symbolicate name "-C"))
 472        ,@(when translate
 473            `((:translate ,translate)))
 474        (:policy :fast-safe)
 475        (:args (object :scs (descriptor-reg))
 476               (value :scs ,scs :target result))
 477        (:info index)
 478        (:arg-types ,type (:constant (signed-byte 30)) ,el-type)
 479        (:results (result :scs ,scs))
 480        (:result-types ,el-type)
 481        (:generator 3                    ; was 5
 482          (inst mov (make-ea :dword :base object
 483                             :disp (- (* (+ ,offset index) n-word-bytes)
 484                                      ,lowtag))
 485                value)
 486          (move result value)))))
 487