From ffjeld at common-lisp.net  Tue Mar  1 00:41:33 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue,  1 Mar 2005 01:41:33 +0100 (CET)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp 
Message-ID: <20050301004133.A51E3884E2@common-lisp.net>

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

Modified Files:
	debugger.lisp 
Log Message:
Have find-function-name search (setf ...) and (method ...) namespaces.

Date: Tue Mar  1 01:41:32 2005
Author: ffjeld

Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.35 movitz/losp/x86-pc/debugger.lisp:1.36
--- movitz/losp/x86-pc/debugger.lisp:1.35	Tue Mar  1 00:34:02 2005
+++ movitz/losp/x86-pc/debugger.lisp	Tue Mar  1 01:41:32 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 22 10:09:18 2002
 ;;;;                
-;;;; $Id: debugger.lisp,v 1.35 2005/02/28 23:34:02 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.36 2005/03/01 00:41:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -614,12 +614,31 @@
 			(location-in-object-p (%run-time-context-slot slot-name)
 					      instruction-location))
 	       (return (values slot-name :run-time-context))))
-      (do-all-symbols (symbol)
-	(when (and (fboundp symbol)
+      (with-hash-table-iterator (hashis (get-global-property :setf-namespace))
+	(do () (nil)
+	  (multiple-value-bind (morep setf-name symbol)
+	      (hashis)
+	    (cond
+	     ((not morep)
+	      (return nil))
+	     ((and (fboundp symbol)
 		   (location-in-code-vector-p%unsafe (funobj-code-vector (symbol-function symbol))
 						     instruction-location))
-	  (return symbol))
+	      (return (list 'setf setf-name)))))))
+      (do-all-symbols (symbol)
+	(when (fboundp symbol)
+	  (let ((f (symbol-function symbol)))
+	    (when (location-in-code-vector-p%unsafe (funobj-code-vector f)
+						    instruction-location)
+	      (return symbol))
+	    (when (typep f 'generic-function)
+	      (dolist (m (generic-function-methods f))
+		(when (location-in-code-vector-p%unsafe (funobj-code-vector (method-function m))
+							instruction-location)
+		  (return-from find-function-name
+		    (funobj-name (method-function m))))))))
 	(when (and (boundp symbol)
 		   (typep (symbol-value symbol) 'code-vector)
 		   (location-in-code-vector-p%unsafe (symbol-value symbol) instruction-location))
 	  (return (values symbol :symbol-value))))))
+



From ffjeld at common-lisp.net  Wed Mar  2 17:15:44 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed,  2 Mar 2005 18:15:44 +0100 (CET)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/io-port.lisp 
Message-ID: <20050302171544.76C5288669@common-lisp.net>

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

Modified Files:
	io-port.lisp 
Log Message:
Fixed stupid bug in (setf io-port :character), the byte output would
be completely wrong.

Date: Wed Mar  2 18:15:43 2005
Author: ffjeld

Index: movitz/losp/muerte/io-port.lisp
diff -u movitz/losp/muerte/io-port.lisp:1.12 movitz/losp/muerte/io-port.lisp:1.13
--- movitz/losp/muerte/io-port.lisp:1.12	Wed Sep 22 19:43:35 2004
+++ movitz/losp/muerte/io-port.lisp	Wed Mar  2 18:15:43 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001-2004, 
+;;;;    Copyright (C) 2001-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Mar 21 22:14:08 2001
 ;;;;                
-;;;; $Id: io-port.lisp,v 1.12 2004/09/22 17:43:35 ffjeld Exp $
+;;;; $Id: io-port.lisp,v 1.13 2005/03/02 17:15:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -165,7 +165,6 @@
 	      (:load-lexical (:lexical-binding ,value-var) :eax)
 	      (:std)
 	      (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
-	      (:shrl ,movitz::+movitz-fixnum-shift+ :eax)
 	      (:shrl 8 :eax)
 	      (:outb :al :dx)
 	      (:movl :edi :edx)



From ffjeld at common-lisp.net  Wed Mar  9 07:16:48 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed,  9 Mar 2005 08:16:48 +0100 (CET)
Subject: [movitz-cvs] CVS update: movitz/losp/lib/repl.lisp 
Message-ID: <20050309071648.D317E88665@common-lisp.net>

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

Modified Files:
	repl.lisp 
Log Message:
Only interpret integers as restarts when we're in a debugger context.

Date: Wed Mar  9 08:16:48 2005
Author: ffjeld

Index: movitz/losp/lib/repl.lisp
diff -u movitz/losp/lib/repl.lisp:1.14 movitz/losp/lib/repl.lisp:1.15
--- movitz/losp/lib/repl.lisp:1.14	Thu Feb 24 13:21:30 2005
+++ movitz/losp/lib/repl.lisp	Wed Mar  9 08:16:48 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Mar 19 14:58:12 2003
 ;;;;                
-;;;; $Id: repl.lisp,v 1.14 2005/02/24 12:21:30 ffjeld Exp $
+;;;; $Id: repl.lisp,v 1.15 2005/03/09 07:16:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -83,6 +83,7 @@
 					    (copy-list results)))
 		     (values-list results)))
 	      (let ((restart (and (integerp form)
+				  muerte:*debugger-dynamic-context*
 				  (muerte:find-restart-by-index form
 								muerte:*debugger-dynamic-context*))))
 		(cond



From ffjeld at common-lisp.net  Wed Mar  9 07:18:18 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed,  9 Mar 2005 08:18:18 +0100 (CET)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cpu-id.lisp 
Message-ID: <20050309071818.5710088665@common-lisp.net>

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

Modified Files:
	cpu-id.lisp 
Log Message:
Mask edx to a _positive_ fixnum.

Date: Wed Mar  9 08:18:15 2005
Author: ffjeld

Index: movitz/losp/muerte/cpu-id.lisp
diff -u movitz/losp/muerte/cpu-id.lisp:1.9 movitz/losp/muerte/cpu-id.lisp:1.10
--- movitz/losp/muerte/cpu-id.lisp:1.9	Sat Aug 14 19:55:29 2004
+++ movitz/losp/muerte/cpu-id.lisp	Wed Mar  9 08:18:14 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001-2004, 
+;;;;    Copyright (C) 2001-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Apr 15 22:47:13 2002
 ;;;;                
-;;;; $Id: cpu-id.lisp,v 1.9 2004/08/14 17:55:29 ffjeld Exp $
+;;;; $Id: cpu-id.lisp,v 1.10 2005/03/09 07:18:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -197,11 +197,12 @@
     (:rdtsc)				; Read Time-Stamp Counter into EDX:EAX
     (:shldl 5 :eax :edx)
     (:shll #.movitz:+movitz-fixnum-shift+ :eax)
-    (:andl #.(cl:logxor #xffffffff movitz::+movitz-fixnum-zmask+) :edx)
+    (:andl #.(cl:* movitz:+movitz-fixnum-factor+ movitz:+movitz-most-positive-fixnum+)
+	   :edx)
     (:andl #.(cl:* movitz:+movitz-fixnum-factor+ movitz:+movitz-most-positive-fixnum+)
 	   :eax)
-    (:movl :edx :ebx)
     (:cld)
+    (:movl :edx :ebx)
     (:movl 2 :ecx)
     (:stc)))
 		      



From ffjeld at common-lisp.net  Wed Mar  9 07:19:20 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed,  9 Mar 2005 08:19:20 +0100 (CET)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp 
Message-ID: <20050309071920.CF20288665@common-lisp.net>

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

Modified Files:
	environment.lisp 
Log Message:
Be less worried about bignums when computing CPU-cycles in time.

Date: Wed Mar  9 08:19:20 2005
Author: ffjeld

Index: movitz/losp/muerte/environment.lisp
diff -u movitz/losp/muerte/environment.lisp:1.9 movitz/losp/muerte/environment.lisp:1.10
--- movitz/losp/muerte/environment.lisp:1.9	Tue Jan 25 14:45:54 2005
+++ movitz/losp/muerte/environment.lisp	Wed Mar  9 08:19:19 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Oct 20 00:41:57 2001
 ;;;;                
-;;;; $Id: environment.lisp,v 1.9 2005/01/25 13:45:54 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.10 2005/03/09 07:19:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -139,13 +139,10 @@
 				    (time-skew-measure start-mem x-lo x-hi))
 			   finally (return x)))))
 	   (clumps (and start-mem (- (malloc-cons-pointer) start-mem)))
-	   (delta-hi (- end-time-hi start-time-hi))
-	   (delta-lo (- end-time-lo start-time-lo skew)))
-      (if (= 0 delta-hi)
-	  (format t "~&;; CPU cycles: ~D.~@[~%;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~]~%"
-		  delta-lo clumps clumps)
-	(format t "~&;; CPU cycles: ~DM.~%~@[;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~]~%"
-		(+ (ash delta-hi 9) (ash delta-lo -20)) clumps clumps)))))
+	   (delta-time (+ (ash (- end-time-hi start-time-hi) 29)
+			  (- end-time-lo start-time-lo skew))))
+      (format t "~&;; CPU cycles: ~D.~%~@[;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~]~%"
+	      delta-time clumps clumps))))
 
 (defmacro time (form)
   `(let ((start-mem (malloc-cons-pointer)))



From ffjeld at common-lisp.net  Wed Mar  9 07:19:54 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed,  9 Mar 2005 08:19:54 +0100 (CET)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <20050309071954.85CF388665@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Add :tag as a type for memref.

Date: Wed Mar  9 08:19:53 2005
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.43 movitz/losp/muerte/memref.lisp:1.44
--- movitz/losp/muerte/memref.lisp:1.43	Wed Feb  2 08:47:34 2005
+++ movitz/losp/muerte/memref.lisp	Wed Mar  9 08:19:53 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.43 2005/02/02 07:47:34 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.44 2005/03/09 07:19:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -83,7 +83,7 @@
 		     `(let ((,object-var ,object)
 			    (,offset-var ,offset))
 			(with-inline-assembly (:returns :untagged-fixnum-ecx
-							:type (unsigned-byte 16))
+							:type (unsigned-byte 8))
 			  (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object-var ,offset-var)
 			  ;; (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
 			  (:movzxb (:eax :ecx ,(offset-by 1)) :ecx)
@@ -287,6 +287,28 @@
 			    (:addl :ebx :ecx)
 			    (:movl (:eax :ecx ,(offset-by 4)) :ecx)
 			    (:andl -4 :ecx)))))))
