X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=55c4dba90e132d5b005eac3237d2397e0f40ea26;hb=df1314801984738011676b539cedd2c2a41d1f6e;hp=24fe5ce10de350c0ae1b86fe1ecbd37463622616;hpb=3ea6f2688adf11331a7a9c243f77a602785d1e1b;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 24fe5ce..55c4dba 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -27,31 +27,30 @@ (args-to-fn (if take-car `(car ,v) v)))) (let* ((fn-sym (gensym)) ; for ONCE-ONLY-ish purposes - (call `(funcall ,fn-sym . ,(args-to-fn))) + (call `(%funcall ,fn-sym . ,(args-to-fn))) (endtest `(or ,@(tests)))) - (ecase accumulate - (:nconc - (let ((temp (gensym)) - (map-result (gensym))) - `(let ((,fn-sym ,fn) - (,map-result (list nil))) - (do-anonymous ((,temp ,map-result) . ,(do-clauses)) - (,endtest (cdr ,map-result)) - (setq ,temp (last (nconc ,temp ,call))))))) - (:list - (let ((temp (gensym)) - (map-result (gensym))) - `(let ((,fn-sym ,fn) - (,map-result (list nil))) - (do-anonymous ((,temp ,map-result) . ,(do-clauses)) - (,endtest (truly-the list (cdr ,map-result))) - (rplacd ,temp (setq ,temp (list ,call))))))) - ((nil) - `(let ((,fn-sym ,fn) - (,n-first ,(first arglists))) - (do-anonymous ,(do-clauses) - (,endtest (truly-the list ,n-first)) - ,call)))))))) + + `(let ((,fn-sym (%coerce-callable-to-fun ,fn))) + ,(ecase accumulate + (:nconc + (let ((temp (gensym)) + (map-result (gensym))) + `(let ((,map-result (list nil))) + (do-anonymous ((,temp ,map-result) . ,(do-clauses)) + (,endtest (cdr ,map-result)) + (setq ,temp (last (nconc ,temp ,call))))))) + (:list + (let ((temp (gensym)) + (map-result (gensym))) + `(let ((,map-result (list nil))) + (do-anonymous ((,temp ,map-result) . ,(do-clauses)) + (,endtest (truly-the list (cdr ,map-result))) + (rplacd ,temp (setq ,temp (list ,call))))))) + ((nil) + `(let ((,n-first ,(first arglists))) + (do-anonymous ,(do-clauses) + (,endtest (truly-the list ,n-first)) + ,call))))))))) (define-source-transform mapc (function list &rest more-lists) (mapfoo-transform function (cons list more-lists) nil t)) @@ -292,55 +291,111 @@ (or end length) (sb!impl::signal-bounding-indices-bad-error vector start end))))) -(macrolet ((def (name) - `(deftransform ,name ((e l &key (test #'eql)) * * - :node node) - (unless (constant-lvar-p l) - (give-up-ir1-transform)) - - (let ((val (lvar-value l))) - (unless (policy node - (or (= speed 3) - (and (>= speed space) - (<= (length val) 5)))) - (give-up-ir1-transform)) - - (labels ((frob (els) - (if els - `(if (funcall test e ',(car els)) - ',els - ,(frob (cdr els))) - nil))) - (frob val)))))) - (def member) - (def memq)) - -;;; FIXME: We have rewritten the original code that used DOLIST to this -;;; more natural MACROLET. However, the original code suggested that when -;;; this was done, a few bytes could be saved by a call to a shared -;;; function. This remains to be done. -(macrolet ((def (fun eq-fun) - `(deftransform ,fun ((item list &key test) (t list &rest t) *) - "convert to EQ test" - ;; FIXME: The scope of this transformation could be - ;; widened somewhat, letting it work whenever the test is - ;; 'EQL and we know from the type of ITEM that it #'EQ - ;; works like #'EQL on it. (E.g. types FIXNUM, CHARACTER, - ;; and SYMBOL.) - ;; If TEST is EQ, apply transform, else - ;; if test is not EQL, then give up on transform, else - ;; if ITEM is not a NUMBER or is a FIXNUM, apply - ;; transform, else give up on transform. - (cond (test - (unless (lvar-fun-is test '(eq)) - (give-up-ir1-transform))) - ((types-equal-or-intersect (lvar-type item) - (specifier-type 'number)) - (give-up-ir1-transform "Item might be a number."))) - `(,',eq-fun item list)))) - (def delete delq) - (def assoc assq) - (def member memq)) +(defun specialized-list-seek-function-name (function-name key-functions) + (or (find-symbol (with-output-to-string (s) + ;; Write "%NAME-FUN1-FUN2-FUN3", etc. Not only is + ;; this ever so slightly faster then FORMAT, this + ;; way we are also proof against *PRINT-CASE* + ;; frobbing and such. + (write-char #\% s) + (write-string (symbol-name function-name) s) + (dolist (f key-functions) + (write-char #\- s) + (write-string (symbol-name f) s))) + (load-time-value (find-package "SB!KERNEL"))) + (bug "Unknown list item seek transform: name=~S, key-functions=~S" + function-name key-functions))) + +(defun transform-list-item-seek (name list key test test-not node) + ;; Key can legally be NIL, but if it's NIL for sure we pretend it's + ;; not there at all. If it might be NIL, make up a form to that + ;; ensure it is a function. + (multiple-value-bind (key key-form) + (if key + (let ((key-type (lvar-type key)) + (null-type (specifier-type 'null))) + (cond ((csubtypep key-type null-type) + (values nil nil)) + ((csubtypep null-type key-type) + (values key '(if key + (%coerce-callable-to-fun key) + #'identity))) + (t + (values key '(%coerce-callable-to-fun key)))))) + (let* ((funs (remove nil (list (and key 'key) (cond (test 'test) + (test-not 'test-not))))) + (target-expr (if key '(%funcall key target) 'target)) + (test-expr (cond (test `(%funcall test item ,target-expr)) + (test-not `(not (%funcall test-not item ,target-expr))) + (t `(eql item ,target-expr))))) + (labels ((open-code (tail) + (when tail + `(if (let ((this ',(car tail))) + ,(ecase name + (assoc + `(and this (let ((target (car this))) + ,test-expr))) + (member + `(let ((target this)) + ,test-expr)))) + ',(ecase name + (assoc (car tail)) + (member tail)) + ,(open-code (cdr tail))))) + (ensure-fun (fun) + (if (eq 'key fun) + key-form + `(%coerce-callable-to-fun ,fun)))) + (let* ((cp (constant-lvar-p list)) + (c-list (when cp (lvar-value list)))) + (cond ((and cp c-list (policy node (>= speed space))) + `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs) + ,(open-code c-list))) + ((and cp (not c-list)) + ;; constant nil list -- nothing to find! + nil) + (t + ;; specialized out-of-line version + `(,(specialized-list-seek-function-name name funs) + item list ,@(mapcar #'ensure-fun funs))))))))) + +(deftransform member ((item list &key key test test-not) * * :node node) + (transform-list-item-seek 'member list key test test-not node)) + +(deftransform assoc ((item list &key key test test-not) * * :node node) + (transform-list-item-seek 'assoc list key test test-not node)) + +(deftransform memq ((item list) (t (constant-arg list))) + (labels ((rec (tail) + (if tail + `(if (eq item ',(car tail)) + ',tail + ,(rec (cdr tail))) + nil))) + (rec (lvar-value list)))) + +;;; A similar transform used to apply to MEMBER and ASSOC, but since +;;; TRANSFORM-LIST-ITEM-SEEK now takes care of them those transform +;;; would never fire, and (%MEMBER-TEST ITEM LIST #'EQ) should be +;;; almost as fast as MEMQ. +(deftransform delete ((item list &key test) (t list &rest t) *) + "convert to EQ test" + ;; FIXME: The scope of this transformation could be + ;; widened somewhat, letting it work whenever the test is + ;; 'EQL and we know from the type of ITEM that it #'EQ + ;; works like #'EQL on it. (E.g. types FIXNUM, CHARACTER, + ;; and SYMBOL.) + ;; If TEST is EQ, apply transform, else + ;; if test is not EQL, then give up on transform, else + ;; if ITEM is not a NUMBER or is a FIXNUM, apply + ;; transform, else give up on transform. + (cond (test + (unless (lvar-fun-is test '(eq)) + (give-up-ir1-transform))) + ((types-equal-or-intersect (lvar-type item) + (specifier-type 'number)) + (give-up-ir1-transform "Item might be a number."))) + `(delq item list)) (deftransform delete-if ((pred list) (t list)) "open code" @@ -403,205 +458,17 @@ (t (give-up-ir1-transform)))) -;;; FIXME: Why is this code commented out? (Why *was* it commented -;;; out? We inherited this situation from cmucl-2.4.8, with no -;;; explanation.) Should we just delete this code? -#| -;;; This is a frob whose job it is to make it easier to pass around -;;; the arguments to IR1 transforms. It bundles together the name of -;;; the argument (which should be referenced in any expansion), and -;;; the continuation for that argument (or NIL if unsupplied.) -(defstruct (arg (:constructor %make-arg (name cont)) - (:copier nil)) - (name nil :type symbol) - (cont nil :type (or continuation null))) -(defmacro make-arg (name) - `(%make-arg ',name ,name)) - -;;; If Arg is null or its CONT is null, then return Default, otherwise -;;; return Arg's NAME. -(defun default-arg (arg default) - (declare (type (or arg null) arg)) - (if (and arg (arg-cont arg)) - (arg-name arg) - default)) - -;;; If Arg is null or has no CONT, return the default. Otherwise, Arg's -;;; CONT must be a constant continuation whose value we return. If not, we -;;; give up. -(defun arg-constant-value (arg default) - (declare (type (or arg null) arg)) - (if (and arg (arg-cont arg)) - (let ((cont (arg-cont arg))) - (unless (constant-continuation-p cont) - (give-up-ir1-transform "Argument is not constant: ~S." - (arg-name arg))) - (continuation-value from-end)) - default)) - -;;; If Arg is a constant and is EQL to X, then return T, otherwise NIL. If -;;; Arg is NIL or its CONT is NIL, then compare to the default. -(defun arg-eql (arg default x) - (declare (type (or arg null) x)) - (if (and arg (arg-cont arg)) - (let ((cont (arg-cont arg))) - (and (constant-continuation-p cont) - (eql (continuation-value cont) x))) - (eql default x))) - -(defstruct (iterator (:copier nil)) - ;; The kind of iterator. - (kind nil (member :normal :result)) - ;; A list of LET* bindings to create the initial state. - (binds nil :type list) - ;; A list of declarations for Binds. - (decls nil :type list) - ;; A form that returns the current value. This may be set with SETF to set - ;; the current value. - (current (error "Must specify CURRENT.")) - ;; In a :NORMAL iterator, a form that tests whether there is a current value. - (done nil) - ;; In a :RESULT iterator, a form that truncates the result at the current - ;; position and returns it. - (result nil) - ;; A form that returns the initial total number of values. The result is - ;; undefined after NEXT has been evaluated. - (length (error "Must specify LENGTH.")) - ;; A form that advances the state to the next value. It is an error to call - ;; this when the iterator is Done. - (next (error "Must specify NEXT."))) - -;;; Type of an index var that can go negative (in the from-end case.) -(deftype neg-index () - `(integer -1 ,most-positive-fixnum)) - -;;; Return an ITERATOR structure describing how to iterate over an arbitrary -;;; sequence. Sequence is a variable bound to the sequence, and Type is the -;;; type of the sequence. If true, INDEX is a variable that should be bound to -;;; the index of the current element in the sequence. -;;; -;;; If we can't tell whether the sequence is a list or a vector, or whether -;;; the iteration is forward or backward, then GIVE-UP. -(defun make-sequence-iterator (sequence type &key start end from-end index) - (declare (symbol sequence) (type ctype type) - (type (or arg null) start end from-end) - (type (or symbol null) index)) - (let ((from-end (arg-constant-value from-end nil))) - (cond ((csubtypep type (specifier-type 'vector)) - (let* ((n-stop (gensym)) - (n-idx (or index (gensym))) - (start (default-arg 0 start)) - (end (default-arg `(length ,sequence) end))) - (make-iterator - :kind :normal - :binds `((,n-idx ,(if from-end `(1- ,end) ,start)) - (,n-stop ,(if from-end `(1- ,start) ,end))) - :decls `((type neg-index ,n-idx ,n-stop)) - :current `(aref ,sequence ,n-idx) - :done `(,(if from-end '<= '>=) ,n-idx ,n-stop) - :next `(setq ,n-idx - ,(if from-end `(1- ,n-idx) `(1+ ,n-idx))) - :length (if from-end - `(- ,n-idx ,n-stop) - `(- ,n-stop ,n-idx))))) - ((csubtypep type (specifier-type 'list)) - (let* ((n-stop (if (and end (not from-end)) (gensym) nil)) - (n-current (gensym)) - (start-p (not (arg-eql start 0 0))) - (end-p (not (arg-eql end nil nil))) - (start (default-arg start 0)) - (end (default-arg end nil))) - (make-iterator - :binds `((,n-current - ,(if from-end - (if (or start-p end-p) - `(nreverse (subseq ,sequence ,start - ,@(when end `(,end)))) - `(reverse ,sequence)) - (if start-p - `(nthcdr ,start ,sequence) - sequence))) - ,@(when n-stop - `((,n-stop (nthcdr (the index - (- ,end ,start)) - ,n-current)))) - ,@(when index - `((,index ,(if from-end `(1- ,end) start))))) - :kind :normal - :decls `((list ,n-current ,n-end) - ,@(when index `((type neg-index ,index)))) - :current `(car ,n-current) - :done `(eq ,n-current ,n-stop) - :length `(- ,(or end `(length ,sequence)) ,start) - :next `(progn - (setq ,n-current (cdr ,n-current)) - ,@(when index - `((setq ,n-idx - ,(if from-end - `(1- ,index) - `(1+ ,index))))))))) - (t - (give-up-ir1-transform - "can't tell whether sequence is a list or a vector"))))) - -;;; Make an iterator used for constructing result sequences. Name is a -;;; variable to be bound to the result sequence. Type is the type of result -;;; sequence to make. Length is an expression to be evaluated to get the -;;; maximum length of the result (not evaluated in list case.) -(defun make-result-sequence-iterator (name type length) - (declare (symbol name) (type ctype type)) - -;;; Define each NAME as a local macro that will call the value of the -;;; function arg with the given arguments. If the argument isn't known to be a -;;; function, give them an efficiency note and reference a coerced version. -(defmacro coerce-funs (specs &body body) - #!+sb-doc - "COERCE-FUNCTIONS ({(Name Fun-Arg Default)}*) Form*" - (collect ((binds) - (defs)) - (dolist (spec specs) - `(let ((body (progn ,@body)) - (n-fun (arg-name ,(second spec))) - (fun-cont (arg-cont ,(second spec)))) - (cond ((not fun-cont) - `(macrolet ((,',(first spec) (&rest args) - `(,',',(third spec) ,@args))) - ,body)) - ((not (csubtypep (continuation-type fun-cont) - (specifier-type 'function))) - (when (policy *compiler-error-context* - (> speed inhibit-warnings)) - (compiler-notify - "~S may not be a function, so must coerce at run-time." - n-fun)) - (once-only ((n-fun `(if (functionp ,n-fun) - ,n-fun - (symbol-function ,n-fun)))) - `(macrolet ((,',(first spec) (&rest args) - `(funcall ,',n-fun ,@args))) - ,body))) - (t - `(macrolet ((,',(first spec) (&rest args) - `(funcall ,',n-fun ,@args))) - ,body))))))) - -;;; Wrap code around the result of the body to define Name as a local macro -;;; that returns true when its arguments satisfy the test according to the Args -;;; Test and Test-Not. If both Test and Test-Not are supplied, abort the -;;; transform. -(defmacro with-sequence-test ((name test test-not) &body body) - `(let ((not-p (arg-cont ,test-not))) - (when (and (arg-cont ,test) not-p) - (abort-ir1-transform "Both ~S and ~S were supplied." - (arg-name ,test) - (arg-name ,test-not))) - (coerce-funs ((,name (if not-p ,test-not ,test) eql)) - ,@body))) -|# - + ;;;; hairy sequence transforms ;;; FIXME: no hairy sequence transforms in SBCL? +;;; +;;; There used to be a bunch of commented out code about here, +;;; containing the (apparent) beginning of hairy sequence transform +;;; infrastructure. People interested in implementing better sequence +;;; transforms might want to look at it for inspiration, even though +;;; the actual code is ancient CMUCL -- and hence bitrotted. The code +;;; was deleted in 1.0.7.23. ;;;; string operations @@ -663,21 +530,10 @@ (def string/=* identity)) -;;;; string-only transforms for sequence functions -;;;; -;;;; Note: CMU CL had more of these, including transforms for -;;;; functions which cons. In SBCL, we've gotten rid of most of the -;;;; transforms for functions which cons, since our GC overhead is -;;;; sufficiently large that it doesn't seem worth it to try to -;;;; economize on function call overhead or on the overhead of runtime -;;;; type dispatch in AREF. The exception is CONCATENATE, since -;;;; a full call to CONCATENATE would have to look up the sequence -;;;; type, which can be really slow. - -;;; Moved here from generic/vm-tran.lisp to satisfy clisp -;;; -;;; FIXME: Add a comment telling whether this holds for all vectors -;;; or only for vectors based on simple arrays (non-adjustable, etc.). +;;;; transforms for sequence functions + +;;; Moved here from generic/vm-tran.lisp to satisfy clisp. Only applies +;;; to vectors based on simple arrays. (def!constant vector-data-bit-offset (* sb!vm:vector-data-offset sb!vm:n-word-bits)) @@ -695,89 +551,253 @@ (<= (sb!vm:saetp-n-bits saetp) sb!vm:n-word-bits))) ) ; EVAL-WHEN -;; FIXME: It turns out that this transform (for SIMPLE-BASE-STRINGS) -;; is critical for the performance of string streams. Make this -;; more explicit. +;;; FIXME: In the copy loops below, we code the loops in a strange +;;; fashion: +;;; +;;; (do ((i (+ src-offset length) (1- i))) +;;; ((<= i 0) ...) +;;; (... (aref foo (1- i)) ...)) +;;; +;;; rather than the more natural (and seemingly more efficient): +;;; +;;; (do ((i (1- (+ src-offset length)) (1- i))) +;;; ((< i 0) ...) +;;; (... (aref foo i) ...)) +;;; +;;; (more efficient because we don't have to do the index adjusting on +;;; every iteration of the loop) +;;; +;;; We do this to avoid a suboptimality in SBCL's backend. In the +;;; latter case, the backend thinks I is a FIXNUM (which it is), but +;;; when used as an array index, the backend thinks I is a +;;; POSITIVE-FIXNUM (which it is). However, since the backend thinks of +;;; these as distinct storage classes, it cannot coerce a move from a +;;; FIXNUM TN to a POSITIVE-FIXNUM TN. The practical effect of this +;;; deficiency is that we have two extra moves and increased register +;;; pressure, which can lead to some spectacularly bad register +;;; allocation. (sub-FIXME: the register allocation even with the +;;; strangely written loops is not always excellent, either...). Doing +;;; it the first way, above, means that I is always thought of as a +;;; POSITIVE-FIXNUM and there are no issues. +;;; +;;; Besides, the *-WITH-OFFSET machinery will fold those index +;;; adjustments in the first version into the array addressing at no +;;; performance penalty! + +;;; This transform is critical to the performance of string streams. If +;;; you tweak it, make sure that you compare the disassembly, if not the +;;; performance of, the functions implementing string streams +;;; (e.g. SB!IMPL::STRING-OUCH). (macrolet ((define-replace-transforms () (loop for saetp across sb!vm:*specialized-array-element-type-properties* - when (valid-bit-bash-saetp-p saetp) + for sequence-type = `(simple-array ,(sb!vm:saetp-specifier saetp) (*)) + unless (= (sb!vm:saetp-typecode saetp) sb!vm::simple-array-nil-widetag) collect - (let* ((sequence-type `(simple-array ,(sb!vm:saetp-specifier saetp) (*))) - (n-element-bits (sb!vm:saetp-n-bits saetp)) - (bash-function (intern (format nil "UB~D-BASH-COPY" n-element-bits) - (find-package "SB!KERNEL")))) - `(deftransform replace ((seq1 seq2 &key (start1 0) (start2 0) end1 end2) - (,sequence-type ,sequence-type &rest t) - ,sequence-type - :node node) - `(let* ((len1 (length seq1)) - (len2 (length seq2)) - (end1 (or end1 len1)) - (end2 (or end2 len2)) - (replace-len1 (- end1 start1)) - (replace-len2 (- end2 start2))) - ,(unless (policy node (= safety 0)) - `(progn - (unless (<= 0 start1 end1 len1) - (sb!impl::signal-bounding-indices-bad-error seq1 start1 end1)) - (unless (<= 0 start2 end2 len2) - (sb!impl::signal-bounding-indices-bad-error seq2 start2 end2)))) - (funcall (function ,',bash-function) - seq2 start2 - seq1 start1 - (min replace-len1 replace-len2)) - seq1))) + `(deftransform replace ((seq1 seq2 &key (start1 0) (start2 0) end1 end2) + (,sequence-type ,sequence-type &rest t) + ,sequence-type + :node node) + ,(cond + ((valid-bit-bash-saetp-p saetp) nil) + ;; If we're not bit-bashing, only allow cases where we + ;; can determine the order of copying up front. (There + ;; are actually more cases we can handle if we know the + ;; amount that we're copying, but this handles the + ;; common cases.) + (t '(unless (= (constant-value-or-lose start1 0) + (constant-value-or-lose start2 0)) + (give-up-ir1-transform)))) + `(let* ((len1 (length seq1)) + (len2 (length seq2)) + (end1 (or end1 len1)) + (end2 (or end2 len2)) + (replace-len1 (- end1 start1)) + (replace-len2 (- end2 start2))) + ,(unless (policy node (= safety 0)) + `(progn + (unless (<= 0 start1 end1 len1) + (sb!impl::signal-bounding-indices-bad-error seq1 start1 end1)) + (unless (<= 0 start2 end2 len2) + (sb!impl::signal-bounding-indices-bad-error seq2 start2 end2)))) + ,',(cond + ((valid-bit-bash-saetp-p saetp) + (let* ((n-element-bits (sb!vm:saetp-n-bits saetp)) + (bash-function (intern (format nil "UB~D-BASH-COPY" n-element-bits) + (find-package "SB!KERNEL")))) + `(funcall (function ,bash-function) seq2 start2 + seq1 start1 (min replace-len1 replace-len2)))) + (t + ;; We can expand the loop inline here because we + ;; would have given up the transform (see above) + ;; if we didn't have constant matching start + ;; indices. + '(do ((i start1 (1+ i)) + (end (+ start1 + (min replace-len1 replace-len2)))) + ((>= i end)) + (declare (optimize (insert-array-bounds-checks 0))) + (setf (aref seq1 i) (aref seq2 i))))) + seq1)) into forms finally (return `(progn ,@forms))))) (define-replace-transforms)) -(macrolet - ((define-subseq-transforms () - (loop for saetp across sb!vm:*specialized-array-element-type-properties* - when (valid-bit-bash-saetp-p saetp) - collect - (let* ((sequence-type `(simple-array ,(sb!vm:saetp-specifier saetp) (*))) - (n-element-bits (sb!vm:saetp-n-bits saetp)) - (bash-function (intern (format nil "UB~D-BASH-COPY" n-element-bits) - (find-package "SB!KERNEL")))) - `(deftransform subseq ((seq start &optional end) - (,sequence-type t &optional t) - ,sequence-type :node node) - `(let* ((length (length seq)) - (end (if end (min end length) length))) - ,(unless (policy node (= safety 0)) - `(progn - (unless (<= 0 start end length) - (sb!impl::signal-bounding-indices-bad-error seq start end)))) - (let* ((size (- end start)) - (result (make-array size :element-type ',',(sb!vm:saetp-specifier saetp)))) - (funcall (function ,',bash-function) - seq start result 0 size) - result)))) - into forms - finally (return `(progn ,@forms))))) - (define-subseq-transforms)) - -(macrolet - ((define-copy-seq-transforms () - (loop for saetp across sb!vm:*specialized-array-element-type-properties* - when (valid-bit-bash-saetp-p saetp) - collect - (let* ((sequence-type `(simple-array ,(sb!vm:saetp-specifier saetp) (*))) - (n-element-bits (sb!vm:saetp-n-bits saetp)) - (bash-function (intern (format nil "UB~D-BASH-COPY" n-element-bits) - (find-package "SB!KERNEL")))) - `(deftransform copy-seq ((seq) (,sequence-type) - ,sequence-type) - `(let* ((length (length seq)) - (result (make-array length :element-type ',',(sb!vm:saetp-specifier saetp)))) - (funcall (function ,',bash-function) - seq 0 result 0 length) - result))) - into forms - finally (return `(progn ,@forms))))) - (define-copy-seq-transforms)) +;;; Expand simple cases of UB-BASH-COPY inline. "simple" is +;;; defined as those cases where we are doing word-aligned copies from +;;; both the source and the destination and we are copying from the same +;;; offset from both the source and the destination. (The last +;;; condition is there so we can determine the direction to copy at +;;; compile time rather than runtime. Remember that UB-BASH-COPY +;;; acts like memmove, not memcpy.) These conditions may seem rather +;;; restrictive, but they do catch common cases, like allocating a (* 2 +;;; N)-size buffer and blitting in the old N-size buffer in. + +(defun frob-bash-transform (src src-offset + dst dst-offset + length n-elems-per-word) + (declare (ignore src dst length)) + (let ((n-bits-per-elem (truncate sb!vm:n-word-bits n-elems-per-word))) + (multiple-value-bind (src-word src-elt) + (truncate (lvar-value src-offset) n-elems-per-word) + (multiple-value-bind (dst-word dst-elt) + (truncate (lvar-value dst-offset) n-elems-per-word) + ;; Avoid non-word aligned copies. + (unless (and (zerop src-elt) (zerop dst-elt)) + (give-up-ir1-transform)) + ;; Avoid copies where we would have to insert code for + ;; determining the direction of copying. + (unless (= src-word dst-word) + (give-up-ir1-transform)) + ;; FIXME: The cross-compiler doesn't optimize TRUNCATE properly, + ;; so we have to do its work here. + `(let ((end (+ ,src-word ,(if (= n-elems-per-word 1) + 'length + `(truncate (the index length) ,n-elems-per-word))))) + (declare (type index end)) + ;; Handle any bits at the end. + (when (logtest length (1- ,n-elems-per-word)) + (let* ((extra (mod length ,n-elems-per-word)) + ;; FIXME: The shift amount on this ASH is + ;; *always* negative, but the backend doesn't + ;; have a NEGATIVE-FIXNUM primitive type, so we + ;; wind up with a pile of code that tests the + ;; sign of the shift count prior to shifting when + ;; all we need is a simple negate and shift + ;; right. Yuck. + (mask (ash #.(1- (ash 1 sb!vm:n-word-bits)) + (* (- extra ,n-elems-per-word) + ,n-bits-per-elem)))) + (setf (sb!kernel:%vector-raw-bits dst end) + (logior + (logandc2 (sb!kernel:%vector-raw-bits dst end) + (ash mask + ,(ecase sb!c:*backend-byte-order* + (:little-endian 0) + (:big-endian `(* (- ,n-elems-per-word extra) + ,n-bits-per-elem))))) + (logand (sb!kernel:%vector-raw-bits src end) + (ash mask + ,(ecase sb!c:*backend-byte-order* + (:little-endian 0) + (:big-endian `(* (- ,n-elems-per-word extra) + ,n-bits-per-elem))))))))) + ;; Copy from the end to save a register. + (do ((i end (1- i))) + ((<= i ,src-word)) + (setf (sb!kernel:%vector-raw-bits dst (1- i)) + (sb!kernel:%vector-raw-bits src (1- i))))))))) + +#.(loop for i = 1 then (* i 2) + collect `(deftransform ,(intern (format nil "UB~D-BASH-COPY" i) + "SB!KERNEL") + ((src src-offset + dst dst-offset + length) + ((simple-unboxed-array (*)) + (constant-arg index) + (simple-unboxed-array (*)) + (constant-arg index) + index) + *) + (frob-bash-transform src src-offset + dst dst-offset length + ,(truncate sb!vm:n-word-bits i))) into forms + until (= i sb!vm:n-word-bits) + finally (return `(progn ,@forms))) + +;;; We expand copy loops inline in SUBSEQ and COPY-SEQ if we're copying +;;; arrays with elements of size >= the word size. We do this because +;;; we know the arrays cannot alias (one was just consed), therefore we +;;; can determine at compile time the direction to copy, and for +;;; word-sized elements, UB-BASH-COPY will do a bit of +;;; needless checking to figure out what's going on. The same +;;; considerations apply if we are copying elements larger than the word +;;; size, with the additional twist that doing it inline is likely to +;;; cons far less than calling REPLACE and letting generic code do the +;;; work. +;;; +;;; However, we do not do this for elements whose size is < than the +;;; word size because we don't want to deal with any alignment issues +;;; inline. The UB*-BASH-COPY transforms might fix things up later +;;; anyway. + +(defun maybe-expand-copy-loop-inline (src src-offset dst dst-offset length + element-type) + (let ((saetp (find-saetp element-type))) + (aver saetp) + (if (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-word-bits) + (expand-aref-copy-loop src src-offset dst dst-offset length) + `(locally (declare (optimize (safety 0))) + (replace ,dst ,src :start1 ,dst-offset :start2 ,src-offset :end1 ,length))))) + +(defun expand-aref-copy-loop (src src-offset dst dst-offset length) + (if (eql src-offset dst-offset) + `(do ((i (+ ,src-offset ,length) (1- i))) + ((<= i ,src-offset)) + (declare (optimize (insert-array-bounds-checks 0))) + (setf (aref ,dst (1- i)) (aref ,src (1- i)))) + ;; KLUDGE: The compiler is not able to derive that (+ offset + ;; length) must be a fixnum, but arrives at (unsigned-byte 29). + ;; We, however, know it must be so, as by this point the bounds + ;; have already been checked. + `(do ((i (truly-the fixnum (+ ,src-offset ,length)) (1- i)) + (j (+ ,dst-offset ,length) (1- j))) + ((<= i ,src-offset)) + (declare (optimize (insert-array-bounds-checks 0)) + (type (integer 0 #.sb!xc:array-dimension-limit) j i)) + (setf (aref ,dst (1- j)) (aref ,src (1- i)))))) + +(deftransform subseq ((seq start &optional end) + ((or (simple-unboxed-array (*)) simple-vector) t &optional t) + * :node node) + (let ((array-type (lvar-type seq))) + (unless (array-type-p array-type) + (give-up-ir1-transform)) + (let ((element-type (type-specifier (array-type-specialized-element-type array-type)))) + `(let* ((length (length seq)) + (end (or end length))) + ,(unless (policy node (= safety 0)) + '(progn + (unless (<= 0 start end length) + (sb!impl::signal-bounding-indices-bad-error seq start end)))) + (let* ((size (- end start)) + (result (make-array size :element-type ',element-type))) + ,(maybe-expand-copy-loop-inline 'seq (if (constant-lvar-p start) + (lvar-value start) + 'start) + 'result 0 'size element-type) + result))))) + +(deftransform copy-seq ((seq) ((or (simple-unboxed-array (*)) simple-vector)) *) + (let ((array-type (lvar-type seq))) + (unless (array-type-p array-type) + (give-up-ir1-transform)) + (let ((element-type (type-specifier (array-type-specialized-element-type array-type)))) + `(let* ((length (length seq)) + (result (make-array length :element-type ',element-type))) + ,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type) + result)))) ;;; FIXME: it really should be possible to take advantage of the ;;; macros used in code/seq.lisp here to avoid duplication of code,