summaryrefslogtreecommitdiff
path: root/module/language/tree-il/compile-bytecode.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2020-05-04 22:28:34 +0200
committerAndy Wingo <wingo@pobox.com>2020-05-04 22:28:34 +0200
commitcfdaf35d7380c790c152762a5b155a8dde8ddf83 (patch)
treec74ce86dd1cfd3123dd2c418fbf0dd8cc7bb3924 /module/language/tree-il/compile-bytecode.scm
parent6b2d56ce15c9f6126db6bd7d5951378e05b4303f (diff)
downloadguile-cfdaf35d7380c790c152762a5b155a8dde8ddf83.tar.gz
Fix baseline compilation of conditionals
* module/language/tree-il/compile-bytecode.scm (canonicalize): Don't add an extra false? around predicates. (compile-closure): Fix predicate comparison instructions.
Diffstat (limited to 'module/language/tree-il/compile-bytecode.scm')
-rw-r--r--module/language/tree-il/compile-bytecode.scm7
1 files changed, 5 insertions, 2 deletions
diff --git a/module/language/tree-il/compile-bytecode.scm b/module/language/tree-il/compile-bytecode.scm
index d0e5271ba..e2eaabfcc 100644
--- a/module/language/tree-il/compile-bytecode.scm
+++ b/module/language/tree-il/compile-bytecode.scm
@@ -399,6 +399,7 @@
(define (finish-conditional exp)
(define (true? x) (match x (($ <const> _ val) val) (_ #f)))
(define (false? x) (match x (($ <const> _ val) (not val)) (_ #f)))
+ (define (predicate? name) (primitive-predicate? (lookup-primitive name)))
(match exp
(($ <conditional> src ($ <conditional> _ test (? true?) (? false?))
consequent alternate)
@@ -406,6 +407,8 @@
(($ <conditional> src ($ <conditional> _ test (? false?) (? true?))
consequent alternate)
(finish-conditional (make-conditional src test alternate consequent)))
+ (($ <conditional> src ($ <primcall> _ (? predicate?)))
+ exp)
(($ <conditional> src test consequent alternate)
(make-conditional src (make-primcall src 'false? (list test))
alternate consequent))))
@@ -864,8 +867,8 @@ in the frame with for the lambda-case clause @var{clause}."
(kf (gensym "false"))
(kdone (gensym "done")))
(match args
- ((a) (emit asm args a kf))
- ((a b) (emit asm args a b kf)))
+ ((a) (emit asm a kf))
+ ((a b) (emit asm a b kf)))
(for-context consequent env ctx)
(unless (eq? ctx 'tail)
(emit-j asm kdone))