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