From efbd589204408fe8af33b9d86a7e33104997bf6a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 16 Sep 2008 00:26:22 +0200 Subject: [PATCH] compile call-with-values, woot! * libguile/vm-engine.c (vm_run): Add another byte onto the bootstrap program, as the offset passed to mv-call now takes two bytes. * module/system/vm/frame.scm (bootstrap-frame?): Update for the new bootstrap length. Really we should just check for 'halt though. * libguile/vm-i-system.c (FETCH_OFFSET): New helper, used in BR(). (goto/nargs, call/nargs): Versions of goto/args and call, respectively, that take the number of arguments from a value on the top of the stack. (mv-call): Call FETCH_OFFSET to get the offset. * module/language/scheme/translate.scm (custom-transformer-table): Compile call-with-values to . There is some trickery because of the r4rs.scm call-with-values trampolines. * module/system/il/ghil.scm: Add and accessors. * module/system/il/compile.scm (codegen): Compile . * module/system/il/glil.scm: Add , which needs some special assembly because of the label. Fix some typos. * module/system/vm/assemble.scm (byte-length): New helper, factored out and made more general. (codegen): Assemble mv-call, including the label. (check-length): New helper, makes sure that the addressing is consistent within the produced object code. (stack->bytes): Rewrite to be more generic -- now `br' instructions aren't the only ones jumping around in the instruction stream. * module/system/vm/conv.scm (make-byte-decoder): Return two values in the #f case. * module/system/vm/disasm.scm (disassemble-bytecode): Rewrite, because the previous implementation depended on a guile interpreter quirk: namely, that multiple values could be represented within one value, and destructured later. --- libguile/vm-engine.c | 4 +- libguile/vm-i-system.c | 33 +++++++++++++--- module/language/scheme/translate.scm | 10 +++++ module/system/il/compile.scm | 23 +++++++++++- module/system/il/ghil.scm | 4 ++ module/system/il/glil.scm | 10 +++-- module/system/vm/assemble.scm | 56 +++++++++++++++++++--------- module/system/vm/conv.scm | 2 +- module/system/vm/disasm.scm | 35 +++++++++-------- module/system/vm/frame.scm | 4 +- 10 files changed, 134 insertions(+), 47 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 48b6ae565..73990d041 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -101,9 +101,9 @@ vm_run (SCM vm, SCM program, SCM args) SCM prog = program; /* Boot program */ - scm_byte_t bytes[5] = {scm_op_mv_call, 0, 1, scm_op_make_int8_1, scm_op_halt}; + scm_byte_t bytes[6] = {scm_op_mv_call, 0, 0, 1, scm_op_make_int8_1, scm_op_halt}; bytes[1] = scm_ilength (args); /* FIXME: argument overflow */ - program = scm_c_make_program (bytes, 5, SCM_BOOL_F); + program = scm_c_make_program (bytes, 6, SCM_BOOL_F); /* Initial frame */ CACHE_REGISTER (); diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 75642b5ba..05fc7476e 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -376,11 +376,18 @@ VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0) * branch and jump */ -#define BR(p) \ +/* offset must be a signed short!!! */ +#define FETCH_OFFSET(offset) \ { \ int h = FETCH (); \ int l = FETCH (); \ - signed short offset = (h << 8) + l; \ + offset = (h << 8) + l; \ +} + +#define BR(p) \ +{ \ + signed short offset; \ + FETCH_OFFSET (offset); \ if (p) \ ip += offset; \ DROP (); \ @@ -701,13 +708,29 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1) goto vm_error_wrong_type_apply; } -VM_DEFINE_INSTRUCTION (mv_call, "mv-call", 2, -1, 1) +VM_DEFINE_INSTRUCTION (goto_nargs, "goto/nargs", 0, 0, 1) { SCM x; - int offset; + POP (x); + nargs = scm_to_int (x); + goto vm_goto_args; +} + +VM_DEFINE_INSTRUCTION (call_nargs, "call/nargs", 0, 0, 1) +{ + SCM x; + POP (x); + nargs = scm_to_int (x); + goto vm_call; +} + +VM_DEFINE_INSTRUCTION (mv_call, "mv-call", 3, -1, 1) +{ + SCM x; + signed short offset; nargs = FETCH (); - offset = FETCH (); + FETCH_OFFSET (offset); x = sp[-nargs]; diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm index b812d40ce..6fed7df48 100644 --- a/module/language/scheme/translate.scm +++ b/module/language/scheme/translate.scm @@ -322,6 +322,16 @@ (else (make-ghil-inline e l 'apply (cons (retrans proc) args))))))) + ;; FIXME: not hygienic, relies on @call-with-values not being shadowed + (call-with-values + ((,producer ,consumer) + (retrans `(@call-with-values ,producer ,consumer))) + (else #f)) + + (@call-with-values + ((,producer ,consumer) + (make-ghil-mv-call e l (retrans producer) (retrans consumer)))) + (values ((,x) (retrans x)) (,args (make-ghil-values e l (map retrans args)))))) diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm index 0e410dca1..70d3db504 100644 --- a/module/system/il/compile.scm +++ b/module/system/il/compile.scm @@ -329,7 +329,28 @@ ;; ([tail-]call NARGS) (comp-push proc) (push-call! loc (if tail 'goto/args 'call) args) - (maybe-drop)))) + (maybe-drop)) + + (( env loc producer consumer) + ;; CONSUMER + ;; PRODUCER + ;; (mv-call MV) + ;; ([tail]-call 1) + ;; goto POST + ;; MV: [tail-]call/nargs + ;; POST: (maybe-drop) + (let ((MV (make-label)) (POST (make-label))) + (comp-push consumer) + (comp-push producer) + (push-code! loc (make-glil-mv-call 0 MV)) + (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1)) + (cond ((not tail) + (push-branch! #f 'br POST))) + (push-label! MV) + (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0)) + (cond ((not tail) + (push-label! POST) + (maybe-drop))))))) ;; ;; main (record-case ghil diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm index 895d476c7..60ec7ff86 100644 --- a/module/system/il/ghil.scm +++ b/module/system/il/ghil.scm @@ -72,6 +72,9 @@ make-ghil-call ghil-call? ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args + make-ghil-mv-call ghil-mv-call? + ghil-mv-call-env ghil-mv-call-loc ghil-mv-call-producer ghil-mv-call-consumer + make-ghil-values ghil-values? ghil-values-env ghil-values-loc ghil-values-values @@ -116,6 +119,7 @@ ( env loc vars vals body) ( env loc vars rest meta body) ( env loc proc args) + ( env loc producer consumer) ( env loc inline args) ( env loc values) ( env loc values))) diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm index ebd352977..7b7159c00 100644 --- a/module/system/il/glil.scm +++ b/module/system/il/glil.scm @@ -61,10 +61,13 @@ glil-label-label make-glil-branch glil-branch? - glil-branch-int glil-branch-label + glil-branch-inst glil-branch-label make-glil-call glil-call? - glil-call-int glil-call-nargs)) + glil-call-inst glil-call-nargs + + make-glil-mv-call glil-mv-call? + glil-mv-call-nargs glil-mv-call-ra)) (define-record ( nargs nrest nlocs nexts)) @@ -87,7 +90,8 @@ ;; Controls ( label) ( inst label) - ( inst nargs))) + ( inst nargs) + ( nargs ra))) ;;; diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index efb98307e..f354ef374 100644 --- a/module/system/vm/assemble.scm +++ b/module/system/vm/assemble.scm @@ -90,6 +90,13 @@ #:bytes (stack->bytes (reverse! stack) '()) #:meta #f #:objs #f #:closure? #f)))) +(define (byte-length x) + (cond ((u8vector? x) (u8vector-length x)) + ((>= (instruction-length (car x)) 0) + ;; one byte for the instruction itself + (1+ (instruction-length (car x)))) + (else (error "variable-length instruction?" x)))) + (define (codegen glil toplevel) (record-case glil (( venv glil body) (record-case glil (( vars meta) ; body? @@ -113,9 +120,6 @@ i))))) (push-code! `(object-ref ,i)))))) (define (current-address) - (define (byte-length x) - (cond ((u8vector? x) (u8vector-length x)) - (else 3))) (apply + (map byte-length stack))) (define (generate-code x) (record-case x @@ -206,7 +210,11 @@ (push-code! (list inst))) (else (error "Wrong number of arguments:" inst nargs)))) - (error "Unknown instruction:" inst))))) + (error "Unknown instruction:" inst))) + + (( nargs ra) + (push (list 'mv-call nargs ra) stack)))) + ;; ;; main (for-each generate-code body) @@ -228,22 +236,36 @@ (() (assoc x alist)) (else (assq x alist)))) +(define (check-length len u8v) + (or (= len (u8vector-length u8v)) + (error "the badness!" len u8v)) + u8v) + (define (stack->bytes stack label-alist) (let loop ((result '()) (stack stack) (addr 0)) (if (null? stack) - (list->u8vector(append-map u8vector->list - (reverse! result))) - (let ((bytes (car stack))) - (if (pair? bytes) - (let* ((offset (- (assq-ref label-alist (cadr bytes)) - (+ addr 3))) - (n (if (< offset 0) (+ offset 65536) offset))) - (set! bytes (code->bytes (list (car bytes) - (quotient n 256) - (modulo n 256)))))) - (loop (cons bytes result) - (cdr stack) - (+ addr (u8vector-length bytes))))))) + (check-length + addr + (list->u8vector + (append-map u8vector->list (reverse! result)))) + (let ((elt (car stack))) + (cond + ((u8vector? elt) + (loop (cons elt result) + (cdr stack) + (+ addr (byte-length elt)))) + ((symbol? (car (last-pair elt))) + ;; not yet code because labels needed to be resolved + (let* ((head (list-head elt (1- (length elt)))) + (label-addr (assq-ref label-alist (car (last-pair elt)))) + (offset (- label-addr (+ addr (byte-length elt)))) + (n (if (< offset 0) (+ offset 65536) offset))) + (loop (cons (code->bytes + (append head (list (quotient n 256) (modulo n 256)))) + result) + (cdr stack) + (+ addr (byte-length elt))))) + (else (error "bad code" elt))))))) ;;; diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm index 280534f44..914044102 100644 --- a/module/system/vm/conv.scm +++ b/module/system/vm/conv.scm @@ -163,7 +163,7 @@ (l '() (cons (pop) l))) ((= n 0) (cons* inst (reverse! l))))))) (values start code)) - #f)))) + (values #f #f))))) ;;; diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm index b28e508d0..279260640 100644 --- a/module/system/vm/disasm.scm +++ b/module/system/vm/disasm.scm @@ -71,23 +71,23 @@ (define (disassemble-bytecode bytes objs) (let ((decode (make-byte-decoder bytes)) - (programs '())) - (do ((addr+code (decode) (decode))) - ((not addr+code) (newline)) - (receive (addr code) addr+code - (pmatch code - ((load-program ,x) - (let ((sym (gensym ""))) - (set! programs (acons sym x programs)) - (print-info addr (format #f "(load-program #~A)" sym) #f))) - (else - (let ((info (list->info code)) - (extra (original-value addr code objs))) - (print-info addr info extra)))))) + (programs '())) + (define (lp addr code) + (pmatch code + (#f (newline)) + ((load-program ,x) + (let ((sym (gensym ""))) + (set! programs (acons sym x programs)) + (print-info addr (format #f "(load-program #~A)" sym) #f))) + (else + (print-info addr (list->info code) + (original-value addr code objs)))) + (if code (call-with-values decode lp))) + (call-with-values decode lp) (for-each (lambda (sym+bytes) - (format #t "Bytecode #~A:\n\n" (car sym+bytes)) - (disassemble-bytecode (cdr sym+bytes) #f)) - (reverse! programs)))) + (format #t "Bytecode #~A:\n\n" (car sym+bytes)) + (disassemble-bytecode (cdr sym+bytes) #f)) + (reverse! programs)))) (define (disassemble-objects objs) (display "Objects:\n\n") @@ -178,6 +178,9 @@ ((make-false) "#f") ((object-ref) (if objs (object->string (vector-ref objs (car args))) #f)) + ((mv-call) + (let ((offset (+ (* (caddr code) 256) (cadddr code)))) + (format #f "MV -> ~A" (+ addr offset 4)))) (else #f))))))) (define (list->info list) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index cb8e81371..10d2a949b 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -46,8 +46,8 @@ (define (bootstrap-frame? frame) (let ((code (program-bytecode (frame-program frame)))) - (and (= (uniform-vector-length code) 5) - (= (uniform-vector-ref code 4) + (and (= (uniform-vector-length code) 6) + (= (uniform-vector-ref code 5) (instruction->opcode 'halt))))) (define (make-frame-chain frame addr)