mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-15 16:20:17 +02:00
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.
This commit is contained in:
Andy Wingo
parent
ef24c01bff
commit
efbd589204
10 changed files with 134 additions and 47 deletions
|
|
@ -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 ();
|
||||
|
|
|
|||
|
|
@ -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];
|
||||
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(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 (u8vector-length bytes)))))))
|
||||
(+ 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)))))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -163,7 +163,7 @@
|
|||
(l '() (cons (pop) l)))
|
||||
((= n 0) (cons* inst (reverse! l)))))))
|
||||
(values start code))
|
||||
#f))))
|
||||
(values #f #f)))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -72,18 +72,18 @@
|
|||
(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
|
||||
(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
|
||||
(let ((info (list->info code))
|
||||
(extra (original-value addr code objs)))
|
||||
(print-info addr info extra))))))
|
||||
(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))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue