/
room.lisp
1522 lines (1428 loc) · 70.6 KB
/
room.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;;; heap-grovelling memory usage stuff
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB-VM")
;;;; type format database
;;; FIXME: this structure seems to no longer serve a purpose.
;;; We'd do as well with a simple-vector of (or symbol cons saetp).
(defstruct (room-info (:constructor make-room-info (name))
(:copier nil))
(name nil :type symbol :read-only t)) ; the name of this type
(declaim (freeze-type room-info))
(defun room-info-type-name (info)
(if (specialized-array-element-type-properties-p info)
(saetp-primitive-type-name info)
(room-info-name info)))
(defconstant tiny-boxed-size-mask #xFF)
(defun compute-room-infos ()
(let ((infos (make-array 256 :initial-element nil)))
(dolist (obj *primitive-objects*)
(let ((widetag (primitive-object-widetag obj))
(lowtag (primitive-object-lowtag obj))
(name (primitive-object-name obj)))
(when (and (member lowtag '(other-pointer-lowtag fun-pointer-lowtag
instance-pointer-lowtag))
(not (member widetag '(t nil simple-fun-widetag))))
(setf (svref infos (symbol-value widetag)) (make-room-info name)))))
(let ((info (make-room-info 'array-header)))
(dolist (code (list #+sb-unicode complex-character-string-widetag
complex-base-string-widetag simple-array-widetag
complex-bit-vector-widetag complex-vector-widetag
complex-array-widetag))
(setf (svref infos code) info)))
(dotimes (i (length *specialized-array-element-type-properties*))
(let ((saetp (aref *specialized-array-element-type-properties* i)))
(setf (svref infos (saetp-typecode saetp)) saetp)))
(let ((cons-info (make-room-info 'cons)))
;; A cons consists of two words, both of which may be either a
;; pointer or immediate data. According to the runtime this means
;; either a fixnum, a character, an unbound-marker, a single-float
;; on a 64-bit system, or a pointer.
(dotimes (i (ash 1 (- n-widetag-bits n-fixnum-tag-bits)))
(setf (svref infos (ash i n-fixnum-tag-bits)) cons-info))
(dotimes (i (ash 1 (- n-widetag-bits n-lowtag-bits)))
(setf (svref infos (logior (ash i n-lowtag-bits) instance-pointer-lowtag))
cons-info)
(setf (svref infos (logior (ash i n-lowtag-bits) list-pointer-lowtag))
cons-info)
(setf (svref infos (logior (ash i n-lowtag-bits) fun-pointer-lowtag))
cons-info)
(setf (svref infos (logior (ash i n-lowtag-bits) other-pointer-lowtag))
cons-info))
(setf (svref infos character-widetag) cons-info)
(setf (svref infos unbound-marker-widetag) cons-info)
;; Single-floats are immediate data on 64-bit systems.
#+64-bit (setf (svref infos single-float-widetag) cons-info))
infos))
(define-load-time-global *room-info* (compute-room-infos))
(declaim (type (simple-vector 256) *room-info*))
(defconstant-eqx +heap-spaces+
'((:dynamic "Dynamic space" dynamic-usage)
#+immobile-space
(:immobile "Immobile space" sb-kernel::immobile-space-usage)
(:read-only "Read-only space" sb-kernel::read-only-space-usage)
(:static "Static space" sb-kernel::static-space-usage))
#'equal)
(defconstant-eqx +stack-spaces+
'((:control-stack "Control stack" sb-kernel::control-stack-usage)
(:binding-stack "Binding stack" sb-kernel::binding-stack-usage))
#'equal)
(defconstant-eqx +all-spaces+ (append +heap-spaces+ +stack-spaces+) #'equal)
(defconstant-eqx +heap-space-keywords+ (mapcar #'first +heap-spaces+) #'equal)
(deftype spaces () `(member . ,+heap-space-keywords+))
;;;; MAP-ALLOCATED-OBJECTS
;;; Return the lower limit and current free-pointer of SPACE as fixnums
;;; whose raw bits (at the register level) represent a pointer.
;;; This makes it "off" by a factor of (EXPT 2 N-FIXNUM-TAG-BITS) - and/or
;;; possibly negative - if you look at the value in Lisp,
;;; but avoids potentially needing a bignum on 32-bit machines.
;;; 64-bit machines have no problem since most current generation CPUs
;;; use an address width that is narrower than 64 bits.
;;; This function is private because of the wacky representation.
(defun %space-bounds (space)
(macrolet ((bounds (a b) `(values (%make-lisp-obj ,a) (%make-lisp-obj ,b))))
(ecase space
(:static ;; These bounds are appropriate for computing the space usage
;; but NOT for computing iteration bounds, because there are
;; "unformatted" words preceding the lowest addressable object.
(bounds static-space-start
(sap-int *static-space-free-pointer*)))
(:read-only
(bounds read-only-space-start
(sap-int *read-only-space-free-pointer*)))
#+immobile-space
(:fixed
(bounds fixedobj-space-start
(sap-int *fixedobj-space-free-pointer*)))
#+immobile-space
(:variable
(bounds text-space-start
(sap-int *text-space-free-pointer*)))
(:dynamic
(bounds dynamic-space-start
(sap-int (dynamic-space-free-pointer)))))))
;;; Return the total number of bytes used in SPACE.
(defun space-bytes (space)
(if (eq space :immobile)
(+ (space-bytes :immobile-fixed)
(space-bytes :immobile-variable))
(multiple-value-bind (start end) (%space-bounds space)
(ash (- end start) n-fixnum-tag-bits))))
(defun instance-length (instance) ; excluding header, not aligned to even
;; Add 1 if expressed length PLUS header (total number of words) would be
;; an even number, and the hash state bits indicate hashed-and-moved.
(+ (%instance-length instance)
;; Compute 1 or 0 depending whether the instance was physically extended
;; by one word for the stable hash value. Extension occurs when and only when
;; the hash state is hashed-and-moved, and the apparent total number of words
;; inclusive of header (and exclusive of extension) is even. ANDing the least
;; significant bit of the payload size with HASH-SLOT-PRESENT arrives at the
;; desired boolean value. If apparent size is odd in hashed-and-moved state,
;; the physical size undergoes no change.
(let ((header-word (instance-header-word instance)))
(logand (ash header-word (- instance-length-shift))
(ash header-word (- hash-slot-present-flag))
1))))
;;; Iterate over all the objects in the contiguous block of memory
;;; with the low address at START and the high address just before
;;; END, calling FUN with the object, the object's type code, and the
;;; object's total size in bytes, including any header and padding.
;;; START and END are untagged, aligned memory addresses interpreted
;;; as FIXNUMs (unlike SAPs or tagged addresses, these will not cons).
(defun map-objects-in-range (fun start end &optional (strict-bound t))
(declare (type function fun))
(declare (dynamic-extent fun))
(let ((start (descriptor-sap start))
(end (descriptor-sap end)))
(loop
(if (sap>= start end) (return))
(let ((word (sap-ref-word start 0)))
(cond
((= (logand word widetag-mask) filler-widetag) ; pseudo-object
(let ((size (ash (filler-nwords word) word-shift)))
(setq start (sap+ start size))))
((= word most-positive-word)
;; has to be a pseudo-cons resulting from removing an insignificant
;; sign word of a bignum. Don't call FUN
(setq start (sap+ start (* 2 n-word-bytes))))
(t
(binding*
((widetag (widetag@baseptr start))
(obj (lispobj@baseptr start widetag))
((typecode size)
;; PRIMITIVE-OBJECT-SIZE works on conses, but they're exceptions already
;; because of absence of a widetag, so may as well not call the sizer.
(if (listp obj)
(values list-pointer-lowtag (* 2 n-word-bytes))
(values widetag (primitive-object-size obj)))))
;; SIZE is surely a fixnum. Non-fixnum would imply at least
;; a 512MB object if 32-bit words, and is inconceivable if 64-bit.
;; But check to be sure.
(aver (not (logtest (the fixnum size) lowtag-mask)))
(funcall fun obj typecode size)
(setq start (sap+ start size)))))))
(when strict-bound
;; If START is not eq to END, then we have blown past our endpoint.
#+sb-devel
(unless (sap= start end)
;; don't make things go more wrong than they already are.
(alien-funcall (extern-alien "printf" (function void system-area-pointer))
(vector-sap #.(format nil "map-objects-in-range failure~%")))
(ldb-monitor))
#-sb-devel
(aver (sap= start end)))))
#+mark-region-gc
(define-alien-variable "allocation_bitmap" (* unsigned-char))
#+mark-region-gc
(defun map-objects-in-discontiguous-range (fun start end generation-mask)
(declare (type function fun)
(type fixnum start end))
(declare (dynamic-extent fun))
;; START/END are passed as fixnum-encoded raw words to ensure no boxing
(let* ((start (get-lisp-obj-address start))
(end (get-lisp-obj-address end))
(first-byte (floor (- start dynamic-space-start)
(ash 8 n-lowtag-bits)))
(last-byte (ceiling (- end dynamic-space-start n-lowtag-bits)
(ash 8 n-lowtag-bits))))
(loop for byte from first-byte to last-byte
do (dotimes (bit 8)
(when (logbitp bit (deref allocation-bitmap byte))
(let ((position (+ dynamic-space-start
(ash (+ (* byte 8) bit) n-lowtag-bits))))
(when (and (<= start position) (< position end))
;; As in MAP-OBJECTS-IN-RANGE.
(binding*
((widetag (widetag@baseptr (int-sap position)))
(obj (lispobj@baseptr (int-sap position) widetag))
((typecode size)
(if (listp obj)
(values list-pointer-lowtag (* 2 n-word-bytes))
(values widetag (primitive-object-size obj)))))
(aver (not (logtest (the fixnum size) lowtag-mask)))
;; TODO: Each line has exactly one generation; should
;; check that in the outer loop instead.
;; This code SHOULD work but does not:
;; (let ((gen (the (not null) (generation-of obj))))
;; (when (logbitp gen generation-mask)
;; So it was using the 'default' arg to gc_gen_of.
;; But why??? We're in a generational space aren't we?
(let ((gen (generation-of obj)))
(when (and gen (logbitp gen generation-mask))
(funcall fun obj typecode size)))))))))))
;;; Access to the GENCGC page table for better precision in
;;; MAP-ALLOCATED-OBJECTS
(define-alien-variable "next_free_page" sb-kernel::page-index-t)
#+immobile-space
(progn
(deftype immobile-subspaces () '(member :fixed :variable))
(declaim (ftype (sfunction (function &rest immobile-subspaces) null)
map-immobile-objects))
(defun map-immobile-objects (function &rest subspaces) ; Perform no filtering
(declare (dynamic-extent function))
(do-rest-arg ((subspace) subspaces)
(multiple-value-bind (start end) (%space-bounds subspace)
(map-objects-in-range function start end)))))
#|
MAP-ALLOCATED-OBJECTS is fundamentally unsafe to use if the user-supplied
function allocates anything. Consider what can happens when NEXT-FREE-PAGE
points to a partially filled page, and one more object is created extending
an allocation region that began on the formerly "last" page:
0x10027cfff0: 0x00000000000000d9 <-- this was Lisp's view of
0x10027cfff8: 0x0000000000000006 the last page (page 1273)
---- page boundary ----
0x10027d0000: 0x0000001000005ecf <-- next_free_page moves here (page 1274)
0x10027d0008: 0x00000000000000ba
0x10027d0010: 0x0000000000000040
0x10027d0018: 0x0000000000000000
Lisp did not think that the page starting at 0x10027d0000 was allocated,
so it believes the stopping point is page 1273. When we read the bytes-used
on that page, we see a totally full page, but do not consider adjoining any
additional pages into the contiguous block.
However the object, a vector, that started on page 1273 ends on page 1274,
causing MAP-OBJECTS-IN-RANGE to assert that it overran 0x10027d0000.
We could try a few things to mitigate this:
* Try to "chase" the value of next-free-page. This is literally impossible -
it's a moving target, and it's extremely likely to exhaust memory doing so,
especially if the supplied lambda is an interpreted function.
(Each object scanned causes consing of more bytes, and we never
"catch up" to the moving next-free-page)
* If the page that we're looking at is full but the FINALLY clause is hit,
don't stop looking for more pages in that one case. Instead keep looking
for the end of the contiguous block, but stop as soon as any potential
stopping point is found; don't chase next-free-page. This is tricky
as well and just about as infeasible.
* Pass a flag to MAP-OBJECTS-IN-RANGE specifying that it's OK to
surpass the expected bound - silently accept our fate.
This is what we do since it's simple, and seems to work.
|#
;;; Iterate over all the objects allocated in each of the SPACES, calling FUN
;;; with the object, the object's type code, and the object's total size in
;;; bytes, including any header and padding. As a special case, if exactly one
;;; space named :ALL is requested, then map over the known spaces.
(defun map-allocated-objects (fun &rest spaces)
(declare (type function fun)
;; KLUDGE: rest-arg and self calls do not play nice and it'll get consed
(optimize (sb-c::recognize-self-calls 0)))
(declare (dynamic-extent fun))
(when (and (= (length spaces) 1) (eq (first spaces) :all))
(return-from map-allocated-objects
(map-allocated-objects fun
:read-only :static
#+immobile-space :immobile
:dynamic)))
;; You can't specify :ALL and also a list of spaces. Check that up front.
(do-rest-arg ((space) spaces) (the spaces space))
(flet ((do-1-space (space)
(ecase space
(:static
;; Static space starts with NIL, which requires special
;; handling, as the header and alignment are slightly off.
(funcall fun nil symbol-widetag (* sizeof-nil-in-words n-word-bytes))
(let ((start (%make-lisp-obj (+ static-space-start static-space-objects-offset)))
(end (%make-lisp-obj (sap-int *static-space-free-pointer*))))
(map-objects-in-range fun start end)))
((:read-only)
;; Read-only space (and dynamic space on cheneygc) is a block
;; of contiguous allocations.
(multiple-value-bind (start end) (%space-bounds space)
(map-objects-in-range fun start end)))
#+immobile-space
(:immobile
(with-system-mutex (*allocator-mutex*)
(map-immobile-objects fun :variable))
;; Filter out padding words
(dx-flet ((filter (obj type size)
(unless (= type list-pointer-lowtag)
(funcall fun obj type size))))
(map-immobile-objects #'filter :fixed))))))
(do-rest-arg ((space) spaces)
(if (eq space :dynamic)
(without-gcing (walk-dynamic-space fun #b1111111 0 0))
(do-1-space space)))))
;;; Using the mask bits you can make many different match conditions resulting
;;; from a product of {boxed,unboxed,code,any} x {large,non-large,both}
;;; e.g. mask = #b10011" constraint = "#b10010"
;;; matches "large & (unboxed | code)"
;;;
;;; I think, when iterating over only code, that if we grab the code_allocator_lock
;;; and free_pages_lock, that this can be made reliable (both crash-free and
;;; guaranteed to visit all chosen objects) despite other threads running.
;;; As things are it is only "maybe" reliable, regardless of the parameters.
(defun walk-dynamic-space (fun generation-mask
page-type-mask page-type-constraint)
(declare (function fun)
(type (unsigned-byte 7) generation-mask)
(type (unsigned-byte 5) page-type-mask page-type-constraint))
;; Dynamic space on gencgc requires walking the GC page tables
;; in order to determine what regions contain objects.
;; We explicitly presume that any pages in an allocation region
;; that are in-use have a BYTES-USED of GENCGC-PAGE-BYTES
;; (indicating a full page) or an otherwise-valid BYTES-USED.
;; We also presume that the pages of an open allocation region
;; after the first page, and any pages that are unallocated,
;; have a BYTES-USED of zero. GENCGC seems to guarantee this.
;; Our procedure is to scan forward through the page table,
;; maintaining an "end pointer" until we reach a page where
;; BYTES-USED is not GENCGC-PAGE-BYTES or we reach
;; NEXT-FREE-PAGE. We then MAP-OBJECTS-IN-RANGE if the range
;; is not empty, and proceed to the next page (unless we've hit
;; NEXT-FREE-PAGE).
;; FIXME: WITHOUT-GCING prevents a GC flip, but doesn't prevent
;; closing allocation regions and opening new ones. This may
;; prove to be an issue with concurrent systems, or with
;; spectacularly poor timing for closing an allocation region
;; in a single-threaded system.
(close-thread-alloc-region)
(do ((initial-next-free-page next-free-page)
(base (int-sap dynamic-space-start))
(start-page 0)
(end-page 0)
(end-page-bytes-used 0))
((> start-page initial-next-free-page))
;; The type constraint on page indices is probably too generous,
;; but it does its job of producing efficient code.
(declare (type (integer 0 (#.(/ (ash 1 n-machine-word-bits) gencgc-page-bytes)))
start-page end-page))
(setq end-page start-page)
(loop (setq end-page-bytes-used
(ash (ash (slot (deref page-table end-page) 'words-used*) -1)
word-shift))
;; See 'page_ends_contiguous_block_p' in gencgc.c
(when (or (< end-page-bytes-used gencgc-page-bytes)
(= (slot (deref page-table (1+ end-page)) 'start) 0))
(return))
(incf end-page))
(let ((start (sap+ base (truly-the signed-word
(logand (* start-page gencgc-page-bytes)
most-positive-word))))
(end (sap+ base (truly-the signed-word
(logand (+ (* end-page gencgc-page-bytes)
end-page-bytes-used)
most-positive-word)))))
(when (sap> end start)
(let ((flags (slot (deref page-table start-page) 'flags)))
;; The GEN slot is declared as (SIGNED 8) which does not satisfy the
;; type restriction on the first argument to LOGBITP.
;; Masking it to 3 bits fixes that, and allows using the other 5 bits
;; for something potentially.
#-mark-region-gc
(when (and (logbitp (logand (slot (deref page-table start-page) 'gen) 7)
generation-mask)
(= (logand flags page-type-mask) page-type-constraint))
;; FIXME: should exclude (0 . 0) conses on PAGE_TYPE_{BOXED,UNBOXED}
;; resulting from zeroing the tail of a bignum or vector etc.
(map-objects-in-range
fun
(%make-lisp-obj (sap-int start))
(%make-lisp-obj (sap-int end))
(< start-page initial-next-free-page)))
;; Generations of pages are basically meaningless (except
;; for pseudo-static pages) so we test generations of lines.
#+mark-region-gc
(when (= (logand flags page-type-mask) page-type-constraint)
(map-objects-in-discontiguous-range
fun
(%make-lisp-obj (sap-int start))
(%make-lisp-obj (sap-int end))
generation-mask)))))
(setq start-page (1+ end-page))))
;; Users are often surprised to learn that a just-consed object can't
;; necessarily be seen by MAP-ALLOCATED-OBJECTS, so close the region
;; to update the page table.
;; Since we're in WITHOUT-GCING, there can be no interrupts.
;; Moreover it's probably not safe in the least to walk any thread's
;; allocation region, unless the observer and observed aren't consing.
(defun close-thread-alloc-region ()
(alien-funcall (extern-alien "close_current_thread_tlab" (function void)))
nil)
;;;; MEMORY-USAGE
#+immobile-space
(progn
(declaim (ftype (function (immobile-subspaces) (values t t t &optional))
immobile-fragmentation-information))
(defun immobile-fragmentation-information (subspace)
(binding* (((start free-pointer) (%space-bounds subspace))
(used-bytes (ash (- free-pointer start) n-fixnum-tag-bits))
(holes '())
(hole-bytes 0))
(if (eq subspace :fixed)
(map-immobile-objects
(lambda (obj type size)
(declare (ignore obj))
(when (= type list-pointer-lowtag) (incf hole-bytes size)))
subspace)
(let ((sum-sizes 0))
(map-immobile-objects
(lambda (obj type size)
(declare (ignore obj type))
(incf sum-sizes size))
subspace)
(setq hole-bytes (- used-bytes sum-sizes))))
(values holes hole-bytes used-bytes)))
(defun show-fragmentation (&key (subspaces '(:fixed :variable))
(stream *standard-output*))
(dolist (subspace subspaces)
(format stream "~(~A~) subspace fragmentation:~%" subspace)
(multiple-value-bind (holes hole-bytes total-space-used)
(immobile-fragmentation-information subspace)
(loop for (start . size) in holes
do (format stream "~2@T~X..~X ~8:D~%" start (+ start size) size))
(format stream "~2@T~18@<~:D hole~:P~> ~8:D (~,2,2F% of ~:D ~
bytes used)~%"
(length holes) hole-bytes
(/ hole-bytes total-space-used) total-space-used))))
(defun sb-kernel::immobile-space-usage ()
(binding* (((nil fixed-hole-bytes fixed-used-bytes)
(immobile-fragmentation-information :fixed))
((nil variable-hole-bytes variable-used-bytes)
(immobile-fragmentation-information :variable))
(total-used-bytes (+ fixed-used-bytes variable-used-bytes))
(total-hole-bytes (+ fixed-hole-bytes variable-hole-bytes)))
(values total-used-bytes total-hole-bytes)))
) ; end PROGN
;;; Return a list of 3-lists (bytes object type-name) for the objects
;;; allocated in Space.
(defun type-breakdown (space)
(declare (muffle-conditions compiler-note))
(let ((sizes (make-array 256 :initial-element 0 :element-type 'word))
(counts (make-array 256 :initial-element 0 :element-type 'word)))
(map-allocated-objects
(lambda (obj type size)
(declare (word size) (optimize (speed 3)) (ignore obj))
(incf (aref sizes type) size)
(incf (aref counts type)))
space)
(let ((totals (make-hash-table :test 'eq)))
(dotimes (i 256)
(let ((total-count (aref counts i)))
(unless (zerop total-count)
(let* ((total-size (aref sizes i))
(name (room-info-type-name (aref *room-info* i)))
(found (ensure-gethash name totals (list 0 0 name))))
(incf (first found) total-size)
(incf (second found) total-count)))))
(collect ((totals-list))
(maphash (lambda (k v)
(declare (ignore k))
(totals-list v))
totals)
(sort (totals-list) #'> :key #'first)))))
;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
;;; (space-name . totals-for-space), where totals-for-space is the list
;;; returned by TYPE-BREAKDOWN.
(defun print-summary (spaces totals)
(let ((summary (make-hash-table :test 'eq))
(space-count (length spaces)))
(dolist (space-total totals)
(dolist (total (cdr space-total))
(push (cons (car space-total) total)
(gethash (third total) summary))))
(collect ((summary-totals))
(maphash (lambda (k v)
(declare (ignore k))
(let ((sum 0))
(declare (unsigned-byte sum))
(dolist (space-total v)
(incf sum (first (cdr space-total))))
(summary-totals (cons sum v))))
summary)
(format t "~2&Summary of space~P: ~(~{~A ~}~)~%" space-count spaces)
(let ((summary-total-bytes 0)
(summary-total-objects 0))
(declare (unsigned-byte summary-total-bytes summary-total-objects))
(dolist (space-totals
(mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
(let ((total-objects 0)
(total-bytes 0)
name)
(declare (unsigned-byte total-objects total-bytes))
(collect ((spaces))
(dolist (space-total space-totals)
(let ((total (cdr space-total)))
(setq name (third total))
(incf total-bytes (first total))
(incf total-objects (second total))
(spaces (cons (car space-total) (first total)))))
(format t "~%~A:~% ~:D bytes, ~:D object~:P"
name total-bytes total-objects)
(unless (= 1 space-count)
(dolist (space (spaces))
(format t ", ~D% ~(~A~)"
(round (* (cdr space) 100) total-bytes) (car space))))
(format t ".~%")
(incf summary-total-bytes total-bytes)
(incf summary-total-objects total-objects))))
(format t "~%Summary total:~% ~:D bytes, ~:D objects.~%"
summary-total-bytes summary-total-objects)))))
(declaim (ftype (sfunction (index &key (:comma-interval (and (integer 1) index))) index)
decimal-with-grouped-digits-width))
(defun decimal-with-grouped-digits-width (value &key (comma-interval 3))
(let ((digits (length (write-to-string value :base 10))))
(+ digits (floor (1- digits) comma-interval))))
;;; Report object usage for a single space.
(defun report-space-total (space-info cutoff)
(declare (list space-info) (type (or single-float null) cutoff))
(destructuring-bind (space . types) space-info
(format t "~2&Breakdown for ~(~A~) space:~%" space)
(let* ((total-bytes (reduce #'+ (mapcar #'first types)))
(bytes-width (decimal-with-grouped-digits-width total-bytes))
(total-objects (reduce #'+ (mapcar #'second types)))
(objects-width (decimal-with-grouped-digits-width total-objects))
(cutoff-point (if cutoff
(truncate (* (float total-bytes) cutoff))
0))
(reported-bytes 0)
(reported-objects 0))
(declare (unsigned-byte total-objects total-bytes cutoff-point
reported-objects reported-bytes))
(flet ((type-usage (bytes objects name &optional note)
(format t " ~V:D bytes for ~V:D ~(~A~) object~2:*~P~*~
~:[~; ~:*(~A)~]~%"
bytes-width bytes objects-width objects name note)))
(loop for (bytes objects name) in types do
(when (<= bytes cutoff-point)
(type-usage (- total-bytes reported-bytes)
(- total-objects reported-objects)
"other")
(return))
(incf reported-bytes bytes)
(incf reported-objects objects)
(type-usage bytes objects name))
(terpri)
(type-usage total-bytes total-objects space "space total")))))
;;; Print information about the heap memory in use. PRINT-SPACES is a
;;; list of the spaces to print detailed information for.
;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
;;; PRINT-SUMMARY is true, then summary information will be printed.
;;; The defaults print only summary information for dynamic space. If
;;; true, CUTOFF is a fraction of the usage in a report below which
;;; types will be combined as OTHER.
(defun memory-usage (&key print-spaces (count-spaces '(:dynamic #+immobile-space :immobile))
(print-summary t) cutoff)
(declare (type (or single-float null) cutoff))
(let* ((spaces (if (eq count-spaces t) +heap-space-keywords+ count-spaces))
(totals (mapcar (lambda (space)
(cons space (type-breakdown space)))
spaces)))
(dolist (space-total totals)
(when (or (eq print-spaces t)
(member (car space-total) print-spaces))
(report-space-total space-total cutoff)))
(when print-summary (print-summary spaces totals)))
(values))
;;; Print a breakdown by instance type of all the instances allocated
;;; in SPACE. If TOP-N is true, print only information for the
;;; TOP-N types with largest usage.
(defun instance-usage (space &key (top-n 15))
(declare (type spaces space) (type (or fixnum null) top-n))
(format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space)
(let ((totals (make-hash-table :test 'eq))
(total-objects 0)
(total-bytes 0))
(declare (unsigned-byte total-objects total-bytes))
(map-allocated-objects
(lambda (obj type size)
(declare (optimize (speed 3)))
(when (or (eql type instance-widetag)
(eql type funcallable-instance-widetag))
(incf total-objects)
(block nil
(let* ((layout (if (eql type funcallable-instance-widetag)
(%fun-layout obj)
(%instance-layout obj)))
(classoid (if (zerop (get-lisp-obj-address layout))
;; Don't crash on partially allocated instances
(return)
(layout-classoid layout)))
(found (ensure-gethash classoid totals (cons 0 0)))
(size size))
(declare (fixnum size))
(incf total-bytes size)
(incf (the fixnum (car found)))
(incf (the fixnum (cdr found)) size)))))
space)
(let* ((sorted (sort (%hash-table-alist totals) #'> :key #'cddr))
(interesting (if top-n
(subseq sorted 0 (min (length sorted) top-n))
sorted))
(bytes-width (decimal-with-grouped-digits-width total-bytes))
(objects-width (decimal-with-grouped-digits-width total-objects))
(totals-label (format nil "~:(~A~) instance total" space))
(types-width (reduce #'max interesting
:key (lambda (info)
(let ((type (first info)))
(length
(typecase type
(string
type)
(classoid
(with-output-to-string (stream)
(sb-ext:print-symbol-with-prefix
stream (classoid-name type))))))))
:initial-value (length totals-label)))
(printed-bytes 0)
(printed-objects 0))
(declare (unsigned-byte printed-bytes printed-objects))
(flet ((type-usage (type objects bytes)
(etypecase type
(string
(format t " ~V@<~A~> ~V:D bytes, ~V:D object~:P.~%"
(1+ types-width) type bytes-width bytes
objects-width objects))
(classoid
(format t " ~V@<~/sb-ext:print-symbol-with-prefix/~> ~
~V:D bytes, ~V:D object~:P.~%"
(1+ types-width) (classoid-name type) bytes-width bytes
objects-width objects)))))
(loop for (type . (objects . bytes)) in interesting
do (incf printed-bytes bytes)
(incf printed-objects objects)
(type-usage type objects bytes))
(terpri)
(let ((residual-objects (- total-objects printed-objects))
(residual-bytes (- total-bytes printed-bytes)))
(unless (zerop residual-objects)
(type-usage "Other types" residual-objects residual-bytes)))
(type-usage totals-label total-objects total-bytes))))
(values))
;;;; PRINT-ALLOCATED-OBJECTS
;;; This function is sheer madness. You're better off using
;;; LIST-ALLOCATED-OBJECTS and then iterating over that, to avoid
;;; seeing all the junk created while doing this thing.
(defun print-allocated-objects (space &key (percent 0) (pages 5)
type larger smaller count
(stream *standard-output*))
(declare (type (integer 0 99) percent) (type index pages)
(type stream stream) (type spaces space)
(type (or index null) type larger smaller count))
(multiple-value-bind (start end) (%space-bounds space)
(when (eq space :static)
(setq start (%make-lisp-obj (+ static-space-start static-space-objects-offset))))
(let* ((space-start (ash start n-fixnum-tag-bits))
(space-end (ash end n-fixnum-tag-bits))
(space-size (- space-end space-start))
(pagesize sb-c:+backend-page-bytes+)
(start (+ space-start (round (* space-size percent) 100)))
(printed-conses (make-hash-table :test 'eq))
(pages-so-far 0)
(count-so-far 0)
(last-page 0))
(declare (type word last-page start)
(fixnum pages-so-far count-so-far pagesize))
(labels ((note-conses (x)
(unless (or (atom x) (gethash x printed-conses))
(setf (gethash x printed-conses) t)
(note-conses (car x))
(note-conses (cdr x)))))
(map-allocated-objects
(lambda (obj obj-type size)
(let ((addr (get-lisp-obj-address obj)))
(when (>= addr start)
(when (if count
(> count-so-far count)
(> pages-so-far pages))
(return-from print-allocated-objects (values)))
(unless count
(let ((this-page (* (the (values word t)
(truncate addr pagesize))
pagesize)))
(declare (type word this-page))
(when (/= this-page last-page)
(when (< pages-so-far pages)
;; FIXME: What is this? (ERROR "Argh..")? or
;; a warning? or code that can be removed
;; once the system is stable? or what?
(format stream "~2&**** Page ~W, address ~X:~%"
pages-so-far addr))
(setq last-page this-page)
(incf pages-so-far))))
(when (and (or (not type) (eql obj-type type))
(or (not smaller) (<= size smaller))
(or (not larger) (>= size larger)))
(incf count-so-far)
(case type
(#.code-header-widetag
(let ((dinfo (%code-debug-info obj)))
(format stream "~&Code object: ~S~%"
(if dinfo ; BUG: what if this is in the asm code ?
(sb-c::compiled-debug-info-name dinfo)
"No debug info."))))
(#.symbol-widetag
(format stream "~&~S~%" obj))
(#.list-pointer-lowtag
(unless (gethash obj printed-conses)
(note-conses obj)
(let ((*print-circle* t)
(*print-level* 5)
(*print-length* 10))
(format stream "~&~S~%" obj))))
(t
(fresh-line stream)
(let ((str (write-to-string obj :level 5 :length 10
:pretty nil)))
(unless (eql type instance-widetag)
(format stream "~S: " (type-of obj)))
(format stream "~A~%"
(subseq str 0 (min (length str) 60))))))))))
space))))
(values))
;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
(defun list-allocated-objects (space &key type larger smaller count
test)
(declare (type (or (eql :all) spaces) space)
(type (or (unsigned-byte 8) null) type)
(type (or index null) larger smaller count)
(type (or function null) test))
(declare (dynamic-extent test))
(when (eql count 0)
(return-from list-allocated-objects nil))
;; This function was pretty much random as to what subset of the heap it
;; visited- it might see half the heap, 1/10th of the heap, who knows, because
;; it stopped based on hitting a sentinel cons cell made just prior to the loop.
;; That stopping condition was totally wrong because allocation does not occur
;; linearly. Taking 2 passes (first count, then store) stands a chance of
;; getting a reasonable point-in-time view as long as other threads are not consing
;; like crazy. If the user-supplied TEST function conses at all, then the result is
;; still very arbitrary - including possible duplication of objects if we visit
;; something and then see it again after GC transports it higher. The only way to
;; allow consing in the predicate would be to use dedicated "arenas" for new
;; allocations, that being a concept which we do not now - and may never - support.
(flet ((wantp (obj widetag size)
(and (or (not type) (eql widetag type))
(or (not smaller) (<= size smaller))
(or (not larger) (>= size larger))
(or (not test) (funcall test obj)))))
;; Unless COUNT is smallish, always start by counting. Don't just trust the user
;; because s/he might specify :COUNT huge-num which is acceptable provided that
;; huge-num is an INDEX which could either exhaust the heap, or at least be
;; wasteful if but a tiny handful of objects would actually satisfy WANTP.
(let* ((output (make-array
(if (typep count '(integer 0 100000))
count
(let ((n 0))
(map-allocated-objects
(lambda (obj widetag size)
(when (wantp obj widetag size) (incf n)))
space)
n))))
(index 0))
(block done
(map-allocated-objects
(lambda (obj widetag size)
(when (wantp obj widetag size)
(setf (aref output index) obj)
(when (= (incf index) (length output))
(return-from done))))
space))
(let ((list
(cond ((= index (length output)) ; easy case
(coerce output 'list))
(t ; didn't fill the array
(collect ((res))
(dotimes (i index (res))
(res (svref output i))))))))
(fill output 0) ; assist GC a bit
list))))
;;; Calls FUNCTION with all objects that have (possibly conservative)
;;; references to them on current stack.
;;; This is for use by SB-INTROSPECT. (Other consumers, at your own risk)
;;; Note that we do not call MAKE-LISP-OBJ in the errorp=nil mode, as it
;;; potentially uses FORMAT and MAKE-UNPRINTABLE-OBJECT with each invocation.
;;; And see the cautionary remarks above that function regarding its dangerous
;;; nature (more so on precise GC). On conservative GC we should be OK here
;;; because we know that there's a stack reference.
(defun map-stack-references (function)
(declare (type function function))
(declare (dynamic-extent function))
(macrolet ((iter (step limit test)
`(do ((sp (current-sp) (sap+ sp (,step n-word-bytes)))
(limit (sb-di::descriptor-sap ,limit))
(seen nil))
((,test sp limit))
(let ((word (sap-ref-word sp 0)))
;; Explicitly skip non-pointer words. The callable that
;; SB-INTROSPECT provides ignores immediate values anyway.
(when (and (is-lisp-pointer word)
(not (zerop (sb-di::valid-tagged-pointer-p (int-sap word)))))
(let ((obj (%make-lisp-obj word)))
(unless (memq obj seen)
(push obj seen)
(funcall function obj))))))))
#+stack-grows-downward-not-upward (iter + *control-stack-end* sap>)
#-stack-grows-downward-not-upward (iter - *control-stack-start* sap<)))
;;; Invoke FUNCTOID (a macro or function) on OBJ and any values in MORE.
;;; Note that neither OBJ nor items in MORE undergo ONCE-ONLY treatment.
;;; The fact that FUNCTOID can be a macro allows treatment of its first argument
;;; as a generalized place in the manner of SETF, allowing read/write access.
;;; CLAUSES are used to modify the output of this macro. See example uses
;;; for more detail.
;;; HIGH EXPERIMENTAL: PROCEED AT YOUR OWN RISK.
(defmacro do-referenced-object ((obj functoid &rest more) &rest alterations
&aux (n-matched-alterations 0))
(labels ((make-case (type &rest actions)
(apply #'make-case* type
(mapcar (lambda (action) `(,functoid ,action ,@more))
actions)))
(make-case* (type &rest actions)
(let* ((found (assoc type alterations :test 'equal))
(alteration (or (cdr found) '(:extend))))
(when found
(incf n-matched-alterations))
(ecase (car alteration)
(:override (list `(,type ,@(cdr alteration))))
(:extend (list `(,type ,@actions ,@(cdr alteration))))
(:delete))))) ; no clause
(prog1
`(typecase ,obj
;; Until the compiler can learn how to efficiently compile jump tables
;; by widetag, test in descending order of popularity.
;; These two are in fact generally the most frequently occurring type.
,.(make-case 'cons `(car ,obj) `(cdr ,obj))
,.(make-case* 'instance
;; %INSTANCE-LAYOUT is defknown'ed to return a LAYOUT,
;; but heap walking might encounter an instance with no layout,
;; hence the need to access the slot opaquely.
`(unless (eql 0 #+compact-instance-header (%primitive %instance-layout ,obj)
#-compact-instance-header (%instance-ref ,obj 0))
(,functoid (%instance-layout ,obj) ,@more)
(do-instance-tagged-slot (.i. ,obj)
(,functoid (%instance-ref ,obj .i.) ,@more))))
(function
(typecase ,obj
,.(make-case* 'closure
`(,functoid (%closure-fun ,obj) ,@more)
`(do-closure-values (.o. ,obj :include-extra-values t)
;; FIXME: doesn't allow setf, but of course there is
;; no closure-index-set anyway, so .O. might be unused
;; if functoid is a macro that does nothing.
(,functoid .o. ,@more)))
,.(make-case* 'funcallable-instance
`(progn
;; As for INSTANCE, allow the functoid to see the access form
(,functoid (%fun-layout ,obj) ,@more)
(,functoid (%funcallable-instance-fun ,obj) ,@more)
;; Unfortunately for FUNCALLABLE-INSTANCEs, the relation
;; between layout bitmap indices and indices as given to
;; FUNCALLABLE-INSTANCE-INFO is not so obvious, and it's
;; both tricky and unnecessary to generalize iteration.
(loop for .i. from 0
to (- (get-closure-length ,obj) funcallable-instance-info-offset)
do (,functoid (%funcallable-instance-info ,obj .i.) ,@more))))
.,(make-case 'function))) ; in case there was code provided for it
(t
;; TODO: the generated code is pretty horrible. OTHER-POINTER-LOWTAG
;; is known at this point, but tested N times.
(typecase ,obj
,.(make-case* 'simple-vector
`(dotimes (.i. (length ,obj))
(,functoid (data-vector-ref ,obj .i.) ,@more)))
;; Fancy arrays aren't highly popular, but this case must precede ARRAY
;; because ARRAY weeds out all other arrays, namely the ones that
;; hold no pointers: simple-string, simple-bit-vector, etc.
,.(make-case '(satisfies array-header-p)
`(%array-data ,obj)
`(%array-displaced-p ,obj)
`(%array-displaced-from ,obj))
,.(make-case 'array)
,.(make-case* 'symbol
`(,functoid (%primitive sb-c:fast-symbol-global-value ,obj) ,@more)
`(,functoid (symbol-%info ,obj) ,@more)
`(,functoid (symbol-name ,obj) ,@more)
`(,functoid (symbol-package ,obj) ,@more))
,.(make-case 'fdefn
`(fdefn-name ,obj)
`(fdefn-fun ,obj)
;; While it looks like we could easily allow a pointer to a movable object
;; in the fdefn-raw-addr slot, it is not exactly trivial- at a bare minimum,
;; translating the raw-addr to a lispobj might have to be pseudoatomic,
;; since we don't know what object to pin when reconstructing it.
;; For simple-funs in dynamic space, it doesn't have to be pseudoatomic
;; because a reference to the interior of code pins the code.
;; Closure trampolines would be fine as well. That leaves funcallable instances
;; as the pain point. Those could go on pages of code as well, but see the
;; comment in conservative_root_p() in gencgc as to why that alone
;; would be inadequate- we require a properly tagged descriptor
;; to enliven any object other than code.
#+(and immobile-code x86-64)
`(%make-lisp-obj
(alien-funcall (extern-alien "decode_fdefn_rawfun" (function unsigned unsigned))
(logandc2 (get-lisp-obj-address ,obj) lowtag-mask))))
,.(make-case* 'code-component
`(loop for .i. from 2 below (code-header-words ,obj)
do (,functoid (code-header-ref ,obj .i.) ,@more)))
,.(make-case '(or float (complex float) bignum
#+sb-simd-pack simd-pack
#+sb-simd-pack-256 simd-pack-256
system-area-pointer)) ; nothing to do
,.(make-case 'weak-pointer
#+weak-vector-readbarrier
`(if (weak-vector-p ,obj)
(dotimes (.i. (weak-vector-len ,obj))
(,functoid (weak-vector-ref ,obj .i.) ,@more))
(weak-pointer-value ,obj))
#-weak-vector-readbarrier
`(weak-pointer-value ,obj))
,.(make-case 'ratio `(%numerator ,obj) `(%denominator ,obj))