Commit | Line | Data |
---|---|---|
691697de | 1 | ;;;; Low-level tests of the bytecode assembler -*- mode: scheme; coding: utf-8; -*- |
e78991aa AW |
2 | ;;;; |
3 | ;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. | |
4 | ;;;; | |
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
691697de | 19 | (define-module (tests bytecode) |
e78991aa | 20 | #:use-module (test-suite lib) |
cb86cbd7 AW |
21 | #:use-module (system vm assembler) |
22 | #:use-module (system vm program) | |
4cbc95f1 | 23 | #:use-module (system vm loader) |
4dfae1bf | 24 | #:use-module (system vm linker) |
cb86cbd7 | 25 | #:use-module (system vm debug)) |
e78991aa | 26 | |
4dfae1bf AW |
27 | (define (assemble-program instructions) |
28 | "Take the sequence of instructions @var{instructions}, assemble them | |
691697de | 29 | into bytecode, link an image, and load that image from memory. Returns |
4dfae1bf AW |
30 | a procedure." |
31 | (let ((asm (make-assembler))) | |
32 | (emit-text asm instructions) | |
33 | (load-thunk-from-memory (link-assembly asm #:page-aligned? #f)))) | |
34 | ||
e78991aa AW |
35 | (define-syntax-rule (assert-equal val expr) |
36 | (let ((x val)) | |
37 | (pass-if (object->string x) (equal? expr x)))) | |
38 | ||
39 | (define (return-constant val) | |
2a4daafd AW |
40 | (assemble-program `((begin-program foo |
41 | ((name . foo))) | |
7396d216 AW |
42 | (begin-standard-arity () 2 #f) |
43 | (load-constant 1 ,val) | |
44 | (return 1) | |
3185c907 | 45 | (end-arity) |
e78991aa AW |
46 | (end-program)))) |
47 | ||
48 | (define-syntax-rule (assert-constants val ...) | |
49 | (begin | |
50 | (assert-equal val ((return-constant val))) | |
51 | ...)) | |
52 | ||
53 | (with-test-prefix "load-constant" | |
54 | (assert-constants | |
55 | 1 | |
56 | -1 | |
57 | 0 | |
58 | most-positive-fixnum | |
59 | most-negative-fixnum | |
60 | #t | |
61 | #\c | |
62 | (integer->char 16000) | |
63 | 3.14 | |
64 | "foo" | |
65 | 'foo | |
66 | #:foo | |
67 | "æ" ;; a non-ASCII Latin-1 string | |
68 | "λ" ;; non-ascii, non-latin-1 | |
69 | '(1 . 2) | |
70 | '(1 2 3 4) | |
71 | #(1 2 3) | |
72 | #("foo" "bar" 'baz) | |
7bfbc7b1 AW |
73 | #vu8() |
74 | #vu8(1 2 3 4 128 129 130) | |
75 | #u32() | |
76 | #u32(1 2 3 4 128 129 130 255 1000) | |
77 | ;; FIXME: Add more tests for arrays (uniform and otherwise) | |
e78991aa AW |
78 | )) |
79 | ||
80 | (with-test-prefix "static procedure" | |
81 | (assert-equal 42 | |
2a4daafd AW |
82 | (((assemble-program `((begin-program foo |
83 | ((name . foo))) | |
7396d216 AW |
84 | (begin-standard-arity () 2 #f) |
85 | (load-static-procedure 1 bar) | |
86 | (return 1) | |
3185c907 | 87 | (end-arity) |
e78991aa | 88 | (end-program) |
2a4daafd AW |
89 | (begin-program bar |
90 | ((name . bar))) | |
7396d216 AW |
91 | (begin-standard-arity () 2 #f) |
92 | (load-constant 1 42) | |
93 | (return 1) | |
3185c907 | 94 | (end-arity) |
e78991aa AW |
95 | (end-program))))))) |
96 | ||
97 | (with-test-prefix "loop" | |
98 | (assert-equal (* 999 500) | |
99 | (let ((sumto | |
100 | (assemble-program | |
101 | ;; 0: limit | |
102 | ;; 1: n | |
103 | ;; 2: accum | |
2a4daafd AW |
104 | '((begin-program countdown |
105 | ((name . countdown))) | |
7396d216 | 106 | (begin-standard-arity (x) 4 #f) |
e78991aa AW |
107 | (br fix-body) |
108 | (label loop-head) | |
af95414f | 109 | (br-if-= 2 1 #f out) |
7396d216 AW |
110 | (add 3 2 3) |
111 | (add1 2 2) | |
e78991aa AW |
112 | (br loop-head) |
113 | (label fix-body) | |
e78991aa | 114 | (load-constant 2 0) |
7396d216 | 115 | (load-constant 3 0) |
e78991aa AW |
116 | (br loop-head) |
117 | (label out) | |
7396d216 | 118 | (return 3) |
3185c907 | 119 | (end-arity) |
e78991aa AW |
120 | (end-program))))) |
121 | (sumto 1000)))) | |
122 | ||
123 | (with-test-prefix "accum" | |
124 | (assert-equal (+ 1 2 3) | |
125 | (let ((make-accum | |
126 | (assemble-program | |
127 | ;; 0: elt | |
128 | ;; 1: tail | |
129 | ;; 2: head | |
2a4daafd AW |
130 | '((begin-program make-accum |
131 | ((name . make-accum))) | |
7396d216 AW |
132 | (begin-standard-arity () 3 #f) |
133 | (load-constant 1 0) | |
134 | (box 1 1) | |
135 | (make-closure 2 accum 1) | |
136 | (free-set! 2 1 0) | |
137 | (return 2) | |
3185c907 | 138 | (end-arity) |
e78991aa | 139 | (end-program) |
2a4daafd AW |
140 | (begin-program accum |
141 | ((name . accum))) | |
7396d216 AW |
142 | (begin-standard-arity (x) 4 #f) |
143 | (free-ref 2 0 0) | |
144 | (box-ref 3 2) | |
145 | (add 3 3 1) | |
146 | (box-set! 2 3) | |
147 | (return 3) | |
3185c907 | 148 | (end-arity) |
e78991aa AW |
149 | (end-program))))) |
150 | (let ((accum (make-accum))) | |
151 | (accum 1) | |
152 | (accum 2) | |
153 | (accum 3))))) | |
154 | ||
155 | (with-test-prefix "call" | |
156 | (assert-equal 42 | |
157 | (let ((call ;; (lambda (x) (x)) | |
158 | (assemble-program | |
2a4daafd AW |
159 | '((begin-program call |
160 | ((name . call))) | |
af95414f | 161 | (begin-standard-arity (f) 7 #f) |
286a0fb3 | 162 | (mov 5 1) |
af95414f AW |
163 | (call 5 1) |
164 | (receive 2 5 7) | |
165 | (return 2) | |
3185c907 | 166 | (end-arity) |
e78991aa AW |
167 | (end-program))))) |
168 | (call (lambda () 42)))) | |
169 | ||
170 | (assert-equal 6 | |
171 | (let ((call-with-3 ;; (lambda (x) (x 3)) | |
172 | (assemble-program | |
2a4daafd AW |
173 | '((begin-program call-with-3 |
174 | ((name . call-with-3))) | |
af95414f | 175 | (begin-standard-arity (f) 7 #f) |
286a0fb3 AW |
176 | (mov 5 1) |
177 | (load-constant 6 3) | |
af95414f AW |
178 | (call 5 2) |
179 | (receive 2 5 7) | |
180 | (return 2) | |
3185c907 | 181 | (end-arity) |
e78991aa AW |
182 | (end-program))))) |
183 | (call-with-3 (lambda (x) (* x 2)))))) | |
184 | ||
185 | (with-test-prefix "tail-call" | |
186 | (assert-equal 3 | |
187 | (let ((call ;; (lambda (x) (x)) | |
188 | (assemble-program | |
2a4daafd AW |
189 | '((begin-program call |
190 | ((name . call))) | |
7396d216 | 191 | (begin-standard-arity (f) 2 #f) |
af95414f AW |
192 | (mov 0 1) |
193 | (tail-call 1) | |
3185c907 | 194 | (end-arity) |
e78991aa AW |
195 | (end-program))))) |
196 | (call (lambda () 3)))) | |
197 | ||
198 | (assert-equal 6 | |
199 | (let ((call-with-3 ;; (lambda (x) (x 3)) | |
200 | (assemble-program | |
2a4daafd AW |
201 | '((begin-program call-with-3 |
202 | ((name . call-with-3))) | |
af95414f AW |
203 | (begin-standard-arity (f) 2 #f) |
204 | (mov 0 1) ;; R0 <- R1 | |
205 | (load-constant 1 3) ;; R1 <- 3 | |
206 | (tail-call 2) | |
3185c907 | 207 | (end-arity) |
e78991aa AW |
208 | (end-program))))) |
209 | (call-with-3 (lambda (x) (* x 2)))))) | |
210 | ||
211 | (with-test-prefix "cached-toplevel-ref" | |
212 | (assert-equal 5.0 | |
213 | (let ((get-sqrt-trampoline | |
214 | (assemble-program | |
2a4daafd AW |
215 | '((begin-program get-sqrt-trampoline |
216 | ((name . get-sqrt-trampoline))) | |
7396d216 | 217 | (begin-standard-arity () 2 #f) |
af95414f | 218 | (current-module 1) |
7396d216 AW |
219 | (cache-current-module! 1 sqrt-scope) |
220 | (load-static-procedure 1 sqrt-trampoline) | |
221 | (return 1) | |
3185c907 | 222 | (end-arity) |
e78991aa AW |
223 | (end-program) |
224 | ||
2a4daafd AW |
225 | (begin-program sqrt-trampoline |
226 | ((name . sqrt-trampoline))) | |
7396d216 | 227 | (begin-standard-arity (x) 3 #f) |
af95414f AW |
228 | (cached-toplevel-box 2 sqrt-scope sqrt #t) |
229 | (box-ref 0 2) | |
230 | (tail-call 2) | |
3185c907 | 231 | (end-arity) |
e78991aa AW |
232 | (end-program))))) |
233 | ((get-sqrt-trampoline) 25.0)))) | |
234 | ||
235 | (define *top-val* 0) | |
236 | ||
237 | (with-test-prefix "cached-toplevel-set!" | |
238 | (let ((prev *top-val*)) | |
239 | (assert-equal (1+ prev) | |
240 | (let ((make-top-incrementor | |
241 | (assemble-program | |
2a4daafd AW |
242 | '((begin-program make-top-incrementor |
243 | ((name . make-top-incrementor))) | |
7396d216 | 244 | (begin-standard-arity () 2 #f) |
af95414f | 245 | (current-module 1) |
7396d216 AW |
246 | (cache-current-module! 1 top-incrementor) |
247 | (load-static-procedure 1 top-incrementor) | |
248 | (return 1) | |
3185c907 | 249 | (end-arity) |
e78991aa AW |
250 | (end-program) |
251 | ||
2a4daafd AW |
252 | (begin-program top-incrementor |
253 | ((name . top-incrementor))) | |
af95414f AW |
254 | (begin-standard-arity () 3 #f) |
255 | (cached-toplevel-box 1 top-incrementor *top-val* #t) | |
256 | (box-ref 2 1) | |
257 | (add1 2 2) | |
258 | (box-set! 1 2) | |
84cc4127 MW |
259 | (reset-frame 1) |
260 | (return-values) | |
3185c907 | 261 | (end-arity) |
e78991aa AW |
262 | (end-program))))) |
263 | ((make-top-incrementor)) | |
264 | *top-val*)))) | |
265 | ||
266 | (with-test-prefix "cached-module-ref" | |
267 | (assert-equal 5.0 | |
268 | (let ((get-sqrt-trampoline | |
269 | (assemble-program | |
2a4daafd AW |
270 | '((begin-program get-sqrt-trampoline |
271 | ((name . get-sqrt-trampoline))) | |
7396d216 AW |
272 | (begin-standard-arity () 2 #f) |
273 | (load-static-procedure 1 sqrt-trampoline) | |
274 | (return 1) | |
3185c907 | 275 | (end-arity) |
e78991aa AW |
276 | (end-program) |
277 | ||
2a4daafd AW |
278 | (begin-program sqrt-trampoline |
279 | ((name . sqrt-trampoline))) | |
7396d216 | 280 | (begin-standard-arity (x) 3 #f) |
af95414f AW |
281 | (cached-module-box 2 (guile) sqrt #t #t) |
282 | (box-ref 0 2) | |
283 | (tail-call 2) | |
3185c907 | 284 | (end-arity) |
e78991aa AW |
285 | (end-program))))) |
286 | ((get-sqrt-trampoline) 25.0)))) | |
287 | ||
288 | (with-test-prefix "cached-module-set!" | |
289 | (let ((prev *top-val*)) | |
290 | (assert-equal (1+ prev) | |
291 | (let ((make-top-incrementor | |
292 | (assemble-program | |
2a4daafd AW |
293 | '((begin-program make-top-incrementor |
294 | ((name . make-top-incrementor))) | |
7396d216 AW |
295 | (begin-standard-arity () 2 #f) |
296 | (load-static-procedure 1 top-incrementor) | |
297 | (return 1) | |
3185c907 | 298 | (end-arity) |
e78991aa AW |
299 | (end-program) |
300 | ||
2a4daafd AW |
301 | (begin-program top-incrementor |
302 | ((name . top-incrementor))) | |
af95414f | 303 | (begin-standard-arity () 3 #f) |
691697de | 304 | (cached-module-box 1 (tests bytecode) *top-val* #f #t) |
af95414f AW |
305 | (box-ref 2 1) |
306 | (add1 2 2) | |
307 | (box-set! 1 2) | |
308 | (return 2) | |
3185c907 | 309 | (end-arity) |
e78991aa AW |
310 | (end-program))))) |
311 | ((make-top-incrementor)) | |
312 | *top-val*)))) | |
cb86cbd7 AW |
313 | |
314 | (with-test-prefix "debug contexts" | |
315 | (let ((return-3 (assemble-program | |
2a4daafd | 316 | '((begin-program return-3 ((name . return-3))) |
7396d216 AW |
317 | (begin-standard-arity () 2 #f) |
318 | (load-constant 1 3) | |
319 | (return 1) | |
3185c907 | 320 | (end-arity) |
cb86cbd7 AW |
321 | (end-program))))) |
322 | (pass-if "program name" | |
d1100525 | 323 | (and=> (find-program-debug-info (program-code return-3)) |
cb86cbd7 AW |
324 | (lambda (pdi) |
325 | (equal? (program-debug-info-name pdi) | |
326 | 'return-3)))) | |
327 | ||
328 | (pass-if "program address" | |
d1100525 | 329 | (and=> (find-program-debug-info (program-code return-3)) |
cb86cbd7 AW |
330 | (lambda (pdi) |
331 | (equal? (program-debug-info-addr pdi) | |
d1100525 | 332 | (program-code return-3))))))) |
e65f80af AW |
333 | |
334 | (with-test-prefix "procedure name" | |
335 | (pass-if-equal 'foo | |
336 | (procedure-name | |
337 | (assemble-program | |
2a4daafd | 338 | '((begin-program foo ((name . foo))) |
7396d216 AW |
339 | (begin-standard-arity () 2 #f) |
340 | (load-constant 1 42) | |
341 | (return 1) | |
3185c907 | 342 | (end-arity) |
e65f80af | 343 | (end-program)))))) |
eb2bc00f AW |
344 | |
345 | (with-test-prefix "simply procedure arity" | |
346 | (pass-if-equal "#<procedure foo ()>" | |
347 | (object->string | |
348 | (assemble-program | |
349 | '((begin-program foo ((name . foo))) | |
7396d216 AW |
350 | (begin-standard-arity () 2 #f) |
351 | (load-constant 1 42) | |
352 | (return 1) | |
eb2bc00f AW |
353 | (end-arity) |
354 | (end-program))))) | |
355 | (pass-if-equal "#<procedure foo (x y)>" | |
356 | (object->string | |
357 | (assemble-program | |
358 | '((begin-program foo ((name . foo))) | |
7396d216 AW |
359 | (begin-standard-arity (x y) 3 #f) |
360 | (load-constant 1 42) | |
361 | (return 1) | |
eb2bc00f AW |
362 | (end-arity) |
363 | (end-program))))) | |
364 | ||
365 | (pass-if-equal "#<procedure foo (x #:optional y . z)>" | |
366 | (object->string | |
367 | (assemble-program | |
368 | '((begin-program foo ((name . foo))) | |
7396d216 AW |
369 | (begin-opt-arity (x) (y) z 4 #f) |
370 | (load-constant 1 42) | |
371 | (return 1) | |
eb2bc00f AW |
372 | (end-arity) |
373 | (end-program)))))) | |
bf8328ec AW |
374 | |
375 | (with-test-prefix "procedure docstrings" | |
376 | (pass-if-equal "qux qux" | |
377 | (procedure-documentation | |
378 | (assemble-program | |
379 | '((begin-program foo ((name . foo) (documentation . "qux qux"))) | |
7396d216 AW |
380 | (begin-standard-arity () 2 #f) |
381 | (load-constant 1 42) | |
382 | (return 1) | |
bf8328ec AW |
383 | (end-arity) |
384 | (end-program)))))) | |
c4c098e3 AW |
385 | |
386 | (with-test-prefix "procedure properties" | |
387 | ;; No properties. | |
388 | (pass-if-equal '() | |
389 | (procedure-properties | |
390 | (assemble-program | |
391 | '((begin-program foo ()) | |
7396d216 AW |
392 | (begin-standard-arity () 2 #f) |
393 | (load-constant 1 42) | |
394 | (return 1) | |
c4c098e3 AW |
395 | (end-arity) |
396 | (end-program))))) | |
397 | ||
398 | ;; Name and docstring (which actually don't go out to procprops). | |
399 | (pass-if-equal '((name . foo) | |
400 | (documentation . "qux qux")) | |
401 | (procedure-properties | |
402 | (assemble-program | |
403 | '((begin-program foo ((name . foo) (documentation . "qux qux"))) | |
7396d216 AW |
404 | (begin-standard-arity () 2 #f) |
405 | (load-constant 1 42) | |
406 | (return 1) | |
c4c098e3 AW |
407 | (end-arity) |
408 | (end-program))))) | |
409 | ||
410 | ;; A property that actually needs serialization. | |
411 | (pass-if-equal '((name . foo) | |
412 | (documentation . "qux qux") | |
413 | (moo . "mooooooooooooo")) | |
414 | (procedure-properties | |
415 | (assemble-program | |
416 | '((begin-program foo ((name . foo) | |
417 | (documentation . "qux qux") | |
418 | (moo . "mooooooooooooo"))) | |
7396d216 AW |
419 | (begin-standard-arity () 2 #f) |
420 | (load-constant 1 42) | |
421 | (return 1) | |
c4c098e3 AW |
422 | (end-arity) |
423 | (end-program))))) | |
424 | ||
425 | ;; Procedure-name still works in this case. | |
426 | (pass-if-equal 'foo | |
427 | (procedure-name | |
428 | (assemble-program | |
429 | '((begin-program foo ((name . foo) | |
430 | (documentation . "qux qux") | |
431 | (moo . "mooooooooooooo"))) | |
7396d216 AW |
432 | (begin-standard-arity () 2 #f) |
433 | (load-constant 1 42) | |
434 | (return 1) | |
c4c098e3 AW |
435 | (end-arity) |
436 | (end-program)))))) |