diff options
author | Andy Wingo <wingo@pobox.com> | 2008-09-16 00:26:22 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2008-09-16 00:26:22 +0200 |
commit | efbd589204408fe8af33b9d86a7e33104997bf6a (patch) | |
tree | fa534cfd59b892c82c72911e0f62eb323f6e6bb7 | |
parent | ef24c01bffb41a9855fe1aea36c4444742aba660 (diff) | |
download | guile-efbd589204408fe8af33b9d86a7e33104997bf6a.tar.gz |
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 <ghil-mv-call>. There is some trickery
because of the r4rs.scm call-with-values trampolines.
* module/system/il/ghil.scm: Add <ghil-mv-call> and accessors.
* module/system/il/compile.scm (codegen): Compile <ghil-mv-call>.
* module/system/il/glil.scm: Add <glil-mv-call>, 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.
-rw-r--r-- | libguile/vm-engine.c | 4 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 33 | ||||
-rw-r--r-- | module/language/scheme/translate.scm | 10 | ||||
-rw-r--r-- | module/system/il/compile.scm | 23 | ||||
-rw-r--r-- | module/system/il/ghil.scm | 4 | ||||
-rw-r--r-- | module/system/il/glil.scm | 10 | ||||
-rw-r--r-- | module/system/vm/assemble.scm | 56 | ||||
-rw-r--r-- | module/system/vm/conv.scm | 2 | ||||
-rw-r--r-- | module/system/vm/disasm.scm | 35 | ||||
-rw-r--r-- | 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; + 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; - int offset; + 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)) + + ((<ghil-mv-call> 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 @@ <ghil-call> make-ghil-call ghil-call? ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args + <ghil-mv-call> make-ghil-mv-call ghil-mv-call? + ghil-mv-call-env ghil-mv-call-loc ghil-mv-call-producer ghil-mv-call-consumer + <ghil-values> make-ghil-values ghil-values? ghil-values-env ghil-values-loc ghil-values-values @@ -116,6 +119,7 @@ (<ghil-bind> env loc vars vals body) (<ghil-lambda> env loc vars rest meta body) (<ghil-call> env loc proc args) + (<ghil-mv-call> env loc producer consumer) (<ghil-inline> env loc inline args) (<ghil-values> env loc values) (<ghil-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 <glil-branch> make-glil-branch glil-branch? - glil-branch-int glil-branch-label + glil-branch-inst glil-branch-label <glil-call> make-glil-call glil-call? - glil-call-int glil-call-nargs)) + glil-call-inst glil-call-nargs + + <glil-mv-call> make-glil-mv-call glil-mv-call? + glil-mv-call-nargs glil-mv-call-ra)) (define-record (<glil-vars> nargs nrest nlocs nexts)) @@ -87,7 +90,8 @@ ;; Controls (<glil-label> label) (<glil-branch> inst label) - (<glil-call> inst nargs))) + (<glil-call> inst nargs) + (<glil-mv-call> 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 ((<vm-asm> venv glil body) (record-case glil ((<glil-asm> 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))) + + ((<glil-mv-call> nargs ra) + (push (list 'mv-call nargs ra) stack)))) + ;; ;; main (for-each generate-code body) @@ -228,22 +236,36 @@ ((<vlink-later>) (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) |