diff options
Diffstat (limited to 'sb-eval2.lisp')
| -rw-r--r-- | sb-eval2.lisp | 58 |
1 files changed, 47 insertions, 11 deletions
diff --git a/sb-eval2.lisp b/sb-eval2.lisp index 0567318..7fb09b2 100644 --- a/sb-eval2.lisp +++ b/sb-eval2.lisp @@ -170,27 +170,63 @@ (defun prepare-nil () (lambda (env) (declare (ignore env)))) +(defmacro specialize (&environment env var value possible-values &body body) + `(ecase ,value + ,@(loop for x in (sb-int:eval-in-lexenv possible-values env) + collect + `((,x) ,(sb-int:eval-in-lexenv `(let ((,var ,x)) ,@body) env))))) + (declaim (ftype (function ((or symbol list) list context) eval-closure) prepare-local-call)) (defun prepare-local-call (f args context) (let* ((args* (mapcar (lambda (form) (prepare-form form context)) args)) (flex (context-find-function context f)) (offset (lexical-offset flex)) (nesting (lexical-nesting flex))) - (lambda (env) - (apply (the function (environment-value env nesting offset)) - (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*))))) + (if (< (length args) 20) + (specialize m% (length args) (loop for i from 0 below 20 collect i) + (let ((argvars (loop for i from 0 below m% + collect (gensym (format nil "ARG~D-" i))))) + `(let ,(loop for var in argvars + for i from 0 below m% + collect `(,var (nth ,i args*))) + (lambda (env) + (funcall (the function (environment-value env nesting offset)) + ,@(loop for var in argvars + collect `(funcall (the eval-closure ,var) env))))))) + (lambda (env) + (apply (the function (environment-value env nesting offset)) + (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*)))))) (declaim (ftype (function ((or symbol list) list context) eval-closure) prepare-global-call)) (defun prepare-global-call (f args context) (let ((args* (mapcar (lambda (form) (prepare-form form context)) args))) - (if (fboundp f) - (let ((f* (fdefinition f))) - (lambda (env) - (apply f* - (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*)))) - (lambda (env) - (apply (fdefinition f) - (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*)))))) + (if (< (length args) 20) + (specialize m% (length args) (loop for i from 0 below 20 collect i) + (let ((argvars (loop for i from 0 below m% + collect (gensym (format nil "ARG~D-" i))))) + `(let ,(loop for var in argvars + for i from 0 below m% + collect `(,var (nth ,i args*))) + (if (fboundp f) + (let ((f* (fdefinition f))) + (lambda (env) + (declare (ignorable env)) + (funcall f* + ,@(loop for var in argvars + collect `(funcall (the eval-closure ,var) env))))) + (lambda (env) + (declare (ignorable env)) + (funcall (fdefinition f) + ,@(loop for var in argvars + collect `(funcall (the eval-closure ,var) env)))))))) + (if (fboundp f) + (let ((f* (fdefinition f))) + (lambda (env) + (apply f* + (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*)))) + (lambda (env) + (apply (fdefinition f) + (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*))))))) (declaim (ftype (function (eval-closure list context) eval-closure) prepare-direct-call)) (defun prepare-direct-call (f args context) |