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
  28             assembly-pack assembly-unpack
  29             object->assembly assembly->object))
  30
  31 ;; nargs, nrest, nlocs, <unused>, len, metalen
  32 (define *program-header-len* (+ 1 1 1 1 4 4))
  33
  34 ;; lengths are encoded in 3 bytes
  35 (define *len-len* 3)
  36
  37 (define (byte-length assembly)
  38   (pmatch assembly
  39     (,label (guard (not (pair? label)))
  40      0)
  41     ((load-unsigned-integer ,str)
  42      (+ 1 *len-len* (string-length str)))
  43     ((load-integer ,str)
  44      (+ 1 *len-len* (string-length str)))
  45     ((load-number ,str)
  46      (+ 1 *len-len* (string-length str)))
  47     ((load-string ,str)
  48      (+ 1 *len-len* (string-length str)))
  49     ((load-symbol ,str)
  50      (+ 1 *len-len* (string-length str)))
  51     ((load-keyword ,str)
  52      (+ 1 *len-len* (string-length str)))
  53     ((load-array ,bv)
  54      (+ 1 *len-len* (bytevector-length bv)))
  55     ((define ,str)
  56      (+ 1 *len-len* (string-length str)))
  57     ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
  58      (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
  59     ((,inst . _) (guard (>= (instruction-length inst) 0))
  60      (+ 1 (instruction-length inst)))
  61     (else (error "unknown instruction" assembly))))
  62
  63
  64 (define *program-alignment* 8)
  65
  66 (define (addr+ addr code)
  67   (fold (lambda (x len) (+ (byte-length x) len))
  68         addr
  69         code))
  70
  71
  72 (define (align-code code addr alignment header-len)
  73   `(,@(make-list (modulo (- alignment
  74                             (modulo (+ addr header-len) alignment))
  75                          alignment)
  76                  '(nop))
  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         ((null? x) `(make-eol))
 110         ((and (integer? x) (exact? x))
 111          (cond ((and (<= -128 x) (< x 128))
 112                 `(make-int8 ,(modulo x 256)))
 113                ((and (<= -32768 x) (< x 32768))
 114                 (let ((n (if (< x 0) (+ x 65536) x)))
 115                   `(make-int16 ,(quotient n 256) ,(modulo n 256))))
 116                ((and (<= 0 x #xffffffffffffffff))
 117                 `(make-uint64 ,@(bytevector->u8-list
 118                                  (let ((bv (make-bytevector 8)))
 119                                    (bytevector-u64-set! bv 0 x (endianness big))
 120                                    bv))))
 121                ((and (<= 0 (+ x #x8000000000000000) #x7fffffffffffffff))
 122                 `(make-int64 ,@(bytevector->u8-list
 123                                 (let ((bv (make-bytevector 8)))
 124                                   (bytevector-s64-set! bv 0 x (endianness big))
 125                                   bv))))
 126                (else #f)))
 127         ((char? x) `(make-char8 ,(char->integer x)))
 128         (else #f)))
 129
 130 (define (assembly->object code)
 131   (pmatch code
 132     ((make-true) #t)
 133     ((make-false) #f) ;; FIXME: Same as the `else' case!
 134     ((make-eol) '())
 135     ((make-int8 ,n)
 136      (if (< n 128) n (- n 256)))
 137     ((make-int16 ,n1 ,n2)
 138      (let ((n (+ (* n1 256) n2)))
 139        (if (< n 32768) n (- n 65536))))
 140     ((make-uint64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
 141      (bytevector-u64-ref
 142       (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
 143       0
 144       (endianness big)))
 145     ((make-int64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
 146      (bytevector-s64-ref
 147       (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
 148       0
 149       (endianness big)))
 150     ((make-char8 ,n)
 151      (integer->char n))
 152     ((load-string ,s) s)
 153     ((load-symbol ,s) (string->symbol s))
 154     ((load-keyword ,s) (symbol->keyword (string->symbol s)))
 155     (else #f)))