mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-28 16:00:22 +02:00
Code Activity

faster conditionals

Browse source 
* module/language/tree-il/compile-glil.scm (flatten): Compile `if'
  statements with `eq?' and `null?', and their `not?' variants, into
  more specific bytecode.
This commit is contained in:
Andy Wingo 2009-11-06 12:13:33 +01:00
parent 0e249fd359
commit b4a595a5d6
1 changed files with 57 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

61
module/language/tree-il/compile-glil.scm
View file

@ -487,7 +487,7 @@
(emit-branch #f 'br RA) (emit-branch #f 'br RA)
(emit-label POST))))))))) (emit-label POST)))))))))
((<conditional> src test then else) ((<conditional> src test then (alternate else))
;; TEST ;; TEST
;; (br-if-not L1) ;; (br-if-not L1)
;; THEN ;; THEN
@ -495,15 +495,68 @@
;; L1: ELSE ;; L1: ELSE
;; L2: ;; L2:
(let ((L1 (make-label)) (L2 (make-label))) (let ((L1 (make-label)) (L2 (make-label)))
(comp-push test) ;; need a pattern matcher
(emit-branch src 'br-if-not L1) (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) (comp-tail then)
;; if there is an RA, comp-tail will cause a jump to it -- just ;; if there is an RA, comp-tail will cause a jump to it -- just
;; have to clean up here if there is no RA. ;; have to clean up here if there is no RA.
(if (and (not RA) (not (eq? context 'tail))) (if (and (not RA) (not (eq? context 'tail)))
(emit-branch #f 'br L2)) (emit-branch #f 'br L2))
(emit-label L1) (emit-label L1)
(comp-tail else) (comp-tail alternate)
(if (and (not RA) (not (eq? context 'tail))) (if (and (not RA) (not (eq? context 'tail)))
(emit-label L2)))) (emit-label L2))))