[movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp

[Frode Vatvedt Fjeld]

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

Modified Files:
	interrupt.lisp 
Log Message:
*** empty log message ***
Date: Thu Nov 11 11:08:45 2004
Author: ffjeld

Index: movitz/losp/muerte/interrupt.lisp
diff -u movitz/losp/muerte/interrupt.lisp:1.29 movitz/losp/muerte/interrupt.lisp:1.30
--- movitz/losp/muerte/interrupt.lisp:1.29	Mon Oct 11 15:52:54 2004
+++ movitz/losp/muerte/interrupt.lisp	Thu Nov 11 11:08:44 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Apr  7 01:50:03 2004
 ;;;;                
-;;;; $Id: interrupt.lisp,v 1.29 2004/10/11 13:52:54 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.30 2004/11/11 10:08:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -62,6 +62,14 @@
 (defun dit-frame-ref (stack frame reg &optional (type :lisp))
   (stack-frame-ref stack frame (dit-frame-index reg) type))
 
+(define-compiler-macro (setf dit-frame-ref) (&whole form value stack frame reg
+					     &optional (type :lisp)
+					     &environment env)
+  (if (not (and (movitz:movitz-constantp stack env)
+		(eq nil (movitz:movitz-eval stack env))))
+      form
+    `(setf (memref ,frame (dit-frame-offset ,reg) :type ,type) ,value)))
+
 ;;;(defun (setf dit-frame-ref) (x reg type &optional (frame *last-dit-frame*))
 ;;;  (setf (memref frame (dit-frame-offset reg) 0 type) x))
 
@@ -117,7 +125,7 @@
 				     :key #'dit-frame-index)
 		  collect `(:pushl ,reg))
 	    (:locally (:pushl (:edi (:edi-offset scratch1))))
-	    
+ 	    
 	    (:locally (:movl (:edi (:edi-offset nursery-space)) :eax))
 	    (:pushl :eax)		; debug0: nursery-space
 	    (:pushl (:eax 2))		; debug1: nursery-space's fresh-pointer
@@ -126,9 +134,9 @@
 	    
 	    ;; Do RET atomicification
 	    (:movl (:ebp ,(dit-frame-offset :eip)) :ecx)
-	    (:cmpb ,(realpart (ia-x86:asm :ret)) (:ecx))
+	    ((:cs-override) :cmpb ,(realpart (ia-x86:asm :ret)) (:ecx))
 	    (:jne 'not-at-ret-instruction)
-	    (:locally (:movl (:edi (:edi-offset ret-trampoline)) :ecx))
+	    (:globally (:movl (:edi (:edi-offset ret-trampoline)) :ecx))
 	    (:movl :ecx (:ebp ,(dit-frame-offset :eip)))
 	   not-at-ret-instruction
 	    
@@ -259,6 +267,9 @@
 	    )))
     (do-it)))
 
+
+
+
 (defun interrupt-default-handler (vector dit-frame)
   (declare (without-check-stack-limit))
   (macrolet ((dereference (fixnum-address &optional (type :lisp))
@@ -277,7 +288,7 @@
 	  (3 (break "Break instruction at ~@Z." $eip))
 	  (4 (error "Primitive overflow assertion failed."))
 	  (6 (error "Illegal instruction at ~@Z." $eip))
-	  (13 (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z"
+	  (13  (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z"
 		     $eip
 		     (dit-frame-ref nil dit-frame :error-code :unsigned-byte32)
 		     $eax $ebx $ecx))
@@ -309,6 +320,7 @@
 		  (stack (%run-time-context-slot 'movitz::stack-vector))
 		  (real-bottom (- (object-location stack) 2))
 		  (stack-left (- old-bottom real-bottom))
+		  (old-es (segment-register :es))
 		  (old-dynamic-env (%run-time-context-slot 'dynamic-env))
 		  (new-bottom (cond
 			       ((< stack-left 50)
@@ -325,8 +337,9 @@
 	     (unwind-protect
 		 (progn
 		   (setf (%run-time-context-slot 'stack-bottom) new-bottom
-			 (%run-time-context-slot 'dynamic-env) 0)
-		   (format *debug-io* "~&Stack-warning: Bumped stack-bottom by ~D to #x~X. Reset ENV.~%"
+			 (%run-time-context-slot 'dynamic-env) 0
+			 (segment-register :es) (segment-register :ds))
+		   (format *debug-io* "~&Stack-warning: Bumped stack-bottom by ~D to #x~X. Reset ENV and ES.~%"
 			   (- old-bottom new-bottom)
 			   new-bottom)
 		   (break "Stack overload exception ~D at EIP=~@Z, ESP=~@Z, bottom=#x~X, ENV=#x~X."
@@ -337,7 +350,8 @@
 	       (format *debug-io* "~&Stack-warning: Resetting stack-bottom to #x~X.~%"
 		       old-bottom)
 	       (setf (%run-time-context-slot 'stack-bottom) old-bottom
-		     (%run-time-context-slot 'dynamic-env) old-dynamic-env))))
+		     (%run-time-context-slot 'dynamic-env) old-dynamic-env
+		     (segment-register :es) old-es))))
 	  (69
 	   (error "Not a function: ~S" (dereference $edx)))
 	  (70