mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-03 18:50:19 +02:00
af95414f1d
* libguile/instructions.c (FOR_EACH_INSTRUCTION_WORD_TYPE): Allow for five-word instructions, and for new instruction word types. * libguile/vm-engine.c (RETURN_ONE_VALUE): Instead of returning the value in the fixed part of the call frame, return it in the same place multiple-value returns go: from slot 1. (BR_ARITHMETIC): Allow arithmetic tests to be negated. (rtl_vm_engine): Change calling convention to use the same location for single and multiple-value returns. Renumber all instructions. (halt, halt/values): Fold into a single instruction (halt). (call): Take the location of the procedure instead of the location of the call frame. Also take the number of args, and reset the sp before jumping to the procedure, so as to indicate the number of arguments. (call/values): Remove, as the new calling convention has RA == MVRA. (tail-call): Require the procedure to be shuffled down already, and take "nlocals" as an arg instead of "nargs". (receive, receive-values): New instructions, for receiving returned values from calls. (return-values): Rename from return/values. Remove "values". (alloc-frame): Rename from reserve-locals. (reset-frame): New instruction. (drop-locals): Remove. (br-if-=, br-if-<, br-if-<=): Allow these instructions to be negatable. (br-if->, br-if->=): Remove. Probably a bad idea, given NaN. (box-ref): Don't bother trying to do a reverse lookup -- the toplevel-box, module-box, and resolve instructions should handle that. (resolve): Add arg to check that the variable is bound. (toplevel-box, module-box): New instructions, replacing toplevel-ref, toplevel-set, module-ref, and module-set. * libguile/vm.c (rtl_boot_continuation_code, rtl_values_code): Adapt to instruction set changes. * module/Makefile.am: Make the assembler and disassembler dependent on vm-operations.h. * module/system/vm/assembler.scm: * module/system/vm/disassembler.scm: Adapt to instruction changes and new instruction word kinds. * test-suite/tests/rtl.test: Adapt to instruction set changes.
421 lines
16 KiB
Scheme
421 lines
16 KiB
Scheme
;;;; Low-level tests of the RTL assembler -*- mode: scheme; coding: utf-8; -*-
|
|
;;;;
|
|
;;;; Copyright (C) 2010, 2011, 2012, 2013 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 rtl)
|
|
#:use-module (test-suite lib)
|
|
#:use-module (system vm assembler)
|
|
#:use-module (system vm program)
|
|
#:use-module (system vm debug))
|
|
|
|
(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 1 ,val)
|
|
(return 1)
|
|
(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)
|
|
;; FIXME: Add 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 1 bar)
|
|
(return 1)
|
|
(end-arity)
|
|
(end-program)
|
|
(begin-program bar
|
|
((name . bar)))
|
|
(begin-standard-arity () 2 #f)
|
|
(load-constant 1 42)
|
|
(return 1)
|
|
(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)
|
|
(br fix-body)
|
|
(label loop-head)
|
|
(br-if-= 2 1 #f out)
|
|
(add 3 2 3)
|
|
(add1 2 2)
|
|
(br loop-head)
|
|
(label fix-body)
|
|
(load-constant 2 0)
|
|
(load-constant 3 0)
|
|
(br loop-head)
|
|
(label out)
|
|
(return 3)
|
|
(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 2 accum 1)
|
|
(free-set! 2 1 0)
|
|
(return 2)
|
|
(end-arity)
|
|
(end-program)
|
|
(begin-program accum
|
|
((name . accum)))
|
|
(begin-standard-arity (x) 4 #f)
|
|
(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)
|
|
(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)
|
|
(mov 5 1)
|
|
(call 5 1)
|
|
(receive 2 5 7)
|
|
(return 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)
|
|
(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))))))
|
|
|
|
(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)
|
|
(mov 0 1)
|
|
(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)
|
|
(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))))))
|
|
|
|
(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 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)))
|
|
(begin-standard-arity (x) 3 #f)
|
|
(cached-toplevel-box 2 sqrt-scope sqrt #t)
|
|
(box-ref 0 2)
|
|
(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 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)))
|
|
(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)
|
|
(return-values 0)
|
|
(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 1 sqrt-trampoline)
|
|
(return 1)
|
|
(end-arity)
|
|
(end-program)
|
|
|
|
(begin-program sqrt-trampoline
|
|
((name . sqrt-trampoline)))
|
|
(begin-standard-arity (x) 3 #f)
|
|
(cached-module-box 2 (guile) sqrt #t #t)
|
|
(box-ref 0 2)
|
|
(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 1 top-incrementor)
|
|
(return 1)
|
|
(end-arity)
|
|
(end-program)
|
|
|
|
(begin-program top-incrementor
|
|
((name . top-incrementor)))
|
|
(begin-standard-arity () 3 #f)
|
|
(cached-module-box 1 (tests rtl) *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)))
|
|
(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))
|
|
(lambda (pdi)
|
|
(equal? (program-debug-info-name pdi)
|
|
'return-3))))
|
|
|
|
(pass-if "program address"
|
|
(and=> (find-program-debug-info (rtl-program-code return-3))
|
|
(lambda (pdi)
|
|
(equal? (program-debug-info-addr pdi)
|
|
(rtl-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 1 42)
|
|
(return 1)
|
|
(end-arity)
|
|
(end-program))))))
|
|
|
|
(with-test-prefix "simply 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)
|
|
(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)
|
|
(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))))))
|