summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-09-16 00:26:22 +0200
committerAndy Wingo <wingo@pobox.com>2008-09-16 00:26:22 +0200
commitefbd589204408fe8af33b9d86a7e33104997bf6a (patch)
treefa534cfd59b892c82c72911e0f62eb323f6e6bb7
parentef24c01bffb41a9855fe1aea36c4444742aba660 (diff)
downloadguile-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.c4
-rw-r--r--libguile/vm-i-system.c33
-rw-r--r--module/language/scheme/translate.scm10
-rw-r--r--module/system/il/compile.scm23
-rw-r--r--module/system/il/ghil.scm4
-rw-r--r--module/system/il/glil.scm10
-rw-r--r--module/system/vm/assemble.scm56
-rw-r--r--module/system/vm/conv.scm2
-rw-r--r--module/system/vm/disasm.scm35
-rw-r--r--module/system/vm/frame.scm4
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)