[movitz-cvs] CVS update: movitz/compiler.lisp

[Frode Vatvedt Fjeld]

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)