diff options
author | Andy Wingo <wingo@pobox.com> | 2020-05-04 22:28:34 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2020-05-04 22:28:34 +0200 |
commit | cfdaf35d7380c790c152762a5b155a8dde8ddf83 (patch) | |
tree | c74ce86dd1cfd3123dd2c418fbf0dd8cc7bb3924 /module/language/tree-il/compile-bytecode.scm | |
parent | 6b2d56ce15c9f6126db6bd7d5951378e05b4303f (diff) | |
download | guile-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.scm | 7 |
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)) |