mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Fix baseline compilation of conditionals

Browse source 
* module/language/tree-il/compile-bytecode.scm (canonicalize): Don't add
  an extra false? around predicates.
  (compile-closure): Fix predicate comparison instructions.
This commit is contained in:
Andy Wingo 2020-05-04 22:28:34 +02:00
parent 6b2d56ce15
commit cfdaf35d73
1 changed files with 5 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

7
module/language/tree-il/compile-bytecode.scm
View file

@ -399,6 +399,7 @@
(define (finish-conditional exp) (define (finish-conditional exp)
(define (true? x) (match x (($ <const> _ val) val) (_ #f))) (define (true? x) (match x (($ <const> _ val) val) (_ #f)))
(define (false? x) (match x (($ <const> _ val) (not val)) (_ #f))) (define (false? x) (match x (($ <const> _ val) (not val)) (_ #f)))
(define (predicate? name) (primitive-predicate? (lookup-primitive name)))
(match exp (match exp
(($ <conditional> src ($ <conditional> _ test (? true?) (? false?)) (($ <conditional> src ($ <conditional> _ test (? true?) (? false?))
consequent alternate) consequent alternate)
@ -406,6 +407,8 @@
(($ <conditional> src ($ <conditional> _ test (? false?) (? true?)) (($ <conditional> src ($ <conditional> _ test (? false?) (? true?))
consequent alternate) consequent alternate)
(finish-conditional (make-conditional src test alternate consequent))) (finish-conditional (make-conditional src test alternate consequent)))
(($ <conditional> src ($ <primcall> _ (? predicate?)))
exp)
(($ <conditional> src test consequent alternate) (($ <conditional> src test consequent alternate)
(make-conditional src (make-primcall src 'false? (list test)) (make-conditional src (make-primcall src 'false? (list test))
alternate consequent)))) alternate consequent))))
@ -864,8 +867,8 @@ in the frame with for the lambda-case clause @var{clause}."
(kf (gensym "false")) (kf (gensym "false"))
(kdone (gensym "done"))) (kdone (gensym "done")))
(match args (match args
((a) (emit asm args a kf)) ((a) (emit asm a kf))
((a b) (emit asm args a b kf))) ((a b) (emit asm a b kf)))
(for-context consequent env ctx) (for-context consequent env ctx)
(unless (eq? ctx 'tail) (unless (eq? ctx 'tail)
(emit-j asm kdone)) (emit-j asm kdone))