src/compiler/x86-64/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 :qword :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     `(cond ((and (integerp ,value)
  58                  (not (typep ,value
  59                              '(or (signed-byte 32) (unsigned-byte 32)))))
  60             (multiple-value-bind (lo hi) (dwords-for-quad ,value)
  61               (inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) lo)
  62               (inst mov (make-ea-for-object-slot ,ptr (floor (+ ,slot 0.5))
  63                                                  ,lowtag)   hi)))
  64            (t
  65             (inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value)))))
  66
  67 (defmacro pushw (ptr &optional (slot 0) (lowtag 0))
  68   `(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
  69
  70 (defmacro popw (ptr &optional (slot 0) (lowtag 0))
  71   `(inst pop (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
  72 \f
  73 ;;;; macros to generate useful values
  74
  75 (defmacro load-symbol (reg symbol)
  76   `(inst mov ,reg (+ nil-value (static-symbol-offset ,symbol))))
  77
  78 (defmacro load-symbol-value (reg symbol)
  79   `(inst mov ,reg
  80          (make-ea :qword
  81                   :disp (+ nil-value
  82                            (static-symbol-offset ',symbol)
  83                            (ash symbol-value-slot word-shift)
  84                            (- other-pointer-lowtag)))))
  85
  86 (defmacro store-symbol-value (reg symbol)
  87   `(inst mov
  88          (make-ea :qword
  89                   :disp (+ nil-value
  90                            (static-symbol-offset ',symbol)
  91                            (ash symbol-value-slot word-shift)
  92                            (- other-pointer-lowtag)))
  93          ,reg))
  94
  95 #!+sb-thread
  96 (defmacro load-tl-symbol-value (reg symbol)
  97   `(progn
  98     (inst mov ,reg
  99      (make-ea :qword
 100       :disp (+ nil-value
 101                (static-symbol-offset ',symbol)
 102                (ash symbol-tls-index-slot word-shift)
 103                (- other-pointer-lowtag))))
 104     (inst fs-segment-prefix)
 105     (inst mov ,reg (make-ea :qword :scale 1 :index ,reg))))
 106 #!-sb-thread
 107 (defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol))
 108
 109 #!+sb-thread
 110 (defmacro store-tl-symbol-value (reg symbol temp)
 111   `(progn
 112     (inst mov ,temp
 113      (make-ea :qword
 114       :disp (+ nil-value
 115                (static-symbol-offset ',symbol)
 116                (ash symbol-tls-index-slot word-shift)
 117                (- other-pointer-lowtag))))
 118     (inst fs-segment-prefix)
 119     (inst mov (make-ea :qword :scale 1 :index ,temp) ,reg)))
 120 #!-sb-thread
 121 (defmacro store-tl-symbol-value (reg symbol temp)
 122   (declare (ignore temp))
 123   `(store-symbol-value ,reg ,symbol))
 124
 125 (defmacro load-type (target source &optional (offset 0))
 126   #!+sb-doc
 127   "Loads the type bits of a pointer into target independent of
 128    byte-ordering issues."
 129   (once-only ((n-target target)
 130               (n-source source)
 131               (n-offset offset))
 132     (ecase *backend-byte-order*
 133       (:little-endian
 134        `(inst mov ,n-target
 135               (make-ea :byte :base ,n-source :disp ,n-offset)))
 136       (:big-endian
 137        `(inst mov ,n-target
 138               (make-ea :byte :base ,n-source :disp (+ ,n-offset 4)))))))
 139 \f
 140 ;;;; allocation helpers
 141
 142 ;;; All allocation is done by calls to assembler routines that
 143 ;;; eventually invoke the C alloc() function.
 144
 145 ;;; Emit code to allocate an object with a size in bytes given by
 146 ;;; Size. The size may be an integer of a TN. If Inline is a VOP
 147 ;;; node-var then it is used to make an appropriate speed vs size
 148 ;;; decision.
 149
 150 ;;; This macro should only be used inside a pseudo-atomic section,
 151 ;;; which should also cover subsequent initialization of the
 152 ;;; object.
 153 (defun allocation (alloc-tn size &optional ignored)
 154   (declare (ignore ignored))
 155   (inst push size)
 156   (inst call (make-fixup (extern-alien-name "alloc_tramp") :foreign))
 157   (inst pop alloc-tn)
 158   (values))
 159
 160 ;;; Allocate an other-pointer object of fixed SIZE with a single word
 161 ;;; header having the specified WIDETAG value. The result is placed in
 162 ;;; RESULT-TN.
 163 (defmacro with-fixed-allocation ((result-tn widetag size &optional inline)
 164                                  &rest forms)
 165   `(pseudo-atomic
 166     (allocation ,result-tn (pad-data-block ,size) ,inline)
 167     (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
 168             ,result-tn)
 169     (inst lea ,result-tn
 170      (make-ea :byte :base ,result-tn :disp other-pointer-lowtag))
 171     ,@forms))
 172 \f
 173 ;;;; error code
 174 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 175   (defun emit-error-break (vop kind code values)
 176     (let ((vector (gensym)))
 177       `((inst int 3)                            ; i386 breakpoint instruction
 178         ;; The return PC points here; note the location for the debugger.
 179         (let ((vop ,vop))
 180           (when vop
 181                 (note-this-location vop :internal-error)))
 182         (inst byte ,kind)                       ; eg trap_Xyyy
 183         (with-adjustable-vector (,vector)       ; interr arguments
 184           (write-var-integer (error-number-or-lose ',code) ,vector)
 185           ,@(mapcar (lambda (tn)
 186                       `(let ((tn ,tn))
 187                          ;; classic CMU CL comment:
 188                          ;;   zzzzz jrd here. tn-offset is zero for constant
 189                          ;;   tns.
 190                          (write-var-integer (make-sc-offset (sc-number
 191                                                              (tn-sc tn))
 192                                                             (or (tn-offset tn)
 193                                                                 0))
 194                                             ,vector)))
 195                     values)
 196           (inst byte (length ,vector))
 197           (dotimes (i (length ,vector))
 198             (inst byte (aref ,vector i))))))))
 199
 200 (defmacro error-call (vop error-code &rest values)
 201   #!+sb-doc
 202   "Cause an error. ERROR-CODE is the error to cause."
 203   (cons 'progn
 204         (emit-error-break vop error-trap error-code values)))
 205
 206 (defmacro generate-error-code (vop error-code &rest values)
 207   #!+sb-doc
 208   "Generate-Error-Code Error-code Value*
 209   Emit code for an error with the specified Error-Code and context Values."
 210   `(assemble (*elsewhere*)
 211      (let ((start-lab (gen-label)))
 212        (emit-label start-lab)
 213        (error-call ,vop ,error-code ,@values)
 214        start-lab)))
 215
 216 \f
 217 ;;;; PSEUDO-ATOMIC
 218
 219 ;;; This is used to wrap operations which leave untagged memory lying
 220 ;;; around.  It's an operation which the AOP weenies would describe as
 221 ;;; having "cross-cutting concerns", meaning it appears all over the
 222 ;;; place and there's no logical single place to attach documentation.
 223 ;;; grep (mostly in src/runtime) is your friend
 224
 225 ;;; FIXME: *PSEUDO-ATOMIC-FOO* could be made into *PSEUDO-ATOMIC-BITS*,
 226 ;;; set with a single operation and cleared with SHR *PSEUDO-ATOMIC-BITS*,-2;
 227 ;;; the ATOMIC bit is bit 0, the INTERRUPTED bit is bit 1, and you check
 228 ;;; the C flag after the shift to see whether you were interrupted.
 229
 230 (defmacro pseudo-atomic (&rest forms)
 231   (with-unique-names (label)
 232     `(let ((,label (gen-label)))
 233       ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
 234       ;; something. (perhaps SVLB, for static variable low byte)
 235       (inst mov (make-ea :byte :disp (+ nil-value
 236                                         (static-symbol-offset
 237                                          '*pseudo-atomic-interrupted*)
 238                                         (ash symbol-value-slot word-shift)
 239                                         ;; FIXME: Use mask, not minus, to
 240                                         ;; take out type bits.
 241                                         (- other-pointer-lowtag)))
 242        0)
 243       (inst mov (make-ea :byte :disp (+ nil-value
 244                                         (static-symbol-offset
 245                                          '*pseudo-atomic-atomic*)
 246                                         (ash symbol-value-slot word-shift)
 247                                         (- other-pointer-lowtag)))
 248        (fixnumize 1))
 249       ,@forms
 250       (inst mov (make-ea :byte :disp (+ nil-value
 251                                         (static-symbol-offset
 252                                          '*pseudo-atomic-atomic*)
 253                                         (ash symbol-value-slot word-shift)
 254                                         (- other-pointer-lowtag)))
 255        0)
 256       ;; KLUDGE: Is there any requirement for interrupts to be
 257       ;; handled in order? It seems as though an interrupt coming
 258       ;; in at this point will be executed before any pending interrupts.
 259       ;; Or do incoming interrupts check to see whether any interrupts
 260       ;; are pending? I wish I could find the documentation for
 261       ;; pseudo-atomics.. -- WHN 19991130
 262       (inst cmp (make-ea :byte
 263                  :disp (+ nil-value
 264                           (static-symbol-offset
 265                            '*pseudo-atomic-interrupted*)
 266                           (ash symbol-value-slot word-shift)
 267                           (- other-pointer-lowtag)))
 268        0)
 269       (inst jmp :eq ,label)
 270       ;; if PAI was set, interrupts were disabled at the same time
 271       ;; using the process signal mask.
 272       (inst break pending-interrupt-trap)
 273       (emit-label ,label))))
 274
 275
 276 \f
 277 ;;;; indexed references
 278
 279 (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
 280   `(progn
 281      (define-vop (,name)
 282        ,@(when translate
 283            `((:translate ,translate)))
 284        (:policy :fast-safe)
 285        (:args (object :scs (descriptor-reg))
 286               (index :scs (any-reg)))
 287        (:arg-types ,type tagged-num)
 288        (:results (value :scs ,scs))
 289        (:result-types ,el-type)
 290        (:generator 3                    ; pw was 5
 291          (inst mov value (make-ea :qword :base object :index index
 292                                   :disp (- (* ,offset n-word-bytes)
 293                                            ,lowtag)))))
 294      (define-vop (,(symbolicate name "-C"))
 295        ,@(when translate
 296            `((:translate ,translate)))
 297        (:policy :fast-safe)
 298        (:args (object :scs (descriptor-reg)))
 299        (:info index)
 300        (:arg-types ,type
 301                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 302                                                 ,(eval offset))))
 303        (:results (value :scs ,scs))
 304        (:result-types ,el-type)
 305        (:generator 2                    ; pw was 5
 306          (inst mov value (make-ea :qword :base object
 307                                   :disp (- (* (+ ,offset index) n-word-bytes)
 308                                            ,lowtag)))))))
 309
 310 (defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
 311   `(progn
 312      (define-vop (,name)
 313        ,@(when translate
 314            `((:translate ,translate)))
 315        (:policy :fast-safe)
 316        (:args (object :scs (descriptor-reg))
 317               (index :scs (any-reg))
 318               (value :scs ,scs :target result))
 319        (:arg-types ,type tagged-num ,el-type)
 320        (:results (result :scs ,scs))
 321        (:result-types ,el-type)
 322        (:generator 4                    ; was 5
 323          (inst mov (make-ea :qword :base object :index index
 324                             :disp (- (* ,offset n-word-bytes) ,lowtag))
 325                value)
 326          (move result value)))
 327      (define-vop (,(symbolicate name "-C"))
 328        ,@(when translate
 329            `((:translate ,translate)))
 330        (:policy :fast-safe)
 331        (:args (object :scs (descriptor-reg))
 332               (value :scs ,scs :target result))
 333        (:info index)
 334        (:arg-types ,type
 335                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 336                                                 ,(eval offset)))
 337                    ,el-type)
 338        (:results (result :scs ,scs))
 339        (:result-types ,el-type)
 340        (:generator 3                    ; was 5
 341          (inst mov (make-ea :qword :base object
 342                             :disp (- (* (+ ,offset index) n-word-bytes)
 343                                      ,lowtag))
 344                value)
 345          (move result value)))))
 346
 347 ;;; helper for alien stuff.
 348 (defmacro with-pinned-objects ((&rest objects) &body body)
 349   "Arrange with the garbage collector that the pages occupied by
 350 OBJECTS will not be moved in memory for the duration of BODY.
 351 Useful for e.g. foreign calls where another thread may trigger
 352 garbage collection"
 353   `(multiple-value-prog1
 354        (progn
 355          ,@(loop for p in objects
 356                  collect `(push-word-on-c-stack
 357                            (int-sap (sb!kernel:get-lisp-obj-address ,p))))
 358          ,@body)
 359      ;; If the body returned normally, we should restore the stack pointer
 360      ;; for the benefit of any following code in the same function.  If
 361      ;; there's a non-local exit in the body, sp is garbage anyway and
 362      ;; will get set appropriately from {a, the} frame pointer before it's
 363      ;; next needed
 364      (pop-words-from-c-stack ,(length objects))))