~ chicken-core (chicken-5) 070f2d22e7409371198b4cefe16243e9de8419e9

commit 070f2d22e7409371198b4cefe16243e9de8419e9
Author:     megane <meganeka@gmail.com>
AuthorDate: Sun Jun 23 16:46:50 2019 +0300
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Sat Jun 29 14:27:50 2019 +0200

    Disable inlining for functions using foreign stubs
    
    A workaround until a better solution appears.
    
    Fixes #1440
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>
    Signed-off-by: Peter Bex <peter@more-magic.net>

diff --git a/NEWS b/NEWS
index 9fc97a67..e15ec4e3 100644
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,8 @@
   - Fixed a bug in lfa2 pass which caused "if" or "cond" nodes to be
     incorrectly unboxed if the "else" branch had a flonum result type
     (#1624, thanks to Sven Hartrumpf)
+  - Inline files no longer refer to unexported foreign stub functions
+    (fixes #1440, thanks to "megane").
 
 5.1.0
 
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 6fc13c50..0ddfa099 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