From 194a9e0eabc3c57d2bd22612b964d1715d0be255 Mon Sep 17 00:00:00 2001
From: Marius Gerbershagen <marius.gerbershagen@gmail.com>
Date: Sat, 16 Jan 2021 16:12:13 +0100
Subject: [PATCH] cmp: fix bug in inlining local functions which are closures

See added test case for explanations.
---
 src/cmp/cmpflet.lsp                 |  5 +++--
 src/tests/normal-tests/compiler.lsp | 35 +++++++++++++++++++++++++++++
 2 files changed, 38 insertions(+), 2 deletions(-)

diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp
index 11650503..48df8f5c 100644
--- a/src/cmp/cmpflet.lsp
+++ b/src/cmp/cmpflet.lsp
@@ -276,8 +276,9 @@
       ;; we introduce a variable to hold the funob
       (let ((var (fun-var fun)))
         (when (and cfb build-object)
-          (setf (var-ref-clb var) t
-                (var-kind var) 'LEXICAL))))
+          (setf (var-ref-clb var) t)
+          (when (not (eq (var-kind var) 'CLOSURE))
+            (setf (var-kind var) 'LEXICAL)))))
     fun))
 
 (defun c2call-local (c1form fun args)
diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp
index 67b09621..0f0c592c 100644
--- a/src/tests/normal-tests/compiler.lsp
+++ b/src/tests/normal-tests/compiler.lsp
@@ -1967,3 +1967,38 @@
                                    (block nil
                                      (progv '(*s*) (list 0) (return 1) *s*)))))))
     (is (not (boundp '*s*)))))
+
+;;; Date 2021-01-16
+;;; Description
+;;;
+;;;     Compiling a local function of type CLOSURE can lead to an
+;;;     internal compiler error if the function is later inlined
+;;;     because the compiler would indiscriminantly change the closure
+;;;     type to LEXICAL during inlining.
+(ext:with-clean-symbols (some-global-fun another-global-fun)
+  (defun some-global-fun (fun)
+    (funcall fun))
+  (defun another-global-fun (x)
+    x)
+  (test cmp.0084.inline-local-closure-type
+    (let ((fun '(lambda (arg)
+                 (declare (optimize speed))
+                 (labels
+                     ((a ()
+                        (some-global-fun #'b)
+                        (c))
+                      (b ()
+                        (c))
+                      (c ()
+                        ;; c is of type CLOSURE (arg is passed to
+                        ;; a global function). This "infects" a
+                        ;; and b to be of type CLOSURE too.
+                        (incf arg)
+                        (another-global-fun arg)))
+                   (declare (inline a))
+                   (a))))
+          compiled-fun warnings-p errors-p)
+      (finishes (multiple-value-setq (compiled-fun warnings-p error-p)
+                  (compile nil fun)))
+      (is (null errors-p))
+      (is (= (funcall compiled-fun 0) 2)))))