Commit | Line | Data |
---|---|---|
5161a3c0 AW |
1 | ;;; -*- mode: scheme; coding: utf-8; -*- |
2 | ||
d69531e2 | 3 | ;;;; Copyright (C) 2009, 2010 |
5161a3c0 AW |
4 | ;;;; Free Software Foundation, Inc. |
5 | ;;;; | |
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. | |
10 | ;;;; | |
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. | |
15 | ;;;; | |
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 | |
19 | ;;;; | |
20 | ||
21 | \f | |
22 | ||
23 | ;;; Commentary: | |
24 | ||
b2b554ef AW |
25 | ;;; Scheme eval, written in Scheme. |
26 | ;;; | |
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"). | |
30 | ;;; | |
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 | |
35 | ;;; current module. | |
36 | ;;; | |
37 | ;;; Evaluate this in Emacs to make code indentation work right: | |
38 | ;;; | |
39 | ;;; (put 'memoized-expression-case 'scheme-indent-function 1) | |
5161a3c0 AW |
40 | ;;; |
41 | ||
42 | ;;; Code: | |
43 | ||
44 | \f | |
45 | ||
5161a3c0 AW |
46 | (eval-when (compile) |
47 | (define-syntax capture-env | |
48 | (syntax-rules () | |
bb0c8157 AW |
49 | ((_ (exp ...)) |
50 | (let ((env (exp ...))) | |
51 | (capture-env env))) | |
5161a3c0 AW |
52 | ((_ env) |
53 | (if (null? env) | |
54 | (current-module) | |
55 | (if (not env) | |
b2b554ef AW |
56 | ;; the and current-module checks that modules are booted, |
57 | ;; and thus the-root-module is defined | |
5f161164 | 58 | (and (current-module) the-root-module) |
5161a3c0 AW |
59 | env))))) |
60 | ||
d8a071fc AW |
61 | ;; Fast case for procedures with fixed arities. |
62 | (define-syntax make-fixed-closure | |
4abb824c | 63 | (lambda (x) |
9331f91c | 64 | (define *max-static-argument-count* 8) |
4abb824c AW |
65 | (define (make-formals n) |
66 | (map (lambda (i) | |
67 | (datum->syntax | |
68 | x | |
69 | (string->symbol | |
70 | (string (integer->char (+ (char->integer #\a) i)))))) | |
71 | (iota n))) | |
72 | (syntax-case x () | |
d8a071fc | 73 | ((_ eval nreq body env) (not (identifier? #'env)) |
4abb824c | 74 | #'(let ((e env)) |
d8a071fc AW |
75 | (make-fixed-closure eval nreq body e))) |
76 | ((_ eval nreq body env) | |
4abb824c AW |
77 | #`(case nreq |
78 | #,@(map (lambda (nreq) | |
79 | (let ((formals (make-formals nreq))) | |
80 | #`((#,nreq) | |
d8a071fc AW |
81 | (lambda (#,@formals) |
82 | (eval body | |
83 | (cons* #,@(reverse formals) env)))))) | |
4abb824c AW |
84 | (iota *max-static-argument-count*)) |
85 | (else | |
86 | #,(let ((formals (make-formals *max-static-argument-count*))) | |
87 | #`(lambda (#,@formals . more) | |
88 | (let lp ((new-env (cons* #,@(reverse formals) env)) | |
89 | (nreq (- nreq #,*max-static-argument-count*)) | |
90 | (args more)) | |
91 | (if (zero? nreq) | |
92 | (eval body | |
d8a071fc AW |
93 | (if (null? args) |
94 | new-env | |
95 | (scm-error 'wrong-number-of-args | |
96 | "eval" "Wrong number of arguments" | |
97 | '() #f))) | |
4abb824c AW |
98 | (if (null? args) |
99 | (scm-error 'wrong-number-of-args | |
100 | "eval" "Wrong number of arguments" | |
101 | '() #f) | |
102 | (lp (cons (car args) new-env) | |
103 | (1- nreq) | |
104 | (cdr args))))))))))))) | |
105 | ||
9331f91c AW |
106 | (define-syntax call |
107 | (lambda (x) | |
108 | (define *max-static-call-count* 4) | |
109 | (syntax-case x () | |
110 | ((_ eval proc nargs args env) (identifier? #'env) | |
111 | #`(case nargs | |
112 | #,@(map (lambda (nargs) | |
113 | #`((#,nargs) | |
114 | (proc | |
115 | #,@(map | |
116 | (lambda (n) | |
117 | (let lp ((n n) (args #'args)) | |
118 | (if (zero? n) | |
119 | #`(eval (car #,args) env) | |
120 | (lp (1- n) #`(cdr #,args))))) | |
121 | (iota nargs))))) | |
122 | (iota *max-static-call-count*)) | |
123 | (else | |
124 | (apply proc | |
125 | #,@(map | |
126 | (lambda (n) | |
127 | (let lp ((n n) (args #'args)) | |
128 | (if (zero? n) | |
129 | #`(eval (car #,args) env) | |
130 | (lp (1- n) #`(cdr #,args))))) | |
131 | (iota *max-static-call-count*)) | |
132 | (let lp ((exps #,(let lp ((n *max-static-call-count*) | |
133 | (args #'args)) | |
134 | (if (zero? n) | |
135 | args | |
136 | (lp (1- n) #`(cdr #,args))))) | |
137 | (args '())) | |
138 | (if (null? exps) | |
139 | (reverse args) | |
140 | (lp (cdr exps) | |
141 | (cons (eval (car exps) env) args))))))))))) | |
142 | ||
b2b554ef AW |
143 | ;; This macro could be more straightforward if the compiler had better |
144 | ;; copy propagation. As it is we do some copy propagation by hand. | |
5161a3c0 AW |
145 | (define-syntax mx-bind |
146 | (lambda (x) | |
147 | (syntax-case x () | |
148 | ((_ data () body) | |
149 | #'body) | |
150 | ((_ data (a . b) body) (and (identifier? #'a) (identifier? #'b)) | |
151 | #'(let ((a (car data)) | |
152 | (b (cdr data))) | |
153 | body)) | |
154 | ((_ data (a . b) body) (identifier? #'a) | |
155 | #'(let ((a (car data)) | |
156 | (xb (cdr data))) | |
157 | (mx-bind xb b body))) | |
158 | ((_ data (a . b) body) | |
159 | #'(let ((xa (car data)) | |
160 | (xb (cdr data))) | |
161 | (mx-bind xa a (mx-bind xb b body)))) | |
162 | ((_ data v body) (identifier? #'v) | |
163 | #'(let ((v data)) | |
164 | body))))) | |
165 | ||
b2b554ef AW |
166 | ;; The resulting nested if statements will be an O(n) dispatch. Once |
167 | ;; we compile `case' effectively, this situation will improve. | |
5161a3c0 AW |
168 | (define-syntax mx-match |
169 | (lambda (x) | |
170 | (syntax-case x (quote) | |
171 | ((_ mx data tag) | |
172 | #'(error "what" mx)) | |
173 | ((_ mx data tag (('type pat) body) c* ...) | |
174 | #`(if (eqv? tag #,(or (memoized-typecode (syntax->datum #'type)) | |
175 | (error "not a typecode" #'type))) | |
176 | (mx-bind data pat body) | |
177 | (mx-match mx data tag c* ...)))))) | |
178 | ||
179 | (define-syntax memoized-expression-case | |
180 | (lambda (x) | |
181 | (syntax-case x () | |
182 | ((_ mx c ...) | |
183 | #'(let ((tag (memoized-expression-typecode mx)) | |
184 | (data (memoized-expression-data mx))) | |
185 | (mx-match mx data tag c ...))))))) | |
186 | ||
187 | ||
21ec0bd9 AW |
188 | ;;; |
189 | ;;; On 18 Feb 2010, I did a profile of how often the various memoized expression | |
190 | ;;; types occur when getting to a prompt on a fresh build. Here are the numbers | |
191 | ;;; I got: | |
192 | ;;; | |
193 | ;;; lexical-ref: 32933054 | |
194 | ;;; call: 20281547 | |
195 | ;;; toplevel-ref: 13228724 | |
196 | ;;; if: 9156156 | |
197 | ;;; quote: 6610137 | |
198 | ;;; let: 2619707 | |
199 | ;;; lambda: 1010921 | |
200 | ;;; begin: 948945 | |
201 | ;;; lexical-set: 509862 | |
202 | ;;; call-with-values: 139668 | |
203 | ;;; apply: 49402 | |
204 | ;;; module-ref: 14468 | |
205 | ;;; define: 1259 | |
206 | ;;; toplevel-set: 328 | |
207 | ;;; dynwind: 162 | |
208 | ;;; with-fluids: 0 | |
209 | ;;; call/cc: 0 | |
210 | ;;; module-set: 0 | |
211 | ;;; | |
212 | ;;; So until we compile `case' into a computed goto, we'll order the clauses in | |
213 | ;;; `eval' in this order, to put the most frequent cases first. | |
214 | ;;; | |
215 | ||
5161a3c0 AW |
216 | (define primitive-eval |
217 | (let () | |
d8a071fc AW |
218 | ;; We pre-generate procedures with fixed arities, up to some number of |
219 | ;; arguments; see make-fixed-closure above. | |
220 | ||
221 | ;; A unique marker for unbound keywords. | |
222 | (define unbound-arg (list 'unbound-arg)) | |
223 | ||
7572ee52 AW |
224 | ;; Procedures with rest, optional, or keyword arguments, potentially with |
225 | ;; multiple arities, as with case-lambda. | |
d8a071fc | 226 | (define (make-general-closure env body nreq rest? nopt kw inits alt) |
7572ee52 AW |
227 | (define alt-proc |
228 | (and alt | |
dc3e203e AW |
229 | (let* ((body (car alt)) |
230 | (nreq (cadr alt)) | |
231 | (rest (if (null? (cddr alt)) #f (caddr alt))) | |
232 | (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt))) | |
233 | (nopt (if tail (car tail) 0)) | |
234 | (kw (and tail (cadr tail))) | |
235 | (inits (if tail (caddr tail) '())) | |
236 | (alt (and tail (cadddr tail)))) | |
237 | (make-general-closure env body nreq rest nopt kw inits alt)))) | |
f3cf9421 AW |
238 | (define (set-procedure-arity! proc) |
239 | (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?)) | |
240 | (if (not alt) | |
241 | (set-procedure-minimum-arity! proc nreq nopt rest?) | |
242 | (let* ((nreq* (cadr alt)) | |
243 | (rest?* (if (null? (cddr alt)) #f (caddr alt))) | |
244 | (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt))) | |
245 | (nopt* (if tail (car tail) 0)) | |
246 | (alt* (and tail (cadddr tail)))) | |
247 | (if (or (< nreq* nreq) | |
248 | (and (= nreq* nreq) | |
249 | (if rest? | |
250 | (and rest?* (> nopt* nopt)) | |
251 | (or rest?* (> nopt* nopt))))) | |
252 | (lp alt* nreq* nopt* rest?*) | |
253 | (lp alt* nreq nopt rest?))))) | |
254 | proc) | |
255 | (set-procedure-arity! | |
256 | (lambda %args | |
257 | (let lp ((env env) | |
258 | (nreq* nreq) | |
259 | (args %args)) | |
260 | (if (> nreq* 0) | |
261 | ;; First, bind required arguments. | |
262 | (if (null? args) | |
263 | (if alt | |
264 | (apply alt-proc %args) | |
265 | (scm-error 'wrong-number-of-args | |
266 | "eval" "Wrong number of arguments" | |
267 | '() #f)) | |
268 | (lp (cons (car args) env) | |
269 | (1- nreq*) | |
270 | (cdr args))) | |
271 | ;; Move on to optional arguments. | |
272 | (if (not kw) | |
273 | ;; Without keywords, bind optionals from arguments. | |
274 | (let lp ((env env) | |
275 | (nopt nopt) | |
276 | (args args) | |
277 | (inits inits)) | |
278 | (if (zero? nopt) | |
279 | (if rest? | |
280 | (eval body (cons args env)) | |
281 | (if (null? args) | |
282 | (eval body env) | |
283 | (if alt | |
284 | (apply alt-proc %args) | |
285 | (scm-error 'wrong-number-of-args | |
286 | "eval" "Wrong number of arguments" | |
287 | '() #f)))) | |
288 | (if (null? args) | |
289 | (lp (cons (eval (car inits) env) env) | |
290 | (1- nopt) args (cdr inits)) | |
291 | (lp (cons (car args) env) | |
292 | (1- nopt) (cdr args) (cdr inits))))) | |
293 | ;; With keywords, we stop binding optionals at the first | |
294 | ;; keyword. | |
295 | (let lp ((env env) | |
296 | (nopt* nopt) | |
297 | (args args) | |
298 | (inits inits)) | |
299 | (if (> nopt* 0) | |
300 | (if (or (null? args) (keyword? (car args))) | |
301 | (lp (cons (eval (car inits) env) env) | |
302 | (1- nopt*) args (cdr inits)) | |
303 | (lp (cons (car args) env) | |
304 | (1- nopt*) (cdr args) (cdr inits))) | |
305 | ;; Finished with optionals. | |
306 | (let* ((aok (car kw)) | |
307 | (kw (cdr kw)) | |
308 | (kw-base (+ nopt nreq (if rest? 1 0))) | |
309 | (imax (let lp ((imax (1- kw-base)) (kw kw)) | |
310 | (if (null? kw) | |
311 | imax | |
312 | (lp (max (cdar kw) imax) | |
313 | (cdr kw))))) | |
314 | ;; Fill in kwargs with "undefined" vals. | |
315 | (env (let lp ((i kw-base) | |
316 | ;; Also, here we bind the rest | |
317 | ;; arg, if any. | |
318 | (env (if rest? (cons args env) env))) | |
319 | (if (<= i imax) | |
320 | (lp (1+ i) (cons unbound-arg env)) | |
321 | env)))) | |
322 | ;; Now scan args for keywords. | |
323 | (let lp ((args args)) | |
324 | (if (and (pair? args) (pair? (cdr args)) | |
325 | (keyword? (car args))) | |
326 | (let ((kw-pair (assq (car args) kw)) | |
327 | (v (cadr args))) | |
328 | (if kw-pair | |
329 | ;; Found a known keyword; set its value. | |
330 | (list-set! env (- imax (cdr kw-pair)) v) | |
331 | ;; Unknown keyword. | |
332 | (if (not aok) | |
333 | (scm-error 'keyword-argument-error | |
334 | "eval" "Unrecognized keyword" | |
335 | '() #f))) | |
336 | (lp (cddr args))) | |
337 | (if (pair? args) | |
338 | (if rest? | |
339 | ;; Be lenient parsing rest args. | |
340 | (lp (cdr args)) | |
341 | (scm-error 'keyword-argument-error | |
342 | "eval" "Invalid keyword" | |
343 | '() #f)) | |
344 | ;; Finished parsing keywords. Fill in | |
345 | ;; uninitialized kwargs by evalling init | |
346 | ;; expressions in their appropriate | |
347 | ;; environment. | |
348 | (let lp ((i (- imax kw-base)) | |
349 | (inits inits)) | |
350 | (if (pair? inits) | |
351 | (let ((tail (list-tail env i))) | |
352 | (if (eq? (car tail) unbound-arg) | |
353 | (set-car! tail | |
354 | (eval (car inits) | |
355 | (cdr tail)))) | |
356 | (lp (1- i) (cdr inits))) | |
357 | ;; Finally, eval the body. | |
358 | (eval body env))))))))))))))) | |
d8a071fc | 359 | |
b2b554ef | 360 | ;; The "engine". EXP is a memoized expression. |
5161a3c0 AW |
361 | (define (eval exp env) |
362 | (memoized-expression-case exp | |
21ec0bd9 | 363 | (('lexical-ref n) |
bb0c8157 AW |
364 | (list-ref env n)) |
365 | ||
21ec0bd9 AW |
366 | (('call (f nargs . args)) |
367 | (let ((proc (eval f env))) | |
368 | (call eval proc nargs args env))) | |
369 | ||
370 | (('toplevel-ref var-or-sym) | |
371 | (variable-ref | |
372 | (if (variable? var-or-sym) | |
373 | var-or-sym | |
bb0c8157 AW |
374 | (memoize-variable-access! exp |
375 | (capture-env (if (pair? env) | |
376 | (cdr (last-pair env)) | |
377 | env)))))) | |
21ec0bd9 | 378 | |
5161a3c0 AW |
379 | (('if (test consequent . alternate)) |
380 | (if (eval test env) | |
381 | (eval consequent env) | |
382 | (eval alternate env))) | |
383 | ||
21ec0bd9 AW |
384 | (('quote x) |
385 | x) | |
386 | ||
5161a3c0 AW |
387 | (('let (inits . body)) |
388 | (let lp ((inits inits) (new-env (capture-env env))) | |
389 | (if (null? inits) | |
390 | (eval body new-env) | |
391 | (lp (cdr inits) | |
392 | (cons (eval (car inits) env) new-env))))) | |
393 | ||
8f9c5b58 | 394 | (('lambda (body nreq . tail)) |
d8a071fc AW |
395 | (if (null? tail) |
396 | (make-fixed-closure eval nreq body (capture-env env)) | |
397 | (if (null? (cdr tail)) | |
398 | (make-general-closure (capture-env env) body nreq (car tail) | |
399 | 0 #f '() #f) | |
400 | (apply make-general-closure (capture-env env) body nreq tail)))) | |
401 | ||
21ec0bd9 AW |
402 | (('begin (first . rest)) |
403 | (let lp ((first first) (rest rest)) | |
404 | (if (null? rest) | |
405 | (eval first env) | |
406 | (begin | |
407 | (eval first env) | |
408 | (lp (car rest) (cdr rest)))))) | |
5161a3c0 AW |
409 | |
410 | (('lexical-set! (n . x)) | |
411 | (let ((val (eval x env))) | |
bb0c8157 | 412 | (list-set! env n val))) |
5161a3c0 | 413 | |
21ec0bd9 AW |
414 | (('call-with-values (producer . consumer)) |
415 | (call-with-values (eval producer env) | |
416 | (eval consumer env))) | |
417 | ||
418 | (('apply (f args)) | |
419 | (apply (eval f env) (eval args env))) | |
420 | ||
421 | (('module-ref var-or-spec) | |
5161a3c0 | 422 | (variable-ref |
21ec0bd9 AW |
423 | (if (variable? var-or-spec) |
424 | var-or-spec | |
425 | (memoize-variable-access! exp #f)))) | |
5161a3c0 | 426 | |
21ec0bd9 | 427 | (('define (name . x)) |
ee15aa46 AW |
428 | (let ((x (eval x env))) |
429 | (if (and (procedure? x) (not (procedure-property x 'name))) | |
430 | (set-procedure-property! x 'name name)) | |
adb8054c MW |
431 | (define! name x) |
432 | (if #f #f))) | |
21ec0bd9 | 433 | |
5161a3c0 AW |
434 | (('toplevel-set! (var-or-sym . x)) |
435 | (variable-set! | |
436 | (if (variable? var-or-sym) | |
437 | var-or-sym | |
bb0c8157 AW |
438 | (memoize-variable-access! exp |
439 | (capture-env (if (pair? env) | |
440 | (cdr (last-pair env)) | |
441 | env)))) | |
5161a3c0 AW |
442 | (eval x env))) |
443 | ||
21ec0bd9 AW |
444 | (('dynwind (in exp . out)) |
445 | (dynamic-wind (eval in env) | |
446 | (lambda () (eval exp env)) | |
447 | (eval out env))) | |
448 | ||
bb0229b5 AW |
449 | (('with-fluids (fluids vals . exp)) |
450 | (let* ((fluids (map (lambda (x) (eval x env)) fluids)) | |
451 | (vals (map (lambda (x) (eval x env)) vals))) | |
1371fe9b AW |
452 | (let lp ((fluids fluids) (vals vals)) |
453 | (if (null? fluids) | |
454 | (eval exp env) | |
455 | (with-fluids (((car fluids) (car vals))) | |
456 | (lp (cdr fluids) (cdr vals))))))) | |
bb0229b5 | 457 | |
747022e4 AW |
458 | (('prompt (tag exp . handler)) |
459 | (@prompt (eval tag env) | |
460 | (eval exp env) | |
461 | (eval handler env))) | |
462 | ||
21ec0bd9 AW |
463 | (('call/cc proc) |
464 | (call/cc (eval proc env))) | |
5161a3c0 AW |
465 | |
466 | (('module-set! (x . var-or-spec)) | |
467 | (variable-set! | |
468 | (if (variable? var-or-spec) | |
469 | var-or-spec | |
470 | (memoize-variable-access! exp #f)) | |
471 | (eval x env))))) | |
472 | ||
b2b554ef | 473 | ;; primitive-eval |
5161a3c0 | 474 | (lambda (exp) |
b2b554ef | 475 | "Evaluate @var{exp} in the current module." |
5161a3c0 | 476 | (eval |
a310a1d1 AW |
477 | (memoize-expression |
478 | (if (macroexpanded? exp) | |
479 | exp | |
480 | ((module-transformer (current-module)) exp))) | |
5161a3c0 | 481 | '())))) |