From ffjeld at common-lisp.net  Fri Apr  8 06:17:29 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri,  8 Apr 2005 08:17:29 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp 
Message-ID: <20050408061729.7705A18C6F5@common-lisp.net>

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

Modified Files:
	segments.lisp 
Log Message:
*** empty log message ***
Date: Fri Apr  8 08:17:29 2005
Author: ffjeld

Index: movitz/losp/muerte/segments.lisp
diff -u movitz/losp/muerte/segments.lisp:1.4 movitz/losp/muerte/segments.lisp:1.5
--- movitz/losp/muerte/segments.lisp:1.4	Thu Oct 21 22:51:13 2004
+++ movitz/losp/muerte/segments.lisp	Fri Apr  8 08:17:28 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001, 2003-2004, 
+;;;;    Copyright (C) 2001, 2003-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:    Thu May  8 14:25:06 2003
 ;;;;                
-;;;; $Id: segments.lisp,v 1.4 2004/10/21 20:51:13 ffjeld Exp $
+;;;; $Id: segments.lisp,v 1.5 2005/04/08 06:17:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,13 +18,13 @@
 
 (in-package muerte)
 
-(defun segment-register (segment-register)
+(defun segment-register-name (segment-register-name)
   "Return the value of an x86 segment register, such as :cs or :ds."
   (macrolet ((sreg (reg)
 	       `(with-inline-assembly (:returns :untagged-fixnum-ecx)
 		  (:xorl :ecx :ecx)
 		  (:movw ,reg :cx))))
-    (ecase segment-register
+    (ecase segment-register-name
       (:ss (sreg :ss))
       (:cs (sreg :cs))
       (:ds (sreg :ds))
@@ -32,7 +32,7 @@
       (:fs (sreg :fs))
       (:gs (sreg :gs)))))
 
-(defun (setf segment-register) (value segment-register)
+(defun (setf segment-register-name) (value segment-register-name)
   "This function indiscriminately sets a segment register,
 which is a great way to crash the machine. So know what you're doing."
   (check-type value (unsigned-byte 16))
@@ -41,7 +41,7 @@
 		  (:compile-form (:result-mode :ecx) value)
 		  (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
 		  (:movw :cx ,reg))))
-    (ecase segment-register
+    (ecase segment-register-name
       (:ss (set-sreg :ss))
       (:cs (set-sreg :cs))
       (:ds (set-sreg :ds))



From ffjeld at common-lisp.net  Wed Apr 13 06:43:15 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 13 Apr 2005 08:43:15 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp 
Message-ID: <20050413064315.8EAA618C6C5@common-lisp.net>

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

Modified Files:
	segments.lisp 
Log Message:
Added segment-descriptor-xxx accessors.

Date: Wed Apr 13 08:43:14 2005
Author: ffjeld

Index: movitz/losp/muerte/segments.lisp
diff -u movitz/losp/muerte/segments.lisp:1.5 movitz/losp/muerte/segments.lisp:1.6
--- movitz/losp/muerte/segments.lisp:1.5	Fri Apr  8 08:17:28 2005
+++ movitz/losp/muerte/segments.lisp	Wed Apr 13 08:43:12 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu May  8 14:25:06 2003
 ;;;;                
-;;;; $Id: segments.lisp,v 1.5 2005/04/08 06:17:28 ffjeld Exp $
+;;;; $Id: segments.lisp,v 1.6 2005/04/13 06:43:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -50,7 +50,7 @@
       (:gs (set-sreg :gs))))
   value)
 
-(defun sgdt ()
+(defun %sgdt ()
   "Return the location of the GDT, and the limit.
 Error if the GDT location is not zero modulo 4."
   (eval-when (:compile-toplevel)
@@ -74,7 +74,7 @@
     (:movl 2 :ecx)
     (:stc)))
 
-(defun lgdt (base-location limit)
+(defun %lgdt (base-location limit)
   "Set the GDT according to base-location and limit.
 This is the setter corresponding to the sgdt getter."
   (eval-when (:compile-toplevel)
@@ -162,4 +162,67 @@
       (:cr4 (set-creg :cr4)))
     value))
     
-  
+(defun segment-descriptor-base (table index)
+  (check-type table (and vector (not simple-vector)))
+  (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))))
+    (logior (ash (memref table (+ 7 offset) :type :unsigned-byte8)
+		 24)
+	    (ash (memref table (+ 4 offset) :type :unsigned-byte16)
+		 16)
+	    (ash (memref table (+ 2 offset) :type :unsigned-byte16)
+		 0))))
+
+(defun (setf segment-descriptor-base) (base table index)
+  (check-type table (and vector (not simple-vector)))
+  (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))))
+    (setf (memref table (+ 7 offset) :type :unsigned-byte8)
+      (ldb (byte 8 24) base))
+    (setf (memref table (+ 4 offset) :type :unsigned-byte8)
+      (ldb (byte 8 16) base))
+    (setf (memref table (+ 2 offset) :type :unsigned-byte16)
+      (ldb (byte 16 0) base))
+    base))
+
+(defun segment-descriptor-limit (table index)
+  (check-type table (and vector (not simple-vector)))
+  (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))))
+    (dpb (memref table (+ 6 offset) :type :unsigned-byte8)
+	 (byte 4 16)
+	 (memref table (+ 0 offset) :type :unsigned-byte16))))
+
+(defun (setf segment-descriptor-limit) (limit table index)
+  (check-type table (and vector (not simple-vector)))
+  (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))))
+    (setf (memref table (+ 6 offset) :type :unsigned-byte8)
+      (ldb (byte 4 16) limit))
+    (setf (memref table (+ 0 offset) :type :unsigned-byte8)
+      (ldb (byte 16 0) limit))
+    limit))
+
+(defun segment-descriptor-type-s-dpl-p (table index)
+  "Access bits 40-47 of the segment descriptor."
+  (check-type table (and vector (not simple-vector)))
+  (memref table (+ 5 (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))
+	  :type :unsigned-byte8))
+
+(defun (setf segment-descriptor-type-s-dpl-p) (bits table index)
+  "Access bits 40-47 of the segment descriptor."
+  (check-type table (and vector (not simple-vector)))
+  (setf (memref table (+ 5 (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))
+		:type :unsigned-byte8)
+    bits))
+		   
+(defun segment-descriptor-avl-x-db-g (table index)
+  "Access bits 52-55 of the segment descriptor."
+  (check-type table (and vector (not simple-vector)))
+  (ldb (byte 4 4)
+       (memref table (+ 5 (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))
+	       :type :unsigned-byte8)))
+
+(defun (setf segment-descriptor-avl-x-db-g) (bits table index)
+  "Access bits 52-55 of the segment descriptor."
+  (check-type table (and vector (not simple-vector)))
+  (setf (ldb (byte 4 4)
+	     (memref table (+ 5 (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))
+		     :type :unsigned-byte8))
+    bits))



From ffjeld at common-lisp.net  Wed Apr 13 06:57:02 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 13 Apr 2005 08:57:02 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp 
Message-ID: <20050413065702.2E8A118C6C5@common-lisp.net>

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

Modified Files:
	segments.lisp 
Log Message:
Reworked %sgdt and %lgdt.

Date: Wed Apr 13 08:57:02 2005
Author: ffjeld

Index: movitz/losp/muerte/segments.lisp
diff -u movitz/losp/muerte/segments.lisp:1.6 movitz/losp/muerte/segments.lisp:1.7
--- movitz/losp/muerte/segments.lisp:1.6	Wed Apr 13 08:43:12 2005
+++ movitz/losp/muerte/segments.lisp	Wed Apr 13 08:57:01 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu May  8 14:25:06 2003
 ;;;;                
-;;;; $Id: segments.lisp,v 1.6 2005/04/13 06:43:12 ffjeld Exp $
+;;;; $Id: segments.lisp,v 1.7 2005/04/13 06:57:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -55,39 +55,38 @@
 Error if the GDT location is not zero modulo 4."
   (eval-when (:compile-toplevel)
     (assert (= 4 movitz:+movitz-fixnum-factor+)))
-  (with-inline-assembly (:returns :multiple-values)
-    (:pushl #.movitz:+scan-skip-word+)
-    (:pushl 2)
-    (:pushl 0)
-    (:pushl 0)
-    (:leal (:esp 2) :ecx)
-    (:sgdt (:ecx))
-    (:popl :ecx)
-    (:shrl 16 :ecx)
-    (:leal ((:ecx #.movitz::+movitz-fixnum-factor+)) :ebx)
-    (:popl :ecx)
-    (:testb 3 :cl)
-    (:jnz '(:sub-program ()
-	    (:compile-form (:result-mode :ignore)
-	     (error "The GDT base is not 4-aligned."))))
-    (:movl :ecx :eax)
-    (:movl 2 :ecx)
-    (:stc)))
+  (without-interrupts
+    (with-inline-assembly (:returns :multiple-values)
+      (:std)
+      (:pushl 0)
+      (:pushl 0)
+      (:leal (:esp 2) :ecx)
+      (:sgdt (:ecx))
+      (:popl :ebx)
+      (:shrl #.(cl:- 16 movitz::+movitz-fixnum-shift+) :ebx)
+      (:andl #.movitz:+movitz-fixnum-zmask+ :ebx)
+      (:popl :eax)
+      (:andl #.movitz:+movitz-fixnum-zmask+ :eax)
+      (:cld)
+      (:movl 2 :ecx)
+      (:stc))))
 
 (defun %lgdt (base-location limit)
   "Set the GDT according to base-location and limit.
 This is the setter corresponding to the sgdt getter."
   (eval-when (:compile-toplevel)
     (assert (= 4 movitz:+movitz-fixnum-factor+)))
-  (with-inline-assembly (:returns :nothing)
-    (:compile-two-forms (:eax :ebx) base-location limit)
-    (:pushl #.movitz:+scan-skip-word+)
-    (:pushl 2)
-    (:shll #.(cl:- 16 movitz:+movitz-fixnum-shift+) :ebx)
-    (:pushl :eax)
-    (:pushl :ebx)
-    (:leal (:esp 2) :ecx)
-    (:lgdt (:ecx))))
+  (check-type base-location fixnum)
+  (check-type limit positive-fixnum)
+  (without-interrupts
+    (with-inline-assembly (:returns :eax)
+      (:compile-form (:result-mode :push) base-location)
+      (:compile-form (:result-mode :push) limit)
+      (:shll #.(cl:- 16 movitz:+movitz-fixnum-shift+) (:esp))
+      (:leal (:esp 2) :ecx)
+      (:lgdt (:ecx))
+      (:popl :eax)
+      (:popl :eax))))
 
 ;;;
 



From ffjeld at common-lisp.net  Wed Apr 13 07:25:42 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 13 Apr 2005 09:25:42 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050413072542.C135F18C702@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fixed bug in make-result-and-returns-glue for case :boolean-cf=1 to
:ebx, :ecx, etc.

Date: Wed Apr 13 09:25:41 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.135 movitz/compiler.lisp:1.136
--- movitz/compiler.lisp:1.135	Sun Feb 27 03:30:22 2005
+++ movitz/compiler.lisp	Wed Apr 13 09:25:41 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.135 2005/02/27 02:30:22 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.136 2005/04/13 07:25:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -5084,7 +5084,7 @@
 	       (:boolean-cf=1
 		(values (append code
 				`((:sbbl :ecx :ecx)
-				  (:movl (:edi (:ecx 4) ,(global-constant-offset 'null-cons))
+				  (:movl (:edi (:ecx 4) ,(global-constant-offset 'not-not-nil))
 					 ,desired-result)))
 			desired-result))
 	       (#.+boolean-modes+



From ffjeld at common-lisp.net  Wed Apr 13 07:26:29 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 13 Apr 2005 09:26:29 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <20050413072629.B0F7718C702@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Added compiler-macro for logbitp.

Date: Wed Apr 13 09:26:29 2005
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.104 movitz/losp/muerte/integers.lisp:1.105
--- movitz/losp/muerte/integers.lisp:1.104	Thu Nov 25 19:05:48 2004
+++ movitz/losp/muerte/integers.lisp	Wed Apr 13 09:26:29 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2000-2004,
+;;;;    Copyright (C) 2000-2005,
 ;;;;    Department of Computer Science, University of Tromso, Norway
 ;;;; 
 ;;;; Filename:      integers.lisp
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.104 2004/11/25 18:05:48 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.105 2005/04/13 07:26:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1513,6 +1513,19 @@
 	       (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
 	       (:btl :ecx (:ebx (:offset movitz-bignum bigit0))))))))
     (do-it)))
+
+(define-compiler-macro logbitp (&whole form &environment env index integer)
+  (if (not (movitz:movitz-constantp index env))
+      form
+    (let ((index (movitz:movitz-eval index env)))
+      (check-type index (integer 0 *))
+      (typecase index
+	((integer 0 31)
+	 `(with-inline-assembly (:returns :boolean-cf=1)
+	    (:compile-form (:result-mode :untagged-fixnum-ecx) ,integer)
+	    (:btl ,index :ecx)))
+	(t form)))))
+
 
 (defun logand (&rest integers)
   (numargs-case



From ffjeld at common-lisp.net  Thu Apr 14 06:14:50 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 14 Apr 2005 08:14:50 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp 
Message-ID: <20050414061450.987218802E@common-lisp.net>

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

Modified Files:
	segments.lisp 
Log Message:
"segment-register-name" was a bad idea.

Date: Thu Apr 14 08:14:49 2005
Author: ffjeld

Index: movitz/losp/muerte/segments.lisp
diff -u movitz/losp/muerte/segments.lisp:1.7 movitz/losp/muerte/segments.lisp:1.8
--- movitz/losp/muerte/segments.lisp:1.7	Wed Apr 13 08:57:01 2005
+++ movitz/losp/muerte/segments.lisp	Thu Apr 14 08:14:49 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu May  8 14:25:06 2003
 ;;;;                
-;;;; $Id: segments.lisp,v 1.7 2005/04/13 06:57:01 ffjeld Exp $
+;;;; $Id: segments.lisp,v 1.8 2005/04/14 06:14:49 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,7 +18,7 @@
 
 (in-package muerte)
 
-(defun segment-register-name (segment-register-name)
+(defun segment-register (segment-register-name)
   "Return the value of an x86 segment register, such as :cs or :ds."
   (macrolet ((sreg (reg)
 	       `(with-inline-assembly (:returns :untagged-fixnum-ecx)
@@ -32,7 +32,7 @@
       (:fs (sreg :fs))
       (:gs (sreg :gs)))))
 
-(defun (setf segment-register-name) (value segment-register-name)
+(defun (setf segment-register) (value segment-register-name)
   "This function indiscriminately sets a segment register,
 which is a great way to crash the machine. So know what you're doing."
   (check-type value (unsigned-byte 16))



From ffjeld at common-lisp.net  Thu Apr 14 06:42:31 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 14 Apr 2005 08:42:31 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp 
Message-ID: <20050414064231.EC3D48802E@common-lisp.net>

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

Modified Files:
	segments.lisp 
Log Message:
Fixed bug in segment-descriptor-base.

Date: Thu Apr 14 08:42:31 2005
Author: ffjeld

Index: movitz/losp/muerte/segments.lisp
diff -u movitz/losp/muerte/segments.lisp:1.8 movitz/losp/muerte/segments.lisp:1.9
--- movitz/losp/muerte/segments.lisp:1.8	Thu Apr 14 08:14:49 2005
+++ movitz/losp/muerte/segments.lisp	Thu Apr 14 08:42:29 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu May  8 14:25:06 2003
 ;;;;                
-;;;; $Id: segments.lisp,v 1.8 2005/04/14 06:14:49 ffjeld Exp $
+;;;; $Id: segments.lisp,v 1.9 2005/04/14 06:42:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -166,7 +166,7 @@
   (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))))
     (logior (ash (memref table (+ 7 offset) :type :unsigned-byte8)
 		 24)
-	    (ash (memref table (+ 4 offset) :type :unsigned-byte16)
+	    (ash (memref table (+ 4 offset) :type :unsigned-byte8)
 		 16)
 	    (ash (memref table (+ 2 offset) :type :unsigned-byte16)
 		 0))))



From ffjeld at common-lisp.net  Fri Apr 15 07:00:31 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 15 Apr 2005 09:00:31 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <20050415070031.1DFB68802E@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Added a vector deftype, so that e.g. (vector (unsigned-byte 32))
should work.

Date: Fri Apr 15 09:00:31 2005
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.42 movitz/losp/muerte/typep.lisp:1.43
--- movitz/losp/muerte/typep.lisp:1.42	Tue Mar  1 00:39:04 2005
+++ movitz/losp/muerte/typep.lisp	Fri Apr 15 09:00:31 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.42 2005/02/28 23:39:04 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.43 2005/04/15 07:00:31 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -525,6 +525,9 @@
   (and (typep x 'cons)
        (or (eq '* car) (typep (car x) car))
        (or (eq '* cdr) (typep (cdr x) cdr))))
+
+(deftype vector (&optional (element-type '*) (size '*))
+  `(simple-array ,element-type (,size)))
 
 (define-simple-typep (atom atom) (x)
   (typep x 'atom))



From ffjeld at common-lisp.net  Fri Apr 15 07:03:10 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 15 Apr 2005 09:03:10 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/ll-testing.lisp 
Message-ID: <20050415070310.1BEDB8802E@common-lisp.net>

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

Added Files:
	ll-testing.lisp 
Log Message:
*** empty log message ***
Date: Fri Apr 15 09:03:09 2005
Author: ffjeld




From ffjeld at common-lisp.net  Fri Apr 15 07:03:48 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 15 Apr 2005 09:03:48 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <20050415070348.366F68802E@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Added :physicalp option for (memref :unsigned-byte32).

Date: Fri Apr 15 09:03:47 2005
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.44 movitz/losp/muerte/memref.lisp:1.45
--- movitz/losp/muerte/memref.lisp:1.44	Wed Mar  9 08:19:53 2005
+++ movitz/losp/muerte/memref.lisp	Fri Apr 15 09:03:47 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.44 2005/03/09 07:19:53 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.45 2005/04/15 07:03:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,12 +18,14 @@
 
 (in-package muerte)
 
-(define-compiler-macro memref (&whole form object offset &key (index 0) (type :lisp)
-							      (localp nil) (endian :host)
+(define-compiler-macro memref (&whole form object offset
+			       &key (index 0) (type :lisp) (localp nil) (endian :host)
+				    (physicalp nil)
 			       &environment env)
   (if (or (not (movitz:movitz-constantp type env))
 	  (not (movitz:movitz-constantp localp env))
-	  (not (movitz:movitz-constantp endian env)))
+	  (not (movitz:movitz-constantp endian env))
+	  (not (movitz:movitz-constantp physicalp env)))
       form
     (labels ((sub-extract-constant-delta (form)
 	       "Try to extract at compile-time an integer offset from form."
@@ -69,7 +71,10 @@
 	    (warn "o: ~S, co: ~S, i: ~S, ci: ~S"
 		  offset constant-offset
 		  index constant-index)
-	    (let ((type (movitz:movitz-eval type env)))
+	    (let ((type (movitz:movitz-eval type env))
+		  (physicalp (movitz:movitz-eval physicalp env)))
+	      (when (and physicalp (not (eq type :unsigned-byte32)))
+		(warn "(memref physicalp) unsupported for type ~S." type))
 	      (case type
 		(:unsigned-byte8
 		 (cond
@@ -310,29 +315,32 @@
 			    (:movl (:eax :ecx ,(offset-by 4)) :ecx)
 			    (:andl 7 :ecx)))))))
 		(:unsigned-byte32
-		 (let ((endian (movitz:movitz-eval endian env)))
-		   (assert (member endian '(:host :little))))
-		 (assert (= 4 movitz::+movitz-fixnum-factor+))
-		 (cond
-		  ((and (eq 0 offset) (eq 0 index))
-		   `(with-inline-assembly (:returns :untagged-fixnum-ecx
-						    :type (unsigned-byte 32))
-		      (:compile-form (:result-mode :eax) ,object)
-		      (:movl (:eax ,(offset-by 4)) :ecx)))
-		  ((eq 0 offset)
-		   `(with-inline-assembly (:returns :untagged-fixnum-ecx
-						    :type (unsigned-byte 32))
-		      (:compile-two-forms (:eax :ecx) ,object ,index)
-		      (:movl (:eax :ecx ,(offset-by 4)) :ecx)))
-		  (t (let ((object-var (gensym "memref-object-")))
-		       `(let ((,object-var ,object))
-			  (with-inline-assembly (:returns :untagged-fixnum-ecx
-							  :type (unsigned-byte 32))
-			    (: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)))))))
+		 (let ((endian (movitz:movitz-eval endian env))
+		       (prefixes (if (not physicalp)
+				     ()
+				   movitz:*compiler-physical-segment-prefix*)))
+		   (assert (member endian '(:host :little)))
+		   (assert (= 4 movitz::+movitz-fixnum-factor+))
+		   (cond
+		    ((and (eq 0 offset) (eq 0 index))
+		     `(with-inline-assembly (:returns :untagged-fixnum-ecx
+						      :type (unsigned-byte 32))
+			(:compile-form (:result-mode :eax) ,object)
+			(,prefixes :movl (:eax ,(offset-by 4)) :ecx)))
+		    ((eq 0 offset)
+		     `(with-inline-assembly (:returns :untagged-fixnum-ecx
+						      :type (unsigned-byte 32))
+			(:compile-two-forms (:eax :ecx) ,object ,index)
+			(,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx)))
+		    (t (let ((object-var (gensym "memref-object-")))
+			 `(let ((,object-var ,object))
+			    (with-inline-assembly (:returns :untagged-fixnum-ecx
+							    :type (unsigned-byte 32))
+			      (:compile-two-forms (:ecx :ebx) ,offset ,index)
+			      (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
+			      (:load-lexical (:lexical-binding ,object-var) :eax)
+			      (:addl :ebx :ecx)
+			      (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx))))))))
 		(:lisp
 		 (let* ((localp (movitz:movitz-eval localp env))
 			(prefixes (if localp



From ffjeld at common-lisp.net  Fri Apr 15 07:04:10 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 15 Apr 2005 09:04:10 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp 
Message-ID: <20050415070410.0B3078802E@common-lisp.net>

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

Modified Files:
	segments.lisp 
Log Message:
Fixed bugs in %sgdt and %lgdt.

Date: Fri Apr 15 09:04:10 2005
Author: ffjeld

Index: movitz/losp/muerte/segments.lisp
diff -u movitz/losp/muerte/segments.lisp:1.9 movitz/losp/muerte/segments.lisp:1.10
--- movitz/losp/muerte/segments.lisp:1.9	Thu Apr 14 08:42:29 2005
+++ movitz/losp/muerte/segments.lisp	Fri Apr 15 09:04:10 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu May  8 14:25:06 2003
 ;;;;                
-;;;; $Id: segments.lisp,v 1.9 2005/04/14 06:42:29 ffjeld Exp $
+;;;; $Id: segments.lisp,v 1.10 2005/04/15 07:04:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -64,9 +64,9 @@
       (:sgdt (:ecx))
       (:popl :ebx)
       (:shrl #.(cl:- 16 movitz::+movitz-fixnum-shift+) :ebx)
-      (:andl #.movitz:+movitz-fixnum-zmask+ :ebx)
+      (:andl -4 :ebx)
       (:popl :eax)
-      (:andl #.movitz:+movitz-fixnum-zmask+ :eax)
+      (:andl -4 :eax)
       (:cld)
       (:movl 2 :ecx)
       (:stc))))



From ffjeld at common-lisp.net  Fri Apr 15 07:04:25 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 15 Apr 2005 09:04:25 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <20050415070425.78BE78802E@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
*** empty log message ***
Date: Fri Apr 15 09:04:24 2005
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.37 movitz/losp/los0.lisp:1.38
--- movitz/losp/los0.lisp:1.37	Wed Mar  9 08:24:54 2005
+++ movitz/losp/los0.lisp	Fri Apr 15 09:04:24 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.37 2005/03/09 07:24:54 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.38 2005/04/15 07:04:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -27,6 +27,8 @@
 ;; (require :lib/net/ip6)
 (require :lib/net/ip4)
 (require :lib/repl)
+
+(require :ll-testing)
 
 (defpackage muerte.init
   (:nicknames #:los0)



From ffjeld at common-lisp.net  Sat Apr 16 16:20:39 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 16 Apr 2005 18:20:39 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/ll-testing.lisp 
Message-ID: <20050416162039.D7ED188678@common-lisp.net>

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

Modified Files:
	ll-testing.lisp 
Log Message:
*** empty log message ***
Date: Sat Apr 16 18:20:39 2005
Author: ffjeld

Index: movitz/losp/ll-testing.lisp
diff -u movitz/losp/ll-testing.lisp:1.1 movitz/losp/ll-testing.lisp:1.2
--- movitz/losp/ll-testing.lisp:1.1	Fri Apr 15 09:03:09 2005
+++ movitz/losp/ll-testing.lisp	Sat Apr 16 18:20:38 2005
@@ -10,10 +10,11 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Apr 14 08:18:43 2005
 ;;;;                
-;;;; $Id: ll-testing.lisp,v 1.1 2005/04/15 07:03:09 ffjeld Exp $
+;;;; $Id: ll-testing.lisp,v 1.2 2005/04/16 16:20:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
+(provide :ll-testing)
 (in-package muerte)
 
 (defun dump-global-segment-table (&key table entries nofill)



From ffjeld at common-lisp.net  Sun Apr 17 18:18:19 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 17 Apr 2005 20:18:19 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/packages.lisp 
Message-ID: <20050417181819.4FA84886F9@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
*** empty log message ***
Date: Sun Apr 17 20:18:18 2005
Author: ffjeld

Index: movitz/losp/muerte/packages.lisp
diff -u movitz/losp/muerte/packages.lisp:1.7 movitz/losp/muerte/packages.lisp:1.8
--- movitz/losp/muerte/packages.lisp:1.7	Tue Mar  1 00:36:08 2005
+++ movitz/losp/muerte/packages.lisp	Sun Apr 17 20:18:18 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Aug 30 15:19:43 2001
 ;;;;                
-;;;; $Id: packages.lisp,v 1.7 2005/02/28 23:36:08 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.8 2005/04/17 18:18:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -49,6 +49,13 @@
 (defun assert-package (name)
   (or (find-package name)
       (error "There is no package named ~S." (string name))))
+
+(defun list-all-packages ()
+  (let (pkgs)
+    (maphash (lambda (k v)
+               (pushnew v pkgs))
+             (get-global-property :packages))
+    pkgs))
 
 (defun find-symbol-string (name start end key &optional (package *package*))
   (check-type name string)



From ffjeld at common-lisp.net  Sun Apr 17 22:24:25 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 18 Apr 2005 00:24:25 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050417222425.572CD886F9@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fix make-special-funarg-shadowing so as to have non-dynamic-extent
&rest bindings work (albeit not very efficiently).

Date: Mon Apr 18 00:24:24 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.136 movitz/compiler.lisp:1.137
--- movitz/compiler.lisp:1.136	Wed Apr 13 09:25:41 2005
+++ movitz/compiler.lisp	Mon Apr 18 00:24:20 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.136 2005/04/13 07:25:41 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.137 2005/04/17 22:24:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -4760,13 +4760,22 @@
 	    need-normalized-ecx-p)))
 
 (defun make-special-funarg-shadowing (env function-body)
-  ""
-  (cond
-   ((without-function-prelude-p env)
-    function-body)
-   ((special-variable-shadows env)
-    `(muerte.cl::let ,(special-variable-shadows env) ,function-body))
-   (t function-body)))
+  "Wrap function-body in a let, if we need to.
+We need to when the function's lambda-list binds a special variable,
+or when there's a non-dynamic-extent &rest binding."
+  (if (without-function-prelude-p env)
+      function-body
+    (let ((shadowing
+	   (append (special-variable-shadows env)
+		   (when (and (rest-var env)
+			      (not (movitz-env-get (rest-var env) 'dynamic-extent nil env nil))
+			      (not (movitz-env-get (rest-var env) 'ignore nil env nil)))
+		     (movitz-env-load-declarations `((muerte.cl:dynamic-extent ,(rest-var env)))
+						   env :funobj)
+		     `((,(rest-var env) (muerte.cl:copy-list ,(rest-var env))))))))
+      (if (null shadowing)
+	  function-body
+	`(muerte.cl::let ,shadowing ,function-body)))))
 
 (defun make-compiled-function-postlude (funobj env use-stack-frame-p)
   (declare (ignore funobj env))



From ffjeld at common-lisp.net  Mon Apr 18 06:44:50 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 18 Apr 2005 08:44:50 +0200 (CEST)
Subject: [movitz-cvs] CVS update: public_html/ChangeLog 
Message-ID: <20050418064450.E12FE18C6B8@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
*** empty log message ***
Date: Mon Apr 18 08:44:50 2005
Author: ffjeld

Index: public_html/ChangeLog
diff -u public_html/ChangeLog:1.3 public_html/ChangeLog:1.4
--- public_html/ChangeLog:1.3	Wed Mar  9 08:33:09 2005
+++ public_html/ChangeLog	Mon Apr 18 08:44:49 2005
@@ -1,3 +1,11 @@
+2005-04-18  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
+
+	* Added support in the compiler for non-dynamic-extent &rest
+	function variables, so you don't _have_ to have those (declare
+	(dynamic-extent rest)) in there. Efficiency-wise, I'd still
+	recommend including them, though, because otherwise copy-list is
+	called to produce a infinite-extent list.
+
 2005-03-09  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
 
 	* Added/much improved support for GC-migration of



From ffjeld at common-lisp.net  Mon Apr 18 07:07:46 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 18 Apr 2005 09:07:46 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp 
Message-ID: <20050418070746.39741880E1@common-lisp.net>

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

Modified Files:
	segments.lisp 
Log Message:
Added accessor segment-descriptor.
Fixed bug in accessor segment-descriptor-avl-x-db-g: use the correct
offset.

Date: Mon Apr 18 09:07:45 2005
Author: ffjeld

Index: movitz/losp/muerte/segments.lisp
diff -u movitz/losp/muerte/segments.lisp:1.10 movitz/losp/muerte/segments.lisp:1.11
--- movitz/losp/muerte/segments.lisp:1.10	Fri Apr 15 09:04:10 2005
+++ movitz/losp/muerte/segments.lisp	Mon Apr 18 09:07:45 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu May  8 14:25:06 2003
 ;;;;                
-;;;; $Id: segments.lisp,v 1.10 2005/04/15 07:04:10 ffjeld Exp $
+;;;; $Id: segments.lisp,v 1.11 2005/04/18 07:07:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -215,13 +215,33 @@
   "Access bits 52-55 of the segment descriptor."
   (check-type table (and vector (not simple-vector)))
   (ldb (byte 4 4)
-       (memref table (+ 5 (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))
+       (memref table (+ 6 (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))
 	       :type :unsigned-byte8)))
 
 (defun (setf segment-descriptor-avl-x-db-g) (bits table index)
   "Access bits 52-55 of the segment descriptor."
   (check-type table (and vector (not simple-vector)))
   (setf (ldb (byte 4 4)
-	     (memref table (+ 5 (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))
+	     (memref table (+ 6 (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))
 		     :type :unsigned-byte8))
     bits))
+
+(defun segment-descriptor (table index)
+  "Access entire segment descriptor as a 64-bit integer."
+  (check-type table (and vector (not simple-vector)))
+  (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))))
+    (logior (ash (memref table offset :index 1 :type :unsigned-byte32)
+		 32)
+	    (ash (memref table offset :index 0 :type :unsigned-byte32)
+		 0))))
+
+(defun (setf segment-descriptor) (value table index)
+  "Access entire segment descriptor as a 64-bit integer."
+  (check-type table (and vector (not simple-vector)))
+  (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))))
+    (setf (memref table offset :index 1 :type :unsigned-byte32)
+      (ldb (byte 32 32) value))
+    (setf (memref table offset :index 0 :type :unsigned-byte32)
+      (ldb (byte 32 0) value))
+    value))
+  



From ffjeld at common-lisp.net  Mon Apr 18 07:08:43 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 18 Apr 2005 09:08:43 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <20050418070843.070CD880E1@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
*** empty log message ***
Date: Mon Apr 18 09:08:42 2005
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.38 movitz/losp/los0.lisp:1.39
--- movitz/losp/los0.lisp:1.38	Fri Apr 15 09:04:24 2005
+++ movitz/losp/los0.lisp	Mon Apr 18 09:08:42 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.38 2005/04/15 07:04:24 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.39 2005/04/18 07:08:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1330,6 +1330,8 @@
     (:movl 4 :eax)
    no-overflow))
 
+(defvar *segment-descriptor-table*)
+
 (defun genesis ()
   ;; (install-shallow-binding)
   (let ((extended-memsize 0))
@@ -1341,6 +1343,11 @@
     (format t "Extended memory: ~D KB~%" extended-memsize)
 
     (idt-init)
+    
+    (setf *segment-descriptor-table*	; Ensure we have a GDT with 16 entries, in static-space.
+      (muerte::install-global-segment-table
+       (muerte::dump-global-segment-table :entries 16)))
+    
     (install-los0-consing :kb-size 500)
     #+ignore
     (install-los0-consing :kb-size (max 50 (truncate (- extended-memsize 2048) 2))))



From ffjeld at common-lisp.net  Mon Apr 18 07:08:58 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 18 Apr 2005 09:08:58 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/ll-testing.lisp 
Message-ID: <20050418070858.A8D0B880E1@common-lisp.net>

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

Modified Files:
	ll-testing.lisp 
Log Message:
Added install-global-segment-table.

Date: Mon Apr 18 09:08:58 2005
Author: ffjeld

Index: movitz/losp/ll-testing.lisp
diff -u movitz/losp/ll-testing.lisp:1.2 movitz/losp/ll-testing.lisp:1.3
--- movitz/losp/ll-testing.lisp:1.2	Sat Apr 16 18:20:38 2005
+++ movitz/losp/ll-testing.lisp	Mon Apr 18 09:08:58 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Apr 14 08:18:43 2005
 ;;;;                
-;;;; $Id: ll-testing.lisp,v 1.2 2005/04/16 16:20:38 ffjeld Exp $
+;;;; $Id: ll-testing.lisp,v 1.3 2005/04/18 07:08:58 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,7 +18,7 @@
 (in-package muerte)
 
 (defun dump-global-segment-table (&key table entries nofill)
-  "Dump contents of the global (segment) descriptor table into a vector."
+  "Dump contents of the current global (segment) descriptor table into a vector."
   (multiple-value-bind (gdt-base gdt-limit)
       (%sgdt)
     (let* ((gdt-entries (/ (1+ gdt-limit) 8))
@@ -34,6 +34,21 @@
 	      do (setf (aref table i)
 		   (memref gdt-base 0 :index i :type :unsigned-byte32 :physicalp t))))
 	table))))
+
+(defun install-global-segment-table (table &optional entries)
+  "Install <table> as the GDT.
+NB! ensure that the table object isn't garbage-collected."
+  (check-type table (vector (unsigned-byte 32)))
+  (let ((entries (or entries (truncate (length table) 2))))
+    (check-type entries (integer 0 *))
+    (let ((limit (1- (* 8 entries)))
+	  (base (+ 2 (+ (object-location table)
+			(memref nil (movitz-type-slot-offset 'movitz-run-time-context
+							     'physical-address-offset)
+				:type :lisp)))))
+      (%lgdt base limit)
+      (values table limit))))
+
 
 (defun format-segment-table (table &key (start 0) (end (truncate (length table) 2)))
   (loop for i from start below end



From ffjeld at common-lisp.net  Tue Apr 19 06:42:12 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 19 Apr 2005 08:42:12 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp 
Message-ID: <20050419064212.9AE67880E6@common-lisp.net>

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

Modified Files:
	environment.lisp 
Log Message:
Use *setf-namespace* rather than (get-global-property :setf-namespace).

Date: Tue Apr 19 08:42:11 2005
Author: ffjeld

Index: movitz/losp/muerte/environment.lisp
diff -u movitz/losp/muerte/environment.lisp:1.10 movitz/losp/muerte/environment.lisp:1.11
--- movitz/losp/muerte/environment.lisp:1.10	Wed Mar  9 08:19:19 2005
+++ movitz/losp/muerte/environment.lisp	Tue Apr 19 08:42:11 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.10 2005/03/09 07:19:19 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.11 2005/04/19 06:42:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -48,8 +48,8 @@
     (symbol
      function-name)
     ((cons (eql setf) (cons symbol null))
-     (gethash (cadr function-name)
-	      (get-global-property :setf-namespace)))))
+     (gethash (cadr function-name) *setf-namespace*
+	      #+ignore (get-global-property :setf-namespace)))))
 
 (defun match-caller (name)
   (do ((frame (stack-frame-uplink nil (current-stack-frame))



From ffjeld at common-lisp.net  Tue Apr 19 06:42:17 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 19 Apr 2005 08:42:17 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp 
Message-ID: <20050419064217.84F25880E6@common-lisp.net>

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

Modified Files:
	eval.lisp 
Log Message:
Use *setf-namespace* rather than (get-global-property :setf-namespace).

Date: Tue Apr 19 08:42:16 2005
Author: ffjeld

Index: movitz/losp/muerte/eval.lisp
diff -u movitz/losp/muerte/eval.lisp:1.15 movitz/losp/muerte/eval.lisp:1.16
--- movitz/losp/muerte/eval.lisp:1.15	Thu Nov 18 18:57:14 2004
+++ movitz/losp/muerte/eval.lisp	Tue Apr 19 08:42:15 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 19 21:15:12 2001
 ;;;;                
-;;;; $Id: eval.lisp,v 1.15 2004/11/18 17:57:14 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.16 2005/04/19 06:42:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -337,15 +337,15 @@
 								     :environment-p nil
 								     :recursive-p nil
 								     :whole-p nil))))))))))
-  
+
 (defun lookup-setf-function (name)
-  (let ((setf-name (gethash name (get-global-property :setf-namespace))))
+  (let ((setf-name (gethash name *setf-namespace*)))
     (assert setf-name (name)
       "No function (~S ~S) defined." 'setf name)
     setf-name))
 
 (defun setf-intern (name)
-  (values (gethash name (get-global-property :setf-namespace))))
+  (values (gethash name *setf-namespace* #+ignore (get-global-property :setf-namespace))))
 
 (defun special-operator-p (operator-name)			   
   (member operator-name '(quote function if progn tagbody go)))



From ffjeld at common-lisp.net  Tue Apr 19 06:42:26 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 19 Apr 2005 08:42:26 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp 
Message-ID: <20050419064226.7B70288448@common-lisp.net>

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

Modified Files:
	functions.lisp 
Log Message:
Use *setf-namespace* rather than (get-global-property :setf-namespace).

Date: Tue Apr 19 08:42:25 2005
Author: ffjeld

Index: movitz/losp/muerte/functions.lisp
diff -u movitz/losp/muerte/functions.lisp:1.27 movitz/losp/muerte/functions.lisp:1.28
--- movitz/losp/muerte/functions.lisp:1.27	Mon Jan 31 16:47:57 2005
+++ movitz/losp/muerte/functions.lisp	Tue Apr 19 08:42:22 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.27 2005/01/31 15:47:57 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.28 2005/04/19 06:42:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -20,6 +20,9 @@
 
 (in-package muerte)
 
+(defvar *setf-namespace* nil
+  "This hash-table is initialized by dump-image.")
+
 (defun identity (x) x)
 
 (defun constantly-prototype (&rest ignore)
@@ -484,15 +487,15 @@
     (symbol
      (symbol-function function-name))
     ((cons (eql setf))
-     (symbol-function (gethash (cadr function-name)
-			       (get-global-property :setf-namespace))))))
+     (symbol-function (gethash (cadr function-name) *setf-namespace*
+			       #+ignore (get-global-property :setf-namespace))))))
 
 (defun (setf fdefinition) (value function-name)
   (etypecase function-name
     (symbol
      (setf (symbol-function function-name) value))
     ((cons (eql setf))
-     (let* ((setf-namespace (get-global-property :setf-namespace))
+     (let* ((setf-namespace *setf-namespace* #+ignore (get-global-property :setf-namespace))
 	    (setf-name (cadr function-name))
 	    (setf-symbol (or (gethash setf-name setf-namespace)
 			     (setf (gethash setf-name setf-namespace)



From ffjeld at common-lisp.net  Tue Apr 19 06:44:01 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 19 Apr 2005 08:44:01 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <20050419064401.E47BC880E6@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Initialize *setf-namespace* at dump-time.
In movitz-read, update old cons-cells also when they are found in the
cache of previously-read cells.

Date: Tue Apr 19 08:44:01 2005
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.88 movitz/image.lisp:1.89
--- movitz/image.lisp:1.88	Mon Jan 10 09:18:56 2005
+++ movitz/image.lisp	Tue Apr 19 08:44:01 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.88 2005/01/10 08:18:56 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.89 2005/04/19 06:44:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -882,6 +882,8 @@
   (let ((handler (movitz-env-symbol-function 'muerte::interrupt-default-handler)))
     (setf (movitz-run-time-context-exception-handlers (image-run-time-context *image*))
       (movitz-read (make-array 256 :initial-element handler))))
+  (setf (movitz-symbol-value (movitz-read 'muerte::*setf-namespace*))
+    (movitz-read (movitz-environment-setf-function-names *movitz-global-environment*) t))
   (let ((load-address (image-start-address *image*)))
     (setf (image-cons-pointer *image*) (- load-address
 					  (image-ds-segment-base *image*))
@@ -969,8 +971,6 @@
 		   (setf (movitz-symbol-value mname) mvalue)))
 	  (setf (movitz-run-time-context-global-properties run-time-context)
 	    (movitz-read (list :packages (make-packages-hash)
-			       :setf-namespace (movitz-environment-setf-function-names
-						*movitz-global-environment*)
 			       :trampoline-funcall%1op (find-primitive-function
 							'muerte::trampoline-funcall%1op)
 			       :trampoline-funcall%2op (find-primitive-function
@@ -1483,7 +1483,10 @@
 					:element-type (array-element-type expr)
 					:initial-contents expr))
 	    (cons
-	     (or (gethash expr (image-cons-constants *image*))
+	     (or (let ((old-cons (gethash expr (image-cons-constants *image*))))
+		   (when old-cons
+		     (update-movitz-object old-cons expr)
+		     old-cons))
 		 (setf (gethash expr (image-cons-constants *image*))
 		   (if (eq '#0=#:error (ignore-errors (when (not (list-length expr)) '#0#)))
 		       (multiple-value-bind (unfolded-expr cdr-index)



From ffjeld at common-lisp.net  Tue Apr 19 06:50:06 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 19 Apr 2005 08:50:06 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp 
Message-ID: <20050419065006.F29D9880E6@common-lisp.net>

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

Modified Files:
	ip4.lisp 
Log Message:
Changed default network addresses in ip4-init (i.e. my lab changed
network).

Date: Tue Apr 19 08:50:04 2005
Author: ffjeld

Index: movitz/losp/lib/net/ip4.lisp
diff -u movitz/losp/lib/net/ip4.lisp:1.16 movitz/losp/lib/net/ip4.lisp:1.17
--- movitz/losp/lib/net/ip4.lisp:1.16	Thu Dec  9 00:40:03 2004
+++ movitz/losp/lib/net/ip4.lisp	Tue Apr 19 08:50:04 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001, 2003-2004, 
+;;;;    Copyright (C) 2001, 2003-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 Apr 30 13:52:57 2003
 ;;;;                
-;;;; $Id: ip4.lisp,v 1.16 2004/12/08 23:40:03 ffjeld Exp $
+;;;; $Id: ip4.lisp,v 1.17 2005/04/19 06:50:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -480,7 +480,7 @@
     (setf *ne2000* nil))
   (values))
 
-(defun ip4-init ()
+(defun ip4-init (&optional (ip :129.242.19.151) (router :129.242.19.129))
   (unless *ip4-nic*
     (let ((ethernet
 	   (some #'muerte.x86-pc.ne2k:ne2k-probe
@@ -488,9 +488,9 @@
       (assert ethernet ethernet "No ethernet device.")
       (setf *ip4-nic* ethernet)))
   (unless *ip4-ip*
-    (setf *ip4-ip* (ip4-address :129.242.16.173)))
+    (setf *ip4-ip* (ip4-address ip)))
   (unless *ip4-router*
-    (setf *ip4-router* (ip4-address :129.242.16.1)))
+    (setf *ip4-router* (ip4-address router)))
   ;; This is to announce our presence on the LAN..
   (assert (polling-arp *ip4-router* (lambda ()
 				      (eql #\space (muerte.x86-pc.keyboard:poll-char))))



From ffjeld at common-lisp.net  Wed Apr 20 06:50:11 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 20 Apr 2005 08:50:11 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <20050420065011.DCA74880AD@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Added compiler-macro movitz-type-word-size.

Date: Wed Apr 20 08:50:10 2005
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.56 movitz/losp/muerte/basic-macros.lisp:1.57
--- movitz/losp/muerte/basic-macros.lisp:1.56	Tue Mar  1 00:38:03 2005
+++ movitz/losp/muerte/basic-macros.lisp	Wed Apr 20 08:50:10 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: basic-macros.lisp,v 1.56 2005/02/28 23:38:03 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.57 2005/04/20 06:50:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -401,6 +401,12 @@
 				       (find-symbol (string slot-name) :movitz))))
      (:leal ((:ecx #.movitz::+movitz-fixnum-factor+) :edi ,(- (movitz::image-nil-word movitz::*image*)))
 	    :eax)))
+
+(define-compiler-macro movitz-type-word-size (type &environment env)
+  (if (not (movitz:movitz-constantp type env))
+      (error "Non-constant movitz-type-word-size call.")
+    (movitz::movitz-type-word-size (intern (symbol-name (movitz:movitz-eval type env))
+					   :movitz))))
 
 (define-compiler-macro movitz-type-slot-offset (type slot &environment env)
   (if (not (and (movitz:movitz-constantp type env)



From ffjeld at common-lisp.net  Wed Apr 20 06:51:13 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 20 Apr 2005 08:51:13 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <20050420065113.016C1880AD@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Use proper movitz-type-word-size operator rather than #.(movitz:...)

Date: Wed Apr 20 08:51:13 2005
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.49 movitz/losp/muerte/inspect.lisp:1.50
--- movitz/losp/muerte/inspect.lisp:1.49	Mon Feb 28 18:00:05 2005
+++ movitz/losp/muerte/inspect.lisp	Wed Apr 20 08:51:12 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.49 2005/02/28 17:00:05 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.50 2005/04/20 06:51:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -264,7 +264,9 @@
     (function
      (copy-funobj old))
     (structure-object
-     (copy-structure old))))
+     (copy-structure old))
+    (run-time-context
+     (%shallow-copy-object old (movitz-type-word-size 'movitz-run-time-context)))))
 
 (defun objects-equalp (x y)
   "Basically, this verifies whether x is a shallow-copy of y, or vice versa."
@@ -364,51 +366,51 @@
       (symbol
        (<= object-location
 	   location
-	   (+ -1 object-location #.(movitz::movitz-type-word-size :movitz-symbol))))
+	   (+ -1 object-location (movitz-type-word-size :movitz-symbol))))
       (run-time-context
        (<= object-location
 	   location
-	   (+ -1 object-location #.(movitz::movitz-type-word-size :movitz-run-time-context))))
+	   (+ -1 object-location (movitz-type-word-size :movitz-run-time-context))))
       (std-instance
        (<= object-location
 	   location
-	   (+ -1 object-location #.(movitz::movitz-type-word-size :movitz-std-instance))))
+	   (+ -1 object-location (movitz-type-word-size :movitz-std-instance))))
       (function
        (<= object-location
 	   location
 	   (+ -1 object-location
-	      #.(movitz::movitz-type-word-size :movitz-funobj)
+	      (movitz-type-word-size :movitz-funobj)
 	      (funobj-num-constants object))))
       ((or string code-vector (simple-array (unsigned-byte 8) 1))
        (<= object-location
 	   location
 	   (+ -1 object-location
-	      #.(movitz::movitz-type-word-size 'movitz-basic-vector)
+	      (movitz-type-word-size 'movitz-basic-vector)
 	      (* 2 (truncate (+ (array-dimension object 0) 7) 8)))))
       (vector-u16
        (<= object-location
 	   location
 	   (+ -1 object-location
-	      #.(movitz::movitz-type-word-size 'movitz-basic-vector)
+	      (movitz-type-word-size 'movitz-basic-vector)
 	      (* 2 (truncate (+ (array-dimension object 0) 3) 4)))))
       ((or vector-u32 simple-vector)
        (<= object-location
 	   location
 	   (+ -1 object-location
-	      #.(movitz::movitz-type-word-size 'movitz-basic-vector)
+	      (movitz-type-word-size 'movitz-basic-vector)
 	      (* 2 (truncate (+ (array-dimension object 0) 1) 2)))))
       (structure-object
        (<= object-location
 	   location
 	   (+ -1 object-location
-	      #.(movitz::movitz-type-word-size :movitz-struct)
+	      (movitz-type-word-size :movitz-struct)
 	      (* 2 (truncate (+ (structure-object-length object) 1) 2))))))))
 
 (defun location-in-code-vector-p%unsafe (code-vector location)
   (and (<= (object-location code-vector) location)
        (<= location
 	   (+ -1 (object-location code-vector)
-	      #.(movitz::movitz-type-word-size 'movitz-basic-vector)
+	      (movitz-type-word-size 'movitz-basic-vector)
 	      (* 2 (truncate (+ (memref code-vector
 					(movitz-type-slot-offset 'movitz-basic-vector 'num-elements))
 				7)



From ffjeld at common-lisp.net  Wed Apr 20 06:51:58 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 20 Apr 2005 08:51:58 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/stream-image.lisp 
Message-ID: <20050420065158.82B1F880AD@common-lisp.net>

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

Modified Files:
	stream-image.lisp 
Log Message:
*** empty log message ***
Date: Wed Apr 20 08:51:57 2005
Author: ffjeld

Index: movitz/stream-image.lisp
diff -u movitz/stream-image.lisp:1.11 movitz/stream-image.lisp:1.12
--- movitz/stream-image.lisp:1.11	Fri Aug  6 16:43:55 2004
+++ movitz/stream-image.lisp	Wed Apr 20 08:51:57 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 Aug 27 14:46:50 2001
 ;;;;                
-;;;; $Id: stream-image.lisp,v 1.11 2004/08/06 14:43:55 ffjeld Exp $
+;;;; $Id: stream-image.lisp,v 1.12 2005/04/20 06:51:57 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -91,6 +91,8 @@
 			(read-binary 'movitz-std-instance (image-stream image)))
 		       (:bignum
 			(read-binary 'movitz-bignum (image-stream image)))
+		       (:run-time-context
+			(read-binary 'movitz-run-time-context (image-stream image)))
 		       (t (warn "unknown other object: #x~X: ~S code #x~X."
 				word type-tag type-code)
 			  (make-instance 'movitz-fixnum :value (truncate word 4))))))



From ffjeld at common-lisp.net  Wed Apr 20 06:52:27 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 20 Apr 2005 08:52:27 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp 
Message-ID: <20050420065227.1E65E880AD@common-lisp.net>

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

Modified Files:
	basic-functions.lisp 
Log Message:
Added operator location-physical-offset.

Date: Wed Apr 20 08:52:26 2005
Author: ffjeld

Index: movitz/losp/muerte/basic-functions.lisp
diff -u movitz/losp/muerte/basic-functions.lisp:1.16 movitz/losp/muerte/basic-functions.lisp:1.17
--- movitz/losp/muerte/basic-functions.lisp:1.16	Thu Jan 27 08:47:37 2005
+++ movitz/losp/muerte/basic-functions.lisp	Wed Apr 20 08:52:26 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 18:41:57 2001
 ;;;;                
-;;;; $Id: basic-functions.lisp,v 1.16 2005/01/27 07:47:37 ffjeld Exp $
+;;;; $Id: basic-functions.lisp,v 1.17 2005/04/20 06:52:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -349,6 +349,18 @@
 
 (defun object-tag (object)
   (object-tag object))
+
+
+(define-compiler-macro location-physical-offset ()
+  '(memref nil (movitz-type-slot-offset 'movitz-run-time-context
+		'physical-address-offset)
+    :type :lisp))
+
+(defun location-physical-offset ()
+  "The offset between physical and logical locations.
+A location is an 4-aligned address (32 bits whose two lsb are zero)
+interpreted as a lispval, and consequently a fixnum."
+  (location-physical-offset))
 
 (defun halt-cpu ()
   (halt-cpu))



From ffjeld at common-lisp.net  Wed Apr 20 06:53:21 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 20 Apr 2005 08:53:21 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp 
Message-ID: <20050420065321.4AAAF880AD@common-lisp.net>

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

Modified Files:
	environment.lisp 
Log Message:
Removed obsolete (get-global-property :setf-namespace) code.

Date: Wed Apr 20 08:53:20 2005
Author: ffjeld

Index: movitz/losp/muerte/environment.lisp
diff -u movitz/losp/muerte/environment.lisp:1.11 movitz/losp/muerte/environment.lisp:1.12
--- movitz/losp/muerte/environment.lisp:1.11	Tue Apr 19 08:42:11 2005
+++ movitz/losp/muerte/environment.lisp	Wed Apr 20 08:53:20 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.11 2005/04/19 06:42:11 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.12 2005/04/20 06:53:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -48,8 +48,7 @@
     (symbol
      function-name)
     ((cons (eql setf) (cons symbol null))
-     (gethash (cadr function-name) *setf-namespace*
-	      #+ignore (get-global-property :setf-namespace)))))
+     (gethash (cadr function-name) *setf-namespace*))))
 
 (defun match-caller (name)
   (do ((frame (stack-frame-uplink nil (current-stack-frame))



From ffjeld at common-lisp.net  Wed Apr 20 06:53:24 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 20 Apr 2005 08:53:24 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp 
Message-ID: <20050420065324.B2A41880AD@common-lisp.net>

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

Modified Files:
	eval.lisp 
Log Message:
Removed obsolete (get-global-property :setf-namespace) code.

Date: Wed Apr 20 08:53:24 2005
Author: ffjeld

Index: movitz/losp/muerte/eval.lisp
diff -u movitz/losp/muerte/eval.lisp:1.16 movitz/losp/muerte/eval.lisp:1.17
--- movitz/losp/muerte/eval.lisp:1.16	Tue Apr 19 08:42:15 2005
+++ movitz/losp/muerte/eval.lisp	Wed Apr 20 08:53:23 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 19 21:15:12 2001
 ;;;;                
-;;;; $Id: eval.lisp,v 1.16 2005/04/19 06:42:15 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.17 2005/04/20 06:53:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -345,7 +345,7 @@
     setf-name))
 
 (defun setf-intern (name)
-  (values (gethash name *setf-namespace* #+ignore (get-global-property :setf-namespace))))
+  (values (gethash name *setf-namespace*)))
 
 (defun special-operator-p (operator-name)			   
   (member operator-name '(quote function if progn tagbody go)))



From ffjeld at common-lisp.net  Wed Apr 20 06:53:29 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 20 Apr 2005 08:53:29 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp 
Message-ID: <20050420065329.4DC55880AD@common-lisp.net>

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

Modified Files:
	functions.lisp 
Log Message:
Removed obsolete (get-global-property :setf-namespace) code.

Date: Wed Apr 20 08:53:28 2005
Author: ffjeld

Index: movitz/losp/muerte/functions.lisp
diff -u movitz/losp/muerte/functions.lisp:1.28 movitz/losp/muerte/functions.lisp:1.29
--- movitz/losp/muerte/functions.lisp:1.28	Tue Apr 19 08:42:22 2005
+++ movitz/losp/muerte/functions.lisp	Wed Apr 20 08:53:28 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.28 2005/04/19 06:42:22 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.29 2005/04/20 06:53:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -476,7 +476,7 @@
   (check-type old-funobj function)
   (%shallow-copy-object old-funobj
 			(+ (funobj-num-constants old-funobj)
-			   #.(movitz::movitz-type-word-size 'movitz-funobj))))
+			   (movitz-type-word-size 'movitz-funobj))))
 
 (defun install-funobj-name (name funobj)
   (setf (funobj-name funobj) name)
@@ -487,18 +487,16 @@
     (symbol
      (symbol-function function-name))
     ((cons (eql setf))
-     (symbol-function (gethash (cadr function-name) *setf-namespace*
-			       #+ignore (get-global-property :setf-namespace))))))
+     (symbol-function (gethash (cadr function-name) *setf-namespace*)))))
 
 (defun (setf fdefinition) (value function-name)
   (etypecase function-name
     (symbol
      (setf (symbol-function function-name) value))
     ((cons (eql setf))
-     (let* ((setf-namespace *setf-namespace* #+ignore (get-global-property :setf-namespace))
-	    (setf-name (cadr function-name))
-	    (setf-symbol (or (gethash setf-name setf-namespace)
-			     (setf (gethash setf-name setf-namespace)
+     (let* ((setf-name (cadr function-name))
+	    (setf-symbol (or (gethash setf-name *setf-namespace*)
+			     (setf (gethash setf-name *setf-namespace*)
 			       (make-symbol (format nil "~A-~A" 'setf 'setf-name))))))
        (setf (symbol-function setf-symbol)
 	 value)))))



From ffjeld at common-lisp.net  Wed Apr 20 06:54:07 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 20 Apr 2005 08:54:07 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp 
Message-ID: <20050420065407.A9F93880AD@common-lisp.net>

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

Modified Files:
	debugger.lisp 
Log Message:
Removed obsolete (get-global-property :setf-namespace) code.

Date: Wed Apr 20 08:54:07 2005
Author: ffjeld

Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.37 movitz/losp/x86-pc/debugger.lisp:1.38
--- movitz/losp/x86-pc/debugger.lisp:1.37	Wed Mar  9 08:22:32 2005
+++ movitz/losp/x86-pc/debugger.lisp	Wed Apr 20 08:54:07 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.37 2005/03/09 07:22:32 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.38 2005/04/20 06:54:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -630,7 +630,7 @@
 			  (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))
+	(with-hash-table-iterator (hashis *setf-namespace*)
 	  (do () (nil)
 	    (multiple-value-bind (morep setf-name symbol)
 		(hashis)



From ffjeld at common-lisp.net  Wed Apr 20 06:54:39 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 20 Apr 2005 08:54:39 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <20050420065439.7054A880AD@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
*** empty log message ***
Date: Wed Apr 20 08:54:38 2005
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.45 movitz/packages.lisp:1.46
--- movitz/packages.lisp:1.45	Wed Mar  9 08:24:37 2005
+++ movitz/packages.lisp	Wed Apr 20 08:54:38 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.45 2005/03/09 07:24:37 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.46 2005/04/20 06:54:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1288,6 +1288,9 @@
 	   #:decode-eflags
 	   #:load-idt
 	   #:segment-register
+	   #:segment-descriptor
+	   #:segment-descriptor-base-location
+	   #:segment-descriptor-limit
 	   #:control-register-lo12
 	   #:control-register-hi20
 	   ))



From ffjeld at common-lisp.net  Wed Apr 20 06:54:51 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 20 Apr 2005 08:54:51 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <20050420065451.5950D880AD@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
*** empty log message ***
Date: Wed Apr 20 08:54:50 2005
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.89 movitz/image.lisp:1.90
--- movitz/image.lisp:1.89	Tue Apr 19 08:44:01 2005
+++ movitz/image.lisp	Wed Apr 20 08:54:50 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.89 2005/04/19 06:44:01 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.90 2005/04/20 06:54:50 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -24,7 +24,7 @@
     :binary-type 3)
    (name
     :binary-type word
-    :initform :global
+    :initform :bootup
     :map-binary-write 'movitz-read-and-intern
     :map-binary-read-delayed 'movitz-word)
    (fast-car



From ffjeld at common-lisp.net  Sun Apr 24 16:46:04 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 24 Apr 2005 18:46:04 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <20050424164604.1BA6E88665@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Ensure there's a valid global binding for *package*.

Date: Sun Apr 24 18:46:03 2005
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.39 movitz/losp/los0.lisp:1.40
--- movitz/losp/los0.lisp:1.39	Mon Apr 18 09:08:42 2005
+++ movitz/losp/los0.lisp	Sun Apr 24 18:46:03 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.39 2005/04/18 07:08:42 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.40 2005/04/24 16:46:03 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1315,9 +1315,9 @@
 						 :index (+ x (* y muerte.x86-pc::*screen-stride*))
 						 :type :unsigned-byte16)))
 			       data)))
-    (muerte.ip4:tftp/ethernet-write :129.242.16.151 "movitz-screendump.txt" data
+    (muerte.ip4:tftp/ethernet-write :129.242.19.132 "movitz-screendump.txt" data
 				    :quiet t
-				    :mac (muerte.ip4::polling-arp :129.242.16.1
+				    :mac (muerte.ip4::polling-arp ip4::*ip4-router*
 								  (lambda ()
 								    (eql #\escape (muerte.x86-pc.keyboard:poll-char)))))))
 
@@ -1332,6 +1332,21 @@
 
 (defvar *segment-descriptor-table*)
 
+(defun threading ()
+  (let* ((thread (muerte::clone-run-time-context :name 'subthread))
+	 (stack (make-array 1022 :element-type '(unsigned-byte 32))))
+    (setf (segment-descriptor *segment-descriptor-table* 8)
+      (segment-descriptor *segment-descriptor-table* (truncate (segment-register :fs) 8)))
+    (warn "Thread ~S FS base: ~S"
+	  thread
+	  (setf (segment-descriptor-base-location *segment-descriptor-table* 8)
+	    (+ (object-location thread)
+	       (muerte::location-physical-offset))))
+    (format *terminal-io* "~&Switching...")
+    (setf (segment-register :fs) (* 8 8))
+    (format *terminal-io* "ok.~%")
+    (values thread stack)))
+
 (defun genesis ()
   ;; (install-shallow-binding)
   (let ((extended-memsize 0))
@@ -1354,12 +1369,13 @@
 
   (setf *debugger-function* #'los0-debugger)
   (clos-bootstrap)
-  (install-shallow-binding)
+  (setf *package* (find-package "INIT"))
+  ;; (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)
 	#+ignore (*debugger-function* #'los0-debugger)
-	(*package* nil))
+	(*package* *package*))
     (with-simple-restart (abort "Skip Los0 boot-up initialization.")
       (setf *cpu-features*
 	(find-cpu-features))



From ffjeld at common-lisp.net  Sun Apr 24 20:36:44 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 24 Apr 2005 22:36:44 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp 
Message-ID: <20050424203644.0E78888665@common-lisp.net>

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

Modified Files:
	procfs-image.lisp 
Log Message:
Some backtrace tweaks.

Date: Sun Apr 24 22:36:44 2005
Author: ffjeld

Index: movitz/procfs-image.lisp
diff -u movitz/procfs-image.lisp:1.22 movitz/procfs-image.lisp:1.23
--- movitz/procfs-image.lisp:1.22	Tue Jan  4 17:56:44 2005
+++ movitz/procfs-image.lisp	Sun Apr 24 22:36:44 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Aug 24 11:39:37 2001
 ;;;;                
-;;;; $Id: procfs-image.lisp,v 1.22 2005/01/04 16:56:44 ffjeld Exp $
+;;;; $Id: procfs-image.lisp,v 1.23 2005/04/24 20:36:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -165,7 +165,8 @@
   (get-word stack-frame))
 
 (defun stack-frame-funobj (stack-frame)
-  (when (zerop (ldb (byte 2 0) stack-frame))
+  (when (and (plusp stack-frame)
+	     (zerop (ldb (byte 2 0) stack-frame)))
     (let ((x (movitz-word (get-word (- stack-frame 4)))))
       (and (typep x 'movitz-funobj) x))))
 
@@ -196,6 +197,7 @@
 	  (image-register32 *image* :esi))
   (let ((*print-length* 20))
     (loop for stack-frame = (current-stack-frame) then (previous-stack-frame stack-frame)
+	while (plusp stack-frame)
 	unless (zerop (mod stack-frame 4))
 	do (format t "[frame #x~8,'0x]" stack-frame)
 	   (loop-finish)
@@ -228,7 +230,9 @@
 			    (debug-get-object (get-word (+ stack-frame -12)) spartan)))
 		  (when print-returns
 		    (format t " (#x~X)" (stack-frame-return-address stack-frame)))))
-	       (t (write (movitz-print movitz-name)))))
+	       (t (when print-frames
+		    (format t "~S " (truncate stack-frame 4)))
+		  (write (movitz-print movitz-name)))))
 	do (format t "~& => ")))
   (values))
 



From ffjeld at common-lisp.net  Sun Apr 24 22:00:00 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 25 Apr 2005 00:00:00 +0200 (CEST)
Subject: [movitz-cvs] CVS update: public_html/ChangeLog 
Message-ID: <20050424220000.3EAF688665@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
*** empty log message ***
Date: Sun Apr 24 23:59:59 2005
Author: ffjeld

Index: public_html/ChangeLog
diff -u public_html/ChangeLog:1.4 public_html/ChangeLog:1.5
--- public_html/ChangeLog:1.4	Mon Apr 18 08:44:49 2005
+++ public_html/ChangeLog	Sun Apr 24 23:59:59 2005
@@ -1,3 +1,13 @@
+2005-04-24  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
+
+	* Fixed a bug in the compilation of (values ...) for more than two
+	values: the stack-pointer would not be reset properly, causing the
+	stack to grow very quickly in certain situations, such as when
+	such a values statement was executed inside a loop, which happens
+	e.g. in do-symbols & friends. This bug has gone undetected because
+	usually a stack-frame exit will occur after a values statement,
+	masking out any failures.
+
 2005-04-18  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
 
 	* Added support in the compiler for non-dynamic-extent &rest



From ffjeld at common-lisp.net  Sun Apr 24 22:08:40 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 25 Apr 2005 00:08:40 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <20050424220840.B193B88665@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Fixed bug in inline-values: stack was not reset properly for >= 3 values.

Date: Mon Apr 25 00:08:39 2005
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.49 movitz/special-operators.lisp:1.50
--- movitz/special-operators.lisp:1.49	Thu Feb  3 10:18:51 2005
+++ movitz/special-operators.lisp	Mon Apr 25 00:08:39 2005
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.49 2005/02/03 09:18:51 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.50 2005/04/24 22:08:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1115,9 +1115,12 @@
 	(t (multiple-value-bind (arguments-code stack-displacement arguments-modifies
 				 arguments-types arguments-functional-p)
 	       (make-compiled-argument-forms sub-forms (all :funobj) (all :env))
+	     (assert (not (minusp (- stack-displacement (- (length sub-forms) 2)))))
 	     (multiple-value-bind (stack-restore-code new-returns)
-		 (make-compiled-stack-restore stack-displacement result-mode :multiple-values)
-	       (declare (ignore stack-restore-code))
+		 (make-compiled-stack-restore (- stack-displacement
+						 (- (length sub-forms) 2))
+					      result-mode
+					      :multiple-values)
 	       (compiler-values ()
 		 :returns new-returns
 		 :type `(values , at arguments-types)
@@ -1127,16 +1130,14 @@
 			       (loop for i from (- (length sub-forms) 3) downto 0
 				   collecting
 				     `(:locally (:popl (:edi (:edi-offset values ,(* i 4))))))
-			       (make-immediate-move (length sub-forms) :ecx)
-			       `((:leal ((:ecx ,+movitz-fixnum-factor+) ,(* -2 +movitz-fixnum-factor+))
-					:edx)
-				 (:locally (:movl :edx (:edi (:edi-offset num-values))))
+			       (make-immediate-move (* +movitz-fixnum-factor+ (- (length sub-forms) 2))
+						    :ecx)
+			       `((:locally (:movl :ecx (:edi (:edi-offset num-values))))
 				 (:stc))
 			       #+ignore
 			       (make-compiled-funcall-by-symbol 'muerte.cl::values
 								(length sub-forms)
 								(all :funobj))
-			       #+ignore
 			       stack-restore-code)))))))))
 
 (define-special-operator muerte::compiler-typecase (&all all &form form)



From ffjeld at common-lisp.net  Sun Apr 24 22:10:27 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 25 Apr 2005 00:10:27 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <20050424221027.633AF88665@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Have (stack-frame-uplink 0) return 0.

Date: Mon Apr 25 00:10:26 2005
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.50 movitz/losp/muerte/inspect.lisp:1.51
--- movitz/losp/muerte/inspect.lisp:1.50	Wed Apr 20 08:51:12 2005
+++ movitz/losp/muerte/inspect.lisp	Mon Apr 25 00:10:26 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.50 2005/04/20 06:51:12 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.51 2005/04/24 22:10:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -47,9 +47,11 @@
     (+ (object-location stack) 2 index)))
 
 (defun stack-frame-uplink (stack frame)
-  (if (eq 0 (stack-frame-funobj stack frame))
-      (dit-frame-casf stack frame)
-    (stack-frame-ref stack frame 0)))
+  (cond
+   ((eq 0 frame) 0)
+   ((eq 0 (stack-frame-funobj stack frame))
+    (dit-frame-casf stack frame))
+   (t (stack-frame-ref stack frame 0))))
 
 (defun stack-vector-designator (stack)
   (etypecase stack



From ffjeld at common-lisp.net  Sun Apr 24 22:11:25 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 25 Apr 2005 00:11:25 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp 
Message-ID: <20050424221125.3158E88665@common-lisp.net>

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

Modified Files:
	segments.lisp 
Log Message:
*** empty log message ***
Date: Mon Apr 25 00:11:24 2005
Author: ffjeld

Index: movitz/losp/muerte/segments.lisp
diff -u movitz/losp/muerte/segments.lisp:1.11 movitz/losp/muerte/segments.lisp:1.12
--- movitz/losp/muerte/segments.lisp:1.11	Mon Apr 18 09:07:45 2005
+++ movitz/losp/muerte/segments.lisp	Mon Apr 25 00:11:24 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu May  8 14:25:06 2003
 ;;;;                
-;;;; $Id: segments.lisp,v 1.11 2005/04/18 07:07:45 ffjeld Exp $
+;;;; $Id: segments.lisp,v 1.12 2005/04/24 22:11:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -161,26 +161,31 @@
       (:cr4 (set-creg :cr4)))
     value))
     
-(defun segment-descriptor-base (table index)
+(defun segment-descriptor-base-location (table index)
   (check-type table (and vector (not simple-vector)))
+  (eval-when (:compile-toplevel)
+    (assert (= 4 movitz::+movitz-fixnum-factor+)))
+  ;; XXX This fails for locations above 2GB.
   (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))))
     (logior (ash (memref table (+ 7 offset) :type :unsigned-byte8)
-		 24)
+		 22)
 	    (ash (memref table (+ 4 offset) :type :unsigned-byte8)
-		 16)
+		 14)
 	    (ash (memref table (+ 2 offset) :type :unsigned-byte16)
-		 0))))
+		 -2))))
 
-(defun (setf segment-descriptor-base) (base table index)
+(defun (setf segment-descriptor-base-location) (base-location table index)
   (check-type table (and vector (not simple-vector)))
+  (eval-when (:compile-toplevel)
+    (assert (= 4 movitz::+movitz-fixnum-factor+)))
   (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data))))
     (setf (memref table (+ 7 offset) :type :unsigned-byte8)
-      (ldb (byte 8 24) base))
+      (ldb (byte 8 22) base-location))
     (setf (memref table (+ 4 offset) :type :unsigned-byte8)
-      (ldb (byte 8 16) base))
+      (ldb (byte 8 14) base-location))
     (setf (memref table (+ 2 offset) :type :unsigned-byte16)
-      (ldb (byte 16 0) base))
-    base))
+      (ash (ldb (byte 14 0) base-location) 2))
+    base-location))
 
 (defun segment-descriptor-limit (table index)
   (check-type table (and vector (not simple-vector)))



From ffjeld at common-lisp.net  Sun Apr 24 22:13:55 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 25 Apr 2005 00:13:55 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp 
Message-ID: <20050424221355.4161E88665@common-lisp.net>

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

Modified Files:
	debugger.lisp 
Log Message:
*** empty log message ***
Date: Mon Apr 25 00:13:54 2005
Author: ffjeld

Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.38 movitz/losp/x86-pc/debugger.lisp:1.39
--- movitz/losp/x86-pc/debugger.lisp:1.38	Wed Apr 20 08:54:07 2005
+++ movitz/losp/x86-pc/debugger.lisp	Mon Apr 25 00:13:54 2005
@@ -6,11 +6,11 @@
 ;;;;    For distribution policy, see the accompanying file COPYING.
 ;;;; 
 ;;;; Filename:      debugger.lisp
-;;;; Description:   
+;;;; Description:   Debugging functionality.
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 22 10:09:18 2002
 ;;;;                
-;;;; $Id: debugger.lisp,v 1.38 2005/04/20 06:54:07 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.39 2005/04/24 22:13:54 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -38,7 +38,8 @@
       muerte::do-slow-method-lookup
       muerte::initial-discriminating-function
       muerte::discriminating-function-max
-      muerte::discriminating-function-max-step2))
+      muerte::discriminating-function-max-step2
+      invoke-debugger-on-designator))
 
 (defconstant +backtrace-gf-discriminatior-functions+
     '(muerte::discriminating-function-max
@@ -132,12 +133,12 @@
 	(stack-frame-call-site stack frame)
       (when (and call-site code)
 	(dolist (map +call-site-numargs-maps+
-		  (warn "no match at ~D for ~S frame ~S [~S]."
-			call-site
-			(stack-frame-funobj stack (stack-frame-uplink stack frame))
-			frame funobj))
+		  #+ignore (warn "no match at ~D for ~S frame ~S [~S]."
+				 call-site
+				 (stack-frame-funobj stack (stack-frame-uplink stack frame))
+				 frame funobj))
 	  (when (not (mismatch code (cdr map)
-			       :start1 (- call-site (length (cdr map)))
+			       :start1 (max 0 (- call-site (length (cdr map))))
 			       :end1 call-site))
 	    (return
 	      (cond
@@ -600,10 +601,11 @@
 		      (format t "?: ~Z" funobj)))
 	       (serious-condition (c)
 		 (let ((*print-safely* t))
-		   (format t " - Error at ~S funobj ~S: ~A"
+		   (format t " - Backtracing error at ~S funobj ~S: ~A"
 			   frame
 			   (stack-frame-funobj nil frame)
-			   c)))))))
+			   c)))))
+	until (zerop (stack-frame-uplink stack frame))))
   (values))
 
 (defun locate-function (instruction-location)



From ffjeld at common-lisp.net  Tue Apr 26 22:23:17 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 27 Apr 2005 00:23:17 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/ll-testing.lisp 
Message-ID: <20050426222317.5BB3E88030@common-lisp.net>

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

Modified Files:
	ll-testing.lisp 
Log Message:
Threads have landed!

Date: Wed Apr 27 00:23:14 2005
Author: ffjeld

Index: movitz/losp/ll-testing.lisp
diff -u movitz/losp/ll-testing.lisp:1.3 movitz/losp/ll-testing.lisp:1.4
--- movitz/losp/ll-testing.lisp:1.3	Mon Apr 18 09:08:58 2005
+++ movitz/losp/ll-testing.lisp	Wed Apr 27 00:23:14 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Apr 14 08:18:43 2005
 ;;;;                
-;;;; $Id: ll-testing.lisp,v 1.3 2005/04/18 07:08:58 ffjeld Exp $
+;;;; $Id: ll-testing.lisp,v 1.4 2005/04/26 22:23:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -43,9 +43,7 @@
     (check-type entries (integer 0 *))
     (let ((limit (1- (* 8 entries)))
 	  (base (+ 2 (+ (object-location table)
-			(memref nil (movitz-type-slot-offset 'movitz-run-time-context
-							     'physical-address-offset)
-				:type :lisp)))))
+			(location-physical-offset)))))
       (%lgdt base limit)
       (values table limit))))
 
@@ -54,8 +52,224 @@
   (loop for i from start below end
       do (format t "~&~2D: base: #x~8,'0X, limit: #x~5,'0X, type-s-dpl-p: ~8,'0b, avl-x-db-g: ~4,'0b~%"
 		 i
-		 (segment-descriptor-base table i)
+		 (* 4 (segment-descriptor-base-location table i))
 		 (segment-descriptor-limit table i)
 		 (segment-descriptor-type-s-dpl-p table i)
 		 (segment-descriptor-avl-x-db-g table i)))
-  (values))
\ No newline at end of file
+  (values))
+
+
+
+(defmacro control-stack-esp (stack)
+  `(stack-frame-ref ,stack 0 1))
+
+(defmacro control-stack-ebp (stack)
+  `(stack-frame-ref ,stack 0 0))
+
+(defun control-stack-init (&optional (stack (make-array 254 :element-type '(unsigned-byte 32))))
+  (let ((i (length stack)))
+    (setf (control-stack-esp stack) i
+	  (control-stack-ebp stack) 0)
+    stack))
+
+(defun control-stack-push (value stack &optional (type :lisp))
+  (let ((i (decf (control-stack-esp stack))))
+    (assert (< 1 i (length stack)))
+    (setf (stack-frame-ref stack i 0 type) value)))
+
+(defun control-stack-enter-frame (stack &optional function)
+  (control-stack-push (control-stack-ebp stack) stack)
+  (setf (control-stack-ebp stack) (control-stack-esp stack))
+  (when function
+    (check-type function function)
+    (control-stack-push function stack))
+  stack)
+
+(defun stack-stopper (&rest args)
+  (declare (ignore args))
+  (declare (without-function-prelude))
+  (error "Stack stop.")
+  (format *terminal-io* "~&Stack-stopper halt.")
+  (loop (halt-cpu)))
+
+(defun control-stack-fixate (stack)
+  (let ((stack-base (+ 2 (object-location stack))))
+    (do ((frame (control-stack-ebp stack)))
+	((zerop (stack-frame-uplink stack frame)))
+      (assert (typep (stack-frame-funobj stack frame) 'function))
+      (let ((previous-frame frame))
+	(setf frame (stack-frame-uplink stack frame))
+	(incf (stack-frame-ref stack previous-frame 0)
+	      stack-base)))
+    (values (+ (control-stack-ebp stack) stack-base)
+	    (+ (control-stack-esp stack) stack-base))))	       
+
+(defun make-thread (segment-descriptor-table)
+  (let* ((fs-index 8)
+	 (thread (muerte::clone-run-time-context :name 'subthread)))
+    (setf (segment-descriptor segment-descriptor-table fs-index)
+      (segment-descriptor segment-descriptor-table (truncate (segment-register :fs) 8)))
+    (warn "Thread ~S FS base: ~S"
+	  thread
+	  (setf (segment-descriptor-base-location segment-descriptor-table fs-index)
+	    (+ (object-location thread)
+	       (muerte::location-physical-offset))))
+    (values thread (* 8 fs-index))))
+
+
+(defun control-stack-bootstrap (stack function &rest args)
+  (declare (dynamic-extent args))
+  (check-type function function)
+  (control-stack-init stack)
+  (control-stack-push 0 stack)
+  (control-stack-enter-frame stack #'stack-stopper)
+  (let ((stack-top (+ (object-location stack) 2 (length stack)))
+	(stack-bottom (+ (object-location stack) 2)))
+    (dolist (arg (cddr args))
+      (control-stack-push arg stack))
+    (control-stack-push (+ 2 1 (object-location (funobj-code-vector #'stack-stopper)))
+			stack)		; XXX The extra word skips the frame-setup.
+    (multiple-value-bind (ebp esp)
+	(control-stack-fixate stack)
+      (stack-yield stack esp ebp
+		   :eax (car args)
+		   :ebx (cadr args)
+		   :ecx (length args)
+		   :esi function)))
+  stack)
+
+(defun test-tt ()
+  (multiple-value-bind (thread stack)
+      (muerte.init::threading)
+    (control-stack-bootstrap stack #'format t "Hello world!")))
+
+(defun test-tr (function &rest args)
+  (declare (dynamic-extent args))
+  (assert (= 2 (length args)))
+  (multiple-value-bind (thread fs)
+      (make-thread muerte.init::*segment-descriptor-table*)
+    (let ((cushion nil)
+	  (stack (control-stack-init-for-yield (make-array 4094 :element-type '(unsigned-byte 32))
+					       function args)))
+      (multiple-value-bind (ebp esp)
+	  (control-stack-fixate stack)
+	(setf (control-stack-ebp stack) ebp
+	      (control-stack-esp stack) esp))
+      (setf (%run-time-context-slot 'dynamic-env thread) 0
+	    (%run-time-context-slot 'stack-vector thread) stack
+	    (%run-time-context-slot 'stack-top thread) (+ 2 (object-location stack)
+							  (length stack))
+	    (%run-time-context-slot 'stack-bottom thread) (+ (object-location stack) 2
+							     (or cushion
+								 (if (>= (length stack) 200)
+								     100
+								   0))))
+      (values thread fs stack))))
+
+(defun stack-bootstrapper (&rest args)
+  (declare (ignore args))
+  (with-inline-assembly (:returns :nothing) (:break))
+  (let ((frame (current-stack-frame)))
+    (assert (eql 0 (stack-frame-uplink nil frame)))
+    (let ((function (stack-frame-ref nil frame 1))
+	  (numargs (stack-frame-ref nil frame 2)))
+      (warn "[~S] bootstrapping function ~S with ~D args." frame function numargs)
+      (check-type function function)
+      (check-type numargs (integer 0 #xffff))
+      (with-inline-assembly (:returns :multiple-values)
+	(:load-lexical (:lexical-binding function) :esi)
+	(:movl (:ebp #x0c) :eax)
+	(:movl (:ebp #x10) :ebx)
+	(:call (:esi (:offset movitz-funobj code-vector%2op))))))
+  (error "Stack bootstrapper stop.")
+  (format *terminal-io* "~&stack-bootstrapper halt.")
+  (loop (halt-cpu)))
+
+(defun control-stack-init-for-yield (stack function args)
+  (check-type function function)
+  (control-stack-init stack)
+  (control-stack-push (second args) stack)
+  (control-stack-push (first args) stack)
+  (control-stack-push (length args) stack)
+  (control-stack-push function stack)
+  (control-stack-enter-frame stack #'stack-bootstrapper)
+  ;; Now pretend stack-bootstrapper called yield. First, the return address
+  (control-stack-push (+ 2 2 (object-location (funobj-code-vector #'stack-bootstrapper)))
+		      stack)		; XXX The extra 2 words skip the frame-setup,
+					; XXX which happens to be 8 bytes..
+  (control-stack-enter-frame stack #'yield)
+  (control-stack-push 0 stack)		; XXX shouldn't need this?
+  stack)
+  
+
+(defun yield (target-rtc fs)
+  (assert (not (eq target-rtc (current-run-time-context))))
+  (let ((my-stack (%run-time-context-slot 'stack-vector))
+	(target-stack (%run-time-context-slot 'stack-vector target-rtc)))
+    (assert (not (eq my-stack target-stack)))
+    (let ((esp (control-stack-esp target-stack))
+	  (ebp (control-stack-ebp target-stack)))
+      (assert (location-in-object-p target-stack esp))
+      (assert (location-in-object-p target-stack ebp))
+      (assert (eq (memref ebp -4) (asm-register :esi)) ()
+	"Cannot yield to a non-yield frame.")
+      ;; Push eflags for later..
+      (setf (memref (decf esp) 0) (eflags))
+      ;; Enable someone to yield back here..
+      (setf (control-stack-ebp my-stack) (asm-register :ebp)
+	    (control-stack-esp my-stack) (asm-register :esp))
+      (with-inline-assembly (:returns :nothing)
+	(:cli)
+	(:load-lexical (:lexical-binding fs) :untagged-fixnum-ecx)
+	(:movw :cx :fs)
+	(:load-lexical (:lexical-binding ebp) :eax)
+	(:load-lexical (:lexical-binding esp) :ebx)
+	(:movl :eax :ebp)
+	(:movl :ebx :esp)
+	(:popfl)))))
+
+(defun stack-yield (stack esp ebp &key eax ebx ecx edx esi eflags (dynamic-env 0) cushion)
+  "Activate stack for the current run-time-context, and load the indicated CPU state.
+EIP is loaded from ESI's code-vector."
+  (assert (not (eq stack (%run-time-context-slot 'stack-vector))))
+  (assert (location-in-object-p stack esp))
+  (assert (location-in-object-p stack ebp))
+  (assert (or (= 0 dynamic-env) (location-in-object-p stack dynamic-env)))
+  (let ((stack-top (+ (object-location stack) 2 (length stack)))
+	(stack-bottom (+ (object-location stack) 2
+			 (or cushion
+			     (if (>= (length stack) 200)
+				 100
+			       0)))))
+    (with-inline-assembly (:returns :non-local-exit)
+      (:clc)
+      (:pushfl)
+      (:popl :ebx)
+      (:compile-form (:result-mode :eax) eflags)
+      (:cmpl :edi :eax)
+      (:je 'no-eflags-provided)
+      (:movl :eax :ebx)
+     no-eflags-provided
+      (:locally (:movl :ebx (:edi (:edi-offset raw-scratch0)))) ; Keep eflags in raw-scratch0
+      (:cli)				; Disable interrupts for a little while
+      (:compile-form (:result-mode :eax) stack)
+      (:locally (:movl :eax (:edi (:edi-offset stack-vector))))
+      (:compile-form (:result-mode :eax) dynamic-env)
+      (:locally (:movl :eax (:edi (:edi-offset dynamic-env))))
+      (:compile-two-forms (:eax :ebx) stack-top stack-bottom)
+      (:locally (:movl :eax (:edi (:edi-offset stack-top))))
+      (:locally (:movl :ebx (:edi (:edi-offset stack-bottom))))
+
+      (:compile-two-forms (:eax :ebx) esp ebp)
+      (:locally (:movl :eax (:edi (:edi-offset scratch1))))
+      (:locally (:movl :ebx (:edi (:edi-offset scratch2))))
+
+      (:compile-form (:result-mode :untagged-fixnum-ecx) ecx)
+      (:compile-two-forms (:eax :ebx) eax ebx)
+      (:compile-two-forms (:edx :esi) edx esi)
+      (:locally (:movl (:edi (:edi-offset scratch1)) :esp))
+      (:locally (:movl (:edi (:edi-offset scratch2)) :ebp))
+      (:locally (:pushl (:edi (:edi-offset raw-scratch0)))) ; reset eflags
+      (:popfl)
+      (:jmp (:esi (:offset movitz-funobj code-vector))))))
+



From ffjeld at common-lisp.net  Tue Apr 26 23:40:30 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 27 Apr 2005 01:40:30 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp 
Message-ID: <20050426234030.EA9B188030@common-lisp.net>

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

Modified Files:
	conditions.lisp 
Log Message:
Have condition argument to invoke-debugger be optional.

Date: Wed Apr 27 01:40:30 2005
Author: ffjeld

Index: movitz/losp/muerte/conditions.lisp
diff -u movitz/losp/muerte/conditions.lisp:1.13 movitz/losp/muerte/conditions.lisp:1.14
--- movitz/losp/muerte/conditions.lisp:1.13	Tue Nov  2 16:52:21 2004
+++ movitz/losp/muerte/conditions.lisp	Wed Apr 27 01:40:29 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 Nov 20 15:47:04 2002
 ;;;;                
-;;;; $Id: conditions.lisp,v 1.13 2004/11/02 15:52:21 ffjeld Exp $
+;;;; $Id: conditions.lisp,v 1.14 2005/04/26 23:40:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -270,7 +270,7 @@
   (signal-simple 'simple-condition datum args)
   nil)
 
-(defun invoke-debugger (condition)
+(defun invoke-debugger (&optional condition)
   (when *debugger-hook*
     (let ((hook *debugger-hook*)
 	  (*debugger-hook* nil))



From ffjeld at common-lisp.net  Tue Apr 26 23:43:57 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 27 Apr 2005 01:43:57 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp 
Message-ID: <20050426234357.259B088030@common-lisp.net>

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

Modified Files:
	run-time-context.lisp 
Log Message:
*** empty log message ***
Date: Wed Apr 27 01:43:56 2005
Author: ffjeld

Index: movitz/losp/muerte/run-time-context.lisp
diff -u movitz/losp/muerte/run-time-context.lisp:1.15 movitz/losp/muerte/run-time-context.lisp:1.16
--- movitz/losp/muerte/run-time-context.lisp:1.15	Mon Oct 11 15:53:19 2004
+++ movitz/losp/muerte/run-time-context.lisp	Wed Apr 27 01:43:56 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2003-2004, 
+;;;;    Copyright (C) 2003-2005, 
 ;;;;    Department of Computer Science, University of Tromsoe, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 12 18:33:02 2003
 ;;;;                
-;;;; $Id: run-time-context.lisp,v 1.15 2004/10/11 13:53:19 ffjeld Exp $
+;;;; $Id: run-time-context.lisp,v 1.16 2005/04/26 23:43:56 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -113,39 +113,39 @@
 (defun clone-run-time-context (&key (parent (current-run-time-context))
 				    (name :anonymous))
   (check-type parent run-time-context)
-  (let ((context (%shallow-copy-object parent #.(movitz::movitz-type-word-size 'movitz-run-time-context))))
+  (let ((context (%shallow-copy-object parent (movitz-type-word-size 'movitz-run-time-context))))
     (setf (%run-time-context-slot 'name context) name
-	  (%run-time-context-slot 'self context) context)
-    (setf (%run-time-context-segment-base 'segment-descriptor-thread-context context) 
-      (+ (* #.movitz::+movitz-fixnum-factor+ (object-location context))
-	 (%run-time-context-slot 'physical-address-offset)))
+	  (%run-time-context-slot 'self context) context
+	  (%run-time-context-slot 'atomically-continuation context) 0)
     context))
 
-(defun switch-to-context (context)
-  (check-type context run-time-context)
-  (with-inline-assembly (:returns :nothing)
-    (:compile-form (:result-mode :eax) context)
-    (:movw #.(cl:1- (cl:* 8 8)) (:esp -6))
-    (:addl #.(cl:+ -6 (movitz::global-constant-offset 'movitz::segment-descriptor-table))
-	   :eax)
-    (:addl :edi :eax)
-    (:locally (:addl (:edi (:edi-offset physical-address-offset)) :eax))
-    (:movl :eax (:esp -4))
-    (:lgdt (:esp -6))
-    (:movw #x28 :ax)
-    (:movw :ax :fs)
-    (:locally (:movl (:edi (:edi-offset self)) :eax))))
-
-(defun %run-time-context-install-stack (context &optional (stack-vector
-							   (make-array 8192 :element-type 'u32))
-							  (cushion 1024))
-  (check-type stack-vector vector)
-  (assert (< cushion (array-dimension stack-vector 0)))
-  (setf (%run-time-context-slot 'stack-vector context) stack-vector)
+;;;(defun switch-to-context (context)
+;;;  (check-type context run-time-context)
+;;;  (with-inline-assembly (:returns :nothing)
+;;;    (:compile-form (:result-mode :eax) context)
+;;;    (:movw #.(cl:1- (cl:* 8 8)) (:esp -6))
+;;;    (:addl #.(cl:+ -6 (movitz::global-constant-offset 'movitz::segment-descriptor-table))
+;;;	   :eax)
+;;;    (:addl :edi :eax)
+;;;    (:locally (:addl (:edi (:edi-offset physical-address-offset)) :eax))
+;;;    (:movl :eax (:esp -4))
+;;;    (:lgdt (:esp -6))
+;;;    (:movw #x28 :ax)
+;;;    (:movw :ax :fs)
+;;;    (:locally (:movl (:edi (:edi-offset self)) :eax))))
+
+(defun %run-time-context-install-stack (context
+					&optional (control-stack
+						   (make-array 8192 :element-type '(unsigned-byte 32)))
+						  (cushion 1024))
+  (check-type control-stack vector)
+  (assert (< cushion (array-dimension control-stack 0)))
+  (setf (%run-time-context-slot 'control-stack context) control-stack)
   (setf (%run-time-context-slot 'stack-top context)
-    (+ (object-location stack-vector) 8
-       (* 4 (array-dimension stack-vector 0))))
+    (+ (object-location control-stack) 8
+       (* 4 (array-dimension control-stack 0))))
   (setf (%run-time-context-slot 'stack-bottom context)
-    (+ (object-location stack-vector) 8
+    (+ (object-location control-stack) 8
        (* 4 cushion)))
-  stack-vector)
+  control-stack)
+



From ffjeld at common-lisp.net  Tue Apr 26 23:44:19 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 27 Apr 2005 01:44:19 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp 
Message-ID: <20050426234419.7DF9E88030@common-lisp.net>

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

Modified Files:
	interrupt.lisp 
Log Message:
Remove superfluous :locally.

Date: Wed Apr 27 01:44:18 2005
Author: ffjeld

Index: movitz/losp/muerte/interrupt.lisp
diff -u movitz/losp/muerte/interrupt.lisp:1.41 movitz/losp/muerte/interrupt.lisp:1.42
--- movitz/losp/muerte/interrupt.lisp:1.41	Wed Mar  9 08:20:54 2005
+++ movitz/losp/muerte/interrupt.lisp	Wed Apr 27 01:44:18 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.41 2005/03/09 07:20:54 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.42 2005/04/26 23:44:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -129,7 +129,7 @@
 	    (:locally (:pushl (:edi (:edi-offset dynamic-env))))
 	    (:locally (:pushl (:edi (:edi-offset atomically-continuation))))
 	    (:locally (:pushl (:edi (:edi-offset raw-scratch0))))
-	    (:locally (:pushl :ecx))
+	    (:pushl :ecx)
 	    (:movcr :cr2 :ecx)
 	    (:locally (:pushl :ecx))
 	    ,@(loop for reg in (sort (copy-list '(:eax :ebx :edx :esi))



From ffjeld at common-lisp.net  Tue Apr 26 23:44:37 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 27 Apr 2005 01:44:37 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/error.lisp 
Message-ID: <20050426234437.8DBA788030@common-lisp.net>

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

Modified Files:
	error.lisp 
Log Message:
*** empty log message ***
Date: Wed Apr 27 01:44:36 2005
Author: ffjeld

Index: movitz/losp/muerte/error.lisp
diff -u movitz/losp/muerte/error.lisp:1.3 movitz/losp/muerte/error.lisp:1.4
--- movitz/losp/muerte/error.lisp:1.3	Wed Sep 22 18:15:41 2004
+++ movitz/losp/muerte/error.lisp	Wed Apr 27 01:44:36 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:    Sat Sep  1 00:49:11 2001
 ;;;;                
-;;;; $Id: error.lisp,v 1.3 2004/09/22 16:15:41 ffjeld Exp $
+;;;; $Id: error.lisp,v 1.4 2005/04/26 23:44:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -25,7 +25,7 @@
 (defvar *error-no-condition-for-debugger* nil
   "If true, don't create a simple-error object just for the debugger,
  (presumably) since this might trigger another bug.")
-(defvar *disable-interrupts-on-error* t)
+(defvar *disable-interrupts-on-error* nil)
 
 (defun error (&rest arguments)
   (declare (dynamic-extent arguments))



From ffjeld at common-lisp.net  Tue Apr 26 23:45:01 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 27 Apr 2005 01:45:01 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <20050426234501.25B3888030@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Added asm-register.

Date: Wed Apr 27 01:45:00 2005
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.57 movitz/losp/muerte/basic-macros.lisp:1.58
--- movitz/losp/muerte/basic-macros.lisp:1.57	Wed Apr 20 08:50:10 2005
+++ movitz/losp/muerte/basic-macros.lisp	Wed Apr 27 01:45:00 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: basic-macros.lisp,v 1.57 2005/04/20 06:50:10 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.58 2005/04/26 23:45:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -367,6 +367,12 @@
 				      ,keyform
 				      ',(mapcar #'first clauses)))))
 
+(define-compiler-macro asm-register (register-name)
+  (if (member register-name '(:eax :ebx :ecx :untagged-fixnum-ecx :edx))
+      `(with-inline-assembly (:returns ,register-name) ())
+    `(with-inline-assembly (:returns :eax)
+       (:movl ,register-name :eax))))
+
 (defmacro movitz-accessor (object-form type slot-name)
   (warn "movitz-accesor deprecated.")
   `(with-inline-assembly (:returns :register :side-effects nil)
@@ -604,7 +610,6 @@
 (define-compiler-macro cdar (x)
   `(cdr (car ,x)))
 			     
-
 (define-compiler-macro rest (x) `(cdr ,x))
 (define-compiler-macro first (x) `(car ,x))
 (define-compiler-macro second (x) `(cadr ,x))



From ffjeld at common-lisp.net  Tue Apr 26 23:45:49 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 27 Apr 2005 01:45:49 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <20050426234549.809A288030@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Fixed stupid bug in previous fix to values compiler.

Date: Wed Apr 27 01:45:48 2005
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.50 movitz/special-operators.lisp:1.51
--- movitz/special-operators.lisp:1.50	Mon Apr 25 00:08:39 2005
+++ movitz/special-operators.lisp	Wed Apr 27 01:45:48 2005
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.50 2005/04/24 22:08:39 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.51 2005/04/26 23:45:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1132,12 +1132,9 @@
 				     `(:locally (:popl (:edi (:edi-offset values ,(* i 4))))))
 			       (make-immediate-move (* +movitz-fixnum-factor+ (- (length sub-forms) 2))
 						    :ecx)
-			       `((:locally (:movl :ecx (:edi (:edi-offset num-values))))
-				 (:stc))
-			       #+ignore
-			       (make-compiled-funcall-by-symbol 'muerte.cl::values
-								(length sub-forms)
-								(all :funobj))
+			       `((:locally (:movl :ecx (:edi (:edi-offset num-values)))))
+			       (make-immediate-move (length sub-forms) :ecx)
+			       `((:stc))
 			       stack-restore-code)))))))))
 
 (define-special-operator muerte::compiler-typecase (&all all &form form)



From ffjeld at common-lisp.net  Tue Apr 26 23:46:14 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 27 Apr 2005 01:46:14 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/ll-testing.lisp 
Message-ID: <20050426234614.B5B1888030@common-lisp.net>

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

Modified Files:
	ll-testing.lisp 
Log Message:
Now there is make-thread.

Date: Wed Apr 27 01:46:14 2005
Author: ffjeld

Index: movitz/losp/ll-testing.lisp
diff -u movitz/losp/ll-testing.lisp:1.4 movitz/losp/ll-testing.lisp:1.5
--- movitz/losp/ll-testing.lisp:1.4	Wed Apr 27 00:23:14 2005
+++ movitz/losp/ll-testing.lisp	Wed Apr 27 01:46:13 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Apr 14 08:18:43 2005
 ;;;;                
-;;;; $Id: ll-testing.lisp,v 1.4 2005/04/26 22:23:14 ffjeld Exp $
+;;;; $Id: ll-testing.lisp,v 1.5 2005/04/26 23:46:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -104,7 +104,7 @@
     (values (+ (control-stack-ebp stack) stack-base)
 	    (+ (control-stack-esp stack) stack-base))))	       
 
-(defun make-thread (segment-descriptor-table)
+(defun alloc-context (segment-descriptor-table)
   (let* ((fs-index 8)
 	 (thread (muerte::clone-run-time-context :name 'subthread)))
     (setf (segment-descriptor segment-descriptor-table fs-index)
@@ -116,7 +116,6 @@
 	       (muerte::location-physical-offset))))
     (values thread (* 8 fs-index))))
 
-
 (defun control-stack-bootstrap (stack function &rest args)
   (declare (dynamic-extent args))
   (check-type function function)
@@ -143,11 +142,16 @@
       (muerte.init::threading)
     (control-stack-bootstrap stack #'format t "Hello world!")))
 
-(defun test-tr (function &rest args)
-  (declare (dynamic-extent args))
-  (assert (= 2 (length args)))
-  (multiple-value-bind (thread fs)
-      (make-thread muerte.init::*segment-descriptor-table*)
+(defun make-thread (&optional (name (gensym "thread-")) (function #'invoke-debugger) &rest args)
+  "Make a thread and initialize its stack to apply function to args."
+  (let* ((fs-index 8) ; a vacant spot in the global segment descriptor table..
+	 (fs (* 8 fs-index))
+	 (thread (muerte::clone-run-time-context :name name))
+	 (segment-descriptor-table muerte.init::*segment-descriptor-table*))
+    (setf (segment-descriptor segment-descriptor-table fs-index)
+      (segment-descriptor segment-descriptor-table (truncate (segment-register :fs) 8)))
+    (setf (segment-descriptor-base-location segment-descriptor-table fs-index)
+      (+ (object-location thread) (muerte::location-physical-offset)))
     (let ((cushion nil)
 	  (stack (control-stack-init-for-yield (make-array 4094 :element-type '(unsigned-byte 32))
 					       function args)))
@@ -164,33 +168,25 @@
 								 (if (>= (length stack) 200)
 								     100
 								   0))))
-      (values thread fs stack))))
+      (values thread fs))))
 
-(defun stack-bootstrapper (&rest args)
-  (declare (ignore args))
-  (with-inline-assembly (:returns :nothing) (:break))
+(defun stack-bootstrapper (&rest ignore)
+  (declare (ignore ignore))
   (let ((frame (current-stack-frame)))
     (assert (eql 0 (stack-frame-uplink nil frame)))
     (let ((function (stack-frame-ref nil frame 1))
-	  (numargs (stack-frame-ref nil frame 2)))
-      (warn "[~S] bootstrapping function ~S with ~D args." frame function numargs)
+	  (args (stack-frame-ref nil frame 2)))
       (check-type function function)
-      (check-type numargs (integer 0 #xffff))
-      (with-inline-assembly (:returns :multiple-values)
-	(:load-lexical (:lexical-binding function) :esi)
-	(:movl (:ebp #x0c) :eax)
-	(:movl (:ebp #x10) :ebx)
-	(:call (:esi (:offset movitz-funobj code-vector%2op))))))
-  (error "Stack bootstrapper stop.")
+      (check-type args list)
+      (apply function args)))
+  (error "Nothing left to do for ~S." (current-run-time-context))
   (format *terminal-io* "~&stack-bootstrapper halt.")
   (loop (halt-cpu)))
 
 (defun control-stack-init-for-yield (stack function args)
   (check-type function function)
   (control-stack-init stack)
-  (control-stack-push (second args) stack)
-  (control-stack-push (first args) stack)
-  (control-stack-push (length args) stack)
+  (control-stack-push args stack)
   (control-stack-push function stack)
   (control-stack-enter-frame stack #'stack-bootstrapper)
   ;; Now pretend stack-bootstrapper called yield. First, the return address
@@ -202,7 +198,8 @@
   stack)
   
 
-(defun yield (target-rtc fs)
+(defun yield (target-rtc fs &optional value)
+  (declare (dynamic-extent values))
   (assert (not (eq target-rtc (current-run-time-context))))
   (let ((my-stack (%run-time-context-slot 'stack-vector))
 	(target-stack (%run-time-context-slot 'stack-vector target-rtc)))
@@ -211,21 +208,24 @@
 	  (ebp (control-stack-ebp target-stack)))
       (assert (location-in-object-p target-stack esp))
       (assert (location-in-object-p target-stack ebp))
-      (assert (eq (memref ebp -4) (asm-register :esi)) ()
-	"Cannot yield to a non-yield frame.")
+      (assert (eq (stack-frame-funobj nil ebp)
+		  (asm-register :esi)) ()
+	"Will not yield to a non-yield frame.")
       ;; Push eflags for later..
       (setf (memref (decf esp) 0) (eflags))
+      ;; Store EBP and ESP so we can get to them after the switch
+      (setf (%run-time-context-slot 'scratch1 target-rtc) ebp
+	    (%run-time-context-slot 'scratch2 target-rtc) esp)
       ;; Enable someone to yield back here..
       (setf (control-stack-ebp my-stack) (asm-register :ebp)
 	    (control-stack-esp my-stack) (asm-register :esp))
-      (with-inline-assembly (:returns :nothing)
-	(:cli)
+      (with-inline-assembly (:returns :eax)
 	(:load-lexical (:lexical-binding fs) :untagged-fixnum-ecx)
+	(:load-lexical (:lexical-binding value) :eax)
+	(:cli)
 	(:movw :cx :fs)
-	(:load-lexical (:lexical-binding ebp) :eax)
-	(:load-lexical (:lexical-binding esp) :ebx)
-	(:movl :eax :ebp)
-	(:movl :ebx :esp)
+	(:locally (:movl (:edi (:edi-offset scratch1)) :ebp))
+	(:locally (:movl (:edi (:edi-offset scratch2)) :esp))
 	(:popfl)))))
 
 (defun stack-yield (stack esp ebp &key eax ebx ecx edx esi eflags (dynamic-env 0) cushion)



From ffjeld at common-lisp.net  Thu Apr 28 22:05:05 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 29 Apr 2005 00:05:05 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/lib/threading.lisp 
Message-ID: <20050428220505.C581088030@common-lisp.net>

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

Added Files:
	threading.lisp 
Log Message:
We do need threads, don't we?
This isn't quite functional, just yet.

Date: Fri Apr 29 00:05:02 2005
Author: ffjeld




From ffjeld at common-lisp.net  Fri Apr 29 22:36:02 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 30 Apr 2005 00:36:02 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <20050429223602.62A4B88704@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Put the initial segment-descriptor-table in an array installed in
variable muerte::*initial-segment-descriptor-table*. Don't embed it in
the run-time-context.

Date: Sat Apr 30 00:36:01 2005
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.90 movitz/image.lisp:1.91
--- movitz/image.lisp:1.90	Wed Apr 20 08:54:50 2005
+++ movitz/image.lisp	Sat Apr 30 00:36:01 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.90 2005/04/20 06:54:50 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.91 2005/04/29 22:36:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -351,13 +351,6 @@
     :map-binary-read-delayed 'movitz-word
     :initarg :exception-handlers
     :accessor movitz-run-time-context-exception-handlers)
-;;;   (exception-handler-tails
-;;;    :binary-type word
-;;;    :initform nil
-;;;    :map-binary-write 'movitz-read-and-intern
-;;;    :map-binary-read-delayed 'movitz-word
-;;;    :initarg :exception-handler-tails
-;;;    :accessor movitz-run-time-context-exception-handler-tails)
    (interrupt-descriptor-table
     :binary-type word
     :accessor movitz-run-time-context-interrupt-descriptor-table
@@ -423,46 +416,6 @@
    (bochs-flags
     :binary-type lu32
     :initform 0)
-   ;; (align-segment-descriptors :binary-type 4)
-   (segment-descriptor-table :binary-type :label)
-   (segment-descriptor-0
-    :binary-type segment-descriptor
-    :initform (make-segment-descriptor))
-   (segment-descriptor-global-code	; 1: true flat code segment
-    :binary-type segment-descriptor
-    :initform (make-segment-descriptor :base 0 :limit #xfffff :type 14 :dpl 0
-				       :flags '(s p d/b g)))
-   (segment-descriptor-global-data	; 2: true flat data segment
-    :binary-type segment-descriptor
-    :initform (make-segment-descriptor :base 0 :limit #xfffff ; data segment
-				       :type 2 :dpl 3
-				       :flags '(s p d/b g)))
-   (segment-descriptor-shifted-code	; 3: 1 MB shifted flat code segment
-    :binary-type segment-descriptor
-    :initform (make-segment-descriptor :base (image-cs-segment-base *image*)
-				       :limit #xfff00 :type 14 :dpl 0
-				       :flags '(s p d/b g)))
-   (segment-descriptor-shifted-data	; 4: 1 MB shifted flat data segment
-    :binary-type segment-descriptor
-    :initform (make-segment-descriptor :base (image-ds-segment-base *image*)
-				       :limit #xfff00 ; data segment
-				       :type 2 :dpl 3
-				       :flags '(s p d/b g)))
-   (segment-descriptor-thread-context	; 5: same as normal shifted-data for initial context.
-    :binary-type segment-descriptor
-    :initform (make-segment-descriptor :base (image-ds-segment-base *image*)
-				       :limit #xfff00 ; data segment
-				       :type 2 :dpl 0
-				       :flags '(s p d/b g)))
-   (segment-descriptor-stack		; 6: same as normal shifted-data, DPL=0
-    :binary-type segment-descriptor
-    :initform (make-segment-descriptor :base (image-ds-segment-base *image*)
-				       :limit #xfff00 ; data segment
-				       :type 2 :dpl 0
-				       :flags '(s p d/b g)))
-   (segment-descriptor-7
-    :binary-type segment-descriptor
-    :initform (make-segment-descriptor))
    (raw-scratch0			; A non-GC-root scratch register
     :binary-type lu32
     :initform 0)
@@ -799,6 +752,31 @@
 	     x)
     y))
 
+(defun make-initial-segment-descriptor-table ()
+  (let ((u32-list
+	 (let ((bt:*endian* :little-endian))
+	   (merge-bytes (with-binary-output-to-list (octet-list)
+			  (mapcar (lambda (init-args)
+				    (write-binary 'segment-descriptor octet-list
+						  (apply #'make-segment-descriptor init-args)))
+				  `(()	; 0
+				    (:base 0 :limit #xfffff ; 1: physical code
+					   :type 14 :dpl 0 :flags (s p d/b g))
+				    (:base 0 :limit #xfffff ; 2: physical data
+					   :type 2 :dpl 3 :flags (s p d/b g))
+				    (:base ,(image-cs-segment-base *image*) ; 3: logical code
+					   :limit #xfff00
+					   :type 14 :dpl 0 :flags (s p d/b g))
+				    (:base ,(image-ds-segment-base *image*) ; 4: logical data
+					   :limit #xfff00
+					   :type 2 :dpl 0 :flags (s p d/b g))
+				    )))
+			8 32))))
+    (movitz-read (make-movitz-vector (length u32-list)
+				     :initial-contents u32-list
+				     :element-type '(unsigned-byte 32)))))
+		     
+
 (defun make-movitz-image (&rest init-args &key start-address &allow-other-keys)
   (let ((*image* (apply #'make-instance 'symbolic-image
 			:nil-object (make-movitz-nil)
@@ -821,10 +799,6 @@
       (ldb (byte 3 0) (image-nil-word *image*))
       (tag :null))
     (setf (image-run-time-context *image*) (make-movitz-run-time-context))
-    (unless (= 0 (mod (+ (image-nil-word *image*) (slot-offset 'movitz-run-time-context
-							       'segment-descriptor-table))
-		      16))
-      (warn "Segment descriptor table is not aligned on a 16-byte boundary."))
     (setf (image-t-symbol *image*) (movitz-read t))
     ;; (warn "NIL value: #x~X" (image-nil-word *image*))
     *image*))
@@ -879,6 +853,9 @@
     (assert (plusp (dump-count *image*))))
   (setf (movitz-symbol-value (movitz-read 'muerte:*build-number*))
     (1+ *bootblock-build*))
+  (when (eq 'unbound (movitz-symbol-value (movitz-read 'muerte::*initial-segment-descriptor-table*)))
+    (setf (movitz-symbol-value (movitz-read 'muerte::*initial-segment-descriptor-table*))
+      (make-initial-segment-descriptor-table)))
   (let ((handler (movitz-env-symbol-function 'muerte::interrupt-default-handler)))
     (setf (movitz-run-time-context-exception-handlers (image-run-time-context *image*))
       (movitz-read (make-array 256 :initial-element handler))))
@@ -1611,10 +1588,15 @@
 			       (:cli)
 			       (:cld)	; clear direction flag => "normal" register GC roots.
 
-			       (:movw ,(1- (* 8 8)) (:esp -6))
-			       (:movl ,(+ (image-ds-segment-base *image*)
-					  (image-nil-word *image*)
-					  (global-constant-offset 'segment-descriptor-table))
+			       (:movw ,(1- (* 8 5)) (:esp -6))
+			       (:movl ,(+ (movitz-read-and-intern
+					   'muerte::*initial-segment-descriptor-table* 'word)
+					  (image-ds-segment-base *image*))
+				      :ecx)
+			       (:movl (:ecx ,(bt:slot-offset 'movitz-symbol 'value))
+				      :ecx)
+			       (:addl ,(+ (bt:slot-offset 'movitz-basic-vector 'data)
+					  (image-ds-segment-base *image*))
 				      :ecx)
 			       (:movl :ecx (:esp -4))
 			       (:lgdt (:esp -6))
@@ -1634,12 +1616,10 @@
 			       (:movw ,(* 4 8) :cx)
 			       (:movw :cx :ds)
 			       (:movw :cx :es)
+			       (:movw :cx :fs)
+			       (:movw :cx :ss)
 			       (:movw ,(* 2 8) :cx)
-			       (:movw :cx :gs) ; global context segment
-			       (:movw ,(* 5 8) :cx)
-			       (:movw :cx :fs) ; thread context segment
-			       (:movw ,(* 6 8) :cx)
-			       (:movw :cx :ss) ; stack segment
+			       (:movw :cx :gs) ; physical context segment
 
 			       (:movl ,(image-nil-word *image*) :edi)
 			       (:globally (:movl (:edi (:edi-offset stack-top)) :esp))



From ffjeld at common-lisp.net  Fri Apr 29 22:36:06 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 30 Apr 2005 00:36:06 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp 
Message-ID: <20050429223606.C101D8870E@common-lisp.net>

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

Modified Files:
	segments.lisp 
Log Message:
Put the initial segment-descriptor-table in an array installed in
variable muerte::*initial-segment-descriptor-table*. Don't embed it in
the run-time-context.

Date: Sat Apr 30 00:36:05 2005
Author: ffjeld

Index: movitz/losp/muerte/segments.lisp
diff -u movitz/losp/muerte/segments.lisp:1.12 movitz/losp/muerte/segments.lisp:1.13
--- movitz/losp/muerte/segments.lisp:1.12	Mon Apr 25 00:11:24 2005
+++ movitz/losp/muerte/segments.lisp	Sat Apr 30 00:36:05 2005
@@ -10,13 +10,15 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu May  8 14:25:06 2003
 ;;;;                
-;;;; $Id: segments.lisp,v 1.12 2005/04/24 22:11:24 ffjeld Exp $
+;;;; $Id: segments.lisp,v 1.13 2005/04/29 22:36:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
 (provide :muerte/segments)
 
 (in-package muerte)
+
+(defvar *initial-segment-descriptor-table*)
 
 (defun segment-register (segment-register-name)
   "Return the value of an x86 segment register, such as :cs or :ds."



From ffjeld at common-lisp.net  Fri Apr 29 22:36:24 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 30 Apr 2005 00:36:24 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp 
Message-ID: <20050429223624.55A2F8870E@common-lisp.net>

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

Modified Files:
	conditions.lisp 
Log Message:
*** empty log message ***
Date: Sat Apr 30 00:36:23 2005
Author: ffjeld

Index: movitz/losp/muerte/conditions.lisp
diff -u movitz/losp/muerte/conditions.lisp:1.14 movitz/losp/muerte/conditions.lisp:1.15
--- movitz/losp/muerte/conditions.lisp:1.14	Wed Apr 27 01:40:29 2005
+++ movitz/losp/muerte/conditions.lisp	Sat Apr 30 00:36:23 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 20 15:47:04 2002
 ;;;;                
-;;;; $Id: conditions.lisp,v 1.14 2005/04/26 23:40:29 ffjeld Exp $
+;;;; $Id: conditions.lisp,v 1.15 2005/04/29 22:36:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -270,7 +270,7 @@
   (signal-simple 'simple-condition datum args)
   nil)
 
-(defun invoke-debugger (&optional condition)
+(defun invoke-debugger (condition)
   (when *debugger-hook*
     (let ((hook *debugger-hook*)
 	  (*debugger-hook* nil))



From ffjeld at common-lisp.net  Fri Apr 29 22:36:49 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 30 Apr 2005 00:36:49 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/ll-testing.lisp 
Message-ID: <20050429223649.EC11588704@common-lisp.net>

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

Modified Files:
	ll-testing.lisp 
Log Message:
*** empty log message ***
Date: Sat Apr 30 00:36:49 2005
Author: ffjeld

Index: movitz/losp/ll-testing.lisp
diff -u movitz/losp/ll-testing.lisp:1.5 movitz/losp/ll-testing.lisp:1.6
--- movitz/losp/ll-testing.lisp:1.5	Wed Apr 27 01:46:13 2005
+++ movitz/losp/ll-testing.lisp	Sat Apr 30 00:36:49 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Apr 14 08:18:43 2005
 ;;;;                
-;;;; $Id: ll-testing.lisp,v 1.5 2005/04/26 23:46:13 ffjeld Exp $
+;;;; $Id: ll-testing.lisp,v 1.6 2005/04/29 22:36:49 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -59,6 +59,8 @@
   (values))
 
 
+(defmacro control-stack-fs (stack)
+  `(stack-frame-ref ,stack 0 2))
 
 (defmacro control-stack-esp (stack)
   `(stack-frame-ref ,stack 0 1))
@@ -137,17 +139,12 @@
 		   :esi function)))
   stack)
 
-(defun test-tt ()
-  (multiple-value-bind (thread stack)
-      (muerte.init::threading)
-    (control-stack-bootstrap stack #'format t "Hello world!")))
-
-(defun make-thread (&optional (name (gensym "thread-")) (function #'invoke-debugger) &rest args)
+(defun make-thread (&key (name (gensym "thread-")) (function #'invoke-debugger) (args '(nil)))
   "Make a thread and initialize its stack to apply function to args."
-  (let* ((fs-index 8) ; a vacant spot in the global segment descriptor table..
+  (let* ((fs-index 8)			; a vacant spot in the global segment descriptor table..
 	 (fs (* 8 fs-index))
 	 (thread (muerte::clone-run-time-context :name name))
-	 (segment-descriptor-table muerte.init::*segment-descriptor-table*))
+	 (segment-descriptor-table (symbol-value 'muerte.init::*segment-descriptor-table*)))
     (setf (segment-descriptor segment-descriptor-table fs-index)
       (segment-descriptor segment-descriptor-table (truncate (segment-register :fs) 8)))
     (setf (segment-descriptor-base-location segment-descriptor-table fs-index)
@@ -157,7 +154,8 @@
 					       function args)))
       (multiple-value-bind (ebp esp)
 	  (control-stack-fixate stack)
-	(setf (control-stack-ebp stack) ebp
+	(setf (control-stack-fs stack) fs
+	      (control-stack-ebp stack) ebp
 	      (control-stack-esp stack) esp))
       (setf (%run-time-context-slot 'dynamic-env thread) 0
 	    (%run-time-context-slot 'stack-vector thread) stack
@@ -168,7 +166,7 @@
 								 (if (>= (length stack) 200)
 								     100
 								   0))))
-      (values thread fs))))
+      (values thread))))
 
 (defun stack-bootstrapper (&rest ignore)
   (declare (ignore ignore))
@@ -194,17 +192,17 @@
 		      stack)		; XXX The extra 2 words skip the frame-setup,
 					; XXX which happens to be 8 bytes..
   (control-stack-enter-frame stack #'yield)
-  (control-stack-push 0 stack)		; XXX shouldn't need this?
   stack)
   
 
-(defun yield (target-rtc fs &optional value)
+(defun yield (target-rtc &optional value)
   (declare (dynamic-extent values))
   (assert (not (eq target-rtc (current-run-time-context))))
   (let ((my-stack (%run-time-context-slot 'stack-vector))
 	(target-stack (%run-time-context-slot 'stack-vector target-rtc)))
     (assert (not (eq my-stack target-stack)))
-    (let ((esp (control-stack-esp target-stack))
+    (let ((fs (control-stack-fs target-stack))
+	  (esp (control-stack-esp target-stack))
 	  (ebp (control-stack-ebp target-stack)))
       (assert (location-in-object-p target-stack esp))
       (assert (location-in-object-p target-stack ebp))
@@ -217,7 +215,8 @@
       (setf (%run-time-context-slot 'scratch1 target-rtc) ebp
 	    (%run-time-context-slot 'scratch2 target-rtc) esp)
       ;; Enable someone to yield back here..
-      (setf (control-stack-ebp my-stack) (asm-register :ebp)
+      (setf (control-stack-fs my-stack) (segment-register :fs)
+	    (control-stack-ebp my-stack) (asm-register :ebp)
 	    (control-stack-esp my-stack) (asm-register :esp))
       (with-inline-assembly (:returns :eax)
 	(:load-lexical (:lexical-binding fs) :untagged-fixnum-ecx)



From ffjeld at common-lisp.net  Fri Apr 29 22:37:09 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 30 Apr 2005 00:37:09 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <20050429223709.63A3B88704@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
*** empty log message ***
Date: Sat Apr 30 00:37:08 2005
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.49 movitz/losp/los0-gc.lisp:1.50
--- movitz/losp/los0-gc.lisp:1.49	Wed Mar  9 08:31:28 2005
+++ movitz/losp/los0-gc.lisp	Sat Apr 30 00:37:08 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.49 2005/03/09 07:31:28 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.50 2005/04/29 22:37:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -392,6 +392,8 @@
 			   new)))))
 		  ((not (object-in-space-p oldspace x))
 		   x)
+		  ((when (typep x 'run-time-context)
+		     (warn "Scavengning ~S" x)))
 		  (t (or (and (eq (object-tag x)
 				  (ldb (byte 3 0)
 				       (memref (object-location x) 0 :type :unsigned-byte8)))



From ffjeld at common-lisp.net  Sat Apr 30 21:15:36 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 30 Apr 2005 23:15:36 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <20050430211536.C814C88671@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Cleaned up the unbound-value protocol a bit.

Date: Sat Apr 30 23:15:36 2005
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.91 movitz/image.lisp:1.92
--- movitz/image.lisp:1.91	Sat Apr 30 00:36:01 2005
+++ movitz/image.lisp	Sat Apr 30 23:15:35 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.91 2005/04/29 22:36:01 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.92 2005/04/30 21:15:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -27,6 +27,19 @@
     :initform :bootup
     :map-binary-write 'movitz-read-and-intern
     :map-binary-read-delayed 'movitz-word)
+   (class
+    :binary-type word
+    :map-binary-write 'movitz-intern
+    :map-binary-read-delayed 'movitz-word
+    :initarg :class
+    :accessor run-time-context-class)
+   (slots
+    :binary-type word
+    :map-binary-write 'movitz-read-and-intern
+    :map-binary-read-delayed 'movitz-word
+    :initarg :slots
+    :initform #()
+    :accessor run-time-context-slots)
    (fast-car
     :binary-type code-vector-word
     :initform nil
@@ -150,10 +163,10 @@
     :reader movitz-run-time-context-null-symbol
     :initarg :null-symbol)
    (new-unbound-value
-    :binary-type lu32
-;;;    :map-binary-read-delayed 'movitz-word
-;;;    :map-binary-write 'movitz-read-and-intern
-    :initform #x7fffffff)
+    :binary-type word
+    :map-binary-read-delayed 'movitz-word
+    :map-binary-write 'movitz-read-and-intern
+    :initform 'unbound)
    ;; primitive functions global constants
    (pop-current-values
     :binary-type code-vector-word
@@ -598,8 +611,8 @@
 
 (defun unbound-value ()
   (declare (special *image*))
-  (slot-value (image-run-time-context *image*)
-	      'new-unbound-value))
+  (movitz-read (slot-value (image-run-time-context *image*)
+			   'new-unbound-value)))
 
 (defun edi-offset ()
   (declare (special *image*))
@@ -861,6 +874,9 @@
       (movitz-read (make-array 256 :initial-element handler))))
   (setf (movitz-symbol-value (movitz-read 'muerte::*setf-namespace*))
     (movitz-read (movitz-environment-setf-function-names *movitz-global-environment*) t))
+  (setf (run-time-context-class (image-run-time-context *image*))
+    (muerte::movitz-find-class 'muerte::run-time-context))
+  (setf (run-time-context-slots (image-run-time-context *image*)) #(1 2 3))
   (let ((load-address (image-start-address *image*)))
     (setf (image-cons-pointer *image*) (- load-address
 					  (image-ds-segment-base *image*))
@@ -1450,6 +1466,7 @@
 	  (etypecase expr
 	    (null *movitz-nil*)
 	    ((member t) (movitz-read 'muerte.cl:t))
+	    ((eql unbound) (make-instance 'movitz-unbound-value))
 	    (symbol (intern-movitz-symbol expr))
 	    (integer (make-movitz-integer expr))
 	    (character (make-movitz-character expr))



From ffjeld at common-lisp.net  Sat Apr 30 21:15:47 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 30 Apr 2005 23:15:47 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <20050430211547.ACCB28870E@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Cleaned up the unbound-value protocol a bit.

Date: Sat Apr 30 23:15:47 2005
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.50 movitz/storage-types.lisp:1.51
--- movitz/storage-types.lisp:1.50	Sun Feb 27 03:31:34 2005
+++ movitz/storage-types.lisp	Sat Apr 30 23:15:43 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: storage-types.lisp,v 1.50 2005/02/27 02:31:34 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.51 2005/04/30 21:15:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -151,11 +151,9 @@
   (ecase type
     (word
      (cond
-       ((eq expr 'unbound)
-	(slot-value (image-run-time-context *image*) 'new-unbound-value))
-       ((typep expr 'movitz-object)
-	(movitz-intern expr))
-       (t (movitz-intern (movitz-read expr)))))
+      ((typep expr 'movitz-object)
+       (movitz-intern expr))
+      (t (movitz-intern (movitz-read expr)))))
     (code-vector-word
      (movitz-intern-code-vector expr))))
 
@@ -533,6 +531,14 @@
 (deftype movitz-string ()
   '(satisfies movitz-stringp))
 
+;;;
+
+(define-binary-class movitz-unbound-value (movitz-immediate-object)
+  ())
+
+(defmethod movitz-intern ((obj movitz-unbound-value) &optional type)
+  (declare (ignore type))
+  #x7fffffff)
 
 ;;; Symbols
 



From ffjeld at common-lisp.net  Sat Apr 30 21:16:13 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 30 Apr 2005 23:16:13 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <20050430211613.1080188671@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
*** empty log message ***
Date: Sat Apr 30 23:16:12 2005
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.46 movitz/packages.lisp:1.47
--- movitz/packages.lisp:1.46	Wed Apr 20 08:54:38 2005
+++ movitz/packages.lisp	Sat Apr 30 23:16:12 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.46 2005/04/20 06:54:38 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.47 2005/04/30 21:16:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1203,6 +1203,7 @@
 	   #:basic-restart
 	   #:illegal-object
 	   #:run-time-context
+	   #:run-time-context-class
 	   #:current-run-time-context
 	   
 	   make-funobj



From ffjeld at common-lisp.net  Sat Apr 30 21:19:43 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 30 Apr 2005 23:19:43 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/movitz-mode.el 
Message-ID: <20050430211943.5282988671@common-lisp.net>

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

Modified Files:
	movitz-mode.el 
Log Message:
Have in-movitz-package-p be somewhat more clever.

Date: Sat Apr 30 23:19:43 2005
Author: ffjeld

Index: movitz/movitz-mode.el
diff -u movitz/movitz-mode.el:1.8 movitz/movitz-mode.el:1.9
--- movitz/movitz-mode.el:1.8	Tue Nov 30 15:16:18 2004
+++ movitz/movitz-mode.el	Sat Apr 30 23:19:42 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Sep 27 18:12:17 2001
 ;;;;                
-;;;; $Id: movitz-mode.el,v 1.8 2004/11/30 14:16:18 ffjeld Exp $
+;;;; $Id: movitz-mode.el,v 1.9 2005/04/30 21:19:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -33,8 +33,10 @@
   (or (and (< 6 (length fi:package))
 	   (string= "MUERTE." (upcase (substring fi:package 0 7))))
       (member (upcase fi:package)
-	      '("MUERTE" "X86" "X86-PC"))))
-
+	      '("MUERTE" "X86" "X86-PC"))
+      (member "MUERTE"
+	      (fi:eval-in-lisp
+	       "(cl:mapcar #'cl:package-name (cl:package-use-list \"%s\"))" (upcase fi:package)))))
 
 (defun movitz-defun-name-and-type ()
   (interactive)



From ffjeld at common-lisp.net  Sat Apr 30 23:22:14 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun,  1 May 2005 01:22:14 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <20050430232214.0867288671@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Have run-time-context-class be a proper metaclass for run-time-context.

Date: Sun May  1 01:22:14 2005
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.92 movitz/image.lisp:1.93
--- movitz/image.lisp:1.92	Sat Apr 30 23:15:35 2005
+++ movitz/image.lisp	Sun May  1 01:22:14 2005
@@ -4,12 +4,12 @@
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;; Filename:      image.lisp
-;;;; Description:   Construction of LispOS images.
+;;;; Description:   Construction of Movitz images.
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.92 2005/04/30 21:15:35 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.93 2005/04/30 23:22:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -876,7 +876,7 @@
     (movitz-read (movitz-environment-setf-function-names *movitz-global-environment*) t))
   (setf (run-time-context-class (image-run-time-context *image*))
     (muerte::movitz-find-class 'muerte::run-time-context))
-  (setf (run-time-context-slots (image-run-time-context *image*)) #(1 2 3))
+  ;;  (setf (run-time-context-slots (image-run-time-context *image*)) #(1 2 3))
   (let ((load-address (image-start-address *image*)))
     (setf (image-cons-pointer *image*) (- load-address
 					  (image-ds-segment-base *image*))



From ffjeld at common-lisp.net  Sat Apr 30 23:22:22 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun,  1 May 2005 01:22:22 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp 
Message-ID: <20050430232222.7A12D8870E@common-lisp.net>

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

Modified Files:
	los-closette.lisp 
Log Message:
Have run-time-context-class be a proper metaclass for run-time-context.

Date: Sun May  1 01:22:20 2005
Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.26 movitz/losp/muerte/los-closette.lisp:1.27
--- movitz/losp/muerte/los-closette.lisp:1.26	Tue Jan 25 14:52:25 2005
+++ movitz/losp/muerte/los-closette.lisp	Sun May  1 01:22:19 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 23 14:29:10 2002
 ;;;;                
-;;;; $Id: los-closette.lisp,v 1.26 2005/01/25 13:52:25 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.27 2005/04/30 23:22:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1006,14 +1006,14 @@
 (defclass infant-object (t) () (:metaclass built-in-class))
 (defclass unbound-value (t) () (:metaclass built-in-class))
 
-(defclass run-time-context (t)
-  ()
-  (:metaclass built-in-class)
-  (:size #.(bt:sizeof 'movitz::movitz-run-time-context))
-  (:slot-map #.(movitz::slot-map 'movitz::movitz-run-time-context
-			       (cl:+ (bt:slot-offset 'movitz::movitz-run-time-context
-						     'movitz::run-time-context-start)
-				     0))))
+;;;(defclass run-time-context (t)
+;;;  ()
+;;;  (:metaclass built-in-class)
+;;;  (:size #.(bt:sizeof 'movitz::movitz-run-time-context))
+;;;  (:slot-map #.(movitz::slot-map 'movitz::movitz-run-time-context
+;;;			       (cl:+ (bt:slot-offset 'movitz::movitz-run-time-context
+;;;						     'movitz::run-time-context-start)
+;;;				     0))))
 
 (defclass stream () ())
 
@@ -1040,13 +1040,7 @@
 (defclass funcallable-standard-object (standard-object function) ())
 (defclass generic-function (metaobject funcallable-standard-object) ())
 (defclass standard-generic-function (generic-function)
-  (#+ignore
-   (name
-    :initarg :name)			; :accessor generic-function-name
-   #+ignore
-   (lambda-list				; :accessor generic-function-lambda-list
-    :initarg :lambda-list)
-   (methods
+  ((methods
     :initform ())			; :accessor generic-function-methods)
    (method-class			; :accessor generic-function-method-class
     :initarg :method-class)
@@ -1718,11 +1712,6 @@
       (write-string ")" stream)))
   object)
 
-(defmethod print-object ((x run-time-context) stream)
-  (print-unreadable-object (x stream :type t :identity t)
-    (format stream " ~S" (%run-time-context-slot 'name x)))
-  x)
-
 (defmethod print-object ((x illegal-object) stream)
   (error "Won't print illegal-object ~Z." x)
   ;; (print-unreadable-object (x stream :type t :identity t))
@@ -1912,3 +1901,32 @@
       (values))))
 
 
+;;;;
+
+(defclass run-time-context-class (std-slotted-class built-in-class) ())
+
+(defclass run-time-context (t)
+  ((name
+    :initarg :name
+    :accessor run-time-context-name)
+   (stack-vector
+    :initarg :stack-vector))
+  (:metaclass run-time-context-class)
+  (:size #.(bt:sizeof 'movitz::movitz-run-time-context))
+  (:slot-map #.(movitz::slot-map 'movitz::movitz-run-time-context
+			       (cl:+ (bt:slot-offset 'movitz::movitz-run-time-context
+						     'movitz::run-time-context-start)
+				     0))))
+
+(defmethod slot-value-using-class ((class run-time-context-class) object
+				   (slot standard-effective-slot-definition))
+  (let ((x (svref (%run-time-context-slot 'slots object)
+		  (slot-definition-location slot))))
+    (if (eq x (load-global-constant new-unbound-value))
+	(slot-unbound class object (slot-definition-name slot))
+      x)))
+
+(defmethod print-object ((x run-time-context) stream)
+  (print-unreadable-object (x stream :type t :identity t)
+    (format stream " ~S" (%run-time-context-slot 'name x)))
+  x)



From ffjeld at common-lisp.net  Sat Apr 30 23:22:29 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun,  1 May 2005 01:22:29 +0200 (CEST)
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/los-closette-compiler.lisp 
Message-ID: <20050430232229.001F088671@common-lisp.net>

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

Modified Files:
	los-closette-compiler.lisp 
Log Message:
Have run-time-context-class be a proper metaclass for run-time-context.

Date: Sun May  1 01:22:29 2005
Author: ffjeld

Index: movitz/losp/muerte/los-closette-compiler.lisp
diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.14 movitz/losp/muerte/los-closette-compiler.lisp:1.15
--- movitz/losp/muerte/los-closette-compiler.lisp:1.14	Tue Jun  8 00:14:06 2004
+++ movitz/losp/muerte/los-closette-compiler.lisp	Sun May  1 01:22:28 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:    Thu Aug 29 13:15:11 2002
 ;;;;                
-;;;; $Id: los-closette-compiler.lisp,v 1.14 2004/06/07 22:14:06 ffjeld Exp $
+;;;; $Id: los-closette-compiler.lisp,v 1.15 2005/04/30 23:22:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -117,14 +117,14 @@
 	slot))
      (t (pushnew class-name *classes-with-old-slot-definitions*)
 	(muerte::translate-program (vector name ; 1
-						  initargs ; 3
-						  initform ; 5 
-						  initfunction ; 7
-						  allocation ; 9
-						  readers ; 11
-						  writers
-						  nil)
-					  :cl :muerte.cl))))
+					   initargs ; 3
+					   initform ; 5 
+					   initfunction ; 7
+					   allocation ; 9
+					   readers ; 11
+					   writers
+					   nil)
+				   :cl :muerte.cl))))
 
   (defun translate-direct-slot-definition (old-slot)
     (if (not (vectorp old-slot))
@@ -486,7 +486,7 @@
 		     (subclassp class *the-class-standard-class*))
 	    (break "Looking for slot ~S in class ~S, while std-class is ~S."
 		   slot-name class *the-class-standard-class*))
-	(let ((slot (find slot-name
+	  (let ((slot (find slot-name
 			    (std-slot-value class 'effective-slots)
 			    :key #'slot-definition-name)))
 	    (if (null slot)
@@ -568,9 +568,11 @@
 			      'make-instance-built-in-class)
 			     ((eq metaclass (movitz-find-class 'funcallable-standard-class nil))
 			      'movitz-make-instance)
-			     (t (warn "Unknown metaclass: ~S" metaclass)
-				'make-instance-built-in-class
-				#+ignore 'movitz-make-instance))
+			     ((eq metaclass (movitz-find-class 'run-time-context-class nil))
+			      'movitz-make-instance)
+			     (t (break "Unknown metaclass: ~S" metaclass)
+				#+ignore 'make-instance-built-in-class
+				'movitz-make-instance))
 			    metaclass
 			    :name name
 			    all-keys)))
@@ -600,18 +602,6 @@
   (defun movitz-make-instance-funcallable (metaclass &rest all-keys &key name direct-superclasses direct-slots &allow-other-keys)
     (declare (ignore all-keys))
     (let ((class (std-allocate-instance metaclass)))
-      #+ignore
-      (dolist (slot (class-slots (movitz-class-of class)))
-	(let ((slot-name (slot-definition-name slot)))
-	  (multiple-value-bind (init-key init-value foundp)
-	      (get-properties all-keys (slot-definition-initargs slot))
-	    (declare (ignore init-key))
-	    (if foundp
-		(setf (movitz-slot-value class slot-name) init-value)
-	      (when (not (null (slot-definition-initform slot)))
-		(warn "initform: ~S" (slot-definition-initform slot))
-		(setf (movitz-slot-value class slot-name)
-		  (eval (slot-definition-initform slot))))))))
       (setf (movitz-class-name class) name)
       (setf (class-direct-subclasses class) ())
       (setf (class-direct-methods class) ())
@@ -619,22 +609,38 @@
 					    :direct-slots direct-slots
 					    :direct-superclasses direct-superclasses)
       class))
+  
+  (defun movitz-make-instance-run-time-context (metaclass &rest all-keys &key name direct-superclasses direct-slots size slot-map &allow-other-keys)
+    (declare (ignore all-keys))
+    (let ((class (std-allocate-instance metaclass)))
+      (when size (setf (std-slot-value class 'size) size))
+      (setf (std-slot-value class 'slot-map) slot-map)
+      (setf (movitz-class-name class) name)
+      (setf (class-direct-subclasses class) ())
+      (setf (class-direct-methods class) ())
+      (std-after-initialization-for-classes class
+					    :direct-slots direct-slots
+					    :direct-superclasses direct-superclasses)
+      class))  
 
   (defun movitz-make-instance (class &rest all-keys)
     ;; (warn "movitz-make-instance: ~S ~S" class all-keys)
     (when (symbolp class)
       (setf class (movitz-find-class class)))
-    (if (eq class (movitz-find-class 'funcallable-standard-class nil))
-	(apply 'movitz-make-instance-funcallable class all-keys)
-      (let ((instance (std-allocate-instance class)))
-	(dolist (slot (class-slots (movitz-class-of instance)))
-	  (let ((slot-name (slot-definition-name slot)))
-	    (multiple-value-bind (init-key init-value foundp)
-		(get-properties all-keys (slot-definition-initargs slot))
-	      (declare (ignore init-key))
-	      (when foundp
-		(setf (movitz-slot-value instance slot-name) init-value)))))
-	instance)))
+    (cond
+     ((eq class (movitz-find-class 'funcallable-standard-class nil))
+      (apply 'movitz-make-instance-funcallable class all-keys) )
+     ((eq class (movitz-find-class 'run-time-context-class nil))
+      (apply 'movitz-make-instance-run-time-context class all-keys))
+     (t (let ((instance (std-allocate-instance class)))
+	  (dolist (slot (class-slots (movitz-class-of instance)))
+	    (let ((slot-name (slot-definition-name slot)))
+	      (multiple-value-bind (init-key init-value foundp)
+		  (get-properties all-keys (slot-definition-initargs slot))
+		(declare (ignore init-key))
+		(when foundp
+		  (setf (movitz-slot-value instance slot-name) init-value)))))
+	  instance))))
   
 ;;; make-instance-standard-class creates and initializes an instance of
 ;;; standard-class without falling into method lookup.  However, it cannot be