Introduce a stack for variables not closed over.

1 files changed, 268 insertions, 59 deletions

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 7fb09b2..af29739 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -8,6 +8,12 @@
 #+(or)
 (setq SB-EXT:*EVALUATOR-MODE* :interpret)
 
+(defvar *stack*)
+(defvar *fp*)
+
+(deftype stack ()
+  `(array t (*)))
+
 (defstruct (environment (:constructor make-environment (parent
                                                         &optional (size 0)
                                                         &aux (data
@@ -17,13 +23,68 @@
   (data nil :type simple-vector))
 (defun make-null-environment () (make-environment nil 0))
 
-(defstruct (lexical (:constructor make-lexical (name offset &optional (nesting nil))))
-  (name nil :type (or symbol list))
-  nesting
-  offset)
+(defclass lexical ()
+  ((name    :accessor lexical-name    :initarg :name    :type (or symbol list))))
+
+(defclass env-lexical (lexical)
+  ((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 lexical-with-nesting (lexical nesting)
-  (make-lexical (lexical-name lexical) (lexical-offset lexical) nesting))
+(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))
+
+(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))
+
+(defun maybe-references-p (form vars)
+  ;; Use `(function ,name) for local functions.
+  ;;
+  ;; FIXME: This doesn't do macro expansion, so it's probably
+  ;; incorrect.
+  (typecase form
+    (symbol
+     (member form vars :test #'equal))
+    (cons
+     (destructuring-bind (a . b) form
+       (or (maybe-references-p a vars)
+           (maybe-references-p b vars))))
+    (t
+     nil)))
+
+(defun maybe-closes-over-p (form vars)
+  ;; Use `(function ,name) for local functions.
+  ;;
+  ;; NOTE: This is a *very* simplistic algorithm with a *lot* of false
+  ;; positives.
+  ;;
+  ;; FIXME: This doesn't do macro expansion, so it's probably
+  ;; incorrect.
+  (typecase form
+    (symbol
+     nil)
+    (cons
+     (destructuring-bind (a . b) form
+       (case a
+         ((lambda)
+          (maybe-references-p form vars))
+         ((flet labels)
+          (typecase b
+            (cons
+             (destructuring-bind (bindings . rest) form
+               (or (maybe-references-p bindings vars)
+                   (maybe-closes-over-p rest vars))))
+            (t
+             (maybe-closes-over-p b vars)))))))
+    (t
+     nil)))
 
 (defstruct (box (:constructor make-box (value)))
   value)
@@ -31,7 +92,8 @@
 
 (defstruct (context (:constructor make-context (&optional parent)))
   parent
-  (levelp nil :type boolean)
+  (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)
@@ -93,58 +155,130 @@
                (cons tag forms)))))
 (defun context-var-lexical-p (context var)
   (context-find-lexical context var))
-(defun context-add-lexicals (context vars)
+(defun context-add-env-lexicals (context vars)
+  ;; open a new variable context
+    (let ((new-context (make-context context)))
+    (with-slots (lexicals env-hop)
+        new-context
+      (setq env-hop t)
+      (setq lexicals (loop for i fixnum from 0
+                           for v in vars
+                           collect (make-env-lexical v i))))
+    new-context))
+(defun context-add-stack-lexicals (context vars)
   ;; open a new variable context
     (let ((new-context (make-context context)))
-    (with-slots (lexicals levelp)
+    (with-slots (lexicals stack-hop)
         new-context
-      (setq levelp t)
-      (setq lexicals (loop for i from 0
+      (setq stack-hop t)
+      (setq lexicals (loop for i fixnum from 0
                            for v in vars
-                           collect (make-lexical v i))))
+                           collect (make-stack-lexical v i))))
     new-context))
-(defun context-add-functions (context fs)
-  (context-add-lexicals context (mapcar (lambda (x) `(function ,x)) fs)))
-(defun context-add-lexical (context var)
-  (context-add-lexicals context (list var)))
+(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 level = 0
+  (loop with env-level = 0
+        with stack-level = 0
         until (null context)
         for record = (find var
                            (context-lexicals context)
                            :key #'lexical-name
                            :test #'equal)
         when record
-          do (return (lexical-with-nesting record level))
-        when (context-levelp context)
-          do (incf level)
+          do (return
+               (etypecase record
+                 (env-lexical   (lexical-with-nesting record env-level))
+                 (stack-lexical (lexical-with-nesting record stack-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) *))
 
+(declaim (inline environment-value))
 (defun environment-value (env nesting offset)
   (dotimes (i (the fixnum nesting))
     (setq env (environment-parent env)))
   (svref (environment-data env) offset))
 
+(declaim (inline (setf environment-value)))
 (defun (setf environment-value) (val env nesting offset)
   (dotimes (i (the fixnum nesting))
     (setq env (environment-parent env)))
   (setf (svref (environment-data env) offset) val))
 
+(defmacro with-stack-frame (nvars &body body)
+  `(call-with-stack-frame ,nvars (lambda () ,@body)))
+
+(declaim (ftype (function (fixnum function) *) call-with-stack-frame)
+         (inline call-with-stack-frame))
+(defun call-with-stack-frame (nvars thunk)
+  (let* ((stack *stack*)
+         (sp (fill-pointer stack))
+         (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 (format t "~&Resizing stack (new size: ~D)."
+                     (+ new-size (the fixnum (round (* size 1.5)))))
+             (adjust-array stack
+                           (list (the fixnum
+                                      (+ new-size (the fixnum
+                                                       (round (* size 1.5))))))))
+    (setf (fill-pointer stack) new-size)
+    (setf (aref stack sp) (the fixnum *fp*))
+    (unwind-protect
+         (let ((*fp* sp))
+           (funcall thunk))
+      (setf (fill-pointer stack) sp))))
+
+(declaim (ftype (function (fixnum) *) deref-stack)
+         (inline deref-stack))
+(defun deref-stack (pos)
+  (aref (the stack *stack*) pos))
+
+(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))))
+    (aref (the stack *stack*) (the fixnum (+ 1 offset pos)))))
+
+(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 (aref (the stack *stack*) (the fixnum (+ 1 offset pos))) val)))
+
 (declaim (ftype (function (symbol context) eval-closure) prepare-ref))
 (defun prepare-ref (var context)
   (if (context-var-lexical-p context var)
       (let* ((lexical (context-find-lexical context var))
              (nesting (lexical-nesting lexical))
              (offset (lexical-offset lexical)))
-        (lambda (env)
-          (environment-value env nesting offset)))
+        (etypecase lexical
+          (env-lexical
+           (lambda (env)
+             (environment-value env nesting offset)))
+          (stack-lexical
+           (lambda (env)
+             (declare (ignore env))
+             (stack-ref nesting offset)))))
       (lambda (env)
         (declare (ignore env))
         (symbol-value var))))
 
-(declaim (ftype (function ((or symbol list) context) eval-closure) prepare-refunction-))
+(declaim (ftype (function ((or symbol list) context) eval-closure) prepare-function-ref))
 (defun prepare-function-ref (function-name context)
   (if (context-var-lexical-p context `(function ,function-name))
       (let* ((lexical (context-find-lexical context `(function ,function-name)))
@@ -243,25 +377,67 @@
         (dolist (form* body* result)
           (setq result (funcall (the eval-closure form*) env)))))))
 
+#+ (or)
+                (if (maybe-closes-over-p `(progn ,@body) vars)
+                    (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 i)
+                                         (funcall (the eval-closure val*) env)))
+                          (funcall body* env)))))
+
 (declaim (ftype (function (list context) eval-closure) prepare-lambda))
 (defun prepare-lambda (lambda-form context)
   (destructuring-bind (lambda-list &rest body) lambda-form
     ;; FIXME: SPECIAL declarations!
-    (let* ((n (length (the list lambda-list)))
-           (new-context (context-add-lexicals context lambda-list))
-           (body* (prepare-progn body new-context)))
-      (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
-                            morep more-context more-count)
-          (sb-int:parse-lambda-list lambda-list)
-       (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))))))))
+    (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
+                          morep more-context more-count)
+        (sb-int:parse-lambda-list lambda-list)
+      (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))))))))))
 
 (defun context->native-environment (context)
   ;;FIXME
@@ -319,13 +495,20 @@
                         for result =
                            (progn
                              (check-type var symbol)
-                             (if ;XXX could lift the conditional out of the lambda
-                              lexical?
-                              (setf (environment-value env
-                                                       (lexical-nesting lexical?)
-                                                       (lexical-offset lexical?))
-                                    value)
-                              (setf (symbol-value var) value)))
+                             (etypecase lexical?  ; XXX could lift the
+                                                  ; case distinction
+                                                  ; out of the lambda
+                               (env-lexical
+                                (setf (environment-value env
+                                                         (lexical-nesting lexical?)
+                                                         (lexical-offset lexical?))
+                                      value))
+                               (stack-lexical
+                                (setf (stack-ref (lexical-nesting lexical?)
+                                                 (lexical-offset lexical?))
+                                      value))
+                               (null
+                                (setf (symbol-value var) value))))
                         finally (return result))))))
            ((catch)
             (destructuring-bind (tag &body body) (rest form)
@@ -360,7 +543,7 @@
                                                     (prepare-lambda (rest form) context))
                                               (cons form (prepare-nil))))
                                         bindings))
