module/system/vm/conv.scm

   1 ;;; Guile VM code converters
   2
   3 ;; Copyright (C) 2001 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 (system vm conv)
  23   :use-module (system vm core)
  24   :use-module (ice-9 match)
  25   :use-module (ice-9 regex)
  26   :export (code-pack code-unpack object->code code->object code->bytes
  27                      make-byte-decoder))
  28
  29 ;;;
  30 ;;; Code compress/decompression
  31 ;;;
  32
  33 (define (code-pack code)
  34   (match code
  35     ((inst (? integer? n))
  36      (cond ((< n 10)
  37             (let ((abbrev (string->symbol (format #f "~A:~A" inst n))))
  38               (if (instruction? abbrev) (list abbrev) code)))
  39            ((> n 255)
  40             (let ((double (string->symbol (format #f "~A*2" inst))))
  41               (if (instruction? double)
  42                   (list double (quotient n 256) (modulo n 256))
  43                   (apply error "Index out of range:" code))))
  44            (else code)))
  45     (else code)))
  46
  47 (define (code-unpack code)
  48   (let ((inst (symbol->string (car code))))
  49     (cond
  50      ((string-match "^([^:]*):([0-9]+)$" inst) =>
  51       (lambda (data)
  52         (cons* (string->symbol (match:substring data 1))
  53                (string->number (match:substring data 2))
  54                (cdr code))))
  55      (else code))))
  56
  57 \f
  58 ;;;
  59 ;;; Encoder/decoder
  60 ;;;
  61
  62 (define (object->code x)
  63   (cond ((eq? x #t) `(make-true))
  64         ((eq? x #f) `(make-false))
  65         ((null? x) `(make-eol))
  66         ((and (integer? x) (exact? x))
  67          (cond ((and (<= -128 x) (< x 128))
  68                 `(make-int8 ,(modulo x 256)))
  69                ((and (<= -32768 x) (< x 32768))
  70                 (let ((n (if (< x 0) (+ x 65536) x)))
  71                   `(make-int16 ,(quotient n 256) ,(modulo n 256))))
  72                (else #f)))
  73         ((char? x) `(make-char8 ,(char->integer x)))
  74         (else #f)))
  75
  76 (define (code->object code)
  77   (match code
  78     (('make-true) #t)
  79     (('make-false) #f) ;; FIXME: Same as the `else' case!
  80     (('make-eol) '())
  81     (('make-int8 n)
  82      (if (< n 128) n (- n 256)))
  83     (('make-int16 n1 n2)
  84      (let ((n (+ (* n1 256) n2)))
  85        (if (< n 32768) n (- n 65536))))
  86     (('make-char8 n)
  87      (integer->char n))
  88     (('load-string s) s)
  89     (('load-symbol s) (string->symbol s))
  90     (('load-keyword s) (symbol->keyword (string->symbol s)))
  91     (else #f)))
  92
  93 (define (code->bytes code)
  94   (let* ((inst (car code))
  95          (rest (cdr code))
  96          (head (make-string 1 (integer->char (instruction->opcode inst))))
  97          (len (instruction-length inst)))
  98     (cond ((< len 0)
  99            ;; Variable-length code
 100            (let ((str (car rest)))
 101              (string-append head (encode-length (string-length str)) str)))
 102           ((= len (length rest))
 103            ;; Fixed-length code
 104            (string-append head (list->string (map integer->char rest))))
 105           (else
 106            (error "Invalid code:" code)))))
 107
 108 (define (make-byte-decoder bytes)
 109   (let ((addr 0) (size (string-length bytes)))
 110     (define (pop)
 111       (let ((byte (char->integer (string-ref bytes addr))))
 112         (set! addr (1+ addr))
 113         byte))
 114     (lambda ()
 115       (if (< addr size)
 116           (let* ((start addr)
 117                  (inst (opcode->instruction (pop)))
 118                  (n (instruction-length inst))
 119                  (code (if (< n 0)
 120                            ;; variable length
 121                            (let* ((end (+ (decode-length pop) addr))
 122                                   (str (substring bytes addr end)))
 123                              (set! addr end)
 124                              (list inst str))
 125                            ;; fixed length
 126                            (do ((n n (1- n))
 127                                 (l '() (cons (pop) l)))
 128                                ((= n 0) (cons* inst (reverse! l)))))))
 129             (values start code))
 130           #f))))
 131
 132 \f
 133 ;;;
 134 ;;; Variable-length code
 135 ;;;
 136
 137 (define (encode-length len)
 138   (define C integer->char)
 139   (cond ((< len 254) (string (C len)))
 140         ((< len (* 256 256))
 141          (string (C 254) (C (quotient len 256)) (C (modulo len 256))))
 142         ((< len most-positive-fixnum)
 143          (string (C 255)
 144                  (C (quotient len (* 256 256 256)))
 145                  (C (modulo (quotient len (* 256 256)) 256))
 146                  (C (modulo (quotient len 256) 256))
 147                  (C (modulo len 256))))
 148         (else (error "Too long code length:" len))))
 149
 150 (define (decode-length pop)
 151   (let ((len (pop)))
 152     (cond ((< len 254) len)
 153           ((= len 254) (+ (* (pop) 256) (pop)))
 154           (else (+ (* (pop) 256 256 256)
 155                    (* (pop) 256 256)
 156                    (* (pop) 256)
 157                    (pop))))))