summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/objcodes.c36
-rw-r--r--libguile/objcodes.h1
-rw-r--r--module/language/assembly.scm4
-rw-r--r--module/language/assembly/compile-bytecode.scm14
-rw-r--r--module/language/assembly/decompile-bytecode.scm11
-rw-r--r--module/language/assembly/disassemble.scm2
-rw-r--r--module/language/glil/compile-assembly.scm2
-rw-r--r--module/system/vm/objcode.scm3
-rw-r--r--test-suite/tests/asm-to-bytecode.test15
9 files changed, 65 insertions, 23 deletions
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 5796a5486..eb40213e9 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -92,10 +92,10 @@ make_objcode_by_mmap (int fd)
data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE));
- if (data->len != (st.st_size - sizeof (*data) - strlen (OBJCODE_COOKIE)))
+ if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (OBJCODE_COOKIE)))
scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
SCM_LIST2 (scm_from_size_t (st.st_size),
- scm_from_uint32 (data->len)));
+ scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (OBJCODE_COOKIE),
SCM_PACK (SCM_BOOL_F), fd);
@@ -118,14 +118,16 @@ scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr)
parent_data = SCM_OBJCODE_DATA (parent);
if (ptr < parent_data->base
- || ptr >= (parent_data->base + parent_data->len
+ || ptr >= (parent_data->base + parent_data->len + parent_data->metalen
- sizeof (struct scm_objcode)))
- scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a)",
- SCM_LIST2 (scm_from_ulong ((ulong)ptr),
- scm_from_uint32 (parent_data->len)));
+ scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)",
+ SCM_LIST4 (scm_from_ulong ((ulong)ptr),
+ scm_from_ulong ((ulong)parent_data->base),
+ scm_from_uint32 (parent_data->len),
+ scm_from_uint32 (parent_data->metalen)));
data = (struct scm_objcode*)ptr;
- if (data->base + data->len > parent_data->base + parent_data->len)
+ if (data->base + data->len + data->metalen > parent_data->base + parent_data->len + parent_data->metalen)
abort ();
SCM_NEWSMOB2 (ret, scm_tc16_objcode, data, parent);
@@ -154,6 +156,21 @@ SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0,
+ (SCM objcode),
+ "")
+#define FUNC_NAME s_scm_objcode_meta
+{
+ SCM_VALIDATE_OBJCODE (1, objcode);
+
+ if (SCM_OBJCODE_META_LEN (objcode) == 0)
+ return SCM_BOOL_F;
+ else
+ return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode)
+ + SCM_OBJCODE_LEN (objcode)));
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
(SCM bytecode),
"")
@@ -180,6 +197,7 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
/* foolishly, we assume that as long as bytecode is around, that c_bytecode
will be of the same length; perhaps a bad assumption? */
+ /* FIXME: check length of bytecode */
return objcode;
}
@@ -214,7 +232,7 @@ SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0,
SCM_VALIDATE_OBJCODE (1, objcode);
- len = SCM_OBJCODE_DATA (objcode)->len + sizeof(struct scm_objcode);
+ len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
/* FIXME: Is `gc_malloc' ok here? */
u8vector = scm_gc_malloc (len, "objcode-u8vector");
memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len);
@@ -233,7 +251,7 @@ SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
scm_c_write (port, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE));
scm_c_write (port, SCM_OBJCODE_DATA (objcode),
- SCM_OBJCODE_LEN (objcode) + sizeof (struct scm_objcode));
+ sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode));
return SCM_UNSPECIFIED;
}
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 7480a03c1..222691668 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -82,6 +82,7 @@ extern scm_t_bits scm_tc16_objcode;
SCM scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr);
extern SCM scm_load_objcode (SCM file);
extern SCM scm_objcode_p (SCM obj);
+extern SCM scm_objcode_meta (SCM objcode);
extern SCM scm_bytecode_to_objcode (SCM bytecode);
extern SCM scm_objcode_to_bytecode (SCM objcode);
extern SCM scm_write_objcode (SCM objcode, SCM port);
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index 8887eab4b..0d62fe9f9 100644
--- a/module/language/assembly.scm
+++ b/module/language/assembly.scm
@@ -48,8 +48,8 @@
(+ 1 *len-len* (string-length str)))
((define ,str)
(+ 1 *len-len* (string-length str)))
- ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,metalen . ,code)
- (+ 1 *program-header-len* len metalen))
+ ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
+ (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
((,inst . _) (guard (>= (instruction-length inst) 0))
(+ 1 (instruction-length inst)))
(else (error "unknown instruction" assembly))))
diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
index bf423ab74..7f1271d2c 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -81,19 +81,27 @@
(write-byte opcode)
(pmatch asm
((load-program ,nargs ,nrest ,nlocs ,nexts
- ,labels ,length ,metalength . ,code)
+ ,labels ,length ,meta . ,code)
(write-byte nargs)
(write-byte nrest)
(write-byte nlocs)
(write-byte nexts)
(write-uint32-le length) ;; FIXME!
- (write-uint32-le metalength) ;; FIXME!
+ (write-uint32-le (if meta (1- (byte-length meta)) 0)) ;; FIXME!
(letrec ((i 0)
(write (lambda (x) (set! i (1+ i)) (write-byte x)))
(get-addr (lambda () i)))
(for-each (lambda (asm)
(write-bytecode asm write get-addr labels))
- code)))
+ code))
+ (if meta
+ ;; don't write the load-program byte for metadata
+ (letrec ((i -1)
+ (write (lambda (x)
+ (set! i (1+ i))
+ (if (> i 0) (write-byte x))))
+ (get-addr (lambda () i)))
+ (write-bytecode meta write get-addr '()))))
((load-integer ,str) (write-loader str))
((load-number ,str) (write-loader str))
((load-string ,str) (write-loader str))
diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm
index e8d175d23..abfc561fa 100644
--- a/module/language/assembly/decompile-bytecode.scm
+++ b/module/language/assembly/decompile-bytecode.scm
@@ -48,16 +48,17 @@
(totlen (+ len metalen))
(i 0))
(define (sub-pop) ;; ...records. ha. ha.
- (let ((b (cond ((< i totlen) (pop))
- ((= i totlen) #f)
+ (let ((b (cond ((< i len) (pop))
+ ((= i len) #f)
(else (error "tried to decode too many bytes")))))
(if b (set! i (1+ i)))
b))
(let lp ((out '()))
- (cond ((> i totlen)
+ (cond ((> i len)
(error "error decoding program -- read too many bytes" out))
- ((= i totlen)
- `(load-program ,nargs ,nrest ,nlocs ,nexts () ,len ,metalen
+ ((= i len)
+ `(load-program ,nargs ,nrest ,nlocs ,nexts () ,len
+ ,(if (zero? metalen) #f (decode-load-program pop))
,@(reverse! out)))
(else
(let ((exp (decode-bytecode sub-pop)))
diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm
index 7a5691952..d83fd3e09 100644
--- a/module/language/assembly/disassemble.scm
+++ b/module/language/assembly/disassemble.scm
@@ -36,7 +36,7 @@
(define (disassemble-load-program asm env)
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,metalen . ,code)
+ ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
(let ((objs (and env (assq-ref env 'objects)))
(meta (and env (assq-ref env 'meta)))
(exts (and env (assq-ref env 'exts)))
diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index fc75930ee..88bb1897b 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -151,7 +151,7 @@
(receive (code bindings sources labels objects len)
(process-body)
(let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
- ,len 0 . ,code)))
+ ,len #f . ,code)))
(cond
(toplevel?
;; toplevel bytecode isn't loaded by the vm, no way to do
diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm
index 209f2da54..df1ff26e4 100644
--- a/module/system/vm/objcode.scm
+++ b/module/system/vm/objcode.scm
@@ -20,7 +20,8 @@
;;; Code:
(define-module (system vm objcode)
- #:export (objcode? bytecode->objcode objcode->bytecode
+ #:export (objcode? objcode-meta
+ bytecode->objcode objcode->bytecode
load-objcode write-objcode
word-size byte-order))
diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test
index 8064489d5..2af3152ff 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -77,7 +77,20 @@
(char->integer #\x)))
;; fixme: little-endian test.
- (comp-test '(load-program 3 2 1 0 '() 3 0 (make-int8 3) (return))
+ (comp-test '(load-program 3 2 1 0 () 3 #f (make-int8 3) (return))
(vector 'load-program 3 2 1 0 3 0 0 0 0 0 0 0
(instruction->opcode 'make-int8) 3
+ (instruction->opcode 'return)))
+
+ ;; fixme: little-endian test.
+ (comp-test '(load-program 3 2 1 0 () 3
+ (load-program 3 2 1 0 () 3
+ #f
+ (make-int8 3) (return))
+ (make-int8 3) (return))
+ (vector 'load-program 3 2 1 0 3 0 0 0 (+ 3 12) 0 0 0
+ (instruction->opcode 'make-int8) 3
+ (instruction->opcode 'return)
+ 3 2 1 0 3 0 0 0 0 0 0 0
+ (instruction->opcode 'make-int8) 3
(instruction->opcode 'return)))))