Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18563

Modified Files: compiler.lisp Log Message: Added support for stack-allocated cons cells.

Date: Tue Jan 4 12:35:11 2005 Author: ffjeld

Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.124 movitz/compiler.lisp:1.125 --- movitz/compiler.lisp:1.124 Mon Jan 3 12:55:04 2005 +++ movitz/compiler.lisp Tue Jan 4 12:35:10 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.124 2005/01/03 11:55:04 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.125 2005/01/04 11:35:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -649,6 +649,10 @@ (case (car instruction) (:call-lexical (process-binding funobj (second instruction) '(:call))) + (:stack-cons + (destructuring-bind (proto-cons dynamic-scope) + (cdr instruction) + (push proto-cons (dynamic-extent-scope-members dynamic-scope)))) (:load-lambda (destructuring-bind (lambda-binding lambda-result-mode capture-env) (cdr instruction) @@ -656,15 +660,13 @@ (assert (eq funobj (binding-funobj lambda-binding)) () "A non-local lambda doesn't make sense. There must be a bug.") (let ((lambda-funobj (function-binding-funobj lambda-binding))) - (let ((dynamic-extent (dynamic-extent-allocation capture-env))) - (when dynamic-extent - (let ((dynamic-scope (allocation-env-scope dynamic-extent))) - ;; (warn "Adding ~S to ~S/~S" lambda-funobj dynamic-extent dynamic-scope) - (setf (movitz-funobj-extent lambda-funobj) :dynamic-extent - (movitz-allocation lambda-funobj) dynamic-scope) - (push lambda-funobj - (dynamic-extent-scope-members (allocation-env-scope dynamic-extent))) - (process-binding funobj (base-binding dynamic-scope) '(:read))))) + (let ((dynamic-scope (find-dynamic-extent-scope capture-env))) + (when dynamic-scope + ;; (warn "Adding ~S to ~S/~S" lambda-funobj dynamic-extent dynamic-scope) + (setf (movitz-funobj-extent lambda-funobj) :dynamic-extent + (movitz-allocation lambda-funobj) dynamic-scope) + (push lambda-funobj (dynamic-extent-scope-members dynamic-scope)) + (process-binding funobj (base-binding dynamic-scope) '(:read)))) (resolve-sub-funobj funobj lambda-funobj) (process-binding funobj lambda-binding '(:read)) ;; This funobj is effectively using every binding that the lambda @@ -3841,7 +3843,6 @@ (destructuring-bind (function-binding register capture-env) (operands instruction) (declare (ignore capture-env)) - ;; (warn "load-lambda not completed for ~S" function-binding) (finalize-code (let* ((sub-funobj (function-binding-funobj function-binding)) (lend-code (loop for bb in (borrowed-bindings sub-funobj) @@ -6896,6 +6897,9 @@ (loop for object in (reverse (dynamic-extent-scope-members scope-env)) appending (etypecase object + (movitz-cons + `((:pushl :edi) + (:pushl :edi))) (movitz-funobj (append (unless (zerop (mod (sizeof object) 8)) `((:pushl :edi))) @@ -6932,3 +6936,19 @@ (when (eq t distance) (values (list (movitz-binding (save-esp-variable to-env) to-env nil)) (list :esp))))) + +(define-find-read-bindings :stack-cons (proto-cons scope-env) + (declare (ignore proto-cons)) + (values (list (base-binding scope-env)) + (list :edx))) + +(define-extended-code-expander :stack-cons (instruction funobj frame-map) + (destructuring-bind (proto-cons dynamic-scope) + (cdr instruction) + (append (make-load-lexical (base-binding dynamic-scope) :edx + funobj nil frame-map) + `((:movl :eax (:edx ,(dynamic-extent-object-offset dynamic-scope proto-cons))) + (:movl :ebx (:edx ,(+ 4 (dynamic-extent-object-offset dynamic-scope proto-cons)))) + (:leal (:edx ,(+ (tag :cons) (dynamic-extent-object-offset dynamic-scope proto-cons))) + :eax))))) +