1 ;;; -*- mode: scheme; coding: utf-8; -*-
3 ;;;; Copyright (C) 2009, 2010
4 ;;;; Free Software Foundation, Inc.
6 ;;;; This library is free software; you can redistribute it and/or
7 ;;;; modify it under the terms of the GNU Lesser General Public
8 ;;;; License as published by the Free Software Foundation; either
9 ;;;; version 3 of the License, or (at your option) any later version.
11 ;;;; This library is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;;; Lesser General Public License for more details.
16 ;;;; You should have received a copy of the GNU Lesser General Public
17 ;;;; License along with this library; if not, write to the Free Software
18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
25 ;;; Scheme eval, written in Scheme.
27 ;;; Expressions are first expanded, by the syntax expander (i.e.
28 ;;; psyntax), then memoized into internal forms. The evaluator itself
29 ;;; only operates on the internal forms ("memoized expressions").
31 ;;; Environments are represented as linked lists of the form (VAL ... .
32 ;;; MOD). If MOD is #f, it means the environment was captured before
33 ;;; modules were booted. If MOD is the literal value '(), we are
34 ;;; evaluating at the top level, and so should track changes to the
37 ;;; Evaluate this in Emacs to make code indentation work right:
39 ;;; (put 'memoized-expression-case 'scheme-indent-function 1)
47 (define-syntax capture-env
53 ;; the and current-module checks that modules are booted,
54 ;; and thus the-root-module is defined
55 (and (current-module) the-root-module)
58 ;; Fast case for procedures with fixed arities.
59 (define-syntax make-fixed-closure
61 (define *max-static-argument-count* 8)
62 (define (make-formals n)
67 (string (integer->char (+ (char->integer #\a) i))))))
70 ((_ eval nreq body env) (not (identifier? #'env))
72 (make-fixed-closure eval nreq body e)))
73 ((_ eval nreq body env)
75 #,@(map (lambda (nreq)
76 (let ((formals (make-formals nreq)))
80 (cons* #,@(reverse formals) env))))))
81 (iota *max-static-argument-count*))
83 #,(let ((formals (make-formals *max-static-argument-count*)))
84 #`(lambda (#,@formals . more)
85 (let lp ((new-env (cons* #,@(reverse formals) env))
86 (nreq (- nreq #,*max-static-argument-count*))
92 (scm-error 'wrong-number-of-args
93 "eval" "Wrong number of arguments"
96 (scm-error 'wrong-number-of-args
97 "eval" "Wrong number of arguments"
99 (lp (cons (car args) new-env)
101 (cdr args)))))))))))))
105 (define *max-static-call-count* 4)
107 ((_ eval proc nargs args env) (identifier? #'env)
109 #,@(map (lambda (nargs)
114 (let lp ((n n) (args #'args))
116 #`(eval (car #,args) env)
117 (lp (1- n) #`(cdr #,args)))))
119 (iota *max-static-call-count*))
124 (let lp ((n n) (args #'args))
126 #`(eval (car #,args) env)
127 (lp (1- n) #`(cdr #,args)))))
128 (iota *max-static-call-count*))
129 (let lp ((exps #,(let lp ((n *max-static-call-count*)
133 (lp (1- n) #`(cdr #,args)))))
138 (cons (eval (car exps) env) args)))))))))))
140 ;; This macro could be more straightforward if the compiler had better
141 ;; copy propagation. As it is we do some copy propagation by hand.
142 (define-syntax mx-bind
147 ((_ data (a . b) body) (and (identifier? #'a) (identifier? #'b))
148 #'(let ((a (car data))
151 ((_ data (a . b) body) (identifier? #'a)
152 #'(let ((a (car data))
154 (mx-bind xb b body)))
155 ((_ data (a . b) body)
156 #'(let ((xa (car data))
158 (mx-bind xa a (mx-bind xb b body))))
159 ((_ data v body) (identifier? #'v)
163 ;; The resulting nested if statements will be an O(n) dispatch. Once
164 ;; we compile `case' effectively, this situation will improve.
165 (define-syntax mx-match
167 (syntax-case x (quote)
170 ((_ mx data tag (('type pat) body) c* ...)
171 #`(if (eqv? tag #,(or (memoized-typecode (syntax->datum #'type))
172 (error "not a typecode" #'type)))
173 (mx-bind data pat body)
174 (mx-match mx data tag c* ...))))))
176 (define-syntax memoized-expression-case
180 #'(let ((tag (memoized-expression-typecode mx))
181 (data (memoized-expression-data mx)))
182 (mx-match mx data tag c ...)))))))
186 ;;; On 18 Feb 2010, I did a profile of how often the various memoized expression
187 ;;; types occur when getting to a prompt on a fresh build. Here are the numbers
190 ;;; lexical-ref: 32933054
192 ;;; toplevel-ref: 13228724
198 ;;; lexical-set: 509862
199 ;;; call-with-values: 139668
201 ;;; module-ref: 14468
203 ;;; toplevel-set: 328
209 ;;; So until we compile `case' into a computed goto, we'll order the clauses in
210 ;;; `eval' in this order, to put the most frequent cases first.
213 (define primitive-eval
215 ;; We pre-generate procedures with fixed arities, up to some number of
216 ;; arguments; see make-fixed-closure above.
218 ;; A unique marker for unbound keywords.
219 (define unbound-arg (list 'unbound-arg))
221 ;; Procedures with rest, optional, or keyword arguments, potentially with
222 ;; multiple arities, as with case-lambda.
223 (define (make-general-closure env body nreq rest? nopt kw inits alt)
226 (apply make-general-closure env (memoized-expression-data alt))))
232 ;; First, bind required arguments.
235 (apply alt-proc %args)
236 (scm-error 'wrong-number-of-args
237 "eval" "Wrong number of arguments"
239 (lp (cons (car args) env)
242 ;; Move on to optional arguments.
244 ;; Without keywords, bind optionals from arguments.
251 (eval body (cons args env))
255 (apply alt-proc %args)
256 (scm-error 'wrong-number-of-args
257 "eval" "Wrong number of arguments"
260 (lp (cons (eval (car inits) env) env)
261 (1- nopt) args (cdr inits))
262 (lp (cons (car args) env)
263 (1- nopt) (cdr args) (cdr inits)))))
264 ;; With keywords, we stop binding optionals at the first
271 (if (or (null? args) (keyword? (car args)))
272 (lp (cons (eval (car inits) env) env)
273 (1- nopt*) args (cdr inits))
274 (lp (cons (car args) env)
275 (1- nopt*) (cdr args) (cdr inits)))
276 ;; Finished with optionals.
277 (let* ((aok (car kw))
279 (kw-base (+ nopt nreq (if rest? 1 0)))
280 (imax (let lp ((imax (1- kw-base)) (kw kw))
283 (lp (max (cdar kw) imax)
285 ;; Fill in kwargs with "undefined" vals.
286 (env (let lp ((i kw-base)
287 ;; Also, here we bind the rest
289 (env (if rest? (cons args env) env)))
291 (lp (1+ i) (cons unbound-arg env))
293 ;; Now scan args for keywords.
294 (let lp ((args args))
295 (if (and (pair? args) (pair? (cdr args))
296 (keyword? (car args)))
297 (let ((kw-pair (assq (car args) kw))
300 ;; Found a known keyword; set its value.
301 (list-set! env (- imax (cdr kw-pair)) v)
304 (scm-error 'keyword-argument-error
305 "eval" "Unrecognized keyword"
310 ;; Be lenient parsing rest args.
312 (scm-error 'keyword-argument-error
313 "eval" "Invalid keyword"
315 ;; Finished parsing keywords. Fill in
316 ;; uninitialized kwargs by evalling init
317 ;; expressions in their appropriate
319 (let lp ((i (- imax kw-base))
322 (let ((tail (list-tail env i)))
323 (if (eq? (car tail) unbound-arg)
327 (lp (1- i) (cdr inits)))
328 ;; Finally, eval the body.
329 (eval body env))))))))))))))
331 ;; The "engine". EXP is a memoized expression.
332 (define (eval exp env)
333 (memoized-expression-case exp
335 (let lp ((n n) (env env))
338 (lp (1- n) (cdr env)))))
340 (('call (f nargs . args))
341 (let ((proc (eval f env)))
342 (call eval proc nargs args env)))
344 (('toplevel-ref var-or-sym)
346 (if (variable? var-or-sym)
351 (memoize-variable-access! exp (capture-env env)))))))
353 (('if (test consequent . alternate))
355 (eval consequent env)
356 (eval alternate env)))
361 (('let (inits . body))
362 (let lp ((inits inits) (new-env (capture-env env)))
366 (cons (eval (car inits) env) new-env)))))
368 (('lambda (body nreq . tail))
370 (make-fixed-closure eval nreq body (capture-env env))
371 (if (null? (cdr tail))
372 (make-general-closure (capture-env env) body nreq (car tail)
374 (apply make-general-closure (capture-env env) body nreq tail))))
376 (('begin (first . rest))
377 (let lp ((first first) (rest rest))
382 (lp (car rest) (cdr rest))))))
384 (('lexical-set! (n . x))
385 (let ((val (eval x env)))
386 (let lp ((n n) (env env))
389 (lp (1- n) (cdr env))))))
391 (('call-with-values (producer . consumer))
392 (call-with-values (eval producer env)
393 (eval consumer env)))
396 (apply (eval f env) (eval args env)))
398 (('module-ref var-or-spec)
400 (if (variable? var-or-spec)
402 (memoize-variable-access! exp #f))))
404 (('define (name . x))
405 (define! name (eval x env)))
407 (('toplevel-set! (var-or-sym . x))
409 (if (variable? var-or-sym)
414 (memoize-variable-access! exp (capture-env env)))))
417 (('dynwind (in exp . out))
418 (dynamic-wind (eval in env)
419 (lambda () (eval exp env))
422 (('with-fluids (fluids vals . exp))
423 (let* ((fluids (map (lambda (x) (eval x env)) fluids))
424 (vals (map (lambda (x) (eval x env)) vals)))
425 (let lp ((fluids fluids) (vals vals))
428 (with-fluids (((car fluids) (car vals)))
429 (lp (cdr fluids) (cdr vals)))))))
431 (('prompt (tag exp . handler))
432 (@prompt (eval tag env)
437 (call/cc (eval proc env)))
439 (('module-set! (x . var-or-spec))
441 (if (variable? var-or-spec)
443 (memoize-variable-access! exp #f))
448 "Evaluate @var{exp} in the current module."
452 ((module-transformer (current-module)) exp))