X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/f82f62944a4e605d385f40b5a4a01e19677bc0b3..3f4829e082c2fdd0553a6ce97fe173f8df327e7b:/test-suite/tests/rtl.test

diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 0e38a8ec8..082e44fa9 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -1,6 +1,6 @@
-;;;; 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
@@ -16,12 +16,22 @@
 ;;;; 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))))
@@ -29,9 +39,9 @@
 (define (return-constant val)
   (assemble-program `((begin-program foo
                                      ((name . foo)))
-                      (begin-standard-arity () 1 #f)
-                      (load-constant 0 ,val)
-                      (return 0)
+                      (begin-standard-arity () 2 #f)
+                      (load-constant 1 ,val)
+                      (return 1)
                       (end-arity)
                       (end-program))))
 
@@ -60,23 +70,27 @@
    '(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)))
-                                      (begin-standard-arity () 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)))
-                                      (begin-standard-arity () 1 #f)
-                                      (load-constant 0 42)
-                                      (return 0)
+                                      (begin-standard-arity () 2 #f)
+                                      (load-constant 1 42)
+                                      (return 1)
                                       (end-arity)
                                       (end-program)))))))
 
@@ -89,19 +103,20 @@
                         ;; 2: accum
                         '((begin-program countdown
                                          ((name . countdown)))
-                          (begin-standard-arity (x) 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))))
@@ -115,21 +130,23 @@
                         ;; 2: head
                         '((begin-program make-accum
                                          ((name . make-accum)))
-                          (begin-standard-arity () 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)))
-                          (begin-standard-arity (x) 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)))
@@ -143,10 +160,12 @@
                        (assemble-program
                         '((begin-program call
                                          ((name . call)))
-                          (begin-standard-arity (f) 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))))
@@ -156,11 +175,13 @@
                        (assemble-program
                         '((begin-program call-with-3
                                          ((name . call-with-3)))
-                          (begin-standard-arity (f) 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))))))
@@ -171,8 +192,10 @@
                        (assemble-program
                         '((begin-program call
                                          ((name . call)))
-                          (begin-standard-arity (f) 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))))
@@ -183,9 +206,10 @@
                         '((begin-program call-with-3
                                          ((name . call-with-3)))
                           (begin-standard-arity (f) 2 #f)
-                          (mov 1 0) ;; R1 <- R0
-                          (load-constant 0 3) ;; R0 <- 3
-                          (tail-call 1 1)
+                          (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))))))
@@ -196,18 +220,21 @@
                        (assemble-program
                         '((begin-program get-sqrt-trampoline
                                          ((name . get-sqrt-trampoline)))
-                          (begin-standard-arity () 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)))
-                          (begin-standard-arity (x) 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))))
@@ -221,20 +248,23 @@
                          (assemble-program
                           '((begin-program make-top-incrementor
                                            ((name . make-top-incrementor)))
-                            (begin-standard-arity () 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)))
-                            (begin-standard-arity () 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))
@@ -246,17 +276,19 @@
                        (assemble-program
                         '((begin-program get-sqrt-trampoline
                                          ((name . get-sqrt-trampoline)))
-                          (begin-standard-arity () 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)))
-                          (begin-standard-arity (x) 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))))
@@ -268,19 +300,20 @@
                          (assemble-program
                           '((begin-program make-top-incrementor
                                            ((name . make-top-incrementor)))
-                            (begin-standard-arity () 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)))
-                            (begin-standard-arity () 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))
@@ -289,51 +322,53 @@
 (with-test-prefix "debug contexts"
   (let ((return-3 (assemble-program
                    '((begin-program return-3 ((name . return-3)))
-                     (begin-standard-arity () 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)))
-          (begin-standard-arity () 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 "simply procedure arity"
+(with-test-prefix "simple procedure arity"
   (pass-if-equal "#<procedure foo ()>"
       (object->string
        (assemble-program
         '((begin-program foo ((name . foo)))
-          (begin-standard-arity () 1 #f)
-          (load-constant 0 42)
-          (return 0)
+          (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) 2 #f)
-          (load-constant 0 42)
-          (return 0)
+          (begin-standard-arity (x y) 3 #f)
+          (definition x 1)
+          (definition y 2)
+          (load-constant 1 42)
+          (return 1)
           (end-arity)
           (end-program)))))
 
@@ -341,9 +376,12 @@
       (object->string
        (assemble-program
         '((begin-program foo ((name . foo)))
-          (begin-opt-arity (x) (y) z 3 #f)
-          (load-constant 0 42)
-          (return 0)
+          (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))))))
 
@@ -352,9 +390,9 @@
       (procedure-documentation
        (assemble-program
         '((begin-program foo ((name . foo) (documentation . "qux qux")))
-          (begin-standard-arity () 1 #f)
-          (load-constant 0 42)
-          (return 0)
+          (begin-standard-arity () 2 #f)
+          (load-constant 1 42)
+          (return 1)
           (end-arity)
           (end-program))))))
 
@@ -364,9 +402,9 @@
       (procedure-properties
        (assemble-program
         '((begin-program foo ())
-          (begin-standard-arity () 1 #f)
-          (load-constant 0 42)
-          (return 0)
+          (begin-standard-arity () 2 #f)
+          (load-constant 1 42)
+          (return 1)
           (end-arity)
           (end-program)))))
 
@@ -376,9 +414,9 @@
       (procedure-properties
        (assemble-program
         '((begin-program foo ((name . foo) (documentation . "qux qux")))
-          (begin-standard-arity () 1 #f)
-          (load-constant 0 42)
-          (return 0)
+          (begin-standard-arity () 2 #f)
+          (load-constant 1 42)
+          (return 1)
           (end-arity)
           (end-program)))))
 
@@ -391,9 +429,9 @@
         '((begin-program foo ((name . foo)
                               (documentation . "qux qux")
                               (moo . "mooooooooooooo")))
-          (begin-standard-arity () 1 #f)
-          (load-constant 0 42)
-          (return 0)
+          (begin-standard-arity () 2 #f)
+          (load-constant 1 42)
+          (return 1)
           (end-arity)
           (end-program)))))
 
@@ -404,8 +442,8 @@
         '((begin-program foo ((name . foo)
                               (documentation . "qux qux")
                               (moo . "mooooooooooooo")))
-          (begin-standard-arity () 1 #f)
-          (load-constant 0 42)
-          (return 0)
+          (begin-standard-arity () 2 #f)
+          (load-constant 1 42)
+          (return 1)
           (end-arity)
           (end-program))))))