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 #!+sb-thread
  88 (defmacro load-tl-symbol-value (reg symbol)
  89   `(progn
  90     (inst mov ,reg
  91      (make-ea :dword
  92       :disp (+ nil-value
  93                (static-symbol-offset ',symbol)
  94                (ash symbol-tls-index-slot word-shift)
  95                (- other-pointer-lowtag))))
  96     (inst fs-segment-prefix)
  97     (inst mov ,reg (make-ea :dword :scale 1 :index ,reg))))
  98 #!-sb-thread
  99 (defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol))
 100
 101 #!+sb-thread
 102 (defmacro store-tl-symbol-value (reg symbol temp)
 103   `(progn
 104     (inst mov ,temp
 105      (make-ea :dword
 106       :disp (+ nil-value
 107                (static-symbol-offset ',symbol)
 108                (ash symbol-tls-index-slot word-shift)
 109                (- other-pointer-lowtag))))
 110     (inst fs-segment-prefix)
 111     (inst mov (make-ea :dword :scale 1 :index ,temp) ,reg)))
 112 #!-sb-thread
 113 (defmacro store-tl-symbol-value (reg symbol temp)
 114   (declare (ignore temp))
 115   `(store-symbol-value ,reg ,symbol))
 116
 117 (defmacro load-type (target source &optional (offset 0))
 118   #!+sb-doc
 119   "Loads the type bits of a pointer into target independent of
 120    byte-ordering issues."
 121   (once-only ((n-target target)
 122               (n-source source)
 123               (n-offset offset))
 124     (ecase *backend-byte-order*
 125       (:little-endian
 126        `(inst mov ,n-target
 127               (make-ea :byte :base ,n-source :disp ,n-offset)))
 128       (:big-endian
 129        `(inst mov ,n-target
 130               (make-ea :byte :base ,n-source :disp (+ ,n-offset 3)))))))
 131 \f
 132 ;;;; allocation helpers
 133
 134 ;;; Two allocation approaches are implemented. A call into C can be
 135 ;;; used, and in that case special care can be taken to disable
 136 ;;; interrupts. Alternatively with gencgc inline allocation is possible
 137 ;;; although it isn't interrupt safe.
 138
 139 ;;; For GENCGC it is possible to inline object allocation, to permit
 140 ;;; this set the following variable to True.
 141 ;;;
 142 ;;; FIXME: The comment above says that this isn't interrupt safe. Is that
 143 ;;; right? If so, do we want to do this? And surely we don't want to do this by
 144 ;;; default? How much time does it save to do this? Is it any different in the
 145 ;;; current CMU CL version instead of the one that I grabbed in 1998?
 146 ;;; (Later observation: In order to be interrupt safe, it'd probably
 147 ;;; have to use PSEUDO-ATOMIC, so it's probably not -- yuck. Try benchmarks
 148 ;;; with and without inline allocation, and unless the inline allocation
 149 ;;; wins by a whole lot, it's not likely to be worth messing with. If
 150 ;;; we want to hack up memory allocation for performance, effort spent
 151 ;;; on DYNAMIC-EXTENT would probably give a better payoff.)
 152 (defvar *maybe-use-inline-allocation* t)
 153
 154 ;;; Emit code to allocate an object with a size in bytes given by
 155 ;;; Size. The size may be an integer of a TN. If Inline is a VOP
 156 ;;; node-var then it is used to make an appropriate speed vs size
 157 ;;; decision.
 158 ;;;
 159 ;;; FIXME: We call into C.. except when inline allocation is enabled..?
 160 ;;;
 161 ;;; FIXME: Also, calls to
 162 ;;; ALLOCATION are always wrapped with PSEUDO-ATOMIC -- why? Is it to
 163 ;;; make sure that no GC happens between the time of allocation and the
 164 ;;; time that the allocated memory has its tag bits set correctly?
 165 ;;; If so, then ALLOCATION itself might as well set the PSEUDO-ATOMIC
 166 ;;; bits, so that the caller need only clear them. Check whether it's
 167 ;;; true that every ALLOCATION is surrounded by PSEUDO-ATOMIC, and
 168 ;;; that every PSEUDO-ATOMIC contains a single ALLOCATION, which is
 169 ;;; its first instruction. If so, the connection should probably be
 170 ;;; formalized, in documentation and in macro definition,
 171 ;;; with the macro becoming e.g. PSEUDO-ATOMIC-ALLOCATION.
 172 (defun allocation (alloc-tn size &optional inline)
 173   ;; FIXME: since it appears that inline allocation is gone, we should
 174   ;; remove the INLINE parameter, and all the above comments.
 175   (declare (ignore inline))
 176   (flet ((load-size (dst-tn size)
 177            (unless (and (tn-p size) (location= alloc-tn size))
 178              (inst mov dst-tn size))))
 179     (let ((alloc-tn-offset (tn-offset alloc-tn)))
 180           ;; C call to allocate via dispatch routines. Each
 181           ;; destination has a special entry point. The size may be a
 182           ;; register or a constant.
 183           (ecase alloc-tn-offset
 184             (#.eax-offset
 185              (case size
 186                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_eax")
 187                                          :foreign)))
 188                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_eax")
 189                                           :foreign)))
 190                (t
 191                 (load-size eax-tn size)
 192                 (inst call (make-fixup (extern-alien-name "alloc_to_eax")
 193                                        :foreign)))))
 194             (#.ecx-offset
 195              (case size
 196                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ecx")
 197                                          :foreign)))
 198                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ecx")
 199                                           :foreign)))
 200                (t
 201                 (load-size ecx-tn size)
 202                 (inst call (make-fixup (extern-alien-name "alloc_to_ecx")
 203                                        :foreign)))))
 204             (#.edx-offset
 205              (case size
 206                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edx")
 207                                          :foreign)))
 208                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edx")
 209                                           :foreign)))
 210                (t
 211                 (load-size edx-tn size)
 212                 (inst call (make-fixup (extern-alien-name "alloc_to_edx")
 213                                        :foreign)))))
 214             (#.ebx-offset
 215              (case size
 216                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ebx")
 217                                          :foreign)))
 218                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ebx")
 219                                           :foreign)))
 220                (t
 221                 (load-size ebx-tn size)
 222                 (inst call (make-fixup (extern-alien-name "alloc_to_ebx")
 223                                        :foreign)))))
 224             (#.esi-offset
 225              (case size
 226                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_esi")
 227                                          :foreign)))
 228                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_esi")
 229                                           :foreign)))
 230                (t
 231                 (load-size esi-tn size)
 232                 (inst call (make-fixup (extern-alien-name "alloc_to_esi")
 233                                        :foreign)))))
 234             (#.edi-offset
 235              (case size
 236                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edi")
 237                                          :foreign)))
 238                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edi")
 239                                           :foreign)))
 240                (t
 241                 (load-size edi-tn size)
 242                 (inst call (make-fixup (extern-alien-name "alloc_to_edi")
 243                                    :foreign))))))))
 244   (values))
 245
 246 ;;; Allocate an other-pointer object of fixed SIZE with a single word
 247 ;;; header having the specified WIDETAG value. The result is placed in
 248 ;;; RESULT-TN.
 249 (defmacro with-fixed-allocation ((result-tn widetag size &optional inline)
 250                                  &rest forms)
 251   `(pseudo-atomic
 252     (allocation ,result-tn (pad-data-block ,size) ,inline)
 253     (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
 254             ,result-tn)
 255     (inst lea ,result-tn
 256      (make-ea :byte :base ,result-tn :disp other-pointer-lowtag))
 257     ,@forms))
 258 \f
 259 ;;;; error code
 260 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 261   (defun emit-error-break (vop kind code values)
 262     (let ((vector (gensym)))
 263       `((inst int 3)                            ; i386 breakpoint instruction
 264         ;; The return PC points here; note the location for the debugger.
 265         (let ((vop ,vop))
 266           (when vop
 267                 (note-this-location vop :internal-error)))
 268         (inst byte ,kind)                       ; eg trap_Xyyy
 269         (with-adjustable-vector (,vector)       ; interr arguments
 270           (write-var-integer (error-number-or-lose ',code) ,vector)
 271           ,@(mapcar (lambda (tn)
 272                       `(let ((tn ,tn))
 273                          ;; classic CMU CL comment:
 274                          ;;   zzzzz jrd here. tn-offset is zero for constant
 275                          ;;   tns.
 276                          (write-var-integer (make-sc-offset (sc-number
 277                                                              (tn-sc tn))
 278                                                             (or (tn-offset tn)
 279                                                                 0))
 280                                             ,vector)))
 281                     values)
 282           (inst byte (length ,vector))
 283           (dotimes (i (length ,vector))
 284             (inst byte (aref ,vector i))))))))
 285
 286 (defmacro error-call (vop error-code &rest values)
 287   #!+sb-doc
 288   "Cause an error. ERROR-CODE is the error to cause."
 289   (cons 'progn
 290         (emit-error-break vop error-trap error-code values)))
 291
 292 (defmacro generate-error-code (vop error-code &rest values)
 293   #!+sb-doc
 294   "Generate-Error-Code Error-code Value*
 295   Emit code for an error with the specified Error-Code and context Values."
 296   `(assemble (*elsewhere*)
 297      (let ((start-lab (gen-label)))
 298        (emit-label start-lab)
 299        (error-call ,vop ,error-code ,@values)
 300        start-lab)))
 301
 302 \f
 303 ;;;; PSEUDO-ATOMIC
 304
 305 ;;; FIXME: *PSEUDO-ATOMIC-FOO* could be made into *PSEUDO-ATOMIC-BITS*,
 306 ;;; set with a single operation and cleared with SHR *PSEUDO-ATOMIC-BITS*,-2;
 307 ;;; the ATOMIC bit is bit 0, the INTERRUPTED bit is bit 1, and you check
 308 ;;; the C flag after the shift to see whether you were interrupted.
 309
 310 ;;; FIXME: It appears that PSEUDO-ATOMIC is used to wrap operations which leave
 311 ;;; untagged memory lying around, but some documentation would be nice.
 312 #!+sb-thread
 313 (defmacro pseudo-atomic (&rest forms)
 314   (with-unique-names (label)
 315     `(let ((,label (gen-label)))
 316       (inst fs-segment-prefix)
 317       (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 1)
 318       (inst fs-segment-prefix)
 319       (inst mov (make-ea :byte
 320                  :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
 321       ,@forms
 322       (inst fs-segment-prefix)
 323       (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 0)
 324       (inst fs-segment-prefix)
 325       (inst cmp (make-ea :byte
 326                  :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
 327       (inst jmp :eq ,label)
 328       ;; if PAI was set, interrupts were disabled at the same time
 329       ;; using the process signal mask.
 330       (inst break pending-interrupt-trap)
 331       (emit-label ,label))))
 332
 333 #!-sb-thread
 334 (defmacro pseudo-atomic (&rest forms)
 335   (with-unique-names (label)
 336     `(let ((,label (gen-label)))
 337       ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
 338       ;; something. (perhaps SVLB, for static variable low byte)
 339       (inst mov (make-ea :byte :disp (+ nil-value
 340                                         (static-symbol-offset
 341                                          '*pseudo-atomic-interrupted*)
 342                                         (ash symbol-value-slot word-shift)
 343                                         ;; FIXME: Use mask, not minus, to
 344                                         ;; take out type bits.
 345                                         (- other-pointer-lowtag)))
 346        0)
 347       (inst mov (make-ea :byte :disp (+ nil-value
 348                                         (static-symbol-offset
 349                                          '*pseudo-atomic-atomic*)
 350                                         (ash symbol-value-slot word-shift)
 351                                         (- other-pointer-lowtag)))
 352        (fixnumize 1))
 353       ,@forms
 354       (inst mov (make-ea :byte :disp (+ nil-value
 355                                         (static-symbol-offset
 356                                          '*pseudo-atomic-atomic*)
 357                                         (ash symbol-value-slot word-shift)
 358                                         (- other-pointer-lowtag)))
 359        0)
 360       ;; KLUDGE: Is there any requirement for interrupts to be
 361       ;; handled in order? It seems as though an interrupt coming
 362       ;; in at this point will be executed before any pending interrupts.
 363       ;; Or do incoming interrupts check to see whether any interrupts
 364       ;; are pending? I wish I could find the documentation for
 365       ;; pseudo-atomics.. -- WHN 19991130
 366       (inst cmp (make-ea :byte
 367                  :disp (+ nil-value
 368                           (static-symbol-offset
 369                            '*pseudo-atomic-interrupted*)
 370                           (ash symbol-value-slot word-shift)
 371                           (- other-pointer-lowtag)))
 372        0)
 373       (inst jmp :eq ,label)
 374       ;; if PAI was set, interrupts were disabled at the same time
 375       ;; using the process signal mask.
 376       (inst break pending-interrupt-trap)
 377       (emit-label ,label))))
 378
 379
 380 \f
 381 ;;;; indexed references
 382
 383 (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
 384   `(progn
 385      (define-vop (,name)
 386        ,@(when translate
 387            `((:translate ,translate)))
 388        (:policy :fast-safe)
 389        (:args (object :scs (descriptor-reg))
 390               (index :scs (any-reg)))
 391        (:arg-types ,type tagged-num)
 392        (:results (value :scs ,scs))
 393        (:result-types ,el-type)
 394        (:generator 3                    ; pw was 5
 395          (inst mov value (make-ea :dword :base object :index index
 396                                   :disp (- (* ,offset n-word-bytes)
 397                                            ,lowtag)))))
 398      (define-vop (,(symbolicate name "-C"))
 399        ,@(when translate
 400            `((:translate ,translate)))
 401        (:policy :fast-safe)
 402        (:args (object :scs (descriptor-reg)))
 403        (:info index)
 404        (:arg-types ,type (:constant (signed-byte 30)))
 405        (:results (value :scs ,scs))
 406        (:result-types ,el-type)
 407        (:generator 2                    ; pw was 5
 408          (inst mov value (make-ea :dword :base object
 409                                   :disp (- (* (+ ,offset index) n-word-bytes)
 410                                            ,lowtag)))))))
 411
 412 (defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
 413   `(progn
 414      (define-vop (,name)
 415        ,@(when translate
 416            `((:translate ,translate)))
 417        (:policy :fast-safe)
 418        (:args (object :scs (descriptor-reg))
 419               (index :scs (any-reg))
 420               (value :scs ,scs :target result))
 421        (:arg-types ,type tagged-num ,el-type)
 422        (:results (result :scs ,scs))
 423        (:result-types ,el-type)
 424        (:generator 4                    ; was 5
 425          (inst mov (make-ea :dword :base object :index index
 426                             :disp (- (* ,offset n-word-bytes) ,lowtag))
 427                value)
 428          (move result value)))
 429      (define-vop (,(symbolicate name "-C"))
 430        ,@(when translate
 431            `((:translate ,translate)))
 432        (:policy :fast-safe)
 433        (:args (object :scs (descriptor-reg))
 434               (value :scs ,scs :target result))
 435        (:info index)
 436        (:arg-types ,type (:constant (signed-byte 30)) ,el-type)
 437        (:results (result :scs ,scs))
 438        (:result-types ,el-type)
 439        (:generator 3                    ; was 5
 440          (inst mov (make-ea :dword :base object
 441                             :disp (- (* (+ ,offset index) n-word-bytes)
 442                                      ,lowtag))
 443                value)
 444          (move result value)))))
 445