Changeset 13490

Timestamp:

Mar 8, 2010, 8:28:19 AM (15 years ago)

Author:

gz

Message:

Add idom-frontier-heap-utilization

File:

• branches/working-0711/ccl/library/dominance.lisp (modified) (6 diffs)

branches/working-0711/ccl/library/dominance.lisp

@@ -44 +44 @@
   (node-doms #() :type simple-vector) ;; postorder-idx of node -> postorder-idx of its immediate dominator
   (idoms #() :type simple-vector) ;; sequence of postorder indices of immediate dominators
+  (revidoms #() :type simple-vector) ;; map dnode -> index in idoms
   (logsizes #() :type simple-vector) ;; corresponding sequence of logical sizes (including all owned objects)
   (physizes #() :type simple-vector) ;; corresponding sequence of physical sizes (including all owned objects)
@@ -393 +394 @@
             while (> changed 0)))
     (setf (cg.node-doms cg) doms)
+    (setf (cg.idoms cg) (sort (delete root-idx (remove-duplicates doms)) #'<))
+    (let ((nodes (cg.nodes cg)))
+      (setf (cg.revidoms cg) (make-rev-map (cg.idoms cg) (lambda (ni) (aref nodes ni)))))
     cg))
 
 (defmethod cg-compute ((stage (eql :idom-sizes)) &aux (cg (current-core)))
   (let* ((nodes (cg.nodes cg))
-         (pseudo-root (length nodes))
-         (idom-nodes (sort (delete pseudo-root (remove-duplicates (cg.node-doms cg))) #'<))
-         (idom-revnodes (make-rev-map idom-nodes (lambda (ni) (aref nodes ni))))
+         (idom-nodes (cg.idoms cg))
+         (idom-revnodes (cg.revidoms cg))
          (seen (make-array (length (cg.head-p cg)) :element-type 'bit :initial-element 0))
          (base (cg.heap-base cg))
@@ -407 +410 @@
          (physizes (make-array nidoms)))
     ;; Any object that's not an idom is only reachable by one idom,
-    ;; so don't need to reinit SEEN bits between calls.
+    ;; so don't need to reinit SEEN bits between iterations.
     (setf (cg.idoms cg) idom-nodes)
     (loop for i from 0 below nidoms as idom = (aref idom-nodes i)
@@ -430 +433 @@
     cg))
 
-(defun idom-heap-utilization (&key unit (sort :size) (threshold 0.01) (area :tenured))
+(defun idom-set-heap-range (area)
   (check-type area (member :tenured :dynamic))
   (multiple-value-bind (base end)
@@ -450 +453 @@
         (setf (cg.stage cg) nil)
         (setf (cg.heap-base cg) base)
-        (setf (cg.heap-end cg) end))))
+        (setf (cg.heap-end cg) end)))))
+  
+
+(defun report-idom-heap-utilization (type-infos &key unit sort threshold)
+  (let ((data  (loop for type being the hash-key of type-infos using (hash-value info)
+                     collect (cons (core-type-string type) info))))
+    (report-heap-utilization data :unit unit :sort sort :stream *standard-output* :threshold threshold)))
+
+(defun idom-heap-utilization (&key unit (sort :size) (threshold 0.01) (area :tenured))
+  (idom-set-heap-range area)
   (cg-compute t)
   (loop with cg = (current-core)
@@ -464 +476 @@
         do (incf (cadr info) logsz)
         do (incf (caddr info) physz)
-        finally (let ((data  (loop for type being the hash-key of type-infos using (hash-value info)
-                                   collect (cons (core-type-string type) info))))
-                  (report-heap-utilization data :unit unit :sort sort :stream *standard-output* :threshold threshold))))
-
+        finally (report-idom-heap-utilization type-infos :unit unit :sort sort :threshold threshold)))
+
+(defun idom-frontier-heap-utilization (&key unit (sort :size) (threshold 0.01) (area :tenured) (test nil))
+  ;; Compute the heap utilization WITHIN selected idom trees, aggregated.
+  (idom-set-heap-range area)
+  (cg-compute :idoms)
+  (let* ((cg (current-core))
+         (nodes (cg.nodes cg))
+         (idom-nodes (cg.idoms cg))
+         (idom-revnodes (cg.revidoms cg))
+         (seen (make-array (length (cg.head-p cg)) :element-type 'bit :initial-element 0))
+         (base (cg.heap-base cg))
+         (high (cg.heap-end cg))
+         (nidoms (length idom-nodes))
+         (type-infos (make-hash-table :test 'eql)))
+    (flet ((record (ptr)
+             (multiple-value-bind (logsize physsize) (core-object-sizes ptr)
+               (let* ((type (core-object-type-key ptr))
+                      (info (or (gethash type type-infos) (setf (gethash type type-infos) (list 0 0 0)))))
+                 (incf (car info))
+                 (incf (cadr info) logsize)
+                 (incf (caddr info) physsize)))))
+      (loop for i from 0 below nidoms as idom = (aref idom-nodes i)
+            do (let* ((dn (aref nodes idom))
+                      (addr (addr base dn))
+                      (ptr (tagged-ptr addr)))
+                 (when (or (null test) (funcall test ptr))
+                   ;; Ok, idom of interest.  Walk its subgraph
+                   (record ptr)
+                   (do-pointers (next addr)
+                     (when (and (<= base next) (< next high))
+                       (let ((next-dn (dnode base next)))
+                         (unless (or (index-for-dnode idom-revnodes next-dn)
+                                     (eql (aref seen next-dn) 1))
+                           (setf (aref seen next-dn) 1)
+                           (record next)
+                           (descend-pointers next)))))))
+            finally (report-idom-heap-utilization type-infos :unit unit :sort sort :threshold threshold)))))