summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--sb-eval2.lisp240
1 files changed, 35 insertions, 205 deletions
diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 4097de4..ccb0d14 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -8,9 +8,7 @@
;;(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*)
-(defvar *sp*)
+(defconstant +stack-max+ 1000)
(defmacro specialize (&environment env var value possible-values &body body)
`(ecase ,value
@@ -18,9 +16,6 @@
collect
`((,x) ,(sb-int:eval-in-lexenv `(let ((,var ,x)) ,@body) env)))))
-(deftype stack ()
- 'simple-vector)
-
(declaim (inline %make-environment))
(defstruct (environment (:constructor %make-environment))
(parent nil :type (or null environment))
@@ -44,7 +39,7 @@
`(let* ((,size% ,size)
(,data% (make-array (list ,size%)))
(,var (%make-environment :parent ,parent :data ,data%)))
- (declare (type (mod 1000) ,size%)
+ (declare (type (mod #.+stack-max+) ,size%)
(dynamic-extent ,var)
(dynamic-extent ,data%))
,@body)))
@@ -56,18 +51,10 @@
((offset :accessor lexical-offset :initarg :offset :type fixnum)
(nesting :accessor lexical-nesting :initarg :nesting :type fixnum)))
-(defclass stack-lexical (lexical)
- ((offset :accessor lexical-offset :initarg :offset :type fixnum)
- (nesting :accessor lexical-nesting :initarg :nesting :type fixnum)))
-
-(defun make-stack-lexical (name offset &optional (nesting -1))
- (make-instance 'stack-lexical :name name :offset offset :nesting nesting))
(defun make-env-lexical (name offset &optional (nesting -1))
(make-instance 'env-lexical :name name :offset offset :nesting nesting))
(defgeneric lexical-with-nesting (lexical nesting))
-(defmethod lexical-with-nesting ((lexical stack-lexical) nesting)
- (make-stack-lexical (lexical-name lexical) (lexical-offset lexical) nesting))
(defmethod lexical-with-nesting ((lexical env-lexical) nesting)
(make-env-lexical (lexical-name lexical) (lexical-offset lexical) nesting))
@@ -116,7 +103,6 @@
(defstruct (context (:constructor make-context (&optional parent)))
parent
(env-hop nil :type boolean)
- (stack-hop nil :type boolean)
(block-tags nil :type list)
(go-tags nil :type list)
(symbol-macros nil :type list)
@@ -188,29 +174,10 @@
for v in vars
collect (make-env-lexical v i))))
new-context))
-(defun context-bump-stack (context)
- (let ((new-context (make-context context)))
- (with-slots (stack-hop)
- new-context
- (setq stack-hop t))
- new-context))
-(defun context-add-stack-lexicals (context vars)
- ;; open a new variable context
- (let ((new-context (make-context context)))
- (with-slots (lexicals stack-hop)
- new-context
- (setq stack-hop t)
- (setq lexicals (loop for i fixnum from 0
- for v in vars
- collect (make-stack-lexical v i))))
- new-context))
(defun context-add-env-functions (context fs)
(context-add-env-lexicals context (mapcar (lambda (x) `(function ,x)) fs)))
-(defun context-add-stack-functions (context fs)
- (context-add-stack-lexicals context (mapcar (lambda (x) `(function ,x)) fs)))
(defun context-find-lexical (context var)
(loop with env-level = 0
- with stack-level = 0
until (null context)
for record = (find var
(context-lexicals context)
@@ -219,12 +186,9 @@
when record
do (return
(etypecase record
- (env-lexical (lexical-with-nesting record env-level))
- (stack-lexical (lexical-with-nesting record stack-level))))
+ (env-lexical (lexical-with-nesting record env-level))))
when (context-env-hop context)
do (incf env-level)
- when (context-stack-hop context)
- do (incf stack-level)
do (setq context (context-parent context))))
(deftype eval-closure () `(function (environment) *))
@@ -241,112 +205,6 @@
(setq env (environment-parent env)))
(setf (svref (environment-data env) offset) val))
-(defmacro with-stack (() &body body)
- `(call-with-stack (lambda () ,@body)))
-
-(declaim (inline call-with-stack))
-(defun call-with-stack (thunk)
- (let ((*stack* (make-array '(10000)))
- (*fp* 0)
- (*sp* 0))
- (funcall thunk)))
-
-(defmacro with-stack-frame (nvars &body body)
- `(call-with-stack-frame ,nvars (lambda () ,@body)))
-
-(declaim (ftype (function (fixnum function) *) really-call-with-stack-frame)
- (inline really-call-with-stack-frame))
-(defun really-call-with-stack-frame (nvars thunk)
- (let* ((stack *stack*)
- (sp *sp*)
- (new-size (+ sp nvars 1)))
- (declare (type stack stack)
- (type fixnum sp new-size))
- (loop for size fixnum = (array-dimension stack 0)
- while (< size new-size)
- do (setq stack
- (adjust-array stack
- (list (the fixnum
- (+ new-size (the fixnum
- (round (* size 1.5))))))))
- (setq *stack* stack))
- (setf (aref stack sp) (the fixnum *fp*))
- (let ((*fp* sp)
- (*sp* new-size))
- (funcall thunk))))
-
-(declaim (ftype (function (fixnum function) *) call-with-stack-frame)
- (inline call-with-stack-frame))
-(defun call-with-stack-frame (nvars thunk)
- (if (boundp '*stack*)
- (really-call-with-stack-frame nvars thunk)
- (with-stack () (really-call-with-stack-frame nvars thunk))))
-
-(declaim (ftype (function (fixnum) *) deref-stack)
- (inline deref-stack))
-(defun deref-stack (pos)
- (aref (the stack *stack*) pos))
-
-(declaim (ftype (function (* fixnum) *) (setf deref-stack))
- (inline (setf deref-stack)))
-(defun (setf deref-stack) (val pos)
- (setf (aref (the stack *stack*) pos) val))
-
-(declaim (ftype (function (fixnum fixnum) *) stack-ref)
- (inline stack-ref))
-(defun stack-ref (nesting offset)
- (let ((pos (the fixnum *fp*)))
- (dotimes (i nesting)
- (setq pos (the fixnum (deref-stack pos))))
- (deref-stack (the fixnum (+ 1 offset pos)))))
-
-(declaim (ftype (function (fixnum) *) stack-ref0)
- (inline stack-ref0))
-(defun stack-ref0 (offset)
- (deref-stack (the fixnum (+ (the fixnum (+ 1 (the fixnum *fp*))) offset))))
-
-(define-compiler-macro stack-ref (&whole form
- &environment env
- nesting offset)
- (if (constantp nesting env)
- (let ((num (sb-int:eval-in-lexenv nesting env)))
- (if (zerop num)
- `(stack-ref0 (the fixnum ,offset))
- `(progn
- (let ((pos *fp*))
- ,@(loop for i from 1 to num
- collect `(setq pos (the fixnum (deref-stack pos))))
- (deref-stack (the fixnum (+ 1 (the fixnum (+ (the fixnum ,offset) pos)))))))))
- form))
-
-(declaim (ftype (function (* fixnum fixnum) *) (setf stack-ref))
- (inline (setf stack-ref)))
-(defun (setf stack-ref) (val nesting offset)
- (let ((pos *fp*))
- (declare (type fixnum pos))
- (dotimes (i nesting)
- (setq pos (deref-stack pos)))
- (setf (deref-stack (the fixnum (+ 1 offset pos))) val)))
-
-(declaim (ftype (function (* fixnum) *) (setf stack-ref0))
- (inline (setf stack-ref0)))
-(defun (setf stack-ref0) (val offset)
- (setf (deref-stack (the fixnum (+ (the fixnum (+ 1 (the fixnum *fp*))) offset))) val))
-
-(define-compiler-macro (setf stack-ref) (&whole form
- &environment env
- val nesting offset)
- (if (constantp nesting env)
- (let ((num (sb-int:eval-in-lexenv nesting env)))
- (if (zerop num)
- `(setf (stack-ref0 (the fixnum ,offset)) ,val)
- `(progn
- (let ((pos *fp*))
- ,@(loop for i from 1 to num
- collect `(setq pos (the fixnum (deref-stack pos))))
- (setf (deref-stack (the fixnum (+ 1 (the fixnum (+ (the fixnum ,offset) pos))))) ,val)))))
- form))
-
(declaim (ftype (function (symbol context) eval-closure) prepare-ref))
(defun prepare-ref (var context)
(if (context-var-lexical-p context var)
@@ -356,18 +214,7 @@
(etypecase lexical
(env-lexical
(lambda (env)
- (environment-value env nesting offset)))
- (stack-lexical
- (if (< nesting 20)
- (specialize m% nesting (loop for i from 0 below 20 collect i)
- `(lambda (env)
- (declare (ignore env))
- ;;(format t "~&; stack-ref ~d ~d" nesting offset)
- (stack-ref ,m% offset)))
- (lambda (env)
- (declare (ignore env))
- ;;(format t "~&; stack-ref ~d ~d" nesting offset)
- (stack-ref nesting offset))))))
+ (environment-value env nesting offset)))))
(lambda (env)
(declare (ignore env))
(symbol-value var))))
@@ -509,7 +356,7 @@
(key-num (length keys))
(aux-num (length aux))
(varnum (length argvars))
- (envp (or (> varnum 1000)
+ (envp (or (> varnum +stack-max+)
(maybe-closes-over-p `(progn ,@body) argvars)))
(new-context (context-add-env-lexicals context argvars))
(default-values (append (mapcar #'lambda-binding-default optional)
@@ -671,17 +518,6 @@
(lexical-nesting lexical?)
(lexical-offset lexical?))
value))
- (stack-lexical
- (let ((nesting (lexical-nesting lexical?))
- (offset (lexical-offset lexical?)))
- (if (< nesting 20)
- (specialize m%
- nesting
- (loop for i from 0 below 20 collect i)
- `(setf (stack-ref ,m% offset)
- value))
- (setf (stack-ref nesting offset)
- value))))
(null
(setf (symbol-value var) value))))
finally (return result))))))
@@ -757,42 +593,37 @@
(cons form nil)))
bindings))
(vars (mapcar #'car real-bindings))
- (envp (maybe-closes-over-p `(progn ,@body) vars))
- (binding-context (if envp
- context
- (context-bump-stack context)))
+ (varnum (length vars))
+ (envp (or (> varnum +stack-max+)
+ (maybe-closes-over-p `(progn ,@body) vars)))
+ (binding-context context)
(bindings* (mapcar (lambda (form)
(cons (car form)
(prepare-form (cdr form)
binding-context)))
real-bindings))
(n (length (the list bindings)))
- (values* (mapcar #'cdr bindings*)))
+ (values* (mapcar #'cdr bindings*))
+ (new-context
+ (context-add-env-lexicals context
+ (mapcar #'first bindings*)))
+ (body*
+ (prepare-progn body new-context)))
(if envp
- (let* ((new-context
- (context-add-env-lexicals context
- (mapcar #'first bindings*)))
- (body*
- (prepare-progn body new-context)))
- (lambda (env)
- (let ((new-env (make-environment env n)))
- (loop for i from 0 below n
- for val* in values*
- do (setf (environment-value new-env 0 i)
- (funcall (the eval-closure val*) env)))
- (funcall body* new-env))))
- (let* ((new-context
- (context-add-stack-lexicals context
- (mapcar #'first bindings*)))
- (body*
- (prepare-progn body new-context)))
- (lambda (env)
- (with-stack-frame n
- (loop for i from 0 below n
- for val* in values*
- do (setf (stack-ref 0 i)
- (funcall (the eval-closure val*) env)))
- (funcall body* env))))))))
+ (lambda (env)
+ (let ((new-env (make-environment env n)))
+ (loop for i from 0 below n
+ for val* in values*
+ do (setf (environment-value new-env 0 i)
+ (funcall (the eval-closure val*) env)))
+ (funcall body* new-env)))
+ (lambda (env)
+ (with-dynamic-extent-environment (new-env env n)
+ (loop for i from 0 below n
+ for val* in values*
+ do (setf (environment-value new-env 0 i)
+ (funcall (the eval-closure val*) env)))
+ (funcall body* new-env)))))))
((let*)
;; FIXME: SPECIAL declarations!
(destructuring-bind (bindings &rest body) (rest form)
@@ -1004,11 +835,10 @@
(make-null-environment))
#+(or)
-(with-stack ()
- (funcall (funcall
- (prepare-form
- '(lambda (a b &optional c (d 10 dp) &rest r &key e (f 12 fp) (g 12 gp) &aux (h 1) (i 2))
- (list a b c d dp e f fp g gp r h i)))
- (make-null-environment))
- 1 2 3 4 :f 5 :e 6))
+(funcall (funcall
+ (prepare-form
+ '(lambda (a b &optional c (d 10 dp) &rest r &key e (f 12 fp) (g 12 gp) &aux (h 1) (i 2))
+ (list a b c d dp e f fp g gp r h i)))
+ (make-null-environment))
+ 1 2 3 4 :f 5 :e 6)
;; => (1 2 3 4 T 6 5 T 12 NIL (:F 5 :E 6) 1 2)