-;;;; Low-level tests of the RTL assembler -*- mode: scheme; coding: utf-8; -*-
+;;;; Low-level tests of the bytecode assembler -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-(define-module (tests rtl)
+(define-module (tests bytecode)
#:use-module (test-suite lib)
#:use-module (system vm assembler)
#:use-module (system vm program)
+ #:use-module (system vm loader)
+ #:use-module (system vm linker)
#:use-module (system vm debug))
+(define (assemble-program instructions)
+ "Take the sequence of instructions @var{instructions}, assemble them
+into bytecode, link an image, and load that image from memory. Returns
+a procedure."
+ (let ((asm (make-assembler)))
+ (emit-text asm instructions)
+ (load-thunk-from-memory (link-assembly asm #:page-aligned? #f))))
+
(define-syntax-rule (assert-equal val expr)
(let ((x val))
(pass-if (object->string x) (equal? expr x))))
(define (return-constant val)
(assemble-program `((begin-program foo
((name . foo)))
- (standard-prelude 0 1 #f)
- (load-constant 0 ,val)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 ,val)
+ (return 1)
+ (end-arity)
(end-program))))
(define-syntax-rule (assert-constants val ...)
'(1 2 3 4)
#(1 2 3)
#("foo" "bar" 'baz)
- ;; FIXME: Add tests for arrays (uniform and otherwise)
+ #vu8()
+ #vu8(1 2 3 4 128 129 130)
+ #u32()
+ #u32(1 2 3 4 128 129 130 255 1000)
+ ;; FIXME: Add more tests for arrays (uniform and otherwise)
))
(with-test-prefix "static procedure"
(assert-equal 42
(((assemble-program `((begin-program foo
((name . foo)))
- (standard-prelude 0 1 #f)
- (load-static-procedure 0 bar)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-static-procedure 1 bar)
+ (return 1)
+ (end-arity)
(end-program)
(begin-program bar
((name . bar)))
- (standard-prelude 0 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
(end-program)))))))
(with-test-prefix "loop"
;; 2: accum
'((begin-program countdown
((name . countdown)))
- (standard-prelude 1 3 #f)
+ (begin-standard-arity (x) 4 #f)
+ (definition x 1)
(br fix-body)
(label loop-head)
- (br-if-= 1 0 out)
- (add 2 1 2)
- (add1 1 1)
+ (br-if-= 2 1 #f out)
+ (add 3 2 3)
+ (add1 2 2)
(br loop-head)
(label fix-body)
- (load-constant 1 0)
(load-constant 2 0)
+ (load-constant 3 0)
(br loop-head)
(label out)
- (return 2)
+ (return 3)
+ (end-arity)
(end-program)))))
(sumto 1000))))
;; 2: head
'((begin-program make-accum
((name . make-accum)))
- (standard-prelude 0 2 #f)
- (load-constant 0 0)
- (box 0 0)
- (make-closure 1 accum (0))
- (return 1)
+ (begin-standard-arity () 3 #f)
+ (load-constant 1 0)
+ (box 1 1)
+ (make-closure 2 accum 1)
+ (free-set! 2 1 0)
+ (return 2)
+ (end-arity)
(end-program)
(begin-program accum
((name . accum)))
- (standard-prelude 1 3 #f)
- (free-ref 1 0)
- (box-ref 2 1)
- (add 2 2 0)
- (box-set! 1 2)
- (return 2)
+ (begin-standard-arity (x) 4 #f)
+ (definition x 1)
+ (free-ref 2 0 0)
+ (box-ref 3 2)
+ (add 3 3 1)
+ (box-set! 2 3)
+ (return 3)
+ (end-arity)
(end-program)))))
(let ((accum (make-accum)))
(accum 1)
(assemble-program
'((begin-program call
((name . call)))
- (standard-prelude 1 1 #f)
- (call 1 0 ())
- (return 1) ;; MVRA from call
- (return 1) ;; RA from call
+ (begin-standard-arity (f) 7 #f)
+ (definition f 1)
+ (mov 5 1)
+ (call 5 1)
+ (receive 2 5 7)
+ (return 2)
+ (end-arity)
(end-program)))))
(call (lambda () 42))))
(assemble-program
'((begin-program call-with-3
((name . call-with-3)))
- (standard-prelude 1 2 #f)
- (load-constant 1 3)
- (call 2 0 (1))
- (return 2) ;; MVRA from call
- (return 2) ;; RA from call
+ (begin-standard-arity (f) 7 #f)
+ (definition f 1)
+ (mov 5 1)
+ (load-constant 6 3)
+ (call 5 2)
+ (receive 2 5 7)
+ (return 2)
+ (end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
(assemble-program
'((begin-program call
((name . call)))
- (standard-prelude 1 1 #f)
- (tail-call 0 0)
+ (begin-standard-arity (f) 2 #f)
+ (definition f 1)
+ (mov 0 1)
+ (tail-call 1)
+ (end-arity)
(end-program)))))
(call (lambda () 3))))
(assemble-program
'((begin-program call-with-3
((name . call-with-3)))
- (standard-prelude 1 2 #f)
- (mov 1 0) ;; R1 <- R0
- (load-constant 0 3) ;; R0 <- 3
- (tail-call 1 1)
+ (begin-standard-arity (f) 2 #f)
+ (definition f 1)
+ (mov 0 1) ;; R0 <- R1
+ (load-constant 1 3) ;; R1 <- 3
+ (tail-call 2)
+ (end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
(assemble-program
'((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline)))
- (standard-prelude 0 1 #f)
- (cache-current-module! 0 sqrt-scope)
- (load-static-procedure 0 sqrt-trampoline)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (current-module 1)
+ (cache-current-module! 1 sqrt-scope)
+ (load-static-procedure 1 sqrt-trampoline)
+ (return 1)
+ (end-arity)
(end-program)
(begin-program sqrt-trampoline
((name . sqrt-trampoline)))
- (standard-prelude 1 2 #f)
- (cached-toplevel-ref 1 sqrt-scope sqrt)
- (tail-call 1 1)
+ (begin-standard-arity (x) 3 #f)
+ (definition x 1)
+ (cached-toplevel-box 2 sqrt-scope sqrt #t)
+ (box-ref 0 2)
+ (tail-call 2)
+ (end-arity)
(end-program)))))
((get-sqrt-trampoline) 25.0))))
(assemble-program
'((begin-program make-top-incrementor
((name . make-top-incrementor)))
- (standard-prelude 0 1 #f)
- (cache-current-module! 0 top-incrementor)
- (load-static-procedure 0 top-incrementor)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (current-module 1)
+ (cache-current-module! 1 top-incrementor)
+ (load-static-procedure 1 top-incrementor)
+ (return 1)
+ (end-arity)
(end-program)
(begin-program top-incrementor
((name . top-incrementor)))
- (standard-prelude 0 1 #f)
- (cached-toplevel-ref 0 top-incrementor *top-val*)
- (add1 0 0)
- (cached-toplevel-set! 0 top-incrementor *top-val*)
- (return/values 0)
+ (begin-standard-arity () 3 #f)
+ (cached-toplevel-box 1 top-incrementor *top-val* #t)
+ (box-ref 2 1)
+ (add1 2 2)
+ (box-set! 1 2)
+ (reset-frame 1)
+ (return-values)
+ (end-arity)
(end-program)))))
((make-top-incrementor))
*top-val*))))
(assemble-program
'((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline)))
- (standard-prelude 0 1 #f)
- (load-static-procedure 0 sqrt-trampoline)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-static-procedure 1 sqrt-trampoline)
+ (return 1)
+ (end-arity)
(end-program)
(begin-program sqrt-trampoline
((name . sqrt-trampoline)))
- (standard-prelude 1 2 #f)
- (cached-module-ref 1 (guile) #t sqrt)
- (tail-call 1 1)
+ (begin-standard-arity (x) 3 #f)
+ (definition x 1)
+ (cached-module-box 2 (guile) sqrt #t #t)
+ (box-ref 0 2)
+ (tail-call 2)
+ (end-arity)
(end-program)))))
((get-sqrt-trampoline) 25.0))))
(assemble-program
'((begin-program make-top-incrementor
((name . make-top-incrementor)))
- (standard-prelude 0 1 #f)
- (load-static-procedure 0 top-incrementor)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-static-procedure 1 top-incrementor)
+ (return 1)
+ (end-arity)
(end-program)
(begin-program top-incrementor
((name . top-incrementor)))
- (standard-prelude 0 1 #f)
- (cached-module-ref 0 (tests rtl) #f *top-val*)
- (add1 0 0)
- (cached-module-set! 0 (tests rtl) #f *top-val*)
- (return 0)
+ (begin-standard-arity () 3 #f)
+ (cached-module-box 1 (tests bytecode) *top-val* #f #t)
+ (box-ref 2 1)
+ (add1 2 2)
+ (box-set! 1 2)
+ (return 2)
+ (end-arity)
(end-program)))))
((make-top-incrementor))
*top-val*))))
(with-test-prefix "debug contexts"
(let ((return-3 (assemble-program
'((begin-program return-3 ((name . return-3)))
- (standard-prelude 0 1 #f)
- (load-constant 0 3)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 3)
+ (return 1)
+ (end-arity)
(end-program)))))
(pass-if "program name"
- (and=> (find-program-debug-info (rtl-program-code return-3))
+ (and=> (find-program-debug-info (program-code return-3))
(lambda (pdi)
(equal? (program-debug-info-name pdi)
'return-3))))
(pass-if "program address"
- (and=> (find-program-debug-info (rtl-program-code return-3))
+ (and=> (find-program-debug-info (program-code return-3))
(lambda (pdi)
(equal? (program-debug-info-addr pdi)
- (rtl-program-code return-3)))))))
+ (program-code return-3)))))))
(with-test-prefix "procedure name"
(pass-if-equal 'foo
(procedure-name
(assemble-program
'((begin-program foo ((name . foo)))
- (standard-prelude 0 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program))))))
+
+(with-test-prefix "simple procedure arity"
+ (pass-if-equal "#<procedure foo ()>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+ (pass-if-equal "#<procedure foo (x y)>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-standard-arity (x y) 3 #f)
+ (definition x 1)
+ (definition y 2)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+
+ (pass-if-equal "#<procedure foo (x #:optional y . z)>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-opt-arity (x) (y) z 4 #f)
+ (definition x 1)
+ (definition y 2)
+ (definition z 3)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program))))))
+
+(with-test-prefix "procedure docstrings"
+ (pass-if-equal "qux qux"
+ (procedure-documentation
+ (assemble-program
+ '((begin-program foo ((name . foo) (documentation . "qux qux")))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program))))))
+
+(with-test-prefix "procedure properties"
+ ;; No properties.
+ (pass-if-equal '()
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ())
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+
+ ;; Name and docstring (which actually don't go out to procprops).
+ (pass-if-equal '((name . foo)
+ (documentation . "qux qux"))
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ((name . foo) (documentation . "qux qux")))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+
+ ;; A property that actually needs serialization.
+ (pass-if-equal '((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo"))
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo")))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+
+ ;; Procedure-name still works in this case.
+ (pass-if-equal 'foo
+ (procedure-name
+ (assemble-program
+ '((begin-program foo ((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo")))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
(end-program))))))
HCoop / bpt / guile.git / blobdiff