0.8.13.19:

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

diff --git a/src/compiler/alpha/macros.lisp b/src/compiler/alpha/macros.lisp
index 958e05a..a251501 100644 (file)
--- a/src/compiler/alpha/macros.lisp
+++ b/src/compiler/alpha/macros.lisp
@@ -87,8 +87,8 @@
 (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:simple-fun-code-offset sb!vm:word-shift)
-                      sb!vm:fun-pointer-lowtag)
+     (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)))

@@ -176,21 +176,6 @@
      ,@body))
 \f
 ;;;; error code
      ,@body))
 \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*))))
-

 (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)))

@@ -200,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))

@@ -239,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*)

@@ -250,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 n-word-bytes)
-                            (- lowtag))
-                         scale))
-           ,(truncate (- (+ (1- (ash 1 16)) lowtag)
-                         (* max-offset n-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)

@@ -309,7 +280,7 @@
             '((inst mskll value 4 value)))))))
 
 (defmacro define-full-setter (name type offset lowtag scs el-type
             '((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

@@ -408,7 +379,7 @@
         (: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

@@ -501,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 n-word-bytes)
-                                   (* index ,scale) ,lowtag)
+               `((inst lda temp (- (+ (* ,offset n-word-bytes)
+                                      (* index ,scale))
+                                   ,lowtag)

                        object)
                        object)

-                 (inst ldq_u temp1 (- (* ,offset n-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 n-word-bytes)
-                                      (* index ,scale) ,lowtag) object)))
+                 (inst stq_u temp1 (- (+ (* ,offset n-word-bytes)
+                                         (* index ,scale))
+                                      ,lowtag) object)))

               (:short
               (:short

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

                        object)
                        object)

-                 (inst ldq_u temp1 (- (* ,offset n-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 n-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))