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)))