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