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
|
(set! (*s7* 'heap-size) 128000) ; old-style -- makes little difference (30 in callgrind)
(load "s7test-block.so" (sublet (curlet) (cons 'init_func 'block_init)))
(define-constant (check-cyclic p1)
(let ((c1 (cyclic-sequences p1))
(c2 (cyclic-sequences (copy p1)))
(c3 (cyclic-sequences (object->let p1))))
(unless (and (equal? c1 c2)
(equal? c2 c3))
(format *stderr* "cyclic: ~S: ~S ~S ~S~%" p1 c1 c2 c3))))
;(define wait-size 20000) ; this makes the gc work much harder (especially the mark process, mark_vector linearly etc)
(if (defined? 'big-tgc)
(define-expansion (wait-size) 20000) ; plug in the constant to avoid endless lookups (this is cheating)
(define-expansion (wait-size) 200))
(define (tgc-cyclic tries)
(let ((wait (make-vector (wait-size) #f)))
(do ((i 0 (+ i 1)))
((= i tries))
(let ((p1 (cons 1 2))
(p2 (make-list 7 1))
(p3 (list 1 2)))
(set-cdr! (cdr p3) p3)
(check-cyclic p1)
(check-cyclic p2)
(check-cyclic p3)
(let ((v1 (vector 1 2))
(v2 (make-vector 7 1))
(v3 (vector 1 2 3))
(v4 (make-vector '(3 2))))
(vector-set! v3 2 v3)
(check-cyclic v1)
(check-cyclic v2)
(check-cyclic v3)
(check-cyclic v4)
(check-cyclic (subvector v2 1 5))
(check-cyclic (subvector v3 1))
(let ((s1 (string #\a #\s #\d #\f)))
(check-cyclic s1)
(check-cyclic (substring s1 1))
(let ((iv1 (int-vector 1 2))
(iv2 (make-int-vector 7 1)))
(check-cyclic iv1)
(check-cyclic iv2)
(check-cyclic (subvector iv2 1 5))
(let ((h1 (hash-table 'a 1))
(h2 (weak-hash-table 'b p1)))
(check-cyclic h1)
(check-cyclic h2)
(let ((i1 (inlet 'a 1 'b 2)))
(check-cyclic i1)
(let ((in1 (open-output-string)))
(format in1 "asdf\n")
(check-cyclic in1)
(let ((in2 (open-input-string "asdf\n")))
(read-line in2)
(check-cyclic in2)
(let ((c1 (c-pointer 0 integer? "info" (cons h1 h2) (vector p3 p2 p1))))
(check-cyclic c1)
(let ((cc (call/cc (lambda (ret) ret))))
(check-cyclic cc)
(let ((ex1 (call-with-exit
(lambda (go)
(check-cyclic go)
go))))
(let ((f1 (lambda (a b c) (+ a b c))))
(check-cyclic f1)
(let ((u1 #<asdf>))
(check-cyclic u1)
(let ((g1 (gensym)))
(check-cyclic g1)
(check-cyclic ())
(check-cyclic #<unspecified)
(check-cyclic when)
(check-cyclic #<eof>)
(check-cyclic #f)
(check-cyclic #\a)
(check-cyclic pi)
(check-cyclic 1/2)
(check-cyclic 1+i)
(check-cyclic 'a)
(check-cyclic (lambda (a) (+ a 1)))
(let ((it1 (make-iterator '(1 2 3))))
(check-cyclic it1)
(let ((b1 (block 1 2 3)))
(check-cyclic b1)
(for-each
(lambda (a)
(vector-set! wait (random (wait-size)) a)
(catch #t
(lambda ()
(call-with-exit
(lambda (r)
(r a))))
(lambda (type info)
(format *stderr* "~A: ~A~%" type (apply format #f info)))))
(list p1 p2 p3 v1 v2 v3 v4 s1 iv2 iv2 h1 h2 i1 in1 in2 c1 cc ex1 u1 g1 it1 b1)))))))))))))))))))))
(tgc-cyclic 25000)
(define (tgc tries)
(do ((wait (make-vector (wait-size) #f))
(i 0 (+ i 1)))
((= i tries))
(let ((p1 (cons 1 2))
(p2 (list 1 1 1 1 1 1 1))
(p3 (list 1 2))
(v1 (vector 1 2))
(v2 (make-vector 7 1))
(v3 (vector 1 2 3))
(v4 (make-vector '(3 2)))
(s1 (string #\a #\s #\d #\f))
(iv2 (make-int-vector 7 1))
(h1 (hash-table 'a 1))
(i1 (inlet 'a 1 'b 2))
(in1 (open-output-string))
(in2 (open-input-string "asdf\n"))
(cc (call/cc (lambda (ret) ret)))
(ex1 (call-with-exit
(lambda (go)
go)))
(f1 (lambda (a b c) (+ a b c)))
(u1 #<asdf>)
(g1 (gensym))
(it1 (make-iterator '(1 2 3)))
(b1 (block 1 2 3)))
(set-cdr! (cdr p3) p3)
(vector-set! v3 2 v3)
(format in1 "asdf\n")
(read-line in2)
(let* ((h2 (weak-hash-table 'b p1))
(c1 (c-pointer 0 integer? "info" (cons h1 h2) (vector p3 p2 p1))))
(for-each
(lambda (a)
(vector-set! wait (random (wait-size)) a)
(catch #t
(lambda ()
(call-with-exit
(lambda (r)
(r a))))
(lambda (type info)
(format *stderr* "~A: ~A~%" type (apply format #f info)))))
(list p1 p2 p3 v1 v2 v3 v4 s1 iv2 iv2 h1 h2 i1 in1 in2 c1 cc ex1 u1 g1 it1 b1))))))
(if (defined? 'big-case)
(tgc 1000000)
(tgc 200000))
;(tgc 1000000000)
;(load "write.scm") (gc) (gc) (let-temporarily (((*s7* 'float-format-precision) 4)) (pretty-print (*s7* 'memory-usage) *stderr*)) (newline)
; weak-hash-table[-iter] undefined
(exit)
|
