module/language/assembly.scm

   1 ;;; Guile Virtual Machine Assembly
   2
   3 ;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (language assembly)
  22   #:use-module (rnrs bytevectors)
  23   #:use-module (system base pmatch)
  24   #:use-module (system vm instruction)
  25   #:use-module ((srfi srfi-1) #:select (fold))
  26   #:export (byte-length
  27             addr+ align-program align-code align-block
  28             assembly-pack assembly-unpack
  29             object->assembly assembly->object))
  30
  31 ;; len, metalen
  32 (define *program-header-len* (+ 4 4))
  33
  34 ;; lengths are encoded in 3 bytes
  35 (define *len-len* 3)
  36
  37
  38 (define (byte-length assembly)
  39   (pmatch assembly
  40     ((,inst . _) (guard (>= (instruction-length inst) 0))
  41      (+ 1 (instruction-length inst)))
  42     ((load-number ,str)
  43      (+ 1 *len-len* (string-length str)))
  44     ((load-string ,str)
  45      (+ 1 *len-len* (string-length str)))
  46     ((load-wide-string ,str)
  47      (+ 1 *len-len* (* 4 (string-length str))))
  48     ((load-symbol ,str)
  49      (+ 1 *len-len* (string-length str)))
  50     ((load-array ,bv)
  51      (+ 1 *len-len* (bytevector-length bv)))
  52     ((load-program ,labels ,len ,meta . ,code)
  53      (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
  54     (,label (guard (not (pair? label)))
  55      0)
  56     (else (error "unknown instruction" assembly))))
  57
  58
  59 (define *program-alignment* 8)
  60
  61 (define (addr+ addr code)
  62   (fold (lambda (x len) (+ (byte-length x) len))
  63         addr
  64         code))
  65
  66 (define (code-alignment addr alignment header-len)
  67   (make-list (modulo (- alignment
  68                         (modulo (+ addr header-len) alignment))
  69                      alignment)
  70              '(nop)))
  71
  72 (define (align-block addr)
  73   '())
  74
  75 (define (align-code code addr alignment header-len)
  76   `(,@(code-alignment addr alignment header-len)
  77     ,code))
  78
  79 (define (align-program prog addr)
  80   (align-code prog addr *program-alignment* 1))
  81
  82 ;;;
  83 ;;; Code compress/decompression
  84 ;;;
  85
  86 (define *abbreviations*
  87   '(((make-int8 0) . (make-int8:0))
  88     ((make-int8 1) . (make-int8:1))))
  89
  90 (define *expansions*
  91   (map (lambda (x) (cons (cdr x) (car x))) *abbreviations*))
  92
  93 (define (assembly-pack code)
  94   (or (assoc-ref *abbreviations* code)
  95       code))
  96
  97 (define (assembly-unpack code)
  98   (or (assoc-ref *expansions* code)
  99       code))
 100
 101 \f
 102 ;;;
 103 ;;; Encoder/decoder
 104 ;;;
 105
 106 (define (object->assembly x)
 107   (cond ((eq? x #t) `(make-true))
 108         ((eq? x #f) `(make-false))
 109         ((eq? x #nil) `(make-nil))
 110         ((null? x) `(make-eol))
 111         ((and (integer? x) (exact? x))
 112          (cond ((and (<= -128 x) (< x 128))
 113                 (assembly-pack `(make-int8 ,(modulo x 256))))
 114                ((and (<= -32768 x) (< x 32768))
 115                 (let ((n (if (< x 0) (+ x 65536) x)))
 116                   `(make-int16 ,(quotient n 256) ,(modulo n 256))))
 117                ((and (<= 0 x #xffffffffffffffff))
 118                 `(make-uint64 ,@(bytevector->u8-list
 119                                  (let ((bv (make-bytevector 8)))
 120                                    (bytevector-u64-set! bv 0 x (endianness big))
 121                                    bv))))
 122                ((and (<= 0 (+ x #x8000000000000000) #x7fffffffffffffff))
 123                 `(make-int64 ,@(bytevector->u8-list
 124                                 (let ((bv (make-bytevector 8)))
 125                                   (bytevector-s64-set! bv 0 x (endianness big))
 126                                   bv))))
 127                (else #f)))
 128         ((char? x)
 129          (cond ((<= (char->integer x) #xff)
 130                 `(make-char8 ,(char->integer x)))
 131                (else
 132                 `(make-char32 ,(char->integer x)))))
 133         (else #f)))
 134
 135 (define (assembly->object code)
 136   (pmatch code
 137     ((make-true) #t)
 138     ((make-false) #f) ;; FIXME: Same as the `else' case!
 139     ((make-nil) #nil)
 140     ((make-eol) '())
 141     ((make-int8 ,n)
 142      (if (< n 128) n (- n 256)))
 143     ((make-int16 ,n1 ,n2)
 144      (let ((n (+ (* n1 256) n2)))
 145        (if (< n 32768) n (- n 65536))))
 146     ((make-uint64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
 147      (bytevector-u64-ref
 148       (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
 149       0
 150       (endianness big)))
 151     ((make-int64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
 152      (bytevector-s64-ref
 153       (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
 154       0
 155       (endianness big)))
 156     ((make-char8 ,n)
 157      (integer->char n))
 158     ((make-char32 ,n1 ,n2 ,n3 ,n4)
 159      (integer->char (+ (* n1 #x1000000)
 160                        (* n2 #x10000)
 161                        (* n3 #x100)
 162                        n4)))
 163     ((load-string ,s) s)
 164     ((load-symbol ,s) (string->symbol s))
 165     (else #f)))