diff options
| -rw-r--r-- | sb-eval2.lisp | 441 |
1 files changed, 358 insertions, 83 deletions
diff --git a/sb-eval2.lisp b/sb-eval2.lisp index 3d075f7..f5c3ad8 100644 --- a/sb-eval2.lisp +++ b/sb-eval2.lisp @@ -8,6 +8,19 @@ ;;(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*) + +(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))))) + +(deftype stack () + 'simple-vector) + (defstruct (environment (:constructor make-environment (parent &optional (size 0) &aux (data @@ -17,17 +30,74 @@ (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))) -(defun lexical-with-nesting (lexical nesting) - (make-lexical (lexical-name lexical) (lexical-offset lexical) nesting)) +(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)) + +(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 (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) @@ -89,58 +159,201 @@ (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 levelp) + (with-slots (lexicals env-hop) new-context - (setq levelp t) - (setq lexicals (loop for i from 0 + (setq env-hop t) + (setq lexicals (loop for i fixnum from 0 for v in vars - collect (make-lexical v i)))) + collect (make-env-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-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 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 (() &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) (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 + (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)))))) (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))) @@ -166,12 +379,6 @@ (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)) @@ -243,33 +450,59 @@ (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) - (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))))) - `(lambda (env) - (lambda ,args + (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))) + (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 - for val in args - collect `(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 - (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))))))))) + (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 @@ -327,13 +560,27 @@ 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 + (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)))))) ((catch) (destructuring-bind (tag &body body) (rest form) @@ -368,7 +615,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))) @@ -381,7 +628,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,23 +648,48 @@ ((let) ;; FIXME: SPECIAL declarations! (destructuring-bind (bindings &rest body) (rest form) - (let* ((bindings* (mapcar (lambda (form) - (if (listp form) - (cons (first form) - (prepare-form (second form) context)) - (cons form (prepare-nil)))) - 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)))))) + (let* ((real-bindings (mapcar (lambda (form) + (if (listp form) + (cons (first form) (second form)) + (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))) + (bindings* (mapcar (lambda (form) + (cons (car form) + (prepare-form (cdr form) + binding-context))) + real-bindings)) + (n (length (the list bindings))) + (values* (mapcar #'cdr bindings*))) + (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)))))))) ((let*) ;; FIXME: SPECIAL declarations! (destructuring-bind (bindings &rest body) (rest form) @@ -429,7 +701,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))) @@ -437,6 +709,10 @@ (funcall val env)) (funcall more new-env))))))))) (prepare-let* bindings context)))) + ((load-time-value) + (let ((load-form (cadr form))) + ;; FIXME + (prepare-form load-form))) ((locally) (prepare-nil)) ((multiple-value-call) @@ -477,7 +753,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)) @@ -599,7 +875,6 @@ (prepare-global-call f args context)))))))))))) t)) - (defun eval (form) (funcall (prepare-form form) (make-null-environment))) |