1 ;;;; Low-level tests of the bytecode assembler -*- mode: scheme; coding: utf-8; -*-
3 ;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
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.
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.
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
19 (define-module (tests bytecode)
20 #:use-module (test-suite lib)
21 #:use-module (system vm assembler)
22 #:use-module (system vm program)
23 #:use-module (system vm loader)
24 #:use-module (system vm linker)
25 #:use-module (system vm debug))
27 (define (assemble-program instructions)
28 "Take the sequence of instructions @var{instructions}, assemble them
29 into bytecode, link an image, and load that image from memory. Returns
31 (let ((asm (make-assembler)))
32 (emit-text asm instructions)
33 (load-thunk-from-memory (link-assembly asm #:page-aligned? #f))))
35 (define-syntax-rule (assert-equal val expr)
37 (pass-if (object->string x) (equal? expr x))))
39 (define (return-constant val)
40 (assemble-program `((begin-program foo
42 (begin-standard-arity () 2 #f)
43 (load-constant 1 ,val)
48 (define-syntax-rule (assert-constants val ...)
50 (assert-equal val ((return-constant val)))
53 (with-test-prefix "load-constant"
67 "æ" ;; a non-ASCII Latin-1 string
68 "λ" ;; non-ascii, non-latin-1
74 #vu8(1 2 3 4 128 129 130)
76 #u32(1 2 3 4 128 129 130 255 1000)
77 ;; FIXME: Add more tests for arrays (uniform and otherwise)
80 (with-test-prefix "static procedure"
82 (((assemble-program `((begin-program foo
84 (begin-standard-arity () 2 #f)
85 (load-static-procedure 1 bar)
91 (begin-standard-arity () 2 #f)
97 (with-test-prefix "loop"
98 (assert-equal (* 999 500)
104 '((begin-program countdown
105 ((name . countdown)))
106 (begin-standard-arity (x) 4 #f)
123 (with-test-prefix "accum"
124 (assert-equal (+ 1 2 3)
130 '((begin-program make-accum
131 ((name . make-accum)))
132 (begin-standard-arity () 3 #f)
135 (make-closure 2 accum 1)
142 (begin-standard-arity (x) 4 #f)
150 (let ((accum (make-accum)))
155 (with-test-prefix "call"
157 (let ((call ;; (lambda (x) (x))
159 '((begin-program call
161 (begin-standard-arity (f) 7 #f)
168 (call (lambda () 42))))
171 (let ((call-with-3 ;; (lambda (x) (x 3))
173 '((begin-program call-with-3
174 ((name . call-with-3)))
175 (begin-standard-arity (f) 7 #f)
183 (call-with-3 (lambda (x) (* x 2))))))
185 (with-test-prefix "tail-call"
187 (let ((call ;; (lambda (x) (x))
189 '((begin-program call
191 (begin-standard-arity (f) 2 #f)
196 (call (lambda () 3))))
199 (let ((call-with-3 ;; (lambda (x) (x 3))
201 '((begin-program call-with-3
202 ((name . call-with-3)))
203 (begin-standard-arity (f) 2 #f)
204 (mov 0 1) ;; R0 <- R1
205 (load-constant 1 3) ;; R1 <- 3
209 (call-with-3 (lambda (x) (* x 2))))))
211 (with-test-prefix "cached-toplevel-ref"
213 (let ((get-sqrt-trampoline
215 '((begin-program get-sqrt-trampoline
216 ((name . get-sqrt-trampoline)))
217 (begin-standard-arity () 2 #f)
219 (cache-current-module! 1 sqrt-scope)
220 (load-static-procedure 1 sqrt-trampoline)
225 (begin-program sqrt-trampoline
226 ((name . sqrt-trampoline)))
227 (begin-standard-arity (x) 3 #f)
228 (cached-toplevel-box 2 sqrt-scope sqrt #t)
233 ((get-sqrt-trampoline) 25.0))))
237 (with-test-prefix "cached-toplevel-set!"
238 (let ((prev *top-val*))
239 (assert-equal (1+ prev)
240 (let ((make-top-incrementor
242 '((begin-program make-top-incrementor
243 ((name . make-top-incrementor)))
244 (begin-standard-arity () 2 #f)
246 (cache-current-module! 1 top-incrementor)
247 (load-static-procedure 1 top-incrementor)
252 (begin-program top-incrementor
253 ((name . top-incrementor)))
254 (begin-standard-arity () 3 #f)
255 (cached-toplevel-box 1 top-incrementor *top-val* #t)
263 ((make-top-incrementor))
266 (with-test-prefix "cached-module-ref"
268 (let ((get-sqrt-trampoline
270 '((begin-program get-sqrt-trampoline
271 ((name . get-sqrt-trampoline)))
272 (begin-standard-arity () 2 #f)
273 (load-static-procedure 1 sqrt-trampoline)
278 (begin-program sqrt-trampoline
279 ((name . sqrt-trampoline)))
280 (begin-standard-arity (x) 3 #f)
281 (cached-module-box 2 (guile) sqrt #t #t)
286 ((get-sqrt-trampoline) 25.0))))
288 (with-test-prefix "cached-module-set!"
289 (let ((prev *top-val*))
290 (assert-equal (1+ prev)
291 (let ((make-top-incrementor
293 '((begin-program make-top-incrementor
294 ((name . make-top-incrementor)))
295 (begin-standard-arity () 2 #f)
296 (load-static-procedure 1 top-incrementor)
301 (begin-program top-incrementor
302 ((name . top-incrementor)))
303 (begin-standard-arity () 3 #f)
304 (cached-module-box 1 (tests bytecode) *top-val* #f #t)
311 ((make-top-incrementor))
314 (with-test-prefix "debug contexts"
315 (let ((return-3 (assemble-program
316 '((begin-program return-3 ((name . return-3)))
317 (begin-standard-arity () 2 #f)
322 (pass-if "program name"
323 (and=> (find-program-debug-info (program-code return-3))
325 (equal? (program-debug-info-name pdi)
328 (pass-if "program address"
329 (and=> (find-program-debug-info (program-code return-3))
331 (equal? (program-debug-info-addr pdi)
332 (program-code return-3)))))))
334 (with-test-prefix "procedure name"
338 '((begin-program foo ((name . foo)))
339 (begin-standard-arity () 2 #f)
345 (with-test-prefix "simply procedure arity"
346 (pass-if-equal "#<procedure foo ()>"
349 '((begin-program foo ((name . foo)))
350 (begin-standard-arity () 2 #f)
355 (pass-if-equal "#<procedure foo (x y)>"
358 '((begin-program foo ((name . foo)))
359 (begin-standard-arity (x y) 3 #f)
365 (pass-if-equal "#<procedure foo (x #:optional y . z)>"
368 '((begin-program foo ((name . foo)))
369 (begin-opt-arity (x) (y) z 4 #f)
375 (with-test-prefix "procedure docstrings"
376 (pass-if-equal "qux qux"
377 (procedure-documentation
379 '((begin-program foo ((name . foo) (documentation . "qux qux")))
380 (begin-standard-arity () 2 #f)
386 (with-test-prefix "procedure properties"
389 (procedure-properties
391 '((begin-program foo ())
392 (begin-standard-arity () 2 #f)
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
403 '((begin-program foo ((name . foo) (documentation . "qux qux")))
404 (begin-standard-arity () 2 #f)
410 ;; A property that actually needs serialization.
411 (pass-if-equal '((name . foo)
412 (documentation . "qux qux")
413 (moo . "mooooooooooooo"))
414 (procedure-properties
416 '((begin-program foo ((name . foo)
417 (documentation . "qux qux")
418 (moo . "mooooooooooooo")))
419 (begin-standard-arity () 2 #f)
425 ;; Procedure-name still works in this case.
429 '((begin-program foo ((name . foo)
430 (documentation . "qux qux")
431 (moo . "mooooooooooooo")))
432 (begin-standard-arity () 2 #f)