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

[Frode Vatvedt Fjeld]

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

Modified Files:
	compiler.lisp 
Log Message:
Two things: 1. Make movitz-macro-expander-make-function work consistently
(return the function's name). 2. Support the supplied-p-parameter for
the optimized compilation of (x &optional (y init supplied-p)).

Date: Sun Feb  8 18:24:13 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.17 movitz/compiler.lisp:1.18
--- movitz/compiler.lisp:1.17	Thu Feb  5 09:46:02 2004
+++ movitz/compiler.lisp	Sun Feb  8 18:24:13 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.17 2004/02/05 14:46:02 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.18 2004/02/08 23:24:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -135,11 +135,14 @@
   object)
 
 (defun movitz-macro-expander-make-function (lambda-form &key name (type :unknown))
-  "Make a lambda-form that is a macro-expander into a proper function."
-  (if *compiler-compile-macro-expanders*
-      (compile (gensym (format nil "~A-expander-~@[~A-~]" type name))
-	       lambda-form)
-    (coerce lambda-form 'function)))
+  "Make a lambda-form that is a macro-expander into a proper function.
+Gensym a name whose symbol-function is set to the macro-expander, and return that symbol."
+  (let ((function-name (gensym (format nil "~A-expander-~@[~A-~]" type name))))
+    (if *compiler-compile-macro-expanders*
+	(compile function-name lambda-form)
+      (setf (symbol-function function-name)
+	(coerce lambda-form 'function)))
+    function-name))
 
 (defun make-compiled-funobj (name lambda-list declarations form env top-level-p &key funobj)
   "Compiler entry-point for making a (lexically) top-level function."
@@ -349,12 +352,12 @@
 	       (loop for function-binding in (sub-function-binding-usage funobj) by #'cddr
 		   do (analyze-funobj (function-binding-funobj function-binding)))
 	       funobj))
-      #+ignore (analyze-funobj toplevel-funobj)
-      #+ignore (dolist (binding bindings)
-		 (let ((types (binding-store-type binding)))
-		   (unless (some #'type-is-t types)
-		     (warn "binding: ~S~%      types: ~S"
-			   binding types))))
+;;;      (analyze-funobj toplevel-funobj)
+;;;      (dolist (binding bindings)
+;;;	(let ((types (binding-store-type binding)))
+;;;	  (when (or t (notany #'type-is-t types))
+;;;	    (warn "binding: ~S~%      types: ~S"
+;;;		  binding types))))
       toplevel-funobj)))
 
 (defun resolve-borrowed-bindings (toplevel-funobj)
@@ -545,42 +548,60 @@
 	 (optional-stack-frame-p (tree-search resolved-optional-code
 					      '(:ebp :esp :call :leave))))
     (assert (not optional-stack-frame-p))
-    (let* ((stack-setup-size stack-frame-size)
-	   (function-code
+    (let* ((function-code
 	    (let* ((req-binding (movitz-binding (first (required-vars function-env))
 						function-env nil))
 		   (req-location (cdr (assoc req-binding frame-map)))
 		   (opt-binding (movitz-binding (first (optional-vars function-env))
 						function-env nil))
-		   (opt-location (cdr (assoc opt-binding frame-map))))
+		   (opt-location (cdr (assoc opt-binding frame-map)))
+		   (optp-binding (movitz-binding (optional-function-argument-supplied-p-var opt-binding)
+						 function-env nil))
+		   (optp-location (cdr (assoc optp-binding frame-map)))
+		   (stack-setup-pre 0))
 	      (append `((:jmp (:edi ,(global-constant-offset 'trampoline-cl-dispatch-1or2))))
 		      '(entry%1op)
 		      (unless (eql nil opt-location)
 			resolved-optional-code)
+		      (when optp-location
+			`((:movl :edi :ecx)
+			  (:jmp 'optp-into-ecx-ok)))
 		      '(entry%2op)
+		      (when optp-location
+			`((,*compiler-global-segment-prefix*
+			   :movl (:edi ,(global-constant-offset 't-symbol)) :ecx)
+			  optp-into-ecx-ok))
 		      (when use-stack-frame-p
 			+enter-stack-frame-code+)
 		      '(start-stack-frame-setup)
 		      (cond
 		       ((and (eql 1 req-location)
 			     (eql 2 opt-location))
-			(decf stack-setup-size 2)
+			(incf stack-setup-pre 2)
 			`((:pushl :eax)
 			  (:pushl :ebx)))
 		       ((and (eql 1 req-location)
 			     (eql nil opt-location))
-			(decf stack-setup-size 1)
+			(incf stack-setup-pre 1)
 			`((:pushl :eax)))
 		       ((and (member req-location '(nil :eax))
 			     (eql 1 opt-location))
-			(decf stack-setup-size 1)
+			(incf stack-setup-pre 1)
 			`((:pushl :ebx)))
 		       ((and (member req-location '(nil :eax))
 			     (member opt-location '(nil :ebx)))
 			nil)
 		       (t (error "Can't deal with req ~S opt ~S."
 				 req-location opt-location)))
-		      (make-stack-setup-code stack-setup-size)
+		      (cond
+		       ((not optp-location)
+			())
+		       ((= optp-location (1+ stack-setup-pre))
+			(incf stack-setup-pre 1)
+			`((:pushl :ecx)))
+		       (t (error "Can't deal with optional-p at ~S, after (~S ~S)."
+				 optp-location req-location opt-location)))
+		      (make-stack-setup-code (- stack-frame-size stack-setup-pre))
 		      resolved-code
 		      (make-compiled-function-postlude funobj function-env
 						       use-stack-frame-p)))))