diff options
Diffstat (limited to 'module/system/vm/conv.scm')
| -rw-r--r-- | module/system/vm/conv.scm | 196 |
1 files changed, 196 insertions, 0 deletions
diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm new file mode 100644 index 000000000..89993f6a3 --- /dev/null +++ b/module/system/vm/conv.scm @@ -0,0 +1,196 @@ +;;; Guile VM code converters + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (system vm conv) + :use-module ((system vm core) + :select (instruction? instruction-length + instruction->opcode opcode->instruction)) + :use-module (system base pmatch) + :use-module (ice-9 regex) + :use-module (srfi srfi-4) + :use-module (srfi srfi-1) + :export (code-pack code-unpack object->code code->object code->bytes + make-byte-decoder)) + +;;; +;;; Code compress/decompression +;;; + +(define (code-pack code) + (pmatch code + ((inst ,n) (guard (integer? n)) + (cond ((< n 10) + (let ((abbrev (string->symbol (format #f "~A:~A" inst n)))) + (if (instruction? abbrev) (list abbrev) code))) + (else code))) + (else code))) + +(define (code-unpack code) + (let ((inst (symbol->string (car code)))) + (cond + ((string-match "^([^:]*):([0-9]+)$" inst) => + (lambda (data) + (cons* (string->symbol (match:substring data 1)) + (string->number (match:substring data 2)) + (cdr code)))) + (else code)))) + + +;;; +;;; Encoder/decoder +;;; + +(define (object->code x) + (cond ((eq? x #t) `(make-true)) + ((eq? x #f) `(make-false)) + ((null? x) `(make-eol)) + ((and (integer? x) (exact? x)) + (cond ((and (<= -128 x) (< x 128)) + `(make-int8 ,(modulo x 256))) + ((and (<= -32768 x) (< x 32768)) + (let ((n (if (< x 0) (+ x 65536) x))) + `(make-int16 ,(quotient n 256) ,(modulo n 256)))) + (else #f))) + ((char? x) `(make-char8 ,(char->integer x))) + (else #f))) + +(define (code->object code) + (pmatch code + ((make-true) #t) + ((make-false) #f) ;; FIXME: Same as the `else' case! + ((make-eol) '()) + ((make-int8 ,n) + (if (< n 128) n (- n 256))) + ((make-int16 ,n1 ,n2) + (let ((n (+ (* n1 256) n2))) + (if (< n 32768) n (- n 65536)))) + ((make-char8 ,n) + (integer->char n)) + ((load-string ,s) s) + ((load-symbol ,s) (string->symbol s)) + ((load-keyword ,s) (symbol->keyword (string->symbol s))) + (else #f))) + +; (let ((c->o code->object)) +; (set! code->object +; (lambda (code) +; (format #t "code->object: ~a~%" code) +; (let ((ret (c->o code))) +; (format #t "code->object returned ~a~%" ret) +; ret)))) + +(define (code->bytes code) + (define (string->u8vector str) + (apply u8vector (map char->integer (string->list str)))) + + (let* ((code (code-pack code)) + (inst (car code)) + (rest (cdr code)) + (len (instruction-length inst)) + (head (instruction->opcode inst))) + (cond ((< len 0) + ;; Variable-length code + ;; Typical instructions are `link' and `load-program'. + (if (string? (car rest)) + (set-car! rest (string->u8vector (car rest)))) + (let* ((str (car rest)) + (str-len (u8vector-length str)) + (encoded-len (encode-length str-len)) + (encoded-len-len (u8vector-length encoded-len))) + (apply u8vector + (append (cons head (u8vector->list encoded-len)) + (u8vector->list str))))) + ((= len (length rest)) + ;; Fixed-length code + (apply u8vector (cons head rest))) + (else + (error "Invalid code:" code))))) + +; (let ((c->b code->bytes)) +; ;; XXX: Debugging output +; (set! code->bytes +; (lambda (code) +; (format #t "code->bytes: ~a~%" code) +; (let ((result (c->b code))) +; (format #t "code->bytes: returned ~a~%" result) +; result)))) + + +(define (make-byte-decoder bytes) + (let ((addr 0) (size (u8vector-length bytes))) + (define (pop) + (let ((byte (u8vector-ref bytes addr))) + (set! addr (1+ addr)) + byte)) + (define (sublist lst start end) + (take (drop lst start) (- end start))) + (lambda () + (if (< addr size) + (let* ((start addr) + (inst (opcode->instruction (pop))) + (n (instruction-length inst)) + (code (if (< n 0) + ;; variable length + (let* ((end (+ (decode-length pop) addr)) + (subbytes (sublist + (u8vector->list bytes) + addr end)) + (->string? (not (eq? inst 'load-program)))) + (set! addr end) + (list inst + (if ->string? + (list->string + (map integer->char subbytes)) + (apply u8vector subbytes)))) + ;; fixed length + (do ((n n (1- n)) + (l '() (cons (pop) l))) + ((= n 0) (cons* inst (reverse! l))))))) + (values start code)) + #f)))) + + +;;; +;;; Variable-length interface +;;; + +;; NOTE: decoded in vm_fetch_length in vm.c as well. + +(define (encode-length len) + (cond ((< len 254) (u8vector len)) + ((< len (* 256 256)) + (u8vector 254 (quotient len 256) (modulo len 256))) + ((< len most-positive-fixnum) + (u8vector 255 + (quotient len (* 256 256 256)) + (modulo (quotient len (* 256 256)) 256) + (modulo (quotient len 256) 256) + (modulo len 256))) + (else (error "Too long code length:" len)))) + +(define (decode-length pop) + (let ((len (pop))) + (cond ((< len 254) len) + ((= len 254) (+ (* (pop) 256) (pop))) + (else (+ (* (pop) 256 256 256) + (* (pop) 256 256) + (* (pop) 256) + (pop)))))) |