source: branches/working-0711/ccl/library/dominance.lisp @ 13465

Last change on this file since 13465 was 13465, checked in by gz, 10 years ago

add :image arg to core-open specify an image file, use it to load any readonly areas missing from the core file (which is usually where class and packae names live)

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