hexstr / cold-print fixes from Douglas Katzman

[sbcl.git] / src / compiler / fndb.lisp

diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index ac471cf..bb39bc4 100644 (file)
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -76,6 +76,11 @@
 
 (defknown (eq eql) (t t) boolean (movable foldable flushable))
 (defknown (equal equalp) (t t) boolean (foldable flushable recursive))
 
 (defknown (eq eql) (t t) boolean (movable foldable flushable))
 (defknown (equal equalp) (t t) boolean (foldable flushable recursive))

+
+#!+(or x86 x86-64)
+(defknown fixnum-mod-p (t fixnum) boolean
+    (movable foldable flushable always-translatable))
+

 \f
 ;;;; classes
 
 \f
 ;;;; classes
 

@@ -86,7 +91,7 @@
 (defknown classoid-of (t) classoid (flushable))
 (defknown layout-of (t) layout (flushable))
 (defknown copy-structure (structure-object) structure-object
 (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

 \f
 ;;;; from the "Control Structure" chapter:
 
 \f
 ;;;; from the "Control Structure" chapter:
 

@@ -110,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
   :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)
 (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) *)
 
 (defknown apply (callable t &rest t) *) ; ### Last arg must be List...
 (defknown funcall (callable &rest t) *)
 

@@ -367,6 +376,10 @@
 (defknown logbitp (unsigned-byte integer) boolean (movable foldable flushable))
 (defknown ash (integer integer) integer
   (movable foldable flushable explicit-check))
 (defknown logbitp (unsigned-byte integer) boolean (movable foldable flushable))
 (defknown ash (integer integer) integer
   (movable foldable flushable explicit-check))

+#!+ash-right-vops
+(defknown %ash/right ((or word sb!vm:signed-word) (mod #.sb!vm:n-word-bits))
+    (or word sb!vm:signed-word)
+    (movable foldable flushable always-translatable))

 (defknown (logcount integer-length) (integer) bit-index
   (movable foldable flushable explicit-check))
 ;;; FIXME: According to the ANSI spec, it's legal to use any
 (defknown (logcount integer-length) (integer) bit-index
   (movable foldable flushable explicit-check))
 ;;; FIXME: According to the ANSI spec, it's legal to use any

@@ -409,6 +422,18 @@
                  char-lessp char-greaterp char-not-greaterp char-not-lessp)
   (character &rest character) boolean (movable foldable flushable))
 
                  char-lessp char-greaterp char-not-greaterp char-not-lessp)
   (character &rest character) boolean (movable foldable flushable))
 