+		(:tag
+		 (assert (= 4 movitz::+movitz-fixnum-factor+))
+		 (cond
+		  ((and (eq 0 offset) (eq 0 index))
+		   `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3))
+		      (:compile-form (:result-mode :eax) ,object)
+		      (:movl (:eax ,(offset-by 4)) :ecx)
+		      (:andl 7 :ecx)))
+		  ((eq 0 offset)
+		   `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3))
+		      (:compile-two-forms (:eax :ecx) ,object ,index)
+		      (:movl (:eax :ecx ,(offset-by 4)) :ecx)
+		      (:andl 7 :ecx)))
+		  (t (let ((object-var (gensym "memref-object-")))
+		       `(let ((,object-var ,object))
+			  (with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3))
+			    (:compile-two-forms (:ecx :ebx) ,offset ,index)
+			    (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
+			    (:load-lexical (:lexical-binding ,object-var) :eax)
+			    (:addl :ebx :ecx)
+			    (:movl (:eax :ecx ,(offset-by 4)) :ecx)
+			    (:andl 7 :ecx)))))))
 		(:unsigned-byte32
 		 (let ((endian (movitz:movitz-eval endian env)))
 		   (assert (member endian '(:host :little))))



From ffjeld at common-lisp.net  Wed Mar  9 07:20:55 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed,  9 Mar 2005 08:20:55 +0100 (CET)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp 
Message-ID: <20050309072055.CE2CE88665@common-lisp.net>

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

Modified Files:
	interrupt.lisp 
Log Message:
Add (setf dit-frame-ref).

Date: Wed Mar  9 08:20:55 2005
Author: ffjeld

Index: movitz/losp/muerte/interrupt.lisp
diff -u movitz/losp/muerte/interrupt.lisp:1.40 movitz/losp/muerte/interrupt.lisp:1.41
--- movitz/losp/muerte/interrupt.lisp:1.40	Thu Feb  3 10:18:55 2005
+++ movitz/losp/muerte/interrupt.lisp	Wed Mar  9 08:20:54 2005
@@ -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.40 2005/02/03 09:18:55 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.41 2005/03/09 07:20:54 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -73,6 +73,10 @@
 		(eq nil (movitz:movitz-eval stack env))))
       form
     `(setf (memref ,frame (dit-frame-offset ,reg) :type ,type) ,value)))
