mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
e5d7c0f13b
* module/language/cps/compile-bytecode.scm (compile-function): Always define a 'closure binding in slot 0. * module/system/vm/frame.scm (available-bindings): No need to futz around not having a closure binding. * module/system/vm/debug.scm (arity-arguments-alist): Expect a closure binding. * test-suite/tests/rtl.test: Emit definitions for the closure.
463 lines
18 KiB
Scheme
463 lines
18 KiB
Scheme
;;;; Low-level tests of the bytecode assembler -*- mode: scheme; coding: utf-8; -*-
|
|
;;;;
|
|
;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015 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 as published by the Free Software Foundation; either
|
|
;;;; version 3 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; This library is distributed in the hope that it will be useful,
|
|
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;;; Lesser General Public License for more details.
|
|
;;;;
|
|
;;;; You should have received a copy 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 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)))
|
|
(begin-standard-arity () 2 #f)
|
|
(load-constant 0 ,val)
|
|
(return-values 2)
|
|
(end-arity)
|
|
(end-program))))
|
|
|
|
(define-syntax-rule (assert-constants val ...)
|
|
(begin
|
|
(assert-equal val ((return-constant val)))
|
|
...))
|
|
|
|
(with-test-prefix "load-constant"
|
|
(assert-constants
|
|
1
|
|
-1
|
|
0
|
|
most-positive-fixnum
|
|
most-negative-fixnum
|
|
#t
|
|
#\c
|
|
(integer->char 16000)
|
|
3.14
|
|
"foo"
|
|
'foo
|
|
#:foo
|
|
"æ" ;; a non-ASCII Latin-1 string
|
|
"λ" ;; non-ascii, non-latin-1
|
|
'(1 . 2)
|
|
'(1 2 3 4)
|
|
#(1 2 3)
|
|
#("foo" "bar" 'baz)
|
|
#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)))
|
|
(begin-standard-arity () 2 #f)
|
|
(load-static-procedure 0 bar)
|
|
(return-values 2)
|
|
(end-arity)
|
|
(end-program)
|
|
(begin-program bar
|
|
((name . bar)))
|
|
(begin-standard-arity () 2 #f)
|
|
(load-constant 0 42)
|
|
(return-values 2)
|
|
(end-arity)
|
|
(end-program)))))))
|
|
|
|
(with-test-prefix "loop"
|
|
(assert-equal (* 999 500)
|
|
(let ((sumto
|
|
(assemble-program
|
|
;; 0: limit
|
|
;; 1: n
|
|
;; 2: accum
|
|
'((begin-program countdown
|
|
((name . countdown)))
|
|
(begin-standard-arity (x) 4 #f)
|
|
(definition closure 0 scm)
|
|
(definition x 1 scm)
|
|
(br fix-body)
|
|
(label loop-head)
|
|
(br-if-= 1 2 #f out)
|
|
(add 0 1 0)
|
|
(add/immediate 1 1 1)
|
|
(br loop-head)
|
|
(label fix-body)
|
|
(load-constant 1 0)
|
|
(load-constant 0 0)
|
|
(br loop-head)
|
|
(label out)
|
|
(mov 2 0)
|
|
(return-values 2)
|
|
(end-arity)
|
|
(end-program)))))
|
|
(sumto 1000))))
|
|
|
|
(with-test-prefix "accum"
|
|
(assert-equal (+ 1 2 3)
|
|
(let ((make-accum
|
|
(assemble-program
|
|
;; 0: elt
|
|
;; 1: tail
|
|
;; 2: head
|
|
'((begin-program make-accum
|
|
((name . make-accum)))
|
|
(begin-standard-arity () 3 #f)
|
|
(load-constant 1 0)
|
|
(box 1 1)
|
|
(make-closure 0 accum 1)
|
|
(free-set! 0 1 0)
|
|
(mov 1 0)
|
|
(return-values 2)
|
|
(end-arity)
|
|
(end-program)
|
|
(begin-program accum
|
|
((name . accum)))
|
|
(begin-standard-arity (x) 4 #f)
|
|
(definition closure 0 scm)
|
|
(definition x 1 scm)
|
|
(free-ref 1 3 0)
|
|
(box-ref 0 1)
|
|
(add 0 0 2)
|
|
(box-set! 1 0)
|
|
(mov 2 0)
|
|
(return-values 2)
|
|
(end-arity)
|
|
(end-program)))))
|
|
(let ((accum (make-accum)))
|
|
(accum 1)
|
|
(accum 2)
|
|
(accum 3)))))
|
|
|
|
(with-test-prefix "call"
|
|
(assert-equal 42
|
|
(let ((call ;; (lambda (x) (x))
|
|
(assemble-program
|
|
'((begin-program call
|
|
((name . call)))
|
|
(begin-standard-arity (f) 7 #f)
|
|
(definition closure 0 scm)
|
|
(definition f 1 scm)
|
|
(mov 1 5)
|
|
(call 5 1)
|
|
(receive 1 5 7)
|
|
(return-values 2)
|
|
(end-arity)
|
|
(end-program)))))
|
|
(call (lambda () 42))))
|
|
|
|
(assert-equal 6
|
|
(let ((call-with-3 ;; (lambda (x) (x 3))
|
|
(assemble-program
|
|
'((begin-program call-with-3
|
|
((name . call-with-3)))
|
|
(begin-standard-arity (f) 7 #f)
|
|
(definition closure 0 scm)
|
|
(definition f 1 scm)
|
|
(mov 1 5)
|
|
(load-constant 0 3)
|
|
(call 5 2)
|
|
(receive 1 5 7)
|
|
(return-values 2)
|
|
(end-arity)
|
|
(end-program)))))
|
|
(call-with-3 (lambda (x) (* x 2))))))
|
|
|
|
(with-test-prefix "tail-call"
|
|
(assert-equal 3
|
|
(let ((call ;; (lambda (x) (x))
|
|
(assemble-program
|
|
'((begin-program call
|
|
((name . call)))
|
|
(begin-standard-arity (f) 2 #f)
|
|
(definition closure 0 scm)
|
|
(definition f 1 scm)
|
|
(mov 1 0)
|
|
(tail-call 1)
|
|
(end-arity)
|
|
(end-program)))))
|
|
(call (lambda () 3))))
|
|
|
|
(assert-equal 6
|
|
(let ((call-with-3 ;; (lambda (x) (x 3))
|
|
(assemble-program
|
|
'((begin-program call-with-3
|
|
((name . call-with-3)))
|
|
(begin-standard-arity (f) 2 #f)
|
|
(definition closure 0 scm)
|
|
(definition f 1 scm)
|
|
(mov 1 0) ;; R0 <- R1
|
|
(load-constant 0 3) ;; R1 <- 3
|
|
(tail-call 2)
|
|
(end-arity)
|
|
(end-program)))))
|
|
(call-with-3 (lambda (x) (* x 2))))))
|
|
|
|
(with-test-prefix "cached-toplevel-ref"
|
|
(assert-equal 5.0
|
|
(let ((get-sqrt-trampoline
|
|
(assemble-program
|
|
'((begin-program get-sqrt-trampoline
|
|
((name . get-sqrt-trampoline)))
|
|
(begin-standard-arity () 2 #f)
|
|
(current-module 0)
|
|
(cache-current-module! 0 sqrt-scope)
|
|
(load-static-procedure 0 sqrt-trampoline)
|
|
(return-values 2)
|
|
(end-arity)
|
|
(end-program)
|
|
|
|
(begin-program sqrt-trampoline
|
|
((name . sqrt-trampoline)))
|
|
(begin-standard-arity (x) 3 #f)
|
|
(definition closure 0 scm)
|
|
(definition x 1 scm)
|
|
(cached-toplevel-box 0 sqrt-scope sqrt #t)
|
|
(box-ref 2 0)
|
|
(tail-call 2)
|
|
(end-arity)
|
|
(end-program)))))
|
|
((get-sqrt-trampoline) 25.0))))
|
|
|
|
(define *top-val* 0)
|
|
|
|
(with-test-prefix "cached-toplevel-set!"
|
|
(let ((prev *top-val*))
|
|
(assert-equal (1+ prev)
|
|
(let ((make-top-incrementor
|
|
(assemble-program
|
|
'((begin-program make-top-incrementor
|
|
((name . make-top-incrementor)))
|
|
(begin-standard-arity () 2 #f)
|
|
(current-module 0)
|
|
(cache-current-module! 0 top-incrementor)
|
|
(load-static-procedure 0 top-incrementor)
|
|
(return-values 2)
|
|
(end-arity)
|
|
(end-program)
|
|
|
|
(begin-program top-incrementor
|
|
((name . top-incrementor)))
|
|
(begin-standard-arity () 3 #f)
|
|
(cached-toplevel-box 1 top-incrementor *top-val* #t)
|
|
(box-ref 0 1)
|
|
(add/immediate 0 0 1)
|
|
(box-set! 1 0)
|
|
(return-values 1)
|
|
(end-arity)
|
|
(end-program)))))
|
|
((make-top-incrementor))
|
|
*top-val*))))
|
|
|
|
(with-test-prefix "cached-module-ref"
|
|
(assert-equal 5.0
|
|
(let ((get-sqrt-trampoline
|
|
(assemble-program
|
|
'((begin-program get-sqrt-trampoline
|
|
((name . get-sqrt-trampoline)))
|
|
(begin-standard-arity () 2 #f)
|
|
(load-static-procedure 0 sqrt-trampoline)
|
|
(return-values 2)
|
|
(end-arity)
|
|
(end-program)
|
|
|
|
(begin-program sqrt-trampoline
|
|
((name . sqrt-trampoline)))
|
|
(begin-standard-arity (x) 3 #f)
|
|
(definition closure 0 scm)
|
|
(definition x 1 scm)
|
|
(cached-module-box 0 (guile) sqrt #t #t)
|
|
(box-ref 2 0)
|
|
(tail-call 2)
|
|
(end-arity)
|
|
(end-program)))))
|
|
((get-sqrt-trampoline) 25.0))))
|
|
|
|
(with-test-prefix "cached-module-set!"
|
|
(let ((prev *top-val*))
|
|
(assert-equal (1+ prev)
|
|
(let ((make-top-incrementor
|
|
(assemble-program
|
|
'((begin-program make-top-incrementor
|
|
((name . make-top-incrementor)))
|
|
(begin-standard-arity () 2 #f)
|
|
(load-static-procedure 0 top-incrementor)
|
|
(return-values 2)
|
|
(end-arity)
|
|
(end-program)
|
|
|
|
(begin-program top-incrementor
|
|
((name . top-incrementor)))
|
|
(begin-standard-arity () 3 #f)
|
|
(cached-module-box 1 (tests bytecode) *top-val* #f #t)
|
|
(box-ref 0 1)
|
|
(add/immediate 0 0 1)
|
|
(box-set! 1 0)
|
|
(mov 1 0)
|
|
(return-values 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)))
|
|
(begin-standard-arity () 2 #f)
|
|
(load-constant 0 3)
|
|
(return-values 2)
|
|
(end-arity)
|
|
(end-program)))))
|
|
(pass-if "program name"
|
|
(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 (program-code return-3))
|
|
(lambda (pdi)
|
|
(equal? (program-debug-info-addr pdi)
|
|
(program-code return-3)))))))
|
|
|
|
(with-test-prefix "procedure name"
|
|
(pass-if-equal 'foo
|
|
(procedure-name
|
|
(assemble-program
|
|
'((begin-program foo ((name . foo)))
|
|
(begin-standard-arity () 2 #f)
|
|
(load-constant 0 42)
|
|
(return-values 2)
|
|
(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)
|
|
(definition closure 0 scm)
|
|
(load-constant 0 42)
|
|
(return-values 2)
|
|
(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 closure 0 scm)
|
|
(definition x 1 scm)
|
|
(definition y 2 scm)
|
|
(load-constant 1 42)
|
|
(return-values 2)
|
|
(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 closure 0 scm)
|
|
(definition x 1 scm)
|
|
(definition y 2 scm)
|
|
(definition z 3 scm)
|
|
(load-constant 2 42)
|
|
(return-values 2)
|
|
(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 0 42)
|
|
(return-values 2)
|
|
(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 0 42)
|
|
(return-values 2)
|
|
(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 0 42)
|
|
(return-values 2)
|
|
(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 0 42)
|
|
(return-values 2)
|
|
(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 0 42)
|
|
(return-values 2)
|
|
(end-arity)
|
|
(end-program))))))
|