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 (define-syntax make-closure
60 (define *max-static-argument-count* 8)
61 (define (make-formals n)
66 (string (integer->char (+ (char->integer #\a) i))))))
69 ((_ eval nreq rest? body env) (not (identifier? #'env))
71 (make-closure eval nreq rest? body e)))
72 ((_ eval nreq rest? body env)
74 #,@(map (lambda (nreq)
75 (let ((formals (make-formals nreq)))
78 (lambda (#,@formals . rest)
80 (cons* rest #,@(reverse formals)
84 (cons* #,@(reverse formals) env)))))))
85 (iota *max-static-argument-count*))
87 #,(let ((formals (make-formals *max-static-argument-count*)))
88 #`(lambda (#,@formals . more)
89 (let lp ((new-env (cons* #,@(reverse formals) env))
90 (nreq (- nreq #,*max-static-argument-count*))
96 (if (not (null? args))
97 (scm-error 'wrong-number-of-args
98 "eval" "Wrong number of arguments"
102 (scm-error 'wrong-number-of-args
103 "eval" "Wrong number of arguments"
105 (lp (cons (car args) new-env)
107 (cdr args)))))))))))))
111 (define *max-static-call-count* 4)
113 ((_ eval proc nargs args env) (identifier? #'env)
115 #,@(map (lambda (nargs)
120 (let lp ((n n) (args #'args))
122 #`(eval (car #,args) env)
123 (lp (1- n) #`(cdr #,args)))))
125 (iota *max-static-call-count*))
130 (let lp ((n n) (args #'args))
132 #`(eval (car #,args) env)
133 (lp (1- n) #`(cdr #,args)))))
134 (iota *max-static-call-count*))
135 (let lp ((exps #,(let lp ((n *max-static-call-count*)
139 (lp (1- n) #`(cdr #,args)))))
144 (cons (eval (car exps) env) args)))))))))))
146 ;; This macro could be more straightforward if the compiler had better
147 ;; copy propagation. As it is we do some copy propagation by hand.
148 (define-syntax mx-bind
153 ((_ data (a . b) body) (and (identifier? #'a) (identifier? #'b))
154 #'(let ((a (car data))
157 ((_ data (a . b) body) (identifier? #'a)
158 #'(let ((a (car data))
160 (mx-bind xb b body)))
161 ((_ data (a . b) body)
162 #'(let ((xa (car data))
164 (mx-bind xa a (mx-bind xb b body))))
165 ((_ data v body) (identifier? #'v)
169 ;; The resulting nested if statements will be an O(n) dispatch. Once
170 ;; we compile `case' effectively, this situation will improve.
171 (define-syntax mx-match
173 (syntax-case x (quote)
176 ((_ mx data tag (('type pat) body) c* ...)
177 #`(if (eqv? tag #,(or (memoized-typecode (syntax->datum #'type))
178 (error "not a typecode" #'type)))
179 (mx-bind data pat body)
180 (mx-match mx data tag c* ...))))))
182 (define-syntax memoized-expression-case
186 #'(let ((tag (memoized-expression-typecode mx))
187 (data (memoized-expression-data mx)))
188 (mx-match mx data tag c ...)))))))
192 ;;; On 18 Feb 2010, I did a profile of how often the various memoized expression
193 ;;; types occur when getting to a prompt on a fresh build. Here are the numbers
196 ;;; lexical-ref: 32933054
198 ;;; toplevel-ref: 13228724
204 ;;; lexical-set: 509862
205 ;;; call-with-values: 139668
207 ;;; module-ref: 14468
209 ;;; toplevel-set: 328
215 ;;; So until we compile `case' into a computed goto, we'll order the clauses in
216 ;;; `eval' in this order, to put the most frequent cases first.
219 (define primitive-eval
221 ;; The "engine". EXP is a memoized expression.
222 (define (eval exp env)
223 (memoized-expression-case exp
225 (let lp ((n n) (env env))
228 (lp (1- n) (cdr env)))))
230 (('call (f nargs . args))
231 (let ((proc (eval f env)))
232 (call eval proc nargs args env)))
234 (('toplevel-ref var-or-sym)
236 (if (variable? var-or-sym)
241 (memoize-variable-access! exp (capture-env env)))))))
243 (('if (test consequent . alternate))
245 (eval consequent env)
246 (eval alternate env)))
251 (('let (inits . body))
252 (let lp ((inits inits) (new-env (capture-env env)))
256 (cons (eval (car inits) env) new-env)))))
258 (('lambda (nreq rest? . body))
259 (make-closure eval nreq rest? body (capture-env env)))
261 (('begin (first . rest))
262 (let lp ((first first) (rest rest))
267 (lp (car rest) (cdr rest))))))
269 (('lexical-set! (n . x))
270 (let ((val (eval x env)))
271 (let lp ((n n) (env env))
274 (lp (1- n) (cdr env))))))
276 (('call-with-values (producer . consumer))
277 (call-with-values (eval producer env)
278 (eval consumer env)))
281 (apply (eval f env) (eval args env)))
283 (('module-ref var-or-spec)
285 (if (variable? var-or-spec)
287 (memoize-variable-access! exp #f))))
289 (('define (name . x))
290 (define! name (eval x env)))
292 (('toplevel-set! (var-or-sym . x))
294 (if (variable? var-or-sym)
299 (memoize-variable-access! exp (capture-env env)))))
302 (('dynwind (in exp . out))
303 (dynamic-wind (eval in env)
304 (lambda () (eval exp env))
307 (('with-fluids (fluids vals . exp))
308 (let* ((fluids (map (lambda (x) (eval x env)) fluids))
309 (vals (map (lambda (x) (eval x env)) vals)))
310 (let lp ((fluids fluids) (vals vals))
313 (with-fluids (((car fluids) (car vals)))
314 (lp (cdr fluids) (cdr vals)))))))
316 (('prompt (tag exp . handler))
317 (@prompt (eval tag env)
322 (call/cc (eval proc env)))
324 (('module-set! (x . var-or-spec))
326 (if (variable? var-or-spec)
328 (memoize-variable-access! exp #f))
333 "Evaluate @var{exp} in the current module."
335 (memoize-expression ((or (module-transformer (current-module))