mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

Optimize branches in the evaluator

Browse source 
* module/ice-9/eval.scm (primitive-eval): Factor out primitive=?
  helper.  Simplify compile-top-call.  Add compile-top-branch for
  primcall branches, so the compiler can see the specialized branch
  operator.
This commit is contained in:
Andy Wingo 2015-03-12 14:26:24 +01:00
parent d76d80d23c
commit 7fee63b947
1 changed files with 68 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

106
module/ice-9/eval.scm
View file

@ -122,49 +122,42 @@
(lambda (env)
(env-ref env depth width)))
(define (primitive=? name loc module var)
"Return true if VAR is the same as the primitive bound to NAME."
(match loc
((mode . loc)
(and (match loc
((mod name* . public?) (eq? name* name))
(_ (eq? loc name)))
;; `module' can be #f if the module system was not yet
;; booted when the environment was captured.
(or (not module)
(eq? var (module-local-variable the-root-module name)))))))
(define (compile-top-call cenv loc args)
(let* ((module (env-toplevel cenv))
(var (%resolve-variable loc module)))
(define (primitive=? name)
"Return true if VAR is the same as the primitive bound to NAME."
(match loc
((mode . loc)
(and (match loc
((mod name* . public?) (eq? name* name))
(_ (eq? loc name)))
;; `module' can be #f if the module system was not yet
;; booted when the environment was captured.
(or (not module)
(eq? var (module-local-variable the-root-module name)))))))
(define-syntax-rule (maybe-primcall (prim ...) arg ...)
(cond
((primitive=? 'prim) (lambda (env) (prim (arg env) ...)))
...
(else (lambda (env) ((variable-ref var) (arg env) ...)))))
(let ((arg (compile arg))
...)
(cond
((primitive=? 'prim loc module var)
(lambda (env) (prim (arg env) ...)))
...
(else (lambda (env) ((variable-ref var) (arg env) ...))))))
(match args
(()
(lambda (env) ((variable-ref var))))
((a)
(let ((a (compile a)))
(maybe-primcall
(null? nil? pair? struct? string? vector? symbol?
keyword? variable? bitvector? char? zero?
1+ 1- car cdr lognot not vector-length
variable-ref string-length struct-vtable)
a)))
(maybe-primcall (1+ 1- car cdr lognot vector-length
variable-ref string-length struct-vtable)
a))
((a b)
(let ((a (compile a))
(b (compile b)))
(maybe-primcall
(+ - * / eq? eqv? equal? = < > <= >=
ash logand logior logxor logtest logbit?
cons vector-ref struct-ref allocate-struct variable-set!)
a b)))
(maybe-primcall (+ - * / ash logand logior logxor
cons vector-ref struct-ref allocate-struct variable-set!)
a b))
((a b c)
(let ((a (compile a))
(b (compile b))
(c (compile c)))
(maybe-primcall (vector-set! struct-set!) a b c)))
(maybe-primcall (vector-set! struct-set!) a b c))
((a b c . args)
(let ((a (compile a))
(b (compile b))
@ -237,12 +230,49 @@
(let ((var (%resolve-variable loc (env-toplevel cenv))))
(lambda (env) var)))
(define (compile-top-branch cenv loc args consequent alternate)
(let* ((module (env-toplevel cenv))
(var (%resolve-variable loc module))
(consequent (compile consequent))
(alternate (compile alternate)))
(define (generic-top-branch)
(let ((test (compile-top-call cenv loc args)))
(lambda (env)
(if (test env) (consequent env) (alternate env)))))
(define-syntax-rule (maybe-primcall (prim ...) arg ...)
(cond
((primitive=? 'prim loc module var)
(let ((arg (compile arg))
...)
(lambda (env)
(if (prim (arg env) ...)
(consequent env)
(alternate env)))))
...
(else (generic-top-branch))))
(match args
((a)
(maybe-primcall (null? nil? pair? struct? string? vector? symbol?
keyword? variable? bitvector? char? zero? not)
a))
((a b)
(maybe-primcall (eq? eqv? equal? = < > <= >= logtest logbit?)
a b))
(_
(generic-top-branch)))))
(define (compile-if test consequent alternate)
(let ((test (compile test))
(consequent (compile consequent))
(alternate (compile alternate)))
(lambda (env)
(if (test env) (consequent env) (alternate env)))))
(match test
((,(typecode call)
(,(typecode box-ref) . (,(typecode resolve) . loc))
. args)
(lazy (env) (compile-top-branch env loc args consequent alternate)))
(_
(let ((test (compile test))
(consequent (compile consequent))
(alternate (compile alternate)))
(lambda (env)
(if (test env) (consequent env) (alternate env)))))))
(define (compile-quote x)
(lambda (env) x))