1 files changed, 165 insertions, 0 deletions
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
new file mode 100644
index 000000000..683da6cc1
--- /dev/null
+++ b/module/language/assembly.scm
@@ -0,0 +1,165 @@
+;;; Guile Virtual Machine Assembly
+
+;; 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 assembly)
+  #:use-module (rnrs bytevector)
+  #:use-module (system base pmatch)
+  #:use-module (system vm instruction)
+  #:use-module ((srfi srfi-1) #:select (fold))
+  #:export (byte-length
+            addr+ align-program align-code align-block
+            assembly-pack assembly-unpack
+            object->assembly assembly->object))
+
+;; nargs, nrest, nlocs, len, metalen, padding
+(define *program-header-len* (+ 1 1 2 4 4 4))
+
+;; lengths are encoded in 3 bytes
+(define *len-len* 3)
+
+
+(define (byte-length assembly)
+  (pmatch assembly
+    (,label (guard (not (pair? label)))
+     0)
+    ((load-number ,str)
+     (+ 1 *len-len* (string-length str)))
+    ((load-string ,str)
+     (+ 1 *len-len* (string-length str)))
+    ((load-wide-string ,str)
+     (+ 1 *len-len* (* 4 (string-length str))))
+    ((load-symbol ,str)
+     (+ 1 *len-len* (string-length str)))
+    ((load-array ,bv)
+     (+ 1 *len-len* (bytevector-length bv)))
+    ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
+     (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
+    ((,inst . _) (guard (>= (instruction-length inst) 0))
+     (+ 1 (instruction-length inst)))
+    (else (error "unknown instruction" assembly))))
+
+
+(define *program-alignment* 8)
+
+(define *block-alignment* 8)
+
+(define (addr+ addr code)
+  (fold (lambda (x len) (+ (byte-length x) len))
+        addr
+        code))
+
+(define (code-alignment addr alignment header-len)
+  (make-list (modulo (- alignment
+                        (modulo (+ addr header-len) alignment))
+                     alignment)
+             '(nop)))
+
+(define (align-block addr)
+  (code-alignment addr *block-alignment* 0))
+
+(define (align-code code addr alignment header-len)
+  `(,@(code-alignment addr alignment header-len)
+    ,code))
+
+(define (align-program prog addr)
+  (align-code prog addr *program-alignment* 1))
+
+;;;
+;;; Code compress/decompression
+;;;
+
+(define *abbreviations*
+  '(((make-int8 0) . (make-int8:0))
+    ((make-int8 1) . (make-int8:1))))
+  
+(define *expansions*
+  (map (lambda (x) (cons (cdr x) (car x))) *abbreviations*))
+
+(define (assembly-pack code)
+  (or (assoc-ref *abbreviations* code)
+      code))
+
+(define (assembly-unpack code)
+  (or (assoc-ref *expansions* code)
+      code))
+
+
+;;;
+;;; Encoder/decoder
+;;;
+
+(define (object->assembly x)
+  (cond ((eq? x #t) `(make-true))
+	((eq? x #f) `(make-false))
+	((null? x) `(make-eol))
+	((and (integer? x) (exact? x))
+	 (cond ((and (<= -128 x) (< x 128))
+		(assembly-pack `(make-int8 ,(modulo x 256))))
+	       ((and (<= -32768 x) (< x 32768))
+		(let ((n (if (< x 0) (+ x 65536) x)))
+		  `(make-int16 ,(quotient n 256) ,(modulo n 256))))
+               ((and (<= 0 x #xffffffffffffffff))
+                `(make-uint64 ,@(bytevector->u8-list
+                                 (let ((bv (make-bytevector 8)))
+                                   (bytevector-u64-set! bv 0 x (endianness big))
+                                   bv))))
+	       ((and (<= 0 (+ x #x8000000000000000) #x7fffffffffffffff))
+                `(make-int64 ,@(bytevector->u8-list
+                                (let ((bv (make-bytevector 8)))
+                                  (bytevector-s64-set! bv 0 x (endianness big))
+                                  bv))))
+	       (else #f)))
+	((char? x)
+         (cond ((<= (char->integer x) #xff)
+                `(make-char8 ,(char->integer x)))
+               (else
+                `(make-char32 ,(char->integer x)))))
+	(else #f)))
+
+(define (assembly->object code)
+  (pmatch code
+    ((make-true) #t)
+    ((make-false) #f) ;; FIXME: Same as the `else' case!
+    ((make-eol) '())
+    ((make-int8 ,n)
+     (if (< n 128) n (- n 256)))
+    ((make-int16 ,n1 ,n2)
+     (let ((n (+ (* n1 256) n2)))
+       (if (< n 32768) n (- n 65536))))
+    ((make-uint64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
+     (bytevector-u64-ref
+      (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
+      0
+      (endianness big)))
+    ((make-int64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
+     (bytevector-s64-ref
+      (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
+      0
+      (endianness big)))
+    ((make-char8 ,n)
+     (integer->char n))
+    ((make-char32 ,n1 ,n2 ,n3 ,n4)
+     (integer->char (+ (* n1 #x1000000)
+                       (* n2 #x10000)
+                       (* n3 #x100)
+                       n4)))
+    ((load-string ,s) s)
+    ((load-symbol ,s) (string->symbol s))
+    (else #f)))