+
+(defun (setf dit-frame-ref) (value stack frame reg &optional (type :lisp))
+  (setf (stack-frame-ref stack (+ frame (dit-frame-index reg)) 0 type)
+    value))
 
 (defun dit-frame-casf (stack dit-frame)
   "Compute the `currently active stack-frame' when the interrupt occurred."



From ffjeld at common-lisp.net  Wed Mar  9 07:21:43 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed,  9 Mar 2005 08:21:43 +0100 (CET)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/serial.lisp 
Message-ID: <20050309072143.3DE748866C@common-lisp.net>

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

Modified Files:
	serial.lisp 
Log Message:
Some hacking for sending console output to serial port.

Date: Wed Mar  9 08:21:42 2005
Author: ffjeld

Index: movitz/losp/x86-pc/serial.lisp
diff -u movitz/losp/x86-pc/serial.lisp:1.2 movitz/losp/x86-pc/serial.lisp:1.3
--- movitz/losp/x86-pc/serial.lisp:1.2	Thu May 20 20:16:13 2004
+++ movitz/losp/x86-pc/serial.lisp	Wed Mar  9 08:21:42 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001-2004, 
+;;;;    Copyright (C) 2001-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 11 14:42:12 2002
 ;;;;                
-;;;; $Id: serial.lisp,v 1.2 2004/05/20 18:16:13 ffjeld Exp $
+;;;; $Id: serial.lisp,v 1.3 2005/03/09 07:21:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,7 +18,7 @@
 (provide :x86-pc/serial)
 
 (defpackage muerte.x86-pc.serial
-  (:use muerte.cl muerte.lib muerte.x86-pc)
+  (:use muerte.cl muerte.lib muerte.x86-pc muerte)
   (:export uart-probe
 	   uart-divisor
 	   uart-baudrate
@@ -147,6 +147,28 @@
 ;;;(defun uart-read-char (io-base)
 ;;;  (loop until ))
 
+(defun uart-write-char (io-base char)
+  (loop until (logbitp 5 (io-register8 io-base +uart-read-lsr+)))
+  (setf (io-port (+ io-base +uart-write-transmitter-buffer+) :character)
+    char))
+
+(defun make-serial-write-char (&key (io-base (or (some #'uart-probe +uart-probe-addresses+)
+						 (error "No serial port found.")))
+				    (baudrate 9600)
+				    (word-length 8)
+				    (parity :none)
+				    (stop-bits 1))
+  (setf (uart-baudrate io-base) baudrate
+	(io-register8 io-base +uart-write-lcr+) (encode-uart-lcr word-length parity stop-bits))
+  (setf (io-register8 io-base +uart-write-fcr+) 0)
+  (lambda (char &optional stream)
+    (case char
+      (#\newline
+       (uart-write-char io-base #\return)))
+    (uart-write-char io-base char)
+    (muerte::%write-char char (muerte::output-stream-designator stream))))
+
+
 (defun com (string &key (io-base (or (some #'uart-probe +uart-probe-addresses+)
 				     (error "No serial port found.")))
 			(baudrate 9600)
@@ -157,7 +179,6 @@
 	(io-register8 io-base +uart-write-lcr+) (encode-uart-lcr word-length parity stop-bits))
   (setf (io-register8 io-base +uart-write-fcr+) 0)
   (loop for c across string
-      do (loop until (logbitp 5 (io-register8 io-base +uart-read-lsr+)))
-	 (setf (io-port (+ io-base +uart-write-transmitter-buffer+) :character) c))
+      do (uart-write-char io-base c))
   io-base)
 



From ffjeld at common-lisp.net  Wed Mar  9 07:22:33 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed,  9 Mar 2005 08:22:33 +0100 (CET)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp 
Message-ID: <20050309072233.3742988665@common-lisp.net>

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

Modified Files:
	debugger.lisp 
Log Message:
Rename find-function-name to locate-function, and improve it.

Date: Wed Mar  9 08:22:32 2005
Author: ffjeld

Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.36 movitz/losp/x86-pc/debugger.lisp:1.37
--- movitz/losp/x86-pc/debugger.lisp:1.36	Tue Mar  1 01:41:32 2005
+++ movitz/losp/x86-pc/debugger.lisp	Wed Mar  9 08:22:32 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 22 10:09:18 2002
 ;;;;                
-;;;; $Id: debugger.lisp,v 1.36 2005/03/01 00:41:32 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.37 2005/03/09 07:22:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -606,39 +606,46 @@
 			   c)))))))
   (values))
 
