Re: [Chicken-hackers] [PATCH] Disable inlining for functions using foreign stubs

[megane]

Evan Hanson <address@hidden> writes:

> Hi megane,
>
> Thanks, this seems like a good fix for now.
>
> On 2019-06-23 17:29, megane wrote:
>> diff --git a/support.scm b/support.scm
>> index f412627d..90635761 100644
>> --- a/support.scm
>> +++ b/support.scm
>> @@ -769,11 +776,11 @@
>>                  ((assq 'inlinable plist))
>>                  (lparams (node-parameters (cdr val)))
>>                  ((not (db-get db sym 'hidden-refs)))
>> -                ((case (variable-mark sym '##compiler#inline)
>> -                   ((yes) #t)
>> -                   ((no) #f)
>> -                   (else 
>> -                    (< (fourth lparams) inline-limit) ) ) ) )
>> +                ((not (eq? 'no (variable-mark sym '##compiler#inline))))
>> +                ((< (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)
>
> ISTM this changes the inlining logic slightly in that symbols marked
> with '##compiler#inline => 'yes will now only be inlined if they're
> under the inline-limit. Previously, they would always be inlined. Is
> that right, and is the change intentional?

Good catch! Didn't intend to change other logic.

Fixed version attached.

>From 4a5334b0fcee91594abbea434a617074e9b91881 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
---
 batch-driver.scm         |  3 ++-
 support.scm              | 20 ++++++++++++++------
 tests/inline-me.scm      |  9 +++++++++
 tests/inlining-tests.scm |  3 +++
 tests/runtests.sh        |  1 +
 5 files changed, 29 insertions(+), 7 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..f373566a 100644
--- a/support.scm
+++ b/support.scm
@@ -755,7 +755,14 @@
 
 ;; 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
@@ -769,11 +776,12 @@
                    ((assq 'inlinable plist))
                    (lparams (node-parameters (cdr val)))
                    ((not (db-get db sym 'hidden-refs)))
-                   ((case (variable-mark sym '##compiler#inline)
-                      ((yes) #t)
-                      ((no) #f)
-                      (else 
-                       (< (fourth lparams) inline-limit) ) ) ) )
+                   ((not (eq? 'no (variable-mark sym '##compiler#inline))))
+                   ((or (eq? 'yes (variable-mark sym '##compiler#inline))
+                        (< (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.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.17.1


>
> Evan