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   :use-module (srfi srfi-4)
  27   :export (code-pack code-unpack object->code code->object code->bytes
  28                      make-byte-decoder))
  29
  30 ;;;
  31 ;;; Code compress/decompression
  32 ;;;
  33
  34 (define (code-pack code)
  35   (match code
  36     ((inst (? integer? n))
  37      (cond ((< n 10)
  38             (let ((abbrev (string->symbol (format #f "~A:~A" inst n))))
  39               (if (instruction? abbrev) (list abbrev) code)))
  40            (else code)))
  41     (else code)))
  42
  43 (define (code-unpack code)
  44   (let ((inst (symbol->string (car code))))
  45     (cond
  46      ((string-match "^([^:]*):([0-9]+)$" inst) =>
  47       (lambda (data)
  48         (cons* (string->symbol (match:substring data 1))
  49                (string->number (match:substring data 2))
  50                (cdr code))))
  51      (else code))))
  52
  53 \f
  54 ;;;
  55 ;;; Encoder/decoder
  56 ;;;
  57
  58 (define (object->code x)
  59   (cond ((eq? x #t) `(make-true))
  60         ((eq? x #f) `(make-false))
  61         ((null? x) `(make-eol))
  62         ((and (integer? x) (exact? x))
  63          (cond ((and (<= -128 x) (< x 128))
  64                 `(make-int8 ,(modulo x 256)))
  65                ((and (<= -32768 x) (< x 32768))
  66                 (let ((n (if (< x 0) (+ x 65536) x)))
  67                   `(make-int16 ,(quotient n 256) ,(modulo n 256))))
  68                (else #f)))
  69         ((char? x) `(make-char8 ,(char->integer x)))
  70         (else #f)))
  71
  72 (define (code->object code)
  73   (match code
  74     (('make-true) #t)
  75     (('make-false) #f) ;; FIXME: Same as the `else' case!
  76     (('make-eol) '())
  77     (('make-int8 n)
  78      (if (< n 128) n (- n 256)))
  79     (('make-int16 n1 n2)
  80      (let ((n (+ (* n1 256) n2)))
  81        (if (< n 32768) n (- n 65536))))
  82     (('make-char8 n)
  83      (integer->char n))
  84     (('load-string s) s)
  85     (('load-symbol s) (string->symbol s))
  86     (('load-keyword s) (make-keyword-from-dash-symbol (string->symbol s)))
  87     (else #f)))
  88
  89 (define (code->bytes code)
  90   (let* ((code (code-pack code))
  91          (inst (car code))
  92          (rest (cdr code))
  93          (len (instruction-length inst))
  94          (head (instruction->opcode inst)))
  95     (cond ((< len 0)
  96            ;; Variable-length code
  97            ;; Typical instructions are `link' and `load-program'.
  98            (let* ((str (car rest))
  99                   (str-len (u8vector-length str))
 100                   (encoded-len (encode-length str-len))
 101                   (encoded-len-len (u8vector-length encoded-len)))
 102              (apply u8vector
 103                     (append (cons head (u8vector->list encoded-len))
 104                             (u8vector->list str)))))
 105           ((= len (length rest))
 106            ;; Fixed-length code
 107            (apply u8vector (cons head rest)))
 108           (else
 109            (error "Invalid code:" code)))))
 110
 111 ; (let ((c->b code->bytes))
 112 ;   ;; XXX: Debugging output
 113 ;   (set! code->bytes
 114 ;       (lambda (code)
 115 ;         (format #t "code->bytes: ~a~%" code)
 116 ;         (let ((result (c->b code)))
 117 ;           (format #t "code->bytes: returned ~a~%" result)
 118 ;           result))))
 119
 120
 121 (define (make-byte-decoder bytes)
 122   (let ((addr 0) (size (u8vector-length bytes)))
 123     (define (pop)
 124       (let ((byte (char->integer (u8vector-ref bytes addr))))
 125         (set! addr (1+ addr))
 126         byte))
 127     (lambda ()
 128       (if (< addr size)
 129           (let* ((start addr)
 130                  (inst (opcode->instruction (pop)))
 131                  (n (instruction-length inst))
 132                  (code (if (< n 0)
 133                            ;; variable length
 134                            (let* ((end (+ (decode-length pop) addr))
 135                                   (str (apply u8vector
 136                                               (list-tail (u8vector->list
 137                                                           bytes)
 138                                                          addr))))
 139                              (set! addr end)
 140                              (list inst str))
 141                            ;; fixed length
 142                            (do ((n n (1- n))
 143                                 (l '() (cons (pop) l)))
 144                                ((= n 0) (cons* inst (reverse! l)))))))
 145             (values start code))
 146           #f))))
 147
 148 \f
 149 ;;;
 150 ;;; Variable-length interface
 151 ;;;
 152
 153 ;; NOTE: decoded in vm_fetch_length in vm.c as well.
 154
 155 (define (encode-length len)
 156   (cond ((< len 254) (u8vector len))
 157         ((< len (* 256 256))
 158          (u8vector 254 (quotient len 256) (modulo len 256)))
 159         ((< len most-positive-fixnum)
 160          (u8vector 255
 161                    (quotient len (* 256 256 256))
 162                    (modulo (quotient len (* 256 256)) 256)
 163                    (modulo (quotient len 256) 256)
 164                    (modulo len 256)))
 165         (else (error "Too long code length:" len))))
 166
 167 (define (decode-length pop)
 168   (let ((len (pop)))
 169     (cond ((< len 254) len)
 170           ((= len 254) (+ (* (pop) 256) (pop)))
 171           (else (+ (* (pop) 256 256 256)
 172                    (* (pop) 256 256)
 173                    (* (pop) 256)
 174                    (pop))))))