Remove obsolete comment in compile-bytecode.scm

[bpt/guile.git] / test-suite / tests / cse.test

diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index c2d2ccc..25e6626 100644 (file)
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -1,7 +1,7 @@
 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
 ;;;;
-;;;;   Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;;   Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -23,10 +23,11 @@
   #:use-module (system base pmatch)
   #:use-module (system base message)
   #:use-module (language tree-il)
+  #:use-module (language tree-il canonicalize)
   #:use-module (language tree-il primitives)
+  #:use-module (language tree-il fix-letrec)
   #:use-module (language tree-il cse)
   #:use-module (language tree-il peval)
-  #:use-module (language glil)
   #:use-module (srfi srfi-13))
 
 (define-syntax pass-if-cse
@@ -34,12 +35,14 @@
     ((_ in pat)
      (pass-if 'in
        (let ((evaled (unparse-tree-il
-                      (cse
-                       (peval
-                        (expand-primitives!
-                         (resolve-primitives!
-                          (compile 'in #:from 'scheme #:to 'tree-il)
-                          (current-module))))))))
+                      (canonicalize
+                       (fix-letrec
+                        (cse
+                         (peval
+                          (expand-primitives
+                           (resolve-primitives
+                            (compile 'in #:from 'scheme #:to 'tree-il)
+                            (current-module))))))))))
          (pmatch evaled
            (pat #t)
            (_   (pk 'cse-mismatch)
@@ -212,15 +215,20 @@
     (lambda _
      (lambda-case
       (((x y) #f #f #f () (_ _))
-       (seq (if (if (primcall struct? (lexical x _))
-                    (primcall eq?
-                              (primcall struct-vtable
-                                        (lexical x _))
-                              (toplevel x-vtable))
-                    (const #f))
-                (void)
-                (primcall throw (const foo)))
-            (primcall struct-ref (lexical x _) (lexical y _)))))))
+       (seq
+         (fix (failure) (_)
+              ((lambda _
+                 (lambda-case
+                  ((() #f #f #f () ())
+                   (primcall throw (const foo))))))
+              (if (primcall struct? (lexical x _))
+                  (if (primcall eq?
+                                (primcall struct-vtable (lexical x _))
+                                (toplevel x-vtable))
+                      (void)
+                      (call (lexical failure _)))
+                  (call (lexical failure _))))
+         (primcall struct-ref (lexical x _) (lexical y _)))))))
 
   ;; Strict argument evaluation also adds info to the DB.
   (pass-if-cse
@@ -236,14 +244,19 @@
     (lambda _
       (lambda-case
        (((x) #f #f #f () (_))
-        (let (z) (_) ((if (if (primcall struct? (lexical x _))
-                              (primcall eq?
-                                        (primcall struct-vtable
-                                                  (lexical x _))
-                                        (toplevel x-vtable))
-                              (const #f))
-                          (primcall struct-ref (lexical x _) (const 1))
-                          (primcall throw (const foo))))
+        (let (z) (_)
+             ((fix (failure) (_)
+                   ((lambda _
+                      (lambda-case
+                       ((() #f #f #f () ())
+                        (primcall throw (const foo))))))
+                   (if (primcall struct? (lexical x _))
+                       (if (primcall eq?
+                                     (primcall struct-vtable (lexical x _))
+                                     (toplevel x-vtable))
+                           (primcall struct-ref (lexical x _) (const 1))
+                           (call (lexical failure _)))
+                       (call (lexical failure _)))))
              (primcall + (lexical z _)
                        (primcall struct-ref (lexical x _) (const 2))))))))
 
@@ -252,4 +265,41 @@
    (let ((x (car y)))
      (cons x (car y)))
    (let (x) (_) ((primcall car (toplevel y)))
-        (primcall cons (lexical x _) (lexical x _)))))
+        (primcall cons (lexical x _) (lexical x _))))
+
+  ;; Dominating expressions only provide predicates when evaluated in
+  ;; test context.
+  (pass-if-cse
+   (let ((t (car x)))
+     (if (car x)
+         'one
+         'two))
+   ;; Actually this one should reduce in other ways, but this is the
+   ;; current reduction:
+   (seq
+     (primcall car (toplevel x))
+     (if (primcall car (toplevel x))
+         (const one)
+         (const two))))
+
+  (pass-if-cse
+   (begin (cons 1 2 3) 4)
+   (seq
+     (primcall cons (const 1) (const 2) (const 3))
+     (const 4)))
+
+  (pass-if "http://bugs.gnu.org/12883"
+    ;; In 2.0.6, compiling this code would trigger an out-of-bounds
+    ;; vlist access in CSE's traversal of its "database".
+    (procedure?
+     (compile '(lambda (v)
+                 (let ((failure (lambda () (bail-out 'match))))
+                   (if (and (pair? v)
+                            (null? (cdr v)))
+                       (let ((w foo)
+                             (x (cdr w)))
+                         (if (and (pair? x) (null? w))
+                             #t
+                             (failure)))
+                       (failure))))
+              #:from 'scheme))))