+(defknown (two-arg-char-equal
+           two-arg-char-not-equal
+           two-arg-char-lessp
+           two-arg-char-not-lessp
+           two-arg-char-greaterp
+           two-arg-char-not-greaterp)
+    (character character) boolean (movable foldable flushable))
+
+(defknown char-equal-constant (character character character)
+  boolean
+  (movable foldable flushable explicit-check))
+

 (defknown character (t) character (movable foldable unsafely-flushable))
 (defknown char-code (character) char-code (movable foldable flushable))
 (defknown (char-upcase char-downcase) (character) character
 (defknown character (t) character (movable foldable unsafely-flushable))
 (defknown char-code (character) char-code (movable foldable flushable))
 (defknown (char-upcase char-downcase) (character) character

@@ -469,10 +494,6 @@
 (defknown %map-to-list-arity-1 (callable sequence) list (flushable call))
 (defknown %map-to-simple-vector-arity-1 (callable sequence) simple-vector
   (flushable call))
 (defknown %map-to-list-arity-1 (callable sequence) list (flushable call))
 (defknown %map-to-simple-vector-arity-1 (callable sequence) simple-vector
   (flushable call))

-(defknown %map-to-nil-on-simple-vector (callable simple-vector) null
-  (flushable call))
-(defknown %map-to-nil-on-vector (callable vector) null (flushable call))
-(defknown %map-to-nil-on-sequence (callable sequence) null (flushable call))

 
 (defknown map-into (sequence callable &rest sequence)
   sequence
 
 (defknown map-into (sequence callable &rest sequence)
   sequence

@@ -649,7 +670,6 @@
   :derive-type (creation-result-type-specifier-nth-arg 1)
   :destroyed-constant-args (nth-constant-nonempty-sequence-args 2 3))
 
   :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)
 (defknown read-sequence (sequence stream
                                   &key
                                   (:start index)

@@ -663,7 +683,7 @@
                                    (:end sequence-end))
   sequence
   ()
                                    (:end sequence-end))
   sequence
   ()

-  :derive-type (sequence-result-nth-arg 1))
+  :derive-type #'result-type-first-arg)

 \f
 ;;;; from the "Manipulating List Structure" chapter:
 (defknown (car cdr first rest)
 \f
 ;;;; from the "Manipulating List Structure" chapter:
 (defknown (car cdr first rest)

@@ -703,9 +723,19 @@
 (defknown make-list (index &key (:initial-element t)) list
   (movable flushable))
 
 (defknown make-list (index &key (:initial-element t)) list
   (movable flushable))
 

+(defknown sb!impl::backq-list (&rest t) list (movable flushable))
+(defknown sb!impl::backq-list* (t &rest t) t (movable flushable))
+(defknown sb!impl::backq-append (&rest t) t (flushable))
+(defknown sb!impl::backq-nconc (&rest t) t ()
+  :destroyed-constant-args (remove-non-constants-and-nils #'butlast))
+(defknown sb!impl::backq-cons (t t) cons (foldable movable flushable))
+(defknown sb!impl::backq-vector (list) simple-vector
+    (foldable movable flushable))
+

 ;;; 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))
 ;;; 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))
 
 (defknown copy-list (list) list (flushable))
 (defknown copy-alist (list) list (flushable))

@@ -727,7 +757,7 @@
   :destroyed-constant-args (nth-constant-nonempty-sequence-args 1))
 
 (defknown ldiff (list t) list (flushable))
   :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)
   :destroyed-constant-args (nth-constant-args 1))
 
 (defknown subst (t t t &key (:key callable) (:test callable)

@@ -764,7 +794,7 @@
 
 (defknown adjoin (t list &key (:key callable) (:test callable)
                     (:test-not callable))
 
 (defknown adjoin (t list &key (:key callable) (:test callable)
                     (:test-not callable))

-  list (foldable flushable call))
+  cons (flushable call))

 
 (defknown (union intersection set-difference set-exclusive-or)
   (list list &key (:key callable) (:test callable) (:test-not callable))
 
 (defknown (union intersection set-difference set-exclusive-or)
   (list list &key (:key callable) (:test callable) (:test-not callable))

@@ -782,7 +812,7 @@
   boolean
   (foldable flushable call))
 
   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)
 (defknown pairlis (t t &optional t) list (flushable))
 
 (defknown (rassoc assoc)

@@ -814,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 ()
 (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))
 (defknown remhash (t hash-table) boolean ()
   :destroyed-constant-args (nth-constant-args 2))
 (defknown maphash (callable hash-table) null (flushable call))

@@ -829,6 +860,7 @@
 (defknown hash-table-test (hash-table) symbol (foldable flushable))
 (defknown sxhash (t) hash (#-sb-xc-host foldable flushable))
 (defknown psxhash (t &optional t) hash (#-sb-xc-host foldable flushable))
 (defknown hash-table-test (hash-table) symbol (foldable flushable))
 (defknown sxhash (t) hash (#-sb-xc-host foldable flushable))
 (defknown psxhash (t &optional t) hash (#-sb-xc-host foldable flushable))

+(defknown hash-table-equalp (hash-table hash-table) boolean (foldable flushable))

 \f
 ;;;; from the "Arrays" chapter
 
 \f
 ;;;; from the "Arrays" chapter
 

@@ -1100,7 +1132,8 @@
      (:lines (or unsigned-byte null))
      (:right-margin (or unsigned-byte null))
      (:miser-width (or unsigned-byte null))
      (:lines (or unsigned-byte null))
      (:right-margin (or unsigned-byte null))
      (:miser-width (or unsigned-byte null))

-     (:pprint-dispatch t))
+     (:pprint-dispatch t)
+     (:suppress-errors t))

   t
   (any explicit-check)
   :derive-type #'result-type-first-arg)
   t
   (any explicit-check)
   :derive-type #'result-type-first-arg)

@@ -1125,11 +1158,14 @@
 (defknown (prin1-to-string princ-to-string) (t) simple-string (flushable))
 
 (defknown write-char (character &optional stream-designator) character
 (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
 (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
 
 (defknown (terpri finish-output force-output clear-output)
   (&optional stream-designator) null

@@ -1139,7 +1175,8 @@
   (explicit-check))
 
 (defknown write-byte (integer stream) integer
   (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)
 
 ;;; FIXME: complicated :DESTROYED-CONSTANT-ARGS
 (defknown format ((or (member nil t) stream string)

@@ -1230,6 +1267,8 @@
 (defknown pathname-version (pathname-designator)
   pathname-version (flushable))
 
 (defknown pathname-version (pathname-designator)
   pathname-version (flushable))
 

+(defknown pathname= (pathname pathname) boolean (movable foldable flushable))
+

 (defknown (namestring file-namestring directory-namestring host-namestring)
   (pathname-designator) (or simple-string null)
   (unsafely-flushable))
 (defknown (namestring file-namestring directory-namestring host-namestring)
   (pathname-designator) (or simple-string null)
   (unsafely-flushable))

@@ -1253,7 +1292,7 @@
 
 (defknown rename-file (pathname-designator filename)
   (values pathname pathname pathname))
 
 (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)
   ())
 (defknown probe-file (pathname-designator) (or pathname null) ())
 (defknown file-write-date (pathname-designator) (or unsigned-byte null)
   ())

@@ -1272,7 +1311,7 @@
    (:print t)
    (:if-does-not-exist t)
    (:external-format external-format-designator))
    (:print t)
    (:if-does-not-exist t)
    (:external-format external-format-designator))

-  t)
+  boolean)

 
 (defknown directory (pathname-designator &key (:resolve-symlinks t))
   list ())
 
 (defknown directory (pathname-designator &key (:resolve-symlinks t))
   list ())

@@ -1367,7 +1406,7 @@
 (defknown (get-internal-run-time get-internal-real-time)
   () internal-time (flushable))
 
 (defknown (get-internal-run-time get-internal-real-time)
   () internal-time (flushable))
 

-(defknown sleep ((or (rational 0) (float 0.0))) null)
+(defknown sleep ((real 0)) null (explicit-check))

 
 ;;; Even though ANSI defines LISP-IMPLEMENTATION-TYPE and
 ;;; LISP-IMPLEMENTATION-VERSION to possibly punt and return NIL, we
 
 ;;; Even though ANSI defines LISP-IMPLEMENTATION-TYPE and
 ;;; LISP-IMPLEMENTATION-VERSION to possibly punt and return NIL, we

@@ -1393,7 +1432,8 @@
 ;;;; miscellaneous extensions
 
 (defknown symbol-global-value (symbol) t ())
 ;;;; 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
 
 (defknown get-bytes-consed () unsigned-byte (flushable))
 (defknown mask-signed-field ((integer 0 *) integer) integer

@@ -1404,7 +1444,11 @@
 \f
 ;;;; magical compiler frobs
 
 \f
 ;;;; magical compiler frobs
 

-(defknown %values-list-or-context (t t t) * (always-translatable))
+(defknown %rest-values (t t t) * (always-translatable))
+(defknown %rest-ref (t t t t) * (always-translatable))
+(defknown %rest-length (t t t) * (always-translatable))
+(defknown %rest-null (t t t t) * (always-translatable))
+(defknown %rest-true (t t t) * (always-translatable))

 
 (defknown %unary-truncate/single-float (single-float) integer (movable foldable flushable))
 (defknown %unary-truncate/double-float (double-float) integer (movable foldable flushable))
 
 (defknown %unary-truncate/single-float (single-float) integer (movable foldable flushable))
 (defknown %unary-truncate/double-float (double-float) integer (movable foldable flushable))

@@ -1458,12 +1502,12 @@
 (defknown %check-bound (array index fixnum) index
   (movable foldable flushable dx-safe))
 (defknown data-vector-ref (simple-array index) t
 (defknown %check-bound (array index fixnum) index
   (movable foldable flushable dx-safe))
 (defknown data-vector-ref (simple-array index) t

-  (foldable explicit-check always-translatable))
-(defknown data-vector-ref-with-offset (simple-array index fixnum) t
-  (foldable explicit-check always-translatable))
+  (foldable unsafely-flushable explicit-check always-translatable))
+(defknown data-vector-ref-with-offset (simple-array fixnum fixnum) t
+  (foldable unsafely-flushable explicit-check always-translatable))

 (defknown data-vector-set (array index t) t
   (explicit-check always-translatable))
 (defknown data-vector-set (array index t) t
   (explicit-check always-translatable))

-(defknown data-vector-set-with-offset (array index fixnum t) t
+(defknown data-vector-set-with-offset (array fixnum fixnum t) t

   (explicit-check always-translatable))
 (defknown hairy-data-vector-ref (array index) t
   (foldable explicit-check))
   (explicit-check always-translatable))
 (defknown hairy-data-vector-ref (array index) t
   (foldable explicit-check))

@@ -1501,14 +1545,63 @@
   function
   (flushable foldable))
 
   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)
+    (t list)
+    list
+    (explicit-check flushable))
+
+(defknown (%member %member-eq
+           %assoc %assoc-eq %rassoc %rassoc-eq)
+    (t list)
+    list
+    (explicit-check foldable flushable))
+
+(defknown (%adjoin-key %adjoin-key-eq)
+    (t list function)
+    list
+    (explicit-check flushable call))
+
+(defknown (%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)
+    (t list function)
+    list
+    (explicit-check flushable call))
+
+(defknown (%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)
+    (t list function function)
+    list
+    (explicit-check flushable call))
+
+(defknown (%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
 
 (defknown %check-vector-sequence-bounds (vector index sequence-end)
   index

@@ -1531,10 +1624,12 @@
 (defknown %set-row-major-aref (array index t) t ()
   :destroyed-constant-args (nth-constant-args 1))
 (defknown (%rplaca %rplacd) (cons t) t ()
 (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 ()
 (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 ()
 (defknown %svset (simple-vector index t) t ()
   :destroyed-constant-args (nth-constant-args 1))
 (defknown %bitset ((array bit) &rest index) bit ()

@@ -1547,19 +1642,22 @@
   :destroyed-constant-args (nth-constant-args 1))
 (defknown %set-symbol-value (symbol t) t ())
 (defknown (setf symbol-function) (function symbol) function ())
   :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 ()
 (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)
 (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)

 \f
 ;;;; ALIEN and call-out-to-C stuff
 
 ;; Used by WITH-PINNED-OBJECTS
 #!+(or x86 x86-64)
 (defknown sb!vm::touch-object (t) (values)
 \f
 ;;;; 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)
 
 #!+linkage-table
 (defknown foreign-symbol-dataref-sap (simple-string)

@@ -1605,6 +1703,12 @@
 (defknown sb!vm:%write-barrier () (values) ())
 (defknown sb!vm:%data-dependency-barrier () (values) ())
 
 (defknown sb!vm:%write-barrier () (values) ())
 (defknown sb!vm:%data-dependency-barrier () (values) ())
 

+#!+sb-safepoint
+;;; Note: This known function does not have an out-of-line definition;
+;;; and if such a definition were needed, it would not need to "call"
+;;; itself inline, but could be a no-op, because the compiler inserts a
+;;; use of the VOP in the function prologue anyway.
+(defknown sb!kernel::gc-safepoint () (values) ())

 
 ;;;; atomic ops
 (defknown %compare-and-swap-svref (simple-vector index t t) t
 
 ;;;; atomic ops
 (defknown %compare-and-swap-svref (simple-vector index t t) t