| 1 | ;;; -*- mode: scheme; coding: utf-8; -*- |
| 2 | |
| 3 | ;;;; Copyright (C) 2009, 2010 |
| 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 | |
| 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) |
| 40 | ;;; |
| 41 | |
| 42 | ;;; Code: |
| 43 | |
| 44 | \f |
| 45 | |
| 46 | (eval-when (compile) |
| 47 | (define-syntax capture-env |
| 48 | (syntax-rules () |
| 49 | ((_ (exp ...)) |
| 50 | (let ((env (exp ...))) |
| 51 | (capture-env env))) |
| 52 | ((_ env) |
| 53 | (if (null? env) |
| 54 | (current-module) |
| 55 | (if (not env) |
| 56 | ;; the and current-module checks that modules are booted, |
| 57 | ;; and thus the-root-module is defined |
| 58 | (and (current-module) the-root-module) |
| 59 | env))))) |
| 60 | |
| 61 | ;; Fast case for procedures with fixed arities. |
| 62 | (define-syntax make-fixed-closure |
| 63 | (lambda (x) |
| 64 | (define *max-static-argument-count* 8) |
| 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 () |
| 73 | ((_ eval nreq body env) (not (identifier? #'env)) |
| 74 | #'(let ((e env)) |
| 75 | (make-fixed-closure eval nreq body e))) |
| 76 | ((_ eval nreq body env) |
| 77 | #`(case nreq |
| 78 | #,@(map (lambda (nreq) |
| 79 | (let ((formals (make-formals nreq))) |
| 80 | #`((#,nreq) |
| 81 | (lambda (#,@formals) |
| 82 | (eval body |
| 83 | (cons* #,@(reverse formals) env)))))) |
| 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 |
| 93 | (if (null? args) |
| 94 | new-env |
| 95 | (scm-error 'wrong-number-of-args |
| 96 | "eval" "Wrong number of arguments" |
| 97 | '() #f))) |
| 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 | |
| 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 | |
| 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. |
| 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 | |
| 166 | ;; The resulting nested if statements will be an O(n) dispatch. Once |
| 167 | ;; we compile `case' effectively, this situation will improve. |
| 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 | |
| 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 | |
| 216 | (define primitive-eval |
| 217 | (let () |
| 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 | |
| 224 | ;; Procedures with rest, optional, or keyword arguments, potentially with |
| 225 | ;; multiple arities, as with case-lambda. |
| 226 | (define (make-general-closure env body nreq rest? nopt kw inits alt) |
| 227 | (define alt-proc |
| 228 | (and alt |
| 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)))) |
| 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))))))))))))))) |
| 359 | |
| 360 | ;; The "engine". EXP is a memoized expression. |
| 361 | (define (eval exp env) |
| 362 | (memoized-expression-case exp |
| 363 | (('lexical-ref n) |
| 364 | (list-ref env n)) |
| 365 | |
| 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 |
| 374 | (memoize-variable-access! exp |
| 375 | (capture-env (if (pair? env) |
| 376 | (cdr (last-pair env)) |
| 377 | env)))))) |
| 378 | |
| 379 | (('if (test consequent . alternate)) |
| 380 | (if (eval test env) |
| 381 | (eval consequent env) |
| 382 | (eval alternate env))) |
| 383 | |
| 384 | (('quote x) |
| 385 | x) |
| 386 | |
| 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 | |
| 394 | (('lambda (body nreq . tail)) |
| 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 | |
| 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)))))) |
| 409 | |
| 410 | (('lexical-set! (n . x)) |
| 411 | (let ((val (eval x env))) |
| 412 | (list-set! env n val))) |
| 413 | |
| 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) |
| 422 | (variable-ref |
| 423 | (if (variable? var-or-spec) |
| 424 | var-or-spec |
| 425 | (memoize-variable-access! exp #f)))) |
| 426 | |
| 427 | (('define (name . x)) |
| 428 | (let ((x (eval x env))) |
| 429 | (if (and (procedure? x) (not (procedure-property x 'name))) |
| 430 | (set-procedure-property! x 'name name)) |
| 431 | (define! name x) |
| 432 | (if #f #f))) |
| 433 | |
| 434 | (('toplevel-set! (var-or-sym . x)) |
| 435 | (variable-set! |
| 436 | (if (variable? var-or-sym) |
| 437 | var-or-sym |
| 438 | (memoize-variable-access! exp |
| 439 | (capture-env (if (pair? env) |
| 440 | (cdr (last-pair env)) |
| 441 | env)))) |
| 442 | (eval x env))) |
| 443 | |
| 444 | (('dynwind (in exp . out)) |
| 445 | (dynamic-wind (eval in env) |
| 446 | (lambda () (eval exp env)) |
| 447 | (eval out env))) |
| 448 | |
| 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))) |
| 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))))))) |
| 457 | |
| 458 | (('prompt (tag exp . handler)) |
| 459 | (@prompt (eval tag env) |
| 460 | (eval exp env) |
| 461 | (eval handler env))) |
| 462 | |
| 463 | (('call/cc proc) |
| 464 | (call/cc (eval proc env))) |
| 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 | |
| 473 | ;; primitive-eval |
| 474 | (lambda (exp) |
| 475 | "Evaluate @var{exp} in the current module." |
| 476 | (eval |
| 477 | (memoize-expression |
| 478 | (if (macroexpanded? exp) |
| 479 | exp |
| 480 | ((module-transformer (current-module)) exp))) |
| 481 | '())))) |