From: Nikodemus Siivola Date: Sat, 10 Dec 2011 00:25:51 +0000 (+0200) Subject: stack-allocatable fill-initialized specialized arrays X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=40bff32181a4d9b591ae2bac69bbee3bd77a82bc;p=sbcl.git stack-allocatable fill-initialized specialized arrays I *think* we had this working earlier already, but it's been broken at least for a while now since there were no tests for it. Add a DEFKNOWN to the array byte bashers, providing the RESULT-ARG -- and make them return the sequence. Replace the unused and bitrotted UNSAFE IR1 attribute with its inverse: DX-SAFE, and use that togather with RESULT-ARG to allow multiple refs to potentially DX leafs. Still accept UNSAFE in DEFKNOWNs occurring in user-code, but ignore it and give a style-warning. For now, add DX-SAFE to LENGTH and VECTOR-LENGTH, which is enough for our purposes. Fixes lp#902351. --- diff --git a/NEWS b/NEWS index eb6225e..5558322 100644 --- a/NEWS +++ b/NEWS @@ -33,6 +33,8 @@ changes relative to sbcl-1.0.54: * enhancement: SBCL now provides either an explicit :BIG-ENDIAN or :LITTLE-ENDIAN in *FEATURES*, instead of :BIG-ENDIAN being implied by lack of the :LITTLE-ENDIAN feature. (Thanks to Luís Oliveira, lp#901661) + * optimization: specialized arrays with non-zero :INITIAL-ELEMENT can + be stack-allocated. (lp#902351) * optimization: the compiler is smarter about representation selection for floating point constants used in full calls. * optimization: the compiler no longer refuses to coerce large fixnums to @@ -78,6 +80,8 @@ changes relative to sbcl-1.0.54: no longer claim to be unable to stack allocate the function. * bug fix: COERCE now signals a type-error on several coercions to subtypes of CHARACTER that are forbidden according to ANSI. (lp#841312) + * bug fix: missing failure-to-stack-allocate compiler notes for some + forms of MAKE-ARRAY with dynamic-extent. (lp#902351) changes in sbcl-1.0.54 relative to sbcl-1.0.53: * minor incompatible changes: diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index cb54b81..7c7e539 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -232,11 +232,16 @@ (values)) ;; common uses for constant-byte-bashing + (defknown ,array-fill-name (word simple-unboxed-array ,offset ,offset) + simple-unboxed-array + () + :result-arg 1) (defun ,array-fill-name (value dst dst-offset length) (declare (type word value) (type ,offset dst-offset length)) (declare (optimize (speed 3) (safety 1))) (,constant-bash-name dst dst-offset length value - #'%vector-raw-bits #'%set-vector-raw-bits)) + #'%vector-raw-bits #'%set-vector-raw-bits) + dst) (defun ,system-area-fill-name (value dst dst-offset length) (declare (type word value) (type ,offset dst-offset length)) (declare (optimize (speed 3) (safety 1))) diff --git a/src/compiler/alpha/cell.lisp b/src/compiler/alpha/cell.lisp index 3cd8558..b99075b 100644 --- a/src/compiler/alpha/cell.lisp +++ b/src/compiler/alpha/cell.lisp @@ -368,7 +368,7 @@ (:variant ,offset)) ,@(when writable `((defknown ((setf ,fn)) (,lisp-type) ,lisp-type - (unsafe)) + ()) (define-vop (,set ,set-vop) (:translate (setf ,fn)) (:variant ,offset))))))))) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 2a2716c..7f76e3c 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -86,7 +86,7 @@ (defknown classoid-of (t) classoid (flushable)) (defknown layout-of (t) layout (flushable)) (defknown copy-structure (structure-object) structure-object - (flushable unsafe)) + (flushable)) ;;;; from the "Control Structure" chapter: @@ -106,14 +106,14 @@ (defknown special-operator-p (symbol) t ;; The set of special operators never changes. (movable foldable flushable)) -(defknown set (symbol t) t (unsafe) +(defknown set (symbol t) t () :derive-type #'result-type-last-arg) -(defknown fdefinition ((or symbol cons)) function (unsafe explicit-check)) +(defknown fdefinition ((or symbol cons)) function (explicit-check)) (defknown %set-fdefinition ((or symbol cons) function) function - (unsafe explicit-check)) + (explicit-check)) (defknown makunbound (symbol) symbol) (defknown fmakunbound ((or symbol cons)) (or symbol cons) - (unsafe explicit-check)) + (explicit-check)) (defknown apply (callable t &rest t) *) ; ### Last arg must be List... (defknown funcall (callable &rest t) *) @@ -130,7 +130,7 @@ ;;; We let VALUES-LIST be foldable, since constant-folding will turn ;;; it into VALUES. VALUES is not foldable, since MV constants are ;;; represented by a call to VALUES. -(defknown values (&rest t) * (movable flushable unsafe)) +(defknown values (&rest t) * (movable flushable)) (defknown values-list (list) * (movable foldable unsafely-flushable)) ;;;; from the "Macros" chapter: @@ -437,7 +437,7 @@ (defknown copy-seq (sequence) consed-sequence (flushable) :derive-type (sequence-result-nth-arg 1)) -(defknown length (sequence) index (foldable flushable)) +(defknown length (sequence) index (foldable flushable dx-safe)) (defknown reverse (sequence) consed-sequence (flushable) :derive-type (sequence-result-nth-arg 1)) @@ -450,7 +450,7 @@ &key (:initial-element t)) consed-sequence - (movable unsafe) + (movable) :derive-type (creation-result-type-specifier-nth-arg 1)) (defknown concatenate (type-specifier &rest sequence) consed-sequence @@ -483,15 +483,14 @@ (defknown (every notany notevery) (callable sequence &rest sequence) boolean (foldable unsafely-flushable call)) -;;; unsafe for :INITIAL-VALUE... (defknown reduce (callable sequence &rest t &key (:from-end t) (:start index) (:end sequence-end) (:initial-value t) (:key callable)) t - (foldable flushable call unsafe)) + (foldable flushable call)) (defknown fill (sequence t &rest t &key (:start index) (:end sequence-end)) sequence - (unsafe) + () :derive-type #'result-type-first-arg :destroyed-constant-args (nth-constant-nonempty-sequence-args 1) :result-arg 0) @@ -680,7 +679,7 @@ t (foldable unsafely-flushable)) -(defknown cons (t t) cons (movable flushable unsafe)) +(defknown cons (t t) cons (movable flushable)) (defknown tree-equal (t t &key (:test callable) (:test-not callable)) boolean (foldable flushable call)) @@ -695,10 +694,10 @@ (defknown %lastn/fixnum (list (and unsigned-byte fixnum)) t (foldable flushable)) (defknown %lastn/bignum (list (and unsigned-byte bignum)) t (foldable flushable)) -(defknown list (&rest t) list (movable flushable unsafe)) -(defknown list* (t &rest t) t (movable flushable unsafe)) +(defknown list (&rest t) list (movable flushable)) +(defknown list* (t &rest t) t (movable flushable)) (defknown make-list (index &key (:initial-element t)) list - (movable flushable unsafe)) + (movable flushable)) ;;; All but last must be of type LIST, but there seems to be no way to ;;; express that in this syntax. @@ -724,31 +723,31 @@ :destroyed-constant-args (nth-constant-nonempty-sequence-args 1)) (defknown ldiff (list t) list (flushable)) -(defknown (rplaca rplacd) (cons t) list (unsafe) +(defknown (rplaca rplacd) (cons t) list () :destroyed-constant-args (nth-constant-args 1)) (defknown subst (t t t &key (:key callable) (:test callable) (:test-not callable)) - t (flushable unsafe call)) + t (flushable call)) (defknown nsubst (t t t &key (:key callable) (:test callable) (:test-not callable)) - t (unsafe call) + t (call) :destroyed-constant-args (nth-constant-nonempty-sequence-args 3)) (defknown (subst-if subst-if-not) (t callable t &key (:key callable)) - t (flushable unsafe call)) + t (flushable call)) (defknown (nsubst-if nsubst-if-not) (t callable t &key (:key callable)) - t (unsafe call) + t (call) :destroyed-constant-args (nth-constant-nonempty-sequence-args 3)) (defknown sublis (list t &key (:key callable) (:test callable) (:test-not callable)) - t (flushable unsafe call)) + t (flushable call)) (defknown nsublis (list t &key (:key callable) (:test callable) (:test-not callable)) - t (flushable unsafe call) + t (flushable call) :destroyed-constant-args (nth-constant-nonempty-sequence-args 2)) (defknown member (t list &key (:key callable) (:test callable) @@ -761,7 +760,7 @@ (defknown adjoin (t list &key (:key callable) (:test callable) (:test-not callable)) - list (foldable flushable unsafe call)) + list (foldable flushable call)) (defknown (union intersection set-difference set-exclusive-or) (list list &key (:key callable) (:test callable) (:test-not callable)) @@ -779,8 +778,8 @@ boolean (foldable flushable call)) -(defknown acons (t t t) list (movable flushable unsafe)) -(defknown pairlis (t t &optional t) list (flushable unsafe)) +(defknown acons (t t t) list (movable flushable)) +(defknown pairlis (t t &optional t) list (flushable)) (defknown (rassoc assoc) (t list &key (:key callable) (:test callable) (:test-not callable)) @@ -788,8 +787,8 @@ (defknown (assoc-if-not assoc-if rassoc-if rassoc-if-not) (callable list &key (:key callable)) list (foldable flushable call)) -(defknown (memq assq) (t list) list (foldable flushable unsafe)) -(defknown delq (t list) list (flushable unsafe) +(defknown (memq assq) (t list) list (foldable flushable)) +(defknown delq (t list) list (flushable) :destroyed-constant-args (nth-constant-nonempty-sequence-args 2)) ;;;; from the "Hash Tables" chapter: @@ -802,15 +801,15 @@ (:weakness (member nil :key :value :key-and-value :key-or-value)) (:synchronized t)) hash-table - (flushable unsafe)) + (flushable)) (defknown hash-table-p (t) boolean (movable foldable flushable)) (defknown gethash (t hash-table &optional t) (values t boolean) - (flushable unsafe)) ; not FOLDABLE, since hash table contents can change + (flushable)) ; not FOLDABLE, since hash table contents can change (defknown sb!impl::gethash2 (t hash-table) (values t boolean) - (flushable unsafe)) ; not FOLDABLE, since hash table contents can change + (flushable)) ; not FOLDABLE, since hash table contents can change (defknown sb!impl::gethash3 (t hash-table t) (values t boolean) - (flushable unsafe)) ; not FOLDABLE, since hash table contents can change -(defknown %puthash (t hash-table t) t (unsafe) + (flushable)) ; not FOLDABLE, since hash table contents can change +(defknown %puthash (t hash-table t) t () :destroyed-constant-args (nth-constant-args 2)) (defknown remhash (t hash-table) boolean () :destroyed-constant-args (nth-constant-args 2)) @@ -838,9 +837,9 @@ (:fill-pointer t) (:displaced-to (or array null)) (:displaced-index-offset index)) - array (flushable unsafe)) + array (flushable)) -(defknown vector (&rest t) simple-vector (flushable unsafe)) +(defknown vector (&rest t) simple-vector (flushable)) (defknown aref (array &rest index) t (foldable)) (defknown row-major-aref (array index) t (foldable)) @@ -899,7 +898,7 @@ (:initial-element t) (:initial-contents t) (:fill-pointer t) (:displaced-to (or array null)) (:displaced-index-offset index)) - array (unsafe)) + array ()) ; :derive-type 'result-type-arg1) Not even close... ;;;; from the "Strings" chapter: @@ -967,7 +966,7 @@ (defknown make-echo-stream (stream stream) stream (flushable)) (defknown make-string-input-stream (string &optional index sequence-end) stream - (flushable unsafe)) + (flushable)) (defknown make-string-output-stream (&key (:element-type type-specifier)) string-output-stream @@ -997,7 +996,7 @@ (defknown set-macro-character (character callable &optional t (or readtable null)) (eql t) - (unsafe)) + ()) (defknown get-macro-character (character &optional (or readtable null)) (values callable boolean) (flushable)) @@ -1005,7 +1004,7 @@ (eql t) ()) (defknown set-dispatch-macro-character (character character callable &optional (or readtable null)) (eql t) - (unsafe)) + ()) (defknown get-dispatch-macro-character (character character &optional (or readtable null)) (or callable null) ()) @@ -1379,7 +1378,7 @@ short-site-name long-site-name) () (or simple-string null) (flushable)) -(defknown identity (t) t (movable foldable flushable unsafe) +(defknown identity (t) t (movable foldable flushable) :derive-type #'result-type-first-arg) (defknown constantly (t) function (movable flushable)) @@ -1456,17 +1455,17 @@ (defknown data-vector-ref-with-offset (simple-array index fixnum) t (foldable explicit-check always-translatable)) (defknown data-vector-set (array index t) t - (unsafe explicit-check always-translatable)) + (explicit-check always-translatable)) (defknown data-vector-set-with-offset (array index fixnum t) t - (unsafe explicit-check always-translatable)) + (explicit-check always-translatable)) (defknown hairy-data-vector-ref (array index) t (foldable explicit-check)) -(defknown hairy-data-vector-set (array index t) t (unsafe explicit-check)) +(defknown hairy-data-vector-set (array index t) t (explicit-check)) (defknown hairy-data-vector-ref/check-bounds (array index) t (foldable explicit-check)) (defknown hairy-data-vector-set/check-bounds (array index t) t - (unsafe explicit-check)) + (explicit-check)) (defknown %caller-frame () t (flushable)) (defknown %caller-pc () system-area-pointer (flushable)) (defknown %with-array-data (array index (or index null)) @@ -1475,7 +1474,7 @@ (defknown %with-array-data/fp (array index (or index null)) (values (simple-array * (*)) index index index) (foldable flushable)) -(defknown %set-symbol-package (symbol t) t (unsafe)) +(defknown %set-symbol-package (symbol t) t ()) (defknown %coerce-name-to-fun ((or symbol cons)) function (flushable)) (defknown %coerce-callable-to-fun (callable) function (flushable)) (defknown array-bounding-indices-bad-error (t t t) nil) @@ -1516,36 +1515,36 @@ nil) ; never returns -(defknown arg-count-error (t t t t t t) nil (unsafe)) +(defknown arg-count-error (t t t t t t) nil ()) ;;;; SETF inverses -(defknown %aset (array &rest t) t (unsafe) +(defknown %aset (array &rest t) t () :destroyed-constant-args (nth-constant-args 1)) -(defknown %set-row-major-aref (array index t) t (unsafe) +(defknown %set-row-major-aref (array index t) t () :destroyed-constant-args (nth-constant-args 1)) -(defknown (%rplaca %rplacd) (cons t) t (unsafe) +(defknown (%rplaca %rplacd) (cons t) t () :destroyed-constant-args (nth-constant-args 1)) -(defknown %put (symbol t t) t (unsafe)) -(defknown %setelt (sequence index t) t (unsafe) +(defknown %put (symbol t t) t ()) +(defknown %setelt (sequence index t) t () :destroyed-constant-args (nth-constant-args 1)) -(defknown %svset (simple-vector index t) t (unsafe) +(defknown %svset (simple-vector index t) t () :destroyed-constant-args (nth-constant-args 1)) -(defknown %bitset ((array bit) &rest index) bit (unsafe) +(defknown %bitset ((array bit) &rest index) bit () :destroyed-constant-args (nth-constant-args 1)) -(defknown %sbitset ((simple-array bit) &rest index) bit (unsafe) +(defknown %sbitset ((simple-array bit) &rest index) bit () :destroyed-constant-args (nth-constant-args 1)) -(defknown %charset (string index character) character (unsafe) +(defknown %charset (string index character) character () :destroyed-constant-args (nth-constant-args 1)) -(defknown %scharset (simple-string index character) character (unsafe) +(defknown %scharset (simple-string index character) character () :destroyed-constant-args (nth-constant-args 1)) -(defknown %set-symbol-value (symbol t) t (unsafe)) -(defknown (setf symbol-function) (function symbol) function (unsafe)) -(defknown %set-symbol-plist (symbol list) list (unsafe)) -(defknown %setnth (unsigned-byte list t) t (unsafe) +(defknown %set-symbol-value (symbol t) t ()) +(defknown (setf symbol-function) (function symbol) function ()) +(defknown %set-symbol-plist (symbol list) list ()) +(defknown %setnth (unsigned-byte list t) t () :destroyed-constant-args (nth-constant-args 2)) (defknown %set-fill-pointer (complex-vector index) index - (unsafe explicit-check) + (explicit-check) :destroyed-constant-args (nth-constant-args 1)) ;;;; ALIEN and call-out-to-C stuff @@ -1553,7 +1552,7 @@ ;; Used by WITH-PINNED-OBJECTS #!+(or x86 x86-64) (defknown sb!vm::touch-object (t) (values) - (unsafe always-translatable)) + (always-translatable)) #!+linkage-table (defknown foreign-symbol-dataref-sap (simple-string) @@ -1571,7 +1570,7 @@ ;;;; miscellaneous internal utilities (defknown %fun-name (function) t (flushable)) -(defknown (setf %fun-name) (t function) t (unsafe)) +(defknown (setf %fun-name) (t function) t ()) (defknown policy-quality (policy symbol) policy-quality (flushable)) @@ -1595,10 +1594,10 @@ ;;;; atomic ops (defknown %compare-and-swap-svref (simple-vector index t t) t - (unsafe)) + ()) (defknown %compare-and-swap-instance-ref (instance index t t) t - (unsafe)) + ()) (defknown %compare-and-swap-symbol-value (symbol t t) t - (unsafe unwind)) + (unwind)) (defknown spin-loop-hint () (values) (always-translatable)) diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 83fa84f..7ab5fd7 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -103,37 +103,37 @@ :ref-trans %array-fill-pointer :ref-known (flushable foldable) :set-trans (setf %array-fill-pointer) - :set-known (unsafe)) + :set-known ()) (fill-pointer-p :type (member t nil) :ref-trans %array-fill-pointer-p :ref-known (flushable foldable) :set-trans (setf %array-fill-pointer-p) - :set-known (unsafe)) + :set-known ()) (elements :type index :ref-trans %array-available-elements :ref-known (flushable foldable) :set-trans (setf %array-available-elements) - :set-known (unsafe)) + :set-known ()) (data :type array :ref-trans %array-data-vector :ref-known (flushable foldable) :set-trans (setf %array-data-vector) - :set-known (unsafe)) + :set-known ()) (displacement :type (or index null) :ref-trans %array-displacement :ref-known (flushable foldable) :set-trans (setf %array-displacement) - :set-known (unsafe)) + :set-known ()) (displaced-p :type t :ref-trans %array-displaced-p :ref-known (flushable foldable) :set-trans (setf %array-displaced-p) - :set-known (unsafe)) + :set-known ()) (displaced-from :type list :ref-trans %array-displaced-from :ref-known (flushable) :set-trans (setf %array-displaced-from) - :set-known (unsafe)) + :set-known ()) (dimensions :rest-p t)) (define-primitive-object (vector :type vector @@ -154,12 +154,12 @@ (entry-points :type (or function null) :ref-known (flushable) :ref-trans %code-entry-points - :set-known (unsafe) + :set-known () :set-trans (setf %code-entry-points)) (debug-info :type t :ref-known (flushable) :ref-trans %code-debug-info - :set-known (unsafe) + :set-known () :set-trans (setf %code-debug-info)) (trace-table-offset) (constants :rest-p t)) @@ -197,20 +197,20 @@ (next :type (or function null) :ref-known (flushable) :ref-trans %simple-fun-next - :set-known (unsafe) + :set-known () :set-trans (setf %simple-fun-next)) (name :ref-known (flushable) :ref-trans %simple-fun-name - :set-known (unsafe) + :set-known () :set-trans (setf %simple-fun-name)) (arglist :type list :ref-known (flushable) :ref-trans %simple-fun-arglist - :set-known (unsafe) + :set-known () :set-trans (setf %simple-fun-arglist)) (type :ref-known (flushable) :ref-trans %simple-fun-type - :set-known (unsafe) + :set-known () :set-trans (setf %simple-fun-type)) ;; NIL for empty, STRING for a docstring, SIMPLE-VECTOR for XREFS, and (CONS ;; STRING SIMPLE-VECTOR) for both. @@ -218,12 +218,12 @@ :ref-trans %simple-fun-info :ref-known (flushable) :set-trans (setf %simple-fun-info) - :set-known (unsafe)) + :set-known ()) ;; the SB!C::DEBUG-FUN object corresponding to this object, or NIL for none #+nil ; FIXME: doesn't work (gotcha, lowly maintenoid!) See notes on bug 137. (debug-fun :ref-known (flushable) :ref-trans %simple-fun-debug-fun - :set-known (unsafe) + :set-known () :set-trans (setf %simple-fun-debug-fun)) (code :rest-p t :c-type "unsigned char")) @@ -241,7 +241,7 @@ :alloc-trans %make-funcallable-instance) (trampoline :init :funcallable-instance-tramp) (function :ref-known (flushable) :ref-trans %funcallable-instance-function - :set-known (unsafe) :set-trans (setf %funcallable-instance-function)) + :set-known () :set-trans (setf %funcallable-instance-function)) (info :rest-p t)) (define-primitive-object (value-cell :lowtag other-pointer-lowtag @@ -250,7 +250,7 @@ ;; for this. Is this needed as well? :alloc-trans make-value-cell) (value :set-trans value-cell-set - :set-known (unsafe) + :set-known () :ref-trans value-cell-ref :ref-known (flushable) :init :arg)) @@ -325,7 +325,7 @@ ;; also the CAR of NIL-as-end-of-list (value :init :unbound :set-trans %set-symbol-global-value - :set-known (unsafe)) + :set-known ()) ;; also the CDR of NIL-as-end-of-list. Its reffer needs special ;; care for this reason, as hash values must be fixnums. (hash :set-trans %set-symbol-hash) diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 90716af..3712e4c 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -87,7 +87,7 @@ (flushable movable)) (defknown %set-symbol-hash (symbol hash) - t (unsafe)) + t ()) (defknown initialize-vector ((simple-array * (*)) &rest t) (simple-array * (*)) @@ -95,10 +95,10 @@ :result-arg 0) (defknown vector-fill* (t t t t) vector - (unsafe) + () :result-arg 0) -(defknown vector-length (vector) index (flushable)) +(defknown vector-length (vector) index (flushable dx-safe)) (defknown vector-sap ((simple-unboxed-array (*))) system-area-pointer (flushable)) @@ -111,7 +111,7 @@ (defknown (get-header-data get-closure-length) (t) (unsigned-byte 24) (flushable)) (defknown set-header-data (t (unsigned-byte 24)) t - (unsafe)) + ()) (defknown %array-dimension (t index) index (flushable)) @@ -127,54 +127,54 @@ (defknown %instance-layout (instance) layout (foldable flushable)) (defknown %set-instance-layout (instance layout) layout - (unsafe)) + ()) (defknown %instance-length (instance) index (foldable flushable)) (defknown %instance-ref (instance index) t (flushable always-translatable)) (defknown %instance-set (instance index t) t - (unsafe always-translatable)) + (always-translatable)) (defknown %layout-invalid-error (t layout) nil) (defknown %raw-instance-ref/word (instance index) sb!vm:word (flushable always-translatable)) (defknown %raw-instance-set/word (instance index sb!vm:word) sb!vm:word - (unsafe always-translatable)) + (always-translatable)) (defknown %raw-instance-ref/single (instance index) single-float (flushable always-translatable)) (defknown %raw-instance-set/single (instance index single-float) single-float - (unsafe always-translatable)) + (always-translatable)) (defknown %raw-instance-ref/double (instance index) double-float (flushable always-translatable)) (defknown %raw-instance-set/double (instance index double-float) double-float - (unsafe always-translatable)) + (always-translatable)) (defknown %raw-instance-ref/complex-single (instance index) (complex single-float) (flushable always-translatable)) (defknown %raw-instance-set/complex-single (instance index (complex single-float)) (complex single-float) - (unsafe always-translatable)) + (always-translatable)) (defknown %raw-instance-ref/complex-double (instance index) (complex double-float) (flushable always-translatable)) (defknown %raw-instance-set/complex-double (instance index (complex double-float)) (complex double-float) - (unsafe always-translatable)) + (always-translatable)) #!+(or x86 x86-64 ppc) (defknown %raw-instance-atomic-incf/word (instance index sb!vm:word) sb!vm:word - (unsafe always-translatable)) + (always-translatable)) #!+(or x86 x86-64 ppc) (defknown %array-atomic-incf/word (t index sb!vm:word) sb!vm:word - (unsafe always-translatable)) + (always-translatable)) ;;; These two are mostly used for bit-bashing operations. (defknown %vector-raw-bits (t fixnum) sb!vm:word (flushable)) (defknown (%set-vector-raw-bits) (t fixnum sb!vm:word) sb!vm:word - (unsafe)) + ()) (defknown allocate-vector ((unsigned-byte 8) index index) (simple-array * (*)) @@ -206,7 +206,7 @@ (defknown current-sp () system-area-pointer (movable flushable)) (defknown current-fp () system-area-pointer (movable flushable)) (defknown stack-ref (system-area-pointer index) t (flushable)) -(defknown %set-stack-ref (system-area-pointer index t) t (unsafe)) +(defknown %set-stack-ref (system-area-pointer index t) t ()) (defknown lra-code-header (t) t (movable flushable)) (defknown fun-code-header (t) t (movable flushable)) (defknown %make-lisp-obj (sb!vm:word) t (movable flushable)) @@ -239,7 +239,7 @@ (foldable flushable movable)) (defknown %bignum-set-length (bignum-type bignum-index) bignum-type - (unsafe)) + ()) (defknown %bignum-ref (bignum-type bignum-index) bignum-element-type (flushable)) @@ -249,11 +249,11 @@ (defknown %bignum-set (bignum-type bignum-index bignum-element-type) bignum-element-type - (unsafe)) + ()) #!+(or x86 x86-64) (defknown %bignum-set-with-offset (bignum-type bignum-index (signed-byte 24) bignum-element-type) - bignum-element-type (unsafe always-translatable)) + bignum-element-type (always-translatable)) (defknown %digit-0-or-plusp (bignum-element-type) boolean (foldable flushable movable)) @@ -351,13 +351,13 @@ (defknown fdefn-p (t) boolean (movable foldable flushable)) (defknown fdefn-name (fdefn) t (foldable flushable)) (defknown fdefn-fun (fdefn) (or function null) (flushable)) -(defknown (setf fdefn-fun) (function fdefn) t (unsafe)) +(defknown (setf fdefn-fun) (function fdefn) t ()) (defknown fdefn-makunbound (fdefn) t ()) (defknown %simple-fun-self (function) function (flushable)) (defknown (setf %simple-fun-self) (function function) function - (unsafe)) + ()) (defknown %closure-fun (function) function (flushable)) @@ -366,10 +366,10 @@ (flushable)) (defknown %make-funcallable-instance (index) function - (unsafe)) + ()) (defknown %funcallable-instance-info (function index) t (flushable)) -(defknown %set-funcallable-instance-info (function index t) t (unsafe)) +(defknown %set-funcallable-instance-info (function index t) t ()) ;;;; mutator accessors diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp index 8789a96..f77dc25 100644 --- a/src/compiler/generic/vm-macs.lisp +++ b/src/compiler/generic/vm-macs.lisp @@ -106,7 +106,7 @@ (forms `(progn (defknown ,cas-trans (,type ,slot-type ,slot-type) - ,slot-type (unsafe)) + ,slot-type ()) #!+compare-and-swap-vops (def-casser ,cas-trans ,offset ,lowtag)))) (when init diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 74df877..f62f0a4 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -565,6 +565,17 @@ (return-from combination-args-flow-cleanly-p nil))))))))))) (recurse combination1))) +(defun ref-good-for-dx-p (ref) + (let* ((lvar (ref-lvar ref)) + (dest (when lvar (lvar-dest lvar)))) + (and (combination-p dest) + (eq :known (combination-kind dest)) + (awhen (combination-fun-info dest) + (or (ir1-attributep (fun-info-attributes it) dx-safe) + (and (not (combination-lvar dest)) + (awhen (fun-info-result-arg it) + (eql lvar (nth it (combination-args dest)))))))))) + (defun trivial-lambda-var-ref-p (use) (and (ref-p use) (let ((var (ref-leaf use))) @@ -573,10 +584,13 @@ (neq :indefinite (lambda-var-extent var))) (let ((home (lambda-var-home var)) (refs (lambda-var-refs var))) - ;; bound by a non-XEP system lambda, no other REFS + ;; bound by a non-XEP system lambda, no other REFS that aren't + ;; DX-SAFE, or are result-args when the result is discarded. (when (and (lambda-system-lambda-p home) (neq :external (lambda-kind home)) - (eq use (car refs)) (not (cdr refs))) + (dolist (ref refs t) + (unless (or (eq use ref) (ref-good-for-dx-p ref)) + (return nil)))) ;; the LAMBDA this var is bound by has only a single REF, going ;; to a combination (let* ((lambda-refs (lambda-refs home)) diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index e121815..f9a0028 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -25,22 +25,29 @@ ;;; breakdown of side effects, since we do very little code motion on ;;; IR1. We are interested in some deeper semantic properties such as ;;; whether it is safe to pass stack closures to. +;;; +;;; FIXME: This whole notion of "bad" explicit attributes is bad for +;;; maintenance. How confident are we that we have no defknowns for functions +;;; with functional arguments that are missing the CALL attribute? Much better +;;; to have NO-CALLS, as it is much less likely to break accidentally. (!def-boolean-attribute ir1 ;; may call functions that are passed as arguments. In order to ;; determine what other effects are present, we must find the ;; effects of all arguments that may be functions. call - ;; may incorporate function or number arguments into the result or - ;; somehow pass them upward. Note that this applies to any argument - ;; that *might* be a function or number, not just the arguments that - ;; always are. - unsafe ;; may fail to return during correct execution. Errors are O.K. + ;; UNUSED, BEWARE OF BITROT. unwind ;; the (default) worst case. Includes all the other bad things, plus ;; any other possible bad thing. If this is present, the above bad ;; attributes will be explicitly present as well. any + ;; all arguments are safe for dynamic extent. + ;; (We used to have an UNSAFE attribute, which was basically the inverse + ;; of this, but it was unused and bitrotted, so when we started making + ;; use of the information we flipped the name and meaning the safe way + ;; around.) + dx-safe ;; may be constant-folded. The function has no side effects, but may ;; be affected by side effects on the arguments. e.g. SVREF, MAPC. ;; Functions that side-effect their arguments are not considered to @@ -67,9 +74,7 @@ important-result ;; may be moved with impunity. Has no side effects except possibly ;; consing, and is affected only by its arguments. - ;; - ;; Since it is not used now, its distribution in fndb.lisp is - ;; mere random; use with caution. + ;; UNUSED, BEWARE OF BITROT. movable ;; The function is a true predicate likely to be open-coded. Convert ;; any non-conditional uses into (IF T NIL). Not usually diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 48af2fb..be5100e 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -469,12 +469,16 @@ ;;; the function might have. (defmacro defknown (name arg-types result-type &optional (attributes '(any)) &body keys) + #-sb-xc-host + (when (member 'unsafe attributes) + (style-warn "Ignoring legacy attribute UNSAFE. Replaced by its inverse: DX-SAFE.") + (setf attributes (remove 'unsafe attributes))) (when (and (intersection attributes '(any call unwind)) (intersection attributes '(movable))) (error "function cannot have both good and bad attributes: ~S" attributes)) (when (member 'any attributes) - (setq attributes (union '(call unsafe unwind) attributes))) + (setq attributes (union '(call unwind) attributes))) (when (member 'flushable attributes) (pushnew 'unsafely-flushable attributes)) diff --git a/tests/compiler-test-util.lisp b/tests/compiler-test-util.lisp index 6a7bca3..47ffa11 100644 --- a/tests/compiler-test-util.lisp +++ b/tests/compiler-test-util.lisp @@ -25,7 +25,7 @@ (cl:in-package :ctu) (unless (fboundp 'compiler-derived-type) - (defknown compiler-derived-type (t) (values t t) (movable flushable unsafe)) + (defknown compiler-derived-type (t) (values t t) (flushable)) (deftransform compiler-derived-type ((x) * * :node node) (sb-c::delay-ir1-transform node :optimize) `(values ',(type-specifier (sb-c::lvar-type x)) t)) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index ab00e06..00c3b7e 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -211,6 +211,36 @@ (true v) nil)) +(defun-with-dx make-array-on-stack-6 () + (let ((v (make-array 3 :initial-element 12 :element-type '(unsigned-byte 8)))) + (declare (sb-int:truly-dynamic-extent v)) + (true v) + nil)) + +(defun-with-dx make-array-on-stack-7 () + (let ((v (make-array 3 :initial-element 12 :element-type '(signed-byte 8)))) + (declare (sb-int:truly-dynamic-extent v)) + (true v) + nil)) + +(defun-with-dx make-array-on-stack-8 () + (let ((v (make-array 3 :initial-element 12 :element-type 'word))) + (declare (sb-int:truly-dynamic-extent v)) + (true v) + nil)) + +(defun-with-dx make-array-on-stack-9 () + (let ((v (make-array 3 :initial-element 12.0 :element-type 'single-float))) + (declare (sb-int:truly-dynamic-extent v)) + (true v) + nil)) + +(defun-with-dx make-array-on-stack-10 () + (let ((v (make-array 3 :initial-element 12.0d0 :element-type 'double-float))) + (declare (sb-int:truly-dynamic-extent v)) + (true v) + nil)) + (defun-with-dx vector-on-stack (x y) (let ((v (vector 1 x 2 y 3))) (declare (sb-int:truly-dynamic-extent v)) @@ -535,6 +565,15 @@ (assert-no-consing (make-array-on-stack-5)) (assert-no-consing (vector-on-stack :x :y))) +(with-test (:name (:no-consing :specialized-dx-vectors) + :skipped-on `(not (and :stack-allocatable-vectors + :c-stack-is-control-stack))) + (assert-no-consing (make-array-on-stack-6)) + (assert-no-consing (make-array-on-stack-7)) + (assert-no-consing (make-array-on-stack-8)) + (assert-no-consing (make-array-on-stack-9)) + (assert-no-consing (make-array-on-stack-10))) + (with-test (:name (:no-consing :dx-raw-instances) :fails-on :ppc :skipped-on '(not :raw-instance-init-vops)) (let (a b) (setf a 1.24 b 1.23d0)