diff options
author | Andy Wingo <wingo@pobox.com> | 2021-05-01 22:13:24 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2021-05-01 22:16:20 +0200 |
commit | 44a6a21dcc11d6da39d4548362cf63452a07bdbd (patch) | |
tree | 5498f481568eda0f24de984184a0b410a4889b29 | |
parent | 3383a2cb10b32b428c28495a84f4e4a40d34c9ee (diff) | |
download | guile-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.scm | 10 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 21 |
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 |