Hi!
Sorry, one of the previous patches was broken (thanks to megane
for pointing this out). Here is an updated version.
felix
From c7744fae69b314f1eaf68b2b60de3e90d4cad264 Mon Sep 17 00:00:00 2001
From: felix <fe...@call-with-current-continuation.org>
Date: Wed, 18 Sep 2019 14:59:51 +0200
Subject: [PATCH] Revert "Revert half of "Add some optimizer simplification
rules""
This reverts commit d8727f4a9bdfded30813a5a433b57eddf60c068f.
---
optimizer.scm | 32 ++++++++++++++++++++++++++++++++
1 file changed, 32 insertions(+)
diff --git a/optimizer.scm b/optimizer.scm
index bd163710..fc2d3165 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -830,6 +830,38 @@
args1)
nargs)
#t))
+ (else (loop (cdr args)
+ (cons (car args) nargs)
+ ok)))))))
+
+ ;; (let ((<var1> (##core#inline <op> ...)))
+ ;; (<var2> ... <var1> ...))
+ ;; -> (<var2> ... (##core#inline <op> ...) ...)
+ ;; ...))
+ ;; - <var1> is used only once.
+ `((let (var) (##core#inline (op) . args1)
+ (##core#call p . args2))
+ (var op args1 p args2)
+ ,(lambda (db may-rewrite var op args1 p args2)
+ (and may-rewrite ; give other optimizations a chance first
+ (= 1 (length (db-get-list db var 'references)))
+ (let loop ((args args2) (nargs '()) (ok #f))
+ (cond ((null? args)
+ (and ok
+ (make-node
+ '##core#call p
+ (reverse nargs))))
+ ((and (eq? '##core#variable
+ (node-class (car args)))
+ (eq? var
+ (car (node-parameters (car args)))))
+ (loop (cdr args)
+ (cons (make-node
+ '##core#inline
+ (list op)
+ args1)
+ nargs)
+ #t))
(else (loop (cdr args)
(cons (car args) nargs)
ok))))))))
--
2.19.1
From 5f0aec415b782023f9827b8ce14e499b148a335a Mon Sep 17 00:00:00 2001
From: felix <fe...@call-with-current-continuation.org>
Date: Wed, 18 Sep 2019 14:36:55 +0200
Subject: [PATCH] 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.
Signed-off-by: felix <fe...@call-with-current-continuation.org>
---
batch-driver.scm | 7 +++++++
c-platform.scm | 1 +
chicken.mdoc | 2 ++
core.scm | 12 ++++++++++++
csc.mdoc | 2 ++
csc.scm | 3 ++-
manual/Declarations | 8 ++++++++
manual/Using the compiler | 2 ++
optimizer.scm | 28 ++++++++++++++++++++++++++--
support.scm | 1 +
tests/inline-unroll.scm | 15 +++++++++++++++
tests/runtests.bat | 4 ++++
tests/runtests.sh | 2 ++
13 files changed, 84 insertions(+), 3 deletions(-)
create mode 100644 tests/inline-unroll.scm
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 9bb08b42..6ac1b8af 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)
@@ -1697,6 +1701,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 fc2d3165..a12bccd5 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
--
2.19.1
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
