/[cmucl]/src/code/room.lisp
ViewVC logotype

Diff of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.8 by ram, Fri Apr 19 13:31:00 1991 UTC revision 1.9 by ram, Tue Apr 23 17:01:34 1991 UTC
# Line 551  Line 551 
551    (nth-value 1 (mach:vm_statistics system:*task-self*)))    (nth-value 1 (mach:vm_statistics system:*task-self*)))
552    
553  (defun print-allocated-objects (space &key (percent 0) (pages 5)  (defun print-allocated-objects (space &key (percent 0) (pages 5)
554                                          type larger smaller count
555                                        (stream *standard-output*))                                        (stream *standard-output*))
556    (declare (type (integer 0 99) percent) (type c::index pages)    (declare (type (integer 0 99) percent) (type c::index pages)
557             (type stream stream) (type spaces space))             (type stream stream) (type spaces space)
558               (type (or c::index null) type larger smaller count))
559    (multiple-value-bind (start-sap end-sap)    (multiple-value-bind (start-sap end-sap)
560                         (space-bounds space)                         (space-bounds space)
561      (let* ((space-start (sap-int start-sap))      (let* ((space-start (sap-int start-sap))
# Line 562  Line 564 
564             (pagesize (pagesize))             (pagesize (pagesize))
565             (start (+ space-start (round (* space-size percent) 100)))             (start (+ space-start (round (* space-size percent) 100)))
566             (pages-so-far 0)             (pages-so-far 0)
567               (count-so-far 0)
568             (last-page 0))             (last-page 0))
569        (declare (type (unsigned-byte 32) last-page start)        (declare (type (unsigned-byte 32) last-page start)
570                 (fixnum pages-so-far pagesize))                 (fixnum pages-so-far count-so-far pagesize))
571        (map-allocated-objects        (map-allocated-objects
572         #'(lambda (obj type size)         #'(lambda (obj obj-type size)
573             (declare (ignore size) (optimize (speed 3) (safety 0)))             (declare (optimize (speed 3) (safety 0)))
574             (let ((addr (get-lisp-obj-address obj)))             (let ((addr (get-lisp-obj-address obj)))
575               (when (and (>= addr start)               (when (>= addr start)
576                          (<= pages-so-far pages))                 (when (if count
577                 (let ((this-page (* (the (unsigned-byte 32)                           (> count-so-far count)
578                                          (truncate addr pagesize))                           (> pages-so-far pages))
579                                     pagesize)))                   (return-from print-allocated-objects (values)))
580                   (declare (type (unsigned-byte 32) this-page))  
581                   (when (/= this-page last-page)                 (unless count
582                     (when (< pages-so-far pages)                   (let ((this-page (* (the (unsigned-byte 32)
583                       (format stream "~2&**** Page ~D, address ~X:~%"                                            (truncate addr pagesize))
584                               pages-so-far addr))                                       pagesize)))
585                     (setq last-page this-page)                     (declare (type (unsigned-byte 32) this-page))
586                     (incf pages-so-far)))                     (when (/= this-page last-page)
587                         (when (< pages-so-far pages)
588                           (format stream "~2&**** Page ~D, address ~X:~%"
589                                   pages-so-far addr))
590                         (setq last-page this-page)
591                         (incf pages-so-far))))
592    
593                 (case type                 (when (and (or (not type) (eql obj-type type))
594                   (#.code-header-type                            (or (not smaller) (<= size smaller))
595                    (let ((dinfo (code-debug-info obj)))                            (or (not larger) (>= size larger)))
596                      (format stream "~&Code object: ~S~%"                   (incf count-so-far)
597                              (if dinfo                   (case type
598                                  (c::compiled-debug-info-name dinfo)                     (#.code-header-type
599                                  "No debug info."))))                      (let ((dinfo (code-debug-info obj)))
600                   (#.symbol-header-type                        (format stream "~&Code object: ~S~%"
601                    (format stream "~&~S~%" obj))                                (if dinfo
602                   (#.list-pointer-type                                    (c::compiled-debug-info-name dinfo)
603                    (write-char #\. stream))                                    "No debug info."))))
604                   (t                     (#.symbol-header-type
605                    (fresh-line stream)                      (format stream "~&~S~%" obj))
606                    (let ((str (write-to-string obj :level 5 :length 10                     (#.list-pointer-type
607                                                :pretty nil)))                      (write-char #\. stream))
608                      (unless (eql type structure-header-type)                     (t
609                        (format stream "~S: " (type-of obj)))                      (fresh-line stream)
610                      (format stream "~A~%"                      (let ((str (write-to-string obj :level 5 :length 10
611                              (subseq str 0 (min (length str) 60)))))))))                                                  :pretty nil)))
612                          (unless (eql type structure-header-type)
613                            (format stream "~S: " (type-of obj)))
614                          (format stream "~A~%"
615                                  (subseq str 0 (min (length str) 60))))))))))
616         space)))         space)))
617    (values))    (values))
618    
# Line 667  Line 679 
679                                 (function                                 (function
680                                  #'(lambda (obj type size)                                  #'(lambda (obj type size)
681                                      (declare (ignore obj type) (fixnum size))                                      (declare (ignore obj type) (fixnum size))
682                                      (integer-length size)))                                      (integer-length (1- size))))
683                                 (type nil))                                 (type nil))
684    (let ((function (if (eval:interpreted-function-p function)    (let ((function (if (eval:interpreted-function-p function)
685                        (compile nil function)                        (compile nil function)

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

  ViewVC Help
Powered by ViewVC 1.1.5