[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-237-g8d59d55
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-237-g8d59d55 |
|
Date: |
Mon, 14 Oct 2013 14:10:18 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=8d59d55e866666a4ed3b9695638265be62b20af0
The branch, master has been updated
via 8d59d55e866666a4ed3b9695638265be62b20af0 (commit)
via 82f4bac420db15b3d41313f1f0213ea34a443d60 (commit)
via c6cd692f08eee7d02249d6891324511bf81aee20 (commit)
via b7f10defe61fd9febbf6c3e68a034d797b2c62c0 (commit)
from 545d776ef6b529eae8cd1d6cad0fe0d792c133a9 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 8d59d55e866666a4ed3b9695638265be62b20af0
Author: Andy Wingo <address@hidden>
Date: Mon Oct 14 16:13:57 2013 +0200
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.
commit 82f4bac420db15b3d41313f1f0213ea34a443d60
Author: Andy Wingo <address@hidden>
Date: Mon Oct 14 16:09:43 2013 +0200
RTL VM: receive-values has allow-extra? flag
* libguile/vm-engine.c (receive-values): Add an ALLOW-EXTRA? flag in
unused bits of the third word. Without it, receive-values will check
for the exact number of incoming values.
* libguile/vm.c (vm_error_wrong_number_of_values): New error case.
* module/language/cps/compile-rtl.scm (emit-rtl-sequence): Adapt to add
the ALLOW-EXTRA? flag.
commit c6cd692f08eee7d02249d6891324511bf81aee20
Author: Andy Wingo <address@hidden>
Date: Mon Oct 14 16:05:45 2013 +0200
Add SCM_F_DYNSTACK_PROMPT_PUSH_NARGS prompt flag
* libguile/dynstack.h (scm_t_dynstack_prompt_flags): New flag,
SCM_F_DYNSTACK_PROMPT_PUSH_NARGS, set if the continuation expects the
number of args to be pushed on the top of the stack.
* libguile/control.c (scm_c_abort): Only push nargs if requested.
* libguile/eval.c (eval):
* libguile/throw.c (pre_init_catch):
* libguile/vm-i-system.c (prompt): Set
SCM_F_DYNSTACK_PROMPT_PUSH_NARGS.
commit b7f10defe61fd9febbf6c3e68a034d797b2c62c0
Author: Andy Wingo <address@hidden>
Date: Mon Oct 14 12:20:58 2013 +0200
call-with-prompt always compiles to CPS $prompt
* module/language/tree-il/compile-cps.scm (convert): For prompts without
inline handlers, eta-convert the handler.
-----------------------------------------------------------------------
Summary of changes:
libguile/control.c | 3 +-
libguile/dynstack.h | 3 +-
libguile/eval.c | 3 +-
libguile/throw.c | 3 +-
libguile/vm-engine.c | 42 ++++++++++++++----------
libguile/vm-i-system.c | 1 +
libguile/vm.c | 8 +++++
module/language/cps/compile-rtl.scm | 30 ++++++++++++++---
module/language/cps/slot-allocation.scm | 29 +++++++++++++++++
module/language/tree-il/compile-cps.scm | 53 +++++++++++++++++++-----------
module/system/vm/disassembler.scm | 2 +-
11 files changed, 129 insertions(+), 48 deletions(-)
diff --git a/libguile/control.c b/libguile/control.c
index 3f2651c..162ff14 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -214,7 +214,8 @@ scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
*(++(SCM_VM_DATA (vm)->sp)) = cont;
for (i = 0; i < n; i++)
*(++(SCM_VM_DATA (vm)->sp)) = argv[i];
- *(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for continuation
*/
+ if (flags & SCM_F_DYNSTACK_PROMPT_PUSH_NARGS)
+ *(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for
continuation */
/* Jump! */
SCM_I_LONGJMP (*registers, 1);
diff --git a/libguile/dynstack.h b/libguile/dynstack.h
index c27c675..08e36a2 100644
--- a/libguile/dynstack.h
+++ b/libguile/dynstack.h
@@ -130,7 +130,8 @@ typedef enum {
} scm_t_dynstack_winder_flags;
typedef enum {
- SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY = (1 << SCM_DYNSTACK_TAG_FLAGS_SHIFT)
+ SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY = (1 << SCM_DYNSTACK_TAG_FLAGS_SHIFT),
+ SCM_F_DYNSTACK_PROMPT_PUSH_NARGS = (2 << SCM_DYNSTACK_TAG_FLAGS_SHIFT)
} scm_t_dynstack_prompt_flags;
typedef void (*scm_t_guard) (void *);
diff --git a/libguile/eval.c b/libguile/eval.c
index f5e1524..205de2d 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -413,7 +413,8 @@ eval (SCM x, SCM env)
/* Push the prompt onto the dynamic stack. */
scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
- SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
+ SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
+ | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
k,
SCM_VM_DATA (vm)->fp,
SCM_VM_DATA (vm)->sp,
diff --git a/libguile/throw.c b/libguile/throw.c
index de157fa..bd7a984 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -474,7 +474,8 @@ pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM
pre_unwind_handler)
/* Push the prompt onto the dynamic stack. */
scm_dynstack_push_prompt (dynstack,
- SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
+ SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
+ | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
sym_pre_init_catch_tag,
SCM_VM_DATA (vm)->fp,
SCM_VM_DATA (vm)->sp,
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index a422d1e..2723702 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1059,20 +1059,25 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
NEXT (2);
}
- /* receive-values proc:24 _:8 nvalues:24
+ /* receive-values proc:24 allow-extra?:1 _:7 nvalues:24
*
* Receive a return of multiple values from a call whose procedure was
* in PROC. If fewer than NVALUES values were returned, signal an
- * error. After receive-values has run, the values can be copied down
- * via `mov'.
+ * error. Unless ALLOW-EXTRA? is true, require that the number of
+ * return values equals NVALUES exactly. After receive-values has
+ * run, the values can be copied down via `mov'.
*/
- VM_DEFINE_OP (4, receive_values, "receive-values", OP2 (U8_U24, X8_U24))
+ VM_DEFINE_OP (4, receive_values, "receive-values", OP2 (U8_U24, B1_X7_U24))
{
scm_t_uint32 proc, nvalues;
SCM_UNPACK_RTL_24 (op, proc);
SCM_UNPACK_RTL_24 (ip[1], nvalues);
- VM_ASSERT (FRAME_LOCALS_COUNT () > proc + nvalues,
- vm_error_not_enough_values ());
+ if (ip[1] & 0x1)
+ VM_ASSERT (FRAME_LOCALS_COUNT () > proc + nvalues,
+ vm_error_not_enough_values ());
+ else
+ VM_ASSERT (FRAME_LOCALS_COUNT () == proc + nvalues,
+ vm_error_wrong_number_of_values (nvalues));
NEXT (2);
}
@@ -2261,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/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 0973792..83e07f1 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1453,6 +1453,7 @@ VM_DEFINE_INSTRUCTION (87, prompt, "prompt", 4, 2, 0)
SYNC_REGISTER ();
/* Push the prompt onto the dynamic stack. */
flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
+ flags |= SCM_F_DYNSTACK_PROMPT_PUSH_NARGS;
scm_dynstack_push_prompt (¤t_thread->dynstack, flags, k,
fp, sp, ip + offset, ®isters);
NEXT;
diff --git a/libguile/vm.c b/libguile/vm.c
index 5f6a5a0..3a2795b 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -429,6 +429,7 @@ static void vm_error_not_a_bytevector (const char *subr,
SCM x) SCM_NORETURN SCM
static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN
SCM_NOINLINE;
static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_wrong_number_of_values (scm_t_uint32 expected)
SCM_NORETURN SCM_NOINLINE;
static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN
SCM_NOINLINE;
static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN
SCM_NOINLINE;
@@ -578,6 +579,13 @@ vm_error_not_enough_values (void)
}
static void
+vm_error_wrong_number_of_values (scm_t_uint32 expected)
+{
+ vm_error ("Wrong number of values returned to continuation (expected ~a)",
+ scm_from_uint32 (expected));
+}
+
+static void
vm_error_continuation_not_rewindable (SCM cont)
{
vm_error ("Unrewindable partial continuation", cont);
diff --git a/module/language/cps/compile-rtl.scm
b/module/language/cps/compile-rtl.scm
index 0fe3216..0303d61 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)
@@ -273,7 +290,10 @@
(match args
(()
(emit-call asm proc-slot (+ nargs 1))
- (emit-receive-values asm proc-slot nreq)
+ ;; FIXME: Only allow more values if there is a rest arg.
+ ;; Express values truncation by the presence of an
+ ;; unused rest arg instead of implicitly.
+ (emit-receive-values asm proc-slot #t nreq)
(when rest?
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index b446d9e..e4e85ec 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 e7befbe..707e08b 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -58,21 +58,7 @@
#:use-module (language cps primitives)
#:use-module (language tree-il analyze)
#:use-module (language tree-il optimize)
- #:use-module ((language tree-il)
- #:select
- (<void>
- <const> <primitive-ref> <lexical-ref> <lexical-set>
- <module-ref> <module-set>
- <toplevel-ref> <toplevel-set> <toplevel-define>
- <conditional>
- <call> <primcall>
- <seq>
- <lambda> <lambda-case>
- <let> <letrec> <fix> <let-values>
- <prompt> <abort>
- make-conditional make-const make-primcall
- tree-il-src
- tree-il-fold))
+ #:use-module ((language tree-il) #:hide (let-gensyms))
#:export (compile-cps))
;;; Guile's semantics are that a toplevel lambda captures a reference on
@@ -405,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
@@ -426,10 +412,37 @@
;; Eta-convert prompts without inline handlers.
(($ <prompt> src escape-only? tag body handler)
- (convert-args (list tag body handler)
- (lambda (args)
- (build-cps-term
- ($continue k ($primcall 'call-with-prompt args))))))
+ (let-gensyms (h args)
+ (convert
+ (make-let
+ src (list 'h) (list h) (list handler)
+ (make-seq
+ src
+ (make-conditional
+ src
+ (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
+ (make-void src)
+ (make-primcall
+ src 'scm-error
+ (list
+ (make-const #f 'wrong-type-arg)
+ (make-const #f "call-with-prompt")
+ (make-const #f "Wrong type (expecting procedure): ~S")
+ (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
+ (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
+ (make-prompt
+ src escape-only? tag body
+ (make-lambda
+ src '()
+ (make-lambda-case
+ src '() #f 'args #f '() (list args)
+ (make-primcall
+ src 'apply
+ (list (make-lexical-ref #f 'h h)
+ (make-lexical-ref #f 'args args)))
+ #f)))))
+ k
+ subst)))
(($ <abort> src tag args tail)
(convert-args (append (list tag) args (list tail))
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index 4917743..09ca337 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)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-237-g8d59d55,
Andy Wingo <=