/[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.24 by pfdietz, Sat Nov 29 02:00:44 2003 UTC revision 1.25 by uid67352, Tue Dec 23 18:44:50 2003 UTC
# Line 47  Line 47 
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))
# Line 65  Line 70 
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)
# Line 104  Line 112 
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    
# Line 124  Line 131 
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
# Line 133  Line 142 
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
# Line 188  Line 219 
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))
# Line 229  Line 261 
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    
# Line 243  Line 300 
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))
# Line 279  Line 349 
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)
# Line 298  Line 368 
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))))
# Line 320  Line 406 
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)
# Line 328  Line 415 
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 * *))
# Line 341  Line 431 
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    
# Line 367  Line 478 
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*))
# Line 470  Line 583 
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)
# Line 591  Line 728 
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*
# Line 632  Line 751 
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)
# Line 648  Line 767 
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
# Line 657  Line 776 
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*)
# Line 676  Line 797 
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*))
# Line 689  Line 810 
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)))))
# Line 704  Line 828 
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
# Line 727  Line 853 
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)))
# Line 752  Line 879 
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    
# Line 786  Line 917 
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)
# Line 825  Line 1002 
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)
# Line 842  Line 1020 
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)
# Line 876  Line 1063 
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)
# Line 901  Line 1091 
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)))
# Line 910  Line 1101 
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*)
# Line 983  Line 1176 
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)
# Line 1003  Line 1197 
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)
# Line 1024  Line 1219 
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)
# Line 1046  Line 1242 
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)))
# Line 1060  Line 1264 
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)))
# Line 1079  Line 1286 
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)
# Line 1144  Line 1361 
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

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

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