~ chicken-core (chicken-5) cf5d2aed000cfd292708d41b3774321bfec5eb67
commit cf5d2aed000cfd292708d41b3774321bfec5eb67
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Jul 9 13:36:40 2019 +0200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Wed Jul 10 19:12:28 2019 +0200
When contracting/inlining procedure calls, catch argument-list mismatch.
Previously a mismatch in the number of arguments to inlined procedures
would trigger an error. Recent changes in the compiler seem to have
exposed optimization oppurtunities that may result in more inlining
and show that the error may not be correct in all situations. This
patch simply aborts the inlining attempt when the arguments don't
match, with no error or warning shown (the available call site
information will be insufficient in nearly all cases).
Fixes #1630
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/core.scm b/core.scm
index c659691d..f74b140f 100644
--- a/core.scm
+++ b/core.scm
@@ -2508,15 +2508,13 @@
(= (length refs) (length sites))
(test varname 'value)
(list? llist) ) ] )
- (when (and name
- (not (llist-match? llist (cdr subs))))
- (quit-compiling
- "~a: procedure `~a' called with wrong number of arguments"
- (source-info->string name)
- (if (pair? name) (cadr name) name)))
- (register-direct-call! id)
- (when custom (register-customizable! varname id))
- (list id custom) )
+ (cond ((and name
+ (not (llist-match? llist (cdr subs))))
+ '())
+ (else
+ (register-direct-call! id)
+ (when custom (register-customizable! varname id))
+ (list id custom) ) ) )
'() ) )
'() ) )
'() ) ) )
diff --git a/optimizer.scm b/optimizer.scm
index abca38df..8017ef19 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -335,15 +335,23 @@
;; only called once
(let* ([lparams (node-parameters lval)]
[llist (third lparams)] )
- (check-signature var args llist)
- (debugging 'o "contracted procedure" info)
- (touch)
- (for-each (cut db-put! db <> 'inline-target #t) fids)
- (walk
- (inline-lambda-bindings
- llist args (first (node-subexpressions lval)) #f db
- void)
- fids gae) ) )
+ (cond ((check-signature var args llist)
+ (debugging 'o "contracted procedure" info)
+ (touch)
+ (for-each (cut db-put! db <> 'inline-target #t)
+ fids)
+ (walk
+ (inline-lambda-bindings
+ llist args (first (node-subexpressions lval))
+ #f db
+ void)
+ fids gae) )
+ (else
+ (debugging
+ 'i
+ "not contracting procedure because argument list does not match"
+ info)
+ (walk-generic n class params subs fids gae #t)))))
((and-let* (((variable-mark var '##compiler#pure))
((eq? '##core#variable (node-class (car args))))
(kvar (first (node-parameters (car args))))
@@ -368,8 +376,8 @@
((and lval
(eq? '##core#lambda (node-class lval)))
;; callee is a lambda
- (let* ([lparams (node-parameters lval)]
- [llist (third lparams)] )
+ (let* ((lparams (node-parameters lval))
+ (llist (third lparams)) )
(##sys#decompose-lambda-list
llist
(lambda (vars argc rest)
@@ -383,29 +391,34 @@
((no) #f)
(else
(or external (< (fourth lparams) inline-limit)))))
- (debugging
- 'i
- (if external
- "global inlining"
- "inlining")
- info ifid (fourth lparams))
- (for-each (cut db-put! db <> 'inline-target #t) fids)
- (check-signature var args llist)
- (debugging 'o "inlining procedure" info)
- (call/cc
- (lambda (return)
- (define (cfk cvar)
- (debugging
- 'i
- "not inlining procedure because it refers to contractable"
- info cvar)
- (return
- (walk-generic n class params subs fids gae #t)))
- (let ((n2 (inline-lambda-bindings
- llist args (first (node-subexpressions lval))
- #t db cfk)))
- (touch)
- (walk n2 fids gae)))))
+ (cond ((check-signature var args llist)
+ (debugging 'i
+ (if external
+ "global inlining"
+ "inlining")
+ info ifid (fourth lparams))
+ (for-each (cut db-put! db <> 'inline-target #t)
+ fids)
+ (debugging 'o "inlining procedure" info)
+ (call/cc
+ (lambda (return)
+ (define (cfk cvar)
+ (debugging
+ 'i
+ "not inlining procedure because it refers to contractable"
+ info cvar)
+ (return (walk-generic n class params subs fids gae #t)))
+ (let ((n2 (inline-lambda-bindings
+ llist args (first (node-subexpressions lval))
+ #t db cfk)))
+ (touch)
+ (walk n2 fids gae)))))
+ (else
+ (debugging
+ 'i
+ "not inlining procedure because argument list does not match"
+ info)
+ (walk-generic n class params subs fids gae #t))))
((test ifid 'has-unused-parameters)
(if (< (length args) argc) ; Expression was already optimized (should this happen?)
(walk-generic n class params subs fids gae #t)
diff --git a/support.scm b/support.scm
index ed746ab9..1d078ca0 100644
--- a/support.scm
+++ b/support.scm
@@ -192,7 +192,6 @@
(set! syntax-error ##sys#syntax-error-hook)
-;; Move to C-platform?
(define (emit-syntax-trace-info info cntr)
(define (thread-id t) (##sys#slot t 14))
(##core#inline "C_emit_syntax_trace_info" info cntr
@@ -204,18 +203,12 @@
[(symbol? llist) (proc llist)]
[else (cons (proc (car llist)) (loop (cdr llist)))] ) ) )
-;; XXX: Shouldn't this be in optimizer.scm?
(define (check-signature var args llist)
- (define (err)
- (quit-compiling
- "Arguments to inlined call of `~A' do not match parameter-list ~A"
- (real-name var)
- (map-llist real-name (cdr llist)) ) )
- (let loop ([as args] [ll llist])
- (cond [(null? ll) (unless (null? as) (err))]
- [(symbol? ll)]
- [(null? as) (err)]
- [else (loop (cdr as) (cdr ll))] ) ) )
+ (let loop ((as args) (ll llist))
+ (cond ((null? ll) (null? as))
+ ((symbol? ll))
+ ((null? as) #f)
+ (else (loop (cdr as) (cdr ll))) ) ) )
;;; Generic utility routines:
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index d4585e37..53275a62 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -449,3 +449,16 @@
(let ((v0 ((foreign-lambda* c-string () "C_return(\"str\");")))
(v1 ((foreign-lambda* (const c-string) () "C_return(\"str\");"))))
(assert (equal? v0 v1)))
+
+; #1630: inlining may result in incorrectly flagged argument-
+; count errors.
+(define (outer x y)
+ (define (append-map proc . lsts)
+ (if (null? lsts)
+ (proc 1)
+ (apply proc lsts)))
+ (append-map (lambda (a) (assert (= a 1))))
+ (append-map (lambda (a b) (assert (and (= a 3) (= b 4))))
+ x y))
+(outer 3 4)
+
Trap