1 ! Copyright (C) 2005, 2011 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs binary-search classes
4 classes.struct combinators combinators.smart continuations fry
5 generalizations generic grouping io io.styles kernel make math
6 math.order math.parser math.statistics memory layouts namespaces
7 parser prettyprint sequences sequences.generalizations sorting
8 splitting strings system vm words hints hashtables ;
14 dup 0 < [ neg commas "-" prepend ] [
16 reverse 3 group "," join reverse
19 : kilobytes ( n -- str )
20 1024 /i commas " KB" append ;
22 : nanos>string ( n -- str )
23 1000 /i commas " µs" append ;
25 : copying-room. ( copying-sizes -- )
27 { "Size:" [ size>> kilobytes ] }
28 { "Occupied:" [ occupied>> kilobytes ] }
29 { "Free:" [ free>> kilobytes ] }
32 : nursery-room. ( data-room -- )
33 "- Nursery space" print nursery>> copying-room. ;
35 : aging-room. ( data-room -- )
36 "- Aging space" print aging>> copying-room. ;
38 : mark-sweep-table. ( mark-sweep-sizes -- )
40 { "Size:" [ size>> kilobytes ] }
41 { "Occupied:" [ occupied>> kilobytes ] }
42 { "Total free:" [ total-free>> kilobytes ] }
43 { "Contiguous free:" [ contiguous-free>> kilobytes ] }
44 { "Free block count:" [ free-block-count>> number>string ] }
47 : tenured-room. ( data-room -- )
48 "- Tenured space" print tenured>> mark-sweep-table. ;
50 : misc-room. ( data-room -- )
51 "- Miscellaneous buffers" print
53 { "Card array:" [ cards>> kilobytes ] }
54 { "Deck array:" [ decks>> kilobytes ] }
55 { "Mark stack:" [ mark-stack>> kilobytes ] }
60 : data-room ( -- data-heap-room )
61 (data-room) data-heap-room memory>struct ;
64 "== Data heap ==" print nl
74 : heap-stat-step ( obj counts sizes -- )
75 [ [ class ] dip inc-at ]
76 [ [ [ size ] [ class ] bi ] dip at+ ] bi-curry* bi ;
80 : heap-stats ( -- counts sizes )
81 [ ] instances H{ } clone H{ } clone
82 [ '[ _ _ heap-stat-step ] each ] 2keep ;
85 heap-stats dup keys natural-sort standard-table-style [
86 [ { "Class" "Bytes" "Instances" } [ write-cell ] each ] with-row
90 dup pick at pprint-cell
96 : collect-gc-events ( quot -- gc-events )
98 [ ] [ disable-gc-events drop ] cleanup
99 disable-gc-events [ gc-event memory>struct ] map ; inline
103 : gc-op-string ( op -- string )
105 { collect-nursery-op [ "Copying from nursery" ] }
106 { collect-aging-op [ "Copying from aging" ] }
107 { collect-to-tenured-op [ "Copying to tenured" ] }
108 { collect-full-op [ "Mark and sweep" ] }
109 { collect-compact-op [ "Mark and compact" ] }
110 { collect-growing-heap-op [ "Grow heap" ] }
113 : (space-occupied) ( data-heap-room code-heap-room -- n )
115 [ [ nursery>> ] [ aging>> ] [ tenured>> ] tri [ occupied>> ] tri@ ]
120 : space-occupied-before ( event -- bytes )
121 [ data-heap-before>> ] [ code-heap-before>> ] bi (space-occupied) ;
123 : space-occupied-after ( event -- bytes )
124 [ data-heap-after>> ] [ code-heap-after>> ] bi (space-occupied) ;
126 : space-reclaimed ( event -- bytes )
127 [ space-occupied-before ] [ space-occupied-after ] bi - ;
129 TUPLE: gc-stats collections times ;
131 : <gc-stats> ( -- stats )
134 V{ } clone >>times ; inline
136 : compute-gc-stats ( events -- stats )
139 dup op>> _ [ drop <gc-stats> ] cache
140 [ 1 + ] change-collections
141 [ total-time>> ] dip times>> push
145 : gc-stats-table-row ( pair -- row )
147 [ first gc-op-string ] [
153 [ mean >integer nanos>string ]
154 [ median >integer nanos>string ]
155 [ infimum nanos>string ]
156 [ supremum nanos>string ]
162 : gc-stats-table ( stats -- table )
163 [ gc-stats-table-row ] map
164 { "" "Number" "Total" "Mean" "Median" "Min" "Max" } prefix ;
170 : gc-event. ( event -- )
172 { "Event type:" [ op>> gc-op-string ] }
173 { "Total time:" [ total-time>> nanos>string ] }
174 { "Space reclaimed:" [ space-reclaimed kilobytes ] }
178 gc-events get [ gc-event. nl ] each ;
181 gc-events get compute-gc-stats gc-stats-table simple-table. ;
185 { "Collections:" [ length commas ] }
186 { "Cards scanned:" [ [ cards-scanned>> ] map-sum commas ] }
187 { "Decks scanned:" [ [ decks-scanned>> ] map-sum commas ] }
188 { "Code blocks scanned:" [ [ code-blocks-scanned>> ] map-sum commas ] }
189 { "Total time:" [ [ total-time>> ] map-sum nanos>string ] }
190 { "Card scan time:" [ [ card-scan-time>> ] map-sum nanos>string ] }
191 { "Code block scan time:" [ [ code-scan-time>> ] map-sum nanos>string ] }
192 { "Data heap sweep time:" [ [ data-sweep-time>> ] map-sum nanos>string ] }
193 { "Code heap sweep time:" [ [ code-sweep-time>> ] map-sum nanos>string ] }
194 { "Compaction time:" [ [ compaction-time>> ] map-sum nanos>string ] }
197 SINGLETONS: +unoptimized+ +optimized+ +profiling+ +pic+ ;
201 { parameters read-only }
202 { relocation read-only }
205 { entry-point read-only } ;
207 TUPLE: code-blocks { blocks sliced-groups } { cache hashtable } ;
211 : code-block-type ( n -- type )
212 { +unoptimized+ +optimized+ +profiling+ +pic+ } nth ;
214 : <code-block> ( seq -- code-block )
221 [ tag-bits get shift ]
222 } spread code-block boa ; inline
224 : <code-blocks> ( seq -- code-blocks )
225 6 <sliced-groups> H{ } clone \ code-blocks boa ;
227 SYMBOL: code-heap-start
228 SYMBOL: code-heap-end
230 : in-code-heap? ( address -- ? )
231 code-heap-start get code-heap-end get between? ;
233 : (lookup-return-address) ( addr seq -- code-block )
234 [ entry-point>> <=> ] with search nip ;
236 HINTS: (lookup-return-address) code-blocks ;
240 M: code-blocks length blocks>> length ; inline
242 FROM: sequences.private => nth-unsafe ;
244 M: code-blocks nth-unsafe
245 [ cache>> ] [ blocks>> ] bi
246 '[ _ nth-unsafe <code-block> ] cache ; inline
248 INSTANCE: code-blocks immutable-sequence
250 : code-blocks ( -- blocks )
251 (code-blocks) <code-blocks> ;
253 : with-code-blocks ( quot -- )
256 [ \ code-blocks set ]
257 [ first entry-point>> code-heap-start set ]
258 [ last [ entry-point>> ] [ size>> ] bi + code-heap-end set ] tri
260 ] with-scope ; inline
262 : lookup-return-address ( addr -- code-block )
264 [ \ code-blocks get (lookup-return-address) ] [ drop f ] if ;
268 : code-block-stats ( code-blocks -- counts sizes )
269 H{ } clone H{ } clone
270 [ '[ [ size>> ] [ type>> ] bi [ nip _ inc-at ] [ _ at+ ] 2bi ] each ]
273 : blocks ( n -- str ) number>string " blocks" append ;
275 : code-block-table-row ( string type counts sizes -- triple )
276 [ at 0 or blocks ] [ at 0 or kilobytes ] bi-curry* bi 3array ;
278 : code-block-table. ( counts sizes -- )
281 { "Optimized code:" +optimized+ }
282 { "Unoptimized code:" +unoptimized+ }
283 { "Inline caches:" +pic+ }
284 { "Profiling stubs:" +profiling+ }
286 ] 2dip '[ _ _ code-block-table-row ] { } assoc>map
291 : code-room ( -- mark-sweep-sizes )
292 (code-room) mark-sweep-sizes memory>struct ;
295 "== Code heap ==" print nl
296 code-room mark-sweep-table. nl
297 code-blocks code-block-stats code-block-table. ;
300 data-room. nl code-room. ;