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