0.8.17.17:

[sbcl.git] / src / compiler / alpha / macros.lisp

diff --git a/src/compiler/alpha/macros.lisp b/src/compiler/alpha/macros.lisp
index fcb878f..a251501 100644 (file)
--- a/src/compiler/alpha/macros.lisp
+++ b/src/compiler/alpha/macros.lisp
@@ -1,34 +1,26 @@
-;;; -*- Package: ALPHA; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
-;;; Carnegie Mellon University, and has been placed in the public domain.
-;;;
-
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains various useful macros for generating Alpha code.
-;;;
-;;; Written by William Lott and Christopher Hoover.
-;;; Alpha conversion by Sean Hallgren.
-;;; 
-
-(in-package "SB!VM")
+;;;; various useful macros for generating Alpha code

 
 

+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.

 
 

-;;; Handy macro for defining top-level forms that depend on the compile
-;;; environment.
+(in-package "SB!VM")

 
 

+;;; a handy macro for defining top level forms that depend on the
+;;; compile environment

 (defmacro expand (expr)
   (let ((gensym (gensym)))
     `(macrolet
         ((,gensym ()
            ,expr))
        (,gensym))))
 (defmacro expand (expr)
   (let ((gensym (gensym)))
     `(macrolet
         ((,gensym ()
            ,expr))
        (,gensym))))

-

 \f
 \f

-;;; Instruction-like macros.
+;;; instruction-like macros

 
 ;;; c.f. x86 backend:
 ;;(defmacro move (dst src)
 
 ;;; c.f. x86 backend:
 ;;(defmacro move (dst src)

@@ -39,7 +31,6 @@
 ;;    `(unless (location= ,n-dst ,n-src)
 ;;       (inst mov ,n-dst ,n-src))))
 
 ;;    `(unless (location= ,n-dst ,n-src)
 ;;       (inst mov ,n-dst ,n-src))))
 

-

 (defmacro move (src dst)
   "Move SRC into DST unless they are location=."
   (once-only ((n-src src) (n-dst dst))
 (defmacro move (src dst)
   "Move SRC into DST unless they are location=."
   (once-only ((n-src src) (n-dst dst))

@@ -70,14 +61,14 @@
   `(inst ldl ,reg
         (+ (static-symbol-offset ',symbol)
            (ash symbol-value-slot word-shift)
   `(inst ldl ,reg
         (+ (static-symbol-offset ',symbol)
            (ash symbol-value-slot word-shift)

-           (- other-pointer-type))
+           (- other-pointer-lowtag))

         null-tn))
 
 (defmacro store-symbol-value (reg symbol)
   `(inst stl ,reg
         (+ (static-symbol-offset ',symbol)
            (ash symbol-value-slot word-shift)
         null-tn))
 
 (defmacro store-symbol-value (reg symbol)
   `(inst stl ,reg
         (+ (static-symbol-offset ',symbol)
            (ash symbol-value-slot word-shift)

-           (- other-pointer-type))
+           (- other-pointer-lowtag))

         null-tn))
 
 (defmacro load-type (target source &optional (offset 0))
         null-tn))
 
 (defmacro load-type (target source &optional (offset 0))

@@ -90,14 +81,14 @@
        (inst ldl ,n-target ,n-offset ,n-source)
        (inst and ,n-target #xff ,n-target))))
 
        (inst ldl ,n-target ,n-offset ,n-source)
        (inst and ,n-target #xff ,n-target))))
 

-;;; Macros to handle the fact that we cannot use the machine native call and
-;;; return instructions. 
+;;; macros to handle the fact that we cannot use the machine native
+;;; call and return instructions

 
 (defmacro lisp-jump (function lip)
   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
   `(progn
 
 (defmacro lisp-jump (function lip)
   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
   `(progn

-     (inst lda ,lip (- (ash sb!vm:function-code-offset sb!vm:word-shift)
-                            sb!vm:function-pointer-type)
+     (inst lda ,lip (- (ash simple-fun-code-offset word-shift)
+                      fun-pointer-lowtag)

            ,function)
      (move ,function code-tn)
      (inst jsr zero-tn ,lip 1)))
            ,function)
      (move ,function code-tn)
      (inst jsr zero-tn ,lip 1)))

@@ -106,7 +97,7 @@
   "Return to RETURN-PC.  LIP is an interior-reg temporary."
   `(progn
      (inst lda ,lip  
   "Return to RETURN-PC.  LIP is an interior-reg temporary."
   `(progn
      (inst lda ,lip  

-          (- (* (1+ ,offset) word-bytes) other-pointer-type)
+          (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)

            ,return-pc)
      ,@(when frob-code
         `((move ,return-pc code-tn)))
            ,return-pc)
      ,@(when frob-code
         `((move ,return-pc code-tn)))

@@ -117,18 +108,15 @@
   "Emit a return-pc header word.  LABEL is the label to use for this
    return-pc."
   `(progn
   "Emit a return-pc header word.  LABEL is the label to use for this
    return-pc."
   `(progn

-     (align lowtag-bits)
+     (align n-lowtag-bits)

      (emit-label ,label)
      (inst lra-header-word)))
 
 
 \f
      (emit-label ,label)
      (inst lra-header-word)))
 
 
 \f

-;;;; Stack TN's
+;;;; stack TN's

 
 

-;;; Load-Stack-TN, Store-Stack-TN  --  Interface
-;;;

 ;;;    Move a stack TN to a register and vice-versa.
 ;;;    Move a stack TN to a register and vice-versa.

-;;;

 (defmacro load-stack-tn (reg stack)
   `(let ((reg ,reg)
         (stack ,stack))
 (defmacro load-stack-tn (reg stack)
   `(let ((reg ,reg)
         (stack ,stack))

@@ -136,7 +124,6 @@
        (sc-case stack
         ((control-stack)
          (loadw reg cfp-tn offset))))))
        (sc-case stack
         ((control-stack)
          (loadw reg cfp-tn offset))))))

