From a371fab1d3ddccf84fc70c66aa3234669f58afbd Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Tue, 16 Sep 2003 03:14:50 +0000 Subject: [PATCH] Fixed up LET/LET* pruning, and added FLET forms. Initialize the random state to (make-random-state t) by default. --- ansi-tests/random-int-form.lsp | 140 +++++++++++++++++++++++++++------ 1 file changed, 115 insertions(+), 25 deletions(-) diff --git a/ansi-tests/random-int-form.lsp b/ansi-tests/random-int-form.lsp index a30d1a9f..920e8c31 100644 --- a/ansi-tests/random-int-form.lsp +++ b/ansi-tests/random-int-form.lsp @@ -37,7 +37,8 @@ (defvar *random-int-form-blocks* nil) -(defun test-random-integer-forms (size nvars n) +(defun test-random-integer-forms + (size nvars n &optional (*random-state* (make-random-state t))) "Generate random integer forms of size SIZE with NVARS variables. Do this N times, returning all those on which a discrepancy @@ -97,15 +98,19 @@ (y (%r))) (list (min x y) (max x y))))) +(defparameter *flet-names* nil) + (defun make-random-integer-form (size vars) "Generate a random legal lisp form of size SIZE (roughly). VARS is a list of variable symbols that contain integers." (if (<= size 1) - ;; Leaf node -- generate a variable or constant - (if (= (random 2) 0) - (let ((r (ash 1 (1+ (random 32))))) - (- (random r) (floor (/ r 2)))) - (random-from-seq vars)) + ;; Leaf node -- generate a variable, constant, or flet function call + (rcase + (10 (let ((r (ash 1 (1+ (random 32))))) + (- (random r) (floor (/ r 2))))) + (9 (random-from-seq vars)) + (1 (if *flet-names* (list (random-from-seq *flet-names*)) + (random-from-seq vars)))) ;; (> size 1) (rcase ;; Unary ops @@ -118,7 +123,8 @@ (let* ((op (random-from-seq '(+ - * logand min max min max ;; gcd lcm #-:allegro logandc1 ;; bug in ACL 6.2 makes this cause crashes - logandc2 logeqv logior lognand lognor logorc1 + logandc2 logeqv logior lognand lognor + #-:allegro logorc1 logorc2 logxor)))) (destructuring-bind (leftsize rightsize) (random-partition (1- size) 2) @@ -176,9 +182,23 @@ `(if ,pred (return-from ,name ,then) ,else))) ;; No blocks -- try again (make-random-integer-form size vars))) + + (5 (make-random-flet-form size vars)) ))) +(defun make-random-flet-form (size vars) + "Generate random flet forms, for now with no arguments." + (let ((fname (random-from-seq #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10 + %f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18)))) + (if (member fname *flet-names* :test #'eq) + (make-random-integer-form size vars) + (destructuring-bind (s1 s2) (random-partition (max 2 (1- size)) 2) + (let ((form1 (make-random-integer-form s1 vars)) + (form2 (let ((*flet-names* (cons fname *flet-names*))) + (make-random-integer-form s2 vars)))) + `(flet ((,fname () ,form1)) ,form2)))))) + (defun make-random-pred-form (size vars) (if (<= size 1) (rcase @@ -324,6 +344,7 @@ ;;; The return value of PRUNE should be ignored. ;;; (defun prune (form try-fn) + (declare (function try-fn)) (flet ((try (x) (funcall try-fn x))) (when (consp form) (let ((op (car form)) @@ -342,7 +363,8 @@ (mapc #'try args) (prune-fn form try-fn)) - ((- + * min max logand logior logxor logeqv and or not eq eql equal = < > <= >= /=) + ((- + * min max logand logior logxor logeqv + and or not eq eql equal = < > <= >= /=) (when (every #'constantp args) (try (eval form))) (mapc #'try args) @@ -378,12 +400,27 @@ (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))))))) + (let ((form1 (first body))) + + ;; Try removing the block entirely if it is not in use + (when (not (find-in-tree name body)) + (try form1)) + + ;; Try removing the block if its only use is an immediately + ;; enclosed return-from: (block <n> (return-from <n> <e>)) + (when (and (consp form1) + (eq (first form1) 'return-from) + (eq (second form1) name) + (not (find-in-tree name (third form1)))) + (try (third form1))) + + ;; Otherwise, try to simplify the subexpression + (prune form1 + #'(lambda (x) + (try `(block ,name ,x)))))))) + + ((flet labels) + (prune-flet form try-fn)) (otherwise (prune-fn form try-fn)) @@ -396,9 +433,10 @@ (find-in-tree value (cdr tree)))))) (defun prune-fn (form try-fn) + (declare (function try-fn)) (let* ((i 0) - (op (car form)) - (args (cdr form)) + (op (first form)) + (args (rest form)) (len (length args))) (flet ((try-arg (x) (funcall @@ -413,40 +451,92 @@ (incf i))))) (defun prune-let (form try-fn) + (declare (function try-fn)) (let* ((op (car form)) (binding-list (cadr form)) (body (cddr form)) (body-len (length body)) (len (length binding-list))) + + ;; Try to simplify (let ((<name> <form>)) <name>) to <form> (when (and (eql len 1) (eql body-len 1) (eql (caar binding-list) (car body))) (funcall try-fn (cadar binding-list))) + + ;; Try to simplify the forms in the RHS of the bindings (let ((i 0)) - (flet ((try-binding (x) + (flet ((try-binding (name form) (funcall try-fn `(,op (,@(subseq binding-list 0 i) - ,x + (,name ,form) ,@(subseq binding-list (1+ i))) ,@body)))) (declare (dynamic-extent (function try-binding))) - (loop while (< i len) - do (prune (elt binding-list i) #'try-binding) + (loop for binding in binding-list + while (< i len) + do (prune (second binding) + #'(lambda (form) + (try-binding (first binding) form))) (incf i)))) + + ;; Try to simplify the body of the LET form (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))) + (when (and (first binding-list) + (not (rest binding-list)) + (not (rest body))) + (let ((binding (first binding-list))) (unless (consp (second binding)) (funcall try-fn `(let () - ,@(subst (cadr binding) (car binding) body)))))) + ,@(subst (second binding) + (first binding) body)))))) + (prune (car (last body)) + #'(lambda (form2) + (funcall try-fn + `(,@(butlast form) ,form2))))))) + +(defun prune-flet (form try-fn) + (declare (function try-fn)) + (let* ((op (car form)) + (binding-list (cadr form)) + (body (cddr form)) + (len (length binding-list))) + + ;; Try to simplify the forms in the RHS of the bindings + (let ((i 0)) + (flet ((try-binding (name args form) + (funcall + try-fn + `(,op + (,@(subseq binding-list 0 i) + (,name ,args ,form) + ,@(subseq binding-list (1+ i))) + ,@body)))) + (declare (dynamic-extent (function try-binding))) + (loop for binding in binding-list + while (< i len) + do (when (null (cdddr binding)) + (prune (third binding) + #'(lambda (form) + (try-binding (first binding) + (second binding) + form)))) + (incf i)))) + + ;; ;; Try to simplify the body of the FLET form + (when body + ;; No bindings -- try to simplify to the last form in the body + (unless binding-list + (funcall try-fn (car (last body)))) + (prune (car (last body)) #'(lambda (form2) (funcall try-fn `(,@(butlast form) ,form2))))))) + + -- GitLab