122 |
(rcase |
(rcase |
123 |
;; Unary ops |
;; Unary ops |
124 |
(40 |
(40 |
125 |
(let ((op (random-from-seq '(- abs signum 1+ 1- identity progn |
(let ((op (random-from-seq '(- abs signum 1+ 1- identity progn floor |
126 |
|
ceiling truncate round |
127 |
integer-length logcount values)))) |
integer-length logcount values)))) |
128 |
`(,op ,(make-random-integer-form (1- size) vars)))) |
`(,op ,(make-random-integer-form (1- size) vars)))) |
129 |
|
(2 `(isqrt (abs ,(make-random-integer-form (- size 2) vars)))) |
130 |
|
(3 |
131 |
|
(destructuring-bind (s1 s2) |
132 |
|
(random-partition (- size 2) 2) |
133 |
|
`(ash ,(make-random-integer-form s1 vars) |
134 |
|
(min ,(random 100) |
135 |
|
,(make-random-integer-form s2 vars))))) |
136 |
|
|
137 |
|
;; binary floor, ceiling, truncate, round |
138 |
|
(4 |
139 |
|
(let ((op (random-from-seq #(floor ceiling truncate round))) |
140 |
|
(op2 (random-from-seq #(max min)))) |
141 |
|
(destructuring-bind (s1 s2) |
142 |
|
(random-partition (- size 2) 2) |
143 |
|
`(,op ,(make-random-integer-form s1 vars) |
144 |
|
(,op2 ,(if (eq op2 'max) |
145 |
|
(1+ (random 100)) |
146 |
|
(- (1+ (random 100)))) |
147 |
|
,(make-random-integer-form s2 vars)))))) |
148 |
|
|
149 |
;; Binary op |
;; Binary op |
150 |
(80 |
(80 |
151 |
(let* ((op (random-from-seq |
(let* ((op (random-from-seq |
152 |
'(+ - * * logand min max min max ;; gcd lcm |
'(+ - * * logand min max min max ;; gcd lcm |
153 |
#-:allegro logandc1 ;; bug in ACL 6.2 makes this cause crashes |
;; #-:allegro |
154 |
|
logandc1 |
155 |
logandc2 logeqv logior lognand lognor |
logandc2 logeqv logior lognand lognor |
156 |
#-:allegro logorc1 ;; another bug in ACL 6.2 |
;; #-:allegro |
157 |
|
logorc1 |
158 |
logorc2 logxor)))) |
logorc2 logxor)))) |
159 |
(destructuring-bind (leftsize rightsize) |
(destructuring-bind (leftsize rightsize) |
160 |
(random-partition (1- size) 2) |
(random-partition (1- size) 2) |
176 |
,(make-random-integer-form s1 vars) |
,(make-random-integer-form s1 vars) |
177 |
,(make-random-byte-spec-form s2 vars) |
,(make-random-byte-spec-form s2 vars) |
178 |
,(make-random-integer-form s3 vars)))) |
,(make-random-integer-form s3 vars)))) |
179 |
#-:allegro |
;; #-:allegro |
180 |
(10 |
(10 |
181 |
(destructuring-bind (s1 s2) (random-partition (1- size) 2) |
(destructuring-bind (s1 s2) (random-partition (1- size) 2) |
182 |
`(,(random-from-seq '(ldb mask-field)) |
`(,(random-from-seq '(ldb mask-field)) |
373 |
(let ((n1 (1+ (random (floor n p))))) |
(let ((n1 (1+ (random (floor n p))))) |
374 |
(cons n1 (random-partition (- n n1) (1- p))))))) |
(cons n1 (random-partition (- n n1) (1- p))))))) |
375 |
|
|
|
;;; Interface to the form pruner |
|
|
|
|
376 |
(defun make-optimized-lambda-form (form vars var-types) |
(defun make-optimized-lambda-form (form vars var-types) |
377 |
`(lambda ,vars |
`(lambda ,vars |
378 |
(declare ,@(mapcar #'(lambda (tp var) |
(declare ,@(mapcar #'(lambda (tp var) |
439 |
|
|
440 |
(let ((unopt-result |
(let ((unopt-result |
441 |
(handler-case |
(handler-case |
442 |
(multiple-value-list |
(identity ;; multiple-value-list |
443 |
(apply unoptimized-compiled-fn vals)) |
(apply unoptimized-compiled-fn vals)) |
444 |
(error (c) (declare (ignore c)) |
(error (c) (declare (ignore c)) |
445 |
(%eval-error :unoptimized-form-error)))) |
(%eval-error :unoptimized-form-error)))) |
446 |
(opt-result |
(opt-result |
447 |
(handler-case |
(handler-case |
448 |
(multiple-value-list |
(identity ;; multiple-value-list |
449 |
(apply optimized-compiled-fn vals)) |
(apply optimized-compiled-fn vals)) |
450 |
(error (c) (declare (ignore c)) |
(error (c) (declare (ignore c)) |
451 |
(%eval-error :optimized-form-error))))) |
(%eval-error :optimized-form-error))))) |
460 |
opt-result |
opt-result |
461 |
unopt-result))))))))))) |
unopt-result))))))))))) |
462 |
|
|
463 |
|
;;; Interface to the form pruner |
464 |
|
|
465 |
(defun prune-int-form (form vars var-types vals-list) |
(defun prune-int-form (form vars var-types vals-list) |
466 |
"Conduct tests on selected simplified versions of FORM. Return the |
"Conduct tests on selected simplified versions of FORM. Return the |
467 |
minimal form that still causes some kind of failure." |
minimal form that still causes some kind of failure." |
547 |
|
|
548 |
((ldb mask-field) |
((ldb mask-field) |
549 |
(try (second args)) |
(try (second args)) |
550 |
|
(when (and (consp (first args)) |
551 |
|
(eq 'byte (first (first args))) |
552 |
|
(every #'numberp (cdr (first args))) |
553 |
|
(numberp (second args))) |
554 |
|
(try (eval form))) |
555 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
556 |
|
|
557 |
((ldb-test) |
((ldb-test) |
588 |
|
|
589 |
((case) |
((case) |
590 |
(prune-case form try-fn)) |
(prune-case form try-fn)) |
591 |
|
|
592 |
|
((isqrt) |
593 |
|
(let ((arg (second form))) |
594 |
|
(assert (null (cddr form))) |
595 |
|
(assert (consp arg)) |
596 |
|
(assert (eq (first arg) 'abs)) |
597 |
|
(let ((arg2 (second arg))) |
598 |
|
;; Try to fold |
599 |
|
(when (integerp arg2) |
600 |
|
(try (isqrt (abs arg2)))) |
601 |
|
;; Otherwise, simplify arg2 |
602 |
|
(prune arg2 #'(lambda (form) |
603 |
|
(try `(isqrt (abs ,form)))))))) |
604 |
|
|
605 |
|
((ash) |
606 |
|
(let ((form1 (second form)) |
607 |
|
(form2 (third form))) |
608 |
|
(try form1) |
609 |
|
(try form2) |
610 |
|
(prune form1 |
611 |
|
#'(lambda (form) |
612 |
|
(try `(ash ,form ,form2)))) |
613 |
|
(when (and (consp form2) |
614 |
|
(= (length form2) 3)) |
615 |
|
(when (and (integerp form1) |
616 |
|
(eq (first form2) 'min) |
617 |
|
(every #'integerp (cdr form2))) |
618 |
|
(try (eval form))) |
619 |
|
(let ((form3 (third form2))) |
620 |
|
(prune form3 |
621 |
|
#'(lambda (form) |
622 |
|
(try |
623 |
|
`(ash ,form1 (,(first form2) ,(second form2) |
624 |
|
,form))))))))) |
625 |
|
|
626 |
|
((floor ceiling truncate round) |
627 |
|
(let ((form1 (second form)) |
628 |
|
(form2 (third form))) |
629 |
|
(try form1) |
630 |
|
(when (cddr form) (try form2)) |
631 |
|
(prune form1 |
632 |
|
(if (cddr form) |
633 |
|
#'(lambda (form) |
634 |
|
(try `(,op ,form ,form2))) |
635 |
|
#'(lambda (form) (try `(,op ,form))))) |
636 |
|
(when (and (consp form2) |
637 |
|
(= (length form2) 3)) |
638 |
|
(when (and (integerp form1) |
639 |
|
(member (first form2) '(max min)) |
640 |
|
(every #'integerp (cdr form2))) |
641 |
|
(try (eval form))) |
642 |
|
(let ((form3 (third form2))) |
643 |
|
(prune form3 |
644 |
|
#'(lambda (form) |
645 |
|
(try |
646 |
|
`(,op ,form1 (,(first form2) ,(second form2) |
647 |
|
,form))))))))) |
648 |
|
|
649 |
(otherwise |
(otherwise |
650 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
658 |
(find-in-tree value (cdr tree)))))) |
(find-in-tree value (cdr tree)))))) |
659 |
|
|
660 |
(defun prune-list (list element-prune-fn list-try-fn) |
(defun prune-list (list element-prune-fn list-try-fn) |
661 |
|
(declare (type function element-prune-fn list-try-fn)) |
662 |
"Utility function for pruning in a list." |
"Utility function for pruning in a list." |
663 |
(loop for i from 0 |
(loop for i from 0 |
664 |
for e in list |
for e in list |
671 |
(subseq list (1+ i)))))))) |
(subseq list (1+ i)))))))) |
672 |
|
|
673 |
(defun prune-case (form try-fn) |
(defun prune-case (form try-fn) |
674 |
|
(declare (type function try-fn)) |
675 |
(let* ((op (first form)) |
(let* ((op (first form)) |
676 |
(expr (second form)) |
(expr (second form)) |
677 |
(cases (cddr form))) |
(cases (cddr form))) |
694 |
;; Assume each case has a single form |
;; Assume each case has a single form |
695 |
(prune-list cases |
(prune-list cases |
696 |
#'(lambda (case try-fn) |
#'(lambda (case try-fn) |
697 |
|
(declare (function try-fn)) |
698 |
(when (eql (length case) 2) |
(when (eql (length case) 2) |
699 |
(prune (cadr case) |
(prune (cadr case) |
700 |
#'(lambda (form) |
#'(lambda (form) |
731 |
;; Try to simplify the forms in the RHS of the bindings |
;; Try to simplify the forms in the RHS of the bindings |
732 |
(prune-list binding-list |
(prune-list binding-list |
733 |
#'(lambda (binding try-fn) |
#'(lambda (binding try-fn) |
734 |
|
(declare (function try-fn)) |
735 |
(prune (cadr binding) |
(prune (cadr binding) |
736 |
#'(lambda (form) |
#'(lambda (form) |
737 |
(funcall try-fn |
(funcall try-fn |
768 |
;; Try to simplify the forms in the RHS of the bindings |
;; Try to simplify the forms in the RHS of the bindings |
769 |
(prune-list binding-list |
(prune-list binding-list |
770 |
#'(lambda (binding try-fn) |
#'(lambda (binding try-fn) |
771 |
|
(declare (function try-fn)) |
772 |
(prune (third binding) |
(prune (third binding) |
773 |
#'(lambda (form) |
#'(lambda (form) |
774 |
(funcall try-fn |
(funcall try-fn |