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 env-toplevel
  47     (syntax-rules ()
  48       ((_ env)
  49        (let lp ((e env))
  50          (if (vector? e)
  51              (lp (vector-ref e 0))
  52              e)))))
  53
  54   (define-syntax make-env
  55     (syntax-rules ()
  56       ((_ n init next)
  57        (let ((v (make-vector (1+ n) init)))
  58          (vector-set! v 0 next)
  59          v))))
  60
  61   (define-syntax make-env*
  62     (syntax-rules ()
  63       ((_ next init ...)
  64        (vector next init ...))))
  65
  66   (define-syntax env-ref
  67     (syntax-rules ()
  68       ((_ env depth width)
  69        (let lp ((e env) (d depth))
  70          (if (zero? d)
  71              (vector-ref e (1+ width))
  72              (lp (vector-ref e 0) (1- d)))))))
  73
  74   (define-syntax env-set!
  75     (syntax-rules ()
  76       ((_ env depth width val)
  77        (let lp ((e env) (d depth))
  78          (if (zero? d)
  79              (vector-set! e (1+ width) val)
  80              (lp (vector-ref e 0) (1- d)))))))
  81
  82   ;; For evaluating the initializers in a "let" expression.  We have to
  83   ;; evaluate the initializers before creating the environment rib, to
  84   ;; prevent continuation-related shenanigans; see
  85   ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time for a
  86   ;; deeper discussion.
  87   ;;
  88   ;; This macro will inline evaluation of the first N initializers.
  89   ;; That number N is indicated by the number of template arguments
  90   ;; passed to the macro.  It's a bit nasty but it's flexible and
  91   ;; optimizes well.
  92   (define-syntax let-env-evaluator
  93     (syntax-rules ()
  94       ((eval-and-make-env eval env (template ...))
  95        (let ()
  96          (define-syntax eval-and-make-env
  97            (syntax-rules ()
  98              ((eval-and-make-env inits width (template ...) k)
  99               (let lp ((n (length '(template ...))) (vals '()))
 100                 (if (eqv? n width)
 101                     (let ((env (make-env n #f env)))
 102                       (let lp ((n (1- n)) (vals vals))
 103                         (if (null? vals)
 104                             (k env)
 105                             (begin
 106                               (env-set! env 0 n (car vals))
 107                               (lp (1- n) (cdr vals))))))
 108                     (lp (1+ n)
 109                         (cons (eval (vector-ref inits n) env) vals)))))
 110              ((eval-and-make-env inits width (var (... ...)) k)
 111               (let ((n (length '(var (... ...)))))
 112                 (if (eqv? n width)
 113                     (k (make-env n #f env))
 114                     (let* ((x (eval (vector-ref inits n) env))
 115                            (k (lambda (env)
 116                                 (env-set! env 0 n x)
 117                                 (k env))))
 118                       (eval-and-make-env inits width (x var (... ...)) k)))))))
 119          (lambda (inits)
 120            (let ((width (vector-length inits))
 121                  (k (lambda (env) env)))
 122              (eval-and-make-env inits width () k)))))))
 123
 124   ;; Fast case for procedures with fixed arities.
 125   (define-syntax make-fixed-closure
 126     (lambda (x)
 127       (define *max-static-argument-count* 8)
 128       (define (make-formals n)
 129         (map (lambda (i)
 130                (datum->syntax
 131                 x
 132                 (string->symbol
 133                  (string (integer->char (+ (char->integer #\a) i))))))
 134              (iota n)))
 135       (syntax-case x ()
 136         ((_ eval nreq body env) (not (identifier? #'env))
 137          #'(let ((e env))
 138              (make-fixed-closure eval nreq body e)))
 139         ((_ eval nreq body env)
 140          #`(case nreq
 141              #,@(map (lambda (nreq)
 142                        (let ((formals (make-formals nreq)))
 143                          #`((#,nreq)
 144                             (lambda (#,@formals)
 145                               (eval body
 146                                     (make-env* env #,@formals))))))
 147                      (iota *max-static-argument-count*))
 148              (else
 149               #,(let ((formals (make-formals *max-static-argument-count*)))
 150                   #`(lambda (#,@formals . more)
 151                       (let ((env (make-env nreq #f env)))
 152                         #,@(map (lambda (formal n)
 153                                   #`(env-set! env 0 #,n #,formal))
 154                                 formals (iota (length formals)))
 155                         (let lp ((i #,*max-static-argument-count*)
 156                                  (args more))
 157                           (cond
 158                            ((= i nreq)
 159                             (eval body
 160                                   (if (null? args)
 161                                       env
 162                                       (scm-error 'wrong-number-of-args
 163                                                  "eval" "Wrong number of arguments"
 164                                                  '() #f))))
 165                            ((null? args)
 166                             (scm-error 'wrong-number-of-args
 167                                        "eval" "Wrong number of arguments"
 168                                        '() #f))
 169                            (else
 170                             (env-set! env 0 i (car args))
 171                             (lp (1+ i) (cdr args))))))))))))))
 172
 173   ;; Fast case for procedures with fixed arities and a rest argument.
 174   (define-syntax make-rest-closure
 175     (lambda (x)
 176       (define *max-static-argument-count* 3)
 177       (define (make-formals n)
 178         (map (lambda (i)
 179                (datum->syntax
 180                 x
 181                 (string->symbol
 182                  (string (integer->char (+ (char->integer #\a) i))))))
 183              (iota n)))
 184       (syntax-case x ()
 185         ((_ eval nreq body env) (not (identifier? #'env))
 186          #'(let ((e env))
 187              (make-rest-closure eval nreq body e)))
 188         ((_ eval nreq body env)
 189          #`(case nreq
 190              #,@(map (lambda (nreq)
 191                        (let ((formals (make-formals nreq)))
 192                          #`((#,nreq)
 193                             (lambda (#,@formals . rest)
 194                               (eval body
 195                                     (make-env* env #,@formals rest))))))
 196                      (iota *max-static-argument-count*))
 197              (else
 198               #,(let ((formals (make-formals *max-static-argument-count*)))
 199                   #`(lambda (#,@formals . more)
 200                       (let ((env (make-env (1+ nreq) #f env)))
 201                         #,@(map (lambda (formal n)
 202                                   #`(env-set! env 0 #,n #,formal))
 203                                 formals (iota (length formals)))
 204                         (let lp ((i #,*max-static-argument-count*)
 205                                  (args more))
 206                           (cond
 207                            ((= i nreq)
 208                             (env-set! env 0 nreq args)
 209                             (eval body env))
 210                            ((null? args)
 211                             (scm-error 'wrong-number-of-args
 212                                        "eval" "Wrong number of arguments"
 213                                        '() #f))
 214                            (else
 215                             (env-set! env 0 i (car args))
 216                             (lp (1+ i) (cdr args))))))))))))))
 217
 218   (define-syntax call
 219     (lambda (x)
 220       (define *max-static-call-count* 4)
 221       (syntax-case x ()
 222         ((_ eval proc nargs args env) (identifier? #'env)
 223          #`(case nargs
 224              #,@(map (lambda (nargs)
 225                        #`((#,nargs)
 226                           (proc
 227                            #,@(map
 228                                (lambda (n)
 229                                  (let lp ((n n) (args #'args))
 230                                    (if (zero? n)
 231                                        #`(eval (car #,args) env)
 232                                        (lp (1- n) #`(cdr #,args)))))
 233                                (iota nargs)))))
 234                      (iota *max-static-call-count*))
 235              (else
 236               (apply proc
 237                      #,@(map
 238                          (lambda (n)
 239                            (let lp ((n n) (args #'args))
 240                              (if (zero? n)
 241                                  #`(eval (car #,args) env)
 242                                  (lp (1- n) #`(cdr #,args)))))
 243                          (iota *max-static-call-count*))
 244                      (let lp ((exps #,(let lp ((n *max-static-call-count*)
 245                                                (args #'args))
 246                                         (if (zero? n)
 247                                             args
 248                                             (lp (1- n) #`(cdr #,args)))))
 249                               (args '()))
 250                        (if (null? exps)
 251                            (reverse args)
 252                            (lp (cdr exps)
 253                                (cons (eval (car exps) env) args)))))))))))
 254
 255   ;; This macro could be more straightforward if the compiler had better
 256   ;; copy propagation. As it is we do some copy propagation by hand.
 257   (define-syntax mx-bind
 258     (lambda (x)
 259       (syntax-case x ()
 260         ((_ data () body)
 261          #'body)
 262         ((_ data (a . b) body) (and (identifier? #'a) (identifier? #'b))
 263          #'(let ((a (car data))
 264                  (b (cdr data)))
 265              body))
 266         ((_ data (a . b) body) (identifier? #'a)
 267          #'(let ((a (car data))
 268                  (xb (cdr data)))
 269              (mx-bind xb b body)))
 270         ((_ data (a . b) body)
 271          #'(let ((xa (car data))
 272                  (xb (cdr data)))
 273              (mx-bind xa a (mx-bind xb b body))))
 274         ((_ data v body) (identifier? #'v)
 275          #'(let ((v data))
 276              body)))))
 277
 278   ;; The resulting nested if statements will be an O(n) dispatch. Once
 279   ;; we compile `case' effectively, this situation will improve.
 280   (define-syntax mx-match
 281     (lambda (x)
 282       (syntax-case x (quote)
 283         ((_ mx data tag)
 284          #'(error "what" mx))
 285         ((_ mx data tag (('type pat) body) c* ...)
 286          #`(if (eqv? tag #,(or (memoized-typecode (syntax->datum #'type))
 287                                (error "not a typecode" #'type)))
 288                (mx-bind data pat body)
 289                (mx-match mx data tag c* ...))))))
 290
 291   (define-syntax memoized-expression-case
 292     (lambda (x)
 293       (syntax-case x ()
 294         ((_ mx c ...)
 295          #'(let ((tag (car mx))
 296                  (data (cdr mx)))
 297              (mx-match mx data tag c ...)))))))
 298
 299
 300 ;;;
 301 ;;; On 18 Feb 2010, I did a profile of how often the various memoized expression
 302 ;;; types occur when getting to a prompt on a fresh build. Here are the numbers
 303 ;;; I got:
 304 ;;;
 305 ;;;      lexical-ref: 32933054
 306 ;;;             call: 20281547
 307 ;;;     toplevel-ref: 13228724
 308 ;;;               if: 9156156
 309 ;;;            quote: 6610137
 310 ;;;              let: 2619707
 311 ;;;           lambda: 1010921
 312 ;;;            begin: 948945
 313 ;;;      lexical-set: 509862
 314 ;;; call-with-values: 139668
 315 ;;;            apply: 49402
 316 ;;;       module-ref: 14468
 317 ;;;           define: 1259
 318 ;;;     toplevel-set: 328
 319 ;;;          call/cc: 0
 320 ;;;       module-set: 0
 321 ;;;
 322 ;;; So until we compile `case' into a computed goto, we'll order the clauses in
 323 ;;; `eval' in this order, to put the most frequent cases first.
 324 ;;;
 325
 326 (define primitive-eval
 327   (let ()
 328     ;; We pre-generate procedures with fixed arities, up to some number
 329     ;; of arguments, and some rest arities; see make-fixed-closure and
 330     ;; make-rest-closure above.
 331
 332     ;; A unique marker for unbound keywords.
 333     (define unbound-arg (list 'unbound-arg))
 334
 335     ;; Procedures with rest, optional, or keyword arguments, potentially with
 336     ;; multiple arities, as with case-lambda.
 337     (define (make-general-closure env body nreq rest? nopt kw inits alt)
 338       (define alt-proc
 339         (and alt                        ; (body meta nreq ...)
 340              (let* ((body (car alt))
 341                     (spec (cddr alt))
 342                     (nreq (car spec))
 343                     (rest (if (null? (cdr spec)) #f (cadr spec)))
 344                     (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
 345                     (nopt (if tail (car tail) 0))
 346                     (kw (and tail (cadr tail)))
 347                     (inits (if tail (caddr tail) '()))
 348                     (alt (and tail (cadddr tail))))
 349                (make-general-closure env body nreq rest nopt kw inits alt))))
 350       (define (set-procedure-arity! proc)
 351         (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
 352           (if (not alt)
 353               (begin
 354                 (set-procedure-property! proc 'arglist
 355                                          (list nreq
 356                                                nopt
 357                                                (if kw (cdr kw) '())
 358                                                (and kw (car kw))
 359                                                (and rest? '_)))
 360                 (set-procedure-minimum-arity! proc nreq nopt rest?))
 361               (let* ((spec (cddr alt))
 362                      (nreq* (car spec))
 363                      (rest?* (if (null? (cdr spec)) #f (cadr spec)))
 364                      (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
 365                      (nopt* (if tail (car tail) 0))
 366                      (alt* (and tail (cadddr tail))))
 367                 (if (or (< nreq* nreq)
 368                         (and (= nreq* nreq)
 369                              (if rest?
 370                                  (and rest?* (> nopt* nopt))
 371                                  (or rest?* (> nopt* nopt)))))
 372                     (lp alt* nreq* nopt* rest?*)
 373                     (lp alt* nreq nopt rest?)))))
 374         proc)
 375       (set-procedure-arity!
 376        (lambda %args
 377          (define (npositional args)
 378            (let lp ((n 0) (args args))
 379              (if (or (null? args)
 380                      (and (>= n nreq) (keyword? (car args))))
 381                  n
 382                  (lp (1+ n) (cdr args)))))
 383          (let ((nargs (length %args)))
 384            (cond
 385             ((or (< nargs nreq)
 386                  (and (not kw) (not rest?) (> nargs (+ nreq nopt)))
 387                  (and alt kw (not rest?) (> (npositional %args) (+ nreq nopt))))
 388              (if alt
 389                  (apply alt-proc %args)
 390                  ((scm-error 'wrong-number-of-args
 391                              "eval" "Wrong number of arguments"
 392                              '() #f))))
 393             (else
 394              (let* ((nvals (+ nreq (if rest? 1 0) (length inits)))
 395                     (env (make-env nvals unbound-arg env)))
 396                (let lp ((i 0) (args %args))
 397                  (cond
 398                   ((< i nreq)
 399                    ;; Bind required arguments.
 400                    (env-set! env 0 i (car args))
 401                    (lp (1+ i) (cdr args)))
 402                   ((not kw)
 403                    ;; Optional args (possibly), but no keyword args.
 404                    (let lp ((i i) (args args) (inits inits))
 405                      (cond
 406                       ((< i (+ nreq nopt))
 407                        (cond
 408                         ((< i nargs)
 409                          (env-set! env 0 i (car args))
 410                          (lp (1+ i) (cdr args) (cdr inits)))
 411                         (else
 412                          (env-set! env 0 i (eval (car inits) env))
 413                          (lp (1+ i) args (cdr inits)))))
 414                       (else
 415                        (when rest?
 416                          (env-set! env 0 i args))
 417                        (eval body env)))))
 418                   (else
 419                    ;; Optional args.  As before, but stop at the first
 420                    ;; keyword.
 421                    (let lp ((i i) (args args) (inits inits))
 422                      (cond
 423                       ((< i (+ nreq nopt))
 424                        (cond
 425                         ((and (< i nargs) (not (keyword? (car args))))
 426                          (env-set! env 0 i (car args))
 427                          (lp (1+ i) (cdr args) (cdr inits)))
 428                         (else
 429                          (env-set! env 0 i (eval (car inits) env))
 430                          (lp (1+ i) args (cdr inits)))))
 431                       (else
 432                        (when rest?
 433                          (env-set! env 0 i args))
 434                        (let ((aok (car kw))
 435                              (kw (cdr kw))
 436                              (kw-base (if rest? (1+ i) i)))
 437                          ;; Now scan args for keywords.
 438                          (let lp ((args args))
 439                            (cond
 440                             ((and (pair? args) (pair? (cdr args))
 441                                   (keyword? (car args)))
 442                              (let ((kw-pair (assq (car args) kw))
 443                                    (v (cadr args)))
 444                                (if kw-pair
 445                                    ;; Found a known keyword; set its value.
 446                                    (env-set! env 0 (cdr kw-pair) v)
 447                                    ;; Unknown keyword.
 448                                    (if (not aok)
 449                                        ((scm-error
 450                                          'keyword-argument-error
 451                                          "eval" "Unrecognized keyword"
 452                                          '() (list (car args))))))
 453                                (lp (cddr args))))
 454                             ((pair? args)
 455                              (if rest?
 456                                  ;; Be lenient parsing rest args.
 457                                  (lp (cdr args))
 458                                  ((scm-error 'keyword-argument-error
 459                                              "eval" "Invalid keyword"
 460                                              '() (list (car args))))))
 461                             (else
 462                              ;; Finished parsing keywords. Fill in
 463                              ;; uninitialized kwargs by evalling init
 464                              ;; expressions in their appropriate
 465                              ;; environment.
 466                              (let lp ((i kw-base) (inits inits))
 467                                (cond
 468                                 ((pair? inits)
 469                                  (when (eq? (env-ref env 0 i) unbound-arg)
 470                                    (env-set! env 0 i (eval (car inits) env)))
 471                                  (lp (1+ i) (cdr inits)))
 472                                 (else
 473                                  ;; Finally, eval the body.
 474                                  (eval body env)))))))))))))))))))))
 475
 476     ;; The "engine". EXP is a memoized expression.
 477     (define (eval exp env)
 478       (memoized-expression-case exp
 479         (('lexical-ref (depth . width))
 480          (env-ref env depth width))
 481
 482         (('call (f nargs . args))
 483          (let ((proc (eval f env)))
 484            (call eval proc nargs args env)))
 485
 486         (('toplevel-ref var-or-sym)
 487          (variable-ref
 488           (if (variable? var-or-sym)
 489               var-or-sym
 490               (memoize-variable-access! exp (env-toplevel env)))))
 491
 492         (('if (test consequent . alternate))
 493          (if (eval test env)
 494              (eval consequent env)
 495              (eval alternate env)))
 496
 497         (('quote x)
 498          x)
 499
 500         (('let (inits . body))
 501          (eval body ((let-env-evaluator eval env (_ _ _ _)) inits)))
 502
 503         (('lambda (body meta nreq . tail))
 504          (let ((proc
 505                 (if (null? tail)
 506                     (make-fixed-closure eval nreq body env)
 507                     (if (null? (cdr tail))
 508                         (make-rest-closure eval nreq body env)
 509                         (apply make-general-closure env body nreq tail)))))
 510            (let lp ((meta meta))
 511              (unless (null? meta)
 512                (set-procedure-property! proc (caar meta) (cdar meta))
 513                (lp (cdr meta))))
 514            proc))
 515
 516         (('seq (head . tail))
 517          (begin
 518            (eval head env)
 519            (eval tail env)))
 520
 521         (('lexical-set! ((depth . width) . x))
 522          (env-set! env depth width (eval x env)))
 523
 524         (('call-with-values (producer . consumer))
 525          (call-with-values (eval producer env)
 526            (eval consumer env)))
 527
 528         (('apply (f args))
 529          (apply (eval f env) (eval args env)))
 530
 531         (('module-ref var-or-spec)
 532          (variable-ref
 533           (if (variable? var-or-spec)
 534               var-or-spec
 535               (memoize-variable-access! exp #f))))
 536
 537         (('define (name . x))
 538          (begin
 539            (define! name (eval x env))
 540            (if #f #f)))
 541
 542         (('capture-module x)
 543          (eval x (current-module)))
 544
 545         (('toplevel-set! (var-or-sym . x))
 546          (variable-set!
 547           (if (variable? var-or-sym)
 548               var-or-sym
 549               (memoize-variable-access! exp (env-toplevel env)))
 550           (eval x env)))
 551
 552         (('call-with-prompt (tag thunk . handler))
 553          (call-with-prompt
 554           (eval tag env)
 555           (eval thunk env)
 556           (eval handler env)))
 557
 558         (('call/cc proc)
 559          (call/cc (eval proc env)))
 560
 561         (('module-set! (x . var-or-spec))
 562          (variable-set!
 563           (if (variable? var-or-spec)
 564               var-or-spec
 565               (memoize-variable-access! exp #f))
 566           (eval x env)))))
 567
 568     ;; primitive-eval
 569     (lambda (exp)
 570       "Evaluate @var{exp} in the current module."
 571       (eval
 572        (memoize-expression
 573         (if (macroexpanded? exp)
 574             exp
 575             ((module-transformer (current-module)) exp)))
 576        #f))))