1.0.12.33: Have foreign.test.sh create .so files under the test directory

[sbcl.git] / src / code / room.lisp

diff --git a/src/code/room.lisp b/src/code/room.lisp
index c957c8d..d181336 100644 (file)
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -88,8 +88,10 @@
       (make-room-info :name 'closure
                       :kind :closure))
 
       (make-room-info :name 'closure
                       :kind :closure))
 

+;; FIXME: This looks rather brittle. Can we get more of these numbers
+;; from somewhere sensible?

 (dolist (stuff '((simple-bit-vector-widetag . -3)
 (dolist (stuff '((simple-bit-vector-widetag . -3)

-                 (simple-vector-widetag . 2)
+                 (simple-vector-widetag . #.sb!vm:word-shift)

                  (simple-array-unsigned-byte-2-widetag . -2)
                  (simple-array-unsigned-byte-4-widetag . -1)
                  (simple-array-unsigned-byte-7-widetag . 0)
                  (simple-array-unsigned-byte-2-widetag . -2)
                  (simple-array-unsigned-byte-4-widetag . -1)
                  (simple-array-unsigned-byte-7-widetag . 0)

@@ -179,11 +181,12 @@
   (multiple-value-bind (start end) (space-bounds space)
     (- (sap-int end) (sap-int start))))
 
   (multiple-value-bind (start end) (space-bounds space)
     (- (sap-int end) (sap-int start))))
 

-;;; Round SIZE (in bytes) up to the next dualword (eight byte) boundary.
+;;; Round SIZE (in bytes) up to the next dualword boundary. A dualword
+;;; is eight bytes on platforms with 32-bit word size and 16 bytes on
+;;; platforms with 64-bit word size.

 #!-sb-fluid (declaim (inline round-to-dualword))
 (defun round-to-dualword (size)
 #!-sb-fluid (declaim (inline round-to-dualword))
 (defun round-to-dualword (size)

-  (declare (fixnum size))
-  (logand (the fixnum (+ size lowtag-mask)) (lognot lowtag-mask)))
+  (logand (the word (+ size lowtag-mask)) (lognot lowtag-mask)))

 
 ;;; Return the total size of a vector in bytes, including any pad.
 #!-sb-fluid (declaim (inline vector-total-size))
 
 ;;; Return the total size of a vector in bytes, including any pad.
 #!-sb-fluid (declaim (inline vector-total-size))

@@ -193,34 +196,33 @@
                 (ecase (room-info-kind info)
                   (:vector 0)
                   (:string 1)))))
                 (ecase (room-info-kind info)
                   (:vector 0)
                   (:string 1)))))

-    (declare (type (integer -3 3) shift))

     (round-to-dualword
      (+ (* vector-data-offset n-word-bytes)
     (round-to-dualword
      (+ (* vector-data-offset n-word-bytes)

-        (the fixnum
-             (if (minusp shift)
-                 (ash (the fixnum
-                           (+ len (the fixnum
-                                       (1- (the fixnum (ash 1 (- shift)))))))
-                      shift)
-                 (ash len shift)))))))
+        (if (minusp shift)
+            (ash (+ len (1- (ash 1 (- shift))))
+                 shift)
+            (ash len shift))))))

 
 ;;; Access to the GENCGC page table for better precision in
 ;;; MAP-ALLOCATED-OBJECTS
 #!+gencgc
 (progn
 
 ;;; Access to the GENCGC page table for better precision in
 ;;; MAP-ALLOCATED-OBJECTS
 #!+gencgc
 (progn

-  (define-alien-type nil
+  (define-alien-type (struct page)

       (struct page
       (struct page

-              (flags unsigned-int)
-              (gen int)
-              (bytes-used int)
-              (start long)))
+              (start long)
+              ;; On platforms with small enough GC pages, this field
+              ;; will be a short. On platforms with larger ones, it'll
+              ;; be an int.
+              (bytes-used (unsigned
+                           #.(if (typep sb!vm:gencgc-page-size
+                                        '(unsigned-byte 16))
+                                 16
+                                 32)))
+              (flags (unsigned 8))
+              (gen (signed 8))))

   (declaim (inline find-page-index))
   (define-alien-routine "find_page_index" long (index long))
   (declaim (inline find-page-index))
   (define-alien-routine "find_page_index" long (index long))

-  (define-alien-variable "page_table"
-      (array (struct page)
-             #.(truncate (- dynamic-space-end
-                            dynamic-space-start)
-                         sb!vm:gencgc-page-size))))
+  (define-alien-variable "page_table" (* (struct page))))

 
 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
 ;;; the object, the object's type code, and the object's total size in
 
 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
 ;;; the object, the object's type code, and the object's total size in

