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