;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012 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
(pat (guard guard-exp) #t)
(_ #f))))))
-(define peval
- ;; The partial evaluator.
- (@@ (language tree-il optimize) peval))
-
-(define-syntax pass-if-peval
- (syntax-rules (resolve-primitives)
- ((_ in pat)
- (pass-if-peval in pat
- (compile 'in #:from 'scheme #:to 'tree-il)))
- ((_ resolve-primitives in pat)
- (pass-if-peval in pat
- (expand-primitives!
- (resolve-primitives!
- (compile 'in #:from 'scheme #:to 'tree-il)
- (current-module)))))
- ((_ in pat code)
- (pass-if 'in
- (let ((evaled (unparse-tree-il (peval code))))
- (pmatch evaled
- (pat #t)
- (_ (pk 'peval-mismatch)
- ((@ (ice-9 pretty-print) pretty-print)
- 'in)
- (newline)
- ((@ (ice-9 pretty-print) pretty-print)
- evaled)
- (newline)
- ((@ (ice-9 pretty-print) pretty-print)
- 'pat)
- (newline)
- #f)))))))
-
\f
(with-test-prefix "tree-il->scheme"
(pass-if-tree-il->scheme
(begin (void) (const 1))
(program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
(assert-tree-il->glil
- (apply (primitive +) (void) (const 1))
+ (primcall + (void) (const 1))
(program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
(with-test-prefix "application"
(assert-tree-il->glil
- (apply (toplevel foo) (const 1))
+ (call (toplevel foo) (const 1))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1)))
(assert-tree-il->glil
- (begin (apply (toplevel foo) (const 1)) (void))
+ (begin (call (toplevel foo) (const 1)) (void))
(program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2)
(label ,l3) (mv-bind 0 #f)
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
- (apply (toplevel foo) (apply (toplevel bar)))
+ (call (toplevel foo) (call (toplevel bar)))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
(call tail-call 1))))
(eq? l1 l3) (eq? l2 l4))
(assert-tree-il->glil
- (apply (primitive null?) (if (toplevel foo) (const 1) (const 2)))
+ (primcall null? (if (toplevel foo) (const 1) (const 2)))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
(const 1) (branch br ,l2)
(label ,l3) (const 2) (label ,l4)
(program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (primitive +))
+ (primcall null? (primitive +))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
(call return 1))))
(lexical #t #f ref 0) (call return 1)
(unbind)))
- (assert-tree-il->glil without-partial-evaluation
+ (assert-tree-il->glil with-options (#:partial-eval? #f #:cse? #f)
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(unbind)))
(assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
+ (let (x) (y) ((const 1)) (primcall null? (lexical x y)))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call null? 1) (call return 1)
(assert-tree-il->glil
;; unreferenced sets may be optimized away -- make sure they are ref'd
(let (x) (y) ((const 1))
- (set! (lexical x y) (apply (primitive 1+) (lexical x y))))
+ (set! (lexical x y) (primcall 1+ (lexical x y))))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
(assert-tree-il->glil
(let (x) (y) ((const 1))
- (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
+ (begin (set! (lexical x y) (primcall 1+ (lexical x y)))
(lexical x y)))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(assert-tree-il->glil
(let (x) (y) ((const 1))
- (apply (primitive null?)
- (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
+ (primcall null?
+ (set! (lexical x y) (primcall 1+ (lexical x y)))))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (@ (foo) bar))
+ (primcall null? (@ (foo) bar))
(program () (std-prelude 0 0 #f) (label _)
(module public ref (foo) bar)
(call null? 1) (call return 1)))
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (@@ (foo) bar))
+ (primcall null? (@@ (foo) bar))
(program () (std-prelude 0 0 #f) (label _)
(module private ref (foo) bar)
(call null? 1) (call return 1))))
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
+ (primcall null? (set! (@ (foo) bar) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 2) (module public set (foo) bar)
(void) (call null? 1) (call return 1)))
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
+ (primcall null? (set! (@@ (foo) bar) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 2) (module private set (foo) bar)
(void) (call null? 1) (call return 1))))
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (toplevel bar))
+ (primcall null? (toplevel bar))
(program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar)
(call null? 1) (call return 1))))
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (set! (toplevel bar) (const 2)))
+ (primcall null? (set! (toplevel bar) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel set bar)
(void) (call null? 1) (call return 1))))
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (define bar (const 2)))
+ (primcall null? (define bar (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel define bar)
(void) (call null? 1) (call return 1))))
(assert-tree-il->glil
;; This gets simplified by `peval'.
- (apply (primitive null?) (const 2))
+ (primcall null? (const 2))
(program () (std-prelude 0 0 #f) (label _)
(const #f) (call return 1))))
;; simple bindings -> let
(assert-tree-il->glil without-partial-evaluation
(letrec (x y) (x1 y1) ((const 10) (const 20))
- (apply (toplevel foo) (lexical x x1) (lexical y y1)))
+ (call (toplevel foo) (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _)
(const 10) (const 20)
(bind (x #f 0) (y #f 1))
;; complex bindings -> box and set! within let
(assert-tree-il->glil without-partial-evaluation
- (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
- (apply (primitive +) (lexical x x1) (lexical y y1)))
+ (letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
+ (primcall + (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 4 #f) (label _)
(void) (void) ;; what are these?
(bind (x #t 0) (y #t 1))
(call new-frame 0) (toplevel ref bar) (call call 0)
(bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2)
(lexical #t #f ref 2) (lexical #t #t set 0)
- (lexical #t #f ref 3) (lexical #t #t set 1) (unbind)
+ (lexical #t #f ref 3) (lexical #t #t set 1)
+ (void) (lexical #t #f set 2) (void) (lexical #t #f set 3) ;; clear bindings
+ (unbind)
(lexical #t #t ref 0) (lexical #t #t ref 1)
(call add 2) (call return 1) (unbind)))
;; complex bindings in letrec* -> box and set! in order
(assert-tree-il->glil without-partial-evaluation
- (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
- (apply (primitive +) (lexical x x1) (lexical y y1)))
+ (letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
+ (primcall + (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _)
(void) (void) ;; what are these?
(bind (x #t 0) (y #t 1))
(assert-tree-il->glil
;; This gets simplified by `peval'.
- (apply (primitive null?) (begin (const #f) (const 2)))
+ (primcall null? (begin (const #f) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const #f) (call return 1))))
(with-test-prefix "values"
(assert-tree-il->glil
- (apply (primitive values)
- (apply (primitive values) (const 1) (const 2)))
+ (primcall values
+ (primcall values (const 1) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 1) (call return 1)))
(assert-tree-il->glil
- (apply (primitive values)
- (apply (primitive values) (const 1) (const 2))
- (const 3))
+ (primcall values
+ (primcall values (const 1) (const 2))
+ (const 3))
(program () (std-prelude 0 0 #f) (label _)
(const 1) (const 3) (call return/values 2)))
(assert-tree-il->glil
- (apply (primitive +)
- (apply (primitive values) (const 1) (const 2)))
+ (primcall +
+ (primcall values (const 1) (const 2)))
+ (program () (std-prelude 0 0 #f) (label _)
+ (const 1) (call return 1)))
+
+ ;; Testing `(values foo)' in push context with RA.
+ (assert-tree-il->glil without-partial-evaluation
+ (primcall cdr
+ (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
+ ((lambda ((name . lp))
+ (lambda-case ((() #f #f #f () ())
+ (primcall values (const (one two)))))))
+ (call (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
(program () (std-prelude 0 0 #f) (label _)
- (const 1) (call return 1))))
+ (branch br _) ;; entering the fix, jump to :2
+ ;; :1 body of lp, jump to :3
+ (label _) (bind) (const (one two)) (branch br _) (unbind)
+ ;; :2 initial call of lp, jump to :1
+ (label _) (bind) (branch br _) (label _) (unbind)
+ ;; :3 the push continuation
+ (call cdr 1) (call return 1))))
;; FIXME: binding info for or-hacked locals might bork the disassembler,
;; and could be tightened in any case
(with-test-prefix "apply"
(assert-tree-il->glil
- (apply (primitive @apply) (toplevel foo) (toplevel bar))
+ (primcall @apply (toplevel foo) (toplevel bar))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
(assert-tree-il->glil
- (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
+ (begin (primcall @apply (toplevel foo) (toplevel bar)) (void))
(program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
- (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
+ (call (toplevel foo) (call (toplevel @apply) (toplevel bar) (toplevel baz)))
(program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
(with-test-prefix "call/cc"
(assert-tree-il->glil
- (apply (primitive @call-with-current-continuation) (toplevel foo))
+ (primcall @call-with-current-continuation (toplevel foo))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
(assert-tree-il->glil
- (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
+ (begin (primcall @call-with-current-continuation (toplevel foo)) (void))
(program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
- (apply (toplevel foo)
- (apply (toplevel @call-with-current-continuation) (toplevel bar)))
+ (call (toplevel foo)
+ (call (toplevel @call-with-current-continuation) (toplevel bar)))
(program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(toplevel ref bar) (call call/cc 1)
(call tail-call 1))))
\f
-(with-test-prefix "partial evaluation"
-
- (pass-if-peval
- ;; First order, primitive.
- (let ((x 1) (y 2)) (+ x y))
- (const 3))
-
- (pass-if-peval
- ;; First order, thunk.
- (let ((x 1) (y 2))
- (let ((f (lambda () (+ x y))))
- (f)))
- (const 3))
-
- (pass-if-peval resolve-primitives
- ;; First order, let-values (requires primitive expansion for
- ;; `call-with-values'.)
- (let ((x 0))
- (call-with-values
- (lambda () (if (zero? x) (values 1 2) (values 3 4)))
- (lambda (a b)
- (+ a b))))
- (const 3))
-
- (pass-if-peval
- ;; First order, coalesced.
- (cons 0 (cons 1 (cons 2 (list 3 4 5))))
- (const (0 1 2 3 4 5)))
-
- (pass-if-peval
- ;; First order, coalesced, mutability preserved.
- (define mutable
- (cons 0 (cons 1 (cons 2 (list 3 4 5)))))
- (define mutable
- ;; This must not be a constant.
- (apply (primitive list)
- (const 0) (const 1) (const 2) (const 3) (const 4) (const 5))))
-
- (pass-if-peval
- ;; First order, mutability preserved.
- (define mutable
- (let loop ((i 3) (r '()))
- (if (zero? i)
- r
- (loop (1- i) (cons (cons i i) r)))))
- (define mutable
- (apply (primitive list)
- (apply (primitive cons) (const 1) (const 1))
- (apply (primitive cons) (const 2) (const 2))
- (apply (primitive cons) (const 3) (const 3)))))
-
- (pass-if-peval
- ;; Mutability preserved.
- (define mutable
- ((lambda (x y z) (list x y z)) 1 2 3))
- (define mutable
- (apply (primitive list) (const 1) (const 2) (const 3))))
-
- (pass-if-peval
- ;; Don't propagate effect-free expressions that operate on mutable
- ;; objects.
- (let* ((x (list 1))
- (y (car x)))
- (set-car! x 0)
- y)
- (let (x) (_) ((apply (primitive list) (const 1)))
- (let (y) (_) ((apply (primitive car) (lexical x _)))
- (begin
- (apply (toplevel set-car!) (lexical x _) (const 0))
- (lexical y _)))))
-
- (pass-if-peval
- ;; Don't propagate effect-free expressions that operate on objects we
- ;; don't know about.
- (let ((y (car x)))
- (set-car! x 0)
- y)
- (let (y) (_) ((apply (primitive car) (toplevel x)))
- (begin
- (apply (toplevel set-car!) (toplevel x) (const 0))
- (lexical y _))))
-
- (pass-if-peval
- ;; First order, evaluated.
- (define one
- (let loop ((i 7)
- (r '()))
- (if (<= i 0)
- (car r)
- (loop (1- i) (cons i r)))))
- (define one (const 1)))
-
- (pass-if-peval
- ;; First order, aliased primitive.
- (let* ((x *) (y (x 1 2))) y)
- (const 2))
-
- (pass-if-peval
- ;; First order, shadowed primitive.
- (begin
- (define (+ x y) (pk x y))
- (+ 1 2))
- (begin
- (define +
- (lambda (_)
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (apply (toplevel pk) (lexical x _) (lexical y _))))))
- (apply (toplevel +) (const 1) (const 2))))
-
- (pass-if-peval
- ;; First-order, effects preserved.
- (let ((x 2))
- (do-something!)
- x)
- (begin
- (apply (toplevel do-something!))
- (const 2)))
-
- (pass-if-peval
- ;; First order, residual bindings removed.
- (let ((x 2) (y 3))
- (* (+ x y) z))
- (apply (primitive *) (const 5) (toplevel z)))
-
- (pass-if-peval
- ;; First order, with lambda.
- (define (foo x)
- (define (bar z) (* z z))
- (+ x (bar 3)))
- (define foo
- (lambda (_)
- (lambda-case
- (((x) #f #f #f () (_))
- (letrec* (bar) (_) ((lambda (_) . _))
- (apply (primitive +) (lexical x _) (const 9))))))))
-
- (pass-if-peval
- ;; First order, with lambda inlined & specialized twice.
- (let ((f (lambda (x y)
- (+ (* x top) y)))
- (x 2)
- (y 3))
- (+ (* x (f x y))
- (f something x)))
- (let (f) (_) ((lambda (_)
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (apply (primitive +)
- (apply (primitive *)
- (lexical x _)
- (toplevel top))
- (lexical y _))))))
- (apply (primitive +)
- (apply (primitive *)
- (const 2)
- (apply (primitive +) ; (f 2 3)
- (apply (primitive *)
- (const 2)
- (toplevel top))
- (const 3)))
- (apply (lexical f _) ; (f something 2)
- ;; This arg is not const, so the lambda does not
- ;; fold. We will fix this in the future when we
- ;; inline lambda to `let'. That will offer the
- ;; possibility of creating a lexical binding for
- ;; `something', to preserve the order of effects.
- (toplevel something)
- (const 2)))))
-
- (pass-if-peval
- ;; First order, with lambda inlined & specialized 3 times.
- (let ((f (lambda (x y) (if (> x 0) y x))))
- (+ (f -1 0)
- (f 1 0)
- (f -1 y)
- (f 2 y)
- (f z y)))
- (let (f) (_)
- ((lambda (_)
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (if (apply (primitive >) (lexical x _) (const 0))
- (lexical y _)
- (lexical x _))))))
- (apply (primitive +)
- (const -1) ; (f -1 0)
- (const 0) ; (f 1 0)
- (apply (lexical f _) ; (f -1 y)
- (const -1) (toplevel y))
- (apply (lexical f _) ; (f 2 y)
- (const 2) (toplevel y))
- (apply (lexical f _) ; (f z y)
- (toplevel z) (toplevel y)))))
-
- (pass-if-peval
- ;; First order, conditional.
- (let ((y 2))
- (lambda (x)
- (if (> y 0)
- (display x)
- 'never-reached)))
- (lambda ()
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel display) (lexical x _))))))
-
- (pass-if-peval
- ;; First order, recursive procedure.
- (letrec ((fibo (lambda (n)
- (if (<= n 1)
- n
- (+ (fibo (- n 1))
- (fibo (- n 2)))))))
- (fibo 7))
- (const 13))
-
- (pass-if-peval
- ;; Don't propagate toplevel references, as intervening expressions
- ;; could alter their bindings.
- (let ((x top))
- (foo)
- x)
- (let (x) (_) ((toplevel top))
- (begin
- (apply (toplevel foo))
- (lexical x _))))
-
- (pass-if-peval
- ;; Higher order.
- ((lambda (f x)
- (f (* (car x) (cadr x))))
- (lambda (x)
- (+ x 1))
- '(2 3))
- (const 7))
-
- (pass-if-peval
- ;; Higher order with optional argument (default value).
- ((lambda* (f x #:optional (y 0))
- (+ y (f (* (car x) (cadr x)))))
- (lambda (x)
- (+ x 1))
- '(2 3))
- (const 7))
-
- (pass-if-peval
- ;; Higher order with optional argument (caller-supplied value).
- ((lambda* (f x #:optional (y 0))
- (+ y (f (* (car x) (cadr x)))))
- (lambda (x)
- (+ x 1))
- '(2 3)
- 35)
- (const 42))
-
- (pass-if-peval
- ;; Higher order.
- ((lambda (f) (f x)) (lambda (x) x))
- (apply (lambda ()
- (lambda-case
- (((x) #f #f #f () (_))
- (lexical x _))))
- (toplevel x)))
-
- (pass-if-peval
- ;; Bug reported at
- ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
- (let ((fold (lambda (f g) (f (g top)))))
- (fold 1+ (lambda (x) x)))
- (let (fold) (_) (_)
- (apply (primitive 1+)
- (apply (lambda ()
- (lambda-case
- (((x) #f #f #f () (_))
- (lexical x _))))
- (toplevel top)))))
-
- (pass-if-peval
- ;; Procedure not inlined when residual code contains recursive calls.
- ;; <http://debbugs.gnu.org/9542>
- (letrec ((fold (lambda (f x3 b null? car cdr)
- (if (null? x3)
- b
- (f (car x3) (fold f (cdr x3) b null? car cdr))))))
- (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
- (letrec (fold) (_) (_)
- (apply (lexical fold _)
- (primitive *)
- (toplevel x)
- (const 1)
- (primitive zero?)
- (lambda ()
- (lambda-case
- (((x1) #f #f #f () (_))
- (lexical x1 _))))
- (lambda ()
- (lambda-case
- (((x2) #f #f #f () (_))
- (apply (primitive -) (lexical x2 _) (const 1))))))))
-
- (pass-if "inlined lambdas are alpha-renamed"
- ;; In this example, `make-adder' is inlined more than once; thus,
- ;; they should use different gensyms for their arguments, because
- ;; the various optimization passes assume uniquely-named variables.
- ;;
- ;; Bug reported at
- ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
- ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
- (pmatch (unparse-tree-il
- (peval (compile
- '(let ((make-adder
- (lambda (x) (lambda (y) (+ x y)))))
- (cons (make-adder 1) (make-adder 2)))
- #:to 'tree-il)))
- ((let (make-adder) (_) (_)
- (apply (primitive cons)
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym1))
- (apply (primitive +)
- (const 1)
- (lexical y ,ref1)))))
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym2))
- (apply (primitive +)
- (const 2)
- (lexical y ,ref2)))))))
- (and (eq? gensym1 ref1)
- (eq? gensym2 ref2)
- (not (eq? gensym1 gensym2))))
- (_ #f)))
-
- (pass-if-peval
- ;; Higher order, mutually recursive procedures.
- (letrec ((even? (lambda (x)
- (or (= 0 x)
- (odd? (- x 1)))))
- (odd? (lambda (x)
- (not (even? (- x 1))))))
- (and (even? 4) (odd? 7)))
- (const #t))
-
- ;;
- ;; Below are cases where constant propagation should bail out.
- ;;
-
- (pass-if-peval
- ;; Non-constant lexical is not propagated.
- (let ((v (make-vector 6 #f)))
- (lambda (n)
- (vector-set! v n n)))
- (let (v) (_)
- ((apply (toplevel make-vector) (const 6) (const #f)))
- (lambda ()
- (lambda-case
- (((n) #f #f #f () (_))
- (apply (toplevel vector-set!)
- (lexical v _) (lexical n _) (lexical n _)))))))
-
- (pass-if-peval
- ;; Mutable lexical is not propagated.
- (let ((v (vector 1 2 3)))
- (lambda ()
- v))
- (let (v) (_)
- ((apply (primitive vector) (const 1) (const 2) (const 3)))
- (lambda ()
- (lambda-case
- ((() #f #f #f () ())
- (lexical v _))))))
-
- (pass-if-peval
- ;; Lexical that is not provably pure is not inlined nor propagated.
- (let* ((x (if (> p q) (frob!) (display 'chbouib)))
- (y (* x 2)))
- (+ x x y))
- (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
- (apply (toplevel frob!))
- (apply (toplevel display) (const chbouib))))
- (apply (primitive +) (lexical x _) (lexical x _)
- (apply (primitive *) (lexical x _) (const 2)))))
-
- (pass-if-peval
- ;; Non-constant arguments not propagated to lambdas.
- ((lambda (x y z)
- (vector-set! x 0 0)
- (set-car! y 0)
- (set-cdr! z '()))
- (vector 1 2 3)
- (make-list 10)
- (list 1 2 3))
- (apply (lambda ()
- (lambda-case
- (((x y z) #f #f #f () (_ _ _))
- (begin
- (apply (toplevel vector-set!)
- (lexical x _) (const 0) (const 0))
- (apply (toplevel set-car!)
- (lexical y _) (const 0))
- (apply (toplevel set-cdr!)
- (lexical z _) (const ()))))))
- (apply (primitive vector) (const 1) (const 2) (const 3))
- (apply (toplevel make-list) (const 10))
- (apply (primitive list) (const 1) (const 2) (const 3))))
-
- (pass-if-peval
- ;; Procedure only called with dynamic args is not inlined.
- (let ((foo top-foo) (bar top-bar))
- (let* ((g (lambda (x y) (+ x y)))
- (f (lambda (g x) (g x x))))
- (+ (f g foo) (f g bar))))
- (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
- (let (g) (_)
- ((lambda _ ; g
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (apply (primitive +) (lexical x _) (lexical y _))))))
- (let (f) (_)
- ((lambda _ ; f
- (lambda-case
- (((g x) #f #f #f () (_ _))
- (apply (lexical g _) (lexical x _) (lexical x _))))))
- (apply (primitive +)
- (apply (lexical g _) (lexical foo _) (lexical foo _))
- (apply (lexical g _) (lexical bar _) (lexical bar _)))))))
-
- (pass-if-peval
- ;; Fresh objects are not turned into constants.
- (let* ((c '(2 3))
- (x (cons 1 c))
- (y (cons 0 x)))
- y)
- (let (x) (_) ((apply (primitive list) (const 1) (const 2) (const 3)))
- (let (y) (_) ((apply (primitive cons) (const 0) (lexical x _)))
- (lexical y _))))
-
- (pass-if-peval
- ;; Bindings mutated.
- (let ((x 2))
- (set! x 3)
- x)
- (let (x) (_) ((const 2))
- (begin
- (set! (lexical x _) (const 3))
- (lexical x _))))
-
- (pass-if-peval
- ;; Bindings mutated.
- (letrec ((x 0)
- (f (lambda ()
- (set! x (+ 1 x))
- x)))
- (frob f) ; may mutate `x'
- x)
- (letrec (x f) (_ _) ((const 0) _)
- (begin
- (apply (toplevel frob) (lexical f _))
- (lexical x _))))
-
- (pass-if-peval
- ;; Bindings mutated.
- (letrec ((f (lambda (x)
- (set! f (lambda (_) x))
- x)))
- (f 2))
- (letrec _ . _))
-
- (pass-if-peval
- ;; Bindings possibly mutated.
- (let ((x (make-foo)))
- (frob! x) ; may mutate `x'
- x)
- (let (x) (_) ((apply (toplevel make-foo)))
- (begin
- (apply (toplevel frob!) (lexical x _))
- (lexical x _))))
-
- (pass-if-peval
- ;; Inlining stops at recursive calls with dynamic arguments.
- (let loop ((x x))
- (if (< x 0) x (loop (1- x))))
- (letrec (loop) (_) ((lambda (_)
- (lambda-case
- (((x) #f #f #f () (_))
- (if _ _
- (apply (lexical loop _)
- (apply (primitive 1-)
- (lexical x _))))))))
- (apply (lexical loop _) (toplevel x))))
-
- (pass-if-peval
- ;; Recursion on the 2nd argument is fully evaluated.
- (let ((x (top)))
- (let loop ((x x) (y 10))
- (if (> y 0)
- (loop x (1- y))
- (foo x y))))
- (let (x) (_) ((apply (toplevel top)))
- (letrec (loop) (_) (_)
- (apply (toplevel foo) (lexical x _) (const 0)))))
-
- (pass-if-peval
- ;; Inlining aborted when residual code contains recursive calls.
- ;; <http://debbugs.gnu.org/9542>
- (let loop ((x x) (y 0))
- (if (> y 0)
- (loop (1+ x) (1+ y))
- (if (< x 0) x (loop (1- x)))))
- (letrec (loop) (_) ((lambda (_)
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (if (apply (primitive >)
- (lexical y _) (const 0))
- _ _)))))
- (apply (lexical loop _) (toplevel x) (const 0))))
-
- (pass-if-peval
- ;; Infinite recursion: `peval' gives up and leaves it as is.
- (letrec ((f (lambda (x) (g (1- x))))
- (g (lambda (x) (h (1+ x))))
- (h (lambda (x) (f x))))
- (f 0))
- (letrec _ . _)))
+(with-test-prefix "labels allocation"
+ (pass-if "http://debbugs.gnu.org/9769"
+ ((compile '(lambda ()
+ (let ((fail (lambda () #f)))
+ (let ((test (lambda () (fail))))
+ (test))
+ #t))
+ ;; Prevent inlining. We're testing analyze.scm's
+ ;; labels allocator here, and inlining it will
+ ;; reduce the entire thing to #t.
+ #:opts '(#:partial-eval? #f)))))
\f
(with-test-prefix "tree-il-fold"
'(lambda ()
(lambda-case
(((x y) #f #f #f () (x1 y1))
- (apply (toplevel +)
- (lexical x x1)
- (lexical y y1)))
+ (call (toplevel +)
+ (lexical x x1)
+ (lexical y y1)))
#f))))))
(and (equal? (map strip-source leaves)
(list (make-lexical-ref #f 'y 'y1)
w "wrong number of arguments to"))))
w)))))
+ (pass-if "top-level applicable struct"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(let ((p current-warning-port))
+ (p (+ (p) 1))
+ (p))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+
+ (pass-if "top-level applicable struct with wrong arguments"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(let ((p current-warning-port))
+ (p 1 2 3))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "wrong number of arguments to")))))
+
(pass-if "local toplevel-defines"
(let ((w (call-with-warnings
(lambda ()
"non-literal format string")))))
(pass-if "non-literal format string using gettext"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(format #t (gettext "~A ~A!") "hello" "world")
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "non-literal format string using gettext as _"
(null? (call-with-warnings
(lambda ()
(compile '(format #t (_ "~A ~A!") "hello" "world")
#:opts %opts-w-format
#:to 'assembly)))))
+ (pass-if "non-literal format string using gettext as top-level _"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(begin
+ (define (_ s) (gettext s "my-domain"))
+ (format #t (_ "~A ~A!") "hello" "world"))
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "non-literal format string using gettext as module-ref _"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(format #t ((@@ (foo) _) "~A ~A!") "hello" "world")
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "non-literal format string using gettext as lexical _"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(let ((_ (lambda (s)
+ (gettext s "my-domain"))))
+ (format #t (_ "~A ~A!") "hello" "world"))
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "non-literal format string using ngettext"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(format #t
+ (ngettext "~a thing" "~a things" n "dom") n)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "non-literal format string using ngettext as N_"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(format #t (N_ "~a thing" "~a things" n) n)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "non-literal format string with (define _ gettext)"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(begin
+ (define _ gettext)
+ (define (foo)
+ (format #t (_ "~A ~A!") "hello" "world")))
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
(pass-if "wrong format string"
(let ((w (call-with-warnings
(lambda ()
(pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
(null? (call-with-warnings
(lambda ()
- (compile '(format some-port "~&~3_~~ ~\n~12they~%")
+ (compile '((@ (ice-9 format) format) some-port
+ "~&~3_~~ ~\n~12they~%")
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "one missing argument, gettext"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format some-port (_ "foo ~A~%"))
+ (compile '(format some-port (gettext "foo ~A~%"))
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "two missing arguments"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "foo ~10,2f and bar ~S~%")
+ (compile '((@ (ice-9 format) format) #f
+ "foo ~10,2f and bar ~S~%")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 2")))))
+ (pass-if "~h"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '((@ (ice-9 format) format) #t
+ "foo ~h ~a~%" 123.4 'bar)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "~:h with locale object"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '((@ (ice-9 format) format) #t
+ "foo ~:h~%" 123.4 %global-locale)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "~:h without locale object"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '((@ (ice-9 format) format) #t "foo ~,2:h" 123.4)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "expected 2, got 1")))))
+
(with-test-prefix "conditionals"
(pass-if "literals"
(null? (call-with-warnings
(lambda ()
- (compile '(format #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
+ (compile '((@ (ice-9 format) format) #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
'a 1 3.14)
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "literals with selector"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~2[foo~;bar~;baz~;~] ~A"
+ (compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
1 'dont-ignore-me)
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "escapes (exact count)"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~[~a~;~a~]")
+ (compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "escapes with selector"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~1[chbouib~;~a~]")
+ (compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "escapes, range"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~[chbouib~;~a~;~2*~a~]")
+ (compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "@"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~@[temperature=~d~]")
+ (compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "nested"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~:[~[hey~;~a~;~va~]~;~3*~]")
+ (compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "unterminated"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~[unterminated")
+ (compile '((@ (ice-9 format) format) #f "~[unterminated")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "unexpected ~;"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "foo~;bar")
+ (compile '((@ (ice-9 format) format) #f "foo~;bar")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "unexpected ~]"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "foo~]")
+ (compile '((@ (ice-9 format) format) #f "foo~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "~{...~}"
(null? (call-with-warnings
(lambda ()
- (compile '(format #f "~A ~{~S~} ~A"
+ (compile '((@ (ice-9 format) format) #f "~A ~{~S~} ~A"
'hello '("ladies" "and")
'gentlemen)
#:opts %opts-w-format
(pass-if "~{...~}, too many args"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~{~S~}" 1 2 3)
+ (compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "~@{...~}"
(null? (call-with-warnings
(lambda ()
- (compile '(format #f "~@{~S~}" 1 2 3)
+ (compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "~@{...~}, too few args"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~A ~@{~S~}")
+ (compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "unterminated ~{...~}"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~{")
+ (compile '((@ (ice-9 format) format) #f "~{")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "~(...~)"
(null? (call-with-warnings
(lambda ()
- (compile '(format #f "~:@(~A ~A~)" 'foo 'bar)
+ (compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "~v"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~v_foo")
+ (compile '((@ (ice-9 format) format) #f "~v_foo")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "~v:@y"
(null? (call-with-warnings
(lambda ()
- (compile '(format #f "~v:@y" 1 123)
+ (compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "~*"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~2*~a" 'a 'b)
+ (compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "~?"
(null? (call-with-warnings
(lambda ()
- (compile '(format #f "~?" "~d ~d" '(1 2))
+ (compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "complex 1"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f
+ (compile '((@ (ice-9 format) format) #f
"~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
1 2 3 4 5 6)
#:opts %opts-w-format
(pass-if "complex 2"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f
+ (compile '((@ (ice-9 format) format) #f
"~:(~A~) Commands~:[~; [abbrev]~]:~2%"
1 2 3 4)
#:opts %opts-w-format
(pass-if "complex 3"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
+ (compile '((@ (ice-9 format) format) #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(compile '(let ((format chbouib))
(format #t "not ~A a format string"))
#:opts %opts-w-format
- #:to 'assembly)))))))
+ #:to 'assembly)))))
+
+ (with-test-prefix "simple-format"
+
+ (pass-if "good"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "wrong number of args"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "wrong number")))))
+
+ (pass-if "unsupported"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(simple-format #t "foo ~x~%" 16)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "unsupported format option")))))
+
+ (pass-if "unsupported, gettext"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(simple-format #t (gettext "foo ~2f~%") 3.14)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "unsupported format option")))))
+
+ (pass-if "unsupported, ngettext"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "unsupported format option"))))))))
HCoop / bpt / guile.git / blobdiff