[Guile-commits] GNU Guile branch, wip-sassy, updated. release_1-9-1-71-g51b91fe

[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=51b91fe14159b539f19812e8af8ec5ca7ab2e97d

The branch, wip-sassy has been updated
       via  51b91fe14159b539f19812e8af8ec5ca7ab2e97d (commit)
      from  66ff15e2f0afa2d2ecd4e7de484acf7324c3b0f1 (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 51b91fe14159b539f19812e8af8ec5ca7ab2e97d
Author: Andy Wingo <address@hidden>
Date:   Fri Aug 14 13:44:16 2009 +0200

    temp commit

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

Summary of changes:
 module/Makefile.am                                 |    4 +-
 .../{compile-assembly.scm => compile-sassy.scm}    |  128 ++++++++++++--------
 module/language/glil/spec.scm                      |    7 +-
 module/language/{value => sassy}/spec.scm          |   20 ++--
 4 files changed, 100 insertions(+), 59 deletions(-)
 copy module/language/glil/{compile-assembly.scm => compile-sassy.scm} (86%)
 copy module/language/{value => sassy}/spec.scm (66%)

diff --git a/module/Makefile.am b/module/Makefile.am
index f5c264b..1230878 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -89,7 +89,9 @@ GHIL_LANG_SOURCES =                                           
\
   language/ghil.scm language/ghil/spec.scm language/ghil/compile-glil.scm
 
 GLIL_LANG_SOURCES =                                            \
-  language/glil/spec.scm language/glil/compile-assembly.scm    \
+  language/glil/compile-assembly.scm                           \
+  language/glil/spec.scm                                       \
+  language/glil/compile-sassy.scm                              \
   language/glil/decompile-assembly.scm
 
 ASSEMBLY_LANG_SOURCES =                                \
diff --git a/module/language/glil/compile-assembly.scm 
b/module/language/glil/compile-sassy.scm
similarity index 86%
copy from module/language/glil/compile-assembly.scm
copy to module/language/glil/compile-sassy.scm
index c67ef69..1ce561e 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-sassy.scm
@@ -1,4 +1,4 @@
-;;; Guile VM assembler
+;;; Guile x86-32 assembler
 
 ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 
@@ -18,7 +18,7 @@
 
 ;;; Code:
 
-(define-module (language glil compile-assembly)
+(define-module (language glil compile-sassy)
   #:use-module (system base syntax)
   #:use-module (system base pmatch)
   #:use-module (language glil)
@@ -71,7 +71,7 @@
 (define (make-meta bindings sources tail)
   (if (and (null? bindings) (null? sources) (null? tail))
       #f
-      (compile-assembly
+      (compile-sassy
        (make-glil-program 0 0 0 '()
                           (list
                            (make-glil-const `(,bindings ,sources ,@tail))
@@ -126,43 +126,46 @@
                       (lambda (x alist)
                         (+ (length alist) *module*))))
 
-(define (compile-assembly glil)
+(define *true* #x104)
+(define *false* #x4)
+(define *null* #x404)
+(define *fixnum-tag* #b10)
+(define *fixnum-shift* 2)
+(define *char-tag* #b00001100)
+(define *char-shift* 8)
+
+(define (compile-sassy glil)
   (receive (code . _)
-      (glil->assembly glil #t '(()) '() '() #f -1)
+      (glil->sassy glil #t '(()) '() #f)
     (car code)))
 (define (make-object-table objects)
   (and (not (null? objects))
        (list->vector (cons #f objects))))
 
-(define (glil->assembly glil toplevel? bindings
-                        source-alist label-alist object-alist addr)
+(define (glil->sassy glil toplevel? bindings source-alist object-alist)
   (define (emit-code x)
-    (values x bindings source-alist label-alist object-alist))
+    (values x bindings source-alist object-alist))
   (define (emit-code/object x object-alist)
-    (values x bindings source-alist label-alist object-alist))
+    (values x bindings source-alist object-alist))
 
   (record-case glil
     ((<glil-program> nargs nrest nlocs meta body)
      (define (process-body)
        (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
-                (label-alist '()) (object-alist (if toplevel? #f '())) (addr 
0))
+                (object-alist (if toplevel? #f '())))
          (cond
           ((null? body)
            (values (reverse code)
                    (close-all-bindings bindings addr)
                    (limn-sources (reverse! source-alist))
-                   (reverse label-alist)
-                   (and object-alist (map car (reverse object-alist)))
-                   addr))
+                   (and object-alist (map car (reverse object-alist)))))
           (else
-           (receive (subcode bindings source-alist label-alist object-alist)
-               (glil->assembly (car body) #f bindings
-                               source-alist label-alist object-alist addr)
+           (receive (subcode bindings source-alist object-alist)
+               (glil->assembly (car body) #f bindings source-alist 
object-alist)
              (lp (cdr body) (append (reverse subcode) code)
-                 bindings source-alist label-alist object-alist
-                 (addr+ addr subcode)))))))
-
-     (receive (code bindings sources labels objects len)
+                 bindings source-alist object-alist))))))
+     
+     (receive (code bindings sources objects)
          (process-body)
        (let* ((meta (make-meta bindings sources meta))
               (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
@@ -178,7 +181,7 @@
            ;; toplevel bytecode isn't loaded by the vm, no way to do
            ;; object table or closure capture (not in the bytecode,
            ;; anyway)
-           (emit-code (align-program prog addr)))
+           (emit-code (list prog)))
           (else
            (let ((table (make-object-table objects)))
              (cond
@@ -204,28 +207,24 @@
      (values '()
              (open-binding bindings vars addr)
              source-alist
-             label-alist
              object-alist))
 
     ((<glil-mv-bind> vars rest)
      (values `((truncate-values ,(length vars) ,(if rest 1 0)))
              (open-binding bindings vars addr)
              source-alist
-             label-alist
              object-alist))
 
     ((<glil-unbind>)
      (values '()
              (close-binding bindings addr)
              source-alist
-             label-alist
              object-alist))
              
     ((<glil-source> props)
      (values '()
              bindings
              (acons addr props source-alist)
-             label-alist
              object-alist))
 
     ((<glil-void>)
@@ -346,48 +345,81 @@
           (error "unknown module var kind" op key)))))
 
     ((<glil-label> label)
-     (let ((code (align-block addr)))
-       (values code
-               bindings
-               source-alist
-               (acons label (addr+ addr code) label-alist)
-               object-alist)))
+     (values `((label ,label))
+             bindings
+             source-alist
+             object-alist))
 
     ((<glil-branch> inst label)
-     (emit-code `((,inst ,label))))
-
+     (emit-code
+      (case inst
+        ((br)
+         `((jmp ,label)))
+        ((br-if)
+         `((pop eax)
+           (cmp eax ,*false*)
+           (jne ,label)))
+        ((br-if-not)
+         `((pop eax)
+           (cmp eax ,*false*)
+           (je ,label)))
+        (else (error "unrecognized inst" inst)))))
+    
     ;; nargs is number of stack args to insn. probably should rename.
     ((<glil-call> inst nargs)
+     ;; verify the inst
      (if (not (instruction? inst))
          (error "Unknown instruction:" inst))
      (let ((pops (instruction-pops inst)))
        (cond ((< pops 0)
               (case (instruction-length inst)
-                ((1) (emit-code `((,inst ,nargs))))
-                ((2) (emit-code `((,inst ,(quotient nargs 256)
-                                         ,(modulo nargs 256)))))
+                ((1 2) #t)
                 (else (error "Unknown length for variable-arg instruction:"
                              inst (instruction-length inst)))))
-             ((= pops nargs)
-              (emit-code `((,inst))))
+             ((= pops nargs) #t)
              (else
-              (error "Wrong number of stack arguments to instruction:" inst 
nargs)))))
-
+              (error "Wrong number of stack arguments to instruction:" inst 
nargs))))
+     (emit-code
+      (case inst
+        ((add)
+         `((locals (fix post)
+             (pop ebx)
+             (pop eax)
+             (add eax ebx)
+             (jno fix)
+             ;;segfault
+             (mov eax 0)
+             (add eax (& eax))
+             (jmp post)
+             (label fix)
+             (sub eax ,*fixnum-tag*)
+             (label post)
+             (push eax)))))
+      (else
+       (error "unhandled instruction" inst))))
+    
     ((<glil-mv-call> nargs ra)
-     (emit-code `((mv-call ,nargs ,ra))))))
+     (error "mv-call not yet supported"))))
 
