From 8d59d55e866666a4ed3b9695638265be62b20af0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 14 Oct 2013 16:13:57 +0200 Subject: [PATCH] RTL: Compile prompts * libguile/vm-engine.c (prompt): Adapt to explicitly set the saved SP so we know how many incoming values the handler will receive, and to make escape-only? a flag. * module/language/cps/compile-rtl.scm (emit-rtl-sequence): $prompt should only be found in a "seq" context, as it just pushes on a prompt and doesn't bind any values. On the other hand it should emit appropriate code for the handler to bind its values, so do that. * module/language/cps/slot-allocation.scm ($cont-allocation): Add a note that proc-slot is used by prompts as well. (allocate-slots): Compute the allocation of a prompt handler's args. * module/language/tree-il/compile-cps.scm (convert): Use "unwind" instead of the nonexistent "pop-prompt". * module/system/vm/disassembler.scm (code-annotation): Adapt to change in prompt VM op. --- libguile/vm-engine.c | 25 +++++++++++---------- module/language/cps/compile-rtl.scm | 25 +++++++++++++++++---- module/language/cps/slot-allocation.scm | 29 +++++++++++++++++++++++++ module/language/tree-il/compile-cps.scm | 2 +- module/system/vm/disassembler.scm | 2 +- 5 files changed, 65 insertions(+), 18 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 6c1318fd3..272370289 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2266,35 +2266,36 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * The dynamic environment */ - /* prompt tag:24 flags:8 handler-offset:24 + /* prompt tag:24 escape-only?:1 _:7 proc-slot:24 _:8 handler-offset:24 * * Push a new prompt on the dynamic stack, with a tag from TAG and a * handler at HANDLER-OFFSET words from the current IP. The handler - * will expect a multiple-value return. + * will expect a multiple-value return as if from a call with the + * procedure at PROC-SLOT. */ - VM_DEFINE_OP (58, prompt, "prompt", OP2 (U8_U24, U8_L24)) -#if 0 + VM_DEFINE_OP (58, prompt, "prompt", OP3 (U8_U24, B1_X7_U24, X8_L24)) { - scm_t_uint32 tag; + scm_t_uint32 tag, proc_slot; scm_t_int32 offset; scm_t_uint8 escape_only_p; scm_t_dynstack_prompt_flags flags; SCM_UNPACK_RTL_24 (op, tag); - escape_only_p = ip[1] & 0xff; - offset = ip[1]; + escape_only_p = ip[1] & 0x1; + SCM_UNPACK_RTL_24 (ip[1], proc_slot); + offset = ip[2]; offset >>= 8; /* Sign extension */ /* Push the prompt onto the dynamic stack. */ flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0; scm_dynstack_push_prompt (¤t_thread->dynstack, flags, LOCAL_REF (tag), - fp, vp->sp, ip + offset, ®isters); - NEXT (2); + fp, + &LOCAL_REF (proc_slot), + (scm_t_uint8 *)(ip + offset), + ®isters); + NEXT (3); } -#else - abort(); -#endif /* wind winder:12 unwinder:12 * diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm index 85e9fec20..0303d6106 100644 --- a/module/language/cps/compile-rtl.scm +++ b/module/language/cps/compile-rtl.scm @@ -190,9 +190,7 @@ (emit-text asm `((,inst ,dst ,@(map slot args)))))) (($ $values (arg)) (or (maybe-load-constant dst arg) - (maybe-mov dst (slot arg)))) - (($ $prompt escape? tag handler) - (emit-prompt asm escape? tag handler))) + (maybe-mov dst (slot arg))))) (maybe-jump k))) (define (emit-vals syms) @@ -224,9 +222,28 @@ (emit-set-cdr! asm (slot pair) (slot value))) (($ $primcall 'define! (sym value)) (emit-define asm (slot sym) (slot value))) + (($ $primcall 'unwind ()) + (emit-unwind asm)) (($ $primcall name args) (error "unhandled primcall in seq context" name)) - (($ $values ()) #f)) + (($ $values ()) #f) + (($ $prompt escape? tag handler) + (match (lookup-cont handler cont-table) + (($ $ktrunc ($ $arity req () rest () #f) khandler-body) + (let ((receive-args (gensym "handler")) + (nreq (length req)) + (proc-slot (lookup-call-proc-slot label allocation))) + (emit-prompt asm (slot tag) escape? proc-slot receive-args) + (emit-br asm k) + (emit-label asm receive-args) + (emit-receive-values asm proc-slot (->bool rest) nreq) + (when rest + (emit-bind-rest asm (+ proc-slot 1 nreq))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves handler allocation)) + (emit-reset-frame asm nlocals) + (emit-br asm khandler-body)))))) (maybe-jump k)) (define (emit-test kt kf) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index b446d9e52..e4e85ec93 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -73,6 +73,10 @@ ;; Currently calls are allocated in the caller frame, above all locals ;; that are live at the time of the call. Therefore there is no ;; parallel move problem. We could be more clever here. + ;; + ;; $prompt expressions also use this call slot to indicate where the + ;; handler's arguments are expected, but without reserving space for a + ;; frame or for the procedure slot. (call-proc-slot cont-call-proc-slot) ;; Tail calls, multiple-value returns, and jumps to continuations with @@ -223,6 +227,9 @@ are comparable with eqv?. A tmp slot may be used." (define (compute-call-proc-slot live-set nlocals) (+ 3 (find-first-trailing-zero (car live-set) nlocals))) + (define (compute-prompt-handler-proc-slot live-set nlocals) + (1- (find-first-trailing-zero (car live-set) nlocals))) + (define dfg (compute-dfg fun #:global? #f)) (define allocation (make-hash-table)) @@ -262,6 +269,16 @@ are comparable with eqv?. A tmp slot may be used." (set-allocation-dead! allocation (cons k dead)) (remove-live-variable sym slot live-set)))) + (define (allocate-prompt-handler! k live-set) + (let ((proc-slot (compute-prompt-handler-proc-slot live-set nlocals))) + (hashq-set! allocation k + (make-cont-allocation + proc-slot + (match (hashq-ref allocation k) + (($ $cont-allocation #f moves) moves) + (#f #f)))) + live-set)) + (define (allocate-frame! k nargs live-set) (let ((proc-slot (compute-call-proc-slot live-set nlocals))) (set! nlocals (max nlocals (+ proc-slot 1 nargs))) @@ -403,6 +420,18 @@ are comparable with eqv?. A tmp slot may be used." (compute-dst-slots)))) (($ $prompt escape? tag handler) + (match (lookup-cont handler (dfg-cont-table dfg)) + (($ $ktrunc arity kargs) + (let* ((live-set (allocate-prompt-handler! label live-set)) + (proc-slot (lookup-call-proc-slot label allocation)) + (dst-syms (lookup-bound-syms kargs dfg)) + (nvals (length dst-syms)) + (src-slots (map (cut + proc-slot 1 <>) (iota nvals))) + (live-set* (fold (cut allocate! <> kargs <> <>) + live-set dst-syms src-slots)) + (dst-slots (map (cut lookup-slot <> allocation) + dst-syms))) + (parallel-move! handler src-slots live-set live-set* dst-slots)))) (use tag live-set)) (_ live-set))) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 836f10e8e..707e08b10 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -391,7 +391,7 @@ ($continue kprim ($prim 'values)))))) ($continue kret - ($primcall 'pop-prompt ()))))) + ($primcall 'unwind ()))))) (krest src ($ktrunc '() 'rest kpop))) ,(if escape-only? (build-cps-term diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index 4917743db..09ca337bf 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -217,7 +217,7 @@ address of that offset." 'br-if-char 'br-if-tc7 'br-if-eq 'br-if-eqv 'br-if-equal 'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=) _ ... target) (list "-> ~A" (vector-ref labels (- (+ offset target) start)))) - (('prompt tag flags handler) + (('prompt tag escape-only? proc-slot handler) ;; The H is for handler. (list "H -> ~A" (vector-ref labels (- (+ offset handler) start)))) (((or 'make-short-immediate 'make-long-immediate) _ imm) -- 2.20.1