1 ;;;; Low-level tests of the bytecode assembler -*- mode: scheme; coding: utf-8; -*-
3 ;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014 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)
124 (with-test-prefix "accum"
125 (assert-equal (+ 1 2 3)
131 '((begin-program make-accum
132 ((name . make-accum)))
133 (begin-standard-arity () 3 #f)
136 (make-closure 2 accum 1)
143 (begin-standard-arity (x) 4 #f)
152 (let ((accum (make-accum)))
157 (with-test-prefix "call"
159 (let ((call ;; (lambda (x) (x))
161 '((begin-program call
163 (begin-standard-arity (f) 7 #f)
171 (call (lambda () 42))))
174 (let ((call-with-3 ;; (lambda (x) (x 3))
176 '((begin-program call-with-3
177 ((name . call-with-3)))
178 (begin-standard-arity (f) 7 #f)
187 (call-with-3 (lambda (x) (* x 2))))))
189 (with-test-prefix "tail-call"
191 (let ((call ;; (lambda (x) (x))
193 '((begin-program call
195 (begin-standard-arity (f) 2 #f)
201 (call (lambda () 3))))
204 (let ((call-with-3 ;; (lambda (x) (x 3))
206 '((begin-program call-with-3
207 ((name . call-with-3)))
208 (begin-standard-arity (f) 2 #f)
210 (mov 0 1) ;; R0 <- R1
211 (load-constant 1 3) ;; R1 <- 3
215 (call-with-3 (lambda (x) (* x 2))))))
217 (with-test-prefix "cached-toplevel-ref"
219 (let ((get-sqrt-trampoline
221 '((begin-program get-sqrt-trampoline
222 ((name . get-sqrt-trampoline)))
223 (begin-standard-arity () 2 #f)
225 (cache-current-module! 1 sqrt-scope)
226 (load-static-procedure 1 sqrt-trampoline)
231 (begin-program sqrt-trampoline
232 ((name . sqrt-trampoline)))
233 (begin-standard-arity (x) 3 #f)
235 (cached-toplevel-box 2 sqrt-scope sqrt #t)
240 ((get-sqrt-trampoline) 25.0))))
244 (with-test-prefix "cached-toplevel-set!"
245 (let ((prev *top-val*))
246 (assert-equal (1+ prev)
247 (let ((make-top-incrementor
249 '((begin-program make-top-incrementor
250 ((name . make-top-incrementor)))
251 (begin-standard-arity () 2 #f)
253 (cache-current-module! 1 top-incrementor)
254 (load-static-procedure 1 top-incrementor)
259 (begin-program top-incrementor
260 ((name . top-incrementor)))
261 (begin-standard-arity () 3 #f)
262 (cached-toplevel-box 1 top-incrementor *top-val* #t)
270 ((make-top-incrementor))
273 (with-test-prefix "cached-module-ref"
275 (let ((get-sqrt-trampoline
277 '((begin-program get-sqrt-trampoline
278 ((name . get-sqrt-trampoline)))
279 (begin-standard-arity () 2 #f)
280 (load-static-procedure 1 sqrt-trampoline)
285 (begin-program sqrt-trampoline
286 ((name . sqrt-trampoline)))
287 (begin-standard-arity (x) 3 #f)
289 (cached-module-box 2 (guile) sqrt #t #t)
294 ((get-sqrt-trampoline) 25.0))))
296 (with-test-prefix "cached-module-set!"
297 (let ((prev *top-val*))
298 (assert-equal (1+ prev)
299 (let ((make-top-incrementor
301 '((begin-program make-top-incrementor
302 ((name . make-top-incrementor)))
303 (begin-standard-arity () 2 #f)
304 (load-static-procedure 1 top-incrementor)
309 (begin-program top-incrementor
310 ((name . top-incrementor)))
311 (begin-standard-arity () 3 #f)
312 (cached-module-box 1 (tests bytecode) *top-val* #f #t)
319 ((make-top-incrementor))
322 (with-test-prefix "debug contexts"
323 (let ((return-3 (assemble-program
324 '((begin-program return-3 ((name . return-3)))
325 (begin-standard-arity () 2 #f)
330 (pass-if "program name"
331 (and=> (find-program-debug-info (program-code return-3))
333 (equal? (program-debug-info-name pdi)
336 (pass-if "program address"
337 (and=> (find-program-debug-info (program-code return-3))
339 (equal? (program-debug-info-addr pdi)
340 (program-code return-3)))))))
342 (with-test-prefix "procedure name"
346 '((begin-program foo ((name . foo)))
347 (begin-standard-arity () 2 #f)
353 (with-test-prefix "simple procedure arity"
354 (pass-if-equal "#<procedure foo ()>"
357 '((begin-program foo ((name . foo)))
358 (begin-standard-arity () 2 #f)
363 (pass-if-equal "#<procedure foo (x y)>"
366 '((begin-program foo ((name . foo)))
367 (begin-standard-arity (x y) 3 #f)
375 (pass-if-equal "#<procedure foo (x #:optional y . z)>"
378 '((begin-program foo ((name . foo)))
379 (begin-opt-arity (x) (y) z 4 #f)
388 (with-test-prefix "procedure docstrings"
389 (pass-if-equal "qux qux"
390 (procedure-documentation
392 '((begin-program foo ((name . foo) (documentation . "qux qux")))
393 (begin-standard-arity () 2 #f)
399 (with-test-prefix "procedure properties"
402 (procedure-properties
404 '((begin-program foo ())
405 (begin-standard-arity () 2 #f)
411 ;; Name and docstring (which actually don't go out to procprops).
412 (pass-if-equal '((name . foo)
413 (documentation . "qux qux"))
414 (procedure-properties
416 '((begin-program foo ((name . foo) (documentation . "qux qux")))
417 (begin-standard-arity () 2 #f)
423 ;; A property that actually needs serialization.
424 (pass-if-equal '((name . foo)
425 (documentation . "qux qux")
426 (moo . "mooooooooooooo"))
427 (procedure-properties
429 '((begin-program foo ((name . foo)
430 (documentation . "qux qux")
431 (moo . "mooooooooooooo")))
432 (begin-standard-arity () 2 #f)
438 ;; Procedure-name still works in this case.
442 '((begin-program foo ((name . foo)
443 (documentation . "qux qux")
444 (moo . "mooooooooooooo")))
445 (begin-standard-arity () 2 #f)