mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

Eliminate trampoline gotos when possible in compile-bytecode

Browse source 
* module/language/cps/compile-bytecode.scm (compile-function): Eliminate
  trampoline jumps for conditional branches that don't shuffle.
This commit is contained in:
Andy Wingo 2015-07-24 15:55:46 +02:00
parent bcfa9fe70e
commit bf6930b3f6
1 changed files with 71 additions and 53 deletions
Download patch file Download diff file Expand all files Collapse all files

124
module/language/cps/compile-bytecode.scm
View file

@ -242,6 +242,18 @@
(($ $primcall 'unwind ()) (($ $primcall 'unwind ())
(emit-unwind asm)))) (emit-unwind asm))))
(define (forward-label label seen)
(if (memv label seen)
label
(match (intmap-ref cps label)
(($ $kargs _ _ ($ $continue k _ ($ $values)))
(match (lookup-parallel-moves label allocation)
(() (match (intmap-ref cps k)
(($ $ktail) label)
(_ (forward-label k (cons label seen)))))
(_ label)))
(cont label))))
(define (compile-values label exp syms) (define (compile-values label exp syms)
(match exp (match exp
(($ $values args) (($ $values args)
@ -250,58 +262,62 @@
(lookup-parallel-moves label allocation))))) (lookup-parallel-moves label allocation)))))
(define (compile-test label exp kt kf next-label) (define (compile-test label exp kt kf next-label)
(define (unary op sym) (let* ((kt (forward-label kt '()))
(cond (kf (forward-label kf '())))
((eq? kt next-label) (define (prefer-true?)
(op asm (slot sym) #t kf)) (if (< (max kt kf) label)
(else ;; Two backwards branches. Prefer
(op asm (slot sym) #f kt) ;; the nearest.
(unless (eq? kf next-label) (> kt kf)
(emit-br asm kf))))) ;; Otherwise prefer a backwards
(define (binary op a b) ;; branch or a near jump.
(cond (< kt kf)))
((eq? kt next-label) (define (unary op sym)
(op asm (slot a) (slot b) #t kf)) (cond
(else ((eq? kt next-label)
(op asm (slot a) (slot b) #f kt) (op asm (slot sym) #t kf))
(unless (eq? kf next-label) ((eq? kf next-label)
(emit-br asm kf))))) (op asm (slot sym) #f kt))
(match exp (else
(($ $values (sym)) (let ((invert? (not (prefer-true?))))
(call-with-values (lambda () (op asm (slot sym) invert? (if invert? kf kt))
(lookup-maybe-constant-value sym allocation)) (emit-br asm (if invert? kt kf))))))
(lambda (has-const? val) (define (binary op a b)
(if has-const? (cond
(if val ((eq? kt next-label)
(unless (eq? kt next-label) (op asm (slot a) (slot b) #t kf))
(emit-br asm kt)) ((eq? kf next-label)
(unless (eq? kf next-label) (op asm (slot a) (slot b) #f kt))
(emit-br asm kf))) (else
(unary emit-br-if-true sym))))) (let ((invert? (not (prefer-true?))))
(($ $primcall 'null? (a)) (unary emit-br-if-null a)) (op asm (slot a) (slot b) invert? (if invert? kf kt))
(($ $primcall 'nil? (a)) (unary emit-br-if-nil a)) (emit-br asm (if invert? kt kf))))))
(($ $primcall 'pair? (a)) (unary emit-br-if-pair a)) (match exp
(($ $primcall 'struct? (a)) (unary emit-br-if-struct a)) (($ $values (sym)) (unary emit-br-if-true sym))
(($ $primcall 'char? (a)) (unary emit-br-if-char a)) (($ $primcall 'null? (a)) (unary emit-br-if-null a))
(($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a)) (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
(($ $primcall 'variable? (a)) (unary emit-br-if-variable a)) (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
(($ $primcall 'vector? (a)) (unary emit-br-if-vector a)) (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
(($ $primcall 'string? (a)) (unary emit-br-if-string a)) (($ $primcall 'char? (a)) (unary emit-br-if-char a))
(($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a)) (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
(($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a)) (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
(($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a)) (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
;; Add more TC7 tests here. Keep in sync with (($ $primcall 'string? (a)) (unary emit-br-if-string a))
;; *branching-primcall-arities* in (language cps primitives) and (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
;; the set of macro-instructions in assembly.scm. (($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a))
(($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b)) (($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a))
(($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b)) ;; Add more TC7 tests here. Keep in sync with
(($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b)) ;; *branching-primcall-arities* in (language cps primitives) and
(($ $primcall '< (a b)) (binary emit-br-if-< a b)) ;; the set of macro-instructions in assembly.scm.
(($ $primcall '<= (a b)) (binary emit-br-if-<= a b)) (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
(($ $primcall '= (a b)) (binary emit-br-if-= a b)) (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
(($ $primcall '>= (a b)) (binary emit-br-if-<= b a)) (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
(($ $primcall '> (a b)) (binary emit-br-if-< b a)) (($ $primcall '< (a b)) (binary emit-br-if-< a b))
(($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b)))) (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
(($ $primcall '= (a b)) (binary emit-br-if-= a b))
(($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
(($ $primcall '> (a b)) (binary emit-br-if-< b a))
(($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b)))))
(define (compile-trunc label k exp nreq rest-var) (define (compile-trunc label k exp nreq rest-var)
(define (do-call proc args emit-call) (define (do-call proc args emit-call)
@ -346,7 +362,9 @@
(define (compile-expression label k exp) (define (compile-expression label k exp)
(let* ((fallthrough? (= k (1+ label)))) (let* ((fallthrough? (= k (1+ label))))
(define (maybe-emit-jump) (define (maybe-emit-jump)
(unless fallthrough? (unless (or fallthrough?
(= (forward-label k '())
(forward-label (1+ label) '())))
(emit-br asm k))) (emit-br asm k)))
(match (intmap-ref cps k) (match (intmap-ref cps k)
(($ $ktail) (($ $ktail)