X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fseqtran.lisp;h=b20f4db127ee576e588499bef7c77afbb4f8ebc4;hb=5cc68148d1a5f9bacf4eb12e396b680d992fc2c2;hp=c0ae9dcc3c1f5f3af5f3c6a964cfe5d023e354e2;hpb=902e93736a0888aa6b04dc328b1eb328423bf426;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index c0ae9dc..b20f4db 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -79,14 +79,14 @@ (deftransform map ((result-type-arg fun seq &rest seqs) * * :node node) (let* ((seq-names (make-gensym-list (1+ (length seqs)))) (bare `(%map result-type-arg fun ,@seq-names)) - (constant-result-type-arg-p (constant-continuation-p result-type-arg)) + (constant-result-type-arg-p (constant-lvar-p result-type-arg)) ;; what we know about the type of the result. (Note that the ;; "result type" argument is not necessarily the type of the ;; result, since NIL means the result has NULL type.) (result-type (if (not constant-result-type-arg-p) 'consed-sequence (let ((result-type-arg-value - (continuation-value result-type-arg))) + (lvar-value result-type-arg))) (if (null result-type-arg-value) 'null result-type-arg-value))))) @@ -122,8 +122,8 @@ bare)))))))) ;;; Return a DO loop, mapping a function FUN to elements of -;;; sequences. SEQS is a list of continuations, SEQ-NAMES - list of -;;; variables, bound to sequences, INTO - a variable, which is used in +;;; sequences. SEQS is a list of lvars, SEQ-NAMES - list of variables, +;;; bound to sequences, INTO - a variable, which is used in ;;; MAP-INTO. RESULT and BODY are forms, which can use variables ;;; FUNCALL-RESULT, containing the result of application of FUN, and ;;; INDEX, containing the current position in sequences. @@ -142,9 +142,9 @@ (bindings `(index 0 (1+ index))) (declarations `(type index index))) (vector-lengths length))) - (loop for seq of-type continuation in seqs + (loop for seq of-type lvar in seqs for seq-name in seq-names - for type = (continuation-type seq) + for type = (lvar-type seq) do (cond ((csubtypep type (specifier-type 'list)) (with-unique-names (index) (bindings `(,index ,seq-name (cdr ,index))) @@ -184,7 +184,7 @@ (deftransform %map ((result-type fun seq &rest seqs) * * :policy (>= speed space)) "open code" - (unless (constant-continuation-p result-type) + (unless (constant-lvar-p result-type) (give-up-ir1-transform "RESULT-TYPE argument not constant")) (labels ( ;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true (fn-1subtypep (fn x y) @@ -194,7 +194,7 @@ (give-up-ir1-transform "can't analyze sequence type relationship")))) (1subtypep (x y) (fn-1subtypep #'sb!xc:subtypep x y))) - (let* ((result-type-value (continuation-value result-type)) + (let* ((result-type-value (lvar-value result-type)) (result-supertype (cond ((null result-type-value) 'null) ((1subtypep result-type-value 'vector) 'vector) @@ -293,10 +293,10 @@ (macrolet ((def (name) `(deftransform ,name ((e l &key (test #'eql)) * * :node node) - (unless (constant-continuation-p l) + (unless (constant-lvar-p l) (give-up-ir1-transform)) - (let ((val (continuation-value l))) + (let ((val (lvar-value l))) (unless (policy node (or (= speed 3) (and (>= speed space) @@ -330,9 +330,9 @@ ;; if ITEM is not a NUMBER or is a FIXNUM, apply ;; transform, else give up on transform. (cond (test - (unless (continuation-fun-is test '(eq)) + (unless (lvar-fun-is test '(eq)) (give-up-ir1-transform))) - ((types-equal-or-intersect (continuation-type item) + ((types-equal-or-intersect (lvar-type item) (specifier-type 'number)) (give-up-ir1-transform "Item might be a number."))) `(,',eq-fun item list)))) @@ -376,11 +376,11 @@ ;;;; utilities -;;; Return true if CONT's only use is a non-NOTINLINE reference to a +;;; Return true if LVAR's only use is a non-NOTINLINE reference to a ;;; global function with one of the specified NAMES. -(defun continuation-fun-is (cont names) - (declare (type continuation cont) (list names)) - (let ((use (continuation-use cont))) +(defun lvar-fun-is (lvar names) + (declare (type lvar lvar) (list names)) + (let ((use (lvar-uses lvar))) (and (ref-p use) (let ((leaf (ref-leaf use))) (and (global-var-p leaf) @@ -388,16 +388,16 @@ (not (null (member (leaf-source-name leaf) names :test #'equal)))))))) -;;; If CONT is a constant continuation, the return the constant value. -;;; If it is null, then return default, otherwise quietly give up the -;;; IR1 transform. +;;; If LVAR is a constant lvar, the return the constant value. If it +;;; is null, then return default, otherwise quietly give up the IR1 +;;; transform. ;;; ;;; ### Probably should take an ARG and flame using the NAME. -(defun constant-value-or-lose (cont &optional default) - (declare (type (or continuation null) cont)) - (cond ((not cont) default) - ((constant-continuation-p cont) - (continuation-value cont)) +(defun constant-value-or-lose (lvar &optional default) + (declare (type (or lvar null) lvar)) + (cond ((not lvar) default) + ((constant-lvar-p lvar) + (lvar-value lvar)) (t (give-up-ir1-transform)))) @@ -624,14 +624,16 @@ ;;; must be SIMPLE-BASE-STRINGs. (macrolet ((def (name lessp equalp) `(deftransform ,name ((string1 string2 start1 end1 start2 end2) - (simple-base-string simple-base-string t t t t) *) + (simple-base-string simple-base-string t t t t) *) `(let* ((end1 (if (not end1) (length string1) end1)) (end2 (if (not end2) (length string2) end2)) (index (sb!impl::%sp-string-compare string1 start1 end1 string2 start2 end2))) (if index - (cond ((= index ,(if ',lessp 'end1 'end2)) index) - ((= index ,(if ',lessp 'end2 'end1)) nil) + (cond ((= index end1) + ,(if ',lessp 'index nil)) + ((= (+ index (- start2 start1)) end2) + ,(if ',lessp nil 'index)) ((,(if ',lessp 'char< 'char>) (schar string1 index) (schar string2 @@ -639,9 +641,9 @@ (+ index (truly-the fixnum (- start2 - start1)))))) + start1)))))) index) - (t nil)) + (t nil)) ,(if ',equalp 'end1 nil)))))) (def string<* t nil) (def string<=* t t) @@ -712,14 +714,63 @@ sb!vm:n-byte-bits))) string1)) +;;; KLUDGE: This isn't the nicest way of achieving efficient string +;;; streams, but it does work; a more general framework for this kind +;;; of optimization, as well as better handling of the possible +;;; keyword arguments, would be nice. +#!+sb-unicode +(deftransform replace ((string1 string2 &key (start1 0) (start2 0) + end1 end2) + ((simple-array character (*)) + (simple-array character (*)) + &rest t) + * + ;; FIXME: consider replacing this policy test + ;; with some tests for the STARTx and ENDx + ;; indices being valid, conditional on high + ;; SAFETY code. + ;; + ;; FIXME: It turns out that this transform is + ;; critical for the performance of string + ;; streams. Make this more explicit. + :policy (< (max safety space) 3)) + `(sb!impl::simple-character-string-replace-from-simple-character-string* + string1 string2 start1 end1 start2 end2)) + +;;; FIXME: this would be a valid transform for certain excluded cases: +;;; * :TEST 'CHAR= or :TEST #'CHAR= +;;; * :TEST 'EQL or :TEST #'EQL +;;; * :FROM-END NIL (or :FROM-END non-NIL, with a little ingenuity) +(deftransform search ((pattern text &key (start1 0) (start2 0) end1 end2) + (simple-string simple-string &rest t) + * + :policy (> speed (max space safety))) + `(block search + (let ((end1 (or end1 (length pattern))) + (end2 (or end2 (length text)))) + (do ((index2 start2 (1+ index2))) + ((>= index2 end2) nil) + (when (do ((index1 start1 (1+ index1)) + (index2 index2 (1+ index2))) + ((>= index1 end1) t) + (when (= index2 end2) + (return-from search nil)) + (when (char/= (char pattern index1) (char text index2)) + (return nil))) + (return index2)))))) + ;;; FIXME: It seems as though it should be possible to make a DEFUN ;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to ;;; CTYPE before calling %CONCATENATE) which is comparably efficient, ;;; at least once DYNAMIC-EXTENT works. ;;; ;;; FIXME: currently KLUDGEed because of bug 188 +;;; +;;; FIXME: disabled for sb-unicode: probably want it back +#!-sb-unicode (deftransform concatenate ((rtype &rest sequences) - (t &rest simple-base-string) + (t &rest (or simple-base-string + (simple-array nil (*)))) simple-base-string :policy (< safety 3)) (loop for rest-seqs on sequences @@ -731,8 +782,11 @@ collect `(,n-length (* (length ,n-seq) sb!vm:n-byte-bits)) into lets collect n-length into all-lengths collect next-start into starts - collect `(bit-bash-copy ,n-seq ,vector-data-bit-offset - res ,start ,n-length) + collect `(if (and (typep ,n-seq '(simple-array nil (*))) + (> ,n-length 0)) + (error 'nil-array-accessed-error) + (bit-bash-copy ,n-seq ,vector-data-bit-offset + res ,start ,n-length)) into forms collect `(setq ,next-start (+ ,start ,n-length)) into forms finally @@ -741,7 +795,8 @@ (declare (ignore rtype)) (let* (,@lets (res (make-string (truncate (the index (+ ,@all-lengths)) - sb!vm:n-byte-bits)))) + sb!vm:n-byte-bits) + :element-type 'base-char))) (declare (type index ,@all-lengths)) (let (,@(mapcar (lambda (name) `(,name 0)) starts)) (declare (type index ,@starts)) @@ -751,7 +806,7 @@ ;;;; CONS accessor DERIVE-TYPE optimizers (defoptimizer (car derive-type) ((cons)) - (let ((type (continuation-type cons)) + (let ((type (lvar-type cons)) (null-type (specifier-type 'null))) (cond ((eq type null-type) null-type) @@ -759,7 +814,7 @@ (cons-type-car-type type))))) (defoptimizer (cdr derive-type) ((cons)) - (let ((type (continuation-type cons)) + (let ((type (lvar-type cons)) (null-type (specifier-type 'null))) (cond ((eq type null-type) null-type) @@ -772,12 +827,12 @@ ;;; %FIND-POSITION-IF only when %FIND-POSITION-IF has an inline ;;; expansion, so we factor out the condition into this function. (defun check-inlineability-of-find-position-if (sequence from-end) - (let ((ctype (continuation-type sequence))) + (let ((ctype (lvar-type sequence))) (cond ((csubtypep ctype (specifier-type 'vector)) ;; It's not worth trying to inline vector code unless we ;; know a fair amount about it at compile time. (upgraded-element-type-specifier-or-give-up sequence) - (unless (constant-continuation-p from-end) + (unless (constant-lvar-p from-end) (give-up-ir1-transform "FROM-END argument value not known at compile time"))) ((csubtypep ctype (specifier-type 'list)) @@ -792,8 +847,7 @@ `(deftransform ,name ((predicate sequence from-end start end key) (function list t t t function) * - :policy (> speed space) - :important t) + :policy (> speed space)) "expand inline" `(let ((index 0) (find nil) @@ -832,15 +886,14 @@ (incf index)))))) (def %find-position-if when) (def %find-position-if-not unless)) - + ;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF ;;; without loss of efficiency. (I.e., the optimizer should be able ;;; to straighten everything out.) (deftransform %find-position ((item sequence from-end start end key test) (t list t t t t t) * - :policy (> speed space) - :important t) + :policy (> speed space)) "expand inline" '(%find-position-if (let ((test-fun (%coerce-callable-to-fun test))) ;; The order of arguments for asymmetric tests @@ -933,8 +986,7 @@ (deftransform %find-position-if ((predicate sequence from-end start end key) (function vector t t t function) * - :policy (> speed space) - :important t) + :policy (> speed space)) "expand inline" (check-inlineability-of-find-position-if sequence from-end) '(%find-position-if-vector-macro predicate sequence @@ -943,8 +995,7 @@ (deftransform %find-position-if-not ((predicate sequence from-end start end key) (function vector t t t function) * - :policy (> speed space) - :important t) + :policy (> speed space)) "expand inline" (check-inlineability-of-find-position-if sequence from-end) '(%find-position-if-not-vector-macro predicate sequence @@ -953,8 +1004,7 @@ (deftransform %find-position ((item sequence from-end start end key test) (t vector t t t function function) * - :policy (> speed space) - :important t) + :policy (> speed space)) "expand inline" (check-inlineability-of-find-position-if sequence from-end) '(%find-position-vector-macro item sequence @@ -1026,8 +1076,8 @@ ;;; perhaps it's worth optimizing the -if-not versions in the same ;;; way as the others? ;;; -;;; FIXME: Maybe remove uses of these deprecated functions (and -;;; definitely of :TEST-NOT) within the implementation of SBCL. +;;; FIXME: Maybe remove uses of these deprecated functions within the +;;; implementation of SBCL. (macrolet ((define-find-position-if-not (fun-name values-index) `(deftransform ,fun-name ((predicate sequence &key from-end (start 0)