~ chicken-core (chicken-5) e28243f97cbfef618e3a5624f19c0af9dd98d6d6
commit e28243f97cbfef618e3a5624f19c0af9dd98d6d6
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Mon Feb 10 15:54:26 2020 +0100
Commit: megane <meganeka@gmail.com>
CommitDate: Wed Feb 12 17:20:50 2020 +0200
Don't directly call external inlineable procedures (fixes #1665)
When a procedure is external, its fid refers to a static function in
another compilation unit, so we can't create a direct call to that
function, even though the procedure itself is inlineable. Therefore,
avoid creating direct calls.
Signed-off-by: megane <meganeka@gmail.com>
diff --git a/core.scm b/core.scm
index 62b3fa67..a490915a 100644
--- a/core.scm
+++ b/core.scm
@@ -2588,6 +2588,8 @@
'no
(variable-mark
varname '##compiler#inline)))
+ ;; May not be external, see #1665
+ (not (node? (variable-mark varname '##compiler#inline-global)))
(or (test varname 'value)
(test varname 'local-value)))] )
(if (and val (eq? '##core#lambda (node-class val)))
diff --git a/tests/inline-me.scm b/tests/inline-me.scm
index f66ce670..d8859555 100644
--- a/tests/inline-me.scm
+++ b/tests/inline-me.scm
@@ -1,9 +1,11 @@
(module
inline-me
- (foreign-foo)
+ (foreign-foo external-foo)
(import scheme (chicken base))
(import (only (chicken foreign) foreign-lambda*))
(define foreign-foo (foreign-lambda* int ((int x)) "C_return ( x + 1 );"))
+ (define (external-foo x y) (display x y))
+
)
diff --git a/tests/inlining-tests.scm b/tests/inlining-tests.scm
index 9adc0f64..54636b31 100644
--- a/tests/inlining-tests.scm
+++ b/tests/inlining-tests.scm
@@ -28,3 +28,23 @@
(import inline-me)
(assert (= 42 (foreign-foo 41)))
+
+;; #1665, don't replace calls to inlinable procedures with direct
+;; calls when those procedures are external (via an inline file).
+(module test-1665
+ ()
+
+ (import scheme inline-me)
+
+ (define (inline-external-with-unroll-limit-test x)
+ (lambda (x)
+ (lambda (a)
+ (if a
+ (external-foo x 'xxx)
+ (if x
+ (external-foo x 'yyy)
+ (external-foo x 'zzz)))
+ 1)))
+
+ (inline-external-with-unroll-limit-test 'yo)
+ (inline-external-with-unroll-limit-test 'yo2))
Trap