/[gcl]/gcl/ansi-tests/random-int-form.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/random-int-form.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.23 by pfdietz, Sun Nov 16 00:51:17 2003 UTC revision 1.24 by pfdietz, Sat Nov 29 02:00:44 2003 UTC
# Line 33  Line 33 
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))
# Line 60  Line 64 
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    
# Line 117  Line 122 
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
# Line 241  Line 248 
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
# Line 335  Line 343 
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*))
# Line 364  Line 379 
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)
# Line 415  Line 438 
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
# Line 598  Line 623 
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*
# Line 752  Line 777 
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
# Line 773  Line 800 
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)
# Line 799  Line 826 
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)
# Line 913  Line 950 
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    
# Line 988  Line 1057 
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))
# Line 1001  Line 1070 
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    

Legend:
Removed from v.1.23  
changed lines
  Added in v.1.24

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26