From f32ee7df37cdc62596e849c079f365000424a712 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Sun, 5 May 2013 20:51:15 +0400 Subject: [PATCH] Better type derivation for APPEND, NCONC, LIST. The result types of APPEND/NCONC depend on the last argument and the presence of conses in the middle. For example (append 42) => 42, (append nil nil 42) => 42, (append (list 1) 42) => (1 . 42), etc. LIST returns NIL in case of no arguments and a cons in other cases. That fact required an adjustment for a values-list optimizer, which removed all arguments from a LIST call making it change the type from LIST to NULL and confusing things. Closes lp#538957 --- NEWS | 2 + src/compiler/fndb.lisp | 1 + src/compiler/generic/vm-ir2tran.lisp | 3 -- src/compiler/ir1opt.lisp | 1 + src/compiler/srctran.lisp | 74 ++++++++++++++++++++++++++++++++++ tests/compiler.pure.lisp | 14 +++++++ 6 files changed, 92 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index e051461..32fd625 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,8 @@ changes relative to sbcl-1.1.7: * enhancement: WITH-PINNED-OBJECTS no longer conses on PPC/GENCGC. * enhancement: (sb-introspect:find-definition-sources-by-name x :vop) now also returns VOPs which do not translate any functions. + * enhancement: better type derivation for APPEND, NCONC, LIST. + (lp#538957) * bug fix: type derivation for LOG{AND,IOR,XOR} scales linearly instead of quadratically with the size of the input in the worst case. (lp#1096444) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index ac1482d..8221b10 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -706,6 +706,7 @@ ;;; All but last must be of type LIST, but there seems to be no way to ;;; express that in this syntax. (defknown append (&rest t) t (flushable)) +(defknown sb!impl::append2 (list t) t (flushable)) (defknown copy-list (list) list (flushable)) (defknown copy-alist (list) list (flushable)) diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index 420b129..dd820f6 100644 --- a/src/compiler/generic/vm-ir2tran.lisp +++ b/src/compiler/generic/vm-ir2tran.lisp @@ -275,13 +275,10 @@ #!+stack-allocatable-lists (progn (defoptimizer (list stack-allocate-result) ((&rest args) node dx) - (declare (ignore node dx)) (not (null args))) (defoptimizer (list* stack-allocate-result) ((&rest args) node dx) - (declare (ignore node dx)) (not (null (rest args)))) (defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args) node dx) - (declare (ignore node dx)) t)) ;;; ...conses diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index dc6769b..b664bf7 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -2034,6 +2034,7 @@ (flush-lvar-externally-checkable-type arg)) (setf (combination-args use) nil) (flush-dest list) + (flush-combination use) (setf (combination-args node) args)) t))) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 298c8a6..282c34f 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -134,6 +134,11 @@ (1 `(cons ,(first args) nil)) (t (values nil t)))) +(defoptimizer (list derive-type) ((&rest args) node) + (if args + (specifier-type 'cons) + (specifier-type 'null))) + ;;; And similarly for LIST*. (define-source-transform list* (arg &rest others) (cond ((not others) arg) @@ -145,6 +150,75 @@ (specifier-type 'cons) (lvar-type arg))) +;;; + +(define-source-transform nconc (&rest args) + (case (length args) + (0 ()) + (1 (car args)) + (t (values nil t)))) + +;;; (append nil nil nil fixnum) => fixnum +;;; (append x x cons x x) => cons +;;; (append x x x x list) => list +;;; (append x x x x sequence) => sequence +;;; (append fixnum x ...) => nil +(defun derive-append-type (args) + (cond ((not args) + (specifier-type 'null)) + (t + (let ((cons-type (specifier-type 'cons)) + (null-type (specifier-type 'null)) + (list-type (specifier-type 'list)) + (last (lvar-type (car (last args))))) + (or + ;; Check that all but the last arguments are lists first + (loop for (arg next) on args + while next + do + (let ((lvar-type (lvar-type arg))) + (unless (or (csubtypep list-type lvar-type) + (csubtypep lvar-type list-type)) + (assert-lvar-type arg list-type + (lexenv-policy *lexenv*)) + (return *empty-type*)))) + (loop with all-nil = t + for (arg next) on args + for lvar-type = (lvar-type arg) + while next + do + (cond + ;; Cons in the middle guarantees the result will be a cons + ((csubtypep lvar-type cons-type) + (return cons-type)) + ;; If all but the last are NIL the type of the last arg + ;; can be used + ((csubtypep lvar-type null-type)) + (all-nil + (setf all-nil nil))) + finally + (return + (cond (all-nil + last) + ((csubtypep last cons-type) + cons-type) + ((csubtypep last list-type) + list-type) + ;; If the last is SEQUENCE (or similar) it'll + ;; be either that sequence or a cons, which is a + ;; sequence + ((csubtypep list-type last) + last))))))))) + +(defoptimizer (append derive-type) ((&rest args)) + (derive-append-type args)) + +(defoptimizer (sb!impl::append2 derive-type) ((&rest args)) + (derive-append-type args)) + +(defoptimizer (nconc derive-type) ((&rest args)) + (derive-append-type args)) + ;;; Translate RPLACx to LET and SETF. (define-source-transform rplaca (x y) (once-only ((n-x x)) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 0e7c53c..f50322e 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -4397,3 +4397,17 @@ ((2 2 0 -2 -1 2) 9223372036854775803) (t 358458651))))))) (assert (= (funcall test -10470605025) 26)))) + +(with-test (:name :append-type-derivation) + (let ((test-cases + '((lambda () (append 10)) (integer 10 10) + (lambda () (append nil 10)) (integer 10 10) + (lambda (x) (append x 10)) t + (lambda (x) (append x (cons 1 2))) cons + (lambda (x y) (append x (cons 1 2) y)) cons + (lambda (x y) (nconc x (the list y) x)) t + (lambda (x y) (print (length y)) (append x y)) sequence))) + (loop for (function result-type) on test-cases by #'cddr + do (assert (equal (car (cdaddr (sb-kernel:%simple-fun-type + (compile nil function)))) + result-type))))) -- 1.7.10.4