diff --git a/libguile/objcodes.c b/libguile/objcodes.c index eb40213e9..7dba0e00b 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -190,14 +190,17 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0, data = (struct scm_objcode*)c_bytecode; SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode); scm_array_handle_release (&handle); + + SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode)); + if (data->len + data->metalen != (size - sizeof (*data))) + scm_misc_error (FUNC_NAME, "bad u8vector size (~a != ~a)", + SCM_LIST2 (scm_from_size_t (size), + scm_from_uint32 (sizeof (*data) + data->len + data->metalen))); assert (increment == 1); - SCM_ASSERT_RANGE (0, bytecode, size < 1<<31); - SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(*data)); SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_U8VECTOR); /* 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; } diff --git a/libguile/programs.c b/libguile/programs.c index e9c093a2e..b6dd7c2a6 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -178,10 +178,15 @@ SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0, "") #define FUNC_NAME s_scm_program_meta { - SCM objs; + SCM metaobj; + SCM_VALIDATE_PROGRAM (1, program); - objs = SCM_PROGRAM_OBJTABLE (program); - return scm_is_true (objs) ? scm_c_vector_ref (objs, 1) : SCM_BOOL_F; + + metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program)); + if (scm_is_true (metaobj)) + return scm_make_program (metaobj, SCM_BOOL_F, SCM_EOL); + else + return SCM_BOOL_F; } #undef FUNC_NAME diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c index 2919638bc..5b086808b 100644 --- a/libguile/vm-i-loader.c +++ b/libguile/vm-i-loader.c @@ -92,7 +92,7 @@ VM_DEFINE_LOADER (65, load_program, "load-program") scm_c_vector_set_x (objs, 0, scm_current_module ()); objcode = scm_c_make_objcode_slice (SCM_PROGRAM_OBJCODE (fp[-1]), ip); - len = sizeof (struct scm_objcode) + SCM_OBJCODE_LEN (objcode); + len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode); PUSH (scm_make_program (objcode, objs, SCM_EOL)); diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index 88bb1897b..d33210159 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -44,21 +44,14 @@ (define-record code) -;; A metadata thunk has no object table, so it is very quick to load. (define (make-meta bindings sources tail) (if (and (null? bindings) (null? sources) (null? tail)) #f - (make-subprogram - ;; we need to prepend #f for the object table. This would have - ;; even less overhead if we just appended the metadata-generating - ;; instructions after the body of the program's code. A FIXME for - ;; the future, eh. - `((make-false) - ,(compile-assembly - (make-glil-program 0 0 0 0 '() - (list - (make-glil-const `(,bindings ,sources ,@tail)) - (make-glil-call 'return 0)))))))) + (compile-assembly + (make-glil-program 0 0 0 0 '() + (list + (make-glil-const `(,bindings ,sources ,@tail)) + (make-glil-call 'return 0)))))) ;; A functional stack of names of live variables. (define (make-open-binding name ext? index) @@ -98,7 +91,7 @@ (close-all-bindings (close-binding bindings end) end))) ;; A functional object table. -(define *module-and-meta* 2) +(define *module* 1) (define (assoc-ref-or-acons alist x make-y) (cond ((assoc-ref alist x) => (lambda (y) (values y alist))) @@ -108,15 +101,15 @@ (define (object-index-and-alist x alist) (assoc-ref-or-acons alist x (lambda (x alist) - (+ (length alist) *module-and-meta*)))) + (+ (length alist) *module*)))) (define (compile-assembly glil) (receive (code . _) (glil->assembly glil 0 '() '(()) '() '() #f 0) (car code))) -(define (make-object-table objects meta) - (and (or meta (not (null? objects))) - (list->vector (cons* #f meta objects)))) +(define (make-object-table objects) + (and (not (null? objects)) + (list->vector (cons #f objects)))) (define (glil->assembly glil nargs nexts-stack bindings source-alist label-alist object-alist addr) @@ -151,7 +144,9 @@ (receive (code bindings sources labels objects len) (process-body) (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels - ,len #f . ,code))) + ,len + ,(make-meta bindings sources meta) + . ,code))) (cond (toplevel? ;; toplevel bytecode isn't loaded by the vm, no way to do @@ -159,10 +154,7 @@ ;; anyway) (emit-code `(,prog))) (else - (let ((table (dump-object (make-object-table - objects - (make-meta bindings sources meta)) - addr)) + (let ((table (dump-object (make-object-table objects) addr)) (closure (if (> closure-level 0) '((make-closure)) '()))) (cond (object-alist