allocation.lisp

Revision 3681, 13.1 kB (checked in by ksprotte, 4 months ago)
checkpoint

Line
1	(in-package :bos.test)
2	(in-suite :bos.test.allocation)
3
4	(store-test allocation-area.none-at-startup
5	(is (null (class-instances 'bos.m2:allocation-area))))
6
7	(store-test allocation-area.no-intersection
8	(with-store-reopenings ()
9	(finishes (make-allocation-rectangle 0 0 100 100))
10	(signals (error) (make-allocation-rectangle 0 0 100 100))))
11
12	(store-test allocation-area.one-contract.no-cache
13	(let ((area (make-allocation-rectangle 0 0 100 100))
14	(sponsor (make-sponsor :login "test-sponsor"))
15	(m2-count 10))
16	(with-store-reopenings (area sponsor)
17	(finishes (make-contract sponsor m2-count))
18	(is (= (- (* 100 100) m2-count) (allocation-area-free-m2s area))))))
19
20	(store-test allocation-area.one-contract.with-cache.1
21	(let ((area (make-allocation-rectangle 0 0 2 5))
22	(sponsor (make-sponsor :login "test-sponsor"))
23	(m2-count 10))
24	(with-transaction ()
25	(bos.m2::activate-allocation-area area))
26	(with-store-reopenings (area sponsor)
27	(finishes (allocation-area-free-m2s area))
28	(is (= 1 (bos.m2.allocation-cache:count-cache-entries)))
29	(is-true (bos.m2.allocation-cache:find-exact-match 10))
30	(finishes (make-contract sponsor m2-count))
31	(is (zerop (allocation-area-free-m2s area))))))
32
33	(store-test allocation-area.one-contract.allocate-all-without-cache
34	(let ((area (make-allocation-rectangle 0 0 100 100))
35	(sponsor (make-sponsor :login "test-sponsor"))
36	(m2-count (* 100 100)))
37	(with-store-reopenings (area sponsor)
38	(finishes (make-contract sponsor m2-count))
39	(signals (error) (make-contract sponsor m2-count))
40	(is (zerop (allocation-area-free-m2s area))))))
41
42	(store-test allocation-area.one-contract.notany-m2-contract
43	(let ((area (make-allocation-rectangle 0 0 8 8))
44	(sponsor (make-sponsor :login "test-sponsor")))
45	(with-store-reopenings (area sponsor)
46	(finishes (make-contract sponsor 10))
47	(is (= (- 64 10) (allocation-area-free-m2s area)))
48	(signals (error) (make-contract sponsor 64)))))
49
50	(store-test allocation-area.return-contract-m2s
51	(let* ((area (make-allocation-rectangle 0 0 8 8))
52	(sponsor (make-sponsor :login "test-sponsor"))
53	(contract (make-contract sponsor 64)))
54	(with-store-reopenings (area sponsor contract)
55	(is (zerop (allocation-area-free-m2s area)))
56	(signals (error) (make-contract sponsor 64))
57	(delete-object contract)
58	(is-true (bos.m2.allocation-cache:find-exact-match 64))
59	(finishes (make-contract sponsor 10))
60	(is (= (- (* 8 8) 10) (allocation-area-free-m2s area))))))
61
62	(store-test allocation-area.return-contract-m2s.big-uncached-contract
63	(let* ((area (make-allocation-rectangle 0 0 30 30))
64	(sponsor (make-sponsor :login "test-sponsor"))
65	(contract (make-contract sponsor 500)))
66	(with-store-reopenings (area sponsor contract)
67	(finishes (delete-object contract))
68	(finishes (make-contract sponsor 10)))))
69
70	(test allocation-area.two-areas
71	(with-fixture initial-bos-store ()
72	(let ((snapshot nil) (bypass t))
73	(declare (ignorable snapshot bypass))
74	(let* ((area1 (make-allocation-rectangle 0 0 8 8))
75	(area2 (make-allocation-rectangle 10 10 8 8))
76	(sponsor (make-sponsor :login "test-sponsor"))
77	(total-free (+ 64 64)))
78	(progn
79	(iter (while (> total-free 20))
80	(for size = (1+ (random 3)))
81	(is (= total-free (+ (allocation-area-free-m2s area1)
82	(allocation-area-free-m2s area2))))
83	(with-transaction ()
84	(iter
85	(while (> size total-free))
86	(for contract = (first (all-contracts)))
87	(incf total-free (length (contract-m2s contract)))
88	(destroy-object contract)))
89	(finishes (make-contract sponsor size))
90	(decf total-free size)))))))
91
92	(test allocation-area.auto-activation.2
93	(skip "the new allocation alogorithm produces more fragmentation, so
94	this test does not work anymore as precisely as before")
95	#+nil
96	(with-fixture initial-bos-store ()
97	(let* ((area1 (make-allocation-rectangle 0 0 8 8))
98	(area2 (make-allocation-rectangle 10 10 8 8))
99	(sponsor (make-sponsor :login "test-sponsor")))
100	(is (not (allocation-area-active-p area1)))
101	(is (not (allocation-area-active-p area2)))
102	(dotimes (i 4)
103	(finishes (make-contract sponsor 16 :paidp t))
104	(is (allocation-area-active-p area1))
105	(is (not (allocation-area-active-p area2))))
106	(finishes (make-contract sponsor 16 :paidp t))
107	(is (allocation-area-active-p area1))
108	(is (allocation-area-active-p area2)))))
109
110
111	(test allocation-area.auto-activation.3
112	(dolist (m2-count '(1000 100))
113	(with-fixture initial-bos-store ()
114	(let* ((area1 (make-allocation-rectangle 0 0 8 8))
115	(area2 (make-allocation-rectangle 10 10 8 8))
116	(sponsor (make-sponsor :login "test-sponsor")))
117	(is (not (allocation-area-active-p area1)))
118	(is (not (allocation-area-active-p area2)))
119	(signals error (make-contract sponsor m2-count :paidp t))
120	(is (not (allocation-area-active-p area1))
121	"allocation areas should not be activated as a side effect,
122	when someone asks for too many m2s (~d) (which will result in
123	an error)" m2-count)
124	(is (not (allocation-area-active-p area2))
125	"allocation areas should not be activated as a side effect,
126	when someone asks for too many m2s (~d) (which will result in
127	an error)" m2-count)))))
128
129	(test allocation-area.auto-activation.4
130	(labels ((make-allocation-areas (widths)
131	(iter
132	(for w in widths)
133	(for pos initially 0 then (+ pos w))
134	(collect (make-allocation-rectangle pos pos w w))))
135	(request-feasible-p (n areas)
136	(some #'(lambda (area) (<= n (allocation-area-free-m2s area))) areas)))
137	(for-all ((allocation-area-widths (gen-list :length (gen-integer :min 1 :max 5)
138	:elements (gen-integer :min 1 :max 20)))
139	(n (gen-integer :min 1 :max 100)))
140	(with-fixture initial-bos-store ()
141	(let* ((areas (make-allocation-areas allocation-area-widths))
142	(sponsor (make-sponsor :login "test-sponsor")))
143	(is (notany #'allocation-area-active-p areas))
144	(is (every #'bos.m2::allocation-area-consistent-p areas))
145	(cond
146	((request-feasible-p n areas)
147	(let ((contract (make-contract sponsor n :paidp t)))
148	(is (= 1 (count-if #'allocation-area-active-p areas)))
149	(is (every #'bos.m2::allocation-area-consistent-p areas))
150	(let ((used-area (find-if #'allocation-area-active-p areas)))
151	(is (eq used-area (bos.m2::m2-allocation-area (first (contract-m2s contract))))))))
152	(t
153	(signals error (make-contract sponsor n :paidp t))
154	(is (notany #'allocation-area-active-p areas))
155	(is (every #'bos.m2::allocation-area-consistent-p areas)))))))))
156
157	(test allocation-area.allocate-m2s-for-sale
158	(flet ((m2p (obj)
159	(typep obj 'm2)))
160	(with-fixture initial-bos-store ()
161	(let* ((area1 (make-allocation-rectangle 0 0 8 8))
162	(area2 (make-allocation-rectangle 10 10 9 9)))
163	(for-all ((n (gen-integer :min 1 :max 60)))
164	(let ((m2s (with-transaction () (bos.m2::allocate-m2s-for-sale n))))
165	(if (null m2s)
166	(pass)
167	(progn
168	(is (listp m2s))
169	(is (every #'m2p m2s))
170	(is (= n (length m2s)))))))))))
171
172	(test allocation-area.allocate-m2s-for-sale.2
173	(flet ((m2p (obj)
174	(typep obj 'm2)))
175	(for-all ((n (gen-integer :min 1 :max 290)))
176	(with-fixture initial-bos-store ()
177	(let* ((area1 (make-allocation-rectangle 0 0 8 8))
178	(area2 (make-allocation-rectangle 10 10 9 9))
179	(m2s (with-transaction () (bos.m2::allocate-m2s-for-sale n))))
180	(if (null m2s)
181	(pass)
182	(progn
183	(is (listp m2s))
184	(is (every #'m2p m2s))
185	(is (= n (length m2s))))))))))
186
187
188
189	(test allocation-area.delete
190	(with-fixture initial-bos-store ()
191	(let ((area (make-allocation-rectangle 0 0 10 10))
192	(sponsor (make-sponsor :login "testuser")))
193	(make-contract sponsor 10)
194	(make-contract sponsor 1)
195	(make-contract sponsor 10)
196	(make-contract sponsor 3)
197	(delete-object area)
198	(is (object-destroyed-p area))
199	(finishes (snapshot)))))
200
201	(store-test contract-tree.1
202	(make-allocation-rectangle 0 0 8 8)
203	(finishes (delete-object (make-contract (make-sponsor :login "test-sponsor") 1 :paidp t))))
204
205	(store-test contract-tree.2
206	(make-allocation-rectangle 0 0 8 8)
207	(finishes (delete-object (make-contract (make-sponsor :login "test-sponsor") 1 :paidp nil))))
208
209	(test validate-allocation-area-inclusion-cache
210	(with-fixture initial-bos-store ()
211	(let ((area1 (make-allocation-rectangle 0 0 8 8)))
212	(finishes (bos.m2::validate-allocation-area-inclusion-cache)))))
213
214	(test allocation.disconnected-m2s.1
215	(with-fixture initial-bos-store ()
216	(let ((area (make-allocation-area
217	#((7193 . 5195) (7351 . 5193)
218	(7340 . 5377) (7185 . 5390)
219	(7174 . 5385) (7166 . 5387)
220	(7156 . 5381) (7150 . 5379)
221	(7143 . 5374) (7136 . 5368)
222	(7135 . 5364) (7135 . 5359)
223	(7140 . 5347) (7145 . 5342)
224	(7148 . 5329) (7156 . 5329)
225	(7157 . 5334) (7166 . 5331)
226	(7170 . 5329) (7171 . 5327)
227	(7174 . 5316) (7184 . 5306)
228	(7185 . 5291) (7196 . 5286)
229	(7197 . 5287) (7200 . 5287)
230	(7201 . 5284) (7203 . 5275)
231	(7201 . 5264) (7191 . 5249)
232	(7203 . 5237) (7199 . 5235)
233	(7195 . 5233) (7198 . 5222)
234	(7202 . 5219) (7202 . 5214)
235	(7204 . 5205) (7195 . 5197))))
236	(sponsor (make-sponsor :login "test-sponsor"))
237	(m2-counts '(12 43 29 3)))
238	(declare (ignore area))
239	(dolist (m2-count m2-counts)
240	(make-contract sponsor m2-count))
241	;; This following check reported:
242	;; WARNING: #<CONTRACT ID: 32131, unpaid> has m2s that are not
243	;; connected
244	(is (bos.m2::consistent-p)))))

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format