forked from dmitryvk/sbcl-win32-threads
/
compiler-extras.lisp
79 lines (75 loc) · 3.14 KB
/
compiler-extras.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
;;;; The files
;;;; compiler-extras.lisp
;;;; code-extras.lisp
;;;; hold things that I (WHN) am working on which are sufficiently
;;;; closely tied to the system that they want to be under the same
;;;; revision control, but which aren't yet ready for prime time.
;;;;
;;;; Unless you like living dangerously, you don't want to be running
;;;; these. But there might be some value to looking at these files to
;;;; see whether I'm working on optimizing something whose performance
;;;; you care about, so that you can patch it, or write test cases for
;;;; it, or pester me to release it, or whatever.
;;;;
;;;; Throughout 0.6.x, these were mostly performance fixes. Fixes for
;;;; logical bugs tend to go straight into the system, but fixes for
;;;; performance problems can easily introduce logical bugs, and no
;;;; one's going to thank me for prematurely replacing old slow
;;;; correct code with new fast code that I haven't yet discovered to
;;;; be wrong.
(in-package "SB-C")
(declaim (optimize (speed 1) (space 2)))
;;; TO DO for DEFTRANSFORM FILL:
;;; ?? This DEFTRANSFORM, and the old DEFTRANSFORMs, should only
;;; apply when SPEED > SPACE.
;;; ?? Add test cases.
#+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)))
"open code"
(let ((et1 (upgraded-element-type-specifier-or-give-up seq1))
(et2 (upgraded-element-type-specifier-or-give-up seq2)))
`(let* ((n-copied (min (- end1 start1) (- end2 start2)))
(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))
(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))))))
seq1)))