diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c index de6f77b08..2816d3309 100644 --- a/libguile/vm-i-loader.c +++ b/libguile/vm-i-loader.c @@ -118,7 +118,7 @@ VM_DEFINE_LOADER (load_program, "load-program") POP (x); /* init meta data */ - if (SCM_CONSP (x)) + if (SCM_PROGRAM_P (x)) { p->meta = x; POP (x); diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index 83050bb13..298edc02f 100644 --- a/module/system/vm/assemble.scm +++ b/module/system/vm/assemble.scm @@ -71,6 +71,25 @@ ;;; Stage 2: Bytecode generation ;;; +(define-macro (push x loc) + `(set! ,loc (cons ,x ,loc))) + +;; this is to avoid glil-const's desire to put constants in the object +;; array -- instead we explicitly want them in the code, because meta +;; info is infrequently used. to load it up always would make garbage, +;; needlessly. so hide it behind a lambda. +(define (make-meta bindings sources tail) + (if (and (null? bindings) (null? sources) (null? tail)) + #f + (let ((stack '())) + (define (push-code! code) + (push (code->bytes code) stack)) + (dump-object! push-code! `(,bindings ,sources ,@tail)) + (push-code! '(return)) + (make-bytespec :vars (make-glil-vars 0 0 0 0) + :bytes (stack->bytes (reverse! stack) '()) + :meta #f :objs #f :closure? #f)))) + (define (codegen glil toplevel) (record-case glil (( venv glil body) (record-case glil (( vars meta) ; body? @@ -81,10 +100,11 @@ (object-alist '())) (define (push-code! code) ; (format #t "push-code! ~a~%" code) - (set! stack (cons (code->bytes code) stack))) + (push (code->bytes code) stack)) (define (push-object! x) (cond ((object->code x) => push-code!) - (toplevel (dump-object! push-code! x)) + (toplevel + (dump-object! push-code! x)) (else (let ((i (cond ((object-assoc x object-alist) => cdr) (else @@ -175,7 +195,7 @@ (set! label-alist (assq-set! label-alist label (current-address)))) (( inst label) - (set! stack (cons (list inst label) stack))) + (push (list inst label) stack)) (( inst nargs) (if (instruction? inst) @@ -195,13 +215,9 @@ (if toplevel (bytecode->objcode bytes (glil-vars-nlocs vars) (glil-vars-nexts vars)) (make-bytespec :vars vars :bytes bytes - :meta (if (and (null? binding-alist) - (null? source-alist) - (null? meta)) - #f - (cons* (reverse! binding-alist) + :meta (make-meta (reverse! binding-alist) (reverse! source-alist) - meta)) + meta) :objs (let ((objs (map car (reverse! object-alist)))) (if (null? objs) #f (list->vector objs))) :closure? (venv-closure? venv)))))))))) @@ -267,7 +283,7 @@ ;; dump meta data (if meta (dump! meta)) ;; dump bytecode - (push-code! `(load-program ,bytes))) + (push-code! `(load-program ,bytes))) (( module name) (dump! module) (dump! name) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index cdb975060..76446862e 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -44,8 +44,11 @@ (define binding:extp cadr) (define binding:index caddr) +(define (curry1 proc) + (lambda (x) (proc (x)))) + (define (program-bindings prog) - (cond ((program-meta prog) => car) + (cond ((program-meta prog) => (curry1 car)) (else '()))) (define (source:addr source) @@ -58,11 +61,11 @@ (vector-ref (cdr source) 2)) (define (program-sources prog) - (cond ((program-meta prog) => cadr) + (cond ((program-meta prog) => (curry1 cadr)) (else '()))) (define (program-properties prog) - (or (and=> (program-meta prog) cddr) + (or (and=> (program-meta prog) (curry1 cddr)) '())) (define (program-property prog prop)