mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 12:20:26 +02:00
Code Activity

Primcall inlining in eval.scm, lazy function body compilation

Browse source 
* module/ice-9/eval.scm (primitive-eval): Lazily compile lambda bodies.
  Special-case calls to top-level or module variables, and recognize
  some of those calls as primcalls.  In that case, emit closures with
  the primcalls.
This commit is contained in:
Andy Wingo 2015-03-12 14:06:15 +01:00
parent eb0376567d
commit d76d80d23c
1 changed files with 95 additions and 30 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -111,26 +111,60 @@
(or (memoized-typecode (syntax->datum #'type))
(error "not a typecode" (syntax->datum #'type)))))))
(define-syntax-rule (lazy (arg ...) exp)
(letrec ((proc (lambda (arg ...)
(set! proc exp)
(proc arg ...))))
(lambda (arg ...)
(proc arg ...))))
(define (compile-lexical-ref depth width)
(lambda (env)
(env-ref env depth width)))
(define (compile-call f args)
(let ((f (compile f)))
(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) ...)))))
(match args
(() (lambda (env) ((f env))))
(()
(lambda (env) ((variable-ref var))))
((a)
(let ((a (compile a)))
(lambda (env) ((f env) (a env)))))
(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)))
((a b)
(let ((a (compile a))
(b (compile b)))
(lambda (env) ((f env) (a env) (b env)))))
(maybe-primcall
(+ - * / eq? eqv? equal? = < > <= >=
ash logand logior logxor logtest logbit?
cons vector-ref struct-ref allocate-struct variable-set!)
a b)))
((a b c)
(let ((a (compile a))
(b (compile b))
(c (compile c)))
(lambda (env) ((f env) (a env) (b env) (c env)))))
(maybe-primcall (vector-set! struct-set!) a b c)))
((a b c . args)
(let ((a (compile a))
(b (compile b))
@ -140,22 +174,57 @@
'()
(cons (compile (car args)) (lp (cdr args)))))))
(lambda (env)
(apply (f env) (a env) (b env) (c env)
(apply (variable-ref var) (a env) (b env) (c env)
(let lp ((args args))
(if (null? args)
'()
(cons ((car args) env) (lp (cdr args))))))))))))
(define (compile-box-ref box)
(define (compile-call f args)
(match f
((,(typecode box-ref) . (,(typecode resolve) . loc))
(lazy (env) (compile-top-call env loc args)))
(_
(match args
(()
(let ((f (compile f)))
(lambda (env) ((f env)))))
((a)
(let ((f (compile f))
(a (compile a)))
(lambda (env) ((f env) (a env)))))
((a b)
(let ((f (compile f))
(a (compile a))
(b (compile b)))
(lambda (env) ((f env) (a env) (b env)))))
((a b c)
(let ((f (compile f))
(a (compile a))
(b (compile b))
(c (compile c)))
(lambda (env) ((f env) (a env) (b env) (c env)))))
((a b c . args)
(let ((f (compile f))
(a (compile a))
(b (compile b))
(c (compile c))
(args (let lp ((args args))
(if (null? args)
'()
(cons (compile (car args)) (lp (cdr args)))))))
(lambda (env)
(apply (f env) (a env) (b env) (c env)
(let lp ((args args))
(if (null? args)
'()
(cons ((car args) env) (lp (cdr args)))))))))))))
(define (compile-box-ref cenv box)
(match box
((,(typecode resolve) . var-or-loc)
(lambda (env)
(cond
((variable? var-or-loc) (variable-ref var-or-loc))
(else
(set! var-or-loc
(%resolve-variable var-or-loc (env-toplevel env)))
(variable-ref var-or-loc)))))
((,(typecode resolve) . loc)
(let ((var (%resolve-variable loc (env-toplevel cenv))))
(lambda (env) (variable-ref var))))
((,(typecode lexical-ref) depth . width)
(lambda (env)
(variable-ref (env-ref env depth width))))
@ -164,13 +233,9 @@
(lambda (env)
(variable-ref (box env)))))))
(define (compile-resolve var-or-loc)
(lambda (env)
(cond
((variable? var-or-loc) var-or-loc)
(else
(set! var-or-loc (%resolve-variable var-or-loc (env-toplevel env)))
var-or-loc))))
(define (compile-resolve cenv loc)
(let ((var (%resolve-variable loc (env-toplevel cenv))))
(lambda (env) var)))
(define (compile-if test consequent alternate)
(let ((test (compile test))
@ -477,7 +542,7 @@
(let ((proc (proc env)))
(set-procedure-property! proc prop val)
proc))))))
(let ((body (compile body)))
(let ((body (lazy (env) (compile body))))
(set-procedure-meta
meta
(match tail
@ -560,10 +625,10 @@
(compile-call f args))
((,(typecode box-ref) . box)
(compile-box-ref box))
(lazy (env) (compile-box-ref env box)))
((,(typecode resolve) . var-or-loc)
(compile-resolve var-or-loc))
((,(typecode resolve) . loc)
(lazy (env) (compile-resolve env loc)))
((,(typecode if) test consequent . alternate)
(compile-if test consequent alternate))
@ -604,10 +669,10 @@
((,(typecode call/cc) . proc)
(compile-call/cc proc))))
(let ((proc (compile
(let ((eval (compile
(memoize-expression
(if (macroexpanded? exp)
exp
((module-transformer (current-module)) exp)))))
(env #f))
(proc env)))
(eval env)))