Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18113
Modified Files: compiler.lisp Log Message: Two substantial changes: Firstly the code for allocating &rest-lists on the stack is rewritten, because the old one didn't observe the stack discipline (causing weird bugs while experimenting with hw interrupts).
Secondly, there was a bug/omission when lending optional-function-argument bindings to sub-functions, i.e like this:
(defun foo (x &optional (y 0)) (lambda () (+ x (incf y))))
The code for foo in this case would be completely bogus, and e.g. over-write (car NIL) and generally ruin everyting.
Date: Fri Aug 6 07:41:37 2004 Author: ffjeld
Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.87 movitz/compiler.lisp:1.88 --- movitz/compiler.lisp:1.87 Wed Jul 28 17:12:54 2004 +++ movitz/compiler.lisp Fri Aug 6 07:41:37 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.87 2004/07/29 00:12:54 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.88 2004/08/06 14:41:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -3404,7 +3404,7 @@ `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location))) (:jne ',(operands result-mode))) (ecase (operator binding-location) - ((:eax :ebx) + ((:eax :ebx :edx) `((:cmpl :edi ,binding-location) (:jne ',(operands result-mode)))) (:argument-stack @@ -3415,7 +3415,7 @@ `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location))) (:je ',(operands result-mode))) (ecase (operator binding-location) - ((:eax :ebx) + ((:eax :ebx :edx) `((:cmpl :edi ,binding-location) (:je ',(operands result-mode)))) (:argument-stack @@ -4264,6 +4264,10 @@ (function-argument-argnum binding))) unless (movitz-env-get optional-var 'ignore nil env nil) append + `((:init-lexvar ,binding)) + when supplied-p-binding + append `((:init-lexvar ,supplied-p-binding)) + append (compiler-values-bind (&code init-code-edx &producer producer) (compiler-call #'compile-form :form (optional-function-argument-init-form binding) @@ -4379,7 +4383,7 @@ (append #+ignore (make-immediate-move rest-position :edx) `(#+ignore (:call (:edi ,(global-constant-offset 'restify-dynamic-extent))) (:init-lexvar ,rest-binding - :init-with-register :eax + :init-with-register :edx :init-with-type list))))) (cond ;; &key processing.. @@ -5942,7 +5946,7 @@ (append (cond ((typep binding 'rest-function-argument) - (assert (eq :eax init-with-register)) + (assert (eq :edx init-with-register)) (assert (or (typep binding 'hidden-rest-function-argument) (movitz-env-get (binding-name binding) 'dynamic-extent nil (binding-env binding))) @@ -5951,13 +5955,47 @@ (setf (need-normalized-ecx-p (find-function-env (binding-env binding) funobj)) t) - (append (make-immediate-move (function-argument-argnum binding) :edx) - `((:call (:edi ,(global-constant-offset 'restify-dynamic-extent)))) - #+ignore - (unless (or (typep binding 'hidden-rest-function-argument) - (movitz-env-get (binding-name binding) - 'dynamic-extent nil (binding-env binding))) - (make-compiled-funcall-by-symbol 'muerte.cl:copy-list 1 funobj))))) + (let ((restify-alloca-loop (gensym "alloca-loop-")) + (restify-done (gensym "restify-done-")) + (restify-at-one (gensym "restify-at-one-")) + (restify-loop (gensym "restify-loop-"))) + (append + ;; (make-immediate-move (function-argument-argnum binding) :edx) + ;; `((:call (:edi ,(global-constant-offset 'restify-dynamic-extent)))) + ;; Make space for (1+ (* 2 (- ECX rest-pos))) words on the stack. + ;; Factor two is for one cons-cell per word, 1 is for 8-byte alignment. + `((:movl :edi :edx) + (:subl ,(function-argument-argnum binding) :ecx) + (:jbe ',restify-done) + (:leal ((:ecx 8) 4) :edx) ; EDX is fixnum counter + ,restify-alloca-loop + (:pushl :edi) + (:subl 4 :edx) + (:jnz ',restify-alloca-loop) + (:leal (:esp 5) :edx) + (:andl -7 :edx)) ; Make EDX a proper consp into the alloca area. + (cond + ((= 0 (function-argument-argnum binding)) + `((:movl :eax (:edx -1)) + (:movl :edx :eax) + (:subl 1 :ecx) + (:jz ',restify-done) + (:addl 8 :eax) + (:movl :eax (:eax -5)))) + (t `((:movl :edx :eax)))) + (when (>= 1 (function-argument-argnum binding)) + `((:jmp ',restify-at-one))) + `(,restify-loop + (:movl (:ebp (:ecx 4) 4) :ebx) + ,restify-at-one + (:movl :ebx (:eax -1)) + (:subl 1 :ecx) + (:jz ',restify-done) + (:addl 8 :eax) + (:movl :eax (:eax -5)) + (:jmp ',restify-loop) + ,restify-done) + )))) (cond ((binding-lended-p binding) (let* ((cons-position (getf (binding-lended-p binding)