X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Froom.lisp;h=c108cc0895cfe2a975bdc791fc0489edbc3ba6b1;hb=545fa4548b327804cf78afe38a2ecd94ced86162;hp=17c2ceca52216bbc4196e6056c66f529b34b7ad7;hpb=d147d512602d761a2dcdfded506dd1a8f9a140dc;p=sbcl.git diff --git a/src/code/room.lisp b/src/code/room.lisp index 17c2cec..c108cc0 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -21,7 +21,7 @@ (kind (required-argument) :type (member :lowtag :fixed :header :vector :string :code :closure :instance)) - ;; Length if fixed-length, shift amount for element size if :vector. + ;; Length if fixed-length, shift amount for element size if :VECTOR. (length nil :type (or fixnum null)))) (eval-when (:compile-toplevel :execute) @@ -29,14 +29,14 @@ (defvar *meta-room-info* (make-array 256 :initial-element nil)) (dolist (obj *primitive-objects*) - (let ((header (primitive-object-header obj)) + (let ((widetag (primitive-object-widetag obj)) (lowtag (primitive-object-lowtag obj)) (name (primitive-object-name obj)) (variable (primitive-object-variable-length obj)) (size (primitive-object-size obj))) (cond ((not lowtag)) - ((not header) + ((not widetag) (let ((info (make-room-info :name name :kind :lowtag)) (lowtag (symbol-value lowtag))) @@ -45,41 +45,41 @@ (setf (svref *meta-room-info* (logior lowtag (ash i 3))) info)))) (variable) (t - (setf (svref *meta-room-info* (symbol-value header)) + (setf (svref *meta-room-info* (symbol-value widetag)) (make-room-info :name name :kind :fixed :length size)))))) -(dolist (code (list complex-string-type simple-array-type - complex-bit-vector-type complex-vector-type - complex-array-type)) +(dolist (code (list complex-string-widetag simple-array-widetag + complex-bit-vector-widetag complex-vector-widetag + complex-array-widetag)) (setf (svref *meta-room-info* code) (make-room-info :name 'array-header :kind :header))) -(setf (svref *meta-room-info* bignum-type) +(setf (svref *meta-room-info* bignum-widetag) (make-room-info :name 'bignum :kind :header)) -(setf (svref *meta-room-info* closure-header-type) +(setf (svref *meta-room-info* closure-header-widetag) (make-room-info :name 'closure :kind :closure)) -(dolist (stuff '((simple-bit-vector-type . -3) - (simple-vector-type . 2) - (simple-array-unsigned-byte-2-type . -2) - (simple-array-unsigned-byte-4-type . -1) - (simple-array-unsigned-byte-8-type . 0) - (simple-array-unsigned-byte-16-type . 1) - (simple-array-unsigned-byte-32-type . 2) - (simple-array-signed-byte-8-type . 0) - (simple-array-signed-byte-16-type . 1) - (simple-array-signed-byte-30-type . 2) - (simple-array-signed-byte-32-type . 2) - (simple-array-single-float-type . 2) - (simple-array-double-float-type . 3) - (simple-array-complex-single-float-type . 3) - (simple-array-complex-double-float-type . 4))) +(dolist (stuff '((simple-bit-vector-widetag . -3) + (simple-vector-widetag . 2) + (simple-array-unsigned-byte-2-widetag . -2) + (simple-array-unsigned-byte-4-widetag . -1) + (simple-array-unsigned-byte-8-widetag . 0) + (simple-array-unsigned-byte-16-widetag . 1) + (simple-array-unsigned-byte-32-widetag . 2) + (simple-array-signed-byte-8-widetag . 0) + (simple-array-signed-byte-16-widetag . 1) + (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))) (setf (svref *meta-room-info* (symbol-value name)) @@ -87,16 +87,16 @@ :kind :vector :length size)))) -(setf (svref *meta-room-info* simple-string-type) - (make-room-info :name 'simple-string-type +(setf (svref *meta-room-info* simple-string-widetag) + (make-room-info :name 'simple-string-widetag :kind :string :length 0)) -(setf (svref *meta-room-info* code-header-type) +(setf (svref *meta-room-info* code-header-widetag) (make-room-info :name 'code :kind :code)) -(setf (svref *meta-room-info* instance-header-type) +(setf (svref *meta-room-info* instance-header-widetag) (make-room-info :name 'instance :kind :instance)) @@ -171,33 +171,33 @@ (prev nil)) (loop (let* ((header (sap-ref-32 current 0)) - (header-type (logand header #xFF)) - (info (svref *room-info* header-type))) + (header-widetag (logand header #xFF)) + (info (svref *room-info* header-widetag))) (cond ((or (not info) (eq (room-info-kind info) :lowtag)) (let ((size (* cons-size word-bytes))) (funcall fun (make-lisp-obj (logior (sap-int current) - list-pointer-type)) - list-pointer-type + list-pointer-lowtag)) + list-pointer-lowtag size) (setq current (sap+ current size)))) - ((eql header-type closure-header-type) + ((eql header-widetag closure-header-widetag) (let* ((obj (make-lisp-obj (logior (sap-int current) - function-pointer-type))) + fun-pointer-lowtag))) (size (round-to-dualword (* (the fixnum (1+ (get-closure-length obj))) word-bytes)))) - (funcall fun obj header-type size) + (funcall fun obj header-widetag size) (setq current (sap+ current size)))) ((eq (room-info-kind info) :instance) (let* ((obj (make-lisp-obj - (logior (sap-int current) instance-pointer-type))) + (logior (sap-int current) instance-pointer-lowtag))) (size (round-to-dualword (* (+ (%instance-length obj) 1) word-bytes)))) (declare (fixnum size)) - (funcall fun obj header-type size) + (funcall fun obj header-widetag size) (aver (zerop (logand size lowtag-mask))) #+nil (when (> size 200000) (break "implausible size, prev ~S" prev)) @@ -206,7 +206,7 @@ (setq current (sap+ current size)))) (t (let* ((obj (make-lisp-obj - (logior (sap-int current) other-pointer-type))) + (logior (sap-int current) other-pointer-lowtag))) (size (ecase (room-info-kind info) (:fixed (aver (or (eql (room-info-length info) @@ -226,7 +226,7 @@ (* (the fixnum (%code-code-size obj)) word-bytes))))))) (declare (fixnum size)) - (funcall fun obj header-type size) + (funcall fun obj header-widetag size) (aver (zerop (logand size lowtag-mask))) #+nil (when (> size 200000) @@ -352,16 +352,16 @@ (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%" total-bytes total-objects (car space-total)))) +;;; Print information about the heap memory in use. PRINT-SPACES is a +;;; list of the spaces to print detailed information for. +;;; COUNT-SPACES is a list of the spaces to scan. For either one, T +;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If +;;; PRINT-SUMMARY is true, then summary information will be printed. +;;; The defaults print only summary information for dynamic space. If +;;; true, CUTOFF is a fraction of the usage in a report below which +;;; types will be combined as OTHER. (defun memory-usage (&key print-spaces (count-spaces '(:dynamic)) (print-summary t) cutoff) - #!+sb-doc - "Print out information about the heap memory in use. :Print-Spaces is a list - of the spaces to print detailed information for. :Count-Spaces is a list of - the spaces to scan. For either one, T means all spaces (:Static, :Dyanmic - and :Read-Only.) If :Print-Summary is true, then summary information will be - printed. The defaults print only summary information for dynamic space. - If true, Cutoff is a fraction of the usage in a report below which types will - be combined as OTHER." (declare (type (or single-float null) cutoff)) (let* ((spaces (if (eq count-spaces t) '(:static :dynamic :read-only) @@ -379,9 +379,8 @@ (values)) +;;; Print info about how much code and no-ops there are in SPACE. (defun count-no-ops (space) - #!+sb-doc - "Print info about how much code and no-ops there are in Space." (declare (type spaces space)) (let ((code-words 0) (no-ops 0) @@ -391,7 +390,7 @@ (map-allocated-objects #'(lambda (obj type size) (declare (fixnum size) (optimize (safety 0))) - (when (eql type code-header-type) + (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 @@ -421,49 +420,49 @@ #'(lambda (obj type size) (declare (fixnum size) (optimize (safety 0))) (case type - (#.code-header-type + (#.code-header-widetag (let ((inst-words (truly-the fixnum (%code-code-size obj)))) (declare (type fixnum inst-words)) (incf non-descriptor-bytes (* inst-words word-bytes)) (incf descriptor-words (- (truncate size word-bytes) inst-words)))) - ((#.bignum-type - #.single-float-type - #.double-float-type - #.simple-string-type - #.simple-bit-vector-type - #.simple-array-unsigned-byte-2-type - #.simple-array-unsigned-byte-4-type - #.simple-array-unsigned-byte-8-type - #.simple-array-unsigned-byte-16-type - #.simple-array-unsigned-byte-32-type - #.simple-array-signed-byte-8-type - #.simple-array-signed-byte-16-type - #.simple-array-signed-byte-30-type - #.simple-array-signed-byte-32-type - #.simple-array-single-float-type - #.simple-array-double-float-type - #.simple-array-complex-single-float-type - #.simple-array-complex-double-float-type) + ((#.bignum-widetag + #.single-float-widetag + #.double-float-widetag + #.simple-string-widetag + #.simple-bit-vector-widetag + #.simple-array-unsigned-byte-2-widetag + #.simple-array-unsigned-byte-4-widetag + #.simple-array-unsigned-byte-8-widetag + #.simple-array-unsigned-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-32-widetag + #.simple-array-single-float-widetag + #.simple-array-double-float-widetag + #.simple-array-complex-single-float-widetag + #.simple-array-complex-double-float-widetag) (incf non-descriptor-headers) (incf non-descriptor-bytes (- size word-bytes))) - ((#.list-pointer-type - #.instance-pointer-type - #.ratio-type - #.complex-type - #.simple-array-type - #.simple-vector-type - #.complex-string-type - #.complex-bit-vector-type - #.complex-vector-type - #.complex-array-type - #.closure-header-type - #.funcallable-instance-header-type - #.value-cell-header-type - #.symbol-header-type - #.sap-type - #.weak-pointer-type - #.instance-header-type) + ((#.list-pointer-lowtag + #.instance-pointer-lowtag + #.ratio-widetag + #.complex-widetag + #.simple-array-widetag + #.simple-vector-widetag + #.complex-string-widetag + #.complex-bit-vector-widetag + #.complex-vector-widetag + #.complex-array-widetag + #.closure-header-widetag + #.funcallable-instance-header-widetag + #.value-cell-header-widetag + #.symbol-header-widetag + #.sap-widetag + #.weak-pointer-widetag + #.instance-header-widetag) (incf descriptor-words (truncate size word-bytes))) (t (error "Bogus type: ~D" type)))) @@ -474,12 +473,11 @@ non-descriptor-bytes non-descriptor-headers) (values))) +;;; Print a breakdown by instance type of all the instances allocated +;;; in SPACE. If TOP-N is true, print only information for the the +;;; TOP-N types with largest usage. (defun instance-usage (space &key (top-n 15)) (declare (type spaces space) (type (or fixnum null) top-n)) - #!+sb-doc - "Print a breakdown by instance type of all the instances allocated in - Space. If TOP-N is true, print only information for the the TOP-N types with - largest usage." (format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space) (let ((totals (make-hash-table :test 'eq)) (total-objects 0) @@ -488,7 +486,7 @@ (map-allocated-objects #'(lambda (obj type size) (declare (fixnum size) (optimize (speed 3) (safety 0))) - (when (eql type instance-header-type) + (when (eql type instance-header-widetag) (incf total-objects) (incf total-bytes size) (let* ((class (layout-class (%instance-ref obj 0))) @@ -523,7 +521,7 @@ (let ((residual-objects (- total-objects printed-objects)) (residual-bytes (- total-bytes printed-bytes))) (unless (zerop residual-objects) - (format t " Other types: ~:D bytes, ~D: object~:P.~%" + (format t " Other types: ~:D bytes, ~D object~:P.~%" residual-bytes residual-objects)))) (format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%" @@ -593,12 +591,15 @@ (return-from print-allocated-objects (values))) (unless count - (let ((this-page (* (the (unsigned-byte 32) - (truncate addr pagesize)) + (let ((this-page (* (the (values (unsigned-byte 32) t) + (truncate addr pagesize)) pagesize))) (declare (type (unsigned-byte 32) this-page)) (when (/= this-page last-page) (when (< pages-so-far pages) + ;; FIXME: What is this? (ERROR "Argh..")? or + ;; a warning? or code that can be removed + ;; once the system is stable? or what? (format stream "~2&**** Page ~D, address ~X:~%" pages-so-far addr)) (setq last-page this-page) @@ -609,15 +610,15 @@ (or (not larger) (>= size larger))) (incf count-so-far) (case type - (#.code-header-type + (#.code-header-widetag (let ((dinfo (%code-debug-info obj))) (format stream "~&Code object: ~S~%" (if dinfo (sb!c::compiled-debug-info-name dinfo) "No debug info.")))) - (#.symbol-header-type + (#.symbol-header-widetag (format stream "~&~S~%" obj)) - (#.list-pointer-type + (#.list-pointer-lowtag (unless (gethash obj printed-conses) (note-conses obj) (let ((*print-circle* t) @@ -628,7 +629,7 @@ (fresh-line stream) (let ((str (write-to-string obj :level 5 :length 10 :pretty nil))) - (unless (eql type instance-header-type) + (unless (eql type instance-header-widetag) (format stream "~S: " (type-of obj))) (format stream "~A~%" (subseq str 0 (min (length str) 60))))))))))