summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-11-06 12:13:33 +0100
committerAndy Wingo <wingo@pobox.com>2009-11-15 21:03:32 +0100
commitb4a595a5d6447ef41d57690e841c545aa45d3a08 (patch)
treee113768cbface36e397ebc607bc8dac735420dce
parent0e249fd35912fabb7678a395753f315e0302515a (diff)
downloadguile-b4a595a5d6447ef41d57690e841c545aa45d3a08.tar.gz
faster conditionals
* module/language/tree-il/compile-glil.scm (flatten): Compile `if' statements with `eq?' and `null?', and their `not?' variants, into more specific bytecode.
-rw-r--r--module/language/tree-il/compile-glil.scm61
1 files changed, 57 insertions, 4 deletions
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 547b215e5..16212bb55 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -487,7 +487,7 @@
(emit-branch #f 'br RA)
(emit-label POST)))))))))
- ((<conditional> src test then else)
+ ((<conditional> src test then (alternate else))
;; TEST
;; (br-if-not L1)
;; THEN
@@ -495,15 +495,68 @@
;; L1: ELSE
;; L2:
(let ((L1 (make-label)) (L2 (make-label)))
- (comp-push test)
- (emit-branch src 'br-if-not L1)
+ ;; need a pattern matcher
+ (record-case test
+ ((<application> proc args)
+ (record-case proc
+ ((<primitive-ref> name)
+ (let ((len (length args)))
+ (cond
+
+ ((and (eq? name 'eq?) (= len 2))
+ (comp-push (car args))
+ (comp-push (cadr args))
+ (emit-branch src 'br-if-not-eq L1))
+
+ ((and (eq? name 'null?) (= len 1))
+ (comp-push (car args))
+ (emit-branch src 'br-if-not-null L1))
+
+ ((and (eq? name 'not) (= len 1))
+ (let ((app (car args)))
+ (record-case app
+ ((<application> proc args)
+ (let ((len (length args)))
+ (record-case proc
+ ((<primitive-ref> name)
+ (cond
+
+ ((and (eq? name 'eq?) (= len 2))
+ (comp-push (car args))
+ (comp-push (cadr args))
+ (emit-branch src 'br-if-eq L1))
+
+ ((and (eq? name 'null?) (= len 1))
+ (comp-push (car args))
+ (emit-branch src 'br-if-null L1))
+
+ (else
+ (comp-push app)
+ (emit-branch src 'br-if L1))))
+ (else
+ (comp-push app)
+ (emit-branch src 'br-if L1)))))
+ (else
+ (comp-push app)
+ (emit-branch src 'br-if L1)))))
+
+ (else
+ (comp-push test)
+ (emit-branch src 'br-if-not L1)))))
+ (else
+ (comp-push test)
+ (emit-branch src 'br-if-not L1))))
+ (else
+ (comp-push test)
+ (emit-branch src 'br-if-not L1)))
+
(comp-tail then)
;; if there is an RA, comp-tail will cause a jump to it -- just
;; have to clean up here if there is no RA.
(if (and (not RA) (not (eq? context 'tail)))
(emit-branch #f 'br L2))
(emit-label L1)
- (comp-tail else)
+ (comp-tail alternate)
(if (and (not RA) (not (eq? context 'tail)))
(emit-label L2))))