/[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.3 by wlott, Fri Oct 12 15:08:16 1990 UTC revision 1.4 by wlott, Sun Mar 17 14:28:27 1991 UTC
# Line 1  Line 1 
1  ;;; -*- Mode: Lisp; Package: VM -*-  ;;; -*- Mode: Lisp; Package: VM -*-
2  ;;;  ;;;
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the Spice Lisp project at  ;;; This code was written as part of the CMU Common Lisp project at
5  ;;; Carnegie-Mellon University, and has been placed in the public domain.  ;;; Carnegie Mellon University, and has been placed in the public domain.
6  ;;; Spice Lisp is currently incomplete and under active development.  ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7  ;;; If you want to use this code or any part of Spice Lisp, please contact  ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8  ;;; Scott Fahlman (Scott.Fahlman@CS.CMU.EDU).  ;;;
9    (ext:file-comment
10      "$Header$")
11    ;;;
12  ;;; **********************************************************************  ;;; **********************************************************************
13  ;;;  ;;;
14  ;;; $Header$  ;;; $Header$
# Line 14  Line 17 
17  ;;;  ;;;
18  (in-package "VM")  (in-package "VM")
19  (use-package "SYSTEM")  (use-package "SYSTEM")
 (in-package "C")  
 (import '(function-code-header make-lisp-obj dynamic-space-free-pointer  
           code-code-size vector-length)  
         "VM")  
