[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-756-g0f0b6f2
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-756-g0f0b6f2 |
|
Date: |
Wed, 19 Feb 2014 18:45:34 +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=0f0b6f2d868b36560ea04f50cdc7b7e1a0e565ea
The branch, master has been updated
via 0f0b6f2d868b36560ea04f50cdc7b7e1a0e565ea (commit)
via 440392fa2dfc7f0000b4175679c974efaa3fb07a (commit)
via ee1c6b575f87f5f7682ecbee2abdf942f08d1dce (commit)
via f2d592185f614e139872ccb84309d88325b54445 (commit)
via b8321c24aaeb6c9f4fef3063a8f87c4dd2173f4a (commit)
from 82490a665cfcf1053c2e14712679f114fb9c4477 (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 0f0b6f2d868b36560ea04f50cdc7b7e1a0e565ea
Author: Andy Wingo <address@hidden>
Date: Wed Feb 19 19:43:48 2014 +0100
Reimplement catch, throw, and with-throw-handler
* module/ice-9/boot-9.scm: Reimplement catch, throw, and
with-throw-handler in such a way that the exception handler is
threaded not through the exception-handling closures, but through a
data structure in the exception-handler fluid. This will allow us to
do unwind-only exception dispatch on stack overflow.
commit 440392fa2dfc7f0000b4175679c974efaa3fb07a
Author: Andy Wingo <address@hidden>
Date: Wed Feb 19 16:54:40 2014 +0100
boot-9 boot order refactor for catch, throw, and such
* module/ice-9/boot-9.scm: Move error-handling initialization after
psyntax initialization. Only "throw" is used before psyntax, and both
throw and catch have pre-boot variants in C.
commit ee1c6b575f87f5f7682ecbee2abdf942f08d1dce
Author: Andy Wingo <address@hidden>
Date: Wed Feb 19 11:19:10 2014 +0100
Fix scm_i_vm_capture_stack comment.
* libguile/vm.c (scm_i_vm_capture_stack): Fix a comment.
commit f2d592185f614e139872ccb84309d88325b54445
Author: Andy Wingo <address@hidden>
Date: Wed Feb 19 11:11:46 2014 +0100
Default stack size is one page.
* libguile/vm.c (initialize_default_stack_size): Initial stack size is
one page.
commit b8321c24aaeb6c9f4fef3063a8f87c4dd2173f4a
Author: Andy Wingo <address@hidden>
Date: Wed Feb 19 11:01:39 2014 +0100
More robust stack expansion and contraction
* libguile/vm.c (allocate_stack, expand_stack): Return NULL on
allocation failure instead of throwing an exception. Throwing an
exception is tricky to get right, and we need more context to do it
correctly.
(return_unused_stack_to_os): Try again if madvise returns -EAGAIN. If
madvise fails, print an error message.
(vm_expand_stack): Abort if stack expansion fails. We'll fix this in
a future patch.
(make_vm): Abort if we can't mmap a single page.
-----------------------------------------------------------------------
Summary of changes:
libguile/vm.c | 80 ++++++++----
module/ice-9/boot-9.scm | 316 ++++++++++++++++++++++++-----------------------
2 files changed, 218 insertions(+), 178 deletions(-)
diff --git a/libguile/vm.c b/libguile/vm.c
index 4c67d50..b071a54 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -108,17 +108,9 @@ scm_i_vm_cont_print (SCM x, SCM port, scm_print_state
*pstate)
scm_puts_unlocked (">", port);
}
-/* In theory, a number of vm instances can be active in the call trace, and we
- only want to reify the continuations of those in the current continuation
- root. I don't see a nice way to do this -- ideally it would involve
dynwinds,
- and previous values of the *the-vm* fluid within the current continuation
- root. But we don't have access to continuation roots in the dynwind stack.
- So, just punt for now, we just capture the continuation for the current VM.
-
- While I'm on the topic, ideally we could avoid copying the C stack if the
- continuation root is inside VM code, and call/cc was invoked within that
same
- call to vm_run; but that's currently not implemented.
- */
+/* Ideally we could avoid copying the C stack if the continuation root
+ is inside VM code, and call/cc was invoked within that same call to
+ vm_run. That's currently not implemented. */
SCM
scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint32 *ra,
scm_t_dynstack *dynstack, scm_t_uint32 flags)
@@ -713,12 +705,15 @@ scm_i_call_with_current_continuation (SCM proc)
* VM
*/
+/* The page size. */
+static size_t page_size;
+
/* Hard stack limit is 512M words: 2 gigabytes on 32-bit machines, 4 on
64-bit machines. */
static const size_t hard_max_stack_size = 512 * 1024 * 1024;
-/* Initial stack size: 4 or 8 kB. */
-static const size_t initial_stack_size = 1024;
+/* Initial stack size. Defaults to one page. */
+static size_t initial_stack_size;
/* Default soft stack limit is 1M words (4 or 8 megabytes). */
static size_t default_max_stack_size = 1024 * 1024;
@@ -726,9 +721,15 @@ static size_t default_max_stack_size = 1024 * 1024;
static void
initialize_default_stack_size (void)
{
- int size = scm_getenv_int ("GUILE_STACK_SIZE", (int) default_max_stack_size);
- if (size >= initial_stack_size && (size_t) size < ((size_t) -1) /
sizeof(SCM))
- default_max_stack_size = size;
+ initial_stack_size = page_size / sizeof (SCM);
+
+ {
+ int size;
+ size = scm_getenv_int ("GUILE_STACK_SIZE", (int) default_max_stack_size);
+ if (size >= initial_stack_size
+ && (size_t) size < ((size_t) -1) / sizeof(SCM))
+ default_max_stack_size = size;
+ }
}
#define VM_NAME vm_regular_engine
@@ -768,13 +769,17 @@ allocate_stack (size_t size)
ret = mmap (NULL, size, PROT_READ | PROT_WRITE,
MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
if (ret == MAP_FAILED)
- SCM_SYSERROR;
+ ret = NULL;
#else
ret = malloc (size);
- if (!ret)
- SCM_SYSERROR;
#endif
+ if (!ret)
+ {
+ perror ("allocate_stack failed");
+ return NULL;
+ }
+
return (SCM *) ret;
}
#undef FUNC_NAME
@@ -806,13 +811,16 @@ expand_stack (SCM *old_stack, size_t old_size, size_t
new_size)
new_stack = mremap (old_stack, old_size, new_size, MREMAP_MAYMOVE);
if (new_stack == MAP_FAILED)
- SCM_SYSERROR;
+ return NULL;
return (SCM *) new_stack;
#else
SCM *new_stack;
new_stack = allocate_stack (new_size);
+ if (!new_stack)
+ return NULL;
+
memcpy (new_stack, old_stack, old_size * sizeof (SCM));
free_stack (old_stack, old_size);
@@ -832,6 +840,11 @@ make_vm (void)
vp->stack_size = initial_stack_size;
vp->stack_base = allocate_stack (vp->stack_size);
+ if (!vp->stack_base)
+ /* As in expand_stack, we don't have any way to throw an exception
+ if we can't allocate one measely page -- there's no stack to
+ handle it. For now, abort. */
+ abort ();
vp->stack_limit = vp->stack_base + vp->stack_size;
vp->max_stack_size = default_max_stack_size;
vp->ip = NULL;
@@ -846,8 +859,6 @@ make_vm (void)
}
#undef FUNC_NAME
-static size_t page_size;
-
static void
return_unused_stack_to_os (struct scm_vm *vp)
{
@@ -864,7 +875,16 @@ return_unused_stack_to_os (struct scm_vm *vp)
/* Return these pages to the OS. The next time they are paged in,
they will be zeroed. */
if (start < end)
- madvise ((void *) start, end - start, MADV_DONTNEED);
+ {
+ int ret = 0;
+
+ do
+ ret = madvise ((void *) start, end - start, MADV_DONTNEED);
+ while (ret && errno == -EAGAIN);
+
+ if (ret)
+ perror ("madvise failed");
+ }
vp->sp_max_since_gc = vp->sp;
#endif
@@ -986,7 +1006,7 @@ vm_expand_stack (struct scm_vm *vp)
stack marker can trace the stack. */
if (stack_size > vp->stack_size)
{
- SCM *old_stack;
+ SCM *old_stack, *new_stack;
size_t new_size;
scm_t_ptrdiff reloc;
@@ -994,7 +1014,17 @@ vm_expand_stack (struct scm_vm *vp)
while (new_size < stack_size)
new_size *= 2;
old_stack = vp->stack_base;
- vp->stack_base = expand_stack (old_stack, vp->stack_size, new_size);
+ new_stack = expand_stack (vp->stack_base, vp->stack_size, new_size);
+ if (!new_stack)
+ /* It would be nice to throw an exception here, but that is
+ extraordinarily hard. Exceptionally hard, you might say!
+ "throw" is implemented in Scheme, and there may be arbitrary
+ pre-unwind handlers that push on more frames. We will
+ endeavor to do so in the future, but for now we just
+ abort. */
+ abort ();
+
+ vp->stack_base = new_stack;
vp->stack_size = new_size;
vp->stack_limit = vp->stack_base + new_size;
reloc = vp->stack_base - old_stack;
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index b6ba03c..23f2d5b 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -43,159 +43,6 @@
-;;; {Error handling}
-;;;
-
-;; Define delimited continuation operators, and implement catch and throw in
-;; terms of them.
-
-(define make-prompt-tag
- (lambda* (#:optional (stem "prompt"))
- ;; The only property that prompt tags need have is uniqueness in the
- ;; sense of eq?. A one-element list will serve nicely.
- (list stem)))
-
-(define default-prompt-tag
- ;; Redefined later to be a parameter.
- (let ((%default-prompt-tag (make-prompt-tag)))
- (lambda ()
- %default-prompt-tag)))
-
-(define (call-with-prompt tag thunk handler)
- ((@@ primitive call-with-prompt) tag thunk handler))
-(define (abort-to-prompt tag . args)
- (abort-to-prompt* tag args))
-
-(define (with-fluid* fluid val thunk)
- "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.
address@hidden must be a procedure of no arguments."
- ((@@ primitive push-fluid) fluid val)
- (call-with-values thunk
- (lambda vals
- ((@@ primitive pop-fluid))
- (apply values vals))))
-
-;; Define catch and with-throw-handler, using some common helper routines and a
-;; shared fluid. Hide the helpers in a lexical contour.
-
-(define with-throw-handler #f)
-(let ()
- (define (default-exception-handler k . args)
- (cond
- ((eq? k 'quit)
- (primitive-exit (cond
- ((not (pair? args)) 0)
- ((integer? (car args)) (car args))
- ((not (car args)) 1)
- (else 0))))
- (else
- (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
- (primitive-exit 1))))
-
- (define %running-exception-handlers (make-fluid '()))
- (define %exception-handler (make-fluid default-exception-handler))
-
- (define (default-throw-handler prompt-tag catch-k)
- (let ((prev (fluid-ref %exception-handler)))
- (lambda (thrown-k . args)
- (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
- (apply abort-to-prompt prompt-tag thrown-k args)
- (apply prev thrown-k args)))))
-
- (define (custom-throw-handler prompt-tag catch-k pre)
- (let ((prev (fluid-ref %exception-handler)))
- (lambda (thrown-k . args)
- (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
- (let ((running (fluid-ref %running-exception-handlers)))
- (with-fluid* %running-exception-handlers (cons pre running)
- (lambda ()
- (if (not (memq pre running))
- (apply pre thrown-k args))
- ;; fall through
- (if prompt-tag
- (apply abort-to-prompt prompt-tag thrown-k args)
- (apply prev thrown-k args)))))
- (apply prev thrown-k args)))))
-
- (set! catch
- (lambda* (k thunk handler #:optional pre-unwind-handler)
- "Invoke @var{thunk} in the dynamic context of @var{handler} for
-exceptions matching @var{key}. If thunk throws to the symbol
address@hidden, then @var{handler} is invoked this way:
address@hidden
- (handler key args ...)
address@hidden lisp
-
address@hidden is a symbol or @code{#t}.
-
address@hidden takes no arguments. If @var{thunk} returns
-normally, that is the return value of @code{catch}.
-
-Handler is invoked outside the scope of its own @code{catch}.
-If @var{handler} again throws to the same key, a new handler
-from further up the call chain is invoked.
-
-If the key is @code{#t}, then a throw to @emph{any} symbol will
-match this call to @code{catch}.
-
-If a @var{pre-unwind-handler} is given and @var{thunk} throws
-an exception that matches @var{key}, Guile calls the
address@hidden before unwinding the dynamic state and
-invoking the main @var{handler}. @var{pre-unwind-handler} should
-be a procedure with the same signature as @var{handler}, that
-is @code{(lambda (key . args))}. It is typically used to save
-the stack at the point where the exception occurred, but can also
-query other parts of the dynamic state at that point, such as
-fluid values.
-
-A @var{pre-unwind-handler} can exit either normally or non-locally.
-If it exits normally, Guile unwinds the stack and dynamic context
-and then calls the normal (third argument) handler. If it exits
-non-locally, that exit determines the continuation."
- (if (not (or (symbol? k) (eqv? k #t)))
- (scm-error 'wrong-type-arg "catch"
- "Wrong type argument in position ~a: ~a"
- (list 1 k) (list k)))
- (let ((tag (make-prompt-tag "catch")))
- (call-with-prompt
- tag
- (lambda ()
- (with-fluid* %exception-handler
- (if pre-unwind-handler
- (custom-throw-handler tag k pre-unwind-handler)
- (default-throw-handler tag k))
- thunk))
- (lambda (cont k . args)
- (apply handler k args))))))
-
- (set! with-throw-handler
- (lambda (k thunk pre-unwind-handler)
- "Add @var{handler} to the dynamic context as a throw handler
-for key @var{k}, then invoke @var{thunk}."
- (if (not (or (symbol? k) (eqv? k #t)))
- (scm-error 'wrong-type-arg "with-throw-handler"
- "Wrong type argument in position ~a: ~a"
- (list 1 k) (list k)))
- (with-fluid* %exception-handler
- (custom-throw-handler #f k pre-unwind-handler)
- thunk)))
-
- (set! throw
- (lambda (key . args)
- "Invoke the catch form matching @var{key}, passing @var{args} to the
address@hidden
-
address@hidden is a symbol. It will match catches of the same symbol or of
@code{#t}.
-
-If there is no handler at all, Guile prints an error and then exits."
- (if (not (symbol? key))
- ((fluid-ref %exception-handler) 'wrong-type-arg "throw"
- "Wrong type argument in position ~a: ~a" (list 1 key) (list
key))
- (apply (fluid-ref %exception-handler) key args)))))
-
-
-
-
;;; {Language primitives}
;;;
@@ -295,6 +142,15 @@ a-cont
(out)
(apply values vals))))
+(define (with-fluid* fluid val thunk)
+ "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.
address@hidden must be a procedure of no arguments."
+ ((@@ primitive push-fluid) fluid val)
+ (call-with-values thunk
+ (lambda vals
+ ((@@ primitive pop-fluid))
+ (apply values vals))))
+
;;; {Low-Level Port Code}
@@ -820,6 +676,160 @@ information is unavailable."
(define sym
(if (module-locally-bound? (current-module) 'sym) sym val)))
+
+
+
+;;; {Error handling}
+;;;
+
+;; Define delimited continuation operators, and implement catch and throw in
+;; terms of them.
+
+(define make-prompt-tag
+ (lambda* (#:optional (stem "prompt"))
+ ;; The only property that prompt tags need have is uniqueness in the
+ ;; sense of eq?. A one-element list will serve nicely.
+ (list stem)))
+
+(define default-prompt-tag
+ ;; Redefined later to be a parameter.
+ (let ((%default-prompt-tag (make-prompt-tag)))
+ (lambda ()
+ %default-prompt-tag)))
+
+(define (call-with-prompt tag thunk handler)
+ ((@@ primitive call-with-prompt) tag thunk handler))
+(define (abort-to-prompt tag . args)
+ (abort-to-prompt* tag args))
+
+;; Define catch and with-throw-handler, using some common helper routines and a
+;; shared fluid. Hide the helpers in a lexical contour.
+
+(define with-throw-handler #f)
+(let ()
+ (define %exception-handler (make-fluid #f))
+ (define (make-exception-handler catch-key prompt-tag pre-unwind)
+ (vector (fluid-ref %exception-handler) catch-key prompt-tag pre-unwind))
+ (define (exception-handler-prev handler) (vector-ref handler 0))
+ (define (exception-handler-catch-key handler) (vector-ref handler 1))
+ (define (exception-handler-prompt-tag handler) (vector-ref handler 2))
+ (define (exception-handler-pre-unwind handler) (vector-ref handler 3))
+
+ (define %running-pre-unwind (make-fluid '()))
+
+ (define (dispatch-exception handler key args)
+ (unless handler
+ (when (eq? key 'quit)
+ (primitive-exit (cond
+ ((not (pair? args)) 0)
+ ((integer? (car args)) (car args))
+ ((not (car args)) 1)
+ (else 0))))
+ (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" key
args)
+ (primitive-exit 1))
+
+ (let ((catch-key (exception-handler-catch-key handler))
+ (prev (exception-handler-prev handler)))
+ (if (or (eqv? catch-key #t) (eq? catch-key key))
+ (let ((prompt-tag (exception-handler-prompt-tag handler))
+ (pre-unwind (exception-handler-pre-unwind handler)))
+ (if pre-unwind
+ ;; Instead of using a "running" set, it would be a lot
+ ;; cleaner semantically to roll back the exception
+ ;; handler binding to the one that was in place when the
+ ;; pre-unwind handler was installed, and keep it like
+ ;; that for the rest of the dispatch. Unfortunately
+ ;; that is incompatible with existing semantics. We'll
+ ;; see if we can change that later on.
+ (let ((running (fluid-ref %running-pre-unwind)))
+ (with-fluid* %running-pre-unwind (cons handler running)
+ (lambda ()
+ (unless (memq handler running)
+ (apply pre-unwind key args))
+ (if prompt-tag
+ (apply abort-to-prompt prompt-tag key args)
+ (dispatch-exception prev key args)))))
+ (apply abort-to-prompt prompt-tag key args)))
+ (dispatch-exception prev key args))))
+
+ (define (throw key . args)
+ "Invoke the catch form matching @var{key}, passing @var{args} to the
address@hidden
+
address@hidden is a symbol. It will match catches of the same symbol or of
@code{#t}.
+
+If there is no handler at all, Guile prints an error and then exits."
+ (unless (symbol? key)
+ (throw 'wrong-type-arg "throw" "Wrong type argument in position ~a: ~a"
+ (list 1 key) (list key)))
+ (dispatch-exception (fluid-ref %exception-handler) key args))
+
+ (define* (catch k thunk handler #:optional pre-unwind-handler)
+ "Invoke @var{thunk} in the dynamic context of @var{handler} for
+exceptions matching @var{key}. If thunk throws to the symbol
address@hidden, then @var{handler} is invoked this way:
address@hidden
+ (handler key args ...)
address@hidden lisp
+
address@hidden is a symbol or @code{#t}.
+
address@hidden takes no arguments. If @var{thunk} returns
+normally, that is the return value of @code{catch}.
+
+Handler is invoked outside the scope of its own @code{catch}.
+If @var{handler} again throws to the same key, a new handler
+from further up the call chain is invoked.
+
+If the key is @code{#t}, then a throw to @emph{any} symbol will
+match this call to @code{catch}.
+
+If a @var{pre-unwind-handler} is given and @var{thunk} throws
+an exception that matches @var{key}, Guile calls the
address@hidden before unwinding the dynamic state and
+invoking the main @var{handler}. @var{pre-unwind-handler} should
+be a procedure with the same signature as @var{handler}, that
+is @code{(lambda (key . args))}. It is typically used to save
+the stack at the point where the exception occurred, but can also
+query other parts of the dynamic state at that point, such as
+fluid values.
+
+A @var{pre-unwind-handler} can exit either normally or non-locally.
+If it exits normally, Guile unwinds the stack and dynamic context
+and then calls the normal (third argument) handler. If it exits
+non-locally, that exit determines the continuation."
+ (if (not (or (symbol? k) (eqv? k #t)))
+ (scm-error 'wrong-type-arg "catch"
+ "Wrong type argument in position ~a: ~a"
+ (list 1 k) (list k)))
+ (let ((tag (make-prompt-tag "catch")))
+ (call-with-prompt
+ tag
+ (lambda ()
+ (with-fluid* %exception-handler
+ (make-exception-handler k tag pre-unwind-handler)
+ thunk))
+ (lambda (cont k . args)
+ (apply handler k args)))))
+
+ (define (with-throw-handler k thunk pre-unwind-handler)
+ "Add @var{handler} to the dynamic context as a throw handler
+for key @var{k}, then invoke @var{thunk}."
+ (if (not (or (symbol? k) (eqv? k #t)))
+ (scm-error 'wrong-type-arg "with-throw-handler"
+ "Wrong type argument in position ~a: ~a"
+ (list 1 k) (list k)))
+ (with-fluid* %exception-handler
+ (make-exception-handler k #f pre-unwind-handler)
+ thunk))
+
+ (define! 'catch catch)
+ (define! 'with-throw-handler with-throw-handler)
+ (define! 'throw throw))
+
+
+
+
;;; The real versions of `map' and `for-each', with cycle detection, and
;;; that use reverse! instead of recursion in the case of `map'.
;;;
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-756-g0f0b6f2,
Andy Wingo <=