>From 892bead3d97c6d006eea3540449e5326dd1d7f6f Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Sun, 23 Jun 2019 16:46:50 +0300
Subject: [PATCH] Disable inlining for functions using foreign stubs

A workaround until a better solution appears.

Fixes #1440

Signed-off-by: Evan Hanson <address@hidden>
---
 batch-driver.scm         |  3 ++-
 support.scm              | 16 +++++++++++++---
 tests/inline-me.scm      |  9 +++++++++
 tests/inlining-tests.scm |  3 +++
 tests/runtests.bat       |  2 ++
 tests/runtests.sh        |  1 +
 6 files changed, 30 insertions(+), 4 deletions(-)
 create mode 100644 tests/inline-me.scm

diff --git a/batch-driver.scm b/batch-driver.scm
index f0cfc2b1..a7d791fd 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -819,7 +819,8 @@
 				(dribble "generating global inline file `~a' ..." f)
 				(emit-global-inline-file
 				 filename f db block-compilation
-				 inline-max-size) ) )
+				 inline-max-size
+				 (map foreign-stub-id foreign-lambda-stubs)) ) )
 			    (begin-time)
 			    ;; Closure conversion
 			    (set! node2 (perform-closure-conversion node2 db))
diff --git a/support.scm b/support.scm
index f412627d..ed746ab9 100644
--- a/support.scm
+++ b/support.scm
@@ -755,7 +755,15 @@
 
 ;; Only used in batch-driver.scm
 (define (emit-global-inline-file source-file inline-file db
-				 block-compilation inline-limit)
+				 block-compilation inline-limit
+				 foreign-stubs)
+  (define (uses-foreign-stubs? node)
+    (let walk ((n node))
+      (case (node-class n)
+	((##core#inline)
+	 (memq (car (node-parameters n)) foreign-stubs))
+	(else
+	 (any walk (node-subexpressions n))))))
   (let ((lst '())
 	(out '()))
     (hash-table-for-each
@@ -772,8 +780,10 @@
 		    ((case (variable-mark sym '##compiler#inline)
 		       ((yes) #t)
 		       ((no) #f)
-		       (else 
-			(< (fourth lparams) inline-limit) ) ) ) )
+		       (else
+			(< (fourth lparams) inline-limit))))
+		    ;; See #1440
+		    ((not (uses-foreign-stubs? (cdr val)))))
 	   (set! lst (cons sym lst))
 	   (set! out (cons (list sym (node->sexpr (cdr val))) out)))))
      db)
diff --git a/tests/inline-me.scm b/tests/inline-me.scm
new file mode 100644
index 00000000..f66ce670
--- /dev/null
+++ b/tests/inline-me.scm
@@ -0,0 +1,9 @@
+(module
+ inline-me
+ (foreign-foo)
+ (import scheme (chicken base))
+ (import (only (chicken foreign) foreign-lambda*))
+
+ (define foreign-foo (foreign-lambda* int ((int x)) "C_return ( x + 1 );"))
+
+)
diff --git a/tests/inlining-tests.scm b/tests/inlining-tests.scm
index 7080d476..9adc0f64 100644
--- a/tests/inlining-tests.scm
+++ b/tests/inlining-tests.scm
@@ -25,3 +25,6 @@
 (define (foo) 0)
 (bar)
 (assert (= 1 (foo)))
+
+(import inline-me)
+(assert (= 42 (foreign-foo 41)))
diff --git a/tests/runtests.bat b/tests/runtests.bat
index cb24be4d..5765f146 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -61,6 +61,8 @@ echo "======================================== csc tests ..."
 if errorlevel 1 exit /b 1
 
 echo ======================================== compiler inlining tests  ...
+%compile_r% inline-me.scm -s -J -oi inline-me.inline
+if errorlevel 1 exit /b 1
 %compile% inlining-tests.scm -optimize-level 3
 if errorlevel 1 exit /b 1
 a.out
diff --git a/tests/runtests.sh b/tests/runtests.sh
index fc90ebbe..1811cc35 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -91,6 +91,7 @@ echo "======================================== csc tests ..."
 $interpret -s csc-tests.scm
 
 echo "======================================== compiler inlining tests  ..."
+$compile_r inline-me.scm -s -J -oi inline-me.inline
 $compile inlining-tests.scm -optimize-level 3
 ./a.out
 
-- 
2.21.0