20  (in-package "LISP")  (in-package "LISP")
21  (import '(  (import '(
22            dynamic-0-space-start dynamic-1-space-start read-only-space-start            dynamic-0-space-start dynamic-1-space-start read-only-space-start
# Line 25  Line 24 
24            *static-space-free-pointer* *read-only-space-free-pointer*)            *static-space-free-pointer* *read-only-space-free-pointer*)
25          "VM")          "VM")
26  (in-package "VM")  (in-package "VM")
27    (import '(di::make-lisp-obj))
28    
29    
30  ;;;; Type format database.  ;;;; Type format database.
# Line 35  Line 35 
35    (name nil :type symbol)    (name nil :type symbol)
36    ;;    ;;
37    ;; Kind of type (how we determine length).    ;; Kind of type (how we determine length).
38    (kind nil :type (member :lowtag :fixed :header :vector    (kind (required-argument)
39                            :string :code :closure :structure))          :type (member :lowtag :fixed :header :vector
40                          :string :code :closure :structure))
41    ;;    ;;
42    ;; Length if fixed-length, shift amount for element size if :vector.    ;; Length if fixed-length, shift amount for element size if :vector.
43    (length nil :type (or fixnum null)))    (length nil :type (or fixnum null)))
# Line 137  Line 138 
138  (proclaim '(inline vector-total-size))  (proclaim '(inline vector-total-size))
139  (defun vector-total-size (obj info)  (defun vector-total-size (obj info)
140    (let ((shift (room-info-length info))    (let ((shift (room-info-length info))
141          (len (+ (vector-length obj)          (len (+ (length (the vector obj))
142                  (ecase (room-info-kind info)                  (ecase (room-info-kind info)
143                    (:vector 0)                    (:vector 0)
144                    (:string 1)))))                    (:string 1)))))
# Line 189  Line 190 
190                               word-bytes))))                               word-bytes))))
191                (funcall fun obj header-type size)                (funcall fun obj header-type size)
192                (setq current (sap+ current size))))                (setq current (sap+ current size))))
193               ((eq (room-info-kind info) :structure)
194                (let* ((obj (make-lisp-obj
195                             (logior (sap-int current) structure-pointer-type)))
196                       (size (round-to-dualword
197                              (* (+ (c::structure-length obj) 1) word-bytes))))
198                  (declare (fixnum size))
199                  (funcall fun obj header-type size)
200                  (assert (zerop (logand size lowtag-mask)))
201                  (when (> size 200000) (break "Implausible size, prev ~S" prev))
202                  (setq prev current)
203                  (setq current (sap+ current size))))
204             (t             (t
205              (let* ((obj (make-lisp-obj              (let* ((obj (make-lisp-obj
206                           (logior (sap-int current) other-pointer-type)))                           (logior (sap-int current) other-pointer-type)))
# Line 201  Line 213 
213                               (* (room-info-length info) word-bytes)))                               (* (room-info-length info) word-bytes)))
214                             ((:vector :string)                             ((:vector :string)
215                              (vector-total-size obj info))                              (vector-total-size obj info))
                            (:structure  
                             (round-to-dualword  
                              (* (+ (c::structure-length obj) 2) word-bytes)))  
216                             (:header                             (:header
217                              (round-to-dualword                              (round-to-dualword
218                               (* (1+ (get-header-data obj)) word-bytes)))                               (* (1+ (get-header-data obj)) word-bytes)))
# Line 363  Line 372 
372    (let ((code-words 0)    (let ((code-words 0)
373          (no-ops 0)          (no-ops 0)
374          (total-bytes 0))          (total-bytes 0))
375      (declare (fixnum code-words no-ops))      (declare (fixnum code-words no-ops)
376                 (type unsigned-byte total-bytes))
377      (map-allocated-objects      (map-allocated-objects
378       #'(lambda (obj type size)       #'(lambda (obj type size)
379           (declare (fixnum size) (optimize (speed 3) (safety 0)))           (declare (fixnum size) (optimize (speed 3) (safety 0)))
# Line 385  Line 395 
395    (values))    (values))
396    
397    
398    ;;; DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE  --  Public
399    ;;;
400    (defun descriptor-vs-non-descriptor-storage (&rest spaces)
401      (let ((descriptor-words 0)
402            (non-descriptor-headers 0)
403            (non-descriptor-bytes 0))
404        (declare (type unsigned-byte descriptor-words non-descriptor-headers
405                       non-descriptor-bytes))
406        (dolist (space (or spaces '(:read-only :static :dynamic)))
407          (declare (inline map-allocated-objects))
408          (map-allocated-objects
409           #'(lambda (obj type size)
410               (declare (fixnum size) (optimize (speed 3) (safety 0)))
411               (case type
412                 (#.code-header-type
413                  (let ((inst-words
414                         (truly-the fixnum (%primitive code-code-size obj))))
415                    (declare (type fixnum inst-words))
416                    (incf non-descriptor-bytes (* inst-words word-bytes))
417                    (incf descriptor-words
418                          (- (truncate size word-bytes) inst-words))))
419                 ((#.bignum-type
420                   #.single-float-type
421                   #.double-float-type
422                   #.simple-string-type
423                   #.simple-bit-vector-type
424                   #.simple-array-unsigned-byte-2-type
425                   #.simple-array-unsigned-byte-4-type
426                   #.simple-array-unsigned-byte-8-type
427                   #.simple-array-unsigned-byte-16-type
428                   #.simple-array-unsigned-byte-32-type
429                   #.simple-array-single-float-type
430                   #.simple-array-double-float-type)
431                  (incf non-descriptor-headers)
432                  (incf non-descriptor-bytes (- size word-bytes)))
433                 ((#.list-pointer-type
434                   #.structure-pointer-type
435                   #.ratio-type
436                   #.complex-type
437                   #.simple-array-type
438                   #.simple-vector-type
439                   #.complex-string-type
440                   #.complex-bit-vector-type
441                   #.complex-vector-type
442                   #.complex-array-type
443                   #.closure-header-type
444                   #.funcallable-instance-header-type
445                   #.value-cell-header-type
446                   #.symbol-header-type
447                   #.sap-type
448                   #.weak-pointer-type
449                   #.structure-header-type)
450                  (incf descriptor-words (truncate size word-bytes)))
451                 (t
452                  (error "Bogus type: ~D" type))))
453           space))
454        (format t "~:D words allocated for descriptor objects.~%"
455                descriptor-words)
456        (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"
457                non-descriptor-bytes non-descriptor-headers)
458        (values)))
459    
460    
461  ;;; STRUCTURE-USAGE  --  Public  ;;; STRUCTURE-USAGE  --  Public
462  ;;;  ;;;
463  (defun structure-usage (space &key (top-n 15))  (defun structure-usage (space &key (top-n 15))
# Line 399  Line 472 
472      (map-allocated-objects      (map-allocated-objects
473       #'(lambda (obj type size)       #'(lambda (obj type size)
474           (declare (fixnum size) (optimize (speed 3) (safety 0)))           (declare (fixnum size) (optimize (speed 3) (safety 0)))
475           (when (and (eql type simple-vector-type)           (when (eql type structure-header-type)
                     (eql (get-header-data obj) vector-structure-subtype))  
476             (incf total-objects)             (incf total-objects)
477             (incf total-bytes size)             (incf total-bytes size)
478             (let* ((name (svref obj 0))             (let* ((name (svref obj 0))

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

  ViewVC Help
Powered by ViewVC 1.1.5