diff options
Diffstat (limited to 'test-suite/tests/cse.test')
-rw-r--r-- | test-suite/tests/cse.test | 147 |
1 files changed, 70 insertions, 77 deletions
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test index e0219e84d..25e662624 100644 --- 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 @@ -28,7 +28,6 @@ #: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 @@ -36,12 +35,12 @@ ((_ in pat) (pass-if 'in (let ((evaled (unparse-tree-il - (canonicalize! - (fix-letrec! + (canonicalize + (fix-letrec (cse (peval - (expand-primitives! - (resolve-primitives! + (expand-primitives + (resolve-primitives (compile 'in #:from 'scheme #:to 'tree-il) (current-module)))))))))) (pmatch evaled @@ -70,7 +69,7 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (apply (primitive eq?) (lexical x _) (lexical y _)))))) + (primcall eq? (lexical x _) (lexical y _)))))) ;; The eq? propagates, and (if TEST #f #t) folds to (not TEST). (pass-if-cse @@ -79,8 +78,8 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (apply (primitive not) - (apply (primitive eq?) (lexical x _) (lexical y _))))))) + (primcall not + (primcall eq? (lexical x _) (lexical y _))))))) ;; (if TEST (not TEST) #f) ;; => (if TEST #f #f) @@ -110,13 +109,13 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (if (apply (primitive set-car!) - (lexical x _) - (lexical y _)) - (apply (primitive not) - (apply (primitive set-car!) - (lexical x _) - (lexical y _))) + (if (primcall set-car! + (lexical x _) + (lexical y _)) + (primcall not + (primcall set-car! + (lexical x _) + (lexical y _))) (const #f)))))) ;; Primitives that access mutable memory can propagate, as long as @@ -130,11 +129,10 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (begin - (apply (primitive string-ref) - (lexical x _) - (lexical y _)) - (const #f)))))) + (seq (primcall string-ref + (lexical x _) + (lexical y _)) + (const #f)))))) ;; However, expressions with dependencies on effects do not propagate ;; through a lambda. @@ -146,15 +144,15 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (if (apply (primitive string-ref) - (lexical x _) - (lexical y _)) + (if (primcall string-ref + (lexical x _) + (lexical y _)) (lambda _ (lambda-case ((() #f #f #f () ()) - (if (apply (primitive string-ref) - (lexical x _) - (lexical y _)) + (if (primcall string-ref + (lexical x _) + (lexical y _)) (const #t) (const #f))))) (const #f)))))) @@ -169,17 +167,16 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (if (apply (primitive string-ref) - (lexical x _) - (lexical y _)) - (begin - (apply (primitive string-set!) - (lexical x _) - (const #\!)) - (apply (primitive not) - (apply (primitive string-ref) - (lexical x _) - (lexical y _)))) + (if (primcall string-ref + (lexical x _) + (lexical y _)) + (seq (primcall string-set! + (lexical x _) + (const #\!)) + (primcall not + (primcall string-ref + (lexical x _) + (lexical y _)))) (const #f)))))) ;; Predicates are only added to the database if they are in a @@ -190,7 +187,7 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (apply (primitive eq?) (lexical x _) (lexical y _)))))) + (primcall eq? (lexical x _) (lexical y _)))))) ;; Conditional bailouts do cause primitives to be added to the DB. (pass-if-cse @@ -199,12 +196,11 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (begin - (if (apply (primitive eq?) - (lexical x _) (lexical y _)) - (void) - (apply (primitive 'throw) (const 'foo))) - (const #t)))))) + (seq (if (primcall eq? + (lexical x _) (lexical y _)) + (void) + (primcall throw (const foo))) + (const #t)))))) ;; A chain of tests in a conditional bailout add data to the DB ;; correctly. @@ -219,21 +215,20 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - (begin + (seq (fix (failure) (_) ((lambda _ (lambda-case ((() #f #f #f () ()) - (apply (primitive throw) (const foo)))))) - (if (apply (primitive struct?) (lexical x _)) - (if (apply (primitive eq?) - (apply (primitive struct-vtable) - (lexical x _)) - (toplevel x-vtable)) + (primcall throw (const foo)))))) + (if (primcall struct? (lexical x _)) + (if (primcall eq? + (primcall struct-vtable (lexical x _)) + (toplevel x-vtable)) (void) - (apply (lexical failure _))) - (apply (lexical failure _)))) - (apply (primitive struct-ref) (lexical x _) (lexical y _))))))) + (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 @@ -254,24 +249,23 @@ ((lambda _ (lambda-case ((() #f #f #f () ()) - (apply (primitive throw) (const foo)))))) - (if (apply (primitive struct?) (lexical x _)) - (if (apply (primitive eq?) - (apply (primitive struct-vtable) - (lexical x _)) - (toplevel x-vtable)) - (apply (primitive struct-ref) (lexical x _) (const 1)) - (apply (lexical failure _))) - (apply (lexical failure _))))) - (apply (primitive +) (lexical z _) - (apply (primitive struct-ref) (lexical x _) (const 2)))))))) + (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)))))))) ;; Replacing named expressions with lexicals. (pass-if-cse (let ((x (car y))) (cons x (car y))) - (let (x) (_) ((apply (primitive car) (toplevel y))) - (apply (primitive cons) (lexical x _) (lexical x _)))) + (let (x) (_) ((primcall car (toplevel y))) + (primcall cons (lexical x _) (lexical x _)))) ;; Dominating expressions only provide predicates when evaluated in ;; test context. @@ -282,23 +276,23 @@ 'two)) ;; Actually this one should reduce in other ways, but this is the ;; current reduction: - (begin - (apply (primitive car) (toplevel x)) - (if (apply (primitive car) (toplevel x)) + (seq + (primcall car (toplevel x)) + (if (primcall car (toplevel x)) (const one) (const two)))) (pass-if-cse (begin (cons 1 2 3) 4) - (begin - (apply (primitive cons) (const 1) (const 2) (const 3)) + (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". - (glil-program? - (compile '(define (proc v) + (procedure? + (compile '(lambda (v) (let ((failure (lambda () (bail-out 'match)))) (if (and (pair? v) (null? (cdr v))) @@ -308,5 +302,4 @@ #t (failure))) (failure)))) - #:from 'scheme - #:to 'glil)))) + #:from 'scheme)))) |