guile/module/ice-9/eval.scm

;;; -*- mode: scheme; coding: utf-8; -*-

;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;



;;; Commentary:

;;; Scheme eval, written in Scheme.
;;;
;;; Expressions are first expanded, by the syntax expander (i.e.
;;; psyntax), then memoized into internal forms. The evaluator itself
;;; only operates on the internal forms ("memoized expressions").
;;;
;;; Environments are represented as linked lists of the form (VAL ... .
;;; MOD). If MOD is #f, it means the environment was captured before
;;; modules were booted. If MOD is the literal value '(), we are
;;; evaluating at the top level, and so should track changes to the
;;; current module.
;;;
;;; Evaluate this in Emacs to make code indentation work right:
;;;
;;;    (put 'memoized-expression-case 'scheme-indent-function 1)
;;;

;;; Code:



(eval-when (compile)
  (define-syntax env-toplevel
    (syntax-rules ()
      ((_ env)
       (let lp ((e env))
         (if (vector? e)
             (lp (vector-ref e 0))
             e)))))

  (define-syntax make-env
    (syntax-rules ()
      ((_ n init next)
       (let ((v (make-vector (1+ n) init)))
         (vector-set! v 0 next)
         v))))

  (define-syntax make-env*
    (syntax-rules ()
      ((_ next init ...)
       (vector next init ...))))

  (define-syntax env-ref
    (syntax-rules ()
      ((_ env depth width)
       (let lp ((e env) (d depth))
         (if (zero? d)
             (vector-ref e (1+ width))
             (lp (vector-ref e 0) (1- d)))))))

  (define-syntax env-set!
    (syntax-rules ()
      ((_ env depth width val)
       (let lp ((e env) (d depth))
         (if (zero? d)
             (vector-set! e (1+ width) val)
             (lp (vector-ref e 0) (1- d)))))))

  ;; For evaluating the initializers in a "let" expression.  We have to
  ;; evaluate the initializers before creating the environment rib, to
  ;; prevent continuation-related shenanigans; see
  ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time for a
  ;; deeper discussion.
  ;;
  ;; This macro will inline evaluation of the first N initializers.
  ;; That number N is indicated by the number of template arguments
  ;; passed to the macro.  It's a bit nasty but it's flexible and
  ;; optimizes well.
  (define-syntax let-env-evaluator
    (syntax-rules ()
      ((eval-and-make-env eval env (template ...))
       (let ()
         (define-syntax eval-and-make-env
           (syntax-rules ()
             ((eval-and-make-env inits width (template ...) k)
              (let lp ((n (length '(template ...))) (vals '()))
                (if (eqv? n width)
                    (let ((env (make-env n #f env)))
                      (let lp ((n (1- n)) (vals vals))
                        (if (null? vals)
                            (k env)
                            (begin
                              (env-set! env 0 n (car vals))
                              (lp (1- n) (cdr vals))))))
                    (lp (1+ n)
                        (cons (eval (vector-ref inits n) env) vals)))))
             ((eval-and-make-env inits width (var (... ...)) k)
              (let ((n (length '(var (... ...)))))
                (if (eqv? n width)
                    (k (make-env n #f env))
                    (let* ((x (eval (vector-ref inits n) env))
                           (k (lambda (env)
                                (env-set! env 0 n x)
                                (k env))))
                      (eval-and-make-env inits width (x var (... ...)) k)))))))
         (lambda (inits)
           (let ((width (vector-length inits))
                 (k (lambda (env) env)))
             (eval-and-make-env inits width () k)))))))

  ;; Fast case for procedures with fixed arities.
  (define-syntax make-fixed-closure
    (lambda (x)
      (define *max-static-argument-count* 8)
      (define (make-formals n)
        (map (lambda (i)
               (datum->syntax
                x
                (string->symbol
                 (string (integer->char (+ (char->integer #\a) i))))))
             (iota n)))
      (syntax-case x ()
        ((_ eval nreq body env) (not (identifier? #'env))
         #'(let ((e env))
             (make-fixed-closure eval nreq body e)))
        ((_ eval nreq body env)
         #`(case nreq
             #,@(map (lambda (nreq)
                       (let ((formals (make-formals nreq)))
                         #`((#,nreq)
                            (lambda (#,@formals)
                              (eval body
                                    (make-env* env #,@formals))))))
                     (iota *max-static-argument-count*))
             (else
              #,(let ((formals (make-formals *max-static-argument-count*)))
                  #`(lambda (#,@formals . more)
                      (let ((env (make-env nreq #f env)))
                        #,@(map (lambda (formal n)
                                  #`(env-set! env 0 #,n #,formal))
                                formals (iota (length formals)))
                        (let lp ((i #,*max-static-argument-count*)
                                 (args more))
                          (cond
                           ((= i nreq)
                            (eval body
                                  (if (null? args)
                                      env
                                      (scm-error 'wrong-number-of-args
                                                 "eval" "Wrong number of arguments"
                                                 '() #f))))
                           ((null? args)
                            (scm-error 'wrong-number-of-args
                                       "eval" "Wrong number of arguments"
                                       '() #f))
                           (else
                            (env-set! env 0 i (car args))
                            (lp (1+ i) (cdr args))))))))))))))

  ;; Fast case for procedures with fixed arities and a rest argument.
  (define-syntax make-rest-closure
    (lambda (x)
      (define *max-static-argument-count* 3)
      (define (make-formals n)
        (map (lambda (i)
               (datum->syntax
                x
                (string->symbol
                 (string (integer->char (+ (char->integer #\a) i))))))
             (iota n)))
      (syntax-case x ()
        ((_ eval nreq body env) (not (identifier? #'env))
         #'(let ((e env))
             (make-rest-closure eval nreq body e)))
        ((_ eval nreq body env)
         #`(case nreq
             #,@(map (lambda (nreq)
                       (let ((formals (make-formals nreq)))
                         #`((#,nreq)
                            (lambda (#,@formals . rest)
                              (eval body
                                    (make-env* env #,@formals rest))))))
                     (iota *max-static-argument-count*))
             (else
              #,(let ((formals (make-formals *max-static-argument-count*)))
                  #`(lambda (#,@formals . more)
                      (let ((env (make-env (1+ nreq) #f env)))
                        #,@(map (lambda (formal n)
                                  #`(env-set! env 0 #,n #,formal))
                                formals (iota (length formals)))
                        (let lp ((i #,*max-static-argument-count*)
                                 (args more))
                          (cond
                           ((= i nreq)
                            (env-set! env 0 nreq args)
                            (eval body env))
                           ((null? args)
                            (scm-error 'wrong-number-of-args
                                       "eval" "Wrong number of arguments"
                                       '() #f))
                           (else
                            (env-set! env 0 i (car args))
                            (lp (1+ i) (cdr args))))))))))))))

  (define-syntax call
    (lambda (x)
      (define *max-static-call-count* 4)
      (syntax-case x ()
        ((_ eval proc nargs args env) (identifier? #'env)
         #`(case nargs
             #,@(map (lambda (nargs)
                       #`((#,nargs)
                          (proc
                           #,@(map
                               (lambda (n)
                                 (let lp ((n n) (args #'args))
                                   (if (zero? n)
                                       #`(eval (car #,args) env)
                                       (lp (1- n) #`(cdr #,args)))))
                               (iota nargs)))))
                     (iota *max-static-call-count*))
             (else
              (apply proc
                     #,@(map
                         (lambda (n)
                           (let lp ((n n) (args #'args))
                             (if (zero? n)
                                 #`(eval (car #,args) env)
                                 (lp (1- n) #`(cdr #,args)))))
                         (iota *max-static-call-count*))
                     (let lp ((exps #,(let lp ((n *max-static-call-count*)
                                               (args #'args))
                                        (if (zero? n)
                                            args
                                            (lp (1- n) #`(cdr #,args)))))
                              (args '()))
                       (if (null? exps)
                           (reverse args)
                           (lp (cdr exps)
                               (cons (eval (car exps) env) args)))))))))))

  ;; This macro could be more straightforward if the compiler had better
  ;; copy propagation. As it is we do some copy propagation by hand.
  (define-syntax mx-bind
    (lambda (x)
      (syntax-case x ()
        ((_ data () body)
         #'body)
        ((_ data (a . b) body) (and (identifier? #'a) (identifier? #'b))
         #'(let ((a (car data))
                 (b (cdr data)))
             body))
        ((_ data (a . b) body) (identifier? #'a)
         #'(let ((a (car data))
                 (xb (cdr data)))
             (mx-bind xb b body)))
        ((_ data (a . b) body) 
         #'(let ((xa (car data))
                 (xb (cdr data)))
             (mx-bind xa a (mx-bind xb b body))))
        ((_ data v body) (identifier? #'v)
         #'(let ((v data))
             body)))))
  
  ;; The resulting nested if statements will be an O(n) dispatch. Once
  ;; we compile `case' effectively, this situation will improve.
  (define-syntax mx-match
    (lambda (x)
      (syntax-case x (quote)
        ((_ mx data tag)
         #'(error "what" mx))
        ((_ mx data tag (('type pat) body) c* ...)
         #`(if (eqv? tag #,(or (memoized-typecode (syntax->datum #'type))
                               (error "not a typecode" #'type)))
               (mx-bind data pat body)
               (mx-match mx data tag c* ...))))))

  (define-syntax memoized-expression-case
    (lambda (x)
      (syntax-case x ()
        ((_ mx c ...)
         #'(let ((tag (car mx))
                 (data (cdr mx)))
             (mx-match mx data tag c ...)))))))


;;;
;;; On 18 Feb 2010, I did a profile of how often the various memoized expression
;;; types occur when getting to a prompt on a fresh build. Here are the numbers
;;; I got:
;;;
;;;      lexical-ref: 32933054
;;;             call: 20281547
;;;     toplevel-ref: 13228724
;;;               if: 9156156
;;;            quote: 6610137
;;;              let: 2619707
;;;           lambda: 1010921
;;;            begin: 948945
;;;      lexical-set: 509862
;;; call-with-values: 139668
;;;            apply: 49402
;;;       module-ref: 14468
;;;           define: 1259
;;;     toplevel-set: 328
;;;          call/cc: 0
;;;       module-set: 0
;;;
;;; So until we compile `case' into a computed goto, we'll order the clauses in
;;; `eval' in this order, to put the most frequent cases first.
;;;

(define primitive-eval
  (let ()
    ;; We pre-generate procedures with fixed arities, up to some number
    ;; of arguments, and some rest arities; see make-fixed-closure and
    ;; make-rest-closure above.

    ;; A unique marker for unbound keywords.
    (define unbound-arg (list 'unbound-arg))

    ;; Procedures with rest, optional, or keyword arguments, potentially with
    ;; multiple arities, as with case-lambda.
    (define (make-general-closure env body nreq rest? nopt kw inits alt)
      (define alt-proc
        (and alt                        ; (body meta nreq ...)
             (let* ((body (car alt))
                    (spec (cddr alt))
                    (nreq (car spec))
                    (rest (if (null? (cdr spec)) #f (cadr spec)))
                    (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
                    (nopt (if tail (car tail) 0))
                    (kw (and tail (cadr tail)))
                    (inits (if tail (caddr tail) '()))
                    (alt (and tail (cadddr tail))))
               (make-general-closure env body nreq rest nopt kw inits alt))))
      (define (set-procedure-arity! proc)
        (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
          (if (not alt)
              (begin
                (set-procedure-property! proc 'arglist
                                         (list nreq
                                               nopt
                                               (if kw (cdr kw) '())
                                               (and kw (car kw))
                                               (and rest? '_)))
                (set-procedure-minimum-arity! proc nreq nopt rest?))
              (let* ((spec (cddr alt))
                     (nreq* (car spec))
                     (rest?* (if (null? (cdr spec)) #f (cadr spec)))
                     (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
                     (nopt* (if tail (car tail) 0))
                     (alt* (and tail (cadddr tail))))
                (if (or (< nreq* nreq)
                        (and (= nreq* nreq)
                             (if rest?
                                 (and rest?* (> nopt* nopt))
                                 (or rest?* (> nopt* nopt)))))
                    (lp alt* nreq* nopt* rest?*)
                    (lp alt* nreq nopt rest?)))))
        proc)
      (set-procedure-arity!
       (lambda %args
         (define (npositional args)
           (let lp ((n 0) (args args))
             (if (or (null? args)
                     (and (>= n nreq) (keyword? (car args))))
                 n
                 (lp (1+ n) (cdr args)))))
         (let ((nargs (length %args)))
           (cond
            ((or (< nargs nreq)
                 (and (not kw) (not rest?) (> nargs (+ nreq nopt)))
                 (and alt kw (not rest?) (> (npositional %args) (+ nreq nopt))))
             (if alt
                 (apply alt-proc %args)
                 ((scm-error 'wrong-number-of-args
                             "eval" "Wrong number of arguments"
                             '() #f))))
            (else
             (let* ((nvals (+ nreq (if rest? 1 0) (length inits)))
                    (env (make-env nvals unbound-arg env)))
               (let lp ((i 0) (args %args))
                 (cond
                  ((< i nreq)
                   ;; Bind required arguments.
                   (env-set! env 0 i (car args))
                   (lp (1+ i) (cdr args)))
                  ((not kw)
                   ;; Optional args (possibly), but no keyword args.
                   (let lp ((i i) (args args) (inits inits))
                     (cond
                      ((< i (+ nreq nopt))
                       (cond
                        ((< i nargs)
                         (env-set! env 0 i (car args))
                         (lp (1+ i) (cdr args) (cdr inits)))
                        (else
                         (env-set! env 0 i (eval (car inits) env))
                         (lp (1+ i) args (cdr inits)))))
                      (else
                       (when rest?
                         (env-set! env 0 i args))
                       (eval body env)))))
                  (else
                   ;; Optional args.  As before, but stop at the first
                   ;; keyword.
                   (let lp ((i i) (args args) (inits inits))
                     (cond
                      ((< i (+ nreq nopt))
                       (cond
                        ((and (< i nargs) (not (keyword? (car args))))
                         (env-set! env 0 i (car args))
                         (lp (1+ i) (cdr args) (cdr inits)))
                        (else
                         (env-set! env 0 i (eval (car inits) env))
                         (lp (1+ i) args (cdr inits)))))
                      (else
                       (when rest?
                         (env-set! env 0 i args))
                       (let ((aok (car kw))
                             (kw (cdr kw))
                             (kw-base (if rest? (1+ i) i)))
                         ;; Now scan args for keywords.
                         (let lp ((args args))
                           (cond
                            ((and (pair? args) (pair? (cdr args))
                                  (keyword? (car args)))
                             (let ((kw-pair (assq (car args) kw))
                                   (v (cadr args)))
                               (if kw-pair
                                   ;; Found a known keyword; set its value.
                                   (env-set! env 0 (cdr kw-pair) v)
                                   ;; Unknown keyword.
                                   (if (not aok)
                                       ((scm-error
                                         'keyword-argument-error
                                         "eval" "Unrecognized keyword"
                                         '() (list (car args))))))
                               (lp (cddr args))))
                            ((pair? args)
                             (if rest?
                                 ;; Be lenient parsing rest args.
                                 (lp (cdr args))
                                 ((scm-error 'keyword-argument-error
                                             "eval" "Invalid keyword"
                                             '() (list (car args))))))
                            (else
                             ;; Finished parsing keywords. Fill in
                             ;; uninitialized kwargs by evalling init
                             ;; expressions in their appropriate
                             ;; environment.
                             (let lp ((i kw-base) (inits inits))
                               (cond
                                ((pair? inits)
                                 (when (eq? (env-ref env 0 i) unbound-arg)
                                   (env-set! env 0 i (eval (car inits) env)))
                                 (lp (1+ i) (cdr inits)))
                                (else
                                 ;; Finally, eval the body.
                                 (eval body env)))))))))))))))))))))

    ;; The "engine". EXP is a memoized expression.
    (define (eval exp env)
      (memoized-expression-case exp
        (('lexical-ref (depth . width))
         (env-ref env depth width))
        
        (('call (f nargs . args))
         (let ((proc (eval f env)))
           (call eval proc nargs args env)))
        
        (('toplevel-ref var-or-sym)
         (variable-ref
          (if (variable? var-or-sym)
              var-or-sym
              (memoize-variable-access! exp (env-toplevel env)))))

        (('if (test consequent . alternate))
         (if (eval test env)
             (eval consequent env)
             (eval alternate env)))
      
        (('quote x)
         x)

        (('let (inits . body))
         (eval body ((let-env-evaluator eval env (_ _ _ _)) inits)))

        (('lambda (body meta nreq . tail))
         (let ((proc
                (if (null? tail)
                    (make-fixed-closure eval nreq body env)
                    (if (null? (cdr tail))
                        (make-rest-closure eval nreq body env)
                        (apply make-general-closure env body nreq tail)))))
           (let lp ((meta meta))
             (unless (null? meta)
               (set-procedure-property! proc (caar meta) (cdar meta))
               (lp (cdr meta))))
           proc))

        (('seq (head . tail))
         (begin
           (eval head env)
           (eval tail env)))
        
        (('lexical-set! ((depth . width) . x))
         (env-set! env depth width (eval x env)))
        
        (('call-with-values (producer . consumer))
         (call-with-values (eval producer env)
           (eval consumer env)))

        (('apply (f args))
         (apply (eval f env) (eval args env)))

        (('module-ref var-or-spec)
         (variable-ref
          (if (variable? var-or-spec)
              var-or-spec
              (memoize-variable-access! exp #f))))

        (('define (name . x))
         (begin
           (define! name (eval x env))
           (if #f #f)))

        (('capture-module x)
         (eval x (current-module)))

        (('toplevel-set! (var-or-sym . x))
         (variable-set!
          (if (variable? var-or-sym)
              var-or-sym
              (memoize-variable-access! exp (env-toplevel env)))
          (eval x env)))
      
        (('call-with-prompt (tag thunk . handler))
         (call-with-prompt
          (eval tag env)
          (eval thunk env)
          (eval handler env)))
        
        (('call/cc proc)
         (call/cc (eval proc env)))

        (('module-set! (x . var-or-spec))
         (variable-set!
          (if (variable? var-or-spec)
              var-or-spec
              (memoize-variable-access! exp #f))
          (eval x env)))))
  
    ;; primitive-eval
    (lambda (exp)
      "Evaluate @var{exp} in the current module."
      (eval 
       (memoize-expression 
        (if (macroexpanded? exp)
            exp
            ((module-transformer (current-module)) exp)))
       #f))))