common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Add dynamic-extent declarations

Browse source 
The code in compiler-extras was used to find places to add these.

Also fix bug in defboot from prior change
This commit is contained in:
Douglas Katzman 2018-04-09 16:14:20 -04:00
parent c1a1ec4c48
commit 4bdae836d7
22 changed files with 153 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
contrib/compiler-extras.lisp
View file

@ -150,3 +150,45 @@
(length pattern))
(1+ i))))
(return))))))))
;;; Scan all functions that take funargs, looking to see whether the funarg
;;; is declared as downward (dynamic-extent) or assumed possibly upward.
;;; Print the names of functions for which the number of funargs differs
;;; from the number of DX args. (This is a way to scan for missing decls)
;;; In an ideal world, the compiler would infer that a funarg can be allocated
;;; with dynamic-extent based on it only appearing as the first argument
;;; to FUNCALL/APPLY, and not being closed over.
;;; But we don't need ideal, we just need good enough.
(flet ((fun-funargs-count (type)
(flet ((funlike-type-p (x)
(or (csubtypep x (specifier-type 'function))
(type= x (specifier-type '(or function null)))
(type= x (specifier-type '(or function symbol))))))
(+ (count-if #'funlike-type-p (fun-type-required type))
(count-if #'funlike-type-p (fun-type-optional type))
(count-if (lambda (x) (funlike-type-p (key-info-type x)))
(fun-type-keywords type))))))
(dotimes (pass 2)
(format t "~[CL symbols~;other symbols~]:~%" pass)
(let (result)
(do-all-symbols (s)
(when (if (= pass 0)
(eq (symbol-package s) (find-package "CL"))
(neq (symbol-package s) (find-package "CL")))
(let ((type (info :function :type s)))
(when (and s
(not (eq type (find-classoid 'function)))
(not (typep type 'defstruct-description))
(not (eq type :generic-function)))
(let ((n-funargs (fun-funargs-count type)))
(when (plusp n-funargs)
(let ((dxable-args
(let ((info (info :function :inlining-data s)))
(when (typep info 'dxable-args)
(dxable-args-list info)))))
(unless (= n-funargs (length dxable-args))
(push (list (length dxable-args) n-funargs s)
result)))))))))
(dolist (x (sort result #'string< :key 'third))
(format t "~{ ~d ~d ~a~}~%" x)))))

1
src/code/debug.lisp
View file

@ -272,6 +272,7 @@ is :DEBUGGER-FRAME.
specifies the currently debugged frame when inside the debugger, and
behaves as :INTERRUPTED-FRAME outside the debugger.
"
(declare (dynamic-extent function))
(loop with result = nil
for index upfrom 0
for frame = (backtrace-start-frame from)

2
src/code/defboot.lisp
View file

@ -255,7 +255,7 @@ evaluated as a PROGN."
nil))))))
`(progn
(eval-when (:compile-toplevel)
(sb!c:%compiler-defun ',name ,inline-thing ,dxable-args t))
(sb!c:%compiler-defun ',name ,inline-thing ',dxable-args t))
(%defun ',name ,named-lambda
,@(when (or inline-thing dxable-args) (list inline-thing))
,@(when dxable-args `(',dxable-args)))

1
src/code/early-extensions.lisp
View file

@ -1556,6 +1556,7 @@ Does not affect the cases that are already controlled by *PRINT-LENGTH*")
(defun call-with-sane-io-syntax (function)
(declare (type function function))
#-sb-xc-host (declare (dynamic-extent function)) ; "unable"
(macrolet ((true (sym)
`(and (boundp ',sym) ,sym)))
(let ((*print-readably* nil)

36
src/code/list.lisp
View file

@ -155,6 +155,7 @@
(defun tree-equal (x y &key (test nil testp) (test-not nil notp))
"Return T if X and Y are isomorphic trees with identical leaves."
(declare (explicit-check))
(declare (dynamic-extent test test-not))
(cond (notp
(when testp
(error ":TEST and :TEST-NOT were both supplied."))
@ -654,6 +655,7 @@
(defun subst (new old tree &key key (test #'eql testp) (test-not #'eql notp))
"Substitutes new for subtrees matching old."
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(let ((key (and key (%coerce-callable-to-fun key)))
@ -673,6 +675,7 @@
(defun subst-if (new test tree &key key)
"Substitutes new for subtrees for which test is true."
(declare (dynamic-extent test key))
(let ((test (%coerce-callable-to-fun test))
(key (and key (%coerce-callable-to-fun key))))
(labels ((s (subtree)
@ -688,6 +691,7 @@
(defun subst-if-not (new test tree &key key)
"Substitutes new for subtrees for which test is false."
(declare (dynamic-extent test key))
(let ((test (%coerce-callable-to-fun test))
(key (and key (%coerce-callable-to-fun key))))
(labels ((s (subtree)
@ -703,6 +707,7 @@
(defun nsubst (new old tree &key key (test #'eql testp) (test-not #'eql notp))
"Substitute NEW for subtrees matching OLD."
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(let ((key (and key (%coerce-callable-to-fun key)))
@ -725,6 +730,7 @@
(defun nsubst-if (new test tree &key key)
"Substitute NEW for subtrees of TREE for which TEST is true."
(declare (dynamic-extent test key))
(let ((test (%coerce-callable-to-fun test))
(key (and key (%coerce-callable-to-fun key))))
(labels ((s (subtree)
@ -743,6 +749,7 @@
(defun nsubst-if-not (new test tree &key key)
"Substitute NEW for subtrees of TREE for which TEST is false."
(declare (dynamic-extent test key))
(let ((test (%coerce-callable-to-fun test))
(key (and key (%coerce-callable-to-fun key))))
(labels ((s (subtree)
@ -761,6 +768,7 @@
(defun sublis (alist tree &key key (test #'eql testp) (test-not #'eql notp))
"Substitute from ALIST into TREE nondestructively."
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(let ((key (and key (%coerce-callable-to-fun key)))
@ -794,6 +802,7 @@
(defun nsublis (alist tree &key key (test #'eql testp) (test-not #'eql notp))
"Substitute from ALIST into TREE destructively."
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(let ((key (and key (%coerce-callable-to-fun key)))
@ -823,6 +832,7 @@
"Return the tail of LIST beginning with first element satisfying EQLity,
:TEST, or :TEST-NOT with the given ITEM."
(declare (explicit-check))
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(let ((key (and key (%coerce-callable-to-fun key)))
@ -844,6 +854,7 @@
(defun member-if (test list &key key)
"Return tail of LIST beginning with first element satisfying TEST."
(declare (explicit-check))
(declare (dynamic-extent test key))
(let ((test (%coerce-callable-to-fun test))
(key (and key (%coerce-callable-to-fun key))))
(if key
@ -853,6 +864,7 @@
(defun member-if-not (test list &key key)
"Return tail of LIST beginning with first element not satisfying TEST."
(declare (explicit-check))
(declare (dynamic-extent test key))
(let ((test (%coerce-callable-to-fun test))
(key (and key (%coerce-callable-to-fun key))))
(if key
@ -870,6 +882,7 @@
(defun adjoin (item list &key key (test #'eql testp) (test-not nil notp))
"Add ITEM to LIST unless it is already a member"
(declare (explicit-check))
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(let ((key (and key (%coerce-callable-to-fun key)))
@ -940,6 +953,7 @@
(defun union (list1 list2 &key key (test nil testp) (test-not nil notp))
"Return the union of LIST1 and LIST2."
(declare (explicit-check))
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
;; We have two possibilities here: for shortish lists we pick up the
@ -979,6 +993,7 @@
(defun nunion (list1 list2 &key key (test nil testp) (test-not nil notp))
"Destructively return the union of LIST1 and LIST2."
(declare (explicit-check))
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
;; We have two possibilities here: for shortish lists we pick up the
@ -1025,6 +1040,7 @@
&key key (test nil testp) (test-not nil notp))
"Return the intersection of LIST1 and LIST2."
(declare (explicit-check))
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(when (and list1 list2)
@ -1039,6 +1055,7 @@
&key key (test nil testp) (test-not nil notp))
"Destructively return the intersection of LIST1 and LIST2."
(declare (explicit-check))
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(when (and list1 list2)
@ -1055,6 +1072,7 @@
&key key (test nil testp) (test-not nil notp))
"Return the elements of LIST1 which are not in LIST2."
(declare (explicit-check))
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(if list2
@ -1070,6 +1088,7 @@
&key key (test nil testp) (test-not nil notp))
"Destructively return the elements of LIST1 which are not in LIST2."
(declare (explicit-check))
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(if list2
@ -1087,6 +1106,7 @@
&key key (test nil testp) (test-not nil notp))
"Return new list of elements appearing exactly once in LIST1 and LIST2."
(declare (explicit-check))
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(let ((result nil))
@ -1105,6 +1125,7 @@
"Destructively return a list with elements which appear but once in LIST1
and LIST2."
(declare (explicit-check))
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(let ((key (and key (%coerce-callable-to-fun key)))
@ -1163,6 +1184,7 @@
(defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp))
"Return T if every element in LIST1 is also in LIST2."
(declare (explicit-check))
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(with-member-test (member-test)
@ -1190,6 +1212,7 @@
"Return the cons in ALIST whose car is equal (by a given test or EQL) to
the ITEM."
(declare (explicit-check))
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(let ((key (and key (%coerce-callable-to-fun key)))
@ -1212,6 +1235,7 @@
"Return the first cons in ALIST whose CAR satisfies PREDICATE. If
KEY is supplied, apply it to the CAR of each cons before testing."
(declare (explicit-check))
(declare (dynamic-extent predicate key))
(let ((predicate (%coerce-callable-to-fun predicate))
(key (and key (%coerce-callable-to-fun key))))
(if key
@ -1222,6 +1246,7 @@
"Return the first cons in ALIST whose CAR does not satisfy PREDICATE.
If KEY is supplied, apply it to the CAR of each cons before testing."
(declare (explicit-check))
(declare (dynamic-extent predicate key))
(let ((predicate (%coerce-callable-to-fun predicate))
(key (and key (%coerce-callable-to-fun key))))
(if key
@ -1232,6 +1257,7 @@
"Return the cons in ALIST whose CDR is equal (by a given test or EQL) to
the ITEM."
(declare (explicit-check))
(declare (dynamic-extent key test test-not))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(let ((key (and key (%coerce-callable-to-fun key)))
@ -1254,6 +1280,7 @@
"Return the first cons in ALIST whose CDR satisfies PREDICATE. If KEY
is supplied, apply it to the CDR of each cons before testing."
(declare (explicit-check))
(declare (dynamic-extent predicate key))
(let ((predicate (%coerce-callable-to-fun predicate))
(key (and key (%coerce-callable-to-fun key))))
(if key
@ -1264,6 +1291,7 @@
"Return the first cons in ALIST whose CDR does not satisfy PREDICATE.
If KEY is supplied, apply it to the CDR of each cons before testing."
(declare (explicit-check))
(declare (dynamic-extent predicate key))
(let ((predicate (%coerce-callable-to-fun predicate))
(key (and key (%coerce-callable-to-fun key))))
(if key
@ -1280,6 +1308,7 @@
;;; CDRs down the arglists calling the function and accumulating
;;; results as desired.
(defun map1 (fun-designator arglists accumulate take-car)
(declare (dynamic-extent fun-designator))
(do* ((fun (%coerce-callable-to-fun fun-designator))
(non-acc-result (car arglists))
(ret-list (list nil))
@ -1321,6 +1350,7 @@
`(defun ,name (function list &rest more-lists)
,documentation
(declare (explicit-check))
(declare (dynamic-extent function))
(dx-let ((lists (list* list more-lists)))
(map1 function lists ,accumulate ,take-car))))))
(define-list-map mapc nil t "LIST")
@ -1392,8 +1422,10 @@
`(defun ,(intern (format nil "%~A~{-~A~}~@[-~A~]" name funs variant))
(x list ,@funs)
(declare (optimize speed (sb!c::verify-arg-count 0)))
,@(when funs `((declare (function ,@funs))))
,@(unless (member name '(member assoc adjoin rassoc)) `((declare (function x))))
,@(when funs `((declare (function ,@funs)
(dynamic-extent ,@funs))))
,@(unless (member name '(member assoc adjoin rassoc))
`((declare (function x) (dynamic-extent x))))
(declare (explicit-check))
,body))))
`(progn

1
src/code/maphash.lisp
View file

@ -65,6 +65,7 @@ current key. The applies to all threads, not just the current one --
even for synchronized hash-tables. If the table may be mutated by
another thread during iteration, use eg. SB-EXT:WITH-LOCKED-HASH-TABLE
to protect the MAPHASH call."
(declare (dynamic-extent function-designator))
(maphash function-designator hash-table)) ; via compiler-macro
(defmacro with-hash-table-iterator ((name hash-table) &body body)

1
src/code/print.lisp
View file

@ -61,6 +61,7 @@ variable: an unreadable object representing the error is printed instead.")
(defun %with-standard-io-syntax (function)
(declare (type function function))
(declare (dynamic-extent function))
(let ((*package* (load-time-value (find-package "COMMON-LISP-USER") t))
(*print-array* t)
(*print-base* 10)

1
src/code/quantifiers.lisp
View file

@ -68,6 +68,7 @@
#-sb-xc-host ; don't redefine CL builtins!
(defun ,name (pred first-seq &rest more-seqs)
,doc
(declare (dynamic-extent pred))
(flet ((map-me (&rest rest)
(let ((value (apply pred rest)))
(,found-test value

5
src/code/room.lisp
View file

@ -314,6 +314,7 @@
;;; as FIXNUMs (unlike SAPs or tagged addresses, these will not cons).
(defun map-objects-in-range (fun start end &optional (strict-bound t))
(declare (type function fun))
(declare (dynamic-extent fun))
(named-let iter ((start start))
(cond
((< (get-lisp-obj-address start) (get-lisp-obj-address end))
@ -383,6 +384,7 @@
(declaim (ftype (sfunction (function &rest immobile-subspaces) null)
map-immobile-objects))
(defun map-immobile-objects (function &rest subspaces) ; Perform no filtering
(declare (dynamic-extent function))
(do-rest-arg ((subspace) subspaces)
(multiple-value-bind (start end) (%space-bounds subspace)
(map-objects-in-range function start end)))))
@ -434,6 +436,7 @@ We could try a few things to mitigate this:
(declare (type function fun)
;; KLUDGE: rest-arg and self calls do not play nice and it'll get consed
(optimize (sb-c::recognize-self-calls 0)))
(declare (dynamic-extent fun))
(when (and (= (length spaces) 1) (eq (first spaces) :all))
(return-from map-allocated-objects
(map-allocated-objects fun
@ -879,6 +882,7 @@ We could try a few things to mitigate this:
(declare (type spaces space)
(type (or index null) larger smaller type count)
(type (or function null) test))
(declare (dynamic-extent test))
(unless *ignore-after*
(setq *ignore-after* (cons 1 2)))
(collect ((counted 0 1+))
@ -905,6 +909,7 @@ We could try a few things to mitigate this:
;;; because we know that there's a stack reference.
(defun map-stack-references (function)
(declare (type function function))
(declare (dynamic-extent function))
(macrolet ((iter (step limit test)
`(do ((sp (current-sp) (sap+ sp (,step n-word-bytes)))
(limit (sb-di::descriptor-sap ,limit))

31
src/code/seq.lisp
View file

@ -86,12 +86,17 @@
(multiple-value-bind (body declarations docstring) (parse-body body t)
(collect ((new-args)
(new-declarations)
;; Things which are functions
(funargs)
;; Things which are definitely used in any code path.
(rebindings/eager)
;; Things which may be used/are only used in certain
;; code paths (e.g. length).
(rebindings/lazy))
(dolist (arg args)
(let ((sym (if (listp arg) (car arg) arg)))
(when (member sym '(function predicate key test test-not))
(funargs sym)))
(case arg
;; FIXME: make this robust. And clean.
((sequence sequence1 sequence2)
@ -120,6 +125,8 @@
`(defun ,name ,(new-args)
,@(when docstring (list docstring))
,@declarations
;; All sequence traversers' funargs are downward funargs
(declare (dynamic-extent ,@(funargs)))
(symbol-macrolet (,@(rebindings/lazy))
(let* (,@(rebindings/eager))
(declare ,@(new-declarations))
@ -1146,6 +1153,7 @@ many elements are copied."
;;; helper functions to handle arity-1 subcases of MAP
(defun %map-to-list-arity-1 (fun sequence)
(declare (explicit-check))
(declare (dynamic-extent fun))
(let ((reversed-result nil)
(really-fun (%coerce-callable-to-fun fun)))
(sb!sequence:dosequence (element sequence)
@ -1154,6 +1162,7 @@ many elements are copied."
(nreverse reversed-result)))
(defun %map-to-simple-vector-arity-1 (fun sequence)
(declare (explicit-check))
(declare (dynamic-extent fun))
(let ((result (make-array (length sequence)))
(index 0)
(really-fun (%coerce-callable-to-fun fun)))
@ -1165,6 +1174,7 @@ many elements are copied."
result))
(defun %map-for-effect-arity-1 (fun sequence)
(declare (explicit-check))
(declare (dynamic-extent fun))
(let ((really-fun (%coerce-callable-to-fun fun)))
(sb!sequence:dosequence (element sequence)
(funcall really-fun element)))
@ -1173,6 +1183,7 @@ many elements are copied."
(declaim (maybe-inline %map-for-effect))
(defun %map-for-effect (fun sequences)
(declare (type function fun) (type list sequences))
(declare (dynamic-extent fun))
(let ((%sequences sequences)
(%iters (mapcar (lambda (s)
(seq-dispatch s
@ -1222,6 +1233,7 @@ many elements are copied."
(defun %map-to-list (fun sequences)
(declare (type function fun)
(type list sequences))
(declare (dynamic-extent fun))
(let ((result nil))
(flet ((f (&rest args)
(declare (truly-dynamic-extent args))
@ -1232,6 +1244,7 @@ many elements are copied."
(defun %map-to-vector (output-type-spec fun sequences)
(declare (type function fun)
(type list sequences))
(declare (dynamic-extent fun))
(let ((min-len 0))
(flet ((f (&rest args)
(declare (truly-dynamic-extent args))
@ -1255,7 +1268,7 @@ many elements are copied."
;;; in RESULT-TYPE.
(defun %map (result-type function &rest sequences)
(declare (explicit-check))
(declare (dynamic-extent sequences))
(declare (dynamic-extent function sequences))
;; Everything that we end up calling uses %COERCE-TO-CALLABLE
;; on FUNCTION so we don't need to declare it of type CALLABLE here.
;; Additionally all the arity-1 mappers use SEQ-DISPATCH which asserts
@ -1306,6 +1319,7 @@ many elements are copied."
(defun map (result-type function first-sequence &rest more-sequences)
(declare (explicit-check))
(declare (dynamic-extent function))
(let ((result
(apply #'%map result-type function first-sequence more-sequences)))
(if (or (eq result-type 'nil) (typep result result-type))
@ -1333,6 +1347,7 @@ many elements are copied."
(type function fun)
(type list sequences))
(declare (explicit-check))
(declare (dynamic-extent fun))
(let ((index start))
(declare (type index index))
(block mapping
@ -1359,6 +1374,7 @@ many elements are copied."
;;; sequences.
(defun map-into (result-sequence function &rest sequences)
(declare (optimize (sb!c::check-tag-existence 0)))
(declare (dynamic-extent function))
(let ((really-fun (%coerce-callable-to-fun function)))
(etypecase result-sequence
(vector
@ -2377,6 +2393,7 @@ many elements are copied."
(declare (type fixnum start end count)
(type (or null function) key)
(type function test)) ; coercion is done by caller
(declare (dynamic-extent test key))
(do ((list (nthcdr start sequence) (cdr list))
(index start (1+ index)))
((or (= index end) (null list) (= count 0)) sequence)
@ -2391,6 +2408,7 @@ many elements are copied."
(type (integer -1 1) incrementer)
(type (or null function) key)
(type function test)) ; coercion is done by caller
(declare (dynamic-extent test key))
(let* ((tag (%other-pointer-widetag sequence))
(getter (the function (svref %%data-vector-reffers%% tag)))
(setter (the function (svref %%data-vector-setters%% tag))))
@ -2431,6 +2449,7 @@ many elements are copied."
(declare (type fixnum start end count)
(type (or null function) key)
(type function test)) ; coercion is done by caller
(declare (dynamic-extent test key))
(do ((list (nthcdr start sequence) (cdr list))
(index start (1+ index)))
((or (= index end) (null list) (= count 0)) sequence)
@ -2445,6 +2464,7 @@ many elements are copied."
(type (integer -1 1) incrementer)
(type (or null function) key)
(type function test)) ; coercion is done by caller
(declare (dynamic-extent test key))
(let* ((tag (%other-pointer-widetag sequence))
(getter (the function (svref %%data-vector-reffers%% tag)))
(setter (the function (svref %%data-vector-setters%% tag))))
@ -2502,6 +2522,7 @@ many elements are copied."
)))
(defun %find-position (item sequence-arg from-end start end key test)
(declare (explicit-check sequence-arg))
(declare (dynamic-extent test key))
(macrolet ((frob (sequence from-end)
`(%find-position item ,sequence
,from-end start end key test))
@ -2511,6 +2532,7 @@ many elements are copied."
(frobs t)))
(defun %find-position-if (predicate sequence-arg from-end start end key)
(declare (explicit-check sequence-arg))
(declare (dynamic-extent predicate key))
(macrolet ((frob (sequence from-end)
`(%find-position-if predicate ,sequence
,from-end start end key))
@ -2520,6 +2542,7 @@ many elements are copied."
(frobs)))
(defun %find-position-if-not (predicate sequence-arg from-end start end key)
(declare (explicit-check sequence-arg))
(declare (dynamic-extent predicate key))
(macrolet ((frob (sequence from-end)
`(%find-position-if-not predicate ,sequence
,from-end start end key))
@ -2531,6 +2554,7 @@ many elements are copied."
(defun find
(item sequence &rest args &key from-end (start 0) end key test test-not)
(declare (truly-dynamic-extent args))
(declare (dynamic-extent key test test-not))
(declare (explicit-check sequence))
(seq-dispatch-checking sequence
(nth-value 0 (%find-position
@ -2545,6 +2569,7 @@ many elements are copied."
(defun position
(item sequence &rest args &key from-end (start 0) end key test test-not)
(declare (truly-dynamic-extent args))
(declare (dynamic-extent key test test-not))
(declare (explicit-check sequence))
(seq-dispatch-checking sequence
(nth-value 1 (%find-position
@ -2560,6 +2585,7 @@ many elements are copied."
(defun find-if (predicate sequence &rest args &key from-end (start 0) end key)
(declare (truly-dynamic-extent args))
(declare (explicit-check sequence))
(declare (dynamic-extent predicate key))
(seq-dispatch-checking sequence
(nth-value 0 (%find-position-if
(%coerce-callable-to-fun predicate)
@ -2574,6 +2600,7 @@ many elements are copied."
(predicate sequence &rest args &key from-end (start 0) end key)
(declare (truly-dynamic-extent args))
(declare (explicit-check sequence))
(declare (dynamic-extent predicate key))
(seq-dispatch-checking sequence
(nth-value 1 (%find-position-if
(%coerce-callable-to-fun predicate)
@ -2589,6 +2616,7 @@ many elements are copied."
(predicate sequence &rest args &key from-end (start 0) end key)
(declare (truly-dynamic-extent args))
(declare (explicit-check sequence))
(declare (dynamic-extent predicate key))
(seq-dispatch-checking sequence
(nth-value 0 (%find-position-if-not
(%coerce-callable-to-fun predicate)
@ -2603,6 +2631,7 @@ many elements are copied."
(predicate sequence &rest args &key from-end (start 0) end key)
(declare (truly-dynamic-extent args))
(declare (explicit-check sequence))
(declare (dynamic-extent predicate key))
(seq-dispatch-checking sequence
(nth-value 1 (%find-position-if-not
(%coerce-callable-to-fun predicate)

8
src/code/sort.lisp
View file

@ -12,6 +12,7 @@
(in-package "SB!IMPL")
(defun sort-vector (vector start end predicate-fun key-fun-or-nil)
(declare (dynamic-extent predicate-fun key-fun-or-nil))
(sort-vector vector start end predicate-fun key-fun-or-nil))
;;; This is MAYBE-INLINE because it's not too hard to have an
@ -23,6 +24,7 @@
"Destructively sort SEQUENCE. PREDICATE should return non-NIL if
ARG1 is to precede ARG2."
(declare (truly-dynamic-extent args))
(declare (dynamic-extent predicate key))
(let ((predicate-fun (%coerce-callable-to-fun predicate)))
(seq-dispatch sequence
(stable-sort-list sequence
@ -42,6 +44,7 @@
"Destructively sort SEQUENCE. PREDICATE should return non-NIL if
ARG1 is to precede ARG2."
(declare (truly-dynamic-extent args))
(declare (dynamic-extent predicate key))
(let ((predicate-fun (%coerce-callable-to-fun predicate)))
(seq-dispatch sequence
(stable-sort-list sequence
@ -79,6 +82,7 @@
(declare (type cons head list1 list2)
(type function test key)
(optimize speed))
(declare (dynamic-extent test key))
(let ((key1 (funcall key (car list1)))
(key2 (funcall key (car list2))))
(macrolet ((merge-one (l1 k1 l2)
@ -162,6 +166,7 @@
(type function test key)
(dynamic-extent head))
(declare (explicit-check))
(declare (dynamic-extent test key))
(labels ((merge* (size list1 tail1 list2 tail2 rest)
(declare (optimize speed)
(type (and fixnum unsigned-byte) size)
@ -319,12 +324,14 @@
(type function pred)
(type (or null function) key))
(declare (explicit-check))
(declare (dynamic-extent pred key))
(vector-merge-sort vector pred key svref))
(defun stable-sort-vector (vector pred key)
(declare (type function pred)
(type (or null function) key))
(declare (explicit-check))
(declare (dynamic-extent pred key))
(vector-merge-sort vector pred key aref))
;;;; merging
@ -379,6 +386,7 @@
;; full calls to SPECIFIER-TYPE at runtime; copying input vectors
;; to lists before doing MERGE-LISTS -- WHN 2003-01-05
(declare (explicit-check))
(declare (dynamic-extent predicate key))
(let ((type (specifier-type result-type))
(pred-fun (%coerce-callable-to-fun predicate))
;; Avoid coercing NIL to a function since 2 out of 3 branches of the

2
src/code/target-thread.lisp
View file

@ -554,6 +554,7 @@ HOLDING-MUTEX-P."
(defun %%wait-for (test stop-sec stop-usec)
(declare (function test))
(declare (dynamic-extent test))
(labels ((try ()
(declare (optimize (safety 0)))
(awhen (funcall test)
@ -611,6 +612,7 @@ HOLDING-MUTEX-P."
(defun %wait-for (test timeout)
(declare (function test))
(declare (dynamic-extent test))
(tagbody
:restart
(multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)

4
src/code/thread.lisp
View file

@ -165,6 +165,7 @@ held mutex, WITH-RECURSIVE-LOCK allows recursive lock attempts to succeed."
`(defun ,(if variant (symbolicate name "/" variant) name)
(function mutex)
(declare (function function))
(declare (dynamic-extent function))
(flet ((%call-with-system-mutex ()
(dx-let (got-it)
(unwind-protect
@ -217,6 +218,7 @@ held mutex, WITH-RECURSIVE-LOCK allows recursive lock attempts to succeed."
(progn
(defun call-with-mutex (function mutex value waitp timeout)
(declare (function function))
(declare (dynamic-extent function))
(unless (or (null value) (eq *current-thread* value))
(error "~S called with non-nil :VALUE that isn't the current thread."
'with-mutex))
@ -232,6 +234,7 @@ held mutex, WITH-RECURSIVE-LOCK allows recursive lock attempts to succeed."
(defun call-with-recursive-lock (function mutex waitp timeout)
(declare (function function))
(declare (dynamic-extent function))
(dx-let ((inner-lock-p (eq (mutex-%owner mutex) *current-thread*))
(got-it nil))
(without-interrupts
@ -247,6 +250,7 @@ held mutex, WITH-RECURSIVE-LOCK allows recursive lock attempts to succeed."
`(defun ,(if variant (symbolicate name "/" variant) name)
(function lock)
(declare (function function))
(declare (dynamic-extent function))
(flet ((%call-with-recursive-system-lock ()
(dx-let ((inner-lock-p
(eq *current-thread* (mutex-owner lock)))

1
src/code/time.lisp
View file

@ -423,6 +423,7 @@ returns values returned by FUNCTION.
NIL.)
EXPERIMENTAL: Interface subject to change."
(declare (dynamic-extent timer function))
(let (old-run-utime
new-run-utime
old-run-stime

1
src/code/toplevel.lisp
View file

@ -547,6 +547,7 @@ that provides the REPL for the system. Assumes that *STANDARD-INPUT* and
(defun %with-rebound-io-syntax (function)
(declare (type function function))
(declare (dynamic-extent function))
(let ((*package* *package*)
(*print-array* *print-array*)
(*print-base* *print-base*)

1
src/code/xset.lisp
View file

@ -39,6 +39,7 @@
(defun map-xset (function xset)
(declare (function function))
#-sb-xc-host (declare (dynamic-extent function)) ; Avoid "unable" in host
(let ((data (xset-data xset)))
(if (listp data)
(dolist (elt data)

7
src/compiler/ir1util.lisp
View file

@ -687,6 +687,12 @@
(unless (or
;; Don't complain about not being able to stack allocate constants.
(and (ref-p use) (constant-p (ref-leaf use)))
;; Don't complain if the object is "essentially" a constant
;; in the form of a global function reference.
(and (ref-p use)
(let ((var (ref-leaf use)))
(and (global-var-p var)
(eq (global-var-kind var) :global-function))))
;; If we're flushing, don't complain if we can flush the combination.
(and flush (combination-p use) (flushable-combination-p use))
;; Don't report those with homes in :OPTIONAL -- we'd get doubled
@ -2175,6 +2181,7 @@ is :ANY, the function name is not checked."
;;; whether to substitute
(defun substitute-leaf-if (test new-leaf old-leaf)
(declare (type leaf new-leaf old-leaf) (type function test))
#-sb-xc-host (declare (dynamic-extent test)) ; "unable"
(dolist (ref (leaf-refs old-leaf))
(when (funcall test ref)
(change-ref-leaf ref new-leaf)))

2
src/compiler/macros.lisp
View file

@ -756,6 +756,7 @@
(key #'identity)
(test #'eql))
(declare (type function next key test))
;; #-sb-xc-host (declare (dynamic-extent next key test)) ; emits "unable" note
(do ((current list (funcall next current)))
((null current) nil)
(when (funcall test (funcall key current) element)
@ -771,6 +772,7 @@
(key #'identity)
(test #'eql))
(declare (type function next key test))
;; #-sb-xc-host (declare (dynamic-extent next key test)) ; emits "unable" note
(do ((current list (funcall next current))
(i 0 (1+ i)))
((null current) nil)

2
src/compiler/main.lisp
View file

@ -191,6 +191,7 @@ Examples:
(defun %with-compilation-unit (fn &key override policy source-plist source-namestring)
(declare (type function fn))
(declare (dynamic-extent fn))
(flet ((with-it ()
(let ((succeeded-p nil)
(*source-plist* (append source-plist *source-plist*))
@ -903,6 +904,7 @@ necessary, since type inference may take arbitrarily long to converge.")
;; a subtype of not-so-aptly-named INPUT-ERROR-IN-COMPILE-FILE.
(defun %do-forms-from-info (function info condition-name)
(declare (function function))
#-sb-xc-host (declare (dynamic-extent function)) ; avoid "unable" note
(let* ((file-info (source-info-file-info info))
(stream (get-source-stream info))
(pos (file-position stream))

1
src/compiler/node.lisp
View file

@ -183,6 +183,7 @@
(defun %with-ir1-environment-from-node (node fun)
(declare (type node node) (type function fun))
#-sb-xc-host (declare (dynamic-extent fun)) ; "unable"
(let ((*current-component* (node-component node))
(*lexenv* (node-lexenv node))
(*current-path* (node-source-path node)))

1
src/compiler/target-disassem.lisp
View file

@ -540,6 +540,7 @@
(type segment segment)
(type disassem-state dstate)
(type (or null stream) stream))
(declare (dynamic-extent function))
(let ((ispace (get-inst-space))
(prefix-p nil) ; just processed a prefix inst

6
tests/dynamic-extent.impure.lisp
View file

@ -1405,3 +1405,9 @@
(assert (equal (fun-name-dx-args 'sortasort) '(1)))
;; And also an inline expansion
(assert (sb-c::fun-name-inline-expansion 'sortasort)))
(with-test (:name :store-dx-arglist-std-functions)
;; You might think this would go in the SB-C::FUN-INFO,
;; but we want user-defined functions to have this bit of info
;; as well, potentially.
(assert (equal (fun-name-dx-args 'remove) '(:test :test-not :key)))
(assert (equal (fun-name-dx-args 'remove-if) '(0 :key))))