/[gcl]/gcl/ansi-tests/random-int-form.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/random-int-form.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3 by pfdietz, Fri Sep 12 12:35:27 2003 UTC revision 1.4 by pfdietz, Sun Sep 14 20:30:05 2003 UTC
# Line 32  Line 32 
32  ;;; that will eventually replace this preliminary effort.  ;;; that will eventually replace this preliminary effort.
33  ;;;  ;;;
34    
35  (declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals*))  (declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals*
36                      *opt-result* *unopt-result*))
37    
38    (defvar *random-int-form-blocks* nil)
39    
40  (defun test-random-integer-forms (size nvars n)  (defun test-random-integer-forms (size nvars n)
41    
# Line 55  Line 58 
58    (let* ((form (make-random-integer-form size vars))    (let* ((form (make-random-integer-form size vars))
59           (var-ranges (mapcar #'make-random-integer-range vars))           (var-ranges (mapcar #'make-random-integer-range vars))
60           (var-types (mapcar #'(lambda (range)           (var-types (mapcar #'(lambda (range)
61                                  `(integer ,(car range) ,(cadr range)))                                  (let ((lo (car range))
62                                          (hi (cadr range)))
63                                      (assert (>= hi lo))
64                                      `(integer ,lo ,hi)))
65                              var-ranges))                              var-ranges))
66           (optimized-fn-src           (vals-list
67            `(lambda ,vars (declare ,@(mapcar #'(lambda (tp var)            (loop repeat 20
68                                                  `(type ,tp ,var))                  collect
                                             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  
69                  (mapcar #'(lambda (range)                  (mapcar #'(lambda (range)
70                              (let ((lo (car range))                              (let ((lo (car range))
71                                    (hi (cadr range)))                                    (hi (cadr range)))
72                                (random-from-interval (1+ hi) lo)))                                (random-from-interval (1+ hi) lo)))
73                          var-ranges)))                          var-ranges))))
74             (setq *int-form-vals* vals)      (test-int-form form vars var-types vals-list)))
            (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  
                                    )))))))))))  
