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

diff --git a/NEWS b/NEWS
index e051461..32fd625 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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)))))