From c3982889e5520aaa9a9a8553d74237f2279a9b11 Mon Sep 17 00:00:00 2001 From: felix Date: Tue, 9 Jul 2019 13:36:40 +0200 Subject: [PATCH] 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). --- core.scm | 16 ++++---- optimizer.scm | 81 +++++++++++++++++++++++----------------- support.scm | 17 +++------ tests/compiler-tests.scm | 13 +++++++ 4 files changed, 72 insertions(+), 55 deletions(-) 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..0857763f 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 5)))) + x y)) +(outer 3 4) + -- 2.19.1