module/ice-9/eval.scm

   1 ;;; -*- mode: scheme; coding: utf-8; -*-
   2
   3 ;;;; Copyright (C) 2009, 2010
   4 ;;;; Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This library is free software; you can redistribute it and/or
   7 ;;;; modify it under the terms of the GNU Lesser General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 3 of the License, or (at your option) any later version.
  10 ;;;;
  11 ;;;; This library is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19 ;;;;
  20
  21 \f
  22
  23 ;;; Commentary:
  24
  25 ;;; Scheme eval, written in Scheme.
  26 ;;;
  27 ;;; Expressions are first expanded, by the syntax expander (i.e.
  28 ;;; psyntax), then memoized into internal forms. The evaluator itself
  29 ;;; only operates on the internal forms ("memoized expressions").
  30 ;;;
  31 ;;; Environments are represented as linked lists of the form (VAL ... .
  32 ;;; MOD). If MOD is #f, it means the environment was captured before
  33 ;;; modules were booted. If MOD is the literal value '(), we are
  34 ;;; evaluating at the top level, and so should track changes to the
  35 ;;; current module.
  36 ;;;
  37 ;;; Evaluate this in Emacs to make code indentation work right:
  38 ;;;
  39 ;;;    (put 'memoized-expression-case 'scheme-indent-function 1)
  40 ;;;
  41
  42 ;;; Code:
  43
  44 \f
  45
  46 (eval-when (compile)
  47   (define-syntax capture-env
  48     (syntax-rules ()
  49       ((_ env)
  50        (if (null? env)
  51            (current-module)
  52            (if (not env)
  53                ;; the and current-module checks that modules are booted,
  54                ;; and thus the-root-module is defined
  55                (and (current-module) the-root-module)
  56                env)))))
  57
  58   (define-syntax make-closure
  59     (lambda (x)
  60       (define *max-static-argument-count* 8)
  61       (define (make-formals n)
  62         (map (lambda (i)
  63                (datum->syntax
  64                 x
  65                 (string->symbol
  66                  (string (integer->char (+ (char->integer #\a) i))))))
  67              (iota n)))
  68       (syntax-case x ()
  69         ((_ eval nreq rest? body env) (not (identifier? #'env))
  70          #'(let ((e env))
  71              (make-closure eval nreq rest? body e)))
  72         ((_ eval nreq rest? body env)
  73          #`(case nreq
  74              #,@(map (lambda (nreq)
  75                        (let ((formals (make-formals nreq)))
  76                          #`((#,nreq)
  77                             (if rest?
  78                                 (lambda (#,@formals . rest)
  79                                   (eval body
  80                                         (cons* rest #,@(reverse formals)
  81                                                env)))
  82                                 (lambda (#,@formals)
  83                                   (eval body
  84                                         (cons* #,@(reverse formals) env)))))))
  85                      (iota *max-static-argument-count*))
  86              (else
  87               #,(let ((formals (make-formals *max-static-argument-count*)))
  88                   #`(lambda (#,@formals . more)
  89                       (let lp ((new-env (cons* #,@(reverse formals) env))
  90                                (nreq (- nreq #,*max-static-argument-count*))
  91                                (args more))
  92                         (if (zero? nreq)
  93                             (eval body
  94                                   (if rest?
  95                                       (cons args new-env)
  96                                       (if (not (null? args))
  97                                           (scm-error 'wrong-number-of-args
  98                                                      "eval" "Wrong number of arguments"
  99                                                      '() #f)
 100                                           new-env)))
 101                             (if (null? args)
 102                                 (scm-error 'wrong-number-of-args
 103                                            "eval" "Wrong number of arguments"
 104                                            '() #f)
 105                                 (lp (cons (car args) new-env)
 106                                     (1- nreq)
 107                                     (cdr args)))))))))))))
 108
 109   (define-syntax call
 110     (lambda (x)
 111       (define *max-static-call-count* 4)
 112       (syntax-case x ()
 113         ((_ eval proc nargs args env) (identifier? #'env)
 114          #`(case nargs
 115              #,@(map (lambda (nargs)
 116                        #`((#,nargs)
 117                           (proc
 118                            #,@(map
 119                                (lambda (n)
 120                                  (let lp ((n n) (args #'args))
 121                                    (if (zero? n)
 122                                        #`(eval (car #,args) env)
 123                                        (lp (1- n) #`(cdr #,args)))))
 124                                (iota nargs)))))
 125                      (iota *max-static-call-count*))
 126              (else
 127               (apply proc
 128                      #,@(map
 129                          (lambda (n)
 130                            (let lp ((n n) (args #'args))
 131                              (if (zero? n)
 132                                  #`(eval (car #,args) env)
 133                                  (lp (1- n) #`(cdr #,args)))))
 134                          (iota *max-static-call-count*))
 135                      (let lp ((exps #,(let lp ((n *max-static-call-count*)
 136                                                (args #'args))
 137                                         (if (zero? n)
 138                                             args
 139                                             (lp (1- n) #`(cdr #,args)))))
 140                               (args '()))
 141                        (if (null? exps)
 142                            (reverse args)
 143                            (lp (cdr exps)
 144                                (cons (eval (car exps) env) args)))))))))))
 145
 146   ;; This macro could be more straightforward if the compiler had better
 147   ;; copy propagation. As it is we do some copy propagation by hand.
 148   (define-syntax mx-bind
 149     (lambda (x)
 150       (syntax-case x ()
 151         ((_ data () body)
 152          #'body)
 153         ((_ data (a . b) body) (and (identifier? #'a) (identifier? #'b))
 154          #'(let ((a (car data))
 155                  (b (cdr data)))
 156              body))
 157         ((_ data (a . b) body) (identifier? #'a)
 158          #'(let ((a (car data))
 159                  (xb (cdr data)))
 160              (mx-bind xb b body)))
 161         ((_ data (a . b) body)
 162          #'(let ((xa (car data))
 163                  (xb (cdr data)))
 164              (mx-bind xa a (mx-bind xb b body))))
 165         ((_ data v body) (identifier? #'v)
 166          #'(let ((v data))
 167              body)))))
 168
 169   ;; The resulting nested if statements will be an O(n) dispatch. Once
 170   ;; we compile `case' effectively, this situation will improve.
 171   (define-syntax mx-match
 172     (lambda (x)
 173       (syntax-case x (quote)
 174         ((_ mx data tag)
 175          #'(error "what" mx))
 176         ((_ mx data tag (('type pat) body) c* ...)
 177          #`(if (eqv? tag #,(or (memoized-typecode (syntax->datum #'type))
 178                                (error "not a typecode" #'type)))
 179                (mx-bind data pat body)
 180                (mx-match mx data tag c* ...))))))
 181
 182   (define-syntax memoized-expression-case
 183     (lambda (x)
 184       (syntax-case x ()
 185         ((_ mx c ...)
 186          #'(let ((tag (memoized-expression-typecode mx))
 187                  (data (memoized-expression-data mx)))
 188              (mx-match mx data tag c ...)))))))
 189
 190
 191 ;;;
 192 ;;; On 18 Feb 2010, I did a profile of how often the various memoized expression
 193 ;;; types occur when getting to a prompt on a fresh build. Here are the numbers
 194 ;;; I got:
 195 ;;;
 196 ;;;      lexical-ref: 32933054
 197 ;;;             call: 20281547
 198 ;;;     toplevel-ref: 13228724
 199 ;;;               if: 9156156
 200 ;;;            quote: 6610137
 201 ;;;              let: 2619707
 202 ;;;           lambda: 1010921
 203 ;;;            begin: 948945
 204 ;;;      lexical-set: 509862
 205 ;;; call-with-values: 139668
 206 ;;;            apply: 49402
 207 ;;;       module-ref: 14468
 208 ;;;           define: 1259
 209 ;;;     toplevel-set: 328
 210 ;;;          dynwind: 162
 211 ;;;      with-fluids: 0
 212 ;;;          call/cc: 0
 213 ;;;       module-set: 0
 214 ;;;
 215 ;;; So until we compile `case' into a computed goto, we'll order the clauses in
 216 ;;; `eval' in this order, to put the most frequent cases first.
 217 ;;;
 218
 219 (define primitive-eval
 220   (let ()
 221     ;; The "engine". EXP is a memoized expression.
 222     (define (eval exp env)
 223       (memoized-expression-case exp
 224         (('lexical-ref n)
 225          (let lp ((n n) (env env))
 226            (if (zero? n)
 227                (car env)
 228                (lp (1- n) (cdr env)))))
 229
 230         (('call (f nargs . args))
 231          (let ((proc (eval f env)))
 232            (call eval proc nargs args env)))
 233
 234         (('toplevel-ref var-or-sym)
 235          (variable-ref
 236           (if (variable? var-or-sym)
 237               var-or-sym
 238               (let lp ((env env))
 239                 (if (pair? env)
 240                     (lp (cdr env))
 241                     (memoize-variable-access! exp (capture-env env)))))))
 242
 243         (('if (test consequent . alternate))
 244          (if (eval test env)
 245              (eval consequent env)
 246              (eval alternate env)))
 247
 248         (('quote x)
 249          x)
 250
 251         (('let (inits . body))
 252          (let lp ((inits inits) (new-env (capture-env env)))
 253            (if (null? inits)
 254                (eval body new-env)
 255                (lp (cdr inits)
 256                    (cons (eval (car inits) env) new-env)))))
 257
 258         (('lambda (nreq rest? . body))
 259          (make-closure eval nreq rest? body (capture-env env)))
 260
 261         (('begin (first . rest))
 262          (let lp ((first first) (rest rest))
 263            (if (null? rest)
 264                (eval first env)
 265                (begin
 266                  (eval first env)
 267                  (lp (car rest) (cdr rest))))))
 268
 269         (('lexical-set! (n . x))
 270          (let ((val (eval x env)))
 271            (let lp ((n n) (env env))
 272              (if (zero? n)
 273                  (set-car! env val)
 274                  (lp (1- n) (cdr env))))))
 275
 276         (('call-with-values (producer . consumer))
 277          (call-with-values (eval producer env)
 278            (eval consumer env)))
 279
 280         (('apply (f args))
 281          (apply (eval f env) (eval args env)))
 282
 283         (('module-ref var-or-spec)
 284          (variable-ref
 285           (if (variable? var-or-spec)
 286               var-or-spec
 287               (memoize-variable-access! exp #f))))
 288
 289         (('define (name . x))
 290          (define! name (eval x env)))
 291
 292         (('toplevel-set! (var-or-sym . x))
 293          (variable-set!
 294           (if (variable? var-or-sym)
 295               var-or-sym
 296               (let lp ((env env))
 297                 (if (pair? env)
 298                     (lp (cdr env))
 299                     (memoize-variable-access! exp (capture-env env)))))
 300           (eval x env)))
 301
 302         (('dynwind (in exp . out))
 303          (dynamic-wind (eval in env)
 304                        (lambda () (eval exp env))
 305                        (eval out env)))
 306
 307         (('with-fluids (fluids vals . exp))
 308          (let* ((fluids (map (lambda (x) (eval x env)) fluids))
 309                 (vals (map (lambda (x) (eval x env)) vals)))
 310            (let lp ((fluids fluids) (vals vals))
 311              (if (null? fluids)
 312                  (eval exp env)
 313                  (with-fluids (((car fluids) (car vals)))
 314                    (lp (cdr fluids) (cdr vals)))))))
 315
 316         (('prompt (tag exp . handler))
 317          (@prompt (eval tag env)
 318                   (eval exp env)
 319                   (eval handler env)))
 320
 321         (('call/cc proc)
 322          (call/cc (eval proc env)))
 323
 324         (('module-set! (x . var-or-spec))
 325          (variable-set!
 326           (if (variable? var-or-spec)
 327               var-or-spec
 328               (memoize-variable-access! exp #f))
 329           (eval x env)))))
 330
 331     ;; primitive-eval
 332     (lambda (exp)
 333       "Evaluate @var{exp} in the current module."
 334       (eval
 335        (if (memoized? exp)
 336            exp
 337            ((module-transformer (current-module)) exp))
 338        '()))))