Skip to content
Snippets Groups Projects
Commit 26bb00af authored by pfdietz's avatar pfdietz
Browse files

Updated the random torture tester. There is now a PRUNE-RESULTS function that...

Updated the random torture tester.  There is now a PRUNE-RESULTS function that reduces the size of the forms that fail testing.  Also, added more lisp forms to the random form generator.
parent 31097618
No related branches found
No related tags found
No related merge requests found
......@@ -2148,6 +2148,9 @@
*cl-standard-generic-function-symbols*
'(declare)))))
(defparameter *cl-function-or-accessor-symbols*
(append *cl-function-symbols* *cl-accessor-symbols*))
(defparameter *cl-non-variable-constant-symbols*
(set-difference
*cl-symbols*
......
......@@ -18,6 +18,24 @@
,@(loop for i from 0 for e in cases collect `(,i ,e))
(t (error "Can't happen?! (in random-case)~%")))))
(defmacro rcase (&body cases)
"Usage: (RCASE (<weight> <form>+)+), where <weight> is a positive real
indicating the relative probability of executing the associated implicit
progn."
(assert cases)
(let* ((weights (mapcar #'car cases))
(cumulative-weights (let ((sum 0))
(loop for w in weights collect (incf sum w))))
(total (car (last cumulative-weights)))
(r (gensym)))
(assert (every #'plusp weights))
`(let ((,r (random ,total)))
(cond
,@(loop for case in (butlast cases)
for cw in cumulative-weights
collect `((< ,r ,cw) ,@(cdr case)))
(t ,@(cdar (last cases)))))))
(defun random-nonnegative-real ()
(if (coin 3)
(random-case
......
......@@ -32,7 +32,10 @@
;;; that will eventually replace this preliminary effort.
;;;
(declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals*))
(declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals*
*opt-result* *unopt-result*))
(defvar *random-int-form-blocks* nil)
(defun test-random-integer-forms (size nvars n)
......@@ -55,46 +58,20 @@
(let* ((form (make-random-integer-form size vars))
(var-ranges (mapcar #'make-random-integer-range vars))
(var-types (mapcar #'(lambda (range)
`(integer ,(car range) ,(cadr range)))
(let ((lo (car range))
(hi (cadr range)))
(assert (>= hi lo))
`(integer ,lo ,hi)))
var-ranges))
(optimized-fn-src
`(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)))
,form))
(unoptimized-fn-src
`(lambda ,vars
(declare (notinline ,@(fn-symbols-in-form form))
(optimize #+cmu (extensions:inhibit-warnings 3)
(safety 3) (speed 0) (debug 3))
(ignorable ,@vars))
,form)))
(setq *optimized-fn-src* optimized-fn-src
*unoptimized-fn-src* unoptimized-fn-src)
(#+sbcl handler-bind
#+sbcl ((sb-ext::compiler-note #'muffle-warning))
#-sbcl progn
(let ((optimized-compiled-fn (compile nil optimized-fn-src))
(unoptimized-compiled-fn (compile nil unoptimized-fn-src)))
(dotimes (i 20 nil)
(let ((vals
(vals-list
(loop repeat 20
collect
(mapcar #'(lambda (range)
(let ((lo (car range))
(hi (cadr range)))
(random-from-interval (1+ hi) lo)))
var-ranges)))
(setq *int-form-vals* vals)
(let ((opt-result (apply unoptimized-compiled-fn vals))
(unopt-result (apply optimized-compiled-fn vals)))
(if (equal opt-result unopt-result)
nil
(return (list (list vars vals
unoptimized-fn-src
optimized-fn-src
)))))))))))
var-ranges))))
(test-int-form form vars var-types vals-list)))
(defun fn-symbols-in-form (form)
"Return a list of the distinct standardized lisp function
......@@ -102,7 +79,7 @@
declaration for the unoptimized form."
(intersection
(remove-duplicates (fn-symbols-in-form* form) :test #'eq)
*cl-function-symbols*))
*cl-function-or-accessor-symbols*))
(defun fn-symbols-in-form* (form)
(when (consp form)
......@@ -114,7 +91,7 @@
"Generate a list (LO HI) of integers, LO <= HI. This is used
for generating integer types."
(declare (ignore var))
(flet ((%r () (let ((r (ash 1 (1+ (random 32)))))
(flet ((%r () (let ((r (ash 1 (1+ (random 35)))))
(- (random r) (floor (/ r 2))))))
(let ((x (%r))
(y (%r)))
......@@ -130,24 +107,26 @@
(- (random r) (floor (/ r 2))))
(random-from-seq vars))
;; (> size 1)
(ecase (random 9)
(rcase
;; Unary ops
((0 1)
(let ((op (random-from-seq '(- abs signum 1+ 1- identity
(40
(let ((op (random-from-seq '(- abs abs signum signum 1+ 1- identity
integer-length logcount))))
`(,op ,(make-random-integer-form (1- size) vars))))
;; Binary op
((2 3 4 5)
(80
(let* ((op (random-from-seq
'(+ - * logand min max ;; gcd lcm
logandc1 logandc2 logeqv logior lognand lognor logorc1
'(+ - * logand min max min max ;; gcd lcm
#-:allegro logandc1 ;; bug in ACL 6.2 makes this cause crashes
logandc2 logeqv logior lognand lognor logorc1
logorc2 logxor))))
(destructuring-bind (leftsize rightsize)
(random-partition (1- size) 2)
`(,op ,(make-random-integer-form leftsize vars)
,(make-random-integer-form rightsize vars)))))
(let ((e1 (make-random-integer-form leftsize vars))
(e2 (make-random-integer-form rightsize vars)))
`(,op ,e1 ,e2)))))
;; conditionals
(6
(20
(let* ((cond-size (random (max 1 (floor size 2))))
(then-size (random (- size cond-size)))
(else-size (- size 1 cond-size then-size))
......@@ -155,52 +134,86 @@
(then-part (make-random-integer-form then-size vars))
(else-part (make-random-integer-form else-size vars)))
`(if ,pred ,then-part ,else-part)))
(7
(10
(destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)
`(,(random-from-seq '(deposit-field dpb))
,(make-random-integer-form s1 vars)
,(make-random-byte-spec-form s2 vars)
,(make-random-integer-form s3 vars))))
(8
(10
(destructuring-bind (s1 s2) (random-partition (1- size) 2)
`(,(random-from-seq '(ldb mask-field))
,(make-random-byte-spec-form s1 vars)
,(make-random-integer-form s2 vars))))
(20
(destructuring-bind (s1 s2) (random-partition (1- size) 2)
(let* ((var (random-from-seq #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)))
(e1 (make-random-integer-form s1 vars))
(e2 (make-random-integer-form s2 (cons var vars))))
;; for now, avoid shadowing
(if (member var vars)
(make-random-integer-form size vars)
`(let ((,var ,e1)) ,e2)))))
(10
(let* ((name (random-from-seq #(b1 b2 b3 b4 b5 b6 b7 b8)))
(*random-int-form-blocks* (adjoin name *random-int-form-blocks*)))
`(block ,name ,(make-random-integer-form (1- size) vars))))
(1
(if *random-int-form-blocks*
(let ((name (random-from-seq *random-int-form-blocks*))
(form (make-random-integer-form (1- size) vars)))
`(return-from ,name ,form))
;; No blocks -- try again
(make-random-integer-form size vars)))
(5
(if *random-int-form-blocks*
(destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)
(let ((name (random-from-seq *random-int-form-blocks*))
(pred (make-random-pred-form s1 vars))
(then (make-random-integer-form s2 vars))
(else (make-random-integer-form s3 vars)))
`(if ,pred (return-from ,name ,then) ,else)))
;; No blocks -- try again
(make-random-integer-form size vars)))
)))
(defun make-random-pred-form (size vars)
(if (<= size 1)
(ecase (random 3)
(0 (if (coin) t nil))
((1 2)
(rcase
(1 (if (coin) t nil))
(2
`(,(random-from-seq '(< <= = > >= /= eql equal))
,(make-random-integer-form size vars)
,(make-random-integer-form size vars))))
(ecase (random 6)
(0 (if (coin) t nil))
(rcase
(1 (if (coin) t nil))
(1 `(not ,(make-random-pred-form (1- size) vars)))
(2 (destructuring-bind (leftsize rightsize)
(random-partition (1- size) 2)
`(,(random-from-seq '(and or))
,(make-random-pred-form leftsize vars)
,(make-random-pred-form rightsize vars))))
(3 (destructuring-bind (leftsize rightsize)
(1 (destructuring-bind (leftsize rightsize)
(random-partition (1- size) 2)
`(,(random-from-seq '(< <= > >= = /= eql equal))
,(make-random-integer-form leftsize vars)
,(make-random-integer-form rightsize vars))))
(4 (let* ((cond-size (random (max 1 (floor size 2))))
(1 (let* ((cond-size (random (max 1 (floor size 2))))
(then-size (random (- size cond-size)))
(else-size (- size 1 cond-size then-size))
(pred (make-random-pred-form cond-size vars))
(then-part (make-random-pred-form then-size vars))
(else-part (make-random-pred-form else-size vars)))
`(if ,pred ,then-part ,else-part)))
(5 (destructuring-bind (s1 s2)
(1 (destructuring-bind (s1 s2)
(random-partition (1- size) 2)
`(ldb-test ,(make-random-byte-spec-form s1 vars)
,(make-random-integer-form s2 vars))))
(1 (let ((index (random (1+ (random 35))))
(form (make-random-integer-form (1- size) vars)))
`(logbitp ,index ,form)))
)))
(defun make-random-byte-spec-form (size vars)
......@@ -218,3 +231,223 @@
(t
(let ((n1 (1+ (random (floor n p)))))
(cons n1 (random-partition (- n n1) (1- p)))))))
;;; Interface to the form pruner
(defun test-int-form (form vars var-types vals-list)
;; Try to compile FORM with associated VARS, and if it compiles
;; check for equality of the two compiled forms.
;; Return a non-nil list of details if a problem is found,
;; NIL otherwise.
(let ((optimized-fn-src
`(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)))
,form))
(unoptimized-fn-src
`(lambda ,vars
(declare (notinline ,@(fn-symbols-in-form form))
(optimize #+cmu (extensions:inhibit-warnings 3)
(safety 3) (speed 0) (debug 3))
(ignorable ,@vars))
,form)))
(setq *int-form-vals* nil
*optimized-fn-src* optimized-fn-src
*unoptimized-fn-src* unoptimized-fn-src)
(handler-bind
(#+sbcl (sb-ext::compiler-note #'muffle-warning)
(warning #'muffle-warning)
(error #'(lambda (c)
(format t "Compilation failure~%")
(return-from test-int-form
(list (list :vars vars
:form form
:var-types var-types
:vals (first vals-list)
:compiler-condition c))))))
(let ((optimized-compiled-fn (compile nil optimized-fn-src))
(unoptimized-compiled-fn (compile nil unoptimized-fn-src)))
(dolist (vals vals-list)
(setq *int-form-vals* vals)
(let ((unopt-result (multiple-value-list
(apply unoptimized-compiled-fn vals)))
(opt-result (multiple-value-list
(apply optimized-compiled-fn vals))))
(if (equal opt-result unopt-result)
nil
(progn
(format t "Different results: ~A, ~A~%"
opt-result unopt-result)
(setq *opt-result* opt-result
*unopt-result* unopt-result)
(return (list (list :vars vars
:vals vals
:form form
:var-types var-types
:optimized-values opt-result
:unoptimized-values unopt-result
)))))))))))
(defun prune-int-form (form vars var-types vals-list)
(flet ((%try-fn (new-form)
(when (test-int-form new-form vars var-types vals-list)
(setf form new-form)
(throw 'success nil))))
(loop
(catch 'success
(prune form #'%try-fn)
(return form)))))
(defun prune-results (result-list)
(assert result-list)
(loop for result in result-list
collect
(let ((form (getf result :form))
(vars (getf result :vars))
(var-types (getf result :var-types))
(vals-list (list (getf result :vals)))
)
`(:vars ,vars
:var-types ,var-types
:vals ,(first vals-list)
:form ,(prune-int-form form vars var-types vals-list)))))
;;;
;;; The call (PRUNE form try-fn) attempts to simplify the lisp form
;;; so that it still satisfies TRY-FN. The function TRY-FN should
;;; return if the substitution is a failure. Otherwise, it should
;;; transfer control elsewhere via GO, THROW, etc.
;;;
;;; The return value of PRUNE should be ignored.
;;;
(defun prune (form try-fn)
(flet ((try (x) (funcall try-fn x)))
(when (consp form)
(let ((op (car form))
(args (cdr form)))
(case op
((signum integer-length logcount
gcd lcm logandc1 logandc2 lognand lognor logorc1 logorc2)
(mapc #'try args)
(try 0)
(try 1)
(try -1)
(prune-fn form try-fn))
((abs 1+ 1- identity)
(mapc #'try args)
(prune-fn form try-fn))
((- + * min max logand logior logxor logeqv and or not eq eql equal = < > <= >= /=)
(when (every #'constantp args)
(try (eval form)))
(mapc #'try args)
(prune-fn form try-fn))
((if)
(let (;; (pred (first args))
(then (second args))
(else (third args)))
(try then)
(try else)
(prune-fn form try-fn)))
((byte)
(prune-fn form try-fn))
((deposit-field dpb)
(try (first args))
(try (third args))
(prune-fn form try-fn))
((ldb mask-field)
(try (second args))
(prune-fn form try-fn))
((ldb-test)
(prune-fn form try-fn))
((let let*)
(prune-let form try-fn))
((block)
(let ((name (second form))
(body (cddr form)))
(when (and body (null (cdr body)))
(when (not (find-in-tree name body))
(try (first body)))
;; Simplify the subexpression
(prune (first body)
#'(lambda (x)
(try `(block ,name ,x)))))))
(otherwise
(prune-fn form try-fn))
)))))
(defun find-in-tree (value tree)
(or (eql value tree)
(and (consp tree)
(or (find-in-tree value (car tree))
(find-in-tree value (cdr tree))))))
(defun prune-fn (form try-fn)
(let* ((i 0)
(op (car form))
(args (cdr form))
(len (length args)))
(flet ((try-arg (x)
(funcall
try-fn
(cons op
(append (subseq args 0 i)
(list x)
(subseq args (1+ i)))))))
(declare (dynamic-extent (function try-arg)))
(loop while (< i len)
do (prune (elt args i) #'try-arg)
(incf i)))))
(defun prune-let (form try-fn)
(let* ((op (car form))
(binding-list (cadr form))
(body (cddr form))
(body-len (length body))
(len (length binding-list)))
(when (and (eql len 1)
(eql body-len 1)
(eql (caar binding-list) (car body)))
(funcall try-fn (cadar binding-list)))
(let ((i 0))
(flet ((try-binding (x)
(funcall
try-fn
`(,op
(,@(subseq binding-list 0 i)
,x
,@(subseq binding-list (1+ i)))
,@body))))
(declare (dynamic-extent (function try-binding)))
(loop while (< i len)
do (prune (elt binding-list i) #'try-binding)
(incf i))))
(when body
(unless binding-list
(funcall try-fn (car (last body))))
(when (and (car binding-list)
(not (cdr binding-list))
(not (cdr body)))
(let ((binding (car binding-list)))
(unless (consp (second binding))
(funcall try-fn `(let ()
,@(subst (cadr binding) (car binding) body))))))
(prune (car (last body))
#'(lambda (form2)
(funcall try-fn
`(,@(butlast form) ,form2)))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment