From 01cc13c8dab7399f6d7ef10e01add5edbbc03e31 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Sat, 7 Sep 2013 02:03:08 +0400 Subject: [PATCH] Improve knownfun declarations. Make some types more accurate, add some :derive-type #'result-type-first/last-arg. Add missing %adjoin/member/assoc-test/not/key defknowns. --- package-data-list.lisp-expr | 1 + src/compiler/fndb.lisp | 105 ++++++++++++++++++++++++++++++------------- 2 files changed, 76 insertions(+), 30 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 631504b..8ebecda 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1866,6 +1866,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "FIND-CALLER-NAME-AND-FRAME" "FIND-INTERRUPTED-NAME-AND-FRAME" "%SET-SYMBOL-VALUE" "%SET-SYMBOL-GLOBAL-VALUE" "%SET-SYMBOL-PACKAGE" + "SET-SYMBOL-GLOBAL-VALUE" "OUTPUT-SYMBOL-NAME" "%COERCE-NAME-TO-FUN" "DEFAULT-STRUCTURE-PRINT" "LAYOUT" "LAYOUT-LENGTH" "LAYOUT-PURE" "DSD-RAW-TYPE" diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index cee3709..b25fe32 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -91,7 +91,7 @@ (defknown classoid-of (t) classoid (flushable)) (defknown layout-of (t) layout (flushable)) (defknown copy-structure (structure-object) structure-object - (flushable)) + (flushable)) ;; FIXME: can derive the type based on the structure ;;;; from the "Control Structure" chapter: @@ -115,10 +115,14 @@ :derive-type #'result-type-last-arg) (defknown fdefinition ((or symbol cons)) function (explicit-check)) (defknown %set-fdefinition ((or symbol cons) function) function - (explicit-check)) -(defknown makunbound (symbol) symbol) + (explicit-check) + :derive-type #'result-type-last-arg) +(defknown makunbound (symbol) symbol + () + :derive-type #'result-type-first-arg) (defknown fmakunbound ((or symbol cons)) (or symbol cons) - (explicit-check)) + (explicit-check) + :derive-type #'result-type-first-arg) (defknown apply (callable t &rest t) *) ; ### Last arg must be List... (defknown funcall (callable &rest t) *) @@ -666,7 +670,6 @@ :derive-type (creation-result-type-specifier-nth-arg 1) :destroyed-constant-args (nth-constant-nonempty-sequence-args 2 3)) -;;; not FLUSHABLE, despite what CMU CL's DEFKNOWN said.. (defknown read-sequence (sequence stream &key (:start index) @@ -680,7 +683,7 @@ (:end sequence-end)) sequence () - :derive-type (sequence-result-nth-arg 1)) + :derive-type #'result-type-first-arg) ;;;; from the "Manipulating List Structure" chapter: (defknown (car cdr first rest) @@ -754,7 +757,7 @@ :destroyed-constant-args (nth-constant-nonempty-sequence-args 1)) (defknown ldiff (list t) list (flushable)) -(defknown (rplaca rplacd) (cons t) list () +(defknown (rplaca rplacd) (cons t) cons () :destroyed-constant-args (nth-constant-args 1)) (defknown subst (t t t &key (:key callable) (:test callable) @@ -791,7 +794,7 @@ (defknown adjoin (t list &key (:key callable) (:test callable) (:test-not callable)) - list (foldable flushable call)) + cons (foldable flushable call)) (defknown (union intersection set-difference set-exclusive-or) (list list &key (:key callable) (:test callable) (:test-not callable)) @@ -809,7 +812,7 @@ boolean (foldable flushable call)) -(defknown acons (t t t) list (movable flushable)) +(defknown acons (t t t) cons (movable flushable)) (defknown pairlis (t t &optional t) list (flushable)) (defknown (rassoc assoc) @@ -841,7 +844,8 @@ (defknown sb!impl::gethash3 (t hash-table t) (values t boolean) (flushable)) ; not FOLDABLE, since hash table contents can change (defknown %puthash (t hash-table t) t () - :destroyed-constant-args (nth-constant-args 2)) + :destroyed-constant-args (nth-constant-args 2) + :derive-type #'result-type-last-arg) (defknown remhash (t hash-table) boolean () :destroyed-constant-args (nth-constant-args 2)) (defknown maphash (callable hash-table) null (flushable call)) @@ -1154,11 +1158,14 @@ (defknown (prin1-to-string princ-to-string) (t) simple-string (flushable)) (defknown write-char (character &optional stream-designator) character - (explicit-check)) + (explicit-check) + :derive-type #'result-type-first-arg) + (defknown (write-string write-line) (string &optional stream-designator &key (:start index) (:end sequence-end)) string - (explicit-check)) + (explicit-check) + :derive-type #'result-type-first-arg) (defknown (terpri finish-output force-output clear-output) (&optional stream-designator) null @@ -1168,7 +1175,8 @@ (explicit-check)) (defknown write-byte (integer stream) integer - (explicit-check)) + (explicit-check) + :derive-type #'result-type-first-arg) ;;; FIXME: complicated :DESTROYED-CONSTANT-ARGS (defknown format ((or (member nil t) stream string) @@ -1284,7 +1292,7 @@ (defknown rename-file (pathname-designator filename) (values pathname pathname pathname)) -(defknown delete-file (pathname-designator) t) +(defknown delete-file (pathname-designator) (eql t)) (defknown probe-file (pathname-designator) (or pathname null) ()) (defknown file-write-date (pathname-designator) (or unsigned-byte null) ()) @@ -1303,7 +1311,7 @@ (:print t) (:if-does-not-exist t) (:external-format external-format-designator)) - t) + boolean) (defknown directory (pathname-designator &key (:resolve-symlinks t)) list ()) @@ -1424,7 +1432,8 @@ ;;;; miscellaneous extensions (defknown symbol-global-value (symbol) t ()) -(defknown set-symbol-global-value (symbol t) t ()) +(defknown set-symbol-global-value (symbol t) t () + :derive-type #'result-type-last-arg) (defknown get-bytes-consed () unsigned-byte (flushable)) (defknown mask-signed-field ((integer 0 *) integer) integer @@ -1536,14 +1545,45 @@ function (flushable foldable)) -(defknown %adjoin (t list) list (explicit-check foldable flushable)) -(defknown %adjoin-key (t list function) list (explicit-check foldable flushable call)) -(defknown %assoc (t list) list (explicit-check foldable flushable)) -(defknown %assoc-key (t list function) list (explicit-check foldable flushable call)) -(defknown %member (t list) list (explicit-check foldable flushable)) -(defknown %member-key (t list function) list (explicit-check foldable flushable call)) -(defknown %rassoc (t list) list (explicit-check foldable flushable)) -(defknown %rassoc-key (t list function) list (explicit-check foldable flushable call)) +(defknown (%adjoin %adjoin-eq %member %member-eq + %assoc %assoc-eq %rassoc %rassoc-eq) + (t list) + list + (explicit-check foldable flushable)) + +(defknown (%adjoin-key %adjoin-key-eq %member-key %member-key-eq + %assoc-key %assoc-key-eq %rassoc-key %rassoc-key-eq) + (t list function) + list + (explicit-check foldable flushable call)) + +(defknown (%assoc-if %assoc-if-not %rassoc-if %rassoc-if-not + %member-if %member-if-not) + (function list) + list + (explicit-check foldable flushable call)) + +(defknown (%assoc-if-key %assoc-if-not-key %rassoc-if-key %rassoc-if-not-key + %member-if-key %member-if-not-key) + (function list function) + list + (explicit-check foldable flushable call)) + +(defknown (%adjoin-test %adjoin-test-not + %member-test %member-test-not + %assoc-test %assoc-test-not + %rassoc-test %rassoc-test-not) + (t list function) + list + (explicit-check foldable flushable call)) + +(defknown (%adjoin-key-test %adjoin-key-test-not + %member-key-test %member-key-test-not + %assoc-key-test %assoc-key-test-not + %rassoc-key-test %rassoc-key-test-not) + (t list function function) + list + (explicit-check foldable flushable call)) (defknown %check-vector-sequence-bounds (vector index sequence-end) index @@ -1566,10 +1606,12 @@ (defknown %set-row-major-aref (array index t) t () :destroyed-constant-args (nth-constant-args 1)) (defknown (%rplaca %rplacd) (cons t) t () - :destroyed-constant-args (nth-constant-args 1)) + :destroyed-constant-args (nth-constant-args 1) + :derive-type #'result-type-last-arg) (defknown %put (symbol t t) t ()) (defknown %setelt (sequence index t) t () - :destroyed-constant-args (nth-constant-args 1)) + :destroyed-constant-args (nth-constant-args 1) + :derive-type #'result-type-last-arg) (defknown %svset (simple-vector index t) t () :destroyed-constant-args (nth-constant-args 1)) (defknown %bitset ((array bit) &rest index) bit () @@ -1582,19 +1624,22 @@ :destroyed-constant-args (nth-constant-args 1)) (defknown %set-symbol-value (symbol t) t ()) (defknown (setf symbol-function) (function symbol) function ()) -(defknown %set-symbol-plist (symbol list) list ()) +(defknown %set-symbol-plist (symbol list) list () + :derive-type #'result-type-last-arg) (defknown %setnth (unsigned-byte list t) t () - :destroyed-constant-args (nth-constant-args 2)) + :destroyed-constant-args (nth-constant-args 2) + :derive-type #'result-type-last-arg) (defknown %set-fill-pointer (complex-vector index) index (explicit-check) - :destroyed-constant-args (nth-constant-args 1)) + :destroyed-constant-args (nth-constant-args 1) + :derive-type #'result-type-last-arg) ;;;; ALIEN and call-out-to-C stuff ;; Used by WITH-PINNED-OBJECTS #!+(or x86 x86-64) (defknown sb!vm::touch-object (t) (values) - (always-translatable)) + (always-translatable)) #!+linkage-table (defknown foreign-symbol-dataref-sap (simple-string) -- 1.7.10.4