From cee8ef591040db9a79cdd19297867672a9529051 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Fri, 18 Oct 2013 15:18:36 +0400 Subject: [PATCH] Remove duplicate implementations of (setf aref/sbit/bit). Since (setf aref/sbit/bit) have to work with (setf (apply #'aref array subscripts)), they had both a setf expander and a setf-function, but it can be implemented with just a setf-function. All other accessors are still done using (defsetf accessor %setaccessor), I haven't found a technical reason to prefer one to another, other than (setf accessor) being a nicer name. Fixes lp#1241095. --- package-data-list.lisp-expr | 5 ++- src/code/array.lisp | 78 +++++++++--------------------------------- src/code/defsetfs.lisp | 10 +++--- src/compiler/array-tran.lisp | 43 +++++++++++------------ src/compiler/fndb.lisp | 13 +++---- src/compiler/macros.lisp | 37 ++++++++++++-------- src/compiler/seqtran.lisp | 2 +- tests/compiler.pure.lisp | 10 ++++++ 8 files changed, 86 insertions(+), 112 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index ed2b70a..7d1b516 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2013,9 +2013,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "STRING<*" "STRING/=*" "%SVSET" "%SP-STRING-COMPARE" "%SETNTH" "%SETELT" "%SET-ROW-MAJOR-AREF" "%SET-FILL-POINTER" - "%SET-FDEFINITION" "%SCHARSET" "%SBITSET" - "%RPLACD" "%RPLACA" "%PUT" "%CHARSET" "%BITSET" - "%ASET")) + "%SET-FDEFINITION" "%SCHARSET" + "%RPLACD" "%RPLACA" "%PUT" "%CHARSET")) #s(sb-cold:package-data :name "SB!THREAD" diff --git a/src/code/array.lisp b/src/code/array.lisp index b5e3999..8055ac0 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -576,42 +576,14 @@ of specialized arrays is supported." (declare (truly-dynamic-extent subscripts)) (row-major-aref array (%array-row-major-index array subscripts))) -(defun %aset (array &rest stuff) - (declare (truly-dynamic-extent stuff)) - (let ((subscripts (butlast stuff)) - (new-value (car (last stuff)))) - (setf (row-major-aref array (%array-row-major-index array subscripts)) - new-value))) - -;;; FIXME: What's supposed to happen with functions -;;; like AREF when we (DEFUN (SETF FOO) ..) when -;;; DEFSETF FOO is also defined? It seems as though the logical -;;; thing to do would be to nuke the macro definition for (SETF FOO) -;;; and replace it with the (SETF FOO) function, issuing a warning, -;;; just as for ordinary functions -;;; * (LISP-IMPLEMENTATION-VERSION) -;;; "18a+ release x86-linux 2.4.7 6 November 1998 cvs" -;;; * (DEFMACRO ZOO (X) `(+ ,X ,X)) -;;; ZOO -;;; * (DEFUN ZOO (X) (* 3 X)) -;;; Warning: ZOO previously defined as a macro. -;;; ZOO -;;; But that doesn't seem to be what happens in CMU CL. -;;; -;;; KLUDGE: this is probably because ANSI, in its wisdom (CLHS -;;; 5.1.2.5) requires implementations to support -;;; (SETF (APPLY #'AREF ...) ...) -;;; [and also #'BIT and #'SBIT]. Yes, this is terrifying, and it's -;;; also terrifying that this sequence of definitions causes it to -;;; work. -;;; -;;; Also, it would be nice to make DESCRIBE FOO tell whether a symbol -;;; has a setf expansion and/or a setf function defined. - -#!-sb-fluid (declaim (inline (setf aref))) +;;; (setf aref/bit/sbit) are implemented using setf-functions, +;;; because they have to work with (setf (apply #'aref array subscripts)) +;;; All other setfs can be done using setf-functions too, but I +;;; haven't found technical advantages or disatvantages for either +;;; scheme. (defun (setf aref) (new-value array &rest subscripts) - (declare (truly-dynamic-extent subscripts)) - (declare (type array array)) + (declare (truly-dynamic-extent subscripts) + (type array array)) (setf (row-major-aref array (%array-row-major-index array subscripts)) new-value)) @@ -639,20 +611,14 @@ of specialized arrays is supported." (defun bit (bit-array &rest subscripts) #!+sb-doc "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS." - (declare (type (array bit) bit-array) (optimize (safety 1))) + (declare (type (array bit) bit-array) + (optimize (safety 1))) (row-major-aref bit-array (%array-row-major-index bit-array subscripts))) -(defun %bitset (bit-array &rest stuff) - (declare (type (array bit) bit-array) (optimize (safety 1))) - (let ((subscripts (butlast stuff)) - (new-value (car (last stuff)))) - (setf (row-major-aref bit-array - (%array-row-major-index bit-array subscripts)) - new-value))) - -#!-sb-fluid (declaim (inline (setf bit))) (defun (setf bit) (new-value bit-array &rest subscripts) - (declare (type (array bit) bit-array) (optimize (safety 1))) + (declare (type (array bit) bit-array) + (type bit new-value) + (optimize (safety 1))) (setf (row-major-aref bit-array (%array-row-major-index bit-array subscripts)) new-value)) @@ -660,25 +626,15 @@ of specialized arrays is supported." (defun sbit (simple-bit-array &rest subscripts) #!+sb-doc "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS." - (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1))) + (declare (type (simple-array bit) simple-bit-array) + (optimize (safety 1))) (row-major-aref simple-bit-array (%array-row-major-index simple-bit-array subscripts))) -;;; KLUDGE: Not all these things (%SET-ROW-MAJOR-AREF, %SET-FILL-POINTER, -;;; %SET-FDEFINITION, %SCHARSET, %SBITSET..) seem to deserve separate names. -;;; Could we just DEFUN (SETF SBIT) etc. and get rid of the non-ANSI names? -;;; -- WHN 19990911 -(defun %sbitset (simple-bit-array &rest stuff) - (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1))) - (let ((subscripts (butlast stuff)) - (new-value (car (last stuff)))) - (setf (row-major-aref simple-bit-array - (%array-row-major-index simple-bit-array subscripts)) - new-value))) - -#!-sb-fluid (declaim (inline (setf sbit))) (defun (setf sbit) (new-value bit-array &rest subscripts) - (declare (type (simple-array bit) bit-array) (optimize (safety 1))) + (declare (type (simple-array bit) bit-array) + (type bit new-value) + (optimize (safety 1))) (setf (row-major-aref bit-array (%array-row-major-index bit-array subscripts)) new-value)) diff --git a/src/code/defsetfs.lisp b/src/code/defsetfs.lisp index 26ed7f2..af7d31e 100644 --- a/src/code/defsetfs.lisp +++ b/src/code/defsetfs.lisp @@ -53,8 +53,11 @@ ;;; from early-setf.lisp (in-package "SB!IMPL") -;;; KLUDGE: Various of these (e.g. AREF and BIT) have DEFUN (SETF FOO) versions -;;; too. Do we really need both? -- WHN 19990921 +;;; (setf aref/bit/sbit) are implemented using setf-functions, +;;; because they have to work with (setf (apply #'aref array subscripts)) +;;; All other setfs can be done using setf-functions too, but I +;;; haven't found technical advantages or disatvantages for either +;;; scheme. #-sb-xc-host (defsetf car %rplaca) #-sb-xc-host (defsetf cdr %rplacd) #-sb-xc-host (defsetf caar (x) (v) `(%rplaca (car ,x) ,v)) @@ -97,13 +100,10 @@ #-sb-xc-host (defsetf tenth (x) (v) `(%rplaca (cdr (cddddr (cddddr ,x))) ,v)) #-sb-xc-host (defsetf rest %rplacd) #-sb-xc-host (defsetf elt %setelt) -#-sb-xc-host (defsetf aref %aset) #-sb-xc-host (defsetf row-major-aref %set-row-major-aref) #-sb-xc-host (defsetf svref %svset) #-sb-xc-host (defsetf char %charset) -#-sb-xc-host (defsetf bit %bitset) #-sb-xc-host (defsetf schar %scharset) -#-sb-xc-host (defsetf sbit %sbitset) (defsetf %array-dimension %set-array-dimension) (defsetf sb!kernel:%vector-raw-bits sb!kernel:%set-vector-raw-bits) #-sb-xc-host (defsetf symbol-value set) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index d70cdb5..fcf1f60 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -230,9 +230,9 @@ (assert-array-rank array (length indices)) (derive-aref-type array)) -(defoptimizer (%aset derive-type) ((array &rest stuff)) - (assert-array-rank array (1- (length stuff))) - (assert-new-value-type (car (last stuff)) array)) +(defoptimizer ((setf aref) derive-type) ((new-value array &rest subscripts)) + (assert-array-rank array (length subscripts)) + (assert-new-value-type new-value array)) (macrolet ((define (name) `(defoptimizer (,name derive-type) ((array index)) @@ -987,28 +987,30 @@ ;;;; array accessors -;;; We convert all typed array accessors into AREF and %ASET with type +;;; We convert all typed array accessors into AREF and (SETF AREF) with type ;;; assertions on the array. -(macrolet ((define-bit-frob (reffer setter simplep) +(macrolet ((define-bit-frob (reffer simplep) `(progn (define-source-transform ,reffer (a &rest i) `(aref (the (,',(if simplep 'simple-array 'array) bit ,(mapcar (constantly '*) i)) ,a) ,@i)) - (define-source-transform ,setter (a &rest i) - `(%aset (the (,',(if simplep 'simple-array 'array) - bit - ,(cdr (mapcar (constantly '*) i))) - ,a) ,@i))))) - (define-bit-frob sbit %sbitset t) - (define-bit-frob bit %bitset nil)) + (define-source-transform (setf ,reffer) (value a &rest i) + `(setf (aref (the (,',(if simplep 'simple-array 'array) + bit + ,(mapcar (constantly '*) i)) + ,a) ,@i) + ,value))))) + (define-bit-frob sbit t) + (define-bit-frob bit nil)) + (macrolet ((define-frob (reffer setter type) `(progn (define-source-transform ,reffer (a i) `(aref (the ,',type ,a) ,i)) (define-source-transform ,setter (a i v) - `(%aset (the ,',type ,a) ,i ,v))))) + `(setf (aref (the ,',type ,a) ,i) ,v))))) (define-frob schar %scharset simple-string) (define-frob char %charset string)) @@ -1061,8 +1063,8 @@ (push (make-symbol (format nil "DIM-~D" i)) dims)) (setf n-indices (nreverse n-indices)) (setf dims (nreverse dims)) - `(lambda (,',array ,@n-indices - ,@',(when new-value (list new-value))) + `(lambda (,@',(when new-value (list new-value)) + ,',array ,@n-indices) (let* (,@(let ((,index -1)) (mapcar (lambda (name) `(,name (array-dimension @@ -1095,17 +1097,16 @@ (with-row-major-index (array indices index) index)) - ;; Convert AREF and %ASET into a HAIRY-DATA-VECTOR-REF (or + ;; Convert AREF and (SETF AREF) into a HAIRY-DATA-VECTOR-REF (or ;; HAIRY-DATA-VECTOR-SET) with the set of indices replaced with the an ;; expression for the row major index. (deftransform aref ((array &rest indices)) (with-row-major-index (array indices index) (hairy-data-vector-ref array index))) - (deftransform %aset ((array &rest stuff)) - (let ((indices (butlast stuff))) - (with-row-major-index (array indices index new-value) - (hairy-data-vector-set array index new-value))))) + (deftransform (setf aref) ((new-value array &rest subscripts)) + (with-row-major-index (array subscripts index new-value) + (hairy-data-vector-set array index new-value)))) ;; For AREF of vectors we do the bounds checking in the callee. This ;; lets us do a significantly more efficient check for simple-arrays @@ -1130,7 +1131,7 @@ `(hairy-data-vector-ref array index)) (t `(hairy-data-vector-ref/check-bounds array index))))) -(deftransform %aset ((array index new-value) (t t t) * :node node) +(deftransform (setf aref) ((new-value array index) (t t t) * :node node) (if (policy node (zerop insert-array-bounds-checks)) `(hairy-data-vector-set array index new-value) `(hairy-data-vector-set/check-bounds array index new-value))) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 0894e9f..86fe96d 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1638,8 +1638,9 @@ ;;;; SETF inverses -(defknown %aset (array &rest t) t () - :destroyed-constant-args (nth-constant-args 1)) +(defknown (setf aref) (t array &rest index) t () + :destroyed-constant-args (nth-constant-args 2) + :derive-type #'result-type-first-arg) (defknown %set-row-major-aref (array index t) t () :destroyed-constant-args (nth-constant-args 1)) (defknown (%rplaca %rplacd) (cons t) t () @@ -1651,10 +1652,10 @@ :derive-type #'result-type-last-arg) (defknown %svset (simple-vector index t) t () :destroyed-constant-args (nth-constant-args 1)) -(defknown %bitset ((array bit) &rest index) bit () - :destroyed-constant-args (nth-constant-args 1)) -(defknown %sbitset ((simple-array bit) &rest index) bit () - :destroyed-constant-args (nth-constant-args 1)) +(defknown (setf bit) (bit (array bit) &rest index) bit () + :destroyed-constant-args (nth-constant-args 2)) +(defknown (setf sbit) (bit (simple-array bit) &rest index) bit () + :destroyed-constant-args (nth-constant-args 2)) (defknown %charset (string index character) character () :destroyed-constant-args (nth-constant-args 1)) (defknown %scharset (simple-string index character) character () diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 99ca9dc..59de9b0 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -514,21 +514,28 @@ (defmacro defoptimizer (what (lambda-list &optional (n-node (sb!xc:gensym)) &rest vars) &body body) - (let ((name (if (symbolp what) what - (symbolicate (first what) "-" (second what) "-OPTIMIZER")))) - - (let ((n-args (gensym))) - `(progn - (defun ,name (,n-node ,@vars) - (declare (ignorable ,@vars)) - (let ((,n-args (basic-combination-args ,n-node))) - ,(parse-deftransform lambda-list body n-args - `(return-from ,name nil)))) - ,@(when (consp what) - `((setf (,(let ((*package* (symbol-package 'sb!c::fun-info))) - (symbolicate "FUN-INFO-" (second what))) - (fun-info-or-lose ',(first what))) - #',name))))))) + (flet ((function-name (name) + (etypecase name + (symbol name) + ((cons (eql setf) (cons symbol null)) + (symbolicate (car name) "-" (cadr name)))))) + (let ((name (if (symbolp what) + what + (symbolicate (function-name (first what)) + "-" (second what) "-OPTIMIZER")))) + + (let ((n-args (gensym))) + `(progn + (defun ,name (,n-node ,@vars) + (declare (ignorable ,@vars)) + (let ((,n-args (basic-combination-args ,n-node))) + ,(parse-deftransform lambda-list body n-args + `(return-from ,name nil)))) + ,@(when (consp what) + `((setf (,(let ((*package* (symbol-package 'sb!c::fun-info))) + (symbolicate "FUN-INFO-" (second what))) + (fun-info-or-lose ',(first what))) + #',name)))))))) ;;;; IR groveling macros diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 9e4d3b4..81f9068 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -315,7 +315,7 @@ '(nth i s)) (deftransform %setelt ((s i v) ((simple-array * (*)) * *) *) - '(%aset s i v)) + '(setf (aref s i) v)) (deftransform %setelt ((s i v) (list * *) * :policy (< safety 3)) '(setf (car (nthcdr i s)) v)) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index c61786e..83353e1 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -4860,3 +4860,13 @@ rest))))) (dotimes (i limit) (test-function (make-function i) i))))) + +(with-test (:name :apply-aref) + (flet ((test (form) + (let (warning) + (handler-bind ((warning (lambda (c) (setf warning c)))) + (compile nil `(lambda (x y) (setf (apply #'sbit x y) 10)))) + (assert (not warning))))) + (test `(lambda (x y) (setf (apply #'aref x y) 21))) + (test `(lambda (x y) (setf (apply #'bit x y) 1))) + (test `(lambda (x y) (setf (apply #'sbit x y) 0))))) -- 1.7.10.4