module/language/assembly.scm

   1 ;;; Guile Virtual Machine Assembly
   2
   3 ;; Copyright (C) 2001, 2009 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 bytevector)
  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 ;; nargs, nrest, nlocs, len, metalen, padding
  32 (define *program-header-len* (+ 1 1 2 4 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     (,label (guard (not (pair? label)))
  41      0)
  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 ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
  53      (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
  54     ((,inst . _) (guard (>= (instruction-length inst) 0))
  55      (+ 1 (instruction-length inst)))
  56     (else (error "unknown instruction" assembly))))
  57
  58
  59 (define *program-alignment* 8)
  60
  61 (define *block-alignment* 8)
  62
  63 (define (addr+ addr code)
  64   (fold (lambda (x len) (+ (byte-length x) len))
  65         addr
  66         code))
  67
  68 (define (code-alignment addr alignment header-len)
  69   (make-list (modulo (- alignment
  70                         (modulo (+ addr header-len) alignment))
  71                      alignment)
  72              '(nop)))
  73
  74 (define (align-block addr)
  75   (code-alignment addr *block-alignment* 0))
  76
  77 (define (align-code code addr alignment header-len)
  78   `(,@(code-alignment addr alignment header-len)
  79     ,code))
  80
  81 (define (align-program prog addr)
  82   (align-code prog addr *program-alignment* 1))
  83
  84 ;;;
  85 ;;; Code compress/decompression
  86 ;;;
  87
  88 (define *abbreviations*
  89   '(((make-int8 0) . (make-int8:0))
  90     ((make-int8 1) . (make-int8:1))))
  91
  92 (define *expansions*
  93   (map (lambda (x) (cons (cdr x) (car x))) *abbreviations*))
  94
  95 (define (assembly-pack code)
  96   (or (assoc-ref *abbreviations* code)
  97       code))
  98
  99 (define (assembly-unpack code)
 100   (or (assoc-ref *expansions* code)
 101       code))
 102
 103 \f
 104 ;;;
 105 ;;; Encoder/decoder
 106 ;;;
 107
 108 (define (object->assembly x)
 109   (cond ((eq? x #t) `(make-true))
 110         ((eq? x #f) `(make-false))
 111         ((null? x) `(make-eol))
 112         ((and (integer? x) (exact? x))
 113          (cond ((and (<= -128 x) (< x 128))
 114                 (assembly-pack `(make-int8 ,(modulo x 256))))
 115                ((and (<= -32768 x) (< x 32768))
 116                 (let ((n (if (< x 0) (+ x 65536) x)))
 117                   `(make-int16 ,(quotient n 256) ,(modulo n 256))))
 118                ((and (<= 0 x #xffffffffffffffff))
 119                 `(make-uint64 ,@(bytevector->u8-list
 120                                  (let ((bv (make-bytevector 8)))
 121                                    (bytevector-u64-set! bv 0 x (endianness big))
 122                                    bv))))
 123                ((and (<= 0 (+ x #x8000000000000000) #x7fffffffffffffff))
 124                 `(make-int64 ,@(bytevector->u8-list
 125                                 (let ((bv (make-bytevector 8)))
 126                                   (bytevector-s64-set! bv 0 x (endianness big))
 127                                   bv))))
 128                (else #f)))
 129         ((char? x)
 130          (cond ((<= (char->integer x) #xff)
 131                 `(make-char8 ,(char->integer x)))
 132                (else
 133                 `(make-char32 ,(char->integer x)))))
 134         (else #f)))
 135
 136 (define (assembly->object code)
 137   (pmatch code
 138     ((make-true) #t)
 139     ((make-false) #f) ;; FIXME: Same as the `else' case!
 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)))