From 5f0aec415b782023f9827b8ce14e499b148a335a Mon Sep 17 00:00:00 2001 From: felix 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 --- 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 {}) ; (hide {}) ; (inline-limit ) +; (unroll-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 ) )' into '(if )'. 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