summaryrefslogtreecommitdiff
path: root/test-suite/tests/cse.test
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/cse.test')
-rw-r--r--test-suite/tests/cse.test129
1 files changed, 62 insertions, 67 deletions
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index e0219e84d..f9b85d495 100644
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -70,7 +70,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 +79,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 +110,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 +130,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 +145,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 +168,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 +188,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 +197,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 +216,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 +250,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,16 +277,16 @@
'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"