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
  47 (defmacro loadw (value ptr &optional (slot 0) (lowtag 0))
  48   `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
  49
  50 (defmacro storew (value ptr &optional (slot 0) (lowtag 0))
  51   (once-only ((value value))
  52     `(cond ((and (integerp ,value)
  53                  (not (typep ,value '(signed-byte 32))))
  54             (inst mov temp-reg-tn ,value)
  55             (inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) temp-reg-tn))
  56            (t
  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
  65 (defun call-indirect (offset)
  66   (typecase offset
  67     ((signed-byte 32)
  68      (inst call (make-ea :qword :disp offset)))
  69     (t
  70      (inst mov temp-reg-tn offset)
  71      (inst call (make-ea :qword :base temp-reg-tn)))))
  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 make-ea-for-symbol-value (symbol)
  79   `(make-ea :qword
  80     :disp (+ nil-value
  81            (static-symbol-offset ',symbol)
  82            (ash symbol-value-slot word-shift)
  83            (- other-pointer-lowtag))))
  84
  85 (defmacro load-symbol-value (reg symbol)
  86   `(inst mov ,reg (make-ea-for-symbol-value ,symbol)))
  87
  88 (defmacro store-symbol-value (reg symbol)
  89   `(inst mov (make-ea-for-symbol-value ,symbol) ,reg))
  90
  91 #!+sb-thread
  92 (defmacro make-ea-for-symbol-tls-index (symbol)
  93   `(make-ea :qword
  94     :disp (+ nil-value
  95            (static-symbol-offset ',symbol)
  96            (ash symbol-tls-index-slot word-shift)
  97            (- other-pointer-lowtag))))
  98
  99 #!+sb-thread
 100 (defmacro load-tl-symbol-value (reg symbol)
 101   `(progn
 102     (inst mov ,reg (make-ea-for-symbol-tls-index ,symbol))
 103     (inst mov ,reg (make-ea :qword :base thread-base-tn :scale 1 :index ,reg))))
 104 #!-sb-thread
 105 (defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol))
 106
 107 #!+sb-thread
 108 (defmacro store-tl-symbol-value (reg symbol temp)
 109   `(progn
 110     (inst mov ,temp (make-ea-for-symbol-tls-index ,symbol))
 111     (inst mov (make-ea :qword :base thread-base-tn :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-binding-stack-pointer (reg)
 118   #!+sb-thread
 119   `(inst mov ,reg (make-ea :qword :base thread-base-tn
 120                    :disp (* n-word-bytes thread-binding-stack-pointer-slot)))
 121   #!-sb-thread
 122   `(load-symbol-value ,reg *binding-stack-pointer*))
 123
 124 (defmacro store-binding-stack-pointer (reg)
 125   #!+sb-thread
 126   `(inst mov (make-ea :qword :base thread-base-tn
 127               :disp (* n-word-bytes thread-binding-stack-pointer-slot))
 128     ,reg)
 129   #!-sb-thread
 130   `(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   (inst and rsp-tn #.(lognot lowtag-mask))
 162   (aver (not (location= alloc-tn rsp-tn)))
 163   (inst lea alloc-tn (make-ea :byte :base rsp-tn :disp lowtag))
 164   (values))
 165
 166 ;;; This macro should only be used inside a pseudo-atomic section,
 167 ;;; which should also cover subsequent initialization of the
 168 ;;; object.
 169 (defun allocation-tramp (alloc-tn size lowtag)
 170   (inst push size)
 171   (inst mov alloc-tn (make-fixup "alloc_tramp" :foreign))
 172   (inst call alloc-tn)
 173   (inst pop alloc-tn)
 174   (when lowtag
 175     (inst lea alloc-tn (make-ea :byte :base alloc-tn :disp lowtag)))
 176   (values))
 177
 178 (defun allocation (alloc-tn size &optional ignored dynamic-extent lowtag)
 179   (declare (ignore ignored))
 180   (when dynamic-extent
 181     (allocation-dynamic-extent alloc-tn size lowtag)
 182     (return-from allocation (values)))
 183   (let ((NOT-INLINE (gen-label))
 184         (DONE (gen-label))
 185         ;; Yuck.
 186         (in-elsewhere (eq *elsewhere* sb!assem::**current-segment**))
 187         ;; thread->alloc_region.free_pointer
 188         (free-pointer
 189          #!+sb-thread
 190          (make-ea :qword
 191                   :base thread-base-tn :scale 1
 192                   :disp (* n-word-bytes thread-alloc-region-slot))
 193          #!-sb-thread
 194          (make-ea :qword
 195                   :scale 1 :disp
 196                   (make-fixup "boxed_region" :foreign)))
 197         ;; thread->alloc_region.end_addr
 198         (end-addr
 199          #!+sb-thread
 200          (make-ea :qword
 201                   :base thread-base-tn :scale 1
 202                   :disp (* n-word-bytes (1+ thread-alloc-region-slot)))
 203          #!-sb-thread
 204          (make-ea :qword
 205                   :scale 1 :disp
 206                   (make-fixup "boxed_region" :foreign 8))))
 207     (cond (in-elsewhere
 208            (allocation-tramp alloc-tn size lowtag))
 209           (t
 210            (inst mov temp-reg-tn free-pointer)
 211            (if (tn-p size)
 212                (if (location= alloc-tn size)
 213                    (inst add alloc-tn temp-reg-tn)
 214                    (inst lea alloc-tn
 215                          (make-ea :qword :base temp-reg-tn :index size)))
 216                (inst lea alloc-tn
 217                      (make-ea :qword :base temp-reg-tn :disp size)))
 218            (inst cmp end-addr alloc-tn)
 219            (inst jmp :be NOT-INLINE)
 220            (inst mov free-pointer alloc-tn)
 221            (if lowtag
 222                (inst lea alloc-tn (make-ea :byte :base temp-reg-tn :disp lowtag))
 223                (inst mov alloc-tn temp-reg-tn))
 224            (emit-label DONE)
 225            (assemble (*elsewhere*)
 226              (emit-label NOT-INLINE)
 227              (cond ((numberp size)
 228                     (allocation-tramp alloc-tn size lowtag))
 229                    (t
 230                     (inst sub alloc-tn free-pointer)
 231                     (allocation-tramp alloc-tn alloc-tn lowtag)))
 232              (inst jmp DONE))))
 233     (values)))
 234
 235 ;;; Allocate an other-pointer object of fixed SIZE with a single word
 236 ;;; header having the specified WIDETAG value. The result is placed in
 237 ;;; RESULT-TN.
 238 (defmacro with-fixed-allocation ((result-tn widetag size &optional inline stack-allocate-p)
 239                                  &body forms)
 240   (unless forms
 241     (bug "empty &body in WITH-FIXED-ALLOCATION"))
 242   (once-only ((result-tn result-tn) (size size) (stack-allocate-p stack-allocate-p))
 243     `(maybe-pseudo-atomic ,stack-allocate-p
 244       (allocation ,result-tn (pad-data-block ,size) ,inline ,stack-allocate-p
 245                   other-pointer-lowtag)
 246       (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
 247               ,result-tn 0 other-pointer-lowtag)
 248       ,@forms)))
 249 \f
 250 ;;;; error code
 251 (defun emit-error-break (vop kind code values)
 252   (assemble ()
 253     #!-ud2-breakpoints
 254     (inst int 3)                  ; i386 breakpoint instruction
 255     ;; On Darwin, we need to use #x0b0f instead of int3 in order
 256     ;; to generate a SIGILL instead of a SIGTRAP as darwin/x86
 257     ;; doesn't seem to be reliably firing SIGTRAP
 258     ;; handlers. Hopefully this will be fixed by Apple at a
 259     ;; later date. Do the same on x86-64 as we do on x86 until this gets
 260     ;; sorted out.
 261     #!+ud2-breakpoints
 262     (inst word #x0b0f)
 263     ;; The return PC points here; note the location for the debugger.
 264     (when vop
 265       (note-this-location vop :internal-error))
 266     (inst byte kind)                       ; eg trap_Xyyy
 267     (with-adjustable-vector (vector)       ; interr arguments
 268       (write-var-integer code vector)
 269       (dolist (tn values)
 270         ;; classic CMU CL comment:
 271         ;;   zzzzz jrd here. tn-offset is zero for constant
 272         ;;   tns.
 273         (write-var-integer (make-sc-offset (sc-number (tn-sc tn))
 274                                            (or (tn-offset tn) 0))
 275                            vector))
 276       (inst byte (length vector))
 277       (dotimes (i (length vector))
 278         (inst byte (aref vector i))))))
 279
 280 (defun error-call (vop error-code &rest values)
 281   #!+sb-doc
 282   "Cause an error. ERROR-CODE is the error to cause."
 283   (emit-error-break vop error-trap (error-number-or-lose error-code) values))
 284
 285 (defun generate-error-code (vop error-code &rest values)
 286   #!+sb-doc
 287   "Generate-Error-Code Error-code Value*
 288   Emit code for an error with the specified Error-Code and context Values."
 289   (assemble (*elsewhere*)
 290     (let ((start-lab (gen-label)))
 291       (emit-label start-lab)
 292       (emit-error-break vop error-trap (error-number-or-lose error-code) values)
 293        start-lab)))
 294
 295 \f
 296 ;;;; PSEUDO-ATOMIC
 297
 298 ;;; This is used to wrap operations which leave untagged memory lying
 299 ;;; around.  It's an operation which the AOP weenies would describe as
 300 ;;; having "cross-cutting concerns", meaning it appears all over the
 301 ;;; place and there's no logical single place to attach documentation.
 302 ;;; grep (mostly in src/runtime) is your friend
 303
 304 (defmacro maybe-pseudo-atomic (not-really-p &body body)
 305   `(if ,not-really-p
 306        (progn ,@body)
 307        (pseudo-atomic ,@body)))
 308
 309 ;;; Unsafely clear pa flags so that the image can properly lose in a
 310 ;;; pa section.
 311 #!+sb-thread
 312 (defmacro %clear-pseudo-atomic ()
 313   '(inst mov (make-ea :qword :base thread-base-tn
 314               :disp (* n-word-bytes thread-pseudo-atomic-bits-slot))
 315     0))
 316
 317 #!+sb-safepoint
 318 (defun emit-safepoint ()
 319   (inst test al-tn (make-ea :byte :disp sb!vm::gc-safepoint-page-addr)))
 320
 321 #!+sb-thread
 322 (defmacro pseudo-atomic (&rest forms)
 323   #!+sb-safepoint-strictly
 324   `(progn ,@forms (emit-safepoint))
 325   #!-sb-safepoint-strictly
 326   (with-unique-names (label)
 327     `(let ((,label (gen-label)))
 328        (inst mov (make-ea :qword
 329                           :base thread-base-tn
 330                           :disp (* n-word-bytes thread-pseudo-atomic-bits-slot))
 331              rbp-tn)
 332        ,@forms
 333        (inst xor (make-ea :qword
 334                           :base thread-base-tn
 335                           :disp (* n-word-bytes thread-pseudo-atomic-bits-slot))
 336              rbp-tn)
 337        (inst jmp :z ,label)
 338        ;; if PAI was set, interrupts were disabled at the same time
 339        ;; using the process signal mask.
 340        (inst break pending-interrupt-trap)
 341        (emit-label ,label)
 342        #!+sb-safepoint
 343        ;; In this case, when allocation thinks a GC should be done, it
 344        ;; does not mark PA as interrupted, but schedules a safepoint
 345        ;; trap instead.  Let's take the opportunity to trigger that
 346        ;; safepoint right now.
 347        (emit-safepoint))))
 348
 349
 350 #!-sb-thread
 351 (defmacro pseudo-atomic (&rest forms)
 352   (with-unique-names (label)
 353     `(let ((,label (gen-label)))
 354        ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
 355        ;; something. (perhaps SVLB, for static variable low byte)
 356        (inst mov (make-ea :qword :disp (+ nil-value
 357                                           (static-symbol-offset
 358                                            '*pseudo-atomic-bits*)
 359                                           (ash symbol-value-slot word-shift)
 360                                           (- other-pointer-lowtag)))
 361              rbp-tn)
 362        ,@forms
 363        (inst xor (make-ea :qword :disp (+ nil-value
 364                                           (static-symbol-offset
 365                                            '*pseudo-atomic-bits*)
 366                                           (ash symbol-value-slot word-shift)
 367                                           (- other-pointer-lowtag)))
 368              rbp-tn)
 369        (inst jmp :z ,label)
 370        ;; if PAI was set, interrupts were disabled at the same time
 371        ;; using the process signal mask.
 372        (inst break pending-interrupt-trap)
 373        (emit-label ,label))))
 374 \f
 375 ;;;; indexed references
 376
 377 (defmacro define-full-compare-and-swap
 378     (name type offset lowtag scs el-type &optional translate)
 379   `(progn
 380      (define-vop (,name)
 381          ,@(when translate `((:translate ,translate)))
 382        (:policy :fast-safe)
 383        (:args (object :scs (descriptor-reg) :to :eval)
 384               (index :scs (any-reg) :to :result)
 385               (old-value :scs ,scs :target rax)
 386               (new-value :scs ,scs))
 387        (:arg-types ,type tagged-num ,el-type ,el-type)
 388        (:temporary (:sc descriptor-reg :offset rax-offset
 389                         :from (:argument 2) :to :result :target value)  rax)
 390        (:results (value :scs ,scs))
 391        (:result-types ,el-type)
 392        (:generator 5
 393          (move rax old-value)
 394          (inst cmpxchg (make-ea :qword :base object :index index
 395                                 :scale (ash 1 (- word-shift n-fixnum-tag-bits))
 396                                 :disp (- (* ,offset n-word-bytes) ,lowtag))
 397                new-value :lock)
 398          (move value rax)))))
 399
 400 (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
 401   `(progn
 402      (define-vop (,name)
 403        ,@(when translate
 404            `((:translate ,translate)))
 405        (:policy :fast-safe)
 406        (:args (object :scs (descriptor-reg))
 407               (index :scs (any-reg)))
 408        (:arg-types ,type tagged-num)
 409        (:results (value :scs ,scs))
 410        (:result-types ,el-type)
 411        (:generator 3                    ; pw was 5
 412          (inst mov value (make-ea :qword :base object :index index
 413                                   :scale (ash 1 (- word-shift n-fixnum-tag-bits))
 414                                   :disp (- (* ,offset n-word-bytes)
 415                                            ,lowtag)))))
 416      (define-vop (,(symbolicate name "-C"))
 417        ,@(when translate
 418            `((:translate ,translate)))
 419        (:policy :fast-safe)
 420        (:args (object :scs (descriptor-reg)))
 421        (:info index)
 422        (:arg-types ,type
 423                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 424                                                 ,(eval offset))))
 425        (:results (value :scs ,scs))
 426        (:result-types ,el-type)
 427        (:generator 2                    ; pw was 5
 428          (inst mov value (make-ea :qword :base object
 429                                   :disp (- (* (+ ,offset index) n-word-bytes)
 430                                            ,lowtag)))))))
 431
 432 (defmacro define-full-reffer+offset (name type offset lowtag scs el-type &optional translate)
 433   `(progn
 434      (define-vop (,name)
 435        ,@(when translate
 436            `((:translate ,translate)))
 437        (:policy :fast-safe)
 438        (:args (object :scs (descriptor-reg))
 439               (index :scs (any-reg)))
 440        (:info offset)
 441        (:arg-types ,type tagged-num
 442                    (:constant (constant-displacement other-pointer-lowtag
 443                                                      n-word-bytes vector-data-offset)))
 444        (:results (value :scs ,scs))
 445        (:result-types ,el-type)
 446        (:generator 3                    ; pw was 5
 447          (inst mov value (make-ea :qword :base object :index index
 448                                   :scale (ash 1 (- word-shift n-fixnum-tag-bits))
 449                                   :disp (- (* (+ ,offset offset) n-word-bytes)
 450                                            ,lowtag)))))
 451      (define-vop (,(symbolicate name "-C"))
 452        ,@(when translate
 453            `((:translate ,translate)))
 454        (:policy :fast-safe)
 455        (:args (object :scs (descriptor-reg)))
 456        (:info index offset)
 457        (:arg-types ,type
 458                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 459                                                 ,(eval offset)))
 460                    (:constant (constant-displacement other-pointer-lowtag
 461                                                      n-word-bytes vector-data-offset)))
 462        (:results (value :scs ,scs))
 463        (:result-types ,el-type)
 464        (:generator 2                    ; pw was 5
 465          (inst mov value (make-ea :qword :base object
 466                                   :disp (- (* (+ ,offset index offset) n-word-bytes)
 467                                            ,lowtag)))))))
 468
 469 (defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
 470   `(progn
 471      (define-vop (,name)
 472        ,@(when translate
 473            `((:translate ,translate)))
 474        (:policy :fast-safe)
 475        (:args (object :scs (descriptor-reg))
 476               (index :scs (any-reg))
 477               (value :scs ,scs :target result))
 478        (:arg-types ,type tagged-num ,el-type)
 479        (:results (result :scs ,scs))
 480        (:result-types ,el-type)
 481        (:generator 4                    ; was 5
 482          (inst mov (make-ea :qword :base object :index index
 483                             :scale (ash 1 (- word-shift n-fixnum-tag-bits))
 484                             :disp (- (* ,offset n-word-bytes) ,lowtag))
 485                value)
 486          (move result value)))
 487      (define-vop (,(symbolicate name "-C"))
 488        ,@(when translate
 489            `((:translate ,translate)))
 490        (:policy :fast-safe)
 491        (:args (object :scs (descriptor-reg))
 492               (value :scs ,scs :target result))
 493        (:info index)
 494        (:arg-types ,type
 495                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 496                                                 ,(eval offset)))
 497                    ,el-type)
 498        (:results (result :scs ,scs))
 499        (:result-types ,el-type)
 500        (:generator 3                    ; was 5
 501          (inst mov (make-ea :qword :base object
 502                             :disp (- (* (+ ,offset index) n-word-bytes)
 503                                      ,lowtag))
 504                value)
 505          (move result value)))))
 506
 507 (defmacro define-full-setter+offset (name type offset lowtag scs el-type &optional translate)
 508   `(progn
 509      (define-vop (,name)
 510        ,@(when translate
 511            `((:translate ,translate)))
 512        (:policy :fast-safe)
 513        (:args (object :scs (descriptor-reg))
 514               (index :scs (any-reg))
 515               (value :scs ,scs :target result))
 516        (:info offset)
 517        (:arg-types ,type tagged-num
 518                    (:constant (constant-displacement other-pointer-lowtag
 519                                                      n-word-bytes
 520                                                      vector-data-offset))
 521                    ,el-type)
 522        (:results (result :scs ,scs))
 523        (:result-types ,el-type)
 524        (:generator 4                    ; was 5
 525          (inst mov (make-ea :qword :base object :index index
 526                             :scale (ash 1 (- word-shift n-fixnum-tag-bits))
 527                             :disp (- (* (+ ,offset offset) n-word-bytes) ,lowtag))
 528                value)
 529          (move result value)))
 530      (define-vop (,(symbolicate name "-C"))
 531        ,@(when translate
 532            `((:translate ,translate)))
 533        (:policy :fast-safe)
 534        (:args (object :scs (descriptor-reg))
 535               (value :scs ,scs :target result))
 536        (:info index offset)
 537        (:arg-types ,type
 538                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
 539                                                 ,(eval offset)))
 540                    (:constant (constant-displacement other-pointer-lowtag
 541                                                      n-word-bytes
 542                                                      vector-data-offset))
 543                    ,el-type)
 544        (:results (result :scs ,scs))
 545        (:result-types ,el-type)
 546        (:generator 3                    ; was 5
 547          (inst mov (make-ea :qword :base object
 548                             :disp (- (* (+ ,offset index offset) n-word-bytes)
 549                                      ,lowtag))
 550                value)
 551          (move result value)))))
 552
 553 ;;; helper for alien stuff.
 554
 555 (def!macro with-pinned-objects ((&rest objects) &body body)
 556   "Arrange with the garbage collector that the pages occupied by
 557 OBJECTS will not be moved in memory for the duration of BODY.
 558 Useful for e.g. foreign calls where another thread may trigger
 559 collection."
 560   (if objects
 561       (let ((pins (make-gensym-list (length objects)))
 562             (wpo (sb!xc:gensym "WITH-PINNED-OBJECTS-THUNK")))
 563         ;; BODY is stuffed in a function to preserve the lexical
 564         ;; environment.
 565         `(flet ((,wpo () (progn ,@body)))
 566            (declare (muffle-conditions compiler-note))
 567            ;; PINS are dx-allocated in case the compiler for some
 568            ;; unfathomable reason decides to allocate value-cells
 569            ;; for them -- since we have DX value-cells on x86oid
 570            ;; platforms this still forces them on the stack.
 571            (dx-let ,(mapcar #'list pins objects)
 572              (multiple-value-prog1 (,wpo)
 573                ;; TOUCH-OBJECT has a VOP with an empty body: compiler
 574                ;; thinks we're using the argument and doesn't flush
 575                ;; the variable, but we don't have to pay any extra
 576                ;; beyond that -- and MULTIPLE-VALUE-PROG1 keeps them
 577                ;; live till the body has finished. *whew*
 578                ,@(mapcar (lambda (pin)
 579                            `(touch-object ,pin))
 580                          pins)))))
 581       `(progn ,@body)))