summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Andreas Benkard <code@mail.matthias.benkard.de>2013-07-16 18:07:19 +0200
committerMatthias Andreas Benkard <code@mail.matthias.benkard.de>2013-07-16 18:07:19 +0200
commit7d80fddca07fda51e3400e8b4dd917e96c4a8b71 (patch)
tree6442a56a4a667e87418b11bbe8c5019e2a438e48
parent68f5f71d4a787dc0a1662d16121db7f40eb8c09c (diff)
PREPARE-LAMBDA: Stack-allocate environments instead of managing a stack.
-rw-r--r--sb-eval2.lisp44
1 files changed, 31 insertions, 13 deletions
diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index ec15ef9..f153590 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -21,15 +21,34 @@
(deftype stack ()
'simple-vector)
-(defstruct (environment (:constructor make-environment (parent
- &optional (size 0)
- &aux (data
- (make-array
- (list size))))))
+(declaim (inline %make-environment))
+(defstruct (environment (:constructor %make-environment))
(parent nil :type (or null environment))
- (data nil :type simple-vector))
+ (data nil :type (or null simple-vector)))
+
+(declaim (inline make-null-environment))
(defun make-null-environment () (make-environment nil 0))
+(declaim (inline make-environment))
+(defun make-environment (parent
+ &optional (size 0)
+ &aux (data
+ (unless (zerop (the fixnum size))
+ (make-array
+ (list size)))))
+ (%make-environment :parent parent :data data))
+
+(defmacro with-dynamic-extent-environment ((var parent size) &body body)
+ (let ((data% (gensym))
+ (size% (gensym)))
+ `(let* ((,size% ,size)
+ (,data% (make-array (list ,size%)))
+ (,var (%make-environment :parent ,parent :data ,data%)))
+ (declare (type (mod 1000) ,size%)
+ (dynamic-extent ,var)
+ (dynamic-extent ,data%))
+ ,@body)))
+
(defclass lexical ()
((name :accessor lexical-name :initarg :name :type (or symbol list))))
@@ -486,10 +505,9 @@
(key-num (length keys))
(aux-num (length aux))
(varnum (length argvars))
- (envp (maybe-closes-over-p `(progn ,@body) argvars))
- (new-context (if envp
- (context-add-env-lexicals context argvars)
- (context-add-stack-lexicals context argvars)))
+ (envp (or (> varnum 1000)
+ (maybe-closes-over-p `(progn ,@body) argvars)))
+ (new-context (context-add-env-lexicals context argvars))
(default-values (append (mapcar #'lambda-binding-default optional)
(mapcar #'lambda-binding-default keys)
(mapcar #'lambda-binding-default aux)))
@@ -580,9 +598,9 @@
(lambda (env)
(lambda (&rest args)
(declare (dynamic-extent args))
- (with-stack-frame varnum
- (handle-arguments args (stack-ref) env)
- (funcall body* env))))))))))
+ (with-dynamic-extent-environment (new-env env varnum)
+ (handle-arguments args (environment-value new-env) new-env)
+ (funcall body* new-env))))))))))
(defun context->native-environment (context)