src/compiler/x86-64/macros.lisp

   1 ;;;; a bunch of handy macros for x86-64
   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 ;;;; instruction-like macros
  15
  16 ;;; This used to be a macro (and still is on the other platforms) but
  17 ;;; the support for SC-dependent move instructions needed here makes
  18 ;;; that expand into so large an expression that the resulting code
  19 ;;; bloat is not justifiable.
  20 (defun move (dst src)
  21   #!+sb-doc
  22   "Move SRC into DST unless they are location=."
  23   (unless (location= dst src)
  24     (sc-case dst
  25       ((single-reg complex-single-reg)
  26        (aver (xmm-register-p src))
  27        (inst movaps dst src))
  28       ((double-reg complex-double-reg)
  29        (aver (xmm-register-p src))
  30        (inst movapd dst src))
  31       #!+sb-simd-pack
  32       ((int-sse-reg sse-reg)
  33        (aver (xmm-register-p src))
  34        (inst movdqa dst src))
  35       #!+sb-simd-pack
  36       ((single-sse-reg double-sse-reg)
  37        (aver (xmm-register-p src))
  38        (inst movaps dst src))
  39       (t
  40        (inst mov dst src)))))
  41
  42 (defmacro make-ea-for-object-slot (ptr slot lowtag)
  43   `(make-ea :qword :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
  44 (defmacro make-ea-for-object-slot-half (ptr slot lowtag)
  45   `(make-ea :dword :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
  46 (defmacro tls-index-of (sym)
  47   `(make-ea :dword :base ,sym :disp (+ 4 (- other-pointer-lowtag))))
  48
  49 (defmacro loadw (value ptr &optional (slot 0) (lowtag 0))
  50   `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
  51
  52 (defmacro storew (value ptr &optional (slot 0) (lowtag 0))
  53   (once-only ((value value))
  54     `(cond ((and (integerp ,value)
  55                  (not (typep ,value '(signed-byte 32))))
  56             (inst mov temp-reg-tn ,value)
  57             (inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) temp-reg-tn))
  58            (t
  59             (inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value)))))
  60
  61 (defmacro pushw (ptr &optional (slot 0) (lowtag 0))
  62   `(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
  63
  64 (defmacro popw (ptr &optional (slot 0) (lowtag 0))
  65   `(inst pop (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
  66
  67 (defun call-indirect (offset)
  68   (typecase offset
  69     ((signed-byte 32)
  70      (inst call (make-ea :qword :disp offset)))
  71     (t
  72      (inst mov temp-reg-tn offset)
  73      (inst call (make-ea :qword :base temp-reg-tn)))))
  74 \f
  75 ;;;; macros to generate useful values
  76
  77 (defmacro load-symbol (reg symbol)
  78   `(inst mov ,reg (+ nil-value (static-symbol-offset ,symbol))))
  79
  80 (defmacro make-ea-for-symbol-value (symbol)
  81   `(make-ea :qword
  82     :disp (+ nil-value
  83            (static-symbol-offset ',symbol)
  84            (ash symbol-value-slot word-shift)
  85            (- other-pointer-lowtag))))
  86
  87 (defmacro load-symbol-value (reg symbol)
  88   `(inst mov ,reg (make-ea-for-symbol-value ,symbol)))
  89
  90 (defmacro store-symbol-value (reg symbol)
  91   `(inst mov (make-ea-for-symbol-value ,symbol) ,reg))
  92
  93 ;; Return the effective address of the value slot of static SYMBOL.
  94 (defun static-symbol-value-ea (symbol)
  95    (make-ea :qword
  96             :disp (+ nil-value
  97                      (static-symbol-offset symbol)
  98                      (ash symbol-value-slot word-shift)
  99                      (- other-pointer-lowtag))))
 100
 101 #!+sb-thread
 102 (progn
 103   ;; Return an EA for the TLS of SYMBOL, or die.
 104   (defun symbol-known-tls-cell (symbol)
 105     (let ((index (info :variable :wired-tls symbol)))
 106       (aver (integerp index))
 107       (make-ea :qword :base thread-base-tn :disp index)))
 108
 109   ;; LOAD/STORE-TL-SYMBOL-VALUE macros are ad-hoc (ugly) emulations
 110   ;; of (INFO :VARIABLE :WIRED-TLS) = :ALWAYS-THREAD-LOCAL
 111   (defmacro load-tl-symbol-value (reg symbol)
 112     `(inst mov ,reg (symbol-known-tls-cell ',symbol)))
 113
 114   (defmacro store-tl-symbol-value (reg symbol)
 115     `(inst mov (symbol-known-tls-cell ',symbol) ,reg)))
 116
 117 #!-sb-thread
 118 (progn
 119   (defmacro load-tl-symbol-value (reg symbol)
 120     `(load-symbol-value ,reg ,symbol))
 121   (defmacro store-tl-symbol-value (reg symbol)
 122     `(store-symbol-value ,reg ,symbol)))
 123
 124 (defmacro load-binding-stack-pointer (reg)
 125   #!+sb-thread `(inst mov ,reg (symbol-known-tls-cell '*binding-stack-pointer*))
 126   #!-sb-thread `(load-symbol-value ,reg *binding-stack-pointer*))
 127
 128 (defmacro store-binding-stack-pointer (reg)
 129   #!+sb-thread `(inst mov (symbol-known-tls-cell '*binding-stack-pointer*) ,reg)
 130   #!-sb-thread `(store-symbol-value ,reg *binding-stack-pointer*))
 131
 132 (defmacro load-type (target source &optional (offset 0))
 133   #!+sb-doc
 134   "Loads the type bits of a pointer into target independent of
 135    byte-ordering issues."
 136   (once-only ((n-target target)
 137               (n-source source)
 138               (n-offset offset))
 139     (ecase *backend-byte-order*
 140       (:little-endian
 141        `(inst movzx ,n-target
 142               (make-ea :byte :base ,n-source :disp ,n-offset)))
 143       (:big-endian
 144        `(inst movzx ,n-target
 145               (make-ea :byte :base ,n-source
 146                              :disp (+ ,n-offset (1- n-word-bytes))))))))
 147 \f
 148 ;;;; allocation helpers
 149
 150 ;;; All allocation is done by calls to assembler routines that
 151 ;;; eventually invoke the C alloc() function.
 152
 153 ;;; Emit code to allocate an object with a size in bytes given by
 154 ;;; Size. The size may be an integer of a TN. If Inline is a VOP
 155 ;;; node-var then it is used to make an appropriate speed vs size
 156 ;;; decision.
 157
 158 (defun allocation-dynamic-extent (alloc-tn size lowtag)
 159   (inst sub rsp-tn size)
 160   ;; see comment in x86/macros.lisp implementation of this
 161   ;; However that comment seems inapplicable here because:
 162   ;; - PAD-DATA-BLOCK quite clearly enforces double-word alignment,
 163   ;;   contradicting "... unfortunately not enforced by ..."
 164   ;; - It's not the job of WITH-FIXED-ALLOCATION to realign anything.
 165   ;; - The real issue is that it's not obvious that the stack is
 166   ;;   16-byte-aligned at *all* times. Maybe it is, maybe it isn't.
 167   (inst and rsp-tn #.(lognot lowtag-mask))
 168   (aver (not (location= alloc-tn rsp-tn)))
 169   (inst lea alloc-tn (make-ea :byte :base rsp-tn :disp lowtag))
 170   (values))
 171
 172 ;;; This macro should only be used inside a pseudo-atomic section,
 173 ;;; which should also cover subsequent initialization of the
 174 ;;; object.
 175 (defun allocation-tramp (alloc-tn size lowtag)
 176   (cond ((typep size '(and integer (not (signed-byte 32))))
 177          ;; MOV accepts large immediate operands, PUSH does not
 178          (inst mov alloc-tn size)
 179          (inst push alloc-tn))
 180         (t
 181          (inst push size)))
 182   (inst mov alloc-tn (make-fixup "alloc_tramp" :foreign))
 183   (inst call alloc-tn)
 184   (inst pop alloc-tn)
 185   (when lowtag
 186     (inst or (reg-in-size alloc-tn :byte) lowtag))
 187   (values))
 188
 189 (defun allocation (alloc-tn size &optional ignored dynamic-extent lowtag)
 190   (declare (ignore ignored))
 191   (when dynamic-extent
 192     (allocation-dynamic-extent alloc-tn size lowtag)
 193     (return-from allocation (values)))
 194   (let ((NOT-INLINE (gen-label))
 195         (DONE (gen-label))
 196         ;; Yuck.
 197         (in-elsewhere (eq *elsewhere* sb!assem::**current-segment**))
 198         ;; thread->alloc_region.free_pointer
 199         (free-pointer
 200          #!+sb-thread
 201          (make-ea :qword
 202                   :base thread-base-tn :scale 1
 203                   :disp (* n-word-bytes thread-alloc-region-slot))
 204          #!-sb-thread
 205          (make-ea :qword
 206                   :scale 1 :disp
 207                   (make-fixup "boxed_region" :foreign)))
 208         ;; thread->alloc_region.end_addr
 209         (end-addr
 210          #!+sb-thread
 211          (make-ea :qword
 212                   :base thread-base-tn :scale 1
 213                   :disp (* n-word-bytes (1+ thread-alloc-region-slot)))
 214          #!-sb-thread
 215          (make-ea :qword
 216                   :scale 1 :disp
 217                   (make-fixup "boxed_region" :foreign 8))))
 218     (cond ((or in-elsewhere
 219                #!+gencgc
 220                ;; large objects will never be made in a per-thread region
 221                (and (integerp size)
 222                     ;; Kludge: this is supposed to be
 223                     ;;  (>= size (extern-alien "large_object_size" long))
 224                     ;; but that won't cross-compile. So, a little OAOOM...
 225                     (>= size (* 4 (max *backend-page-bytes* gencgc-card-bytes
 226                                        gencgc-alloc-granularity)))))
 227            (allocation-tramp alloc-tn size lowtag))
 228           (t
 229            (inst mov temp-reg-tn free-pointer)
 230            (cond ((tn-p size)
 231                   (if (location= alloc-tn size)
 232                       (inst add alloc-tn temp-reg-tn)
 233                       (inst lea alloc-tn
 234                             (make-ea :qword :base temp-reg-tn :index size))))
 235                  ((typep size '(signed-byte 31))
 236                   (inst lea alloc-tn
 237                         (make-ea :qword :base temp-reg-tn :disp size)))
 238                  (t ; a doozy - 'disp' in an EA is too small for this size
 239                   (inst mov alloc-tn temp-reg-tn)
 240                   (inst add alloc-tn (constantize size))))
 241            (inst cmp alloc-tn end-addr)
 242            (inst jmp :a NOT-INLINE)
 243            (inst mov free-pointer alloc-tn)
 244            (if lowtag
 245                (inst lea alloc-tn (make-ea :byte :base temp-reg-tn :disp lowtag))
 246                (inst mov alloc-tn temp-reg-tn))
 247            (emit-label DONE)
 248            (assemble (*elsewhere*)
 249              (emit-label NOT-INLINE)
 250              (cond ((numberp size)
 251                     (allocation-tramp alloc-tn size lowtag))
 252                    (t
 253                     (inst sub alloc-tn free-pointer)
 254                     (allocation-tramp alloc-tn alloc-tn lowtag)))
 255              (inst jmp DONE))))
 256     (values)))
 257
 258 ;;; Allocate an other-pointer object of fixed SIZE with a single word
 259 ;;; header having the specified WIDETAG value. The result is placed in
 260 ;;; RESULT-TN.
 261 (defmacro with-fixed-allocation ((result-tn widetag size &optional inline stack-allocate-p)
 262                                  &body forms)
 263   (unless forms
 264     (bug "empty &body in WITH-FIXED-ALLOCATION"))
 265   (once-only ((result-tn result-tn) (size size) (stack-allocate-p stack-allocate-p))
 266     `(maybe-pseudo-atomic ,stack-allocate-p
 267       (allocation ,result-tn (pad-data-block ,size) ,inline ,stack-allocate-p
 268                   other-pointer-lowtag)
 269       (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
 270               ,result-tn 0 other-pointer-lowtag)
 271       ,@forms)))
 272 \f
 273 ;;;; error code
 274 (defun emit-error-break (vop kind code values)
 275   (assemble ()
 276     #!-ud2-breakpoints
 277     (inst int 3)                  ; i386 breakpoint instruction
 278     ;; On Darwin, we need to use #x0b0f instead of int3 in order
 279     ;; to generate a SIGILL instead of a SIGTRAP as darwin/x86
 280     ;; doesn't seem to be reliably firing SIGTRAP
 281     ;; handlers. Hopefully this will be fixed by Apple at a
 282     ;; later date. Do the same on x86-64 as we do on x86 until this gets
 283     ;; sorted out.
 284     #!+ud2-breakpoints
 285     (inst word #x0b0f)
 286     ;; The return PC points here; note the location for the debugger.
 287     (when vop
 288       (note-this-location vop :internal-error))
 289     (inst byte kind)                       ; eg trap_Xyyy
 290     (case kind
 291       (#.invalid-arg-count-trap) ; there is no "payload" in this trap kind
 292       (t
 293        (with-adjustable-vector (vector)       ; interr arguments
 294          (write-var-integer code vector)
 295          (dolist (tn values)
 296         ;; classic CMU CL comment:
 297         ;;   zzzzz jrd here. tn-offset is zero for constant
 298         ;;   tns.
 299            (write-var-integer (make-sc-offset (sc-number (tn-sc tn))
 300                                               (or (tn-offset tn) 0))
 301                               vector))
 302          (inst byte (length vector))
 303          (dotimes (i (length vector))
 304            (inst byte (aref vector i))))))))
 305
 306 (defun error-call (vop error-code &rest values)
 307   #!+sb-doc
 308   "Cause an error. ERROR-CODE is the error to cause."
 309   (emit-error-break vop error-trap (error-number-or-lose error-code) values))
 310
 311 (defun generate-error-code (vop error-code &rest values)
 312   #!+sb-doc
 313   "Generate-Error-Code Error-code Value*
 314   Emit code for an error with the specified Error-Code and context Values."
 315   (assemble (*elsewhere*)
 316     (let ((start-lab (gen-label)))
 317       (emit-label start-lab)
 318       (emit-error-break vop
 319                         (case error-code ; should be named ERROR-SYMBOL really
 320                           (invalid-arg-count-error invalid-arg-count-trap)
 321                           (t error-trap))
 322                         (error-number-or-lose error-code)
 323                         values)
 324       start-lab)))
 325
 326 \f
 327 ;;;; PSEUDO-ATOMIC
 328
 329 ;;; This is used to wrap operations which leave untagged memory lying
 330 ;;; around.  It's an operation which the AOP weenies would describe as
 331 ;;; having "cross-cutting concerns", meaning it appears all over the
 332 ;;; place and there's no logical single place to attach documentation.
 333 ;;; grep (mostly in src/runtime) is your friend
 334
 335 (defmacro maybe-pseudo-atomic (not-really-p &body body)
 336   `(if ,not-really-p
 337        (progn ,@body)
 338        (pseudo-atomic ,@body)))
 339
 340 ;;; Unsafely clear pa flags so that the image can properly lose in a
 341 ;;; pa section.
 342 #!+sb-thread
 343 (defmacro %clear-pseudo-atomic ()
 344   '(inst mov (make-ea :qword :base thread-base-tn
 345               :disp (* n-word-bytes thread-pseudo-atomic-bits-slot))
 346     0))
 347
 348 #!+sb-safepoint
 349 (defun emit-safepoint ()
 350   (inst test al-tn (make-ea :byte :disp gc-safepoint-page-addr)))
 351
 352 #!+sb-thread
 353 (defmacro pseudo-atomic (&rest forms)
 354   #!+sb-safepoint-strictly
 355   `(progn ,@forms (emit-safepoint))
 356   #!-sb-safepoint-strictly
 357   (with-unique-names (label)
 358     `(let ((,label (gen-label)))
 359        (inst mov (make-ea :qword
 360                           :base thread-base-tn
 361                           :disp (* n-word-bytes thread-pseudo-atomic-bits-slot))
 362              rbp-tn)
 363        ,@forms
 364        (inst xor (make-ea :qword
 365                           :base thread-base-tn
 366                           :disp (* n-word-bytes thread-pseudo-atomic-bits-slot))
 367              rbp-tn)
 368        (inst jmp :z ,label)
 369        ;; if PAI was set, interrupts were disabled at the same time
 370        ;; using the process signal mask.
 371        (inst break pending-interrupt-trap)
 372        (emit-label ,label)
 373        #!+sb-safepoint
 374        ;; In this case, when allocation thinks a GC should be done, it
 375        ;; does not mark PA as interrupted, but schedules a safepoint
 376        ;; trap instead.  Let's take the opportunity to trigger that
 377        ;; safepoint right now.
 378        (emit-safepoint))))
 379
 380
 381 #!-sb-thread
 382 (defmacro pseudo-atomic (&rest forms)
 383   (with-unique-names (label)
 384     `(let ((,label (gen-label)))
 385        ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
 386        ;; something. (perhaps SVLB, for static variable low byte)
 387        (inst mov (make-ea :qword :disp (+ nil-value
 388                                           (static-symbol-offset
 389                                            '*pseudo-atomic-bits*)
 390                                           (ash symbol-value-slot word-shift)
 391                                           (- other-pointer-lowtag)))
 392              rbp-tn)
 393        ,@forms
 394        (inst xor (make-ea :qword :disp (+ nil-value
 395                                           (static-symbol-offset
 396                                            '*pseudo-atomic-bits*)
 397                                           (ash symbol-value-slot word-shift)
 398                                           (- other-pointer-lowtag)))
 399              rbp-tn)
 400        (inst jmp :z ,label)
 401        ;; if PAI was set, interrupts were disabled at the same time
 402        ;; using the process signal mask.
 403        (inst break pending-interrupt-trap)
 404        (emit-label ,label))))
 405 \f
 406 ;;;; indexed references
 407
 408 (defmacro define-full-compare-and-swap
 409     (name type offset lowtag scs el-type &optional translate)
 410   `(progn
 411      (define-vop (,name)
 412          ,@(when translate `((:translate ,translate)))
 413        (:policy :fast-safe)
 414        (:args (object :scs (descriptor-reg) :to :eval)
 415               (index :scs (any-reg) :to :result)
 416               (old-value :scs ,scs :target rax)
 417               (new-value :scs ,scs))
 418        (:arg-types ,type tagged-num ,el-type ,el-type)
 419        (:temporary (:sc descriptor-reg :offset rax-offset
 420                         :from (:argument 2) :to :result :target value)  rax)
 421        (:results (value :scs ,scs))
 422        (:result-types ,el-type)
 423        (:generator 5
 424          (move rax old-value)
 425          (inst cmpxchg (make-ea :qword :base object :index index
 426                                 :scale (ash 1 (- word-shift n-fixnum-tag-bits))
 427                                 :disp (- (* ,offset n-word-bytes) ,lowtag))
 428                new-value :lock)
 429          (move value rax)))))
 430
 431 (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
 432   `(progn
 433      (define-vop (,name)
 434        ,@(when translate
 435            `((:translate ,translate)))
 436        (:policy :fast-safe)
 437        (:args (object :scs (descriptor-reg))
 438               (index :scs (any-reg)))
 439        (:arg-types ,type tagged-num)
 440        (:results (value :scs ,scs))
 441        (:result-types ,el-type)
 442        (:generator 3                    ; pw was 5
 443          (inst mov value (make-ea :qword :base object :index index
 444                                   :scale (ash 1 (- word-shift n-fixnum-tag-bits))
 445                                   :disp (- (* ,offset n-word-bytes)
 446                                            ,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
 454                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 455                                                 ,(eval offset))))
 456        (:results (value :scs ,scs))
 457        (:result-types ,el-type)
 458        (:generator 2                    ; pw was 5
 459          (inst mov value (make-ea :qword :base object
 460                                   :disp (- (* (+ ,offset index) n-word-bytes)
 461                                            ,lowtag)))))))
 462
 463 (defmacro define-full-reffer+offset (name type offset lowtag scs el-type &optional translate)
 464   `(progn
 465      (define-vop (,name)
 466        ,@(when translate
 467            `((:translate ,translate)))
 468        (:policy :fast-safe)
 469        (:args (object :scs (descriptor-reg))
 470               (index :scs (any-reg)))
 471        (:info offset)
 472        (:arg-types ,type tagged-num
 473                    (:constant (constant-displacement other-pointer-lowtag
 474                                                      n-word-bytes vector-data-offset)))
 475        (:results (value :scs ,scs))
 476        (:result-types ,el-type)
 477        (:generator 3                    ; pw was 5
 478          (inst mov value (make-ea :qword :base object :index index
 479                                   :scale (ash 1 (- word-shift n-fixnum-tag-bits))
 480                                   :disp (- (* (+ ,offset offset) n-word-bytes)
 481                                            ,lowtag)))))
 482      (define-vop (,(symbolicate name "-C"))
 483        ,@(when translate
 484            `((:translate ,translate)))
 485        (:policy :fast-safe)
 486        (:args (object :scs (descriptor-reg)))
 487        (:info index offset)
 488        (:arg-types ,type
 489                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 490                                                 ,(eval offset)))
 491                    (:constant (constant-displacement other-pointer-lowtag
 492                                                      n-word-bytes vector-data-offset)))
 493        (:results (value :scs ,scs))
 494        (:result-types ,el-type)
 495        (:generator 2                    ; pw was 5
 496          (inst mov value (make-ea :qword :base object
 497                                   :disp (- (* (+ ,offset index offset) n-word-bytes)
 498                                            ,lowtag)))))))
 499
 500 (defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
 501   `(progn
 502      (define-vop (,name)
 503        ,@(when translate
 504            `((:translate ,translate)))
 505        (:policy :fast-safe)
 506        (:args (object :scs (descriptor-reg))
 507               (index :scs (any-reg))
 508               (value :scs ,scs :target result))
 509        (:arg-types ,type tagged-num ,el-type)
 510        (:results (result :scs ,scs))
 511        (:result-types ,el-type)
 512        (:generator 4                    ; was 5
 513          (inst mov (make-ea :qword :base object :index index
 514                             :scale (ash 1 (- word-shift n-fixnum-tag-bits))
 515                             :disp (- (* ,offset n-word-bytes) ,lowtag))
 516                value)
 517          (move result value)))
 518      (define-vop (,(symbolicate name "-C"))
 519        ,@(when translate
 520            `((:translate ,translate)))
 521        (:policy :fast-safe)
 522        (:args (object :scs (descriptor-reg))
 523               (value :scs ,scs :target result))
 524        (:info index)
 525        (:arg-types ,type
 526                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 527                                                 ,(eval offset)))
 528                    ,el-type)
 529        (:results (result :scs ,scs))
 530        (:result-types ,el-type)
 531        (:generator 3                    ; was 5
 532          (inst mov (make-ea :qword :base object
 533                             :disp (- (* (+ ,offset index) n-word-bytes)
 534                                      ,lowtag))
 535                value)
 536          (move result value)))))
 537
 538 (defmacro define-full-setter+offset (name type offset lowtag scs el-type &optional translate)
 539   `(progn
 540      (define-vop (,name)
 541        ,@(when translate
 542            `((:translate ,translate)))
 543        (:policy :fast-safe)
 544        (:args (object :scs (descriptor-reg))
 545               (index :scs (any-reg))
 546               (value :scs ,scs :target result))
 547        (:info offset)
 548        (:arg-types ,type tagged-num
 549                    (:constant (constant-displacement other-pointer-lowtag
 550                                                      n-word-bytes
 551                                                      vector-data-offset))
 552                    ,el-type)
 553        (:results (result :scs ,scs))
 554        (:result-types ,el-type)
 555        (:generator 4                    ; was 5
 556          (inst mov (make-ea :qword :base object :index index
 557                             :scale (ash 1 (- word-shift n-fixnum-tag-bits))
 558                             :disp (- (* (+ ,offset offset) n-word-bytes) ,lowtag))
 559                value)
 560          (move result value)))
 561      (define-vop (,(symbolicate name "-C"))
 562        ,@(when translate
 563            `((:translate ,translate)))
 564        (:policy :fast-safe)
 565        (:args (object :scs (descriptor-reg))
 566               (value :scs ,scs :target result))
 567        (:info index offset)
 568        (:arg-types ,type
 569                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 570                                                 ,(eval offset)))
 571                    (:constant (constant-displacement other-pointer-lowtag
 572                                                      n-word-bytes
 573                                                      vector-data-offset))
 574                    ,el-type)
 575        (:results (result :scs ,scs))
 576        (:result-types ,el-type)
 577        (:generator 3                    ; was 5
 578          (inst mov (make-ea :qword :base object
 579                             :disp (- (* (+ ,offset index offset) n-word-bytes)
 580                                      ,lowtag))
 581                value)
 582          (move result value)))))
 583
 584 ;;; helper for alien stuff.
 585
 586 (def!macro with-pinned-objects ((&rest objects) &body body)
 587   #!+sb-doc
 588   "Arrange with the garbage collector that the pages occupied by
 589 OBJECTS will not be moved in memory for the duration of BODY.
 590 Useful for e.g. foreign calls where another thread may trigger
 591 collection."
 592   (if objects
 593       (let ((pins (make-gensym-list (length objects)))
 594             (wpo (sb!xc:gensym "WITH-PINNED-OBJECTS-THUNK")))
 595         ;; BODY is stuffed in a function to preserve the lexical
 596         ;; environment.
 597         `(flet ((,wpo () (progn ,@body)))
 598            (declare (muffle-conditions compiler-note))
 599            ;; PINS are dx-allocated in case the compiler for some
 600            ;; unfathomable reason decides to allocate value-cells
 601            ;; for them -- since we have DX value-cells on x86oid
 602            ;; platforms this still forces them on the stack.
 603            (dx-let ,(mapcar #'list pins objects)
 604              (multiple-value-prog1 (,wpo)
 605                ;; TOUCH-OBJECT has a VOP with an empty body: compiler
 606                ;; thinks we're using the argument and doesn't flush
 607                ;; the variable, but we don't have to pay any extra
 608                ;; beyond that -- and MULTIPLE-VALUE-PROG1 keeps them
 609                ;; live till the body has finished. *whew*
 610                ,@(mapcar (lambda (pin)
 611                            `(touch-object ,pin))
 612                          pins)))))
 613       `(progn ,@body)))