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* $x $y $z)) |
*opt-result* *unopt-result* $x $y $z |
37 |
|
*compile-unoptimized-form*)) |
38 |
|
|
39 |
(defun f (i) (let ((plist (elt $y i))) |
(defun f (i) (let ((plist (elt $y i))) |
40 |
(apply (compile nil (getf plist :optimized-lambda-form)) |
(apply (compile nil (getf plist :optimized-lambda-form)) |
41 |
(getf plist :vals)))) |
(getf plist :vals)))) |
42 |
|
|
43 |
(defun g (i) (let ((plist (elt $y i))) |
(defun g (i) (let ((plist (elt $y i))) |
44 |
(apply (compile nil (getf plist :unoptimized-lambda-form)) |
(if *compile-unoptimized-form* |
45 |
(getf plist :vals)))) |
(apply (compile nil (getf plist :unoptimized-lambda-form)) |
46 |
|
(getf plist :vals)) |
47 |
|
(apply (eval `(function ,(getf plist :unoptimized-lambda-form))) |
48 |
|
(getf plist :vals))))) |
49 |
|
|
50 |
(defun loop-random-int-forms (&optional (size 200) (nvars 3)) |
(defun loop-random-int-forms (&optional (size 200) (nvars 3)) |
51 |
(unless (boundp '$x) (setq $x nil)) |
(unless (boundp '$x) (setq $x nil)) |
64 |
(terpri)))) |
(terpri)))) |
65 |
|
|
66 |
(defvar *random-int-form-blocks* nil) |
(defvar *random-int-form-blocks* nil) |
67 |
|
(defvar *random-int-form-catch-tags* nil) |
68 |
|
|
69 |
(defvar *maximum-random-int-bits* 45) |
(defvar *maximum-random-int-bits* 45) |
70 |
|
|
122 |
(form (let ((*vars* (loop for v in vars |
(form (let ((*vars* (loop for v in vars |
123 |
for tp in var-types |
for tp in var-types |
124 |
collect (make-var-desc :name v |
collect (make-var-desc :name v |
125 |
:type tp)))) |
:type tp))) |
126 |
|
(*random-int-form-blocks* nil) |
127 |
|
(*random-int-form-catch-tags* nil)) |
128 |
(make-random-integer-form size))) |
(make-random-integer-form size))) |
129 |
(vals-list |
(vals-list |
130 |
(loop repeat 20 |
(loop repeat 20 |
248 |
(4 |
(4 |
249 |
(let ((arg (let ((*flet-names* nil) |
(let ((arg (let ((*flet-names* nil) |
250 |
(*vars* nil) |
(*vars* nil) |
251 |
(*random-int-form-blocks* nil)) |
(*random-int-form-blocks* nil) |
252 |
|
(*random-int-form-catch-tags* nil)) |
253 |
(make-random-integer-form (1- size))))) |
(make-random-integer-form (1- size))))) |
254 |
(rcase |
(rcase |
255 |
(2 `(load-time-value ,arg t)) |
(2 `(load-time-value ,arg t)) |
256 |
(1 `(load-time-value ,arg)) |
(1 `(load-time-value ,arg)) |
257 |
(1 `(load-time-value ,arg nil))))) |
(1 `(load-time-value ,arg nil))))) |
258 |
|
|
259 |
#-(or cmu allegro) |
#-(or cmu allegro) |
260 |
(2 |
(2 |
343 |
(2 `(multiple-value-bind (,var) ,e1 ,e2))))))) |
(2 `(multiple-value-bind (,var) ,e1 ,e2))))))) |
344 |
|
|
345 |
(4 `(let () ,(make-random-integer-form (1- size)))) |
(4 `(let () ,(make-random-integer-form (1- size)))) |
346 |
|
|
347 |
(10 |
(10 |
348 |
(let* ((name (random-from-seq #(b1 b2 b3 b4 b5 b6 b7 b8))) |
(let* ((name (random-from-seq #(b1 b2 b3 b4 b5 b6 b7 b8))) |
349 |
(*random-int-form-blocks* (adjoin name *random-int-form-blocks*))) |
(*random-int-form-blocks* (adjoin name *random-int-form-blocks*))) |
350 |
`(block ,name ,(make-random-integer-form (1- size))))) |
`(block ,name ,(make-random-integer-form (1- size))))) |
351 |
|
|
352 |
|
(20 |
353 |
|
(let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8)))) |
354 |
|
(*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*))) |
355 |
|
`(catch ,tag ,(make-random-integer-form (1- size))))) |
356 |
|
|
357 |
(4 ;; setq |
(4 ;; setq |
358 |
(if *vars* |
(if *vars* |
359 |
(let* ((vdesc (random-from-seq *vars*)) |
(let* ((vdesc (random-from-seq *vars*)) |
379 |
;; No blocks -- try again |
;; No blocks -- try again |
380 |
(make-random-integer-form size))) |
(make-random-integer-form size))) |
381 |
|
|
382 |
|
(20 |
383 |
|
(if *random-int-form-catch-tags* |
384 |
|
(let ((tag (random-from-seq *random-int-form-catch-tags*)) |
385 |
|
(form (make-random-integer-form (1- size)))) |
386 |
|
`(throw ,tag ,form)) |
387 |
|
;; No catch tags -- try again |
388 |
|
(make-random-integer-form size))) |
389 |
|
|
390 |
(5 |
(5 |
391 |
(if *random-int-form-blocks* |
(if *random-int-form-blocks* |
392 |
(destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) |
(destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) |
438 |
(make-random-integer-form size) |
(make-random-integer-form size) |
439 |
(let* ((op (random-from-seq #(flet labels))) |
(let* ((op (random-from-seq #(flet labels))) |
440 |
(minargs (random 4)) |
(minargs (random 4)) |
441 |
(maxargs (rcase |
(maxargs #+:allegro minargs |
442 |
|
#-:allegro |
443 |
|
(rcase |
444 |
(1 minargs) |
(1 minargs) |
445 |
(1 (+ minargs (random 4))))) |
(1 (+ minargs (random 4))))) |
446 |
(arg-names (loop for i from 1 to maxargs |
(arg-names (loop for i from 1 to maxargs |
623 |
#+cmu (declare (optimize (extensions:inhibit-warnings 3))) |
#+cmu (declare (optimize (extensions:inhibit-warnings 3))) |
624 |
(declare (optimize (safety 3))) |
(declare (optimize (safety 3))) |
625 |
(declare (optimize (speed 0))) |
(declare (optimize (speed 0))) |
626 |
(declare (optimize (debug 0))) |
(declare (optimize (debug 3))) |
627 |
,form)) |
,form)) |
628 |
|
|
629 |
(defvar *compile-using-defun* |
(defvar *compile-using-defun* |
777 |
(when (gethash form *prune-table*) |
(when (gethash form *prune-table*) |
778 |
(return-from prune nil)) |
(return-from prune nil)) |
779 |
(flet ((try (x) (funcall try-fn x))) |
(flet ((try (x) (funcall try-fn x))) |
780 |
(when (consp form) |
(cond |
781 |
|
((keywordp form) nil) |
782 |
|
((integerp form) |
783 |
|
(unless (zerop form) (try 0))) |
784 |
|
((consp form) |
785 |
(let* ((op (car form)) |
(let* ((op (car form)) |
786 |
(args (cdr form)) |
(args (cdr form)) |
787 |
(nargs (length args))) |
(nargs (length args))) |
788 |
(case op |
(case op |
789 |
|
|
790 |
((signum integer-length logcount |
((signum integer-length logcount |
791 |
gcd lcm logandc1 logandc2 lognand lognor logorc1 logorc2 |
logandc1 logandc2 lognand lognor logorc1 logorc2 |
792 |
realpart imagpart) |
realpart imagpart) |
793 |
(mapc #'try args) |
(mapc #'try args) |
|
(try 0) |
|
|
(try -1) |
|
794 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
795 |
|
|
796 |
((abs 1+ 1- identity values progn prog1 multiple-value-prog1 unwind-protect |
((abs 1+ 1- identity values progn prog1 multiple-value-prog1 unwind-protect |
800 |
|
|
801 |
((typep) |
((typep) |
802 |
(try (car args)) |
(try (car args)) |
803 |
(prune (cadr args) |
(prune (car args) |
804 |
#'(lambda (form) `(,op ,form ,@(cdr args))))) |
#'(lambda (form) `(,op ,form ,@(cdr args))))) |
805 |
|
|
806 |
((load-time-value) |
((load-time-value) |
826 |
(when (every #'constantp args) |
(when (every #'constantp args) |
827 |
(try (eval form))) |
(try (eval form))) |
828 |
(mapc try-fn args) |
(mapc try-fn args) |
829 |
|
(prune-fn form try-fn) |
830 |
|
(try t) |
831 |
|
(try nil)) |
832 |
|
|
833 |
|
((and or = < > <= >= /=) |
834 |
|
(when (every #'constantp args) |
835 |
|
(try (eval form))) |
836 |
|
(try t) |
837 |
|
(try nil) |
838 |
|
(mapc try-fn args) |
839 |
|
(prune-nary-fn form try-fn) |
840 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
841 |
|
|
842 |
((- + * min max logand logior logxor logeqv |
((- + * min max logand logior logxor logeqv gcd lcm) |
|
and or = < > <= >= /=) |
|
843 |
(when (every #'constantp args) |
(when (every #'constantp args) |
844 |
(try (eval form))) |
(try (eval form))) |
845 |
(mapc try-fn args) |
(mapc try-fn args) |
950 |
#'(lambda (x) |
#'(lambda (x) |
951 |
(try `(block ,name ,x)))))))) |
(try `(block ,name ,x)))))))) |
952 |
|
|
953 |
|
((catch) |
954 |
|
(let* ((tag (second form)) |
955 |
|
(name (if (consp tag) (cadr tag) tag)) |
956 |
|
(body (cddr form))) |
957 |
|
(when (and body (null (cdr body))) |
958 |
|
(let ((form1 (first body))) |
959 |
|
|
960 |
|
;; Try removing the catch entirely if it is not in use |
961 |
|
;; We make assumptions here about what throws can |
962 |
|
;; be present. |
963 |
|
(when (or (not (find-in-tree 'throw body)) |
964 |
|
(not (find-in-tree name body))) |
965 |
|
(try form1)) |
966 |
|
|
967 |
|
;; Try removing the block if its only use is an immediately |
968 |
|
;; enclosed return-from: (block <n> (return-from <n> <e>)) |
969 |
|
(when (and (consp form1) |
970 |
|
(eq (first form1) 'throw) |
971 |
|
(equal (second form1) name) |
972 |
|
(not (find-in-tree name (third form1)))) |
973 |
|
(try (third form1))) |
974 |
|
|
975 |
|
;; Otherwise, try to simplify the subexpression |
976 |
|
(prune form1 |
977 |
|
#'(lambda (x) |
978 |
|
(try `(catch ,tag ,x)))))))) |
979 |
|
|
980 |
|
((throw) |
981 |
|
(try (second args)) |
982 |
|
(prune (second args) |
983 |
|
#'(lambda (x) (try `(throw ,(first args) ,x))))) |
984 |
|
|
985 |
((flet labels) |
((flet labels) |
986 |
(prune-flet form try-fn)) |
(prune-flet form try-fn)) |
987 |
|
|
1057 |
(prune-list fn-args |
(prune-list fn-args |
1058 |
#'prune |
#'prune |
1059 |
#'(lambda (args) |
#'(lambda (args) |
1060 |
(funcall try-fn `(funcall ,fn ,@args)))))) |
(try `(funcall ,fn ,@args)))))) |
1061 |
|
|
1062 |
((apply) |
((apply) |
1063 |
(let ((fn (second form)) |
(let ((fn (second form)) |
1070 |
(prune-list fn-args |
(prune-list fn-args |
1071 |
#'prune |
#'prune |
1072 |
#'(lambda (args) |
#'(lambda (args) |
1073 |
(funcall try-fn `(apply ,fn ,@args ,list-arg)))) |
(try `(apply ,fn ,@args ,list-arg)))) |
1074 |
(when (and (consp list-arg) |
(when (and (consp list-arg) |
1075 |
(eq (car list-arg) 'list)) |
(eq (car list-arg) 'list)) |
1076 |
|
(try `(apply ,fn ,@fn-args ,@(cdr list-arg) nil)) |
1077 |
(prune-list (cdr list-arg) |
(prune-list (cdr list-arg) |
1078 |
#'prune |
#'prune |
1079 |
#'(lambda (args) |
#'(lambda (args) |
1080 |
(funcall try-fn `(apply ,fn ,@fn-args |
(try `(apply ,fn ,@fn-args |
1081 |
(list ,@args)))))))) |
(list ,@args)))))))) |
1082 |
|
|
1083 |
(otherwise |
(otherwise |
1084 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
1085 |
)))) |
))))) |
1086 |
(setf (gethash form *prune-table*) t) |
(setf (gethash form *prune-table*) t) |
1087 |
nil) |
nil) |
1088 |
|
|