module/ice-9/eval.scm

   1 ;;; -*- mode: scheme; coding: utf-8; -*-
   2
   3 ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 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.  NB: There should be no
 333     ;; other instance of '(unbound-arg) in this compilation unit, so
 334     ;; that this marker is indeed unique.  It's a hack, but it allows
 335     ;; the constant to propagate to inner closures, reducing free
 336     ;; variable counts all around, so it is important for perf.
 337     (define unbound-arg '(unbound-arg))
 338
 339     ;; Procedures with rest, optional, or keyword arguments, potentially with
 340     ;; multiple arities, as with case-lambda.
 341     (define (make-general-closure env body nreq rest? nopt kw inits alt)
 342       (define alt-proc
 343         (and alt                        ; (body meta nreq ...)
 344              (let* ((body (car alt))
 345                     (spec (cddr alt))
 346                     (nreq (car spec))
 347                     (rest (if (null? (cdr spec)) #f (cadr spec)))
 348                     (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
 349                     (nopt (if tail (car tail) 0))
 350                     (kw (and tail (cadr tail)))
 351                     (inits (if tail (caddr tail) '()))
 352                     (alt (and tail (cadddr tail))))
 353                (make-general-closure env body nreq rest nopt kw inits alt))))
 354       (define (set-procedure-arity! proc)
 355         (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
 356           (if (not alt)
 357               (begin
 358                 (set-procedure-property! proc 'arglist
 359                                          (list nreq
 360                                                nopt
 361                                                (if kw (cdr kw) '())
 362                                                (and kw (car kw))
 363                                                (and rest? '_)))
 364                 (set-procedure-minimum-arity! proc nreq nopt rest?))
 365               (let* ((spec (cddr alt))
 366                      (nreq* (car spec))
 367                      (rest?* (if (null? (cdr spec)) #f (cadr spec)))
 368                      (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
 369                      (nopt* (if tail (car tail) 0))
 370                      (alt* (and tail (cadddr tail))))
 371                 (if (or (< nreq* nreq)
 372                         (and (= nreq* nreq)
 373                              (if rest?
 374                                  (and rest?* (> nopt* nopt))
 375                                  (or rest?* (> nopt* nopt)))))
 376                     (lp alt* nreq* nopt* rest?*)
 377                     (lp alt* nreq nopt rest?)))))
 378         proc)
 379       (set-procedure-arity!
 380        (lambda %args
 381          (define (npositional args)
 382            (let lp ((n 0) (args args))
 383              (if (or (null? args)
 384                      (and (>= n nreq) (keyword? (car args))))
 385                  n
 386                  (lp (1+ n) (cdr args)))))
 387          (let ((nargs (length %args)))
 388            (cond
 389             ((or (< nargs nreq)
 390                  (and (not kw) (not rest?) (> nargs (+ nreq nopt)))
 391                  (and alt kw (not rest?) (> (npositional %args) (+ nreq nopt))))
 392              (if alt
 393                  (apply alt-proc %args)
 394                  ((scm-error 'wrong-number-of-args
 395                              "eval" "Wrong number of arguments"
 396                              '() #f))))
 397             (else
 398              (let* ((nvals (+ nreq (if rest? 1 0) (length inits)))
 399                     (env (make-env nvals unbound-arg env)))
 400                (let lp ((i 0) (args %args))
 401                  (cond
 402                   ((< i nreq)
 403                    ;; Bind required arguments.
 404                    (env-set! env 0 i (car args))
 405                    (lp (1+ i) (cdr args)))
 406                   ((not kw)
 407                    ;; Optional args (possibly), but no keyword args.
 408                    (let lp ((i i) (args args) (inits inits))
 409                      (cond
 410                       ((< i (+ nreq nopt))
 411                        (cond
 412                         ((< i nargs)
 413                          (env-set! env 0 i (car args))
 414                          (lp (1+ i) (cdr args) (cdr inits)))
 415                         (else
 416                          (env-set! env 0 i (eval (car inits) env))
 417                          (lp (1+ i) args (cdr inits)))))
 418                       (else
 419                        (when rest?
 420                          (env-set! env 0 i args))
 421                        (eval body env)))))
 422                   (else
 423                    ;; Optional args.  As before, but stop at the first
 424                    ;; keyword.
 425                    (let lp ((i i) (args args) (inits inits))
 426                      (cond
 427                       ((< i (+ nreq nopt))
 428                        (cond
 429                         ((and (< i nargs) (not (keyword? (car args))))
 430                          (env-set! env 0 i (car args))
 431                          (lp (1+ i) (cdr args) (cdr inits)))
 432                         (else
 433                          (env-set! env 0 i (eval (car inits) env))
 434                          (lp (1+ i) args (cdr inits)))))
 435                       (else
 436                        (when rest?
 437                          (env-set! env 0 i args))
 438                        (let ((aok (car kw))
 439                              (kw (cdr kw))
 440                              (kw-base (if rest? (1+ i) i)))
 441                          ;; Now scan args for keywords.
 442                          (let lp ((args args))
 443                            (cond
 444                             ((and (pair? args) (pair? (cdr args))
 445                                   (keyword? (car args)))
 446                              (let ((kw-pair (assq (car args) kw))
 447                                    (v (cadr args)))
 448                                (if kw-pair
 449                                    ;; Found a known keyword; set its value.
 450                                    (env-set! env 0 (cdr kw-pair) v)
 451                                    ;; Unknown keyword.
 452                                    (if (not aok)
 453                                        ((scm-error
 454                                          'keyword-argument-error
 455                                          "eval" "Unrecognized keyword"
 456                                          '() (list (car args))))))
 457                                (lp (cddr args))))
 458                             ((pair? args)
 459                              (if rest?
 460                                  ;; Be lenient parsing rest args.
 461                                  (lp (cdr args))
 462                                  ((scm-error 'keyword-argument-error
 463                                              "eval" "Invalid keyword"
 464                                              '() (list (car args))))))
 465                             (else
 466                              ;; Finished parsing keywords. Fill in
 467                              ;; uninitialized kwargs by evalling init
 468                              ;; expressions in their appropriate
 469                              ;; environment.
 470                              (let lp ((i kw-base) (inits inits))
 471                                (cond
 472                                 ((pair? inits)
 473                                  (when (eq? (env-ref env 0 i) unbound-arg)
 474                                    (env-set! env 0 i (eval (car inits) env)))
 475                                  (lp (1+ i) (cdr inits)))
 476                                 (else
 477                                  ;; Finally, eval the body.
 478                                  (eval body env)))))))))))))))))))))
 479
 480     ;; The "engine". EXP is a memoized expression.
 481     (define (eval exp env)
 482       (memoized-expression-case exp
 483         (('lexical-ref (depth . width))
 484          (env-ref env depth width))
 485
 486         (('call (f nargs . args))
 487          (let ((proc (eval f env)))
 488            (call eval proc nargs args env)))
 489
 490         (('toplevel-ref var-or-sym)
 491          (variable-ref
 492           (if (variable? var-or-sym)
 493               var-or-sym
 494               (memoize-variable-access! exp (env-toplevel env)))))
 495
 496         (('if (test consequent . alternate))
 497          (if (eval test env)
 498              (eval consequent env)
 499              (eval alternate env)))
 500
 501         (('quote x)
 502          x)
 503
 504         (('let (inits . body))
 505          (eval body ((let-env-evaluator eval env (_ _ _ _)) inits)))
 506
 507         (('lambda (body meta nreq . tail))
 508          (let ((proc
 509                 (if (null? tail)
 510                     (make-fixed-closure eval nreq body env)
 511                     (mx-bind
 512                      tail (rest? . tail)
 513                      (if (null? tail)
 514                          (make-rest-closure eval nreq body env)
 515                          (mx-bind
 516                           tail (nopt kw inits alt)
 517                           (make-general-closure env body nreq rest?
 518                                                 nopt kw inits alt)))))))
 519            (let lp ((meta meta))
 520              (unless (null? meta)
 521                (set-procedure-property! proc (caar meta) (cdar meta))
 522                (lp (cdr meta))))
 523            proc))
 524
 525         (('seq (head . tail))
 526          (begin
 527            (eval head env)
 528            (eval tail env)))
 529
 530         (('lexical-set! ((depth . width) . x))
 531          (env-set! env depth width (eval x env)))
 532
 533         (('call-with-values (producer . consumer))
 534          (call-with-values (eval producer env)
 535            (eval consumer env)))
 536
 537         (('apply (f args))
 538          (apply (eval f env) (eval args env)))
 539
 540         (('module-ref var-or-spec)
 541          (variable-ref
 542           (if (variable? var-or-spec)
 543               var-or-spec
 544               (memoize-variable-access! exp #f))))
 545
 546         (('define (name . x))
 547          (begin
 548            (define! name (eval x env))
 549            (if #f #f)))
 550
 551         (('capture-module x)
 552          (eval x (current-module)))
 553
 554         (('toplevel-set! (var-or-sym . x))
 555          (variable-set!
 556           (if (variable? var-or-sym)
 557               var-or-sym
 558               (memoize-variable-access! exp (env-toplevel env)))
 559           (eval x env)))
 560
 561         (('call-with-prompt (tag thunk . handler))
 562          (call-with-prompt
 563           (eval tag env)
 564           (eval thunk env)
 565           (eval handler env)))
 566
 567         (('call/cc proc)
 568          (call/cc (eval proc env)))
 569
 570         (('module-set! (x . var-or-spec))
 571          (variable-set!
 572           (if (variable? var-or-spec)
 573               var-or-spec
 574               (memoize-variable-access! exp #f))
 575           (eval x env)))))
 576
 577     ;; primitive-eval
 578     (lambda (exp)
 579       "Evaluate @var{exp} in the current module."
 580       (eval
 581        (memoize-expression
 582         (if (macroexpanded? exp)
 583             exp
 584             ((module-transformer (current-module)) exp)))
 585        #f))))