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
  15 ;;; stack %st(0) (fr0 here). Loads imply a push to an empty register
  16 ;;; which 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 value,
  19 ;;; 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 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-type)))))
  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-type)))
  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 ;;; Call into C.
 126 ;;;
 127 ;;; FIXME: Except when inline allocation is enabled..?
 128 ;;;
 129 ;;; FIXME: Also, calls to
 130 ;;; ALLOCATION are always wrapped with PSEUDO-ATOMIC -- why? Is it to
 131 ;;; make sure that no GC happens between the time of allocation and the
 132 ;;; time that the allocated memory has its tag bits set correctly?
 133 ;;; If so, then ALLOCATION itself might as well set the PSEUDO-ATOMIC
 134 ;;; bits, so that the caller need only clear them. Check whether it's
 135 ;;; true that every ALLOCATION is surrounded by PSEUDO-ATOMIC, and
 136 ;;; that every PSEUDO-ATOMIC contains a single ALLOCATION, which is
 137 ;;; its first instruction. If so, the connection should probably be
 138 ;;; formalized, in documentation and in macro definition,
 139 ;;; with the macro becoming e.g. PSEUDO-ATOMIC-ALLOCATION.
 140 (defun allocation (alloc-tn size &optional inline)
 141   #!+sb-doc
 142   "Emit code to allocate an object with a size in bytes given by Size.
 143    The size may be an integer of a TN.
 144    If Inline is a VOP node-var then it is used to make an appropriate
 145    speed vs size decision."
 146   (flet ((load-size (dst-tn size)
 147            (unless (and (tn-p size) (location= alloc-tn size))
 148              (inst mov dst-tn size))))
 149     (let ((alloc-tn-offset (tn-offset alloc-tn)))
 150       ;; FIXME: All these (MAKE-FIXUP (EXTERN-ALIEN-NAME "foo") :FOREIGN)
 151       ;; expressions should be moved into MACROLET ((ALIEN-FIXUP ..)),
 152       ;; and INST CALL (MAKE-FIXUP ..) should become CALL-ALIEN-FIXUP.
 153       (if (and #!+gencgc t #!-gencgc nil
 154                *maybe-use-inline-allocation*
 155                (or (null inline) (policy inline (>= speed space))))
 156           ;; Inline allocation with GENCGC.
 157           (let ((ok (gen-label)))
 158             ;; Load the size first so that the size can be in the same
 159             ;; register as alloc-tn.
 160             (load-size alloc-tn size)
 161             (inst add alloc-tn
 162                   (make-fixup (extern-alien-name "current_region_free_pointer")
 163                               :foreign))
 164             (inst cmp alloc-tn
 165                   (make-fixup (extern-alien-name "current_region_end_addr")
 166                               :foreign))
 167             (inst jmp :be OK)
 168             ;; Dispatch to the appropriate overflow routine. There is a
 169             ;; routine for each destination.
 170             ;; FIXME: Could we use an alist here instead of an ECASE with lots
 171             ;; of duplicate code? (and similar question for next ECASE, too)
 172             (ecase alloc-tn-offset
 173               (#.eax-offset ;; FIXME: Why the #\# #\.?
 174                (inst call (make-fixup (extern-alien-name "alloc_overflow_eax")
 175                                       :foreign)))
 176               (#.ecx-offset
 177                (inst call (make-fixup (extern-alien-name "alloc_overflow_ecx")
 178                                       :foreign)))
 179               (#.edx-offset
 180                (inst call (make-fixup (extern-alien-name "alloc_overflow_edx")
 181                                       :foreign)))
 182               (#.ebx-offset
 183                (inst call (make-fixup (extern-alien-name "alloc_overflow_ebx")
 184                                       :foreign)))
 185               (#.esi-offset
 186                (inst call (make-fixup (extern-alien-name "alloc_overflow_esi")
 187                                       :foreign)))
 188               (#.edi-offset
 189                (inst call (make-fixup (extern-alien-name "alloc_overflow_edi")
 190                                       :foreign))))
 191             (emit-label ok)
 192             (inst xchg (make-fixup
 193                         (extern-alien-name "current_region_free_pointer")
 194                         :foreign)
 195                   alloc-tn))
 196           ;; C call to allocate via dispatch routines. Each
 197           ;; destination has a special entry point. The size may be a
 198           ;; register or a constant.
 199           (ecase alloc-tn-offset
 200             (#.eax-offset
 201              (case size
 202                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_eax")
 203                                          :foreign)))
 204                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_eax")
 205                                           :foreign)))
 206                (t
 207                 (load-size eax-tn size)
 208                 (inst call (make-fixup (extern-alien-name "alloc_to_eax")
 209                                        :foreign)))))
 210             (#.ecx-offset
 211              (case size
 212                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ecx")
 213                                          :foreign)))
 214                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ecx")
 215                                           :foreign)))
 216                (t
 217                 (load-size ecx-tn size)
 218                 (inst call (make-fixup (extern-alien-name "alloc_to_ecx")
 219                                        :foreign)))))
 220             (#.edx-offset
 221              (case size
 222                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edx")
 223                                          :foreign)))
 224                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edx")
 225                                           :foreign)))
 226                (t
 227                 (load-size edx-tn size)
 228                 (inst call (make-fixup (extern-alien-name "alloc_to_edx")
 229                                        :foreign)))))
 230             (#.ebx-offset
 231              (case size
 232                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ebx")
 233                                          :foreign)))
 234                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ebx")
 235                                           :foreign)))
 236                (t
 237                 (load-size ebx-tn size)
 238                 (inst call (make-fixup (extern-alien-name "alloc_to_ebx")
 239                                        :foreign)))))
 240             (#.esi-offset
 241              (case size
 242                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_esi")
 243                                          :foreign)))
 244                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_esi")
 245                                           :foreign)))
 246                (t
 247                 (load-size esi-tn size)
 248                 (inst call (make-fixup (extern-alien-name "alloc_to_esi")
 249                                        :foreign)))))
 250             (#.edi-offset
 251              (case size
 252                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edi")
 253                                          :foreign)))
 254                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edi")
 255                                           :foreign)))
 256                (t
 257                 (load-size edi-tn size)
 258                 (inst call (make-fixup (extern-alien-name "alloc_to_edi")
 259                                        :foreign)))))))))
 260   (values))
 261
 262 (defmacro with-fixed-allocation ((result-tn type-code size &optional inline)
 263                                  &rest forms)
 264   #!+sb-doc
 265   "Allocate an other-pointer object of fixed Size with a single
 266    word header having the specified Type-Code. The result is placed in
 267    Result-TN."
 268   `(pseudo-atomic
 269     (allocation ,result-tn (pad-data-block ,size) ,inline)
 270     (storew (logior (ash (1- ,size) sb!vm:type-bits) ,type-code) ,result-tn)
 271     (inst lea ,result-tn
 272      (make-ea :byte :base ,result-tn :disp other-pointer-type))
 273     ,@forms))
 274
 275 \f
 276 ;;;; error code
 277
 278 (defvar *adjustable-vectors* nil)
 279
 280 (defmacro with-adjustable-vector ((var) &rest body)
 281   `(let ((,var (or (pop *adjustable-vectors*)
 282                    (make-array 16
 283                                :element-type '(unsigned-byte 8)
 284                                :fill-pointer 0
 285                                :adjustable t))))
 286      (setf (fill-pointer ,var) 0)
 287      (unwind-protect
 288          (progn
 289            ,@body)
 290        (push ,var *adjustable-vectors*))))
 291
 292 (eval-when (:compile-toplevel :load-toplevel :execute)
 293   (defun emit-error-break (vop kind code values)
 294     (let ((vector (gensym)))
 295       `((inst int 3)                            ; i386 breakpoint instruction
 296         ;; The return PC points here; note the location for the debugger.
 297         (let ((vop ,vop))
 298           (when vop
 299                 (note-this-location vop :internal-error)))
 300         (inst byte ,kind)                       ; eg trap_Xyyy
 301         (with-adjustable-vector (,vector)       ; interr arguments
 302           (write-var-integer (error-number-or-lose ',code) ,vector)
 303           ,@(mapcar (lambda (tn)
 304                       `(let ((tn ,tn))
 305                          ;; classic CMU CL comment:
 306                          ;;   zzzzz jrd here. tn-offset is zero for constant
 307                          ;;   tns.
 308                          (write-var-integer (make-sc-offset (sc-number
 309                                                              (tn-sc tn))
 310                                                             (or (tn-offset tn)
 311                                                                 0))
 312                                             ,vector)))
 313                     values)
 314           (inst byte (length ,vector))
 315           (dotimes (i (length ,vector))
 316             (inst byte (aref ,vector i))))))))
 317
 318 (defmacro error-call (vop error-code &rest values)
 319   #!+sb-doc
 320   "Cause an error. ERROR-CODE is the error to cause."
 321   (cons 'progn
 322         (emit-error-break vop error-trap error-code values)))
 323
 324 ;;; not used in SBCL
 325 #|
 326 (defmacro cerror-call (vop label error-code &rest values)
 327   #!+sb-doc
 328   "Cause a continuable error. If the error is continued, execution resumes
 329   at LABEL."
 330   `(progn
 331      ,@(emit-error-break vop cerror-trap error-code values)
 332      (inst jmp ,label)))
 333 |#
 334
 335 (defmacro generate-error-code (vop error-code &rest values)
 336   #!+sb-doc
 337   "Generate-Error-Code Error-code Value*
 338   Emit code for an error with the specified Error-Code and context Values."
 339   `(assemble (*elsewhere*)
 340      (let ((start-lab (gen-label)))
 341        (emit-label start-lab)
 342        (error-call ,vop ,error-code ,@values)
 343        start-lab)))
 344
 345 ;;; not used in SBCL
 346 #|
 347 (defmacro generate-cerror-code (vop error-code &rest values)
 348   #!+sb-doc
 349   "Generate-CError-Code Error-code Value*
 350   Emit code for a continuable error with the specified Error-Code and
 351   context Values. If the error is continued, execution resumes after
 352   the GENERATE-CERROR-CODE form."
 353   (let ((continue (gensym "CONTINUE-LABEL-"))
 354         (error (gensym "ERROR-LABEL-")))
 355     `(let ((,continue (gen-label))
 356            (,error (gen-label)))
 357        (emit-label ,continue)
 358        (assemble (*elsewhere*)
 359          (emit-label ,error)
 360          (cerror-call ,vop ,continue ,error-code ,@values))
 361        ,error)))
 362 |#
 363 \f
 364 ;;;; PSEUDO-ATOMIC
 365
 366 ;;; FIXME: This should be a compile-time option, not a runtime option. Doing it
 367 ;;; at runtime is bizarre. As I understand it, the default should definitely be
 368 ;;; to have pseudo-atomic behavior, but for a performance-critical program
 369 ;;; which is guaranteed not to have asynchronous exceptions, it could be worth
 370 ;;; something to compile with :SB-NO-PSEUDO-ATOMIC.
 371 (defvar *enable-pseudo-atomic* t)
 372
 373 ;;; FIXME: *PSEUDO-ATOMIC-ATOMIC* and *PSEUDO-ATOMIC-INTERRUPTED*
 374 ;;; should be in package SB!VM or SB!KERNEL, not SB!IMPL.
 375
 376 ;;; FIXME: *PSEUDO-ATOMIC-FOO* could be made into *PSEUDO-ATOMIC-BITS*,
 377 ;;; set with a single operation and cleared with SHR *PSEUDO-ATOMIC-BITS*,-2;
 378 ;;; the ATOMIC bit is bit 0, the INTERRUPTED bit is bit 1, and you check
 379 ;;; the C flag after the shift to see whether you were interrupted.
 380
 381 ;;; FIXME: It appears that PSEUDO-ATOMIC is used to wrap operations which leave
 382 ;;; untagged memory lying around, but some documentation would be nice.
 383 (defmacro pseudo-atomic (&rest forms)
 384   (let ((label (gensym "LABEL-")))
 385     `(let ((,label (gen-label)))
 386        (when *enable-pseudo-atomic*
 387          ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
 388          ;; something. (perhaps SVLB, for static variable low byte)
 389          (inst mov (make-ea :byte :disp (+ nil-value
 390                                            (static-symbol-offset
 391                                             'sb!impl::*pseudo-atomic-interrupted*)
 392                                            (ash symbol-value-slot word-shift)
 393                                            ;; FIXME: Use mask, not minus, to
 394                                            ;; take out type bits.
 395                                            (- other-pointer-type)))
 396                0)
 397          (inst mov (make-ea :byte :disp (+ nil-value
 398                                            (static-symbol-offset
 399                                             'sb!impl::*pseudo-atomic-atomic*)
 400                                            (ash symbol-value-slot word-shift)
 401                                            (- other-pointer-type)))
 402                (fixnumize 1)))
 403        ,@forms
 404        (when *enable-pseudo-atomic*
 405          (inst mov (make-ea :byte :disp (+ nil-value
 406                                            (static-symbol-offset
 407                                             'sb!impl::*pseudo-atomic-atomic*)
 408                                            (ash symbol-value-slot word-shift)
 409                                            (- other-pointer-type)))
 410                0)
 411          ;; KLUDGE: Is there any requirement for interrupts to be
 412          ;; handled in order? It seems as though an interrupt coming
 413          ;; in at this point will be executed before any pending interrupts.
 414          ;; Or do incoming interrupts check to see whether any interrupts
 415          ;; are pending? I wish I could find the documentation for
 416          ;; pseudo-atomics.. -- WHN 19991130
 417          (inst cmp (make-ea :byte
 418                             :disp (+ nil-value
 419                                      (static-symbol-offset
 420                                       'sb!impl::*pseudo-atomic-interrupted*)
 421                                      (ash symbol-value-slot word-shift)
 422                                      (- other-pointer-type)))
 423                0)
 424          (inst jmp :eq ,label)
 425          (inst break pending-interrupt-trap)
 426          (emit-label ,label)))))
 427 \f
 428 ;;;; indexed references
 429
 430 (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
 431   `(progn
 432      (define-vop (,name)
 433        ,@(when translate
 434            `((:translate ,translate)))
 435        (:policy :fast-safe)
 436        (:args (object :scs (descriptor-reg))
 437               (index :scs (any-reg)))
 438        (:arg-types ,type tagged-num)
 439        (:results (value :scs ,scs))
 440        (:result-types ,el-type)
 441        (:generator 3                    ; pw was 5
 442          (inst mov value (make-ea :dword :base object :index index
 443                                   :disp (- (* ,offset word-bytes) ,lowtag)))))
 444      (define-vop (,(symbolicate name "-C"))
 445        ,@(when translate
 446            `((:translate ,translate)))
 447        (:policy :fast-safe)
 448        (:args (object :scs (descriptor-reg)))
 449        (:info index)
 450        (:arg-types ,type (:constant (signed-byte 30)))
 451        (:results (value :scs ,scs))
 452        (:result-types ,el-type)
 453        (:generator 2                    ; pw was 5
 454          (inst mov value (make-ea :dword :base object
 455                                   :disp (- (* (+ ,offset index) word-bytes)
 456                                            ,lowtag)))))))
 457
 458 (defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
 459   `(progn
 460      (define-vop (,name)
 461        ,@(when translate
 462            `((:translate ,translate)))
 463        (:policy :fast-safe)
 464        (:args (object :scs (descriptor-reg))
 465               (index :scs (any-reg))
 466               (value :scs ,scs :target result))
 467        (:arg-types ,type tagged-num ,el-type)
 468        (:results (result :scs ,scs))
 469        (:result-types ,el-type)
 470        (:generator 4                    ; was 5
 471          (inst mov (make-ea :dword :base object :index index
 472                             :disp (- (* ,offset word-bytes) ,lowtag))
 473                value)
 474          (move result value)))
 475      (define-vop (,(symbolicate name "-C"))
 476        ,@(when translate
 477            `((:translate ,translate)))
 478        (:policy :fast-safe)
 479        (:args (object :scs (descriptor-reg))
 480               (value :scs ,scs :target result))
 481        (:info index)
 482        (:arg-types ,type (:constant (signed-byte 30)) ,el-type)
 483        (:results (result :scs ,scs))
 484        (:result-types ,el-type)
 485        (:generator 3                    ; was 5
 486          (inst mov (make-ea :dword :base object
 487                             :disp (- (* (+ ,offset index) word-bytes) ,lowtag))
 488                value)
 489          (move result value)))))
 490