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