diff --git a/contrib/compiler-extras.lisp b/contrib/compiler-extras.lisp index 140b563da..3d2a84a59 100644 --- a/contrib/compiler-extras.lisp +++ b/contrib/compiler-extras.lisp @@ -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))))) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index c94a7c511..559b0bfd0 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -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) diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index b153c8e85..cb2520ba2 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -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))) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 84a6a41ed..6e00c42f2 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -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) diff --git a/src/code/list.lisp b/src/code/list.lisp index c6d693198..19259581f 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -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 diff --git a/src/code/maphash.lisp b/src/code/maphash.lisp index c115c2a1b..e661c9e12 100644 --- a/src/code/maphash.lisp +++ b/src/code/maphash.lisp @@ -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) diff --git a/src/code/print.lisp b/src/code/print.lisp index e28ee28a7..924f2ff55 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -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) diff --git a/src/code/quantifiers.lisp b/src/code/quantifiers.lisp index 0d4b06242..098b4c27d 100644 --- a/src/code/quantifiers.lisp +++ b/src/code/quantifiers.lisp @@ -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 diff --git a/src/code/room.lisp b/src/code/room.lisp index 418f48be1..7afa65cc3 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -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)) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 53fefa206..c4019256f 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -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) diff --git a/src/code/sort.lisp b/src/code/sort.lisp index fc868dbba..271de7cca 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -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 diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 58fbb05eb..5f57acd1f 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -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) diff --git a/src/code/thread.lisp b/src/code/thread.lisp index ed53c68da..1608d171a 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -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))) diff --git a/src/code/time.lisp b/src/code/time.lisp index ec182d591..5123e8186 100644 --- a/src/code/time.lisp +++ b/src/code/time.lisp @@ -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 diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 713f6cb4c..da8d86545 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -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*) diff --git a/src/code/xset.lisp b/src/code/xset.lisp index 408f6c1dd..d0bd24f25 100644 --- a/src/code/xset.lisp +++ b/src/code/xset.lisp @@ -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) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 41eeccb67..9d72ddcd0 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -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))) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 74012184e..73f7e0640 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -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) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 59bcecf73..5811f69c3 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -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)) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index be5b9ffc7..593ef396e 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -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))) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 453dfa905..9a4e3e348 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -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 diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 11ef163c0..960e7c731 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -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))))