static opcodes; refactor program/objcode division; use new assembly pipeline

[bpt/guile.git] / module / language / assembly.scm

diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index baeba29..e66e753 100644 (file)
--- a/module/language/assembly.scm
+++ b/module/language/assembly.scm
@@ -22,28 +22,85 @@
 (define-module (language assembly)
   #:use-module (system base pmatch)
   #:use-module (system vm instruction)
-  #:export (byte-length))
+  #:export (byte-length code-pack code-unpack object->code code->object))
+
+(define (len+ len)
+  (+ 3 len))
 
 (define (byte-length x)
   (pmatch x
     (,label (guard (not (pair? label)))
      0)
-    ;; instructions take one byte, hence the 1+.
     ((load-integer ,str)
-     (1+ (string-length str)))
+     (1+ (len+ (string-length str))))
     ((load-number ,str)
-     (1+ (string-length str)))
+     (1+ (len+ (string-length str))))
     ((load-string ,str)
-     (1+ (string-length str)))
+     (1+ (len+ (string-length str))))
     ((load-symbol ,str)
-     (1+ (string-length str)))
+     (1+ (len+ (string-length str))))
     ((load-keyword ,str)
-     (1+ (string-length str)))
+     (1+ (len+ (string-length str))))
     ((define ,str)
-     (1+ (string-length str)))
-    ((assembly ,nargs ,nrest ,nlocs ,nexts ,labels ,len . ,code)
+     (1+ (len+ (string-length str))))
+    ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len . ,code)
      ;; lengths of nargs, nrest, nlocs, nexts, len, and code, respectively
-     (+ 1 1 1 1 4 len))
+     (1+ (+ 1 1 1 1 4 len)))
     ((,inst . _) (guard (>= (instruction-length inst) 0))
      (1+ (instruction-length inst)))
     (else (error "unknown instruction" x))))
+
+;;;
+;;; 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 (code-pack code)
+  (or (assoc-ref code *abbreviations*)
+      code))
+
+(define (code-unpack code)
+  (or (assoc-ref code *expansions*)
+      code))
+
+\f
+;;;
+;;; Encoder/decoder
+;;;
+
+(define (object->code 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))
+               `(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))))
+              (else #f)))
+       ((char? x) `(make-char8 ,(char->integer x)))
+       (else #f)))
+
+(define (code->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-char8 ,n)
+     (integer->char n))
+    ((load-string ,s) s)
+    ((load-symbol ,s) (string->symbol s))
+    ((load-keyword ,s) (symbol->keyword (string->symbol s)))
+    (else #f)))