;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015 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
(expand-pattern v pat (let () e0 e ...) (fk))))))
(define-syntax expand-pattern
- (syntax-rules (_ quote unquote)
+ (syntax-rules (_ quote unquote ?)
((_ v _ kt kf) kt)
((_ v () kt kf) (if (null? v) kt kf))
((_ v (quote lit) kt kf)
(let ((vx (car v)) (vy (cdr v)))
(expand-pattern vx x (expand-pattern vy y kt kf) kf))
kf))
+ ((_ v (? pred var) kt kf)
+ (if (pred v) (let ((var v)) kt) kf))
((_ v #f kt kf) (if (eqv? v #f) kt kf))
((_ v var kt kf) (let ((var v)) kt))))
(or (memoized-typecode (syntax->datum #'type))
(error "not a typecode" (syntax->datum #'type)))))))
+ (define-syntax-rule (lazy (arg ...) exp)
+ (letrec ((proc (lambda (arg ...)
+ (set! proc exp)
+ (proc arg ...))))
+ (lambda (arg ...)
+ (proc arg ...))))
+
(define (compile-lexical-ref depth width)
(lambda (env)
(env-ref env depth width)))
- (define (compile-call f nargs args)
- (let ((f (compile f)))
+ (define (primitive=? name loc module var)
+ "Return true if VAR is the same as the primitive bound to NAME."
+ (match loc
+ ((mode . loc)
+ (and (match loc
+ ((mod name* . public?) (eq? name* name))
+ (_ (eq? loc name)))
+ ;; `module' can be #f if the module system was not yet
+ ;; booted when the environment was captured.
+ (or (not module)
+ (eq? var (module-local-variable the-root-module name)))))))
+
+ (define (compile-top-call cenv loc args)
+ (let* ((module (env-toplevel cenv))
+ (var (%resolve-variable loc module)))
+ (define-syntax-rule (maybe-primcall (prim ...) arg ...)
+ (let ((arg (compile arg))
+ ...)
+ (cond
+ ((primitive=? 'prim loc module var)
+ (lambda (env) (prim (arg env) ...)))
+ ...
+ (else (lambda (env) ((variable-ref var) (arg env) ...))))))
(match args
- (() (lambda (env) ((f env))))
+ (()
+ (lambda (env) ((variable-ref var))))
((a)
- (let ((a (compile a)))
- (lambda (env) ((f env) (a env)))))
+ (maybe-primcall (1+ 1- car cdr lognot vector-length
+ variable-ref string-length struct-vtable)
+ a))
((a b)
- (let ((a (compile a))
- (b (compile b)))
- (lambda (env) ((f env) (a env) (b env)))))
+ (maybe-primcall (+ - * / ash logand logior logxor
+ cons vector-ref struct-ref allocate-struct variable-set!)
+ a b))
((a b c)
- (let ((a (compile a))
- (b (compile b))
- (c (compile c)))
- (lambda (env) ((f env) (a env) (b env) (c env)))))
+ (maybe-primcall (vector-set! struct-set!) a b c))
((a b c . args)
(let ((a (compile a))
(b (compile b))
'()
(cons (compile (car args)) (lp (cdr args)))))))
(lambda (env)
- (apply (f env) (a env) (b env) (c env)
+ (apply (variable-ref var) (a env) (b env) (c env)
(let lp ((args args))
(if (null? args)
'()
(cons ((car args) env) (lp (cdr args))))))))))))
+ (define (compile-call f args)
+ (match f
+ ((,(typecode box-ref) . (,(typecode resolve) . loc))
+ (lazy (env) (compile-top-call env loc args)))
+ (_
+ (match args
+ (()
+ (let ((f (compile f)))
+ (lambda (env) ((f env)))))
+ ((a)
+ (let ((f (compile f))
+ (a (compile a)))
+ (lambda (env) ((f env) (a env)))))
+ ((a b)
+ (let ((f (compile f))
+ (a (compile a))
+ (b (compile b)))
+ (lambda (env) ((f env) (a env) (b env)))))
+ ((a b c)
+ (let ((f (compile f))
+ (a (compile a))
+ (b (compile b))
+ (c (compile c)))
+ (lambda (env) ((f env) (a env) (b env) (c env)))))
+ ((a b c . args)
+ (let ((f (compile f))
+ (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 resolve) . loc)
+ (lazy (cenv)
+ (let ((var (%resolve-variable loc (env-toplevel cenv))))
+ (lambda (env) (variable-ref var)))))
((,(typecode lexical-ref) depth . width)
(lambda (env)
(variable-ref (env-ref env depth width))))
(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-resolve cenv loc)
+ (let ((var (%resolve-variable loc (env-toplevel cenv))))
+ (lambda (env) var)))
+
+ (define (compile-top-branch cenv loc args consequent alternate)
+ (let* ((module (env-toplevel cenv))
+ (var (%resolve-variable loc module))
+ (consequent (compile consequent))
+ (alternate (compile alternate)))
+ (define (generic-top-branch)
+ (let ((test (compile-top-call cenv loc args)))
+ (lambda (env)
+ (if (test env) (consequent env) (alternate env)))))
+ (define-syntax-rule (maybe-primcall (prim ...) arg ...)
+ (cond
+ ((primitive=? 'prim loc module var)
+ (let ((arg (compile arg))
+ ...)
+ (lambda (env)
+ (if (prim (arg env) ...)
+ (consequent env)
+ (alternate env)))))
+ ...
+ (else (generic-top-branch))))
+ (match args
+ ((a)
+ (maybe-primcall (null? nil? pair? struct? string? vector? symbol?
+ keyword? variable? bitvector? char? zero? not)
+ a))
+ ((a b)
+ (maybe-primcall (eq? eqv? equal? = < > <= >= logtest logbit?)
+ a b))
+ (_
+ (generic-top-branch)))))
(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)))))
+ (match test
+ ((,(typecode call)
+ (,(typecode box-ref) . (,(typecode resolve) . loc))
+ . args)
+ (lazy (env) (compile-top-branch env loc args 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))
(let ((proc (proc env)))
(set-procedure-property! proc prop val)
proc))))))
- (let ((body (compile body)))
+ (let ((body (lazy (env) (compile body))))
(set-procedure-meta
meta
(match tail
((,(typecode lexical-ref) depth . width)
(compile-lexical-ref depth width))
- ((,(typecode call) f nargs . args)
- (compile-call f nargs args))
+ ((,(typecode call) f . args)
+ (compile-call f args))
((,(typecode box-ref) . box)
(compile-box-ref box))
- ((,(typecode resolve) . var-or-loc)
- (compile-resolve var-or-loc))
+ ((,(typecode resolve) . loc)
+ (lazy (env) (compile-resolve env loc)))
((,(typecode if) test consequent . alternate)
(compile-if test consequent alternate))
((,(typecode call/cc) . proc)
(compile-call/cc proc))))
- (let ((proc (compile
- (memoize-expression
+ (let ((eval (compile
+ (memoize-expression
(if (macroexpanded? exp)
exp
((module-transformer (current-module)) exp)))))
(env #f))
- (proc env)))
+ (eval env)))
HCoop / bpt / guile.git / blobdiff