* module/system/vm/conv.scm (encode-length): Use u8vectors.
(code->bytes): Likewise.
* module/system/vm/assemble.scm (codegen): Use u8vectors instead
of strings.
* src/objcodes.c (objcode->string): Removed.
(objcode->u8vector): New function.
* module/system/base/compile.scm (compile-file): Use `objcode->u8vector'
and `uniform-vector-write'.
git-archimport-id: lcourtes@laas.fr--2004-libre/guile-vm--revival--0.6--patch-3
(let ((comp (compiled-file-name file)))
(catch #t
(lambda ()
- (call-with-compile-error-catch
- (lambda ()
+; (call-with-compile-error-catch
+; (lambda ()
(call-with-output-file comp
(lambda (port)
(let* ((source (read-file-in file scheme))
scheme opts)))
(if (memq :c opts)
(pprint-glil objcode port)
- (uniform-array-write (objcode->string objcode) port)))))
- (format #t "Wrote ~A\n" comp))))
+ (uniform-vector-write (objcode->u8vector objcode) port)))))
+ (format #t "Wrote ~A\n" comp))
(lambda (key . args)
(format #t "ERROR: During compiling ~A:\n" file)
(display "ERROR: ")
(format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args))
(delete-file comp)))))
+; (let ((c-f compile-file))
+; ;; XXX: Debugging output
+; (set! compile-file
+; (lambda (file . opts)
+; (format #t "compile-file: ~a ~a~%" file opts)
+; (let ((result (apply c-f (cons file opts))))
+; (format #t "compile-file: returned ~a~%" result)
+; result))))
+
(define-public (load-source-file file . opts)
(let ((source (read-file-in file scheme)))
(apply compile-in source (current-module) scheme opts)))
:use-module (ice-9 match)
:use-module (ice-9 regex)
:use-module (ice-9 common-list)
+ :use-module (srfi srfi-4)
:export (preprocess assemble))
(define (assemble glil env . opts)
(push-code! `(object-ref ,i))))))
(define (current-address)
(define (byte-length x)
- (cond ((string? x) (string-length x))
+ (cond ((string? x) (u8vector-length x))
(else 3)))
(apply + (map byte-length stack)))
(define (generate-code x)
(define (stack->bytes stack label-alist)
(let loop ((result '()) (stack stack) (addr 0))
(if (null? stack)
- (apply string-append (reverse! result))
+ (apply u8vector
+ (apply append
+ (map u8vector->list (reverse! result))))
(let ((bytes (car stack)))
(if (pair? bytes)
(let* ((offset (- (assq-ref label-alist (cadr bytes))
(modulo n 256))))))
(loop (cons bytes result)
(cdr stack)
- (+ addr (string-length bytes)))))))
+ (+ addr (u8vector-length bytes)))))))
\f
;;;
;; NOTE: undumpped in vm_load.c.
(define (dump-object! push-code! x)
+ (define (symbol->u8vector sym)
+ (apply u8vector
+ (map char->integer
+ (string->list (symbol->string sym)))))
+ (define (number->u8vector num)
+ (apply u8vector
+ (map char->integer
+ (string->list (number->string num)))))
+ (define (string->u8vector str)
+ (apply u8vector
+ (map char->integer (string->list str))))
+
(let dump! ((x x))
(cond
((object->code x) => push-code!)
(push-code! `(load-program ,bytes)))
(($ <vlink> module name)
;; FIXME: dump module
- (push-code! `(link ,(symbol->string name))))
+ (push-code! `(link ,(symbol->u8vector name))))
(($ <vmod> id)
(push-code! `(load-module ,id)))
((and ($ integer) ($ exact))
(let ((str (do ((n x (quotient n 256))
(l '() (cons (modulo n 256) l)))
((= n 0)
- (list->string (map integer->char l))))))
+ (apply u8vector l)))))
(push-code! `(load-integer ,str))))
(($ number)
- (push-code! `(load-number ,(number->string x))))
+ (push-code! `(load-number ,(number->u8vector x))))
(($ string)
- (push-code! `(load-string ,x)))
+ (push-code! `(load-string ,(string->u8vector x))))
(($ symbol)
- (push-code! `(load-symbol ,(symbol->string x))))
+ (push-code! `(load-symbol ,(symbol->u8vector x))))
(($ keyword)
(push-code! `(load-keyword
- ,(symbol->string (keyword-dash-symbol x)))))
+ ,(symbol->u8vector (keyword-dash-symbol x)))))
(($ list)
(for-each dump! x)
(push-code! `(list ,(length x))))
:use-module (system vm core)
:use-module (ice-9 match)
:use-module (ice-9 regex)
+ :use-module (srfi srfi-4)
:export (code-pack code-unpack object->code code->object code->bytes
make-byte-decoder))
(let* ((code (code-pack code))
(inst (car code))
(rest (cdr code))
- (head (make-string 1 (integer->char (instruction->opcode inst))))
- (len (instruction-length inst)))
+ (len (instruction-length inst))
+ (head (instruction->opcode inst)))
(cond ((< len 0)
;; Variable-length code
- (let ((str (car rest)))
- (string-append head (encode-length (string-length str)) str)))
+ ;; Typical instructions are `link' and `load-program'.
+ (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
- (string-append head (list->string (map integer->char rest))))
+ (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 (string-length bytes)))
+ (let ((addr 0) (size (u8vector-length bytes)))
(define (pop)
- (let ((byte (char->integer (string-ref bytes addr))))
+ (let ((byte (char->integer (u8vector-ref bytes addr))))
(set! addr (1+ addr))
byte))
(lambda ()
(code (if (< n 0)
;; variable length
(let* ((end (+ (decode-length pop) addr))
- (str (substring bytes addr end)))
+ (str (apply u8vector
+ (list-tail (u8vector->list
+ bytes)
+ addr))))
(set! addr end)
(list inst str))
;; fixed length
;; NOTE: decoded in vm_fetch_length in vm.c as well.
(define (encode-length len)
- (define C integer->char)
- (cond ((< len 254) (string (C len)))
+ (cond ((< len 254) (u8vector len))
((< len (* 256 256))
- (string (C 254) (C (quotient len 256)) (C (modulo len 256))))
+ (u8vector 254 (quotient len 256) (modulo len 256)))
((< len most-positive-fixnum)
- (string (C 255)
- (C (quotient len (* 256 256 256)))
- (C (modulo (quotient len (* 256 256)) 256))
- (C (modulo (quotient len 256) 256))
- (C (modulo len 256))))
+ (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)
guile_vm_LDADD = libguilevm.la
guile_vm_LDFLAGS = $(GUILE_LDFLAGS)
+AM_CFLAGS = -Wall -g
+
lib_LTLIBRARIES = libguilevm.la
libguilevm_la_SOURCES = \
envs.c frames.c instructions.c objcodes.c programs.c vm.c \
#include <sys/mman.h>
#include <sys/stat.h>
#include <sys/types.h>
+#include <assert.h>
#include "programs.h"
#include "objcodes.h"
#define FUNC_NAME s_scm_bytecode_to_objcode
{
size_t size;
- char *base, *c_bytecode;
+ ssize_t increment;
+ scm_t_array_handle handle;
+ char *base;
+ const char *c_bytecode;
SCM objcode;
- SCM_VALIDATE_STRING (1, bytecode);
+ if (scm_u8vector_p (bytecode) != SCM_BOOL_T)
+ scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
SCM_VALIDATE_INUM (2, nlocs);
SCM_VALIDATE_INUM (3, nexts);
- size = scm_c_string_length (bytecode) + 10;
+ c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
+ assert (increment == 1);
+
objcode = make_objcode (size);
base = SCM_OBJCODE_BASE (objcode);
base[8] = scm_to_int (nlocs);
base[9] = scm_to_int (nexts);
- /* FIXME: We should really use SRFI-4 u8vectors! (Ludovic) */
- c_bytecode = scm_to_locale_string (bytecode);
memcpy (base + 10, c_bytecode, size - 10);
- free (c_bytecode);
+
+ scm_array_handle_release (&handle);
return objcode;
}
}
#undef FUNC_NAME
-SCM_DEFINE (scm_objcode_to_string, "objcode->string", 1, 0, 0,
+SCM_DEFINE (scm_objcode_to_u8vector, "objcode->u8vector", 1, 0, 0,
(SCM objcode),
"")
-#define FUNC_NAME s_scm_objcode_to_string
+#define FUNC_NAME s_scm_objcode_to_u8vector
{
+ char *u8vector;
+ size_t size;
+
SCM_VALIDATE_OBJCODE (1, objcode);
- return scm_makfromstr (SCM_OBJCODE_BASE (objcode),
- SCM_OBJCODE_SIZE (objcode),
- 0);
+
+ size = SCM_OBJCODE_SIZE (objcode);
+ /* FIXME: Is `gc_malloc' ok here? */
+ u8vector = scm_gc_malloc (size, "objcode-u8vector");
+ memcpy (u8vector, SCM_OBJCODE_BASE (objcode), size);
+
+ return scm_take_u8vector (u8vector, size);
}
#undef FUNC_NAME
HCoop / bpt / guile.git / commitdiff