0.8.5.47:
[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)))