-
Notifications
You must be signed in to change notification settings - Fork 0
/
embiggen.lisp
56 lines (56 loc) · 2.76 KB
/
embiggen.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
;;; Arrange so that all layouts have bignums as their bitmap,
;;; for exercising the C instance scavenging code.
;;;
;;; The use of a hashtable here was supposed end up with some layouts
;;; whose bitmap is at a lower address than the layout itself.
;;; This should randomize scavenging such that it sometimes sees
;;; a layout-bitmap that was already forwarded.
;;; However it doesn't work as desired; something else will have
;;; to be done to force that to happen.
;;;
;;; This test can't be run with immobile space enabled
;;; due simply to the assertion that instances in immobile space
;;; (which all happen to be layouts at the moment)
;;; do not have bignum bitmaps, which is true because a LAYOUT
;;; does not have enough slots to warrant a bignum bitmap.
;;;
;;; But the test's entire purpose is to assign noncanonical bignums
;;; (that are equivalent to fixnums) into every layout.
;;;
#-(or immobile-space (and));; FIXME: it's breaking something
(let ((ht (make-hash-table :test 'eql)))
(flet ((bignumify (int)
(or (gethash int ht)
(setf (gethash int ht)
(if (typep int 'fixnum)
(sb-bignum:make-small-bignum int)
int)))))
(sb-vm::map-allocated-objects
(lambda (obj type size)
(declare (ignore type size))
(when (and (typep obj 'sb-kernel:layout)
(typep (sb-kernel:layout-bitmap obj) 'fixnum))
(let ((flags (sb-kernel:layout-%flags obj)))
(setf (sb-kernel:layout-bitmap obj)
(if (logtest (logior sb-kernel:+condition-layout-flag+
sb-kernel:+pcl-object-layout-flag+)
flags)
;; *** this is bogus, since conditions have an arbitrary
;; number of slots, and need the special case of "all 1s"
;; But it's ok as a test.
(1- (ash 1 99))
(bignumify
(let ((bitmap (sb-kernel:layout-bitmap obj)))
(if (/= bitmap -1)
bitmap
(let ((len (sb-kernel:layout-length obj)))
;; force the 0th bit to 1, for the layout
;; (Shouldn't LENGTH be right? Doesn't seem to be)
(logior #-compact-instance-header 1
(1- (ash 1 len)))))))))
(unless (plusp (length (sb-kernel:layout-equalp-tests obj)))
(let ((n (- (sb-kernel:layout-length obj) sb-vm:instance-data-start)))
(when (>= n 0)
(setf (sb-kernel:layout-equalp-tests obj)
(make-array n :initial-element 0))))))))
:all)))