1 ! Copyright (C) 2005, 2011 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs binary-search classes classes.struct
4 combinators combinators.smart continuations fry grouping hashtables
5 hints io io.styles kernel layouts literals math math.order math.parser
6 math.statistics memory namespaces prettyprint sequences
7 sequences.generalizations sorting vm ;
11 PRIMITIVE: (callback-room) ( -- allocator-room )
12 PRIMITIVE: (code-blocks) ( -- array )
13 PRIMITIVE: (code-room) ( -- allocator-room )
14 PRIMITIVE: (data-room) ( -- data-room )
15 PRIMITIVE: disable-gc-events ( -- events )
16 PRIMITIVE: enable-gc-events ( -- )
19 dup 0 < [ neg commas "-" prepend ] [
21 reverse 3 group "," join reverse
24 : kilobytes ( n -- str )
25 1024 /i commas " KB" append ;
27 : nanos>string ( n -- str )
28 1000 /i commas " µs" append ;
30 : copying-room. ( copying-sizes -- )
32 { "Size:" [ size>> kilobytes ] }
33 { "Occupied:" [ occupied>> kilobytes ] }
34 { "Free:" [ free>> kilobytes ] }
37 : nursery-room. ( data-room -- )
38 "- Nursery space" print nursery>> copying-room. ;
40 : aging-room. ( data-room -- )
41 "- Aging space" print aging>> copying-room. ;
43 : mark-sweep-table. ( mark-sweep-sizes -- )
45 { "Size:" [ size>> kilobytes ] }
46 { "Occupied:" [ occupied>> kilobytes ] }
47 { "Total free:" [ total-free>> kilobytes ] }
48 { "Contiguous free:" [ contiguous-free>> kilobytes ] }
49 { "Free block count:" [ free-block-count>> number>string ] }
52 : tenured-room. ( data-room -- )
53 "- Tenured space" print tenured>> mark-sweep-table. ;
55 : misc-room. ( data-room -- )
56 "- Miscellaneous buffers" print
58 { "Card array:" [ cards>> kilobytes ] }
59 { "Deck array:" [ decks>> kilobytes ] }
60 { "Mark stack:" [ mark-stack>> kilobytes ] }
65 : data-room ( -- data-heap-room )
66 (data-room) data-heap-room memory>struct ;
69 "== Data heap ==" print nl
79 : heap-stat-step ( obj counts sizes -- )
80 [ [ class-of ] dip inc-at ]
81 [ [ [ size ] [ class-of ] bi ] dip at+ ] bi-curry* bi ;
85 : heap-stats ( -- counts sizes )
86 [ ] instances H{ } clone H{ } clone
87 [ '[ _ _ heap-stat-step ] each ] 2keep ;
90 heap-stats dup keys natural-sort standard-table-style [
91 [ { "Class" "Bytes" "Instances" } [ write-cell ] each ] with-row
95 dup pick at pprint-cell
101 : collect-gc-events ( quot -- gc-events )
103 [ disable-gc-events ] [ drop ] cleanup
104 [ gc-event memory>struct ] map ; inline
108 : gc-op-string ( op -- string )
110 { COLLECT-NURSERY-OP [ "Copying from nursery" ] }
111 { COLLECT-AGING-OP [ "Copying from aging" ] }
112 { COLLECT-TO-TENURED-OP [ "Copying to tenured" ] }
113 { COLLECT-FULL-OP [ "Mark and sweep" ] }
114 { COLLECT-COMPACT-OP [ "Mark and compact" ] }
115 { COLLECT-GROWING-DATA-HEAP-OP [ "Grow heap" ] }
118 : (space-occupied) ( data-heap-room code-heap-room -- n )
120 [ [ nursery>> ] [ aging>> ] [ tenured>> ] tri [ occupied>> ] tri@ ]
125 : space-occupied-before ( event -- bytes )
126 [ data-heap-before>> ] [ code-heap-before>> ] bi (space-occupied) ;
128 : space-occupied-after ( event -- bytes )
129 [ data-heap-after>> ] [ code-heap-after>> ] bi (space-occupied) ;
131 : space-reclaimed ( event -- bytes )
132 [ space-occupied-before ] [ space-occupied-after ] bi - ;
134 TUPLE: gc-stats collections times ;
136 : <gc-stats> ( -- stats )
139 V{ } clone >>times ; inline
141 : compute-gc-stats ( events -- stats )
144 dup op>> _ [ drop <gc-stats> ] cache
145 [ 1 + ] change-collections
146 [ total-time>> ] dip times>> push
150 : gc-stats-table-row ( pair -- row )
152 [ first gc-op-string ] [
158 [ mean >integer nanos>string ]
159 [ median >integer nanos>string ]
160 [ infimum nanos>string ]
161 [ supremum nanos>string ]
167 : gc-stats-table ( stats -- table )
168 [ gc-stats-table-row ] map
169 { "" "Number" "Total" "Mean" "Median" "Min" "Max" } prefix ;
175 : gc-event. ( event -- )
177 { "Event type:" [ op>> gc-op-string ] }
178 { "Total time:" [ total-time>> nanos>string ] }
179 { "Space reclaimed:" [ space-reclaimed kilobytes ] }
183 gc-events get [ gc-event. nl ] each ;
186 gc-events get compute-gc-stats gc-stats-table simple-table. ;
188 : sum-phase-times ( events phase -- n )
189 '[ times>> _ swap nth ] map-sum nanos>string ; inline
193 { "Collections:" [ length commas ] }
194 { "Cards scanned:" [ [ cards-scanned>> ] map-sum commas ] }
195 { "Decks scanned:" [ [ decks-scanned>> ] map-sum commas ] }
196 { "Code blocks scanned:" [ [ code-blocks-scanned>> ] map-sum commas ] }
197 { "Total time:" [ [ total-time>> ] map-sum nanos>string ] }
198 { "Card scan time:" [ PHASE-CARD-SCAN sum-phase-times ] }
199 { "Code block scan time:" [ PHASE-CODE-SCAN sum-phase-times ] }
200 { "Marking time:" [ PHASE-MARKING sum-phase-times ] }
201 { "Data heap sweep time:" [ PHASE-DATA-SWEEP sum-phase-times ] }
202 { "Code heap sweep time:" [ PHASE-CODE-SWEEP sum-phase-times ] }
203 { "Data compaction time:" [ PHASE-DATA-COMPACTION sum-phase-times ] }
208 { parameters read-only }
209 { relocation read-only }
212 { entry-point read-only } ;
214 TUPLE: code-blocks { blocks groups } { cache hashtable } ;
218 : <code-block> ( seq -- code-block )
225 [ tag-bits get shift ]
226 } spread code-block boa ; inline
228 : <code-blocks> ( seq -- code-blocks )
229 6 <groups> H{ } clone \ code-blocks boa ;
231 SYMBOL: code-heap-start
232 SYMBOL: code-heap-end
234 : in-code-heap? ( address -- ? )
235 code-heap-start get code-heap-end get between? ;
237 : (lookup-return-address) ( addr seq -- code-block )
238 [ entry-point>> <=> ] with search nip ;
240 HINTS: (lookup-return-address) code-blocks ;
244 M: code-blocks length blocks>> length ; inline
246 FROM: sequences.private => nth-unsafe ;
248 M: code-blocks nth-unsafe
249 [ cache>> ] [ blocks>> ] bi
250 '[ _ nth-unsafe <code-block> ] cache ; inline
252 INSTANCE: code-blocks immutable-sequence
254 : get-code-blocks ( -- blocks )
255 (code-blocks) <code-blocks> ;
257 : with-code-blocks ( quot -- )
260 [ \ code-blocks set ]
261 [ first entry-point>> code-heap-start set ]
262 [ last [ entry-point>> ] [ size>> ] bi + code-heap-end set ] tri
264 ] with-scope ; inline
266 : lookup-return-address ( addr -- code-block )
268 [ \ code-blocks get (lookup-return-address) ] [ drop f ] if ;
272 : code-block-stats ( code-blocks -- counts sizes )
273 H{ } clone H{ } clone
274 [ '[ [ size>> ] [ type>> ] bi [ nip _ inc-at ] [ _ at+ ] 2bi ] each ]
277 : blocks ( n -- str ) number>string " blocks" append ;
279 : code-block-table-row ( string type counts sizes -- triple )
280 [ at 0 or blocks ] [ at 0 or kilobytes ] bi-curry* bi 3array ;
282 : code-block-table. ( counts sizes -- )
285 ${ "Optimized code:" CODE-BLOCK-OPTIMIZED }
286 ${ "Unoptimized code:" CODE-BLOCK-UNOPTIMIZED }
287 ${ "Inline caches:" CODE-BLOCK-PIC }
289 ] 2dip '[ _ _ code-block-table-row ] { } assoc>map
294 : code-room ( -- mark-sweep-sizes )
295 (code-room) mark-sweep-sizes memory>struct ;
297 : callback-room ( -- mark-sweep-sizes )
298 (callback-room) mark-sweep-sizes memory>struct ;
301 "== Code heap ==" print nl
302 code-room mark-sweep-table. nl
303 get-code-blocks code-block-stats code-block-table. ;
305 : callback-room. ( -- )
306 "== Callback heap ==" print nl
307 callback-room mark-sweep-table. ;
310 data-room. nl code-room. nl callback-room. ;