From 44a6a21dcc11d6da39d4548362cf63452a07bdbd Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sat, 1 May 2021 22:13:24 +0200
Subject: [PATCH] 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.
---
 module/language/tree-il/effects.scm | 10 +++++++---
 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