diff options
author | Andy Wingo <wingo@pobox.com> | 2009-11-06 12:13:33 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-11-15 21:03:32 +0100 |
commit | b4a595a5d6447ef41d57690e841c545aa45d3a08 (patch) | |
tree | e113768cbface36e397ebc607bc8dac735420dce | |
parent | 0e249fd35912fabb7678a395753f315e0302515a (diff) | |
download | guile-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.scm | 61 |
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)))) |