summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Andreas Benkard <code@mail.matthias.benkard.de>2013-07-15 15:12:47 +0200
committerMatthias Andreas Benkard <code@mail.matthias.benkard.de>2013-07-15 15:12:47 +0200
commita2f6a616c648a4cd21908d582d001675ef7ad49e (patch)
treeb968e4bef1481966b0a48fdcb37a7d52da1169fd
parentd3146c8ace90aee2564c7ccc146f0128f5bad5e8 (diff)
parentba4403aa5be2a280ee67842d71753933ed8e1be0 (diff)
Merge branch 'master' into stack
Conflicts: sb-eval2.lisp
-rw-r--r--sb-eval2.lisp79
1 files changed, 49 insertions, 30 deletions
diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 61aafae..f5c3ad8 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -5,8 +5,8 @@
(in-package "SB-EVAL2")
-#+(or)
-(setq SB-EXT:*EVALUATOR-MODE* :interpret)
+;;(declaim (optimize (debug 3) (space 0) (speed 0) (safety 3) (compilation-speed 0)))
+(declaim (optimize (debug 0) (space 0) (speed 3) (safety 0) (compilation-speed 0)))
(defvar *stack*)
(defvar *fp*)
@@ -94,10 +94,6 @@
(t
nil)))
-(defstruct (box (:constructor make-box (value)))
- value)
-(defun unbox (box) (box-value box))
-
(defstruct (context (:constructor make-context (&optional parent)))
parent
(env-hop nil :type boolean)
@@ -460,30 +456,53 @@
(declare (ignorable required optional restp rest keyp keys allowp auxp aux
morep more-context more-count))
(let* ((argvars lambda-list) ;fixme
- (n (length (the list lambda-list))))
- (if (maybe-closes-over-p `(progn ,@body) argvars)
- (let* ((new-context (context-add-env-lexicals context argvars))
- (body* (prepare-progn body new-context)))
- (lambda (env)
- (lambda (&rest args)
- (declare (dynamic-extent args))
- ;; FIXME: non-simple lambda-lists
- (let ((new-env (make-environment env n)))
- (loop for i from 0 to n
- for val in args
- do (setf (environment-value new-env 0 i) val))
- (funcall body* new-env)))))
- (let* ((new-context (context-add-stack-lexicals context argvars))
- (body* (prepare-progn body new-context)))
- (lambda (env)
- (lambda (&rest args)
- (declare (dynamic-extent args))
- ;; FIXME: non-simple lambda-lists
- (with-stack-frame n
- (loop for i from 0 below n
- for val in args
- do (setf (stack-ref 0 i) val))
- (funcall body* env))))))))))
+ (n (length (the list lambda-list)))
+ (envp (maybe-closes-over-p `(progn ,@body) argvars))
+ (new-context (if envp
+ (context-add-env-lexicals context argvars)
+ (context-add-stack-lexicals context argvars)))
+ (body* (prepare-progn body new-context)))
+ (if (< n 20)
+ (specialize m% n (loop for i from 0 below 20 collect i)
+ (let ((args (loop for i from 0 below m%
+ collect (gensym (format nil "ARG~D-" i)))))
+ `(if envp
+ (lambda (env)
+ (lambda ,args
+ ;; FIXME: non-simple lambda-lists
+ (let ((new-env (make-environment env ,m%)))
+ ,@(loop for i from 0
+ for val in args
+ collect `(setf (environment-value new-env 0 ,i) ,val))
+ (funcall body* new-env))))
+ (lambda (env)
+ (lambda ,args
+ ;; FIXME: non-simple lambda-lists
+ (with-stack-frame ,m%
+ ,@(loop for i from 0
+ for val in args
+ collect `(setf (stack-ref 0 ,i) ,val))
+ (funcall body* env)))))))
+ (if envp
+ (lambda (env)
+ (lambda (&rest args)
+ (declare (dynamic-extent args))
+ ;; FIXME: non-simple lambda-lists
+ (let ((new-env (make-environment env n)))
+ (loop for i from 0 to n
+ for val in args
+ do (setf (environment-value new-env 0 i) val))
+ (funcall body* new-env))))
+ (lambda (env)
+ (lambda (&rest args)
+ (declare (dynamic-extent args))
+ ;; FIXME: non-simple lambda-lists
+ (with-stack-frame n
+ (loop for i from 0 below n
+ for val in args
+ do (setf (stack-ref 0 i) val))
+ (funcall body* env))))))))))
+
(defun context->native-environment (context)
;;FIXME