X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/f49fd9afd698706bd7ff474412b7db0586ad0a56..c53b5d891fb8369abcb7fb3f8d00e134ab7b2d9b:/test-suite/tests/peval.test diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index c24fa8bcd..5b003d26d 100644 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@ -1,7 +1,7 @@ ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- ;;;; Andy Wingo --- 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 @@ -25,6 +25,7 @@ #:use-module (language tree-il) #:use-module (language tree-il primitives) #:use-module (language glil) + #:use-module (rnrs bytevectors) ;; for the bytevector primitives #:use-module (srfi srfi-13)) (define peval @@ -830,6 +831,153 @@ (((x) #f #f #f () (_)) (apply (toplevel top) (lexical x _))))))) + (pass-if-peval resolve-primitives + ;; The inliner sees through a `let'. + ((let ((a 10)) (lambda (b) (* b 2))) 30) + (const 60)) + + (pass-if-peval + ((lambda () + (define (const x) (lambda (_) x)) + (let ((v #f)) + ((const #t) v)))) + (const #t)) + + (pass-if-peval + ;; Applications of procedures with rest arguments can get inlined. + ((lambda (x y . z) + (list x y z)) + 1 2 3 4) + (let (z) (_) ((apply (primitive list) (const 3) (const 4))) + (apply (primitive list) (const 1) (const 2) (lexical z _)))) + + (pass-if-peval resolve-primitives + ;; Unmutated lists can get inlined. + (let ((args (list 2 3))) + (apply (lambda (x y z w) + (list x y z w)) + 0 1 args)) + (apply (primitive list) (const 0) (const 1) (const 2) (const 3))) + + (pass-if-peval resolve-primitives + ;; However if the list might have been mutated, it doesn't propagate. + (let ((args (list 2 3))) + (foo! args) + (apply (lambda (x y z w) + (list x y z w)) + 0 1 args)) + (let (args) (_) ((apply (primitive list) (const 2) (const 3))) + (begin + (apply (toplevel foo!) (lexical args _)) + (apply (primitive @apply) + (lambda () + (lambda-case + (((x y z w) #f #f #f () (_ _ _ _)) + (apply (primitive list) + (lexical x _) (lexical y _) + (lexical z _) (lexical w _))))) + (const 0) + (const 1) + (lexical args _))))) + + (pass-if-peval resolve-primitives + ;; Here the `args' that gets built by the application of the lambda + ;; takes more than effort "10" to visit. Test that we fall back to + ;; the source expression of the operand, which is still a call to + ;; `list', so the inlining still happens. + (lambda (bv offset n) + (let ((x (bytevector-ieee-single-native-ref + bv + (+ offset 0))) + (y (bytevector-ieee-single-native-ref + bv + (+ offset 4)))) + (let ((args (list x y))) + (@apply + (lambda (bv offset x y) + (bytevector-ieee-single-native-set! + bv + (+ offset 0) + x) + (bytevector-ieee-single-native-set! + bv + (+ offset 4) + y)) + bv + offset + args)))) + (lambda () + (lambda-case + (((bv offset n) #f #f #f () (_ _ _)) + (let (x y) (_ _) ((apply (primitive bytevector-ieee-single-native-ref) + (lexical bv _) + (apply (primitive +) + (lexical offset _) (const 0))) + (apply (primitive bytevector-ieee-single-native-ref) + (lexical bv _) + (apply (primitive +) + (lexical offset _) (const 4)))) + (begin + (apply (primitive bytevector-ieee-single-native-set!) + (lexical bv _) + (apply (primitive +) + (lexical offset _) (const 0)) + (lexical x _)) + (apply (primitive bytevector-ieee-single-native-set!) + (lexical bv _) + (apply (primitive +) + (lexical offset _) (const 4)) + (lexical y _)))))))) + + (pass-if-peval resolve-primitives + ;; Here we ensure that non-constant expressions are not copied. + (lambda () + (let ((args (list (foo!)))) + (@apply + (lambda (z x) + (list z x)) + ;; This toplevel ref might raise an unbound variable exception. + ;; The effects of `(foo!)' must be visible before this effect. + z + args))) + (lambda () + (lambda-case + ((() #f #f #f () ()) + (let (_) (_) ((apply (toplevel foo!))) + (let (z) (_) ((toplevel z)) + (apply (primitive 'list) + (lexical z _) + (lexical _ _)))))))) + + (pass-if-peval resolve-primitives + ;; Rest args referenced more than once are not destructured. + (lambda () + (let ((args (list 'foo))) + (set-car! args 'bar) + (@apply + (lambda (z x) + (list z x)) + z + args))) + (lambda () + (lambda-case + ((() #f #f #f () ()) + (let (args) (_) + ((apply (primitive list) (const foo))) + (begin + (apply (primitive set-car!) (lexical args _) (const bar)) + (apply (primitive @apply) + (lambda . _) + (toplevel z) + (lexical args _)))))))) + + (pass-if-peval resolve-primitives + ;; Let-values inlining, even with consumers with rest args. + (call-with-values (lambda () (values 1 2)) + (lambda args + (apply list args))) + (apply (primitive list) (const 1) (const 2))) + (pass-if-peval ;; Constant folding: cons of #nil does not make list (cons 1 #nil) @@ -959,19 +1107,24 @@ resolve-primitives ;; `while' without `break' or `continue' has no prompts and gets its ;; condition folded. Unfortunately the outer `lp' does not yet get - ;; elided. + ;; elided, and the continuation tag stays around. (The continue tag + ;; stays around because although it is not referenced, recursively + ;; visiting the loop in the continue handler manages to visit the tag + ;; twice before aborting. The abort doesn't unroll the recursive + ;; reference.) (while #t #t) - (letrec (lp) (_) - ((lambda _ - (lambda-case - ((() #f #f #f () ()) - (letrec (loop) (_) - ((lambda _ - (lambda-case - ((() #f #f #f () ()) - (apply (lexical loop _)))))) - (apply (lexical loop _))))))) - (apply (lexical lp _)))) + (let (_) (_) ((apply (primitive make-prompt-tag) . _)) + (letrec (lp) (_) + ((lambda _ + (lambda-case + ((() #f #f #f () ()) + (letrec (loop) (_) + ((lambda _ + (lambda-case + ((() #f #f #f () ()) + (apply (lexical loop _)))))) + (apply (lexical loop _))))))) + (apply (lexical lp _))))) (pass-if-peval resolve-primitives @@ -1028,4 +1181,60 @@ (toplevel C)) (apply (toplevel baz) (toplevel x)) (apply (lexical failure _))))) - (apply (lexical failure _)))))) + (apply (lexical failure _))))) + + ;; Multiple common tests should get lifted as well. + (pass-if-peval resolve-primitives + (if (and (struct? x) (eq? (struct-vtable x) A) B) + (foo x) + (if (and (struct? x) (eq? (struct-vtable x) A) C) + (bar x) + (if (and (struct? x) (eq? (struct-vtable x) A) D) + (baz x) + (qux x)))) + (let (failure) (_) ((lambda _ + (lambda-case + ((() #f #f #f () ()) + (apply (toplevel qux) (toplevel x)))))) + (if (apply (primitive struct?) (toplevel x)) + (if (apply (primitive eq?) + (apply (primitive struct-vtable) (toplevel x)) + (toplevel A)) + (if (toplevel B) + (apply (toplevel foo) (toplevel x)) + (if (toplevel C) + (apply (toplevel bar) (toplevel x)) + (if (toplevel D) + (apply (toplevel baz) (toplevel x)) + (apply (lexical failure _))))) + (apply (lexical failure _))) + (apply (lexical failure _))))) + + (pass-if-peval resolve-primitives + (apply (lambda (x y) (cons x y)) '(1 2)) + (apply (primitive cons) (const 1) (const 2))) + + (pass-if-peval resolve-primitives + (apply (lambda (x y) (cons x y)) (list 1 2)) + (apply (primitive cons) (const 1) (const 2))) + + (pass-if-peval resolve-primitives + (let ((t (make-prompt-tag))) + (call-with-prompt t + (lambda () (abort-to-prompt t 1 2 3)) + (lambda (k x y z) (list x y z)))) + (apply (primitive 'list) (const 1) (const 2) (const 3))) + + (pass-if-peval resolve-primitives + ;; Should not inline tail list to apply if it is mutable. + ;; + (let ((l '())) + (if (pair? arg) + (set! l arg)) + (apply f l)) + (let (l) (_) ((const ())) + (begin + (if (apply (primitive pair?) (toplevel arg)) + (set! (lexical l _) (toplevel arg)) + (void)) + (apply (primitive @apply) (toplevel f) (lexical l _))))))