~ chicken-core (chicken-5) 5d55f18857977c41a642161316e4cc497e333f5b
commit 5d55f18857977c41a642161316e4cc497e333f5b
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Sep 18 14:36:55 2019 +0200
Commit: megane <meganeka@gmail.com>
CommitDate: Sun Oct 13 18:13:52 2019 +0300
Catch runaway inlining
Recent changes in the optmimizer have trggered situations, where
inlining small procedures could progress endlessly. This patch now
records inline-operations and inhibits any inlining of procedure A in
procedure B if A was inlined into B previously at least N times, where
N is the new numeric "unroll-limit". Compiler-options and the assiocated
decdeclaration have been added as well.
Fixes #1648
Signed-off-by: felix <felix@call-with-current-continuation.org>
Signed-off-by: megane <meganeka@gmail.com>
diff --git a/batch-driver.scm b/batch-driver.scm
index ac871a8b..82ed562e 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -395,6 +395,12 @@
(or (string->number arg)
(quit-compiling
"invalid argument to `-inline-limit' option: `~A'" arg) ) ) ) )
+ (and-let* ((ulimit (memq 'unroll-limit options)))
+ (set! unroll-limit
+ (let ((arg (option-arg ulimit)))
+ (or (string->number arg)
+ (quit-compiling
+ "invalid argument to `-unroll-limit' option: `~A'" arg) ) ) ) )
(when (memq 'case-insensitive options)
(dribble "Identifiers and symbols are case insensitive")
(register-feature! 'case-insensitive)
@@ -774,6 +780,7 @@
(perform-high-level-optimizations
node2 db block-compilation
inline-locally inline-max-size
+ unroll-limit
inline-substitutions-enabled))
(end-time "optimization")
(print-node "optimized-iteration" '|5| node2)
diff --git a/c-platform.scm b/c-platform.scm
index 3c4e737f..87f36698 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -110,6 +110,7 @@
output-file include-path heap-size stack-size unit uses module
keyword-style require-extension inline-limit profile-name
prelude postlude prologue epilogue nursery extend feature no-feature
+ unroll-limit
emit-inline-file consult-inline-file
emit-types-file consult-types-file
emit-import-library))
diff --git a/chicken.mdoc b/chicken.mdoc
index d6324203..e6d5c920 100644
--- a/chicken.mdoc
+++ b/chicken.mdoc
@@ -200,6 +200,8 @@ Assume variable do not change their type.
Combine groups of local procedures into dispatch loop.
.It Fl lfa2
Perform additional lightweight flow-analysis pass.
+.It Fl unroll-limit Ar LIMIT
+Specifies inlining limit for self-recursive calls.
.El
.Pp
Configuration options:
diff --git a/core.scm b/core.scm
index b05a68b6..02c7c6b7 100644
--- a/core.scm
+++ b/core.scm
@@ -54,6 +54,7 @@
; (foreign-declare {<string>})
; (hide {<name>})
; (inline-limit <limit>)
+; (unroll-limit <limit>)
; (keep-shadowed-macros)
; (no-argc-checks)
; (no-bound-checks)
@@ -305,6 +306,7 @@
;; Other, non-boolean, flags set by (batch) driver
profiled-procedures import-libraries inline-max-size
+ unroll-limit
extended-bindings standard-bindings
;; non-booleans set by the (batch) driver, and read by the (c) backend
@@ -370,6 +372,7 @@
(define-constant constant-table-size 301)
(define-constant file-requirements-size 301)
(define-constant default-inline-max-size 20)
+(define-constant default-unroll-limit 1)
;;; Global variables containing compilation parameters:
@@ -397,6 +400,7 @@
(define disable-stack-overflow-checking #f)
(define external-protos-first #f)
(define inline-max-size default-inline-max-size)
+(define unroll-limit default-unroll-limit)
(define emit-closure-info #t)
(define undefine-shadowed-macros #t)
(define profiled-procedures #f)
@@ -1701,6 +1705,14 @@
(warning
"invalid argument to `inline-limit' declaration"
spec) ) ) )
+ ((unroll-limit)
+ (check-decl spec 1 1)
+ (let ((n (cadr spec)))
+ (if (number? n)
+ (set! unroll-limit n)
+ (warning
+ "invalid argument to `unroll-limit' declaration"
+ spec) ) ) )
((pure)
(let ((syms (cdr spec)))
(if (every symbol? syms)
diff --git a/csc.mdoc b/csc.mdoc
index 61d17c37..9630d716 100644
--- a/csc.mdoc
+++ b/csc.mdoc
@@ -201,6 +201,8 @@ Assume variable do not change their type.
Combine groups of local procedures into dispatch loop.
.It Fl lfa2
Perform additional lightweight flow-analysis pass.
+.It Fl unroll-limit Ar LIMIT
+Specifies inlining limit for self-recursive calls.
.El
.Pp
Configuration options:
diff --git a/csc.scm b/csc.scm
index d4ce7fa8..60272816 100644
--- a/csc.scm
+++ b/csc.scm
@@ -159,7 +159,7 @@
(define-constant complex-options
'(-debug -heap-size -nursery -stack-size -compiler -unit -uses -keyword-style
-optimize-level -include-path -database-size -extend -prelude -postlude -prologue -epilogue -emit-link-file
- -inline-limit -profile-name
+ -inline-limit -profile-name -unroll-limit
-emit-inline-file -consult-inline-file
-emit-types-file -consult-types-file
-feature -debug-level
@@ -429,6 +429,7 @@ Usage: #{csc} [OPTION ...] [FILENAME ...]
-clustering combine groups of local procedures into dispatch
loop
-lfa2 perform additional lightweight flow-analysis pass
+ -unroll-limit LIMIT specifies inlining limit for self-recursive calls
Configuration options:
diff --git a/manual/Declarations b/manual/Declarations
index 21d4db34..52500dc4 100644
--- a/manual/Declarations
+++ b/manual/Declarations
@@ -153,6 +153,14 @@ Enabling global inlining implies {{(declare (inline))}}.
Sets the maximum size of procedures which may potentially be inlined. The default threshold is {{20}}.
+=== unroll-limit
+
+ [declaration specifier] (unroll-limit LIMIT)
+
+Sets the maximum number of times a self-recursive call is inlined and
+so effectively "unrolled". The default limit is 1.
+
+
=== keep-shadowed-macros
[declaration specifier] (keep-shadowed-macros)
diff --git a/manual/Using the compiler b/manual/Using the compiler
index 51d905d4..da9f1808 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -166,6 +166,8 @@ the source text should be read from standard input.
; -no-usual-integrations : Specifies that standard procedures and certain internal procedures may be redefined, and can not be inlined. This is equivalent to declaring {{(not usual-integrations)}}.
+; -unroll-limit LIMIT : Specifies how often direct recursive calls should be "unrolled" by inlining the procedure body at the call site. The default limit is 1.
+
; -version : Prints the version and some copyright information and exit the compiler.
; -verbose : enables output of notes that are not necessarily warnings but might be of interest.
diff --git a/optimizer.scm b/optimizer.scm
index bd163710..3e84ce53 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -150,9 +150,12 @@
(define simplifications (make-vector 301 '()))
(define simplified-ops '())
(define broken-constant-nodes '())
+;; holds a-list mapping inlined fid's to inline-target-fid for catching runaway
+;; unrolling:
+(define inline-history '())
(define (perform-high-level-optimizations
- node db block-compilation may-inline inline-limit may-rewrite)
+ node db block-compilation may-inline inline-limit max-unrolls may-rewrite)
(let ((removed-lets 0)
(removed-ifs 0)
(replaced-vars 0)
@@ -390,7 +393,12 @@
(case (variable-mark var '##compiler#inline)
((no) #f)
(else
- (or external (< (fourth lparams) inline-limit)))))
+ (or external (< (fourth lparams) inline-limit))))
+ (or (within-unrolling-limit ifid (car fids) max-unrolls)
+ (begin
+ (debugging 'i "not inlining as unroll-limit is exceeded"
+ info ifid (car fids))
+ #f)))
(cond ((check-signature var args llist)
(debugging 'i
(if external
@@ -411,6 +419,8 @@
(let ((n2 (inline-lambda-bindings
llist args (first (node-subexpressions lval))
#t db cfk)))
+ (set! inline-history
+ (alist-cons ifid (car fids) inline-history))
(touch)
(walk n2 fids gae)))))
(else
@@ -567,6 +577,20 @@
(values node2 dirty) ) ) ) ) )
+;; Check whether inlined procedure has already been inlined in the
+;; same target procedure and count occurrences. If the number of
+;; inlinings exceed the unroll-limit
+
+(define (within-unrolling-limit fid tfid max-unrolls)
+ (let ((p (cons fid tfid)))
+ (let loop ((h inline-history) (n 0))
+ (cond ((null? h))
+ ((equal? p (car h))
+ (and (< n max-unrolls)
+ (loop (cdr h) (add1 n))))
+ (else (loop (cdr h) n))))))
+
+
;;; Pre-optimization phase:
;
; - Transform expressions of the form '(if (not <x>) <y> <z>)' into '(if <x> <z> <y>)'.
diff --git a/support.scm b/support.scm
index 53dcbf99..729d44aa 100644
--- a/support.scm
+++ b/support.scm
@@ -1786,6 +1786,7 @@ Usage: chicken FILENAME [OPTION ...]
-clustering combine groups of local procedures into dispatch
loop
-lfa2 perform additional lightweight flow-analysis pass
+ -unroll-limit LIMIT specifies inlining limit for self-recursive calls
Configuration options:
diff --git a/tests/inline-unroll.scm b/tests/inline-unroll.scm
new file mode 100644
index 00000000..d85a87ab
--- /dev/null
+++ b/tests/inline-unroll.scm
@@ -0,0 +1,15 @@
+;; trivial test for catching runaway inlining (#1648), by
+;; megane:
+
+(module uri-generic
+ (uri-relative-from)
+
+ (import scheme)
+
+ (define (uri-relative-from uabs base)
+ (dif-segs-from uabs base))
+
+ (define (dif-segs-from sabs base)
+ (if (null? base)
+ sabs
+ (dif-segs-from sabs base))))
diff --git a/tests/runtests.bat b/tests/runtests.bat
index 3234ee06..accaa7d0 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -67,6 +67,10 @@ if errorlevel 1 exit /b 1
if errorlevel 1 exit /b 1
a.out
if errorlevel 1 exit /b 1
+%compile% inline-unroll.scm -optimize-level 3
+if errorlevel 1 exit /b 1
+a.out
+if errorlevel 1 exit /b 1
echo ======================================== compiler message tests ...
%compile% -analyze-only messages-test.scm 2>messages.out
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 5b581747..950b6c09 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -94,6 +94,8 @@ echo "======================================== compiler inlining tests ..."
$compile_r inline-me.scm -s -J -oi inline-me.inline
$compile inlining-tests.scm -optimize-level 3
./a.out
+$compile inline-unroll.scm -optimize-level 3
+./a.out
echo "======================================== compiler message tests ..."
$compile -analyze-only messages-test.scm 2>messages.out
Trap