[movitz-cvs] CVS update: movitz/special-operators-cl.lisp

[Frode Vatvedt Fjeld]

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
Changed the mechanism of dynamic control transfer so as to avoid
having instruction-pointers present on the stack. Rather, we keep an
index to the jumper-table of the target function. A jumper-table is a
table of instruction-pointers pointing somewhere inside the function's
code-vector, and is the first n elements of the function-objects
constants.

The purpose of all this is to reduce the complexity of scavenging the
control-stack. Almost all the problems associated with this seems to
be rooted in the presence of (potential) untagged
instruction-pointers.

Date: Tue Apr 13 09:07:41 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.14 movitz/special-operators-cl.lisp:1.15
--- movitz/special-operators-cl.lisp:1.14	Tue Mar 30 16:33:54 2004
+++ movitz/special-operators-cl.lisp	Tue Apr 13 09:07:40 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.14 2004/03/30 21:33:54 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.15 2004/04/13 13:07:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -713,7 +713,8 @@
 			    (:jmp (:esi :ecx ,(+ (slot-offset 'movitz-funobj 'constant0)
 						 (* 4 label-id)))))))))))) ; transfer control, finally.
 
-(define-special-operator block (&all forward &funobj funobj &form form &env env &result-mode result-mode)
+(define-special-operator block (&all forward &funobj funobj &form form &env env
+				     &result-mode result-mode)
   (destructuring-bind (block-name &body body)
       (cdr form)
     (let* ((exit-block-label (gensym (format nil "exit-block-~A-" block-name)))
@@ -1140,27 +1141,26 @@
 	    :type '(values &rest t)
 	    :code code))))))
 
-(defun make-compiled-catch-wrapper (tag-form funobj env body-returns body-code &optional exit-point-pusher)
+(defun make-compiled-catch-wrapper (tag-form funobj env body-returns body-code)
   (assert (member body-returns '(:multiple-values :non-local-exit)))
   (values 4				; stack-used, must be added to body-code's env.
-	  (with-labels (catch (exit-point-offset exit-point))
-	    (append (or exit-point-pusher
-			`((:locally (:pushl (:edi (:edi-offset dynamic-env))))
-			  (:call (:pc+ 0)) ; push EIP
-			  ,exit-point-offset
-			  (:addl '(:funcall - ',exit-point ',exit-point-offset) (:esp))))
+	  (with-labels (catch (label-set exit-point))
+	    (append `((:declare-label-set ,label-set (,exit-point))
+		      (:locally (:pushl (:edi (:edi-offset dynamic-env)))) ; push dynamic-env
+		      (:pushl ',label-set))
 		    (compiler-call #'compile-form
 		      :env env
-		      ;; :with-stack-used 2
+		      :with-stack-used 2
 		      :funobj funobj
 		      :form tag-form
 		      :result-mode :push)
 		    `((:pushl :ebp)	; push stack frame
 		      (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) ; install catch
 		    body-code
-		    `((:leal (:esp ,(+ -4 16)) :esp)
-		      (:locally (:popl (:edi (:edi-offset dynamic-env)))))
-		    `(,exit-point)))))
+		    `((:popl :ebp)	; This value is identical to current EBP.
+		      ,exit-point
+		      (:leal (:esp ,(+ -8 16)) :esp)
+		      (:locally (:popl (:edi (:edi-offset dynamic-env)))))))))
 
 (define-special-operator unwind-protect (&all all &form form &env env)
   (destructuring-bind (protected-form &body cleanup-forms)