2
;;;; Author: Paul Dietz
3
;;;; Created: Wed Sep 10 18:03:52 2003
4
;;;; Contains: Simple randon form generator/tester
8
(compile-and-load "random-aux.lsp")
11
;;; This file contains a routine for generating random legal Common Lisp functions
12
;;; for differential testing.
14
;;; To run the random tests by themselves, start a lisp in the ansi-tests directory
15
;;; and do the following:
16
;;; (load "gclload1.lsp")
17
;;; (compile-and-load "random-int-form.lsp")
18
;;; (in-package :cl-test)
19
;;; (let ((*random-state* (make-random-state t)))
20
;;; (test-random-integer-forms 100 4 10000)) ;; or other parameters
22
;;; If a test breaks during testing the variables *optimized-fn-src*,
23
;;; *unoptimized-fn-src*, and *int-form-vals* can be used to get the source
24
;;; of the optimized/unoptimized lambda forms being compiled, and the arguments
25
;;; on which they are called.
27
;;; If a difference is found between optimized/unoptimized functions the forms,
28
;;; values, and results are collected. A list of all these discrepancies is returned
29
;;; after testing finishes (assuming nothing breaks).
31
;;; The variable *compile-unoptimized-form* controls whether the low optimization
32
;;; form is compiled, or if a form funcalling it is EVALed. The latter is often
33
;;; faster, and may find more problems since an interpreter and compiler may evaluate
34
;;; forms in very different ways.
36
;;; The rctest/ subdirectory contains fragments of a more OO random form generator
37
;;; that will eventually replace this preliminary effort.
39
;;; The file misc.lsp contains tests that were mostly for bugs found by this
40
;;; random tester in various Common Lisp implementations.
43
(declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals*
44
*opt-result* *unopt-result* $x $y $z
45
*compile-unoptimized-form*))
47
;;; Little functions used to run collected tests.
48
;;; (f i) runs the ith collected optimized test
49
;;; (g i) runs the ith collected unoptimized test
50
;;; (p i) prints the ith test (forms, input values, and other information)
52
(defun f (i) (let ((plist (elt $y i)))
53
(apply (compile nil (getf plist :optimized-lambda-form))
56
(defun g (i) (let ((plist (elt $y i)))
57
(if *compile-unoptimized-form*
58
(apply (compile nil (getf plist :unoptimized-lambda-form))
60
(apply (the function (eval `(function ,(getf plist :unoptimized-lambda-form))))
61
(getf plist :vals)))))
63
(defun p (i) (write (elt $y i) :pretty t :escape t) (values))
65
(defun load-failures (&key (pathname "failures.lsp"))
66
(length (setq $y (with-open-file (s pathname :direction :input)
67
(loop for x = (read s nil)
68
while x collect x)))))
70
(defun tn (n &optional (size 100))
71
(length (setq $y (prune-results (setq $x (test-random-integer-forms size 2 n))))))
73
(declaim (special *s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*))
75
(defparameter *loop-random-int-form-period* 2000)
77
;;; Run the random tester, collecting failures into the special
80
(defun loop-random-int-forms (&optional (size 200) (nvars 3))
81
(unless (boundp '$x) (setq $x nil))
82
(unless (boundp '$y) (setq $y nil))
87
(finish-output *standard-output*)
88
(let ((x (test-random-integer-forms
89
size nvars *loop-random-int-form-period*
90
:index (* (1- i) *loop-random-int-form-period*))))
92
(setq $x (append $x x))
93
(setq x (prune-results x))
94
(terpri) (print x) (finish-output *standard-output*)
95
(setq $y (append $y x)))
98
(defvar *random-int-form-blocks* nil)
99
(defvar *random-int-form-catch-tags* nil)
100
(defvar *go-tags* nil)
102
(defvar *maximum-random-int-bits* 45)
104
(defvar *random-vals-list-bound* 10)
106
(defvar *max-compile-time* 0)
107
(defvar *max-compile-term* nil)
109
(defvar *print-immediately* nil)
111
(defvar *compile-unoptimized-form*
112
#+(or allegro sbcl) t
113
#-(or allegro sbcl) nil)
115
(declaim (special *vars*))
118
(name nil :type symbol)
121
(defun test-random-integer-forms
123
&key ((:random-state *random-state*) (make-random-state t))
130
"Generate random integer forms of size SIZE with NVARS variables.
131
Do this N times, returning all those on which a discrepancy
132
is found between optimized and nonoptimize, notinlined code."
134
(assert (integerp nvars))
135
(assert (<= 1 nvars 26))
136
(assert (and (integerp n) (plusp n)))
137
(assert (and (integerp n) (plusp size)))
140
;;; (loop for x in (reverse sb-ext:*before-gc-hooks*)
141
;;; do (pushnew x sb-ext:*after-gc-hooks*))
143
(loop for i from 1 to n
144
do (when (= (mod i 100) 0)
145
;; #+sbcl (print "Do gc...")
146
;; #+sbcl (sb-ext::gc :full t)
147
(prin1 i) (princ " ") (finish-output *standard-output*))
148
nconc (let ((result (test-random-integer-form
149
(if random-size (1+ (random size)) size)
150
(if random-nvars (1+ (random nvars)) nvars)
152
:file-prefix file-prefix)))
154
(let ((*print-readably* t))
155
(format t "~%~A~%" (format nil "~S" (car result)))
156
(finish-output *standard-output*)))
159
(defun test-random-integer-form
160
(size nvars &key (index 0) (file-prefix "b"))
161
(let* ((vars (subseq '(a b c d e f g h i j k l m
162
n o p q r s u v w x y z) 0 nvars))
163
(var-ranges (mapcar #'make-random-integer-range vars))
164
(var-types (mapcar #'(lambda (range)
165
(let ((lo (car range))
170
(form (let ((*vars* (loop for v in vars
172
collect (make-var-desc :name v
174
(*random-int-form-blocks* nil)
175
(*random-int-form-catch-tags* nil)
178
(make-random-integer-form (1+ (random size)))))
180
(loop repeat *random-vals-list-bound*
182
(mapcar #'(lambda (range)
183
(let ((lo (car range))
185
(random-from-interval (1+ hi) lo)))
187
(opt-decls-1 (make-random-optimize-settings))
188
(opt-decls-2 (make-random-optimize-settings)))
189
(when *print-immediately*
191
(s (format nil "~A~A.lsp" file-prefix index)
192
:direction :output :if-exists :error)
193
(print `(defparameter *x*
195
:var-types ,var-types
196
:vals-list ,vals-list
201
(print '(load "c.lsp") s)
204
(make-list 1000000) ;; try to trigger a gc
206
(test-int-form form vars var-types vals-list opt-decls-1 opt-decls-2)))
208
(defun make-random-optimize-settings ()
209
(loop for settings = (cons
210
(list 'speed (1+ (random 3)))
211
(loop for s in '(space safety debug compilation-speed)
215
#+allegro (subsetp '((speed 3) (safety 0)) settings :test 'equal)
217
finally (return settings)))
219
(defun fn-symbols-in-form (form)
220
"Return a list of the distinct standardized lisp function
221
symbols occuring ing FORM. These are used to generate a NOTINLINE
222
declaration for the unoptimized form."
224
(remove-duplicates (fn-symbols-in-form* form) :test #'eq)
225
*cl-function-or-accessor-symbols*))
227
(defun fn-symbols-in-form* (form)
229
(if (symbolp (car form))
230
(cons (car form) (mapcan #'fn-symbols-in-form* (cdr form)))
231
(mapcan #'fn-symbols-in-form* form))))
233
(defun make-random-integer-range (&optional var)
234
"Generate a list (LO HI) of integers, LO <= HI. This is used
235
for generating integer types."
236
(declare (ignore var))
238
(1 (flet ((%r () (let ((r (ash 1 (1+ (random *maximum-random-int-bits*)))))
239
(- (random r) (floor (/ r 2))))))
242
(list (min x y) (max x y)))))
243
(1 (let* ((b (ash 1 (1+ (random *maximum-random-int-bits*))))
244
(b2 (floor (/ b 2))))
245
(let ((x (- (random b) b2))
246
(y (- (random b) b2)))
247
(list (min x y) (max x y)))))))
249
(defun fn-arg-name (fn-name arg-index)
250
(intern (concatenate 'string
251
(subseq (symbol-name fn-name) 1)
252
(format nil "-~D" arg-index))
253
(symbol-package fn-name)))
255
(declaim (special *flet-names*))
256
(defparameter *flet-names* nil)
258
(defun make-random-integer ()
259
(let ((r (ash 1 (1+ (random 32)))))
260
(- (random r) (floor (/ r 2)))))
262
(defun random-var-desc ()
264
(let* ((pos (random (length *vars*)))
265
(desc (elt *vars* pos)))
266
(when (= pos (position (var-desc-name desc) (the list *vars*)
267
:key #'var-desc-name))
270
(defun is-zero-rank-integer-array-type (type)
271
"This function was introduced because of a bug in ACL 6.2"
272
; (subtypep type '(array integer 0))
274
(eq (car type) 'array)
276
(or (eq (cadr type) '*)
277
(subtypep (cadr type) 'integer))
278
(or (eql (caddr type) 0)
279
(null (caddr type)))))
281
(defun make-random-integer-form (size)
282
"Generate a random legal lisp form of size SIZE (roughly)."
285
;; Leaf node -- generate a variable, constant, or flet function call
289
(10 (make-random-integer))
291
(let* ((desc (random-var-desc))
292
(type (var-desc-type desc))
293
(name (var-desc-name desc)))
295
((subtypep type 'integer) name)
296
(; (subtypep type '(array integer 0))
297
(is-zero-rank-integer-array-type type)
299
((subtypep type '(cons integer integer))
300
(rcase (1 `(car ,name))
304
(1 (if *go-tags* `(go ,(random-from-seq *go-tags*)) nil))
306
(let* ((flet-entry (random-from-seq *flet-names*))
307
(flet-name (car flet-entry))
308
(flet-minargs (cadr flet-entry))
309
(flet-maxargs (caddr flet-entry))
310
(nargs (random-from-interval (1+ flet-maxargs) flet-minargs))
311
(args (loop repeat nargs
312
collect (make-random-integer-form 1))))
313
`(,flet-name ,@args))
322
(make-random-integer-flet-call-form size))
324
(5 (make-random-aref-form size))
328
(let ((op (random-from-seq '(- abs signum 1+ 1- conjugate
330
numerator denominator
332
#-(or armedbear) ignore-errors
333
cl:handler-case restart-case
334
ceiling truncate round realpart imagpart
335
integer-length logcount values
337
`(,op ,(make-random-integer-form (1- size)))))
341
(make-random-integer-unwind-protect-form size))
343
(5 (make-random-integer-mapping-form size))
345
;; prog1, multiple-value-prog1
348
(let* ((op (random-from-seq #(prog1 multiple-value-prog1)))
350
(sizes (random-partition (1- size) (1+ nforms)))
351
(args (mapcar #'make-random-integer-form sizes)))
355
(2 (let* ((nforms (random 4))
356
(sizes (random-partition (1- size) (+ nforms 2)))
357
(args (mapcar #'make-random-integer-form sizes)))
360
(2 `(isqrt (abs ,(make-random-integer-form (- size 2)))))
362
(2 `(the integer ,(make-random-integer-form (1- size))))
364
(1 `(cl:handler-bind nil ,(make-random-integer-form (1- size))))
365
(1 `(restart-bind nil ,(make-random-integer-form (1- size))))
366
#-armedbear (1 `(macrolet () ,(make-random-integer-form (1- size))))
371
(let* ((var (random-from-seq #(iv1 iv2 iv3 iv4)))
373
(sizes (random-partition (1- size) 2))
374
(body (let ((*vars* (cons (make-var-desc :name var :type nil)
376
(make-random-integer-form (first sizes))))
377
(ret-form (make-random-integer-form (second sizes))))
378
(unless (consp body) (setq body `(progn ,body)))
379
`(dotimes (,var ,count ,ret-form) ,body)))
382
(5 (make-random-loop-form (1- size)))
384
(5 (make-random-count-form size))
386
#-(or gcl ecl armedbear)
389
(let ((arg (let ((*flet-names* nil)
391
(*random-int-form-blocks* nil)
392
(*random-int-form-catch-tags* nil)
394
(make-random-integer-form (1- size)))))
396
(4 `(load-time-value ,arg t))
397
(2 `(load-time-value ,arg))
398
(2 `(load-time-value ,arg nil)))))
401
(2 (make-random-integer-eval-form size))
405
(destructuring-bind (s1 s2)
406
(random-partition (- size 2) 2)
407
`(ash ,(make-random-integer-form s1)
409
,(make-random-integer-form s2)))))
411
;; binary floor, ceiling, truncate, round
413
(let ((op (random-from-seq #(floor ceiling truncate round mod rem)))
414
(op2 (random-from-seq #(max min))))
415
(destructuring-bind (s1 s2)
416
(random-partition (- size 2) 2)
417
`(,op ,(make-random-integer-form s1)
418
(,op2 ,(if (eq op2 'max)
420
(- (1+ (random 100))))
421
,(make-random-integer-form s2))))))
425
(let* ((op (random-from-seq
426
'(+ - * logand min max gcd
430
logandc2 logeqv logior lognand lognor
436
(destructuring-bind (leftsize rightsize)
437
(random-partition (1- size) 2)
438
(let ((e1 (make-random-integer-form leftsize))
439
(e2 (make-random-integer-form rightsize)))
444
(let* ((op (random-from-seq
445
#(boole-1 boole-2 boole-and boole-andc1 boole-andc2
446
boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand
447
boole-nor boole-orc1 boole-orc2 boole-set boole-xor))))
448
(destructuring-bind (leftsize rightsize)
449
(random-partition (- size 2) 2)
450
(let ((e1 (make-random-integer-form leftsize))
451
(e2 (make-random-integer-form rightsize)))
452
`(boole ,op ,e1 ,e2)))))
456
(let* ((op (random-from-seq #(+ - * logand min max logior
457
values lcm gcd logxor)))
458
(nargs (1+ (min (random 10) (random 10) (random 10))))
459
(sizes (random-partition (1- size) nargs))
460
(args (mapcar #'make-random-integer-form sizes)))
464
(3 `(expt ,(make-random-integer-form (1- size)) ,(random 3)))
467
(2 `(coerce ,(make-random-integer-form (1- size)) 'integer))
469
;; complex (degenerate case)
470
(2 `(complex ,(make-random-integer-form (1- size)) 0))
472
;; quotient (degenerate cases)
473
(1 `(/ ,(make-random-integer-form (1- size)) 1))
474
(1 `(/ ,(make-random-integer-form (1- size)) -1))
477
(5 (make-random-tagbody-and-progn size))
481
(let* ((cond-size (random (max 1 (floor size 2))))
482
(then-size (random (- size cond-size)))
483
(else-size (- size 1 cond-size then-size))
484
(pred (make-random-pred-form cond-size))
485
(then-part (make-random-integer-form then-size))
486
(else-part (make-random-integer-form else-size)))
487
`(if ,pred ,then-part ,else-part)))
489
(destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)
490
`(,(random-from-seq '(deposit-field dpb))
491
,(make-random-integer-form s1)
492
,(make-random-byte-spec-form s2)
493
,(make-random-integer-form s3))))
497
(destructuring-bind (s1 s2) (random-partition (1- size) 2)
498
`(,(random-from-seq '(ldb mask-field))
499
,(make-random-byte-spec-form s1)
500
,(make-random-integer-form s2))))
502
(20 (make-random-integer-binding-form size))
506
(4 (make-random-integer-progv-form size))
508
(4 `(let () ,(make-random-integer-form (1- size))))
511
(let* ((name (random-from-seq #(b1 b2 b3 b4 b5 b6 b7 b8)))
512
(*random-int-form-blocks* (adjoin name *random-int-form-blocks*)))
513
`(block ,name ,(make-random-integer-form (1- size)))))
516
(let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8))))
517
(*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*)))
518
`(catch ,tag ,(make-random-integer-form (1- size)))))
520
(4 ;; setq and similar
521
(make-random-integer-setq-form size))
523
(10 (make-random-integer-case-form size))
526
(if *random-int-form-blocks*
527
(let ((name (random-from-seq *random-int-form-blocks*))
528
(form (make-random-integer-form (1- size))))
529
`(return-from ,name ,form))
530
;; No blocks -- try again
531
(make-random-integer-form size)))
534
(if *random-int-form-catch-tags*
535
(let ((tag (random-from-seq *random-int-form-catch-tags*))
536
(form (make-random-integer-form (1- size))))
538
;; No catch tags -- try again
539
(make-random-integer-form size)))
542
(if *random-int-form-blocks*
543
(destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)
544
(let ((name (random-from-seq *random-int-form-blocks*))
545
(pred (make-random-pred-form s1))
546
(then (make-random-integer-form s2))
547
(else (make-random-integer-form s3)))
548
`(if ,pred (return-from ,name ,then) ,else)))
549
;; No blocks -- try again
550
(make-random-integer-form size)))
554
(make-random-flet-form size))
557
(let* ((nbits (1+ (min (random 20) (random 20))))
558
(bvec (coerce (loop repeat nbits collect (random 2)) 'simple-bit-vector))
559
(op (random-from-seq #(bit sbit))))
560
`(,op ,bvec (min ,(1- nbits) (max 0 ,(make-random-integer-form (- size 3 nbits)))))))
563
(let* ((nvals (1+ (min (random 20) (random 20))))
564
(lim (ash 1 (+ 3 (random 40))))
565
(vec (coerce (loop repeat nvals collect (random lim)) 'simple-vector))
566
(op (random-from-seq #(aref svref elt))))
567
`(,op ,vec (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals)))))))
570
(let* ((nvals (1+ (min (random 20) (random 20))))
571
(lim (ash 1 (+ 3 (random 40))))
572
(vals (loop repeat nvals collect (random lim)))
574
`(,op ',vals (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals)))))))
578
(defun make-random-aref-form (size)
581
(let* ((desc (random-var-desc))
582
(type (var-desc-type desc))
583
(name (var-desc-name desc)))
586
((subtypep type '(array integer (*)))
587
`(aref ,name (min ,(1- (first (third type)))
588
(max 0 ,(make-random-integer-form (- size 2))))))
589
((subtypep type '(array integer (* *)))
590
(destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2)
592
(min ,(1- (first (third type)))
593
(max 0 ,(make-random-integer-form s1)))
594
(min ,(1- (second (third type)))
595
(max 0 ,(make-random-integer-form s2))))))
597
(make-random-integer-form size)))
599
(defun make-random-count-form (size)
600
(destructuring-bind (s1 s2)
601
(random-partition (1- size) 2)
602
(let ((arg1 (make-random-integer-form s1))
603
(arg2-args (loop repeat s2 collect (make-random-integer))))
605
(test (random-from-seq #(eql = /= < > <= >=)))
607
(1 (make-array (list s2) :initial-contents arg2-args))
609
(let* ((mask (1- (ash 1 (1+ (random 32))))))
610
(make-array (list s2)
612
(mapcar #'(lambda (x) (logand x mask)) arg2-args)
613
:element-type `(integer 0 ,mask))))
614
(1 `(quote ,arg2-args)))))
615
`(,op ,arg1 ,arg2 ,@(rcase
617
(1 (list :test `(quote ,test)))
618
(1 (list :test-not `(quote ,test)))))))))
620
(defun make-random-integer-flet-call-form (size)
622
(let* ((flet-entry (random-from-seq *flet-names*))
623
(flet-name (car flet-entry))
624
(flet-minargs (cadr flet-entry))
625
(flet-maxargs (caddr flet-entry))
626
(nargs (random-from-interval (1+ flet-maxargs) flet-minargs))
630
(let* ((arg-sizes (random-partition (1- size) nargs))
631
(args (mapcar #'make-random-integer-form arg-sizes)))
633
(1 `(,flet-name ,@args))
634
(1 `(multiple-value-call #',flet-name (values ,@args)))
635
(1 `(funcall (function ,flet-name) ,@args))
636
(1 (let ((r (random (1+ (length args)))))
637
`(apply (function ,flet-name)
639
(list ,@(subseq args r))))))))
640
(t (make-random-integer-form size))))
641
(make-random-integer-form size)))
643
(defun make-random-integer-unwind-protect-form (size)
644
(let* ((op 'unwind-protect)
646
(sizes (random-partition (1- size) (1+ nforms)))
647
(arg (make-random-integer-form (first sizes)))
649
;; We have to be careful not to generate code that will
650
;; illegally transfer control to a dead location
651
(let ((*flet-names* nil)
653
(*random-int-form-blocks* nil)
654
(*random-int-form-catch-tags* nil))
655
(mapcar #'make-random-integer-form (rest sizes)))))
656
`(,op ,arg ,@unwind-forms)))
658
(defun make-random-integer-eval-form (size)
660
(let ((*flet-names* nil)
661
(*vars* (remove-if-not #'(lambda (s)
662
(member (var-desc-name s)
663
'(*s1* *s2* *s3* *s4* *s5*
667
(*random-int-form-blocks* nil)
669
(make-random-integer-form size))))
671
(2 `(eval ',(%arg (1- size))))
672
(2 (let* ((nargs (1+ (random 4)))
673
(sizes (random-partition (1- size) nargs))
674
(args (mapcar #'%arg sizes)))
675
`(eval (values ,@args))))
678
(defun make-random-type-for-var (var e1)
682
((and (member var '(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*) :test #'eq)
683
(setq desc (find var *vars* :key #'var-desc-name)))
684
(var-desc-type desc))
687
(1 (setq e1 `(make-array nil :initial-element ,e1
688
,@(rcase (1 nil) (1 '(:adjustable t)))))
689
'(array integer nil))
690
(1 (let ((size (1+ (random 10))))
691
(setq e1 `(make-array '(,size):initial-element ,e1
692
,@(rcase (1 nil) (1 '(:adjustable t)))))
693
`(array integer (,size))))
695
(1 (let ((size1 (1+ (random 10)))
696
(size2 (1+ (random 10))))
697
(setq e1 `(make-array '(,size1 ,size2):initial-element ,e1
698
,@(rcase (1 nil) (1 '(:adjustable t)))))
699
`(array integer (,size1 ,size2))))
701
(1 (setq e1 `(cons ,e1 ,(make-random-integer-form 1)))
702
'(cons integer integer))
703
(1 (setq e1 `(cons ,(make-random-integer-form 1) ,e1))
704
'(cons integer integer)))))
707
(defun make-random-integer-binding-form (size)
708
(destructuring-bind (s1 s2) (random-partition (1- size) 2)
710
(2 (random-from-seq #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)))
711
(2 (random-from-seq #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*)))))
712
(e1 (make-random-integer-form s1))
713
(type (multiple-value-bind (type2 e)
714
(make-random-type-for-var var e1)
717
(e2 (let ((*vars* (cons (make-var-desc :name var :type type)
719
(make-random-integer-form s2)))
720
(op (random-from-seq #(let let*))))
721
;; for now, avoid shadowing
722
(if (member var *vars* :key #'var-desc-name)
723
(make-random-integer-form size)
725
(8 `(,op ((,var ,e1))
726
,@(rcase (1 `((declare (dynamic-extent ,var))))
729
(2 `(multiple-value-bind (,var) ,e1 ,e2)))))))
731
(defun make-random-integer-progv-form (size)
732
(let* ((num-vars (random 4))
733
(possible-vars #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*))
735
(loop repeat num-vars
736
do (loop for r = (elt possible-vars (random (length possible-vars)))
737
while (member r vars)
738
finally (push r vars)))
739
(setq vars (remove-if #'(lambda (var) (let ((desc (find var *vars* :key #'var-desc-name)))
740
(and desc (not (subtypep (var-desc-type desc) 'integer)))))
742
num-vars (length vars))
744
`(progv nil nil ,(make-random-integer-form (1- size)))
745
(destructuring-bind (s1 s2) (random-partition (1- size) 2)
746
(let* ((var-sizes (random-partition s1 num-vars))
747
(var-forms (mapcar #'make-random-integer-form var-sizes))
748
(*vars* (append (loop for v in vars collect
749
(make-var-desc :name v :type '(integer * *)))
751
(body-form (make-random-integer-form s2)))
752
`(progv ',vars (list ,@var-forms) ,body-form))))))
754
(defun make-random-integer-mapping-form (size)
757
(nargs (1+ (random (min 10 (max 1 size)))))
758
(sequence-op (random-from-seq '(vector list))))
759
(when (coin 2) (setq keyargs '(:from-end t)))
762
(let ((start (random nargs)))
763
(setq keyargs `(:start ,start ,@keyargs))
765
(let ((end (+ start 1 (random (- nargs start)))))
766
(setq keyargs `(:end ,end ,@keyargs))))))
769
(let ((end (1+ (random nargs))))
770
(setq keyargs `(:end ,end ,@keyargs))))))
773
(let ((sizes (random-partition (1- size) nargs))
774
(op (random-from-seq #(+ - * logand logxor logior max min))))
775
`(reduce ,(rcase (1 `(function ,op))
778
,@(mapcar #'make-random-integer-form sizes))
782
(destructuring-bind (size1 size2) (random-partition (1- size) 2)
783
(let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6))
784
(var1 (random-from-seq vars))
785
(var2 (random-from-seq (remove var1 vars)))
786
(form (let ((*vars* (list*
787
(make-var-desc :name var1 :type '(integer * *))
788
(make-var-desc :name var2 :type '(integer * *))
790
(make-random-integer-form size1)))
791
(sizes (random-partition size2 nargs))
792
(args (mapcar #'make-random-integer-form sizes)))
793
`(reduce (function (lambda (,var1 ,var2) ,form))
794
(,sequence-op ,@args)
797
(defun make-random-integer-setq-form (size)
799
(let* ((vdesc (random-from-seq *vars*))
800
(var (var-desc-name vdesc))
801
(type (var-desc-type vdesc))
802
(op (random-from-seq #(setq setf shiftf))))
804
((subtypep '(integer * *) type)
805
(assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
807
(1 (when (member var '(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*))
808
(setq op (random-from-seq #(setf shiftf))
809
var `(symbol-value ',var))))
810
(1 (setq op 'multiple-value-setq)
811
(setq var (list var)))
813
`(,op ,var ,(make-random-integer-form (1- size))))
815
(eq (car type) 'integer)
816
(integerp (second type))
817
(integerp (third type)))
818
(assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
820
(1 (when (member var '(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*))
821
(setq op (random-from-seq #(setf shiftf))
822
var `(symbol-value ',var))))
823
(1 (setq op 'multiple-value-setq)
824
(setq var (list var)))
826
`(,op ,var ,(random-from-interval (1+ (third type)) (second type))))
827
((and type (is-zero-rank-integer-array-type type)) ; (subtypep type '(array integer nil))
828
(assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
830
(setq op (random-from-seq #(setf shiftf))))
831
`(,op (aref ,var) ,(make-random-integer-form (- size 2))))
832
((and type (subtypep type '(array integer (*))))
834
(setq op (random-from-seq #(setf shiftf))))
835
(destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2)
836
`(,op (aref ,var (min ,(1- (first (third type)))
838
,(make-random-integer-form s1))))
839
,(make-random-integer-form s2))))
840
((and type (subtypep type '(array integer (* *))))
842
(setq op (random-from-seq #(setf shiftf))))
843
(destructuring-bind (s1 s2 s3) (random-partition (max 3 (- size 3)) 3)
845
(min ,(1- (first (third type)))
847
,(make-random-integer-form s1)))
848
(min ,(1- (second (third type)))
850
,(make-random-integer-form s2))))
851
,(make-random-integer-form s3))))
852
;; Abort -- can't assign
853
(t (make-random-integer-form size))))
854
(make-random-integer-form size)))
857
(defun make-random-integer-case-form (size)
858
(let ((ncases (1+ (random 10))))
859
(if (< (+ size size) (+ ncases 2))
860
;; Too small, give up
861
(make-random-integer-form size)
862
(let* ((sizes (random-partition (1- size) (+ ncases 2)))
863
(bound (ash 1 (+ 2 (random 16))))
864
(lower-bound (if (coin 3) 0 (- bound)))
865
(upper-bound (if (and (< lower-bound 0) (coin 3))
870
for case-size in (cddr sizes)
871
for vals = (loop repeat (1+ (min (random 10) (random 10)))
872
collect (random-from-interval
873
upper-bound lower-bound))
874
for result = (make-random-integer-form case-size)
876
collect `(,vals ,result)))
877
(expr (make-random-integer-form (first sizes))))
880
(t ,(make-random-integer-form (second sizes))))))))
882
(defun make-random-flet-form (size)
883
"Generate random flet, labels forms, for now with no arguments
884
and a single binding per form."
885
(let ((fname (random-from-seq #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10
886
%f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18))))
887
(if (assoc fname *flet-names*)
888
;; Fail if the name is in use
889
(make-random-integer-form size)
890
(let* ((op (random-from-seq #(flet labels)))
892
(maxargs #+:allegro minargs
896
(1 (+ minargs (random 4)))))
898
(keyarg-n (if keyarg-p (random 3) 0))
899
(arg-names (loop for i from 1 to maxargs
900
collect (fn-arg-name fname i)))
901
(key-arg-names (loop for i from 1 to keyarg-n
902
collect (intern (format nil "KEY~A" i)
903
(find-package "CL-TEST"))))
904
(allow-other-keys (and keyarg-p (coin 3)))
906
(destructuring-bind (s1 s2 . opt-sizes)
907
(random-partition (1- size) (+ 2 keyarg-n (- maxargs minargs)))
909
;; Allow return-from of the flet/labels function
910
(let ((*random-int-form-blocks*
911
(cons fname *random-int-form-blocks*))
912
(*vars* (nconc (loop for var in (append arg-names key-arg-names)
913
collect (make-var-desc :name var
914
:type '(integer * *)))
916
(make-random-integer-form s1)))
917
(form2 (let ((*flet-names* (cons (list fname minargs maxargs keyarg-p)
919
(make-random-integer-form s2)))
920
(opt-forms (mapcar #'make-random-integer-form opt-sizes)))
922
`(,op ((,fname (,@(subseq arg-names 0 minargs)
925
(subseq arg-names minargs)
931
(subseq opt-forms (- maxargs minargs)))
932
(when allow-other-keys '(&allow-other-keys))
936
`(,op ((,fname (,@arg-names
942
(when allow-other-keys '(&allow-other-keys))
947
(defun make-random-tagbody (size)
948
(let* ((num-forms (random 6))
950
(loop for i below num-forms
951
do (loop for tag = (rcase
952
#-allegro (1 (random 8))
953
(1 (random-from-seq #(tag1 tag2 tag3 tag4
954
tag5 tag6 tag7 tag8))))
955
while (member tag tags)
956
finally (push tag tags)))
957
(assert (= (length (remove-duplicates tags)) (length tags)))
958
(let* ((*go-tags* (set-difference *go-tags* tags))
959
(sizes (if (> num-forms 0) (random-partition (1- size) num-forms) nil))
961
(loop for tag-list on tags
962
for i below num-forms
964
collect (let ((*go-tags* (append tag-list *go-tags*)))
965
(make-random-integer-form size)))))
966
`(tagbody ,@(loop for tag in tags
968
when (atom form) do (setq form `(progn ,form))
969
append `(,form ,tag))))))
971
(defun make-random-tagbody-and-progn (size)
972
(let* ((final-size (random (max 1 (floor size 5))))
973
(tagbody-size (- size final-size)))
974
(let ((final-form (make-random-integer-form final-size))
975
(tagbody-form (make-random-tagbody tagbody-size)))
976
`(progn ,tagbody-form ,final-form))))
978
(defun make-random-pred-form (size)
979
"Make a random form whose value is to be used as a generalized boolean."
982
(1 (if (coin) t nil))
984
`(,(random-from-seq '(< <= = > >= /= eql equal))
985
,(make-random-integer-form size)
986
,(make-random-integer-form size))))
988
(1 (if (coin) t nil))
989
(3 `(not ,(make-random-pred-form (1- size))))
990
(6 (destructuring-bind (leftsize rightsize)
991
(random-partition (1- size) 2)
992
`(,(random-from-seq '(and or))
993
,(make-random-pred-form leftsize)
994
,(make-random-pred-form rightsize))))
995
(1 (destructuring-bind (leftsize rightsize)
996
(random-partition (1- size) 2)
997
`(,(random-from-seq '(< <= > >= = /= eql equal))
998
,(make-random-integer-form leftsize)
999
,(make-random-integer-form rightsize))))
1000
(3 (let* ((cond-size (random (max 1 (floor size 2))))
1001
(then-size (random (- size cond-size)))
1002
(else-size (- size 1 cond-size then-size))
1003
(pred (make-random-pred-form cond-size))
1004
(then-part (make-random-pred-form then-size))
1005
(else-part (make-random-pred-form else-size)))
1006
`(if ,pred ,then-part ,else-part)))
1007
(1 (destructuring-bind (s1 s2)
1008
(random-partition (1- size) 2)
1009
`(ldb-test ,(make-random-byte-spec-form s1)
1010
,(make-random-integer-form s2))))
1012
(2 (destructuring-bind (s1 s2)
1013
(random-partition (1- size) 2)
1014
(let ((arg1 (make-random-integer-form s1))
1015
(arg2-args (loop repeat s2 collect (make-random-integer))))
1016
(let ((op (random-from-seq #(find position)))
1017
(test (random-from-seq #(eql = /= < > <= >=)))
1019
(1 (make-array (list s2) :initial-contents arg2-args))
1021
(let* ((mask (1- (ash 1 (1+ (random 32))))))
1022
(make-array (list s2)
1024
(mapcar #'(lambda (x) (logand x mask)) arg2-args)
1025
:element-type `(integer 0 ,mask))))
1026
(1 `(quote ,arg2-args)))))
1027
`(,op ,arg1 ,arg2 ,@(rcase
1029
(1 (list :test `(quote ,test)))
1030
(1 (list :test-not `(quote ,test)))))))))
1032
(1 (let ((index (random (1+ (random *maximum-random-int-bits*))))
1033
(form (make-random-integer-form (1- size))))
1034
`(logbitp ,index ,form)))
1036
(let ((subform (make-random-integer-form (- size 2)))
1039
(1 `(integer ,@(make-random-integer-range)))
1040
(1 `(integer ,(make-random-integer)))
1041
(1 `(integer * ,(make-random-integer)))
1043
`(typep ,subform ',type)))
1046
(defun make-random-loop-form (size)
1048
(make-random-integer-form size)
1049
(let* ((var (random-from-seq #(lv1 lv2 lv3 lv4)))
1051
(*vars* (cons (make-var-desc :name var :type nil)
1054
(1 `(loop for ,var below ,count count ,(make-random-pred-form (- size 2))))
1055
(1 `(loop for ,var below ,count sum ,(make-random-integer-form (- size 2))))
1058
(defun make-random-byte-spec-form (size)
1059
(declare (ignore size))
1060
(let* ((pform (random 33))
1061
(sform (1+ (random 33))))
1062
`(byte ,sform ,pform)))
1064
(defun make-random-element-of-type (type)
1065
"Create a random element of a lisp type."
1068
(let ((type-op (first type)))
1071
(let ((lo (let ((lo (cadr type)))
1073
((consp lo) (1+ (car lo)))
1076
(hi (let ((hi (caddr type)))
1078
((consp hi) (1- (car hi)))
1083
(let ((x (ash 1 (random *maximum-random-int-bits*))))
1084
(random-from-interval x (- x)))
1085
(random-from-interval (1+ hi)
1086
(- hi (random (ash 1 *maximum-random-int-bits*)))))
1089
(random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1)
1091
;; May generalize the next case to increase odds
1092
;; of certain integers (near 0, near endpoints, near
1094
(random-from-interval (1+ hi) lo)))))
1096
(let ((modulus (second type)))
1097
(assert (and (integerp modulus)
1099
(make-random-element-of-type `(integer 0 (,modulus)))))
1101
(if (null (cdr type))
1102
(make-random-element-of-type '(integer 0 *))
1103
(let ((bits (second type)))
1105
(make-random-element-of-type '(integer 0 *))
1107
(assert (and (integerp bits) (>= bits 1)))
1108
(make-random-element-of-type
1109
`(integer 0 ,(1- (ash 1 bits)))))))))
1114
(boolean (random-from-seq #(nil t)))
1115
(symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| cl:car)))
1116
(unsigned-byte (random-from-interval
1117
(1+ (ash 1 (random *maximum-random-int-bits*))) 0))
1118
(integer (let ((x (ash 1 (random *maximum-random-int-bits*))))
1119
(random-from-interval (1+ x) (- x))))
1122
(defun make-optimized-lambda-form (form vars var-types opt-decls)
1124
,@(mapcar #'(lambda (tp var) `(declare (type ,tp ,var)))
1126
(declare (ignorable ,@vars))
1127
#+cmu (declare (optimize (extensions:inhibit-warnings 3)))
1128
(declare (optimize ,@opt-decls))
1131
(defun make-unoptimized-lambda-form (form vars var-types opt-decls)
1132
(declare (ignore var-types))
1134
(declare (notinline ,@(fn-symbols-in-form form)))
1135
#+cmu (declare (optimize (extensions:inhibit-warnings 3)))
1136
(declare (optimize ,@opt-decls))
1139
(defvar *compile-using-defun*
1140
#-(or allegro lispworks) nil
1141
#+(or allegro lispworks) t)
1142
(defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1)
1143
(defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2)
1145
(defun test-int-form (form vars var-types vals-list opt-decls-1 opt-decls-2)
1146
;; Try to compile FORM with associated VARS, and if it compiles
1147
;; check for equality of the two compiled forms.
1148
;; Return a non-nil list of details if a problem is found,
1150
(let ((optimized-fn-src (make-optimized-lambda-form form vars var-types opt-decls-1))
1151
(unoptimized-fn-src (make-unoptimized-lambda-form form vars var-types opt-decls-2)))
1152
(setq *int-form-vals* nil
1153
*optimized-fn-src* optimized-fn-src
1154
*unoptimized-fn-src* unoptimized-fn-src)
1156
(lambda-form opt-defun-name)
1158
(#+sbcl (sb-ext::compiler-note #'muffle-warning)
1159
(warning #'muffle-warning)
1160
(error #'(lambda (c)
1161
(format t "Compilation failure~%~A~%"
1162
(format nil "~S" form))
1163
(finish-output *standard-output*)
1164
(return-from test-int-form
1165
(list (list :vars vars
1167
:var-types var-types
1168
:vals (first vals-list)
1169
:lambda-form lambda-form
1173
(with-output-to-string
1176
(let ((start-time (get-universal-time)))
1178
(if *compile-using-defun*
1180
(eval `(defun ,opt-defun-name
1181
,@(cdr lambda-form)))
1182
(compile opt-defun-name)
1183
(symbol-function opt-defun-name))
1184
(compile nil lambda-form))
1185
(let* ((stop-time (get-universal-time))
1186
(total-time (- stop-time start-time)))
1187
(when (> total-time *max-compile-time*)
1188
(setf *max-compile-time* total-time)
1189
(setf *max-compile-term* lambda-form)))
1192
(let ((optimized-compiled-fn (%compile optimized-fn-src
1193
*name-to-use-in-optimized-defun*))
1194
(unoptimized-compiled-fn
1195
(if *compile-unoptimized-form*
1196
(%compile unoptimized-fn-src *name-to-use-in-unoptimized-defun*)
1197
(eval `(function ,unoptimized-fn-src)))))
1198
(declare (type function optimized-compiled-fn unoptimized-compiled-fn))
1199
(dolist (vals vals-list)
1200
(setq *int-form-vals* vals)
1203
(let ((*print-circle* t))
1204
(format t "~A~%" (format nil "~S" form)))
1205
(finish-output *standard-output*)
1207
(list (list :vars vars
1210
:var-types var-types
1213
:optimized-lambda-form optimized-fn-src
1214
:unoptimized-lambda-form unoptimized-fn-src
1220
(#+sbcl (sb-ext::compiler-note #'muffle-warning)
1221
(warning #'muffle-warning))
1222
(identity ;; multiple-value-list
1223
(apply unoptimized-compiled-fn vals)))
1224
((or error serious-condition)
1226
(%eval-error (list :unoptimized-form-error
1227
(with-output-to-string
1228
(s) (prin1 c s)))))))
1232
(#+sbcl (sb-ext::compiler-note #'muffle-warning)
1233
(warning #'muffle-warning))
1234
(identity ;; multiple-value-list
1235
(apply optimized-compiled-fn vals)))
1236
((or error serious-condition)
1238
(%eval-error (list :optimized-form-error
1239
(with-output-to-string
1240
(s) (prin1 c s))))))))
1241
(if (equal opt-result unopt-result)
1244
(format t "Different results: ~A, ~A~%"
1245
opt-result unopt-result)
1246
(setq *opt-result* opt-result
1247
*unopt-result* unopt-result)
1248
(%eval-error (list :different-results
1250
unopt-result)))))))))))
1252
;;; Interface to the form pruner
1254
(declaim (special *prune-table*))
1256
(defun prune-int-form (input-form vars var-types vals-list opt-decls-1 opt-decls-2)
1257
"Conduct tests on selected simplified versions of INPUT-FORM. Return the
1258
minimal form that still causes some kind of failure."
1260
(let ((form input-form))
1261
(flet ((%try-fn (new-form)
1262
(when (test-int-form new-form vars var-types vals-list
1263
opt-decls-1 opt-decls-2)
1264
(setf form new-form)
1265
(throw 'success nil))))
1266
(let ((*prune-table* (make-hash-table :test #'eq)))
1269
(prune form #'%try-fn)
1271
(when (equal form input-form) (return form))
1272
(setq input-form form))))
1274
(defun prune-results (result-list)
1275
"Given a list of test results, prune their forms down to a minimal set."
1276
(loop for result in result-list
1278
(let* ((form (getf result :form))
1279
(vars (getf result :vars))
1280
(var-types (getf result :var-types))
1281
(vals-list (list (getf result :vals)))
1282
(opt-decl-1 (getf result :decls1))
1283
(opt-decl-2 (getf result :decls2))
1284
(pruned-form (prune-int-form form vars var-types vals-list opt-decl-1 opt-decl-2))
1285
(optimized-lambda-form (make-optimized-lambda-form
1286
pruned-form vars var-types opt-decl-1))
1287
(unoptimized-lambda-form (make-unoptimized-lambda-form
1288
pruned-form vars var-types opt-decl-2)))
1290
:var-types ,var-types
1291
:vals ,(first vals-list)
1295
:optimized-lambda-form ,optimized-lambda-form
1296
:unoptimized-lambda-form ,unoptimized-lambda-form))))
1299
;;; The call (PRUNE form try-fn) attempts to simplify the lisp form
1300
;;; so that it still satisfies TRY-FN. The function TRY-FN should
1301
;;; return if the substitution is a failure. Otherwise, it should
1302
;;; transfer control elsewhere via GO, THROW, etc.
1304
;;; The return value of PRUNE should be ignored.
1306
(defun prune (form try-fn)
1307
(declare (type function try-fn))
1308
(when (gethash form *prune-table*)
1309
(return-from prune nil))
1310
(flet ((try (x) (funcall try-fn x)))
1312
((keywordp form) nil)
1314
(unless (zerop form) (try 0)))
1316
(let* ((op (car form))
1318
(nargs (length args)))
1326
((signum integer-length logcount
1327
logandc1 logandc2 lognand lognor logorc1 logorc2
1331
(prune-fn form try-fn))
1334
(when (and (eq (car args) nil)
1335
(eq (cadr args) ':initial-element)
1336
; (null (cdddr args))
1338
(prune (caddr args) #'(lambda (form) (try `(make-array nil :initial-element ,form . ,(cdddr args)))))
1340
(try `(make-array nil :initial-element ,(caddr args))))
1344
(prune-fn form try-fn))
1348
(let* ((binding-form (first args))
1350
(var (first binding-form))
1351
(count-form (second binding-form))
1352
(result (third binding-form)))
1354
(unless (eql count-form 0)
1355
(try `(dotimes (,var 0 ,result) ,@body)))
1356
(prune result #'(lambda (form)
1357
(try `(dotimes (,var ,count-form ,form) ,@body))))
1358
(when (= (length body) 1)
1362
(try `(dotimes (,var ,count-form ,result) ,form))))))))
1367
(prune-fn form try-fn))
1369
((identity ignore-errors cl:handler-case restart-case locally)
1370
(unless (and (consp args)
1372
(eql (caar args) 'tagbody))
1374
(prune-fn form try-fn))
1379
(prune (second args)
1380
#'(lambda (form) (try `(boole ,(first args) ,form ,(third args)))))
1382
#'(lambda (form) (try `(boole ,(first args) ,(second args) ,form)))))
1384
((unwind-protect prog1 multiple-value-prog1)
1386
(let ((val (first args))
1389
(try `(unwind-protect ,val))
1391
(loop for i from 0 below (length rest)
1393
(try `(unwind-protect ,val
1395
,@(subseq rest (1+ i))))))))
1396
(prune-fn form try-fn))
1399
(assert (>= (length args) 2))
1400
(let ((val1 (first args))
1401
(arg2 (second args))
1404
(prune-fn form try-fn)
1406
(try `(prog2 ,val1 ,arg2))
1408
(loop for i from 0 below (length rest)
1410
(try `(prog2 ,val1 ,arg2
1412
,@(subseq rest (1+ i)))))))))
1417
#'(lambda (form) `(,op ,form ,@(cdr args)))))
1420
(let ((arg (first args)))
1424
(try `(load-time-value ,arg))
1427
(try `(load-time-value ,form ,(second args))))))
1431
(try `(load-time-value ,form))))))))
1435
(let ((arg (first args)))
1439
((eql (car arg) 'quote)
1440
(prune (cadr arg) #'(lambda (form) (try `(eval ',form)))))
1443
(prune arg #'(lambda (form) `(eval ,form))))))
1446
((the macrolet cl:handler-bind restart-bind)
1447
(assert (= (length args) 2))
1449
(prune (second args) try-fn))
1452
(when (every #'constantp args)
1457
(prune-fn form try-fn)
1460
((and or = < > <= >= /=)
1461
(when (every #'constantp args)
1466
(prune-nary-fn form try-fn)
1467
(prune-fn form try-fn))
1469
((- + * min max logand logior logxor logeqv gcd lcm values)
1470
(when (every #'constantp args)
1474
(prune-nary-fn form try-fn)
1475
(prune-fn form try-fn))
1478
(when (every #'constantp args)
1483
(prune (car args) #'(lambda (form) (try `(/ ,form ,(second args)))))))
1485
((expt rationalize rational numberator denominator)
1488
(prune-fn form try-fn))
1493
(prune #'(lambda (form) (try `(coerce ,form ,(cadr args))))
1497
((multiple-value-call)
1498
;; Simplify usual case
1500
(destructuring-bind (arg1 arg2) args
1501
(when (and (consp arg1) (consp arg2)
1502
(eql (first arg1) 'function)
1503
(eql (first arg2) 'values))
1504
(mapc try-fn (rest arg2))
1505
(let ((fn (second arg1)))
1507
(try `(,fn ,@(rest arg2)))))
1508
;; Prune the VALUES form
1509
(prune-list (rest arg2)
1512
(try `(multiple-value-call ,arg1 (values ,@args)))))
1514
(mapc try-fn (rest args)))
1516
((bit sbit elt aref svref)
1518
(when (= (length args) 2)
1519
(let ((arg1 (car args))
1521
(when (and (consp arg2)
1522
(eql (car arg2) 'min)
1523
(integerp (cadr arg2)))
1524
(let ((arg2.2 (caddr arg2)))
1526
(when (and (consp arg2.2)
1527
(eql (car arg2.2) 'max)
1528
(integerp (cadr arg2.2)))
1529
(prune (caddr arg2.2)
1531
(try `(,op ,arg1 (min ,(cadr arg2)
1532
(max ,(cadr arg2.2) ,form))))))))))))
1539
(let (;; (pred (first args))
1540
(then (second args))
1541
(else (third args)))
1544
(when (every #'constantp args)
1546
(prune-fn form try-fn)))
1550
;; Assumes only one assignment
1551
(assert (= (length form) 3))
1553
(unless (integerp (second args))
1554
(prune (second args)
1556
(try `(,op ,(first args) ,form))))))
1558
((multiple-value-setq)
1560
;; Assumes only one assignment, and one variable
1561
(assert (= (length form) 3))
1562
(assert (= (length (first args)) 1))
1563
(try `(setq ,(caar args) ,(cadr args)))
1564
(unless (integerp (second args))
1565
(prune (second args)
1567
(try `(,op ,(first args) ,form))))))
1570
(prune-fn form try-fn))
1572
((deposit-field dpb)
1574
(destructuring-bind (a1 a2 a3)
1578
(when (and (integerp a1)
1581
(eq (first a2) 'byte)
1582
(integerp (second a2))
1583
(integerp (third a2))))
1585
(prune-fn form try-fn))
1590
(when (and (consp (first args))
1591
(eq 'byte (first (first args)))
1592
(every #'numberp (cdr (first args)))
1593
(numberp (second args)))
1595
(prune-fn form try-fn))
1600
(prune-fn form try-fn))
1603
(prune-let form try-fn))
1605
((multiple-value-bind)
1606
(assert (= (length args) 3))
1607
(let ((arg1 (first args))
1608
(arg2 (second args))
1609
(body (caddr args)))
1610
(when (= (length arg1) 1)
1611
(try `(let ((,(first arg1) ,arg2)) ,body)))
1612
(prune arg2 #'(lambda (form)
1613
(try `(multiple-value-bind ,arg1 ,form ,body))))
1614
(prune body #'(lambda (form)
1615
(try `(multiple-value-bind ,arg1 ,arg2 ,form))))))
1618
(let ((name (second form))
1620
(when (and body (null (cdr body)))
1621
(let ((form1 (first body)))
1623
;; Try removing the block entirely if it is not in use
1624
(when (not (find-in-tree name body))
1627
;; Try removing the block if its only use is an immediately
1628
;; enclosed return-from: (block <n> (return-from <n> <e>))
1629
(when (and (consp form1)
1630
(eq (first form1) 'return-from)
1631
(eq (second form1) name)
1632
(not (find-in-tree name (third form1))))
1633
(try (third form1)))
1635
;; Otherwise, try to simplify the subexpression
1638
(try `(block ,name ,x))))))))
1641
(let* ((tag (second form))
1642
(name (if (consp tag) (cadr tag) tag))
1644
(when (and body (null (cdr body)))
1645
(let ((form1 (first body)))
1647
;; Try removing the catch entirely if it is not in use
1648
;; We make assumptions here about what throws can
1650
(when (or (not (find-in-tree 'throw body))
1651
(not (find-in-tree name body)))
1654
;; Try removing the block if its only use is an immediately
1655
;; enclosed return-from: (block <n> (return-from <n> <e>))
1656
(when (and (consp form1)
1657
(eq (first form1) 'throw)
1658
(equal (second form1) name)
1659
(not (find-in-tree name (third form1))))
1660
(try (third form1)))
1662
;; Otherwise, try to simplify the subexpression
1665
(try `(catch ,tag ,x))))))))
1669
(prune (second args)
1670
#'(lambda (x) (try `(throw ,(first args) ,x)))))
1674
(prune-flet form try-fn))
1677
(prune-case form try-fn))
1680
(let ((arg (second form)))
1681
(assert (null (cddr form)))
1682
(assert (consp arg))
1683
(assert (eq (first arg) 'abs))
1684
(let ((arg2 (second arg)))
1687
(when (integerp arg2)
1688
(try (isqrt (abs arg2))))
1689
;; Otherwise, simplify arg2
1690
(prune arg2 #'(lambda (form)
1691
(try `(isqrt (abs ,form))))))))
1695
(let ((form1 (second form))
1696
(form2 (third form)))
1701
(try `(ash ,form ,form2))))
1702
(when (and (consp form2)
1703
(= (length form2) 3))
1704
(when (and (integerp form1)
1705
(eq (first form2) 'min)
1706
(every #'integerp (cdr form2)))
1708
(let ((form3 (third form2)))
1712
`(ash ,form1 (,(first form2) ,(second form2)
1715
((floor ceiling truncate round mod rem)
1717
(let ((form1 (second form))
1718
(form2 (third form)))
1720
(when (cddr form) (try form2))
1724
(try `(,op ,form ,form2)))
1725
#'(lambda (form) (try `(,op ,form)))))
1726
(when (and (consp form2)
1727
(= (length form2) 3))
1728
(when (and (integerp form1)
1729
(member (first form2) '(max min))
1730
(every #'integerp (cdr form2)))
1732
(let ((form3 (third form2)))
1736
`(,op ,form1 (,(first form2) ,(second form2)
1740
(unless (eql (car args) 0)
1742
#'(lambda (arg) (try `(constantly ,arg))))))
1746
(let ((fn (second form))
1747
(fn-args (cddr form)))
1748
(mapc try-fn fn-args)
1749
(unless (equal fn '(constantly 0))
1750
(try `(funcall (constantly 0) ,@fn-args)))
1751
(when (and (consp fn)
1752
(eql (car fn) 'function)
1753
(symbolp (cadr fn)))
1754
(try `(,(cadr fn) ,@fn-args)))
1758
(try `(funcall ,fn ,@args))))))
1762
(let ((arg1 (car args))
1765
(when (and ;; (null (cddr args))
1767
(eql (car arg1) 'function))
1768
(let ((arg1.2 (cadr arg1)))
1769
(when (and (consp arg1.2)
1770
(eql (car arg1.2) 'lambda))
1771
(let ((largs (cadr arg1.2))
1772
(body (cddr arg1.2)))
1773
(when (null (cdr body))
1776
(try `(reduce (function (lambda ,largs ,bform))
1777
,arg2 ,@rest)))))))))
1781
(let ((arg2.rest (cdr arg2)))
1782
(mapc try-fn arg2.rest)
1783
(prune-list arg2.rest
1787
(,(car arg2) ,@args)
1792
(let ((fn (second form))
1793
(fn-args (butlast (cddr form)))
1794
(list-arg (car (last form))))
1795
(mapc try-fn fn-args)
1796
(unless (equal fn '(constantly 0))
1797
(try `(apply (constantly 0) ,@(cddr form))))
1798
(when (and (consp list-arg)
1799
(eq (car list-arg) 'list))
1800
(mapc try-fn (cdr list-arg)))
1804
(try `(apply ,fn ,@args ,list-arg))))
1805
(when (and (consp list-arg)
1806
(eq (car list-arg) 'list))
1807
(try `(apply ,fn ,@fn-args ,@(cdr list-arg) nil))
1808
(prune-list (cdr list-arg)
1811
(try `(apply ,fn ,@fn-args
1812
(list ,@args))))))))
1816
(prune-progv form try-fn))
1820
(prune-tagbody form try-fn))
1823
(when (null args) (try nil))
1824
(try (car (last args)))
1825
(loop for i from 0 below (1- (length args))
1827
do (try `(progn ,@(subseq args 0 i)
1828
,@(subseq args (1+ i))))
1829
do (when (and (consp a)
1832
(and (eq (car a) 'tagbody)
1833
(every #'consp (cdr a)))))
1834
(try `(progn ,@(subseq args 0 i)
1835
,@(copy-list (cdr a))
1836
,@(subseq args (1+ i))))))
1837
(prune-fn form try-fn))
1841
(when (and (eql (length args) 6)
1842
(eql (elt args 0) 'for)
1843
(eql (elt args 2) 'below))
1844
(let ((var (elt args 1))
1845
(count (elt args 3))
1846
(form (elt args 5)))
1847
(unless (eql count 0) (try count))
1850
(try `(let ((,(elt args 1) 0)) ,(elt args 5)))
1851
(prune form #'(lambda (form)
1852
(try `(loop for ,var below ,count sum ,form)))))
1854
(unless (or (eql form t) (eql form nil))
1855
(try `(loop for ,var below ,count count t))
1856
(try `(loop for ,var below ,count count nil))
1859
(try `(loop for ,var below ,count count ,form))))))
1864
(prune-fn form try-fn))
1867
(setf (gethash form *prune-table*) t)
1870
(defun find-in-tree (value tree)
1871
"Return true if VALUE is eql to a node in TREE."
1872
(or (eql value tree)
1874
(or (find-in-tree value (car tree))
1875
(find-in-tree value (cdr tree))))))
1877
(defun prune-list (list element-prune-fn list-try-fn)
1878
(declare (type function element-prune-fn list-try-fn))
1879
"Utility function for pruning in a list."
1882
do (funcall element-prune-fn
1885
(funcall list-try-fn
1886
(append (subseq list 0 i)
1888
(subseq list (1+ i))))))))
1890
(defun prune-case (form try-fn)
1891
(declare (type function try-fn))
1892
(flet ((try (e) (funcall try-fn e)))
1893
(let* ((op (first form))
1894
(expr (second form))
1895
(cases (cddr form)))
1897
;; Try just the top expression
1900
;; Try simplifying the expr
1903
(try `(,op ,form ,@cases))))
1905
;; Try individual cases
1906
(loop for case in cases
1907
do (try (first (last (rest case)))))
1909
;; Try deleting individual cases
1910
(loop for i from 0 below (1- (length cases))
1912
,@(subseq cases 0 i)
1913
,@(subseq cases (1+ i)))))
1915
;; Try simplifying the cases
1916
;; Assume each case has a single form
1918
#'(lambda (case try-fn)
1919
(declare (type function try-fn))
1920
(when (eql (length case) 2)
1924
(list (car case) form))))))
1926
(try `(,op ,expr ,@cases)))))))
1928
(defun prune-tagbody (form try-fn)
1929
(declare (type function try-fn))
1930
(let (;; (op (car form))
1938
(unless (find-in-tree e (subseq body 0 i))
1939
(funcall try-fn `(tagbody ,@(subseq body 0 i)
1940
,@(subseq body (1+ i))))))
1943
`(tagbody ,@(subseq body 0 i)
1944
,@(subseq body (1+ i))))
1947
;; Don't put an atom here.
1951
`(tagbody ,@(subseq body 0 i)
1953
,@(subseq body (1+ i))))))))))))
1955
(defun prune-progv (form try-fn)
1956
(declare (type function try-fn))
1957
(let (;; (op (car form))
1958
(vars-form (cadr form))
1959
(vals-form (caddr form))
1960
(body-list (cdddr form)))
1961
(when (and (null vars-form) (null vals-form))
1962
(funcall try-fn `(let () ,@body-list)))
1963
(when (and (consp vals-form) (eql (car vals-form) 'list))
1964
(when (and (consp vars-form) (eql (car vars-form) 'quote))
1965
(let ((vars (cadr vars-form))
1966
(vals (cdr vals-form)))
1967
(when (eql (length vars) (length vals))
1968
(let ((let-form `(let () ,@body-list)))
1969
(mapc #'(lambda (var val)
1970
(setq let-form `(let ((,var ,val)) ,let-form)))
1972
(funcall try-fn let-form)))
1973
;; Try simplifying the vals forms
1978
`(progv ,vars-form (list ,@vals) ,@body-list)))))))
1979
;; Try simplifying the body
1980
(when (eql (length body-list) 1)
1981
(prune (car body-list)
1984
`(progv ,vars-form ,vals-form ,form)))))))
1986
(defun prune-nary-fn (form try-fn)
1987
;; Attempt to reduce the number of arguments to the fn
1988
;; Do not reduce below 1
1989
(declare (type function try-fn))
1990
(let* ((op (car form))
1992
(nargs (length args)))
1994
(loop for i from 1 to nargs
1995
do (funcall try-fn `(,op ,@(subseq args 0 (1- i))
1996
,@(subseq args i)))))))
1998
(defun prune-fn (form try-fn)
1999
"Attempt to simplify a function call form. It is considered
2000
acceptable to replace the call by one of its argument forms."
2001
(declare (type function try-fn))
2002
(prune-list (cdr form)
2005
(funcall try-fn (cons (car form) args)))))
2007
(defun prune-let (form try-fn)
2008
"Attempt to simplify a LET form."
2009
(declare (type function try-fn))
2010
(let* ((op (car form))
2011
(binding-list (cadr form))
2013
(body-len (length body))
2014
(len (length binding-list))
2017
(when (> body-len 1)
2018
(funcall try-fn `(,op ,binding-list ,@(cdr body))))
2020
;; Try to simplify (let ((<name> <form>)) ...) to <form>
2022
(when (and (>= len 1)
2024
;; (eql (caar binding-list) (car body))
2026
(let ((val-form (cadar binding-list)))
2027
(unless (and (consp val-form)
2028
(eql (car val-form) 'make-array))
2029
(funcall try-fn val-form))))
2033
(let ((val-form (cadar binding-list)))
2034
(when (consp val-form)
2035
(case (car val-form)
2037
(let ((init (getf (cddr val-form) :initial-element)))
2039
(funcall try-fn init))))
2041
(funcall try-fn (cadr val-form))
2042
(funcall try-fn (caddr val-form)))))))
2044
;; Try to simplify the forms in the RHS of the bindings
2045
(prune-list binding-list
2046
#'(lambda (binding try-fn)
2047
(declare (type function try-fn))
2048
(prune (cadr binding)
2053
#'(lambda (bindings)
2054
(funcall try-fn `(,op ,bindings ,@body))))
2056
;; Prune off unused variable
2057
(when (and binding-list
2058
(not (rest binding-list))
2059
(let ((name (caar binding-list)))
2061
(not (find-if-subtree #'(lambda (x) (eq x name)) body)))))
2062
(funcall try-fn `(progn ,@body)))
2064
;; Try to simplify the body of the LET form
2066
(unless binding-list
2067
(funcall try-fn (car (last body))))
2068
(when (and (first binding-list)
2069
(not (rest binding-list))
2071
(let ((binding (first binding-list)))
2072
(unless (or (consp (second binding))
2073
(has-binding-to-var (first binding) body)
2074
(has-assignment-to-var (first binding) body)
2076
(funcall try-fn `(let ()
2077
,@(subst (second binding)
2079
(remove-if #'(lambda (x) (and (consp x) (eq (car x) 'declare)))
2082
(prune (car (last body))
2085
`(,@(butlast form) ,form2)))))))
2087
(defun has-assignment-to-var (var form)
2092
(and (member (car form) '(setq setf shiftf) :test #'eq)
2093
(eq (cadr form) var))
2094
(and (eql (car form) 'multiple-value-setq)
2095
(member var (cadr form))))))
2098
(defun has-binding-to-var (var form)
2104
(loop for binding in (cadr form)
2105
thereis (eq (car binding) var)))
2107
(and (consp (cadr form))
2108
(eq (caadr form) 'quote)
2109
(consp (second (cadr form)))
2110
(member var (second (cadr form)))))
2114
(defun find-if-subtree (pred tree)
2115
(declare (type function pred))
2117
((funcall pred tree) tree)
2119
(or (find-if-subtree pred (car tree))
2120
(find-if-subtree pred (cdr tree))))
2123
(defun prune-flet (form try-fn)
2124
"Attempt to simplify a FLET form."
2125
(declare (type function try-fn))
2127
(let* ((op (car form))
2128
(binding-list (cadr form))
2131
;; Remove a declaration, if any
2132
(when (and (consp body)
2134
(eq (caar body) 'declare))
2135
(funcall try-fn `(,op ,binding-list ,@(cdr body))))
2137
;; Try to prune optional arguments
2138
(prune-list binding-list
2139
#'(lambda (binding try-fn)
2140
(declare (type function try-fn))
2141
(let* ((name (car binding))
2142
(args (cadr binding))
2143
(body (cddr binding))
2144
(opt-pos (position-if #'(lambda (e) (member e '(&key &optional)))
2148
(let ((normal-args (subseq args 0 (1- opt-pos)))
2149
(optionals (subseq args opt-pos)))
2150
(prune-list optionals
2151
#'(lambda (opt-lambda-arg try-fn)
2152
(declare (type function try-fn))
2153
(when (consp opt-lambda-arg)
2154
(let ((name (first opt-lambda-arg))
2155
(form (second opt-lambda-arg)))
2158
(funcall try-fn (list name form)))))))
2159
#'(lambda (opt-args)
2161
`(,name (,@normal-args
2165
#'(lambda (bindings)
2166
(funcall try-fn `(,op ,bindings ,@body))))
2169
;; Try to simplify the forms in the RHS of the bindings
2170
(prune-list binding-list
2171
#'(lambda (binding try-fn)
2172
(declare (type function try-fn))
2174
;; Prune body of a binding
2175
(prune (third binding)
2178
(list (first binding)
2181
#'(lambda (bindings)
2182
(funcall try-fn `(,op ,bindings ,@body))))
2184
;; ;; Try to simplify the body of the FLET form
2187
;; No bindings -- try to simplify to the last form in the body
2188
(unless binding-list
2189
(funcall try-fn (first (last body))))
2191
(when (and (consp binding-list)
2192
(null (rest binding-list)))
2193
(let ((binding (first binding-list)))
2194
;; One binding -- match on (flet ((<name> () <body>)) (<name>))
2195
(when (and (symbolp (first binding))
2196
(not (find-in-tree (first binding) (rest binding)))
2197
(null (second binding))
2198
(equal body (list (list (first binding)))))
2199
(funcall try-fn `(,op () ,@(cddr binding))))
2200
;; One binding -- try to remove it if not used
2201
(when (and (symbolp (first binding))
2202
(not (find-in-tree (first binding) body)))
2203
(funcall try-fn (first (last body))))
2207
;; Try to simplify (the last form in) the body.
2208
(prune (first (last body))
2211
`(,@(butlast form) ,form2)))))))
2213
;;; Routine to walk form, applying a function at each form
2214
;;; The fn is applied in preorder. When it returns :stop, do
2215
;;; not descend into subforms
2218
(defun walk (form fn)
2219
(declare (type function fn))
2220
(unless (eq (funcall fn form) :stop)
2222
(let ((op (car form)))
2227
(dolist (clause (cdr form))
2228
(walk-implicit-progn clause fn)))
2229
((multiple-value-bind)
2230
(walk (third form) fn)
2231
(walk-body (cdddr form) fn))
2232
((function quote declare) nil)
2233
((block the return-from)
2234
(walk-implicit-progn (cddr form) fn))
2236
(walk (cadr form) fn)
2237
(dolist (clause (cddr form))
2238
(walk-implicit-progn (cdr clause) fn)))
2246
;;;;;;;;;;;;;;;;;;;;;;
2247
;;; Convert pruned results to test cases
2249
(defun produce-test-cases (instances &key
2250
(stream *standard-output*)
2253
(dolist (inst instances)
2254
(let* (;; (vars (getf inst :vars))
2255
(vals (getf inst :vals))
2256
(optimized-lambda-form (getf inst :optimized-lambda-form))
2257
(unoptimized-lambda-form (getf inst :unoptimized-lambda-form))
2259
(concatenate 'string prefix (format nil "~D" index))
2263
(let* ((fn1 ',optimized-lambda-form)
2264
(fn2 ',unoptimized-lambda-form)
2266
(v1 (apply (compile nil fn1) vals))
2267
(v2 (apply (compile nil fn2) vals)))
2272
(print test-form stream)
added
removed
ansi-tests/random-int-form.lsp
