contrib/compiler-extras.lisp

   1 ;;;; The files
   2 ;;;;   compiler-extras.lisp
   3 ;;;;   code-extras.lisp
   4 ;;;; hold things that I (WHN) am working on which are sufficiently
   5 ;;;; closely tied to the system that they want to be under the same
   6 ;;;; revision control, but which aren't yet ready for prime time.
   7 ;;;;
   8 ;;;; Unless you like living dangerously, you don't want to be running
   9 ;;;; these. But there might be some value to looking at these files to
  10 ;;;; see whether I'm working on optimizing something whose performance
  11 ;;;; you care about, so that you can patch it, or write test cases for
  12 ;;;; it, or pester me to release it, or whatever.
  13 ;;;;
  14 ;;;; Throughout 0.6.x, these were mostly performance fixes. Fixes for
  15 ;;;; logical bugs tend to go straight into the system, but fixes for
  16 ;;;; performance problems can easily introduce logical bugs, and no
  17 ;;;; one's going to thank me for prematurely replacing old slow
  18 ;;;; correct code with new fast code that I haven't yet discovered to
  19 ;;;; be wrong.
  20
  21 (in-package "SB-C")
  22
  23 (declaim (optimize (speed 1) (space 2)))
  24
  25 ;;; TO DO for DEFTRANSFORM FILL:
  26 ;;;   ?? This DEFTRANSFORM, and the old DEFTRANSFORMs, should only
  27 ;;;      apply when SPEED > SPACE.
  28 ;;;   ?? Add test cases.
  29
  30 #+nil ; not tested yet..
  31 (deftransform replace ((seq1 seq2 &key (start1 0) end1 (start2 0) end2)
  32                        (vector vector &key
  33                                (:start1 index) (:end1 (or index null))
  34                                (:start2 index) (:end2 (or index null)))
  35                        *
  36                        ;; This is potentially an awfully big transform
  37                        ;; (if things like (EQ SEQ1 SEQ2) aren't known
  38                        ;; at runtime). We need to make it available
  39                        ;; inline, since otherwise there's no way to do
  40                        ;; it efficiently on all array types, but it
  41                        ;; probably doesn't belong inline all the time.
  42                        :policy (> speed (1+ space)))
  43   "open code"
  44   (let ((et1 (upgraded-element-type-specifier-or-give-up seq1))
  45         (et2 (upgraded-element-type-specifier-or-give-up seq2)))
  46     `(let* ((n-copied (min (- end1 start1) (- end2 start2)))
  47             (effective-end1 (+ start1 n-copied)))
  48        (if (eq seq1 seq2)
  49            (with-array-data ((seq seq1)
  50                              (start (min start1 start2))
  51                              (end (max end1 end2)))
  52              (declare (type (simple-array ,et1 1) seq))
  53              (if (<= start1 start2)
  54                  (let ((index2 start2))
  55                    (declare (type index index2))
  56                    (loop for index1 of-type index
  57                          from start1 below effective-end1 do
  58                          (setf (aref seq index1)
  59                                (aref seq index2))
  60                          (incf index2)))
  61                  (let ((index2 (1- end2)))
  62                    (declare (type (integer -2 #.most-positive-fixnum) index2))
  63                    (loop for index1 of-type index-or-minus-1
  64                          from (1- effective-end1) downto start1 do
  65                          (setf (aref seq index1)
  66                                (aref seq index2))
  67                          (decf index2)))))
  68            (with-array-data ((seq1 seq1) (start1 start1) (end1 end1))
  69              (declare (type (simple-array ,et1 1) seq1))
  70              (with-array-data ((seq2 seq2) (start2 start2) (end2 end2))
  71                (declare (type (simple-array ,et2 1) seq2))
  72                (let ((index2 start2))
  73                  (declare (type index index2))
  74                  (loop for index1 of-type index
  75                        from start1 below effective-end1 do
  76                        (setf (aref seq index1)
  77                              (aref seq index2))
  78                        (incf index2))))))
  79        seq1)))
  80
  81 ;;; Boyer-Moore search for strings.
  82 ;;;
  83 ;;; TODO:
  84 ;;; * START/END keywords
  85 ;;; * a literal :TEST #'CHAR= or :TEST #'EQL is OK (also #'EQ)
  86 ;;; * fewer hardcoded constants
  87 ;;; * :FROM-END
  88 ;;;
  89 ;;; * investigate whether we can make this work with a hashtable and a
  90 ;;; default for "not in pattern"
  91 (deftransform search ((pattern text)
  92                       (simple-base-string simple-base-string))
  93   (unless (constant-lvar-p pattern)
  94     (give-up-ir1-transform))
  95   (let* ((pattern (lvar-value pattern))
  96          (bad-character (make-array 256 :element-type 'fixnum :initial-element (length pattern)))
  97          (temp (make-array (length pattern) :element-type 'fixnum))
  98          (good-suffix (make-array (length pattern) :element-type 'fixnum :initial-element (1- (length pattern)))))
  99
 100     (dotimes (i (1- (length pattern)))
 101       (setf (aref bad-character (char-code (aref pattern i)))
 102             (- (length pattern) 1 i)))
 103
 104     (setf (aref temp (1- (length pattern))) (length pattern))
 105     (loop with g = (1- (length pattern))
 106           with f = (1- (length pattern)) ; XXXXXX?
 107           for i downfrom (- (length pattern) 2) above 0
 108           if (and (> i g)
 109                   (< (aref temp (- (+ i (length pattern)) 1 f)) (- i g)))
 110           do (setf (aref temp i) (aref temp (- (+ i (length pattern)) 1 f)))
 111           else
 112           do (progn
 113                (when (< i g)
 114                  (setf g i))
 115                (setf f i)
 116                (do ()
 117                    ((not
 118                      (and (>= g 0)
 119                          (char= (aref pattern g)
 120                                 (aref pattern (- (+ g (length pattern)) 1 f))))))
 121                  (decf g))
 122                (setf (aref temp i) (- f g))))
 123
 124     (loop with j = 0
 125           for i downfrom (1- (length pattern)) to -1
 126           if (or (= i -1) (= (aref temp i) (1+ i)))
 127           do (do ()
 128                  ((>= j (- (length pattern) 1 i)))
 129                (when (= (aref good-suffix j) (length pattern))
 130                  (setf (aref good-suffix j) (- (length pattern) 1 i)))
 131                (incf j)))
 132
 133     (loop for i from 0 below (1- (length pattern))
 134           do (setf (aref good-suffix (- (length pattern) 1 (aref temp i)))
 135                    (- (length pattern) 1 i)))
 136
 137     `(let ((good-suffix ,good-suffix)
 138            (bad-character ,bad-character))
 139       (declare (optimize speed (safety 0)))
 140       (block search
 141         (do ((j 0))
 142             ((> j (- (length text) (length pattern))))
 143           (declare (fixnum j))
 144           (do ((i (1- (length pattern)) (1- i)))
 145               ((< i 0) (return-from search j))
 146             (declare (fixnum i))
 147             (when (char/= (aref pattern i) (aref text (+ i j)))
 148               (incf j (max (aref good-suffix i)
 149                            (+ (- (aref bad-character (char-code (aref text (+ i j))))
 150                                  (length pattern))
 151                               (1+ i))))
 152               (return))))))))