expand-primitives!
effect-free-primitive? effect+exception-free-primitive?
constructor-primitive? accessor-primitive?
- singly-valued-primitive? equality-primitive?))
- singly-valued-primitive? bailout-primitive?
++ singly-valued-primitive? equality-primitive?
++ bailout-primitive?
+ negate-primitive))
+ ;; When adding to this, be sure to update *multiply-valued-primitives*
+ ;; if appropriate.
(define *interesting-primitive-names*
'(apply @apply
call-with-values @call-with-values
+ * - / 1- 1+ quotient remainder modulo
ash logand logior logxor
not
- pair? null? list? symbol? vector? string? struct?
- nil?
- pair? null? list? symbol? vector? string? struct? number? char?
++ pair? null? list? symbol? vector? string? struct? number? char? nil?
+
+ complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+
+ char<? char<=? char>=? char>?
+
acons cons cons*
list vector
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
not
- pair? null? list? symbol? vector? struct? string?
- nil?
- pair? null? list? symbol? vector? struct? string? number? char?
++ pair? null? list? symbol? vector? struct? string? number? char? nil
+ complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+ char<? char<=? char>=? char>?
+ struct-vtable
- string-length
+ string-length vector-length
;; These all should get expanded out by expand-primitives!.
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
'(values
eq? eqv? equal?
not
- pair? null? list? symbol? vector? struct? string?
+ pair? null? list? symbol? vector? struct? string? number? char?
acons cons cons* list vector))
- ;; Primitives that only return one value.
- (define *singly-valued-primitives*
- '(eq? eqv? equal?
- memq memv
- = < > <= >= zero?
- + * - / 1- 1+ quotient remainder modulo
- ash logand logior logxor
- not
- pair? null? list? symbol? vector? acons cons cons*
- nil?
- list vector
- car cdr
- set-car! set-cdr!
- caar cadr cdar cddr
- caaar caadr cadar caddr cdaar cdadr cddar cdddr
- caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
- cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- vector-ref vector-set!
- variable-ref variable-set!
- variable-bound?
- fluid-ref fluid-set!
- make-prompt-tag
- struct? struct-vtable make-struct struct-ref struct-set!
- string-length string-ref string-set!
- bytevector-u8-ref bytevector-u8-set!
- bytevector-s8-ref bytevector-s8-set!
- u8vector-ref u8vector-set! s8vector-ref s8vector-set!
- bytevector-u16-ref bytevector-u16-set!
- bytevector-u16-native-ref bytevector-u16-native-set!
- bytevector-s16-ref bytevector-s16-set!
- bytevector-s16-native-ref bytevector-s16-native-set!
- u16vector-ref u16vector-set! s16vector-ref s16vector-set!
- bytevector-u32-ref bytevector-u32-set!
- bytevector-u32-native-ref bytevector-u32-native-set!
- bytevector-s32-ref bytevector-s32-set!
- bytevector-s32-native-ref bytevector-s32-native-set!
- u32vector-ref u32vector-set! s32vector-ref s32vector-set!
- bytevector-u64-ref bytevector-u64-set!
- bytevector-u64-native-ref bytevector-u64-native-set!
- bytevector-s64-ref bytevector-s64-set!
- bytevector-s64-native-ref bytevector-s64-native-set!
- u64vector-ref u64vector-set! s64vector-ref s64vector-set!
- bytevector-ieee-single-ref bytevector-ieee-single-set!
- bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
- bytevector-ieee-double-ref bytevector-ieee-double-set!
- bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
- f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
+ ;; Primitives that don't always return one value.
+ (define *multiply-valued-primitives*
+ '(apply @apply
+ call-with-values @call-with-values
+ call-with-current-continuation @call-with-current-continuation
+ call/cc
+ dynamic-wind
+ @dynamic-wind
+ values
+ @prompt call-with-prompt @abort abort-to-prompt))
+
+ ;; Procedures that cause a nonlocal, non-resumable abort.
+ (define *bailout-primitives*
+ '(throw error scm-error))
+
+ ;; Negatable predicates.
+ (define *negatable-primitives*
+ '((even? . odd?)
+ (exact? . inexact?)
+ (< . >=)
+ (> . <=)
+ (char<? . char>=?)
+ (char>? . char<=?)))
+(define *equality-primitives*
+ '(eq? eqv? equal?))
+
(define *effect-free-primitive-table* (make-hash-table))
(define *effect+exceptions-free-primitive-table* (make-hash-table))
- (define *singly-valued-primitive-table* (make-hash-table))
+(define *equality-primitive-table* (make-hash-table))
+ (define *multiply-valued-primitive-table* (make-hash-table))
+ (define *bailout-primitive-table* (make-hash-table))
+ (define *negatable-primitive-table* (make-hash-table))
(for-each (lambda (x)
(hashq-set! *effect-free-primitive-table* x #t))
(for-each (lambda (x)
(hashq-set! *effect+exceptions-free-primitive-table* x #t))
*effect+exception-free-primitives*)
- (for-each (lambda (x)
- (hashq-set! *singly-valued-primitive-table* x #t))
- *singly-valued-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *equality-primitive-table* x #t))
+ *equality-primitives*)
+ (for-each (lambda (x)
+ (hashq-set! *multiply-valued-primitive-table* x #t))
+ *multiply-valued-primitives*)
+ (for-each (lambda (x)
+ (hashq-set! *bailout-primitive-table* x #t))
+ *bailout-primitives*)
+ (for-each (lambda (x)
+ (hashq-set! *negatable-primitive-table* (car x) (cdr x))
+ (hashq-set! *negatable-primitive-table* (cdr x) (car x)))
+ *negatable-primitives*)
(define (constructor-primitive? prim)
(memq prim *primitive-constructors*))
(hashq-ref *effect-free-primitive-table* prim))
(define (effect+exception-free-primitive? prim)
(hashq-ref *effect+exceptions-free-primitive-table* prim))
- (define (singly-valued-primitive? prim)
- (hashq-ref *singly-valued-primitive-table* prim))
+(define (equality-primitive? prim)
+ (hashq-ref *equality-primitive-table* prim))
+ (define (singly-valued-primitive? prim)
+ (not (hashq-ref *multiply-valued-primitive-table* prim)))
+ (define (bailout-primitive? prim)
+ (hashq-ref *bailout-primitive-table* prim))
+ (define (negate-primitive prim)
+ (hashq-ref *negatable-primitive-table* prim))
(define (resolve-primitives! x mod)
+ (define local-definitions
+ (make-hash-table))
+
+ (let collect-local-definitions ((x x))
+ (record-case x
+ ((<toplevel-define> name)
+ (hashq-set! local-definitions name #t))
+ ((<seq> head tail)
+ (collect-local-definitions head)
+ (collect-local-definitions tail))
+ (else #f)))
+
(post-order!
(lambda (x)
(record-case x
--- /dev/null
- (pass-if-peval in pat
- (compile 'in #:from 'scheme #:to 'tree-il)))
- ((_ resolve-primitives in pat)
+ ;;;; 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.
+ ;;;;
+ ;;;; This library is free software; you can redistribute it and/or
+ ;;;; modify it under the terms of the GNU Lesser General Public
+ ;;;; License as published by the Free Software Foundation; either
+ ;;;; version 3 of the License, or (at your option) any later version.
+ ;;;;
+ ;;;; This library is distributed in the hope that it will be useful,
+ ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ ;;;; Lesser General Public License for more details.
+ ;;;;
+ ;;;; You should have received a copy of the GNU Lesser General Public
+ ;;;; License along with this library; if not, write to the Free Software
+ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+ (define-module (test-suite tree-il)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (system base pmatch)
+ #:use-module (system base message)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
+ #:use-module (language glil)
+ #:use-module (srfi srfi-13))
+
+ (define peval
+ ;; The partial evaluator.
+ (@@ (language tree-il optimize) peval))
+
+ (define-syntax pass-if-peval
+ (syntax-rules (resolve-primitives)
+ ((_ in pat)
- (pass-if-peval resolve-primitives
+ (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 "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
++ (pass-if-peval
+ ;; 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))
+
- (apply (primitive values) (const 1) (const 2)))
++ (pass-if-peval
+ ;; First order, multiple values.
+ (let ((x 1) (y 2))
+ (values x y))
- (pass-if-peval resolve-primitives
++ (primcall values (const 1) (const 2)))
+
- (apply (primitive values) (const 1) (const 2)))
++ (pass-if-peval
+ ;; First order, multiple values truncated.
+ (let ((x (values 1 'a)) (y 2))
+ (values x y))
- (pass-if-peval resolve-primitives
++ (primcall values (const 1) (const 2)))
+
- (apply (primitive list)
- (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
++ (pass-if-peval
+ ;; First order, multiple values truncated.
+ (or (values 1 2) 3)
+ (const 1))
+
+ (pass-if-peval
+ ;; First order, coalesced, mutability preserved.
+ (cons 0 (cons 1 (cons 2 (list 3 4 5))))
- (apply (primitive cons) (const 0)
- (apply (primitive cons) (const 1)
- (apply (primitive cons) (const 2)
- (const (3 4 5))))))
++ (primcall list
++ (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
+
+ (pass-if-peval
+ ;; First order, coalesced, immutability preserved.
+ (cons 0 (cons 1 (cons 2 '(3 4 5))))
- (apply (primitive list)
- (apply (primitive cons) (const 1) (const 1))
- (apply (primitive cons) (const 2) (const 2))
- (apply (primitive cons) (const 3) (const 3))))
++ (primcall cons (const 0)
++ (primcall cons (const 1)
++ (primcall cons (const 2)
++ (const (3 4 5))))))
+
+ ;; These two tests doesn't work any more because we changed the way we
+ ;; deal with constants -- now the algorithm will see a construction as
+ ;; being bound to the lexical, so it won't propagate it. It can't
+ ;; even propagate it in the case that it is only referenced once,
+ ;; because:
+ ;;
+ ;; (let ((x (cons 1 2))) (lambda () x))
+ ;;
+ ;; is not the same as
+ ;;
+ ;; (lambda () (cons 1 2))
+ ;;
+ ;; Perhaps if we determined that not only was it only referenced once,
+ ;; it was not closed over by a lambda, then we could propagate it, and
+ ;; re-enable these two tests.
+ ;;
+ #;
+ (pass-if-peval
+ ;; First order, mutability preserved.
+ (let loop ((i 3) (r '()))
+ (if (zero? i)
+ r
+ (loop (1- i) (cons (cons i i) r))))
- ((apply (primitive list)
- (apply (primitive cons) (const 3) (const 3))))
++ (primcall list
++ (primcall cons (const 1) (const 1))
++ (primcall cons (const 2) (const 2))
++ (primcall cons (const 3) (const 3))))
+ ;;
+ ;; See above.
+ #;
+ (pass-if-peval
+ ;; First order, evaluated.
+ (let loop ((i 7)
+ (r '()))
+ (if (<= i 0)
+ (car r)
+ (loop (1- i) (cons i r))))
+ (const 1))
+
+ ;; Instead here are tests for what happens for the above cases: they
+ ;; unroll but they don't fold.
+ (pass-if-peval
+ (let loop ((i 3) (r '()))
+ (if (zero? i)
+ r
+ (loop (1- i) (cons (cons i i) r))))
+ (let (r) (_)
- ((apply (primitive cons)
- (apply (primitive cons) (const 2) (const 2))
- (lexical r _)))
- (apply (primitive cons)
- (apply (primitive cons) (const 1) (const 1))
- (lexical r _)))))
++ ((primcall list
++ (primcall cons (const 3) (const 3))))
+ (let (r) (_)
- ((apply (primitive list) (const 4)))
++ ((primcall cons
++ (primcall cons (const 2) (const 2))
++ (lexical r _)))
++ (primcall cons
++ (primcall cons (const 1) (const 1))
++ (lexical r _)))))
+
+ ;; See above.
+ (pass-if-peval
+ (let loop ((i 4)
+ (r '()))
+ (if (<= i 0)
+ (car r)
+ (loop (1- i) (cons i r))))
+ (let (r) (_)
- ((apply (primitive cons)
- (const 3)
- (lexical r _)))
++ ((primcall list (const 4)))
+ (let (r) (_)
- ((apply (primitive cons)
- (const 2)
- (lexical r _)))
++ ((primcall cons
++ (const 3)
++ (lexical r _)))
+ (let (r) (_)
- ((apply (primitive cons)
- (const 1)
- (lexical r _)))
- (apply (primitive car)
- (lexical r _)))))))
++ ((primcall cons
++ (const 2)
++ (lexical r _)))
+ (let (r) (_)
- (pass-if-peval resolve-primitives
++ ((primcall cons
++ (const 1)
++ (lexical r _)))
++ (primcall car
++ (lexical r _)))))))
+
+ ;; Static sums.
+ (pass-if-peval
+ (let loop ((l '(1 2 3 4)) (sum 0))
+ (if (null? l)
+ sum
+ (loop (cdr l) (+ sum (car l)))))
+ (const 10))
+
- (apply (primitive list) (const #\y) (const #\o)))
++ (pass-if-peval
+ (let ((string->chars
+ (lambda (s)
+ (define (char-at n)
+ (string-ref s n))
+ (define (len)
+ (string-length s))
+ (let loop ((i 0))
+ (if (< i (len))
+ (cons (char-at i)
+ (loop (1+ i)))
+ '())))))
+ (string->chars "yo"))
- (begin
- (apply . _)
- (const #t)))
++ (primcall list (const #\y) (const #\o)))
+
+ (pass-if-peval
+ ;; Primitives in module-refs are resolved (the expansion of `pmatch'
+ ;; below leads to calls to (@@ (system base pmatch) car) and
+ ;; similar, which is what we want to be inlined.)
+ (begin
+ (use-modules (system base pmatch))
+ (pmatch '(a b c d)
+ ((a b . _)
+ #t)))
- (apply (primitive list) (const 1) (const 2) (const 3)))
++ (seq (call . _)
++ (const #t)))
+
+ (pass-if-peval
+ ;; Mutability preserved.
+ ((lambda (x y z) (list x y z)) 1 2 3)
- (let (x) (_) ((apply (primitive list) (const 1)))
- (let (y) (_) ((apply (primitive car) (lexical x _)))
- (begin
- (apply (toplevel set-car!) (lexical x _) (const 0))
++ (primcall 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 (y) (_) ((apply (primitive car) (toplevel x)))
- (begin
- (apply (toplevel set-car!) (toplevel x) (const 0))
++ (let (x) (_) ((primcall list (const 1)))
++ (let (y) (_) ((primcall car (lexical x _)))
++ (seq
++ (primcall 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)
- (apply (lexical x _) (lexical x _))))))
- (apply (lexical x _) (lexical x _))))
++ (let (y) (_) ((primcall car (toplevel x)))
++ (seq
++ (primcall set-car! (toplevel x) (const 0))
+ (lexical y _))))
+
+ (pass-if-peval
+ ;; Infinite recursion
+ ((lambda (x) (x x)) (lambda (x) (x x)))
+ (let (x) (_)
+ ((lambda _
+ (lambda-case
+ (((x) _ _ _ _ _)
- (begin
++ (call (lexical x _) (lexical x _))))))
++ (call (lexical x _) (lexical x _))))
+
+ (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))
- (apply (toplevel pk) (lexical x _) (lexical y _))))))
- (apply (toplevel +) (const 1) (const 2))))
++ (seq
+ (define +
+ (lambda (_)
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
- (begin
- (apply (toplevel do-something!))
++ (call (toplevel pk) (lexical x _) (lexical y _))))))
++ (call (toplevel +) (const 1) (const 2))))
+
+ (pass-if-peval
+ ;; First-order, effects preserved.
+ (let ((x 2))
+ (do-something!)
+ x)
- (apply (primitive *) (const 5) (toplevel z)))
++ (seq
++ (call (toplevel do-something!))
+ (const 2)))
+
+ (pass-if-peval
+ ;; First order, residual bindings removed.
+ (let ((x 2) (y 3))
+ (* (+ x y) z))
- (apply (primitive +) (lexical x _) (const 9)))))))
++ (primcall * (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 () (_))
- (apply (primitive +)
- (apply (primitive *)
- (const 2)
- (apply (primitive +) ; (f 2 3)
- (apply (primitive *)
- (const 2)
- (toplevel top))
- (const 3)))
- (let (x) (_) ((toplevel something)) ; (f something 2)
- ;; `something' is not const, so preserve order of
- ;; effects with a lexical binding.
- (apply (primitive +)
- (apply (primitive *)
- (lexical x _)
- (toplevel top))
- (const 2)))))
++ (primcall + (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)))
- (apply (primitive +)
- (const -1) ; (f -1 0)
- (const 0) ; (f 1 0)
- (begin (toplevel y) (const -1)) ; (f -1 y)
- (toplevel y) ; (f 2 y)
- (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
- (if (apply (primitive >) (lexical x _) (const 0))
- (lexical y _)
- (lexical x _)))))
++ (primcall +
++ (primcall *
++ (const 2)
++ (primcall + ; (f 2 3)
++ (primcall *
++ (const 2)
++ (toplevel top))
++ (const 3)))
++ (let (x) (_) ((toplevel something)) ; (f something 2)
++ ;; `something' is not const, so preserve order of
++ ;; effects with a lexical binding.
++ (primcall +
++ (primcall *
++ (lexical x _)
++ (toplevel top))
++ (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)))
- (apply (toplevel display) (lexical x _))))))
++ (primcall
++ +
++ (const -1) ; (f -1 0)
++ (primcall
++ +
++ (const 0) ; (f 1 0)
++ (primcall
++ +
++ (seq (toplevel y) (const -1)) ; (f -1 y)
++ (primcall
++ +
++ (toplevel y) ; (f 2 y)
++ (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
++ (if (primcall > (lexical x _) (const 0))
++ (lexical y _)
++ (lexical x _))))))))
+
+ (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 () (_))
- (begin
- (apply (toplevel foo))
++ (call (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 4))
+ (const 3))
+
+ (pass-if-peval
+ ;; Don't propagate toplevel references, as intervening expressions
+ ;; could alter their bindings.
+ (let ((x top))
+ (foo)
+ x)
+ (let (x) (_) ((toplevel top))
- (let (y) (_) ((apply (toplevel foo)))
- (apply (primitive +) (lexical y _) (const 7))))
++ (seq
++ (call (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 with optional argument (side-effecting default
+ ;; value).
+ ((lambda* (f x #:optional (y (foo)))
+ (+ y (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3))
- (apply (primitive 1+) (toplevel top)))
++ (let (y) (_) ((call (toplevel foo)))
++ (primcall + (lexical y _) (const 7))))
+
+ (pass-if-peval
+ ;; Higher order with optional argument (caller-supplied value).
+ ((lambda* (f x #:optional (y (foo)))
+ (+ 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))
+ (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)))
- (apply (lexical fold _)
++ (primcall 1+ (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 (primitive -) (lexical x2 _) (const 1))))))))
++ (call (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 () (_))
- (peval (compile
- '(let ((make-adder
- (lambda (x) (lambda (y) (+ x y)))))
- (cons (make-adder 1) (make-adder 2)))
- #:to 'tree-il)))
- ((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))))))
++ (primcall 1- (lexical x2 _))))))))
+
+ (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
- (begin (apply (toplevel foo!))
- (const 10)))
++ (peval (expand-primitives!
++ (resolve-primitives!
++ (compile
++ '(let ((make-adder
++ (lambda (x) (lambda (y) (+ x y)))))
++ (cons (make-adder 1) (make-adder 2)))
++ #:to 'tree-il)
++ (current-module)))))
++ ((primcall cons
++ (lambda ()
++ (lambda-case
++ (((y) #f #f #f () (,gensym1))
++ (primcall +
++ (const 1)
++ (lexical y ,ref1)))))
++ (lambda ()
++ (lambda-case
++ (((y) #f #f #f () (,gensym2))
++ (primcall +
++ (const 2)
++ (lexical y ,ref2))))))
+ (and (eq? gensym1 ref1)
+ (eq? gensym2 ref2)
+ (not (eq? gensym1 gensym2))))
+ (_ #f)))
+
+ (pass-if-peval
+ ;; Unused letrec bindings are pruned.
+ (letrec ((a (lambda () (b)))
+ (b (lambda () (a)))
+ (c (lambda (x) x)))
+ (c 10))
+ (const 10))
+
+ (pass-if-peval
+ ;; Unused letrec bindings are pruned.
+ (letrec ((a (foo!))
+ (b (lambda () (a)))
+ (c (lambda (x) x)))
+ (c 10))
- (apply (primitive memv)
- (const 1)
- (apply (primitive list) (const 3) (const 2) (const 1))))
++ (seq (call (toplevel foo!))
++ (const 10)))
+
+ (pass-if-peval
+ ;; Higher order, mutually recursive procedures.
+ (letrec ((even? (lambda (x)
+ (or (= 0 x)
+ (odd? (- x 1)))))
+ (odd? (lambda (x)
+ (not (even? x)))))
+ (and (even? 4) (odd? 7)))
+ (const #t))
+
+ (pass-if-peval
+ ;; Memv with constants.
+ (memv 1 '(3 2 1))
+ (const '(1)))
+
+ (pass-if-peval
+ ;; Memv with non-constant list. It could fold but doesn't
+ ;; currently.
+ (memv 1 (list 3 2 1))
- (if (if (apply (primitive eqv?) (lexical key _) (const 3))
++ (primcall memv
++ (const 1)
++ (primcall list (const 3) (const 2) (const 1))))
+
+ (pass-if-peval
+ ;; Memv with non-constant key, constant list, test context
+ (case foo
+ ((3 2 1) 'a)
+ (else 'b))
+ (let (key) (_) ((toplevel foo))
- (if (apply (primitive eqv?) (lexical key _) (const 2))
++ (if (if (primcall eqv? (lexical key _) (const 3))
+ (const #t)
- (apply (primitive eqv?) (lexical key _) (const 1))))
++ (if (primcall eqv? (lexical key _) (const 2))
+ (const #t)
- ;; Memv with non-constant key, empty list, test context. Currently
- ;; doesn't fold entirely.
++ (primcall eqv? (lexical key _) (const 1))))
+ (const a)
+ (const b))))
+
+ (pass-if-peval
- (begin (toplevel foo) (const b)))
++ ;; Memv with non-constant key, empty list, test context.
+ (case foo
+ (() 'a)
+ (else 'b))
- ((apply (toplevel make-vector) (const 6) (const #f)))
++ (seq (toplevel foo) (const 'b)))
+
+ ;;
+ ;; 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 vector-set!)
- (lexical v _) (lexical n _) (lexical n _)))))))
++ ((call (toplevel make-vector) (const 6) (const #f)))
+ (lambda ()
+ (lambda-case
+ (((n) #f #f #f () (_))
- ((apply (primitive vector) (const 1) (const 2) (const 3)))
++ (primcall 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) (_)
- (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
- (apply (toplevel frob!))
- (apply (toplevel display) (const chbouib))))
- (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
- (apply (primitive +)
- (lexical x _) (lexical x _) (lexical y _)))))
++ ((primcall 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))
- ((apply (primitive vector) (const 1) (const 2) (const 3))
- (apply (toplevel make-list) (const 10))
- (apply (primitive list) (const 1) (const 2) (const 3)))
- (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 ())))))
++ (let (x) (_) ((if (primcall > (toplevel p) (toplevel q))
++ (call (toplevel frob!))
++ (call (toplevel display) (const chbouib))))
++ (let (y) (_) ((primcall * (lexical x _) (const 2)))
++ (primcall +
++ (lexical x _)
++ (primcall + (lexical x _) (lexical y _))))))
+
+ (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))
+ (let (x y z) (_ _ _)
- (apply (primitive +)
- (apply (primitive +) (lexical foo _) (lexical foo _))
- (apply (primitive +) (lexical bar _) (lexical bar _)))))
++ ((primcall vector (const 1) (const 2) (const 3))
++ (call (toplevel make-list) (const 10))
++ (primcall list (const 1) (const 2) (const 3)))
++ (seq
++ (primcall vector-set!
++ (lexical x _) (const 0) (const 0))
++ (seq (primcall set-car!
++ (lexical y _) (const 0))
++ (primcall set-cdr!
++ (lexical z _) (const ()))))))
+
+ (pass-if-peval
+ (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 (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
- (apply (primitive cons) (const 0) (lexical x _))))
++ (primcall +
++ (primcall + (lexical foo _) (lexical foo _))
++ (primcall + (lexical bar _) (lexical bar _)))))
+
+ (pass-if-peval
+ ;; Fresh objects are not turned into constants, nor are constants
+ ;; turned into fresh objects.
+ (let* ((c '(2 3))
+ (x (cons 1 c))
+ (y (cons 0 x)))
+ y)
- (begin
++ (let (x) (_) ((primcall cons (const 1) (const (2 3))))
++ (primcall cons (const 0) (lexical x _))))
+
+ (pass-if-peval
+ ;; Bindings mutated.
+ (let ((x 2))
+ (set! x 3)
+ x)
+ (let (x) (_) ((const 2))
- (begin
- (apply (toplevel frob) (lambda _ _))
++ (seq
+ (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) (_) ((const 0))
- (let (x) (_) ((apply (toplevel make-foo)))
- (begin
- (apply (toplevel frob!) (lexical x _))
++ (seq
++ (call (toplevel frob) (lambda _ _))
+ (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)
- (apply (lexical loop _)
- (apply (primitive 1-)
- (lexical x _))))))))
- (apply (lexical loop _) (toplevel x))))
++ (let (x) (_) ((call (toplevel make-foo)))
++ (seq
++ (call (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 _ _
- (let (x) (_) ((apply (toplevel top)))
- (apply (toplevel foo) (lexical x _) (const 0))))
++ (call (lexical loop _)
++ (primcall 1-
++ (lexical x _))))))))
++ (call (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))))
- (if (apply (primitive >)
- (lexical y _) (const 0))
++ (let (x) (_) ((call (toplevel top)))
++ (call (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) (1+ y)))))
+ (letrec (loop) (_) ((lambda (_)
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
- (apply (lexical loop _) (toplevel x) (const 0))))
++ (if (primcall >
++ (lexical y _) (const 0))
+ _ _)))))
- (apply (lexical loop _) (const 0))))
++ (call (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 _ . _))
+
+ (pass-if-peval
+ ;; Infinite recursion: all the arguments to `loop' are static, but
+ ;; unrolling it would lead `peval' to enter an infinite loop.
+ (let loop ((x 0))
+ (and (< x top)
+ (loop (1+ x))))
+ (letrec (loop) (_) ((lambda . _))
- (begin
++ (call (lexical loop _) (const 0))))
+
+ (pass-if-peval
+ ;; This test checks that the `start' binding is indeed residualized.
+ ;; See the `referenced?' procedure in peval's `prune-bindings'.
+ (let ((pos 0))
+ (set! pos 1) ;; Cause references to `pos' to residualize.
+ (let ((here (let ((start pos)) (lambda () start))))
+ (here)))
+ (let (pos) (_) ((const 0))
- (apply (lexical here _))))))
++ (seq
+ (set! (lexical pos _) (const 1))
+ (let (here) (_) (_)
- (apply (lexical a _)))))
++ (call (lexical here _))))))
+
+ (pass-if-peval
+ ;; FIXME: should this one residualize the binding?
+ (letrec ((a a))
+ 1)
+ (const 1))
+
+ (pass-if-peval
+ ;; This is a fun one for peval to handle.
+ (letrec ((a a))
+ a)
+ (letrec (a) (_) ((lexical a _))
+ (lexical a _)))
+
+ (pass-if-peval
+ ;; Another interesting recursive case.
+ (letrec ((a b) (b a))
+ a)
+ (letrec (a) (_) ((lexical a _))
+ (lexical a _)))
+
+ (pass-if-peval
+ ;; Another pruning case, that `a' is residualized.
+ (letrec ((a (lambda () (a)))
+ (b (lambda () (a)))
+ (c (lambda (x) x)))
+ (let ((d (foo b)))
+ (c d)))
+
+ ;; "b c a" is the current order that we get with unordered letrec,
+ ;; but it's not important to this test, so if it changes, just adapt
+ ;; the test.
+ (letrec (b c a) (_ _ _)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
- (apply (lexical a _))))))
++ (call (lexical a _)))))
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (lexical x _))))
+ (lambda _
+ (lambda-case
+ ((() #f #f #f () ())
- ((apply (toplevel foo) (lexical b _)))
- (apply (lexical c _)
- (lexical d _)))))
++ (call (lexical a _))))))
+ (let (d)
+ (_)
- (apply (toplevel foo)
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel top) (lexical x _)))))
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel top) (lexical x _)))))))
++ ((call (toplevel foo) (lexical b _)))
++ (call (lexical c _) (lexical d _)))))
+
+ (pass-if-peval
+ ;; In this case, we can prune the bindings. `a' ends up being copied
+ ;; because it is only referenced once in the source program. Oh
+ ;; well.
+ (letrec* ((a (lambda (x) (top x)))
+ (b (lambda () a)))
+ (foo (b) (b)))
- (apply (primitive cons) (const 1) (const '#nil)))
++ (call (toplevel foo)
++ (lambda _
++ (lambda-case
++ (((x) #f #f #f () (_))
++ (call (toplevel top) (lexical x _)))))
++ (lambda _
++ (lambda-case
++ (((x) #f #f #f () (_))
++ (call (toplevel top) (lexical x _)))))))
+
+ (pass-if-peval
+ ;; Constant folding: cons of #nil does not make list
+ (cons 1 #nil)
- (begin (apply (toplevel foo)) (const #f)))
++ (primcall cons (const 1) (const '#nil)))
+
+ (pass-if-peval
+ ;; Constant folding: cons
+ (begin (cons 1 2) #f)
+ (const #f))
+
+ (pass-if-peval
+ ;; Constant folding: cons
+ (begin (cons (foo) 2) #f)
- (begin (apply (toplevel bar)) (const 1)))
++ (seq (call (toplevel foo)) (const #f)))
+
+ (pass-if-peval
+ ;; Constant folding: cons
+ (if (cons 0 0) 1 2)
+ (const 1))
+
+ (pass-if-peval
+ ;; Constant folding: car+cons
+ (car (cons 1 0))
+ (const 1))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+cons
+ (cdr (cons 1 0))
+ (const 0))
+
+ (pass-if-peval
+ ;; Constant folding: car+cons, impure
+ (car (cons 1 (bar)))
- (begin (apply (toplevel bar)) (const 0)))
++ (seq (call (toplevel bar)) (const 1)))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+cons, impure
+ (cdr (cons (bar) 0))
- (apply (primitive list) (const 0)))
++ (seq (call (toplevel bar)) (const 0)))
+
+ (pass-if-peval
+ ;; Constant folding: car+list
+ (car (list 1 0))
+ (const 1))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+list
+ (cdr (list 1 0))
- (begin (apply (toplevel bar)) (const 1)))
++ (primcall list (const 0)))
+
+ (pass-if-peval
+ ;; Constant folding: car+list, impure
+ (car (list 1 (bar)))
- (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
++ (seq (call (toplevel bar)) (const 1)))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+list, impure
+ (cdr (list (bar) 0))
- resolve-primitives
++ (seq (call (toplevel bar)) (primcall list (const 0))))
++
++ (pass-if-peval
++ ;; Equality primitive: same lexical
++ (let ((x (random))) (eq? x x))
++ (seq (call (toplevel random)) (const #t)))
++
++ (pass-if-peval
++ ;; Equality primitive: merge lexical identities
++ (let* ((x (random)) (y x)) (eq? x y))
++ (seq (call (toplevel random)) (const #t)))
+
+ (pass-if-peval
- (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
- (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
+ ;; Non-constant guards get lexical bindings.
+ (dynamic-wind foo (lambda () bar) baz)
- resolve-primitives
++ (let (w u) (_ _) ((toplevel foo) (toplevel baz))
++ (dynwind (lexical w _)
++ (call (lexical w _))
++ (toplevel bar)
++ (call (lexical u _))
++ (lexical u _))))
+
+ (pass-if-peval
- resolve-primitives
+ ;; Constant guards don't need lexical bindings.
+ (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
+ (dynwind
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel foo))))
++ (toplevel foo)
+ (toplevel bar)
++ (toplevel baz)
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel baz))))))
+
+ (pass-if-peval
- resolve-primitives
+ ;; Prompt is removed if tag is unreferenced
+ (let ((tag (make-prompt-tag)))
+ (call-with-prompt tag
+ (lambda () 1)
+ (lambda args args)))
+ (const 1))
+
+ (pass-if-peval
- resolve-primitives
+ ;; Prompt is removed if tag is unreferenced, with explicit stem
+ (let ((tag (make-prompt-tag "foo")))
+ (call-with-prompt tag
+ (lambda () 1)
+ (lambda args args)))
+ (const 1))
+
+ ;; Handler lambda inlined
+ (pass-if-peval
- resolve-primitives
+ (call-with-prompt tag
+ (lambda () 1)
+ (lambda (k x) x))
+ (prompt (toplevel tag)
+ (const 1)
+ (lambda-case
+ (((k x) #f #f #f () (_ _))
+ (lexical x _)))))
+
+ ;; Handler toplevel not inlined
+ (pass-if-peval
- (apply (primitive @apply)
- (lexical handler _)
- (lexical args _)))))))
+ (call-with-prompt tag
+ (lambda () 1)
+ handler)
+ (let (handler) (_) ((toplevel handler))
+ (prompt (toplevel tag)
+ (const 1)
+ (lambda-case
+ ((() #f args #f () (_))
- resolve-primitives
++ (primcall @apply
++ (lexical handler _)
++ (lexical args _)))))))
+
+ (pass-if-peval
- (apply (lexical loop _))))))
- (apply (lexical loop _)))))))
- (apply (lexical lp _))))
+ ;; `while' without `break' or `continue' has no prompts and gets its
+ ;; condition folded. Unfortunately the outer `lp' does not yet get
+ ;; elided.
+ (while #t #t)
+ (letrec (lp) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (letrec (loop) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
- resolve-primitives
++ (call (lexical loop _))))))
++ (call (lexical loop _)))))))
++ (call (lexical lp _))))
+
+ (pass-if-peval
- (pass-if-peval resolve-primitives
+ (lambda (a . rest)
+ (apply (lambda (x y) (+ x y))
+ a rest))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ _))))
+
++ (pass-if-peval
+ (car '(1 2))
+ (const 1)))
HCoop / bpt / guile.git / commitdiff