47 |
(apply (eval `(function ,(getf plist :unoptimized-lambda-form))) |
(apply (eval `(function ,(getf plist :unoptimized-lambda-form))) |
48 |
(getf plist :vals))))) |
(getf plist :vals))))) |
49 |
|
|
50 |
|
(defun tn (n &optional (size 100)) |
51 |
|
(length (setq $y (prune-results (setq $x (test-random-integer-forms size 2 n)))))) |
52 |
|
|
53 |
|
(declaim (special *s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*)) |
54 |
|
|
55 |
(defun loop-random-int-forms (&optional (size 200) (nvars 3)) |
(defun loop-random-int-forms (&optional (size 200) (nvars 3)) |
56 |
(unless (boundp '$x) (setq $x nil)) |
(unless (boundp '$x) (setq $x nil)) |
57 |
(unless (boundp '$y) (setq $y nil)) |
(unless (boundp '$y) (setq $y nil)) |
70 |
|
|
71 |
(defvar *random-int-form-blocks* nil) |
(defvar *random-int-form-blocks* nil) |
72 |
(defvar *random-int-form-catch-tags* nil) |
(defvar *random-int-form-catch-tags* nil) |
73 |
|
(defvar *go-tags* nil) |
74 |
|
|
75 |
(defvar *maximum-random-int-bits* 45) |
(defvar *maximum-random-int-bits* 45) |
76 |
|
|
77 |
(defvar *max-compile-time* 0) |
(defvar *max-compile-time* 0) |
78 |
(defvar *max-compile-term* nil) |
(defvar *max-compile-term* nil) |
79 |
|
|
80 |
|
(defvar *print-immediately* nil) |
81 |
|
|
82 |
(defvar *compile-unoptimized-form* |
(defvar *compile-unoptimized-form* |
83 |
#-(or gcl clisp) t |
#-(or gcl clisp) t |
84 |
#+(or gcl clisp) nil) |
#+(or gcl clisp) nil) |
112 |
nconc (let ((result (test-random-integer-form size nvars))) |
nconc (let ((result (test-random-integer-form size nvars))) |
113 |
(when result |
(when result |
114 |
(let ((*print-readably* t)) |
(let ((*print-readably* t)) |
115 |
(terpri) |
(format t "~%~A~%" (format nil "~S" (car result))) |
|
(print (car result)) |
|
116 |
(finish-output *standard-output*))) |
(finish-output *standard-output*))) |
117 |
result))) |
result))) |
118 |
|
|
131 |
collect (make-var-desc :name v |
collect (make-var-desc :name v |
132 |
:type tp))) |
:type tp))) |
133 |
(*random-int-form-blocks* nil) |
(*random-int-form-blocks* nil) |
134 |
(*random-int-form-catch-tags* nil)) |
(*random-int-form-catch-tags* nil) |
135 |
|
(*go-tags* nil) |
136 |
|
) |
137 |
(make-random-integer-form size))) |
(make-random-integer-form size))) |
138 |
(vals-list |
(vals-list |
139 |
(loop repeat 20 |
(loop repeat 20 |
142 |
(let ((lo (car range)) |
(let ((lo (car range)) |
143 |
(hi (cadr range))) |
(hi (cadr range))) |
144 |
(random-from-interval (1+ hi) lo))) |
(random-from-interval (1+ hi) lo))) |
145 |
var-ranges)))) |
var-ranges))) |
146 |
(test-int-form form vars var-types vals-list))) |
(opt-decls-1 (make-random-optimize-settings)) |
147 |
|
(opt-decls-2 (make-random-optimize-settings))) |
148 |
|
(when *print-immediately* |
149 |
|
(print `(:vars ,vars |
150 |
|
:var-types ,var-types |
151 |
|
:vals-list ,vals-list |
152 |
|
:decls1 ,opt-decls-1 |
153 |
|
:decls2 ,opt-decls-2 |
154 |
|
:form ,form)) |
155 |
|
;; (cl-user::gc) |
156 |
|
) |
157 |
|
(test-int-form form vars var-types vals-list opt-decls-1 opt-decls-2))) |
158 |
|
|
159 |
|
(defun make-random-optimize-settings () |
160 |
|
(loop for settings = (cons |
161 |
|
(list 'speed (1+ (random 3))) |
162 |
|
(loop for s in '(space safety debug compilation-speed) |
163 |
|
for n = (random 4) |
164 |
|
collect (list s n))) |
165 |
|
while |
166 |
|
#+allegro (subsetp '((speed 3) (safety 0)) settings :test 'equal) |
167 |
|
#-allegro nil |
168 |
|
finally (return settings))) |
169 |
|
|
170 |
(defun fn-symbols-in-form (form) |
(defun fn-symbols-in-form (form) |
171 |
"Return a list of the distinct standardized lisp function |
"Return a list of the distinct standardized lisp function |
219 |
when |
when |
220 |
(rcase |
(rcase |
221 |
(10 (make-random-integer)) |
(10 (make-random-integer)) |
222 |
(9 (if *vars* (var-desc-name (random-from-seq *vars*)) |
(9 (if *vars* (var-desc-name (random-from-seq *vars*)) |
223 |
nil)) |
nil)) |
224 |
|
(1 (if *go-tags* `(go ,(random-from-seq *go-tags*)) nil)) |
225 |
(2 (if *flet-names* |
(2 (if *flet-names* |
226 |
(let* ((flet-entry (random-from-seq *flet-names*)) |
(let* ((flet-entry (random-from-seq *flet-names*)) |
227 |
(flet-name (car flet-entry)) |
(flet-name (car flet-entry)) |
261 |
|
|
262 |
;; Unary ops |
;; Unary ops |
263 |
(40 |
(40 |
264 |
(let ((op (random-from-seq '(- abs signum 1+ 1- identity progn floor ignore-errors |
(let ((op (random-from-seq '(- abs signum 1+ 1- conjugate |
265 |
|
rational rationalize |
266 |
|
numerator denominator |
267 |
|
identity progn floor ignore-errors |
268 |
cl:handler-case restart-case |
cl:handler-case restart-case |
269 |
ceiling truncate round realpart imagpart |
ceiling truncate round realpart imagpart |
270 |
integer-length logcount values multiple-value-prog1 |
integer-length logcount values |
271 |
prog1 unwind-protect locally)))) |
locally)))) |
272 |
`(,op ,(make-random-integer-form (1- size))))) |
`(,op ,(make-random-integer-form (1- size))))) |
273 |
|
|
274 |
|
(4 |
275 |
|
(let* ((op 'unwind-protect) |
276 |
|
(nforms (random 4)) |
277 |
|
(sizes (random-partition (1- size) (1+ nforms))) |
278 |
|
(arg (make-random-integer-form (first sizes))) |
279 |
|
(unwind-forms |
280 |
|
;; We have to be careful not to generate code that will |
281 |
|
;; illegally transfer control to a dead location |
282 |
|
(let ((*flet-names* nil) |
283 |
|
(*go-tags* nil) |
284 |
|
(*random-int-form-blocks* nil) |
285 |
|
(*random-int-form-catch-tags* nil)) |
286 |
|
(mapcar #'make-random-integer-form (rest sizes))))) |
287 |
|
`(,op ,arg ,@unwind-forms))) |
288 |
|
|
289 |
|
(4 |
290 |
|
(let* ((op (random-from-seq #(prog1 multiple-value-prog1))) |
291 |
|
(nforms (random 4)) |
292 |
|
(sizes (random-partition (1- size) (1+ nforms))) |
293 |
|
(args (mapcar #'make-random-integer-form sizes))) |
294 |
|
`(,op ,@args))) |
295 |
|
|
296 |
(2 `(isqrt (abs ,(make-random-integer-form (- size 2))))) |
(2 `(isqrt (abs ,(make-random-integer-form (- size 2))))) |
297 |
|
|
300 |
(1 `(cl:handler-bind nil ,(make-random-integer-form (1- size)))) |
(1 `(cl:handler-bind nil ,(make-random-integer-form (1- size)))) |
301 |
(1 `(macrolet () ,(make-random-integer-form (1- size)))) |
(1 `(macrolet () ,(make-random-integer-form (1- size)))) |
302 |
|
|
303 |
|
;; dotimes |
304 |
|
#-allegro |
305 |
|
(10 |
306 |
|
(let* ((var (random-from-seq #(iv1 iv2 iv3 iv4))) |
307 |
|
(count (random 10)) |
308 |
|
(sizes (random-partition (1- size) 2)) |
309 |
|
(body (let ((*vars* (cons (make-var-desc :name var :type nil) |
310 |
|
*vars*))) |
311 |
|
(make-random-integer-form (first sizes)))) |
312 |
|
(ret-form (make-random-integer-form (second sizes)))) |
313 |
|
`(dotimes (,var ,count ,ret-form) ,body))) |
314 |
|
|
315 |
;; load-time-value |
;; load-time-value |
316 |
#-(or gcl ecl) |
#-(or gcl ecl) |
317 |
(4 |
(4 |
318 |
(let ((arg (let ((*flet-names* nil) |
(let ((arg (let ((*flet-names* nil) |
319 |
(*vars* nil) |
(*vars* nil) |
320 |
(*random-int-form-blocks* nil) |
(*random-int-form-blocks* nil) |
321 |
(*random-int-form-catch-tags* nil)) |
(*random-int-form-catch-tags* nil) |
322 |
|
(*go-tags* nil)) |
323 |
(make-random-integer-form (1- size))))) |
(make-random-integer-form (1- size))))) |
324 |
(rcase |
(rcase |
325 |
(2 `(load-time-value ,arg t)) |
(2 `(load-time-value ,arg t)) |
349 |
;; Binary op |
;; Binary op |
350 |
(30 |
(30 |
351 |
(let* ((op (random-from-seq |
(let* ((op (random-from-seq |
352 |
'(+ - * logand min max gcd ;; lcm |
'(+ - * logand min max gcd |
353 |
|
#-gcl lcm |
354 |
#-:allegro |
#-:allegro |
355 |
logandc1 |
logandc1 |
356 |
logandc2 logeqv logior lognand lognor |
logandc2 logeqv logior lognand lognor |
357 |
#-:allegro |
#-:allegro |
358 |
logorc1 |
logorc1 |
359 |
logorc2 |
logorc2 |
|
#-:allegro |
|
360 |
logxor |
logxor |
361 |
)))) |
)))) |
362 |
(destructuring-bind (leftsize rightsize) |
(destructuring-bind (leftsize rightsize) |
368 |
;; n-ary ops |
;; n-ary ops |
369 |
(30 |
(30 |
370 |
(let* ((op (random-from-seq #(+ - * logand min max logior |
(let* ((op (random-from-seq #(+ - * logand min max logior |
371 |
#-:allegro |
#-gcl lcm |
372 |
logxor))) |
gcd logxor))) |
373 |
(nargs (1+ (min (random 10) (random 10) (random 10)))) |
(nargs (1+ (min (random 10) (random 10) (random 10)))) |
374 |
(sizes (random-partition (1- size) nargs)) |
(sizes (random-partition (1- size) nargs)) |
375 |
(args (mapcar #'make-random-integer-form sizes))) |
(args (mapcar #'make-random-integer-form sizes))) |
376 |
`(,op ,@args))) |
`(,op ,@args))) |
377 |
|
|
378 |
|
;; expt |
379 |
|
(3 `(expt ,(make-random-integer-form (1- size)) ,(random 10))) |
380 |
|
|
381 |
|
;; coerce |
382 |
|
(2 `(coerce ,(make-random-integer-form (1- size)) 'integer)) |
383 |
|
|
384 |
|
;; complex (degenerate case) |
385 |
|
(2 `(complex ,(make-random-integer-form (1- size)) 0)) |
386 |
|
|
387 |
|
;; quotient (degenerate cases) |
388 |
|
(1 `(/ ,(make-random-integer-form (1- size)) 1)) |
389 |
|
(1 `(/ ,(make-random-integer-form (1- size)) -1)) |
390 |
|
|
391 |
|
;; tagbody |
392 |
|
(5 (make-random-tagbody size)) |
393 |
|
|
394 |
;; conditionals |
;; conditionals |
395 |
(20 |
(20 |
396 |
(let* ((cond-size (random (max 1 (floor size 2)))) |
(let* ((cond-size (random (max 1 (floor size 2)))) |
406 |
,(make-random-integer-form s1) |
,(make-random-integer-form s1) |
407 |
,(make-random-byte-spec-form s2) |
,(make-random-byte-spec-form s2) |
408 |
,(make-random-integer-form s3)))) |
,(make-random-integer-form s3)))) |
409 |
|
|
410 |
#-:allegro |
#-:allegro |
411 |
(10 |
(10 |
412 |
(destructuring-bind (s1 s2) (random-partition (1- size) 2) |
(destructuring-bind (s1 s2) (random-partition (1- size) 2) |
415 |
,(make-random-integer-form s2)))) |
,(make-random-integer-form s2)))) |
416 |
(20 |
(20 |
417 |
(destructuring-bind (s1 s2) (random-partition (1- size) 2) |
(destructuring-bind (s1 s2) (random-partition (1- size) 2) |
418 |
(let* ((var (random-from-seq #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10))) |
(let* ((var (rcase |
419 |
|
(2 (random-from-seq #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10))) |
420 |
|
(2 (random-from-seq #(*s1* *s2* *s3* *s4* |
421 |
|
*s5* *s6* *s7* *s8*))))) |
422 |
(e1 (make-random-integer-form s1)) |
(e1 (make-random-integer-form s1)) |
423 |
(e2 (let ((*vars* (cons (make-var-desc :name var |
(e2 (let ((*vars* (cons (make-var-desc :name var |
424 |
:type '(integer * *)) |
:type '(integer * *)) |
431 |
(rcase |
(rcase |
432 |
(8 `(,op ((,var ,e1)) ,e2)) |
(8 `(,op ((,var ,e1)) ,e2)) |
433 |
(2 `(multiple-value-bind (,var) ,e1 ,e2))))))) |
(2 `(multiple-value-bind (,var) ,e1 ,e2))))))) |
434 |
|
|
435 |
|
;; progv |
436 |
|
(4 |
437 |
|
(let* ((num-vars (random 4)) |
438 |
|
(possible-vars #(*s1* *s2* *s3* *s4* |
439 |
|
*s5* *s6* *s7* *s8*)) |
440 |
|
(vars nil)) |
441 |
|
(loop repeat num-vars |
442 |
|
do (loop for r = (elt possible-vars (random (length possible-vars))) |
443 |
|
while (member r vars) |
444 |
|
finally (push r vars))) |
445 |
|
(if (null vars) |
446 |
|
`(progv nil nil ,(make-random-integer-form (1- size))) |
447 |
|
(destructuring-bind (s1 s2) (random-partition (1- size) 2) |
448 |
|
(let* ((var-sizes (random-partition s1 num-vars)) |
449 |
|
(var-forms (mapcar #'make-random-integer-form var-sizes)) |
450 |
|
(*vars* (append (loop for v in vars collect |
451 |
|
(make-var-desc :name v :type '(integer * *))) |
452 |
|
*vars*)) |
453 |
|
(body-form (make-random-integer-form s2))) |
454 |
|
`(progv ',vars (list ,@var-forms) ,body-form)))))) |
455 |
|
|
456 |
(4 `(let () ,(make-random-integer-form (1- size)))) |
(4 `(let () ,(make-random-integer-form (1- size)))) |
457 |
|
|
478 |
(integerp (second type)) |
(integerp (second type)) |
479 |
(integerp (third type))) |
(integerp (third type))) |
480 |
`(setq ,var ,(random-from-interval (1+ (third type)) (second type)))) |
`(setq ,var ,(random-from-interval (1+ (third type)) (second type)))) |
481 |
|
;; Abort -- can't assign |
482 |
(t (make-random-integer-form size)))) |
(t (make-random-integer-form size)))) |
483 |
(make-random-integer-form size))) |
(make-random-integer-form size))) |
484 |
|
|
485 |
(3 (make-random-integer-case-form size)) |
(3 (make-random-integer-case-form size)) |
486 |
|
|
487 |
(3 |
(3 |
488 |
(if *random-int-form-blocks* |
(if *random-int-form-blocks* |
489 |
(let ((name (random-from-seq *random-int-form-blocks*)) |
(let ((name (random-from-seq *random-int-form-blocks*)) |
583 |
,form2) |
,form2) |
584 |
`(,op ((,fname ,arg-names ,form1)) ,form2)))))))) |
`(,op ((,fname ,arg-names ,form1)) ,form2)))))))) |
585 |
|
|
586 |
|
(defun make-random-tagbody (size) |
587 |
|
(let* ((num-forms (random 6)) |
588 |
|
(tags nil)) |
589 |
|
(loop for i below num-forms |
590 |
|
do (loop for tag = (rcase (1 (random 8)) |
591 |
|
(1 (random-from-seq #(tag1 tag2 tag3 tag4 tag5 tag6 tag7 tag8)))) |
592 |
|
while (member tag tags) |
593 |
|
finally (push tag tags))) |
594 |
|
(assert (= (length (remove-duplicates tags)) (length tags))) |
595 |
|
(let* ((*go-tags* (set-difference *go-tags* tags)) |
596 |
|
(sizes (random-partition (1- size) (1+ num-forms))) |
597 |
|
(forms |
598 |
|
(loop for tag-list on tags |
599 |
|
for i below num-forms |
600 |
|
for size in sizes |
601 |
|
collect (let ((*go-tags* (append tag-list *go-tags*))) |
602 |
|
(make-random-integer-form size)))) |
603 |
|
(final-form (make-random-integer-form (car (last sizes))))) |
604 |
|
`(progn (tagbody ,@(loop for tag in tags |
605 |
|
for form in forms |
606 |
|
when (atom form) do (setq form `(progn ,form)) |
607 |
|
append `(,form ,tag))) |
608 |
|
,final-form)))) |
609 |
|
|
610 |
(defun make-random-pred-form (size) |
(defun make-random-pred-form (size) |
611 |
"Make a random form whose value is to be used as a generalized boolean." |
"Make a random form whose value is to be used as a generalized boolean." |
612 |
(if (<= size 1) |
(if (<= size 1) |
728 |
(let ((n1 (1+ (random (floor n p))))) |
(let ((n1 (1+ (random (floor n p))))) |
729 |
(cons n1 (random-partition (- n n1) (1- p))))))) |
(cons n1 (random-partition (- n n1) (1- p))))))) |
730 |
|
|
731 |
(defun make-optimized-lambda-form (form vars var-types) |
(defun make-optimized-lambda-form (form vars var-types opt-decls) |
732 |
`(lambda ,vars |
`(lambda ,vars |
|
#| |
|
|
(declare ,@(mapcar #'(lambda (tp var) |
|
|
`(type ,tp ,var)) |
|
|
var-types vars) |
|
|
(ignorable ,@vars) |
|
|
(optimize #+cmu (extensions:inhibit-warnings 3) |
|
|
(speed 3) (safety 1) (debug 1))) |
|
|
|# |
|
733 |
,@(mapcar #'(lambda (tp var) `(declare (type ,tp ,var))) |
,@(mapcar #'(lambda (tp var) `(declare (type ,tp ,var))) |
734 |
var-types vars) |
var-types vars) |
735 |
(declare (ignorable ,@vars)) |
(declare (ignorable ,@vars)) |
736 |
#+cmu (declare (optimize (extensions:inhibit-warnings 3))) |
#+cmu (declare (optimize (extensions:inhibit-warnings 3))) |
737 |
(declare (optimize (speed 3))) |
(declare (optimize ,@opt-decls)) |
|
(declare (optimize (safety 1))) |
|
|
(declare (optimize (debug 1))) |
|
738 |
,form)) |
,form)) |
739 |
|
|
740 |
(defun make-unoptimized-lambda-form (form vars var-types) |
(defun make-unoptimized-lambda-form (form vars var-types opt-decls) |
741 |
(declare (ignore var-types)) |
(declare (ignore var-types)) |
742 |
`(lambda ,vars |
`(lambda ,vars |
|
#| |
|
|
(declare (notinline ,@(fn-symbols-in-form form)) |
|
|
(optimize #+cmu (extensions:inhibit-warnings 3) |
|
|
(safety 3) (speed 0) (debug 3)) |
|
|
(ignorable ,@vars)) |
|
|
|# |
|
743 |
(declare (notinline ,@(fn-symbols-in-form form))) |
(declare (notinline ,@(fn-symbols-in-form form))) |
744 |
#+cmu (declare (optimize (extensions:inhibit-warnings 3))) |
#+cmu (declare (optimize (extensions:inhibit-warnings 3))) |
745 |
(declare (optimize (safety 3))) |
(declare (optimize ,@opt-decls)) |
|
(declare (optimize (speed 0))) |
|
|
(declare (optimize (debug 3))) |
|
746 |
,form)) |
,form)) |
747 |
|
|
748 |
(defvar *compile-using-defun* |
(defvar *compile-using-defun* |
751 |
(defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1) |
(defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1) |
752 |
(defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2) |
(defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2) |
753 |
|
|
754 |
(defun test-int-form (form vars var-types vals-list) |
(defun test-int-form (form vars var-types vals-list opt-decls-1 opt-decls-2) |
755 |
;; Try to compile FORM with associated VARS, and if it compiles |
;; Try to compile FORM with associated VARS, and if it compiles |
756 |
;; check for equality of the two compiled forms. |
;; check for equality of the two compiled forms. |
757 |
;; Return a non-nil list of details if a problem is found, |
;; Return a non-nil list of details if a problem is found, |
758 |
;; NIL otherwise. |
;; NIL otherwise. |
759 |
(let ((optimized-fn-src (make-optimized-lambda-form form vars var-types)) |
(let ((optimized-fn-src (make-optimized-lambda-form form vars var-types opt-decls-1)) |
760 |
(unoptimized-fn-src (make-unoptimized-lambda-form form vars var-types))) |
(unoptimized-fn-src (make-unoptimized-lambda-form form vars var-types opt-decls-2))) |
761 |
(setq *int-form-vals* nil |
(setq *int-form-vals* nil |
762 |
*optimized-fn-src* optimized-fn-src |
*optimized-fn-src* optimized-fn-src |
763 |
*unoptimized-fn-src* unoptimized-fn-src) |
*unoptimized-fn-src* unoptimized-fn-src) |
767 |
(#+sbcl (sb-ext::compiler-note #'muffle-warning) |
(#+sbcl (sb-ext::compiler-note #'muffle-warning) |
768 |
(warning #'muffle-warning) |
(warning #'muffle-warning) |
769 |
(error #'(lambda (c) |
(error #'(lambda (c) |
770 |
(format t "Compilation failure~%") |
(format t "Compilation failure~%~A~%" |
771 |
(print form) |
(format nil "~S" form)) |
772 |
(finish-output *standard-output*) |
(finish-output *standard-output*) |
773 |
(return-from test-int-form |
(return-from test-int-form |
774 |
(list (list :vars vars |
(list (list :vars vars |
776 |
:var-types var-types |
:var-types var-types |
777 |
:vals (first vals-list) |
:vals (first vals-list) |
778 |
:lambda-form lambda-form |
:lambda-form lambda-form |
779 |
|
:decls1 opt-decls-1 |
780 |
|
:decls2 opt-decls-2 |
781 |
:compiler-condition |
:compiler-condition |
782 |
(with-output-to-string |
(with-output-to-string |
783 |
(*standard-output*) |
(*standard-output*) |
797 |
(when (> total-time *max-compile-time*) |
(when (> total-time *max-compile-time*) |
798 |
(setf *max-compile-time* total-time) |
(setf *max-compile-time* total-time) |
799 |
(setf *max-compile-term* lambda-form))) |
(setf *max-compile-term* lambda-form))) |
800 |
#+:ecl (si:gc t) |
;; #+:ecl (si:gc t) |
801 |
))))) |
))))) |
802 |
(let ((optimized-compiled-fn (%compile optimized-fn-src |
(let ((optimized-compiled-fn (%compile optimized-fn-src |
803 |
*name-to-use-in-optimized-defun*)) |
*name-to-use-in-optimized-defun*)) |
810 |
(setq *int-form-vals* vals) |
(setq *int-form-vals* vals) |
811 |
(flet ((%eval-error |
(flet ((%eval-error |
812 |
(kind) |
(kind) |
813 |
(print form) |
(let ((*print-circle* t)) |
814 |
|
(format t "~A~%" (format nil "~S" form))) |
815 |
(finish-output *standard-output*) |
(finish-output *standard-output*) |
816 |
(return |
(return |
817 |
(list (list :vars vars |
(list (list :vars vars |
818 |
:vals vals |
:vals vals |
819 |
:form form |
:form form |
820 |
:var-types var-types |
:var-types var-types |
821 |
|
:decls1 opt-decls-1 |
822 |
|
:decls2 opt-decls-2 |
823 |
:optimized-lambda-form optimized-fn-src |
:optimized-lambda-form optimized-fn-src |
824 |
:unoptimized-lambda-form unoptimized-fn-src |
:unoptimized-lambda-form unoptimized-fn-src |
825 |
:kind kind))))) |
:kind kind))))) |
828 |
(cl:handler-case |
(cl:handler-case |
829 |
(identity ;; multiple-value-list |
(identity ;; multiple-value-list |
830 |
(apply unoptimized-compiled-fn vals)) |
(apply unoptimized-compiled-fn vals)) |
831 |
(error (c) (declare (ignore c)) |
((or error serious-condition) |
832 |
|
(c) (declare (ignore c)) |
833 |
(%eval-error :unoptimized-form-error)))) |
(%eval-error :unoptimized-form-error)))) |
834 |
(opt-result |
(opt-result |
835 |
(cl:handler-case |
(cl:handler-case |
836 |
(identity ;; multiple-value-list |
(identity ;; multiple-value-list |
837 |
(apply optimized-compiled-fn vals)) |
(apply optimized-compiled-fn vals)) |
838 |
(error (c) (declare (ignore c)) |
((or error serious-condition) |
839 |
|
(c) (declare (ignore c)) |
840 |
(%eval-error :optimized-form-error))))) |
(%eval-error :optimized-form-error))))) |
841 |
(if (equal opt-result unopt-result) |
(if (equal opt-result unopt-result) |
842 |
nil |
nil |
853 |
|
|
854 |
(declaim (special *prune-table*)) |
(declaim (special *prune-table*)) |
855 |
|
|
856 |
(defun prune-int-form (input-form vars var-types vals-list) |
(defun prune-int-form (input-form vars var-types vals-list opt-decls-1 opt-decls-2) |
857 |
"Conduct tests on selected simplified versions of INPUT-FORM. Return the |
"Conduct tests on selected simplified versions of INPUT-FORM. Return the |
858 |
minimal form that still causes some kind of failure." |
minimal form that still causes some kind of failure." |
859 |
(loop do |
(loop do |
860 |
(let ((form input-form)) |
(let ((form input-form)) |
861 |
(flet ((%try-fn (new-form) |
(flet ((%try-fn (new-form) |
862 |
(when (test-int-form new-form vars var-types vals-list) |
(when (test-int-form new-form vars var-types vals-list |
863 |
|
opt-decls-1 opt-decls-2) |
864 |
(setf form new-form) |
(setf form new-form) |
865 |
(throw 'success nil)))) |
(throw 'success nil)))) |
866 |
(let ((*prune-table* (make-hash-table :test #'eq))) |
(let ((*prune-table* (make-hash-table :test #'eq))) |
879 |
(vars (getf result :vars)) |
(vars (getf result :vars)) |
880 |
(var-types (getf result :var-types)) |
(var-types (getf result :var-types)) |
881 |
(vals-list (list (getf result :vals))) |
(vals-list (list (getf result :vals))) |
882 |
(pruned-form (prune-int-form form vars var-types vals-list)) |
(opt-decl-1 (getf result :decls1)) |
883 |
|
(opt-decl-2 (getf result :decls2)) |
884 |
|
(pruned-form (prune-int-form form vars var-types vals-list opt-decl-1 opt-decl-2)) |
885 |
(optimized-lambda-form (make-optimized-lambda-form |
(optimized-lambda-form (make-optimized-lambda-form |
886 |
pruned-form vars var-types)) |
pruned-form vars var-types opt-decl-1)) |
887 |
(unoptimized-lambda-form (make-unoptimized-lambda-form |
(unoptimized-lambda-form (make-unoptimized-lambda-form |
888 |
pruned-form vars var-types))) |
pruned-form vars var-types opt-decl-2))) |
889 |
`(:vars ,vars |
`(:vars ,vars |
890 |
:var-types ,var-types |
:var-types ,var-types |
891 |
:vals ,(first vals-list) |
:vals ,(first vals-list) |
892 |
:form ,pruned-form |
:form ,pruned-form |
893 |
|
:decls1 ,opt-decl-1 |
894 |
|
:decls2 ,opt-decl-2 |
895 |
:optimized-lambda-form ,optimized-lambda-form |
:optimized-lambda-form ,optimized-lambda-form |
896 |
:unoptimized-lambda-form ,unoptimized-lambda-form)))) |
:unoptimized-lambda-form ,unoptimized-lambda-form)))) |
897 |
|
|
917 |
(args (cdr form)) |
(args (cdr form)) |
918 |
(nargs (length args))) |
(nargs (length args))) |
919 |
(case op |
(case op |
920 |
|
|
921 |
|
((quote) nil) |
922 |
|
|
923 |
|
((go) |
924 |
|
(try 0)) |
925 |
|
|
926 |
((signum integer-length logcount |
((signum integer-length logcount |
927 |
logandc1 logandc2 lognand lognor logorc1 logorc2 |
logandc1 logandc2 lognand lognor logorc1 logorc2 |
928 |
realpart imagpart) |
realpart imagpart) |
929 |
(mapc #'try args) |
(try 0) |
930 |
|
(mapc try-fn args) |
931 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
932 |
|
|
933 |
|
((dotimes) |
934 |
|
(try 0) |
935 |
|
(let* ((binding-form (first args)) |
936 |
|
(body (rest args)) |
937 |
|
(var (first binding-form)) |
938 |
|
(count-form (second binding-form)) |
939 |
|
(result (third binding-form))) |
940 |
|
(try result) |
941 |
|
(unless (eql count-form 0) |
942 |
|
(try `(dotimes (,var 0 ,result) ,@body))) |
943 |
|
(prune result #'(lambda (form) |
944 |
|
(try `(dotimes (,var ,count-form ,form) ,@body)))) |
945 |
|
(when (= (length body) 1) |
946 |
|
(prune (first body) |
947 |
|
#'(lambda (form) |
948 |
|
(try `(dotimes (,var ,count-form ,result) ,form))))))) |
949 |
|
|
950 |
((abs 1+ 1- identity values progn prog1 multiple-value-prog1 unwind-protect |
((abs 1+ 1-) |
951 |
ignore-errors cl:handler-case restart-case locally) |
(try 0) |
952 |
(mapc try-fn args) |
(mapc try-fn args) |
953 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
954 |
|
|
955 |
|
((identity values progn |
956 |
|
ignore-errors cl:handler-case restart-case locally) |
957 |
|
(unless (and (consp args) |
958 |
|
(consp (car args)) |
959 |
|
(eql (caar args) 'tagbody)) |
960 |
|
(mapc try-fn args)) |
961 |
|
(prune-fn form try-fn)) |
962 |
|
|
963 |
|
((unwind-protect prog1 multiple-value-prog1) |
964 |
|
(try (first args)) |
965 |
|
(let ((val (first args)) |
966 |
|
(rest (rest args))) |
967 |
|
(when rest |
968 |
|
(try `(unwind-protect ,val)) |
969 |
|
(when (cdr rest) |
970 |
|
(loop for i from 0 below (length rest) |
971 |
|
do |
972 |
|
(try `(unwind-protect ,val |
973 |
|
,@(subseq rest 0 i) |
974 |
|
,@(subseq rest (1+ i)))))))) |
975 |
|
(prune-fn form try-fn)) |
976 |
|
|
977 |
|
|
978 |
((typep) |
((typep) |
979 |
(try (car args)) |
(try (car args)) |
980 |
(prune (car args) |
(prune (car args) |
1002 |
((not eq eql equal) |
((not eq eql equal) |
1003 |
(when (every #'constantp args) |
(when (every #'constantp args) |
1004 |
(try (eval form))) |
(try (eval form))) |
1005 |
|
(try t) |
1006 |
|
(try nil) |
1007 |
(mapc try-fn args) |
(mapc try-fn args) |
1008 |
(prune-fn form try-fn) |
(prune-fn form try-fn) |
1009 |
(try t) |
) |
|
(try nil)) |
|
1010 |
|
|
1011 |
((and or = < > <= >= /=) |
((and or = < > <= >= /=) |
1012 |
(when (every #'constantp args) |
(when (every #'constantp args) |
1020 |
((- + * min max logand logior logxor logeqv gcd lcm) |
((- + * min max logand logior logxor logeqv gcd lcm) |
1021 |
(when (every #'constantp args) |
(when (every #'constantp args) |
1022 |
(try (eval form))) |
(try (eval form))) |
1023 |
|
(try 0) |
1024 |
(mapc try-fn args) |
(mapc try-fn args) |
1025 |
(prune-nary-fn form try-fn) |
(prune-nary-fn form try-fn) |
1026 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
1027 |
|
|
1028 |
|
((/) |
1029 |
|
(when (every #'constantp args) |
1030 |
|
(try (eval form))) |
1031 |
|
(try 0) |
1032 |
|
(try (car args)) |
1033 |
|
(when (cddr args) |
1034 |
|
(prune (car args) #'(lambda (form) (try `(/ ,form ,(second args))))))) |
1035 |
|
|
1036 |
((multiple-value-call) |
((multiple-value-call) |
1037 |
;; Simplify usual case |
;; Simplify usual case |
1038 |
(when (= nargs 2) |
(when (= nargs 2) |
1063 |
(prune-fn form try-fn))) |
(prune-fn form try-fn))) |
1064 |
|
|
1065 |
((setq) |
((setq) |
1066 |
|
(try 0) |
1067 |
;; Assumes only one assignment |
;; Assumes only one assignment |
1068 |
(assert (= (length form) 3)) |
(assert (= (length form) 3)) |
1069 |
(try (second args)) |
(try (second args)) |
1070 |
(prune (second args) |
(unless (integerp (second args)) |
1071 |
#'(lambda (form) |
(prune (second args) |
1072 |
(try `(,op ,(first args) ,form))))) |
#'(lambda (form) |
1073 |
|
(try `(,op ,(first args) ,form)))))) |
1074 |
|
|
1075 |
((byte) |
((byte) |
1076 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
1077 |
|
|
1078 |
((deposit-field dpb) |
((deposit-field dpb) |
1079 |
|
(try 0) |
1080 |
(destructuring-bind (a1 a2 a3) |
(destructuring-bind (a1 a2 a3) |
1081 |
args |
args |
1082 |
(try a1) |
(try a1) |
1091 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
1092 |
|
|
1093 |
((ldb mask-field) |
((ldb mask-field) |
1094 |
|
(try 0) |
1095 |
(try (second args)) |
(try (second args)) |
1096 |
(when (and (consp (first args)) |
(when (and (consp (first args)) |
1097 |
(eq 'byte (first (first args))) |
(eq 'byte (first (first args))) |
1101 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
1102 |
|
|
1103 |
((ldb-test) |
((ldb-test) |
1104 |
|
(try t) |
1105 |
|
(try nil) |
1106 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
1107 |
|
|
1108 |
((let let*) |
((let let*) |
1176 |
#'(lambda (x) (try `(throw ,(first args) ,x))))) |
#'(lambda (x) (try `(throw ,(first args) ,x))))) |
1177 |
|
|
1178 |
((flet labels) |
((flet labels) |
1179 |
|
(try 0) |
1180 |
(prune-flet form try-fn)) |
(prune-flet form try-fn)) |
1181 |
|
|
1182 |
((case) |
((case) |
1197 |
(try `(isqrt (abs ,form)))))))) |
(try `(isqrt (abs ,form)))))))) |
1198 |
|
|
1199 |
((ash) |
((ash) |
1200 |
|
(try 0) |
1201 |
(let ((form1 (second form)) |
(let ((form1 (second form)) |
1202 |
(form2 (third form))) |
(form2 (third form))) |
1203 |
(try form1) |
(try form1) |
1219 |
,form))))))))) |
,form))))))))) |
1220 |
|
|
1221 |
((floor ceiling truncate round mod rem) |
((floor ceiling truncate round mod rem) |
1222 |
|
(try 0) |
1223 |
(let ((form1 (second form)) |
(let ((form1 (second form)) |
1224 |
(form2 (third form))) |
(form2 (third form))) |
1225 |
(try form1) |
(try form1) |
1242 |
`(,op ,form1 (,(first form2) ,(second form2) |
`(,op ,form1 (,(first form2) ,(second form2) |
1243 |
,form))))))))) |
,form))))))))) |
1244 |
|
|
1245 |
|
((constantly) |
1246 |
|
(unless (eql (car args) 0) |
1247 |
|
(prune (car args) |
1248 |
|
#'(lambda (arg) (try `(constantly ,arg)))))) |
1249 |
|
|
1250 |
((funcall) |
((funcall) |
1251 |
|
(try 0) |
1252 |
(let ((fn (second form)) |
(let ((fn (second form)) |
1253 |
(fn-args (cddr form))) |
(fn-args (cddr form))) |
1254 |
(mapc try-fn fn-args) |
(mapc try-fn fn-args) |
1255 |
|
(unless (equal fn '(constantly 0)) |
1256 |
|
(try `(funcall (constantly 0) ,@fn-args))) |
1257 |
(when (and (consp fn) |
(when (and (consp fn) |
1258 |
(eql (car fn) 'function) |
(eql (car fn) 'function) |
1259 |
(symbolp (cadr fn))) |
(symbolp (cadr fn))) |
1264 |
(try `(funcall ,fn ,@args)))))) |
(try `(funcall ,fn ,@args)))))) |
1265 |
|
|
1266 |
((apply) |
((apply) |
1267 |
|
(try 0) |
1268 |
(let ((fn (second form)) |
(let ((fn (second form)) |
1269 |
(fn-args (butlast (cddr form))) |
(fn-args (butlast (cddr form))) |
1270 |
(list-arg (car (last form)))) |
(list-arg (car (last form)))) |
1271 |
(mapc try-fn fn-args) |
(mapc try-fn fn-args) |
1272 |
|
(unless (equal fn '(constantly 0)) |
1273 |
|
(try `(apply (constantly 0) ,@(cddr form)))) |
1274 |
(when (and (consp list-arg) |
(when (and (consp list-arg) |
1275 |
(eq (car list-arg) 'list)) |
(eq (car list-arg) 'list)) |
1276 |
(mapc try-fn (cdr list-arg))) |
(mapc try-fn (cdr list-arg))) |
1286 |
#'(lambda (args) |
#'(lambda (args) |
1287 |
(try `(apply ,fn ,@fn-args |
(try `(apply ,fn ,@fn-args |
1288 |
(list ,@args)))))))) |
(list ,@args)))))))) |
1289 |
|
|
1290 |
|
((progv) |
1291 |
|
(try 0) |
1292 |
|
(prune-progv form try-fn)) |
1293 |
|
|
1294 |
|
((tagbody) |
1295 |
|
(try 0) |
1296 |
|
(prune-tagbody form try-fn)) |
1297 |
|
|
1298 |
(otherwise |
(otherwise |
1299 |
|
(try 0) |
1300 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
1301 |
|
|
1302 |
))))) |
))))) |
1303 |
(setf (gethash form *prune-table*) t) |
(setf (gethash form *prune-table*) t) |
1304 |
nil) |
nil) |
1361 |
#'(lambda (cases) |
#'(lambda (cases) |
1362 |
(try `(,op ,expr ,@cases))))))) |
(try `(,op ,expr ,@cases))))))) |
1363 |
|
|
1364 |
|
(defun prune-tagbody (form try-fn) |
1365 |
|
(declare (type function try-fn)) |
1366 |
|
(let (;; (op (car form)) |
1367 |
|
(body (cdr form))) |
1368 |
|
(loop for i from 0 |
1369 |
|
for e in body |
1370 |
|
do |
1371 |
|
(cond |
1372 |
|
((atom e) |
1373 |
|
;; A tag |
1374 |
|
(unless (find-in-tree e (subseq body 0 i)) |
1375 |
|
(funcall try-fn `(tagbody ,@(subseq body 0 i) |
1376 |
|
,@(subseq body (1+ i)))))) |
1377 |
|
(t |
1378 |
|
(funcall try-fn |
1379 |
|
`(tagbody ,@(subseq body 0 i) |
1380 |
|
,@(subseq body (1+ i)))) |
1381 |
|
(prune e |
1382 |
|
#'(lambda (form) |
1383 |
|
;; Don't put an atom here. |
1384 |
|
(when (consp form) |
1385 |
|
(funcall |
1386 |
|
try-fn |
1387 |
|
`(tagbody ,@(subseq body 0 i) |
1388 |
|
,form |
1389 |
|
,@(subseq body (1+ i)))))))))))) |
1390 |
|
|
1391 |
|
(defun prune-progv (form try-fn) |
1392 |
|
(declare (type function try-fn)) |
1393 |
|
(let (;; (op (car form)) |
1394 |
|
(vars-form (cadr form)) |
1395 |
|
(vals-form (caddr form)) |
1396 |
|
(body-list (cdddr form))) |
1397 |
|
(when (and (null vars-form) (null vals-form)) |
1398 |
|
(funcall try-fn `(let () ,@body-list))) |
1399 |
|
(when (and (consp vals-form) (eql (car vals-form) 'list)) |
1400 |
|
(when (and (consp vars-form) (eql (car vars-form) 'quote)) |
1401 |
|
(let ((vars (cadr vars-form)) |
1402 |
|
(vals (cdr vals-form))) |
1403 |
|
(when (eql (length vars) (length vals)) |
1404 |
|
(let ((let-form `(let () ,@body-list))) |
1405 |
|
(mapc #'(lambda (var val) |
1406 |
|
(setq let-form `(let ((,var ,val)) ,let-form))) |
1407 |
|
vars vals) |
1408 |
|
(funcall try-fn let-form))) |
1409 |
|
;; Try simplifying the vals forms |
1410 |
|
(prune-list vals |
1411 |
|
#'prune |
1412 |
|
#'(lambda (vals) |
1413 |
|
(funcall try-fn |
1414 |
|
`(progv ,vars-form (list ,@vals) ,@body-list))))))) |
1415 |
|
;; Try simplifying the body |
1416 |
|
(when (eql (length body-list) 1) |
1417 |
|
(prune (car body-list) |
1418 |
|
#'(lambda (form) |
1419 |
|
(funcall try-fn |
1420 |
|
`(progv ,vars-form ,vals-form ,form))))))) |
1421 |
|
|
1422 |
(defun prune-nary-fn (form try-fn) |
(defun prune-nary-fn (form try-fn) |
1423 |
;; Attempt to reduce the number of arguments to the fn |
;; Attempt to reduce the number of arguments to the fn |
1424 |
;; Do not reduce below 1 |
;; Do not reduce below 1 |