[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.1.0-312-gbc6e7fd

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=bc6e7fd902350e317455ededc505fc6a4bcff252

The branch, wip-rtl has been updated
       via  bc6e7fd902350e317455ededc505fc6a4bcff252 (commit)
       via  6d8b29345c56b2acc023a7a8c9d824384a735b1d (commit)
       via  87955c41eeab6ed35a0e6f1ecda18b50bda483de (commit)
      from  c24fed19329e145cb534494005b236c6c042c397 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit bc6e7fd902350e317455ededc505fc6a4bcff252
Author: Andy Wingo <address@hidden>
Date:   Wed Jun 6 11:03:57 2012 +0200

    pairs and vectors working
    
    * module/system/vm/rtl.scm (link-constants): Fix vectors.
    * test-suite/tests/rtl.test ("load-constant"): Add tests for pairs and
      vectors.

commit 6d8b29345c56b2acc023a7a8c9d824384a735b1d
Author: Andy Wingo <address@hidden>
Date:   Wed Jun 6 10:56:32 2012 +0200

    add tests for loading constants; fix wide stringbufs
    
    * module/system/vm/rtl.scm (tc7-narrow-stringbuf)
      (tc7-wide-stringbuf, write-stringbuf): Fix wide stringbufs.
      (link-data): Fix size computation for wide stringbufs.
    
      Remove a bunch of commented fragments from the end of the file.
    
    * test-suite/Makefile.am (SCM_TESTS):
    * test-suite/tests/rtl.test: Add new tests for programs that return
      constants.

commit 87955c41eeab6ed35a0e6f1ecda18b50bda483de
Author: Andy Wingo <address@hidden>
Date:   Wed Jun 6 10:26:18 2012 +0200

    assemble-program is much easier to use now
    
    * module/system/vm/rtl.scm: Move around macro-assembler definitions.
      (begin-program, label): New macro-instructions.
      (emit-text): Rename from emit-program, and take the metadata like the
      label and the nlocals inline to the program, via the begin-program
      macro-instruction.
      (emit-init-constants):
      (assemble-program): Rename from assemble-rtl-program and take just one
      argument, the instructions, possibly including macroinstructions.
      Load it directly, returning a procedure.

-----------------------------------------------------------------------

Summary of changes:
 module/system/vm/rtl.scm  |  253 ++++++++++++++++++---------------------------
 test-suite/Makefile.am    |    1 +
 test-suite/tests/rtl.test |   59 +++++++++++
 3 files changed, 161 insertions(+), 152 deletions(-)
 create mode 100644 test-suite/tests/rtl.test

diff --git a/module/system/vm/rtl.scm b/module/system/vm/rtl.scm
index 8eb64cf..dab4e8e 100644
--- a/module/system/vm/rtl.scm
+++ b/module/system/vm/rtl.scm
@@ -23,14 +23,16 @@
   #:use-module (system vm instruction)
   #:use-module (system vm elf)
   #:use-module (system vm program)
+  #:use-module (system vm objcode)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-4)
   #:use-module (srfi srfi-9)
   #:export (make-assembler
-            emit-program
-            link-assembly))
+            emit-text
+            link-assembly
+            assemble-program))
 
 (define-syntax-rule (pack-u8-u24 x y)
   (logior x (ash y 8)))
@@ -183,10 +185,6 @@
 (define-inlinable (reset-asm-start! asm)
   (set-asm-start! asm (+ (asm-idx asm) (asm-written asm))))
 
-(define (emit-label asm label)
-  (reset-asm-start! asm)
-  (set-asm-labels! asm (acons label (asm-start asm) (asm-labels asm))))
-
 (define (emit-exported-label asm label)
   (set-asm-labels! asm (acons label (asm-start asm) (asm-labels asm))))
 
@@ -350,35 +348,6 @@
 
 (visit-opcodes define-assembler)
 
-(define-syntax define-macro-assembler
-  (lambda (x)
-    (syntax-case x ()
-      ((_ (name arg ...) body body* ...)
-       (with-syntax ((emit (id-append #'name #'emit- #'name)))
-         #'(define emit
-             (let ((emit (lambda (arg ...) body body* ...)))
-               (hashq-set! assemblers 'name emit)
-               emit)))))))
-
-(define (static? x)
-  (or (pair? x) (vector? x) (string? x)))
-
-(define-macro-assembler (load-constant asm dst obj)
-  (cond
-   ((immediate? obj)
-    (let ((bits (object-address obj)))
-      (cond
-       ((and (< dst 256) (zero? (ash bits -16)))
-        (emit-make-short-immediate asm dst obj))
-       ((zero? (ash bits -32))
-        (emit-make-long-immediate asm dst obj))
-       (else
-        (emit-make-long-long-immediate asm dst obj)))))
-   ((static? obj)
-    (emit-make-non-immediate asm dst (emit-non-immediate asm obj)))
-   (else
-    (emit-static-ref asm dst (emit-non-immediate asm obj)))))
-
 (define-syntax disassembler
   (lambda (x)
     (define (parse-first-word exp type)
@@ -533,16 +502,85 @@
               (lp (+ offset len) (cons elt out))))
           (cons* locals meta (reverse out))))))
 
