X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Froom.lisp;h=fdebda6e5d2f73e1906486397160b6421d65bace;hb=d4c7ab04ed10729a2cfa3321f4382d8a218ad958;hp=90a7ecee5f6a619cafcbbc4353068e01e18e58d4;hpb=e0814eee6f6dea52db010b45a330100f2fe65832;p=sbcl.git diff --git a/src/code/room.lisp b/src/code/room.lisp index 90a7ece..fdebda6 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -32,10 +32,32 @@ (let ((widetag (primitive-object-widetag obj)) (lowtag (primitive-object-lowtag obj)) (name (primitive-object-name obj)) - (variable (primitive-object-var-length obj)) + (variable (primitive-object-variable-length-p obj)) (size (primitive-object-size obj))) (cond ((not lowtag)) + (;; KLUDGE described in dan_b message "Another one for the + ;; collection [bug 108]" (sbcl-devel 2004-01-22) + ;; + ;; In a freshly started SBCL 0.8.7.20ish, (TIME (ROOM T)) causes + ;; debugger invoked on a SB-INT:BUG in thread 5911: + ;; failed AVER: "(SAP= CURRENT END)" + ;; [WHN: Similar things happened on one but not the other of my + ;; machines when I just run ROOM a lot in a loop.] + ;; + ;; This appears to be due to my [DB] abuse of the primitive + ;; object macros to define a thread object that shares a lowtag + ;; with fixnums and has no widetag: it looks like the code that + ;; generates *META-ROOM-INFO* infers from this that even fixnums + ;; are thread-sized - probably undesirable. + ;; + ;; This [the fix; the EQL NAME 'THREAD clause here] is more in the + ;; nature of a workaround than a really good fix. I'm not sure + ;; what a really good fix is: I /think/ it's probably to remove + ;; the :LOWTAG option in DEFINE-PRIMITIVE-OBJECT THREAD, then teach + ;; genesis to generate the necessary OBJECT_SLOT_OFFSET macros + ;; for assembly source in the runtime/genesis/*.h files. + (eql name 'thread)) ((not widetag) (let ((info (make-room-info :name name :kind :lowtag)) @@ -50,9 +72,9 @@ :kind :fixed :length size)))))) -(dolist (code (list complex-string-widetag simple-array-widetag +(dolist (code (list complex-base-string-widetag simple-array-widetag complex-bit-vector-widetag complex-vector-widetag - complex-array-widetag)) + complex-array-widetag complex-vector-nil-widetag)) (setf (svref *meta-room-info* code) (make-room-info :name 'array-header :kind :header))) @@ -69,29 +91,42 @@ (simple-vector-widetag . 2) (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-8-widetag . 0) + (simple-array-unsigned-byte-15-widetag . 1) (simple-array-unsigned-byte-16-widetag . 1) + (simple-array-unsigned-byte-31-widetag . 2) (simple-array-unsigned-byte-32-widetag . 2) (simple-array-signed-byte-8-widetag . 0) (simple-array-signed-byte-16-widetag . 1) + (simple-array-unsigned-byte-29-widetag . 2) (simple-array-signed-byte-30-widetag . 2) (simple-array-signed-byte-32-widetag . 2) (simple-array-single-float-widetag . 2) (simple-array-double-float-widetag . 3) (simple-array-complex-single-float-widetag . 3) (simple-array-complex-double-float-widetag . 4))) - (let ((name (car stuff)) - (size (cdr stuff))) + (let* ((name (car stuff)) + (size (cdr stuff)) + (sname (string name))) (setf (svref *meta-room-info* (symbol-value name)) - (make-room-info :name name + (make-room-info :name (intern (subseq sname + 0 + (mismatch sname "-WIDETAG" + :from-end t))) :kind :vector :length size)))) -(setf (svref *meta-room-info* simple-string-widetag) - (make-room-info :name 'simple-string-widetag +(setf (svref *meta-room-info* simple-base-string-widetag) + (make-room-info :name 'simple-base-string :kind :string :length 0)) +(setf (svref *meta-room-info* simple-array-nil-widetag) + (make-room-info :name 'simple-array-nil + :kind :fixed + :length 2)) + (setf (svref *meta-room-info* code-header-widetag) (make-room-info :name 'code :kind :code)) @@ -100,7 +135,7 @@ (make-room-info :name 'instance :kind :instance)) -); eval-when (compile eval) +) ; EVAL-WHEN (defparameter *room-info* '#.*meta-room-info*) (deftype spaces () '(member :static :dynamic :read-only)) @@ -123,7 +158,8 @@ (values (int-sap read-only-space-start) (int-sap (* *read-only-space-free-pointer* n-word-bytes)))) (:dynamic - (values (int-sap dynamic-space-start) + (values (int-sap #!+gencgc dynamic-space-start + #!-gencgc (current-dynamic-space-start)) (dynamic-space-free-pointer))))) ;;; Return the total number of bytes used in SPACE. @@ -211,7 +247,8 @@ (:fixed (aver (or (eql (room-info-length info) (1+ (get-header-data obj))) - (floatp obj))) + (floatp obj) + (simple-array-nil-p obj))) (round-to-dualword (* (room-info-length info) n-word-bytes))) ((:vector :string) @@ -429,7 +466,8 @@ ((#.bignum-widetag #.single-float-widetag #.double-float-widetag - #.simple-string-widetag + #.simple-base-string-widetag + #.simple-array-nil-widetag #.simple-bit-vector-widetag #.simple-array-unsigned-byte-2-widetag #.simple-array-unsigned-byte-4-widetag @@ -452,7 +490,8 @@ #.complex-widetag #.simple-array-widetag #.simple-vector-widetag - #.complex-string-widetag + #.complex-base-string-widetag + #.complex-vector-nil-widetag #.complex-bit-vector-widetag #.complex-vector-widetag #.complex-array-widetag @@ -489,19 +528,19 @@ (when (eql type instance-header-widetag) (incf total-objects) (incf total-bytes size) - (let* ((class (layout-class (%instance-ref obj 0))) - (found (gethash class totals))) + (let* ((classoid (layout-classoid (%instance-ref obj 0))) + (found (gethash classoid totals))) (cond (found (incf (the fixnum (car found))) (incf (the fixnum (cdr found)) size)) (t - (setf (gethash class totals) (cons 1 size))))))) + (setf (gethash classoid totals) (cons 1 size))))))) space) (collect ((totals-list)) - (maphash (lambda (class what) + (maphash (lambda (classoid what) (totals-list (cons (prin1-to-string - (class-proper-name class)) + (classoid-proper-name classoid)) what))) totals) (let ((sorted (sort (totals-list) #'> :key #'cddr)) @@ -529,32 +568,6 @@ (values)) -(defun find-holes (&rest spaces) - (dolist (space (or spaces '(:read-only :static :dynamic))) - (format t "In ~A space:~%" space) - (let ((start-addr nil) - (total-bytes 0)) - (declare (type (or null (unsigned-byte 32)) start-addr) - (type (unsigned-byte 32) total-bytes)) - (map-allocated-objects - (lambda (object typecode bytes) - (declare (ignore typecode) - (type (unsigned-byte 32) bytes)) - (if (and (consp object) - (eql (car object) 0) - (eql (cdr object) 0)) - (if start-addr - (incf total-bytes bytes) - (setf start-addr (sb!di::get-lisp-obj-address object) - total-bytes bytes)) - (when start-addr - (format t "~:D bytes at #X~X~%" total-bytes start-addr) - (setf start-addr nil)))) - space) - (when start-addr - (format t "~:D bytes at #X~X~%" total-bytes start-addr)))) - (values)) - ;;;; PRINT-ALLOCATED-OBJECTS (defun print-allocated-objects (space &key (percent 0) (pages 5)