2 ;;;; compiler-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.
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.
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
23 (declaim (optimize (speed 1) (space 2)))
25 ;;; TO DO for DEFTRANSFORM FILL:
26 ;;; ?? This DEFTRANSFORM, and the old DEFTRANSFORMs, should only
27 ;;; apply when SPEED > SPACE.
28 ;;; ?? Add test cases.
30 #+nil
; not tested yet..
31 (deftransform replace
((seq1 seq2
&key
(start1 0) end1
(start2 0) end2
)
33 (:start1 index
) (:end1
(or index null
))
34 (:start2 index
) (:end2
(or index null
)))
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
)))
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
)))
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
)
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
)
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
)
81 ;;; Boyer-Moore search for strings.
84 ;;; * START/END keywords
85 ;;; * a literal :TEST #'CHAR= or :TEST #'EQL is OK (also #'EQ)
86 ;;; * fewer hardcoded constants
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
)))))
100 (dotimes (i (1- (length pattern
)))
101 (setf (aref bad-character
(char-code (aref pattern i
)))
102 (- (length pattern
) 1 i
)))
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
109 (< (aref temp
(- (+ i
(length pattern
)) 1 f
)) (- i g
)))
110 do
(setf (aref temp i
) (aref temp
(- (+ i
(length pattern
)) 1 f
)))
119 (char= (aref pattern g
)
120 (aref pattern
(- (+ g
(length pattern
)) 1 f
))))))
122 (setf (aref temp i
) (- f g
))))
125 for i downfrom
(1- (length pattern
)) to -
1
126 if
(or (= i -
1) (= (aref temp i
) (1+ i
)))
128 ((>= j
(- (length pattern
) 1 i
)))
129 (when (= (aref good-suffix j
) (length pattern
))
130 (setf (aref good-suffix j
) (- (length pattern
) 1 i
)))
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
)))
137 `(let ((good-suffix ,good-suffix
)
138 (bad-character ,bad-character
))
139 (declare (optimize speed
(safety 0)))
142 ((> j
(- (length text
) (length pattern
))))
144 (do ((i (1- (length pattern
)) (1- i
)))
145 ((< i
0) (return-from search j
))
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
))))
155 ;;; Scan all functions that take funargs, looking to see whether the funarg
156 ;;; is declared as downward (dynamic-extent) or assumed possibly upward.
157 ;;; Print the names of functions for which the number of funargs differs
158 ;;; from the number of DX args. (This is a way to scan for missing decls)
159 ;;; In an ideal world, the compiler would infer that a funarg can be allocated
160 ;;; with dynamic-extent based on it only appearing as the first argument
161 ;;; to FUNCALL/APPLY, and not being closed over.
162 ;;; But we don't need ideal, we just need good enough.
163 (flet ((fun-funargs-count (type)
164 (flet ((funlike-type-p (x)
165 (or (csubtypep x
(specifier-type 'function
))
166 (type= x
(specifier-type '(or function null
)))
167 (type= x
(specifier-type '(or function symbol
))))))
168 (+ (count-if #'funlike-type-p
(fun-type-required type
))
169 (count-if #'funlike-type-p
(fun-type-optional type
))
170 (count-if (lambda (x) (funlike-type-p (key-info-type x
)))
171 (fun-type-keywords type
))))))
173 (format t
"~[CL symbols~;other symbols~]:~%" pass
)
177 (eq (symbol-package s
) (find-package "CL"))
178 (neq (symbol-package s
) (find-package "CL")))
179 (let ((type (info :function
:type s
)))
181 (not (eq type
(find-classoid 'function
)))
182 (not (typep type
'defstruct-description
))
183 (not (eq type
:generic-function
)))
184 (let ((n-funargs (fun-funargs-count type
)))
185 (when (plusp n-funargs
)
187 (let ((info (info :function
:inlining-data s
)))
188 (when (typep info
'dxable-args
)
189 (dxable-args-list info
)))))
190 (unless (= n-funargs
(length dxable-args
))
191 (push (list (length dxable-args
) n-funargs s
)
193 (dolist (x (sort result
#'string
< :key
'third
))
194 (format t
"~{ ~d ~d ~a~}~%" x
)))))