temp commit

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 =				\

module/language/glil/compile-sassy.scm

@@ -0,0 +1,478 @@
+;;; Guile x86-32 assembler
+
+;; 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
+;;;; 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
+
+;;; Code:
+
+(define-module (language glil compile-sassy)
+  #:use-module (system base syntax)
+  #:use-module (system base pmatch)
+  #:use-module (language glil)
+  #:use-module (language assembly)
+  #:use-module (system vm instruction)
+  #:use-module ((system vm program) #:select (make-binding))
+  #:use-module (ice-9 receive)
+  #:use-module ((srfi srfi-1) #:select (fold))
+  #:use-module (rnrs bytevector)
+  #:export (compile-assembly))
+
+;; Variable cache cells go in the object table, and serialize as their
+;; keys. The reason we wrap the keys in these records is so they don't
+;; compare as `equal?' to other objects in the object table.
+;;
+;; `key' is either a symbol or the list (MODNAME SYM PUBLIC?)
+
+(define-record <variable-cache-cell> key)
+
+;; Subprograms can be loaded into an object table as well. We need a
+;; disjoint type here too. (Subprograms have their own object tables --
+;; though probably we should just make one table per compilation unit.)
+
+(define-record <subprogram> table prog)
+
+
+(define (limn-sources sources)
+  (let lp ((in sources) (out '()) (filename #f))
+    (if (null? in)
+        (reverse! out)
+        (let ((addr (caar in))
+              (new-filename (assq-ref (cdar in ) 'filename))
+              (line (assq-ref (cdar in) 'line))
+              (column (assq-ref (cdar in) 'column)))
+          (cond
+           ((not (equal? new-filename filename))
+            (lp (cdr in)
+                `((,addr . (,line . ,column))
+                  (filename . ,new-filename)
+                  . ,out)
+                new-filename))
+           ((or (null? out) (not (equal? (cdar out) `(,line . ,column))))
+            (lp (cdr in)
+                `((,addr . (,line . ,column))
+                  . ,out)
+                filename))
+           (else
+            (lp (cdr in) out filename)))))))
+
+(define (make-meta bindings sources tail)
+  (if (and (null? bindings) (null? sources) (null? tail))
+      #f
+      (compile-sassy
+       (make-glil-program 0 0 0 '()
+                          (list
+                           (make-glil-const `(,bindings ,sources ,@tail))
+                           (make-glil-call 'return 1))))))
+
+;; A functional stack of names of live variables.
+(define (make-open-binding name boxed? index)
+  (list name boxed? index))
+(define (make-closed-binding open-binding start end)
+  (make-binding (car open-binding) (cadr open-binding)
+                (caddr open-binding) start end))
+(define (open-binding bindings vars start)
+  (cons
+   (acons start
+          (map
+           (lambda (v)
+             (pmatch v
+               ((,name ,boxed? ,i)
+                (make-open-binding name boxed? i))
+               (else (error "unknown binding type" v))))
+           vars)
+          (car bindings))
+   (cdr bindings)))
+(define (close-binding bindings end)
+  (pmatch bindings
+    ((((,start . ,closing) . ,open) . ,closed)
+     (cons open
+           (fold (lambda (o tail)
+                   ;; the cons is for dsu sort
+                   (acons start (make-closed-binding o start end)
+                          tail))
+                 closed
+                 closing)))
+    (else (error "broken bindings" bindings))))
+(define (close-all-bindings bindings end)
+  (if (null? (car bindings))
+      (map cdr
+           (stable-sort (reverse (cdr bindings))
+                        (lambda (x y) (< (car x) (car y)))))
+      (close-all-bindings (close-binding bindings end) end)))
+
+;; A functional object table.
+(define *module* 1)
+(define (assoc-ref-or-acons alist x make-y)
+  (cond ((assoc-ref alist x)
+         => (lambda (y) (values y alist)))
+        (else
+         (let ((y (make-y x alist)))
+           (values y (acons x y alist))))))
+(define (object-index-and-alist x alist)
+  (assoc-ref-or-acons alist x
+                      (lambda (x alist)
+                        (+ (length alist) *module*))))
+
+(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->sassy glil #t '(()) '() #f)
+    (car code)))
+(define (make-object-table objects)
+  (and (not (null? objects))
+       (list->vector (cons #f objects))))
+
+(define (glil->sassy glil toplevel? bindings source-alist object-alist)
+  (define (emit-code x)
+    (values x bindings source-alist object-alist))
+  (define (emit-code/object x 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 '())
+                (object-alist (if toplevel? #f '())))
+         (cond
+          ((null? body)
+           (values (reverse code)
+                   (close-all-bindings bindings addr)
+                   (limn-sources (reverse! source-alist))
+                   (and object-alist (map car (reverse object-alist)))))
+          (else
+           (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 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))
+              (prog `(load-program ,nargs ,nrest ,nlocs ,labels
+                                  ,(+ len meta-pad)
+                                  ,meta
+                                  ,@code
+                                  ,@(if meta
+                                        (make-list meta-pad '(nop))
+                                        '()))))
+         (cond
+          (toplevel?
+           ;; toplevel bytecode isn't loaded by the vm, no way to do
+           ;; object table or closure capture (not in the bytecode,
+           ;; anyway)
+           (emit-code (list prog)))
+          (else
+           (let ((table (make-object-table objects)))
+             (cond
+              (object-alist
+               ;; if we are being compiled from something with an object
+               ;; table, cache the program there
+               (receive (i object-alist)
+                   (object-index-and-alist (make-subprogram table prog)
+                                           object-alist)
+                 (emit-code/object `(,(if (< i 256)
+                                          `(object-ref ,i)
+                                          `(long-object-ref ,(quotient i 256)
+                                                            ,(modulo i 256))))
+                                   object-alist)))
+              (else
+               ;; otherwise emit a load directly
+               (let ((table-code (dump-object table addr)))
+                 (emit-code
+                  `(,@table-code
+                    ,@(align-program prog (addr+ addr table-code)))))))))))))
+    
+    ((<glil-bind> vars)
+     (values '()
+             (open-binding bindings vars addr)
+             source-alist
+             object-alist))
+
+    ((<glil-mv-bind> vars rest)
+     (values `((truncate-values ,(length vars) ,(if rest 1 0)))
+             (open-binding bindings vars addr)
+             source-alist
+             object-alist))
+
+    ((<glil-unbind>)
+     (values '()
+             (close-binding bindings addr)
+             source-alist
+             object-alist))
+             
+    ((<glil-source> props)
+     (values '()
+             bindings
+             (acons addr props source-alist)
+             object-alist))
+
+    ((<glil-void>)
+     (emit-code '((void))))
+
+    ((<glil-const> obj)
+     (cond
+      ((object->assembly obj)
+       => (lambda (code)
+            (emit-code (list code))))
+      ((not object-alist)
+       (emit-code (dump-object obj addr)))
+      (else
+       (receive (i object-alist)
+           (object-index-and-alist obj object-alist)
+         (emit-code/object (if (< i 256)
+                               `((object-ref ,i))
+                               `((long-object-ref ,(quotient i 256)
+                                                  ,(modulo i 256))))
+                           object-alist)))))
+
+    ((<glil-lexical> local? boxed? op index)
+     (emit-code
+      (if local?
+          (if (< index 256)
+              (case op
+                ((ref) (if boxed?
+                           `((local-boxed-ref ,index))
+                           `((local-ref ,index))))
+                ((set) (if boxed?
+                           `((local-boxed-set ,index))
+                           `((local-set ,index))))
+                ((box) `((box ,index)))
+                ((empty-box) `((empty-box ,index)))
+                ((fix) `((fix-closure 0 ,index)))
+                (else (error "what" op)))
+              (let ((a (quotient i 256))
+                    (b (modulo i 256)))
+                `((,(case op
+                      ((ref)
+                       (if boxed?
+                           `((long-local-ref ,a ,b)
+                             (variable-ref))
+                           `((long-local-ref ,a ,b))))
+                      ((set)
+                       (if boxed?
+                           `((long-local-ref ,a ,b)
+                             (variable-set))
+                           `((long-local-set ,a ,b))))
+                      ((box)
+                       `((make-variable)
+                         (variable-set)
+                         (long-local-set ,a ,b)))
+                      ((empty-box)
+                       `((make-variable)
+                         (long-local-set ,a ,b)))
+                      ((fix)
+                       `((fix-closure ,a ,b)))
+                      (else (error "what" op)))
+                   ,index))))
+          `((,(case op
+                ((ref) (if boxed? 'free-boxed-ref 'free-ref))
+                ((set) (if boxed? 'free-boxed-set (error "what." glil)))
+                (else (error "what" op)))
+             ,index)))))
+    
+    ((<glil-toplevel> op name)
+     (case op
+       ((ref set)
+        (cond
+         ((not object-alist)
+          (emit-code `(,@(dump-object name addr)
+                       (link-now)
+                       ,(case op 
+                          ((ref) '(variable-ref))
+                          ((set) '(variable-set))))))
+         (else
+          (receive (i object-alist)
+              (object-index-and-alist (make-variable-cache-cell name)
+                                      object-alist)
+            (emit-code/object (if (< i 256)
+                                  `((,(case op
+                                        ((ref) 'toplevel-ref)
+                                        ((set) 'toplevel-set))
+                                     ,i))
+                                  `((,(case op
+                                        ((ref) 'long-toplevel-ref)
+                                        ((set) 'long-toplevel-set))
+                                     ,(quotient i 256)
+                                     ,(modulo i 256))))
+                              object-alist)))))
+       ((define)
+        (emit-code `(,@(dump-object name addr)
+                     (define))))
+       (else
+        (error "unknown toplevel var kind" op name))))
+
+    ((<glil-module> op mod name public?)
+     (let ((key (list mod name public?)))
+       (case op
+         ((ref set)
+          (cond
+           ((not object-alist)
+            (emit-code `(,@(dump-object key addr)
+                         (link-now)
+                         ,(case op 
+                            ((ref) '(variable-ref))
+                            ((set) '(variable-set))))))
+           (else
+            (receive (i object-alist)
+                (object-index-and-alist (make-variable-cache-cell key)
+                                        object-alist)
+              (emit-code/object (case op
+                                  ((ref) `((toplevel-ref ,i)))
+                                  ((set) `((toplevel-set ,i))))
+                                object-alist)))))
+         (else
+          (error "unknown module var kind" op key)))))
+
+    ((<glil-label> label)
+     (values `((label ,label))
+             bindings
+             source-alist
+             object-alist))
+
+    ((<glil-branch> 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 2) #t)
+                (else (error "Unknown length for variable-arg instruction:"
+                             inst (instruction-length inst)))))
+             ((= pops nargs) #t)
+             (else
+              (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)
+     (error "mv-call not yet supported"))))
+
+(define (dump-object x)
+  (define (too-long x)
+    (error (string-append x " too long")))
+
+  (cond
+   ((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))
+        ,(subprogram-prog x))
+      ))
+   ((number? x)
+    `((load-number ,(number->string x))))
+   ((string? x)
+    (case (string-width x)
+      ((1) `((load-string ,x)))
+      ((4) (align-code `(load-wide-string ,x) addr 4 4))
+      (else (error "bad string width" x))))
+   ((symbol? x)
+    (let ((str (symbol->string x)))
+      (case (string-width str)
+        ((1) `((load-symbol ,str)))
+        ((4) `(,@(dump-object str addr)
+               (make-symbol)))
+        (else (error "bad string width" str)))))
+   ((keyword? x)
+    `(,@(dump-object (keyword->symbol x) addr)
+      (make-keyword)))
+   ((list? x)
+    (let ((tail (let ((len (length x)))
+                  (if (>= len 65536) (too-long "list"))
+                  `((list ,(quotient len 256) ,(modulo len 256))))))
+      (let dump-objects ((objects x) (codes '()) (addr addr))
+        (if (null? objects)
+            (fold append tail codes)
+            (let ((code (dump-object (car objects) addr)))
+              (dump-objects (cdr objects) (cons code codes)
+                            (addr+ addr code)))))))
+   ((pair? x)
+    (let ((kar (dump-object (car x) addr)))
+      `(,@kar
+        ,@(dump-object (cdr x) (addr+ addr kar))
+        (cons))))
+   ((vector? x)
+    (let* ((len (vector-length x))
+           (tail (if (>= len 65536)
+                     (too-long "vector")
+                     `((vector ,(quotient len 256) ,(modulo len 256))))))
+      (let dump-objects ((i 0) (codes '()) (addr addr))
+        (if (>= i len)
+            (fold append tail codes)
+            (let ((code (dump-object (vector-ref x i) addr)))
+              (dump-objects (1+ i) (cons code codes)
+                            (addr+ addr code)))))))
+   ((and (array? x) (symbol? (array-type x)))
+    (let* ((type (dump-object (array-type x) addr))
+           (shape (dump-object (array-shape x) (addr+ addr type))))
+      `(,@type
+        ,@shape
+        ,@(align-code
+           `(load-array ,(uniform-array->bytevector x))
+           (addr+ (addr+ addr type) shape)
+           8
+           4))))
+   (else
+    (error "assemble: unrecognized object" x))))
+

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)))

module/language/sassy/spec.scm

@@ -0,0 +1,34 @@
+;;; Guile x86-32 Machine Assembly
+
+;; 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
+;;;; 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
+
+;;; Code:
+
+(define-module (language sassy spec)
+  #:use-module (system base language)
+  ;  #:use-module (language sassy compile-elf)
+  #:export (assembly))
+
+(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))
+  )