-                     (new-context (context-add-functions context (mapcar #'first bindings*)))
+                     (new-context (context-add-env-functions context (mapcar #'first bindings*)))
                      (functions (mapcar #'cdr bindings*))
                      (n (length functions))
                      (body* (prepare-progn body new-context)))
@@ -373,7 +556,7 @@
                     (funcall body* new-env))))))
            ((labels)
             (destructuring-bind (bindings &rest body) (rest form)
-              (let* ((new-context (context-add-functions context (mapcar #'first bindings)))
+              (let* ((new-context (context-add-env-functions context (mapcar #'first bindings)))
                      (bindings* (mapcar (lambda (form)
                                           (if (listp form)
                                               (cons (first form)
@@ -401,15 +584,32 @@
                                         bindings))
                      (n (length bindings*))
                      (values* (mapcar #'cdr bindings*))
-                     (new-context (context-add-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 to n
-                          for val* in values*
-                          do (setf (environment-value new-env 0 i)
-                                   (funcall (the eval-closure val*) env)))
-                    (funcall body* new-env))))))
+                     (vars (mapcar #'car bindings*)))
+                (if (maybe-closes-over-p `(progn ,@body) vars)
+                    (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))))))))
            ((let*)
             ;; FIXME: SPECIAL declarations!
             (destructuring-bind (bindings &rest body) (rest form)
@@ -421,7 +621,7 @@
                                  (let* ((var  (if (listp binding) (first binding) binding))
                                         (val  (if (listp binding) (prepare-form (second binding) context) (prepare-nil)))
                                       
-                                        (new-context (context-add-lexical context var))
+                                        (new-context (context-add-env-lexicals context (list var)))
                                         (more (prepare-let* rest-bindings new-context)))
                                    (lambda (env)
                                      (let ((new-env (make-environment env 1)))
@@ -469,7 +669,7 @@
             (destructuring-bind (vars value-form &body body) (rest form)
               (let* ((value-form* (prepare-form value-form context))
                      (n           (length (the list vars)))
-                     (new-context (context-add-lexicals context vars))
+                     (new-context (context-add-env-lexicals context vars))
                      (body*       (prepare-progn body new-context)))
                 (lambda (env)
                   (let* ((new-env (make-environment env n))
@@ -592,8 +792,17 @@
    t))
 
 
+(defmacro with-stack (() &body body)
+  `(call-with-stack (lambda () ,@body)))
+
+(defun call-with-stack (thunk)
+  (let ((*stack* (make-array '(2000) :fill-pointer t :adjustable t))
+        (*fp* 0))
+    (funcall thunk)))
+
 (defun eval (form)
-  (funcall (prepare-form form) (make-null-environment)))
+  (with-stack ()
+    (funcall (prepare-form form) (make-null-environment))))
 
 
 (defun load (filename)