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

[Frode Vatvedt Fjeld]

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

Modified Files:
	los0.lisp 
Log Message:
install-shallow-binding now really seems to work.

Date: Fri Nov 12 17:25:10 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.24 movitz/losp/los0.lisp:1.25
--- movitz/losp/los0.lisp:1.24	Thu Nov 11 20:28:18 2004
+++ movitz/losp/los0.lisp	Fri Nov 12 17:25:09 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.24 2004/11/11 19:28:18 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.25 2004/11/12 16:25:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1254,7 +1254,7 @@
     (:ret)))
 
 (defun genesis ()
-  (install-shallow-binding)
+  ;; (install-shallow-binding)
   (let ((extended-memsize 0))
     ;;  Find out how much extended memory we have 
     (setf (io-port #x70 :unsigned-byte8) #x18)
@@ -1491,9 +1491,10 @@
     (:locally (:cmpl :ecx (:edi (:edi-offset dynamic-env))))
     (:je 'install-completed)
     (:movl (:ecx 0) :eax)		; symbol
+    (:movl (:eax (:offset movitz-symbol value)) :ebx) ; symbol's old-value into EBX
+    (:movl :ebx (:ecx 4))		; save old-value in binding's scratch
     (:movl (:ecx 8) :ebx)		; new value
-    (:xchgl :ebx (:eax (:offset movitz-symbol value))) ; exchange new and old value
-    (:movl :ebx (:ecx 8))
+    (:movl :ebx (:eax (:offset movitz-symbol value))) ; install new value
     (:movl (:ecx 12) :ecx)
     (:jmp 'install-loop)
    install-completed
@@ -1517,7 +1518,7 @@
     (:cmpl :edx :ecx)
     (:je 'uninstall-completed)
     (:movl (:ecx 0) :eax)		; symbol
-    (:movl (:ecx 8) :ebx)		; old value
+    (:movl (:ecx 4) :ebx)		; old value
     (:movl :ebx (:eax (:offset movitz-symbol value))) ; reload old value
     (:movl (:ecx 12) :ecx)
     (:jmp 'uninstall-loop)
@@ -1550,15 +1551,31 @@
     (:movl :ebx (:eax (:offset movitz-symbol value)))
     (:ret)))
 
-(defun install-shallow-binding ()
-  (macrolet ((install (slot function)
-	       `(setf (%run-time-context-slot ',slot) (symbol-value ',function))))
-    (install muerte:dynamic-variable-install dynamic-variable-install-shallow)
-    (install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow)
-    (install muerte::dynamic-store dynamic-store-shallow)
-    (install muerte::dynamic-load-unprotected dynamic-load-unprotected-shallow)
-    (install muerte::dynamic-load dynamic-load-shallow))
-  (values))
+(defun install-shallow-binding (&key quiet)
+  (without-interrupts
+    (unless quiet
+      (warn "Installing shallow-binding strategy.."))
+    (macrolet ((install (slot function)
+		 `(prog1 (cons ',slot (%run-time-context-slot ',slot))
+		    (setf (%run-time-context-slot ',slot) (symbol-value ',function)))))
+      (list (install muerte:dynamic-variable-install dynamic-variable-install-shallow)
+	    (install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow)
+	    (install muerte::dynamic-store dynamic-store-shallow)
+	    (install muerte::dynamic-load-unprotected dynamic-load-unprotected-shallow)
+	    (prog1 (install muerte::dynamic-load dynamic-load-shallow)
+	      (labels ((install-shallow-env (env)
+			 "We use this local function in order to install dynamic-env slots
+                          in reverse order, by depth-first recursion."
+			 (unless (eq 0 env)
+			   (install-shallow-env (memref env 12))
+			   (let ((name (memref env 0)))
+			     (when (symbolp name)
+			       (setf (memref env 4)
+				 (%symbol-global-value name))
+			       (setf (%symbol-global-value name)
+				 (memref env 8)))))))
+		(install-shallow-env (load-global-constant dynamic-env
+							   :thread-local t))))))))
 
 (genesis)