summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2021-05-01 22:13:24 +0200
committerAndy Wingo <wingo@pobox.com>2021-05-01 22:16:20 +0200
commit44a6a21dcc11d6da39d4548362cf63452a07bdbd (patch)
tree5498f481568eda0f24de984184a0b410a4889b29
parent3383a2cb10b32b428c28495a84f4e4a40d34c9ee (diff)
downloadguile-44a6a21dcc11d6da39d4548362cf63452a07bdbd.tar.gz
Fix tree-il effects analysis for prompts
* module/language/tree-il/effects.scm (make-effects-analyzer): The body of a prompt is an expression only for escape-only prompts, and the handler is always a lambda. Fix bug where a prompt could be incorrectly marked effect-free. * test-suite/tests/tree-il.test ("optimize"): Add test for bug 48098. Fixes bug 48098.
-rw-r--r--module/language/tree-il/effects.scm10
-rw-r--r--test-suite/tests/tree-il.test21
2 files changed, 28 insertions, 3 deletions
diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm
index 6e5ff33a0..f69f84165 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -1,6 +1,6 @@
;;; Effects analysis on Tree-IL
-;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012, 2013, 2021 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -588,8 +588,12 @@ of an expression."
(($ <prompt> _ escape-only? tag body handler)
(logior (compute-effects tag)
- (compute-effects body)
- (compute-effects handler)))
+ (compute-effects (if escape-only?
+ body
+ (make-call #f body '())))
+ ;; Calls handler with probably wrong argument count,
+ ;; but that will just add a &type-check effect.
+ (compute-effects (make-call #f handler '()))))
(($ <abort> _ tag args tail)
(logior &all-effects-but-bailout
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 217a1000f..97bf17aa2 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -24,6 +24,7 @@
#:use-module (system base message)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
+ #:use-module (language tree-il optimize)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-13))
@@ -90,6 +91,26 @@
#:from 'tree-il
#:to 'scheme)))))
+
+(define* (compile+optimize exp #:key (env (current-module))
+ (optimization-level 2) (opts '()))
+ (let ((optimize (make-lowerer optimization-level opts)))
+ (optimize (compile exp #:to 'tree-il #:env env) env)))
+
+(with-test-prefix "optimize"
+
+ (pass-if-equal "https://debbugs.gnu.org/48098"
+ '(begin
+ (display "hey!\n")
+ 42)
+ (decompile
+ (compile+optimize
+ '(begin
+ (call-with-prompt (make-prompt-tag)
+ (lambda () (display "hey!\n"))
+ (lambda (k) #f))
+ 42)))))
+
(with-test-prefix "tree-il->scheme"
(pass-if-tree-il->scheme