X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fcompiler-extras.lisp;h=140b563daca10a09ce1c9e23e1cdacf8bc0359a8;hb=4150a9f9936714c8a04fc2cd8ae6df26ec5f7db8;hp=0bbee06c4c6e85d7ea7f60a620cc5642c55ad5b3;hpb=18d4de696bc5063aad026ba62be613c7b07f5fc8;p=sbcl.git diff --git a/contrib/compiler-extras.lisp b/contrib/compiler-extras.lisp index 0bbee06..140b563 100644 --- a/contrib/compiler-extras.lisp +++ b/contrib/compiler-extras.lisp @@ -29,51 +29,124 @@ #+nil ; not tested yet.. (deftransform replace ((seq1 seq2 &key (start1 0) end1 (start2 0) end2) - (vector vector &key - (:start1 index) (:end1 (or index null)) - (:start2 index) (:end2 (or index null))) - * - ;; This is potentially an awfully big transform - ;; (if things like (EQ SEQ1 SEQ2) aren't known - ;; at runtime). We need to make it available - ;; inline, since otherwise there's no way to do - ;; it efficiently on all array types, but it - ;; probably doesn't belong inline all the time. - :policy (> speed (1+ space))) + (vector vector &key + (:start1 index) (:end1 (or index null)) + (:start2 index) (:end2 (or index null))) + * + ;; This is potentially an awfully big transform + ;; (if things like (EQ SEQ1 SEQ2) aren't known + ;; at runtime). We need to make it available + ;; inline, since otherwise there's no way to do + ;; it efficiently on all array types, but it + ;; probably doesn't belong inline all the time. + :policy (> speed (1+ space))) "open code" (let ((et1 (upgraded-element-type-specifier-or-give-up seq1)) - (et2 (upgraded-element-type-specifier-or-give-up seq2))) + (et2 (upgraded-element-type-specifier-or-give-up seq2))) `(let* ((n-copied (min (- end1 start1) (- end2 start2))) - (effective-end1 (+ start1 n-copied))) + (effective-end1 (+ start1 n-copied))) (if (eq seq1 seq2) - (with-array-data ((seq seq1) - (start (min start1 start2)) - (end (max end1 end2))) - (declare (type (simple-array ,et1 1) seq)) - (if (<= start1 start2) - (let ((index2 start2)) - (declare (type index index2)) - (loop for index1 of-type index - from start1 below effective-end1 do - (setf (aref seq index1) - (aref seq index2)) - (incf index2))) - (let ((index2 (1- end2))) - (declare (type (integer -2 #.most-positive-fixnum) index2)) - (loop for index1 of-type index-or-minus-1 - from (1- effective-end1) downto start1 do - (setf (aref seq index1) - (aref seq index2)) - (decf index2))))) - (with-array-data ((seq1 seq1) (start1 start1) (end1 end1)) - (declare (type (simple-array ,et1 1) seq1)) - (with-array-data ((seq2 seq2) (start2 start2) (end2 end2)) - (declare (type (simple-array ,et2 1) seq2)) + (with-array-data ((seq seq1) + (start (min start1 start2)) + (end (max end1 end2))) + (declare (type (simple-array ,et1 1) seq)) + (if (<= start1 start2) + (let ((index2 start2)) + (declare (type index index2)) + (loop for index1 of-type index + from start1 below effective-end1 do + (setf (aref seq index1) + (aref seq index2)) + (incf index2))) + (let ((index2 (1- end2))) + (declare (type (integer -2 #.most-positive-fixnum) index2)) + (loop for index1 of-type index-or-minus-1 + from (1- effective-end1) downto start1 do + (setf (aref seq index1) + (aref seq index2)) + (decf index2))))) + (with-array-data ((seq1 seq1) (start1 start1) (end1 end1)) + (declare (type (simple-array ,et1 1) seq1)) + (with-array-data ((seq2 seq2) (start2 start2) (end2 end2)) + (declare (type (simple-array ,et2 1) seq2)) (let ((index2 start2)) - (declare (type index index2)) - (loop for index1 of-type index - from start1 below effective-end1 do - (setf (aref seq index1) - (aref seq index2)) - (incf index2)))))) + (declare (type index index2)) + (loop for index1 of-type index + from start1 below effective-end1 do + (setf (aref seq index1) + (aref seq index2)) + (incf index2)))))) seq1))) + +;;; Boyer-Moore search for strings. +;;; +;;; TODO: +;;; * START/END keywords +;;; * a literal :TEST #'CHAR= or :TEST #'EQL is OK (also #'EQ) +;;; * fewer hardcoded constants +;;; * :FROM-END +;;; +;;; * investigate whether we can make this work with a hashtable and a +;;; default for "not in pattern" +(deftransform search ((pattern text) + (simple-base-string simple-base-string)) + (unless (constant-lvar-p pattern) + (give-up-ir1-transform)) + (let* ((pattern (lvar-value pattern)) + (bad-character (make-array 256 :element-type 'fixnum :initial-element (length pattern))) + (temp (make-array (length pattern) :element-type 'fixnum)) + (good-suffix (make-array (length pattern) :element-type 'fixnum :initial-element (1- (length pattern))))) + + (dotimes (i (1- (length pattern))) + (setf (aref bad-character (char-code (aref pattern i))) + (- (length pattern) 1 i))) + + (setf (aref temp (1- (length pattern))) (length pattern)) + (loop with g = (1- (length pattern)) + with f = (1- (length pattern)) ; XXXXXX? + for i downfrom (- (length pattern) 2) above 0 + if (and (> i g) + (< (aref temp (- (+ i (length pattern)) 1 f)) (- i g))) + do (setf (aref temp i) (aref temp (- (+ i (length pattern)) 1 f))) + else + do (progn + (when (< i g) + (setf g i)) + (setf f i) + (do () + ((not + (and (>= g 0) + (char= (aref pattern g) + (aref pattern (- (+ g (length pattern)) 1 f)))))) + (decf g)) + (setf (aref temp i) (- f g)))) + + (loop with j = 0 + for i downfrom (1- (length pattern)) to -1 + if (or (= i -1) (= (aref temp i) (1+ i))) + do (do () + ((>= j (- (length pattern) 1 i))) + (when (= (aref good-suffix j) (length pattern)) + (setf (aref good-suffix j) (- (length pattern) 1 i))) + (incf j))) + + (loop for i from 0 below (1- (length pattern)) + do (setf (aref good-suffix (- (length pattern) 1 (aref temp i))) + (- (length pattern) 1 i))) + + `(let ((good-suffix ,good-suffix) + (bad-character ,bad-character)) + (declare (optimize speed (safety 0))) + (block search + (do ((j 0)) + ((> j (- (length text) (length pattern)))) + (declare (fixnum j)) + (do ((i (1- (length pattern)) (1- i))) + ((< i 0) (return-from search j)) + (declare (fixnum i)) + (when (char/= (aref pattern i) (aref text (+ i j))) + (incf j (max (aref good-suffix i) + (+ (- (aref bad-character (char-code (aref text (+ i j)))) + (length pattern)) + (1+ i)))) + (return))))))))