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