source: branches/qres/ccl/library/dominance.lisp @ 15278

Last change on this file since 15278 was 13502, checked in by gz, 9 years ago

From trunk: formatting tweaks, non-linux changes, doc and error message fixes

File size: 22.9 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2010 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19;(setq *print-array* nil)
20;(setq *print-simple-bit-vector* nil)
21
22#+:linuxx8664-target
23(progn
24
25(export '(idom-heap-utilization))
26
27#|
28(open-core "home:core.28209")
29(idom-heap-utilization :unit nil :sort :size)
30|#
31
32(defconstant half-fixnum-shift (ash (integer-length most-positive-fixnum) -1))
33
34(defconstant half-fixnum-mask (1- (ash 1 half-fixnum-shift)))
35
36(defstruct (core-graph (:include core-info) (:conc-name "CG.") (:constructor %cons-cg))
37  (heap-base 0 :type fixnum)
38  (heap-end 0 :type fixnum)
39  (stage nil) ;; indication of what has been computed and what hasn't, so can restart.
40  (head-p #.(make-array 0 :element-type 'bit) :type simple-bit-vector)
41  (ptrs-p #.(make-array 0 :element-type 'bit) :type simple-bit-vector)
42  ;; Nodes after eliminating single-entry and leaf objects
43  (nodes #() :type simple-vector) ;; map postorder-idx -> dnode
44  (revnodes #() :type simple-vector) ;; map dnode -> postorder-idx
45  (roots () :type list)
46  (predecessors #() :type simple-vector) ;; postorder-idx -> list of postorder indices of predecessors
47  (node-doms #() :type simple-vector) ;; postorder-idx of node -> postorder-idx of its immediate dominator
48  (idoms #() :type simple-vector) ;; sequence of postorder indices of immediate dominators
49  (revidoms #() :type simple-vector) ;; map dnode -> index in idoms
50  (logsizes #() :type simple-vector) ;; corresponding sequence of logical sizes (including all owned objects)
51  (physizes #() :type simple-vector) ;; corresponding sequence of physical sizes (including all owned objects)
52  )
53
54(setq *core-info-class* 'core-graph)
55
56(defparameter *cg-stages* '(nil :objects :leaves :postorder :predecessors :idoms :idom-sizes t))
57
58(defmethod cg-compute :before (stage &aux (cg (current-core)))
59  (assert (memq stage *cg-stages*))
60  (check-type cg core-graph)
61  (when (eql (cg.heap-base cg) 0)
62    (let ((area-ptr (core-q (kernel-global-address 'tenured-area))))
63      (setf (cg.heap-base cg) (core-q area-ptr target::area.low))
64      (setf (cg.heap-end cg) (core-q area-ptr target::area.active))))
65  ;; ensure have all the prereqs
66  (loop for undone = (cdr (memq (cg.stage cg) *cg-stages*))
67        while (memq stage (cdr undone))
68        do (format t "~&Computing ~a" (car undone))
69        do (cg-compute (car undone))))
70
71(defmethod cg-compute :after (stage &aux (cg (current-core)))
72  (setf (cg.stage cg) stage))
73
74(defmethod cg-compute ((stage (eql t))) ;; before method does all the work
75  nil)
76
77
78(declaim (inline core-node-p))
79(defun core-node-p (ptr) (or (core-consp  ptr) (core-uvector-p ptr)))
80
81(declaim (inline dnode addr))
82
83(defun dnode (base n) (the fixnum (ash (%i- n base) (- target::dnode-shift))))
84
85(defun addr (base n) (%i+ base (ash (the fixnum n) target::dnode-shift)))
86
87(defun tagged-ptr (ptr)
88  (let ((header (core-q ptr)))
89    (cond ((uvheader-p header)
90           (let ((subtag (uvheader-typecode header)))
91             (+ ptr (cond ((eq subtag target::subtag-symbol) target::fulltag-symbol)
92                          ((eq subtag target::subtag-function) target::fulltag-function)
93                          (t target::fulltag-misc)))) )
94          (t
95           (+ ptr target::fulltag-cons)))))
96
97(defun core-physsize (obj)
98  ;; (assert (core-node-p obj))
99  (if (core-consp obj)
100    target::dnode-size
101    (logandc2 (+ (uvheader-byte-size (core-uvheader obj)) target::node-size (1- target::dnode-size))
102              (1- target::dnode-size))))
103
104(defun core-object-sizes (obj)
105  (let ((fulltag (logand obj target::fulltagmask)))
106    (if (eq fulltag target::fulltag-cons)
107      (values target::dnode-size target::dnode-size)
108      (if (%i<= target::fulltag-misc fulltag)
109        (let* ((header (core-uvheader obj))
110               (logsize (uvheader-byte-size header))
111               ;; total including header and alignment.
112               (total (logandc2 (+ logsize target::node-size (1- target::dnode-size))
113                                (1- target::dnode-size))))
114          (values logsize total))))))
115
116(defun link-range (ptr)
117  (declare (fixnum ptr))
118  (let* ((addr (logandc2 ptr target::fulltagmask))
119         (header (core-q addr))
120         (end addr))
121    (declare (fixnum addr end))
122    (if (uvheader-p header)
123      (let ((subtag (%ilogand header target::fulltagmask)))
124        (declare (fixnum subtag))
125        (when (or (eq subtag target::fulltag-nodeheader-0)
126                  (eq subtag target::fulltag-nodeheader-1))
127          (incf addr target::node-size)
128          (setq end (+ addr (ash (uvheader-size header) target::word-shift)))
129          (when (eql (uvheader-typecode header) target::subtag-function)
130            (incf addr (ash (core-l addr) target::word-shift)))))
131      (setq end (+ addr target::dnode-size)))
132    (values addr end)))
133
134(defmethod cg-compute ((stage (eql :objects)) &aux (cg (current-core)))
135  "Compute incoming pointer counts"
136  (let* ((base (cg.heap-base cg))
137         (high (cg.heap-end cg))
138         (ndnodes (dnode base high))
139         (ptrs (make-array ndnodes :element-type 'bit :initial-element 0))
140         (head (make-array ndnodes :element-type 'bit :initial-element 0)))
141    (declare (fixnum base ndnodes)
142             (type simple-bit-vector ptrs head))
143    (map-core-region base high
144                     (lambda (obj)
145                       (multiple-value-bind (start end) (link-range obj)
146                         (loop for addr from start below end by target::node-size
147                               as ptr = (core-q addr)
148                               do (when (and (<= base ptr) (< ptr high) (core-node-p ptr))
149                                    (let ((dnode (dnode base ptr)))
150                                      (setf (aref head dnode) (aref ptrs dnode))
151                                      (setf (aref ptrs dnode) 1)))))
152                       ;; Mark that have an object even if there are no refs to it.
153                       (let ((dnode (dnode base obj)))
154                         (when (eql (aref ptrs dnode) 0)
155                           (setf (aref head dnode) 1)))))
156    ;; head = 0, ptrs = 0  -- not an object (internal dnode)
157    ;; head = 0, ptrs = 1  -- single-entry object (exactly one pointer to it)
158    ;; head = 1, ptrs = 0  -- root object (no pointers to it)
159    ;; head = 1, ptrs = 1  -- multiple-entry object
160    (setf (cg.head-p cg) head)
161    (setf (cg.ptrs-p cg) ptrs)
162    cg))
163
164(defmethod cg-compute ((stage (eql :leaves)) &aux (cg (current-core)))
165  "Mark leaf nodes (nodes with no outgoing pointers)"
166  (let* ((base (cg.heap-base cg))
167         (high (cg.heap-end cg))
168         (ptrs (cg.ptrs-p cg))
169         (head (cg.head-p cg)))
170    (declare (fixnum base high))
171    (loop for dn upfrom 0
172          for h bit across head
173          for p bit across ptrs
174          do (unless (and (eql h 0) (eql p 0))
175               (unless (multiple-value-bind (start end) (link-range (addr base dn))
176                         (loop for addr from start below end by target::node-size
177                            as val = (core-q addr)
178                            thereis (and (<= base val) (< val high) (core-node-p val))))
179                 (setf (aref head dn) 0)
180                 (setf (aref ptrs dn) 0))))
181    ;; head = 0, ptrs = 0  -- not an object (internal dnode) or a leaf
182    ;; head = 0, ptrs = 1  -- single-entry object (exactly one pointer to it), not leaf
183    ;; head = 1, ptrs = 0  -- root object (no pointers to it), not leaf
184    ;; head = 1, ptrs = 1  -- multiple-entry object, not leaf
185    cg))
186
187(defun collect-root-dnodes (cg)
188  (let ((head (cg.head-p cg))
189        (ptrs (cg.ptrs-p cg)))
190    (loop for dn = (position 1 head) then (position 1 head :start (1+ dn)) while dn
191          when (eql (aref ptrs dn) 0) collect dn)))
192
193(defmethod cg-compute ((stage (eql :postorder)) &aux (cg (current-core)))
194  (let* ((roots (collect-root-dnodes cg))
195         (head (cg.head-p cg))
196         (ptrs (cg.ptrs-p cg))
197         (halo-roots ())
198         (n (count 1 head))
199         (base (cg.heap-base cg))
200         (high (cg.heap-end cg))
201         (ndnodes (dnode base high))
202         (seen (make-array ndnodes :element-type 'bit :initial-element 0))
203         (nodes (make-array n))
204         (node-count 0))
205    (assert (< ndnodes (ash 1 half-fixnum-shift)))
206    (flet ((dfs (root-dn)
207             (setf (aref seen root-dn) 1)
208             (let ((path (multiple-value-bind (start end) (link-range (addr base root-dn))
209                           (list (list* start end root-dn)))))
210               (loop
211                  (destructuring-bind (start end . pred-dn) (car path)
212                    (incf (caar path) target::node-size)
213                    (if (eql start end)
214                        (progn
215                          (when (eql (aref head pred-dn) 1)
216                            (setf (aref nodes node-count) pred-dn)
217                            (incf node-count))
218                          (setq path (cdr path))
219                          (when (null path) (return)))
220                        (let ((next (core-q start)))
221                          (when (and (<= base next) (< next high) (core-node-p next))
222                            (let ((next-dn (dnode base next)))
223                              (if (eql (aref ptrs next-dn) 0) ;; root or leaf -- ignore leaf
224                                  (when (eql (aref head next-dn) 1) ;; previously assumed halo root
225                                    #+debug (warn "REASSIGNING HALO ROOT ~s -> ~d" (assq next-dn halo-roots) node-count)
226                                    (assert (eql (aref seen next-dn) 1))
227                                    (setf (aref ptrs next-dn) 1)
228                                    ;; not actually a root after all. Shift the region containing
229                                    ;; nodes from previous handling of next-dn to the end, as if
230                                    ;; just walked it right now.
231                                    (destructuring-bind (start . end) (cdr (assq next-dn halo-roots))
232                                      (shift-vector-region nodes start end node-count))
233                                    (setq halo-roots (delete next-dn halo-roots :key 'car)))
234                                  ;; non-leaf non-root
235                                  (when (eq (aref seen next-dn) 0)
236                                    (setf (aref seen next-dn) 1)
237                                    (multiple-value-bind (start end) (link-range next)
238                                      (push (list* start end next-dn) path)))))))))))))
239      (map nil #'dfs roots)
240      ;; Map through "halo" roots
241      (loop until (eql (length nodes) node-count)
242         as circ = (loop for nd = (position 1 head) then (position 1 head :start (1+ nd)) while nd
243                      when (eql (aref seen nd) 0) return nd)
244         do (when (null circ)
245              ;; Must have some cycles consisting of just single-entry nodes, since we caught all other ones
246              (setq circ (loop for nd = (position 1 ptrs) then (position 1 ptrs :start (1+ nd)) while nd
247                            when (eql (aref seen nd) 0) return nd))
248              #+debug (progn (format t "~&Breaking a SINGLE-NODE CYCLE at ") (core-print (tagged-ptr (addr (cg.heap-base cg) circ))))
249              (setf (aref head circ) 1))
250         do (let ((start node-count))
251              #+debug (progn (format t "~&Breaking out a HALO ROOT at ") (core-print (tagged-ptr (addr (cg.heap-base cg) circ))))
252              (dfs circ)
253              ;; This just makes it faster to find these in the dfs, it gets undone below.
254              (setf (aref ptrs circ) 0)
255              (push (list* circ start node-count) halo-roots))))
256    (setq roots (nconc (mapcar (lambda (x &aux (dn (car x)))
257                                 (setf (aref ptrs dn) 1)
258                                 dn)
259                               halo-roots)
260                       roots))
261    (setf (cg.roots cg) roots)
262    (setf (cg.nodes cg) nodes)
263    cg))
264
265(defun shift-vector-region (vector start mid end)
266  ;; move the interval from START to MID to after the interval from MID to END.
267  (loop as n2 = (- end mid) as n1 = (- mid start)
268        while (and (> n2 0) (> n1 0))
269        do (if (< n1 n2)
270             (loop for i from start below mid
271                   do (rotatef (aref vector i) (aref vector (+ i n1)))
272                   finally (setq start mid mid (+ mid n1)))
273             (loop for i from mid below end
274                   do (rotatef (aref vector i) (aref vector (- i n1)))
275                   finally (setq start (+ start n2))))))
276
277
278(declaim (inline make-rev-map))
279
280(defun make-rev-map (arr &optional (fn 'identity))
281  (let* ((n (length arr))
282         (revarr (make-array n)))
283    (loop for i from 0 below n as dn = (funcall fn (aref arr i))
284          do (setf (aref revarr i) (+ (ash i half-fixnum-shift) dn))) ;; [pidx ,, dn]
285    (sort revarr #'< :key (lambda (i.d) (logand i.d half-fixnum-mask)))))
286
287(defun index-for-dnode (revnodes dn)
288  (declare (type simple-vector revnodes) (fixnum dn)
289           (optimize (speed 3) (safety 0)))
290  (let ((low 0)
291        (high (length revnodes)))
292    (declare (fixnum low high) )
293    (loop
294      (when (eq low high) (return nil))
295      (let* ((half (ash (%i+ high low) -1))
296             (val (%ilogand2 (%svref revnodes half) half-fixnum-mask)))
297        (declare (fixnum half val))
298        (when (eq val dn)
299          (return (the fixnum (ash (the fixnum (%svref revnodes half)) (- half-fixnum-shift)))))
300        (if (< val dn)
301          (setq low (1+ half))
302          (setq high half))))))
303
304(defmacro do-pointers ((child-var addr) &body body)
305  (let ((path (gensym))
306        (start (gensym))
307        (end (gensym)))
308    ` (macrolet ((descend-pointers (child)
309                   `(multiple-value-bind (start end) (link-range ,child)
310                      (push (cons start end) ,',path))))
311        (let ((,path nil))
312          (descend-pointers ,addr)
313          (loop
314            (destructuring-bind (,start . ,end) (car ,path)
315              (incf (caar ,path) target::node-size)
316              (if (eq ,start ,end)
317                (unless (setq ,path (cdr ,path)) (return))
318                (let ((,child-var (core-q ,start)))
319                  (when (core-node-p ,child-var)
320                    ,@body)))))))))
321
322(defmethod cg-compute ((stage (eql :predecessors)) &aux (cg (current-core)))
323  (let* ((base (cg.heap-base cg))
324         (high (cg.heap-end cg))
325         (roots (cg.roots cg))
326         (head (cg.head-p cg))
327         (ptrs (cg.ptrs-p cg))
328         (nodes (cg.nodes cg)) ;; pidx -> dn
329         (n (length nodes))
330         (revnodes (make-rev-map nodes)) ;; dn -> pidx
331         (predecessors (make-array (1+ n) :initial-element 0)))
332    (flet ((record-predecessor (dn pred-i)
333             (let* ((i (index-for-dnode revnodes dn))
334                    (old (aref predecessors i)))
335               (cond ((eql old 0)
336                      (setf (aref predecessors i) (1+ pred-i)))
337                     ((fixnump old)
338                      (if (eql (logandc2 old half-fixnum-mask) 0)
339                        (setf (aref predecessors i) (+ (ash old half-fixnum-shift) pred-i))
340                        ;; could do more here, but most cases are covered by the 2-elt optimization
341                        (setf (aref predecessors i)
342                              (list pred-i
343                                    (logand old half-fixnum-mask) (1- (ash old (- half-fixnum-shift)))))))
344                     (t (setf (aref predecessors i) (cons pred-i old)))))))
345      (loop for dn across nodes as dn-idx upfrom 0
346            do (ASSERT (eql dn-idx (index-for-dnode revnodes dn)))
347            do (do-pointers (next (addr base dn))
348                 (when (and (<= base next) (< next high))
349                   (let ((next-dn (dnode base next)))
350                     (when (eq (aref ptrs next-dn) 1) ;; non-leaf
351                       (if (eql (aref head next-dn) 1) ;; stop at head node
352                         (record-predecessor next-dn dn-idx)
353                         (descend-pointers next)))))))
354      ;; Pretend there is one single root node which is the predecessor of all our roots.
355      (loop for root-dn in roots do (record-predecessor root-dn n)))
356    (setf (cg.revnodes cg) revnodes)
357    (setf (cg.predecessors cg) predecessors)
358    cg))
359
360(defun predecessor-list (predecessors i)
361  (let ((p (aref predecessors i)))
362    (cond ((eql p 0) '())
363          ((fixnump p)
364           (let ((p1 (logand p half-fixnum-mask)))
365             (if (eql p p1)
366               (list (1- p1))
367               (list p1 (1- (ash p (- half-fixnum-shift)))))))
368          (t p))))
369
370;;; Ok, now on to compute dominance
371;; immediate dominators per Cooper, Harvey, Kennedy.
372(defmethod cg-compute ((stage (eql :idoms)) &aux (cg (current-core)))
373  (let* ((predecessors (cg.predecessors cg))
374         (root-idx (1- (length predecessors)))
375         (doms (make-array (1+ root-idx) :initial-element nil)))
376    (flet ((intersect (i1 i2)
377             (when (and i1 i2)
378               (loop until (eq i1 i2)
379                     do (loop while (< i1 i2) do (setq i1 (aref doms i1)))
380                     do (loop while (< i2 i1) do (setq i2 (aref doms i2)))))
381             (or i1 i2))
382           (preds (i)
383             (predecessor-list predecessors i)))
384      (declare (inline intersect preds))
385      (setf (aref doms root-idx) root-idx)
386      (loop for changed = 0
387            do (loop for i from (1- root-idx) downto 0
388                     do (let ((new-idom nil))
389                          (loop for p in (preds i)
390                                do (when (aref doms p) (setq new-idom (intersect p new-idom))))
391                          (unless (eql new-idom (aref doms i))
392                            (setf (aref doms i) new-idom)
393                            (incf changed))))
394            DO (progn #+debug (format t "~&Finished loop, changed=~d~%" changed))
395            while (> changed 0)))
396    (setf (cg.node-doms cg) doms)
397    (setf (cg.idoms cg) (sort (delete root-idx (remove-duplicates doms)) #'<))
398    (let ((nodes (cg.nodes cg)))
399      (setf (cg.revidoms cg) (make-rev-map (cg.idoms cg) (lambda (ni) (aref nodes ni)))))
400    cg))
401
402(defmethod cg-compute ((stage (eql :idom-sizes)) &aux (cg (current-core)))
403  (let* ((nodes (cg.nodes cg))
404         (idom-nodes (cg.idoms cg))
405         (idom-revnodes (cg.revidoms cg))
406         (seen (make-array (length (cg.head-p cg)) :element-type 'bit :initial-element 0))
407         (base (cg.heap-base cg))
408         (high (cg.heap-end cg))
409         (nidoms (length idom-nodes))
410         (logsizes (make-array nidoms))
411         (physizes (make-array nidoms)))
412    ;; Any object that's not an idom is only reachable by one idom,
413    ;; so don't need to reinit SEEN bits between iterations.
414    (setf (cg.idoms cg) idom-nodes)
415    (loop for i from 0 below nidoms as idom = (aref idom-nodes i)
416         do (let* ((dn (aref nodes idom))
417                   (addr (addr base dn))
418                   (ptr (tagged-ptr addr)))
419              (multiple-value-bind (logsize physsize) (core-object-sizes ptr)
420                (do-pointers (next addr)
421                  (when (and (<= base next) (< next high))
422                    (let ((next-dn (dnode base next)))
423                      (unless (or (index-for-dnode idom-revnodes next-dn)
424                                  (eql (aref seen next-dn) 1))
425                        (setf (aref seen next-dn) 1)
426                        (multiple-value-bind (this-logsize this-physsize) (core-object-sizes next)
427                          (incf logsize this-logsize)
428                          (incf physsize this-physsize))
429                        (descend-pointers next)))))
430                (setf (aref logsizes i) logsize)
431                (setf (aref physizes i) physsize))))
432    (setf (cg.logsizes cg) logsizes)
433    (setf (cg.physizes cg) physizes)
434    cg))
435
436(defun idom-set-heap-range (area)
437  (check-type area (member :tenured :dynamic))
438  (multiple-value-bind (base end)
439      (cond ((eq area :tenured)
440             (let ((area-ptr (core-q (kernel-global-address 'tenured-area))))
441               (values (core-q area-ptr target::area.low)
442                       (core-q area-ptr target::area.active))))
443            ((eq area :dynamic)
444             (let* ((newest (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ))
445                    (oldest (core-q (kernel-global-address 'tenured-area))))
446               (assert (loop for this = newest then older as older = (core-q this target::area.succ)
447                             until (eql this oldest)
448                             always (eql (core-q this target::area.low) (core-q older target::area.active))))
449               (values (core-q oldest target::area.low)
450                       (core-q newest target::area.active)))))
451    (let ((cg (current-core)))
452      (unless (and (eq base (cg.heap-base cg))
453                   (eq end (cg.heap-end cg)))
454        (setf (cg.stage cg) nil)
455        (setf (cg.heap-base cg) base)
456        (setf (cg.heap-end cg) end)))))
457 
458
459(defun report-idom-heap-utilization (type-infos &key unit sort threshold)
460  (let ((data  (loop for type being the hash-key of type-infos using (hash-value info)
461                     collect (cons (core-type-string type) info))))
462    (report-heap-utilization data :unit unit :sort sort :stream *standard-output* :threshold threshold)))
463
464(defun idom-heap-utilization (&key unit (sort :size) (threshold 0.01) (area :tenured))
465  (idom-set-heap-range area)
466  (cg-compute t)
467  (loop with cg = (current-core)
468        with nodes = (cg.nodes cg)
469        with type-infos = (make-hash-table :test 'eql)
470        with base = (cg.heap-base cg)
471        for idx across (cg.idoms cg)
472        for logsz across (cg.logsizes cg)
473        for physz across (cg.physizes cg)
474        as type = (core-object-type-key (tagged-ptr (addr base (aref nodes idx))))
475        as info = (or (gethash type type-infos) (setf (gethash type type-infos) (list 0 0 0)))
476        do (incf (car info))
477        do (incf (cadr info) logsz)
478        do (incf (caddr info) physz)
479        finally (report-idom-heap-utilization type-infos :unit unit :sort sort :threshold threshold)))
480
481(defun idom-frontier-heap-utilization (&key unit (sort :size) (threshold 0.01) (area :tenured) (test nil))
482  ;; Compute the heap utilization WITHIN selected idom trees, aggregated.
483  (idom-set-heap-range area)
484  (cg-compute :idoms)
485  (let* ((cg (current-core))
486         (nodes (cg.nodes cg))
487         (idom-nodes (cg.idoms cg))
488         (idom-revnodes (cg.revidoms cg))
489         (seen (make-array (length (cg.head-p cg)) :element-type 'bit :initial-element 0))
490         (base (cg.heap-base cg))
491         (high (cg.heap-end cg))
492         (nidoms (length idom-nodes))
493         (type-infos (make-hash-table :test 'eql)))
494    (flet ((record (ptr)
495             (multiple-value-bind (logsize physsize) (core-object-sizes ptr)
496               (let* ((type (core-object-type-key ptr))
497                      (info (or (gethash type type-infos) (setf (gethash type type-infos) (list 0 0 0)))))
498                 (incf (car info))
499                 (incf (cadr info) logsize)
500                 (incf (caddr info) physsize)))))
501      (loop for i from 0 below nidoms as idom = (aref idom-nodes i)
502            do (let* ((dn (aref nodes idom))
503                      (addr (addr base dn))
504                      (ptr (tagged-ptr addr)))
505                 (when (or (null test) (funcall test ptr))
506                   ;; Ok, idom of interest.  Walk its subgraph
507                   (record ptr)
508                   (do-pointers (next addr)
509                     (when (and (<= base next) (< next high))
510                       (let ((next-dn (dnode base next)))
511                         (unless (or (index-for-dnode idom-revnodes next-dn)
512                                     (eql (aref seen next-dn) 1))
513                           (setf (aref seen next-dn) 1)
514                           (record next)
515                           (descend-pointers next)))))))
516            finally (report-idom-heap-utilization type-infos :unit unit :sort sort :threshold threshold)))))
517
518)
Note: See TracBrowser for help on using the repository browser.