diff options
-rw-r--r-- | libguile/objcodes.c | 36 | ||||
-rw-r--r-- | libguile/objcodes.h | 1 | ||||
-rw-r--r-- | module/language/assembly.scm | 4 | ||||
-rw-r--r-- | module/language/assembly/compile-bytecode.scm | 14 | ||||
-rw-r--r-- | module/language/assembly/decompile-bytecode.scm | 11 | ||||
-rw-r--r-- | module/language/assembly/disassemble.scm | 2 | ||||
-rw-r--r-- | module/language/glil/compile-assembly.scm | 2 | ||||
-rw-r--r-- | module/system/vm/objcode.scm | 3 | ||||
-rw-r--r-- | test-suite/tests/asm-to-bytecode.test | 15 |
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))))) |