Updated the assembly process so that `u8vectors' are used. Compilation works.

* 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

module/system/base/compile.scm

@@ -57,8 +57,8 @@
   (let ((comp (compiled-file-name file)))
     (catch #t
       (lambda ()
-	(call-with-compile-error-catch
+;	(call-with-compile-error-catch
-	 (lambda ()
+;	 (lambda ()
 	   (call-with-output-file comp
 	     (lambda (port)
 	       (let* ((source (read-file-in file scheme))
@@ -66,8 +66,8 @@
 				      scheme opts)))
 		 (if (memq :c opts)
 		   (pprint-glil objcode port)
-		   (uniform-array-write (objcode->string objcode) port)))))
+		   (uniform-vector-write (objcode->u8vector objcode) port)))))
-	   (format #t "Wrote ~A\n" comp))))
+	   (format #t "Wrote ~A\n" comp))
       (lambda (key . args)
 	(format #t "ERROR: During compiling ~A:\n" file)
 	(display "ERROR: ")
@@ -76,6 +76,15 @@
 	(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)))

module/system/vm/assemble.scm

@@ -27,6 +27,7 @@
   :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)
@@ -89,7 +90,7 @@
 		  (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)
@@ -187,7 +188,9 @@
 (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))
@@ -198,7 +201,7 @@
 					       (modulo n 256))))))
 	  (loop (cons bytes result)
 		(cdr stack)
-		(+ addr (string-length bytes)))))))
+		(+ addr (u8vector-length bytes)))))))
 
 
 ;;;
@@ -208,6 +211,18 @@
 ;; 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!)
@@ -241,24 +256,24 @@
 	 (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))))

module/system/vm/conv.scm

@@ -23,6 +23,7 @@
   :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))
 
@@ -89,22 +90,38 @@
   (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)))
+	   ;; Typical instructions are `link' and `load-program'.
-	     (string-append head (encode-length (string-length str)) str)))
+	   (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 ()
@@ -115,7 +132,10 @@
 		 (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
@@ -133,16 +153,15 @@
 ;; NOTE: decoded in vm_fetch_length in vm.c as well.
 
 (define (encode-length len)
-  (define C integer->char)
+  (cond ((< len 254) (u8vector len))
-  (cond ((< len 254) (string (C 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)
+	 (u8vector 255
-		 (C (quotient len (* 256 256 256)))
+		   (quotient len (* 256 256 256))
-		 (C (modulo (quotient len (* 256 256)) 256))
+		   (modulo (quotient len (* 256 256)) 256)
-		 (C (modulo (quotient len 256) 256))
+		   (modulo (quotient len 256) 256)
-		 (C (modulo len 256))))
+		   (modulo len 256)))
 	(else (error "Too long code length:" len))))
 
 (define (decode-length pop)

src/Makefile.am

@@ -4,6 +4,8 @@ guile_vm_SOURCES = guile-vm.c
 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	\

src/objcodes.c

@@ -45,6 +45,7 @@
 #include <sys/mman.h>
 #include <sys/stat.h>
 #include <sys/types.h>
+#include <assert.h>
 
 #include "programs.h"
 #include "objcodes.h"
@@ -138,14 +139,20 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
 #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);
 
@@ -153,10 +160,9 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
   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;
 }
@@ -178,15 +184,22 @@ SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
 }
 #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),
+  size = SCM_OBJCODE_SIZE (objcode);
-			 0);
+  /* 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