From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Andrew Whatson Newsgroups: gmane.lisp.guile.devel Subject: [PATCH] Improve reporting of exception locations Date: Tue, 20 Sep 2022 12:00:44 +1000 Message-ID: <20220920020044.19963-1-whatson@gmail.com> Mime-Version: 1.0 Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="7886"; mail-complaints-to="usenet@ciao.gmane.io" Cc: Andrew Whatson To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Tue Sep 20 04:02:10 2022 Return-path: Envelope-to: guile-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1oaSaP-0001su-QY for guile-devel@m.gmane-mx.org; Tue, 20 Sep 2022 04:02:09 +0200 Original-Received: from localhost ([::1]:60330 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1oaSaO-0001Of-9k for guile-devel@m.gmane-mx.org; Mon, 19 Sep 2022 22:02:08 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:41994) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1oaSaA-0001OS-CS for guile-devel@gnu.org; Mon, 19 Sep 2022 22:01:54 -0400 Original-Received: from mail-pg1-x532.google.com ([2607:f8b0:4864:20::532]:33308) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1oaSa8-0001hM-CX for guile-devel@gnu.org; Mon, 19 Sep 2022 22:01:54 -0400 Original-Received: by mail-pg1-x532.google.com with SMTP id f193so1136008pgc.0 for ; Mon, 19 Sep 2022 19:01:51 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date; bh=85q40XFJ33cleWCQh4Z/jQHuEvE2FFmw8j2ZuSNrTbA=; b=kFBXtsqle89KRFiM/7iaHS0XoAEqIK3cOq56nl8XIwTDT9f3kFZpFvQnB5NSzmlWVW tpEQlPtvBXN5jrjZRIHmElchrs/KZJi6UFLaFRcaUHUTEeSt286VQ9e5ZGtLHRn+1HDg 57yQPIEJILc5gg2RPFE20+w4bNjK3z8ogQC2L7Fw9a0WN0F3Li3vJ3iJ6iPESBj4QmA4 bQzEossR7d7Xovdq0EZWZoRX/m7hZplAeDvJVdX85EiW/9ilIGaq0qWwuQdEY6lc+zVs Z1u/+cqsfvQwy5f1hcqerrfJlUOg79/XTQi3ZK9j1pGArZHf+Iz6fk61NZQchUOX7Zd+ EH1g== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date; bh=85q40XFJ33cleWCQh4Z/jQHuEvE2FFmw8j2ZuSNrTbA=; b=qtjUHHGXbrtiJoUc80o4VUvSW9dMx4TB7A0wTr1GGDfdPbp6IJCUNS1QyXPO4VkvfL jKkuBL/cFOW+3/flhiz6T7L3zVjQFWE+Kcjqxv2PDNEZcWENPygBsEc0IrDd2arpR7tk JWRM223Kol4jzJoOCSP1PVgzCTzJuuUJVJXj+1D/0qldKdf5Hdgldkk9uxNKKjOgg2Ra FiL8j8M+VcPQCsGIbLixVMIeafoqJCjO+v59Z8l3u6exJdNOPCRlp17UtTJ5qC29QzL6 Q1NTONWJ38cQVOAHIBG8nDmGdSCjrsIHYTpVK12+40/rRdwGyO+TEB2HPsesC/K5eGUF nWkA== X-Gm-Message-State: ACrzQf0NHw4XQH/gXXAiYdG16XKpdxcmeFNB5kHKhqW+bdixtIhgtloO ZYLzWI+BCQzqmUC5zWW9atogsCBmIZI= X-Google-Smtp-Source: AMsMyM4EIvu2dTFVbAVmMMK9tHYRiT2YapHx+KV/k53IEMYoMm3+hoEsWd80gxubw+9AJOj+byipBQ== X-Received: by 2002:a63:1304:0:b0:439:ac9b:34af with SMTP id i4-20020a631304000000b00439ac9b34afmr17950964pgl.464.1663639310316; Mon, 19 Sep 2022 19:01:50 -0700 (PDT) Original-Received: from fumo.fritz.box (eft1854679.lnk.telstra.net. [101.187.131.186]) by smtp.gmail.com with ESMTPSA id ja7-20020a170902efc700b0017865059c5dsm64894plb.161.2022.09.19.19.01.48 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 19 Sep 2022 19:01:49 -0700 (PDT) X-Mailer: git-send-email 2.37.3 Received-SPF: pass client-ip=2607:f8b0:4864:20::532; envelope-from=whatson@gmail.com; helo=mail-pg1-x532.google.com X-Spam_score_int: -20 X-Spam_score: -2.1 X-Spam_bar: -- X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001, RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Original-Sender: "guile-devel" Xref: news.gmane.io gmane.lisp.guile.devel:21355 Archived-At: Most errors were reported as coming from boot-9.scm due to incorrect hard-coded stack-narrowing offsets. This patch fixes the offsets and adds an argument to specify additional frames to skip when calling raise-exception. * libguile/stacks.h: * libguile/stacks.c (scm_skip_stack_frames_fluid): New internal var. (scm_init_stacks): Define %skip-stack-frames and initialize to 0. * libguile/continuations.c (print_exception_and_backtrace): * libguile/throw.c (handler_message): Use scm_skip_stack_frames_fluid to accurately trim the stack. * module/ice-9/boot-9.scm (raise-exception): Add #:skip-frames kwarg. Call handler with %skip-stack-frames set appropriately. (throw): Call raise-exception with #:skip-frames 1. * module/ice-9/threads.scm (call-with-new-thread): * module/system/repl/error-handling.scm (call-with-error-handling): Use %skip-stack-frames to accurately trim the stack. --- libguile/continuations.c | 12 +++++++----- libguile/stacks.c | 5 +++++ libguile/stacks.h | 1 + libguile/throw.c | 15 +++++++-------- module/ice-9/boot-9.scm | 19 +++++++++++++++---- module/ice-9/threads.scm | 6 +++--- module/system/repl/error-handling.scm | 10 ++++++---- 7 files changed, 44 insertions(+), 24 deletions(-) diff --git a/libguile/continuations.c b/libguile/continuations.c index b8b6e1dca..227be46f9 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -38,6 +38,7 @@ #include "debug.h" #include "dynstack.h" #include "eval.h" +#include "fluids.h" #include "gsubr.h" #include "init.h" #include "instructions.h" @@ -395,12 +396,13 @@ should_print_backtrace (SCM tag, SCM stack) static void print_exception_and_backtrace (SCM port, SCM tag, SCM args) { - SCM stack, frame; + SCM skip, stack, frame; - /* We get here via a throw to a catch-all. In that case there is the - throw frame active, and this catch closure, so narrow by two - frames. */ - stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2))); + /* We get here via a throw to a catch-all. Narrow by the number of + frames specified in %skip-stack-frames to get an accurate error + location. */ + skip = scm_fluid_ref (scm_skip_stack_frames_fluid); + stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (skip)); frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F; if (should_print_backtrace (tag, stack)) diff --git a/libguile/stacks.c b/libguile/stacks.c index 36842920b..5c7d57a06 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -48,6 +48,8 @@ #include "stacks.h" +SCM scm_skip_stack_frames_fluid; + static SCM scm_sys_stacks; @@ -473,5 +475,8 @@ scm_init_stacks () SCM_UNDEFINED); scm_set_struct_vtable_name_x (scm_stack_type, scm_from_utf8_symbol ("stack")); + + scm_skip_stack_frames_fluid = scm_make_fluid_with_default (SCM_INUM0); + scm_c_define ("%skip-stack-frames", scm_skip_stack_frames_fluid); #include "stacks.x" } diff --git a/libguile/stacks.h b/libguile/stacks.h index 25ece853a..39d0433ac 100644 --- a/libguile/stacks.h +++ b/libguile/stacks.h @@ -59,6 +59,7 @@ SCM_API SCM scm_stack_id (SCM stack); SCM_API SCM scm_stack_ref (SCM stack, SCM i); SCM_API SCM scm_stack_length (SCM stack); +SCM_INTERNAL SCM scm_skip_stack_frames_fluid; SCM_INTERNAL void scm_init_stacks (void); #endif /* SCM_STACKS_H */ diff --git a/libguile/throw.c b/libguile/throw.c index e837abe89..468ed0241 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -366,16 +366,15 @@ should_print_backtrace (SCM tag, SCM stack) static void handler_message (void *handler_data, SCM tag, SCM args) { - SCM p, stack, frame; + SCM p, skip, stack, frame; p = scm_current_error_port (); - /* Usually we get here via a throw to a catch-all. In that case - there is the throw frame active, and the catch closure, so narrow by - two frames. It is possible for a user to invoke - scm_handle_by_message directly, though, so it could be this - narrows too much. We'll have to see how this works out in - practice. */ - stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2))); + /* Usually we get here via a throw to a catch-all, though it is + possible for a user to invoke scm_handle_by_message directly. + Narrow by the number of frames specified in %skip-stack-frames to + get an accurate error location. */ + skip = scm_fluid_ref (scm_skip_stack_frames_fluid); + stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (skip)); frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F; if (should_print_backtrace (tag, stack)) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index a46145ed5..f5080fe2e 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1628,7 +1628,7 @@ exception that is an instance of @var{rtd}." (exception-kind exn) (exception-args exn)) (primitive-exit 1)))) - (define* (raise-exception exn #:key (continuable? #f)) + (define* (raise-exception exn #:key (continuable? #f) (skip-frames 0)) "Raise an exception by invoking the current exception handler on @var{exn}. The handler is called with a continuation whose dynamic environment is that of the call to @code{raise}, except that the current @@ -1638,7 +1638,14 @@ called was installed. If @var{continuable?} is true, the handler is invoked in tail position relative to the @code{raise-exception} call. Otherwise if the handler returns, a non-continuable exception of type @code{&non-continuable} is -raised in the same dynamic environment as the handler." +raised in the same dynamic environment as the handler. + +The @var{skip-frames} argument can be used to specify a number of +additional stack frames to skip when determining the error location. +This is useful for helper functions which raise an exception but +shouldn't be reported as the source of the error. The default value of +0 will treat the caller of @code{raise-exception} as the source of the +error." (define (capture-current-exception-handlers) ;; FIXME: This is quadratic. (let lp ((depth 0)) @@ -1677,7 +1684,11 @@ raised in the same dynamic environment as the handler." (else (lp handlers))))) (else - (with-fluids ((%active-exception-handlers handlers)) + (with-fluids ((%active-exception-handlers handlers) + ;; Calling raise-exception adds 3 frames to + ;; the stack; record this so the handler can + ;; determine the correct error location. + (%skip-stack-frames (+ 3 skip-frames))) (cond (continuable? (handler exn)) @@ -1761,7 +1772,7 @@ 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))) - (raise-exception (make-exception-from-throw key args))) + (raise-exception (make-exception-from-throw key args) #:skip-frames 1)) (define (with-throw-handler k thunk pre-unwind-handler) "Add @var{handler} to the dynamic context as a throw handler diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index c42bd266f..c2fc155c1 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -134,9 +134,9 @@ Once @var{thunk} or @var{handler} returns, the return value is made the (lambda () (%start-stack 'thread thunk)) (lambda _ (values)) (lambda (key . args) - ;; Narrow by three: the dispatch-exception, - ;; this thunk, and make-stack. - (let ((stack (make-stack #t 3))) + ;; Narrow by two extra frames: this thunk, and make-stack. + (let* ((skip (+ 2 (fluid-ref %skip-stack-frames))) + (stack (make-stack #t skip))) (false-if-exception (begin (when stack diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm index 8d5a8a5f0..f9f8b1416 100644 --- a/module/system/repl/error-handling.scm +++ b/module/system/repl/error-handling.scm @@ -135,9 +135,9 @@ (cdr (fluid-ref %stacks)))) (stack (narrow-stack->vector (make-stack #t) - ;; Cut three frames from the top of the stack: - ;; make-stack, this one, and the throw handler. - 3 + ;; Cut two extra frames from the top of the stack: + ;; make-stack, and this one. + (+ 2 (fluid-ref %skip-stack-frames)) ;; Narrow the end of the stack to the most recent ;; start-stack. tag @@ -165,7 +165,9 @@ (frames (narrow-stack->vector (make-stack #t) ;; Narrow as above, for the debugging case. - 3 tag 0 (and tag 1)))) + (+ 2 (fluid-ref %skip-stack-frames)) + tag + 0 (and tag 1)))) (with-saved-ports (lambda () (print-frames frames))) (report-error key args) (if #f #f))))) -- 2.37.3