diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 997c638f8..d4ab7c680 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1020,9 +1020,8 @@ ;;; express that in this syntax, append-call-type-deriver does that. (defknown append (&rest t) t (flushable) :call-type-deriver #'append-call-type-deriver) -(defknown sb-impl::append2 (list t) t - (flushable no-verify-arg-count) - :call-type-deriver #'append-call-type-deriver) +(defknown sb-impl::append2 (proper-list t) t + (flushable no-verify-arg-count)) (defknown copy-list (proper-or-dotted-list) list (flushable) :derive-type (sequence-result-nth-arg 0 :preserve-dimensions t)) @@ -1032,7 +1031,8 @@ (defknown copy-tree (t) t (flushable recursive)) (defknown revappend (proper-list t) t (flushable)) -(defknown nconc (&rest (modifying t :butlast t)) t ()) +(defknown nconc (&rest (modifying t :butlast t)) t () + :call-type-deriver #'nconc-call-type-deriver) (defknown nreconc ((modifying list) t) t (important-result)) (defknown butlast (proper-or-dotted-list &optional unsigned-byte) list (flushable)) diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index 0a547c5f4..5aaa4c139 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -571,6 +571,25 @@ (not trusted)) (reoptimize-lvar arg))))) +(defun nconc-call-type-deriver (call trusted) + (let* ((policy (lexenv-policy (node-lexenv call))) + (args (combination-args call)) + (list-type (specifier-type 'list))) + ;; All but the last argument should be proper lists + (loop for (arg next) on args + while next + do + (add-annotation + arg + (make-lvar-proper-sequence-annotation + :kind 'proper-or-dotted-list)) + (when (policy policy (> check-constant-modification 0)) + (add-annotation arg + (make-lvar-modified-annotation :caller 'nconc))) + (when (and (assert-lvar-type arg list-type policy) + (not trusted)) + (reoptimize-lvar arg))))) + ;;; It's either (number) or (real real) (defun atan-call-type-deriver (call trusted) (let* ((policy (lexenv-policy (node-lexenv call))) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index a386c1f34..da2f7b982 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -270,6 +270,9 @@ (specifier-type t) (specifier-type 'list))) +(setf (fun-info-externally-checkable-type (fun-info-or-lose 'nconc)) + #'append-externally-checkable-type-optimizer) + (flet ((remove-nil (fun args) (let ((remove (loop for (arg . rest) on args