75    
76  (defun fn-symbols-in-form (form)  (defun fn-symbols-in-form (form)
77    "Return a list of the distinct standardized lisp function    "Return a list of the distinct standardized lisp function
# Line 102  Line 79 
79     declaration for the unoptimized form."     declaration for the unoptimized form."
80    (intersection    (intersection
81     (remove-duplicates (fn-symbols-in-form* form) :test #'eq)     (remove-duplicates (fn-symbols-in-form* form) :test #'eq)
82     *cl-function-symbols*))     *cl-function-or-accessor-symbols*))
83    
84  (defun fn-symbols-in-form* (form)  (defun fn-symbols-in-form* (form)
85    (when (consp form)    (when (consp form)
# Line 114  Line 91 
91    "Generate a list (LO HI) of integers, LO <= HI.  This is used    "Generate a list (LO HI) of integers, LO <= HI.  This is used
92     for generating integer types."     for generating integer types."
93    (declare (ignore var))    (declare (ignore var))
94    (flet ((%r () (let ((r (ash 1 (1+ (random 32)))))    (flet ((%r () (let ((r (ash 1 (1+ (random 35)))))
95                    (- (random r) (floor (/ r 2))))))                    (- (random r) (floor (/ r 2))))))
96      (let ((x (%r))      (let ((x (%r))
97            (y (%r)))            (y (%r)))
# Line 130  Line 107 
107              (- (random r) (floor (/ r 2))))              (- (random r) (floor (/ r 2))))
108          (random-from-seq vars))          (random-from-seq vars))
109      ;; (> size 1)      ;; (> size 1)
110      (ecase (random 9)      (rcase
111       ;; Unary ops       ;; Unary ops
112       ((0 1)       (40
113        (let ((op (random-from-seq '(- abs signum 1+ 1- identity        (let ((op (random-from-seq '(- abs abs signum signum 1+ 1- identity
114                                       integer-length logcount))))                                       integer-length logcount))))
115          `(,op ,(make-random-integer-form (1- size) vars))))          `(,op ,(make-random-integer-form (1- size) vars))))
116       ;; Binary op       ;; Binary op
117       ((2 3 4 5)       (80
118        (let* ((op (random-from-seq        (let* ((op (random-from-seq
119                    '(+ - * logand min max ;; gcd lcm                    '(+ - * logand min max min max ;; gcd lcm
120                        logandc1 logandc2 logeqv logior lognand lognor logorc1                        #-:allegro logandc1  ;; bug in ACL 6.2 makes this cause crashes
121                          logandc2 logeqv logior lognand lognor logorc1
122                        logorc2 logxor))))                        logorc2 logxor))))
123          (destructuring-bind (leftsize rightsize)          (destructuring-bind (leftsize rightsize)
124              (random-partition (1- size) 2)              (random-partition (1- size) 2)
125            `(,op ,(make-random-integer-form leftsize vars)            (let ((e1 (make-random-integer-form leftsize vars))
126                  ,(make-random-integer-form rightsize vars)))))                  (e2 (make-random-integer-form rightsize vars)))
127                `(,op ,e1 ,e2)))))
128       ;; conditionals       ;; conditionals
129       (6       (20
130        (let* ((cond-size (random (max 1 (floor size 2))))        (let* ((cond-size (random (max 1 (floor size 2))))
131               (then-size (random (- size cond-size)))               (then-size (random (- size cond-size)))
132               (else-size (- size 1 cond-size then-size))               (else-size (- size 1 cond-size then-size))
# Line 155  Line 134 
134               (then-part (make-random-integer-form then-size vars))               (then-part (make-random-integer-form then-size vars))
135               (else-part (make-random-integer-form else-size vars)))               (else-part (make-random-integer-form else-size vars)))
136          `(if ,pred ,then-part ,else-part)))          `(if ,pred ,then-part ,else-part)))
137       (7       (10
138        (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)        (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)
139          `(,(random-from-seq '(deposit-field dpb))          `(,(random-from-seq '(deposit-field dpb))
140            ,(make-random-integer-form s1 vars)            ,(make-random-integer-form s1 vars)
141            ,(make-random-byte-spec-form s2 vars)            ,(make-random-byte-spec-form s2 vars)
142            ,(make-random-integer-form s3 vars))))            ,(make-random-integer-form s3 vars))))
143       (8       (10
144        (destructuring-bind (s1 s2) (random-partition (1- size) 2)        (destructuring-bind (s1 s2) (random-partition (1- size) 2)
145            `(,(random-from-seq '(ldb mask-field))            `(,(random-from-seq '(ldb mask-field))
146              ,(make-random-byte-spec-form s1 vars)              ,(make-random-byte-spec-form s1 vars)
147              ,(make-random-integer-form s2 vars))))              ,(make-random-integer-form s2 vars))))
148         (20
149          (destructuring-bind (s1 s2) (random-partition (1- size) 2)
150            (let* ((var (random-from-seq #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)))
151                   (e1 (make-random-integer-form s1 vars))
152                   (e2 (make-random-integer-form s2 (cons var vars))))
153              ;; for now, avoid shadowing
154              (if (member var vars)
155                  (make-random-integer-form size vars)
156                `(let ((,var ,e1)) ,e2)))))
157         (10
158          (let* ((name (random-from-seq #(b1 b2 b3 b4 b5 b6 b7 b8)))
159                 (*random-int-form-blocks* (adjoin name *random-int-form-blocks*)))
160            `(block ,name ,(make-random-integer-form (1- size) vars))))
161         (1
162          (if *random-int-form-blocks*
163              (let ((name (random-from-seq *random-int-form-blocks*))
164                    (form (make-random-integer-form (1- size) vars)))
165                `(return-from ,name ,form))
166            ;; No blocks -- try again
167            (make-random-integer-form size vars)))
168    
169         (5
170          (if *random-int-form-blocks*
171              (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)
172                (let ((name (random-from-seq *random-int-form-blocks*))
173                      (pred (make-random-pred-form s1 vars))
174                      (then (make-random-integer-form s2 vars))
175                      (else (make-random-integer-form s3 vars)))
176                  `(if ,pred (return-from ,name ,then) ,else)))
177            ;; No blocks -- try again
178            (make-random-integer-form size vars)))
179                    
180       )))       )))
181    
182  (defun make-random-pred-form (size vars)  (defun make-random-pred-form (size vars)
183    (if (<= size 1)    (if (<= size 1)
184        (ecase (random 3)        (rcase
185          (0 (if (coin) t nil))          (1 (if (coin) t nil))
186          ((1 2)          (2
187           `(,(random-from-seq '(< <= = > >= /= eql equal))           `(,(random-from-seq '(< <= = > >= /= eql equal))
188             ,(make-random-integer-form size vars)             ,(make-random-integer-form size vars)
189             ,(make-random-integer-form size vars))))             ,(make-random-integer-form size vars))))
190      (ecase (random 6)      (rcase
191        (0 (if (coin) t nil))        (1 (if (coin) t nil))
192        (1 `(not ,(make-random-pred-form (1- size) vars)))        (1 `(not ,(make-random-pred-form (1- size) vars)))
193        (2 (destructuring-bind (leftsize rightsize)        (2 (destructuring-bind (leftsize rightsize)
194               (random-partition (1- size) 2)               (random-partition (1- size) 2)
195             `(,(random-from-seq '(and or))             `(,(random-from-seq '(and or))
196               ,(make-random-pred-form leftsize vars)               ,(make-random-pred-form leftsize vars)
197               ,(make-random-pred-form rightsize vars))))               ,(make-random-pred-form rightsize vars))))
198        (3 (destructuring-bind (leftsize rightsize)        (1 (destructuring-bind (leftsize rightsize)
199               (random-partition (1- size) 2)               (random-partition (1- size) 2)
200             `(,(random-from-seq '(< <= > >= = /= eql equal))             `(,(random-from-seq '(< <= > >= = /= eql equal))
201               ,(make-random-integer-form leftsize vars)               ,(make-random-integer-form leftsize vars)
202               ,(make-random-integer-form rightsize vars))))               ,(make-random-integer-form rightsize vars))))
203        (4 (let* ((cond-size (random (max 1 (floor size 2))))        (1 (let* ((cond-size (random (max 1 (floor size 2))))
204                  (then-size (random (- size cond-size)))                  (then-size (random (- size cond-size)))
205                  (else-size (- size 1 cond-size then-size))                  (else-size (- size 1 cond-size then-size))
206                  (pred (make-random-pred-form cond-size vars))                  (pred (make-random-pred-form cond-size vars))
207                  (then-part (make-random-pred-form then-size vars))                  (then-part (make-random-pred-form then-size vars))
208                  (else-part (make-random-pred-form else-size vars)))                  (else-part (make-random-pred-form else-size vars)))
209             `(if ,pred ,then-part ,else-part)))             `(if ,pred ,then-part ,else-part)))
210        (5 (destructuring-bind (s1 s2)        (1 (destructuring-bind (s1 s2)
211               (random-partition (1- size) 2)               (random-partition (1- size) 2)
212             `(ldb-test ,(make-random-byte-spec-form s1 vars)             `(ldb-test ,(make-random-byte-spec-form s1 vars)
213                        ,(make-random-integer-form s2 vars))))                        ,(make-random-integer-form s2 vars))))
214          (1 (let ((index (random (1+ (random 35))))
215                   (form (make-random-integer-form (1- size) vars)))
216               `(logbitp ,index ,form)))
217        )))        )))
218    
219  (defun make-random-byte-spec-form (size vars)  (defun make-random-byte-spec-form (size vars)
# Line 218  Line 231 
231     (t     (t
232      (let ((n1 (1+ (random (floor n p)))))      (let ((n1 (1+ (random (floor n p)))))
233        (cons n1 (random-partition (- n n1) (1- p)))))))        (cons n1 (random-partition (- n n1) (1- p)))))))
234    
235    ;;; Interface to the form pruner
236    
237    (defun test-int-form (form vars var-types vals-list)
238      ;; Try to compile FORM with associated VARS, and if it compiles
239      ;; check for equality of the two compiled forms.
240      ;; Return a non-nil list of details if a problem is found,
241      ;; NIL otherwise.
242      (let ((optimized-fn-src
243              `(lambda ,vars
244                 (declare ,@(mapcar #'(lambda (tp var)
245                                        `(type ,tp ,var))
246                                    var-types vars)
247                          (ignorable ,@vars)
248                          (optimize #+cmu (extensions:inhibit-warnings 3)
249                                    (speed 3) (safety 1) (debug 1)))
250                 ,form))
251             (unoptimized-fn-src
252              `(lambda ,vars
253                 (declare (notinline ,@(fn-symbols-in-form form))
254                          (optimize #+cmu (extensions:inhibit-warnings 3)
255                                    (safety 3) (speed 0) (debug 3))
256                          (ignorable ,@vars))
257                 ,form)))
258        (setq *int-form-vals* nil
259              *optimized-fn-src* optimized-fn-src
260              *unoptimized-fn-src* unoptimized-fn-src)
261        (handler-bind
262         (#+sbcl (sb-ext::compiler-note #'muffle-warning)
263                 (warning #'muffle-warning)
264                 (error #'(lambda (c)
265                            (format t "Compilation failure~%")
266                            (return-from test-int-form
267                              (list (list :vars vars
268                                          :form form
269                                          :var-types var-types
270                                          :vals (first vals-list)
271                                          :compiler-condition c))))))
272         (let ((optimized-compiled-fn (compile nil optimized-fn-src))
273               (unoptimized-compiled-fn (compile nil unoptimized-fn-src)))
274           (dolist (vals vals-list)
275             (setq *int-form-vals* vals)
276             (let ((unopt-result (multiple-value-list
277                                (apply unoptimized-compiled-fn vals)))
278                   (opt-result (multiple-value-list
279                                  (apply optimized-compiled-fn vals))))
280               (if (equal opt-result unopt-result)
281                   nil
282                 (progn
283                   (format t "Different results: ~A, ~A~%"
284                           opt-result unopt-result)
285                   (setq *opt-result* opt-result
286                         *unopt-result* unopt-result)
287                   (return (list (list :vars vars
288                                       :vals vals
289                                       :form form
290                                       :var-types var-types
291                                       :optimized-values opt-result
292                                       :unoptimized-values unopt-result
293                                       )))))))))))
294    
295    (defun prune-int-form (form vars var-types vals-list)
296      (flet ((%try-fn (new-form)
297                      (when (test-int-form new-form vars var-types vals-list)
298                        (setf form new-form)
299                        (throw 'success nil))))
300        (loop
301         (catch 'success
302           (prune form #'%try-fn)
303           (return form)))))
304    
305    (defun prune-results (result-list)
306      (assert result-list)
307      (loop for result in result-list
308            collect
309            (let ((form (getf result :form))
310                  (vars (getf result :vars))
311                  (var-types (getf result :var-types))
312                  (vals-list (list (getf result :vals)))
313                  )
314              `(:vars ,vars
315                :var-types ,var-types
316                :vals ,(first vals-list)
317                :form ,(prune-int-form form vars var-types vals-list)))))
318    
319    ;;;
320    ;;; The call (PRUNE form try-fn) attempts to simplify the lisp form
321    ;;; so that it still satisfies TRY-FN.  The function TRY-FN should
322    ;;; return if the substitution is a failure.  Otherwise, it should
323    ;;; transfer control elsewhere via GO, THROW, etc.
324    ;;;
325    ;;; The return value of PRUNE should be ignored.
326    ;;;
327    (defun prune (form try-fn)
328      (flet ((try (x) (funcall try-fn x)))
329        (when (consp form)
330          (let ((op (car form))
331                (args (cdr form)))
332            (case op
333            
334             ((signum integer-length logcount
335                      gcd lcm logandc1 logandc2 lognand lognor logorc1 logorc2)
336              (mapc #'try args)
337              (try 0)
338              (try 1)
339              (try -1)
340              (prune-fn form try-fn))
341            
342             ((abs 1+ 1- identity)
343              (mapc #'try args)
344              (prune-fn form try-fn))
345            
346             ((- + * min max logand logior logxor logeqv and or not eq eql equal = < > <= >= /=)
347              (when (every #'constantp args)
348                (try (eval form)))
349              (mapc #'try args)
350              (prune-fn form try-fn))
351            
352             ((if)
353              (let (;; (pred (first args))
354                    (then (second args))
355                    (else (third args)))
356                (try then)
357                (try else)
358                (prune-fn form try-fn)))
359    
360             ((byte)
361              (prune-fn form try-fn))
362    
363             ((deposit-field dpb)
364              (try (first args))
365              (try (third args))
366              (prune-fn form try-fn))
367    
368             ((ldb mask-field)
369              (try (second args))
370              (prune-fn form try-fn))
371    
372             ((ldb-test)
373              (prune-fn form try-fn))
374    
375             ((let let*)
376              (prune-let form try-fn))
377    
378             ((block)
379              (let ((name (second form))
380                    (body (cddr form)))
381                (when (and body (null (cdr body)))
382                  (when (not (find-in-tree name body))
383                    (try (first body)))
384                  ;; Simplify the subexpression
385                  (prune (first body)
386                         #'(lambda (x)
387                             (try `(block ,name ,x)))))))
388            
389             (otherwise
390              (prune-fn form try-fn))
391             )))))
392    
393    (defun find-in-tree (value tree)
394      (or (eql value tree)
395          (and (consp tree)
396               (or (find-in-tree value (car tree))
397                   (find-in-tree value (cdr tree))))))
398    
399    (defun prune-fn (form try-fn)
400      (let* ((i 0)
401             (op (car form))
402             (args (cdr form))
403             (len (length args)))
404        (flet ((try-arg (x)
405                        (funcall
406                         try-fn
407                         (cons op
408                               (append (subseq args 0 i)
409                                       (list x)
410                                       (subseq args (1+ i)))))))
411          (declare (dynamic-extent (function try-arg)))
412          (loop while (< i len)
413                do (prune (elt args i) #'try-arg)
414                   (incf i)))))
415    
416    (defun prune-let (form try-fn)
417      (let* ((op (car form))
418             (binding-list (cadr form))
419             (body (cddr form))
420             (body-len (length body))
421             (len (length binding-list)))
422        (when (and (eql len 1)
423                   (eql body-len 1)
424                   (eql (caar binding-list) (car body)))
425          (funcall try-fn (cadar binding-list)))
426        (let ((i 0))
427          (flet ((try-binding (x)
428                              (funcall
429                               try-fn
430                               `(,op
431                                 (,@(subseq binding-list 0 i)
432                                    ,x
433                                    ,@(subseq binding-list (1+ i)))
434                                 ,@body))))
435            (declare (dynamic-extent (function try-binding)))
436            (loop while (< i len)
437                  do (prune (elt binding-list i) #'try-binding)
438                  (incf i))))
439        (when body
440          (unless binding-list
441            (funcall try-fn (car (last body))))
442          (when (and (car binding-list)
443                     (not (cdr binding-list))
444                     (not (cdr body)))
445            (let ((binding (car binding-list)))
446              (unless (consp (second binding))
447                (funcall try-fn `(let ()
448                                   ,@(subst (cadr binding) (car binding) body))))))
449          (prune (car (last body))
450                 #'(lambda (form2)
451                     (funcall try-fn
452                              `(,@(butlast form) ,form2)))))))
453    

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

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