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

Convert primitive-eval to "compile" its expressions to linked closures

Browse source 
* libguile/memoize.c (memoize): Fix meta on subsequent case-lambda
  clauses.

* module/ice-9/eval.scm (primitive-eval): Rewrite to compile expressions
  to thunks, to avoid runtime dispatch cost.
This commit is contained in:
Andy Wingo 2014-12-10 14:34:44 +01:00
parent dc33a94502
commit 95de4f52a8
2 changed files with 518 additions and 473 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/memoize.c
View file

@ -574,7 +574,7 @@ memoize (SCM exp, SCM env)
SCM_BOOL_F);
return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
SCM_BOOL_F /* meta, filled in later */);
SCM_EOL /* meta, filled in later */);
}
case SCM_EXPANDED_LET:

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

@ -27,22 +27,18 @@
;;; psyntax), then memoized into internal forms. The evaluator itself
;;; only operates on the internal forms ("memoized expressions").
;;;
;;; Environments are represented as linked lists of the form (VAL ... .
;;; MOD). If MOD is #f, it means the environment was captured before
;;; modules were booted. If MOD is the literal value '(), we are
;;; evaluating at the top level, and so should track changes to the
;;; current module.
;;;
;;; Evaluate this in Emacs to make code indentation work right:
;;;
;;; (put 'memoized-expression-case 'scheme-indent-function 1)
;;; Environments are represented as a chain of vectors, linked through
;;; their first elements. The terminal element of an environment is the
;;; module that was current when the outer lexical environment was
;;; entered.
;;;
;;; Code:
(eval-when (compile)
(define (primitive-eval exp)
"Evaluate @var{exp} in the current module."
(define-syntax env-toplevel
(syntax-rules ()
((_ env)
@ -79,366 +75,337 @@
(vector-set! e (1+ width) val)
(lp (vector-ref e 0) (1- d)))))))
;; For evaluating the initializers in a "let" expression. We have to
;; evaluate the initializers before creating the environment rib, to
;; prevent continuation-related shenanigans; see
;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time for a
;; deeper discussion.
;;
;; This macro will inline evaluation of the first N initializers.
;; That number N is indicated by the number of template arguments
;; passed to the macro. It's a bit nasty but it's flexible and
;; optimizes well.
(define-syntax let-env-evaluator
(syntax-rules ()
((eval-and-make-env eval env (template ...))
(let ()
(define-syntax eval-and-make-env
(syntax-rules ()
((eval-and-make-env inits width (template ...) k)
(let lp ((n (length '(template ...))) (vals '()))
(if (eqv? n width)
(let ((env (make-env n #f env)))
(let lp ((n (1- n)) (vals vals))
(if (null? vals)
(k env)
(begin
(env-set! env 0 n (car vals))
(lp (1- n) (cdr vals))))))
(lp (1+ n)
(cons (eval (vector-ref inits n) env) vals)))))
((eval-and-make-env inits width (var (... ...)) k)
(let ((n (length '(var (... ...)))))
(if (eqv? n width)
(k (make-env n #f env))
(let* ((x (eval (vector-ref inits n) env))
(k (lambda (env)
(env-set! env 0 n x)
(k env))))
(eval-and-make-env inits width (x var (... ...)) k)))))))
(lambda (inits)
(let ((width (vector-length inits))
(k (lambda (env) env)))
(eval-and-make-env inits width () k)))))))
;; This is a modified version of Oleg Kiselyov's "pmatch".
(define-syntax-rule (match e cs ...)
(let ((v e)) (expand-clauses v cs ...)))
;; Fast case for procedures with fixed arities.
(define-syntax make-fixed-closure
(define-syntax expand-clauses
(syntax-rules ()
((_ v) ((error "unreachable")))
((_ v (pat e0 e ...) cs ...)
(let ((fk (lambda () (expand-clauses v cs ...))))
(expand-pattern v pat (let () e0 e ...) (fk))))))
(define-syntax expand-pattern
(syntax-rules (_ quote unquote)
((_ v _ kt kf) kt)
((_ v () kt kf) (if (null? v) kt kf))
((_ v (quote lit) kt kf)
(if (equal? v (quote lit)) kt kf))
((_ v (unquote exp) kt kf)
(if (equal? v exp) kt kf))
((_ v (x . y) kt kf)
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(expand-pattern vx x (expand-pattern vy y kt kf) kf))
kf))
((_ v #f kt kf) (if (eqv? v #f) kt kf))
((_ v var kt kf) (let ((var v)) kt))))
(define-syntax typecode
(lambda (x)
(define *max-static-argument-count* 8)
(define (make-formals n)
(map (lambda (i)
(datum->syntax
x
(string->symbol
(string (integer->char (+ (char->integer #\a) i))))))
(iota n)))
(syntax-case x ()
((_ eval nreq body env) (not (identifier? #'env))
#'(let ((e env))
(make-fixed-closure eval nreq body e)))
((_ eval nreq body env)
#`(case nreq
#,@(map (lambda (nreq)
(let ((formals (make-formals nreq)))
#`((#,nreq)
(lambda (#,@formals)
(eval body
(make-env* env #,@formals))))))
(iota *max-static-argument-count*))
(else
#,(let ((formals (make-formals *max-static-argument-count*)))
#`(lambda (#,@formals . more)
(let ((env (make-env nreq #f env)))
#,@(map (lambda (formal n)
#`(env-set! env 0 #,n #,formal))
formals (iota (length formals)))
(let lp ((i #,*max-static-argument-count*)
(args more))
(cond
((= i nreq)
(eval body
((_ type)
(or (memoized-typecode (syntax->datum #'type))
(error "not a typecode" (syntax->datum #'type)))))))
(define (compile-lexical-ref depth width)
(lambda (env)
(env-ref env depth width)))
(define (compile-call f nargs args)
(let ((f (compile f)))
(match args
(() (lambda (env) ((f env))))
((a)
(let ((a (compile a)))
(lambda (env) ((f env) (a env)))))
((a b)
(let ((a (compile a))
(b (compile b)))
(lambda (env) ((f env) (a env) (b env)))))
((a b c)
(let ((a (compile a))
(b (compile b))
(c (compile c)))
(lambda (env) ((f env) (a env) (b env) (c env)))))
((a b c . args)
(let ((a (compile a))
(b (compile b))
(c (compile c))
(args (let lp ((args args))
(if (null? args)
env
'()
(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 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 lexical-ref) depth . width)
(lambda (env)
(variable-ref (env-ref env depth width))))
(_
(let ((box (compile box)))
(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-if test 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))
(define (compile-let inits body)
(let ((body (compile body))
(width (vector-length inits)))
(case width
((0) (lambda (env)
(body (make-env* env))))
((1)
(let ((a (compile (vector-ref inits 0))))
(lambda (env)
(body (make-env* env (a env))))))
((2)
(let ((a (compile (vector-ref inits 0)))
(b (compile (vector-ref inits 1))))
(lambda (env)
(body (make-env* env (a env) (b env))))))
((3)
(let ((a (compile (vector-ref inits 0)))
(b (compile (vector-ref inits 1)))
(c (compile (vector-ref inits 2))))
(lambda (env)
(body (make-env* env (a env) (b env) (c env))))))
((4)
(let ((a (compile (vector-ref inits 0)))
(b (compile (vector-ref inits 1)))
(c (compile (vector-ref inits 2)))
(d (compile (vector-ref inits 3))))
(lambda (env)
(body (make-env* env (a env) (b env) (c env) (d env))))))
(else
(let lp ((n width)
(k (lambda (env)
(make-env width #f env))))
(if (zero? n)
(lambda (env)
(body (k env)))
(lp (1- n)
(let ((init (compile (vector-ref inits (1- n)))))
(lambda (env)
(let* ((x (init env))
(new-env (k env)))
(env-set! new-env 0 (1- n) x)
new-env))))))))))
(define (compile-fixed-lambda body nreq)
(case nreq
((0) (lambda (env)
(lambda ()
(body (make-env* env)))))
((1) (lambda (env)
(lambda (a)
(body (make-env* env a)))))
((2) (lambda (env)
(lambda (a b)
(body (make-env* env a b)))))
((3) (lambda (env)
(lambda (a b c)
(body (make-env* env a b c)))))
((4) (lambda (env)
(lambda (a b c d)
(body (make-env* env a b c d)))))
((5) (lambda (env)
(lambda (a b c d e)
(body (make-env* env a b c d e)))))
((6) (lambda (env)
(lambda (a b c d e f)
(body (make-env* env a b c d e f)))))
((7) (lambda (env)
(lambda (a b c d e f g)
(body (make-env* env a b c d e f g)))))
(else
(lambda (env)
(lambda (a b c d e f g . more)
(let ((env (make-env nreq #f env)))
(env-set! env 0 0 a)
(env-set! env 0 1 b)
(env-set! env 0 2 c)
(env-set! env 0 3 d)
(env-set! env 0 4 e)
(env-set! env 0 5 f)
(env-set! env 0 6 g)
(let lp ((n 7) (args more))
(cond
((= n nreq)
(unless (null? args)
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f))))
'() #f))
(body env))
((null? args)
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f))
(else
(env-set! env 0 i (car args))
(lp (1+ i) (cdr args))))))))))))))
(env-set! env 0 n (car args))
(lp (1+ n) (cdr args)))))))))))
;; Fast case for procedures with fixed arities and a rest argument.
(define-syntax make-rest-closure
(lambda (x)
(define *max-static-argument-count* 3)
(define (make-formals n)
(map (lambda (i)
(datum->syntax
x
(string->symbol
(string (integer->char (+ (char->integer #\a) i))))))
(iota n)))
(syntax-case x ()
((_ eval nreq body env) (not (identifier? #'env))
#'(let ((e env))
(make-rest-closure eval nreq body e)))
((_ eval nreq body env)
#`(case nreq
#,@(map (lambda (nreq)
(let ((formals (make-formals nreq)))
#`((#,nreq)
(lambda (#,@formals . rest)
(eval body
(make-env* env #,@formals rest))))))
(iota *max-static-argument-count*))
(define (compile-rest-lambda body nreq rest?)
(case nreq
((0) (lambda (env)
(lambda rest
(body (make-env* env rest)))))
((1) (lambda (env)
(lambda (a . rest)
(body (make-env* env a rest)))))
((2) (lambda (env)
(lambda (a b . rest)
(body (make-env* env a b rest)))))
((3) (lambda (env)
(lambda (a b c . rest)
(body (make-env* env a b c rest)))))
(else
#,(let ((formals (make-formals *max-static-argument-count*)))
#`(lambda (#,@formals . more)
(lambda (env)
(lambda (a b c . more)
(let ((env (make-env (1+ nreq) #f env)))
#,@(map (lambda (formal n)
#`(env-set! env 0 #,n #,formal))
formals (iota (length formals)))
(let lp ((i #,*max-static-argument-count*)
(args more))
(env-set! env 0 0 a)
(env-set! env 0 1 b)
(env-set! env 0 2 c)
(let lp ((n 3) (args more))
(cond
((= i nreq)
(env-set! env 0 nreq args)
(eval body env))
((= n nreq)
(env-set! env 0 n args)
(body env))
((null? args)
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f))
(else
(env-set! env 0 i (car args))
(lp (1+ i) (cdr args))))))))))))))
(env-set! env 0 n (car args))
(lp (1+ n) (cdr args)))))))))))
(define-syntax call
(lambda (x)
(define *max-static-call-count* 4)
(syntax-case x ()
((_ eval proc nargs args env) (identifier? #'env)
#`(case nargs
#,@(map (lambda (nargs)
#`((#,nargs)
(proc
#,@(map
(lambda (n)
(let lp ((n n) (args #'args))
(if (zero? n)
#`(eval (car #,args) env)
(lp (1- n) #`(cdr #,args)))))
(iota nargs)))))
(iota *max-static-call-count*))
(else
(apply proc
#,@(map
(lambda (n)
(let lp ((n n) (args #'args))
(if (zero? n)
#`(eval (car #,args) env)
(lp (1- n) #`(cdr #,args)))))
(iota *max-static-call-count*))
(let lp ((exps #,(let lp ((n *max-static-call-count*)
(args #'args))
(if (zero? n)
args
(lp (1- n) #`(cdr #,args)))))
(args '()))
(if (null? exps)
(reverse args)
(lp (cdr exps)
(cons (eval (car exps) env) args)))))))))))
;; This macro could be more straightforward if the compiler had better
;; copy propagation. As it is we do some copy propagation by hand.
(define-syntax mx-bind
(lambda (x)
(syntax-case x ()
((_ data () body)
#'body)
((_ data (a . b) body) (and (identifier? #'a) (identifier? #'b))
#'(let ((a (car data))
(b (cdr data)))
body))
((_ data (a . b) body) (identifier? #'a)
#'(let ((a (car data))
(xb (cdr data)))
(mx-bind xb b body)))
((_ data (a . b) body)
#'(let ((xa (car data))
(xb (cdr data)))
(mx-bind xa a (mx-bind xb b body))))
((_ data v body) (identifier? #'v)
#'(let ((v data))
body)))))
;; The resulting nested if statements will be an O(n) dispatch. Once
;; we compile `case' effectively, this situation will improve.
(define-syntax mx-match
(lambda (x)
(syntax-case x (quote else)
((_ mx data tag)
#'(error "what" mx))
((_ mx data tag (else body))
#'body)
((_ mx data tag (('type pat) body) c* ...)
#`(if (eqv? tag #,(or (memoized-typecode (syntax->datum #'type))
(error "not a typecode" #'type)))
(mx-bind data pat body)
(mx-match mx data tag c* ...))))))
(define-syntax memoized-expression-case
(lambda (x)
(syntax-case x ()
((_ mx c ...)
#'(let ((tag (car mx))
(data (cdr mx)))
(mx-match mx data tag c ...)))))))
;;;
;;; On 18 Feb 2010, I did a profile of how often the various memoized expression
;;; types occur when getting to a prompt on a fresh build. Here are the numbers
;;; I got:
;;;
;;; lexical-ref: 32933054
;;; call: 20281547
;;; toplevel-ref: 13228724
;;; if: 9156156
;;; quote: 6610137
;;; let: 2619707
;;; lambda: 1010921
;;; begin: 948945
;;; lexical-set: 509862
;;; call-with-values: 139668
;;; apply: 49402
;;; module-ref: 14468
;;; define: 1259
;;; toplevel-set: 328
;;; call/cc: 0
;;; module-set: 0
;;;
;;; So until we compile `case' into a computed goto, we'll order the clauses in
;;; `eval' in this order, to put the most frequent cases first.
;;;
(define primitive-eval
(let ()
;; We pre-generate procedures with fixed arities, up to some number
;; of arguments, and some rest arities; see make-fixed-closure and
;; make-rest-closure above.
;; Procedures with rest, optional, or keyword arguments, potentially with
;; multiple arities, as with case-lambda.
(define (make-general-closure env body nreq rest? nopt kw ninits unbound
alt)
(define alt-proc
(and alt ; (body meta nreq ...)
(let* ((body (car alt))
(spec (cddr alt))
(nreq (car spec))
(rest (if (null? (cdr spec)) #f (cadr spec)))
(tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
(nopt (if tail (car tail) 0))
(kw (and tail (cadr tail)))
(ninits (if tail (caddr tail) 0))
(unbound (and tail (cadddr tail)))
(alt (and tail (car (cddddr tail)))))
(make-general-closure env body nreq rest nopt kw ninits unbound
alt))))
(define (set-procedure-arity! proc)
(let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
(if (not alt)
(begin
(set-procedure-property! proc 'arglist
(list nreq
nopt
(if kw (cdr kw) '())
(and kw (car kw))
(and rest? '_)))
(set-procedure-minimum-arity! proc nreq nopt rest?))
(let* ((spec (cddr alt))
(nreq* (car spec))
(rest?* (if (null? (cdr spec)) #f (cadr spec)))
(tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
(nopt* (if tail (car tail) 0))
(alt* (and tail (car (cddddr tail)))))
(if (or (< nreq* nreq)
(and (= nreq* nreq)
(if rest?
(and rest?* (> nopt* nopt))
(or rest?* (> nopt* nopt)))))
(lp alt* nreq* nopt* rest?*)
(lp alt* nreq nopt rest?)))))
proc)
(set-procedure-arity!
(lambda %args
(define (npositional args)
(let lp ((n 0) (args args))
(if (or (null? args)
(and (>= n nreq) (keyword? (car args))))
n
(lp (1+ n) (cdr args)))))
(let ((nargs (length %args)))
(define (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt)
(lambda (env)
(define alt (and make-alt (make-alt env)))
(lambda args
(let ((nargs (length args)))
(cond
((or (< nargs nreq)
(and (not kw) (not rest?) (> nargs (+ nreq nopt)))
(and alt kw (not rest?) (> (npositional %args) (+ nreq nopt))))
((or (< nargs nreq) (and (not rest?) (> nargs (+ nreq nopt))))
(if alt
(apply alt-proc %args)
(apply alt args)
((scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f))))
(else
(let* ((nvals (+ nreq (if rest? 1 0) ninits))
(env (make-env nvals unbound env)))
(let lp ((i 0) (args %args))
(define (bind-req args)
(let lp ((i 0) (args args))
(cond
((< i nreq)
;; Bind required arguments.
(env-set! env 0 i (car args))
(lp (1+ i) (cdr args)))
((not kw)
;; Optional args (possibly), but no keyword args.
(let lp ((i i) (args args))
(else
(bind-opt args)))))
(define (bind-opt args)
(let lp ((i nreq) (args args))
(cond
((and (< i (+ nreq nopt)) (< i nargs))
(env-set! env 0 i (car args))
(lp (1+ i) (cdr args)))
(else
(bind-rest args)))))
(define (bind-rest args)
(when rest?
(env-set! env 0 (+ nreq nopt) args))
(eval body env)))))
(else
;; Optional args. As before, but stop at the first
;; keyword.
(let lp ((i i) (args args))
(body env))
(bind-req args))))))))
(define (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt)
(define allow-other-keys? (car kw))
(define keywords (cdr kw))
(lambda (env)
(define alt (and make-alt (make-alt env)))
(lambda args
(define (npositional args)
(let lp ((n 0) (args args))
(if (or (null? args)
(and (>= n nreq) (keyword? (car args))))
n
(lp (1+ n) (cdr args)))))
(let ((nargs (length args)))
(cond
((and (< i (+ nreq nopt))
(< i nargs)
((or (< nargs nreq)
(and alt (not rest?) (> (npositional args) (+ nreq nopt))))
(if alt
(apply alt args)
((scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f))))
(else
(let* ((nvals (+ nreq (if rest? 1 0) ninits))
(env (make-env nvals unbound env)))
(define (bind-req args)
(let lp ((i 0) (args args))
(cond
((< i nreq)
;; Bind required arguments.
(env-set! env 0 i (car args))
(lp (1+ i) (cdr args)))
(else
(bind-opt args)))))
(define (bind-opt args)
(let lp ((i nreq) (args args))
(cond
((and (< i (+ nreq nopt)) (< i nargs)
(not (keyword? (car args))))
(env-set! env 0 i (car args))
(lp (1+ i) (cdr args)))
(else
(bind-rest args)))))
(define (bind-rest args)
(when rest?
(env-set! env 0 (+ nreq nopt) args))
(let ((aok (car kw))
(kw (cdr kw)))
;; Now scan args for keywords.
(bind-kw args))
(define (bind-kw args)
(let lp ((args args))
(cond
((and (pair? args) (pair? (cdr args))
(keyword? (car args)))
(let ((kw-pair (assq (car args) kw))
(let ((kw-pair (assq (car args) keywords))
(v (cadr args)))
(if kw-pair
;; Found a known keyword; set its value.
(env-set! env 0 (cdr kw-pair) v)
;; Unknown keyword.
(if (not aok)
(if (not allow-other-keys?)
((scm-error
'keyword-argument-error
"eval" "Unrecognized keyword"
@ -452,115 +419,193 @@
"eval" "Invalid keyword"
'() (list (car args))))))
(else
;; Finally, eval the body.
(eval body env))))))))))))))))))
(body env)))))
(bind-req args))))))))
;; The "engine". EXP is a memoized expression.
(define (eval exp env)
(memoized-expression-case exp
(('lexical-ref (depth . width))
(env-ref env depth width))
(define (compute-arity alt nreq rest? nopt kw)
(let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
(if (not alt)
(let ((arglist (list nreq
nopt
(if kw (cdr kw) '())
(and kw (car kw))
(and rest? '_))))
(values arglist nreq nopt rest?))
(let* ((spec (cddr alt))
(nreq* (car spec))
(rest?* (if (null? (cdr spec)) #f (cadr spec)))
(tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
(nopt* (if tail (car tail) 0))
(alt* (and tail (car (cddddr tail)))))
(if (or (< nreq* nreq)
(and (= nreq* nreq)
(if rest?
(and rest?* (> nopt* nopt))
(or rest?* (> nopt* nopt)))))
(lp alt* nreq* nopt* rest?*)
(lp alt* nreq nopt rest?))))))
(('call (f nargs . args))
(let ((proc (eval f env)))
(call eval proc nargs args env)))
(define (compile-general-lambda body nreq rest? nopt kw ninits unbound alt)
(call-with-values
(lambda ()
(compute-arity alt nreq rest? nopt kw))
(lambda (arglist min-nreq min-nopt min-rest?)
(define make-alt
(match alt
(#f #f)
((body meta nreq . tail)
(compile-lambda body meta nreq tail))))
(define make-closure
(if kw
(compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt)
(compile-opt-lambda body nreq rest? nopt ninits unbound make-alt)))
(lambda (env)
(let ((proc (make-closure env)))
(set-procedure-property! proc 'arglist arglist)
(set-procedure-minimum-arity! proc min-nreq min-nopt min-rest?)
proc)))))
(('box-ref box)
(memoized-expression-case box
;; Accelerate common cases.
(('resolve var-or-loc)
(if (variable? var-or-loc)
(variable-ref var-or-loc)
(variable-ref (eval box env))))
(('lexical-ref (depth . width))
(variable-ref (env-ref env depth width)))
(else
(variable-ref (eval box env)))))
(define (compile-lambda body meta nreq tail)
(define (set-procedure-meta meta proc)
(match meta
(() proc)
(((prop . val) . meta)
(set-procedure-meta meta
(lambda (env)
(let ((proc (proc env)))
(set-procedure-property! proc prop val)
proc))))))
(let ((body (compile body)))
(set-procedure-meta
meta
(match tail
(() (compile-fixed-lambda body nreq))
((rest? . tail)
(match tail
(() (compile-rest-lambda body nreq rest?))
((nopt kw ninits unbound alt)
(compile-general-lambda body nreq rest? nopt kw
ninits unbound alt))))))))
(('resolve var-or-loc)
(if (variable? var-or-loc)
var-or-loc
(let ((var (%resolve-variable var-or-loc (env-toplevel env))))
(set-cdr! exp var)
var)))
(('if (test consequent . alternate))
(if (eval test env)
(eval consequent env)
(eval alternate env)))
(('quote x)
x)
(('let (inits . body))
(eval body ((let-env-evaluator eval env (_ _ _ _)) inits)))
(('lambda (body meta nreq . tail))
(let ((proc
(if (null? tail)
(make-fixed-closure eval nreq body env)
(mx-bind
tail (rest? . tail)
(if (null? tail)
(make-rest-closure eval nreq body env)
(mx-bind
tail (nopt kw ninits unbound alt)
(make-general-closure env body nreq rest?
nopt kw ninits unbound
alt)))))))
(let lp ((meta meta))
(unless (null? meta)
(set-procedure-property! proc (caar meta) (cdar meta))
(lp (cdr meta))))
proc))
(('capture-env (locs . body))
(define (compile-capture-env locs body)
(let ((body (compile body)))
(lambda (env)
(let* ((len (vector-length locs))
(new-env (make-env len #f (env-toplevel env))))
(let lp ((n 0))
(when (< n len)
(mx-bind
(vector-ref locs n) (depth . width)
(env-set! new-env 0 n (env-ref env depth width)))
(match (vector-ref locs n)
((depth . width)
(env-set! new-env 0 n (env-ref env depth width))))
(lp (1+ n))))
(eval body new-env)))
(body new-env)))))
(('seq (head . tail))
(begin
(eval head env)
(eval tail env)))
(define (compile-seq head tail)
(let ((head (compile head))
(tail (compile tail)))
(lambda (env)
(head env)
(tail env))))
(('box-set! (box . val))
(variable-set! (eval box env) (eval val env)))
(define (compile-box-set! box val)
(let ((box (compile box))
(val (compile val)))
(lambda (env)
(let ((val (val env)))
(variable-set! (box env) val)))))
(('lexical-set! ((depth . width) . x))
(env-set! env depth width (eval x env)))
(define (compile-lexical-set! depth width x)
(let ((x (compile x)))
(lambda (env)
(env-set! env depth width (x env)))))
(('call-with-values (producer . consumer))
(call-with-values (eval producer env)
(eval consumer env)))
(define (compile-call-with-values producer consumer)
(let ((producer (compile producer))
(consumer (compile consumer)))
(lambda (env)
(call-with-values (producer env)
(consumer env)))))
(('apply (f args))
(apply (eval f env) (eval args env)))
(define (compile-apply f args)
(let ((f (compile f))
(args (compile args)))
(lambda (env)
(apply (f env) (args env)))))
(('capture-module x)
(eval x (current-module)))
(define (compile-capture-module x)
(let ((x (compile x)))
(lambda (env)
(x (current-module)))))
(('call-with-prompt (tag thunk . handler))
(call-with-prompt
(eval tag env)
(eval thunk env)
(eval handler env)))
(define (compile-call-with-prompt tag thunk handler)
(let ((tag (compile tag))
(thunk (compile thunk))
(handler (compile handler)))
(lambda (env)
(call-with-prompt (tag env) (thunk env) (handler env)))))
(('call/cc proc)
(call/cc (eval proc env)))))
(define (compile-call/cc proc)
(let ((proc (compile proc)))
(lambda (env)
(call/cc (proc env)))))
;; primitive-eval
(lambda (exp)
"Evaluate @var{exp} in the current module."
(eval
(define (compile exp)
(match exp
((,(typecode lexical-ref) depth . width)
(compile-lexical-ref depth width))
((,(typecode call) f nargs . args)
(compile-call f nargs args))
((,(typecode box-ref) . box)
(compile-box-ref box))
((,(typecode resolve) . var-or-loc)
(compile-resolve var-or-loc))
((,(typecode if) test consequent . alternate)
(compile-if test consequent alternate))
((,(typecode quote) . x)
(compile-quote x))
((,(typecode let) inits . body)
(compile-let inits body))
((,(typecode lambda) body meta nreq . tail)
(compile-lambda body meta nreq tail))
((,(typecode capture-env) locs . body)
(compile-capture-env locs body))
((,(typecode seq) head . tail)
(compile-seq head tail))
((,(typecode box-set!) box . val)
(compile-box-set! box val))
((,(typecode lexical-set!) (depth . width) . x)
(compile-lexical-set! depth width x))
((,(typecode call-with-values) producer . consumer)
(compile-call-with-values producer consumer))
((,(typecode apply) f args)
(compile-apply f args))
((,(typecode capture-module) . x)
(compile-capture-module x))
((,(typecode call-with-prompt) tag thunk . handler)
(compile-call-with-prompt tag thunk handler))
((,(typecode call/cc) . proc)
(compile-call/cc proc))))
(let ((proc (compile
(memoize-expression
(if (macroexpanded? exp)
exp
((module-transformer (current-module)) exp)))
#f))))
((module-transformer (current-module)) exp)))))
(env #f))
(proc env)))