-

 (defmacro store-stack-tn (stack reg)
   `(let ((stack ,stack)
         (reg ,reg))
 (defmacro store-stack-tn (stack reg)
   `(let ((stack ,stack)
         (reg ,reg))

@@ -145,11 +132,8 @@
         ((control-stack)
          (storew reg cfp-tn offset))))))
 
         ((control-stack)
          (storew reg cfp-tn offset))))))
 

-
-;;; MAYBE-LOAD-STACK-TN  --  Interface
-;;;
+;;; Move the TN Reg-Or-Stack into Reg if it isn't already there.

 (defmacro maybe-load-stack-tn (reg reg-or-stack)
 (defmacro maybe-load-stack-tn (reg reg-or-stack)

-  "Move the TN Reg-Or-Stack into Reg if it isn't already there."

   (once-only ((n-reg reg)
              (n-stack reg-or-stack))
     `(sc-case ,n-reg
   (once-only ((n-reg reg)
              (n-stack reg-or-stack))
     `(sc-case ,n-reg

@@ -160,10 +144,8 @@
          ((control-stack)
           (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
 
          ((control-stack)
           (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
 

-;;; MAYBE-LOAD-STACK-NFP-TN -- Interface
-;;;
+;;; Move the TN Reg-Or-Stack into Reg if it isn't already there.

 (defmacro maybe-load-stack-nfp-tn (reg reg-or-stack temp)
 (defmacro maybe-load-stack-nfp-tn (reg reg-or-stack temp)

-  "Move the TN Reg-Or-Stack into Reg if it isn't already there."

   (once-only ((n-reg reg)
              (n-stack reg-or-stack))
      `(when ,reg
   (once-only ((n-reg reg)
              (n-stack reg-or-stack))
      `(when ,reg

@@ -176,43 +158,24 @@
            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))
            (inst mskll nsp-tn 0 ,temp)
            (inst bis ,temp ,n-reg ,n-reg))))))))
            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))
            (inst mskll nsp-tn 0 ,temp)
            (inst bis ,temp ,n-reg ,n-reg))))))))

-
-

 \f
 \f

-;;;; Storage allocation:
-
-(defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
+;;;; storage allocation
+
+;;; Do stuff to allocate an other-pointer object of fixed SIZE with a
+;;; single word header having the specified WIDETAG value. The result is
+;;; placed in RESULT-TN, Flag-Tn must be wired to NL3-OFFSET, and
+;;; Temp-TN is a non- descriptor temp (which may be randomly used by
+;;; the body.) The body is placed inside the PSEUDO-ATOMIC, and
+;;; presumably initializes the object.
+(defmacro with-fixed-allocation ((result-tn temp-tn widetag size)

                                 &body body)
                                 &body body)

-  "Do stuff to allocate an other-pointer object of fixed Size with a single
-   word header having the specified Type-Code.  The result is placed in
-   Result-TN, Flag-Tn must be wired to NL3-OFFSET, and Temp-TN is a non-
-   descriptor temp (which may be randomly used by the body.)  The body is
-   placed inside the PSEUDO-ATOMIC, and presumably initializes the object."

   `(pseudo-atomic (:extra (pad-data-block ,size))
   `(pseudo-atomic (:extra (pad-data-block ,size))

-     (inst bis alloc-tn other-pointer-type ,result-tn)
-     (inst li (logior (ash (1- ,size) type-bits) ,type-code) ,temp-tn)
-     (storew ,temp-tn ,result-tn 0 other-pointer-type)
+     (inst bis alloc-tn other-pointer-lowtag ,result-tn)
+     (inst li (logior (ash (1- ,size) n-widetag-bits) ,widetag) ,temp-tn)
+     (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)

      ,@body))
      ,@body))