-(defun find-function-name (instruction-location)
-  "Try to find a name bound to a function whose code-vector matches instruction-location."
+(defun locate-function (instruction-location)
+  "Try to find a function whose code-vector matches instruction-location, or just a code-vector."
   (check-type instruction-location fixnum)
-  (or (loop for (slot-name type) in (slot-value (class-of (current-run-time-context)) 'slot-map)
-	  do (when (and (eq type 'code-vector-word)
-			(location-in-object-p (%run-time-context-slot slot-name)
-					      instruction-location))
-	       (return (values slot-name :run-time-context))))
-      (with-hash-table-iterator (hashis (get-global-property :setf-namespace))
-	(do () (nil)
-	  (multiple-value-bind (morep setf-name symbol)
-	      (hashis)
-	    (cond
-	     ((not morep)
-	      (return nil))
-	     ((and (fboundp symbol)
-		   (location-in-code-vector-p%unsafe (funobj-code-vector (symbol-function symbol))
-						     instruction-location))
-	      (return (list 'setf setf-name)))))))
-      (do-all-symbols (symbol)
-	(when (fboundp symbol)
-	  (let ((f (symbol-function symbol)))
-	    (when (location-in-code-vector-p%unsafe (funobj-code-vector f)
-						    instruction-location)
-	      (return symbol))
-	    (when (typep f 'generic-function)
-	      (dolist (m (generic-function-methods f))
-		(when (location-in-code-vector-p%unsafe (funobj-code-vector (method-function m))
-							instruction-location)
-		  (return-from find-function-name
-		    (funobj-name (method-function m))))))))
-	(when (and (boundp symbol)
-		   (typep (symbol-value symbol) 'code-vector)
-		   (location-in-code-vector-p%unsafe (symbol-value symbol) instruction-location))
-	  (return (values symbol :symbol-value))))))
+  (labels ((match-funobj (function instruction-location &optional (limit 5))
+	     (cond
+	      ((location-in-code-vector-p%unsafe (funobj-code-vector function)
+						 instruction-location)
+	       function)
+	      ((not (plusp limit))
+	       nil)			; recurse no more.
+	      ;; Search for a local function.
+	      ((loop for i from (funobj-num-jumpers function) below (funobj-num-constants function)
+		   as x = (funobj-constant-ref function i)
+		   thereis (and (typep x 'function)
+				(match-funobj x instruction-location (1- limit)))))
+	      ;; Search a GF's method functions.
+	      ((when (typep function 'generic-function)
+		 (loop for m in (generic-function-methods function)
+		     thereis (match-funobj (method-function m) instruction-location (1- limit))))))))
+    (or (loop for (slot-name type) in (slot-value (class-of (current-run-time-context)) 'slot-map)
+	    do (when (and (eq type 'code-vector-word)
+			  (location-in-object-p (%run-time-context-slot slot-name)
+						instruction-location))
+		 (return (values slot-name :run-time-context))))
+	(with-hash-table-iterator (hashis (get-global-property :setf-namespace))
+	  (do () (nil)
+	    (multiple-value-bind (morep setf-name symbol)
+		(hashis)
+	      (cond
+	       ((not morep)
+		(return nil))
+	       ((fboundp symbol)
+		(let ((it (match-funobj (symbol-function symbol) instruction-location)))
+		  (when it (return it))))))))
+	(do-all-symbols (symbol)
+	  (when (fboundp symbol)
+	    (let ((it (match-funobj (symbol-function symbol) instruction-location)))
+	      (when it (return it))))
+	  (when (and (boundp symbol)
+		     (typep (symbol-value symbol) 'code-vector)
+		     (location-in-code-vector-p%unsafe (symbol-value symbol) instruction-location))
+	    (return (values symbol :symbol-value)))))))
 



From ffjeld at common-lisp.net  Wed Mar  9 07:24:17 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed,  9 Mar 2005 08:24:17 +0100 (CET)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <20050309072417.F3A4D88665@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Code-vector migration now appears to work.

Date: Wed Mar  9 08:24:17 2005
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.48 movitz/losp/muerte/scavenge.lisp:1.49
--- movitz/losp/muerte/scavenge.lisp:1.48	Tue Feb 15 23:22:47 2005
+++ movitz/losp/muerte/scavenge.lisp	Wed Mar  9 08:24:16 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.48 2005/02/15 22:22:47 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.49 2005/03/09 07:24:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -90,19 +90,51 @@
 	      (memref scan 0 :type :unsigned-byte32) scan)
 	    (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	    ;; Process code-vector pointers specially..
-	    (let* ((funobj (%word-offset scan #.(movitz:tag :other)))
-		   (code-vector (funobj-code-vector funobj))
-		   (num-jumpers (funobj-num-jumpers funobj)))
-	      (check-type code-vector code-vector)
-	      (map-header-vals function (+ scan 5) (+ scan 7)) ; scan funobj's lambda-list and name
-	      (let ((new-code-vector (funcall function code-vector scan)))
-		(check-type new-code-vector code-vector)
-		(unless (eq code-vector new-code-vector)
-		  (error "Code-vector migration is not implemented (~S)." funobj)
-		  (setf (memref scan 0 :index -1) (%word-offset new-code-vector 2))
-		  ;; Do more stuff here to update code-vectors and jumpers
-		  ))
-	      (incf scan (+ 7 num-jumpers)))) ; Don't scan the jumpers.
+	    (let* ((old-code-vector (memref (incf scan) 0 :type :code-vector))
+		   (new-code-vector (map-instruction-pointer function scan old-code-vector)))
+	      (cond
+	       ((not (eq new-code-vector old-code-vector))
+		;; Code-vector%1op
+		(if (location-in-code-vector-p%unsafe old-code-vector
+						      (memref (incf scan) 0 :type :location))
+		    (map-instruction-pointer function scan old-code-vector)
+		  (map-instruction-pointer function scan))
+		;; Code-vector%2op
+		(if (location-in-code-vector-p%unsafe old-code-vector
+						      (memref (incf scan) 0 :type :location))
+		    (map-instruction-pointer function scan old-code-vector)
+		  (map-instruction-pointer function scan))
+		;; Code-vector%3op
+		(if (location-in-code-vector-p%unsafe old-code-vector
+						      (memref (incf scan) 0 :type :location))
+		    (map-instruction-pointer function scan old-code-vector)
+		  (map-instruction-pointer function scan))
+		;; lambda-list and name
+		(map-header-vals function (incf scan) (incf scan 2))
+		;; Jumpers
+		(let ((num-jumpers (memref scan 0 :type :unsigned-byte14)))
+		  (dotimes (i num-jumpers)
+		    (map-instruction-pointer function (incf scan) old-code-vector))))
+	       ((eq new-code-vector old-code-vector)
+		;; Code-vector%1op
+		(unless (location-in-code-vector-p%unsafe old-code-vector
+							  (memref (incf scan) 0 :type :location))
+		  (map-instruction-pointer function scan))
+		;; Code-vector%2op
+		(unless (location-in-code-vector-p%unsafe old-code-vector
+							  (memref (incf scan) 0 :type :location))
+		  (map-instruction-pointer function scan))
+		;; Code-vector%3op
+		(unless (location-in-code-vector-p%unsafe old-code-vector
+							  (memref (incf scan) 0 :type :location))
+		  (map-instruction-pointer function scan))
+		;; lambda-list and name
+		(map-header-vals function (incf scan) (incf scan 2))
+		;; Jumpers
+		(let ((num-jumpers (memref scan 0 :type :unsigned-byte14))
+		      #+ignore (num-constants (memref scan 2 :type :unsigned-byte16)))
+		  (incf scan num-jumpers)
+		  #+ignore (warn "~D jumpers for ~S, ~S" num-jumpers *scan-last* scan))))))
 	   ((scavenge-typep x :infant-object)
 	    (assert (evenp scan) ()
 	      "Scanned infant ~S at odd location #x~X." x scan)
@@ -168,51 +200,54 @@
 	     (+ start-frame 1)
 	     map-region))
 
-(defun scavenge-find-pf (location)
+(defun scavenge-match-code-vector (function code-vector location)
+  "Is location inside code-vector, under evacuator function?
+If so, return the actual code-vector pointer that matches."
+  (if (location-in-code-vector-p%unsafe code-vector location)
+      code-vector
+    (let ((fwd (funcall function code-vector nil)))
+      (check-type fwd code-vector)
+      (when (location-in-code-vector-p%unsafe fwd location)
+	fwd))))
+
+(defun scavenge-find-pf (function location)
   (loop for (slot-name type) in (slot-value (class-of (current-run-time-context)) 'slot-map)
       do (when (eq type 'code-vector-word)
-	   (let ((code-vector (%run-time-context-slot slot-name)))
-	     (when (location-in-object-p code-vector location)
-	       (return code-vector))))))
+	   (let ((it (scavenge-match-code-vector function (%run-time-context-slot slot-name) location)))
+	     (when it (return it))))))
 
-(defun scavenge-find-code-vector (location casf-funobj esi &optional primitive-function-p edx)
-  (flet ((match-funobj (funobj location)
+(defun scavenge-find-code-vector (function location casf-funobj esi &optional primitive-function-p edx)
+  (flet ((match-funobj (function funobj location)
 	   (cond
 	    ((not (typep funobj 'function))
 	     nil)
 	    ((let ((x (funobj-code-vector funobj)))
-	       (and (location-in-object-p x location) x)))
+	       (scavenge-match-code-vector function x location)))
 	    ((let ((x (funobj-code-vector%1op funobj)))
-	       (and (typep x 'vector)
-		    (location-in-object-p x location)
-		    x)))
+	       (and (typep x '(not fixnum))
+		    (scavenge-match-code-vector function x location))))
 	    ((let ((x (funobj-code-vector%2op funobj)))
-	       (and (typep x 'vector)
-		    (location-in-object-p x location)
-		    x)))
+	       (and (typep x '(not fixnum))
+		    (scavenge-match-code-vector function x location))))
 	    ((let ((x (funobj-code-vector%3op funobj)))
-	       (and (typep x 'vector)
-		    (location-in-object-p x location)
-		    x))))))
+	       (and (typep x '(not fixnum))
+		    (scavenge-match-code-vector function x location)))))))
     (cond
-     ((location-in-object-p (symbol-value 'ret-trampoline) location)
-      (symbol-value 'ret-trampoline))
-     ((location-in-object-p (%run-time-context-slot 'dynamic-jump-next) location)
-      (%run-time-context-slot 'dynamic-jump-next))
+     ((scavenge-match-code-vector function (symbol-value 'ret-trampoline) location))
+     ((scavenge-match-code-vector function (%run-time-context-slot 'dynamic-jump-next) location))
      ((eq 0 casf-funobj)
       (let ((dit-code-vector (symbol-value 'default-interrupt-trampoline)))
 	(cond
-	 ((location-in-object-p dit-code-vector location)
-	  dit-code-vector)
-	 ((match-funobj esi location))
+	 ((scavenge-match-code-vector function dit-code-vector location))
+	 ((match-funobj function esi location))
 	 (t (break "DIT returns outside DIT??")))))
-     ((match-funobj casf-funobj location))
-     ((match-funobj esi location))      
-     ((match-funobj edx location))
+     ((match-funobj function casf-funobj location))
+     ((match-funobj function esi location))      
+     ((match-funobj function edx location))
      ((not (typep casf-funobj 'function))
       (break "Unknown funobj/frame-type: ~S" casf-funobj))
      ((when primitive-function-p
-	(scavenge-find-pf location)
+	(scavenge-find-pf function location)
 	#+ignore
 	(%find-code-vector location)))
      (t (with-simple-restart (continue "Try to perform a code-vector-search.")
@@ -243,7 +278,8 @@
 	      ((not (typep frame-funobj 'function))
 	       (error "Unknown stack-frame funobj ~S at ~S" frame-funobj frame))
 	      (t (let* ((old-code-vector
-			 (scavenge-find-code-vector (stack-frame-ref nil eip-index 0 :location)
+			 (scavenge-find-code-vector function
+						    (stack-frame-ref nil eip-index 0 :location)
 						    frame-funobj nil nil)))
 		   (map-instruction-pointer function eip-index old-code-vector))
 		 (let ((raw-locals (funobj-frame-raw-locals frame-funobj)))
@@ -275,11 +311,9 @@
 	   (casf-frame
 	    (dit-frame-casf nil dit-frame))
 	   (casf-funobj (map-stack-value function (stack-frame-funobj nil casf-frame) casf-frame))
-	   (casf-code-vector (map-stack-value function
-					      (case casf-funobj
-						(0 (symbol-value 'default-interrupt-trampoline))
-						(t (funobj-code-vector casf-funobj)))
-					      casf-frame)))
+	   (casf-code-vector (case casf-funobj
+			       (0 (symbol-value 'default-interrupt-trampoline))
+			       (t (funobj-code-vector casf-funobj)))))
       ;; 1. Scavenge the dit-frame
       (cond
        ((and (not (= 0 atomically))
@@ -301,7 +335,8 @@
 	     (next-frame-bottom (+ dit-frame 1 (dit-frame-index :eflags)))
 	     (next-eip-index (+ dit-frame (dit-frame-index :eip)))
 	     (old-code-vector
-	      (scavenge-find-code-vector (stack-frame-ref nil eip-index 0 :location)
+	      (scavenge-find-code-vector function
+					 (stack-frame-ref nil eip-index 0 :location)
 					 0 interrupted-esi
 					 nil))
 	     (new-code-vector (map-instruction-pointer function eip-index old-code-vector)))
@@ -312,17 +347,18 @@
 	   ((and (or (eq x0-tag 1)	; 1 or 5?
 		     (eq x0-tag 3)	; 3 or 7?
 		     (and (oddp x0-location) (eq x0-tag 2))) ; 6?
-		 (location-in-object-p casf-code-vector x0-location))
+		 (scavenge-match-code-vector function casf-code-vector x0-location))
 	    (when (= #xc3 (memref-int (stack-frame-ref nil next-eip-index 0 :unsigned-byte32)
 				      :physicalp nil :type :unsigned-byte8))
 	      (setf (stack-frame-ref nil next-eip-index 0 :code-vector)
 		(symbol-value 'ret-trampoline)))
 	    (let* ((old-x0-code-vector
-		    (scavenge-find-code-vector (stack-frame-ref nil next-eip-index 0 :location)
+		    (scavenge-find-code-vector function
+					       (stack-frame-ref nil next-eip-index 0 :location)
 					       casf-funobj interrupted-esi t
 					       (unless secondary-register-mode-p
 						 (dit-frame-ref nil dit-frame :edx)))))
-	      (map-instruction-pointer function next-eip-index old-x0-code-vector))
+	      (map-instruction-pointer function next-eip-index old-x0-code-vector dit-frame))
 	    (setf next-eip-index next-frame-bottom
 		  next-frame-bottom (1+ next-frame-bottom)))
 	   (t (multiple-value-bind (x1-location x1-tag)
@@ -330,28 +366,54 @@
 		(when (and (or (eq x1-tag 1) ; 1 or 5?
 			       (eq x1-tag 3) ; 3 or 7?
 			       (and (oddp x1-location) (eq x1-tag 2))) ; 6?
-			   (location-in-object-p casf-code-vector x1-location))
+			   (scavenge-match-code-vector function casf-code-vector x1-location))
 		  (let* ((old-x1-code-vector
-			  (scavenge-find-code-vector (stack-frame-ref nil next-eip-index 0 :location)
+			  (scavenge-find-code-vector function
+						     (stack-frame-ref nil next-eip-index 0 :location)
 						     casf-funobj
 						     (unless secondary-register-mode-p
 						       interrupted-esi)
 						     t)))
-		    (map-instruction-pointer function next-eip-index old-x1-code-vector))
+		    (map-instruction-pointer function next-eip-index old-x1-code-vector dit-frame))
 		  (setf next-eip-index (+ 1 next-frame-bottom)
 			next-frame-bottom (+ 2 next-frame-bottom)))))))
 	;; proceed
 	(map-stack function casf-frame next-frame-bottom next-eip-index map-region)))))
 
 (defun map-instruction-pointer (function location
-				&optional (old-code-vector (memref location 0 :type :code-vector)))
+				&optional (old-code-vector (memref location 0 :type :code-vector))
+					  debug-context)
   "Update the (raw) instruction-pointer at location,
 assuming the pointer refers to old-code-vector."
-  (check-type old-code-vector code-vector)
-  (assert (location-in-object-p old-code-vector (memref location 0 :type :location)))
-  (let ((new-code-vector (funcall function old-code-vector nil)))
-    (when (not (eq old-code-vector new-code-vector))
-      (break "Code-vector for stack instruction-pointer moved at location ~S" location))
-    new-code-vector))
+  ;; (check-type old-code-vector code-vector) ; Can't de-reference old objects..
+  (let ((old-ip-location (memref location 0 :type :location)))
+    (assert (location-in-code-vector-p%unsafe old-code-vector old-ip-location))
+    (let ((new-code-vector (funcall function old-code-vector nil)))
+      (when (not (eq old-code-vector new-code-vector))
+	(check-type new-code-vector code-vector)
+	(let ((location-offset (- old-ip-location (object-location old-code-vector)))
+	      (lowbits (ldb (byte 2 0) (memref location 0 :type :unsigned-byte8))))
+	  (let ((oeip (memref location 0 :type :unsigned-byte32))
+		(neip (+ (* 4 (object-location new-code-vector))
+			 (* location-offset 4)
+			 lowbits)))
+	    #+ignore
+	    (warn "Instruction-pointer moved at location ~S, old=~S [~S ~S ~S], new=~Z ~S [~S ~S ~S] context ~S"
+		  location
+		  oeip
+		  (memref-int oeip :physicalp nil :type :unsigned-byte8 :offset 0)
+		  (memref-int oeip :physicalp nil :type :unsigned-byte8 :offset 1)
+		  (memref-int oeip :physicalp nil :type :unsigned-byte8 :offset 2)
+		  new-code-vector
+		  neip
+		  (memref-int neip :physicalp nil :type :unsigned-byte8 :offset 0)
+		  (memref-int neip :physicalp nil :type :unsigned-byte8 :offset 1)
+		  (memref-int neip :physicalp nil :type :unsigned-byte8 :offset 2)
+		  debug-context))
+	  (setf (memref location 0 :type :unsigned-byte32)
+	    (+ (* 4 (object-location new-code-vector))
+	       (* location-offset 4)
+	       lowbits))))
+      new-code-vector)))
 
 



From ffjeld at common-lisp.net  Wed Mar  9 07:24:38 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed,  9 Mar 2005 08:24:38 +0100 (CET)
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <20050309072438.A52D388665@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
*** empty log message ***
Date: Wed Mar  9 08:24:37 2005
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.44 movitz/packages.lisp:1.45
--- movitz/packages.lisp:1.44	Fri Feb 25 08:58:26 2005
+++ movitz/packages.lisp	Wed Mar  9 08:24:37 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Nov 15 21:39:55 2003
 ;;;;                
-;;;; $Id: packages.lisp,v 1.44 2005/02/25 07:58:26 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.45 2005/03/09 07:24:37 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1129,6 +1129,7 @@
 	   #:stack-frame-ref
 	   #:check-stack-limit
 	   #:dit-frame-ref
+	   #:dit-frame-casf
 	   #:interrupt-default-handler
 	   #:exception-handler
 



From ffjeld at common-lisp.net  Wed Mar  9 07:24:55 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed,  9 Mar 2005 08:24:55 +0100 (CET)
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <20050309072455.F16A188665@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
*** empty log message ***
Date: Wed Mar  9 08:24:55 2005
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.36 movitz/losp/los0.lisp:1.37
--- movitz/losp/los0.lisp:1.36	Tue Jan  4 21:24:00 2005
+++ movitz/losp/los0.lisp	Wed Mar  9 08:24:54 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.36 2005/01/04 20:24:00 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.37 2005/03/09 07:24:54 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -20,6 +20,7 @@
 (require :x86-pc/io-space)
 (require :x86-pc/ne2k)
 (require :x86-pc/floppy)
+(require :x86-pc/serial)
 
 (require :lib/readline)
 (require :lib/toplevel)
@@ -40,7 +41,7 @@
 ;; 	#:muerte.ip6
 	#:muerte.ip4
 	#:muerte.mop
-	#+ignore muerte.x86-pc.serial))
+	#:muerte.x86-pc.serial))
 
 (require :los0-gc)			; Must come after defpackage.
 
@@ -1011,7 +1012,8 @@
   (if (not (and (boundp '*debugger-condition*)
 		*debugger-condition*))
       (fresh-line)
-    (let ((condition *debugger-condition*))
+    (let ((condition *debugger-condition*)
+	  (*print-safely* t))
       (cond
        ((consp condition)
 	(fresh-line)
@@ -1141,7 +1143,7 @@
 (defun random (limit)
   (etypecase limit
     (fixnum
-     (rem (read-time-stamp-counter) limit))
+     (mod (read-time-stamp-counter) limit))
     (muerte::positive-bignum
      (let ((x (muerte::copy-bignum limit)))
        (dotimes (i (1- (muerte::%bignum-bigits x)))
@@ -1210,8 +1212,9 @@
 	(assert (string= fasit x) ()
 	  "Failed tesT. Fasit: ~S, X: ~S" fasit x)))))
 
-(defun test-clc (&optional timeout)
-  (test-timer timeout)
+(defun test-clc (&optional timeout no-timer)
+  (unless no-timer
+    (test-timer timeout))
   (loop
     (funcall (find-symbol (string :test-clc) :clc))))
 
@@ -1231,7 +1234,7 @@
 ;;;		 (vector-push funobj ts)
 ;;;		 (vector-push offset ts)
 ;;;		 (vector-push code-vector ts))))
-      (muerte::cli)
+;;;      (muerte::cli)
       (pic8259-end-of-interrupt 0)
       (when (eql #\esc (muerte.x86-pc.keyboard:poll-char))
 	(break "Test-timer keyboard break."))
@@ -1246,12 +1249,11 @@
 	(when (eq (with-inline-assembly (:returns :eax) (:movl :esi :eax))
 		  (stack-frame-funobj nil frame))
 	  (error "Double interrupt.")))
-      #+ignore
-      (dolist (range muerte::%memory-map-roots%)
-	(map-header-vals (lambda (x type)
-			   (declare (ignore type))
-			   x)
-			 (car range) (cdr range)))
+;;;      (dolist (range muerte::%memory-map-roots%)
+;;;	(map-header-vals (lambda (x type)
+;;;			   (declare (ignore type))
+;;;			   x)
+;;;			 (car range) (cdr range)))
       (map-stack-vector (lambda (x foo)
 			  (declare (ignore foo))
 			  x)
@@ -1261,11 +1263,12 @@
 	(:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*)
 	(:shrl 2 :ecx)
 	((:gs-override) :movb #x20 (:ecx 159)))
-      (setf *timer-prevstack* *timer-stack*
-	    *timer-stack* (muerte::copy-current-control-stack))
+      #+ignore (setf *timer-prevstack* *timer-stack*
+		     *timer-stack* (muerte::copy-current-control-stack))
       (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+
 	    (pit8253-timer-count 0) (or timeout (+ base (random variation))))
-      (muerte::sti)))
+;;;      (muerte::sti)
+      ))
   (with-inline-assembly (:returns :nothing)
     (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*)
     (:shrl 2 :ecx)
@@ -1274,24 +1277,10 @@
 	(pit8253-timer-count 0) (or timeout (+ base (random variation))))
   (setf (pic8259-irq-mask) #xfffe)
   (pic8259-end-of-interrupt 0)
-  (with-inline-assembly (:returns :nothing) (:sti))
-  ;; (dotimes (i 100000))
-  #+ignore
-  (with-inline-assembly (:returns :nothing)
-    (:compile-two-forms (:ebx :edx)
-			(read-time-stamp-counter)
-			(read-time-stamp-counter))
-    (:movl :eax (#x1000000))
-    (:movl :ebx (#x1000004))
-    (:movl :ecx (#x1000008))
-    (:movl :edx (#x100000c))
-    (:movl :ebp (#x1000010))
-    (:movl :esp (#x1000014))
-    (:movl :esi (#x1000018))
-    (:halt)
-    (:cli)
-    (:halt)
-    ))
+  (with-inline-assembly (:returns :nothing) (:sti)))
+
+(defun wetweg (x)
+  (memref-int (memref x 2 :type :unsigned-byte32) :physicalp nil :type :unsigned-byte8))
 
 (defun test-throwing (&optional (x #xffff))
   (when x
@@ -1338,7 +1327,7 @@
     (:jno 'no-overflow)
     (:movl 4 :eax)
    no-overflow))
-    
+
 (defun genesis ()
   ;; (install-shallow-binding)
   (let ((extended-memsize 0))
@@ -1352,10 +1341,11 @@
     (idt-init)
     (install-los0-consing :kb-size 500)
     #+ignore
-    (install-los0-consing :kb-size (max 100 (truncate (- extended-memsize 2048) 2))))
+    (install-los0-consing :kb-size (max 50 (truncate (- extended-memsize 2048) 2))))
 
   (setf *debugger-function* #'los0-debugger)
   (clos-bootstrap)
+  (install-shallow-binding)
   (let ((*repl-readline-context* (make-readline-context :history-size 16))
 	#+ignore (*backtrace-stack-frame-barrier* (stack-frame-uplink (current-stack-frame)))
 	#+ignore (*error-no-condition-for-debugger* t)
@@ -1385,6 +1375,10 @@
 		       *standard-input* s
 		       *terminal-io* s
 		       *debug-io* s)))
+;;;    (ignore-errors
+;;;     (setf (symbol-function 'write-char)
+;;;       (muerte.x86-pc.serial::make-serial-write-char :baudrate 38400))
+;;;     (format t "~&Installed serial-port write-char."))
     (let ((* nil) (** nil) (*** nil)
 	  (/ nil) (// nil) (/// nil)
 	  (+ nil) (++ nil) (+++ nil)
@@ -1409,41 +1403,6 @@
   (let ((string (muerte.readline:contextual-readline *repl-readline-context*)))
     (simple-read-from-string string eof-error-p eof-value)))
 
-(defun handle-warning (condition)
-  (format t "Handle-warning: ~S" condition)
-  (throw :debugger nil))
-
-(defun zoo (x)
-  (cond
-   (x (warn "foo"))
-   (t nil))
-  nil)
-
-#+ignore
-(defun progntest ()
-  (prog ()
-    (unwind-protect
-	(progn
-	  (print 'x) 
-	  (go mumbo)
-	  (error "bar"))
-      (print 'y))
-   mumbo))
-
-#+ignore
-(defun test-restart (x)
-  (with-simple-restart (test "It's just a test, so ignore ~S." x)
-    (check-type x symbol)))
-
-#+ignore
-(defun condtest ()
-  (format t "You have two attempts..")
-  (handler-bind
-      ((error #'(lambda (c) (print 'x) (warn "An error occurred..")))
-       (warning #'handle-warning)
-       (t #'invoke-debugger))
-    (read-eval-print)
-    (read-eval-print)))
 
 #+ignore
 (defun ztstring (physical-address)



From ffjeld at common-lisp.net  Wed Mar  9 07:31:29 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed,  9 Mar 2005 08:31:29 +0100 (CET)
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <20050309073129.8802488665@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Includes testing of code-vector migration.

Date: Wed Mar  9 08:31:28 2005
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.48 movitz/losp/los0-gc.lisp:1.49
--- movitz/losp/los0-gc.lisp:1.48	Thu Jan 27 08:48:53 2005
+++ movitz/losp/los0-gc.lisp	Wed Mar  9 08:31:28 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.48 2005/01/27 07:48:53 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.49 2005/03/09 07:31:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -335,9 +335,19 @@
 (defparameter *x* #4000(nil))		; Have this in static space.
 (defparameter *xx* #4000(nil))		; Have this in static space.
 
+(defparameter *code-vector-foo* 0)
+(defvar *old-code-vectors* #250())
+(defvar *new-code-vectors* #250())
+
+(defun debug (location x)
+  (setf (dummy x)
+    (let ((new (shallow-copy x)))
+      (warn "[~S] Migrating code-vector ~Z => ~Z." location x new)
+      new)))
 
 (defun stop-and-copy (&optional evacuator)
   (setf (fill-pointer *x*) 0)
+  (setf (fill-pointer *old-code-vectors*) 0)
   (multiple-value-bind (newspace oldspace)
       (without-interrupts
 	(let* ((space0 (%run-time-context-slot 'nursery-space))
@@ -349,14 +359,37 @@
 	  (setf (%run-time-context-slot 'nursery-space) space1)
 	  (values space1 space0)))
     ;; Evacuate-oldspace is to be mapped over every potential pointer.
-    (let ((evacuator
+    (let ((*code-vector-foo* (incf *code-vector-foo* 2))
+	  (evacuator
 	   (or evacuator
 	       (lambda (x location)
 		 "If x is in oldspace, migrate it to newspace."
-		 (declare (ignore location))
+		 ;; (declare (ignore location))
 		 (cond
 		  ((null x)
 		   nil)
+		  ((object-in-space-p newspace x)
+		   x)
+		  ((and (typep x 'code-vector)
+			(not (object-in-space-p oldspace x))
+			(not (object-in-space-p newspace x))
+			(= (ldb (byte 12 0) (object-location x))
+			   (ldb (byte 12 0) *code-vector-foo*))
+			(not (eq x (funobj-code-vector #'stop-and-copy)))
+			(not (eq x (symbol-value 'muerte::default-interrupt-trampoline)))
+;;;			(not (eq x (symbol-value 'muerte::ret-trampoline)))
+			(not (muerte::scavenge-find-pf (lambda (x y) x) (object-location x))))
+		   (let ((p (position (object-location x) *old-code-vectors*)))
+		     (if p
+			 (aref *new-code-vectors* p)
+		       (setf (aref *new-code-vectors*
+				   (vector-push (object-location x) *old-code-vectors*))
+			 (let ((new (shallow-copy x)))
+			   (warn "[~S] Migrating ~@[~S ~]~Z => ~Z." 
+				 location
+				 (muerte::locate-function (object-location x))
+				 x new)
+			   new)))))
 		  ((not (object-in-space-p oldspace x))
 		   x)
 		  (t (or (and (eq (object-tag x)
@@ -375,47 +408,57 @@
 			   (setf (memref (object-location x) 0) forward-x)
 			   forward-x))))))))
       ;; Scavenge roots
-      (dolist (range muerte::%memory-map-roots%)
-	(map-header-vals evacuator (car range) (cdr range)))
-      (map-stack-vector evacuator nil (current-stack-frame))
+      (with-simple-restart (nil "Scanning stack.")
+	(map-stack-vector evacuator nil (current-stack-frame)))
+      (with-simple-restart (nil "Scanning heap.")
+	(dolist (range muerte::%memory-map-roots%)
+	  (map-header-vals evacuator (car range) (cdr range))))
       ;; Scan newspace, Cheney style.
-      (loop with newspace-location = (+ 2 (object-location newspace))
-	  with scan-pointer = 2
-	  as fresh-pointer = (space-fresh-pointer newspace)
-	  while (< scan-pointer fresh-pointer)
-	  do (map-header-vals evacuator
-			      (+ newspace-location scan-pointer)
-			      (+ newspace-location (space-fresh-pointer newspace)))
-	     (setf scan-pointer fresh-pointer))
-
+      (with-simple-restart (nil "Cheney-scanning newspace.")
+	(loop with newspace-location = (+ 2 (object-location newspace))
+	    with scan-pointer = 2
+	    as fresh-pointer = (space-fresh-pointer newspace)
+	    while (< scan-pointer fresh-pointer)
+	    do (map-header-vals evacuator
+				(+ newspace-location scan-pointer)
+				(+ newspace-location (space-fresh-pointer newspace)))
+	       (setf scan-pointer fresh-pointer)))
       ;; Consistency check..
+      (map-stack-vector (lambda (x foo)
+			  (declare (ignore foo))
+			  x)
+			nil
+			(current-stack-frame))
       (when *gc-consitency-check*
-	(without-interrupts
-	  (let ((a *x*))
-	    ;; First, restore the state of old-space
-	    (do ((i 0 (+ i 3)))
-		((>= i (length a)))
-	      (let ((old (%lispval-object (aref a i)))
-		    (old-class (aref a (+ i 1))))
-		(setf (memref (object-location old) 0 :type :unsigned-byte32) old-class)))
-	    ;; Then, check that each migrated object is equalp to its new self.
-	    (do ((i 0 (+ i 3)))
-		((>= i (length a)))
-	      (let ((old (%lispval-object (aref a i)))
-		    (new (%lispval-object (aref a (+ i 2)))))
-		(unless (and (object-in-space-p newspace new)
-			     (object-in-space-p oldspace old)
-			     (objects-equalp old new))
-		  (let ((*old* old)
-			(*new* new)
-			(*old-class* (aref a (+ i 1))))
-		    (declare (special *old* *new* *old-class*))
-		    (with-simple-restart (continue "Ignore failed GC consistency check.")
+	(with-simple-restart (continue "Ignore failed GC consistency check.")
+	  (without-interrupts
+	    (let ((a *x*))
+	      ;; First, restore the state of old-space
+	      (do ((end (- (length a) 2))
+		   (i 0 (+ i 3)))
+		  ((>= i end))
+		(let ((old (%lispval-object (aref a i)))
+		      (old-class (aref a (+ i 1))))
+		  (setf (memref (object-location old) 0 :type :unsigned-byte32) old-class)))
+	      ;; Then, check that each migrated object is equalp to its new self.
+	      (do ((i 0 (+ i 3)))
+		  ((>= i (length a)))
+		(let ((old (%lispval-object (aref a i)))
+		      (new (%lispval-object (aref a (+ i 2)))))
+		  (unless (and (object-in-space-p newspace new)
+			       (not (object-in-space-p newspace old))
+			       (objects-equalp old new))
+		    (let ((*evacuator* evacuator)
+			  (*old* old)
+			  (*new* new)
+			  (*old-class* (aref a (+ i 1))))
+		      (declare (special *old* *new* *old-class* *evacuator*))
 		      (error "GC consistency check failed:
 old object: ~Z: ~S
 new object: ~Z: ~S
+equalp: ~S
 oldspace: ~Z, newspace: ~Z, i: ~D"
-			     old old new new oldspace newspace i))))))
+			     old old new new (objects-equalp old new) oldspace newspace i))))))
 	    (map-header-vals (lambda (x y)
 			       (declare (ignore y))
 			       (when (location-in-object-p (space-other (%run-time-context-slot 'nursery-space))
@@ -442,6 +485,10 @@
 				(location-in-object-p oldspace (object-location o)))
 		       (break "Seeing old (unmapped) object ~Z in stack at ~S."
 			      o (+ (object-location stack) i 2))))))))
+      (loop for o across *old-code-vectors*
+	  for n across *new-code-vectors*
+	  do (setf (memref o 0) (memref n -6))
+	     (fill (muerte::%location-object o 6) #xcc))
       ;; GC completed, oldspace is evacuated.
       (unless *gc-quiet*
 	(let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2))
@@ -454,9 +501,37 @@
       (fill oldspace #x13 :start 2)
       ;; (setf *gc-stack2* *gc-stack*)
       (setf *gc-stack* (muerte::copy-current-control-stack))
-      (setf (fill-pointer *xx*) (fill-pointer *x*))
-      (replace *xx* *x*)))
+      #+ignore (setf (fill-pointer *xx*) (fill-pointer *x*))
+      #+ignore (replace *xx* *x*)))
   (values))
+
+(defun simple-stop-and-copy (newspace oldspace)
+  (flet ((evacuator (x)
+	   "If x is in oldspace, migrate it to newspace."
+	   (if (not (object-in-space-p oldspace x))
+	       x
+	     (or (and (eq (object-tag x)
+			  (memref (object-location x) 0 :type :tag))
+		      (let ((forwarded-x (memref (object-location x) 0)))
+			(and (object-in-space-p newspace forwarded-x)
+			     forwarded-x)))
+		 (setf (memref (object-location x) 0)
+		   (shallow-copy x))))))
+    ;; Scavenge roots
+    (map-stack-vector #'evacuator nil (current-stack-frame))
+    (dolist (range muerte::%memory-map-roots%)
+      (map-header-vals #'evacuator (car range) (cdr range)))
+    ;; Scan newspace, Cheney style.
+    (loop with newspace-location = (+ 2 (object-location newspace))
+	with scan-pointer = 2
+	as fresh-pointer = (space-fresh-pointer newspace)
+	while (< scan-pointer fresh-pointer)
+	do (map-header-vals #'evacuator
+			    (+ newspace-location scan-pointer)
+			    (+ newspace-location (space-fresh-pointer newspace)))
+	   (setf scan-pointer fresh-pointer))
+    (initialize-space oldspace)
+    (values)))
 
 
 (defun find-object-by-location (location &key (continuep t) (breakp nil))



From ffjeld at common-lisp.net  Wed Mar  9 07:33:10 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed,  9 Mar 2005 08:33:10 +0100 (CET)
Subject: [movitz-cvs] CVS update: public_html/ChangeLog 
Message-ID: <20050309073310.2033D88665@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
*** empty log message ***
Date: Wed Mar  9 08:33:09 2005
Author: ffjeld

Index: public_html/ChangeLog
diff -u public_html/ChangeLog:1.2 public_html/ChangeLog:1.3
--- public_html/ChangeLog:1.2	Thu Feb 24 13:23:08 2005
+++ public_html/ChangeLog	Wed Mar  9 08:33:09 2005
@@ -1,3 +1,9 @@
+2005-03-09  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
+
+	* Added/much improved support for GC-migration of
+	code-vectors. Should now work well, except for some extreme corner
+	cases such as the interrupt-trampoline code-vector.
+
 2005-02-24  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
 
 	* Entering an integer at the REPL now invokes the corresponding