Changeset 13494


Ignore:
Timestamp:
Mar 8, 2010, 5:13:50 PM (10 years ago)
Author:
gz
Message:

new file, dominance analysis of core files

Location:
trunk/source
Files:
4 edited
1 copied

Legend:

Unmodified
Added
Removed
  • trunk/source

  • trunk/source/level-1/l1-boot-2.lisp

    r13398 r13494  
    316316      (bin-load-provide "LEAKS" "leaks")
    317317      (bin-load-provide "CORE-FILES" "core-files")
     318      (bin-load-provide "DOMINANCE" "dominance")
    318319      (bin-load-provide "MCL-COMPAT" "mcl-compat")
    319320      (require "LOOP")
  • trunk/source/lib/compile-ccl.lisp

    r13417 r13494  
    209209    leaks
    210210    core-files
     211    dominance
    211212    asdf
    212213    defsystem
  • trunk/source/lib/systems.lisp

    r13085 r13494  
    209209    (leaks            "ccl:bin;leaks"            ("ccl:library;leaks.lisp"))
    210210    (core-files       "ccl:bin;core-files"       ("ccl:library;core-files.lisp"))
     211    (dominance        "ccl:bin;dominance"        ("ccl:library;dominance.lisp"))
    211212 
    212213    (prepare-mcl-environment "ccl:bin;prepare-mcl-environment" ("ccl:lib;prepare-mcl-environment.lisp"))
  • trunk/source/library/dominance.lisp

    r13442 r13494  
    2020;(setq *print-simple-bit-vector* nil)
    2121
    22 (export '(open-core-graph idom-heap-utilization))
     22(export '(idom-heap-utilization))
    2323
    2424#|
    25 (setq cg (open-core-graph  "home:core.28209"))
     25(open-core "home:core.28209")
    2626(idom-heap-utilization :unit nil :sort :size)
    2727|#
     
    3434  (heap-base 0 :type fixnum)
    3535  (heap-end 0 :type fixnum)
    36   (stage nil) ;; indication of what has been computed, and what hasn't so can restart.
    37   (head-p (make-array 0 :element-type 'bit) :type simple-bit-vector)
    38   (ptrs-p (make-array 0 :element-type 'bit) :type simple-bit-vector)
     36  (stage nil) ;; indication of what has been computed and what hasn't, so can restart.
     37  (head-p #.(make-array 0 :element-type 'bit) :type simple-bit-vector)
     38  (ptrs-p #.(make-array 0 :element-type 'bit) :type simple-bit-vector)
    3939  ;; Nodes after eliminating single-entry and leaf objects
    4040  (nodes #() :type simple-vector) ;; map postorder-idx -> dnode
     
    4444  (node-doms #() :type simple-vector) ;; postorder-idx of node -> postorder-idx of its immediate dominator
    4545  (idoms #() :type simple-vector) ;; sequence of postorder indices of immediate dominators
     46  (revidoms #() :type simple-vector) ;; map dnode -> index in idoms
    4647  (logsizes #() :type simple-vector) ;; corresponding sequence of logical sizes (including all owned objects)
    4748  (physizes #() :type simple-vector) ;; corresponding sequence of physical sizes (including all owned objects)
    4849  )
    4950
    50 (defun open-core-graph (pathname)
    51   (let ((cg (%cons-cg)))
    52     (open-core pathname :core-info cg)
    53     (let ((area-ptr (core-q (kernel-global-address 'tenured-area))))
    54       (setf (cg.heap-base cg) (core-q area-ptr target::area.low))
    55       (setf (cg.heap-end cg) (core-q area-ptr target::area.active)))
    56     cg))
     51(setq *core-info-class* 'core-graph)
    5752
    5853(defparameter *cg-stages* '(nil :objects :leaves :postorder :predecessors :idoms :idom-sizes t))
     
    6156  (assert (memq stage *cg-stages*))
    6257  (check-type cg core-graph)
     58  (when (eql (cg.heap-base cg) 0)
     59    (let ((area-ptr (core-q (kernel-global-address 'tenured-area))))
     60      (setf (cg.heap-base cg) (core-q area-ptr target::area.low))
     61      (setf (cg.heap-end cg) (core-q area-ptr target::area.active))))
    6362  ;; ensure have all the prereqs
    6463  (loop for undone = (cdr (memq (cg.stage cg) *cg-stages*))
     
    393392            while (> changed 0)))
    394393    (setf (cg.node-doms cg) doms)
     394    (setf (cg.idoms cg) (sort (delete root-idx (remove-duplicates doms)) #'<))
     395    (let ((nodes (cg.nodes cg)))
     396      (setf (cg.revidoms cg) (make-rev-map (cg.idoms cg) (lambda (ni) (aref nodes ni)))))
    395397    cg))
    396398
    397399(defmethod cg-compute ((stage (eql :idom-sizes)) &aux (cg (current-core)))
    398400  (let* ((nodes (cg.nodes cg))
    399          (pseudo-root (length nodes))
    400          (idom-nodes (sort (delete pseudo-root (remove-duplicates (cg.node-doms cg))) #'<))
    401          (idom-revnodes (make-rev-map idom-nodes (lambda (ni) (aref nodes ni))))
     401         (idom-nodes (cg.idoms cg))
     402         (idom-revnodes (cg.revidoms cg))
    402403         (seen (make-array (length (cg.head-p cg)) :element-type 'bit :initial-element 0))
    403404         (base (cg.heap-base cg))
     
    407408         (physizes (make-array nidoms)))
    408409    ;; Any object that's not an idom is only reachable by one idom,
    409     ;; so don't need to reinit SEEN bits between calls.
     410    ;; so don't need to reinit SEEN bits between iterations.
    410411    (setf (cg.idoms cg) idom-nodes)
    411412    (loop for i from 0 below nidoms as idom = (aref idom-nodes i)
     
    430431    cg))
    431432
    432 (defun idom-heap-utilization (&key unit (sort :size) (threshold 0.01))
     433(defun idom-set-heap-range (area)
     434  (check-type area (member :tenured :dynamic))
     435  (multiple-value-bind (base end)
     436      (cond ((eq area :tenured)
     437             (let ((area-ptr (core-q (kernel-global-address 'tenured-area))))
     438               (values (core-q area-ptr target::area.low)
     439                       (core-q area-ptr target::area.active))))
     440            ((eq area :dynamic)
     441             (let* ((newest (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ))
     442                    (oldest (core-q (kernel-global-address 'tenured-area))))
     443               (assert (loop for this = newest then older as older = (core-q this target::area.succ)
     444                             until (eql this oldest)
     445                             always (eql (core-q this target::area.low) (core-q older target::area.active))))
     446               (values (core-q oldest target::area.low)
     447                       (core-q newest target::area.active)))))
     448    (let ((cg (current-core)))
     449      (unless (and (eq base (cg.heap-base cg))
     450                   (eq end (cg.heap-end cg)))
     451        (setf (cg.stage cg) nil)
     452        (setf (cg.heap-base cg) base)
     453        (setf (cg.heap-end cg) end)))))
     454 
     455
     456(defun report-idom-heap-utilization (type-infos &key unit sort threshold)
     457  (let ((data  (loop for type being the hash-key of type-infos using (hash-value info)
     458                     collect (cons (core-type-string type) info))))
     459    (report-heap-utilization data :unit unit :sort sort :stream *standard-output* :threshold threshold)))
     460
     461(defun idom-heap-utilization (&key unit (sort :size) (threshold 0.01) (area :tenured))
     462  (idom-set-heap-range area)
    433463  (cg-compute t)
    434464  (loop with cg = (current-core)
     
    444474        do (incf (cadr info) logsz)
    445475        do (incf (caddr info) physz)
    446         finally (let ((data  (loop for type being the hash-key of type-infos using (hash-value info)
    447                                    collect (cons (core-type-string type) info))))
    448                   (report-heap-utilization data :unit unit :sort sort :stream *standard-output* :threshold threshold))))
    449 
     476        finally (report-idom-heap-utilization type-infos :unit unit :sort sort :threshold threshold)))
     477
     478(defun idom-frontier-heap-utilization (&key unit (sort :size) (threshold 0.01) (area :tenured) (test nil))
     479  ;; Compute the heap utilization WITHIN selected idom trees, aggregated.
     480  (idom-set-heap-range area)
     481  (cg-compute :idoms)
     482  (let* ((cg (current-core))
     483         (nodes (cg.nodes cg))
     484         (idom-nodes (cg.idoms cg))
     485         (idom-revnodes (cg.revidoms cg))
     486         (seen (make-array (length (cg.head-p cg)) :element-type 'bit :initial-element 0))
     487         (base (cg.heap-base cg))
     488         (high (cg.heap-end cg))
     489         (nidoms (length idom-nodes))
     490         (type-infos (make-hash-table :test 'eql)))
     491    (flet ((record (ptr)
     492             (multiple-value-bind (logsize physsize) (core-object-sizes ptr)
     493               (let* ((type (core-object-type-key ptr))
     494                      (info (or (gethash type type-infos) (setf (gethash type type-infos) (list 0 0 0)))))
     495                 (incf (car info))
     496                 (incf (cadr info) logsize)
     497                 (incf (caddr info) physsize)))))
     498      (loop for i from 0 below nidoms as idom = (aref idom-nodes i)
     499            do (let* ((dn (aref nodes idom))
     500                      (addr (addr base dn))
     501                      (ptr (tagged-ptr addr)))
     502                 (when (or (null test) (funcall test ptr))
     503                   ;; Ok, idom of interest.  Walk its subgraph
     504                   (record ptr)
     505                   (do-pointers (next addr)
     506                     (when (and (<= base next) (< next high))
     507                       (let ((next-dn (dnode base next)))
     508                         (unless (or (index-for-dnode idom-revnodes next-dn)
     509                                     (eql (aref seen next-dn) 1))
     510                           (setf (aref seen next-dn) 1)
     511                           (record next)
     512                           (descend-pointers next)))))))
     513            finally (report-idom-heap-utilization type-infos :unit unit :sort sort :threshold threshold)))))
Note: See TracChangeset for help on using the changeset viewer.