Minor evaluator tweaks

[bpt/guile.git] / module / ice-9 / eval.scm

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

;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 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
;;;;

\f

;;; 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:

\f

(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 else)
        ((_ mx data tag)
         #'(error "what" mx))
        ((_ mx data tag (else body))
         #'body)
        ((_ 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.

    ;; 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 ninits unbound
                                  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)))
                    (ninits (if tail (caddr tail) 0))
                    (unbound (and tail (cadddr tail)))
                    (alt (and tail (car (cddddr tail)))))
               (make-general-closure env body nreq rest nopt kw ninits unbound
                                     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 (car (cddddr 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) ninits))
                    (env (make-env nvals unbound 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))
                     (cond
                      ((and (< i (+ nreq nopt)) (< i nargs))
                       (env-set! env 0 i (car args))
                       (lp (1+ i) (cdr args)))
                      (else
                       (when rest?
                         (env-set! env 0 (+ nreq nopt) args))
                       (eval body env)))))
                  (else
                   ;; Optional args.  As before, but stop at the first
                   ;; keyword.
                   (let lp ((i i) (args args))
                     (cond
                      ((and (< i (+ nreq nopt))
                            (< i nargs)
                            (not (keyword? (car args))))
                       (env-set! env 0 i (car args))
                       (lp (1+ i) (cdr args)))
                      (else
                       (when rest?
                         (env-set! env 0 (+ nreq nopt) args))
                       (let ((aok (car kw))
                             (kw (cdr kw)))
                         ;; 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
                             ;; 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)))
        
        (('box-ref box)
         (memoized-expression-case box
           ;; Accelerate common cases.
           (('resolve var-or-loc)
            (if (variable? var-or-loc)
                (variable-ref var-or-loc)
                (variable-ref (eval box env))))
           (('lexical-ref (depth . width))
            (variable-ref (env-ref env depth width)))
           (else
            (variable-ref (eval box env)))))

        (('resolve var-or-loc)
         (if (variable? var-or-loc)
             var-or-loc
             (let ((var (%resolve-variable var-or-loc (env-toplevel env))))
               (set-cdr! exp var)
               var)))

        (('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)
                    (mx-bind
                     tail (rest? . tail)
                     (if (null? tail)
                         (make-rest-closure eval nreq body env)
                         (mx-bind
                          tail (nopt kw ninits unbound alt)
                          (make-general-closure env body nreq rest?
                                                nopt kw ninits unbound
                                                alt)))))))
           (let lp ((meta meta))
             (unless (null? meta)
               (set-procedure-property! proc (caar meta) (cdar meta))
               (lp (cdr meta))))
           proc))

        (('capture-env (locs . body))
         (let* ((len (vector-length locs))
                (new-env (make-env len #f (env-toplevel env))))
           (let lp ((n 0))
             (when (< n len)
               (mx-bind
                (vector-ref locs n) (depth . width)
                (env-set! new-env 0 n (env-ref env depth width)))
               (lp (1+ n))))
           (eval body new-env)))

        (('seq (head . tail))
         (begin
           (eval head env)
           (eval tail env)))
        
        (('box-set! (box . val))
         (variable-set! (eval box env) (eval val 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)))

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

        (('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)))))
  
    ;; primitive-eval
    (lambda (exp)
      "Evaluate @var{exp} in the current module."
      (eval 
       (memoize-expression 
        (if (macroexpanded? exp)
            exp
            ((module-transformer (current-module)) exp)))
       #f))))