module/ice-9/eval.scm

   1 ;;; -*- mode: scheme; coding: utf-8; -*-
   2
   3 ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18 ;;;;
  19
  20 \f
  21
  22 ;;; Commentary:
  23
  24 ;;; Scheme eval, written in Scheme.
  25 ;;;
  26 ;;; Expressions are first expanded, by the syntax expander (i.e.
  27 ;;; psyntax), then memoized into internal forms. The evaluator itself
  28 ;;; only operates on the internal forms ("memoized expressions").
  29 ;;;
  30 ;;; Environments are represented as linked lists of the form (VAL ... .
  31 ;;; MOD). If MOD is #f, it means the environment was captured before
  32 ;;; modules were booted. If MOD is the literal value '(), we are
  33 ;;; evaluating at the top level, and so should track changes to the
  34 ;;; current module.
  35 ;;;
  36 ;;; Evaluate this in Emacs to make code indentation work right:
  37 ;;;
  38 ;;;    (put 'memoized-expression-case 'scheme-indent-function 1)
  39 ;;;
  40
  41 ;;; Code:
  42
  43 \f
  44
  45 (eval-when (compile)
  46   (define-syntax capture-env
  47     (syntax-rules ()
  48       ((_ (exp ...))
  49        (let ((env (exp ...)))
  50          (capture-env env)))
  51       ((_ env)
  52        (if (null? env)
  53            (current-module)
  54            (if (not env)
  55                ;; the and current-module checks that modules are booted,
  56                ;; and thus the-root-module is defined
  57                (and (current-module) the-root-module)
  58                env)))))
  59
  60   (define-syntax env-toplevel
  61     (syntax-rules ()
  62       ((_ env)
  63        (let lp ((e env))
  64          (if (vector? e)
  65              (lp (vector-ref e 0))
  66              e)))))
  67
  68   (define-syntax make-env
  69     (syntax-rules ()
  70       ((_ n init next)
  71        (let ((v (make-vector (1+ n) init)))
  72          (vector-set! v 0 next)
  73          v))))
  74
  75   (define-syntax make-env*
  76     (syntax-rules ()
  77       ((_ next init ...)
  78        (vector next init ...))))
  79
  80   (define-syntax env-ref
  81     (syntax-rules ()
  82       ((_ env depth width)
  83        (let lp ((e env) (d depth))
  84          (if (zero? d)
  85              (vector-ref e (1+ width))
  86              (lp (vector-ref e 0) (1- d)))))))
  87
  88   (define-syntax env-set!
  89     (syntax-rules ()
  90       ((_ env depth width val)
  91        (let lp ((e env) (d depth))
  92          (if (zero? d)
  93              (vector-set! e (1+ width) val)
  94              (lp (vector-ref e 0) (1- d)))))))
  95
  96   ;; Fast case for procedures with fixed arities.
  97   (define-syntax make-fixed-closure
  98     (lambda (x)
  99       (define *max-static-argument-count* 8)
 100       (define (make-formals n)
 101         (map (lambda (i)
 102                (datum->syntax
 103                 x
 104                 (string->symbol
 105                  (string (integer->char (+ (char->integer #\a) i))))))
 106              (iota n)))
 107       (syntax-case x ()
 108         ((_ eval nreq body env) (not (identifier? #'env))
 109          #'(let ((e env))
 110              (make-fixed-closure eval nreq body e)))
 111         ((_ eval nreq body env)
 112          #`(case nreq
 113              #,@(map (lambda (nreq)
 114                        (let ((formals (make-formals nreq)))
 115                          #`((#,nreq)
 116                             (lambda (#,@formals)
 117                               (eval body
 118                                     (make-env* env #,@formals))))))
 119                      (iota *max-static-argument-count*))
 120              (else
 121               #,(let ((formals (make-formals *max-static-argument-count*)))
 122                   #`(lambda (#,@formals . more)
 123                       (let ((env (make-env nreq #f env)))
 124                         #,@(map (lambda (formal n)
 125                                   #`(env-set! env 0 #,n #,formal))
 126                                 formals (iota (length formals)))
 127                         (let lp ((i #,*max-static-argument-count*)
 128                                  (args more))
 129                           (cond
 130                            ((= i nreq)
 131                             (eval body
 132                                   (if (null? args)
 133                                       env
 134                                       (scm-error 'wrong-number-of-args
 135                                                  "eval" "Wrong number of arguments"
 136                                                  '() #f))))
 137                            ((null? args)
 138                             (scm-error 'wrong-number-of-args
 139                                        "eval" "Wrong number of arguments"
 140                                        '() #f))
 141                            (else
 142                             (env-set! env 0 i (car args))
 143                             (lp (1+ i) (cdr args))))))))))))))
 144
 145   ;; Fast case for procedures with fixed arities and a rest argument.
 146   (define-syntax make-rest-closure
 147     (lambda (x)
 148       (define *max-static-argument-count* 3)
 149       (define (make-formals n)
 150         (map (lambda (i)
 151                (datum->syntax
 152                 x
 153                 (string->symbol
 154                  (string (integer->char (+ (char->integer #\a) i))))))
 155              (iota n)))
 156       (syntax-case x ()
 157         ((_ eval nreq body env) (not (identifier? #'env))
 158          #'(let ((e env))
 159              (make-rest-closure eval nreq body e)))
 160         ((_ eval nreq body env)
 161          #`(case nreq
 162              #,@(map (lambda (nreq)
 163                        (let ((formals (make-formals nreq)))
 164                          #`((#,nreq)
 165                             (lambda (#,@formals . rest)
 166                               (eval body
 167                                     (make-env* env #,@formals rest))))))
 168                      (iota *max-static-argument-count*))
 169              (else
 170               #,(let ((formals (make-formals *max-static-argument-count*)))
 171                   #`(lambda (#,@formals . more)
 172                       (let ((env (make-env (1+ nreq) #f env)))
 173                         #,@(map (lambda (formal n)
 174                                   #`(env-set! env 0 #,n #,formal))
 175                                 formals (iota (length formals)))
 176                         (let lp ((i #,*max-static-argument-count*)
 177                                  (args more))
 178                           (cond
 179                            ((= i nreq)
 180                             (env-set! env 0 nreq args)
 181                             (eval body env))
 182                            ((null? args)
 183                             (scm-error 'wrong-number-of-args
 184                                        "eval" "Wrong number of arguments"
 185                                        '() #f))
 186                            (else
 187                             (env-set! env 0 i (car args))
 188                             (lp (1+ i) (cdr args))))))))))))))
 189
 190   (define-syntax call
 191     (lambda (x)
 192       (define *max-static-call-count* 4)
 193       (syntax-case x ()
 194         ((_ eval proc nargs args env) (identifier? #'env)
 195          #`(case nargs
 196              #,@(map (lambda (nargs)
 197                        #`((#,nargs)
 198                           (proc
 199                            #,@(map
 200                                (lambda (n)
 201                                  (let lp ((n n) (args #'args))
 202                                    (if (zero? n)
 203                                        #`(eval (car #,args) env)
 204                                        (lp (1- n) #`(cdr #,args)))))
 205                                (iota nargs)))))
 206                      (iota *max-static-call-count*))
 207              (else
 208               (apply proc
 209                      #,@(map
 210                          (lambda (n)
 211                            (let lp ((n n) (args #'args))
 212                              (if (zero? n)
 213                                  #`(eval (car #,args) env)
 214                                  (lp (1- n) #`(cdr #,args)))))
 215                          (iota *max-static-call-count*))
 216                      (let lp ((exps #,(let lp ((n *max-static-call-count*)
 217                                                (args #'args))
 218                                         (if (zero? n)
 219                                             args
 220                                             (lp (1- n) #`(cdr #,args)))))
 221                               (args '()))
 222                        (if (null? exps)
 223                            (reverse args)
 224                            (lp (cdr exps)
 225                                (cons (eval (car exps) env) args)))))))))))
 226
 227   ;; This macro could be more straightforward if the compiler had better
 228   ;; copy propagation. As it is we do some copy propagation by hand.
 229   (define-syntax mx-bind
 230     (lambda (x)
 231       (syntax-case x ()
 232         ((_ data () body)
 233          #'body)
 234         ((_ data (a . b) body) (and (identifier? #'a) (identifier? #'b))
 235          #'(let ((a (car data))
 236                  (b (cdr data)))
 237              body))
 238         ((_ data (a . b) body) (identifier? #'a)
 239          #'(let ((a (car data))
 240                  (xb (cdr data)))
 241              (mx-bind xb b body)))
 242         ((_ data (a . b) body)
 243          #'(let ((xa (car data))
 244                  (xb (cdr data)))
 245              (mx-bind xa a (mx-bind xb b body))))
 246         ((_ data v body) (identifier? #'v)
 247          #'(let ((v data))
 248              body)))))
 249
 250   ;; The resulting nested if statements will be an O(n) dispatch. Once
 251   ;; we compile `case' effectively, this situation will improve.
 252   (define-syntax mx-match
 253     (lambda (x)
 254       (syntax-case x (quote)
 255         ((_ mx data tag)
 256          #'(error "what" mx))
 257         ((_ mx data tag (('type pat) body) c* ...)
 258          #`(if (eqv? tag #,(or (memoized-typecode (syntax->datum #'type))
 259                                (error "not a typecode" #'type)))
 260                (mx-bind data pat body)
 261                (mx-match mx data tag c* ...))))))
 262
 263   (define-syntax memoized-expression-case
 264     (lambda (x)
 265       (syntax-case x ()
 266         ((_ mx c ...)
 267          #'(let ((tag (memoized-expression-typecode mx))
 268                  (data (memoized-expression-data mx)))
 269              (mx-match mx data tag c ...)))))))
 270
 271
 272 ;;;
 273 ;;; On 18 Feb 2010, I did a profile of how often the various memoized expression
 274 ;;; types occur when getting to a prompt on a fresh build. Here are the numbers
 275 ;;; I got:
 276 ;;;
 277 ;;;      lexical-ref: 32933054
 278 ;;;             call: 20281547
 279 ;;;     toplevel-ref: 13228724
 280 ;;;               if: 9156156
 281 ;;;            quote: 6610137
 282 ;;;              let: 2619707
 283 ;;;           lambda: 1010921
 284 ;;;            begin: 948945
 285 ;;;      lexical-set: 509862
 286 ;;; call-with-values: 139668
 287 ;;;            apply: 49402
 288 ;;;       module-ref: 14468
 289 ;;;           define: 1259
 290 ;;;     toplevel-set: 328
 291 ;;;          call/cc: 0
 292 ;;;       module-set: 0
 293 ;;;
 294 ;;; So until we compile `case' into a computed goto, we'll order the clauses in
 295 ;;; `eval' in this order, to put the most frequent cases first.
 296 ;;;
 297
 298 (define primitive-eval
 299   (let ()
 300     ;; We pre-generate procedures with fixed arities, up to some number
 301     ;; of arguments, and some rest arities; see make-fixed-closure and
 302     ;; make-rest-closure above.
 303
 304     ;; A unique marker for unbound keywords.
 305     (define unbound-arg (list 'unbound-arg))
 306
 307     ;; Procedures with rest, optional, or keyword arguments, potentially with
 308     ;; multiple arities, as with case-lambda.
 309     (define (make-general-closure env body nreq rest? nopt kw inits alt)
 310       (define alt-proc
 311         (and alt                        ; (body docstring nreq ...)
 312              (let* ((body (car alt))
 313                     (spec (cddr alt))
 314                     (nreq (car spec))
 315                     (rest (if (null? (cdr spec)) #f (cadr spec)))
 316                     (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
 317                     (nopt (if tail (car tail) 0))
 318                     (kw (and tail (cadr tail)))
 319                     (inits (if tail (caddr tail) '()))
 320                     (alt (and tail (cadddr tail))))
 321                (make-general-closure env body nreq rest nopt kw inits alt))))
 322       (define (set-procedure-arity! proc)
 323         (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
 324           (if (not alt)
 325               (begin
 326                 (set-procedure-property! proc 'arglist
 327                                          (list nreq
 328                                                nopt
 329                                                (if kw (cdr kw) '())
 330                                                (and kw (car kw))
 331                                                (and rest? '_)))
 332                 (set-procedure-minimum-arity! proc nreq nopt rest?))
 333               (let* ((spec (cddr alt))
 334                      (nreq* (car spec))
 335                      (rest?* (if (null? (cdr spec)) #f (cadr spec)))
 336                      (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
 337                      (nopt* (if tail (car tail) 0))
 338                      (alt* (and tail (cadddr tail))))
 339                 (if (or (< nreq* nreq)
 340                         (and (= nreq* nreq)
 341                              (if rest?
 342                                  (and rest?* (> nopt* nopt))
 343                                  (or rest?* (> nopt* nopt)))))
 344                     (lp alt* nreq* nopt* rest?*)
 345                     (lp alt* nreq nopt rest?)))))
 346         proc)
 347       (set-procedure-arity!
 348        (lambda %args
 349          (define (npositional args)
 350            (let lp ((n 0) (args args))
 351              (if (or (null? args)
 352                      (and (>= n nreq) (keyword? (car args))))
 353                  n
 354                  (lp (1+ n) (cdr args)))))
 355          (let ((nargs (length %args)))
 356            (cond
 357             ((or (< nargs nreq)
 358                  (and (not kw) (not rest?) (> nargs (+ nreq nopt)))
 359                  (and kw (not rest?) (> (npositional %args) (+ nreq nopt))))
 360              (if alt
 361                  (apply alt-proc %args)
 362                  ((scm-error 'wrong-number-of-args
 363                              "eval" "Wrong number of arguments"
 364                              '() #f))))
 365             (else
 366              (let* ((nvals (+ nreq (if rest? 1 0) (length inits)))
 367                     (env (make-env nvals unbound-arg env)))
 368                (let lp ((i 0) (args %args))
 369                  (cond
 370                   ((< i nreq)
 371                    ;; Bind required arguments.
 372                    (env-set! env 0 i (car args))
 373                    (lp (1+ i) (cdr args)))
 374                   ((not kw)
 375                    ;; Optional args (possibly), but no keyword args.
 376                    (let lp ((i i) (args args) (inits inits))
 377                      (cond
 378                       ((< i (+ nreq nopt))
 379                        (cond
 380                         ((< i nargs)
 381                          (env-set! env 0 i (car args))
 382                          (lp (1+ i) (cdr args) (cdr inits)))
 383                         (else
 384                          (env-set! env 0 i (eval (car inits) env))
 385                          (lp (1+ i) args (cdr inits)))))
 386                       (else
 387                        (when rest?
 388                          (env-set! env 0 i args))
 389                        (eval body env)))))
 390                   (else
 391                    ;; Optional args.  As before, but stop at the first
 392                    ;; keyword.
 393                    (let lp ((i i) (args args) (inits inits))
 394                      (cond
 395                       ((< i (+ nreq nopt))
 396                        (cond
 397                         ((and (< i nargs) (not (keyword? (car args))))
 398                          (env-set! env 0 i (car args))
 399                          (lp (1+ i) (cdr args) (cdr inits)))
 400                         (else
 401                          (env-set! env 0 i (eval (car inits) env))
 402                          (lp (1+ i) args (cdr inits)))))
 403                       (else
 404                        (when rest?
 405                          (env-set! env 0 i args))
 406                        (let ((aok (car kw))
 407                              (kw (cdr kw))
 408                              (kw-base (if rest? (1+ i) i)))
 409                          ;; Now scan args for keywords.
 410                          (let lp ((args args))
 411                            (cond
 412                             ((and (pair? args) (pair? (cdr args))
 413                                   (keyword? (car args)))
 414                              (let ((kw-pair (assq (car args) kw))
 415                                    (v (cadr args)))
 416                                (if kw-pair
 417                                    ;; Found a known keyword; set its value.
 418                                    (env-set! env 0 (cdr kw-pair) v)
 419                                    ;; Unknown keyword.
 420                                    (if (not aok)
 421                                        ((scm-error
 422                                          'keyword-argument-error
 423                                          "eval" "Unrecognized keyword"
 424                                          '() (list (car args))))))
 425                                (lp (cddr args))))
 426                             ((pair? args)
 427                              (if rest?
 428                                  ;; Be lenient parsing rest args.
 429                                  (lp (cdr args))
 430                                  ((scm-error 'keyword-argument-error
 431                                              "eval" "Invalid keyword"
 432                                              '() (list (car args))))))
 433                             (else
 434                              ;; Finished parsing keywords. Fill in
 435                              ;; uninitialized kwargs by evalling init
 436                              ;; expressions in their appropriate
 437                              ;; environment.
 438                              (let lp ((i kw-base) (inits inits))
 439                                (cond
 440                                 ((pair? inits)
 441                                  (when (eq? (env-ref env 0 i) unbound-arg)
 442                                    (env-set! env 0 i (eval (car inits) env)))
 443                                  (lp (1+ i) (cdr inits)))
 444                                 (else
 445                                  ;; Finally, eval the body.
 446                                  (eval body env)))))))))))))))))))))
 447
 448     ;; The "engine". EXP is a memoized expression.
 449     (define (eval exp env)
 450       (memoized-expression-case exp
 451         (('lexical-ref (depth . width))
 452          (env-ref env depth width))
 453
 454         (('call (f nargs . args))
 455          (let ((proc (eval f env)))
 456            (call eval proc nargs args env)))
 457
 458         (('toplevel-ref var-or-sym)
 459          (variable-ref
 460           (if (variable? var-or-sym)
 461               var-or-sym
 462               (memoize-variable-access! exp
 463                                         (capture-env (env-toplevel env))))))
 464
 465         (('if (test consequent . alternate))
 466          (if (eval test env)
 467              (eval consequent env)
 468              (eval alternate env)))
 469
 470         (('quote x)
 471          x)
 472
 473         (('let (inits . body))
 474          (let* ((width (vector-length inits))
 475                 (new-env (make-env width #f (capture-env env))))
 476            (let lp ((i 0))
 477              (when (< i width)
 478                (env-set! new-env 0 i (eval (vector-ref inits i) env))
 479                (lp (1+ i))))
 480            (eval body new-env)))
 481
 482         (('lambda (body docstring nreq . tail))
 483          (let ((proc
 484                 (if (null? tail)
 485                     (make-fixed-closure eval nreq body (capture-env env))
 486                     (if (null? (cdr tail))
 487                         (make-rest-closure eval nreq body (capture-env env))
 488                         (apply make-general-closure (capture-env env)
 489                                body nreq tail)))))
 490            (when docstring
 491              (set-procedure-property! proc 'documentation docstring))
 492            proc))
 493
 494         (('seq (head . tail))
 495          (begin
 496            (eval head env)
 497            (eval tail env)))
 498
 499         (('lexical-set! ((depth . width) . x))
 500          (env-set! env depth width (eval x env)))
 501
 502         (('call-with-values (producer . consumer))
 503          (call-with-values (eval producer env)
 504            (eval consumer env)))
 505
 506         (('apply (f args))
 507          (apply (eval f env) (eval args env)))
 508
 509         (('module-ref var-or-spec)
 510          (variable-ref
 511           (if (variable? var-or-spec)
 512               var-or-spec
 513               (memoize-variable-access! exp #f))))
 514
 515         (('define (name . x))
 516          (let ((x (eval x env)))
 517            (if (and (procedure? x) (not (procedure-property x 'name)))
 518                (set-procedure-property! x 'name name))
 519            (define! name x)
 520            (if #f #f)))
 521
 522         (('toplevel-set! (var-or-sym . x))
 523          (variable-set!
 524           (if (variable? var-or-sym)
 525               var-or-sym
 526               (memoize-variable-access! exp
 527                                         (capture-env (env-toplevel env))))
 528           (eval x env)))
 529
 530         (('call-with-prompt (tag thunk . handler))
 531          (call-with-prompt
 532           (eval tag env)
 533           (eval thunk env)
 534           (eval handler env)))
 535
 536         (('call/cc proc)
 537          (call/cc (eval proc env)))
 538
 539         (('module-set! (x . var-or-spec))
 540          (variable-set!
 541           (if (variable? var-or-spec)
 542               var-or-spec
 543               (memoize-variable-access! exp #f))
 544           (eval x env)))))
 545
 546     ;; primitive-eval
 547     (lambda (exp)
 548       "Evaluate @var{exp} in the current module."
 549       (eval
 550        (memoize-expression
 551         (if (macroexpanded? exp)
 552             exp
 553             ((module-transformer (current-module)) exp)))
 554        '()))))