diff --git a/ansi-tests/cl-symbol-names.lsp b/ansi-tests/cl-symbol-names.lsp index 9d7c06df0b1ce9674094ba7c9382bc53a096c6f8..e0b8acd6b152d0d7a43da33fe943d927da014412 100644 --- a/ansi-tests/cl-symbol-names.lsp +++ b/ansi-tests/cl-symbol-names.lsp @@ -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* diff --git a/ansi-tests/random-aux.lsp b/ansi-tests/random-aux.lsp index e48f18aa89dae010ae5e153ec52a282e784e993e..56895a90a2d55235d4ddb2147a83f07999e9080d 100644 --- a/ansi-tests/random-aux.lsp +++ b/ansi-tests/random-aux.lsp @@ -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 diff --git a/ansi-tests/random-int-form.lsp b/ansi-tests/random-int-form.lsp index 00f72747daa0280bf38bf68905556e9dd4e17206..ce9bc3c68df1f21bcc8c243c9c0b397704ccdf4f 100644 --- a/ansi-tests/random-int-form.lsp +++ b/ansi-tests/random-int-form.lsp @@ -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))))))) +