-(define (dump-object x addr)
+(define (dump-object x)
   (define (too-long x)
     (error (string-append x " too long")))
 
   (cond
-   ((object->assembly x) => list)
-   ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
+   ((eq? x #t) `((push ,*true*)))
+   ((eq? x #f) `((push ,*false*)))
+   ((null? x) `((push ,*null*)))
+   ((and (integer? x) (exact? x)
+         (<= most-negative-fixnum x) (<= x most-positive-fixnum))
+    `((push ,(logior (ash x *fixnum-shift*) *fixnum-tag*))))
+   ((char? x)
+    `((push ,(logior (ash (char->integer x) *char-shift*) *char-tag*))))
+   ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x)))
    ((subprogram? x)
-    (let ((table-code (dump-object (subprogram-table x) addr)))
-      `(,@table-code
-        ,@(align-program (subprogram-prog x)
-                         (addr+ addr table-code)))))
+    (let ((table-code ))
+      `(,@(dump-object (subprogram-table x))
+        ,(subprogram-prog x))
+      ))
    ((number? x)
     `((load-number ,(number->string x))))
    ((string? x)
diff --git a/module/language/glil/spec.scm b/module/language/glil/spec.scm
index d5291a2..3b7e970 100644
--- a/module/language/glil/spec.scm
+++ b/module/language/glil/spec.scm
@@ -1,6 +1,6 @@
 ;;; Guile Lowlevel Intermediate Language
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 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
@@ -23,6 +23,7 @@
   #:use-module (language glil)
   #:use-module (language glil compile-assembly)
   #:use-module (language glil decompile-assembly)
+  #:use-module (language glil compile-sassy)
   #:export (glil))
 
 (define (write-glil exp . port)
@@ -37,5 +38,7 @@
   #:reader     read
   #:printer    write-glil
   #:parser      parse-glil
-  #:compilers   `((assembly . ,compile-asm))
+  #:compilers   `((assembly . ,compile-asm)
+                  (sassy . ,(lambda x e opts)
+                         (values (compile-sassy x) e e)))
   #:decompilers `((assembly . ,decompile-assembly)))
diff --git a/module/language/value/spec.scm b/module/language/sassy/spec.scm
similarity index 66%
copy from module/language/value/spec.scm
copy to module/language/sassy/spec.scm
index aebba8c..65d4a26 100644
--- a/module/language/value/spec.scm
+++ b/module/language/sassy/spec.scm
@@ -1,6 +1,6 @@
-;;; Guile Lowlevel Intermediate Language
+;;; Guile x86-32 Machine Assembly
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2009 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
@@ -18,13 +18,17 @@
 
 ;;; Code:
 
-(define-module (language value spec)
+(define-module (language sassy spec)
   #:use-module (system base language)
-  #:export (value))
+  ;  #:use-module (language sassy compile-elf)
+  #:export (assembly))
 
-(define-language value
-  #:title      "Guile Values"
-  #:version    "0.3"
-  #:reader     #f
+(define-language sassy
+  #:title      "Guile x86-32 Assembly Language"
+  #:version    "2.0"
+  #:reader     read
   #:printer    write
+  #:parser      read
+;  #:compilers   `((bytecode . ,compile-bytecode))
+;  #:decompilers `((bytecode . ,decompile-bytecode))
   )


hooks/post-receive
-- 
GNU Guile