From 2f453e77acd12b73a09c3b50601a420d3454b732 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Wed, 8 Aug 2001 01:55:55 +0000 Subject: [PATCH] 0.pre7.1: moved new WITH-ARRAY-DATA stuff from contrib/*-extras.lisp to main SBCL system --- contrib/code-extras.lisp | 3 - contrib/compiler-extras.lisp | 129 +----------------------------------------- package-data-list.lisp-expr | 7 ++- src/code/array.lisp | 44 +++----------- src/code/sysmacs.lisp | 54 +++++++++++++++++- src/compiler/array-tran.lisp | 50 +++++++++++++--- src/compiler/fndb.lisp | 1 + 7 files changed, 109 insertions(+), 179 deletions(-) diff --git a/contrib/code-extras.lisp b/contrib/code-extras.lisp index 6df26a1..aedfa21 100644 --- a/contrib/code-extras.lisp +++ b/contrib/code-extras.lisp @@ -4,9 +4,6 @@ (declaim (optimize (speed 3) (space 1))) -(defun %with-array-data (array start end) - (%with-array-data-macro array start end :fail-inline? t)) - ;;; Like CMU CL, we use HEAPSORT. However, instead of trying to ;;; generalize the CMU CL code to allow START and END values, this ;;; code has been written from scratch following Chapter 7 of diff --git a/contrib/compiler-extras.lisp b/contrib/compiler-extras.lisp index daf18af..421ad18 100644 --- a/contrib/compiler-extras.lisp +++ b/contrib/compiler-extras.lisp @@ -19,8 +19,7 @@ (in-package "SB-KERNEL") (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(%with-array-data-macro - index-or-minus-1 + (export '(index-or-minus-1 %find-position %find-position-vector-macro %find-position-if %find-position-if-vector-macro))) @@ -30,132 +29,6 @@ (declaim (optimize (speed 1) (space 2))) -;;; This checks to see whether the array is simple and the start and -;;; end are in bounds. If so, it proceeds with those values. -;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA -;;; may be further optimized. -;;; -;;; Given any ARRAY, bind DATA-VAR to the array's data vector and -;;; START-VAR and END-VAR to the start and end of the designated -;;; portion of the data vector. SVALUE and EVALUE are any start and -;;; end specified to the original operation, and are factored into the -;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative -;;; offset of all displacements encountered, and does not include -;;; SVALUE. -;;; -;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is -;;; forced to be inline, overriding the ordinary judgment of the -;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are -;;; fairly picky about their arguments, figuring that if you haven't -;;; bothered to get all your ducks in a row, you probably don't care -;;; that much about speed anyway! But in some cases it makes sense to -;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and -;;; the DEFTRANSFORM can't tell that that's going on, so it can make -;;; sense to use FORCE-INLINE option in that case. -(defmacro with-array-data (((data-var array &key offset-var) - (start-var &optional (svalue 0)) - (end-var &optional (evalue nil)) - &key force-inline) - &body forms) - (once-only ((n-array array) - (n-svalue `(the index ,svalue)) - (n-evalue `(the (or index null) ,evalue))) - `(multiple-value-bind (,data-var - ,start-var - ,end-var - ,@(when offset-var `(,offset-var))) - (if (not (array-header-p ,n-array)) - (let ((,n-array ,n-array)) - (declare (type (simple-array * (*)) ,n-array)) - ,(once-only ((n-len `(length ,n-array)) - (n-end `(or ,n-evalue ,n-len))) - `(if (<= ,n-svalue ,n-end ,n-len) - ;; success - (values ,n-array ,n-svalue ,n-end 0) - ;; failure: Make a NOTINLINE call to - ;; %WITH-ARRAY-DATA with our bad data - ;; to cause the error to be signalled. - (locally - (declare (notinline %with-array-data)) - (%with-array-data ,n-array ,n-svalue ,n-evalue))))) - (,(if force-inline '%with-array-data-macro '%with-array-data) - ,n-array ,n-svalue ,n-evalue)) - ,@forms))) - -;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in -;;; DEFTRANSFORMs and DEFUNs. -(defmacro %with-array-data-macro (array - start - end - &key - (element-type '*) - unsafe? - fail-inline?) - (let ((size (gensym "SIZE-")) - (data (gensym "DATA-")) - (cumulative-offset (gensym "CUMULATIVE-OFFSET-"))) - `(let* ((,size (array-total-size ,array)) - (,end (cond (,end - (unless (or ,unsafe? (<= ,end ,size)) - ,(if fail-inline? - `(error "End ~D is greater than total size ~D." - ,end ,size) - `(failed-%with-array-data ,array ,start ,end))) - ,end) - (t ,size)))) - (unless (or ,unsafe? (<= ,start ,end)) - ,(if fail-inline? - `(error "Start ~D is greater than end ~D." ,start ,end) - `(failed-%with-array-data ,array ,start ,end))) - (do ((,data ,array (%array-data-vector ,data)) - (,cumulative-offset 0 - (+ ,cumulative-offset - (%array-displacement ,data)))) - ((not (array-header-p ,data)) - (values (the (simple-array ,element-type 1) ,data) - (the index (+ ,cumulative-offset ,start)) - (the index (+ ,cumulative-offset ,end)) - (the index ,cumulative-offset))) - (declare (type index ,cumulative-offset)))))) - -(defun upgraded-element-type-specifier-or-give-up (continuation) - (let* ((element-ctype (extract-upgraded-element-type continuation)) - (element-type-specifier (type-specifier element-ctype))) - (if (eq element-type-specifier '*) - (give-up-ir1-transform - "upgraded array element type not known at compile time") - element-type-specifier))) - -(deftransform %with-array-data ((array start end) - ;; Note: This transform is limited to - ;; VECTOR only because I happened to - ;; create it in order to get sequence - ;; function operations to be more - ;; efficient. It might very well be - ;; reasonable to allow general ARRAY - ;; here, I just haven't tried to - ;; understand the performance issues - ;; involved. -- WHN - (vector index (or index null)) - * - :important t - :node node - :policy (> speed space)) - "inline non-SIMPLE-vector-handling logic" - (let ((element-type (upgraded-element-type-specifier-or-give-up array))) - `(%with-array-data-macro array start end - :unsafe? ,(policy node (= safety 0)) - :element-type ,element-type))) - -;;; It'd waste space to expand copies of error handling in every -;;; inline %WITH-ARRAY-DATA, so we have them call this function -;;; instead. This is just a wrapper which is known never to return. -(defknown failed-%with-array-data (t t t) nil) -(defun failed-%with-array-data (array start end) - (declare (notinline %with-array-data)) - (%with-array-data array start end) - (error "internal error: shouldn't be here with valid parameters")) - (deftransform fill ((seq item &key (start 0) (end (length seq))) (vector t &key (:start t) (:end index)) * diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 8a9d113..dd2495e 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -940,7 +940,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%SQRT" "%SXHASH-SIMPLE-STRING" "%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TAN-QUICK" "%TANH" "%UNARY-ROUND" "%UNARY-TRUNCATE" - "%WITH-ARRAY-DATA" "WITH-ARRAY-DATA" + "%WITH-ARRAY-DATA" "%WITH-ARRAY-DATA-MACRO" "*ALREADY-MAYBE-GCING*" "*CURRENT-LEVEL*" "*EMPTY-TYPE*" "*EVAL-STACK-TOP*" "*GC-INHIBIT*" @@ -1015,7 +1015,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "DOUBLE-FLOAT-P" "FLOAT-WAIT" "DYNAMIC-SPACE-FREE-POINTER" "DYNAMIC-USAGE" "!DEFUN-FROM-COLLECTED-COLD-INIT-FORMS" - "ERROR-NUMBER-OR-LOSE" "FDEFINITION-OBJECT" + "ERROR-NUMBER-OR-LOSE" + "FAILED-%WITH-ARRAY-DATA" + "FDEFINITION-OBJECT" "FDOCUMENTATION" "FILENAME" "FIND-AND-INIT-OR-CHECK-LAYOUT" "FLOAT-EXPONENT" "FLOAT-FORMAT-DIGITS" "FLOAT-FORMAT-NAME" @@ -1212,6 +1214,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "VECTOR-TO-VECTOR*" "VECTOR-TO-SIMPLE-STRING*" "VECTOR-TO-BIT-VECTOR*" "VECTOR-TO-SIMPLE-BIT-VECTOR*" "VECTOR-OF-CHECKED-LENGTH-GIVEN-LENGTH" + "WITH-ARRAY-DATA" "WITH-CIRCULARITY-DETECTION" "WITH-TYPE-CACHES" "WRONG-NUMBER-OF-INDICES-ERROR" diff --git a/src/code/array.lisp b/src/code/array.lisp index f3ee81b..90891e1 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -46,42 +46,16 @@ (fixnum index)) (%check-bound array bound index)) -;;; the guts of the WITH-ARRAY-DATA macro (except when DEFTRANSFORM -;;; %WITH-ARRAY-DATA takes over) (defun %with-array-data (array start end) - (declare (array array) (type index start) (type (or index null) end)) - ;; FIXME: The VALUES declaration here is correct, but as of SBCL - ;; 0.6.6, the corresponding runtime assertion is implemented - ;; horribly inefficiently, with a full call to %TYPEP for every - ;; call to this function. As a quick fix, I commented it out, - ;; but the proper fix would be to fix up type checking. - ;; - ;; A simpler test case for the optimization bug is - ;; (DEFUN FOO (X) - ;; (DECLARE (TYPE INDEXOID X)) - ;; (THE (VALUES INDEXOID) - ;; (VALUES X))) - ;; which also compiles to a full call to %TYPEP. - #+nil (declare (values (simple-array * (*)) index index index)) - (let* ((size (array-total-size array)) - (end (cond (end - (unless (<= end size) - (error "End ~D is greater than total size ~D." - end size)) - end) - (t size)))) - (when (> start end) - (error "Start ~D is greater than end ~D." start end)) - (do ((data array (%array-data-vector data)) - (cumulative-offset 0 - (+ cumulative-offset - (%array-displacement data)))) - ((not (array-header-p data)) - (values (the (simple-array * (*)) data) - (the index (+ cumulative-offset start)) - (the index (+ cumulative-offset end)) - (the index cumulative-offset))) - (declare (type index cumulative-offset))))) + (%with-array-data-macro array start end :fail-inline? t)) + +;;; It'd waste space to expand copies of error handling in every +;;; inline %WITH-ARRAY-DATA, so we have them call this function +;;; instead. This is just a wrapper which is known never to return. +(defun failed-%with-array-data (array start end) + (declare (notinline %with-array-data)) + (%with-array-data array start end) + (error "internal error: shouldn't be here with valid parameters")) ;;;; MAKE-ARRAY diff --git a/src/code/sysmacs.lisp b/src/code/sysmacs.lisp index 34bcb94..af5c65e 100644 --- a/src/code/sysmacs.lisp +++ b/src/code/sysmacs.lisp @@ -10,7 +10,7 @@ ;;;; files for more information. (in-package "SB!IMPL") - + ;;; This checks to see whether the array is simple and the start and ;;; end are in bounds. If so, it proceeds with those values. ;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA @@ -23,9 +23,20 @@ ;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative ;;; offset of all displacements encountered, and does not include ;;; SVALUE. +;;; +;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is +;;; forced to be inline, overriding the ordinary judgment of the +;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are +;;; fairly picky about their arguments, figuring that if you haven't +;;; bothered to get all your ducks in a row, you probably don't care +;;; that much about speed anyway! But in some cases it makes sense to +;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and +;;; the DEFTRANSFORM can't tell that that's going on, so it can make +;;; sense to use FORCE-INLINE option in that case. (defmacro with-array-data (((data-var array &key offset-var) (start-var &optional (svalue 0)) - (end-var &optional (evalue nil))) + (end-var &optional (evalue nil)) + &key force-inline) &body forms) (once-only ((n-array array) (n-svalue `(the index ,svalue)) @@ -48,9 +59,46 @@ (locally (declare (notinline %with-array-data)) (%with-array-data ,n-array ,n-svalue ,n-evalue))))) - (%with-array-data ,n-array ,n-svalue ,n-evalue)) + (,(if force-inline '%with-array-data-macro '%with-array-data) + ,n-array ,n-svalue ,n-evalue)) ,@forms))) +;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in +;;; DEFTRANSFORMs and DEFUNs. +(defmacro %with-array-data-macro (array + start + end + &key + (element-type '*) + unsafe? + fail-inline?) + (let ((size (gensym "SIZE-")) + (data (gensym "DATA-")) + (cumulative-offset (gensym "CUMULATIVE-OFFSET-"))) + `(let* ((,size (array-total-size ,array)) + (,end (cond (,end + (unless (or ,unsafe? (<= ,end ,size)) + ,(if fail-inline? + `(error "End ~D is greater than total size ~D." + ,end ,size) + `(failed-%with-array-data ,array ,start ,end))) + ,end) + (t ,size)))) + (unless (or ,unsafe? (<= ,start ,end)) + ,(if fail-inline? + `(error "Start ~D is greater than end ~D." ,start ,end) + `(failed-%with-array-data ,array ,start ,end))) + (do ((,data ,array (%array-data-vector ,data)) + (,cumulative-offset 0 + (+ ,cumulative-offset + (%array-displacement ,data)))) + ((not (array-header-p ,data)) + (values (the (simple-array ,element-type 1) ,data) + (the index (+ ,cumulative-offset ,start)) + (the index (+ ,cumulative-offset ,end)) + (the index ,cumulative-offset))) + (declare (type index ,cumulative-offset)))))) + #!-gengc (defmacro without-gcing (&rest body) #!+sb-doc diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 05e57ab..c2f7c83 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -11,14 +11,18 @@ (in-package "SB!C") -;;;; DERIVE-TYPE optimizers - -;;; Array operations that use a specific number of indices implicitly -;;; assert that the array is of that rank. -(defun assert-array-rank (array rank) - (assert-continuation-type - array - (specifier-type `(array * ,(make-list rank :initial-element '*))))) +;;;; utilities for optimizing array operations + +;;; Return UPGRADED-ARRAY-ELEMENT-TYPE for CONTINUATION, or do +;;; GIVE-UP-IR1-TRANSFORM if the upgraded element type can't be +;;; determined. +(defun upgraded-element-type-specifier-or-give-up (continuation) + (let* ((element-ctype (extract-upgraded-element-type continuation)) + (element-type-specifier (type-specifier element-ctype))) + (if (eq element-type-specifier '*) + (give-up-ir1-transform + "upgraded array element type not known at compile time") + element-type-specifier))) ;;; Array access functions return an object from the array, hence its ;;; type will be asserted to be array element type. @@ -52,6 +56,15 @@ (or (not arg) (and (constant-continuation-p arg) (not (continuation-value arg))))) + +;;;; DERIVE-TYPE optimizers + +;;; Array operations that use a specific number of indices implicitly +;;; assert that the array is of that rank. +(defun assert-array-rank (array rank) + (assert-continuation-type + array + (specifier-type `(array * ,(make-list rank :initial-element '*))))) (defoptimizer (array-in-bounds-p derive-type) ((array &rest indices)) (assert-array-rank array (length indices)) @@ -480,6 +493,27 @@ (error "The end of vector data was out of range.")) |# +(deftransform %with-array-data ((array start end) + ;; Note: This transform is limited to + ;; VECTOR only because I happened to + ;; create it in order to get sequence + ;; function operations to be more + ;; efficient. It might very well be + ;; reasonable to allow general ARRAY + ;; here, I just haven't tried to + ;; understand the performance issues + ;; involved. -- WHN + (vector index (or index null)) + * + :important t + :node node + :policy (> speed space)) + "inline non-SIMPLE-vector-handling logic" + (let ((element-type (upgraded-element-type-specifier-or-give-up array))) + `(%with-array-data-macro array start end + :unsafe? ,(policy node (= safety 0)) + :element-type ,element-type))) + ;;; We convert all typed array accessors into AREF and %ASET with type ;;; assertions on the array. (macrolet ((define-frob (reffer setter type) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 4f4f813..6439b19 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1300,6 +1300,7 @@ (defknown %set-symbol-package (symbol t) t (unsafe)) (defknown %coerce-name-to-function ((or symbol cons)) function (flushable)) (defknown %coerce-callable-to-function (callable) function (flushable)) +(defknown failed-%with-array-data (t t t) nil) ;;; Structure slot accessors or setters are magically "known" to be ;;; these functions, although the var remains the Slot-Accessor -- 1.7.10.4