module/language/assembly.scm

   1 ;;; Guile Virtual Machine Assembly
   2
   3 ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9 ;;
  10 ;; This program 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
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Code:
  21
  22 (define-module (language assembly)
  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
  28             assembly-pack assembly-unpack
  29             object->assembly assembly->object))
  30
  31 ;; nargs, nrest, nlocs, nexts, 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     ((define ,str)
  54      (+ 1 *len-len* (string-length str)))
  55     ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
  56      (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
  57     ((,inst . _) (guard (>= (instruction-length inst) 0))
  58      (+ 1 (instruction-length inst)))
  59     (else (error "unknown instruction" assembly))))
  60
  61
  62 (define *program-alignment* 8)
  63
  64 (define (addr+ addr code)
  65   (fold (lambda (x len) (+ (byte-length x) len))
  66         addr
  67         code))
  68
  69 (define (align-program prog addr)
  70   `(,@(make-list (modulo (- *program-alignment*
  71                             (modulo (1+ addr) *program-alignment*))
  72                          ;; plus the one for the load-program inst itself
  73                          *program-alignment*)
  74                  '(nop))
  75     ,prog))
  76
  77 ;;;
  78 ;;; Code compress/decompression
  79 ;;;
  80
  81 (define *abbreviations*
  82   '(((make-int8 0) . (make-int8:0))
  83     ((make-int8 1) . (make-int8:1))))
  84
  85 (define *expansions*
  86   (map (lambda (x) (cons (cdr x) (car x))) *abbreviations*))
  87
  88 (define (assembly-pack code)
  89   (or (assoc-ref *abbreviations* code)
  90       code))
  91
  92 (define (assembly-unpack code)
  93   (or (assoc-ref *expansions* code)
  94       code))
  95
  96 \f
  97 ;;;
  98 ;;; Encoder/decoder
  99 ;;;
 100
 101 (define (object->assembly x)
 102   (cond ((eq? x #t) `(make-true))
 103         ((eq? x #f) `(make-false))
 104         ((null? x) `(make-eol))
 105         ((and (integer? x) (exact? x))
 106          (cond ((and (<= -128 x) (< x 128))
 107                 `(make-int8 ,(modulo x 256)))
 108                ((and (<= -32768 x) (< x 32768))
 109                 (let ((n (if (< x 0) (+ x 65536) x)))
 110                   `(make-int16 ,(quotient n 256) ,(modulo n 256))))
 111                (else #f)))
 112         ((char? x) `(make-char8 ,(char->integer x)))
 113         (else #f)))
 114
 115 (define (assembly->object code)
 116   (pmatch code
 117     ((make-true) #t)
 118     ((make-false) #f) ;; FIXME: Same as the `else' case!
 119     ((make-eol) '())
 120     ((make-int8 ,n)
 121      (if (< n 128) n (- n 256)))
 122     ((make-int16 ,n1 ,n2)
 123      (let ((n (+ (* n1 256) n2)))
 124        (if (< n 32768) n (- n 65536))))
 125     ((make-char8 ,n)
 126      (integer->char n))
 127     ((load-string ,s) s)
 128     ((load-symbol ,s) (string->symbol s))
 129     ((load-keyword ,s) (symbol->keyword (string->symbol s)))
 130     (else #f)))