diff options
-rw-r--r-- | libguile/memoize.c | 2 | ||||
-rw-r--r-- | module/ice-9/eval.scm | 1021 |
2 files changed, 534 insertions, 489 deletions
diff --git a/libguile/memoize.c b/libguile/memoize.c index 88a168fd8..6396d944c 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -574,7 +574,7 @@ memoize (SCM exp, SCM env) SCM_BOOL_F); return MAKMEMO_LAMBDA (memoize (body, new_env), arity, - SCM_BOOL_F /* meta, filled in later */); + SCM_EOL /* meta, filled in later */); } case SCM_EXPANDED_LET: diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index a1398f6d5..84b2147cd 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -27,22 +27,18 @@ ;;; 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) +;;; Environments are represented as a chain of vectors, linked through +;;; their first elements. The terminal element of an environment is the +;;; module that was current when the outer lexical environment was +;;; entered. ;;; ;;; Code: -(eval-when (compile) +(define (primitive-eval exp) + "Evaluate @var{exp} in the current module." (define-syntax env-toplevel (syntax-rules () ((_ env) @@ -79,488 +75,537 @@ (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 + ;; This is a modified version of Oleg Kiselyov's "pmatch". + (define-syntax-rule (match e cs ...) + (let ((v e)) (expand-clauses v cs ...))) + + (define-syntax expand-clauses (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 + ((_ v) ((error "unreachable"))) + ((_ v (pat e0 e ...) cs ...) + (let ((fk (lambda () (expand-clauses v cs ...)))) + (expand-pattern v pat (let () e0 e ...) (fk)))))) + + (define-syntax expand-pattern + (syntax-rules (_ quote unquote) + ((_ v _ kt kf) kt) + ((_ v () kt kf) (if (null? v) kt kf)) + ((_ v (quote lit) kt kf) + (if (equal? v (quote lit)) kt kf)) + ((_ v (unquote exp) kt kf) + (if (equal? v exp) kt kf)) + ((_ v (x . y) kt kf) + (if (pair? v) + (let ((vx (car v)) (vy (cdr v))) + (expand-pattern vx x (expand-pattern vy y kt kf) kf)) + kf)) + ((_ v #f kt kf) (if (eqv? v #f) kt kf)) + ((_ v var kt kf) (let ((var v)) kt)))) + + (define-syntax typecode (lambda (x) (syntax-case x () - ((_ mx c ...) - #'(let ((tag (car mx)) - (data (cdr mx))) - (mx-match mx data tag c ...))))))) + ((_ type) + (or (memoized-typecode (syntax->datum #'type)) + (error "not a typecode" (syntax->datum #'type))))))) + + (define (compile-lexical-ref depth width) + (lambda (env) + (env-ref env depth width))) + + (define (compile-call f nargs args) + (let ((f (compile f))) + (match args + (() (lambda (env) ((f env)))) + ((a) + (let ((a (compile a))) + (lambda (env) ((f env) (a env))))) + ((a b) + (let ((a (compile a)) + (b (compile b))) + (lambda (env) ((f env) (a env) (b env))))) + ((a b c) + (let ((a (compile a)) + (b (compile b)) + (c (compile c))) + (lambda (env) ((f env) (a env) (b env) (c env))))) + ((a b c . args) + (let ((a (compile a)) + (b (compile b)) + (c (compile c)) + (args (let lp ((args args)) + (if (null? args) + '() + (cons (compile (car args)) (lp (cdr args))))))) + (lambda (env) + (apply (f env) (a env) (b env) (c env) + (let lp ((args args)) + (if (null? args) + '() + (cons ((car args) env) (lp (cdr args)))))))))))) + + (define (compile-box-ref box) + (match box + ((,(typecode resolve) . var-or-loc) + (lambda (env) + (cond + ((variable? var-or-loc) (variable-ref var-or-loc)) + (else + (set! var-or-loc + (%resolve-variable var-or-loc (env-toplevel env))) + (variable-ref var-or-loc))))) + ((,(typecode lexical-ref) depth . width) + (lambda (env) + (variable-ref (env-ref env depth width)))) + (_ + (let ((box (compile box))) + (lambda (env) + (variable-ref (box env))))))) + + (define (compile-resolve var-or-loc) + (lambda (env) + (cond + ((variable? var-or-loc) var-or-loc) + (else + (set! var-or-loc (%resolve-variable var-or-loc (env-toplevel env))) + var-or-loc)))) + + (define (compile-if test consequent alternate) + (let ((test (compile test)) + (consequent (compile consequent)) + (alternate (compile alternate))) + (lambda (env) + (if (test env) (consequent env) (alternate env))))) + + (define (compile-quote x) + (lambda (env) x)) + + (define (compile-let inits body) + (let ((body (compile body)) + (width (vector-length inits))) + (case width + ((0) (lambda (env) + (body (make-env* env)))) + ((1) + (let ((a (compile (vector-ref inits 0)))) + (lambda (env) + (body (make-env* env (a env)))))) + ((2) + (let ((a (compile (vector-ref inits 0))) + (b (compile (vector-ref inits 1)))) + (lambda (env) + (body (make-env* env (a env) (b env)))))) + ((3) + (let ((a (compile (vector-ref inits 0))) + (b (compile (vector-ref inits 1))) + (c (compile (vector-ref inits 2)))) + (lambda (env) + (body (make-env* env (a env) (b env) (c env)))))) + ((4) + (let ((a (compile (vector-ref inits 0))) + (b (compile (vector-ref inits 1))) + (c (compile (vector-ref inits 2))) + (d (compile (vector-ref inits 3)))) + (lambda (env) + (body (make-env* env (a env) (b env) (c env) (d env)))))) + (else + (let lp ((n width) + (k (lambda (env) + (make-env width #f env)))) + (if (zero? n) + (lambda (env) + (body (k env))) + (lp (1- n) + (let ((init (compile (vector-ref inits (1- n))))) + (lambda (env) + (let* ((x (init env)) + (new-env (k env))) + (env-set! new-env 0 (1- n) x) + new-env)))))))))) + + (define (compile-fixed-lambda body nreq) + (case nreq + ((0) (lambda (env) + (lambda () + (body (make-env* env))))) + ((1) (lambda (env) + (lambda (a) + (body (make-env* env a))))) + ((2) (lambda (env) + (lambda (a b) + (body (make-env* env a b))))) + ((3) (lambda (env) + (lambda (a b c) + (body (make-env* env a b c))))) + ((4) (lambda (env) + (lambda (a b c d) + (body (make-env* env a b c d))))) + ((5) (lambda (env) + (lambda (a b c d e) + (body (make-env* env a b c d e))))) + ((6) (lambda (env) + (lambda (a b c d e f) + (body (make-env* env a b c d e f))))) + ((7) (lambda (env) + (lambda (a b c d e f g) + (body (make-env* env a b c d e f g))))) + (else + (lambda (env) + (lambda (a b c d e f g . more) + (let ((env (make-env nreq #f env))) + (env-set! env 0 0 a) + (env-set! env 0 1 b) + (env-set! env 0 2 c) + (env-set! env 0 3 d) + (env-set! env 0 4 e) + (env-set! env 0 5 f) + (env-set! env 0 6 g) + (let lp ((n 7) (args more)) + (cond + ((= n nreq) + (unless (null? args) + (scm-error 'wrong-number-of-args + "eval" "Wrong number of arguments" + '() #f)) + (body env)) + ((null? args) + (scm-error 'wrong-number-of-args + "eval" "Wrong number of arguments" + '() #f)) + (else + (env-set! env 0 n (car args)) + (lp (1+ n) (cdr args))))))))))) + + (define (compile-rest-lambda body nreq rest?) + (case nreq + ((0) (lambda (env) + (lambda rest + (body (make-env* env rest))))) + ((1) (lambda (env) + (lambda (a . rest) + (body (make-env* env a rest))))) + ((2) (lambda (env) + (lambda (a b . rest) + (body (make-env* env a b rest))))) + ((3) (lambda (env) + (lambda (a b c . rest) + (body (make-env* env a b c rest))))) + (else + (lambda (env) + (lambda (a b c . more) + (let ((env (make-env (1+ nreq) #f env))) + (env-set! env 0 0 a) + (env-set! env 0 1 b) + (env-set! env 0 2 c) + (let lp ((n 3) (args more)) + (cond + ((= n nreq) + (env-set! env 0 n args) + (body env)) + ((null? args) + (scm-error 'wrong-number-of-args + "eval" "Wrong number of arguments" + '() #f)) + (else + (env-set! env 0 n (car args)) + (lp (1+ n) (cdr args))))))))))) + + (define (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt) + (lambda (env) + (define alt (and make-alt (make-alt env))) + (lambda args + (let ((nargs (length args))) + (cond + ((or (< nargs nreq) (and (not rest?) (> nargs (+ nreq nopt)))) + (if alt + (apply alt 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))) + (define (bind-req args) + (let lp ((i 0) (args args)) + (cond + ((< i nreq) + ;; Bind required arguments. + (env-set! env 0 i (car args)) + (lp (1+ i) (cdr args))) + (else + (bind-opt args))))) + (define (bind-opt args) + (let lp ((i nreq) (args args)) + (cond + ((and (< i (+ nreq nopt)) (< i nargs)) + (env-set! env 0 i (car args)) + (lp (1+ i) (cdr args))) + (else + (bind-rest args))))) + (define (bind-rest args) + (when rest? + (env-set! env 0 (+ nreq nopt) args)) + (body env)) + (bind-req args)))))))) + + (define (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt) + (define allow-other-keys? (car kw)) + (define keywords (cdr kw)) + (lambda (env) + (define alt (and make-alt (make-alt env))) + (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 alt (not rest?) (> (npositional args) (+ nreq nopt)))) + (if alt + (apply alt 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))) + (define (bind-req args) + (let lp ((i 0) (args args)) + (cond + ((< i nreq) + ;; Bind required arguments. + (env-set! env 0 i (car args)) + (lp (1+ i) (cdr args))) + (else + (bind-opt args))))) + (define (bind-opt args) + (let lp ((i nreq) (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 + (bind-rest args))))) + (define (bind-rest args) + (when rest? + (env-set! env 0 (+ nreq nopt) args)) + (bind-kw args)) + (define (bind-kw args) + (let lp ((args args)) + (cond + ((and (pair? args) (pair? (cdr args)) + (keyword? (car args))) + (let ((kw-pair (assq (car args) keywords)) + (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 allow-other-keys?) + ((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 + (body env))))) + (bind-req args)))))))) + + (define (compute-arity alt nreq rest? nopt kw) + (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?)) + (if (not alt) + (let ((arglist (list nreq + nopt + (if kw (cdr kw) '()) + (and kw (car kw)) + (and rest? '_)))) + (values arglist 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?)))))) + + (define (compile-general-lambda body nreq rest? nopt kw ninits unbound alt) + (call-with-values + (lambda () + (compute-arity alt nreq rest? nopt kw)) + (lambda (arglist min-nreq min-nopt min-rest?) + (define make-alt + (match alt + (#f #f) + ((body meta nreq . tail) + (compile-lambda body meta nreq tail)))) + (define make-closure + (if kw + (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt) + (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt))) + (lambda (env) + (let ((proc (make-closure env))) + (set-procedure-property! proc 'arglist arglist) + (set-procedure-minimum-arity! proc min-nreq min-nopt min-rest?) + proc))))) + + (define (compile-lambda body meta nreq tail) + (define (set-procedure-meta meta proc) + (match meta + (() proc) + (((prop . val) . meta) + (set-procedure-meta meta + (lambda (env) + (let ((proc (proc env))) + (set-procedure-property! proc prop val) + proc)))))) + (let ((body (compile body))) + (set-procedure-meta + meta + (match tail + (() (compile-fixed-lambda body nreq)) + ((rest? . tail) + (match tail + (() (compile-rest-lambda body nreq rest?)) + ((nopt kw ninits unbound alt) + (compile-general-lambda body nreq rest? nopt kw + ninits unbound alt)))))))) + + (define (compile-capture-env locs body) + (let ((body (compile body))) + (lambda (env) + (let* ((len (vector-length locs)) + (new-env (make-env len #f (env-toplevel env)))) + (let lp ((n 0)) + (when (< n len) + (match (vector-ref locs n) + ((depth . width) + (env-set! new-env 0 n (env-ref env depth width)))) + (lp (1+ n)))) + (body new-env))))) + + (define (compile-seq head tail) + (let ((head (compile head)) + (tail (compile tail))) + (lambda (env) + (head env) + (tail env)))) + + (define (compile-box-set! box val) + (let ((box (compile box)) + (val (compile val))) + (lambda (env) + (let ((val (val env))) + (variable-set! (box env) val))))) + + (define (compile-lexical-set! depth width x) + (let ((x (compile x))) + (lambda (env) + (env-set! env depth width (x env))))) + + (define (compile-call-with-values producer consumer) + (let ((producer (compile producer)) + (consumer (compile consumer))) + (lambda (env) + (call-with-values (producer env) + (consumer env))))) + + (define (compile-apply f args) + (let ((f (compile f)) + (args (compile args))) + (lambda (env) + (apply (f env) (args env))))) + + (define (compile-capture-module x) + (let ((x (compile x))) + (lambda (env) + (x (current-module))))) + + (define (compile-call-with-prompt tag thunk handler) + (let ((tag (compile tag)) + (thunk (compile thunk)) + (handler (compile handler))) + (lambda (env) + (call-with-prompt (tag env) (thunk env) (handler env))))) + + (define (compile-call/cc proc) + (let ((proc (compile proc))) + (lambda (env) + (call/cc (proc env))))) + + (define (compile exp) + (match exp + ((,(typecode lexical-ref) depth . width) + (compile-lexical-ref depth width)) + + ((,(typecode call) f nargs . args) + (compile-call f nargs args)) + + ((,(typecode box-ref) . box) + (compile-box-ref box)) + ((,(typecode resolve) . var-or-loc) + (compile-resolve var-or-loc)) -;;; -;;; 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. -;;; + ((,(typecode if) test consequent . alternate) + (compile-if test consequent alternate)) -(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))) + ((,(typecode quote) . x) + (compile-quote x)) + + ((,(typecode let) inits . body) + (compile-let inits body)) + + ((,(typecode lambda) body meta nreq . tail) + (compile-lambda body meta nreq tail)) + + ((,(typecode capture-env) locs . body) + (compile-capture-env locs body)) + + ((,(typecode seq) head . tail) + (compile-seq head tail)) + + ((,(typecode box-set!) box . val) + (compile-box-set! box val)) + + ((,(typecode lexical-set!) (depth . width) . x) + (compile-lexical-set! depth width x)) + + ((,(typecode call-with-values) producer . consumer) + (compile-call-with-values producer consumer)) + + ((,(typecode apply) f args) + (compile-apply f args)) + + ((,(typecode capture-module) . x) + (compile-capture-module x)) + + ((,(typecode call-with-prompt) tag thunk . handler) + (compile-call-with-prompt tag thunk handler)) - (('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)))) + ((,(typecode call/cc) . proc) + (compile-call/cc proc)))) + + (let ((proc (compile + (memoize-expression + (if (macroexpanded? exp) + exp + ((module-transformer (current-module)) exp))))) + (env #f)) + (proc env))) |