Add :application-type parameter for save-lisp-and-die on Windows.
[sbcl.git] / 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))))))))