-(define (emit-program asm label nlocals instructions)
+(define-syntax define-macro-assembler
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (name arg ...) body body* ...)
+       (with-syntax ((emit (id-append #'name #'emit- #'name)))
+         #'(define emit
+             (let ((emit (lambda (arg ...) body body* ...)))
+               (hashq-set! assemblers 'name emit)
+               emit)))))))
+
+(define (static? x)
+  (or (pair? x) (vector? x) (string? x)))
+
+(define-macro-assembler (load-constant asm dst obj)
+  (cond
+   ((immediate? obj)
+    (let ((bits (object-address obj)))
+      (cond
+       ((and (< dst 256) (zero? (ash bits -16)))
+        (emit-make-short-immediate asm dst obj))
+       ((zero? (ash bits -32))
+        (emit-make-long-immediate asm dst obj))
+       (else
+        (emit-make-long-long-immediate asm dst obj)))))
+   ((static? obj)
+    (emit-make-non-immediate asm dst (emit-non-immediate asm obj)))
+   (else
+    (emit-static-ref asm dst (emit-non-immediate asm obj)))))
+
+(define-macro-assembler (begin-program asm label nlocals)
   (emit-label asm label)
   (emit asm nlocals)
-  (emit asm 0)
+  (emit asm 0) ; meta-label
+  )
+
+(define-macro-assembler (label asm sym)
+  (reset-asm-start! asm)
+  (set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm))))
+
+(define-macro-assembler (init-non-immediate asm label offset obj)
+  (let ((obj-label (cdr (vhash-assoc obj (archive-constants
+                                          (asm-archive asm))))))
+    (if (static? obj)
+        (emit-make-non-immediate asm 0 obj-label)
+        (emit-static-ref asm 0 obj-label))
+    (emit-static-set! asm 0 label offset)))
+
+(define-macro-assembler (init-string asm label obj)
+  (let ((obj-label (cdr (vhash-assoc obj
+                                     (archive-stringbufs (asm-archive asm))))))
+    (emit-make-non-immediate asm 0 obj-label)
+    (emit-static-set! asm 0 label 1)))
+
+(define-macro-assembler (init-symbol asm label obj)
+  (let ((str-label (cdr (vhash-assoc (symbol->string obj)
+                                     (archive-constants (asm-archive asm))))))
+    (emit-make-non-immediate asm 0 str-label)
+    (emit-string->symbol asm 0 0)
+    (emit-static-set! asm 0 label 0)))
+
+(define-macro-assembler (init-keyword asm label obj)
+  (let ((sym-label (cdr (vhash-assoc (keyword->symbol obj)
+                                     (archive-constants (asm-archive asm))))))
+    (emit-static-ref asm 0 sym-label)
+    (emit-symbol->keyword asm 0 0)
+    (emit-static-set! asm 0 label 0)))
+
+(define-macro-assembler (init-number asm label obj)
+  (let ((str-label (cdr (vhash-assoc (number->string obj)
+                                     (archive-constants (asm-archive asm))))))
+    (emit-make-non-immediate asm 0 str-label)
+    (emit-string->number asm 0 0)
+    (emit-static-set! asm 0 label 0)))
+
+(define (emit-text asm instructions)
   (for-each (lambda (inst)
-              (if (pair? inst)
-                  (apply (or (hashq-ref assemblers (car inst))
-                             (error 'bad-instruction inst))
-                         asm (cdr inst))
-                  (emit-label asm inst)))
+              (apply (or (hashq-ref assemblers (car inst))
+                         (error 'bad-instruction inst))
+                     asm (cdr inst)))
             instructions))
 
 (define (process-relocs buf relocs labels)
@@ -668,7 +706,8 @@
      (modulo (- alignment (modulo address alignment)) alignment)))
 
 (define tc7-vector 13)
-(define tc7-stringbuf 39)
+(define tc7-narrow-stringbuf 39)
+(define tc7-wide-stringbuf (+ 39 #x400))
 (define tc7-ro-string (+ 21 #x200))
 
 (define (write-immediate asm buf pos x)
@@ -691,13 +730,16 @@
 
 (define (write-stringbuf asm buf pos x label inits)
   (let ((endianness (asm-endianness asm))
-        (len (string-length x)))
+        (len (string-length x))
+        (tag (if (= (string-bytes-per-char x) 1)
+                 tc7-narrow-stringbuf
+                 tc7-wide-stringbuf)))
     (case (asm-word-size asm)
       ((4)
-       (bytevector-u32-set! buf pos tc7-stringbuf endianness)
+       (bytevector-u32-set! buf pos tag endianness)
        (bytevector-u32-set! buf (+ pos 4) len endianness))
       ((8)
-       (bytevector-u64-set! buf pos tc7-stringbuf endianness)
+       (bytevector-u64-set! buf pos tag endianness)
        (bytevector-u64-set! buf (+ pos 8) len endianness))
       (else
        (error "bad word size" asm)))
@@ -776,48 +818,14 @@
   (write-immediate asm buf pos #f)
   (cons `(init-number ,label ,x) inits))
 
-(define-macro-assembler (init-non-immediate asm label offset obj)
-  (let ((obj-label (cdr (vhash-assoc obj (archive-constants
-                                          (asm-archive asm))))))
-    (if (static? obj)
-        (emit-make-non-immediate asm 0 obj-label)
-        (emit-static-ref asm 0 obj-label))
-    (emit-static-set! asm 0 label offset)))
-
-(define-macro-assembler (init-string asm label obj)
-  (let ((obj-label (cdr (vhash-assoc obj
-                                     (archive-stringbufs (asm-archive asm))))))
-    (emit-make-non-immediate asm 0 obj-label)
-    (emit-static-set! asm 0 label 1)))
-
-(define-macro-assembler (init-symbol asm label obj)
-  (let ((str-label (cdr (vhash-assoc (symbol->string obj)
-                                     (archive-constants (asm-archive asm))))))
-    (emit-make-non-immediate asm 0 str-label)
-    (emit-string->symbol asm 0 0)
-    (emit-static-set! asm 0 label 0)))
-
-(define-macro-assembler (init-keyword asm label obj)
-  (let ((sym-label (cdr (vhash-assoc (keyword->symbol obj)
-                                     (archive-constants (asm-archive asm))))))
-    (emit-static-ref asm 0 sym-label)
-    (emit-symbol->keyword asm 0 0)
-    (emit-static-set! asm 0 label 0)))
-
-(define-macro-assembler (init-number asm label obj)
-  (let ((str-label (cdr (vhash-assoc (number->string obj)
-                                     (archive-constants (asm-archive asm))))))
-    (emit-make-non-immediate asm 0 str-label)
-    (emit-string->number asm 0 0)
-    (emit-static-set! asm 0 label 0)))
-
 (define (emit-init-constants asm inits)
   (let ((label (gensym "init-constants")))
-    (emit-program asm label 1
-                  `((assert-nargs-ee/locals 0 1)
-                    ,@inits
-                    (load-constant 0 ,*unspecified*)
-                    (return 0)))
+    (emit-text asm
+               `((begin-program ,label 1)
+                 (assert-nargs-ee/locals 0 1)
+                 ,@inits
+                 (load-constant 0 ,*unspecified*)
+                 (return 0)))
     label))
 
 (define (link-data asm data strings-are-stringbufs?)
@@ -826,13 +834,13 @@
 
   (define (byte-length x)
     (cond
-     ((string? x) ;; assume stringbuf
+     ((string? x)
       (if strings-are-stringbufs?
           ;; Strings are actually stringbufs.
           (+ (* 2 (asm-word-size asm))
              (case (string-bytes-per-char x)
                ((1) (1+ (string-length x)))
-               ((4) (1+ (* (string-length x) 4)))
+               ((4) (* (1+ (string-length x)) 4))
                (else (error "bad string bytes per char" x))))
           (* 4 (asm-word-size asm))))
      ((pair? x)
@@ -894,7 +902,7 @@
       (and (immediate? (car x)) (immediate? (cdr x))))
      ((vector? x)
       (let lp ((i 0))
-        (or (= i (vector-length i))
+        (or (= i (vector-length x))
             (and (immediate? (vector-ref x i))
                  (lp (1+ i))))))
      (else #f)))
@@ -934,67 +942,8 @@
 (define (link-assembly asm)
   (link-elf (link-objects asm)))
 
-(define (assemble-rtl-program label nlocals instructions)
+(define (assemble-program instructions)
   (let ((asm (make-assembler)))
-    (emit-program asm label nlocals instructions)
-    (link-objects asm)))
-
-  #;
-  (let ((buf (asm-finish asm)))
-    (values (make-rtl-program buf) buf))
-  
-#;
-(assemble-rtl-program
- 3
- '((assert-nargs-ee/locals 1 2)
-   (br fix-body)
-   loop-head
-   (make-short-immediate 2 0)
-   (br-if-= 1 2 out)
-   (sub1 1 1)
-   (br loop-head)
-   fix-body
-   (mov 1 0)
-   (br loop-head)
-   out
-   (make-short-immediate 0 #t)
-   (return 0)))
-
-#;
- (define (fib n) (if (< n 2) 1 (+ (fib (1- n)) (fib (- n 2)))))
-
-#;
-(assemble-rtl-program
- ;; locals: 0: 
- '((assert-nargs-ee/locals 1 0)
-   (make-short-immediate 1 2)
-   (br-if-< 0 1 base-case)
-
-   (sub1 1 0)
-   ()
-
-   base-case
-   (make-short-immediate 1 1)
-   (return 1))
-
-   2    (local-ref 0)                   ;; `n'
-   4    (make-int8 2)                   ;; 2
-   6    (lt?)                           
-   7    (br-if-not :L95)                ;; -> 13
-  11    (make-int8:1)                   ;; 1
-  12    (return)                        
-  13    (new-frame)                     
-  14    (toplevel-ref 1)                ;; `fib'
-  16    (local-ref 0)                   ;; `n'
-  18    (sub1)                          
-  19    (call 1)                        
-  21    (new-frame)                     
-  22    (toplevel-ref 1)                ;; `fib'
-  24    (local-ref 0)                   ;; `n'
-  26    (make-int8 2)                   ;; 2
-  28    (sub)                           
-  29    (call 1)                        
-  31    (add)                           
-  32    (return)                        
-
-)
\ No newline at end of file
+    (emit-text asm instructions)
+    (load-thunk-from-memory
+     (link-elf (link-objects asm) #:page-aligned? #f))))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index c20a977..9dd0f0d 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -112,6 +112,7 @@ SCM_TESTS = tests/00-initial-env.test               \
            tests/reader.test                   \
            tests/receive.test                  \
            tests/regexp.test                   \
+           tests/rtl.test                      \
            tests/session.test                  \
            tests/signals.test                  \
            tests/srcprop.test                  \
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
new file mode 100644
index 0000000..f4ec91a
--- /dev/null
+++ b/test-suite/tests/rtl.test
@@ -0,0 +1,59 @@
+;;;; Low-level tests of the RTL assembler -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;;   Copyright (C) 2010, 2011, 2012 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 rtl))
+
+(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 1)
+                      (assert-nargs-ee/locals 0 1)
+                      (load-constant 0 ,val)
+                      (return 0))))
+
+(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)
+   ))


hooks/post-receive
-- 
GNU Guile