-
-

 \f
 \f

-;;;; Error Code
-
-
-(defvar *adjustable-vectors* nil)
-
-(defmacro with-adjustable-vector ((var) &rest body)
-  `(let ((,var (or (pop *adjustable-vectors*)
-                  (make-array 16
-                              :element-type '(unsigned-byte 8)
-                              :fill-pointer 0
-                              :adjustable t))))
-     (setf (fill-pointer ,var) 0)
-     (unwind-protect
-        (progn
-          ,@body)
-       (push ,var *adjustable-vectors*))))
-
+;;;; error code

 (eval-when (:compile-toplevel :load-toplevel :execute) 
   (defun emit-error-break (vop kind code values)
     (let ((vector (gensym)))
 (eval-when (:compile-toplevel :load-toplevel :execute) 
   (defun emit-error-break (vop kind code values)
     (let ((vector (gensym)))

@@ -222,12 +185,12 @@
        (inst gentrap ,kind)
        (with-adjustable-vector (,vector)
          (write-var-integer (error-number-or-lose ',code) ,vector)
        (inst gentrap ,kind)
        (with-adjustable-vector (,vector)
          (write-var-integer (error-number-or-lose ',code) ,vector)

-         ,@(mapcar #'(lambda (tn)
-                       `(let ((tn ,tn))
-                          (write-var-integer (make-sc-offset (sc-number
-                                                              (tn-sc tn))
-                                                             (tn-offset tn))
-                                             ,vector)))
+         ,@(mapcar (lambda (tn)
+                     `(let ((tn ,tn))
+                        (write-var-integer (make-sc-offset (sc-number
+                                                            (tn-sc tn))
+                                                           (tn-offset tn))
+                                           ,vector)))

                    values)
          (inst byte (length ,vector))
          (dotimes (i (length ,vector))
                    values)
          (inst byte (length ,vector))
          (dotimes (i (length ,vector))

@@ -261,8 +224,7 @@
   Emit code for a continuable error with the specified Error-Code and
   context Values.  If the error is continued, execution resumes after
   the GENERATE-CERROR-CODE form."
   Emit code for a continuable error with the specified Error-Code and
   context Values.  If the error is continued, execution resumes after
   the GENERATE-CERROR-CODE form."

-  (let ((continue (gensym "CONTINUE-LABEL-"))
-       (error (gensym "ERROR-LABEL-")))
+  (with-unique-names (continue error)

     `(let ((,continue (gen-label)))
        (emit-label ,continue)
        (assemble (*elsewhere*)
     `(let ((,continue (gen-label)))
        (emit-label ,continue)
        (assemble (*elsewhere*)

@@ -272,28 +234,15 @@
           ,error)))))
 
 \f
           ,error)))))
 
 \f

-;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
-;;;
+;;; a handy macro for making sequences look atomic

 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
   `(progn
      (inst addq alloc-tn 1 alloc-tn)
      ,@forms
      (inst lda alloc-tn (1- ,extra) alloc-tn)
      (inst stl zero-tn 0 alloc-tn)))
 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
   `(progn
      (inst addq alloc-tn 1 alloc-tn)
      ,@forms
      (inst lda alloc-tn (1- ,extra) alloc-tn)
      (inst stl zero-tn 0 alloc-tn)))

-
-

 \f
 \f

-;;;; Memory accessor vop generators
-
-(deftype load/store-index (scale lowtag min-offset
-                                &optional (max-offset min-offset))
-  `(integer ,(- (truncate (+ (ash 1 16)
-                            (* min-offset word-bytes)
-                            (- lowtag))
-                         scale))
-           ,(truncate (- (+ (1- (ash 1 16)) lowtag)
-                         (* max-offset word-bytes))
-                      scale)))
+;;;; memory accessor vop generators

 
 (defmacro define-full-reffer (name type offset lowtag scs el-type
                                   &optional translate)
 
 (defmacro define-full-reffer (name type offset lowtag scs el-type
                                   &optional translate)

@@ -310,7 +259,7 @@
        (:result-types ,el-type)
        (:generator 5
         (inst addq object index lip)
        (:result-types ,el-type)
        (:generator 5
         (inst addq object index lip)

-        (inst ldl value (- (* ,offset word-bytes) ,lowtag) lip)
+        (inst ldl value (- (* ,offset n-word-bytes) ,lowtag) lip)

         ,@(when (equal scs '(unsigned-reg))
             '((inst mskll value 4 value)))))
      (define-vop (,(symbolicate name "-C"))
         ,@(when (equal scs '(unsigned-reg))
             '((inst mskll value 4 value)))))
      (define-vop (,(symbolicate name "-C"))

@@ -320,18 +269,18 @@
        (:args (object :scs (descriptor-reg)))
        (:info index)
        (:arg-types ,type
        (:args (object :scs (descriptor-reg)))
        (:info index)
        (:arg-types ,type

-                  (:constant (load/store-index ,word-bytes ,(eval lowtag)
+                  (:constant (load/store-index ,n-word-bytes ,(eval lowtag)

                                                ,(eval offset))))
        (:results (value :scs ,scs))
        (:result-types ,el-type)
        (:generator 4
                                                ,(eval offset))))
        (:results (value :scs ,scs))
        (:result-types ,el-type)
        (:generator 4

-        (inst ldl value (- (* (+ ,offset index) word-bytes) ,lowtag)
+        (inst ldl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)

               object)
         ,@(when (equal scs '(unsigned-reg))
             '((inst mskll value 4 value)))))))
 
 (defmacro define-full-setter (name type offset lowtag scs el-type
               object)
         ,@(when (equal scs '(unsigned-reg))
             '((inst mskll value 4 value)))))))
 
 (defmacro define-full-setter (name type offset lowtag scs el-type

-                                  &optional translate #+gengc (remember t))
+                                  &optional translate #!+gengc (remember t))

   `(progn
      (define-vop (,name)
        ,@(when translate
   `(progn
      (define-vop (,name)
        ,@(when translate

@@ -346,7 +295,7 @@
        (:result-types ,el-type)
        (:generator 2
         (inst addq index object lip)
        (:result-types ,el-type)
        (:generator 2
         (inst addq index object lip)

-        (inst stl value (- (* ,offset word-bytes) ,lowtag) lip)
+        (inst stl value (- (* ,offset n-word-bytes) ,lowtag) lip)

         (move value result)))
      (define-vop (,(symbolicate name "-C"))
        ,@(when translate
         (move value result)))
      (define-vop (,(symbolicate name "-C"))
        ,@(when translate

@@ -356,13 +305,13 @@
              (value :scs ,scs))
        (:info index)
        (:arg-types ,type
              (value :scs ,scs))
        (:info index)
        (:arg-types ,type

-                  (:constant (load/store-index ,word-bytes ,(eval lowtag)
+                  (:constant (load/store-index ,n-word-bytes ,(eval lowtag)

                                                ,(eval offset)))
                   ,el-type)
        (:results (result :scs ,scs))
        (:result-types ,el-type)
        (:generator 1
                                                ,(eval offset)))
                   ,el-type)
        (:results (result :scs ,scs))
        (:result-types ,el-type)
        (:generator 1

-        (inst stl value (- (* (+ ,offset index) word-bytes) ,lowtag)
+        (inst stl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)

               object)
         (move value result)))))
 
               object)
         (move value result)))))
 

@@ -390,28 +339,31 @@
           ,@(ecase size
               (:byte
                (if signed
           ,@(ecase size
               (:byte
                (if signed

-                   `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag)
+                   `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)

                            lip)
                            lip)

-                     (inst lda temp1 (1+ (- (* ,offset word-bytes) ,lowtag))
+                     (inst lda temp1 (1+ (- (* ,offset n-word-bytes) ,lowtag))

                            lip)
                      (inst extqh temp temp1 temp)
                      (inst sra temp 56 value))
                            lip)
                      (inst extqh temp temp1 temp)
                      (inst sra temp 56 value))

-                   `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) lip)
-                     (inst lda temp1 (- (* ,offset word-bytes) ,lowtag)
+                   `((inst ldq_u
+                           temp
+                           (- (* ,offset n-word-bytes) ,lowtag)
+                           lip)
+                     (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)

                                          lip)
                      (inst extbl temp temp1 value))))
               (:short
                (if signed
                                          lip)
                      (inst extbl temp temp1 value))))
               (:short
                (if signed

-                   `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag)
+                   `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)

                            lip)
                            lip)

-                     (inst lda temp1 (- (* ,offset word-bytes) ,lowtag)
+                     (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)

                            lip)
                      (inst extwl temp temp1 temp)
                      (inst sll temp 48 temp)
                      (inst sra temp 48 value))
                            lip)
                      (inst extwl temp temp1 temp)
                      (inst sll temp 48 temp)
                      (inst sra temp 48 value))

-                   `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag)
+                   `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)

                            lip)
                            lip)

-                     (inst lda temp1 (- (* ,offset word-bytes) ,lowtag) lip)
+                     (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)

                      (inst extwl temp temp1 value)))))))
        (define-vop (,(symbolicate name "-C"))
         ,@(when translate
                      (inst extwl temp temp1 value)))))))
        (define-vop (,(symbolicate name "-C"))
         ,@(when translate

@@ -427,40 +379,40 @@
         (:result-types ,el-type)
         (:temporary (:sc non-descriptor-reg) temp)
         (:temporary (:sc non-descriptor-reg) temp1)
         (:result-types ,el-type)
         (:temporary (:sc non-descriptor-reg) temp)
         (:temporary (:sc non-descriptor-reg) temp1)

-        (:generator 5
+        (:generator 4

           ,@(ecase size
               (:byte
                (if signed
           ,@(ecase size
               (:byte
                (if signed

-                   `((inst ldq_u temp (- (+ (* ,offset word-bytes)
+                   `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)

                                             (* index ,scale)) ,lowtag)
                            object)
                                             (* index ,scale)) ,lowtag)
                            object)

-                     (inst lda temp1 (1+ (- (+ (* ,offset word-bytes)
+                     (inst lda temp1 (1+ (- (+ (* ,offset n-word-bytes)

                                                (* index ,scale)) ,lowtag))
                            object)
                      (inst extqh temp temp1 temp)
                      (inst sra temp 56 value))
                                                (* index ,scale)) ,lowtag))
                            object)
                      (inst extqh temp temp1 temp)
                      (inst sra temp 56 value))

-                   `((inst ldq_u temp (- (+ (* ,offset word-bytes)
+                   `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)

                                             (* index ,scale)) ,lowtag)
                            object)
                                             (* index ,scale)) ,lowtag)
                            object)