@@ -231,9 +233,9 @@
   (without-gcing
    (multiple-value-bind (start end) (space-bounds space)
      (declare (type system-area-pointer start end))
   (without-gcing
    (multiple-value-bind (start end) (space-bounds space)
      (declare (type system-area-pointer start end))

-     (declare (optimize (speed 3) (safety 0)))
+     (declare (optimize (speed 3)))

      (let ((current start)
      (let ((current start)

-           (skip-tests-until-addr 0))
+           #!+gencgc (skip-tests-until-addr 0))

        (labels ((maybe-finish-mapping ()
                   (unless (sap< current end)
                     (aver (sap= current end))
        (labels ((maybe-finish-mapping ()
                   (unless (sap< current end)
                     (aver (sap= current end))

@@ -265,7 +267,7 @@
                             ;; bitfields?
                             (let ((alloc-flag (ldb (byte 3 2)
                                                    (slot page 'flags)))
                             ;; bitfields?
                             (let ((alloc-flag (ldb (byte 3 2)
                                                    (slot page 'flags)))

-                                   (bytes-used (slot page 'bytes-used)))
+                                  (bytes-used (slot page 'bytes-used)))

                               ;; If the page is not free and the current
                               ;; pointer is still below the allocation offset
                               ;; of the page
                               ;; If the page is not free and the current
                               ;; pointer is still below the allocation offset
                               ;; of the page

@@ -275,8 +277,7 @@
                                 ;; Don't bother testing again until we
                                 ;; get past that allocation offset
                                 (setf skip-tests-until-addr
                                 ;; Don't bother testing again until we
                                 ;; get past that allocation offset
                                 (setf skip-tests-until-addr

-                                      (+ (logandc2 addr page-mask)
-                                         (the fixnum bytes-used)))
+                                      (+ (logandc2 addr page-mask) bytes-used))

                                 ;; And then continue with the scheduled
                                 ;; mapping
                                 (return-from maybe-skip-page))
                                 ;; And then continue with the scheduled
                                 ;; mapping
                                 (return-from maybe-skip-page))

@@ -296,13 +297,13 @@
                     (eq (room-info-kind info) :lowtag))
                 (let ((size (* cons-size n-word-bytes)))
                   (funcall fun
                     (eq (room-info-kind info) :lowtag))
                 (let ((size (* cons-size n-word-bytes)))
                   (funcall fun

-                           (make-lisp-obj (logior (sap-int current)
+                           (%make-lisp-obj (logior (sap-int current)

                                                   list-pointer-lowtag))
                            list-pointer-lowtag
                            size)
                   (setq current (sap+ current size))))
                ((eql header-widetag closure-header-widetag)
                                                   list-pointer-lowtag))
                            list-pointer-lowtag
                            size)
                   (setq current (sap+ current size))))
                ((eql header-widetag closure-header-widetag)

-                (let* ((obj (make-lisp-obj (logior (sap-int current)
+                (let* ((obj (%make-lisp-obj (logior (sap-int current)

                                                    fun-pointer-lowtag)))
                        (size (round-to-dualword
                               (* (the fixnum (1+ (get-closure-length obj)))
                                                    fun-pointer-lowtag)))
                        (size (round-to-dualword
                               (* (the fixnum (1+ (get-closure-length obj)))

@@ -310,7 +311,7 @@
                   (funcall fun obj header-widetag size)
                   (setq current (sap+ current size))))
                ((eq (room-info-kind info) :instance)
                   (funcall fun obj header-widetag size)
                   (setq current (sap+ current size))))
                ((eq (room-info-kind info) :instance)

-                (let* ((obj (make-lisp-obj
+                (let* ((obj (%make-lisp-obj

                              (logior (sap-int current) instance-pointer-lowtag)))
                        (size (round-to-dualword
                               (* (+ (%instance-length obj) 1) n-word-bytes))))
                              (logior (sap-int current) instance-pointer-lowtag)))
                        (size (round-to-dualword
                               (* (+ (%instance-length obj) 1) n-word-bytes))))

@@ -319,7 +320,7 @@
                   (aver (zerop (logand size lowtag-mask)))
                   (setq current (sap+ current size))))
                (t
                   (aver (zerop (logand size lowtag-mask)))
                   (setq current (sap+ current size))))
                (t

-                (let* ((obj (make-lisp-obj
+                (let* ((obj (%make-lisp-obj

                              (logior (sap-int current) other-pointer-lowtag)))
                        (size (ecase (room-info-kind info)
                                (:fixed
                              (logior (sap-int current) other-pointer-lowtag)))
                        (size (ecase (room-info-kind info)
                                (:fixed

@@ -340,10 +341,14 @@
                                    (round-to-dualword
                                     (* (the fixnum (%code-code-size obj))
                                        n-word-bytes)))))))
                                    (round-to-dualword
                                     (* (the fixnum (%code-code-size obj))
                                        n-word-bytes)))))))

-                  (declare (fixnum size))

                   (funcall fun obj header-widetag size)
                   (funcall fun obj header-widetag size)

-                  (aver (zerop (logand size lowtag-mask)))
-                  (setq current (sap+ current size))))))))))))
+                  (macrolet ((frob ()
+                               `(progn
+                                  (aver (zerop (logand size lowtag-mask)))
+                                  (setq current (sap+ current size)))))
+                    (etypecase size
+                      (fixnum (frob))
+                      (word (frob))))))))))))))

 
 \f
 ;;;; MEMORY-USAGE
 
 \f
 ;;;; MEMORY-USAGE

@@ -351,11 +356,11 @@
 ;;; Return a list of 3-lists (bytes object type-name) for the objects
 ;;; allocated in Space.
 (defun type-breakdown (space)
 ;;; Return a list of 3-lists (bytes object type-name) for the objects
 ;;; allocated in Space.
 (defun type-breakdown (space)

-  (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum))
-        (counts (make-array 256 :initial-element 0 :element-type 'fixnum)))
+  (let ((sizes (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits)))
+        (counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits))))

     (map-allocated-objects
      (lambda (obj type size)
     (map-allocated-objects
      (lambda (obj type size)

-       (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj))
+       (declare (word size) (optimize (speed 3)) (ignore obj))

        (incf (aref sizes type) size)
        (incf (aref counts type)))
      space)
        (incf (aref sizes type) size)
        (incf (aref counts type)))
      space)

@@ -395,7 +400,7 @@
       (maphash (lambda (k v)
                  (declare (ignore k))
                  (let ((sum 0))
       (maphash (lambda (k v)
                  (declare (ignore k))
                  (let ((sum 0))

-                   (declare (fixnum sum))
+                   (declare (unsigned-byte sum))

                    (dolist (space-total v)
                      (incf sum (first (cdr space-total))))
                    (summary-totals (cons sum v))))
                    (dolist (space-total v)
                      (incf sum (first (cdr space-total))))
                    (summary-totals (cons sum v))))

@@ -404,13 +409,13 @@
       (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
       (let ((summary-total-bytes 0)
             (summary-total-objects 0))
       (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
       (let ((summary-total-bytes 0)
             (summary-total-objects 0))

-        (declare (fixnum summary-total-bytes summary-total-objects))
+        (declare (unsigned-byte summary-total-bytes summary-total-objects))

         (dolist (space-totals
                  (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
           (let ((total-objects 0)
                 (total-bytes 0)
                 name)
         (dolist (space-totals
                  (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
           (let ((total-objects 0)
                 (total-bytes 0)
                 name)

-            (declare (fixnum total-objects total-bytes))
+            (declare (unsigned-byte total-objects total-bytes))

             (collect ((spaces))
               (dolist (space-total space-totals)
                 (let ((total (cdr space-total)))
             (collect ((spaces))
               (dolist (space-total space-totals)
                 (let ((total (cdr space-total)))

@@ -442,8 +447,8 @@
                            0))
          (reported-bytes 0)
          (reported-objects 0))
                            0))
          (reported-bytes 0)
          (reported-objects 0))

-    (declare (fixnum total-objects total-bytes cutoff-point reported-objects
-                     reported-bytes))
+    (declare (unsigned-byte total-objects total-bytes cutoff-point reported-objects
+                            reported-bytes))

     (loop for (bytes objects name) in types do
       (when (<= bytes cutoff-point)
         (format t "  ~10:D bytes for ~9:D other object~2:*~P.~%"
     (loop for (bytes objects name) in types do
       (when (<= bytes cutoff-point)
         (format t "  ~10:D bytes for ~9:D other object~2:*~P.~%"

@@ -494,12 +499,13 @@
              (type unsigned-byte total-bytes))
     (map-allocated-objects
      (lambda (obj type size)
              (type unsigned-byte total-bytes))
     (map-allocated-objects
      (lambda (obj type size)

-       (declare (fixnum size) (optimize (safety 0)))

        (when (eql type code-header-widetag)
        (when (eql type code-header-widetag)

-         (incf total-bytes size)

          (let ((words (truly-the fixnum (%code-code-size obj)))
                (sap (truly-the system-area-pointer
          (let ((words (truly-the fixnum (%code-code-size obj)))
                (sap (truly-the system-area-pointer

-                               (%primitive code-instructions obj))))
+                               (%primitive code-instructions obj)))
+               (size size))
+           (declare (fixnum size))
+           (incf total-bytes size)

            (incf code-words words)
            (dotimes (i words)
              (when (zerop (sap-ref-word sap (* i n-word-bytes)))
            (incf code-words words)
            (dotimes (i words)
              (when (zerop (sap-ref-word sap (* i n-word-bytes)))

@@ -523,11 +529,11 @@
       (declare (inline map-allocated-objects))
       (map-allocated-objects
        (lambda (obj type size)
       (declare (inline map-allocated-objects))
       (map-allocated-objects
        (lambda (obj type size)

-         (declare (fixnum size) (optimize (safety 0)))

          (case type
            (#.code-header-widetag
          (case type
            (#.code-header-widetag

-            (let ((inst-words (truly-the fixnum (%code-code-size obj))))
-              (declare (type fixnum inst-words))
+            (let ((inst-words (truly-the fixnum (%code-code-size obj)))
+                  (size size))
+              (declare (type fixnum size inst-words))

               (incf non-descriptor-bytes (* inst-words n-word-bytes))
               (incf descriptor-words
                     (- (truncate size n-word-bytes) inst-words))))
               (incf non-descriptor-bytes (* inst-words n-word-bytes))
               (incf descriptor-words
                     (- (truncate size n-word-bytes) inst-words))))

@@ -545,7 +551,7 @@
              #.simple-array-unsigned-byte-32-widetag
              #.simple-array-signed-byte-8-widetag
              #.simple-array-signed-byte-16-widetag
              #.simple-array-unsigned-byte-32-widetag
              #.simple-array-signed-byte-8-widetag
              #.simple-array-signed-byte-16-widetag

-             ; #.simple-array-signed-byte-30-widetag
+             ;; #.simple-array-signed-byte-30-widetag

              #.simple-array-signed-byte-32-widetag
              #.simple-array-single-float-widetag
              #.simple-array-double-float-widetag
              #.simple-array-signed-byte-32-widetag
              #.simple-array-single-float-widetag
              #.simple-array-double-float-widetag

@@ -571,7 +577,7 @@
              #.sap-widetag
              #.weak-pointer-widetag
              #.instance-header-widetag)
              #.sap-widetag
              #.weak-pointer-widetag
              #.instance-header-widetag)

-            (incf descriptor-words (truncate size n-word-bytes)))
+            (incf descriptor-words (truncate (the fixnum size) n-word-bytes)))

            (t
             (error "bogus widetag: ~W" type))))
        space))
            (t
             (error "bogus widetag: ~W" type))))
        space))

@@ -590,15 +596,17 @@
   (let ((totals (make-hash-table :test 'eq))
         (total-objects 0)
         (total-bytes 0))
   (let ((totals (make-hash-table :test 'eq))
         (total-objects 0)
         (total-bytes 0))

-    (declare (fixnum total-objects total-bytes))
+    (declare (unsigned-byte total-objects total-bytes))

     (map-allocated-objects
      (lambda (obj type size)
     (map-allocated-objects
      (lambda (obj type size)

-       (declare (fixnum size) (optimize (speed 3) (safety 0)))
+       (declare (optimize (speed 3)))

        (when (eql type instance-header-widetag)
          (incf total-objects)
        (when (eql type instance-header-widetag)
          (incf total-objects)

-         (incf total-bytes size)

          (let* ((classoid (layout-classoid (%instance-ref obj 0)))
          (let* ((classoid (layout-classoid (%instance-ref obj 0)))

-                (found (gethash classoid totals)))
+                (found (gethash classoid totals))
+                (size size))
+           (declare (fixnum size))
+           (incf total-bytes size)

            (cond (found
                   (incf (the fixnum (car found)))
                   (incf (the fixnum (cdr found)) size))
            (cond (found
                   (incf (the fixnum (car found)))
                   (incf (the fixnum (cdr found)) size))

@@ -615,7 +623,7 @@
       (let ((sorted (sort (totals-list) #'> :key #'cddr))
             (printed-bytes 0)
             (printed-objects 0))
       (let ((sorted (sort (totals-list) #'> :key #'cddr))
             (printed-bytes 0)
             (printed-objects 0))

-        (declare (fixnum printed-bytes printed-objects))
+        (declare (unsigned-byte printed-bytes printed-objects))

         (dolist (what (if top-n
                           (subseq sorted 0 (min (length sorted) top-n))
                           sorted))
         (dolist (what (if top-n
                           (subseq sorted 0 (min (length sorted) top-n))
                           sorted))

@@ -664,7 +672,6 @@
                    (note-conses (cdr x)))))
         (map-allocated-objects
          (lambda (obj obj-type size)
                    (note-conses (cdr x)))))
         (map-allocated-objects
          (lambda (obj obj-type size)

-           (declare (optimize (safety 0)))

            (let ((addr (get-lisp-obj-address obj)))
              (when (>= addr start)
                (when (if count
            (let ((addr (get-lisp-obj-address obj)))
              (when (>= addr start)
                (when (if count

@@ -745,7 +752,6 @@
     (let ((res ()))
       (map-allocated-objects
        (lambda (obj obj-type size)
     (let ((res ()))
       (map-allocated-objects
        (lambda (obj obj-type size)

-         (declare (optimize (safety 0)))

          (when (and (or (not type) (eql obj-type type))
                     (or (not smaller) (<= size smaller))
                     (or (not larger) (>= size larger))
          (when (and (or (not type) (eql obj-type type))
                     (or (not smaller) (<= size smaller))
                     (or (not larger) (>= size larger))

@@ -765,7 +771,7 @@
              (funcall fun obj))))
     (map-allocated-objects
      (lambda (obj obj-type size)
              (funcall fun obj))))
     (map-allocated-objects
      (lambda (obj obj-type size)

-       (declare (optimize (safety 0)) (ignore obj-type size))
+       (declare (ignore obj-type size))

        (typecase obj
          (cons
           (when (or (eq (car obj) object)
        (typecase obj
          (cons
           (when (or (eq (car obj) object)

@@ -792,7 +798,8 @@
           (when (or (eq (symbol-name obj) object)
                     (eq (symbol-package obj) object)
                     (eq (symbol-plist obj) object)
           (when (or (eq (symbol-name obj) object)
                     (eq (symbol-package obj) object)
                     (eq (symbol-plist obj) object)

-                    (eq (symbol-value obj) object))
+                    (and (boundp obj)
+                         (eq (symbol-value obj) object)))

             (maybe-call fun obj)))))
      space)))
 
             (maybe-call fun obj)))))
      space)))