32 |
;;; that will eventually replace this preliminary effort. |
;;; that will eventually replace this preliminary effort. |
33 |
;;; |
;;; |
34 |
|
|
35 |
(declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals*)) |
(declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals* |
36 |
|
*opt-result* *unopt-result*)) |
37 |
|
|
38 |
|
(defvar *random-int-form-blocks* nil) |
39 |
|
|
40 |
(defun test-random-integer-forms (size nvars n) |
(defun test-random-integer-forms (size nvars n) |
41 |
|
|
58 |
(let* ((form (make-random-integer-form size vars)) |
(let* ((form (make-random-integer-form size vars)) |
59 |
(var-ranges (mapcar #'make-random-integer-range vars)) |
(var-ranges (mapcar #'make-random-integer-range vars)) |
60 |
(var-types (mapcar #'(lambda (range) |
(var-types (mapcar #'(lambda (range) |
61 |
`(integer ,(car range) ,(cadr range))) |
(let ((lo (car range)) |
62 |
|
(hi (cadr range))) |
63 |
|
(assert (>= hi lo)) |
64 |
|
`(integer ,lo ,hi))) |
65 |
var-ranges)) |
var-ranges)) |
66 |
(optimized-fn-src |
(vals-list |
67 |
`(lambda ,vars (declare ,@(mapcar #'(lambda (tp var) |
(loop repeat 20 |
68 |
`(type ,tp ,var)) |
collect |
|
var-types vars) |
|
|
(ignorable ,@vars) |
|
|
(optimize #+cmu (extensions:inhibit-warnings 3) |
|
|
(speed 3) (safety 1) (debug 1))) |
|
|
,form)) |
|
|
(unoptimized-fn-src |
|
|
`(lambda ,vars |
|
|
(declare (notinline ,@(fn-symbols-in-form form)) |
|
|
(optimize #+cmu (extensions:inhibit-warnings 3) |
|
|
(safety 3) (speed 0) (debug 3)) |
|
|
(ignorable ,@vars)) |
|
|
,form))) |
|
|
(setq *optimized-fn-src* optimized-fn-src |
|
|
*unoptimized-fn-src* unoptimized-fn-src) |
|
|
(#+sbcl handler-bind |
|
|
#+sbcl ((sb-ext::compiler-note #'muffle-warning)) |
|
|
#-sbcl progn |
|
|
(let ((optimized-compiled-fn (compile nil optimized-fn-src)) |
|
|
(unoptimized-compiled-fn (compile nil unoptimized-fn-src))) |
|
|
(dotimes (i 20 nil) |
|
|
(let ((vals |
|
69 |
(mapcar #'(lambda (range) |
(mapcar #'(lambda (range) |
70 |
(let ((lo (car range)) |
(let ((lo (car range)) |
71 |
(hi (cadr range))) |
(hi (cadr range))) |
72 |
(random-from-interval (1+ hi) lo))) |
(random-from-interval (1+ hi) lo))) |
73 |
var-ranges))) |
var-ranges)))) |
74 |
(setq *int-form-vals* vals) |
(test-int-form form vars var-types vals-list))) |
|
(let ((opt-result (apply unoptimized-compiled-fn vals)) |
|
|
(unopt-result (apply optimized-compiled-fn vals))) |
|
|
(if (equal opt-result unopt-result) |
|
|
nil |
|
|
(return (list (list vars vals |
|
|
unoptimized-fn-src |
|
|
optimized-fn-src |
|
|
))))))))))) |
|
75 |
|
|
76 |
(defun fn-symbols-in-form (form) |
(defun fn-symbols-in-form (form) |
77 |
"Return a list of the distinct standardized lisp function |
"Return a list of the distinct standardized lisp function |
79 |
declaration for the unoptimized form." |
declaration for the unoptimized form." |
80 |
(intersection |
(intersection |
81 |
(remove-duplicates (fn-symbols-in-form* form) :test #'eq) |
(remove-duplicates (fn-symbols-in-form* form) :test #'eq) |
82 |
*cl-function-symbols*)) |
*cl-function-or-accessor-symbols*)) |
83 |
|
|
84 |
(defun fn-symbols-in-form* (form) |
(defun fn-symbols-in-form* (form) |
85 |
(when (consp form) |
(when (consp form) |
91 |
"Generate a list (LO HI) of integers, LO <= HI. This is used |
"Generate a list (LO HI) of integers, LO <= HI. This is used |
92 |
for generating integer types." |
for generating integer types." |
93 |
(declare (ignore var)) |
(declare (ignore var)) |
94 |
(flet ((%r () (let ((r (ash 1 (1+ (random 32))))) |
(flet ((%r () (let ((r (ash 1 (1+ (random 35))))) |
95 |
(- (random r) (floor (/ r 2)))))) |
(- (random r) (floor (/ r 2)))))) |
96 |
(let ((x (%r)) |
(let ((x (%r)) |
97 |
(y (%r))) |
(y (%r))) |
107 |
(- (random r) (floor (/ r 2)))) |
(- (random r) (floor (/ r 2)))) |
108 |
(random-from-seq vars)) |
(random-from-seq vars)) |
109 |
;; (> size 1) |
;; (> size 1) |
110 |
(ecase (random 9) |
(rcase |
111 |
;; Unary ops |
;; Unary ops |
112 |
((0 1) |
(40 |
113 |
(let ((op (random-from-seq '(- abs signum 1+ 1- identity |
(let ((op (random-from-seq '(- abs abs signum signum 1+ 1- identity |
114 |
integer-length logcount)))) |
integer-length logcount)))) |
115 |
`(,op ,(make-random-integer-form (1- size) vars)))) |
`(,op ,(make-random-integer-form (1- size) vars)))) |
116 |
;; Binary op |
;; Binary op |
117 |
((2 3 4 5) |
(80 |
118 |
(let* ((op (random-from-seq |
(let* ((op (random-from-seq |
119 |
'(+ - * logand min max ;; gcd lcm |
'(+ - * logand min max min max ;; gcd lcm |
120 |
logandc1 logandc2 logeqv logior lognand lognor logorc1 |
#-:allegro logandc1 ;; bug in ACL 6.2 makes this cause crashes |
121 |
|
logandc2 logeqv logior lognand lognor logorc1 |
122 |
logorc2 logxor)))) |
logorc2 logxor)))) |
123 |
(destructuring-bind (leftsize rightsize) |
(destructuring-bind (leftsize rightsize) |
124 |
(random-partition (1- size) 2) |
(random-partition (1- size) 2) |
125 |
`(,op ,(make-random-integer-form leftsize vars) |
(let ((e1 (make-random-integer-form leftsize vars)) |
126 |
,(make-random-integer-form rightsize vars))))) |
(e2 (make-random-integer-form rightsize vars))) |
127 |
|
`(,op ,e1 ,e2))))) |
128 |
;; conditionals |
;; conditionals |
129 |
(6 |
(20 |
130 |
(let* ((cond-size (random (max 1 (floor size 2)))) |
(let* ((cond-size (random (max 1 (floor size 2)))) |
131 |
(then-size (random (- size cond-size))) |
(then-size (random (- size cond-size))) |
132 |
(else-size (- size 1 cond-size then-size)) |
(else-size (- size 1 cond-size then-size)) |
134 |
(then-part (make-random-integer-form then-size vars)) |
(then-part (make-random-integer-form then-size vars)) |
135 |
(else-part (make-random-integer-form else-size vars))) |
(else-part (make-random-integer-form else-size vars))) |
136 |
`(if ,pred ,then-part ,else-part))) |
`(if ,pred ,then-part ,else-part))) |
137 |
(7 |
(10 |
138 |
(destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) |
(destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) |
139 |
`(,(random-from-seq '(deposit-field dpb)) |
`(,(random-from-seq '(deposit-field dpb)) |
140 |
,(make-random-integer-form s1 vars) |
,(make-random-integer-form s1 vars) |
141 |
,(make-random-byte-spec-form s2 vars) |
,(make-random-byte-spec-form s2 vars) |
142 |
,(make-random-integer-form s3 vars)))) |
,(make-random-integer-form s3 vars)))) |
143 |
(8 |
(10 |
144 |
(destructuring-bind (s1 s2) (random-partition (1- size) 2) |
(destructuring-bind (s1 s2) (random-partition (1- size) 2) |
145 |
`(,(random-from-seq '(ldb mask-field)) |
`(,(random-from-seq '(ldb mask-field)) |
146 |
,(make-random-byte-spec-form s1 vars) |
,(make-random-byte-spec-form s1 vars) |
147 |
,(make-random-integer-form s2 vars)))) |
,(make-random-integer-form s2 vars)))) |
148 |
|
(20 |
149 |
|
(destructuring-bind (s1 s2) (random-partition (1- size) 2) |
150 |
|
(let* ((var (random-from-seq #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10))) |
151 |
|
(e1 (make-random-integer-form s1 vars)) |
152 |
|
(e2 (make-random-integer-form s2 (cons var vars)))) |
153 |
|
;; for now, avoid shadowing |
154 |
|
(if (member var vars) |
155 |
|
(make-random-integer-form size vars) |
156 |
|
`(let ((,var ,e1)) ,e2))))) |
157 |
|
(10 |
158 |
|
(let* ((name (random-from-seq #(b1 b2 b3 b4 b5 b6 b7 b8))) |
159 |
|
(*random-int-form-blocks* (adjoin name *random-int-form-blocks*))) |
160 |
|
`(block ,name ,(make-random-integer-form (1- size) vars)))) |
161 |
|
(1 |
162 |
|
(if *random-int-form-blocks* |
163 |
|
(let ((name (random-from-seq *random-int-form-blocks*)) |
164 |
|
(form (make-random-integer-form (1- size) vars))) |
165 |
|
`(return-from ,name ,form)) |
166 |
|
;; No blocks -- try again |
167 |
|
(make-random-integer-form size vars))) |
168 |
|
|
169 |
|
(5 |
170 |
|
(if *random-int-form-blocks* |
171 |
|
(destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) |
172 |
|
(let ((name (random-from-seq *random-int-form-blocks*)) |
173 |
|
(pred (make-random-pred-form s1 vars)) |
174 |
|
(then (make-random-integer-form s2 vars)) |
175 |
|
(else (make-random-integer-form s3 vars))) |
176 |
|
`(if ,pred (return-from ,name ,then) ,else))) |
177 |
|
;; No blocks -- try again |
178 |
|
(make-random-integer-form size vars))) |
179 |
|
|
180 |
))) |
))) |
181 |
|
|
182 |
(defun make-random-pred-form (size vars) |
(defun make-random-pred-form (size vars) |
183 |
(if (<= size 1) |
(if (<= size 1) |
184 |
(ecase (random 3) |
(rcase |
185 |
(0 (if (coin) t nil)) |
(1 (if (coin) t nil)) |
186 |
((1 2) |
(2 |
187 |
`(,(random-from-seq '(< <= = > >= /= eql equal)) |
`(,(random-from-seq '(< <= = > >= /= eql equal)) |
188 |
,(make-random-integer-form size vars) |
,(make-random-integer-form size vars) |
189 |
,(make-random-integer-form size vars)))) |
,(make-random-integer-form size vars)))) |
190 |
(ecase (random 6) |
(rcase |
191 |
(0 (if (coin) t nil)) |
(1 (if (coin) t nil)) |
192 |
(1 `(not ,(make-random-pred-form (1- size) vars))) |
(1 `(not ,(make-random-pred-form (1- size) vars))) |
193 |
(2 (destructuring-bind (leftsize rightsize) |
(2 (destructuring-bind (leftsize rightsize) |
194 |
(random-partition (1- size) 2) |
(random-partition (1- size) 2) |
195 |
`(,(random-from-seq '(and or)) |
`(,(random-from-seq '(and or)) |
196 |
,(make-random-pred-form leftsize vars) |
,(make-random-pred-form leftsize vars) |
197 |
,(make-random-pred-form rightsize vars)))) |
,(make-random-pred-form rightsize vars)))) |
198 |
(3 (destructuring-bind (leftsize rightsize) |
(1 (destructuring-bind (leftsize rightsize) |
199 |
(random-partition (1- size) 2) |
(random-partition (1- size) 2) |
200 |
`(,(random-from-seq '(< <= > >= = /= eql equal)) |
`(,(random-from-seq '(< <= > >= = /= eql equal)) |
201 |
,(make-random-integer-form leftsize vars) |
,(make-random-integer-form leftsize vars) |
202 |
,(make-random-integer-form rightsize vars)))) |
,(make-random-integer-form rightsize vars)))) |
203 |
(4 (let* ((cond-size (random (max 1 (floor size 2)))) |
(1 (let* ((cond-size (random (max 1 (floor size 2)))) |
204 |
(then-size (random (- size cond-size))) |
(then-size (random (- size cond-size))) |
205 |
(else-size (- size 1 cond-size then-size)) |
(else-size (- size 1 cond-size then-size)) |
206 |
(pred (make-random-pred-form cond-size vars)) |
(pred (make-random-pred-form cond-size vars)) |
207 |
(then-part (make-random-pred-form then-size vars)) |
(then-part (make-random-pred-form then-size vars)) |
208 |
(else-part (make-random-pred-form else-size vars))) |
(else-part (make-random-pred-form else-size vars))) |
209 |
`(if ,pred ,then-part ,else-part))) |
`(if ,pred ,then-part ,else-part))) |
210 |
(5 (destructuring-bind (s1 s2) |
(1 (destructuring-bind (s1 s2) |
211 |
(random-partition (1- size) 2) |
(random-partition (1- size) 2) |
212 |
`(ldb-test ,(make-random-byte-spec-form s1 vars) |
`(ldb-test ,(make-random-byte-spec-form s1 vars) |
213 |
,(make-random-integer-form s2 vars)))) |
,(make-random-integer-form s2 vars)))) |
214 |
|
(1 (let ((index (random (1+ (random 35)))) |
215 |
|
(form (make-random-integer-form (1- size) vars))) |
216 |
|
`(logbitp ,index ,form))) |
217 |
))) |
))) |
218 |
|
|
219 |
(defun make-random-byte-spec-form (size vars) |
(defun make-random-byte-spec-form (size vars) |
231 |
(t |
(t |
232 |
(let ((n1 (1+ (random (floor n p))))) |
(let ((n1 (1+ (random (floor n p))))) |
233 |
(cons n1 (random-partition (- n n1) (1- p))))))) |
(cons n1 (random-partition (- n n1) (1- p))))))) |
234 |
|
|
235 |
|
;;; Interface to the form pruner |
236 |
|
|
237 |
|
(defun test-int-form (form vars var-types vals-list) |
238 |
|
;; Try to compile FORM with associated VARS, and if it compiles |
239 |
|
;; check for equality of the two compiled forms. |
240 |
|
;; Return a non-nil list of details if a problem is found, |
241 |
|
;; NIL otherwise. |
242 |
|
(let ((optimized-fn-src |
243 |
|
`(lambda ,vars |
244 |
|
(declare ,@(mapcar #'(lambda (tp var) |
245 |
|
`(type ,tp ,var)) |
246 |
|
var-types vars) |
247 |
|
(ignorable ,@vars) |
248 |
|
(optimize #+cmu (extensions:inhibit-warnings 3) |
249 |
|
(speed 3) (safety 1) (debug 1))) |
250 |
|
,form)) |
251 |
|
(unoptimized-fn-src |
252 |
|
`(lambda ,vars |
253 |
|
(declare (notinline ,@(fn-symbols-in-form form)) |
254 |
|
(optimize #+cmu (extensions:inhibit-warnings 3) |
255 |
|
(safety 3) (speed 0) (debug 3)) |
256 |
|
(ignorable ,@vars)) |
257 |
|
,form))) |
258 |
|
(setq *int-form-vals* nil |
259 |
|
*optimized-fn-src* optimized-fn-src |
260 |
|
*unoptimized-fn-src* unoptimized-fn-src) |
261 |
|
(handler-bind |
262 |
|
(#+sbcl (sb-ext::compiler-note #'muffle-warning) |
263 |
|
(warning #'muffle-warning) |
264 |
|
(error #'(lambda (c) |
265 |
|
(format t "Compilation failure~%") |
266 |
|
(return-from test-int-form |
267 |
|
(list (list :vars vars |
268 |
|
:form form |
269 |
|
:var-types var-types |
270 |
|
:vals (first vals-list) |
271 |
|
:compiler-condition c)))))) |
272 |
|
(let ((optimized-compiled-fn (compile nil optimized-fn-src)) |
273 |
|
(unoptimized-compiled-fn (compile nil unoptimized-fn-src))) |
274 |
|
(dolist (vals vals-list) |
275 |
|
(setq *int-form-vals* vals) |
276 |
|
(let ((unopt-result (multiple-value-list |
277 |
|
(apply unoptimized-compiled-fn vals))) |
278 |
|
(opt-result (multiple-value-list |
279 |
|
(apply optimized-compiled-fn vals)))) |
280 |
|
(if (equal opt-result unopt-result) |
281 |
|
nil |
282 |
|
(progn |
283 |
|
(format t "Different results: ~A, ~A~%" |
284 |
|
opt-result unopt-result) |
285 |
|
(setq *opt-result* opt-result |
286 |
|
*unopt-result* unopt-result) |
287 |
|
(return (list (list :vars vars |
288 |
|
:vals vals |
289 |
|
:form form |
290 |
|
:var-types var-types |
291 |
|
:optimized-values opt-result |
292 |
|
:unoptimized-values unopt-result |
293 |
|
))))))))))) |
294 |
|
|
295 |
|
(defun prune-int-form (form vars var-types vals-list) |
296 |
|
(flet ((%try-fn (new-form) |
297 |
|
(when (test-int-form new-form vars var-types vals-list) |
298 |
|
(setf form new-form) |
299 |
|
(throw 'success nil)))) |
300 |
|
(loop |
301 |
|
(catch 'success |
302 |
|
(prune form #'%try-fn) |
303 |
|
(return form))))) |
304 |
|
|
305 |
|
(defun prune-results (result-list) |
306 |
|
(assert result-list) |
307 |
|
(loop for result in result-list |
308 |
|
collect |
309 |
|
(let ((form (getf result :form)) |
310 |
|
(vars (getf result :vars)) |
311 |
|
(var-types (getf result :var-types)) |
312 |
|
(vals-list (list (getf result :vals))) |
313 |
|
) |
314 |
|
`(:vars ,vars |
315 |
|
:var-types ,var-types |
316 |
|
:vals ,(first vals-list) |
317 |
|
:form ,(prune-int-form form vars var-types vals-list))))) |
318 |
|
|
319 |
|
;;; |
320 |
|
;;; The call (PRUNE form try-fn) attempts to simplify the lisp form |
321 |
|
;;; so that it still satisfies TRY-FN. The function TRY-FN should |
322 |
|
;;; return if the substitution is a failure. Otherwise, it should |
323 |
|
;;; transfer control elsewhere via GO, THROW, etc. |
324 |
|
;;; |
325 |
|
;;; The return value of PRUNE should be ignored. |
326 |
|
;;; |
327 |
|
(defun prune (form try-fn) |
328 |
|
(flet ((try (x) (funcall try-fn x))) |
329 |
|
(when (consp form) |
330 |
|
(let ((op (car form)) |
331 |
|
(args (cdr form))) |
332 |
|
(case op |
333 |
|
|
334 |
|
((signum integer-length logcount |
335 |
|
gcd lcm logandc1 logandc2 lognand lognor logorc1 logorc2) |
336 |
|
(mapc #'try args) |
337 |
|
(try 0) |
338 |
|
(try 1) |
339 |
|
(try -1) |
340 |
|
(prune-fn form try-fn)) |
341 |
|
|
342 |
|
((abs 1+ 1- identity) |
343 |
|
(mapc #'try args) |
344 |
|
(prune-fn form try-fn)) |
345 |
|
|
346 |
|
((- + * min max logand logior logxor logeqv and or not eq eql equal = < > <= >= /=) |
347 |
|
(when (every #'constantp args) |
348 |
|
(try (eval form))) |
349 |
|
(mapc #'try args) |
350 |
|
(prune-fn form try-fn)) |
351 |
|
|
352 |
|
((if) |
353 |
|
(let (;; (pred (first args)) |
354 |
|
(then (second args)) |
355 |
|
(else (third args))) |
356 |
|
(try then) |
357 |
|
(try else) |
358 |
|
(prune-fn form try-fn))) |
359 |
|
|
360 |
|
((byte) |
361 |
|
(prune-fn form try-fn)) |
362 |
|
|
363 |
|
((deposit-field dpb) |
364 |
|
(try (first args)) |
365 |
|
(try (third args)) |
366 |
|
(prune-fn form try-fn)) |
367 |
|
|
368 |
|
((ldb mask-field) |
369 |
|
(try (second args)) |
370 |
|
(prune-fn form try-fn)) |
371 |
|
|
372 |
|
((ldb-test) |
373 |
|
(prune-fn form try-fn)) |
374 |
|
|
375 |
|
((let let*) |
376 |
|
(prune-let form try-fn)) |
377 |
|
|
378 |
|
((block) |
379 |
|
(let ((name (second form)) |
380 |
|
(body (cddr form))) |
381 |
|
(when (and body (null (cdr body))) |
382 |
|
(when (not (find-in-tree name body)) |
383 |
|
(try (first body))) |
384 |
|
;; Simplify the subexpression |
385 |
|
(prune (first body) |
386 |
|
#'(lambda (x) |
387 |
|
(try `(block ,name ,x))))))) |
388 |
|
|
389 |
|
(otherwise |
390 |
|
(prune-fn form try-fn)) |
391 |
|
))))) |
392 |
|
|
393 |
|
(defun find-in-tree (value tree) |
394 |
|
(or (eql value tree) |
395 |
|
(and (consp tree) |
396 |
|
(or (find-in-tree value (car tree)) |
397 |
|
(find-in-tree value (cdr tree)))))) |
398 |
|
|
399 |
|
(defun prune-fn (form try-fn) |
400 |
|
(let* ((i 0) |
401 |
|
(op (car form)) |
402 |
|
(args (cdr form)) |
403 |
|
(len (length args))) |
404 |
|
(flet ((try-arg (x) |
405 |
|
(funcall |
406 |
|
try-fn |
407 |
|
(cons op |
408 |
|
(append (subseq args 0 i) |
409 |
|
(list x) |
410 |
|
(subseq args (1+ i))))))) |
411 |
|
(declare (dynamic-extent (function try-arg))) |
412 |
|
(loop while (< i len) |
413 |
|
do (prune (elt args i) #'try-arg) |
414 |
|
(incf i))))) |
415 |
|
|
416 |
|
(defun prune-let (form try-fn) |
417 |
|
(let* ((op (car form)) |
418 |
|
(binding-list (cadr form)) |
419 |
|
(body (cddr form)) |
420 |
|
(body-len (length body)) |
421 |
|
(len (length binding-list))) |
422 |
|
(when (and (eql len 1) |
423 |
|
(eql body-len 1) |
424 |
|
(eql (caar binding-list) (car body))) |
425 |
|
(funcall try-fn (cadar binding-list))) |
426 |
|
(let ((i 0)) |
427 |
|
(flet ((try-binding (x) |
428 |
|
(funcall |
429 |
|
try-fn |
430 |
|
`(,op |
431 |
|
(,@(subseq binding-list 0 i) |
432 |
|
,x |
433 |
|
,@(subseq binding-list (1+ i))) |
434 |
|
,@body)))) |
435 |
|
(declare (dynamic-extent (function try-binding))) |
436 |
|
(loop while (< i len) |
437 |
|
do (prune (elt binding-list i) #'try-binding) |
438 |
|
(incf i)))) |
439 |
|
(when body |
440 |
|
(unless binding-list |
441 |
|
(funcall try-fn (car (last body)))) |
442 |
|
(when (and (car binding-list) |
443 |
|
(not (cdr binding-list)) |
444 |
|
(not (cdr body))) |
445 |
|
(let ((binding (car binding-list))) |
446 |
|
(unless (consp (second binding)) |
447 |
|
(funcall try-fn `(let () |
448 |
|
,@(subst (cadr binding) (car binding) body)))))) |
449 |
|
(prune (car (last body)) |
450 |
|
#'(lambda (form2) |
451 |
|
(funcall try-fn |
452 |
|
`(,@(butlast form) ,form2))))))) |
453 |
|
|