-                     (inst lda temp1 (- (+ (* ,offset word-bytes)
+                     (inst lda temp1 (- (+ (* ,offset n-word-bytes)

                                            (* index ,scale)) ,lowtag)
                            object)
                      (inst extbl temp temp1 value))))
               (:short
                (if signed
                                            (* index ,scale)) ,lowtag)
                            object)
                      (inst extbl temp temp1 value))))
               (:short
                (if signed

-                   `((inst ldq_u temp (- (+ (* ,offset word-bytes)
+                   `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)

                                             (* index ,scale)) ,lowtag)
                            object)
                                             (* index ,scale)) ,lowtag)
                            object)

-                     (inst lda temp1 (- (+ (* ,offset word-bytes)
+                     (inst lda temp1 (- (+ (* ,offset n-word-bytes)

                                            (* index ,scale)) ,lowtag)
                            object)
                      (inst extwl temp temp1 temp)
                      (inst sll temp 48 temp)
                      (inst sra temp 48 value))
                                            (* index ,scale)) ,lowtag)
                            object)
                      (inst extwl temp temp1 temp)
                      (inst sll temp 48 temp)
                      (inst sra temp 48 value))

-                   `((inst ldq_u temp (- (+ (* ,offset word-bytes)
+                   `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)

                                             (* index ,scale)) ,lowtag)
                            object)
                                             (* index ,scale)) ,lowtag)
                            object)

-                     (inst lda temp1 (- (+ (* ,offset word-bytes)
+                     (inst lda temp1 (- (+ (* ,offset n-word-bytes)

                                            (* index ,scale)) ,lowtag)
                            object)
                      (inst extwl temp temp1 value))))))))))
                                            (* index ,scale)) ,lowtag)
                            object)
                      (inst extwl temp temp1 value))))))))))

@@ -489,19 +441,19 @@
               '((inst addq lip index lip)))
           ,@(ecase size
               (:byte
               '((inst addq lip index lip)))
           ,@(ecase size
               (:byte

-               `((inst lda temp (- (* ,offset word-bytes) ,lowtag) lip)
-                 (inst ldq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip)
+               `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
+                 (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)

                  (inst insbl value  temp temp2)
                  (inst mskbl temp1 temp temp1)
                  (inst bis temp1 temp2 temp1)
                  (inst insbl value  temp temp2)
                  (inst mskbl temp1 temp temp1)
                  (inst bis temp1 temp2 temp1)

-                 (inst stq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip)))
+                 (inst stq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)))

               (:short
               (:short

-               `((inst lda temp (- (* ,offset word-bytes) ,lowtag) lip)
-                 (inst ldq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip)
+               `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
+                 (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)

                  (inst mskwl temp1 temp temp1)
                  (inst inswl value temp temp2)
                  (inst bis temp1 temp2 temp)
                  (inst mskwl temp1 temp temp1)
                  (inst inswl value temp temp2)
                  (inst bis temp1 temp2 temp)

-                 (inst stq_u temp (- (* ,offset word-bytes) ,lowtag) lip))))
+                 (inst stq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip))))

           (move value result)))
        (define-vop (,(symbolicate name "-C"))
         ,@(when translate
           (move value result)))
        (define-vop (,(symbolicate name "-C"))
         ,@(when translate

@@ -520,30 +472,45 @@
         (:temporary (:sc non-descriptor-reg) temp2)
         (:results (result :scs ,scs))
         (:result-types ,el-type)
         (:temporary (:sc non-descriptor-reg) temp2)
         (:results (result :scs ,scs))
         (:result-types ,el-type)

-        (:generator 5
+        (:generator 4

           ,@(ecase size
               (:byte
           ,@(ecase size
               (:byte

-               `((inst lda temp (- (* ,offset word-bytes)
-                                   (* index ,scale) ,lowtag)
+               `((inst lda temp (- (+ (* ,offset n-word-bytes)
+                                      (* index ,scale))
+                                   ,lowtag)

                        object)
                        object)

-                 (inst ldq_u temp1 (- (* ,offset word-bytes) 
-                                      (* index ,scale) ,lowtag)
+                 (inst ldq_u temp1 (- (+ (* ,offset n-word-bytes) 
+                                         (* index ,scale))
+                                      ,lowtag)

                        object)
                  (inst insbl value temp temp2)
                  (inst mskbl temp1 temp temp1)
                  (inst bis temp1 temp2 temp1)
                        object)
                  (inst insbl value temp temp2)
                  (inst mskbl temp1 temp temp1)
                  (inst bis temp1 temp2 temp1)

-                 (inst stq_u temp1 (- (* ,offset word-bytes)
-                                      (* index ,scale) ,lowtag) object)))
+                 (inst stq_u temp1 (- (+ (* ,offset n-word-bytes)
+                                         (* index ,scale))
+                                      ,lowtag) object)))

               (:short
               (:short

-               `((inst lda temp (- (* ,offset word-bytes)
-                                   (* index ,scale) ,lowtag)
+               `((inst lda temp (- (+ (* ,offset n-word-bytes)
+                                      (* index ,scale))
+                                   ,lowtag)

                        object)
                        object)

-                 (inst ldq_u temp1 (- (* ,offset word-bytes)
-                                      (* index ,scale) ,lowtag)
+                 (inst ldq_u temp1 (- (+ (* ,offset n-word-bytes)
+                                         (* index ,scale))
+                                      ,lowtag)

                        object)
                  (inst mskwl temp1 temp temp1)
                  (inst inswl value temp temp2)
                  (inst bis temp1 temp2 temp)
                        object)
                  (inst mskwl temp1 temp temp1)
                  (inst inswl value temp temp2)
                  (inst bis temp1 temp2 temp)

-                 (inst stq_u temp (- (* ,offset word-bytes)
-                                     (* index ,scale) ,lowtag) object))))
+                 (inst stq_u temp (- (+ (* ,offset n-word-bytes)
+                                        (* index ,scale))
+                                     ,lowtag) object))))

           (move value result))))))
           (move value result))))))

+
+(defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
+  "Arrange with the garbage collector that the pages occupied by
+OBJECTS will not be moved in memory for the duration of BODY.
+Useful for e.g. foreign calls where another thread may trigger
+garbage collection.  This is currently implemented by disabling GC"
+  (declare (ignore objects))           ;should we eval these for side-effect?
+  `(without-gcing
+    ,@body))