From ffjeld at common-lisp.net  Tue Nov  2 15:52:21 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 02 Nov 2004 16:52:21 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp 
Message-ID: <E1CP0xJ-0001DU-00@common-lisp.net>

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

Modified Files:
	conditions.lisp 
Log Message:
For "unseen throw tag" condition, print tag by ~S rather than ~Z.

Date: Tue Nov  2 16:52:21 2004
Author: ffjeld

Index: movitz/losp/muerte/conditions.lisp
diff -u movitz/losp/muerte/conditions.lisp:1.12 movitz/losp/muerte/conditions.lisp:1.13
--- movitz/losp/muerte/conditions.lisp:1.12	Mon Aug 23 15:58:19 2004
+++ movitz/losp/muerte/conditions.lisp	Tue Nov  2 16:52:21 2004
@@ -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.12 2004/08/23 13:58:19 ffjeld Exp $
+;;;; $Id: conditions.lisp,v 1.13 2004/11/02 15:52:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -117,7 +117,7 @@
     :initarg :tag
     :reader throw-error-tag))
   (:report (lambda (c s)
-	     (format s "Cannot throw to tag ~Z." (throw-error-tag c)))))
+	     (format s "Cannot throw to tag `~S'." (throw-error-tag c)))))
 
 (define-condition wrong-argument-count (program-error)
   ((function




From ffjeld at common-lisp.net  Tue Nov  2 15:53:31 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 02 Nov 2004 16:53:31 +0100
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1CP0yR-0001E1-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Improved support for changing image's ds-segment-base etc. There were
some bugs in offset calculations etc.

Date: Tue Nov  2 16:53:31 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.72 movitz/image.lisp:1.73
--- movitz/image.lisp:1.72	Thu Oct 21 22:40:32 2004
+++ movitz/image.lisp	Tue Nov  2 16:53:30 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.72 2004/10/21 20:40:32 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.73 2004/11/02 15:53:30 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -430,28 +430,31 @@
    (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 0
+				       :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-start-address *image*)
+    :initform (make-segment-descriptor :base (image-cs-segment-base *image*)
 				       :limit #xfff00 :type 10 :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-start-address *image*)
+    :initform (make-segment-descriptor :base (image-ds-segment-base *image*)
 				       :limit #xfff00 ; data segment
-				       :type 2 :dpl 0
+				       :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-start-address *image*)
+    :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-6
+   (segment-descriptor-stack		; 6: same as normal shifted-data, DPL=0
     :binary-type segment-descriptor
-    :initform (make-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))
@@ -520,9 +523,11 @@
 
 (defclass movitz-image ()
   ((ds-segment-base
+    :initarg :ds-segment-base
     :initform #x100000
     :accessor image-ds-segment-base)
    (cs-segment-base
+    :initarg :cs-segment-base
     :initform #x100000
     :accessor image-cs-segment-base)))
 
@@ -776,18 +781,21 @@
 	     x)
     y))
 
-(defun make-movitz-image (start-address)
-  (let ((*image* (make-instance 'symbolic-image
-		   :nil-object (make-movitz-nil)
-		   :start-address start-address
-		   :movitz-features '(:movitz)
-		   :function-code-sizes
-		   (if (boundp '*image*)
-		       (copy-hash-table (function-code-sizes *image*))
-		     (make-hash-table :test #'equal)))))
+(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)
+			:start-address start-address
+			:movitz-features '(:movitz)
+			:function-code-sizes
+			(if (boundp '*image*)
+			    (copy-hash-table (function-code-sizes *image*))
+			  (make-hash-table :test #'equal))
+			init-args)))
     (setf (image-nil-word *image*)
       (+ 5 (- (slot-offset 'movitz-run-time-context 'null-symbol)
-	      (slot-offset 'movitz-run-time-context 'run-time-context-start))))
+	      (slot-offset 'movitz-run-time-context 'run-time-context-start))
+	 (- start-address
+	    (image-ds-segment-base *image*))))
     (format t "~&;; NIL value: #x~X.~%" (image-nil-word *image*))
     (assert (eq :null (extract-tag (image-nil-word *image*))) ()
       "NIL value #x~X has tag ~D, but it must be ~D."
@@ -817,9 +825,13 @@
     (check-type code-vector movitz-basic-vector)
     code-vector))
 
-(defun create-image (&key (init-file *default-image-init-file*)
-			  (start-address #x100000))
-  (psetq *image* (let ((*image* (make-movitz-image start-address)))
+(defun create-image (&rest init-args
+		     &key (init-file *default-image-init-file*)
+			  ;; (start-address #x100000)
+			  &allow-other-keys)
+  (psetq *image* (let ((*image* (apply #'make-movitz-image
+				       :start-address #x100000
+				       init-args)))
 		   (when init-file
 		     (movitz-compile-file init-file))
 		   *image*)
@@ -1048,12 +1060,16 @@
 	summing
 	  (let ((obj (image-memref image p nil)))
 	    (cond
-	     ((not obj) 0)
+	     ((not obj) 0)		; (+ 1mb (- 1mb)) vs. (+ 0 (- 1mb 1mb))
 	     (t (let ((new-pos (+ p file-start-position
-				  (- (image-start-address image)
-				     (image-ds-segment-base image)))))
-		  (incf pad-size (- new-pos (file-position stream)))
-		  (file-position stream new-pos))
+				  (- (image-ds-segment-base image)
+				     (image-start-address image)))))
+		  (let ((pad-delta (- new-pos (file-position stream))))
+		    (with-simple-restart (continue "Never mind.")
+		      (assert (<= 0 pad-delta 31) ()
+			"pad-delta ~S for ~S, p: ~S, new-pos: ~S" pad-delta obj p new-pos))
+		    (incf pad-size pad-delta))
+		  (assert (file-position stream new-pos)))
 		;; (warn "Dump at address #x~X, filepos #x~X: ~A" p (file-position stream) obj)
 		(let ((old-pos (file-position stream))
 		      (write-size (write-binary-record obj stream)))
@@ -1590,11 +1606,12 @@
 			       (:movw ,(* 4 8) :cx)
 			       (:movw :cx :ds)
 			       (:movw :cx :es)
-			       (: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
 
 			       (:movl ,(image-nil-word *image*) :edi)
 			       (:globally (:movl (:edi (:edi-offset stack-top)) :esp))




From ffjeld at common-lisp.net  Sun Nov  7 21:07:59 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 07 Nov 2004 22:07:59 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1CQuGV-0005qX-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Fixed svref and (setf svref) to actually enforce the index range.
Also, use (movitz-type-slot-offset ..) rather than hard-coded constants
a few places.

Date: Sun Nov  7 22:07:59 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.46 movitz/losp/muerte/arrays.lisp:1.47
--- movitz/losp/muerte/arrays.lisp:1.46	Thu Oct 21 22:30:07 2004
+++ movitz/losp/muerte/arrays.lisp	Sun Nov  7 22:07:59 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.46 2004/10/21 20:30:07 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.47 2004/11/07 21:07:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -445,10 +445,12 @@
 ;;; simple-vector accessors
 
 (define-compiler-macro svref%unsafe (simple-vector index)
-  `(memref ,simple-vector 2 :index ,index))
+  `(memref ,simple-vector (movitz-type-slot-offset 'movitz-basic-vector 'data)
+	   :index ,index))
 
 (define-compiler-macro (setf svref%unsafe) (value simple-vector index)
-  `(setf (memref ,simple-vector 2 :index ,index) ,value))
+  `(setf (memref ,simple-vector (movitz-type-slot-offset 'movitz-basic-vector 'data)
+		 :index ,index) ,value))
 
 (defun svref%unsafe (simple-vector index)
 ;;  (compiler-macro-call svref%unsafe simple-vector index))
@@ -460,83 +462,90 @@
   (setf (svref%unsafe simple-vector index) value))
 
 (defun svref (simple-vector index)
-  (etypecase simple-vector
-    (simple-vector
-     (macrolet
-	 ((do-it ()
-	    `(with-inline-assembly (:returns :eax)
-	       (:compile-two-forms (:eax :ebx) simple-vector index)
-	       (:leal (:eax ,(- (movitz::tag :other))) :ecx)
-	       (:testb 7 :cl)
-	       (:jne '(:sub-program (not-basic-simple-vector)
-		       (:compile-form (:result-mode :ignore)
-			(error "Not a simple-vector: ~S." simple-vector))))
-	       (:movl (:eax ,movitz:+other-type-offset+) :ecx)
-	       (:testb ,movitz:+movitz-fixnum-zmask+ :bl)
-	       (:jnz '(:sub-program (illegal-index)
-		       (:compile-form (:result-mode :ignore)
-			(error "Illegal index: ~S." index))))
-	       (:cmpw ,(movitz:basic-vector-type-tag :any-t) :cx)
-	       (:jne 'not-basic-simple-vector)
-	       (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
-		      :eax)
-	       )))
-       (do-it)))))
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :eax)
+	    (:compile-two-forms (:eax :ebx) simple-vector index)
+	    (:leal (:eax ,(- (movitz::tag :other))) :ecx)
+	    (:testb 7 :cl)
+	    (:jne '(:sub-program (not-basic-simple-vector)
+		    (:compile-form (:result-mode :ignore)
+		     (error "Not a simple-vector: ~S." simple-vector))))
+	    (:movl (:eax ,movitz:+other-type-offset+) :ecx)
+	    (:testb ,movitz:+movitz-fixnum-zmask+ :bl)
+	    (:jnz '(:sub-program (illegal-index)
+		    (:compile-form (:result-mode :ignore)
+		     (error "Illegal index: ~S." index))))
+	    (:cmpw ,(movitz:basic-vector-type-tag :any-t) :cx)
+	    (:jne 'not-basic-simple-vector)
+	    (:cmpl :ebx (:eax (:offset movitz-basic-vector num-elements)))
+	    (:jbe 'illegal-index)
+	    (:movl (:eax :ebx (:offset movitz-basic-vector data)) :eax)
+	    )))
+    (do-it)))
     
 
 (defun (setf svref) (value simple-vector index)
-  (etypecase simple-vector
-    (simple-vector
-     (macrolet
-	 ((do-it ()
-	    `(with-inline-assembly (:returns :eax)
-	       (:compile-two-forms (:ebx :edx) simple-vector index)
-	       (:leal (:ebx ,(- (movitz::tag :other))) :ecx)
-	       (:testb 7 :cl)
-	       (:jne '(:sub-program (not-basic-simple-vector)
-		       (:compile-form (:result-mode :ignore)
-			(error "Not a simple-vector: ~S." simple-vector))))
-	       (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
-	       (:testb ,movitz:+movitz-fixnum-zmask+ :dl)
-	       (:jnz '(:sub-program (illegal-index)
-		       (:compile-form (:result-mode :ignore)
-			(error "Illegal index: ~S." index))))
-	       (:compile-form (:result-mode :eax) value)
-	       (:cmpw ,(movitz:basic-vector-type-tag :any-t) :cx)
-	       (:jne 'not-basic-simple-vector)
-	       (:movl :eax
-		      (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))))))
-       (do-it)))))
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :eax)
+	    (:compile-two-forms (:ebx :edx) simple-vector index)
+	    (:leal (:ebx ,(- (movitz::tag :other))) :ecx)
+	    (:testb 7 :cl)
+	    (:jne '(:sub-program (not-basic-simple-vector)
+		    (:compile-form (:result-mode :ignore)
+		     (error "Not a simple-vector: ~S." simple-vector))))
+	    (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
+	    (:testb ,movitz:+movitz-fixnum-zmask+ :dl)
+	    (:jnz '(:sub-program (illegal-index)
+		    (:compile-form (:result-mode :ignore)
+		     (error "Illegal index: ~S." index))))
+	    (:compile-form (:result-mode :eax) value)
+	    (:cmpw ,(movitz:basic-vector-type-tag :any-t) :cx)
+	    (:jne 'not-basic-simple-vector)
+	    (:cmpl :edx (:ebx (:offset movitz-basic-vector num-elements)))
+	    (:jbe 'illegal-index)
+	    (:movl :eax
+		   (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))))))
+    (do-it)))
 
 ;;; string accessors
 
 (defun char (string index)
   (check-type string string)
   (assert (below index (array-dimension string 0)))
-  (memref string 2 :index index :type :character))
+  (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data)
+	  :index index :type :character))
 
 (defun (setf char) (value string index)
   (assert (below index (array-dimension string 0)))
-  (setf (memref string 2 :index index :type :character) value))
+  (setf (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data)
+		:index index :type :character) value))
 
 (defun schar (string index)
   (check-type string string)
   (assert (below index (length string)))
-  (memref string 2 :index index :type :character))
+  (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data)
+	  :index index
+	  :type :character))
 
 (defun (setf schar) (value string index)
   (check-type string string)
   (assert (below index (length string)))
-  (setf (aref string index) value))
+  (setf (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data)
+		:index index :type :character)
+    value))
 
 (define-compiler-macro char%unsafe (string index)
-  `(memref ,string 2 :index ,index :type :character))
+  `(memref ,string (movitz-type-slot-offset 'movitz-basic-vector 'data)
+	   :index ,index :type :character))
 
 (defun char%unsafe (string index)
   (char%unsafe string index))
 
 (define-compiler-macro (setf char%unsafe) (value string index)
-  `(setf (memref ,string 2 :index ,index :type :character) ,value))
+  `(setf (memref ,string (movitz-type-slot-offset 'movitz-basic-vector 'data)
+		 :index ,index :type :character) ,value))
 
 (defun (setf char%unsafe) (value string index)
   (setf (char%unsafe string index) value))
@@ -544,13 +553,15 @@
 ;;; u8 accessors
 
 (define-compiler-macro u8ref%unsafe (vector index)
-  `(memref ,vector 2 :index ,index :type :unsigned-byte8))
+  `(memref ,vector (movitz-type-slot-offset 'movitz-basic-vector 'data)
+	   :index ,index :type :unsigned-byte8))
 
 (defun u8ref%unsafe (vector index)
   (u8ref%unsafe vector index))
 
 (define-compiler-macro (setf u8ref%unsafe) (value vector index)
-  `(setf (memref ,vector 2 :index ,index :type :unsigned-byte8) ,value))
+  `(setf (memref ,vector (movitz-type-slot-offset 'movitz-basic-vector 'data)
+		 :index ,index :type :unsigned-byte8) ,value))
 
 (defun (setf u8ref%unsafe) (value vector index)
   (setf (u8ref%unsafe vector index) value))
@@ -558,7 +569,8 @@
 ;;; u32 accessors
 
 (define-compiler-macro u32ref%unsafe (vector index)
-  `(memref ,vector 2 :index ,index :type :unsigned-byte32))
+  `(memref ,vector (movitz-type-slot-offset 'movitz-basic-vector 'data)
+	   :index ,index :type :unsigned-byte32))
 
 (defun u32ref%unsafe (vector index)
   (compiler-macro-call u32ref%unsafe vector index))




From ffjeld at common-lisp.net  Sun Nov  7 21:10:07 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 07 Nov 2004 22:10:07 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/format.lisp 
Message-ID: <E1CQuIZ-0005sM-00@common-lisp.net>

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

Modified Files:
	format.lisp 
Log Message:
Prefer reverse over nreverse in this particular case.

Date: Sun Nov  7 22:10:05 2004
Author: ffjeld

Index: movitz/losp/muerte/format.lisp
diff -u movitz/losp/muerte/format.lisp:1.8 movitz/losp/muerte/format.lisp:1.9
--- movitz/losp/muerte/format.lisp:1.8	Tue Oct 12 16:42:41 2004
+++ movitz/losp/muerte/format.lisp	Sun Nov  7 22:10:03 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Mar 23 01:18:36 2002
 ;;;;                
-;;;; $Id: format.lisp,v 1.8 2004/10/12 14:42:41 ffjeld Exp $
+;;;; $Id: format.lisp,v 1.9 2004/11/07 21:10:03 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -160,13 +160,13 @@
 		     (write (pop args) :level nil :length nil))
 		    (t (write (pop args)))))
 	      (#\B (format-integer (pop args) 2 at-sign-p colon-p
-				   (nreverse prefix-parameters)))
+				   (reverse prefix-parameters)))
 	      (#\O (format-integer (pop args) 8 at-sign-p colon-p
-				   (nreverse prefix-parameters)))
+				   (reverse prefix-parameters)))
 	      (#\D (format-integer (pop args) 10 at-sign-p colon-p
-				   (nreverse prefix-parameters)))
+				   (reverse prefix-parameters)))
 	      (#\X (format-integer (pop args) 16 at-sign-p colon-p
-				   (nreverse prefix-parameters)))
+				   (reverse prefix-parameters)))
 	      (#\F (apply 'format-float (pop args) at-sign-p colon-p (nreverse prefix-parameters)))
 	      (#\C (if colon-p
 		       (let ((c (pop args)))




From ffjeld at common-lisp.net  Wed Nov 10 15:30:55 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 10 Nov 2004 16:30:55 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1CRuQx-0005v3-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Remove explicit alignment test.

Date: Wed Nov 10 16:30:53 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.36 movitz/losp/muerte/memref.lisp:1.37
--- movitz/losp/muerte/memref.lisp:1.36	Thu Oct 21 22:47:26 2004
+++ movitz/losp/muerte/memref.lisp	Wed Nov 10 16:30:53 2004
@@ -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.36 2004/10/21 20:47:26 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.37 2004/11/10 15:30:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -793,9 +793,9 @@
 		(:shll 2 :ecx)
 		(:addl :ebx :eax)
 		(:into)
-		(:testb ,(mask-field (byte (+ 2 movitz::+movitz-fixnum-shift+) 0) -1)
-			:al)
-		(:jnz '(:sub-program () (:int 63)))
+;;;		(:testb ,(mask-field (byte (+ 2 movitz::+movitz-fixnum-shift+) 0) -1)
+;;;			:al)
+;;;		(:jnz '(:sub-program () (:int 63)))
 		(:addl :eax :ecx)
 		(:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address
 		(,prefixes :movl (:ecx) :ecx)))))




From ffjeld at common-lisp.net  Wed Nov 10 15:31:42 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 10 Nov 2004 16:31:42 +0100
Subject: [movitz-cvs] CVS update: movitz/compiler-types.lisp 
Message-ID: <E1CRuRi-0005wv-00@common-lisp.net>

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

Modified Files:
	compiler-types.lisp 
Log Message:
*** empty log message ***
Date: Wed Nov 10 16:31:41 2004
Author: ffjeld

Index: movitz/compiler-types.lisp
diff -u movitz/compiler-types.lisp:1.20 movitz/compiler-types.lisp:1.21
--- movitz/compiler-types.lisp:1.20	Wed Sep 15 12:19:06 2004
+++ movitz/compiler-types.lisp	Wed Nov 10 16:31:41 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Sep 10 00:40:07 2003
 ;;;;                
-;;;; $Id: compiler-types.lisp,v 1.20 2004/09/15 10:19:06 ffjeld Exp $
+;;;; $Id: compiler-types.lisp,v 1.21 2004/11/10 15:31:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -667,7 +667,7 @@
 	      (cdar intscope)))
     (list (movitz-read (caar intscope))))
    ((and (null members) (null intscope))
-    (warn "Not singleton, nulloton."))))
+    (break "Not singleton, nulloton."))))
 
 (defun movitz-subtypep (type0 type1)
   "Compile-time subtypep."
@@ -678,11 +678,11 @@
 (defun encoded-integer-types-add (code0 integer-range0 members0 include0 complement0
 				  code1 integer-range1 members1 include1 complement1)
   "Return the integer type that can result from adding a member of type0 to a member of type1."
-  (declare (ignore members0 members1))
+  ;; (declare (ignore members0 members1))
   (cond
-   ((or include0 include1)
+   ((or include0 include1 members0 members1)
     ;; We can't know..
-    'integer)
+    'number)
    ((or complement0 complement1)
     (break "adding complement types..?"))
    (t (let ((integer-range (numscope-plus (encoded-numscope code0 integer-range0)




From ffjeld at common-lisp.net  Wed Nov 10 15:32:03 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 10 Nov 2004 16:32:03 +0100
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CRuS3-0005xR-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
*** empty log message ***
Date: Wed Nov 10 16:31:58 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.102 movitz/compiler.lisp:1.103
--- movitz/compiler.lisp:1.102	Thu Oct 21 22:38:28 2004
+++ movitz/compiler.lisp	Wed Nov 10 16:31:58 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.102 2004/10/21 20:38:28 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.103 2004/11/10 15:31:58 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -47,7 +47,7 @@
 (defparameter *compiler-physical-segment-prefix* '(:gs-override)
   "Use this instruction prefix when accessing a physical memory location (i.e. typically some memory-mapped hardware device).")
 
-(defparameter *compiler-nonlocal-lispval-read-segment-prefix* '(:fs-override)
+(defparameter *compiler-nonlocal-lispval-read-segment-prefix* '()
   "Use this segment prefix when reading a lispval at (potentially)
 non-local locations.")
 
@@ -55,6 +55,11 @@
   "Use this segment prefix when writing a lispval at (potentially)
 non-local locations.")
 
+(defparameter *compiler-use-cons-reader-segment-protocol-p* nil)
+
+(defparameter *compiler-cons-read-segment-prefix* '(:gs-override)
+  "Use this segment prefix for CAR and CDR, when using cons-reader protocol.")
+
 (defvar *compiler-allow-untagged-word-bits* 0
   "Allow (temporary) untagged values of this bit-size to exist, because
 the system ensures one way or another that there can be no pointers below
@@ -6187,20 +6192,35 @@
 	(cond
 	 ((and binding-is-list-p
 	       (member location '(:eax :ebx :ecx :edx)))
-	  `((:movl (,location ,op-offset) ,dst)))
+	  `(,*compiler-nonlocal-lispval-read-segment-prefix*
+	    (:movl (,location ,op-offset) ,dst)))
 	 (binding-is-list-p
 	  `(,@(make-load-lexical binding dst funobj nil frame-map)
-	      (:movl (,dst ,op-offset) ,dst)))
-	 ((eq location :ebx)
-	  `((,*compiler-global-segment-prefix*
-	     :call (:edi ,(global-constant-offset fast-op-ebx)))
-	    ,@(when (not (eq dst :eax))
-		`((:movl :eax ,dst)))))
-	 (t `(,@(make-load-lexical binding :eax funobj nil frame-map)
-		(,*compiler-global-segment-prefix* 
-		 :call (:edi ,(global-constant-offset fast-op)))
-		,@(when (not (eq dst :eax))
-		    `((:movl :eax ,dst))))))))))
+	      (,*compiler-nonlocal-lispval-read-segment-prefix*
+	       :movl (,dst ,op-offset) ,dst)))
+	 ((not *compiler-use-cons-reader-segment-protocol-p*)
+	  (cond
+	   ((eq location :ebx)
+	    `((,*compiler-global-segment-prefix*
+	       :call (:edi ,(global-constant-offset fast-op-ebx)))
+	      ,@(when (not (eq dst :eax))
+		  `((:movl :eax ,dst)))))
+	   (t `(,@(make-load-lexical binding :eax funobj nil frame-map)
+		  (,*compiler-global-segment-prefix* 
+		   :call (:edi ,(global-constant-offset fast-op)))
+		  ,@(when (not (eq dst :eax))
+		      `((:movl :eax ,dst)))))))
+	 (t (cond
+	     ((member location '(:ebx :ecx :edx))
+	      `((,(or *compiler-cons-read-segment-prefix*
+		      *compiler-nonlocal-lispval-read-segment-prefix*)
+		 :movl (:eax ,op-offset) ,dst)))
+	     (t (append (make-load-lexical binding :eax funobj nil frame-map)
+			`((,(or *compiler-cons-read-segment-prefix*
+				*compiler-nonlocal-lispval-read-segment-prefix*)
+			   :movl (:eax ,op-offset) ,dst)))))))))))
+
+	     
 
 
 ;;;;;;;;;;;;;;;;;; endp




From ffjeld at common-lisp.net  Wed Nov 10 15:35:33 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 10 Nov 2004 16:35:33 +0100
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1CRuVR-0005y7-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
*** empty log message ***
Date: Wed Nov 10 16:35:32 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.43 movitz/storage-types.lisp:1.44
--- movitz/storage-types.lisp:1.43	Thu Oct 21 22:42:51 2004
+++ movitz/storage-types.lisp	Wed Nov 10 16:35:32 2004
@@ -9,14 +9,12 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: storage-types.lisp,v 1.43 2004/10/21 20:42:51 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.44 2004/11/10 15:35:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
 (in-package movitz)
 
-;; (defconstant +tag-other+ 6)
-
 (define-unsigned lu64 8 :little-endian)
 
 (define-bitfield segment-descriptor (lu64)
@@ -171,14 +169,15 @@
 ;;; Fixnums
 
 (eval-when (:compile-toplevel :execute :load-toplevel)
-  (defconstant +movitz-fixnum-bits+ 30)
-  (defconstant +movitz-fixnum-shift+ (- 32 +movitz-fixnum-bits+))
-  (defconstant +movitz-fixnum-factor+ (expt 2 +movitz-fixnum-shift+))
-  (defconstant +movitz-fixnum-zmask+ (1- +movitz-fixnum-factor+))
-  (defconstant +movitz-most-positive-fixnum+ (1- (expt 2 (1- +movitz-fixnum-bits+))))
-  (defconstant +movitz-most-negative-fixnum+ (- (expt 2 (1- +movitz-fixnum-bits+))))
+  (defparameter +movitz-fixnum-bits+ 30)
+  (defparameter +movitz-fixnum-shift+ (- 32 +movitz-fixnum-bits+))
+  (defparameter +movitz-fixnum-factor+ (expt 2 +movitz-fixnum-shift+))
+  (defparameter +movitz-fixnum-zmask+ (1- +movitz-fixnum-factor+))
+  (defparameter +movitz-most-positive-fixnum+ (1- (expt 2 (1- +movitz-fixnum-bits+))))
+  (defparameter +movitz-most-negative-fixnum+ (- (expt 2 (1- +movitz-fixnum-bits+))))
 
-  (defparameter +other-type-offset+ -6))
+  (defparameter +object-pointer-shift+ 0)
+  (defparameter +other-type-offset+ (- -6 +object-pointer-shift+)))
 
 (defun fixnum-integer (word)
   "For a Movitz word, that must be a fixnum, return the corresponding
@@ -266,7 +265,7 @@
 	:map-binary-read-delayed 'movitz-word
 	:initarg :cdr
 	:accessor movitz-cdr))
-  (:slot-align car -1))
+  (:slot-align car #.(- -1 +object-pointer-shift+)))
 
 (defmethod movitz-object-offset ((obj movitz-cons)) 1)
 




From ffjeld at common-lisp.net  Wed Nov 10 15:36:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 10 Nov 2004 16:36:16 +0100
Subject: [movitz-cvs] CVS update: ia-x86/read.lisp 
Message-ID: <E1CRuW8-0005yn-00@common-lisp.net>

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

Modified Files:
	read.lisp 
Log Message:
*** empty log message ***
Date: Wed Nov 10 16:36:15 2004
Author: ffjeld

Index: ia-x86/read.lisp
diff -u ia-x86/read.lisp:1.7 ia-x86/read.lisp:1.8
--- ia-x86/read.lisp:1.7	Thu Sep  2 11:02:58 2004
+++ ia-x86/read.lisp	Wed Nov 10 16:36:15 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Jul 31 13:54:27 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: read.lisp,v 1.7 2004/09/02 09:02:58 ffjeld Exp $
+;;;; $Id: read.lisp,v 1.8 2004/11/10 15:36:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -304,7 +304,7 @@
 		     (list* i (read-proglist-internal sub-programs
 						      :do-append-programs do-append-programs)))
 		 ;; nothing to insert other than i itself..
-		 (list i)))
+		 (when i (list i))))
       finally (assert (= (length *programs-to-append*)
 			 *already-appended*) ()
 		"Dangling sub-programs to append: ~S"




From ffjeld at common-lisp.net  Wed Nov 10 17:34:41 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 10 Nov 2004 18:34:41 +0100
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1CRwMj-0007bv-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Added support for pliant protocol for dynamic binding.

Date: Wed Nov 10 18:34:40 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.73 movitz/image.lisp:1.74
--- movitz/image.lisp:1.73	Tue Nov  2 16:53:30 2004
+++ movitz/image.lisp	Wed Nov 10 18:34:40 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.73 2004/11/02 15:53:30 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.74 2004/11/10 17:34:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -191,6 +191,16 @@
     :binary-tag :primitive-function
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-type code-vector-word)
+   (dynamic-variable-install
+    :map-binary-write 'movitz-intern-code-vector
+    :binary-tag :primitive-function
+    :map-binary-read-delayed 'movitz-word-code-vector
+    :binary-type code-vector-word)
+   (dynamic-variable-uninstall
+    :map-binary-write 'movitz-intern-code-vector
+    :binary-tag :primitive-function
+    :map-binary-read-delayed 'movitz-word-code-vector
+    :binary-type code-vector-word)
    (assert-1arg
     :map-binary-write 'movitz-intern-code-vector
     :binary-tag :primitive-function
@@ -435,7 +445,7 @@
    (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 10 :dpl 0
+				       :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




From ffjeld at common-lisp.net  Wed Nov 10 17:34:48 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 10 Nov 2004 18:34:48 +0100
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1CRwMq-0007cD-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
Added support for pliant protocol for dynamic binding.

Date: Wed Nov 10 18:34:47 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.28 movitz/special-operators-cl.lisp:1.29
--- movitz/special-operators-cl.lisp:1.28	Thu Oct 21 22:44:52 2004
+++ movitz/special-operators-cl.lisp	Wed Nov 10 18:34:47 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.28 2004/10/21 20:44:52 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.29 2004/11/10 17:34:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -288,15 +288,14 @@
 				   `((:locally (:movl :esp (:edi (:edi-offset dynamic-env))))))
 				 (if (not recompile-body-p)
 				     body-code
-				   (progn #+ignore (warn "recompile..")
+				   (progn #+ignore (warn "recompile..") ; XXX
 					  (compile-body)))
 				 (when (plusp (num-specials local-env))
 				   `((:movl (:esp ,(+ -4 (* 16 (num-specials local-env)))) :edx)
+				     (:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context
+									     'dynamic-variable-uninstall))))
 				     (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
-				     (:leal (:esp ,(* 16 (num-specials local-env))) :esp))
-				   #+ignore
-				   `((:leal (:esp ,(+ -4 (* 16 (num-specials local-env)))) :esp)
-				     (:locally (:popl (:edi (:edi-offset dynamic-env)))))))))
+				     (:leal (:esp ,(* 16 (num-specials local-env))) :esp))))))
 		      (compiler-values (body-values)
 			:returns body-returns
 			:producer (default-compiler-values-producer)
@@ -1077,7 +1076,7 @@
 							      values-form :eax
 							      funobj env)
 		      (with-labels (progv (no-more-symbols no-more-values loop zero-specials))
-			`((:xorl :ecx :ecx) ; count number of bindings
+			`((:xorl :ecx :ecx) ; count number of bindings (fixnum)
 			  (:locally (:pushl (:edi (:edi-offset dynamic-env)))) ; first tail
 			  (:cmpl :edi :ebx)
 			  (:je '(:sub-program (,zero-specials)
@@ -1086,7 +1085,7 @@
 				 (:globally (:pushl (:edi (:edi-offset unbound-value)))) ;  [[ binding tag ]]
 				 (:pushl :edi) ; binding name
 				 (:pushl :esp)
-				 (:incl :ecx)
+				 (:addl 4 :ecx)
 				 (:jmp ',no-more-symbols)))
 			  ,loop
 			  (:cmpl :edi :ebx) ; (endp symbols)
@@ -1101,21 +1100,30 @@
 			  (:globally (:pushl (:edi (:edi-offset unbound-value)))) ;  [[ binding tag ]]
 			  (:pushl (:ebx -1)) ; push (car symbols) [[ binding name ]]
 			  (:movl (:ebx 3) :ebx) ; (pop symbols)
-			  (:incw :cx)
-			  (:jc '(:sub-program (too-many-symbols) (:int 71)))
+			  (:addl 4 :ecx)
+			  ;; (:jc '(:sub-program (too-many-symbols) (:int 71)))
 			  (:pushl :esp)	; push next tail
 			  (:jmp ',loop)
 			  ,no-more-symbols
 			  (:popl :eax)	; remove extra pre-pushed tail
 			  (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))) ; install env
-			  ;; ecx = N
-			  (:shll 4 :ecx) ; ecx = 16*N
-			  (:leal (:esp :ecx -4) :eax) ; eax = esp + 16*N - 4
-			  (:pushl :eax))) ; push address of first binding's tail
+			  ;; ecx = N/fixnum
+			  ;; (:shll 4 :ecx) ; ecx = 16*N
+			  ;; (:leal (:esp :ecx -4) :eax) ; eax = esp + 16*N - 4
+			  (:pushl :ecx)	; Save number of bindings.
+			  #+ignore (:pushl :eax))) ; push address of first binding's tail
 		      body-code
 		      (when (eq body-returns :push)
 			`((:popl :eax))) ; glue :push => :eax
-		      `((:popl :esp)	; pop address of first binding's tail
+		      `((:movl (:esp) :edx) ; number of bindings
+			(:movl (:esp (:edx 4)) :edx) ; previous dynamic-env
+			(:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context
+								'dynamic-variable-uninstall))))
+			(:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
+			(:popl :edx)	; number of bindings
+			(:leal (:esp (:edx 4)) :esp))
+		      #+ignore
+		      `((:popl :edx)	; pop address of first binding's tail
 			(:locally (:popl (:edi (:edi-offset dynamic-env))))))))))
 
 (define-special-operator labels (&all forward &form form &env env &funobj funobj)




From ffjeld at common-lisp.net  Wed Nov 10 17:34:55 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 10 Nov 2004 18:34:55 +0100
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1CRwMx-0007cZ-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Added support for pliant protocol for dynamic binding.

Date: Wed Nov 10 18:34:51 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.47 movitz/losp/muerte/primitive-functions.lisp:1.48
--- movitz/losp/muerte/primitive-functions.lisp:1.47	Thu Oct 21 22:34:09 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Wed Nov 10 18:34:51 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.47 2004/10/21 20:34:09 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.48 2004/11/10 17:34:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -111,16 +111,22 @@
 ;;;  -32: car ...
 
 (define-primitive-function dynamic-unwind-next (dynamic-env)
-  "Locate the next unwind-protect entry between here and dynamic-env.
+  "Locate the next unwind-protect entry between here and dynamic-env/EAX.
 If no such entry is found, return (same) dynamic-env in EAX and CF=0.
-Otherwise return the unwind-protect entry in EAX and CF=1. Preserve EDX."
+Otherwise return the unwind-protect entry in EAX and CF=1. Preserve EDX.
+Point is: Return the 'next step' in unwinding towards dynamic-env.
+Note that it's an error if dynamic-env isn't in the current dynamic environment,
+it's supposed to have been found by e.g. dynamic-locate-catch-tag."
+  ;; XXX: Not really sure if there's any point in the CF return value,
+  ;;      because I don't think there's ever any need to know whether
+  ;;      the returned entry is an unwind-protect or the actual target.
   (with-inline-assembly (:returns :nothing)
     (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax))
     (:globally (:movl (:edi (:edi-offset unwind-protect-tag)) :ebx))
     (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx))
     
    search-loop
-    (:jecxz '(:sub-program () (:halt) (:int 63))) ; XXX don't halt
+    (:jecxz '(:sub-program () (:int 63)))
     (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx))
 
     (:cmpl :ecx :eax)
@@ -129,6 +135,9 @@
     (:cmpl :ebx (:ecx 4))		; unwind-protect entry?
     (:je 'found-unwind-protect)
     
+    ;; We don't need to check for and uninstall dynamic binding entries,
+    ;; because uninstall is a NOP under naive deep binding.
+    
     (:movl (:ecx 12) :ecx)		; proceed search
     (:jmp 'search-loop)
    found-unwind-protect
@@ -136,7 +145,20 @@
     (:stc)
    found-dynamic-env
     (:ret)))
-  
+
+(define-primitive-function dynamic-variable-install ()
+  ""
+  (with-inline-assembly (:returns :nothing)
+    (:ret)))
+
+(define-primitive-function dynamic-variable-uninstall (dynamic-env)
+  "Uninstall each dynamic binding between 'here' (i.e. the current 
+dynamic environment pointer) and the dynamic-env pointer provided in EDX.
+This must be done without affecting 'current values'! (i.e. eax, ebx, ecx, or CF),
+and also EDX must not be affected."
+  (with-inline-assembly (:returns :nothing)
+    ;; Default binding strategy is naive deep binding, so this is a NOP.
+    (:ret)))
 
 (define-primitive-function dynamic-locate-catch-tag (tag)
   "Search the dynamic environment for a catch slot matching <tag> in EAX.




From ffjeld at common-lisp.net  Wed Nov 10 17:37:22 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 10 Nov 2004 18:37:22 +0100
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CRwPK-0007dU-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
*** empty log message ***
Date: Wed Nov 10 18:37:21 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.103 movitz/compiler.lisp:1.104
--- movitz/compiler.lisp:1.103	Wed Nov 10 16:31:58 2004
+++ movitz/compiler.lisp	Wed Nov 10 18:37:20 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.103 2004/11/10 15:31:58 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.104 2004/11/10 17:37:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -5742,7 +5742,9 @@
       (stack-delta from-env to-env)
     (assert stack-distance)
     (assert (null unwind-protects) ()
-      "Lexical unwind-protect not implemented.")
+      "Lexical unwind-protect not implemented, to-env: ~S." to-env)
+    (when (plusp num-dynamic-slots)
+      (warn "Lexical jump across ~D specials." num-dynamic-slots))
     (cond
      ((and (eq t stack-distance)
 	   (zerop num-dynamic-slots))




From ffjeld at common-lisp.net  Thu Nov 11 10:08:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Nov 2004 11:08:46 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp 
Message-ID: <E1CSBsk-00045V-00@common-lisp.net>

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

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

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




From ffjeld at common-lisp.net  Thu Nov 11 10:48:23 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Nov 2004 11:48:23 +0100
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1CSCV5-0004k2-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
More about dynamic binding protocol: also call
dynamic-variable-install at binding time.

Date: Thu Nov 11 11:48:22 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.29 movitz/special-operators-cl.lisp:1.30
--- movitz/special-operators-cl.lisp:1.29	Wed Nov 10 18:34:47 2004
+++ movitz/special-operators-cl.lisp	Thu Nov 11 11:48:22 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.29 2004/11/10 17:34:47 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.30 2004/11/11 10:48:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -285,7 +285,9 @@
 							  :init-with-type ,(type-specifier-primary type))))))))
 					(t init-code)))
 				 (when (plusp (num-specials local-env))
-				   `((:locally (:movl :esp (:edi (:edi-offset dynamic-env))))))
+				   `((:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context
+									     'dynamic-variable-install))))
+				     (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))))
 				 (if (not recompile-body-p)
 				     body-code
 				   (progn #+ignore (warn "recompile..") ; XXX
@@ -1106,11 +1108,14 @@
 			  (:jmp ',loop)
 			  ,no-more-symbols
 			  (:popl :eax)	; remove extra pre-pushed tail
+			  (:movl :ecx :edx)
+			  (:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context
+								  'dynamic-variable-install))))
 			  (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))) ; install env
 			  ;; ecx = N/fixnum
 			  ;; (:shll 4 :ecx) ; ecx = 16*N
 			  ;; (:leal (:esp :ecx -4) :eax) ; eax = esp + 16*N - 4
-			  (:pushl :ecx)	; Save number of bindings.
+			  (:pushl :edx)	; Save number of bindings.
 			  #+ignore (:pushl :eax))) ; push address of first binding's tail
 		      body-code
 		      (when (eq body-returns :push)




From ffjeld at common-lisp.net  Thu Nov 11 10:48:28 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Nov 2004 11:48:28 +0100
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1CSCVA-0004kO-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
More about dynamic binding protocol: also call
dynamic-variable-install at binding time.

Date: Thu Nov 11 11:48:27 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.48 movitz/losp/muerte/primitive-functions.lisp:1.49
--- movitz/losp/muerte/primitive-functions.lisp:1.48	Wed Nov 10 18:34:51 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Thu Nov 11 11:48:27 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.48 2004/11/10 17:34:51 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.49 2004/11/11 10:48:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -147,7 +147,8 @@
     (:ret)))
 
 (define-primitive-function dynamic-variable-install ()
-  ""
+  "Install each dynamic binding entry between that in ESP and current dynamic-env.
+Preserve EDX."
   (with-inline-assembly (:returns :nothing)
     (:ret)))
 
@@ -169,10 +170,6 @@
 When the tag is not found, no cleanup-forms are executed, and carry is cleared upon return,
 with EAX still holding the tag."
   (with-inline-assembly (:returns :multiple-values)
-;;;    (:pushl :ebp)
-;;;    (:movl :esp :ebp)			; set up a pseudo stack-frame
-;;;    (:pushl :edi)
-    
     (:globally (:movl (:edi (:edi-offset unwind-protect-tag)) :edx))
     (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx))
 
@@ -188,52 +185,18 @@
     (:jz 'success)
 
    mismatch
-;;;    (:cmpl :edx (:ecx 4))		; is env-slot in ECX == unwind-protect?
-;;;    (:jne 'not-unwind-protect)
-;;;    (:pushl :ecx)			; ..then save env-slot (in pseudo stack-frame)
 
    not-unwind-protect
     (:movl (:ecx 12) :ecx)		; get parent
     (:jmp 'search-loop)
     
    success
-
-;;;    (:pushl 0)				; mark, meaning next slot is ``the'' target slot.
-;;;    (:pushl :ecx)			; save the found env-slot
-;;;
-;;;    ;; Now execute any unwind-protect cleanup-forms we encountered.
-;;;    ;; We are still inside the pseudo stack-frame.
-;;;    (:leal (:ebp -8) :edx)		; EDX points to the current dynamic-slot-slot
-;;;
-;;;   unwind-loop
-;;;    (:movl (:edx) :eax)			; next dynamic-slot to unwind
-;;;    (:testl :eax :eax)			; is this the last entry?
-;;;    (:jz 'unwind-done)
-;;;    (:pushl :ebp)			; save EBP
-;;;    (:pushl :edx)			; and EDX
-;;;    (:movl (:eax 12) :ebx)		; unwind dynamic-env..
-;;;    (:locally (:movl :ebx (:edi (:edi-offset dynamic-env))))
-;;;    (:movl (:eax 0) :ebp)		; install clean-up's stack-frame (but keep our ESP)
-;;;    (:movl (:ebp -4) :esi)		; ..and install clean-up's funobj in ESI
-;;;    (:movl (:eax 8) :edx)
-;;;    (:call (:esi :edx (:offset movitz-funobj constant0)))
-;;;    (:popl :edx)			; restoure our EDX
-;;;    (:popl :ebp)			; restore our EBP
-;;;    (:subl 4 :edx)			; ..slide EDX to next position inside stack-frame.
-;;;    (:jmp 'unwind-loop)
-;;;
-;;;   unwind-done
-;;;    (:movl (:edx -4) :eax)		; the final dyamic-slot target.
-;;;    (:leave)				; exit pseudo stack-frame
-;;;    (:movl (:ebp -4) :esi)
     (:movl :ecx :eax)
     (:stc)				; signal success
     (:ret)				; return
     
    search-failed
     (:clc)				; signal failure
-;;;    (:leave)				; exit pseudo stack-frame
-;;;    (:movl (:ebp -4) :esi)
     (:ret)))				; return.
     
 (define-primitive-function dynamic-unwind ()




From ffjeld at common-lisp.net  Thu Nov 11 11:09:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Nov 2004 12:09:38 +0100
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1CSCpe-00051l-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Replaced primitive-function dynamic-find-binding with
dynamic-load-unprotected, which has somewhat clearer semantics.

Date: Thu Nov 11 12:09:37 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.49 movitz/losp/muerte/primitive-functions.lisp:1.50
--- movitz/losp/muerte/primitive-functions.lisp:1.49	Thu Nov 11 11:48:27 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Thu Nov 11 12:09:37 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.49 2004/11/11 10:48:27 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.50 2004/11/11 11:09:37 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -213,37 +213,41 @@
     (:jnz 'loop)
    done
     (:ret)))
-
-(define-primitive-function dynamic-find-binding (symbol)
-  "Search the stack for a dynamic binding of SYMBOL.
-   On success, return Carry=1, and the address of the
-   binding in EAX. On failure, return Carry=0 and EAX unmodified.
-   Preserves EBX."
-  (with-inline-assembly (:returns :eax)
+    
+(define-primitive-function dynamic-load (symbol)
+  "Load the dynamic value of SYMBOL into EAX."
+  (with-inline-assembly (:returns :multiple-values)
     (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx))
-    (:jecxz 'fail)
+    (:jecxz 'no-stack-binding)
+    ;; Be defensive: Verify that ECX is within stack.
+    (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx))
     (:cmpl :eax (:ecx))
     (:je 'success)
-    (:locally (:movl (:edi (:edi-offset stack-top)) :edx))
    search-loop
-    (:cmpl :edx (:ecx 12))
-    (:jnc '(:sub-program () (:int 97)))
     (:movl (:ecx 12) :ecx)		; parent
-    (:jecxz 'fail)
+    (:jecxz 'no-stack-binding)
+    ;; Be defensive: Verify that ECX is within stack.
+    (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx))
     (:cmpl :eax (:ecx))			; compare name
     (:jne 'search-loop)
     ;; fall through on success
    success
-    (:leal (:ecx 8) :eax)		; location of binding value cell
-    (:stc)
+    (:movl :eax :edx)			; Keep symbol in case it's unbound.
+    (:movl (:ecx 8) :eax)
+    (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax))
+    (:je '(:sub-program (unbound) (:int 99)))
     (:ret)
-    
-   fail
-    (:clc)
+   no-stack-binding
+    ;; take the global value of SYMBOL, compare it against unbond-value
+    (:movl :eax :edx)			; Keep symbol in case it's unbound.
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:eax (:offset movitz-symbol value)) :eax)
+    (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax))
+    (:je '(:sub-program (unbound) (:int 99)))
     (:ret)))
-    
-(define-primitive-function dynamic-load (symbol)
-  "Load the dynamic value of SYMBOL into EAX."
+
+(define-primitive-function dynamic-load-unprotected (symbol)
+  "Load the dynamic value of SYMBOL into EAX. If unbound, return unbound-value."
   (with-inline-assembly (:returns :multiple-values)
     (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx))
     (:jecxz 'no-stack-binding)
@@ -260,17 +264,12 @@
     (:jne 'search-loop)
     ;; fall through on success
    success
-    (:movl :eax :edx)			; Keep symbol in case it's unbound.
     (:movl (:ecx 8) :eax)
-    (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax))
-    (:je '(:sub-program (unbound) (:int 99)))
     (:ret)
    no-stack-binding
     ;; take the global value of SYMBOL, compare it against unbond-value
-    (:movl :eax :edx)			; Keep symbol in case it's unbound.
-    (:movl (:eax #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::value)) :eax)
-    (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax))
-    (:je '(:sub-program (unbound) (:int 99)))
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:eax (:offset movitz-symbol value)) :eax)
     (:ret)))
 
 (define-primitive-function dynamic-store (symbol value)




From ffjeld at common-lisp.net  Thu Nov 11 19:24:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Nov 2004 20:24:53 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1CSKYv-0003HZ-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Rewrite boundp in terms of dynamic-load-unprotected.

Date: Thu Nov 11 20:24:52 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.43 movitz/losp/muerte/basic-macros.lisp:1.44
--- movitz/losp/muerte/basic-macros.lisp:1.43	Thu Oct 21 22:33:57 2004
+++ movitz/losp/muerte/basic-macros.lisp	Thu Nov 11 20:24:52 2004
@@ -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.43 2004/10/21 20:33:57 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.44 2004/11/11 19:24:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1069,18 +1069,13 @@
 
 (define-compiler-macro boundp (symbol)
   `(with-inline-assembly-case ()
-     (do-case (t :boolean-cf=1 :labels (boundp-done))
+     (do-case (t :boolean-zf=0 :labels (boundp-done))
        (:compile-form (:result-mode :eax) ,symbol)
-       (:cmpl :edi :eax)
-       (:cmc)
-       (:je 'boundp-done)		; if ZF=1, then CF=1 after CMC
-       (:call-local-pf dynamic-find-binding)
-       (:jc 'boundp-done)
-       (:movl (:eax #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::value)) :eax)
-       (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax))
-       (:je 'boundp-done)
-       (:stc)
-      boundp-done)))
+       (:leal (:eax ,(- (movitz:tag :symbol))) :ecx)
+       (:testb 7 :cl)
+       (:jne '(:sub-program () (:int 66)))
+       (:call-local-pf dynamic-load-unprotected)
+       (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax)))))
 
 (defmacro define-global-variable (name init-form &optional docstring)
   "A global variable will be accessed by ignoring local bindings."




From ffjeld at common-lisp.net  Thu Nov 11 19:25:26 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Nov 2004 20:25:26 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp 
Message-ID: <E1CSKZS-0003I5-00@common-lisp.net>

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

Modified Files:
	symbols.lisp 
Log Message:
Rewrite boundp in terms of dynamic-load-unprotected.

Date: Thu Nov 11 20:25:25 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.22 movitz/losp/muerte/symbols.lisp:1.23
--- movitz/losp/muerte/symbols.lisp:1.22	Thu Oct 21 22:34:11 2004
+++ movitz/losp/muerte/symbols.lisp	Thu Nov 11 20:25:25 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 23:55:41 2001
 ;;;;                
-;;;; $Id: symbols.lisp,v 1.22 2004/10/21 20:34:11 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.23 2004/11/11 19:25:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -52,12 +52,7 @@
   (check-type symbol symbol)
   (with-inline-assembly (:returns :eax)
     (:compile-form (:result-mode :eax) symbol)
-    (:call-local-pf dynamic-find-binding)
-    (:jnc 'no-local-binding)
-    (:movl (:eax) :eax)
-    (:jmp 'done)
-   no-local-binding
-    (:movl (:eax (:offset movitz-symbol value)) :eax)
+    (:call-local-pf dynamic-load-unprotected)
    done))
 
 (defun (setf symbol-value) (value symbol)
@@ -128,7 +123,7 @@
   (get-symbol-slot symbol package))
 
 (defun boundp (symbol)
-  (boundp symbol))
+  (compiler-macro-call boundp symbol))
 
 (defun makunbound (symbol)
   (setf (symbol-value symbol)




From ffjeld at common-lisp.net  Thu Nov 11 19:26:07 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Nov 2004 20:26:07 +0100
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1CSKa7-0003IW-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
More improved implementation of dynamic binding protocol.

Date: Thu Nov 11 20:26:06 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.30 movitz/special-operators-cl.lisp:1.31
--- movitz/special-operators-cl.lisp:1.30	Thu Nov 11 11:48:22 2004
+++ movitz/special-operators-cl.lisp	Thu Nov 11 20:26:06 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.30 2004/11/11 10:48:22 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.31 2004/11/11 19:26:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -292,7 +292,11 @@
 				     body-code
 				   (progn #+ignore (warn "recompile..") ; XXX
 					  (compile-body)))
-				 (when (plusp (num-specials local-env))
+				 (when (and (plusp (num-specials local-env))
+					    (not (eq :non-local-exit body-returns)))
+				   #+ignore
+				   (warn "let spec ret: ~S, want: ~S ~S"
+					 body-returns result-mode let-var-specs)
 				   `((:movl (:esp ,(+ -4 (* 16 (num-specials local-env)))) :edx)
 				     (:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context
 									     'dynamic-variable-uninstall))))
@@ -1248,7 +1252,7 @@
 		 ;; Execute protected form..
 		 (compiler-call #'compile-form
 		   :env unwind-protect-env
-		   :with-stack-used t
+		   :with-stack-used t ;; XXX Not really true, is it?
 		   :forward all
 		   :result-mode :multiple-values
 		   :form protected-form)




From ffjeld at common-lisp.net  Thu Nov 11 19:26:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Nov 2004 20:26:15 +0100
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1CSKaF-0003Is-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
More improved implementation of dynamic binding protocol.

Date: Thu Nov 11 20:26:12 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.50 movitz/losp/muerte/primitive-functions.lisp:1.51
--- movitz/losp/muerte/primitive-functions.lisp:1.50	Thu Nov 11 12:09:37 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Thu Nov 11 20:26:12 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.50 2004/11/11 11:09:37 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.51 2004/11/11 19:26:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -150,13 +150,14 @@
   "Install each dynamic binding entry between that in ESP and current dynamic-env.
 Preserve EDX."
   (with-inline-assembly (:returns :nothing)
+    ;; Default binding strategy is naive deep binding, so this is a NOP.
     (:ret)))
 
 (define-primitive-function dynamic-variable-uninstall (dynamic-env)
   "Uninstall each dynamic binding between 'here' (i.e. the current 
 dynamic environment pointer) and the dynamic-env pointer provided in EDX.
 This must be done without affecting 'current values'! (i.e. eax, ebx, ecx, or CF),
-and also EDX must not be affected."
+and also EDX must be preserved."
   (with-inline-assembly (:returns :nothing)
     ;; Default binding strategy is naive deep binding, so this is a NOP.
     (:ret)))
@@ -309,6 +310,10 @@
     (:testl :edi :edi)			; clear ZF
    search-failed
     (:ret)))				; success: ZF=0, eax=value
+
+
+
+;;;;;;;;;;;;;; Heap allocation protocol
 
 (define-primitive-function get-cons-pointer ()
   "Return in EAX the next object location with space for EAX words, with tag 6.




From ffjeld at common-lisp.net  Thu Nov 11 19:27:35 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Nov 2004 20:27:35 +0100
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1CSKbX-0003Jq-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Replace dynamic-find-binding with dynamic-load-unprotected. Add rtc-slot scratch2.

Date: Thu Nov 11 20:27:34 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.74 movitz/image.lisp:1.75
--- movitz/image.lisp:1.74	Wed Nov 10 18:34:40 2004
+++ movitz/image.lisp	Thu Nov 11 20:27:33 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.74 2004/11/10 17:34:40 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.75 2004/11/11 19:27:33 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -161,7 +161,7 @@
     :map-binary-write 'movitz-intern-code-vector
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-tag :primitive-function)
-   (dynamic-find-binding
+   (dynamic-load-unprotected
     :map-binary-write 'movitz-intern-code-vector
     :binary-tag :primitive-function
     :map-binary-read-delayed 'movitz-word-code-vector
@@ -476,6 +476,9 @@
     :initform 0)
    (non-pointers-end :binary-type :label) ; ========= NON-POINTER-END =======
    (scratch1
+    :binary-type word
+    :initform 0)
+   (scratch2
     :binary-type word
     :initform 0)
    (ret-trampoline




From ffjeld at common-lisp.net  Thu Nov 11 19:28:19 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Nov 2004 20:28:19 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1CSKcF-0003KL-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
*** empty log message ***
Date: Thu Nov 11 20:28:18 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.23 movitz/losp/los0.lisp:1.24
--- movitz/losp/los0.lisp:1.23	Mon Oct 11 15:51:55 2004
+++ movitz/losp/los0.lisp	Thu Nov 11 20:28:18 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.23 2004/10/11 13:51:55 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.24 2004/11/11 19:28:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -46,6 +46,29 @@
 
 (in-package muerte.init)
 
+
+(defun test0 ()
+  (ash 1 -1000000000000))
+
+(defun test1 ()
+  (unwind-protect 0 (the integer 1)))
+
+(defun test2 ()
+  (funcall
+   (compile
+    nil
+    '(lambda (a) (declare (notinline > *))
+      (declare (optimize (compilation-speed 0) (safety 2) (speed 2) (debug 0) (space 3)))
+      (catch 'ct1 (* a (throw 'ct1 (if (> 0) a 0))))))
+   5445205692802))
+
+(defun test3 ()
+  (loop for x below 2 count (not (not (typep x t)))))
+
+(defun test4 ()
+  (let ((a 1)) (if (not (/= a 0)) a 0)))
+
+
 (defun test-floppy ()
   (muerte.x86-pc::fd-start-disk)	; to initialize the controller and spin the drive up.
   (muerte.x86-pc::fd-cmd-seek 70)	; to seek to track 70.
@@ -1095,6 +1118,14 @@
 	(:stc))
     (values eax ebx ecx edx p1 p2)))
 
+(defun null-primitive-function (x)
+  "This function is just like identity, except it also calls a null primitive function.
+Can be used to measure the overhead of primitive function."
+  (with-inline-assembly (:returns :eax)
+    (:load-lexical (:lexical-binding x) :eax)
+    (% bytes 8 #xff #x97)		; (:call-local-pf ret-trampoline)
+    (% bytes 32 #.(bt:slot-offset 'movitz::movitz-run-time-context 'movitz::ret-trampoline))))
+
 (defun my-test-labels (x)
   (labels (#+ignore (p () (print x))
 		    (q (y) (list x y)))
@@ -1223,6 +1254,7 @@
     (:ret)))
 
 (defun genesis ()
+  (install-shallow-binding)
   (let ((extended-memsize 0))
     ;;  Find out how much extended memory we have 
     (setf (io-port #x70 :unsigned-byte8) #x18)
@@ -1295,9 +1327,14 @@
 
 #+ignore
 (defun progntest ()
-  (unwind-protect
-      (progn (print 'x) 'foo (error "bar"))
-    (print 'y)))
+  (prog ()
+    (unwind-protect
+	(progn
+	  (print 'x) 
+	  (go mumbo)
+	  (error "bar"))
+      (print 'y))
+   mumbo))
 
 #+ignore
 (defun test-restart (x)
@@ -1355,4 +1392,173 @@
 	   (#\esc (break "Under the bridge."))
 	   (#\e (error "this is an error!"))))))))
 
+
+(defparameter *write-barrier* nil)
+
+(defun show-writes ()
+  (loop with num = (length *write-barrier*)
+      for i from 0 below num by 4
+      initially (format t "~&Number of writes: ~D" (truncate num 4))
+      do (format t "~&~D ~S: [~Z] Write to ~S: ~S."
+		 i (aref *write-barrier* (+ i 3))
+		 (aref *write-barrier* i)
+		 (aref *write-barrier* i) (aref *write-barrier* (+ i 2))))
+  (values))
+
+(defun es-test (&optional (barrier-size 1000))
+  (setf *write-barrier* (or *write-barrier*
+			    (make-array (* 4 barrier-size) :fill-pointer 0))
+	(fill-pointer *write-barrier*) 0
+	(exception-handler 13) #'general-protection-handler
+	(segment-register :es) 0)
+  (values))
+
+(defun general-protection-handler (vector dit-frame)
+  (assert (= vector 13))
+  (let ((eip (dit-frame-ref nil dit-frame :eip :unsigned-byte32)))
+    (assert (= #x26 (memref-int eip 0 0 :unsigned-byte8))) ; ES override prefix?
+    (let ((opcode (memref-int eip 1 0 :unsigned-byte8))
+	  (mod/rm (memref-int eip 2 0 :unsigned-byte8)))
+      (if (not (= #x89 opcode))
+	  (interrupt-default-handler vector dit-frame)
+	(let ((value (ecase (ldb (byte 3 3) mod/rm)
+		       (0 (dit-frame-ref nil dit-frame :eax :lisp))
+		       (3 (dit-frame-ref nil dit-frame :ebx :lisp)))))
+	  ;; If we return, don't execute with the ES override prefix:
+	  (setf (dit-frame-ref nil dit-frame :eip :unsigned-byte32) (1+ eip))
+	  ;; If value isn't a pointer, we don't care..
+	  (when (typep value 'pointer)
+	    (multiple-value-bind (object offset)
+		(case (logand mod/rm #xc7)
+		  (#x40			; (:movl <value> (:eax <disp8>))
+		   (values (dit-frame-ref nil dit-frame :eax)
+			   (memref-int eip 3 0 :signed-byte8)))
+		  (#x43			; (:movl <value> (:ebx <disp8>))
+		   (values (dit-frame-ref nil dit-frame :ebx)
+			   (memref-int eip 3 0 :signed-byte8)))
+		  (#x44			; the disp8/SIB case
+		   (let ((sib (memref-int eip 3 0 :unsigned-byte8)))
+		     (case sib
+		       ((#x19 #x0b)
+			(values (dit-frame-ref nil dit-frame :ebx)
+				(+ (dit-frame-ref nil dit-frame :ecx :unsigned-byte8)
+				   (memref-int eip 4 0 :signed-byte8))))
+		       ((#x1a)
+			(values (dit-frame-ref nil dit-frame :ebx)
+				(+ (dit-frame-ref nil dit-frame :edx :unsigned-byte8)
+				   (memref-int eip 4 0 :signed-byte8))))))))
+	      (when (not object)
+		(setf (segment-register :es) (segment-register :ds))
+		(break "[~S] With value ~S, unknown movl at ~S: ~S ~S ~S ~S"
+		       dit-frame value eip
+		       (memref-int eip 1 0 :unsigned-byte8)
+		       (memref-int eip 2 0 :unsigned-byte8)
+		       (memref-int eip 3 0 :unsigned-byte8)
+		       (memref-int eip 4 0 :unsigned-byte8)))
+	      (check-type object pointer)
+	      (check-type offset fixnum)
+	      (let ((write-barrier *write-barrier*)
+		    (location (object-location object)))
+		(assert (not (location-in-object-p
+			      (los0::space-other (%run-time-context-slot 'nursery-space))
+			      location)) ()
+		  "Write ~S to old-space at ~S." value location)
+		(unless (or (eq object write-barrier)
+			    #+ignore
+			    (location-in-object-p (%run-time-context-slot 'nursery-space)
+						  location)
+			    (location-in-object-p (%run-time-context-slot 'stack-vector)
+						  location))
+		  (if (location-in-object-p (%run-time-context-slot 'nursery-space)
+					    location)
+		      (vector-push 'stack-actually write-barrier)		      
+		    (vector-push object write-barrier))
+		  (vector-push offset write-barrier)
+		  (vector-push value write-barrier)
+		  (unless (vector-push eip write-barrier)
+		    (setf (segment-register :es) (segment-register :ds))
+		    (break "Write-barrier is full: ~D" (length write-barrier))))))))))))
+
+;;;;;;;;;;;;;;;;;; Shallow binding
+
+(define-primitive-function dynamic-variable-install-shallow ()
+  "Install each dynamic binding entry between that in ESP (offset by 4 due to
+the call to this primitive-function!) and current dynamic-env.
+Preserve EDX."
+  (with-inline-assembly (:returns :nothing)
+    (:leal (:esp 4) :ecx)
+   install-loop
+    (:locally (:cmpl :ecx (:edi (:edi-offset dynamic-env))))
+    (:je 'install-completed)
+    (:movl (:ecx 0) :eax)		; symbol
+    (:movl (:ecx 8) :ebx)		; new value
+    (:xchgl :ebx (:eax (:offset movitz-symbol value))) ; exchange new and old value
+    (:movl :ebx (:ecx 8))
+    (:movl (:ecx 12) :ecx)
+    (:jmp 'install-loop)
+   install-completed
+    (:ret)))
+
+(define-primitive-function dynamic-variable-uninstall-shallow (dynamic-env)
+  "Uninstall each dynamic binding between 'here' (i.e. the current 
+dynamic environment pointer) and the dynamic-env pointer provided in EDX.
+This must be done without affecting 'current values'! (i.e. eax, ebx, ecx, or CF),
+and also EDX must be preserved."
+  (with-inline-assembly (:returns :nothing)
+    (:jc 'ecx-ok)
+    (:movl 1 :ecx)
+   ecx-ok
+    (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0))))
+    (:locally (:movl :eax (:edi (:edi-offset scratch1))))
+    (:locally (:movl :ebx (:edi (:edi-offset scratch2))))
+    
+    (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx))
+   uninstall-loop
+    (:cmpl :edx :ecx)
+    (:je 'uninstall-completed)
+    (:movl (:ecx 0) :eax)		; symbol
+    (:movl (:ecx 8) :ebx)		; old value
+    (:movl :ebx (:eax (:offset movitz-symbol value))) ; reload old value
+    (:movl (:ecx 12) :ecx)
+    (:jmp 'uninstall-loop)
+   uninstall-completed
+
+    (:locally (:movl (:edi (:edi-offset raw-scratch0)) :ecx))
+    (:locally (:movl (:edi (:edi-offset scratch1)) :eax))
+    (:locally (:movl (:edi (:edi-offset scratch2)) :ebx))
+    (:stc)
+    (:ret)))
+
+(define-primitive-function dynamic-load-shallow (symbol)
+  "Load the dynamic value of SYMBOL into EAX."
+  (with-inline-assembly (:returns :multiple-values)
+    (:movl (:eax (:offset movitz-symbol value)) :eax)
+    (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax))
+    (:je '(:sub-program (unbound) (:int 99)))
+    (:ret)))
+
+(define-primitive-function dynamic-load-unprotected-shallow (symbol)
+  "Load the dynamic value of SYMBOL into EAX."
+  (with-inline-assembly (:returns :multiple-values)
+    (:movl (:eax (:offset movitz-symbol value)) :eax)
+    (:ret)))
+
+(define-primitive-function dynamic-store-shallow (symbol value)
+  "Store VALUE (ebx) in the dynamic binding of SYMBOL (eax).
+   Preserves EBX and EAX."
+  (with-inline-assembly (:returns :multiple-values)
+    (:movl :ebx (:eax (:offset movitz-symbol value)))
+    (:ret)))
+
+(defun install-shallow-binding ()
+  (macrolet ((install (slot function)
+	       `(setf (%run-time-context-slot ',slot) (symbol-value ',function))))
+    (install muerte:dynamic-variable-install dynamic-variable-install-shallow)
+    (install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow)
+    (install muerte::dynamic-store dynamic-store-shallow)
+    (install muerte::dynamic-load-unprotected dynamic-load-unprotected-shallow)
+    (install muerte::dynamic-load dynamic-load-shallow))
+  (values))
+
 (genesis)
+




From ffjeld at common-lisp.net  Thu Nov 11 19:28:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Nov 2004 20:28:53 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp 
Message-ID: <E1CSKcn-0003Kl-00@common-lisp.net>

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

Modified Files:
	interrupt.lisp 
Log Message:
Include rtc-slot scratch2 when saving dynamic context.

Date: Thu Nov 11 20:28:52 2004
Author: ffjeld

Index: movitz/losp/muerte/interrupt.lisp
diff -u movitz/losp/muerte/interrupt.lisp:1.30 movitz/losp/muerte/interrupt.lisp:1.31
--- movitz/losp/muerte/interrupt.lisp:1.30	Thu Nov 11 11:08:44 2004
+++ movitz/losp/muerte/interrupt.lisp	Thu Nov 11 20:28:51 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Apr  7 01:50:03 2004
 ;;;;                
-;;;; $Id: interrupt.lisp,v 1.30 2004/11/11 10:08:44 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.31 2004/11/11 19:28:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -28,7 +28,7 @@
       :atomically-continuation
       :raw-scratch0      
       :ecx :eax :edx :ebx :esi
-      :scratch1
+      :scratch1 :scratch2
       :debug0
       :debug1
       :tail-marker))
@@ -125,6 +125,7 @@
 				     :key #'dit-frame-index)
 		  collect `(:pushl ,reg))
 	    (:locally (:pushl (:edi (:edi-offset scratch1))))
+	    (:locally (:pushl (:edi (:edi-offset scratch2))))
  	    
 	    (:locally (:movl (:edi (:edi-offset nursery-space)) :eax))
 	    (:pushl :eax)		; debug0: nursery-space
@@ -209,6 +210,8 @@
 	    (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0))))
 	    (:movl (:ebp ,(dit-frame-offset :scratch1)) :eax)
 	    (:locally (:movl :eax (:edi (:edi-offset scratch1))))
+	    (:movl (:ebp ,(dit-frame-offset :scratch2)) :eax)
+	    (:locally (:movl :eax (:edi (:edi-offset scratch2))))
 
 	    ;; Load the DF flag from the interruptee before we restore
 	    ;; its register contents.
@@ -266,9 +269,6 @@
 	    (:int 63)
 	    )))
     (do-it)))
-
-
-
 
 (defun interrupt-default-handler (vector dit-frame)
   (declare (without-check-stack-limit))




From ffjeld at common-lisp.net  Thu Nov 11 19:29:10 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Nov 2004 20:29:10 +0100
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1CSKd4-0003LG-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
more symbols.

Date: Thu Nov 11 20:29:08 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.38 movitz/packages.lisp:1.39
--- movitz/packages.lisp:1.38	Wed Sep 22 19:59:44 2004
+++ movitz/packages.lisp	Thu Nov 11 20:29:08 2004
@@ -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.38 2004/09/22 17:59:44 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.39 2004/11/11 19:29:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1084,7 +1084,7 @@
 	   yes-or-no-p
 	   zerop))
 
-(defpackage #:muerte
+(defpackage muerte
   (:use muerte.mop muerte.common-lisp)
   (:import-from common-lisp cl:nil)
   (:shadow get-setf-expansion)
@@ -1128,7 +1128,8 @@
 	   #:stack-frame-call-site
 	   #:stack-frame-ref
 	   #:check-stack-limit
-	   #:interrupt-frame-ref
+	   #:dit-frame-ref
+	   #:interrupt-default-handler
 	   #:exception-handler
 
 	   #:*build-number*
@@ -1186,6 +1187,9 @@
 	   find-restart-from-context
 	   map-active-restarts
 	   with-basic-restart
+	   
+	   #:dynamic-variable-install
+	   #:dynamic-variable-uninstall
 
 	   #:code-vector
 	   #:vector-u8




From ffjeld at common-lisp.net  Fri Nov 12 14:39:05 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Nov 2004 15:39:05 +0100
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1CScZt-0002FY-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
Removed dead code.

Date: Fri Nov 12 15:39:04 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.31 movitz/special-operators-cl.lisp:1.32
--- movitz/special-operators-cl.lisp:1.31	Thu Nov 11 20:26:06 2004
+++ movitz/special-operators-cl.lisp	Fri Nov 12 15:39:04 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.31 2004/11/11 19:26:06 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.32 2004/11/12 14:39:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1130,10 +1130,7 @@
 								'dynamic-variable-uninstall))))
 			(:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
 			(:popl :edx)	; number of bindings
-			(:leal (:esp (:edx 4)) :esp))
-		      #+ignore
-		      `((:popl :edx)	; pop address of first binding's tail
-			(:locally (:popl (:edi (:edi-offset dynamic-env))))))))))
+			(:leal (:esp (:edx 4)) :esp)))))))
 
 (define-special-operator labels (&all forward &form form &env env &funobj funobj)
   (destructuring-bind (labels-specs &body declarations-and-body)




From ffjeld at common-lisp.net  Fri Nov 12 14:41:11 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Nov 2004 15:41:11 +0100
Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp 
Message-ID: <E1CScbv-0002G9-00@common-lisp.net>

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

Modified Files:
	procfs-image.lisp 
Log Message:
Somewhat improved backtrace output.

Date: Fri Nov 12 15:41:10 2004
Author: ffjeld

Index: movitz/procfs-image.lisp
diff -u movitz/procfs-image.lisp:1.19 movitz/procfs-image.lisp:1.20
--- movitz/procfs-image.lisp:1.19	Wed Sep 15 12:22:52 2004
+++ movitz/procfs-image.lisp	Fri Nov 12 15:41:10 2004
@@ -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.19 2004/09/15 10:22:52 ffjeld Exp $
+;;;; $Id: procfs-image.lisp,v 1.20 2004/11/12 14:41:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -194,7 +194,7 @@
 	do (let ((movitz-name (funobj-name (stack-frame-funobj stack-frame))))
 	     (typecase movitz-name
 	       (null
-		(write-string "?")
+		;; (write-string "?")
 		(let* ((eax (get-word (+ (* 4 (interrupt-frame-index :eax)) stack-frame)))
 		       (ebx (get-word (+ (* 4 (interrupt-frame-index :ebx)) stack-frame)))
 		       (ecx (get-word (+ (* 4 (interrupt-frame-index :ecx)) stack-frame)))
@@ -205,12 +205,12 @@
 		       (exception (get-word (+ (* 4 (interrupt-frame-index :exception-vector))
 					       stack-frame))))
 		  (format t "#x~X {EAX: #x~X, EBX: #x~X, ECX: #x~X, EDX: #x~X, EDI: #x~X, ESI: #x~X, EIP: #x~X, exception ~D}"
-			  stack-frame
+			  (truncate stack-frame 4)
 			  eax ebx ecx edx edi esi eip exception)))
 	       (movitz-symbol
 		(let ((name (movitz-print movitz-name)))
 		  (when print-frames
-		    (format t "~S " stack-frame))
+		    (format t "~S " (truncate stack-frame 4)))
 		  (when (string= name 'toplevel-function)
 		    (loop-finish))
 		  (when reqs




From ffjeld at common-lisp.net  Fri Nov 12 14:51:30 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Nov 2004 15:51:30 +0100
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1CSclu-0002Sg-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Changed exact-throw, the basic operator for dynamic control transfer,
quite a bit. The (ill-specified) primitive-function
dynamic-locate-catch-tag is removed, its essential job is now
performed by the normal function find-catch-tag.

Date: Fri Nov 12 15:51:29 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.75 movitz/image.lisp:1.76
--- movitz/image.lisp:1.75	Thu Nov 11 20:27:33 2004
+++ movitz/image.lisp	Fri Nov 12 15:51:28 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.75 2004/11/11 19:27:33 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.76 2004/11/12 14:51:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -172,11 +172,6 @@
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-type code-vector-word)
    (dynamic-store
-    :map-binary-write 'movitz-intern-code-vector
-    :binary-tag :primitive-function
-    :map-binary-read-delayed 'movitz-word-code-vector
-    :binary-type code-vector-word)
-   (dynamic-locate-catch-tag
     :map-binary-write 'movitz-intern-code-vector
     :binary-tag :primitive-function
     :map-binary-read-delayed 'movitz-word-code-vector




From ffjeld at common-lisp.net  Fri Nov 12 14:51:39 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Nov 2004 15:51:39 +0100
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1CScm3-0002T6-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Changed exact-throw, the basic operator for dynamic control transfer,
quite a bit. The (ill-specified) primitive-function
dynamic-locate-catch-tag is removed, its essential job is now
performed by the normal function find-catch-tag.

Date: Fri Nov 12 15:51:37 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.39 movitz/packages.lisp:1.40
--- movitz/packages.lisp:1.39	Thu Nov 11 20:29:08 2004
+++ movitz/packages.lisp	Fri Nov 12 15:51:37 2004
@@ -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.39 2004/11/11 19:29:08 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.40 2004/11/12 14:51:37 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1088,8 +1088,7 @@
   (:use muerte.mop muerte.common-lisp)
   (:import-from common-lisp cl:nil)
   (:shadow get-setf-expansion)
-  (:export exact-throw
-	   translate-program
+  (:export translate-program
 	   decode-macro-lambda-list
 	   with-inline-assembly
 	   with-progn-results




From ffjeld at common-lisp.net  Fri Nov 12 14:51:47 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Nov 2004 15:51:47 +0100
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1CScmB-0002TX-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Changed exact-throw, the basic operator for dynamic control transfer,
quite a bit. The (ill-specified) primitive-function
dynamic-locate-catch-tag is removed, its essential job is now
performed by the normal function find-catch-tag.

Date: Fri Nov 12 15:51:45 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.42 movitz/special-operators.lisp:1.43
--- movitz/special-operators.lisp:1.42	Thu Oct 21 22:41:56 2004
+++ movitz/special-operators.lisp	Fri Nov 12 15:51:44 2004
@@ -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.42 2004/10/21 20:41:56 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.43 2004/11/12 14:51:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1175,7 +1175,10 @@
 	  finally (error "No compiler-typecase clause matched compile-time type ~S." keyform-type)))))
 
 (define-special-operator muerte::exact-throw (&all all-throw &form form &env env &funobj funobj)
-  (destructuring-bind (tag context value-form)
+  "Perform a dynamic control transfer to catch-env-slot context (evaluated),
+with values from value-form. Error-form, if provided, is evaluated in case the context
+is zero (i.e. not found)."
+  (destructuring-bind (context value-form &optional error-form)
       (cdr form)
     (let* ((local-env (make-local-movitz-environment env funobj :type 'let-env))
 	   (dynamic-slot-binding
@@ -1186,43 +1189,46 @@
 	    (movitz-env-add-binding local-env
 				    (make-instance 'located-binding
 				      :name (gensym "continuation-step-")))))
-      (with-labels (throw (save-tag-var save-context-var))
-	(compiler-values ()
-	  :returns :non-local-exit
-	  :code (append (compiler-call #'compile-form
-			  :forward all-throw
-			  :result-mode :multiple-values
-			  :form `(muerte.cl:let ((,save-tag-var ,tag)
-						 (,save-context-var ,context))
-				   (muerte.cl:multiple-value-prog1
-				       ,value-form
-				     (muerte::with-inline-assembly (:returns :nothing)
-				       (:compile-two-forms (:eax :ebx) ,save-tag-var ,save-context-var)
-				       (:globally (:call (:edi (:edi-offset dynamic-locate-catch-tag))))
-				       (:jnc '(:sub-program () (:int 108)))
-				       (:store-lexical ,dynamic-slot-binding :eax :type t)
-				       (:globally (:call (:edi (:edi-offset dynamic-unwind-next))))
-				       (:store-lexical ,next-continuation-step-binding :eax :type t)
-				       ))))
-			;; now outside of m-v-prog1's cloak, with final dynamic-slot in ..
-			;; ..unwind it and transfer control.
-			;;
-			;; * 12 dynamic-env uplink
-			;; *  8 target jumper number
-			;; *  4 target catch tag
-			;; *  0 target EBP
-			`((:load-lexical ,dynamic-slot-binding :edx)
-			  (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation
-			  (:load-lexical ,next-continuation-step-binding :edx) ; next continuation-step
-			  (:locally (:movl :esi (:edi (:edi-offset scratch1))))
-			  (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit dynamic-env
-			  (:movl :edx :esp) ; enter non-local jump stack mode.
+      (compiler-values ()
+	:returns :non-local-exit
+	:code (append (compiler-call #'compile-form
+			:forward all-throw
+			:result-mode dynamic-slot-binding
+			:form context)
+		      (compiler-call #'compile-form
+			:forward all-throw
+			:result-mode :multiple-values
+			:form `(muerte.cl:multiple-value-prog1
+				   ,value-form
+				 (muerte::with-inline-assembly (:returns :nothing)
+				   (:load-lexical ,dynamic-slot-binding :eax)
+				   ,@(when error-form
+				       `((:testl :eax :eax)
+					 (:jz '(:sub-program ()
+						(:compile-form (:result-mode :ignore)
+						 ,error-form)))))
+				   (:locally (:call (:edi (:edi-offset dynamic-unwind-next))))
+				   (:store-lexical ,next-continuation-step-binding :eax :type t)
+				   )))
+		      ;; now outside of m-v-prog1's cloak, with final dynamic-slot in ..
+		      ;; ..unwind it and transfer control.
+		      ;;
+		      ;; * 12 dynamic-env uplink
+		      ;; *  8 target jumper number
+		      ;; *  4 target catch tag
+		      ;; *  0 target EBP
+		      `((:load-lexical ,dynamic-slot-binding :edx)
+			(:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation
+			(:load-lexical ,next-continuation-step-binding :edx) ; next continuation-step
+			(:locally (:movl :esi (:edi (:edi-offset scratch1))))
+			(:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit dynamic-env
+			(:movl :edx :esp) ; enter non-local jump stack mode.
 			  
-			  (:movl (:esp) :edx) ; target stack-frame EBP
-			  (:movl (:edx -4) :esi) ; get target funobj into ESI
+			(:movl (:esp) :edx) ; target stack-frame EBP
+			(:movl (:edx -4) :esi) ; get target funobj into ESI
 			  
-			  (:movl (:esp 8) :edx) ; target jumper number
-			  (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0))))))))))
+			(:movl (:esp 8) :edx) ; target jumper number
+			(:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0)))))))))
 
 
 (define-special-operator muerte::with-basic-restart (&all defaults &form form &env env)




From ffjeld at common-lisp.net  Fri Nov 12 14:52:01 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Nov 2004 15:52:01 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp 
Message-ID: <E1CScmP-0002Tx-00@common-lisp.net>

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

Modified Files:
	basic-functions.lisp 
Log Message:
Changed exact-throw, the basic operator for dynamic control transfer,
quite a bit. The (ill-specified) primitive-function
dynamic-locate-catch-tag is removed, its essential job is now
performed by the normal function find-catch-tag.

Date: Fri Nov 12 15:51:56 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-functions.lisp
diff -u movitz/losp/muerte/basic-functions.lisp:1.13 movitz/losp/muerte/basic-functions.lisp:1.14
--- movitz/losp/muerte/basic-functions.lisp:1.13	Tue Jul 13 04:26:24 2004
+++ movitz/losp/muerte/basic-functions.lisp	Fri Nov 12 15:51:56 2004
@@ -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.13 2004/07/13 02:26:24 ffjeld Exp $
+;;;; $Id: basic-functions.lisp,v 1.14 2004/11/12 14:51:56 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -27,6 +27,26 @@
 
 (defun not (x)
   (not x))
+
+(defun find-catch-tag (catch-tag)
+  "Find the dynamic-env slot that matches the catch-tag, or 0 if unseen."
+  (with-inline-assembly (:returns :eax)
+    (:load-lexical (:lexical-binding catch-tag) :eax)
+    (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx))
+    (:jecxz 'search-done)
+   search-loop
+    (:cmpl :eax (:ecx 4))		; Does tag match entry?
+    (:jne 'search-next)			; if not, goto next.
+    (:testl 3 (:ecx))			; Is this really a catch entry?
+    (:jz 'search-done)			; if yes, we have found it.
+   search-next
+    (:movl (:ecx 12) :ecx)
+    (:testl :ecx :ecx)
+    (:jnz 'search-loop)
+    ;; Search failed, ECX=0
+   search-done
+    (:movl :ecx :eax)))
+    
 
 (defmacro numargs ()
   `(with-inline-assembly (:returns :ecx)




From ffjeld at common-lisp.net  Fri Nov 12 14:52:09 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Nov 2004 15:52:09 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1CScmX-0002UN-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Changed exact-throw, the basic operator for dynamic control transfer,
quite a bit. The (ill-specified) primitive-function
dynamic-locate-catch-tag is removed, its essential job is now
performed by the normal function find-catch-tag.

Date: Fri Nov 12 15:52:08 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.44 movitz/losp/muerte/basic-macros.lisp:1.45
--- movitz/losp/muerte/basic-macros.lisp:1.44	Thu Nov 11 20:24:52 2004
+++ movitz/losp/muerte/basic-macros.lisp	Fri Nov 12 15:52:05 2004
@@ -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.44 2004/11/11 19:24:52 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.45 2004/11/12 14:52:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -116,7 +116,11 @@
     `(compiled-cond (,test-form ,then-form))))
 
 (defmacro throw (tag result-form)
-  `(exact-throw ,tag 0 ,result-form))
+  (let ((tag-var (gensym "throw-tag-")))
+    `(let ((,tag-var ,tag))
+       (exact-throw (find-catch-tag ,tag-var)
+		    ,result-form
+		    (error 'throw-error :tag ,tag-var)))))
 
 (defmacro when (test-form &rest forms)
   `(cond (,test-form , at forms)))




From ffjeld at common-lisp.net  Fri Nov 12 14:52:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Nov 2004 15:52:18 +0100
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1CScmg-0002Un-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Changed exact-throw, the basic operator for dynamic control transfer,
quite a bit. The (ill-specified) primitive-function
dynamic-locate-catch-tag is removed, its essential job is now
performed by the normal function find-catch-tag.

Date: Fri Nov 12 15:52:17 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.51 movitz/losp/muerte/primitive-functions.lisp:1.52
--- movitz/losp/muerte/primitive-functions.lisp:1.51	Thu Nov 11 20:26:12 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Fri Nov 12 15:52:16 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.51 2004/11/11 19:26:12 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.52 2004/11/12 14:52:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -81,8 +81,8 @@
 ;;; Dynamic binding:
 ;;;   12: parent (no parent == #x0)
 ;;;    8: value
-;;;    4: tag = #:unbound (unique value that cannot be a catch tag)
-;;;    0: binding name/symbol
+;;;    4: scratch, free to use by binding implementation.
+;;;    0: binding name (a symbol)
 
 ;;; Catch exit-point:
 ;;;   12: parent (no parent == #x0)
@@ -161,44 +161,6 @@
   (with-inline-assembly (:returns :nothing)
     ;; Default binding strategy is naive deep binding, so this is a NOP.
     (:ret)))
-
-(define-primitive-function dynamic-locate-catch-tag (tag)
-  "Search the dynamic environment for a catch slot matching <tag> in EAX.
-If EBX is not zero, only match that exact dynamic context (which presumably
-was located earlier by other means).
-Iff a tag is found, any intervening unwind-protect cleanup-forms are executed, and
-this functions returns with EAX pointing to the dynamic-slot for tag, and with carry set.
-When the tag is not found, no cleanup-forms are executed, and carry is cleared upon return,
-with EAX still holding the tag."
-  (with-inline-assembly (:returns :multiple-values)
-    (:globally (:movl (:edi (:edi-offset unwind-protect-tag)) :edx))
-    (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx))
-
-   search-loop
-    (:jecxz 'search-failed)
-    
-    (:cmpl :eax (:ecx 4))		; is env-slot in ECX == tag?
-    (:jne 'mismatch)
-    
-    (:cmpl :ecx :ebx)
-    (:je 'success)
-    (:testl :ebx :ebx)
-    (:jz 'success)
-
-   mismatch
-
-   not-unwind-protect
-    (:movl (:ecx 12) :ecx)		; get parent
-    (:jmp 'search-loop)
-    
-   success
-    (:movl :ecx :eax)
-    (:stc)				; signal success
-    (:ret)				; return
-    
-   search-failed
-    (:clc)				; signal failure
-    (:ret)))				; return.
     
 (define-primitive-function dynamic-unwind ()
   "Unwind ECX dynamic environment slots. Scratch EAX."




From ffjeld at common-lisp.net  Fri Nov 12 14:52:27 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Nov 2004 15:52:27 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/restarts.lisp 
Message-ID: <E1CScmp-0002VE-00@common-lisp.net>

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

Modified Files:
	restarts.lisp 
Log Message:
Changed exact-throw, the basic operator for dynamic control transfer,
quite a bit. The (ill-specified) primitive-function
dynamic-locate-catch-tag is removed, its essential job is now
performed by the normal function find-catch-tag.

Date: Fri Nov 12 15:52:25 2004
Author: ffjeld

Index: movitz/losp/muerte/restarts.lisp
diff -u movitz/losp/muerte/restarts.lisp:1.4 movitz/losp/muerte/restarts.lisp:1.5
--- movitz/losp/muerte/restarts.lisp:1.4	Thu Sep  2 11:41:04 2004
+++ movitz/losp/muerte/restarts.lisp	Fri Nov 12 15:52:24 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct 28 09:27:13 2003
 ;;;;                
-;;;; $Id: restarts.lisp,v 1.4 2004/09/02 09:41:04 ffjeld Exp $
+;;;; $Id: restarts.lisp,v 1.5 2004/11/12 14:52:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -119,8 +119,7 @@
 	   (function
 	    (apply function arguments))
 	   (symbol
-	    (exact-throw (load-global-constant restart-tag)
-			 (basic-restart->dynamic-context restart)
+	    (exact-throw (basic-restart->dynamic-context restart)
 			 (ecase function
 			   ((with-simple-restart)
 			    (values nil t))))))))




From ffjeld at common-lisp.net  Fri Nov 12 15:13:48 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Nov 2004 16:13:48 +0100
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1CSd7U-0002jF-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
No longer need to push unbound-value as part of dynamic-binding's env-slots.

Date: Fri Nov 12 16:13:47 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.32 movitz/special-operators-cl.lisp:1.33
--- movitz/special-operators-cl.lisp:1.32	Fri Nov 12 15:39:04 2004
+++ movitz/special-operators-cl.lisp	Fri Nov 12 16:13:47 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.32 2004/11/12 14:39:04 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.33 2004/11/12 15:13:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -83,7 +83,7 @@
 				      :form init-form
 				      :modify-accumulate let-modifies
 				      :result-mode :push)
-				    `((:globally (:pushl (:edi (:edi-offset unbound-value)))))
+				    `((:pushl :edi)) ; scratch
 				    (prog1 nil (incf (stack-used init-env) 2))
 				    (compiler-call #'compile-self-evaluating ; binding name
 				      :env init-env
@@ -1103,11 +1103,10 @@
 			  (:movl (:eax 3) :eax) ; (pop values)
 			  ,no-more-values
 			  (:pushl :edx)	; push (car values) [[ binding value ]]
-			  (:globally (:pushl (:edi (:edi-offset unbound-value)))) ;  [[ binding tag ]]
+			  (:pushl :edi)	; push binding scratch
 			  (:pushl (:ebx -1)) ; push (car symbols) [[ binding name ]]
 			  (:movl (:ebx 3) :ebx) ; (pop symbols)
 			  (:addl 4 :ecx)
-			  ;; (:jc '(:sub-program (too-many-symbols) (:int 71)))
 			  (:pushl :esp)	; push next tail
 			  (:jmp ',loop)
 			  ,no-more-symbols




From ffjeld at common-lisp.net  Fri Nov 12 16:24:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Nov 2004 17:24:53 +0100
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1CSeEH-0003lo-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Make dynamic-env of "word" type. It's a "location", really.

Date: Fri Nov 12 17:24:52 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.76 movitz/image.lisp:1.77
--- movitz/image.lisp:1.76	Fri Nov 12 15:51:28 2004
+++ movitz/image.lisp	Fri Nov 12 17:24:51 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.76 2004/11/12 14:51:28 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.77 2004/11/12 16:24:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -107,7 +107,7 @@
     :binary-tag :primitive-function)
    ;; per thread parameters
    (dynamic-env
-    :binary-type lu32
+    :binary-type word
     :initform 0)
    ;; More per-thread parameters
    (unwind-protect-tag




From ffjeld at common-lisp.net  Fri Nov 12 16:25:11 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Nov 2004 17:25:11 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1CSeEZ-0003mI-00@common-lisp.net>

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

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

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

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




From ffjeld at common-lisp.net  Fri Nov 12 20:55:51 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Nov 2004 21:55:51 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1CSiSV-0007aA-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Add dynamic-unwind-next-shallow.

Date: Fri Nov 12 21:55:49 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.25 movitz/losp/los0.lisp:1.26
--- movitz/losp/los0.lisp:1.25	Fri Nov 12 17:25:09 2004
+++ movitz/losp/los0.lisp	Fri Nov 12 21:55:49 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.25 2004/11/12 16:25:09 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.26 2004/11/12 20:55:49 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1530,6 +1530,47 @@
     (:stc)
     (:ret)))
 
+(define-primitive-function dynamic-unwind-next-shallow (dynamic-env)
+  "Locate the next unwind-protect entry between here and dynamic-env/EAX.
+If no such entry is found, return (same) dynamic-env in EAX and CF=0.
+Otherwise return the unwind-protect entry in EAX and CF=1. Preserve EDX.
+Point is: Return the 'next step' in unwinding towards dynamic-env.
+Note that it's an error if dynamic-env isn't in the current dynamic environment,
+it's supposed to have been found by e.g. dynamic-locate-catch-tag."
+  ;; XXX: Not really sure if there's any point in the CF return value,
+  ;;      because I don't think there's ever any need to know whether
+  ;;      the returned entry is an unwind-protect or the actual target.
+  (with-inline-assembly (:returns :nothing)
+    (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax))
+    (:locally (:movl :eax (:edi (:edi-offset scratch2)))) ; Free up EAX
+    ;; (:globally (:movl (:edi (:edi-offset unwind-protect-tag)) :ebx))
+    (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx))
+    
+   search-loop
+    (:jecxz '(:sub-program () (:int 63)))
+    (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx))
+
+    (:locally (:cmpl :ecx (:edi (:edi-offset scratch2))))
+    (:je 'found-dynamic-env)
+
+    (:movl (:ecx 4) :ebx)
+    (:globally (:cmpl :ebx (:edi (:edi-offset unwind-protect-tag))))
+    (:je 'found-unwind-protect)
+
+    ;; If this entry is a dynamic variable binding, uninstall it.
+    (:movl (:ecx) :eax)			; symbol?
+    (:testb 3 :al)			;
+    (:jz 'not-variable-binding)		; not symbol?
+    (:movl :ebx (:eax (:offset movitz-symbol value))) ; uninstall.
+   not-variable-binding
+    (:movl (:ecx 12) :ecx)		; proceed search
+    (:jmp 'search-loop)
+   found-unwind-protect
+    (:stc)
+   found-dynamic-env
+    (:movl :ecx :eax)
+    (:ret)))
+
 (define-primitive-function dynamic-load-shallow (symbol)
   "Load the dynamic value of SYMBOL into EAX."
   (with-inline-assembly (:returns :multiple-values)
@@ -1560,6 +1601,7 @@
 		    (setf (%run-time-context-slot ',slot) (symbol-value ',function)))))
       (list (install muerte:dynamic-variable-install dynamic-variable-install-shallow)
 	    (install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow)
+	    (install muerte::dynamic-unwind-next dynamic-unwind-next-shallow)
 	    (install muerte::dynamic-store dynamic-store-shallow)
 	    (install muerte::dynamic-load-unprotected dynamic-load-unprotected-shallow)
 	    (prog1 (install muerte::dynamic-load dynamic-load-shallow)




From ffjeld at common-lisp.net  Sat Nov 13 14:49:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 13 Nov 2004 15:49:53 +0100
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1CSzDt-0005rU-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
Fixed the block and return-from special-operators to work better in
the non-trivial cases (across function-boundaries, unwind-protects etc.)

Date: Sat Nov 13 15:49:52 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.33 movitz/special-operators-cl.lisp:1.34
--- movitz/special-operators-cl.lisp:1.33	Fri Nov 12 16:13:47 2004
+++ movitz/special-operators-cl.lisp	Sat Nov 13 15:49:51 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.33 2004/11/12 15:13:47 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.34 2004/11/13 14:49:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -629,8 +629,7 @@
 	:returns last-returns
 	:functional-p nil))))
 		  
-(define-special-operator tagbody
-    (&all forward &funobj funobj &form form &env env)
+(define-special-operator tagbody (&all forward &funobj funobj &form form &env env)
   (let* ((save-esp-variable (gensym "tagbody-save-esp"))
 	 (lexical-catch-tag-variable (gensym "tagbody-lexical-catch-tag-"))
 	 (label-set-name (gensym "label-set-"))
@@ -744,7 +743,7 @@
 			;; The target jumper points to the tagbody's label-set.
 			;; Now, install correct jumper within tagbody as target.
 			`((:addl ,(* 4 label-id) (:edx 8))))
-		    (:globally (:call (:edi (:edi-offset dynamic-unwind-next))))
+		    (:locally (:call (:edi (:edi-offset dynamic-unwind-next))))
 		    ;; have next-continuation in EAX, final-continuation in EDX
 		    (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation
 		    (:locally (:movl :esi (:edi (:edi-offset scratch1))))
@@ -767,9 +766,10 @@
 				((:eax :eax :multiple-values :function :ebx :ecx :ignore)
 				 result-mode)
 				(t :eax)))
-	   (block-returns-mode (case block-result-mode
+	   (block-returns-mode (case (result-mode-type block-result-mode)
 				 (:function :multiple-values)
 				 (:ignore :nothing)
+				 ((:boolean-branch-on-true :boolean-branch-on-false) :eax)
 				 (t block-result-mode)))
 	   (block-env (make-instance 'lexical-exit-point-env
 			:uplink env
@@ -779,13 +779,10 @@
 			:exit-label exit-block-label
 			:exit-result-mode block-result-mode))
 	   (save-esp-binding (make-instance 'located-binding
-			       :name save-esp-variable))
-	   (lexical-catch-tag-binding (make-instance 'located-binding
-					:name lexical-catch-tag-variable)))
+			       :name save-esp-variable)))
       (movitz-env-add-binding block-env save-esp-binding)
-      (movitz-env-add-binding block-env lexical-catch-tag-binding)
-      (movitz-env-load-declarations `((muerte.cl::ignorable ,save-esp-variable ,lexical-catch-tag-variable))
-				 block-env nil)
+      (movitz-env-load-declarations `((muerte.cl::ignorable ,save-esp-variable))
+				    block-env nil)
       (setf (movitz-env-get block-name :block-name nil block-env)
 	block-env)
       (compiler-values-bind (&code block-code &functional-p block-no-side-effects-p)
@@ -794,14 +791,15 @@
 	    :result-mode block-result-mode
 	    :form `(muerte.cl:progn , at body)
 	    :env block-env)
-	(let ((maybe-store-esp-code
-	       (when (and (not (eq block-result-mode :function))
+	(let ((label-set-name (gensym "block-label-set-"))
+	      (maybe-store-esp-code
+	       (when (and #+ignore (not (eq block-result-mode :function))
 			  (operators-present-in-code-p block-code '(:lexical-control-transfer) nil
 						       :test (lambda (x) (eq block-env (fifth x)))))
 		 `((:init-lexvar ,save-esp-binding
 				 :init-with-register :esp
 				 :init-with-type t)))))
-	  (if (not (code-uses-binding-p block-code lexical-catch-tag-binding))
+	  (if (not (code-uses-binding-p block-code save-esp-binding))
 	      (compiler-values ()
 		:code (append maybe-store-esp-code
 			      block-code
@@ -810,25 +808,29 @@
 		:functional-p block-no-side-effects-p)
 	    (multiple-value-bind (new-code new-returns)
 		(make-result-and-returns-glue :multiple-values block-returns-mode block-code)
-	      (multiple-value-bind (stack-used wrapped-code)
-		  (make-compiled-catch-wrapper lexical-catch-tag-variable
-					       funobj block-env new-returns
-					       new-code)
-		(incf (stack-used block-env) stack-used)
-		(setf (num-specials block-env) 1) ; block-env now has one dynamic slot
-		(compiler-values ()
-		  :code (append maybe-store-esp-code
-				`((:movl :esp :eax)
-				  (:addl :eax :eax)
-				  (:xorl ,(ash (movitz-symbol-hash-key (movitz-read block-name)) 16) :eax)
-				  (:init-lexvar ,lexical-catch-tag-binding
-						:init-with-register :eax
-						:init-with-type t))
-				wrapped-code
-				(list exit-block-label))
-		  :returns block-returns-mode
-		  :functional-p block-no-side-effects-p)))))))))
-
+	      (assert (eq :multiple-values new-returns))
+	      (incf (stack-used block-env) 4)
+	      (setf (num-specials block-env) 1) ; block-env now has one dynamic slot
+	      (compiler-values ()
+		:code (append `((:declare-label-set ,label-set-name (,exit-block-label))
+				;; catcher
+				(:locally (:pushl (:edi (:edi-offset dynamic-env))))
+				(:pushl ',label-set-name)
+				(:locally (:pushl (:edi (:edi-offset unbound-value))))
+				(:pushl :ebp)
+				(:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))
+			      `((:init-lexvar ,save-esp-binding
+					      :init-with-register :esp
+					      :init-with-type t))
+			      new-code
+			      ;; wrapped-code
+			      `(,exit-block-label
+				(:movl (:esp 12) :edx)
+				(:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
+				(:popl :ebp)
+				(:leal (:esp 12) :esp)))
+		:returns :multiple-values
+		:functional-p block-no-side-effects-p))))))))
 
 (define-special-operator return-from (&all all &form form &env env &funobj funobj)
   (destructuring-bind (block-name &optional result-form)
@@ -837,7 +839,8 @@
       (assert block-env (block-name)
 	"Block-name not found for return-from: ~S." block-name)
       (cond
-       ((eq funobj (movitz-environment-funobj block-env))
+       ((and (eq funobj (movitz-environment-funobj block-env))
+	     (null (nth-value 2 (stack-delta env block-env))))
 	(compiler-values-bind (&code return-code &returns return-mode)
 	    (compiler-call #'compile-form
 	      :forward all
@@ -847,12 +850,12 @@
 	    :returns :non-local-exit
 	    :code (append return-code
 			  `((:lexical-control-transfer nil ,return-mode ,env ,block-env))))))
-       ((not (eq funobj (movitz-environment-funobj block-env)))
+       ((not (and (eq funobj (movitz-environment-funobj block-env))
+		  (null (nth-value 2 (stack-delta env block-env)))))
 	(compiler-call #'compile-form-unprotected
 	  :forward all
-	  :form `(muerte.cl:throw
-		     ,(movitz-env-lexical-catch-tag-variable block-env)
-		   ,result-form)))))))
+	  :form `(muerte::exact-throw ,(save-esp-variable block-env)
+				      ,result-form)))))))
 
 (define-special-operator require (&form form)
   (let ((*require-dependency-chain*




From ffjeld at common-lisp.net  Sat Nov 13 14:50:14 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 13 Nov 2004 15:50:14 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/packages.lisp 
Message-ID: <E1CSzEE-0005ry-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
*** empty log message ***
Date: Sat Nov 13 15:50:13 2004
Author: ffjeld

Index: movitz/losp/muerte/packages.lisp
diff -u movitz/losp/muerte/packages.lisp:1.5 movitz/losp/muerte/packages.lisp:1.6
--- movitz/losp/muerte/packages.lisp:1.5	Thu Oct 21 22:50:19 2004
+++ movitz/losp/muerte/packages.lisp	Sat Nov 13 15:50:13 2004
@@ -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.5 2004/10/21 20:50:19 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.6 2004/11/13 14:50:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -172,10 +172,10 @@
 	      ((keywordp symbol)
 	       (format t "~&~W == keyword~%" symbol))
 	      ((fboundp symbol)
-	       (format t "~&~W == function arglist: ~A~%"
+	       (format t "~&~W == function ~:A~%"
 		       symbol (funobj-lambda-list (symbol-function symbol))))
 	      ((boundp symbol)
-	       (format t "~&~W == variable value: ~S~%"
+	       (format t "~&~W == variable ~S~%"
 		       symbol (symbol-value symbol)))
 	      (t (format t "~&~W~%" symbol))))))
     (let ((string (string string)))




From ffjeld at common-lisp.net  Sat Nov 13 16:10:11 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 13 Nov 2004 17:10:11 +0100
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1CT0Tb-0006vj-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Removed the bogus dynamic-unwind primitive-function and special operator.

Date: Sat Nov 13 17:10:10 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.77 movitz/image.lisp:1.78
--- movitz/image.lisp:1.77	Fri Nov 12 17:24:51 2004
+++ movitz/image.lisp	Sat Nov 13 17:10:09 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.77 2004/11/12 16:24:51 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.78 2004/11/13 16:10:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -177,11 +177,6 @@
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-type code-vector-word)
    (dynamic-unwind-next
-    :map-binary-write 'movitz-intern-code-vector
-    :binary-tag :primitive-function
-    :map-binary-read-delayed 'movitz-word-code-vector
-    :binary-type code-vector-word)
-   (dynamic-unwind
     :map-binary-write 'movitz-intern-code-vector
     :binary-tag :primitive-function
     :map-binary-read-delayed 'movitz-word-code-vector




From ffjeld at common-lisp.net  Sat Nov 13 16:10:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 13 Nov 2004 17:10:16 +0100
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1CT0Tg-0006w5-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Removed the bogus dynamic-unwind primitive-function and special operator.

Date: Sat Nov 13 17:10:15 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.43 movitz/special-operators.lisp:1.44
--- movitz/special-operators.lisp:1.43	Fri Nov 12 15:51:44 2004
+++ movitz/special-operators.lisp	Sat Nov 13 17:10:14 2004
@@ -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.43 2004/11/12 14:51:44 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.44 2004/11/13 16:10:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -993,16 +993,6 @@
 				cloaked-code
 				;; pop the result back
 				`((:popl ,protected-register)))))))))))))
-
-(define-special-operator muerte::dynamic-unwind (&form form)
-  (let ((unwind-count (second form)))
-    (check-type unwind-count (integer 0 *))
-    (if (zerop unwind-count)
-	(compiler-values ())
-      (compiler-values ()
-	:returns :nothing
-	:code (append (make-immediate-move unwind-count :ecx)
-		      `((:globally (:call (:edi (:edi-offset dynamic-unwind))))))))))
 
 (define-special-operator muerte::with-local-env (&all all &form form)
   (destructuring-bind ((local-env) sub-form)




From ffjeld at common-lisp.net  Sat Nov 13 16:10:23 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 13 Nov 2004 17:10:23 +0100
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1CT0Tn-0006wR-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Removed the bogus dynamic-unwind primitive-function and special operator.

Date: Sat Nov 13 17:10:22 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.52 movitz/losp/muerte/primitive-functions.lisp:1.53
--- movitz/losp/muerte/primitive-functions.lisp:1.52	Fri Nov 12 15:52:16 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Sat Nov 13 17:10:21 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.52 2004/11/12 14:52:16 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.53 2004/11/13 16:10:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -160,21 +160,6 @@
 and also EDX must be preserved."
   (with-inline-assembly (:returns :nothing)
     ;; Default binding strategy is naive deep binding, so this is a NOP.
-    (:ret)))
-    
-(define-primitive-function dynamic-unwind ()
-  "Unwind ECX dynamic environment slots. Scratch EAX."
-  (with-inline-assembly (:returns :nothing)
-    (:jecxz 'done)
-   loop
-    (:locally (:movl (:edi (:edi-offset dynamic-env)) :eax))
-    (:testl :eax :eax)
-    (:jz '(:sub-program () (:int 255)))	; end of dynamic environment???
-    (:movl (:eax 12) :eax)		; get parent
-    (:locally (:movl :eax (:edi (:edi-offset dynamic-env))))
-    (:decl :ecx)
-    (:jnz 'loop)
-   done
     (:ret)))
     
 (define-primitive-function dynamic-load (symbol)




From ffjeld at common-lisp.net  Sat Nov 13 16:13:03 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 13 Nov 2004 17:13:03 +0100
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CT0WN-0006y0-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fixed make-compiled-lexical-control-transfer to do the right thing
when jumping across dynamic bindings, finally.

Date: Sat Nov 13 17:13:02 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.104 movitz/compiler.lisp:1.105
--- movitz/compiler.lisp:1.104	Wed Nov 10 18:37:20 2004
+++ movitz/compiler.lisp	Sat Nov 13 17:13:01 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.104 2004/11/10 17:37:20 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.105 2004/11/13 16:13:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -5742,9 +5742,8 @@
       (stack-delta from-env to-env)
     (assert stack-distance)
     (assert (null unwind-protects) ()
-      "Lexical unwind-protect not implemented, to-env: ~S." to-env)
-    (when (plusp num-dynamic-slots)
-      (warn "Lexical jump across ~D specials." num-dynamic-slots))
+      "Lexical unwind-protect not implemented, to-env: ~S. (this is not supposed to happen)"
+      to-env)
     (cond
      ((and (eq t stack-distance)
 	   (zerop num-dynamic-slots))
@@ -5762,7 +5761,14 @@
 			:env to-env
 			:result-mode (exit-result-mode to-env)
 			:form `(muerte::with-cloak (,return-mode)
-				 (muerte::dynamic-unwind ,num-dynamic-slots)))
+				 (muerte::with-inline-assembly (:returns :nothing)
+				   ;; Compute target dynamic-env
+				   (:locally (:movl (:edi (:edi-offset dynamic-env)) :eax))
+				   ,@(loop repeat num-dynamic-slots
+					 collect `(:movl (:eax 12) :eax))
+				   (:locally (:call (:edi (:edi-offset dynamic-unwind-next))))
+				   (:locally (:movl :eax (:edi (:edi-offset dynamic-env))))
+				   (:jc '(:sub-program () (:int 63))))))
 		      `((:load-lexical ,(save-esp-variable to-env) :esp)
 			(:jmp ',to-label)))))
      ((zerop num-dynamic-slots)
@@ -5782,7 +5788,14 @@
 			:env to-env
 			:result-mode (exit-result-mode to-env)
 			:form `(muerte::with-cloak (,return-mode)
-				 (muerte::dynamic-unwind ,num-dynamic-slots)))
+				 (muerte::with-inline-assembly (:returns :nothing)
+				   ;; Compute target dynamic-env
+				   (:locally (:movl (:edi (:edi-offset dynamic-env)) :eax))
+				   ,@(loop repeat num-dynamic-slots
+					 collect `(:movl (:eax 12) :eax))
+				   (:locally (:call (:edi (:edi-offset dynamic-unwind-next))))
+				   (:locally (:movl :eax (:edi (:edi-offset dynamic-env))))
+				   (:jc '(:sub-program () (:int 63))))))
 		      (make-compiled-stack-restore stack-distance
 						   (exit-result-mode to-env)
 						   return-mode)




From ffjeld at common-lisp.net  Sun Nov 14 22:57:41 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Nov 2004 23:57:41 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1CTTJV-0008Fq-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Changed the signature of memref-int.

Date: Sun Nov 14 23:57:39 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.26 movitz/losp/los0.lisp:1.27
--- movitz/losp/los0.lisp:1.26	Fri Nov 12 21:55:49 2004
+++ movitz/losp/los0.lisp	Sun Nov 14 23:57:39 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.26 2004/11/12 20:55:49 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.27 2004/11/14 22:57:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -351,9 +351,17 @@
 #+ignore
 (defun test-lexthrow (x)
   (apply (lambda (a b)
-	   (if (plusp a) 0 (return-from test-lexthrow (+ a b))))
+	   (unwind-protect
+	       (if (plusp a) 0 (return-from test-lexthrow (+ a b)))
+	     (warn "To serve and protect!")))
 	 x))
 
+#+ignore
+(defun test-lexgo (x)
+  (let ((*print-base* 2))
+    (return-from test-lexgo (print 123))))
+
+#+ignore
 (defun test-xgo (c x)
   (tagbody
    loop
@@ -1241,10 +1249,10 @@
 			 (progn
 ;;;			   (unless (logbitp 9 (eflags))
 ;;;			     (break "Someone switched off interrupts!"))
-			   (incf (memref-int muerte.x86-pc::*screen* 0 0 :unsigned-byte16 t))
+			   (incf (memref-int muerte.x86-pc::*screen* :type :unsigned-byte16))
 			   (throw 'foo 'inner-peace))
-		       (incf (memref-int muerte.x86-pc::*screen* 0 80 :unsigned-byte16 t)))))
-	(incf (memref-int muerte.x86-pc::*screen* 0 160 :unsigned-byte16 t))))))
+		       (incf (memref-int muerte.x86-pc::*screen* :index 80 :type :unsigned-byte16)))))
+	(incf (memref-int muerte.x86-pc::*screen* :index 160 :type :unsigned-byte16))))))
 
 (defun mumbojumbo ()
   (with-inline-assembly (:returns :multiple-values)
@@ -1354,11 +1362,11 @@
 #+ignore
 (defun ztstring (physical-address)
   (let ((s (make-string (loop for i upfrom 0
-			    until (= 0 (memref-int physical-address 0 i :unsigned-byte8 t))
+			    until (= 0 (memref-int physical-address :index i :type :unsigned-byte8))
 			    finally (return i)))))
     (loop for i from 0 below (length s)
 	do (setf (char s i)
-	     (code-char (memref-int physical-address 0 i :unsigned-byte8 t))))
+	     (code-char (memref-int physical-address :index i :type :unsigned-byte8))))
     s))
 
 (defmacro do-default ((var &rest error-spec) &body init-forms)
@@ -1416,9 +1424,9 @@
 (defun general-protection-handler (vector dit-frame)
   (assert (= vector 13))
   (let ((eip (dit-frame-ref nil dit-frame :eip :unsigned-byte32)))
-    (assert (= #x26 (memref-int eip 0 0 :unsigned-byte8))) ; ES override prefix?
-    (let ((opcode (memref-int eip 1 0 :unsigned-byte8))
-	  (mod/rm (memref-int eip 2 0 :unsigned-byte8)))
+    (assert (= #x26 (memref-int eip :offset 0 :type :unsigned-byte8 :physicalp nil))) ; ES override prefix?
+    (let ((opcode (memref-int eip :offset 1 :type :unsigned-byte8 :physicalp nil))
+	  (mod/rm (memref-int eip :offset 2 :type :unsigned-byte8 :physicalp nil)))
       (if (not (= #x89 opcode))
 	  (interrupt-default-handler vector dit-frame)
 	(let ((value (ecase (ldb (byte 3 3) mod/rm)
@@ -1432,29 +1440,29 @@
 		(case (logand mod/rm #xc7)
 		  (#x40			; (:movl <value> (:eax <disp8>))
 		   (values (dit-frame-ref nil dit-frame :eax)
-			   (memref-int eip 3 0 :signed-byte8)))
+			   (memref-int eip :offset 3 :type :signed-byte8 :physicalp nil)))
 		  (#x43			; (:movl <value> (:ebx <disp8>))
 		   (values (dit-frame-ref nil dit-frame :ebx)
-			   (memref-int eip 3 0 :signed-byte8)))
+			   (memref-int eip :offset 3 :type :signed-byte8 :physicalp nil)))
 		  (#x44			; the disp8/SIB case
-		   (let ((sib (memref-int eip 3 0 :unsigned-byte8)))
+		   (let ((sib (memref-int eip :offset 3 :type :unsigned-byte8 :physicalp nil)))
 		     (case sib
 		       ((#x19 #x0b)
 			(values (dit-frame-ref nil dit-frame :ebx)
 				(+ (dit-frame-ref nil dit-frame :ecx :unsigned-byte8)
-				   (memref-int eip 4 0 :signed-byte8))))
+				   (memref-int eip :offset 4 :type :signed-byte8 :physicalp nil))))
 		       ((#x1a)
 			(values (dit-frame-ref nil dit-frame :ebx)
 				(+ (dit-frame-ref nil dit-frame :edx :unsigned-byte8)
-				   (memref-int eip 4 0 :signed-byte8))))))))
+				   (memref-int eip :offset 4 :type :signed-byte8 :physicalp nil))))))))
 	      (when (not object)
 		(setf (segment-register :es) (segment-register :ds))
 		(break "[~S] With value ~S, unknown movl at ~S: ~S ~S ~S ~S"
 		       dit-frame value eip
-		       (memref-int eip 1 0 :unsigned-byte8)
-		       (memref-int eip 2 0 :unsigned-byte8)
-		       (memref-int eip 3 0 :unsigned-byte8)
-		       (memref-int eip 4 0 :unsigned-byte8)))
+		       (memref-int eip :offset 1 :type :unsigned-byte8 :physicalp nil)
+		       (memref-int eip :offset 2 :type :unsigned-byte8 :physicalp nil)
+		       (memref-int eip :offset 3 :type :unsigned-byte8 :physicalp nil)
+		       (memref-int eip :offset 4 :type :unsigned-byte8 :physicalp nil)))
 	      (check-type object pointer)
 	      (check-type offset fixnum)
 	      (let ((write-barrier *write-barrier*)




From ffjeld at common-lisp.net  Sun Nov 14 22:57:59 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Nov 2004 23:57:59 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1CTTJn-0008GD-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Changed the signature of memref-int.

Date: Sun Nov 14 23:57:46 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.37 movitz/losp/muerte/memref.lisp:1.38
--- movitz/losp/muerte/memref.lisp:1.37	Wed Nov 10 16:30:53 2004
+++ movitz/losp/muerte/memref.lisp	Sun Nov 14 23:57:45 2004
@@ -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.37 2004/11/10 15:30:53 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.38 2004/11/14 22:57:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -759,8 +759,9 @@
 	 (setf (memref object offset :index index :localp t) value)
        (setf (memref object offset :index index :localp nil) value)))))
 
-(define-compiler-macro memref-int (&whole form &environment env address offset index type
-				   &optional physicalp)
+(define-compiler-macro memref-int
+    (&whole form address &key (offset 0) (index 0) (type :unsigned-byte32) (physicalp t)
+     &environment env)
   (if (or (not (movitz:movitz-constantp type physicalp))
 	  (not (movitz:movitz-constantp physicalp env)))
       form
@@ -793,9 +794,6 @@
 		(:shll 2 :ecx)
 		(:addl :ebx :eax)
 		(:into)
-;;;		(:testb ,(mask-field (byte (+ 2 movitz::+movitz-fixnum-shift+) 0) -1)
-;;;			:al)
-;;;		(:jnz '(:sub-program () (:int 63)))
 		(:addl :eax :ecx)
 		(:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address
 		(,prefixes :movl (:ecx) :ecx)))))
@@ -852,31 +850,32 @@
 		    (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address
 		    (,prefixes :movzxw (:ecx) :ecx)))))))))))
 
-(defun memref-int (address offset index type &optional physicalp)
+(defun memref-int (address &key (offset 0) (index 0) (type :unsigned-byte32) (physicalp t))
   (cond
-   ((not physicalp)
+   (physicalp
     (ecase type
       (:lisp
-       (memref-int address offset index :lisp))
+       (memref-int address :offset offset :index index))
       (:unsigned-byte8
-       (memref-int address offset index :unsigned-byte8))
+       (memref-int address :offset offset :index index :type :unsigned-byte8))
       (:unsigned-byte16
-       (memref-int address offset index :unsigned-byte16))
+       (memref-int address :offset offset :index index :type :unsigned-byte16))
       (:unsigned-byte32
-       (memref-int address offset index :unsigned-byte32))))
-   (physicalp
+       (memref-int address :offset offset :index index))))
+   ((not physicalp)
     (ecase type
       (:lisp
-       (memref-int address offset index :lisp t))
+       (memref-int address :offset offset :index index :physicalp nil))
       (:unsigned-byte8
-       (memref-int address offset index :unsigned-byte8 t))
+       (memref-int address :offset offset :index index :type :unsigned-byte8 :physicalp nil))
       (:unsigned-byte16
-       (memref-int address offset index :unsigned-byte16 t))
+       (memref-int address :offset offset :index index :type :unsigned-byte16 :physicalp nil))
       (:unsigned-byte32
-       (memref-int address offset index :unsigned-byte32 t))))))
+       (memref-int address :offset offset :index index :physicalp nil))))))
 
-(define-compiler-macro (setf memref-int) (&whole form &environment env value address offset index type
-					  &optional physicalp)
+(define-compiler-macro (setf memref-int)
+    (&whole form value address &key (offset 0) (index 0) (type :type) (physicalp t)
+     &environment env)
   (if (or (not (movitz:movitz-constantp type env))
 	  (not (movitz:movitz-constantp physicalp env)))
       (progn
@@ -977,20 +976,25 @@
 		    (:leal ((:eax ,movitz:+movitz-fixnum-factor+)) :eax)
 		    (:cld)))))))))))
 
-(defun (setf memref-int) (value address offset index type &optional physicalp)
+(defun (setf memref-int)
+    (value address &key (offset 0) (index 0) (type :unsigned-byte32) (physicalp t))
   (cond
-   ((not physicalp)
+   (physicalp
     (ecase type
       (:unsigned-byte8
-       (setf (memref-int address offset index :unsigned-byte8) value))
+       (setf (memref-int address :offset offset :index index :type :unsigned-byte8)
+	 value))
       (:unsigned-byte16
-       (setf (memref-int address offset index :unsigned-byte16) value))))
-   (physicalp
+       (setf (memref-int address :offset offset :index index :type :unsigned-byte16)
+	 value))))
+   ((not physicalp)
     (ecase type
       (:unsigned-byte8
-       (setf (memref-int address offset index :unsigned-byte8 t) value))
+       (setf (memref-int address :offset offset :index index :type :unsigned-byte8 :physicalp nil)
+	 value))
       (:unsigned-byte16
-       (setf (memref-int address offset index :unsigned-byte16 t) value))))))
+       (setf (memref-int address :offset offset :index index :type :unsigned-byte16 :physicalp nil)
+	 value))))))
 
 (defun memcopy (object-1 object-2 offset index-1 index-2 count type)
   (ecase type




From ffjeld at common-lisp.net  Sun Nov 14 22:58:07 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Nov 2004 23:58:07 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp 
Message-ID: <E1CTTJv-0008GW-00@common-lisp.net>

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

Modified Files:
	pci.lisp 
Log Message:
Changed the signature of memref-int.

Date: Sun Nov 14 23:58:02 2004
Author: ffjeld

Index: movitz/losp/x86-pc/pci.lisp
diff -u movitz/losp/x86-pc/pci.lisp:1.3 movitz/losp/x86-pc/pci.lisp:1.4
--- movitz/losp/x86-pc/pci.lisp:1.3	Wed May  5 10:24:38 2004
+++ movitz/losp/x86-pc/pci.lisp	Sun Nov 14 23:58:02 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Dec 14 22:33:42 2003
 ;;;;                
-;;;; $Id: pci.lisp,v 1.3 2004/05/05 08:24:38 ffjeld Exp $
+;;;; $Id: pci.lisp,v 1.4 2004/11/14 22:58:02 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -20,12 +20,11 @@
 
 (defun find-bios32 ()
   (loop for bios32 from #xe0000 to #xffff0 by 16
-      if (and (= (memref-int bios32 0 0 :unsigned-byte16 t) #x335f)
-	      (= (memref-int bios32 0 1 :unsigned-byte16 t) #x5f32)
+      if (and (= (memref-int bios32) #x5f32335f)
 	      (loop with checksum = 0
-		  ;; initially (warn "PCI magic found at #x~X" bios32)
-		  as i from 0 below (* 16 (memref-int bios32 0 9 :unsigned-byte8 t))
+				    ;; initially (warn "PCI magic found at #x~X" bios32)
+		  as i from 0 below (* 16 (memref-int bios32 :offset 9 :type :unsigned-byte8))
 		  do (incf checksum
-			   (memref-int bios32 0 i :unsigned-byte8 t))
+			   (memref-int bios32 :offset i :type :unsigned-byte8))
 		  finally (return (= 0 (ldb (byte 8 0 ) checksum)))))
       return bios32))




From ffjeld at common-lisp.net  Sun Nov 14 22:58:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Nov 2004 23:58:18 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/textmode-console.lisp 
Message-ID: <E1CTTK6-0008Gy-00@common-lisp.net>

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

Modified Files:
	textmode-console.lisp 
Log Message:
Changed the signature of memref-int.

Date: Sun Nov 14 23:58:16 2004
Author: ffjeld

Index: movitz/losp/x86-pc/textmode-console.lisp
diff -u movitz/losp/x86-pc/textmode-console.lisp:1.3 movitz/losp/x86-pc/textmode-console.lisp:1.4
--- movitz/losp/x86-pc/textmode-console.lisp:1.3	Mon Jan 19 12:23:52 2004
+++ movitz/losp/x86-pc/textmode-console.lisp	Sun Nov 14 23:58:16 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul  8 15:13:24 2003
 ;;;;                
-;;;; $Id: textmode-console.lisp,v 1.3 2004/01/19 11:23:52 ffjeld Exp $
+;;;; $Id: textmode-console.lisp,v 1.4 2004/11/14 22:58:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -62,14 +62,14 @@
 		 (* line (console-width console) 2)
 		 (* from-column 2))))
     (dotimes (i (- (console-width console) from-column))
-      (setf (memref-int dest 0 i :unsigned-byte16) #x0720))
+      (setf (memref-int dest :index i :type :unsigned-byte16) #x0720))
     nil))
 
 (defmethod (setf console-char) (character (console vga-text-console) x y)
   (when (and (below x (console-width console))
 	     (below y (console-height console)))
     (let ((index (+ x (* y (stride console)))))
-      (setf (memref-int (base console) 0 index :unsigned-byte16)
+      (setf (memref-int (base console) :index index :type :unsigned-byte16)
 	(logior (ash (color console) 8) (char-code character)))))
   character)
 
@@ -77,7 +77,7 @@
   (when (and (below x (console-width console))
 	     (below y (console-height console)))
     (let* ((index (+ x (* y (stride console))))
-	   (code (memref-int (base console) 0 index :unsigned-byte16)))
+	   (code (memref-int (base console) :index index :type :unsigned-byte16)))
       (code-char (ldb (byte 8 0) code)))))
 
 (defmethod put-string ((console vga-text-console) string x y
@@ -88,7 +88,7 @@
 	for column from x below (console-width console)
 	for i from start below end
 	as character = (char string i)
-	do (setf (memref-int base 0 cursor :unsigned-byte16)
+	do (setf (memref-int base :index cursor :type :unsigned-byte16)
 	     (logior color (char-code character)))))
   string)
 
@@ -97,7 +97,7 @@
     (loop with base = (base console)
 	for index upfrom (+ x (* y (stride console)))
 	for column from x below (console-width console)
-	do (setf (memref-int base 0 index :unsigned-byte16)
+	do (setf (memref-int base :index index :type :unsigned-byte16)
 	     #x0720))))
 
 (defmethod scroll-down ((console vga-text-console))
@@ -106,8 +106,8 @@
       for row from (base console) by ystride
       do (loop with next-row = (+ row ystride)
 	     for x below (console-width console)
-	     do (setf (memref-int row 0 x :unsigned-byte16)
-		  (memref-int next-row 0 x :unsigned-byte16))))
+	     do (setf (memref-int row :index x :type :unsigned-byte16)
+		  (memref-int next-row :index x :type :unsigned-byte16))))
   nil)
 
 (defmethod stream-read-char ((stream vga-text-console))




From ffjeld at common-lisp.net  Sun Nov 14 22:58:26 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Nov 2004 23:58:26 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/textmode.lisp 
Message-ID: <E1CTTKE-0008HO-00@common-lisp.net>

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

Modified Files:
	textmode.lisp 
Log Message:
Changed the signature of memref-int.

Date: Sun Nov 14 23:58:24 2004
Author: ffjeld

Index: movitz/losp/x86-pc/textmode.lisp
diff -u movitz/losp/x86-pc/textmode.lisp:1.12 movitz/losp/x86-pc/textmode.lisp:1.13
--- movitz/losp/x86-pc/textmode.lisp:1.12	Thu Sep 23 13:05:51 2004
+++ movitz/losp/x86-pc/textmode.lisp	Sun Nov 14 23:58:23 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Thu Nov  9 15:38:56 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: textmode.lisp,v 1.12 2004/09/23 11:05:51 ffjeld Exp $
+;;;; $Id: textmode.lisp,v 1.13 2004/11/14 22:58:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -95,10 +95,9 @@
 	 (when (>= x *screen-width*)
 	   (textmode-write-char #\newline)
 	   (setf x *cursor-x* y *cursor-y*))
-	 (let ((index (+ x (* y *screen-stride*))))
-	   (setf (memref-int *screen* 0 index :unsigned-byte16 t)
-	     (logior #x0700 (char-code c)))
-	   (move-vga-cursor (setf *cursor-x* (1+ x)) y)))))
+	 (setf (memref-int *screen* :index (+ x (* y *screen-stride*)) :type :unsigned-byte16)
+	   (logior #x0700 (char-code c)))
+	 (move-vga-cursor (setf *cursor-x* (1+ x)) y))))
   nil)
 
 (defun textmode-copy-line (destination source count)
@@ -137,19 +136,19 @@
 (defun textmode-clear-line (from-column line)
   (let ((dest (+ *screen* (* line *screen-width* 2) (* from-column 2))))
     (dotimes (i (- *screen-width* from-column))
-      (setf (memref-int dest 0 i :unsigned-byte16 t) #x0720))))
+      (setf (memref-int dest :index i :type :unsigned-byte16) #x0720))))
       
 (defun write-word (word)
   (let ((dest (+ *screen* (* *cursor-x* 2) (* *cursor-y* *screen-width* 2))))
-    (setf (memref-int dest 0 0 :unsigned-byte16 t) #x0723
-	  (memref-int dest 0 1 :unsigned-byte16 t) #x0778)
+    (setf (memref-int dest :index 0 :type :unsigned-byte16) #x0723
+	  (memref-int dest :index 1 :type :unsigned-byte16) #x0778)
     (write-word-lowlevel word (+ dest 4))
     (textmode-write-char #\newline)))
 
 (defun write-word-nl (word)
   (let ((dest (+ *screen* (* *cursor-x* 2) (* *cursor-y* 160))))
-    (setf (memref-int dest 0 0 :unsigned-byte16 t) #x0723
-	  (memref-int dest 0 1 :unsigned-byte16 t) #x0778)
+    (setf (memref-int dest :index 0 :type :unsigned-byte16) #x0723
+	  (memref-int dest :index 1 :type :unsigned-byte16) #x0778)
     (write-word-lowlevel word (+ dest 4))))
 
 (defun write-word-bottom (word)




From ffjeld at common-lisp.net  Sun Nov 14 22:58:34 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Nov 2004 23:58:34 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/vga.lisp 
Message-ID: <E1CTTKM-0008Ho-00@common-lisp.net>

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

Modified Files:
	vga.lisp 
Log Message:
Changed the signature of memref-int.

Date: Sun Nov 14 23:58:33 2004
Author: ffjeld

Index: movitz/losp/x86-pc/vga.lisp
diff -u movitz/losp/x86-pc/vga.lisp:1.5 movitz/losp/x86-pc/vga.lisp:1.6
--- movitz/losp/x86-pc/vga.lisp:1.5	Wed Apr 21 18:24:16 2004
+++ movitz/losp/x86-pc/vga.lisp	Sun Nov 14 23:58:33 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 25 14:08:20 2001
 ;;;;                
-;;;; $Id: vga.lisp,v 1.5 2004/04/21 16:24:16 ffjeld Exp $
+;;;; $Id: vga.lisp,v 1.6 2004/11/14 22:58:33 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -314,7 +314,7 @@
 
 (defun vmemwr (dst-off src start end)
   (loop for i from start below end as dst upfrom dst-off
-      do (setf (memref-int (vga-memory-map) 0 dst :unsigned-byte8 t)
+      do (setf (memref-int (vga-memory-map) :index dst :type :unsigned-byte8)
 	   (aref src i)))
   (values))
 




From ffjeld at common-lisp.net  Mon Nov 15 14:42:17 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 15 Nov 2004 15:42:17 +0100
Subject: [movitz-cvs] CVS update: movitz/movitz.lisp 
Message-ID: <E1CTi3d-0005aB-00@common-lisp.net>

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

Modified Files:
	movitz.lisp 
Log Message:
*** empty log message ***
Date: Mon Nov 15 15:42:16 2004
Author: ffjeld

Index: movitz/movitz.lisp
diff -u movitz/movitz.lisp:1.9 movitz/movitz.lisp:1.10
--- movitz/movitz.lisp:1.9	Thu Jul 29 02:13:09 2004
+++ movitz/movitz.lisp	Mon Nov 15 15:42:15 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Oct  9 20:52:58 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: movitz.lisp,v 1.9 2004/07/29 00:13:09 ffjeld Exp $
+;;;; $Id: movitz.lisp,v 1.10 2004/11/15 14:42:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -31,7 +31,7 @@
     (ldb (byte 32 0)
 	 (- +code-vector-word-offset+)))
 
-(defconstant +movitz-multiple-values-limit+ 127)
+(defvar +movitz-multiple-values-limit+ 63)
 
 (defvar *bq-level* 0)
 (defvar *default-image-init-file* #p"losp/los0.lisp")




From ffjeld at common-lisp.net  Mon Nov 15 23:08:58 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 16 Nov 2004 00:08:58 +0100
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CTpxy-00050g-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Disable optimize-code-dirties, because the optimization it performed
wasn't safe.

Date: Tue Nov 16 00:08:57 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.105 movitz/compiler.lisp:1.106
--- movitz/compiler.lisp:1.105	Sat Nov 13 17:13:01 2004
+++ movitz/compiler.lisp	Tue Nov 16 00:08:57 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.105 2004/11/13 16:13:01 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.106 2004/11/15 23:08:57 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1457,7 +1457,9 @@
   "These optimizations may rearrange register usage in a way that is incompatible
 with other optimizations that track register usage. So this is performed just once,
 initially."
-  (labels
+  unoptimized-code
+  #+ignore
+  (labels				; This stuff doesn't work..
       ((explain (always format &rest args)
 	 (when (or always *explain-peephole-optimizations*)
 	   (warn "Peephole: ~?~&----------------------------" format args)))
@@ -1488,16 +1490,15 @@
 	as i1 = (first pc)		; current instruction, collected by default.
 	and i2 = (second pc) and i3 = (third pc)
 	while pc
- 	do (cond
-	    ((let ((regx (register-operand (twop-src i1 :movl)))
-		   (regy (register-operand (twop-dst i1 :movl))))
-	       (and regx regy
-		    (eq regx (twop-dst i2 :movl))
-		    (eq regx (twop-src i3 :cmpl))
-		    (eq regy (twop-dst i3 :cmpl))))
-	     (setq p (list `(:cmpl ,(twop-src i2) ,(twop-src i1)))
-		   next-pc (nthcdr 3 pc))
-	     (explain nil "4: ~S for ~S" p (subseq pc 0 4))))
+ 	do (let ((regx (register-operand (twop-src i1 :movl)))
+		 (regy (register-operand (twop-dst i1 :movl))))
+	     (when (and regx regy
+			(eq regx (twop-dst i2 :movl))
+			(eq regx (twop-src i3 :cmpl))
+			(eq regy (twop-dst i3 :cmpl)))
+	       (setq p (list `(:cmpl ,(twop-src i2) ,regx) i1)
+		     next-pc (nthcdr 3 pc))
+	       (explain t "4: ~S for ~S [regx ~S, regy ~S]" p (subseq pc 0 5) regx regy)))
 	nconc p)))
 
 (defun optimize-code-internal (unoptimized-code recursive-count &rest key-args




From ffjeld at common-lisp.net  Mon Nov 15 23:10:25 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 16 Nov 2004 00:10:25 +0100
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1CTpzN-00051I-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
Change the compilation of unwind-protect to only use a single
dynamic-env entry.

Date: Tue Nov 16 00:10:24 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.34 movitz/special-operators-cl.lisp:1.35
--- movitz/special-operators-cl.lisp:1.34	Sat Nov 13 15:49:51 2004
+++ movitz/special-operators-cl.lisp	Tue Nov 16 00:10:24 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.34 2004/11/13 14:49:51 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.35 2004/11/15 23:10:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1235,15 +1235,9 @@
 	  :returns :multiple-values
 	  :code (append
 		 ;; install default continuation dynamic-env..
-		 `((:locally (:pushl (:edi (:edi-offset dynamic-env)))) ; uplink
-		   (:declare-label-set ,continue-label (,continue))
-		   (:pushl ',continue-label)
-		   (:locally (:pushl (:edi (:edi-offset unbound-value))))
-		   (:pushl :ebp)
-		   (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))
-		 ;; install unwind-protect dynamic-env..
 		 `((:locally (:pushl (:edi (:edi-offset dynamic-env))))
 		   (:declare-label-set ,cleanup-label (,cleanup-entry))
+		   (:declare-label-set ,continue-label (,continue))
 		   (:pushl ',cleanup-label) ; jumper index
 		   (:globally (:pushl (:edi (:edi-offset unwind-protect-tag)))) ; tag
 		   (:pushl :ebp)	; stack-frame
@@ -1256,13 +1250,14 @@
 		   :result-mode :multiple-values
 		   :form protected-form)
 		 ;; From now on, take care not to touch current-values from protected-form.
-		 `((:leal (:esp 16) :edx) ; default final continuation
-		   (:locally (:movl :edx (:edi (:edi-offset raw-scratch0))))
+		 `((:locally (:movl :esp (:edi (:edi-offset raw-scratch0))))
 		   ,cleanup-entry
-		   (:movl (:esp 12) :edx) ; pop out of unwind-protect
-		   (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
-		   (:popl :ebp)
-		   (:leal (:esp 12) :esp)
+
+		   ;; Modify unwind-protect dyn-env-entry to be normal continuation
+		   (:locally (:movl (:edi (:edi-offset unbound-value)) :edx))
+		   (:movl :edx (:esp 4)) ; not unwind-protect-tag
+		   (:movl ',continue-label (:esp 8)) ; new jumper index
+		   
 		   (:locally (:pushl (:edi (:edi-offset raw-scratch0))))) ; push final-continuation
 		 ;; Execute cleanup-forms.
 		 (compiler-call #'compile-form-unprotected
@@ -1295,7 +1290,6 @@
 		   (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
 		   (:popl :ebp)
 		   (:leal (:esp 12) :esp))))))))
-
 
 (define-special-operator if (&all all &form form &env env &result-mode result-mode)
   (destructuring-bind (test-form then-form &optional else-form)




From ffjeld at common-lisp.net  Wed Nov 17 13:32:48 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 17 Nov 2004 14:32:48 +0100
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CUPvU-000649-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Renamed dynamic-load to dynamic-variable-lookup, and dynamic-store to
dynamic-variable-store.

Date: Wed Nov 17 14:32:47 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.106 movitz/compiler.lisp:1.107
--- movitz/compiler.lisp:1.106	Tue Nov 16 00:08:57 2004
+++ movitz/compiler.lisp	Wed Nov 17 14:32:46 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.106 2004/11/15 23:08:57 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.107 2004/11/17 13:32:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -5602,7 +5602,7 @@
 	  :modifies nil
 	  :final-form form
 	  :code `((:load-constant ,form :eax)
-		  (:call (:edi ,(global-constant-offset 'dynamic-load))))))
+		  (:call (:edi ,(global-constant-offset 'dynamic-variable-lookup))))))
        (t (check-type binding dynamic-binding)
 	  (compiler-values ()
 	    :returns :eax
@@ -5610,7 +5610,7 @@
 	    :modifies nil
 	    :final-form form
 	    :code `((:load-constant ,form :eax)
-		    (:call (:edi ,(global-constant-offset 'dynamic-load))))))))))
+		    (:call (:edi ,(global-constant-offset 'dynamic-variable-lookup))))))))))
 
 (define-compiler compile-lambda-form (&form form)
   "3.1.2.2.4 Lambda Forms"




From ffjeld at common-lisp.net  Wed Nov 17 13:33:00 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 17 Nov 2004 14:33:00 +0100
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1CUPvg-00064U-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Renamed dynamic-load to dynamic-variable-lookup, and dynamic-store to
dynamic-variable-store.

Date: Wed Nov 17 14:32:55 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.78 movitz/image.lisp:1.79
--- movitz/image.lisp:1.78	Sat Nov 13 17:10:09 2004
+++ movitz/image.lisp	Wed Nov 17 14:32:54 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.78 2004/11/13 16:10:09 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.79 2004/11/17 13:32:54 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -161,17 +161,17 @@
     :map-binary-write 'movitz-intern-code-vector
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-tag :primitive-function)
-   (dynamic-load-unprotected
+   (dynamic-variable-lookup-unbound
     :map-binary-write 'movitz-intern-code-vector
     :binary-tag :primitive-function
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-type code-vector-word)
-   (dynamic-load
+   (dynamic-variable-lookup
     :map-binary-write 'movitz-intern-code-vector
     :binary-tag :primitive-function
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-type code-vector-word)
-   (dynamic-store
+   (dynamic-variable-store
     :map-binary-write 'movitz-intern-code-vector
     :binary-tag :primitive-function
     :map-binary-read-delayed 'movitz-word-code-vector




From ffjeld at common-lisp.net  Wed Nov 17 13:33:08 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 17 Nov 2004 14:33:08 +0100
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1CUPvo-00064o-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
Renamed dynamic-load to dynamic-variable-lookup, and dynamic-store to
dynamic-variable-store.

Date: Wed Nov 17 14:33:03 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.35 movitz/special-operators-cl.lisp:1.36
--- movitz/special-operators-cl.lisp:1.35	Tue Nov 16 00:10:24 2004
+++ movitz/special-operators-cl.lisp	Wed Nov 17 14:33:03 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.35 2004/11/15 23:10:24 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.36 2004/11/17 13:33:03 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -623,7 +623,7 @@
 				      :form value-form
 				      :result-mode :ebx)
 				    `((:load-constant ,var :eax)
-				      (:globally (:call (:edi (:edi-offset dynamic-store)))))))))))
+				      (:locally (:call (:edi (:edi-offset dynamic-variable-store)))))))))))
       (compiler-values ()
 	:code code
 	:returns last-returns
@@ -1253,11 +1253,11 @@
 		 `((:locally (:movl :esp (:edi (:edi-offset raw-scratch0))))
 		   ,cleanup-entry
 
-		   ;; Modify unwind-protect dyn-env-entry to be normal continuation
+		   ;; Now (?), modify unwind-protect dyn-env-entry to be normal continuation
 		   (:locally (:movl (:edi (:edi-offset unbound-value)) :edx))
 		   (:movl :edx (:esp 4)) ; not unwind-protect-tag
 		   (:movl ',continue-label (:esp 8)) ; new jumper index
-		   
+
 		   (:locally (:pushl (:edi (:edi-offset raw-scratch0))))) ; push final-continuation
 		 ;; Execute cleanup-forms.
 		 (compiler-call #'compile-form-unprotected
@@ -1274,8 +1274,14 @@
 			      (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax))
 			      (:store-lexical ,next-continuation-step-binding :eax :type t))
 			    , at cleanup-forms))
-		 `((:load-lexical ,next-continuation-step-binding :edx)
-		   (:locally (:popl (:edi (:edi-offset raw-scratch0)))) ; pop final continuation
+		 `((:locally (:popl (:edi (:edi-offset raw-scratch0)))) ; pop final continuation
+		   
+;;;		   ;; Now (?), modify unwind-protect dyn-env-entry to be normal continuation
+;;;		   (:locally (:movl (:edi (:edi-offset unbound-value)) :edx))
+;;;		   (:movl :edx (:esp 4)) ; not unwind-protect-tag
+;;;		   (:movl ',continue-label (:esp 8)) ; new jumper index
+
+		   (:load-lexical ,next-continuation-step-binding :edx)
 		   (:locally (:movl :esi (:edi (:edi-offset scratch1))))
 		   (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
 		   (:movl :edx :esp)	; enter non-local jump stack mode (possibly).




From ffjeld at common-lisp.net  Wed Nov 17 13:33:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 17 Nov 2004 14:33:18 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1CUPvy-00065P-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Renamed dynamic-load to dynamic-variable-lookup, and dynamic-store to
dynamic-variable-store.

Date: Wed Nov 17 14:33:16 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.27 movitz/losp/los0.lisp:1.28
--- movitz/losp/los0.lisp:1.27	Sun Nov 14 23:57:39 2004
+++ movitz/losp/los0.lisp	Wed Nov 17 14:33:11 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.27 2004/11/14 22:57:39 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.28 2004/11/17 13:33:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -53,6 +53,10 @@
 (defun test1 ()
   (unwind-protect 0 (the integer 1)))
 
+(defun x (bios32)
+  (warn "X: ~S" (memref-int bios32))
+  (warn "X: ~S" (= (memref-int bios32) #x5f32335f)))
+
 (defun test2 ()
   (funcall
    (compile
@@ -1579,7 +1583,7 @@
     (:movl :ecx :eax)
     (:ret)))
 
-(define-primitive-function dynamic-load-shallow (symbol)
+(define-primitive-function dynamic-variable-lookup-shallow (symbol)
   "Load the dynamic value of SYMBOL into EAX."
   (with-inline-assembly (:returns :multiple-values)
     (:movl (:eax (:offset movitz-symbol value)) :eax)
@@ -1587,13 +1591,13 @@
     (:je '(:sub-program (unbound) (:int 99)))
     (:ret)))
 
-(define-primitive-function dynamic-load-unprotected-shallow (symbol)
+(define-primitive-function dynamic-variable-lookup-unbound-shallow (symbol)
   "Load the dynamic value of SYMBOL into EAX."
   (with-inline-assembly (:returns :multiple-values)
     (:movl (:eax (:offset movitz-symbol value)) :eax)
     (:ret)))
 
-(define-primitive-function dynamic-store-shallow (symbol value)
+(define-primitive-function dynamic-variable-store-shallow (symbol value)
   "Store VALUE (ebx) in the dynamic binding of SYMBOL (eax).
    Preserves EBX and EAX."
   (with-inline-assembly (:returns :multiple-values)
@@ -1610,9 +1614,9 @@
       (list (install muerte:dynamic-variable-install dynamic-variable-install-shallow)
 	    (install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow)
 	    (install muerte::dynamic-unwind-next dynamic-unwind-next-shallow)
-	    (install muerte::dynamic-store dynamic-store-shallow)
-	    (install muerte::dynamic-load-unprotected dynamic-load-unprotected-shallow)
-	    (prog1 (install muerte::dynamic-load dynamic-load-shallow)
+	    (install muerte::dynamic-variable-store dynamic-variable-store-shallow)
+	    (install muerte::dynamic-variable-lookup-unbound dynamic-variable-lookup-unbound-shallow)
+	    (prog1 (install muerte::dynamic-variable-lookup dynamic-variable-lookup-shallow)
 	      (labels ((install-shallow-env (env)
 			 "We use this local function in order to install dynamic-env slots
                           in reverse order, by depth-first recursion."




From ffjeld at common-lisp.net  Wed Nov 17 13:33:31 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 17 Nov 2004 14:33:31 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1CUPwB-00065p-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Renamed dynamic-load to dynamic-variable-lookup, and dynamic-store to
dynamic-variable-store.

Date: Wed Nov 17 14:33:27 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.45 movitz/losp/muerte/basic-macros.lisp:1.46
--- movitz/losp/muerte/basic-macros.lisp:1.45	Fri Nov 12 15:52:05 2004
+++ movitz/losp/muerte/basic-macros.lisp	Wed Nov 17 14:33:25 2004
@@ -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.45 2004/11/12 14:52:05 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.46 2004/11/17 13:33:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1078,7 +1078,7 @@
        (:leal (:eax ,(- (movitz:tag :symbol))) :ecx)
        (:testb 7 :cl)
        (:jne '(:sub-program () (:int 66)))
-       (:call-local-pf dynamic-load-unprotected)
+       (:call-local-pf dynamic-variable-lookup-unbound)
        (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax)))))
 
 (defmacro define-global-variable (name init-form &optional docstring)




From ffjeld at common-lisp.net  Wed Nov 17 13:33:39 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 17 Nov 2004 14:33:39 +0100
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1CUPwJ-00066F-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Renamed dynamic-load to dynamic-variable-lookup, and dynamic-store to
dynamic-variable-store.

Date: Wed Nov 17 14:33:34 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.53 movitz/losp/muerte/primitive-functions.lisp:1.54
--- movitz/losp/muerte/primitive-functions.lisp:1.53	Sat Nov 13 17:10:21 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Wed Nov 17 14:33:34 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.53 2004/11/13 16:10:21 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.54 2004/11/17 13:33:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -162,7 +162,7 @@
     ;; Default binding strategy is naive deep binding, so this is a NOP.
     (:ret)))
     
-(define-primitive-function dynamic-load (symbol)
+(define-primitive-function dynamic-variable-lookup (symbol)
   "Load the dynamic value of SYMBOL into EAX."
   (with-inline-assembly (:returns :multiple-values)
     (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx))
@@ -194,7 +194,7 @@
     (:je '(:sub-program (unbound) (:int 99)))
     (:ret)))
 
-(define-primitive-function dynamic-load-unprotected (symbol)
+(define-primitive-function dynamic-variable-lookup-unbound (symbol)
   "Load the dynamic value of SYMBOL into EAX. If unbound, return unbound-value."
   (with-inline-assembly (:returns :multiple-values)
     (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx))
@@ -220,7 +220,7 @@
      :movl (:eax (:offset movitz-symbol value)) :eax)
     (:ret)))
 
-(define-primitive-function dynamic-store (symbol value)
+(define-primitive-function dynamic-variable-store (symbol value)
   "Store VALUE (ebx) in the dynamic binding of SYMBOL (eax).
    Preserves EBX and EAX."
   (with-inline-assembly (:returns :multiple-values)




From ffjeld at common-lisp.net  Wed Nov 17 13:33:47 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 17 Nov 2004 14:33:47 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp 
Message-ID: <E1CUPwR-00066X-00@common-lisp.net>

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

Modified Files:
	symbols.lisp 
Log Message:
Renamed dynamic-load to dynamic-variable-lookup, and dynamic-store to
dynamic-variable-store.

Date: Wed Nov 17 14:33:42 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.23 movitz/losp/muerte/symbols.lisp:1.24
--- movitz/losp/muerte/symbols.lisp:1.23	Thu Nov 11 20:25:25 2004
+++ movitz/losp/muerte/symbols.lisp	Wed Nov 17 14:33:42 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 23:55:41 2001
 ;;;;                
-;;;; $Id: symbols.lisp,v 1.23 2004/11/11 19:25:25 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.24 2004/11/17 13:33:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -45,14 +45,14 @@
     (symbol
      (with-inline-assembly (:returns :eax)
        (:compile-form (:result-mode :eax) symbol)
-       (:call-local-pf dynamic-load)))))
+       (:call-local-pf dynamic-variable-lookup)))))
 
 (defun %unbounded-symbol-value (symbol)
   "Return the symbol's value without checking if it's bound or not."
   (check-type symbol symbol)
   (with-inline-assembly (:returns :eax)
     (:compile-form (:result-mode :eax) symbol)
-    (:call-local-pf dynamic-load-unprotected)
+    (:call-local-pf dynamic-variable-lookup-unbound)
    done))
 
 (defun (setf symbol-value) (value symbol)
@@ -63,7 +63,7 @@
      (with-inline-assembly (:returns :ebx)
        (:compile-form (:result-mode :eax) symbol)
        (:compile-form (:result-mode :ebx) value)
-       (:call-local-pf dynamic-store)))))
+       (:call-local-pf dynamic-variable-store)))))
 
 (defun set (symbol value)
   (setf (symbol-value symbol) value))




From ffjeld at common-lisp.net  Wed Nov 17 14:02:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 17 Nov 2004 15:02:20 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1CUQO4-0006Yl-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Added deinstall-shallow-binding, so we can flip back and forth between
shallow and deep binding at any time.

Date: Wed Nov 17 15:02:19 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.28 movitz/losp/los0.lisp:1.29
--- movitz/losp/los0.lisp:1.28	Wed Nov 17 14:33:11 2004
+++ movitz/losp/los0.lisp	Wed Nov 17 15:02:18 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.28 2004/11/17 13:33:11 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.29 2004/11/17 14:02:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1605,31 +1605,52 @@
     (:ret)))
 
 (defun install-shallow-binding (&key quiet)
+  (unless quiet
+    (warn "Installing shallow-binding strategy.."))
   (without-interrupts
-    (unless quiet
-      (warn "Installing shallow-binding strategy.."))
     (macrolet ((install (slot function)
 		 `(prog1 (cons ',slot (%run-time-context-slot ',slot))
 		    (setf (%run-time-context-slot ',slot) (symbol-value ',function)))))
-      (list (install muerte:dynamic-variable-install dynamic-variable-install-shallow)
-	    (install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow)
-	    (install muerte::dynamic-unwind-next dynamic-unwind-next-shallow)
-	    (install muerte::dynamic-variable-store dynamic-variable-store-shallow)
-	    (install muerte::dynamic-variable-lookup-unbound dynamic-variable-lookup-unbound-shallow)
-	    (prog1 (install muerte::dynamic-variable-lookup dynamic-variable-lookup-shallow)
-	      (labels ((install-shallow-env (env)
-			 "We use this local function in order to install dynamic-env slots
-                          in reverse order, by depth-first recursion."
-			 (unless (eq 0 env)
-			   (install-shallow-env (memref env 12))
-			   (let ((name (memref env 0)))
-			     (when (symbolp name)
-			       (setf (memref env 4)
-				 (%symbol-global-value name))
-			       (setf (%symbol-global-value name)
-				 (memref env 8)))))))
-		(install-shallow-env (load-global-constant dynamic-env
-							   :thread-local t))))))))
+      (prog1
+	  (list (install muerte:dynamic-variable-install dynamic-variable-install-shallow)
+		(install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow)
+		(install muerte::dynamic-unwind-next dynamic-unwind-next-shallow)
+		(install muerte::dynamic-variable-store dynamic-variable-store-shallow)
+		(install muerte::dynamic-variable-lookup-unbound dynamic-variable-lookup-unbound-shallow)
+		(install muerte::dynamic-variable-lookup dynamic-variable-lookup-shallow))
+	(labels ((install-shallow-env (env)
+		   "We use this local function in order to install dynamic-env slots
+                    in reverse order, by depth-first recursion."
+		   (unless (eq 0 env)
+		     (install-shallow-env (memref env 12))
+		     (let ((name (memref env 0)))
+		       (when (symbolp name)
+			 (setf (memref env 4)
+			   (%symbol-global-value name))
+			 (setf (%symbol-global-value name)
+			   (memref env 8)))))))
+	  (install-shallow-env (load-global-constant dynamic-env :thread-local t)))))))
+
+(defun deinstall-shallow-binding (&key quiet)
+  (unless quiet
+    (warn "Deinstalling shallow-binding strategy.."))
+  (without-interrupts
+    (macrolet ((install (slot)
+		 `(setf (%run-time-context-slot ',slot) (symbol-value ',slot))))
+      (install muerte:dynamic-variable-install)
+      (install muerte:dynamic-variable-uninstall)
+      (install muerte::dynamic-unwind-next)
+      (install muerte::dynamic-variable-store)
+      (install muerte::dynamic-variable-lookup-unbound)
+      (install muerte::dynamic-variable-lookup)
+      (loop for env = (load-global-constant dynamic-env :thread-local t)
+	  then (memref env 12)
+	  while (plusp env)
+	  do (let ((name (memref env 0)))
+	       (when (symbolp name)
+		 (setf (%symbol-global-value name)
+		   (memref env 4)))))
+      (values))))
 
 (genesis)
 




From ffjeld at common-lisp.net  Thu Nov 18 09:28:54 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 18 Nov 2004 10:28:54 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1CUib0-0007MB-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Added some trival cases for (coerce .. 'list) and (coerce .. 'vector)

Date: Thu Nov 18 10:28:53 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.37 movitz/losp/muerte/typep.lisp:1.38
--- movitz/losp/muerte/typep.lisp:1.37	Wed Sep 15 12:22:59 2004
+++ movitz/losp/muerte/typep.lisp	Thu Nov 18 10:28:52 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.37 2004/09/15 10:22:59 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.38 2004/11/18 09:28:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -620,5 +620,11 @@
   (cond
    ((typep object result-type)
     object)
+   ((and (eq result-type 'list)
+	 (typep object 'sequence))
+    (map 'list #'identity object))
+   ((and (typep object 'sequence)
+	 (member result-type '(vector array)))
+    (make-array (length object) :initial-contents object))
    (t (error "Don't know how to coerce ~S to ~S." object result-type))))
 




From ffjeld at common-lisp.net  Thu Nov 18 17:57:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 18 Nov 2004 18:57:15 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp 
Message-ID: <E1CUqWx-0007Ds-00@common-lisp.net>

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

Modified Files:
	eval.lisp 
Log Message:
Added a trivial proclaim.

Date: Thu Nov 18 18:57:14 2004
Author: ffjeld

Index: movitz/losp/muerte/eval.lisp
diff -u movitz/losp/muerte/eval.lisp:1.14 movitz/losp/muerte/eval.lisp:1.15
--- movitz/losp/muerte/eval.lisp:1.14	Fri Oct 22 14:33:27 2004
+++ movitz/losp/muerte/eval.lisp	Thu Nov 18 18:57:14 2004
@@ -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.14 2004/10/22 12:33:27 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.15 2004/11/18 17:57:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -439,3 +439,8 @@
 	      (setf (symbol-function name) function))
 	    t nil)))
 
+
+(defun proclaim (declaration)
+  ;; What do do?
+  (warn "Unknown declaration: ~S" declaration)
+  (values))




From ffjeld at common-lisp.net  Thu Nov 18 17:58:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 18 Nov 2004 18:58:38 +0100
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CUqYI-0007EI-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Changed dynamic binding lookup protocol. Only use the "unbounded"
primitive-function, and have the caller check whether the value is the
unbound-value or not. And, rename to dynamic-variable-lookup.

Date: Thu Nov 18 18:58:37 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.107 movitz/compiler.lisp:1.108
--- movitz/compiler.lisp:1.107	Wed Nov 17 14:32:46 2004
+++ movitz/compiler.lisp	Thu Nov 18 18:58:35 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.107 2004/11/17 13:32:46 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.108 2004/11/18 17:58:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -5602,7 +5602,11 @@
 	  :modifies nil
 	  :final-form form
 	  :code `((:load-constant ,form :eax)
-		  (:call (:edi ,(global-constant-offset 'dynamic-variable-lookup))))))
+		  (,*compiler-local-segment-prefix*
+		   :call (:edi ,(global-constant-offset 'dynamic-variable-lookup)))
+		  (,*compiler-local-segment-prefix*
+		   :cmpl :eax (:edi ,(global-constant-offset 'unbound-value)))
+		  (:je '(:sub-program () (:int 99))))))
        (t (check-type binding dynamic-binding)
 	  (compiler-values ()
 	    :returns :eax
@@ -5610,7 +5614,11 @@
 	    :modifies nil
 	    :final-form form
 	    :code `((:load-constant ,form :eax)
-		    (:call (:edi ,(global-constant-offset 'dynamic-variable-lookup))))))))))
+		    (,*compiler-local-segment-prefix*
+		     :call (:edi ,(global-constant-offset 'dynamic-variable-lookup)))
+		    (,*compiler-local-segment-prefix*
+		     :cmpl :eax (:edi ,(global-constant-offset 'unbound-value)))
+		    (:je '(:sub-program () (:int 99))))))))))
 
 (define-compiler compile-lambda-form (&form form)
   "3.1.2.2.4 Lambda Forms"
@@ -6486,3 +6494,38 @@
 			 `((:movl :eax ,destination))))
 		      (binding
 		       (make-store-lexical destination :eax nil frame-map))))))))))
+
+;;;;;;;
+
+(define-find-read-bindings :eql (x y)
+  (list x y))
+
+(define-extended-code-expander :eql (instruction funobj frame-map)
+  (destructuring-bind (x y)
+      (cdr instruction)
+    (let* ((x-type (apply #'encoded-type-decode (binding-store-type x)))
+	   (y-type (apply #'encoded-type-decode (binding-store-type y)))
+	   (x-singleton (type-specifier-singleton x-type))
+	   (y-singleton (type-specifier-singleton y-type)))
+      (when (and y-singleton (not x-singleton))
+	(rotatef x y)
+	(rotatef x-type y-type)
+	(rotatef x-singleton y-singleton))
+      (warn "eql ~S ~S" x-singleton y-singleton)
+      (cond
+       ((and x-singleton y-singleton)
+	(break "Constant EQL: ~S ~S" (car x-singleton) (car y-singleton)))
+       ((or (movitz-subtypep x-type 'fixnum)
+	    (movitz-subtypep x-type 'character)
+	    (movitz-subtypep y-type 'fixnum)
+	    (movitz-subtypep y-type 'character))
+	(break "EQL that is EQ."))
+       (t (append (make-load-lexical x :eax funobj nil frame-map)
+		  (make-load-lexical y :ebx funobj nil frame-map)
+		  (let ((eql-done (gensym "eql-done-")))
+		    `((:cmpl :eax :ebx)
+		      (:je ',eql-done)
+		      (,*compiler-global-segment-prefix*
+		       :movl (:edi ,(global-constant-offset 'complicated-eql)) :esi)
+		      (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%2op)))
+		      ,eql-done))))))))




From ffjeld at common-lisp.net  Thu Nov 18 17:58:47 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 18 Nov 2004 18:58:47 +0100
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1CUqYR-0007Ei-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Changed dynamic binding lookup protocol. Only use the "unbounded"
primitive-function, and have the caller check whether the value is the
unbound-value or not. And, rename to dynamic-variable-lookup.

Date: Thu Nov 18 18:58:46 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.79 movitz/image.lisp:1.80
--- movitz/image.lisp:1.79	Wed Nov 17 14:32:54 2004
+++ movitz/image.lisp	Thu Nov 18 18:58:41 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.79 2004/11/17 13:32:54 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.80 2004/11/18 17:58:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -161,11 +161,6 @@
     :map-binary-write 'movitz-intern-code-vector
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-tag :primitive-function)
-   (dynamic-variable-lookup-unbound
-    :map-binary-write 'movitz-intern-code-vector
-    :binary-tag :primitive-function
-    :map-binary-read-delayed 'movitz-word-code-vector
-    :binary-type code-vector-word)
    (dynamic-variable-lookup
     :map-binary-write 'movitz-intern-code-vector
     :binary-tag :primitive-function




From ffjeld at common-lisp.net  Thu Nov 18 17:58:56 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 18 Nov 2004 18:58:56 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1CUqYa-0007F2-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Changed dynamic binding lookup protocol. Only use the "unbounded"
primitive-function, and have the caller check whether the value is the
unbound-value or not. And, rename to dynamic-variable-lookup.

Date: Thu Nov 18 18:58:54 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.29 movitz/losp/los0.lisp:1.30
--- movitz/losp/los0.lisp:1.29	Wed Nov 17 15:02:18 2004
+++ movitz/losp/los0.lisp	Thu Nov 18 18:58:50 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.29 2004/11/17 14:02:18 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.30 2004/11/18 17:58:50 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -46,6 +46,8 @@
 
 (in-package muerte.init)
 
+(defun xx (a b)
+  (eql b #x123456789))
 
 (defun test0 ()
   (ash 1 -1000000000000))
@@ -1494,20 +1496,23 @@
 ;;;;;;;;;;;;;;;;;; Shallow binding
 
 (define-primitive-function dynamic-variable-install-shallow ()
-  "Install each dynamic binding entry between that in ESP (offset by 4 due to
-the call to this primitive-function!) and current dynamic-env.
-Preserve EDX."
+  "Install each dynamic binding entry between that in ESP
+ (offset by 4 due to the call to this primitive-function!)
+and current dynamic-env. Preserve EDX."
   (with-inline-assembly (:returns :nothing)
-    (:leal (:esp 4) :ecx)
+    (:leal (:esp 4) :ecx)		; first entry
    install-loop
-    (:locally (:cmpl :ecx (:edi (:edi-offset dynamic-env))))
+    (:locally
+      (:cmpl :ecx (:edi (:edi-offset dynamic-env))))
     (:je 'install-completed)
-    (:movl (:ecx 0) :eax)		; symbol
-    (:movl (:eax (:offset movitz-symbol value)) :ebx) ; symbol's old-value into EBX
-    (:movl :ebx (:ecx 4))		; save old-value in binding's scratch
-    (:movl (:ecx 8) :ebx)		; new value
-    (:movl :ebx (:eax (:offset movitz-symbol value))) ; install new value
-    (:movl (:ecx 12) :ecx)
+    (:movl (:ecx 0) :eax)		; binding's name
+    (:movl (:eax (:offset movitz-symbol value))
+	   :ebx)			; old value into EBX
+    (:movl :ebx (:ecx 4))		; save old value in scratch
+    (:movl (:ecx 8) :ebx)		; new value..
+    (:movl :ebx				; ..into symbol's value slot
+	   (:eax (:offset movitz-symbol value)))
+    (:movl (:ecx 12) :ecx)		; iterate next binding
     (:jmp 'install-loop)
    install-completed
     (:ret)))
@@ -1587,14 +1592,6 @@
   "Load the dynamic value of SYMBOL into EAX."
   (with-inline-assembly (:returns :multiple-values)
     (:movl (:eax (:offset movitz-symbol value)) :eax)
-    (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax))
-    (:je '(:sub-program (unbound) (:int 99)))
-    (:ret)))
-
-(define-primitive-function dynamic-variable-lookup-unbound-shallow (symbol)
-  "Load the dynamic value of SYMBOL into EAX."
-  (with-inline-assembly (:returns :multiple-values)
-    (:movl (:eax (:offset movitz-symbol value)) :eax)
     (:ret)))
 
 (define-primitive-function dynamic-variable-store-shallow (symbol value)
@@ -1609,27 +1606,25 @@
     (warn "Installing shallow-binding strategy.."))
   (without-interrupts
     (macrolet ((install (slot function)
-		 `(prog1 (cons ',slot (%run-time-context-slot ',slot))
-		    (setf (%run-time-context-slot ',slot) (symbol-value ',function)))))
-      (prog1
-	  (list (install muerte:dynamic-variable-install dynamic-variable-install-shallow)
-		(install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow)
-		(install muerte::dynamic-unwind-next dynamic-unwind-next-shallow)
-		(install muerte::dynamic-variable-store dynamic-variable-store-shallow)
-		(install muerte::dynamic-variable-lookup-unbound dynamic-variable-lookup-unbound-shallow)
-		(install muerte::dynamic-variable-lookup dynamic-variable-lookup-shallow))
-	(labels ((install-shallow-env (env)
-		   "We use this local function in order to install dynamic-env slots
+		 `(setf (%run-time-context-slot ',slot) (symbol-value ',function))))
+      (install muerte:dynamic-variable-install dynamic-variable-install-shallow)
+      (install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow)
+      (install muerte::dynamic-unwind-next dynamic-unwind-next-shallow)
+      (install muerte::dynamic-variable-store dynamic-variable-store-shallow)
+      (install muerte::dynamic-variable-lookup dynamic-variable-lookup-shallow))
+    (labels ((install-shallow-env (env)
+	       "We use this local function in order to install dynamic-env slots
                     in reverse order, by depth-first recursion."
-		   (unless (eq 0 env)
-		     (install-shallow-env (memref env 12))
-		     (let ((name (memref env 0)))
-		       (when (symbolp name)
-			 (setf (memref env 4)
-			   (%symbol-global-value name))
-			 (setf (%symbol-global-value name)
-			   (memref env 8)))))))
-	  (install-shallow-env (load-global-constant dynamic-env :thread-local t)))))))
+	       (unless (eq 0 env)
+		 (install-shallow-env (memref env 12))
+		 (let ((name (memref env 0)))
+		   (when (symbolp name)
+		     (setf (memref env 4)
+		       (%symbol-global-value name))
+		     (setf (%symbol-global-value name)
+		       (memref env 8)))))))
+      (install-shallow-env (load-global-constant dynamic-env :thread-local t))))
+  (values))
 
 (defun deinstall-shallow-binding (&key quiet)
   (unless quiet
@@ -1641,16 +1636,15 @@
       (install muerte:dynamic-variable-uninstall)
       (install muerte::dynamic-unwind-next)
       (install muerte::dynamic-variable-store)
-      (install muerte::dynamic-variable-lookup-unbound)
-      (install muerte::dynamic-variable-lookup)
-      (loop for env = (load-global-constant dynamic-env :thread-local t)
-	  then (memref env 12)
-	  while (plusp env)
-	  do (let ((name (memref env 0)))
-	       (when (symbolp name)
-		 (setf (%symbol-global-value name)
-		   (memref env 4)))))
-      (values))))
+      (install muerte::dynamic-variable-lookup))
+    (loop for env = (load-global-constant dynamic-env :thread-local t)
+	then (memref env 12)
+	while (plusp env)
+	do (let ((name (memref env 0)))
+	     (when (symbolp name)
+	       (setf (%symbol-global-value name)
+		 (memref env 4)))))
+    (values)))
 
 (genesis)
 




From ffjeld at common-lisp.net  Thu Nov 18 17:59:05 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 18 Nov 2004 18:59:05 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1CUqYj-0007FP-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Changed dynamic binding lookup protocol. Only use the "unbounded"
primitive-function, and have the caller check whether the value is the
unbound-value or not. And, rename to dynamic-variable-lookup.

Date: Thu Nov 18 18:59:03 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.46 movitz/losp/muerte/basic-macros.lisp:1.47
--- movitz/losp/muerte/basic-macros.lisp:1.46	Wed Nov 17 14:33:25 2004
+++ movitz/losp/muerte/basic-macros.lisp	Thu Nov 18 18:59:03 2004
@@ -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.46 2004/11/17 13:33:25 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.47 2004/11/18 17:59:03 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -446,6 +446,12 @@
 	 (:compile-two-forms (:eax :ebx) ,x ,y)
 	 (:cmpl :eax :ebx)))))
 
+#+ignore
+(define-compiler-macro eql (&whole form x y &environment env)
+  `(let ((x ,x) (y ,y))
+     (with-inline-assembly (:returns :boolean-zf=1)
+       (:eql (:lexical-binding x) (:lexical-binding y)))))
+
 (define-compiler-macro eql (&whole form x y &environment env)
   (cond
    ((and (movitz:movitz-constantp x env)
@@ -1078,7 +1084,7 @@
        (:leal (:eax ,(- (movitz:tag :symbol))) :ecx)
        (:testb 7 :cl)
        (:jne '(:sub-program () (:int 66)))
-       (:call-local-pf dynamic-variable-lookup-unbound)
+       (:call-local-pf dynamic-variable-lookup)
        (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax)))))
 
 (defmacro define-global-variable (name init-form &optional docstring)




From ffjeld at common-lisp.net  Thu Nov 18 17:59:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 18 Nov 2004 18:59:18 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp 
Message-ID: <E1CUqYw-0007Fz-00@common-lisp.net>

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

Modified Files:
	symbols.lisp 
Log Message:
Changed dynamic binding lookup protocol. Only use the "unbounded"
primitive-function, and have the caller check whether the value is the
unbound-value or not. And, rename to dynamic-variable-lookup.

Date: Thu Nov 18 18:59:12 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.24 movitz/losp/muerte/symbols.lisp:1.25
--- movitz/losp/muerte/symbols.lisp:1.24	Wed Nov 17 14:33:42 2004
+++ movitz/losp/muerte/symbols.lisp	Thu Nov 18 18:59:11 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 23:55:41 2001
 ;;;;                
-;;;; $Id: symbols.lisp,v 1.24 2004/11/17 13:33:42 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.25 2004/11/18 17:59:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -45,14 +45,16 @@
     (symbol
      (with-inline-assembly (:returns :eax)
        (:compile-form (:result-mode :eax) symbol)
-       (:call-local-pf dynamic-variable-lookup)))))
+       (:call-local-pf dynamic-variable-lookup)
+       (:locally (:cmpl :eax (:edi (:edi-offset unbound-value))))
+       (:je '(:sub-program (unbound) (:int 99)))))))
 
 (defun %unbounded-symbol-value (symbol)
   "Return the symbol's value without checking if it's bound or not."
   (check-type symbol symbol)
   (with-inline-assembly (:returns :eax)
     (:compile-form (:result-mode :eax) symbol)
-    (:call-local-pf dynamic-variable-lookup-unbound)
+    (:call-local-pf dynamic-variable-lookup)
    done))
 
 (defun (setf symbol-value) (value symbol)




From ffjeld at common-lisp.net  Thu Nov 18 23:49:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 19 Nov 2004 00:49:16 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1CUw1c-00040y-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
*** empty log message ***
Date: Fri Nov 19 00:49:14 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.47 movitz/losp/muerte/basic-macros.lisp:1.48
--- movitz/losp/muerte/basic-macros.lisp:1.47	Thu Nov 18 18:59:03 2004
+++ movitz/losp/muerte/basic-macros.lisp	Fri Nov 19 00:49:13 2004
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 20012000, 2002-2004,
+;;;;    Copyright (C) 2000-2004,
 ;;;;    Department of Computer Science, University of Tromso, Norway
 ;;;; 
 ;;;; Filename:      basic-macros.lisp
@@ -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.47 2004/11/18 17:59:03 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.48 2004/11/18 23:49:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 




From ffjeld at common-lisp.net  Thu Nov 18 23:50:02 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 19 Nov 2004 00:50:02 +0100
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CUw2M-00041T-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Some tuning of the mess that is forwarding-bindings and register allocaiton.

Date: Fri Nov 19 00:49:56 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.108 movitz/compiler.lisp:1.109
--- movitz/compiler.lisp:1.108	Thu Nov 18 18:58:35 2004
+++ movitz/compiler.lisp	Fri Nov 19 00:49:53 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.108 2004/11/18 17:58:35 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.109 2004/11/18 23:49:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2756,13 +2756,13 @@
   (let* ((count-init-pc (gethash binding var-counts))
 	 (count (car count-init-pc))
 	 (init-pc (cdr count-init-pc)))
+    ;; (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc)
     (cond
      ((binding-lended-p binding)
       ;; We can't lend a register.
       (values nil :never))
      ((and (= 1 count)
 	   init-pc)
-      ;; (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc)
       (assert (instruction-is (first init-pc) :init-lexvar))
       (destructuring-bind (init-binding &key init-with-register init-with-type
 					     protect-registers protect-carry)
@@ -2773,7 +2773,7 @@
 		(find-if (lambda (i)
 			   (and (not (instruction-is i :init-lexvar))
 				(member binding (find-read-bindings i)
-					:test #'eq)))
+					:test #'eq #+ignore #'binding-eql)))
 			 (cdr init-pc)
 			 #-sbcl :end #-sbcl 15))
 	       (binding-destination (third load-instruction))
@@ -2836,6 +2836,9 @@
 		   (assert (not (cdr count-init-pc)))
 		   (setf (cdr count-init-pc) init-pc))
 		 (unless storep
+		   (unless (eq binding (binding-target binding))
+		     ;; (break "ewfew: ~S" (gethash (binding-target binding) var-counter))
+		     (take-note-of-binding (binding-target binding)))
 		   (incf (car count-init-pc))))
 	       #+ignore
 	       (when (typep binding 'forwarding-binding)
@@ -2878,7 +2881,7 @@
 			     (when init-with-register
 			       (take-note-of-binding binding t pc)
 			       (when (and (typep init-with-register 'binding)
-					  #+ignore (not (typep binding 'forwarding-binding)))
+					  (not (typep binding 'forwarding-binding))) ; XXX
 				 (take-note-of-binding init-with-register)))))
 			  (t (mapcar #'take-note-of-binding 
 				     (find-read-bindings instruction))
@@ -6090,7 +6093,7 @@
 				 (and (typep binding 'forwarding-binding)
 				      (recursive-located-p (forwarding-binding-target b))))))
 		    (recursive-located-p binding)))
-	(warn "Unused variable: ~S." (binding-name binding))))
+	#+ignore (warn "Unused variable: ~S." (binding-name binding))))
      ((typep binding 'forwarding-binding)
       ;; No need to do any initialization because the target will be initialized.
       (assert (not (binding-lended-p binding)))
@@ -6409,8 +6412,8 @@
       (when (and (bindingp destination)
 		 (binding-lended-p destination))
 	(warn "Add for lend0: ~S" destination))
-      (let ((loc0 (new-binding-location term0 frame-map :default nil))
-	    (loc1 (new-binding-location term1 frame-map :default nil)))
+      (let ((loc0 (new-binding-location (binding-target term0) frame-map :default nil))
+	    (loc1 (new-binding-location (binding-target term1) frame-map :default nil)))
 ;;;	(warn "add: ~A" instruction)
 ;;;	(warn "add for: ~S is ~A, from ~A/~A and ~A/~A."
 ;;;	      destination result-type
@@ -6455,7 +6458,7 @@
 ;;;		  loc1 term1
 ;;;		  (type-specifier-singleton type0)
 ;;;		  (eq loc1 destination))
-;;;	     (warn "ADDI: ~S" instruction)
+;;;	    (warn "ADDI: ~S" instruction)
 	    (append (cond
 		     ((and (eq :eax loc0) (eq :ebx loc1))
 		      nil)
@@ -6511,21 +6514,25 @@
 	(rotatef x y)
 	(rotatef x-type y-type)
 	(rotatef x-singleton y-singleton))
-      (warn "eql ~S ~S" x-singleton y-singleton)
-      (cond
-       ((and x-singleton y-singleton)
-	(break "Constant EQL: ~S ~S" (car x-singleton) (car y-singleton)))
-       ((or (movitz-subtypep x-type 'fixnum)
-	    (movitz-subtypep x-type 'character)
-	    (movitz-subtypep y-type 'fixnum)
-	    (movitz-subtypep y-type 'character))
-	(break "EQL that is EQ."))
-       (t (append (make-load-lexical x :eax funobj nil frame-map)
-		  (make-load-lexical y :ebx funobj nil frame-map)
-		  (let ((eql-done (gensym "eql-done-")))
-		    `((:cmpl :eax :ebx)
-		      (:je ',eql-done)
-		      (,*compiler-global-segment-prefix*
-		       :movl (:edi ,(global-constant-offset 'complicated-eql)) :esi)
-		      (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%2op)))
-		      ,eql-done))))))))
+      (let ((x-loc (new-binding-location (binding-target x) frame-map :default nil))
+	    (y-loc (new-binding-location (binding-target y) frame-map :default nil)))
+	(warn "eql ~S/~S ~S/~S"
+	      x x-loc
+	      y y-loc)
+	(cond
+	 ((and x-singleton y-singleton)
+	  (break "Constant EQL: ~S ~S" (car x-singleton) (car y-singleton)))
+	 ((or (movitz-subtypep x-type 'fixnum)
+	      (movitz-subtypep x-type 'character)
+	      (movitz-subtypep y-type 'fixnum)
+	      (movitz-subtypep y-type 'character))
+	  (break "EQL that is EQ."))
+	 (t (append (make-load-lexical x :eax funobj nil frame-map)
+		    (make-load-lexical y :ebx funobj nil frame-map)
+		    (let ((eql-done (gensym "eql-done-")))
+		      `((:cmpl :eax :ebx)
+			(:je ',eql-done)
+			(,*compiler-global-segment-prefix*
+			 :movl (:edi ,(global-constant-offset 'complicated-eql)) :esi)
+			(:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%2op)))
+			,eql-done)))))))))




From ffjeld at common-lisp.net  Fri Nov 19 20:12:32 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 19 Nov 2004 21:12:32 +0100
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CVF7Q-0004IV-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
More tuning of (forwarding-)binding/register allocation stuff. This
fix removes many superfluous stack-pushes/register-spills.

Date: Fri Nov 19 21:12:29 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.109 movitz/compiler.lisp:1.110
--- movitz/compiler.lisp:1.109	Fri Nov 19 00:49:53 2004
+++ movitz/compiler.lisp	Fri Nov 19 21:12:26 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.109 2004/11/18 23:49:53 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.110 2004/11/19 20:12:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -430,19 +430,24 @@
 	(analyze-funobj toplevel-funobj))
     (let ((binding-usage (make-hash-table :test 'eq)))
       (labels ((binding-resolved-p (binding)
-		 (let ((analysis (gethash binding binding-usage)))
-		   (and analysis
-			(null (type-analysis-thunks analysis)))))
+		 (or (typep binding 'constant-object-binding)
+		     (let ((analysis (gethash binding binding-usage)))
+		       (and analysis
+			    (null (type-analysis-thunks analysis))))))
 	       (binding-resolve (binding)
-		 (if (not (bindingp binding))
-		     binding
-		   (let ((analysis (gethash binding binding-usage)))
-		     (assert (and (and analysis
-				       (null (type-analysis-thunks analysis))))
-			 (binding)
-		       "Can't resolve unresolved binding ~S." binding)
-		     (apply #'encoded-type-decode
-			    (type-analysis-encoded-type analysis)))))
+		 (cond
+		  ((not (bindingp binding))
+		   binding)
+		  ((typep binding 'constant-object-binding)
+		   (apply #'encoded-type-decode
+			  (binding-store-type binding)))
+		  (t (let ((analysis (gethash binding binding-usage)))
+		       (assert (and (and analysis
+					 (null (type-analysis-thunks analysis))))
+			   (binding)
+			 "Can't resolve unresolved binding ~S." binding)
+		       (apply #'encoded-type-decode
+			      (type-analysis-encoded-type analysis))))))
 	       (type-is-t (type-specifier)
 		 (or (eq type-specifier t)
 		     (and (listp type-specifier)
@@ -1501,6 +1506,9 @@
 	       (explain t "4: ~S for ~S [regx ~S, regy ~S]" p (subseq pc 0 5) regx regy)))
 	nconc p)))
 
+(defun xsubseq (sequence start end)
+  (subseq sequence start (min (length sequence) end)))
+
 (defun optimize-code-internal (unoptimized-code recursive-count &rest key-args
 			       &key keep-labels stack-frame-size)
   "Peephole optimizer. Based on a lot of rather random techniques."
@@ -1808,7 +1816,7 @@
 						 (mapcar (lambda (lpc)
 							   (if (eq 'unknown-label-usage lpc)
 							       nil
-							     (rcode-map (nreverse (subseq lpc 0 9)))))
+							     (rcode-map (nreverse (xsubseq lpc 0 9)))))
 							 (find-branches-to-label unoptimized-code label 9))))
 			     (full-map (let ((rcode (nreverse (let* ((pos (loop for x on unoptimized-code
 									      as pos upfrom 0
@@ -2773,7 +2781,7 @@
 		(find-if (lambda (i)
 			   (and (not (instruction-is i :init-lexvar))
 				(member binding (find-read-bindings i)
-					:test #'eq #+ignore #'binding-eql)))
+					:test #'binding-eql)))
 			 (cdr init-pc)
 			 #-sbcl :end #-sbcl 15))
 	       (binding-destination (third load-instruction))
@@ -3501,11 +3509,11 @@
 		    (cond
 		     ((not dest-location) ; unknown, e.g. a borrowed-binding.
 		      (append (install-for-single-value binding binding-location :ecx nil)
-			      (make-store-lexical result-mode :ecx nil frame-map)))
+			      (make-store-lexical result-mode :ecx nil funobj frame-map)))
 		     ((equal binding-location dest-location)
 		      nil)
 		     ((member binding-location '(:eax :ebx :ecx :edx))
-		      (make-store-lexical destination binding-location nil frame-map))
+		      (make-store-lexical destination binding-location nil funobj frame-map))
 		     ((member dest-location '(:eax :ebx :ecx :edx))
 		      (install-for-single-value binding binding-location dest-location nil))
 		     (t #+ignore (warn "binding => binding: ~A => ~A~% => ~A ~A"
@@ -3514,75 +3522,84 @@
 				       binding
 				       destination)
 			(append (install-for-single-value binding binding-location :eax nil)
-				(make-store-lexical result-mode :eax nil frame-map))))))
+				(make-store-lexical result-mode :eax nil funobj frame-map))))))
 		 (t (make-result-and-returns-glue
 		     result-mode :eax
 		     (install-for-single-value binding binding-location :eax nil)))
 		 )))))))))
 
-(defun make-store-lexical (binding source shared-reference-p frame-map
+(defun make-store-lexical (binding source shared-reference-p funobj frame-map
 			   &key protect-registers)
   (assert (not (and shared-reference-p
 		    (not (binding-lended-p binding))))
       (binding)
     "funny binding: ~W" binding)
-  (let ((protect-registers (cons source protect-registers)))
-    (cond
-     ((eq :untagged-fixnum-ecx source)
-      (if (eq :untagged-fixnum-ecx
-	      (new-binding-location binding frame-map))
-	  nil
-	(append (make-result-and-returns-glue :ecx :untagged-fixnum-ecx)
-		(make-store-lexical binding :ecx shared-reference-p frame-map
-				    :protect-registers protect-registers))))
-     ((typep binding 'borrowed-binding)
-      (let ((slot (borrowed-binding-reference-slot binding)))
-	(if (not shared-reference-p)
-	    (let ((tmp-reg (chose-free-register protect-registers)
-			   #+ignore(if (eq source :eax) :ebx :eax)))
-	      `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
-		       ,tmp-reg)
-		(:movl ,source (-1 ,tmp-reg))))
-	  `((:movl ,source (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot))))))))
-     ((typep binding 'forwarding-binding)
-      (assert (not (binding-lended-p binding)) (binding))
-      (make-store-lexical (forwarding-binding-target binding)
-			  source shared-reference-p frame-map))
-     ((not (new-binding-located-p binding frame-map))
-      ;; (warn "Can't store to unlocated binding ~S." binding)
-      nil)
-     ((and (binding-lended-p binding)
-	   (not shared-reference-p))
-      (let ((tmp-reg (chose-free-register protect-registers)
-		     #+ignore (if (eq source :eax) :ebx :eax))
-	    (location (new-binding-location binding frame-map)))
-	(if (integerp location)
-	    `((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg)
-	      (:movl ,source (,tmp-reg -1)))
-	  (ecase (operator location)
-	    (:argument-stack
-	     (assert (<= 2 (function-argument-argnum binding)) ()
-	       "store-lexical argnum can't be ~A." (function-argument-argnum binding))
-	     `((:movl (:ebp ,(argument-stack-offset binding)) ,tmp-reg)
-	       (:movl ,source (,tmp-reg -1))))))))
-     (t (let ((location (new-binding-location binding frame-map)))
+  (if (typep source 'constant-object-binding)
+      (make-load-constant (constant-object source) binding funobj frame-map)
+    (let ((protect-registers (cons source protect-registers))
+	  #+ignore (source (if (not (typep source 'constant-object-binding))
+			       source
+			     (etypecase (constant-object source)
+			       (movitz-null
+				:edi)
+			       (movitz-immediate-object
+				(movitz-immediate-value (constant-object source)))))))
+      (cond
+       ((eq :untagged-fixnum-ecx source)
+	(if (eq :untagged-fixnum-ecx
+		(new-binding-location binding frame-map))
+	    nil
+	  (append (make-result-and-returns-glue :ecx :untagged-fixnum-ecx)
+		  (make-store-lexical binding :ecx shared-reference-p funobj frame-map
+				      :protect-registers protect-registers))))
+       ((typep binding 'borrowed-binding)
+	(let ((slot (borrowed-binding-reference-slot binding)))
+	  (if (not shared-reference-p)
+	      (let ((tmp-reg (chose-free-register protect-registers)
+			     #+ignore(if (eq source :eax) :ebx :eax)))
+		`((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
+			 ,tmp-reg)
+		  (:movl ,source (-1 ,tmp-reg))))
+	    `((:movl ,source (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot))))))))
+       ((typep binding 'forwarding-binding)
+	(assert (not (binding-lended-p binding)) (binding))
+	(make-store-lexical (forwarding-binding-target binding)
+			    source shared-reference-p funobj frame-map))
+       ((not (new-binding-located-p binding frame-map))
+	;; (warn "Can't store to unlocated binding ~S." binding)
+	nil)
+       ((and (binding-lended-p binding)
+	     (not shared-reference-p))
+	(let ((tmp-reg (chose-free-register protect-registers)
+		       #+ignore (if (eq source :eax) :ebx :eax))
+	      (location (new-binding-location binding frame-map)))
 	  (if (integerp location)
-	      `((:movl ,source (:ebp ,(stack-frame-offset location))))
+	      `((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg)
+		(:movl ,source (,tmp-reg -1)))
 	    (ecase (operator location)
-	      ((:push)
-	       `((:pushl ,source)))
-	      ((:eax :ebx :ecx :edx)
-	       (unless (eq source location)
-		 `((:movl ,source ,location))))
 	      (:argument-stack
 	       (assert (<= 2 (function-argument-argnum binding)) ()
 		 "store-lexical argnum can't be ~A." (function-argument-argnum binding))
-	       `((:movl ,source (:ebp ,(argument-stack-offset binding)))))
-	      (:untagged-fixnum-ecx
-	       (append (unless (member source '(:ecx :untagged-fixnum-ecx))
-			 `((:movl ,source :ecx)))
-		       (unless (eq source :untagged-fixnum-ecx)
-			 `((:sarl ,+movitz-fixnum-shift+ :ecx))))))))))))
+	       `((:movl (:ebp ,(argument-stack-offset binding)) ,tmp-reg)
+		 (:movl ,source (,tmp-reg -1))))))))
+       (t (let ((location (new-binding-location binding frame-map)))
+	    (if (integerp location)
+		`((:movl ,source (:ebp ,(stack-frame-offset location))))
+	      (ecase (operator location)
+		((:push)
+		 `((:pushl ,source)))
+		((:eax :ebx :ecx :edx)
+		 (unless (eq source location)
+		   `((:movl ,source ,location))))
+		(:argument-stack
+		 (assert (<= 2 (function-argument-argnum binding)) ()
+		   "store-lexical argnum can't be ~A." (function-argument-argnum binding))
+		 `((:movl ,source (:ebp ,(argument-stack-offset binding)))))
+		(:untagged-fixnum-ecx
+		 (append (unless (member source '(:ecx :untagged-fixnum-ecx))
+			   `((:movl ,source :ecx)))
+			 (unless (eq source :untagged-fixnum-ecx)
+			   `((:sarl ,+movitz-fixnum-shift+ :ecx)))))))))))))
 
 (defun finalize-code (code funobj frame-map)
   ;; (print-code 'to-be-finalized code)
@@ -3613,7 +3630,7 @@
 			 (append `((:pushl :edx)
 				   (:globally (:call (:edi (:edi-offset ensure-heap-cons-variable))))
 				   (:popl :edx))
-				 (make-store-lexical lended-binding :eax t frame-map)))
+				 (make-store-lexical lended-binding :eax t funobj frame-map)))
 		       `((:movl :eax
 				(,funobj-register
 				 ,(+ (slot-offset 'movitz-funobj 'constant0)
@@ -3696,7 +3713,7 @@
 				  `((:movl (:edi ,(global-constant-offset 'copy-funobj)) :esi)
 				    (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%1op)))
 				    (:movl :eax :edx))
-				  (make-store-lexical function-binding :eax nil frame-map)
+				  (make-store-lexical function-binding :eax nil funobj frame-map)
 				  (loop for bb in (borrowed-bindings sub-funobj)
 				      append (make-lend-lexical bb :edx nil))))))
 		    funobj frame-map)))
@@ -3762,7 +3779,7 @@
 	 (movitz-null
 	  (ecase (result-mode-type result-mode)
 	    (:lexical-binding
-	     (make-store-lexical result-mode :edi nil frame-map))
+	     (make-store-lexical result-mode :edi nil funobj frame-map))
 	    (:push
 	     '((:pushl :edi)))
 	    ((:eax :ebx :ecx :edx)
@@ -3800,7 +3817,7 @@
 	    (:lexical-binding
 	     (append `((:movl (:edi ,(global-constant-offset 't-symbol))
 			      :eax))
-		     (make-store-lexical result-mode :eax nil frame-map)))
+		     (make-store-lexical result-mode :eax nil funobj frame-map)))
 	    #+ignore
 	    (t (when (eq :boolean result-mode)
 		 (warn "Compiling ~S for mode ~S." object result-mode))
@@ -3812,7 +3829,7 @@
 	    (ecase (result-mode-type result-mode)
 	      (:lexical-binding
 	       (append (make-immediate-move x :eax)
-		       (make-store-lexical result-mode :eax nil frame-map)))
+		       (make-store-lexical result-mode :eax nil funobj frame-map)))
 	      (:untagged-fixnum-eax
 	       (let ((value (movitz-fixnum-value object)))
 		 (check-type value (unsigned-byte 16))
@@ -3833,7 +3850,7 @@
 	    (:lexical-binding
 	     (append `((:movl ,(new-make-compiled-constant-reference movitz-obj funobj)
 			      :eax))
-		     (make-store-lexical result-mode :eax nil frame-map)))
+		     (make-store-lexical result-mode :eax nil funobj frame-map)))
 	    (:push
 	     `((:pushl ,(new-make-compiled-constant-reference movitz-obj funobj))))
 	    ((:eax :ebx :ecx :edx :esi)
@@ -6049,7 +6066,7 @@
     (declare (ignore type))
     (make-store-lexical (ensure-local-binding destination funobj)
 			(ensure-local-binding source funobj)
-			shared-reference-p frame-map
+			shared-reference-p funobj frame-map
 			:protect-registers protect-registers)))
 
 ;;;;;;;;;;;;;;;;;; Init-lexvar
@@ -6161,7 +6178,7 @@
 	   (let* ((cons-position (getf (binding-lending binding)
 				       :stack-cons-location))
 		  (init-register (etypecase init-with-register
-				   (lexical-binding
+				   ((or lexical-binding constant-object-binding)
 				    (or (find-if (lambda (r)
 						   (not (member r protect-registers)))
 						 '(:edx :ebx :eax))
@@ -6189,7 +6206,7 @@
 	  ((typep init-with-register 'lexical-binding)
 	   (make-load-lexical init-with-register binding funobj nil frame-map))
 	  (init-with-register
-	   (make-store-lexical binding init-with-register nil frame-map))))))))
+	   (make-store-lexical binding init-with-register nil funobj frame-map))))))))
 
 ;;;;;;;;;;;;;;;;;; car
 
@@ -6308,6 +6325,7 @@
   nil)
 
 (define-extended-code-expander :incf-lexvar (instruction funobj frame-map)
+  (break "incf-lexvar??")
   (destructuring-bind (binding delta &key protect-registers)
       (cdr instruction)
     (check-type binding binding)
@@ -6334,7 +6352,7 @@
 	      (:addl ,(* delta +movitz-fixnum-factor+) :eax)
 	      (:into)
 	      ,@(make-store-lexical (ensure-local-binding binding funobj)
-				    register nil frame-map
+				    register nil funobj frame-map
 				    :protect-registers protect-registers))))
        (t (let ((register (chose-free-register protect-registers)))
 	    `(,@(make-load-lexical (ensure-local-binding binding funobj)
@@ -6347,7 +6365,7 @@
 		(:addl ,(* delta +movitz-fixnum-factor+) ,register)
 		(:into)
 		,@(make-store-lexical (ensure-local-binding binding funobj)
-				      register nil frame-map
+				      register nil funobj frame-map
 				      :protect-registers protect-registers))))))))
 
 ;;;;; Load-constant
@@ -6384,7 +6402,16 @@
 
 (define-find-read-bindings :add (term0 term1 destination)
   (declare (ignore destination))
-  (list term0 term1))
+  (let* ((type0 (and (binding-store-type term0)
+		     (apply #'encoded-type-decode (binding-store-type term0))))
+	 (type1 (and (binding-store-type term1)
+		     (apply #'encoded-type-decode (binding-store-type term1))))
+	 (singleton0 (and type0 (type-specifier-singleton type0)))
+	 (singleton1 (and type1 (type-specifier-singleton type1))))
+    (append (unless (and singleton0 (typep (car singleton0) 'movitz-fixnum))
+	      (list term0))
+	    (unless (and singleton1 (typep (car singleton1) 'movitz-fixnum))
+	      (list term1)))))
 
 (define-extended-code-expander :add (instruction funobj frame-map)
   (destructuring-bind (term0 term1 destination)
@@ -6415,18 +6442,47 @@
       (let ((loc0 (new-binding-location (binding-target term0) frame-map :default nil))
 	    (loc1 (new-binding-location (binding-target term1) frame-map :default nil)))
 ;;;	(warn "add: ~A" instruction)
-;;;	(warn "add for: ~S is ~A, from ~A/~A and ~A/~A."
-;;;	      destination result-type
-;;;	      term0 loc0
-;;;	      term1 loc1)
+	#+ignore
+	(warn "add for: ~S is ~A, from ~A/~A and ~A/~A."
+	      destination result-type
+	      term0 loc0
+	      term1 loc1)
 	(cond
 	 ((type-specifier-singleton result-type)
 	  ;; (break "constant add: ~S" instruction)
 	  (make-load-constant (car (type-specifier-singleton result-type))
 			      destination funobj frame-map))
+	 ((movitz-subtypep type0 '(integer 0 0))
+	  (cond
+	   ((eql destination loc1)
+	    (break "NOP add: ~S" instruction))
+	   ((and (member destination-location '(:eax :ebx :ecx :edx))
+		 (member loc1 '(:eax :ebx :ecx :edx)))
+	    `((:movl ,loc1 ,destination-location)))
+	   ((integerp loc1)
+	    (make-load-lexical term1 destination-location funobj nil frame-map))
+	   #+ignore
+	   ((integerp destination-location)
+	    (make-store-lexical destination-location loc1 nil funobj frame-map))
+	   (t (break "Unknown X zero-add: ~S" instruction))))
+	 ((movitz-subtypep type1 '(integer 0 0))
+	  ;; (warn "zero-add ~S => ~S [~S]" loc0 destination-location result-type)
+	  (cond
+	   ((eql destination loc0)
+	    (break "NOP add: ~S" instruction))
+	   ((and (member destination-location '(:eax :ebx :ecx :edx))
+		 (member loc0 '(:eax :ebx :ecx :edx)))
+	    `((:movl ,loc0 ,destination-location)))
+	   ((integerp loc0)
+	    (make-load-lexical term0 destination-location funobj nil frame-map))
+	   #+ignore
+	   ((integerp destination-location)
+	    (make-store-lexical destination-location loc0 nil funobj frame-map))
+	   (t (break "Unknown Y zero-add: ~S" instruction))))
 	 ((and (movitz-subtypep type0 'fixnum)
 	       (movitz-subtypep type1 'fixnum)
 	       (movitz-subtypep result-type 'fixnum))
+	  ;; (warn "ADDX: ~S" instruction)
 	  (cond
 	   ((and (type-specifier-singleton type0)
 		 (eq loc1 destination-location))
@@ -6449,17 +6505,24 @@
 		 (integerp destination-location))
 	    (append `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
 			     ,loc1))
-		    (make-store-lexical destination loc1 nil frame-map)))
-	   (t
-;;;	    (warn "ADD: ~A/~S = ~A/~S + ~A/~S,~%~A ~A"
-;;;		  destination-location
-;;;		  destination
-;;;		  loc0 term0
-;;;		  loc1 term1
-;;;		  (type-specifier-singleton type0)
-;;;		  (eq loc1 destination))
-;;;	    (warn "ADDI: ~S" instruction)
+		    (make-store-lexical destination loc1 nil funobj frame-map)))
+	   (t #+ignore (warn "ADD: ~A/~S = ~A/~S + ~A/~S,~%~A ~A"
+			     destination-location
+			     destination
+			     loc0 term0
+			     loc1 term1
+			     (type-specifier-singleton type0)
+			     (eq loc1 destination))
+;;; 	    (warn "ADDI: ~S" instruction)
 	    (append (cond
+		     ((type-specifier-singleton type0)
+		      (append (make-load-lexical term1 :eax funobj nil frame-map)
+			      (make-load-constant (car (type-specifier-singleton type0))
+						  :ebx funobj frame-map)))
+		     ((type-specifier-singleton type1)
+		      (append (make-load-lexical term0 :eax funobj nil frame-map)
+			      (make-load-constant (car (type-specifier-singleton type1))
+						  :ebx funobj frame-map)))
 		     ((and (eq :eax loc0) (eq :ebx loc1))
 		      nil)
 		     ((and (eq :ebx loc0) (eq :eax loc1))
@@ -6477,8 +6540,16 @@
 		       (unless (eq destination :eax)
 			 `((:movl :eax ,destination))))
 		      (binding
-		       (make-store-lexical destination :eax nil frame-map)))))))
+		       (make-store-lexical destination :eax nil funobj frame-map)))))))
 	 (t (append (cond
+		     ((type-specifier-singleton type0)
+		      (append (make-load-lexical term1 :eax funobj nil frame-map)
+			      (make-load-constant (car (type-specifier-singleton type0))
+						  :ebx funobj frame-map)))
+		     ((type-specifier-singleton type1)
+		      (append (make-load-lexical term0 :eax funobj nil frame-map)
+			      (make-load-constant (car (type-specifier-singleton type1))
+						  :ebx funobj frame-map)))
 		     ((and (eq :eax loc0) (eq :ebx loc1))
 		      nil)
 		     ((and (eq :ebx loc0) (eq :eax loc1))
@@ -6496,7 +6567,7 @@
 		       (unless (eq destination :eax)
 			 `((:movl :eax ,destination))))
 		      (binding
-		       (make-store-lexical destination :eax nil frame-map))))))))))
+		       (make-store-lexical destination :eax nil funobj frame-map))))))))))
 
 ;;;;;;;
 




From ffjeld at common-lisp.net  Fri Nov 19 20:12:44 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 19 Nov 2004 21:12:44 +0100
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1CVF7c-0004Ip-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
More tuning of (forwarding-)binding/register allocation stuff. This
fix removes many superfluous stack-pushes/register-spills.

Date: Fri Nov 19 21:12:39 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.36 movitz/special-operators-cl.lisp:1.37
--- movitz/special-operators-cl.lisp:1.36	Wed Nov 17 14:33:03 2004
+++ movitz/special-operators-cl.lisp	Fri Nov 19 21:12:37 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.36 2004/11/17 13:33:03 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.37 2004/11/19 20:12:37 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -278,7 +278,25 @@
 								     :init-with-register ,final-form
 								     ;; :init-with-type ,final-form
 								     ))))
-					    (t (append init-code
+					    ((typep final-form 'constant-object-binding)
+					     #+ignore
+					     (warn "type: ~S or ~S" final-form 
+						   (type-specifier-primary type))
+					     (append (if functional-p
+							 nil
+						       (compiler-call #'compile-form-unprotected
+							 :env init-env
+							 :defaults all
+							 :form init-form
+							 :result-mode :ignore
+							 :modify-accumulate let-modifies))
+						     `((:init-lexvar
+							,binding
+							:init-with-register ,final-form
+							:init-with-type ,(type-specifier-primary type)
+							))))
+					    (t ;; (warn "for ~S ~S ~S" binding init-register final-form)
+					       (append init-code
 						       `((:init-lexvar
 							  ,binding
 							  :init-with-register ,init-register




From ffjeld at common-lisp.net  Fri Nov 19 20:13:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 19 Nov 2004 21:13:46 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/lists.lisp 
Message-ID: <E1CVF8c-0004JL-00@common-lisp.net>

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

Modified Files:
	lists.lisp 
Log Message:
Say compiler-macro-call explicitly.

Date: Fri Nov 19 21:13:45 2004
Author: ffjeld

Index: movitz/losp/muerte/lists.lisp
diff -u movitz/losp/muerte/lists.lisp:1.9 movitz/losp/muerte/lists.lisp:1.10
--- movitz/losp/muerte/lists.lisp:1.9	Thu Aug 12 18:58:19 2004
+++ movitz/losp/muerte/lists.lisp	Fri Nov 19 21:13:44 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Tue Dec  5 18:40:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: lists.lisp,v 1.9 2004/08/12 16:58:19 ffjeld Exp $
+;;;; $Id: lists.lisp,v 1.10 2004/11/19 20:13:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -61,7 +61,7 @@
     (:ret)))
 
 (defun endp (x)
-  (endp x))				; compiler-macro
+  (compiler-macro-call endp x))
 
 (defun assoc (item alist &key (test 'eql) (key 'identity))
   (numargs-case




From ffjeld at common-lisp.net  Fri Nov 19 20:16:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 19 Nov 2004 21:16:16 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp 
Message-ID: <E1CVFB2-0004UN-00@common-lisp.net>

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

Modified Files:
	interrupt.lisp 
Log Message:
Don't reset dynamic-env on stack overflow. It's a rather bad idea,
since it precludes any popping back to top-level.

Date: Fri Nov 19 21:16:15 2004
Author: ffjeld

Index: movitz/losp/muerte/interrupt.lisp
diff -u movitz/losp/muerte/interrupt.lisp:1.31 movitz/losp/muerte/interrupt.lisp:1.32
--- movitz/losp/muerte/interrupt.lisp:1.31	Thu Nov 11 20:28:51 2004
+++ movitz/losp/muerte/interrupt.lisp	Fri Nov 19 21:16:15 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Apr  7 01:50:03 2004
 ;;;;                
-;;;; $Id: interrupt.lisp,v 1.31 2004/11/11 19:28:51 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.32 2004/11/19 20:16:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -337,9 +337,9 @@
 	     (unwind-protect
 		 (progn
 		   (setf (%run-time-context-slot 'stack-bottom) new-bottom
-			 (%run-time-context-slot 'dynamic-env) 0
+			 ;; (%run-time-context-slot 'dynamic-env) 0
 			 (segment-register :es) (segment-register :ds))
-		   (format *debug-io* "~&Stack-warning: Bumped stack-bottom by ~D to #x~X. Reset ENV and ES.~%"
+		   (format *debug-io* "~&Stack-warning: Bumped stack-bottom by ~D to #x~X. Reset ES.~%"
 			   (- old-bottom new-bottom)
 			   new-bottom)
 		   (break "Stack overload exception ~D at EIP=~@Z, ESP=~@Z, bottom=#x~X, ENV=#x~X."
@@ -350,7 +350,7 @@
 	       (format *debug-io* "~&Stack-warning: Resetting stack-bottom to #x~X.~%"
 		       old-bottom)
 	       (setf (%run-time-context-slot 'stack-bottom) old-bottom
-		     (%run-time-context-slot 'dynamic-env) old-dynamic-env
+		     ;; (%run-time-context-slot 'dynamic-env) old-dynamic-env
 		     (segment-register :es) old-es))))
 	  (69
 	   (error "Not a function: ~S" (dereference $edx)))




From ffjeld at common-lisp.net  Fri Nov 19 23:03:57 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Nov 2004 00:03:57 +0100
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1CVHnJ-0006oM-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
added special-operator eql%b, which is the compiled eql.

Date: Sat Nov 20 00:03:50 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.44 movitz/special-operators.lisp:1.45
--- movitz/special-operators.lisp:1.44	Sat Nov 13 17:10:14 2004
+++ movitz/special-operators.lisp	Sat Nov 20 00:03:49 2004
@@ -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.44 2004/11/13 16:10:14 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.45 2004/11/19 23:03:49 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1302,3 +1302,18 @@
 			  (:popl :ebp)
 			  (:leal (:esp 12) :esp)
 			  )))))))
+
+
+(define-special-operator muerte::eql%b (&form form &env env &result-mode result-mode)
+  (destructuring-bind (x y)
+      (cdr form)
+    (let ((returns (case (result-mode-type result-mode)
+		     ((:boolean-branch-on-true :boolean-branch-on-false)
+		      result-mode)
+		     (t :boolean-zf=1)))
+	  (x (movitz-binding x env))
+	  (y (movitz-binding y env)))
+      (compiler-values ()
+	:returns returns
+	:code `((:eql ,x ,y ,returns))))))
+			     




From ffjeld at common-lisp.net  Fri Nov 19 23:07:07 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Nov 2004 00:07:07 +0100
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CVHqN-0006sb-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fixed some bugs in compiler's type-inference. Added eql
extended-operator.

Date: Sat Nov 20 00:07:03 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.110 movitz/compiler.lisp:1.111
--- movitz/compiler.lisp:1.110	Fri Nov 19 21:12:26 2004
+++ movitz/compiler.lisp	Sat Nov 20 00:06:58 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.110 2004/11/19 20:12:26 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.111 2004/11/19 23:06:58 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -431,6 +431,7 @@
     (let ((binding-usage (make-hash-table :test 'eq)))
       (labels ((binding-resolved-p (binding)
 		 (or (typep binding 'constant-object-binding)
+		     (typep binding 'function-argument)
 		     (let ((analysis (gethash binding binding-usage)))
 		       (and analysis
 			    (null (type-analysis-thunks analysis))))))
@@ -441,6 +442,8 @@
 		  ((typep binding 'constant-object-binding)
 		   (apply #'encoded-type-decode
 			  (binding-store-type binding)))
+		  ((typep binding 'function-argument)
+		   t)
 		  (t (let ((analysis (gethash binding binding-usage)))
 		       (assert (and (and analysis
 					 (null (type-analysis-thunks analysis))))
@@ -6571,11 +6574,12 @@
 
 ;;;;;;;
 
-(define-find-read-bindings :eql (x y)
+(define-find-read-bindings :eql (x y mode)
+  (declare (ignore mode))
   (list x y))
 
 (define-extended-code-expander :eql (instruction funobj frame-map)
-  (destructuring-bind (x y)
+  (destructuring-bind (x y return-mode)
       (cdr instruction)
     (let* ((x-type (apply #'encoded-type-decode (binding-store-type x)))
 	   (y-type (apply #'encoded-type-decode (binding-store-type y)))
@@ -6585,25 +6589,105 @@
 	(rotatef x y)
 	(rotatef x-type y-type)
 	(rotatef x-singleton y-singleton))
-      (let ((x-loc (new-binding-location (binding-target x) frame-map :default nil))
+      (let (;;(x-loc (new-binding-location (binding-target x) frame-map :default nil))
 	    (y-loc (new-binding-location (binding-target y) frame-map :default nil)))
+	#+ignore
 	(warn "eql ~S/~S ~S/~S"
 	      x x-loc
 	      y y-loc)
-	(cond
-	 ((and x-singleton y-singleton)
-	  (break "Constant EQL: ~S ~S" (car x-singleton) (car y-singleton)))
-	 ((or (movitz-subtypep x-type 'fixnum)
-	      (movitz-subtypep x-type 'character)
-	      (movitz-subtypep y-type 'fixnum)
-	      (movitz-subtypep y-type 'character))
-	  (break "EQL that is EQ."))
-	 (t (append (make-load-lexical x :eax funobj nil frame-map)
-		    (make-load-lexical y :ebx funobj nil frame-map)
+	(flet ((make-branch ()
+		 (ecase (operator return-mode)
+		   (:boolean-branch-on-false
+		    `((:jne ',(operands return-mode))))
+		   (:boolean-branch-on-true
+		    `((:je ',(operands return-mode))))
+		   (:boolean-zf=1)))
+	       (make-load-eax-ebx ()
+		 (if (eq :eax y-loc)
+		     (make-load-lexical x :ebx funobj nil frame-map)
+		   (append (make-load-lexical x :eax funobj nil frame-map)
+			   (make-load-lexical y :ebx funobj nil frame-map)))))
+	  (cond
+	   ((and x-singleton y-singleton)
+	    (let ((eql (etypecase (car x-singleton)
+			 (movitz-immediate-object
+			  (and (typep (car y-singleton) 'movitz-immediate-object)
+			       (eql (movitz-immediate-value (car x-singleton))
+				    (movitz-immediate-value (car y-singleton))))))))
+	      (case (operator return-mode)
+		(:boolean-branch-on-false
+		 (when (not eql)
+		   (warn "constant eql ~S to ~S" instruction (operands return-mode))
+		   `((:jmp ',(operands return-mode)))))
+		(t (break "Constant EQL: ~S ~S" (car x-singleton) (car y-singleton))))))
+	   ((and x-singleton
+		 (eq :untagged-fixnum-ecx y-loc))
+	    (let ((value (etypecase (car x-singleton)
+			   (movitz-fixnum
+			    (movitz-fixnum-value (car x-singleton)))
+			   (movitz-bignum
+			    (movitz-bignum-value (car x-singleton))))))
+	      (check-type value (unsigned-byte 32))
+	      `((:cmpl ,value :ecx)
+		,@(make-branch))))
+	   ((and x-singleton
+		 (typep (car x-singleton) '(or movitz-immediate-object movitz-null)))
+	    (let ((value (if (typep (car x-singleton) 'movitz-null)
+			     :edi
+			   (movitz-immediate-value (car x-singleton)))))
+	      (append (cond
+		       ((and (eql value 0)
+			     (member y-loc '(:eax :ebx :ecx :edx)))
+			`((:testl ,y-loc ,y-loc)))
+		       ((and (member y-loc '(:eax :ebx :ecx :edx))
+			     (not (binding-lended-p y)))
+			`((:cmpl ,value ,y-loc)))
+		       ((and (integerp y-loc)
+			     (not (binding-lended-p y)))
+			`((:cmpl ,value (:ebp ,(stack-frame-offset y-loc)))))
+		       ((and (eq :argument-stack (operator y-loc))
+			     (not (binding-lended-p y)))
+			`((:cmpl ,value (:ebp ,(argument-stack-offset (binding-target y))))))
+		       (t (break "x-singleton: ~S with loc ~S"
+				 (movitz-immediate-value (car x-singleton))
+				 y-loc)))
+		      (make-branch))))
+	   (y-singleton
+	    (break "y-singleton"))
+	   ((or (movitz-subtypep x-type 'fixnum)
+		(movitz-subtypep x-type 'character)
+		(movitz-subtypep y-type 'fixnum)
+		(movitz-subtypep y-type 'character))
+	    (append (make-load-eax-ebx)
+		    `((:cmpl :eax :ebx))
+		    (make-branch)))
+	   ((eq :boolean-branch-on-false (operator return-mode))
+	    (let ((eql-done (gensym "eql-done-"))
+		  (on-false-label (operands return-mode)))
+	      (append (make-load-eax-ebx)
+		      `((:cmpl :eax :ebx)
+			(:je ',eql-done)
+			(,*compiler-global-segment-prefix*
+			 :movl (:edi ,(global-constant-offset 'complicated-eql)) :esi)
+			(:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%2op)))
+			(:jne ',on-false-label)
+			,eql-done))))
+	   ((eq :boolean-branch-on-true (operator return-mode))
+	    (let ((on-true-label (operands return-mode)))
+	      (append (make-load-eax-ebx)
+		      `((:cmpl :eax :ebx)
+			(:je ',on-true-label)
+			(,*compiler-global-segment-prefix*
+			 :movl (:edi ,(global-constant-offset 'complicated-eql)) :esi)
+			(:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%2op)))
+			(:je ',on-true-label)))))
+	   ((eq return-mode :boolean-zf=1)
+	    (append (make-load-eax-ebx)
 		    (let ((eql-done (gensym "eql-done-")))
 		      `((:cmpl :eax :ebx)
 			(:je ',eql-done)
 			(,*compiler-global-segment-prefix*
 			 :movl (:edi ,(global-constant-offset 'complicated-eql)) :esi)
 			(:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%2op)))
-			,eql-done)))))))))
+			,eql-done))))
+	   (t (error "unknown eql: ~S" instruction))))))))




From ffjeld at common-lisp.net  Fri Nov 19 23:07:56 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Nov 2004 00:07:56 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1CVHrA-0006tm-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Compiler-macro eql => eql%b.

Date: Sat Nov 20 00:07:50 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.48 movitz/losp/muerte/basic-macros.lisp:1.49
--- movitz/losp/muerte/basic-macros.lisp:1.48	Fri Nov 19 00:49:13 2004
+++ movitz/losp/muerte/basic-macros.lisp	Sat Nov 20 00:07:49 2004
@@ -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.48 2004/11/18 23:49:13 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.49 2004/11/19 23:07:49 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -446,50 +446,12 @@
 	 (:compile-two-forms (:eax :ebx) ,x ,y)
 	 (:cmpl :eax :ebx)))))
 
-#+ignore
-(define-compiler-macro eql (&whole form x y &environment env)
+(define-compiler-macro eql (x y)
   `(let ((x ,x) (y ,y))
-     (with-inline-assembly (:returns :boolean-zf=1)
-       (:eql (:lexical-binding x) (:lexical-binding y)))))
-
-(define-compiler-macro eql (&whole form x y &environment env)
-  (cond
-   ((and (movitz:movitz-constantp x env)
-	 (movitz:movitz-constantp y env))
-    (eql (movitz:movitz-eval x env)
-	 (movitz:movitz-eval y env)))
-   ((movitz:movitz-constantp y env)
-    `(eql ,y ,x))
-   ((and (movitz:movitz-constantp x env)
-	 (not (typep (movitz:movitz-eval x env)
-		     '(and number (not fixnum)))))
-    `(eq ',(movitz:movitz-eval x env) ,y))
-   (t `(with-inline-assembly (:returns :boolean-zf=1 :labels (eql-done))
-	 (:compile-two-forms (:eax :ebx) ,x ,y)
-	 (:cmpl :eax :ebx)
-	 (:je 'eql-done)
-	 (:globally (:movl (:edi (:edi-offset complicated-eql)) :esi))
-	 (:call (:esi (:offset movitz-funobj code-vector%2op)))
-	eql-done))))
+     (eql%b x y)))
 
 (define-compiler-macro values (&rest sub-forms)
   `(inline-values , at sub-forms))
-
-#+ignore
-(define-compiler-macro values (&whole form &rest sub-forms)
-  (case (length sub-forms)
-    (0 `(with-inline-assembly (:returns :multiple-values :side-effects nil :type (values))
-	  (:movl :edi :eax)
-	  (:xorl :ecx :ecx)
-	  (:stc)))
-    (1 `(with-inline-assembly (:returns :eax :side-effects nil :type (values t))
-	  (:compile-form (:result-mode :eax) ,(first sub-forms))))
-    (2 `(with-inline-assembly (:returns :multiple-values :side-effects nil :type (values t t))
-	  (:compile-two-forms (:eax :ebx) ,(first sub-forms) ,(second sub-forms))
-	  (:xorl :ecx :ecx)
-	  (:movb 2 :cl)
-	  (:stc)))
-    (t form)))
 
 (defmacro multiple-value-list (form)
   `(multiple-value-call #'list ,form))




From ffjeld at common-lisp.net  Fri Nov 19 23:56:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Nov 2004 00:56:16 +0100
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CVIbw-0007bH-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fixed bug in :cons-get expander.

Date: Sat Nov 20 00:56:15 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.111 movitz/compiler.lisp:1.112
--- movitz/compiler.lisp:1.111	Sat Nov 20 00:06:58 2004
+++ movitz/compiler.lisp	Sat Nov 20 00:56:14 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.111 2004/11/19 23:06:58 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.112 2004/11/19 23:56:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -6234,13 +6234,13 @@
       (let* ((binding (binding-target (ensure-local-binding (binding-target cell) funobj)))
 	     (location (new-binding-location (binding-target binding) frame-map))
 	     (binding-is-list-p (binding-store-subtypep binding 'list)))
-;;;	 (warn "car of loc ~A bind ~A"
-;;;	       location binding)
+	#+ignore (warn "car of loc ~A bind ~A"
+		       location binding)
 	(cond
 	 ((and binding-is-list-p
 	       (member location '(:eax :ebx :ecx :edx)))
-	  `(,*compiler-nonlocal-lispval-read-segment-prefix*
-	    (:movl (,location ,op-offset) ,dst)))
+	  `((,*compiler-nonlocal-lispval-read-segment-prefix*
+	    :movl (,location ,op-offset) ,dst)))
 	 (binding-is-list-p
 	  `(,@(make-load-lexical binding dst funobj nil frame-map)
 	      (,*compiler-nonlocal-lispval-read-segment-prefix*




From ffjeld at common-lisp.net  Sat Nov 20 01:29:56 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Nov 2004 02:29:56 +0100
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CVK4Z-0000dB-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Tweaked eql some more.

Date: Sat Nov 20 02:29:54 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.112 movitz/compiler.lisp:1.113
--- movitz/compiler.lisp:1.112	Sat Nov 20 00:56:14 2004
+++ movitz/compiler.lisp	Sat Nov 20 02:29:52 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.112 2004/11/19 23:56:14 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.113 2004/11/20 01:29:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2575,8 +2575,11 @@
 
 (defun instruction-uncontinues-p (instruction)
   "Is it impossible for control to return after instruction?"
-  (member (instruction-is instruction)
-	  '(:jmp :ret)))
+  (or (member (instruction-is instruction)
+	      '(:jmp :ret))
+      (member instruction
+	      '((:int 100))
+	      :test #'equalp)))
   
 (defun sub-environment-p (env1 env2)
   (cond
@@ -6589,7 +6592,7 @@
 	(rotatef x y)
 	(rotatef x-type y-type)
 	(rotatef x-singleton y-singleton))
-      (let (;;(x-loc (new-binding-location (binding-target x) frame-map :default nil))
+      (let (;; (x-loc (new-binding-location (binding-target x) frame-map :default nil))
 	    (y-loc (new-binding-location (binding-target y) frame-map :default nil)))
 	#+ignore
 	(warn "eql ~S/~S ~S/~S"
@@ -6617,7 +6620,6 @@
 	      (case (operator return-mode)
 		(:boolean-branch-on-false
 		 (when (not eql)
-		   (warn "constant eql ~S to ~S" instruction (operands return-mode))
 		   `((:jmp ',(operands return-mode)))))
 		(t (break "Constant EQL: ~S ~S" (car x-singleton) (car y-singleton))))))
 	   ((and x-singleton
@@ -6652,15 +6654,22 @@
 				 (movitz-immediate-value (car x-singleton))
 				 y-loc)))
 		      (make-branch))))
+	   ((and x-singleton
+		 (typep (car x-singleton) 'movitz-symbol)
+		 (member y-loc '(:eax :ebx :edx)))
+	    (append (make-load-constant (car x-singleton) y-loc funobj frame-map :op :cmpl)
+		    (make-branch)))
 	   (y-singleton
 	    (break "y-singleton"))
-	   ((or (movitz-subtypep x-type 'fixnum)
-		(movitz-subtypep x-type 'character)
-		(movitz-subtypep y-type 'fixnum)
-		(movitz-subtypep y-type 'character))
+	   ((or (movitz-subtypep x-type '(or fixnum character symbol vector))
+		(movitz-subtypep y-type '(or fixnum character symbol vector)))
 	    (append (make-load-eax-ebx)
 		    `((:cmpl :eax :ebx))
 		    (make-branch)))
+	   #+ignore
+	   ((warn "eql ~S/~S ~S/~S"
+		  x x-loc
+		  y y-loc))
 	   ((eq :boolean-branch-on-false (operator return-mode))
 	    (let ((eql-done (gensym "eql-done-"))
 		  (on-false-label (operands return-mode)))




From ffjeld at common-lisp.net  Sat Nov 20 17:36:09 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Nov 2004 18:36:09 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp 
Message-ID: <E1CVZ9d-0005vR-00@common-lisp.net>

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

Modified Files:
	more-macros.lisp 
Log Message:
Added member compiler-macro.

Date: Sat Nov 20 18:36:07 2004
Author: ffjeld

Index: movitz/losp/muerte/more-macros.lisp
diff -u movitz/losp/muerte/more-macros.lisp:1.20 movitz/losp/muerte/more-macros.lisp:1.21
--- movitz/losp/muerte/more-macros.lisp:1.20	Wed Sep 22 19:48:00 2004
+++ movitz/losp/muerte/more-macros.lisp	Sat Nov 20 18:36:07 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Jun  7 15:05:57 2002
 ;;;;                
-;;;; $Id: more-macros.lisp,v 1.20 2004/09/22 17:48:00 ffjeld Exp $
+;;;; $Id: more-macros.lisp,v 1.21 2004/11/20 17:36:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -134,6 +134,32 @@
 	 ((null ,cons-var) ,result-form)
        (let ((,var (pop ,cons-var)))
 	 , at declarations-and-body))))
+
+(define-compiler-macro member (&whole form item list &key (key ''identity) (test ''eql)
+			       &environment env)
+  (let* ((test (or (and (movitz:movitz-constantp test env)
+			(translate-program (movitz:movitz-eval test env) :muerte.cl :cl))
+		   (and (consp test) (eq 'function (car test))
+			(cadr test))))
+	 (key (or (and (movitz:movitz-constantp key env)
+		       (translate-program (movitz:movitz-eval key env) :muerte.cl :cl))
+		  (and (consp key) (eq 'function (car key))
+		       (cadr key)))))
+    (cond
+     ((and test (symbolp test) (eq key 'identity))
+      `(do ((item ,item)
+	    (p ,list (cdr p)))
+	   ((endp p) nil)
+	 (when (,test (car p) item)
+	   (return p))))
+     ((and test (symbolp test)
+	   key (symbolp key))
+      `(do ((item ,item)
+	    (p ,list (cdr p)))
+	   ((endp p) nil)
+	 (when (,test (car p) (,key item))
+	   (return p))))
+     (t form))))
 
 (defmacro letf* (bindings &body body &environment env)
   "Does what one might expect, saving the old values and setting the generalized




From ffjeld at common-lisp.net  Sat Nov 20 17:43:25 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Nov 2004 18:43:25 +0100
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CVZGf-0005yp-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fixed some lisp-val to untagged-fixnum-ecx conversions.

Date: Sat Nov 20 18:43:19 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.113 movitz/compiler.lisp:1.114
--- movitz/compiler.lisp:1.113	Sat Nov 20 02:29:52 2004
+++ movitz/compiler.lisp	Sat Nov 20 18:43:13 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.113 2004/11/20 01:29:52 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.114 2004/11/20 17:43:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -3377,8 +3377,8 @@
 			((:ebx :ecx :edx :esi) `((:movl :eax ,result-mode)))
 			((:eax :single-value) nil)
 			(:untagged-fixnum-ecx
-			 `((:movl :eax :ecx)
-			   (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)))))
+			 `((,*compiler-global-segment-prefix*
+			    :call (:edi ,(global-constant-offset 'unbox-u32)))))))
 		     ((:ebx :ecx :edx)
 		      (assert (not indirect-p))
 		      (unless (eq result-mode lexb-location)
@@ -4836,27 +4836,14 @@
 	    (values (append code
 			    `((:load-lexical ,returns-provided ,desired-result)))
 		    desired-result))))
-	#+ignore
-	(:untagged-fixnum-eax
-	 (case returns-provided
-	   (:untagged-fixnum-eax
-	    (values code :untagged-fixnum-eax))
-	   ((:eax :single-value :multiple-values :function)
-	    (values (append code
-			    `((:testb ,+movitz-fixnum-zmask+ :al)
-			      (:jnz '(:sub-program (not-an-integer) (:int 107))) ;
-			      (:sarl ,+movitz-fixnum-shift+ :eax)))
-		    :untagged-fixnum-eax))))
 	(:untagged-fixnum-ecx
 	 (case returns-provided
 	   (:untagged-fixnum-ecx
 	    (values code :untagged-fixnum-ecx))
 	   ((:eax :single-value :multiple-values :function)
 	    (values (append code
-			    `((:testb ,+movitz-fixnum-zmask+ :al)
-			      (:jnz '(:sub-program (not-an-integer) (:int 107))) ;
-			      (:movl :eax :ecx)
-			      (:sarl ,+movitz-fixnum-shift+ :ecx)))
+			    `((,*compiler-global-segment-prefix*
+			       :call (:edi ,(global-constant-offset 'unbox-u32)))))
 		    :untagged-fixnum-ecx))
 	   (:ecx
 	    (values (append code




From ffjeld at common-lisp.net  Sun Nov 21 00:10:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 21 Nov 2004 01:10:12 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1CVfIy-0003OV-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Minor tweaking of isqrt.

Date: Sun Nov 21 01:10:11 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.100 movitz/losp/muerte/integers.lisp:1.101
--- movitz/losp/muerte/integers.lisp:1.100	Tue Oct 12 16:43:55 2004
+++ movitz/losp/muerte/integers.lisp	Sun Nov 21 01:10:11 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.100 2004/10/12 14:43:55 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.101 2004/11/21 00:10:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2192,18 +2192,18 @@
 
 (defun isqrt (natural)
   "=> natural-root"
-  (etypecase natural
-    ((eql 0) 0)
-    ((integer 1 *)
-     (let ((r 1))
-       (do ((next-r (truncate (+ r (truncate natural r)) 2)
-		    (truncate (+ r (truncate natural r)) 2)))
-	   ((typep (- next-r r) '(integer 0 1))
-	    (let ((r+1 (1+ r)))
-	      (if (<= (* r+1 r+1) natural)
-		  r+1
-		r)))
-	 (setf r next-r))))))
+  (check-type natural (integer 0 *))
+  (if (= 0 natural)
+      0
+    (let ((r 1))
+      (do ((next-r (truncate (+ r (truncate natural r)) 2)
+		   (truncate (+ r (truncate natural r)) 2)))
+	  ((typep (- next-r r) '(integer 0 1))
+	   (let ((r+1 (1+ r)))
+	     (if (<= (* r+1 r+1) natural)
+		 r+1
+	       r)))
+	(setf r next-r)))))
 
 (defun expt (base-number power-number)
   "Take base-number to the power-number."




From ffjeld at common-lisp.net  Sun Nov 21 12:30:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 21 Nov 2004 13:30:43 +0100
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CVqrb-0005H0-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Changed the way the unbound value is checked for at dynamic lookup: If
the unbound-value is #x7fffffff, we can make and unbound variable
trigger an exception like this:  (:cmpl -1 :eax) (:into).

Date: Sun Nov 21 13:30:36 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.114 movitz/compiler.lisp:1.115
--- movitz/compiler.lisp:1.114	Sat Nov 20 18:43:13 2004
+++ movitz/compiler.lisp	Sun Nov 21 13:30:35 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.114 2004/11/20 17:43:13 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.115 2004/11/21 12:30:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -65,6 +65,9 @@
 the system ensures one way or another that there can be no pointers below
 this size.")
 
+(defvar *compiler-use-into-unbound-protocol* t
+  "Use #x7fffffff as the <unbound-value> and thereby the INTO
+instruction for checking whether a value is the unbound value.")
 
 (defvar *compiler-compile-eval-whens* t
   "When encountering (eval-when (:compile-toplevel) <code>),
@@ -5614,24 +5617,42 @@
 	  :functional-p t
 	  :modifies nil
 	  :final-form form
-	  :code `((:load-constant ,form :eax)
-		  (,*compiler-local-segment-prefix*
-		   :call (:edi ,(global-constant-offset 'dynamic-variable-lookup)))
-		  (,*compiler-local-segment-prefix*
-		   :cmpl :eax (:edi ,(global-constant-offset 'unbound-value)))
-		  (:je '(:sub-program () (:int 99))))))
+	  :code (if *compiler-use-into-unbound-protocol*
+		    `((:load-constant ,form :ebx)
+		      (,*compiler-local-segment-prefix*
+		       :call (:edi ,(global-constant-offset 'dynamic-variable-lookup)))
+		      (:cmpl -1 :eax)
+		      (:into))
+		  (let ((not-unbound (gensym "not-unbound-")))
+		    `((:load-constant ,form :ebx)
+		      (,*compiler-local-segment-prefix*
+		       :call (:edi ,(global-constant-offset 'dynamic-variable-lookup)))
+		      (,*compiler-local-segment-prefix*
+		       :cmpl :eax (:edi ,(global-constant-offset 'unbound-value)))
+		      (:jne ',not-unbound)
+		      (:int 99)
+		      ,not-unbound)))))
        (t (check-type binding dynamic-binding)
 	  (compiler-values ()
 	    :returns :eax
 	    :functional-p t
 	    :modifies nil
 	    :final-form form
-	    :code `((:load-constant ,form :eax)
-		    (,*compiler-local-segment-prefix*
-		     :call (:edi ,(global-constant-offset 'dynamic-variable-lookup)))
-		    (,*compiler-local-segment-prefix*
-		     :cmpl :eax (:edi ,(global-constant-offset 'unbound-value)))
-		    (:je '(:sub-program () (:int 99))))))))))
+	    :code (if *compiler-use-into-unbound-protocol*
+		    `((:load-constant ,form :ebx)
+		      (,*compiler-local-segment-prefix*
+		       :call (:edi ,(global-constant-offset 'dynamic-variable-lookup)))
+		      (:cmpl -1 :eax)
+		      (:into))
+		  (let ((not-unbound (gensym "not-unbound-")))
+		    `((:load-constant ,form :ebx)
+		      (,*compiler-local-segment-prefix*
+		       :call (:edi ,(global-constant-offset 'dynamic-variable-lookup)))
+		      (,*compiler-local-segment-prefix*
+		       :cmpl :eax (:edi ,(global-constant-offset 'unbound-value)))
+		      (:jne ',not-unbound)
+		      (:int 99)
+		      ,not-unbound)))))))))
 
 (define-compiler compile-lambda-form (&form form)
   "3.1.2.2.4 Lambda Forms"




From ffjeld at common-lisp.net  Tue Nov 23 13:45:55 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 14:45:55 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp 
Message-ID: <E1CWazT-0008AL-00@common-lisp.net>

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

Modified Files:
	pci.lisp 
Log Message:
Some basic functions for interfacing the PCI bios32.

Date: Tue Nov 23 14:45:53 2004
Author: ffjeld

Index: movitz/losp/x86-pc/pci.lisp
diff -u movitz/losp/x86-pc/pci.lisp:1.4 movitz/losp/x86-pc/pci.lisp:1.5
--- movitz/losp/x86-pc/pci.lisp:1.4	Sun Nov 14 23:58:02 2004
+++ movitz/losp/x86-pc/pci.lisp	Tue Nov 23 14:45:51 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Dec 14 22:33:42 2003
 ;;;;                
-;;;; $Id: pci.lisp,v 1.4 2004/11/14 22:58:02 ffjeld Exp $
+;;;; $Id: pci.lisp,v 1.5 2004/11/23 13:45:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,13 +18,65 @@
 
 (provide :x86-pc/pci)
 
-(defun find-bios32 ()
+(defun find-bios32-base ()
   (loop for bios32 from #xe0000 to #xffff0 by 16
       if (and (= (memref-int bios32) #x5f32335f)
 	      (loop with checksum = 0
-				    ;; initially (warn "PCI magic found at #x~X" bios32)
 		  as i from 0 below (* 16 (memref-int bios32 :offset 9 :type :unsigned-byte8))
 		  do (incf checksum
 			   (memref-int bios32 :offset i :type :unsigned-byte8))
 		  finally (return (= 0 (ldb (byte 8 0 ) checksum)))))
       return bios32))
+
+(defvar *bios32-base* nil)
+
+(defun init-pci ()
+  (setf *bios32-base*
+    (find-bios32-base))
+  (if (not *bios32-base*)
+      (error "No PCI BIOS32 found.")
+    (let ((entry (memref-int *bios32-base* :offset 4))
+	  (revision (memref-int *bios32-base* :offset 8 :type :unsigned-byte8))
+	  (length (memref-int *bios32-base* :offset 9 :type :unsigned-byte8)))
+      (values entry revision length))))
+
+(defun pci-far-call (address &key (eax 0) (ebx 0) (cs 8))
+  "Make a 'far call' to cs:address with the provided values for eax and ebx.
+Returns the values of registers AL, EBX, ECX, and EDX. (Well, for now only the
+lower 30 bits are actually returned.) The stack discipline is broken during
+this call, so we disable interrupts in a somewhat feeble attempt to avoid trouble."
+  (without-interrupts
+    (with-inline-assembly (:returns :multiple-values)
+      (:load-lexical (:lexical-binding cs) :untagged-fixnum-ecx)
+      (:pushl :ecx)			; Code segment
+      (:load-lexical (:lexical-binding address) :untagged-fixnum-ecx)
+      (:pushl :ecx)			; Code address
+      (:load-lexical (:lexical-binding ebx) :untagged-fixnum-ecx)
+      (:pushl :ecx)			; EBX
+      (:load-lexical (:lexical-binding eax) :untagged-fixnum-ecx)
+      (:movl :ecx :eax)
+      (:popl :ebx)
+      (:call-segment (:esp))
+      (:leal (:esp 8) :esp)
+      (:andl #xff :eax)
+      (:shll 2 :eax)
+      (:shll 2 :ebx)
+      (:shll 2 :ecx)
+      (:shll 2 :edx)
+      (:locally (:movl :ecx (:edi (:edi-offset values) 0)))
+      (:locally (:movl :edx (:edi (:edi-offset values) 4)))
+      (:movl 4 :ecx)
+      (:stc))))
+
+(defun pci-directory (eax &optional (ebx 0))
+  "Calling with '$PCI' should find the PCI directory."
+  (unless *bios32-base*
+    (init-pci))
+  (let ((eax (etypecase eax
+	       ((unsigned-byte 32)
+		eax)
+	       (string
+		(loop for c across eax as i upfrom 0 by 8
+		    summing (ash (char-code c) i))))))
+    (pci-far-call (memref-int *bios32-base* :offset 4)
+		  :eax eax :ebx ebx)))




From ffjeld at common-lisp.net  Tue Nov 23 16:00:25 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:00:25 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arithmetic-macros.lisp 
Message-ID: <E1CWd5d-0001jO-00@common-lisp.net>

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

Modified Files:
	arithmetic-macros.lisp 
Log Message:
*** empty log message ***
Date: Tue Nov 23 17:00:21 2004
Author: ffjeld

Index: movitz/losp/muerte/arithmetic-macros.lisp
diff -u movitz/losp/muerte/arithmetic-macros.lisp:1.8 movitz/losp/muerte/arithmetic-macros.lisp:1.9
--- movitz/losp/muerte/arithmetic-macros.lisp:1.8	Mon Oct 11 15:52:04 2004
+++ movitz/losp/muerte/arithmetic-macros.lisp	Tue Nov 23 17:00:20 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 13:42:46 2004
 ;;;;                
-;;;; $Id: arithmetic-macros.lisp,v 1.8 2004/10/11 13:52:04 ffjeld Exp $
+;;;; $Id: arithmetic-macros.lisp,v 1.9 2004/11/23 16:00:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -95,18 +95,21 @@
 	 (movitz:movitz-constantp max env))
     (let ((min (movitz:movitz-eval min env))
 	  (max (movitz:movitz-eval max env)))
-      (check-type min fixnum)
-      (check-type max fixnum)
       (cond
        ((movitz:movitz-constantp x env)
 	(<= min (movitz:movitz-eval x env) max))
        ((< max min)
-	nil)
+	`(progn ,x nil))
        ((= max min)
 	`(= ,x ,min))
        ((minusp min)
 	`(let ((x ,x))
 	   (and (<= ,min x) (<= x ,max))))
+       ((or (not (typep min 'fixnum))
+	    (not (typep max 'fixnum)))
+	`(let ((x ,x))
+	   (and (<=%2op ,min x)
+		(<=%2op x ,max))))
        ((= 0 min)
 	`(with-inline-assembly (:returns :boolean-cf=1)
 	   (:compile-form (:result-mode :eax) ,x)




From ffjeld at common-lisp.net  Tue Nov 23 16:02:37 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:02:37 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1CWd7l-0001sp-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
*** empty log message ***
Date: Tue Nov 23 17:02:34 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.49 movitz/losp/muerte/basic-macros.lisp:1.50
--- movitz/losp/muerte/basic-macros.lisp:1.49	Sat Nov 20 00:07:49 2004
+++ movitz/losp/muerte/basic-macros.lisp	Tue Nov 23 17:02:34 2004
@@ -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.49 2004/11/19 23:07:49 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.50 2004/11/23 16:02:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1042,12 +1042,12 @@
 (define-compiler-macro boundp (symbol)
   `(with-inline-assembly-case ()
      (do-case (t :boolean-zf=0 :labels (boundp-done))
-       (:compile-form (:result-mode :eax) ,symbol)
-       (:leal (:eax ,(- (movitz:tag :symbol))) :ecx)
+       (:compile-form (:result-mode :ebx) ,symbol)
+       (:leal (:ebx ,(- (movitz:tag :symbol))) :ecx)
        (:testb 7 :cl)
        (:jne '(:sub-program () (:int 66)))
        (:call-local-pf dynamic-variable-lookup)
-       (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax)))))
+       (:globally (:cmpl (:edi (:edi-offset new-unbound-value)) :eax)))))
 
 (defmacro define-global-variable (name init-form &optional docstring)
   "A global variable will be accessed by ignoring local bindings."




From ffjeld at common-lisp.net  Tue Nov 23 16:03:36 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:03:36 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1CWd8i-0001tG-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Changed the dynamic-env a bit, reflect this in with-each-dynamic-context.

Date: Tue Nov 23 17:03:35 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.43 movitz/losp/muerte/inspect.lisp:1.44
--- movitz/losp/muerte/inspect.lisp:1.43	Mon Oct 11 15:52:44 2004
+++ movitz/losp/muerte/inspect.lisp	Tue Nov 23 17:03:35 2004
@@ -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.43 2004/10/11 13:52:44 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.44 2004/11/23 16:03:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -103,6 +103,7 @@
   "Only use this if you know what you're doing. See run-time.lisp."
   (let ((context (gensym "dynamic-context-"))
 	(tag (gensym "dynamic-tag-"))
+	(name (gensym "dynamic-name-"))
 	(bind-clause (find :binding clauses :key #'caar))
 	(catch-clause (find :catch clauses :key #'caar))
 	(up-clause (find :unwind-protect clauses :key #'caar))
@@ -110,10 +111,12 @@
     `(do ((,context ,(if start-context start-context '(current-dynamic-context))
 		    (dynamic-context-uplink ,context)))
 	 ((not (plusp ,context)) ,result)
-       (let ((,tag (dynamic-context-tag ,context)))
+       (let ((,tag (dynamic-context-tag ,context))
+	     (,name (stack-frame-ref nil ,context 0 :lisp)))
+	 (declare (ignorable ,name))
 	 (cond
 	  ,@(when bind-clause
-	      `(((eq ,tag (load-global-constant unbound-value))
+	      `(((symbolp ,name)
 		 (multiple-value-bind ,(cdar bind-clause)
 		     (values ,context
 			     (stack-frame-ref nil ,context 0 :lisp)




From ffjeld at common-lisp.net  Tue Nov 23 16:05:28 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:05:28 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1CWdAW-0001tk-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Try to be a bit more clever in dpb.

Date: Tue Nov 23 17:05:25 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.101 movitz/losp/muerte/integers.lisp:1.102
--- movitz/losp/muerte/integers.lisp:1.101	Sun Nov 21 01:10:11 2004
+++ movitz/losp/muerte/integers.lisp	Tue Nov 23 17:05:23 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.101 2004/11/21 00:10:11 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.102 2004/11/23 16:05:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2119,8 +2119,12 @@
 	 
 
 (defun dpb (newbyte bytespec integer)
-  (logior (mask-field bytespec (ash newbyte (byte-position bytespec)))
-	  (logandc2 integer (mask-field bytespec -1))))
+  (logior (if (= 0 newbyte)
+	      0
+	    (mask-field bytespec (ash newbyte (byte-position bytespec))))
+	  (if (= 0 integer)
+	      0
+	    (logandc2 integer (mask-field bytespec -1)))))
 
 (defun mask-field (bytespec integer)
   (ash (ldb bytespec integer) (byte-position bytespec)))




From ffjeld at common-lisp.net  Tue Nov 23 16:06:00 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:06:00 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp 
Message-ID: <E1CWdB2-0001uA-00@common-lisp.net>

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

Modified Files:
	interrupt.lisp 
Log Message:
Recognize the INTO unbound-variable protocol.

Date: Tue Nov 23 17:05:59 2004
Author: ffjeld

Index: movitz/losp/muerte/interrupt.lisp
diff -u movitz/losp/muerte/interrupt.lisp:1.32 movitz/losp/muerte/interrupt.lisp:1.33
--- movitz/losp/muerte/interrupt.lisp:1.32	Fri Nov 19 21:16:15 2004
+++ movitz/losp/muerte/interrupt.lisp	Tue Nov 23 17:05:59 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Apr  7 01:50:03 2004
 ;;;;                
-;;;; $Id: interrupt.lisp,v 1.32 2004/11/19 20:16:15 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.33 2004/11/23 16:05:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -286,7 +286,15 @@
 	(case vector
 	  (0 (error 'division-by-zero))
 	  (3 (break "Break instruction at ~@Z." $eip))
-	  (4 (error "Primitive overflow assertion failed."))
+	  (4 (warn "into ~@Z" $eax)
+	     (if (not (eq (load-global-constant new-unbound-value)
+			  (dereference $eax)))
+		 (error "Primitive overflow assertion failed.")
+	       (let ((name (dereference $ebx)))
+		 (with-simple-restart (new-value "Set the value of ~S." name)
+		   (error 'unbound-variable :name name))
+		 (format *query-io* "~&Enter a value for ~S: " name)
+		 (setf (dereference $eax) (read *query-io*)))))
 	  (6 (error "Illegal instruction at ~@Z." $eip))
 	  (13  (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z"
 		     $eip
@@ -360,10 +368,6 @@
 	   (let ((name (dereference $edx)))
 	     (when (symbolp name)
 	       (error 'undefined-function :name name))))
-	  (99
-	   (let ((name (dereference $edx)))
-	     (when (symbolp name)
-	       (error 'unbound-variable :name name))))
 	  ((100);; 101 102 103 104 105)
 	   (let ((funobj (dereference (+ dit-frame (dit-frame-index :esi))))
 		 (code (dit-frame-ref nil dit-frame :ecx :unsigned-byte8)))




From ffjeld at common-lisp.net  Tue Nov 23 16:06:39 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:06:39 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp 
Message-ID: <E1CWdBf-0001ua-00@common-lisp.net>

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

Modified Files:
	los-closette.lisp 
Log Message:
change to new-unbound-value.

Date: Tue Nov 23 17:06:37 2004
Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.22 movitz/losp/muerte/los-closette.lisp:1.23
--- movitz/losp/muerte/los-closette.lisp:1.22	Thu Oct 21 22:34:06 2004
+++ movitz/losp/muerte/los-closette.lisp	Tue Nov 23 17:06:37 2004
@@ -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.22 2004/10/21 20:34:06 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.23 2004/11/23 16:06:37 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -134,7 +134,7 @@
 (defun std-allocate-instance (class)
   (allocate-std-instance class
 			 (allocate-slot-storage (count-if 'instance-slot-p (class-slots class))
-						(load-global-constant unbound-value))))
+						(load-global-constant new-unbound-value))))
 
 (defun allocate-slot-storage (size initial-value)
   (make-array size :initial-element initial-value))
@@ -881,9 +881,11 @@
        (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
 	:movl (:eax (:offset movitz-basic-vector data ,(* location 4))) :eax)
        (#.movitz:*compiler-global-segment-prefix*
-	:cmpl :eax ,(movitz::make-indirect-reference :edi (movitz::global-constant-offset 'unbound-value)))
+	:cmpl :eax ,(movitz::make-indirect-reference :edi (movitz::global-constant-offset
+							   'new-unbound-value)))
        (:je '(:sub-program (unbound)
-	      (:compile-form (:result-mode :multiple-values) (slot-unbound-trampoline instance ,location))
+	      (:compile-form (:result-mode :multiple-values)
+	       (slot-unbound-trampoline instance ,location))
 	      (:jmp 'done)))
        (:clc)
        done)))
@@ -923,13 +925,13 @@
 	     (symbol-function (svref *standard-effective-slot-readers* slot-location))
 	   (lambda (instance)
 	     (let ((x (standard-instance-access instance slot-location)))
-	       (if (not (eq x (load-global-constant unbound-value)))
+	       (if (not (eq x (load-global-constant new-unbound-value)))
 		   x
 		 (slot-unbound-trampoline instance slot-location))))))
 	(funcallable-standard-class
 	 (lambda (instance)
 	   (let ((x (svref (std-gf-instance-slots instance) slot-location)))
-	     (if (not (eq x (load-global-constant unbound-value)))
+	     (if (not (eq x (load-global-constant new-unbound-value)))
 		 x
 	       (slot-unbound-trampoline instance slot-location)))))))))
 
@@ -1288,7 +1290,7 @@
   (let* ((location (slot-definition-location (find-slot (std-instance-class instance) slot-name)))
          (slots (std-instance-slots instance))
          (val (svref slots location)))
-    (if (eq (load-global-constant unbound-value) val)
+    (if (eq (load-global-constant new-unbound-value) val)
         (error "The slot ~S is unbound in the object ~S."
                slot-name instance)
       val)))
@@ -1299,7 +1301,7 @@
     (let* ((location (slot-definition-location slot))
 	   (slots (std-gf-instance-slots instance))
 	   (val (svref slots location)))
-      (if (eq (load-global-constant unbound-value) val)
+      (if (eq (load-global-constant new-unbound-value) val)
 	  (error "The slot ~S is unbound in the object ~S."
 		 slot-name instance)
 	val))))
@@ -1314,7 +1316,7 @@
 (defmethod slot-value-using-class ((class standard-class) object
 				   (slot standard-effective-slot-definition))
   (let ((x (standard-instance-access object (slot-definition-location slot))))
-    (if (eq x (load-global-constant unbound-value))
+    (if (eq x (load-global-constant new-unbound-value))
 	(slot-unbound class object (slot-definition-name slot))
       x)))
 
@@ -1323,7 +1325,7 @@
   (let* ((location (slot-definition-location slot))
          (slots (std-gf-instance-slots object))
          (val (svref slots location)))
-    (if (eq (load-global-constant unbound-value) val)
+    (if (eq (load-global-constant new-unbound-value) val)
 	(slot-unbound class object (slot-definition-name slot))        
       val)))
 
@@ -1361,11 +1363,11 @@
       (slot-boundp-using-class class object slot))))
 
 (defmethod slot-boundp-using-class ((class standard-class) object (slot standard-effective-slot-definition))
-  (not (eq (load-global-constant unbound-value)
+  (not (eq (load-global-constant new-unbound-value)
 	   (standard-instance-access object (slot-definition-location slot)))))
   
 (defmethod slot-boundp-using-class ((class funcallable-standard-class) object (slot standard-effective-slot-definition))
-  (not (eq (load-global-constant unbound-value)
+  (not (eq (load-global-constant new-unbound-value)
 	   (svref (std-gf-instance-slots object) (slot-definition-location slot)))))
 
 (defmethod slot-boundp-using-class ((class built-in-class) object slot)
@@ -1381,12 +1383,12 @@
 
 (defmethod slot-makunbound-using-class ((class standard-class) object (slot standard-effective-slot-definition))
   (setf (standard-instance-access object (slot-definition-location slot))
-    (load-global-constant unbound-value))
+    (load-global-constant new-unbound-value))
   object)
   
 (defmethod slot-makunbound-using-class ((class funcallable-standard-class) object (slot standard-effective-slot-definition))
   (setf (svref (std-gf-instance-slots object) (slot-definition-location slot))
-    (load-global-constant unbound-value))
+    (load-global-constant new-unbound-value))
   object)
 
 (defmethod slot-makunbound-using-class ((class built-in-class) object slot)
@@ -1748,7 +1750,7 @@
     ;; (warn "access ~S of ~S at ~S" slot-name class-name location)
     (assert location)
     (let ((x (standard-instance-access slot location)))
-      (if (eq x (load-global-constant unbound-value))
+      (if (eq x (load-global-constant new-unbound-value))
 	  (error "The slot ~S is unbound in the ~S ~Z." slot-name class-name slot)
 	x))))
 




From ffjeld at common-lisp.net  Tue Nov 23 16:07:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:07:38 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1CWdCc-0001v3-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Improved memref :unsigned-byte8 and :unsigned-byte16 a bit.

Date: Tue Nov 23 17:07:37 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.38 movitz/losp/muerte/memref.lisp:1.39
--- movitz/losp/muerte/memref.lisp:1.38	Sun Nov 14 23:57:45 2004
+++ movitz/losp/muerte/memref.lisp	Tue Nov 23 17:07:37 2004
@@ -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.38 2004/11/14 22:57:45 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.39 2004/11/23 16:07:37 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -73,11 +73,22 @@
 	      (case type
 		(:unsigned-byte8
 		 (cond
-		  ((and (eq 0 offset) (eq 0 index))
+		  ((and (eql 0 offset) (eql 0 index))
 		   `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8))
 		      (:compile-form (:result-mode :eax) ,object)
 		      (:movzxb (:eax ,(offset-by 1)) :ecx)))
-		  ((eq 0 offset)
+		  ((eql 0 index)
+		   (let ((object-var (gensym "memref-object-"))
+			 (offset-var (gensym "memref-offset-")))
+		     `(let ((,object-var ,object)
+			    (,offset-var ,offset))
+			(with-inline-assembly (:returns :untagged-fixnum-ecx
+							:type (unsigned-byte 16))
+			  (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object-var ,offset-var)
+			  ;; (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
+			  (:movzxb (:eax :ecx ,(offset-by 1)) :ecx)
+			  ))))
+		  ((eql 0 offset)
 		   `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8))
 		      (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object ,index)
 		      (:movzxb (:eax :ecx ,(offset-by 1)) :ecx)))
@@ -97,18 +108,30 @@
 					  (:little nil)
 					  (:big `((:xchgb :cl :ch))))))
 		   (cond
-		    ((and (eq 0 offset) (eq 0 index))
+		    ((and (eql 0 offset) (eql 0 index))
 		     `(with-inline-assembly (:returns :untagged-fixnum-ecx
 						      :type (unsigned-byte 16))
 			(:compile-form (:result-mode :eax) ,object)
 			(:movzxw (:eax ,(offset-by 2)) :ecx)
 			, at endian-fix-ecx))
-		    ((eq 0 offset)
+		    ((eql 0 index)
+		     (let ((object-var (gensym "memref-object-"))
+			   (offset-var (gensym "memref-offset-")))
+		       `(let ((,object-var ,object)
+			      (,offset-var ,offset))
+			  (with-inline-assembly (:returns :untagged-fixnum-ecx
+							  :type (unsigned-byte 16))
+			    (:compile-two-forms (:eax :ecx) ,object-var ,offset-var)
+			    (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
+			    (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)
+			    , at endian-fix-ecx))))
+		    ((eql 0 offset)
 		     (let ((object-var (gensym "memref-object-"))
 			   (index-var (gensym "memref-index-")))
 		       `(let ((,object-var ,object)
 			      (,index-var ,index))
-			  (with-inline-assembly (:returns :untagged-fixnum-ecx)
+			  (with-inline-assembly (:returns :untagged-fixnum-ecx
+							  :type (unsigned-byte 16))
 			    (:compile-two-forms (:eax :ecx) ,object-var ,index-var)
 			    (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
 			    (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)




From ffjeld at common-lisp.net  Tue Nov 23 16:09:00 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:09:00 +0100
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1CWdDw-0001vt-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
New dynamic-variable protocol.

Date: Tue Nov 23 17:08:58 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.54 movitz/losp/muerte/primitive-functions.lisp:1.55
--- movitz/losp/muerte/primitive-functions.lisp:1.54	Wed Nov 17 14:33:34 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Tue Nov 23 17:08:58 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.54 2004/11/17 13:33:34 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.55 2004/11/23 16:08:58 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -162,53 +162,53 @@
     ;; Default binding strategy is naive deep binding, so this is a NOP.
     (:ret)))
     
-(define-primitive-function dynamic-variable-lookup (symbol)
-  "Load the dynamic value of SYMBOL into EAX."
-  (with-inline-assembly (:returns :multiple-values)
-    (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx))
-    (:jecxz 'no-stack-binding)
-    ;; Be defensive: Verify that ECX is within stack.
-    (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx))
-    (:cmpl :eax (:ecx))
-    (:je 'success)
-   search-loop
-    (:movl (:ecx 12) :ecx)		; parent
-    (:jecxz 'no-stack-binding)
-    ;; Be defensive: Verify that ECX is within stack.
-    (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx))
-    (:cmpl :eax (:ecx))			; compare name
-    (:jne 'search-loop)
-    ;; fall through on success
-   success
-    (:movl :eax :edx)			; Keep symbol in case it's unbound.
-    (:movl (:ecx 8) :eax)
-    (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax))
-    (:je '(:sub-program (unbound) (:int 99)))
-    (:ret)
-   no-stack-binding
-    ;; take the global value of SYMBOL, compare it against unbond-value
-    (:movl :eax :edx)			; Keep symbol in case it's unbound.
-    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
-     :movl (:eax (:offset movitz-symbol value)) :eax)
-    (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax))
-    (:je '(:sub-program (unbound) (:int 99)))
-    (:ret)))
+;;;(define-primitive-function dynamic-variable-lookup (symbol)
+;;;  "Load the dynamic value of SYMBOL into EAX."
+;;;  (with-inline-assembly (:returns :multiple-values)
+;;;    (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx))
+;;;    (:jecxz 'no-stack-binding)
+;;;    ;; Be defensive: Verify that ECX is within stack.
+;;;    (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx))
+;;;    (:cmpl :eax (:ecx))
+;;;    (:je 'success)
+;;;   search-loop
+;;;    (:movl (:ecx 12) :ecx)		; parent
+;;;    (:jecxz 'no-stack-binding)
+;;;    ;; Be defensive: Verify that ECX is within stack.
+;;;    (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx))
+;;;    (:cmpl :eax (:ecx))			; compare name
+;;;    (:jne 'search-loop)
+;;;    ;; fall through on success
+;;;   success
+;;;    (:movl :eax :edx)			; Keep symbol in case it's unbound.
+;;;    (:movl (:ecx 8) :eax)
+;;;    (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax))
+;;;    (:je '(:sub-program (unbound) (:int 99)))
+;;;    (:ret)
+;;;   no-stack-binding
+;;;    ;; take the global value of SYMBOL, compare it against unbond-value
+;;;    (:movl :eax :edx)			; Keep symbol in case it's unbound.
+;;;    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+;;;     :movl (:eax (:offset movitz-symbol value)) :eax)
+;;;    (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax))
+;;;    (:je '(:sub-program (unbound) (:int 99)))
+;;;    (:ret)))
 
-(define-primitive-function dynamic-variable-lookup-unbound (symbol)
-  "Load the dynamic value of SYMBOL into EAX. If unbound, return unbound-value."
+(define-primitive-function dynamic-variable-lookup (symbol)
+  "Load the dynamic value of SYMBOL/EBX into EAX. If unbound, return unbound-value."
   (with-inline-assembly (:returns :multiple-values)
     (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx))
     (:jecxz 'no-stack-binding)
     ;; Be defensive: Verify that ECX is within stack.
     (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx))
-    (:cmpl :eax (:ecx))
+    (:cmpl :ebx (:ecx))
     (:je 'success)
    search-loop
     (:movl (:ecx 12) :ecx)		; parent
     (:jecxz 'no-stack-binding)
     ;; Be defensive: Verify that ECX is within stack.
     (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx))
-    (:cmpl :eax (:ecx))			; compare name
+    (:cmpl :ebx (:ecx))			; compare name
     (:jne 'search-loop)
     ;; fall through on success
    success
@@ -217,7 +217,7 @@
    no-stack-binding
     ;; take the global value of SYMBOL, compare it against unbond-value
     (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
-     :movl (:eax (:offset movitz-symbol value)) :eax)
+     :movl (:ebx (:offset movitz-symbol value)) :eax)
     (:ret)))
 
 (define-primitive-function dynamic-variable-store (symbol value)




From ffjeld at common-lisp.net  Tue Nov 23 16:09:19 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:09:19 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1CWdEF-0001wJ-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Recognize #x7ffffff as unbound-value.

Date: Tue Nov 23 17:09:18 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.34 movitz/losp/muerte/scavenge.lisp:1.35
--- movitz/losp/muerte/scavenge.lisp:1.34	Fri Oct 22 09:57:25 2004
+++ movitz/losp/muerte/scavenge.lisp	Tue Nov 23 17:09:17 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.34 2004/10/22 07:57:25 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.35 2004/11/23 16:09:17 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -53,13 +53,14 @@
 	  (when verbose
 	    (format *terminal-io* " [at ~S: ~S]" scan x))
 	  (cond
-	   ((or (and (= 0 x2) (= 2 x))
-		(and (= #xffff x2) (= #xfffe x))))
 	   ((let ((tag (ldb (byte 3 0) x)))
 	      (or (= tag #.(movitz:tag :null))
 		  (= tag #.(movitz:tag :even-fixnum))
 		  (= tag #.(movitz:tag :odd-fixnum))
 		  (scavenge-typep x :character))))
+	   ((or (and (= 0 x2) (= 2 x))
+		(and (= #xffff x2) (= #xfffe x))
+		(and (= #x7fff x2) (= #xffff x))))
 	   ((scavenge-typep x :illegal)
 	    (error "Illegal word ~S at ~S." x scan))
 	   ((scavenge-typep x :bignum)




From ffjeld at common-lisp.net  Tue Nov 23 16:09:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:09:38 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp 
Message-ID: <E1CWdEY-0001wj-00@common-lisp.net>

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

Modified Files:
	symbols.lisp 
Log Message:
New dynamic variable protocol.

Date: Tue Nov 23 17:09:34 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.25 movitz/losp/muerte/symbols.lisp:1.26
--- movitz/losp/muerte/symbols.lisp:1.25	Thu Nov 18 18:59:11 2004
+++ movitz/losp/muerte/symbols.lisp	Tue Nov 23 17:09:34 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 23:55:41 2001
 ;;;;                
-;;;; $Id: symbols.lisp,v 1.25 2004/11/18 17:59:11 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.26 2004/11/23 16:09:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -44,16 +44,18 @@
     (null nil)
     (symbol
      (with-inline-assembly (:returns :eax)
-       (:compile-form (:result-mode :eax) symbol)
+       (:compile-form (:result-mode :ebx) symbol)
        (:call-local-pf dynamic-variable-lookup)
-       (:locally (:cmpl :eax (:edi (:edi-offset unbound-value))))
-       (:je '(:sub-program (unbound) (:int 99)))))))
+       (:cmpl -1 :eax)
+       (:into)))))
+;;;       (:locally (:cmpl :eax (:edi (:edi-offset unbound-value))))
+;;;       (:je '(:sub-program (unbound) (:int 99)))))))
 
 (defun %unbounded-symbol-value (symbol)
   "Return the symbol's value without checking if it's bound or not."
   (check-type symbol symbol)
   (with-inline-assembly (:returns :eax)
-    (:compile-form (:result-mode :eax) symbol)
+    (:compile-form (:result-mode :ebx) symbol)
     (:call-local-pf dynamic-variable-lookup)
    done))
 
@@ -129,7 +131,7 @@
 
 (defun makunbound (symbol)
   (setf (symbol-value symbol)
-    (load-global-constant unbound-value))
+    (load-global-constant new-unbound-value))
   symbol)
 
 (defun fboundp (symbol)
@@ -138,7 +140,7 @@
 
 (defun %create-symbol (name &optional (package nil)
 				      (plist nil)
-				      (value (load-global-constant unbound-value))
+				      (value (load-global-constant new-unbound-value))
 				      (function (load-global-constant movitz::unbound-function))
 				      (flags 0))
   (eval-when (:compile-toplevel)




From ffjeld at common-lisp.net  Tue Nov 23 16:10:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:10:20 +0100
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CWdFE-0001xH-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Minor tweaks.

Date: Tue Nov 23 17:10:18 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.115 movitz/compiler.lisp:1.116
--- movitz/compiler.lisp:1.115	Sun Nov 21 13:30:35 2004
+++ movitz/compiler.lisp	Tue Nov 23 17:10:17 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.115 2004/11/21 12:30:35 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.116 2004/11/23 16:10:17 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -3484,6 +3484,10 @@
 		    (ecase (operator binding-location)
 		      ((:eax :ebx :ecx :edx)
 		       `((:pushl ,binding-location)))
+		      (:untagged-fixnum-ecx
+		       `((,*compiler-local-segment-prefix*
+			  :call (:edi ,(global-constant-offset 'box-u32-ecx)))
+			 (:pushl :eax)))
 		      (:argument-stack
 		       (assert (<= 2 (function-argument-argnum binding)) ()
 			 ":load-lexical argnum can't be ~A." (function-argument-argnum binding))
@@ -6446,6 +6450,9 @@
 	   (result-type (multiple-value-call #'encoded-integer-types-add
 			  (values-list (binding-store-type term0))
 			  (values-list (binding-store-type term1)))))
+;;;      (warn "dest: ~S ~S"
+;;;	    (apply #'encoded-type-decode (binding-store-type destination))
+;;;	    result-type)	    
       (when (binding-lended-p term0)
 	(warn "Add for lend0: ~S" term0))
       (when (binding-lended-p term1)
@@ -6669,8 +6676,10 @@
 		    (make-branch)))
 	   (y-singleton
 	    (break "y-singleton"))
-	   ((or (movitz-subtypep x-type '(or fixnum character symbol vector))
-		(movitz-subtypep y-type '(or fixnum character symbol vector)))
+	   ((and (not (eq t x-type))	; this is for bootstrapping purposes.
+		 (not (eq t y-type))	; ..
+		 (or (movitz-subtypep x-type '(or fixnum character symbol vector))
+		     (movitz-subtypep y-type '(or fixnum character symbol vector))))
 	    (append (make-load-eax-ebx)
 		    `((:cmpl :eax :ebx))
 		    (make-branch)))




From ffjeld at common-lisp.net  Tue Nov 23 16:10:40 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:10:40 +0100
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1CWdFY-0001xi-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
new-unbound-value.

Date: Tue Nov 23 17:10:39 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.80 movitz/image.lisp:1.81
--- movitz/image.lisp:1.80	Thu Nov 18 18:58:41 2004
+++ movitz/image.lisp	Tue Nov 23 17:10:38 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.80 2004/11/18 17:58:41 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.81 2004/11/23 16:10:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -149,11 +149,11 @@
     :binary-type movitz-symbol
     :reader movitz-run-time-context-null-symbol
     :initarg :null-symbol)
-   (unbound-value
-    :binary-type word
-    :map-binary-read-delayed 'movitz-word
-    :map-binary-write 'movitz-read-and-intern
-    :initform 'muerte::unbound)
+   (new-unbound-value
+    :binary-type lu32
+;;;    :map-binary-read-delayed 'movitz-word
+;;;    :map-binary-write 'movitz-read-and-intern
+    :initform #x7fffffff)
    ;; primitive functions global constants
    (pop-current-values
     :binary-type code-vector-word
@@ -420,7 +420,7 @@
     :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 10 :dpl 0
+    :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
@@ -626,7 +626,7 @@
 (defun unbound-value ()
   (declare (special *image*))
   (slot-value (image-run-time-context *image*)
-	      'unbound-value))
+	      'new-unbound-value))
 
 (defun edi-offset ()
   (declare (special *image*))




From ffjeld at common-lisp.net  Tue Nov 23 16:10:54 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:10:54 +0100
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1CWdFm-0001y8-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
*** empty log message ***
Date: Tue Nov 23 17:10:52 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.40 movitz/packages.lisp:1.41
--- movitz/packages.lisp:1.40	Fri Nov 12 15:51:37 2004
+++ movitz/packages.lisp	Tue Nov 23 17:10:51 2004
@@ -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.40 2004/11/12 14:51:37 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.41 2004/11/23 16:10:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1151,6 +1151,8 @@
 	   
 	   #:%symbol-global-value
 	   #:define-global-variable
+	   
+	   #:movitz-type-slot-offset
 	   
 	   vector-element-type
 	   vector-element-size




From ffjeld at common-lisp.net  Tue Nov 23 16:11:33 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:11:33 +0100
Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp 
Message-ID: <E1CWdGP-0001zL-00@common-lisp.net>

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

Modified Files:
	procfs-image.lisp 
Log Message:
Have with-bochs-image copy the ds-segment etc. from *image*.

Date: Tue Nov 23 17:11:31 2004
Author: ffjeld

Index: movitz/procfs-image.lisp
diff -u movitz/procfs-image.lisp:1.20 movitz/procfs-image.lisp:1.21
--- movitz/procfs-image.lisp:1.20	Fri Nov 12 15:41:10 2004
+++ movitz/procfs-image.lisp	Tue Nov 23 17:11:31 2004
@@ -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.20 2004/11/12 14:41:10 ffjeld Exp $
+;;;; $Id: procfs-image.lisp,v 1.21 2004/11/23 16:11:31 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -72,6 +72,12 @@
 	 (pid (bochs-parameter :pid ,path)))
      (procfs:with-procfs-attached (,procfs-var pid :direction :io)
        (let ((,image-var (make-instance 'bochs-image
+			   :ds-segment-base (if (boundp '*previous-image*)
+						(image-ds-segment-base *previous-image*)
+					      0)
+			   :cs-segment-base (if (boundp '*previous-image*)
+						(image-cs-segment-base *previous-image*)
+					      0)
 			   :pid pid
 			   :procfs ,procfs-var
 			   :stream (procfs:procfs-connection-mem-stream ,procfs-var)




From ffjeld at common-lisp.net  Tue Nov 23 16:12:34 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:12:34 +0100
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1CWdHO-00020t-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
new-unbound-value

Date: Tue Nov 23 17:12:27 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.37 movitz/special-operators-cl.lisp:1.38
--- movitz/special-operators-cl.lisp:1.37	Fri Nov 19 21:12:37 2004
+++ movitz/special-operators-cl.lisp	Tue Nov 23 17:12:25 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.37 2004/11/19 20:12:37 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.38 2004/11/23 16:12:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -97,29 +97,36 @@
 		    and do (incf (num-specials local-env))
 			;; lexical...
 		    else collect
-			 (compiler-values-bind (&code init-code	&functional-p functional-p
-						&type type &returns init-register
-						&final-form final-form)
-			     (compiler-call #'compile-form-to-register
-			       :env init-env
-			       :defaults all
-			       :form init-form
-			       :modify-accumulate let-modifies)
-			   ;; (warn "prod: ~S, type: ~S" prod type)
-			   (list var
-				 init-form
-				 init-code
-				 functional-p
-				 (let ((init-type (type-specifier-primary type)))
-				   (assert init-type ()
-				     "The init-form ~S yielded the empty primary type!" type)
-				   init-type)
-				 (case init-register
-				   (:non-local-exit :edi)
-				   (t init-register))
-				 final-form))
-		    and do (movitz-env-add-binding local-env (make-instance 'located-binding
-							       :name var)))))
+			 (let ((binding (make-instance 'located-binding :name var)))
+			   (movitz-env-add-binding local-env binding)
+			   (compiler-values-bind (&code init-code	&functional-p functional-p
+						  &type type &returns init-register
+						  &final-form final-form)
+			       (compiler-call #'compile-form-to-register
+				 :env init-env
+				 :defaults all
+				 :form init-form
+				 :modify-accumulate let-modifies)
+;;;			     ;; (warn "prod: ~S, type: ~S" prod type)
+;;;			     (warn "var ~S init: ~S.." var init-form)
+;;;			     (print-code 'init
+;;;					 (compiler-call #'compile-form
+;;;					   :env init-env
+;;;					   :defaults all
+;;;					   :form init-form
+;;;					   :result-mode binding))
+			     (list var
+				   init-form
+				   init-code
+				   functional-p
+				   (let ((init-type (type-specifier-primary type)))
+				     (assert init-type ()
+				       "The init-form ~S yielded the empty primary type!" type)
+				     init-type)
+				   (case init-register
+				     (:non-local-exit :edi)
+				     (t init-register))
+				   final-form))))))
 	  (setf (stack-used local-env)
 	    (stack-used init-env))
 	  (flet ((compile-body ()
@@ -834,7 +841,7 @@
 				;; catcher
 				(:locally (:pushl (:edi (:edi-offset dynamic-env))))
 				(:pushl ',label-set-name)
-				(:locally (:pushl (:edi (:edi-offset unbound-value))))
+				(:locally (:pushl (:edi (:edi-offset unbound-function))))
 				(:pushl :ebp)
 				(:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))
 			      `((:init-lexvar ,save-esp-binding
@@ -1109,7 +1116,7 @@
 			  (:je '(:sub-program (,zero-specials)
 				 ;; Insert dummy binding
 				 (:pushl :edi) ; biding value
-				 (:globally (:pushl (:edi (:edi-offset unbound-value)))) ;  [[ binding tag ]]
+				 (:pushl :edi) ; scratch
 				 (:pushl :edi) ; binding name
 				 (:pushl :esp)
 				 (:addl 4 :ecx)
@@ -1117,7 +1124,7 @@
 			  ,loop
 			  (:cmpl :edi :ebx) ; (endp symbols)
 			  (:je ',no-more-symbols) ;  .. (go no-more-symbols)
-			  (:globally (:movl (:edi (:edi-offset unbound-value)) :edx))
+			  (:globally (:movl (:edi (:edi-offset new-unbound-value)) :edx))
 			  (:cmpl :edi :eax) ; (endp values)
 			  (:je ',no-more-values) ; .. (go no-more-values)
 			  (:movl (:eax -1) :edx)
@@ -1272,7 +1279,7 @@
 		   ,cleanup-entry
 
 		   ;; Now (?), modify unwind-protect dyn-env-entry to be normal continuation
-		   (:locally (:movl (:edi (:edi-offset unbound-value)) :edx))
+		   (:locally (:movl (:edi (:edi-offset unbound-function)) :edx))
 		   (:movl :edx (:esp 4)) ; not unwind-protect-tag
 		   (:movl ',continue-label (:esp 8)) ; new jumper index
 




From ffjeld at common-lisp.net  Tue Nov 23 16:14:36 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:14:36 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/arp.lisp 
Message-ID: <E1CWdJM-00021Q-00@common-lisp.net>

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

Modified Files:
	arp.lisp 
Log Message:
Use untyped (i.e. memref) accessors to packets.

Date: Tue Nov 23 17:14:33 2004
Author: ffjeld

Index: movitz/losp/lib/net/arp.lisp
diff -u movitz/losp/lib/net/arp.lisp:1.5 movitz/losp/lib/net/arp.lisp:1.6
--- movitz/losp/lib/net/arp.lisp:1.5	Thu Jul 22 02:58:50 2004
+++ movitz/losp/lib/net/arp.lisp	Tue Nov 23 17:14:33 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Mar 20 15:01:15 2003
 ;;;;                
-;;;; $Id: arp.lisp,v 1.5 2004/07/22 00:58:50 ffjeld Exp $
+;;;; $Id: arp.lisp,v 1.6 2004/11/23 16:14:33 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -45,14 +45,11 @@
 				       (+ start 28)))
     (setf packet (make-array +min-ethernet-frame-size+
 			     :element-type '(unsigned-byte 8))))
-  (setf (aref packet (+ start 0)) (ldb (byte 8 8) hard-type)
-	(aref packet (+ start 1)) (ldb (byte 8 0) hard-type)
-	(aref packet (+ start 2)) (ldb (byte 8 8) prot-type)
-	(aref packet (+ start 3)) (ldb (byte 8 0) prot-type)
-	(aref packet (+ start 4)) hard-size
-	(aref packet (+ start 5)) prot-size
-	(aref packet (+ start 6)) (ldb (byte 8 8) op)
-	(aref packet (+ start 7)) (ldb (byte 8 0) op))
+  (setf (ip4-ref packet start 0 :unsigned-byte16) hard-type
+	(ip4-ref packet start 2 :unsigned-byte16) prot-type
+	(ip4-ref packet start 4 :unsigned-byte8) hard-size
+	(ip4-ref packet start 5 :unsigned-byte8) prot-size
+	(ip4-ref packet start 6 :unsigned-byte16) op)
   (replace packet sender-hardware-address
 	   :start1 (+ start 8)
 	   :end1 (+ start 14)
@@ -72,35 +69,53 @@
 
 
 (defun arp-operation (packet &optional (start 14))
-  (bvref-u16 packet start 6))
+  (ip4-ref packet start 6 :unsigned-byte16))
 
 (defun arp-hard-type (packet &optional (start 14))
-  (bvref-u16 packet start 0))
+  (ip4-ref packet start 0 :unsigned-byte16))
 
 (defun arp-prot-type (packet &optional (start 14))
-  (bvref-u16 packet start 2))
-
+  (ip4-ref packet start 2 :unsigned-byte16))
 
 (defvar *ne2000* nil)
+
+(defun arp-polling (ip &optional (waiter #'false))
+  (loop with nic = *ip4-nic*
+      for packet = (muerte.ethernet:receive nic)
+      until (funcall waiter)
+      do (transmit nic
+		   (format-ethernet-packet (format-arp-request nil +arp-op-request+ *ip4-ip*
+							       (mac-address nic) ip)
+					   (mac-address nic)
+					   muerte.ethernet:+broadcast-address+
+					   muerte.ethernet:+ether-type-arp+))
+	 (when (and packet
+		    (eq +ether-type-arp+ (ether-type packet))
+		    (eq +arp-op-reply+ (arp-operation packet))
+		    (not (mismatch packet ip :start1 28 :end1 32)))
+	   (return (subseq packet 22 28)))))
 	  
 (defun test-arp (&optional (ip #(129 242 16 30)) (my-ip #(129 242 16 173))
-			   (device (or *ne2000*
-				       #+ignore
-				       (setf *ne2000* (some #'muerte.x86-pc.ne2k:ne2k-probe muerte.x86-pc.ne2k:+ne2k-probe-addresses+)))))
+			   (device *ne2000*))
   
-  (loop for packet = (muerte.ethernet:receive device)
+  (loop with ip = (ip4-address ip) and my-ip = (ip4-address my-ip)
+      for packet = (muerte.ethernet:receive device)
       with i = 9999
       do (when (= (incf i) 10000)
 	   (setf i 0)
 	   (transmit device
-		     (format-ethernet-packet (format-arp-request nil +arp-op-request+ my-ip (mac-address device) ip)
+		     (format-ethernet-packet (format-arp-request nil +arp-op-request+
+								 my-ip (mac-address device) ip)
 					     (mac-address device)
 					     muerte.ethernet:+broadcast-address+
 					     muerte.ethernet:+ether-type-arp+)))
       until (or (muerte.x86-pc.keyboard:poll-char)
 		(when (and packet
-			   (or (eq +ether-type-arp+ (ether-type packet)) (warn "not type"))
-			   (or (eq +arp-op-reply+ (arp-operation packet)) (warn "not op"))
-			   (or (not (mismatch packet ip :start1 28 :end1 32)) (warn "mismatch: ~S" (subseq packet 28 32))))
+			   (or (eq +ether-type-arp+ (ether-type packet))
+			       (warn "not type"))
+			   (or (eq +arp-op-reply+ (arp-operation packet))
+			       (warn "not op"))
+			   (or (not (mismatch packet ip :start1 28 :end1 32))
+			       (warn "mismatch: ~S" (subseq packet 28 32))))
 		  (format t "The MAC of ~S is ~22/ethernet:pprint-mac/." ip packet)
 		  t))))




From ffjeld at common-lisp.net  Tue Nov 23 16:14:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:14:46 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ethernet.lisp 
Message-ID: <E1CWdJW-00021q-00@common-lisp.net>

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

Modified Files:
	ethernet.lisp 
Log Message:
Use untyped (i.e. memref) accessors to packets.

Date: Tue Nov 23 17:14:44 2004
Author: ffjeld

Index: movitz/losp/lib/net/ethernet.lisp
diff -u movitz/losp/lib/net/ethernet.lisp:1.4 movitz/losp/lib/net/ethernet.lisp:1.5
--- movitz/losp/lib/net/ethernet.lisp:1.4	Thu Feb 26 12:30:07 2004
+++ movitz/losp/lib/net/ethernet.lisp	Tue Nov 23 17:14:40 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 17 15:25:31 2002
 ;;;;                
-;;;; $Id: ethernet.lisp,v 1.4 2004/02/26 11:30:07 ffjeld Exp $
+;;;; $Id: ethernet.lisp,v 1.5 2004/11/23 16:14:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -65,6 +65,12 @@
 
 ;;; Packet accessors
 
+(defmacro packet-ref (packet start offset type)
+  `(memref ,packet (+ (muerte:movitz-type-slot-offset 'movitz-basic-vector 'data)
+		      ,start ,offset)
+	   :endian :big
+	   :type ,type))
+
 (defun ether-destination (packet &optional (start 0))
   (subseq packet start (+ start 6)))
 
@@ -80,35 +86,31 @@
   source)
 
 (defun ether-type (packet &optional (start 0))
-  (bvref-u16 packet start 12)
-  #+ignore
-  (logior (ash (aref packet (+ start 12)) 8)
-	  (aref packet (+ start 13))))
+  (packet-ref packet start 12 :unsigned-byte16))
 
 (defun (setf ether-type) (type packet &optional (start 0))
-  (setf (aref packet (+ start 12)) (ldb (byte 8 8) type)
-	(aref packet (+ start 13)) (ldb (byte 8 0) type))
-  type)
+  (setf (packet-ref packet start 12 :unsigned-byte16)
+    type))
 
 (defun ether-802.3-p (packet &optional (start 0))
   "Is the packet a 802.3 type packet?"
   (<= (ether-type packet start) #x5dc))
 
 (defun ether-802.3-llc-type (packet &optional (start 0))
-  (aref packet (+ start 16)))
+  (packet-ref packet start 16 :unsigned-byte8))
 
 (defun ether-802.3-llc-dsap (packet &optional (start 0))
-  (aref packet (+ start 14)))
+  (packet-ref packet start 14 :unsigned-byte8))
 
 (defun ether-802.3-llc-ssap (packet &optional (start 0))
-  (aref packet (+ start 15)))
+  (packet-ref packet start 15 :unsigned-byte8))
 
 (defun ether-802.3-snap-p (packet &optional (start 0))
   (and (ether-802.3-p packet)
        (= #xAA (ether-802.3-llc-ssap packet start))))
 
 (defun ether-802.3-snap-type (packet &optional (start 0))
-  (bvref-u16 packet start 20))
+  (packet-ref packet start 20 :unsigned-byte16))
 
 ;;;
 




From ffjeld at common-lisp.net  Tue Nov 23 16:14:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 17:14:53 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp 
Message-ID: <E1CWdJd-000227-00@common-lisp.net>

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

Modified Files:
	ip4.lisp 
Log Message:
Use untyped (i.e. memref) accessors to packets.

Date: Tue Nov 23 17:14:49 2004
Author: ffjeld

Index: movitz/losp/lib/net/ip4.lisp
diff -u movitz/losp/lib/net/ip4.lisp:1.7 movitz/losp/lib/net/ip4.lisp:1.8
--- movitz/losp/lib/net/ip4.lisp:1.7	Thu Oct 21 22:52:11 2004
+++ movitz/losp/lib/net/ip4.lisp	Tue Nov 23 17:14:49 2004
@@ -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.7 2004/10/21 20:52:11 ffjeld Exp $
+;;;; $Id: ip4.lisp,v 1.8 2004/11/23 16:14:49 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -25,12 +25,23 @@
 	   #:read-ip4-address
 	   #:ip4-address
 	   #:ip4-test
-	   #:ip4-free))
-
-(require :lib/net/arp)
+	   #:ip4-free
+	   #:*ip4-nic*
+	   #:*ip4-ip*))
 
 (in-package muerte.ip4)
 
+(defvar *ip4-nic* nil)
+(defvar *ip4-ip* nil)
+
+(defmacro ip4-ref (packet start offset type)
+  `(memref ,packet (+ (muerte:movitz-type-slot-offset 'movitz-basic-vector 'data)
+		      ,start ,offset)
+	   :endian :big
+	   :type ,type))
+
+(require :lib/net/arp)
+
 (defclass ip4-stack ()
   ((interface
     :initarg :interface
@@ -62,10 +73,11 @@
   (20 options))
 
 (defun ip-protocol (packet &optional (start 14))
-  (aref packet (+ start +ip-header-protocol+)))
+  (ip4-ref packet start +ip-header-protocol+ :unsigned-byte8))
 
 (defun ip-header-length (packet &optional (start 14))
-  (ldb (byte 4 0) (aref packet (+ start +ip-header-version-header-length+))))
+  (ldb (byte 4 0)
+       (ip4-ref packet start +ip-header-version-header-length+ :unsigned-byte8)))
 
 (defun checksum-ok (x)
   (= #xffff
@@ -160,8 +172,6 @@
        (warn "Received unknown ARP packet of type ~D~@[ ~A~]"
 	     (arp-operation packet start)
 	     (integer-name 'arp-op (arp-operation packet start) nil)))))
-	   
-
 
 ;;; ICMP
 
@@ -173,27 +183,27 @@
   (8 echo-request))
 
 (defun icmp-type (packet &optional (start 34))
-  (aref packet start))
+  (ip4-ref packet start 0 :unsigned-byte8))
 
 (defun (setf icmp-type) (value packet &optional (start 34))
-  (setf (aref packet start) value))
+  (setf (ip4-ref packet start 0 :unsigned-byte8)
+    value))
 
 (defun icmp-code (packet &optional (start 34))
-  (aref packet (1+ start)))
+  (ip4-ref packet start 1 :unsigned-byte8))
 
 (defun icmp-checksum (packet &optional (start 34))
-  (bvref-u16 packet start 2))
+  (ip4-ref packet start 2 :unsigned-byte16))
 
 (defun icmp-identifier (packet &optional (start 34))
-  (bvref-u16 packet start 4))
+  (ip4-ref packet start 4 :unsigned-byte16))
 
 (defun icmp-seqno (packet &optional (start 34))
-  (bvref-u16 packet start 6))
+  (ip4-ref packet start 6 :unsigned-byte16))
 
 (defun (setf icmp-checksum) (value packet &optional (start 34))
-  (setf (aref packet (+ start 2)) (ldb (byte 8 8) value)
-	(aref packet (+ start 3)) (ldb (byte 8 0) value))
-  value)
+  (setf (ip4-ref packet start 2 :unsigned-byte16)
+    value))
 
 (defmethod icmp-input ((stack ip4-stack) packet ip-start icmp-start)
   (named-integer-case icmp-type (icmp-type packet icmp-start)
@@ -253,20 +263,20 @@
 ;;;; UDP
 
 (defun udp-src-port (packet &optional (start 34))
-  (bvref-u16 packet start 0))
+  (ip4-ref packet start 0 :unsigned-byte16))
 
 (defun (setf udp-src-port) (value packet &optional (start 34))
-  (setf (bvref-u16 packet start 0) value))
+  (setf (ip4-ref packet start 0 :unsigned-byte16)
+    value))
 
 (defun udp-dst-port (packet &optional (start 34))
-  (bvref-u16 packet start 2))
+  (ip4-ref packet start 2 :unsigned-byte16))
 
 (defun udp-length (packet &optional (start 34))
-  (bvref-u16 packet start 4))
+  (ip4-ref packet start 4 :unsigned-byte16))
 
 (defun udp-checksum (packet &optional (start 34))
-  (bvref-u16 packet start 6))
-
+  (ip4-ref packet start 6 :unsigned-byte16))
 
 (defmethod udp-input ((stack ip4-stack) packet ip-start udp-start)
   (warn "Got UDP packet of length ~D from ~@v/ip4:pprint-ip4/."
@@ -296,22 +306,24 @@
   (5 urg))
 
 (defun tcp-src-port (packet &optional (start 34))
-  (bvref-u16 packet start +tcp-header-src-port+))
+  (ip4-ref packet start +tcp-header-src-port+ :unsigned-byte16))
 
 (defun tcp-dst-port (packet &optional (start 34))
-  (bvref-u16 packet start +tcp-header-dst-port+))
+  (ip4-ref packet start +tcp-header-dst-port+ :unsigned-byte16))
 
 (defun tcp-header-length (packet &optional (start 34))
-  (ldb (byte 4 4) (aref packet (+ start +tcp-header-flags-length+))))
+  (ldb (byte 4 4)
+       (ip4-ref packet start +tcp-header-flags-length+ :unsigned-byte8)))
 
 (defun tcp-flags (packet &optional (start 34))
-  (ldb (byte 6 0) (aref packet (+ start +tcp-header-flags-length+ 1))))
+  (ldb (byte 6 0)
+       (ip4-ref packet start (+ +tcp-header-flags-length+ 1) :unsigned-byte8)))
 
 (defun tcp-window-size (packet &optional (start 34))
-  (bvref-u16 packet start +tcp-header-window-size+))
+  (ip4-ref packet start +tcp-header-window-size+ :unsigned-byte16))
 
 (defun tcp-checksum (packet &optional (start 34))
-  (bvref-u16 packet start +tcp-header-checksum+))
+  (ip4-ref packet start +tcp-header-checksum+ :unsigned-byte16))
 
 (defun print-flags (x set)
   (loop with first = t
@@ -383,23 +395,23 @@
     (setf *ne2000* nil))
   (values))
 
-(defvar *ne2000* nil)
-
-(defun ip4-test (&key (ip #(129 242 16 173))
-		      (ethernet *ne2000*)
-		      (router #(129 242 16 1)))
-  (unless ethernet
-    (setf ethernet
-      (some #'muerte.x86-pc.ne2k:ne2k-probe
-	    muerte.x86-pc.ne2k:+ne2k-probe-addresses+))
-    (assert ethernet ethernet "No ethernet device.")
-    (when ethernet
-      (setf (promiscuous-p ethernet) nil
-	    (accept-broadcasts-p ethernet) t)
-      (setf *ne2000* ethernet)))
-  (let ((stack (make-instance 'ip4-stack
-		 :interface ethernet
-		 :address (ip4-address ip))))
+(defun ip4-init ()
+  (unless *ip4-nic*
+    (let ((ethernet
+	   (some #'muerte.x86-pc.ne2k:ne2k-probe
+		 muerte.x86-pc.ne2k:+ne2k-probe-addresses+)))
+      (assert ethernet ethernet "No ethernet device.")
+      (setf *ip4-nic* ethernet)))
+  (unless *ip4-ip*
+    (setf *ip4-ip* (ip4-address :129.242.16.173)))
+  (values *ip4-nic* *ip4-ip*))
+
+(defun ip4-test (&key (router #(129 242 16 1)))
+  (ip4-init)
+  (let ((ethernet *ip4-nic*)
+	(stack (make-instance 'ip4-stack
+		 :interface *ip4-nic*
+		 :address *ip4-ip*)))
     (when router
       (transmit (interface stack)
 		(format-ethernet-packet (format-arp-request nil +arp-op-request+




From ffjeld at common-lisp.net  Tue Nov 23 19:03:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 20:03:18 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1CWfwc-0004p4-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Have install-internal-time set up a stupd sleep function.

Date: Tue Nov 23 20:03:16 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.30 movitz/losp/los0.lisp:1.31
--- movitz/losp/los0.lisp:1.30	Thu Nov 18 18:58:50 2004
+++ movitz/losp/los0.lisp	Tue Nov 23 20:03:15 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.30 2004/11/18 17:58:50 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.31 2004/11/23 19:03:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -46,9 +46,6 @@
 
 (in-package muerte.init)
 
-(defun xx (a b)
-  (eql b #x123456789))
-
 (defun test0 ()
   (ash 1 -1000000000000))
 
@@ -72,7 +69,7 @@
   (loop for x below 2 count (not (not (typep x t)))))
 
 (defun test4 ()
-  (let ((a 1)) (if (not (/= a 0)) a 0)))
+  (let ((aa 1)) (if (not (/= aa 0)) aa 0)))
 
 
 (defun test-floppy ()
@@ -244,13 +241,6 @@
   (break "xfuncall:~{ ~S~^,~}" args)
   (values))
 
-(defun xx ()
-  (format t "wefewf")
-  (with-inline-assembly (:returns :untagged-fixnum-ecx)
-    (:sbbl :edx :edx)
-    (:andl :edx :ecx)
-    (:leal (:edx :ecx 1) :ecx)))
-
 (defun xfoo (f) 
   (do-check-esp
       (multiple-value-bind (a b c d)
@@ -545,8 +535,11 @@
    (print 'hello-cleanup)))
 
 (defun test-cons (x)
-  (let ((c (cons x x)))
-    (cdr c)))
+  (let ((cc (cons x x)))
+    (cdr cc)))
+
+(defun xx (x)
+  (eql nil x))
 
 (defun test-fixed (x y z)
   (warn "x: ~W, y: ~W, z: ~W" x y z))
@@ -732,7 +725,7 @@
 (defclass pie2 (food)
   ((filling :accessor pie-filling 
 	    :initarg :filling
-	    :initform nil)))
+	    )))
 
 (defmethod cook ((p (eql 'pie)))
   (warn "Won't really cook a symbolic pie!")
@@ -796,7 +789,7 @@
 
 (defun init-nano-sleep ()
   (setf *cpu-frequency-mhz*
-    (truncate (assess-cpu-frequency) 100)))
+    (truncate (assess-cpu-frequency) 976)))
 
 (defun nano-sleep (nano-seconds)
   (let* ((t0 (read-time-stamp-counter))
@@ -844,7 +837,16 @@
 		      (read-time-stamp-counter)
 		    (+ (ash (ldb (byte 16 0) hi) 13) 
 		       (ash lo -16)))))
-	      (setf internal-time-units-per-second res)))))))))
+	      (setf internal-time-units-per-second res))))))))
+  (setf (symbol-function 'sleep)
+    (lambda (seconds)
+      ;; A stupid busy-waiting sleeper.
+      (check-type seconds (real 0 *))
+      (let ((start-time (get-internal-run-time)))
+	(loop with start-time = (get-internal-run-time)
+	    with end-time = (+ start-time (* seconds internal-time-units-per-second))
+	    while (< (get-internal-run-time) end-time)))))
+  (values))
 
 
 ;;;(defun get-internal-run-time ()
@@ -1260,13 +1262,15 @@
 		       (incf (memref-int muerte.x86-pc::*screen* :index 80 :type :unsigned-byte16)))))
 	(incf (memref-int muerte.x86-pc::*screen* :index 160 :type :unsigned-byte16))))))
 
-(defun mumbojumbo ()
-  (with-inline-assembly (:returns :multiple-values)
-    (:leave)
-    (:movl (:ebp -4) :esi)
-    (:break)
-    (:ret)))
-
+(defun mumbojumbo (x)
+  (with-inline-assembly (:returns :eax)
+    (:compile-form (:result-mode :untagged-fixnum-ecx) x)
+    (:movl 0 :eax)
+    (:cmpl -1 :ecx)
+    (:jno 'no-overflow)
+    (:movl 4 :eax)
+   no-overflow))
+    
 (defun genesis ()
   ;; (install-shallow-binding)
   (let ((extended-memsize 0))
@@ -1591,7 +1595,7 @@
 (define-primitive-function dynamic-variable-lookup-shallow (symbol)
   "Load the dynamic value of SYMBOL into EAX."
   (with-inline-assembly (:returns :multiple-values)
-    (:movl (:eax (:offset movitz-symbol value)) :eax)
+    (:movl (:ebx (:offset movitz-symbol value)) :eax)
     (:ret)))
 
 (define-primitive-function dynamic-variable-store-shallow (symbol value)




From ffjeld at common-lisp.net  Tue Nov 23 19:30:29 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Nov 2004 20:30:29 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1CWgMv-000566-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Fixed the array constructors to deal correctly with :fill-pointer t.

Date: Tue Nov 23 20:30:24 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.47 movitz/losp/muerte/arrays.lisp:1.48
--- movitz/losp/muerte/arrays.lisp:1.47	Sun Nov  7 22:07:59 2004
+++ movitz/losp/muerte/arrays.lisp	Tue Nov 23 20:30:23 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.47 2004/11/07 21:07:59 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.48 2004/11/23 19:30:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -632,144 +632,149 @@
 	    `(funcall%unsafe ,writer ,store-var , at args)
 	    `(funcall%unsafe ,reader , at args))))
 
-(defun make-basic-vector%character (dimension fill-pointer initial-element initial-contents)
-  (check-type dimension (and fixnum (integer 0 *)))
-  (let* ((words (+ 2 (truncate (+ dimension 3) 4)))
+(defun make-basic-vector%character (length fill-pointer initial-element initial-contents)
+  (check-type length (and fixnum (integer 0 *)))
+  (let* ((words (+ 2 (truncate (+ length 3) 4)))
 	 (array (macrolet
 		    ((do-it ()
 		       `(with-non-pointer-allocation-assembly (words :fixed-size-p t
 								     :object-register :eax)
-			  (:load-lexical (:lexical-binding dimension) :ecx)
+			  (:load-lexical (:lexical-binding length) :ecx)
 			  (:movl ,(movitz:basic-vector-type-tag :character)
 				 (:eax (:offset movitz-basic-vector type)))
 			  (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))))))
 		  (do-it))))
     (cond
-     (fill-pointer
+     ((integerp fill-pointer)
       (setf (fill-pointer array) fill-pointer))
-     ((array-has-fill-pointer-p array)
-      (setf (fill-pointer array) dimension)))
+     ((or (eq t fill-pointer)
+	  (array-has-fill-pointer-p array))
+      (setf (fill-pointer array) length)))
     (cond
      (initial-element
       (check-type initial-element character)
-      (dotimes (i dimension)
+      (dotimes (i length)
 	(setf (char array i) initial-element)))
      (initial-contents
       (replace array initial-contents)))
     array))
 
-(defun make-basic-vector%u32 (dimension fill-pointer initial-element initial-contents)
-  (check-type dimension (and fixnum (integer 0 *)))
-  (let* ((words (+ 2 dimension))
+(defun make-basic-vector%u32 (length fill-pointer initial-element initial-contents)
+  (check-type length (and fixnum (integer 0 *)))
+  (let* ((words (+ 2 length))
 	 (array (macrolet
 		    ((do-it ()
 		       `(with-non-pointer-allocation-assembly (words :fixed-size-p t
 								     :object-register :eax)
-			  (:load-lexical (:lexical-binding dimension) :ecx)
+			  (:load-lexical (:lexical-binding length) :ecx)
 			  (:movl ,(movitz:basic-vector-type-tag :u32)
 				 (:eax (:offset movitz-basic-vector type)))
 			  (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))))))
 		  (do-it))))
     (cond
-     (fill-pointer
+     ((integerp fill-pointer)
       (setf (fill-pointer array) fill-pointer))
-     ((array-has-fill-pointer-p array)
-      (setf (fill-pointer array) dimension)))
+     ((or (eq t fill-pointer)
+	  (array-has-fill-pointer-p array))
+      (setf (fill-pointer array) length)))
     (cond
      (initial-element
       ;; (check-type initial-element (unsigned-byte 32))
-      (dotimes (i dimension)
+      (dotimes (i length)
 	(setf (u32ref%unsafe array i) initial-element)))
      (initial-contents
       (replace array initial-contents)))
     array))
 
-(defun make-basic-vector%u8 (dimension fill-pointer initial-element initial-contents)
-  (check-type dimension (and fixnum (integer 0 *)))
-  (let* ((words (+ 2 (truncate (+ dimension 3) 4)))
+(defun make-basic-vector%u8 (length fill-pointer initial-element initial-contents)
+  (check-type length (and fixnum (integer 0 *)))
+  (let* ((words (+ 2 (truncate (+ length 3) 4)))
 	 (array (macrolet
 		    ((do-it ()
 		       `(with-non-pointer-allocation-assembly (words :fixed-size-p t
 								     :object-register :eax)
-			  (:load-lexical (:lexical-binding dimension) :ecx)
+			  (:load-lexical (:lexical-binding length) :ecx)
 			  (:movl ,(movitz:basic-vector-type-tag :u8)
 				 (:eax (:offset movitz-basic-vector type)))
 			  (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))))))
 		  (do-it))))
     (cond
-     (fill-pointer
+     ((integerp fill-pointer)
       (setf (fill-pointer array) fill-pointer))
-     ((array-has-fill-pointer-p array)
-      (setf (fill-pointer array) dimension)))
+     ((or (eq t fill-pointer)
+	  (array-has-fill-pointer-p array))
+      (setf (fill-pointer array) length)))
     (cond
      (initial-element
       (check-type initial-element (unsigned-byte 8))
-      (dotimes (i dimension)
+      (dotimes (i length)
 	(setf (u8ref%unsafe array i) initial-element)))
      (initial-contents
       (replace array initial-contents)))
     array))
 
-(defun make-basic-vector%bit (dimension fill-pointer initial-element initial-contents)
-  (check-type dimension (and fixnum (integer 0 *)))
-  (let* ((words (+ 2 (truncate (+ dimension 31) 32)))
+(defun make-basic-vector%bit (length fill-pointer initial-element initial-contents)
+  (check-type length (and fixnum (integer 0 *)))
+  (let* ((words (+ 2 (truncate (+ length 31) 32)))
 	 (array (macrolet
 		    ((do-it ()
 		       `(with-non-pointer-allocation-assembly (words :fixed-size-p t
 								     :object-register :eax)
-			  (:load-lexical (:lexical-binding dimension) :ecx)
+			  (:load-lexical (:lexical-binding length) :ecx)
 			  (:movl ,(movitz:basic-vector-type-tag :bit)
 				 (:eax (:offset movitz-basic-vector type)))
 			  (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))))))
 		  (do-it))))
     (cond
-     (fill-pointer
+     ((integerp fill-pointer)
       (setf (fill-pointer array) fill-pointer))
-     ((array-has-fill-pointer-p array)
-      (setf (fill-pointer array) dimension)))
+     ((or (eq t fill-pointer)
+	  (array-has-fill-pointer-p array))
+      (setf (fill-pointer array) length)))
     (cond
      (initial-element
       (check-type initial-element bit)
-      (dotimes (i dimension)
+      (dotimes (i length)
 	(setf (aref array i) initial-element)))
      (initial-contents
       (replace array initial-contents)))
     array))
 
-(defun make-basic-vector%code (dimension fill-pointer initial-element initial-contents)
-  (check-type dimension (and fixnum (integer 0 *)))
-  (let* ((words (+ 2 (truncate (+ dimension 3) 4)))
+(defun make-basic-vector%code (length fill-pointer initial-element initial-contents)
+  (check-type length (and fixnum (integer 0 *)))
+  (let* ((words (+ 2 (truncate (+ length 3) 4)))
 	 (array (macrolet
 		    ((do-it ()
 		       `(with-non-pointer-allocation-assembly (words :fixed-size-p t
 								     :object-register :eax)
-			  (:load-lexical (:lexical-binding dimension) :ecx)
+			  (:load-lexical (:lexical-binding length) :ecx)
 			  (:movl ,(movitz:basic-vector-type-tag :code)
 				 (:eax (:offset movitz-basic-vector type)))
 			  (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))))))
 		  (do-it))))
     (cond
-     (fill-pointer
+     ((integerp fill-pointer)
       (setf (fill-pointer array) fill-pointer))
-     ((array-has-fill-pointer-p array)
-      (setf (fill-pointer array) dimension)))
+     ((or (eq t fill-pointer)
+	  (array-has-fill-pointer-p array))
+      (setf (fill-pointer array) length)))
     (cond
      (initial-element
       (check-type initial-element (unsigned-byte 8))
-      (dotimes (i dimension)
+      (dotimes (i length)
 	(setf (u8ref%unsafe array i) initial-element)))
      (initial-contents
       (replace array initial-contents)))
     array))
 
-(defun make-basic-vector%t (dimension fill-pointer initial-element initial-contents)
-  (check-type dimension (and fixnum (integer 0 *)))
-  (let* ((words (+ 2 dimension))
+(defun make-basic-vector%t (length fill-pointer initial-element initial-contents)
+  (check-type length (and fixnum (integer 0 *)))
+  (let* ((words (+ 2 length))
 	 (array (macrolet
 		    ((do-it ()
 		       `(with-allocation-assembly (words :fixed-size-p t
 							 :object-register :eax)
-			  (:load-lexical (:lexical-binding dimension) :ecx)
+			  (:load-lexical (:lexical-binding length) :ecx)
 			  (:movl ,(movitz:basic-vector-type-tag :any-t)
 				 (:eax (:offset movitz-basic-vector type)))
 			  (:movl :ecx (:eax (:offset movitz-basic-vector num-elements)))
@@ -785,17 +790,14 @@
 			  )))
 		  (do-it))))
     (cond
-     (fill-pointer
+     ((integerp fill-pointer)
       (setf (fill-pointer array) fill-pointer))
-     ((array-has-fill-pointer-p array)
-      (setf (fill-pointer array) dimension)))
+     ((or (eq t fill-pointer)
+	  (array-has-fill-pointer-p array))
+      (setf (fill-pointer array) length)))
     (cond
      (initial-contents
-      (replace array initial-contents))
-     #+ignore
-     (initial-element
-      (dotimes (i dimension)
-	(setf (svref%unsafe array i) initial-element))))
+      (replace array initial-contents)))
     array))
 
 (defun make-array (dimensions &key element-type initial-element initial-contents adjustable




From ffjeld at common-lisp.net  Wed Nov 24 10:02:44 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 11:02:44 +0100
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CWtz2-0001CB-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fix detection of unused variables.

Date: Wed Nov 24 11:02:43 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.116 movitz/compiler.lisp:1.117
--- movitz/compiler.lisp:1.116	Tue Nov 23 17:10:17 2004
+++ movitz/compiler.lisp	Wed Nov 24 11:02:42 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.116 2004/11/23 16:10:17 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.117 2004/11/24 10:02:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2772,7 +2772,7 @@
    This function is factored out from assign-bindings."
   (let* ((count-init-pc (gethash binding var-counts))
 	 (count (car count-init-pc))
-	 (init-pc (cdr count-init-pc)))
+	 (init-pc (second count-init-pc)))
     ;; (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc)
     (cond
      ((binding-lended-p binding)
@@ -2845,13 +2845,20 @@
   (check-type function-env function-env)
   ;; (print-code 'discover code)
   (let ((var-counter (make-hash-table :test #'eq :size 40)))
-    (labels ((take-note-of-binding (binding &optional storep init-pc)
+    (labels ((record-binding-used (binding)
 	       (let ((count-init-pc (or (gethash binding var-counter)
 					(setf (gethash binding var-counter)
-					  (cons 0 nil)))))
+					  (list 0 nil t)))))
+		 (setf (third count-init-pc) t)
+		 (when (typep binding 'forwarding-binding)
+		   (record-binding-used (forwarding-binding-target binding)))))
+	     (take-note-of-binding (binding &optional storep init-pc)
+	       (let ((count-init-pc (or (gethash binding var-counter)
+					(setf (gethash binding var-counter)
+					  (list 0 nil t)))))
 		 (when init-pc
-		   (assert (not (cdr count-init-pc)))
-		   (setf (cdr count-init-pc) init-pc))
+		   (assert (not (second count-init-pc)))
+		   (setf (second count-init-pc) init-pc))
 		 (unless storep
 		   (unless (eq binding (binding-target binding))
 		     ;; (break "ewfew: ~S" (gethash (binding-target binding) var-counter))
@@ -2902,6 +2909,8 @@
 				 (take-note-of-binding init-with-register)))))
 			  (t (mapcar #'take-note-of-binding 
 				     (find-read-bindings instruction))
+			     (mapcar #'record-binding-used ; This is just concerning "unused variable"
+				     (find-used-bindings instruction)) ; warnings!
 			     (let ((store-binding (find-written-binding-and-type instruction)))
 			       (when store-binding
 				 (take-note-of-binding store-binding t)))
@@ -2953,13 +2962,13 @@
 				    (prog1 nil ; may need lending-cons
 				      (setf (new-binding-location binding frame-map)
 					`(:argument-stack ,(function-argument-argnum binding)))))
-				   ((not (plusp (or (car (gethash binding var-counts)) 0)))
-				    (prog1 t
-				      (unless (or (movitz-env-get variable 'ignore nil env nil)
-						  (movitz-env-get variable 'ignorable nil env nil)
-						  (typep binding 'hidden-rest-function-argument))
-					(warn "Unused variable: ~S"
-					      (binding-name binding))))))
+				   ((unless (or (movitz-env-get variable 'ignore nil env nil)
+						(movitz-env-get variable 'ignorable nil env nil)
+						(typep binding 'hidden-rest-function-argument)
+						(third (gethash binding var-counts)))
+				      (warn "Unused variable: ~S"
+					    (binding-name binding))))
+				   ((not (plusp (or (car (gethash binding var-counts)) 0)))))
 			   collect binding))
 		      (bindings-fun-arg-sorted
 		       (when (eq env function-env)
@@ -2987,7 +2996,7 @@
 				      (located-binding
 				       (let* ((count-init (gethash b var-counts))
 					      (count (car count-init))
-					      (init-pc (cdr count-init)))
+					      (init-pc (second count-init)))
 					 (if (not (and count init-pc))
 					     50
 					   (truncate
@@ -5924,6 +5933,9 @@
 (defvar *extended-code-find-read-binding*
     (make-hash-table :test #'eq))
 
+(defvar *extended-code-find-used-bindings*
+    (make-hash-table :test #'eq))
+
 (defmacro define-find-read-bindings (name lambda-list &body body)
   (let ((defun-name (intern
 		     (with-standard-io-syntax
@@ -5935,6 +5947,28 @@
 	     (cdr instruction)
 	   , at body)))))
 
+(defmacro define-find-used-bindings (name lambda-list &body body)
+  (let ((defun-name (intern
+		     (with-standard-io-syntax
+		       (format nil "~A-~A" 'find-used-bindings name)))))
+    `(progn
+       (setf (gethash ',name *extended-code-find-used-bindings*) ',defun-name)
+       (defun ,defun-name (instruction)
+	 (destructuring-bind ,lambda-list
+	     (cdr instruction)
+	   , at body)))))
+
+(defun find-used-bindings (extended-instruction)
+  "Return zero, one or two bindings that this instruction reads."
+  (when (listp extended-instruction)
+    (let* ((operator (car extended-instruction))
+	   (finder (or (gethash operator *extended-code-find-used-bindings*)
+		       (gethash operator *extended-code-find-read-binding*))))
+      (when finder
+	(let ((result (funcall finder extended-instruction)))
+	  (check-type result list "a list of read bindings")
+	  result)))))
+
 (defun find-read-bindings (extended-instruction)
   "Return zero, one or two bindings that this instruction reads."
   (when (listp extended-instruction)
@@ -6417,6 +6451,11 @@
 		  x))
 	      (list term0 term1)
 	      ))))
+
+(define-find-used-bindings :add (term0 term1 destination)
+  (if (bindingp destination)
+      (list term0 term1 destination)
+    (list term0 term1)))
 
 (define-find-read-bindings :add (term0 term1 destination)
   (declare (ignore destination))




From ffjeld at common-lisp.net  Wed Nov 24 10:03:00 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 11:03:00 +0100
Subject: [movitz-cvs] CVS update: movitz/parse.lisp 
Message-ID: <E1CWtzI-0001CU-00@common-lisp.net>

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

Modified Files:
	parse.lisp 
Log Message:
Just indentation.

Date: Wed Nov 24 11:02:59 2004
Author: ffjeld

Index: movitz/parse.lisp
diff -u movitz/parse.lisp:1.3 movitz/parse.lisp:1.4
--- movitz/parse.lisp:1.3	Mon Jan 19 12:23:41 2004
+++ movitz/parse.lisp	Wed Nov 24 11:02:59 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:49:17 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: parse.lisp,v 1.3 2004/01/19 11:23:41 ffjeld Exp $
+;;;; $Id: parse.lisp,v 1.4 2004/11/24 10:02:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -122,24 +122,24 @@
        ((and (symbolp (car program))
 	     (eq (symbol-package (car program)) from-package))
 	(cons (translate-symbol (car program))
-	      (muerte::translate-program (rest program) from-package to-package
-						:when when
-						:remove-double-quotes-p remove-double-quotes-p
-						:quote-symbol quote-symbol)))
+	      (muerte::translate-program (cdr program) from-package to-package
+					 :when when
+					 :remove-double-quotes-p remove-double-quotes-p
+					 :quote-symbol quote-symbol)))
        ((consp (car program))
 	(cons (muerte::translate-program (car program) from-package to-package
-						:when when
-						:remove-double-quotes-p remove-double-quotes-p
-						:quote-symbol quote-symbol)
+					 :when when
+					 :remove-double-quotes-p remove-double-quotes-p
+					 :quote-symbol quote-symbol)
 	      (muerte::translate-program (cdr program) from-package to-package
-						:when when
-						:remove-double-quotes-p remove-double-quotes-p
-						:quote-symbol quote-symbol)))
+					 :when when
+					 :remove-double-quotes-p remove-double-quotes-p
+					 :quote-symbol quote-symbol)))
        (t (cons (car program)
 		(muerte::translate-program (cdr program) from-package to-package
-						  :when when
-						  :remove-double-quotes-p remove-double-quotes-p
-						  :quote-symbol quote-symbol)))))))
+					   :when when
+					   :remove-double-quotes-p remove-double-quotes-p
+					   :quote-symbol quote-symbol)))))))
 
 (defun decode-normal-lambda-list (lambda-list &optional host-symbols-p)
   "3.4.1 Ordinary Lambda Lists.




From ffjeld at common-lisp.net  Wed Nov 24 10:05:49 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 11:05:49 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/misc.lisp 
Message-ID: <E1CWu21-0001D5-00@common-lisp.net>

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

Modified Files:
	misc.lisp 
Log Message:
Wrote add-u16-ones-complement for IP checksumming.

Date: Wed Nov 24 11:05:47 2004
Author: ffjeld

Index: movitz/losp/lib/misc.lisp
diff -u movitz/losp/lib/misc.lisp:1.5 movitz/losp/lib/misc.lisp:1.6
--- movitz/losp/lib/misc.lisp:1.5	Sat Aug 14 19:52:35 2004
+++ movitz/losp/lib/misc.lisp	Wed Nov 24 11:05:47 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon May 12 17:13:31 2003
 ;;;;                
-;;;; $Id: misc.lisp,v 1.5 2004/08/14 17:52:35 ffjeld Exp $
+;;;; $Id: misc.lisp,v 1.6 2004/11/24 10:05:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -62,6 +62,32 @@
 		    sum (packet-ref (1+ i)) into lo
 		    finally (return (+ lo (ash hi 8))))
 		(ash (packet-ref (1- end)) 8))))))))
+
+(defun add-u16-ones-complement (&rest integers)
+  (numargs-case
+   (1 (x)
+      (if (= 0 x)
+	  #xffff
+	(ldb (byte 16 0) x)))
+   (2 (x y)
+      (with-inline-assembly (:returns :eax)
+	(:compile-two-forms (:eax :ebx) x y)
+	(:andl #.(cl:* movitz:+movitz-fixnum-factor+ #xffff) :eax)
+	(:andl #.(cl:* movitz:+movitz-fixnum-factor+ #xffff) :ebx)
+	(:addl :ebx :eax)
+	(:jz '(:sub-program (fix-zero)
+	       (:movl #.(cl:* movitz:+movitz-fixnum-factor+ #xffff) :eax)
+	       (:jmp 'done)))
+	(:testl #.(cl:* movitz:+movitz-fixnum-factor+ #x10000) :eax)
+	(:jz 'done)
+	(:addl #.movitz:+movitz-fixnum-factor+ :eax)
+	(:andl #.(cl:* movitz:+movitz-fixnum-factor+ #xffff) :eax)
+	(:jz 'fix-zero)
+       done))
+   (t (&rest integers)
+      (declare (dynamic-extent integers))
+      (reduce #'add-u16-ones-complement integers :initial-value 0))))
+
 
 
 (defstruct (counter-u32 (:constructor make-counter-u32-object)) lo hi)




From ffjeld at common-lisp.net  Wed Nov 24 10:06:27 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 11:06:27 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp 
Message-ID: <E1CWu2d-0001DV-00@common-lisp.net>

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

Modified Files:
	ip4.lisp 
Log Message:
Wrote format-ip-header, format-udp-header, etc.

Date: Wed Nov 24 11:06:26 2004
Author: ffjeld

Index: movitz/losp/lib/net/ip4.lisp
diff -u movitz/losp/lib/net/ip4.lisp:1.8 movitz/losp/lib/net/ip4.lisp:1.9
--- movitz/losp/lib/net/ip4.lisp:1.8	Tue Nov 23 17:14:49 2004
+++ movitz/losp/lib/net/ip4.lisp	Wed Nov 24 11:06:25 2004
@@ -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.8 2004/11/23 16:14:49 ffjeld Exp $
+;;;; $Id: ip4.lisp,v 1.9 2004/11/24 10:06:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -26,6 +26,8 @@
 	   #:ip4-address
 	   #:ip4-test
 	   #:ip4-free
+	   #:format-ip4-header
+	   #:format-udp-header
 	   #:*ip4-nic*
 	   #:*ip4-ip*))
 
@@ -79,6 +81,37 @@
   (ldb (byte 4 0)
        (ip4-ref packet start +ip-header-version-header-length+ :unsigned-byte8)))
 
+(defun ip-header-source (packet &optional (start 14))
+  (subseq packet (+ start 12) (+ start 16)))
+
+(defun ip-header-destination (packet &optional (start 14))
+  (subseq packet (+ start 16) (+ start 20)))
+
+(defun format-ip4-header (packet &key (start 14) (payload 0)
+				      (id 0) (ttl 64) (checksum t)
+				      (protocol 0) (flags 0)
+				      (fragment-offset 0)
+				      source destination)
+  (setf (ip4-ref packet start 0 :unsigned-byte16) #x4500
+	(ip4-ref packet start 2 :unsigned-byte16) (+ payload 20)
+	(ip4-ref packet start 4 :unsigned-byte16) id
+	(ip4-ref packet start 6 :unsigned-byte16) (dpb flags (byte 3 13) fragment-offset)
+	(ip4-ref packet start 8 :unsigned-byte8) ttl
+	(ip4-ref packet start 9 :unsigned-byte8) protocol)
+  (when source
+    (replace packet source :start1 (+ start 12)))
+  (when destination
+    (replace packet destination :start1 (+ start 16)))
+  (cond
+   ((eq t checksum)
+    (setf (ip4-ref packet start 10 :unsigned-byte16) 0)
+    (setf (ip4-ref packet start 10 :unsigned-byte16)
+      (logxor #xffff
+	      (checksum-octets packet start (+ start 20)))))
+   ((integerp checksum)
+    (setf (ip4-ref packet start 10 :unsigned-byte16) checksum)))
+  packet)
+
 (defun checksum-ok (x)
   (= #xffff
      (+ (ldb (byte 16 0) x)
@@ -272,11 +305,51 @@
 (defun udp-dst-port (packet &optional (start 34))
   (ip4-ref packet start 2 :unsigned-byte16))
 
+(defun (setf udp-dst-port) (value packet &optional (start 34))
+  (setf (ip4-ref packet start 2 :unsigned-byte16)
+    value))
+
 (defun udp-length (packet &optional (start 34))
   (ip4-ref packet start 4 :unsigned-byte16))
 
+(defun (setf udp-length) (value packet &optional (start 34))
+  (setf (ip4-ref packet start 4 :unsigned-byte16)
+    value))
+
 (defun udp-checksum (packet &optional (start 34))
   (ip4-ref packet start 6 :unsigned-byte16))
+
+(defun (setf udp-checksum) (value packet &optional (start 34))
+  (setf (ip4-ref packet start 6 :unsigned-byte16)
+    value))
+
+(defun format-udp-header (packet &key (start 34)
+				      (source *ip4-ip*) (source-port 1024)
+				      destination (destination-port 0)
+				      (payload (- (length packet) start 8))
+				      (checksum t))
+  (let ((udp-length (+ payload 8)))
+    (format-ip4-header packet
+		       :source source
+		       :destination destination
+		       :payload udp-length
+		       :protocol +ip-protocol-udp+)
+    (setf (ip4-ref packet start 0 :unsigned-byte16) source-port
+	  (ip4-ref packet start 2 :unsigned-byte16) destination-port
+	  (ip4-ref packet start 4 :unsigned-byte16) udp-length)
+    (cond
+     ((integerp checksum)
+      (setf (ip4-ref packet start 6 :unsigned-byte16) checksum))
+     ((eq t checksum)
+      (setf (ip4-ref packet start 6 :unsigned-byte16) 0)
+      (setf (ip4-ref packet start 6 :unsigned-byte16)
+	(logxor #xffff
+		(add-u16-ones-complement (checksum-octets source)
+					 (checksum-octets destination)
+					 +ip-protocol-udp+ udp-length
+					 (checksum-octets packet start (+ start udp-length)))))))
+    packet))
+  
 
 (defmethod udp-input ((stack ip4-stack) packet ip-start udp-start)
   (warn "Got UDP packet of length ~D from ~@v/ip4:pprint-ip4/."




From ffjeld at common-lisp.net  Wed Nov 24 10:07:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 11:07:12 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ethernet.lisp 
Message-ID: <E1CWu3M-0001Dw-00@common-lisp.net>

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

Modified Files:
	ethernet.lisp 
Log Message:
Have make-ethernet-packet take an optional size parameter.

Date: Wed Nov 24 11:07:11 2004
Author: ffjeld

Index: movitz/losp/lib/net/ethernet.lisp
diff -u movitz/losp/lib/net/ethernet.lisp:1.5 movitz/losp/lib/net/ethernet.lisp:1.6
--- movitz/losp/lib/net/ethernet.lisp:1.5	Tue Nov 23 17:14:40 2004
+++ movitz/losp/lib/net/ethernet.lisp	Wed Nov 24 11:07:11 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 17 15:25:31 2002
 ;;;;                
-;;;; $Id: ethernet.lisp,v 1.5 2004/11/23 16:14:40 ffjeld Exp $
+;;;; $Id: ethernet.lisp,v 1.6 2004/11/24 10:07:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -235,7 +235,7 @@
   (values))
 
 						    
-(defun make-ethernet-packet ()
-  (make-array +max-ethernet-frame-size+
+(defun make-ethernet-packet (&optional (size +max-ethernet-frame-size+))
+  (make-array size
 	      :element-type '(unsigned-byte 8)
 	      :fill-pointer t))




From ffjeld at common-lisp.net  Wed Nov 24 10:08:30 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 11:08:30 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1CWu4c-0001EY-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Added better type-spec rational

Date: Wed Nov 24 11:08:29 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.38 movitz/losp/muerte/typep.lisp:1.39
--- movitz/losp/muerte/typep.lisp:1.38	Thu Nov 18 10:28:52 2004
+++ movitz/losp/muerte/typep.lisp	Wed Nov 24 11:08:28 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.38 2004/11/18 09:28:52 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.39 2004/11/24 10:08:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -574,6 +574,13 @@
 (define-simple-typep (package packagep))
 
 ;;;
+
+(define-typep rational (x &optional (lower-limit '*) (upper-limit '*))
+  (and (typep x 'rational)
+       (or (eq lower-limit '*)
+	   (<= lower-limit x))
+       (or (eq upper-limit '*)
+	   (<= x upper-limit))))
 
 (define-typep and (x &rest types)
   (declare (dynamic-extent types))




From ffjeld at common-lisp.net  Wed Nov 24 10:08:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 11:08:43 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1CWu4p-0001Ey-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Added deftype real

Date: Wed Nov 24 11:08:42 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.102 movitz/losp/muerte/integers.lisp:1.103
--- movitz/losp/muerte/integers.lisp:1.102	Tue Nov 23 17:05:23 2004
+++ movitz/losp/muerte/integers.lisp	Wed Nov 24 11:08:41 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.102 2004/11/23 16:05:23 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.103 2004/11/24 10:08:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -426,6 +426,11 @@
    ((typep size '(integer 1 *))
     (list 'integer 0 (1- (ash 1 size))))
    (t (error "Illegal size for unsigned-byte."))))
+
+(deftype real (&optional (lower-limit '*) (upper-limit '*))
+  `(or (integer ,lower-limit ,upper-limit)
+       (rational ,lower-limit ,upper-limit)))
+  
 
 (define-simple-typep (bit bitp) (x)
   (or (eq x 0) (eq x 1)))




From ffjeld at common-lisp.net  Wed Nov 24 10:09:00 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 11:09:00 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/package.lisp 
Message-ID: <E1CWu56-0001FO-00@common-lisp.net>

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

Modified Files:
	package.lisp 
Log Message:
*** empty log message ***
Date: Wed Nov 24 11:08:59 2004
Author: ffjeld

Index: movitz/losp/lib/package.lisp
diff -u movitz/losp/lib/package.lisp:1.4 movitz/losp/lib/package.lisp:1.5
--- movitz/losp/lib/package.lisp:1.4	Thu Jul 22 00:29:16 2004
+++ movitz/losp/lib/package.lisp	Wed Nov 24 11:08:59 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Sep 27 17:24:11 2002
 ;;;;                
-;;;; $Id: package.lisp,v 1.4 2004/07/21 22:29:16 ffjeld Exp $
+;;;; $Id: package.lisp,v 1.5 2004/11/24 10:08:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -46,6 +46,7 @@
 	   
 	   ;; :lib/misc
 	   #:checksum-octets
+	   #:add-u16-ones-complement
 	   #:make-counter-u32
 	   #:u32-add
 	   




From ffjeld at common-lisp.net  Wed Nov 24 10:09:14 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 11:09:14 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/arp.lisp 
Message-ID: <E1CWu5K-0001Fo-00@common-lisp.net>

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

Modified Files:
	arp.lisp 
Log Message:
*** empty log message ***
Date: Wed Nov 24 11:09:12 2004
Author: ffjeld

Index: movitz/losp/lib/net/arp.lisp
diff -u movitz/losp/lib/net/arp.lisp:1.6 movitz/losp/lib/net/arp.lisp:1.7
--- movitz/losp/lib/net/arp.lisp:1.6	Tue Nov 23 17:14:33 2004
+++ movitz/losp/lib/net/arp.lisp	Wed Nov 24 11:09:12 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Mar 20 15:01:15 2003
 ;;;;                
-;;;; $Id: arp.lisp,v 1.6 2004/11/23 16:14:33 ffjeld Exp $
+;;;; $Id: arp.lisp,v 1.7 2004/11/24 10:09:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -79,21 +79,24 @@
 
 (defvar *ne2000* nil)
 
-(defun arp-polling (ip &optional (waiter #'false))
-  (loop with nic = *ip4-nic*
+(defun polling-arp (ip &optional (waiter #'false))
+  (loop with ip = (ip4-address ip) and nic = *ip4-nic* and transmit-time = 0
       for packet = (muerte.ethernet:receive nic)
       until (funcall waiter)
-      do (transmit nic
-		   (format-ethernet-packet (format-arp-request nil +arp-op-request+ *ip4-ip*
-							       (mac-address nic) ip)
-					   (mac-address nic)
-					   muerte.ethernet:+broadcast-address+
-					   muerte.ethernet:+ether-type-arp+))
-	 (when (and packet
+      do (when (and packet
 		    (eq +ether-type-arp+ (ether-type packet))
 		    (eq +arp-op-reply+ (arp-operation packet))
 		    (not (mismatch packet ip :start1 28 :end1 32)))
-	   (return (subseq packet 22 28)))))
+	   (return (subseq packet 22 28)))
+	 (when (< internal-time-units-per-second
+		  (- (get-internal-run-time) transmit-time))
+	   (setf transmit-time (get-internal-run-time))
+	   (transmit nic
+		     (format-ethernet-packet (format-arp-request nil +arp-op-request+ *ip4-ip*
+								 (mac-address nic) ip)
+					     (mac-address nic)
+					     muerte.ethernet:+broadcast-address+
+					     muerte.ethernet:+ether-type-arp+)))))
 	  
 (defun test-arp (&optional (ip #(129 242 16 30)) (my-ip #(129 242 16 173))
 			   (device *ne2000*))




From ffjeld at common-lisp.net  Wed Nov 24 13:12:04 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 14:12:04 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/ne2k.lisp 
Message-ID: <E1CWwwG-0003uT-00@common-lisp.net>

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

Modified Files:
	ne2k.lisp 
Log Message:
*** empty log message ***
Date: Wed Nov 24 14:12:03 2004
Author: ffjeld

Index: movitz/losp/x86-pc/ne2k.lisp
diff -u movitz/losp/x86-pc/ne2k.lisp:1.11 movitz/losp/x86-pc/ne2k.lisp:1.12
--- movitz/losp/x86-pc/ne2k.lisp:1.11	Mon Aug 23 15:53:36 2004
+++ movitz/losp/x86-pc/ne2k.lisp	Wed Nov 24 14:12:02 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 17 15:16:00 2002
 ;;;;                
-;;;; $Id: ne2k.lisp,v 1.11 2004/08/23 13:53:36 ffjeld Exp $
+;;;; $Id: ne2k.lisp,v 1.12 2004/11/24 13:12:02 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -20,8 +20,7 @@
 (defpackage muerte.x86-pc.ne2k
   (:use muerte.cl muerte muerte.lib muerte.x86-pc muerte.ethernet)
   (:export #:ne2k-probe
-	   #:+ne2k-probe-addresses+
-	   
+	   #:*ne2k-probe-addresses*
 	   #:with-dp8390
 	   #:with-dp8390-dma
 	   #:dp8390-initialize
@@ -41,7 +40,8 @@
 
 (in-package muerte.x86-pc.ne2k)
 
-(defconstant +ne2k-probe-addresses+ '(#x240 #x260 #x280 #x300 #x320 #x340))
+(defparameter *ne2k-probe-addresses*
+    '(#x300 #x240 #x260 #x280 #x300 #x320 #x340))
 
 (defun ne2k-probe (io-base)
   (let ((io-space (make-io-space :range io-base #x20)))




From ffjeld at common-lisp.net  Wed Nov 24 13:12:27 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 14:12:27 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp 
Message-ID: <E1CWwwd-0003ut-00@common-lisp.net>

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

Modified Files:
	ip4.lisp 
Log Message:
Ensure zero-padding for UDP checksum.

Date: Wed Nov 24 14:12:27 2004
Author: ffjeld

Index: movitz/losp/lib/net/ip4.lisp
diff -u movitz/losp/lib/net/ip4.lisp:1.9 movitz/losp/lib/net/ip4.lisp:1.10
--- movitz/losp/lib/net/ip4.lisp:1.9	Wed Nov 24 11:06:25 2004
+++ movitz/losp/lib/net/ip4.lisp	Wed Nov 24 14:12:26 2004
@@ -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.9 2004/11/24 10:06:25 ffjeld Exp $
+;;;; $Id: ip4.lisp,v 1.10 2004/11/24 13:12:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -342,6 +342,8 @@
       (setf (ip4-ref packet start 6 :unsigned-byte16) checksum))
      ((eq t checksum)
       (setf (ip4-ref packet start 6 :unsigned-byte16) 0)
+      (when (oddp udp-length)		; Ensure zero-padding for checksum.
+	(setf (ip4-ref packet start udp-length :unsigned-byte8) 0))
       (setf (ip4-ref packet start 6 :unsigned-byte16)
 	(logxor #xffff
 		(add-u16-ones-complement (checksum-octets source)
@@ -472,7 +474,7 @@
   (unless *ip4-nic*
     (let ((ethernet
 	   (some #'muerte.x86-pc.ne2k:ne2k-probe
-		 muerte.x86-pc.ne2k:+ne2k-probe-addresses+)))
+		 muerte.x86-pc.ne2k:*ne2k-probe-addresses*)))
       (assert ethernet ethernet "No ethernet device.")
       (setf *ip4-nic* ethernet)))
   (unless *ip4-ip*




From ffjeld at common-lisp.net  Wed Nov 24 14:20:50 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 15:20:50 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/misc.lisp 
Message-ID: <E1CWy0o-00053e-00@common-lisp.net>

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

Modified Files:
	misc.lisp 
Log Message:
Added extract-zero-terminated-string.

Date: Wed Nov 24 15:20:49 2004
Author: ffjeld

Index: movitz/losp/lib/misc.lisp
diff -u movitz/losp/lib/misc.lisp:1.6 movitz/losp/lib/misc.lisp:1.7
--- movitz/losp/lib/misc.lisp:1.6	Wed Nov 24 11:05:47 2004
+++ movitz/losp/lib/misc.lisp	Wed Nov 24 15:20:49 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon May 12 17:13:31 2003
 ;;;;                
-;;;; $Id: misc.lisp,v 1.6 2004/11/24 10:05:47 ffjeld Exp $
+;;;; $Id: misc.lisp,v 1.7 2004/11/24 14:20:49 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -88,6 +88,18 @@
       (declare (dynamic-extent integers))
       (reduce #'add-u16-ones-complement integers :initial-value 0))))
 
+(defun extract-zero-terminated-string (vector &optional start (end (length vector)))
+  (check-type vector (and vector (not simple-vector)))
+  (let ((string (make-string (- (or (position 0 vector :start start) end)
+				start))))
+    (loop for i from 0 below (length string)
+	do (setf (char string i)
+	     (memref vector (+ (movitz-type-slot-offset 'movitz-basic-vector 'data)
+			       start)
+		     :index i
+		     :type :character))
+	finally (return string))))
+    
 
 
 (defstruct (counter-u32 (:constructor make-counter-u32-object)) lo hi)




From ffjeld at common-lisp.net  Wed Nov 24 14:20:57 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 15:20:57 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/package.lisp 
Message-ID: <E1CWy0v-00053w-00@common-lisp.net>

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

Modified Files:
	package.lisp 
Log Message:
Added extract-zero-terminated-string.

Date: Wed Nov 24 15:20:56 2004
Author: ffjeld

Index: movitz/losp/lib/package.lisp
diff -u movitz/losp/lib/package.lisp:1.5 movitz/losp/lib/package.lisp:1.6
--- movitz/losp/lib/package.lisp:1.5	Wed Nov 24 11:08:59 2004
+++ movitz/losp/lib/package.lisp	Wed Nov 24 15:20:55 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Sep 27 17:24:11 2002
 ;;;;                
-;;;; $Id: package.lisp,v 1.5 2004/11/24 10:08:59 ffjeld Exp $
+;;;; $Id: package.lisp,v 1.6 2004/11/24 14:20:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -47,6 +47,7 @@
 	   ;; :lib/misc
 	   #:checksum-octets
 	   #:add-u16-ones-complement
+	   #:extract-zero-terminated-string
 	   #:make-counter-u32
 	   #:u32-add
 	   




From ffjeld at common-lisp.net  Wed Nov 24 14:22:58 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 15:22:58 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp 
Message-ID: <E1CWy2s-00054V-00@common-lisp.net>

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

Modified Files:
	ip4.lisp 
Log Message:
Have checksum-ok accept any number of checksum terms, since typically
there will be a frew terms from the pseudo-header and one term from
the actual packet.

Date: Wed Nov 24 15:22:57 2004
Author: ffjeld

Index: movitz/losp/lib/net/ip4.lisp
diff -u movitz/losp/lib/net/ip4.lisp:1.10 movitz/losp/lib/net/ip4.lisp:1.11
--- movitz/losp/lib/net/ip4.lisp:1.10	Wed Nov 24 14:12:26 2004
+++ movitz/losp/lib/net/ip4.lisp	Wed Nov 24 15:22:57 2004
@@ -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.10 2004/11/24 13:12:26 ffjeld Exp $
+;;;; $Id: ip4.lisp,v 1.11 2004/11/24 14:22:57 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -112,10 +112,12 @@
     (setf (ip4-ref packet start 10 :unsigned-byte16) checksum)))
   packet)
 
-(defun checksum-ok (x)
-  (= #xffff
-     (+ (ldb (byte 16 0) x)
-	(ash x -16))))
+(defun checksum-ok (x &rest more-xes)
+  (declare (dynamic-extent more-xes))
+  (let ((x (reduce #'add-u16-ones-complement more-xes :initial-value x)))
+    (= #xffff
+       (+ (ldb (byte 16 0) x)
+	  (ash x -16)))))
 
 (defun ip-input (stack packet start)
   (let ((header-size (* 4 (ip-header-length packet start))))




From ffjeld at common-lisp.net  Wed Nov 24 14:27:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 15:27:16 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/tftp.lisp 
Message-ID: <E1CWy72-00056S-00@common-lisp.net>

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

Added Files:
	tftp.lisp 
Log Message:
Some simple TFTP code that writes a file to a tftp server.

Date: Wed Nov 24 15:27:15 2004
Author: ffjeld





From ffjeld at common-lisp.net  Wed Nov 24 16:19:04 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 17:19:04 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/simple-streams.lisp 
Message-ID: <E1CWzrE-0006o0-00@common-lisp.net>

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

Modified Files:
	simple-streams.lisp 
Log Message:
Added %read-key.

Date: Wed Nov 24 17:19:02 2004
Author: ffjeld

Index: movitz/losp/muerte/simple-streams.lisp
diff -u movitz/losp/muerte/simple-streams.lisp:1.6 movitz/losp/muerte/simple-streams.lisp:1.7
--- movitz/losp/muerte/simple-streams.lisp:1.6	Sat Sep 25 17:26:49 2004
+++ movitz/losp/muerte/simple-streams.lisp	Wed Nov 24 17:19:02 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Aug 29 13:39:43 2003
 ;;;;                
-;;;; $Id: simple-streams.lisp,v 1.6 2004/09/25 15:26:49 ffjeld Exp $
+;;;; $Id: simple-streams.lisp,v 1.7 2004/11/24 16:19:02 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -512,6 +512,13 @@
 	 (%finish-output stream))
        (funcall-stm-handler j-read-char (sm melded-stream stream)
 			    eof-error-p eof-value blocking-p)))))
+
+(defun %read-key (stream eof-error-p eof-value recursive-p blocking-p)
+  (etypecase stream
+    (function
+     (funcall stream 'stream-read-key))
+    (simple-stream			; XXX
+     (%read-char stream eof-error-p eof-value recursive-p blocking-p))))
 
 (defun %unread-char (stream character)
   (declare (type simple-stream stream) (ignore character))




From ffjeld at common-lisp.net  Wed Nov 24 16:19:37 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 17:19:37 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/streams.lisp 
Message-ID: <E1CWzrl-0006oR-00@common-lisp.net>

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

Modified Files:
	streams.lisp 
Log Message:
Added read-key, which is like read-char only it can return symbols
such as :up, :page-down etc. also, not just characters.

Date: Wed Nov 24 17:19:36 2004
Author: ffjeld

Index: movitz/losp/muerte/streams.lisp
diff -u movitz/losp/muerte/streams.lisp:1.3 movitz/losp/muerte/streams.lisp:1.4
--- movitz/losp/muerte/streams.lisp:1.3	Thu May 20 20:13:55 2004
+++ movitz/losp/muerte/streams.lisp	Wed Nov 24 17:19:36 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Jun 30 14:33:15 2003
 ;;;;                
-;;;; $Id: streams.lisp,v 1.3 2004/05/20 18:13:55 ffjeld Exp $
+;;;; $Id: streams.lisp,v 1.4 2004/11/24 16:19:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -115,6 +115,10 @@
 (defun read-char (&optional input-stream (eof-error-p t) eof-value recursive-p)
   " => char"
   (%read-char (input-stream-designator input-stream) eof-error-p eof-value recursive-p t))
+
+(defun read-key (&optional input-stream (eof-error-p t) eof-value recursive-p)
+  " => char, symbol, etc."
+  (%read-key (input-stream-designator input-stream) eof-error-p eof-value recursive-p t))
 
 (defun finish-output (&optional stream)
   "finish-output attempts to ensure that any buffered output sent to output-stream has reached its




From ffjeld at common-lisp.net  Wed Nov 24 16:20:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 17:20:16 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/keyboard.lisp 
Message-ID: <E1CWzsO-0006p7-00@common-lisp.net>

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

Modified Files:
	keyboard.lisp 
Log Message:
Make poll-key similar to poll-char. A key is a character or a symbolic
key name.

Date: Wed Nov 24 17:20:15 2004
Author: ffjeld

Index: movitz/losp/x86-pc/keyboard.lisp
diff -u movitz/losp/x86-pc/keyboard.lisp:1.3 movitz/losp/x86-pc/keyboard.lisp:1.4
--- movitz/losp/x86-pc/keyboard.lisp:1.3	Thu Oct  7 14:45:07 2004
+++ movitz/losp/x86-pc/keyboard.lisp	Wed Nov 24 17:20:14 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Sep 24 16:04:12 2001
 ;;;;                
-;;;; $Id: keyboard.lisp,v 1.3 2004/10/07 12:45:07 ffjeld Exp $
+;;;; $Id: keyboard.lisp,v 1.4 2004/11/24 16:20:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -23,6 +23,7 @@
 	   ;; read-char
 	   poll-keypress
 	   read-keypress
+	   poll-key
 	   set-leds
 	   cpu-reset))
 
@@ -155,7 +156,7 @@
 	   (aref *scan-codes* key-code))))
 ;;;  (< -1 key-code (length *scan-codes*)))
 
-(defun read-key ()
+(defun get-key ()
   (when (lowlevel-event-p)
     (multiple-value-bind (key-code release-p)
 	(lowlevel-read)
@@ -175,7 +176,7 @@
 
 (defun poll-keypress ()
   (multiple-value-bind (key release-p)
-      (read-key)
+      (get-key)
     (unless release-p
       (values key *qualifier-state*))))
 
@@ -189,6 +190,7 @@
   (multiple-value-bind (key qualifiers)
       (poll-keypress)
     (cond
+     ((not key) nil)
      ((symbolp key)
       (case key
 	(:up #\^p)
@@ -204,8 +206,16 @@
 		    (- (char-code #\a)))))
      (t key))))
 
-;;;(defun read-char ()
-;;;  (loop when (poll-char) return it))
+(defun poll-key ()
+  (multiple-value-bind (key qualifiers)
+      (poll-keypress)
+    (if (and (characterp key)
+	     (qualifier-p :ctrl qualifiers)
+	     (char<= #\a (char-downcase key) #\z))
+	(code-char (+ (char-code #\^a)
+		      (char-code (char-downcase key))
+		      (- (char-code #\a))))
+      key)))
 
 (defun set-leds (led0 led1 led2)
   (loop while (logbitp 1 (io-port #x64 :unsigned-byte8)))




From ffjeld at common-lisp.net  Wed Nov 24 16:20:31 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 17:20:31 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/ne2k.lisp 
Message-ID: <E1CWzsd-0006pX-00@common-lisp.net>

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

Modified Files:
	ne2k.lisp 
Log Message:
*** empty log message ***
Date: Wed Nov 24 17:20:30 2004
Author: ffjeld

Index: movitz/losp/x86-pc/ne2k.lisp
diff -u movitz/losp/x86-pc/ne2k.lisp:1.12 movitz/losp/x86-pc/ne2k.lisp:1.13
--- movitz/losp/x86-pc/ne2k.lisp:1.12	Wed Nov 24 14:12:02 2004
+++ movitz/losp/x86-pc/ne2k.lisp	Wed Nov 24 17:20:30 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 17 15:16:00 2002
 ;;;;                
-;;;; $Id: ne2k.lisp,v 1.12 2004/11/24 13:12:02 ffjeld Exp $
+;;;; $Id: ne2k.lisp,v 1.13 2004/11/24 16:20:30 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -47,7 +47,7 @@
   (let ((io-space (make-io-space :range io-base #x20)))
     (with-io-space-lock ()
       (when (null (io-space-occupants io-space))
-	(format t "Probing for ne2k NIC at #x~X.." io-base)
+	(format *query-io* "~&Probing for ne2k NIC at #x~X.." io-base)
 	(with-dp8390 (dp8390 io-base)
 	  (let ((tmp (dp8390 #x1f)))
 	    (io-delay 5000)




From ffjeld at common-lisp.net  Wed Nov 24 16:21:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 17:21:43 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip6.lisp 
Message-ID: <E1CWztn-0006qX-00@common-lisp.net>

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

Modified Files:
	ip6.lisp 
Log Message:
*** empty log message ***
Date: Wed Nov 24 17:21:42 2004
Author: ffjeld

Index: movitz/losp/lib/net/ip6.lisp
diff -u movitz/losp/lib/net/ip6.lisp:1.6 movitz/losp/lib/net/ip6.lisp:1.7
--- movitz/losp/lib/net/ip6.lisp:1.6	Sun Apr 11 20:53:42 2004
+++ movitz/losp/lib/net/ip6.lisp	Wed Nov 24 17:21:42 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 14 17:25:31 2001
 ;;;;                
-;;;; $Id: ip6.lisp,v 1.6 2004/04/11 18:53:42 ffjeld Exp $
+;;;; $Id: ip6.lisp,v 1.7 2004/11/24 16:21:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -568,9 +568,12 @@
   
 (defvar *ne2000* nil)
 
-(defun ip6-test (&optional (ne2000 (or *ne2000*
-				       (setf *ne2000* (some #'muerte.x86-pc.ne2k:ne2k-probe muerte.x86-pc.ne2k:+ne2k-probe-addresses+))
-				       (error "No ethernet device."))))
+(defun ip6-test (&optional (ne2000 
+			    (or *ne2000*
+				(setf *ne2000*
+				  (some #'muerte.x86-pc.ne2k:ne2k-probe
+					muerte.x86-pc.ne2k:*ne2k-probe-addresses*))
+				(error "No ethernet device."))))
   (let* ((link-local-address (link-local-address-by-mac (mac-address ne2000)))
 	 (solicited-node-address (solicited-node-address link-local-address))
 	 (neighbor-cache (make-neighbor-cache)))




From ffjeld at common-lisp.net  Wed Nov 24 16:22:01 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 17:22:01 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp 
Message-ID: <E1CWzu5-0006qx-00@common-lisp.net>

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

Modified Files:
	ip4.lisp 
Log Message:
Include :lib/net/tftp.

Date: Wed Nov 24 17:21:58 2004
Author: ffjeld

Index: movitz/losp/lib/net/ip4.lisp
diff -u movitz/losp/lib/net/ip4.lisp:1.11 movitz/losp/lib/net/ip4.lisp:1.12
--- movitz/losp/lib/net/ip4.lisp:1.11	Wed Nov 24 15:22:57 2004
+++ movitz/losp/lib/net/ip4.lisp	Wed Nov 24 17:21:57 2004
@@ -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.11 2004/11/24 14:22:57 ffjeld Exp $
+;;;; $Id: ip4.lisp,v 1.12 2004/11/24 16:21:57 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -43,6 +43,7 @@
 	   :type ,type))
 
 (require :lib/net/arp)
+(require :lib/net/tftp)
 
 (defclass ip4-stack ()
   ((interface




From ffjeld at common-lisp.net  Wed Nov 24 16:22:23 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 17:22:23 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/tftp.lisp 
Message-ID: <E1CWzuR-0006rU-00@common-lisp.net>

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

Modified Files:
	tftp.lisp 
Log Message:
Minor output niceties.

Date: Wed Nov 24 17:22:21 2004
Author: ffjeld

Index: movitz/losp/lib/net/tftp.lisp
diff -u movitz/losp/lib/net/tftp.lisp:1.1 movitz/losp/lib/net/tftp.lisp:1.2
--- movitz/losp/lib/net/tftp.lisp:1.1	Wed Nov 24 15:27:14 2004
+++ movitz/losp/lib/net/tftp.lisp	Wed Nov 24 17:22:21 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Oct  6 12:42:51 2004
 ;;;;                
-;;;; $Id: tftp.lisp,v 1.1 2004/11/24 14:27:14 ffjeld Exp $
+;;;; $Id: tftp.lisp,v 1.2 2004/11/24 16:22:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -84,8 +84,8 @@
 		 for ack = nil then (receive *ip4-nic* ack)
 		 until
 		   (with-simple-restart (continue
-					 "Continue TFTP stop-and-wait for block ~D~@[, port ~D~]."
-					 ack-block-number port)
+					 "Continue TFTP stop-and-wait for ~S block ~D~@[, port ~D~]."
+					 file-name ack-block-number port)
 		     (when (funcall breaker)
 		       (break "TFTP/Ethernet"))
 		     (when (< (* timeout internal-time-units-per-second)
@@ -137,7 +137,8 @@
 		       (setf (fill-pointer packet) j))
 		 (format-udp-header packet :destination ip :destination-port port)
 		 (format-ethernet-packet packet (mac-address *ip4-nic*) mac +ether-type-ip4+)
-		 (write-char #\. speak)
+		 (when speak
+		   (write-char #\. speak))
 		 (transmit-stop-and-wait packet block-number port)))
 	(format speak "done.")
 	(values)))))




From ffjeld at common-lisp.net  Wed Nov 24 16:22:45 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 17:22:45 +0100
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1CWzun-0006ru-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
*** empty log message ***
Date: Wed Nov 24 17:22:44 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.41 movitz/packages.lisp:1.42
--- movitz/packages.lisp:1.41	Tue Nov 23 17:10:51 2004
+++ movitz/packages.lisp	Wed Nov 24 17:22:43 2004
@@ -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.41 2004/11/23 16:10:51 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.42 2004/11/24 16:22:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1097,6 +1097,7 @@
 	   numargs-case
 	   movitz-accessor
 	   simple-read-from-string
+	   #:read-key
 	   print-word
 	   fixnump below
 	   print-unreadable-movitz-object




From ffjeld at common-lisp.net  Wed Nov 24 16:23:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 17:23:12 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/console.lisp 
Message-ID: <E1CWzvE-0006tF-00@common-lisp.net>

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

Modified Files:
	console.lisp 
Log Message:
Use unwind-protect rather than m-v-prog1 for restoring console context.

Date: Wed Nov 24 17:23:11 2004
Author: ffjeld

Index: movitz/losp/lib/console.lisp
diff -u movitz/losp/lib/console.lisp:1.5 movitz/losp/lib/console.lisp:1.6
--- movitz/losp/lib/console.lisp:1.5	Mon Jul 12 11:11:56 2004
+++ movitz/losp/lib/console.lisp	Wed Nov 24 17:23:11 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Aug 14 18:14:16 2003
 ;;;;                
-;;;; $Id: console.lisp,v 1.5 2004/07/12 09:11:56 ffjeld Exp $
+;;;; $Id: console.lisp,v 1.6 2004/11/24 16:23:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -28,7 +28,7 @@
        (let ((,x-var (cursor-x ,stream-var))
 	     (,y-var (cursor-y ,stream-var))
 	     (,scroll-var *scroll-offset*))
-	 (multiple-value-prog1 (progn , at body)
+	 (unwind-protect (progn , at body)
 	   (setf (cursor-x ,stream-var) ,x-var
 		 (cursor-y ,stream-var) (- ,y-var (- *scroll-offset* ,scroll-var))))))))
 




From ffjeld at common-lisp.net  Wed Nov 24 16:23:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 17:23:46 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/readline.lisp 
Message-ID: <E1CWzvm-0006tf-00@common-lisp.net>

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

Modified Files:
	readline.lisp 
Log Message:
Add an option to signal a keypress-condition at each keypress.

Date: Wed Nov 24 17:23:45 2004
Author: ffjeld

Index: movitz/losp/lib/readline.lisp
diff -u movitz/losp/lib/readline.lisp:1.5 movitz/losp/lib/readline.lisp:1.6
--- movitz/losp/lib/readline.lisp:1.5	Thu Jul 29 18:20:18 2004
+++ movitz/losp/lib/readline.lisp	Wed Nov 24 17:23:45 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov  2 13:58:58 2001
 ;;;;                
-;;;; $Id: readline.lisp,v 1.5 2004/07/29 16:20:18 ffjeld Exp $
+;;;; $Id: readline.lisp,v 1.6 2004/11/24 16:23:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -22,6 +22,9 @@
   (:use #:muerte.cl #:muerte.lib)
   (:export #:readline
 	   #:readline-buffer
+	   #:readline-keypress
+	   #:readline-keypress-key
+	   #:*readline-signal-keypresses*
 	   #:make-readline-buffer
 	   #:readline-buffer-string
 	   #:readline-buffer-cursor-position
@@ -32,6 +35,8 @@
 
 (in-package muerte.readline)
 
+(defvar *readline-signal-keypresses* nil)
+
 (defun complete-symbol-name (string &key (start 0) (end (length string)) (collect-matches nil)
 					 filter-matches (package *package*))
   "=> completion (a symbol), completion-count completion-start completion-end completion-collection.
@@ -108,7 +113,12 @@
   (cursor-end 0)
   string)
 
-(defun readline (readline-buffer console &optional (terminator-keys '(#\newline)))
+(define-condition readline-keypress ()
+  ((key
+    :accessor readline-keypress-key
+    :initarg :key)))
+
+(defun readline (readline-buffer console &key (terminators '(#\newline)))
   (with-accessors ((buffer readline-buffer-string)
 		   (pos readline-buffer-cursor-position)
 		   (end readline-buffer-cursor-end))
@@ -118,113 +128,98 @@
       (write-string buffer t :end end)
       (setf (cursor-x console) (+ cursor-origin pos)))
     (loop with previous-key-was-tab-p = nil
+	with keypress-condition = (when *readline-signal-keypresses*
+				    (make-condition 'readline-keypress))
 	and displayed-completions-p = nil
-	as key = (read-char console)
-	do (when (integerp key)
-	     (with-saved-excursion (console)
-	       (warn "key: ~S" key)))
-;;;	do (setf key
-;;;	     (case key
-;;;	       (#\^k :kill)
-;;;	       (#\^y :yank)
-;;;	       (#\^p :previous)
-;;;	       (#\^n :next)
-;;;	       (t key)))
-	do (unless (char= key #\tab)
-	     (setf previous-key-was-tab-p nil))
-	when (member key terminator-keys)
-	do (when displayed-completions-p
-	     (do ((y (1+ (cursor-y console)) (1+ y)))
-		 ((>= y (console-height console)))
-	       (clear-line console 0 y)))
-	and return key
-	do (case key
-	     (#\tab
-	      (when (plusp pos)
-		(let ((token-pos pos))
-		  (do ()		; move to start of token
-		      ((or (zerop token-pos)
-			   (member (char buffer (1- token-pos))
-				   '(#\space #\( #\) #\newline #\'))))
-		    (decf token-pos))
-		  (multiple-value-bind (completion completion-count completion-start
-					completion-end completion-collection)
-		      (complete-symbol-name
-		       buffer
-		       :start token-pos
-		       :end pos
-		       :collect-matches previous-key-was-tab-p
-		       :filter-matches (if (and (< 0 token-pos)
-						(char= #\( (char buffer (1- token-pos)))
-						(not (and (< 1 token-pos)
-							  (char= #\( (char buffer (- token-pos 2))))))
-					   #'fboundp
-					 nil))
-		    ;; (warn "comp: ~S" completion-collection)
-		    ;; move tail string forward
-		    (when completion
-		      (let ((completion-length (- completion-end completion-start)))
-			(incf end completion-length)
-			(dotimes (i (- end pos completion-length))
-			  (setf (char buffer (- end i 1))
-			    (char buffer (- end i 1 completion-length))))
-			;; insert completion
-			(loop for i from completion-start below completion-end
-			    do (write-char 
-				(setf (char buffer pos) (char-downcase (char (symbol-name completion) i))))
-			    do (incf pos))
-			(let ((x (cursor-x console)))
-			  (write-string buffer t :start pos :end end)
-			  (setf (cursor-x console) x))))
-		    (when displayed-completions-p
-		      (do ((y (1+ (cursor-y console)) (1+ y)))
-			  ((>= y (console-height console)))
-			(clear-line console 0 y))
-		      (setf displayed-completions-p nil))
-		    (when previous-key-was-tab-p
-		      (with-saved-excursion (console)
-			(cond
-			 ((null completion-collection)
-			  (format t "~%No completions."))
-			 ((< completion-count 20)
-			  (format t "~%Completions:~{ ~A~}." completion-collection))
-			 (t (format t "~%~D completions!" completion-count))))
-		      (setf displayed-completions-p t)))))
-	      (setf previous-key-was-tab-p (not previous-key-was-tab-p)))
-	     ((:left #\^b)
-	      (unless (zerop pos)
-		(decf pos)
-		(decf (cursor-x console))))
-	     (#\^a
-	      (decf (cursor-x console) pos)
-	      (setf pos 0))
-	     ((:right #\^f)
-	      (when (< pos end)
-		(incf pos)
-		(incf (cursor-x console))))
-	     (#\^e
-	      (incf (cursor-x console) (- end pos))
-	      (setf pos end))
-	     ((:kill #\^k)
-	      (let ((x (cursor-x console)))
-		(dotimes (i (- end pos))
-		  (write-char #\space))
-		(setf (cursor-x console) x
-		      end pos)))
-	     ((#\delete #\^d)
-	      (when (< pos end)
-		(dotimes (i (- end pos))
-		  (setf (char buffer (+ pos i))
-		    (char buffer (+ pos i 1))))
-		(decf end)
+	as key = (muerte:read-key console)
+	do (with-saved-excursion (console)
+	     (when keypress-condition
+	       (setf (readline-keypress-key keypress-condition) key)
+	       (with-simple-restart (continue "Proceed with interactive READLINE.")
+		 (signal keypress-condition))))
+	   (when (characterp key)
+	     (unless (char= key #\tab)
+	       (setf previous-key-was-tab-p nil))
+	     (when (member key terminators)
+	       (when displayed-completions-p
+		 (do ((y (1+ (cursor-y console)) (1+ y)))
+		     ((>= y (console-height console)))
+		   (clear-line console 0 y)))
+	       (return key))
+	     (case key
+	       (#\tab
+		(when (plusp pos)
+		  (let ((token-pos pos))
+		    (do ()		; move to start of token
+			((or (zerop token-pos)
+			     (member (char buffer (1- token-pos))
+				     '(#\space #\( #\) #\newline #\'))))
+		      (decf token-pos))
+		    (multiple-value-bind (completion completion-count completion-start
+					  completion-end completion-collection)
+			(complete-symbol-name
+			 buffer
+			 :start token-pos
+			 :end pos
+			 :collect-matches previous-key-was-tab-p
+			 :filter-matches (if (and (< 0 token-pos)
+						  (char= #\( (char buffer (1- token-pos)))
+						  (not (and (< 1 token-pos)
+							    (char= #\( (char buffer (- token-pos 2))))))
+					     #'fboundp
+					   nil))
+		      ;; (warn "comp: ~S" completion-collection)
+		      ;; move tail string forward
+		      (when completion
+			(let ((completion-length (- completion-end completion-start)))
+			  (incf end completion-length)
+			  (dotimes (i (- end pos completion-length))
+			    (setf (char buffer (- end i 1))
+			      (char buffer (- end i 1 completion-length))))
+			  ;; insert completion
+			  (loop for i from completion-start below completion-end
+			      do (write-char 
+				  (setf (char buffer pos) (char-downcase (char (symbol-name completion) i))))
+			      do (incf pos))
+			  (let ((x (cursor-x console)))
+			    (write-string buffer t :start pos :end end)
+			    (setf (cursor-x console) x))))
+		      (when displayed-completions-p
+			(do ((y (1+ (cursor-y console)) (1+ y)))
+			    ((>= y (console-height console)))
+			  (clear-line console 0 y))
+			(setf displayed-completions-p nil))
+		      (when previous-key-was-tab-p
+			(with-saved-excursion (console)
+			  (cond
+			   ((null completion-collection)
+			    (format t "~%No completions."))
+			   ((< completion-count 20)
+			    (format t "~%Completions:~{ ~A~}." completion-collection))
+			   (t (format t "~%~D completions!" completion-count))))
+			(setf displayed-completions-p t)))))
+		(setf previous-key-was-tab-p (not previous-key-was-tab-p)))
+	       ((:left #\^b)
+		(unless (zerop pos)
+		  (decf pos)
+		  (decf (cursor-x console))))
+	       (#\^a
+		(decf (cursor-x console) pos)
+		(setf pos 0))
+	       ((:right #\^f)
+		(when (< pos end)
+		  (incf pos)
+		  (incf (cursor-x console))))
+	       (#\^e
+		(incf (cursor-x console) (- end pos))
+		(setf pos end))
+	       ((:kill #\^k)
 		(let ((x (cursor-x console)))
-		  (write-string buffer t :start pos :end end)
-		  (write-char #\space)
-		  (setf (cursor-x console) x))))
-	     (#\backspace
-	      (unless (zerop pos)
-		(decf pos)
-		(decf (cursor-x console))
+		  (dotimes (i (- end pos))
+		    (write-char #\space))
+		  (setf (cursor-x console) x
+			end pos)))
+	       ((#\delete #\^d)
 		(when (< pos end)
 		  (dotimes (i (- end pos))
 		    (setf (char buffer (+ pos i))
@@ -233,19 +228,32 @@
 		  (let ((x (cursor-x console)))
 		    (write-string buffer t :start pos :end end)
 		    (write-char #\space)
-		    (setf (cursor-x console) x)))))
-	     (t (when (and (characterp key)
-			   (< 1 (- (console-width console)
-				   (cursor-x console))))
-		  (dotimes (i (- end pos))
-		    (setf (char buffer (- end i))
-		      (char buffer (- end i 1))))
-		  (setf (char buffer pos) key)
-		  (incf end)
-		  (let ((x (cursor-x console)))
-		    (write-string buffer t :start pos :end end)
-		    (setf (cursor-x console) (1+ x)))
-		  (incf pos)))))))
+		    (setf (cursor-x console) x))))
+	       (#\backspace
+		(unless (zerop pos)
+		  (decf pos)
+		  (decf (cursor-x console))
+		  (when (< pos end)
+		    (dotimes (i (- end pos))
+		      (setf (char buffer (+ pos i))
+			(char buffer (+ pos i 1))))
+		    (decf end)
+		    (let ((x (cursor-x console)))
+		      (write-string buffer t :start pos :end end)
+		      (write-char #\space)
+		      (setf (cursor-x console) x)))))
+	       (t (when (and (characterp key)
+			     (< 1 (- (console-width console)
+				     (cursor-x console))))
+		    (dotimes (i (- end pos))
+		      (setf (char buffer (- end i))
+			(char buffer (- end i 1))))
+		    (setf (char buffer pos) key)
+		    (incf end)
+		    (let ((x (cursor-x console)))
+		      (write-string buffer t :start pos :end end)
+		      (setf (cursor-x console) (1+ x)))
+		    (incf pos))))))))
 
 (defstruct readline-context-state
   scratch
@@ -299,8 +307,8 @@
 	  as terminator =
 	    (readline (replace-buffer scratch (aref buffers edit-buffer))
 		      *standard-output*
-		      (append break-characters
-			      '(#\^c #\newline #\^p #\^n :up :down)))
+		      :terminators (append break-characters
+					   '(#\^c #\newline #\^p #\^n :up :down)))
 	  do (when (or (eql #\^c terminator)
 		       (member terminator break-characters))
 	       (signal 'readline-break :character terminator))
@@ -333,7 +341,8 @@
 	       ((#\^n :down)
 		(replace-buffer (aref buffers edit-buffer) scratch)
 		(setf (cursor-x *standard-output*) cursor-origin
-		      edit-buffer (mod (1+ edit-buffer) (length buffers)))))))))
+		      edit-buffer (mod (1+ edit-buffer) (length buffers))))
+	       (t (warn "unknown terminator: ~S" terminator)))))))
 
 
 




From ffjeld at common-lisp.net  Wed Nov 24 16:24:19 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 17:24:19 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1CWzwJ-0006u5-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Added a dump-screen-to-tftp button, f12.

Date: Wed Nov 24 17:24:17 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.31 movitz/losp/los0.lisp:1.32
--- movitz/losp/los0.lisp:1.31	Tue Nov 23 20:03:15 2004
+++ movitz/losp/los0.lisp	Wed Nov 24 17:24:16 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.31 2004/11/23 19:03:15 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.32 2004/11/24 16:24:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1262,6 +1262,27 @@
 		       (incf (memref-int muerte.x86-pc::*screen* :index 80 :type :unsigned-byte16)))))
 	(incf (memref-int muerte.x86-pc::*screen* :index 160 :type :unsigned-byte16))))))
 
+(defun fvf-textmode-screendump ()
+  (muerte.ip4::ip4-init)
+  (let* ((w muerte.x86-pc::*screen-width*)
+	 (h muerte.x86-pc::*screen-height*)
+	 (data (make-array (* w h)
+			   :element-type 'character
+			   :fill-pointer 0)))
+    (loop for y below h
+	do (loop for x below w
+	       do (vector-push (code-char
+				(ldb (byte 8 0)
+				     (memref-int muerte.x86-pc::*screen*
+						 :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
+				    :quiet t
+				    :mac (muerte.ip4::polling-arp :129.242.16.1
+								  (lambda ()
+								    (eql #\esc (muerte.x86-pc.keyboard:poll-char)))))))
+
 (defun mumbojumbo (x)
   (with-inline-assembly (:returns :eax)
     (:compile-form (:result-mode :untagged-fixnum-ecx) x)
@@ -1319,13 +1340,21 @@
 		       *debug-io* s)))
     (let ((* nil) (** nil) (*** nil)
 	  (/ nil) (// nil) (/// nil)
-	  (+ nil) (++ nil) (+++ nil))
+	  (+ nil) (++ nil) (+++ nil)
+	  (*readline-signal-keypresses* t))
       (format t "~&Movitz image Los0 build ~D." *build-number*)
-      (loop
-	(catch :top-level-repl		; If restarts don't work, you can throw this..
-	  (with-simple-restart (abort "Abort to the top command level.")
-	    (read-eval-print))))))
-  
+      (handler-bind 
+	  ((readline-keypress
+	    (lambda (c)
+	      (let ((key (readline-keypress-key c)))
+		(when (eq :f12 key)
+		  (fvf-textmode-screendump)
+		  (format *query-io* "~&Dumped console contents by TFTP."))))))
+	(loop
+	  (catch :top-level-repl	; If restarts don't work, you can throw this..
+	    (with-simple-restart (abort "Abort to the top command level.")
+	      (read-eval-print)))))))
+
   (error "What's up? [~S]" 'hey))
 
 (defun read (&optional input-stream eof-error-p eof-value recursive-p)




From ffjeld at common-lisp.net  Wed Nov 24 16:24:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 17:24:38 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/textmode.lisp 
Message-ID: <E1CWzwc-0006uV-00@common-lisp.net>

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

Modified Files:
	textmode.lisp 
Log Message:
Add support for read-key.

Date: Wed Nov 24 17:24:36 2004
Author: ffjeld

Index: movitz/losp/x86-pc/textmode.lisp
diff -u movitz/losp/x86-pc/textmode.lisp:1.13 movitz/losp/x86-pc/textmode.lisp:1.14
--- movitz/losp/x86-pc/textmode.lisp:1.13	Sun Nov 14 23:58:23 2004
+++ movitz/losp/x86-pc/textmode.lisp	Wed Nov 24 17:24:36 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Thu Nov  9 15:38:56 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: textmode.lisp,v 1.13 2004/11/14 22:58:23 ffjeld Exp $
+;;;; $Id: textmode.lisp,v 1.14 2004/11/24 16:24:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -224,6 +224,8 @@
      (loop when (muerte.x86-pc.keyboard:poll-char) return it))
     (muerte::stream-read-char-no-hang
      (muerte.x86-pc.keyboard:poll-char))
+    (muerte::stream-read-key
+     (loop when (muerte.x86-pc.keyboard:poll-key) return it))
     (cursor-x (cursor-column))
     (cursor-y (cursor-row))
     (console-width *screen-width*)




From ffjeld at common-lisp.net  Wed Nov 24 16:26:30 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 17:26:30 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp 
Message-ID: <E1CWzyQ-0006v0-00@common-lisp.net>

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

Modified Files:
	ip4.lisp 
Log Message:
Define constants etc first, then include files that might depend on them.

Date: Wed Nov 24 17:26:29 2004
Author: ffjeld

Index: movitz/losp/lib/net/ip4.lisp
diff -u movitz/losp/lib/net/ip4.lisp:1.12 movitz/losp/lib/net/ip4.lisp:1.13
--- movitz/losp/lib/net/ip4.lisp:1.12	Wed Nov 24 17:21:57 2004
+++ movitz/losp/lib/net/ip4.lisp	Wed Nov 24 17:26:29 2004
@@ -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.12 2004/11/24 16:21:57 ffjeld Exp $
+;;;; $Id: ip4.lisp,v 1.13 2004/11/24 16:26:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -42,9 +42,6 @@
 	   :endian :big
 	   :type ,type))
 
-(require :lib/net/arp)
-(require :lib/net/tftp)
-
 (defclass ip4-stack ()
   ((interface
     :initarg :interface
@@ -74,6 +71,9 @@
   (12 source)
   (16 destination)
   (20 options))
+
+(require :lib/net/arp)
+(require :lib/net/tftp)
 
 (defun ip-protocol (packet &optional (start 14))
   (ip4-ref packet start +ip-header-protocol+ :unsigned-byte8))




From ffjeld at common-lisp.net  Wed Nov 24 17:27:44 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 18:27:44 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/arp.lisp 
Message-ID: <E1CX0vg-0007qo-00@common-lisp.net>

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

Modified Files:
	arp.lisp 
Log Message:
*** empty log message ***
Date: Wed Nov 24 18:27:43 2004
Author: ffjeld

Index: movitz/losp/lib/net/arp.lisp
diff -u movitz/losp/lib/net/arp.lisp:1.7 movitz/losp/lib/net/arp.lisp:1.8
--- movitz/losp/lib/net/arp.lisp:1.7	Wed Nov 24 11:09:12 2004
+++ movitz/losp/lib/net/arp.lisp	Wed Nov 24 18:27:42 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Mar 20 15:01:15 2003
 ;;;;                
-;;;; $Id: arp.lisp,v 1.7 2004/11/24 10:09:12 ffjeld Exp $
+;;;; $Id: arp.lisp,v 1.8 2004/11/24 17:27:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -79,10 +79,10 @@
 
 (defvar *ne2000* nil)
 
-(defun polling-arp (ip &optional (waiter #'false))
+(defun polling-arp (ip &optional (breaker #'false))
   (loop with ip = (ip4-address ip) and nic = *ip4-nic* and transmit-time = 0
       for packet = (muerte.ethernet:receive nic)
-      until (funcall waiter)
+      until (funcall breaker)
       do (when (and packet
 		    (eq +ether-type-arp+ (ether-type packet))
 		    (eq +arp-op-reply+ (arp-operation packet))




From ffjeld at common-lisp.net  Wed Nov 24 17:28:02 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 18:28:02 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp 
Message-ID: <E1CX0vy-0007rE-00@common-lisp.net>

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

Modified Files:
	ip4.lisp 
Log Message:
Minor tweaks.

Date: Wed Nov 24 18:28:01 2004
Author: ffjeld

Index: movitz/losp/lib/net/ip4.lisp
diff -u movitz/losp/lib/net/ip4.lisp:1.13 movitz/losp/lib/net/ip4.lisp:1.14
--- movitz/losp/lib/net/ip4.lisp:1.13	Wed Nov 24 17:26:29 2004
+++ movitz/losp/lib/net/ip4.lisp	Wed Nov 24 18:28:01 2004
@@ -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.13 2004/11/24 16:26:29 ffjeld Exp $
+;;;; $Id: ip4.lisp,v 1.14 2004/11/24 17:28:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -29,12 +29,14 @@
 	   #:format-ip4-header
 	   #:format-udp-header
 	   #:*ip4-nic*
-	   #:*ip4-ip*))
+	   #:*ip4-ip*
+	   #:*ip4-router*))
 
 (in-package muerte.ip4)
 
 (defvar *ip4-nic* nil)
 (defvar *ip4-ip* nil)
+(defvar *ip4-router* nil)
 
 (defmacro ip4-ref (packet start offset type)
   `(memref ,packet (+ (muerte:movitz-type-slot-offset 'movitz-basic-vector 'data)
@@ -165,11 +167,12 @@
 		    (t 0)))
   (when (and (not start-p) (or colon at))
     (incf start 14))
-  (format stream "~D.~D.~D.~D"
-	  (aref address (+ start 0))
-	  (aref address (+ start 1))
-	  (aref address (+ start 2))
-	  (aref address (+ start 3)))
+  (let ((address (ip4-address address)))
+    (format stream "~D.~D.~D.~D"
+	    (ip4-ref address start 0 :unsigned-byte8)
+	    (ip4-ref address start 1 :unsigned-byte8)
+	    (ip4-ref address start 2 :unsigned-byte8)
+	    (ip4-ref address start 3 :unsigned-byte8)))
   nil)
 
 (defun arp-input (stack packet start)
@@ -454,6 +457,10 @@
 (defun ip4-address (specifier &optional (start 0))
   (or (ignore-errors
        (typecase specifier
+	 ((simple-array (unsigned-byte 8) (*))
+	  (if (= start 0)
+	      specifier
+	    (subseq specifier start (+ start 4))))
 	 ((or string symbol)
 	  (read-ip4-address (string specifier) start))
 	 (vector
@@ -482,23 +489,25 @@
       (setf *ip4-nic* ethernet)))
   (unless *ip4-ip*
     (setf *ip4-ip* (ip4-address :129.242.16.173)))
+  (unless *ip4-router*
+    (setf *ip4-router* (ip4-address :129.242.16.1)))
+  ;; This is to announce our presence on the LAN..
+  (polling-arp *ip4-router* (lambda ()
+			      (eql #\esc (muerte.x86-pc.keyboard:poll-char))))
   (values *ip4-nic* *ip4-ip*))
 
-(defun ip4-test (&key (router #(129 242 16 1)))
+(defun ip4-test ()
   (ip4-init)
   (let ((ethernet *ip4-nic*)
 	(stack (make-instance 'ip4-stack
 		 :interface *ip4-nic*
 		 :address *ip4-ip*)))
-    (when router
-      (transmit (interface stack)
-		(format-ethernet-packet (format-arp-request nil +arp-op-request+
-							    (address stack)
-							    (mac-address (interface stack))
-							    (ip4-address router))
-					(mac-address (interface stack))
-					+broadcast-address+
-					+ether-type-arp+)))
+    (when *ip4-router*
+      (format *query-io* "~&Router ~/ip4:pprint-ip4/ is at ~/ethernet:pprint-mac/."
+	      *ip4-router*
+	      (polling-arp *ip4-router* 
+			   (lambda ()
+			     (eql #\esc (muerte.x86-pc.keyboard:poll-char))))))
     (loop
       (case (muerte.x86-pc.keyboard:poll-char)
 	((nil))




From ffjeld at common-lisp.net  Wed Nov 24 22:11:45 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Nov 2004 23:11:45 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/arp.lisp 
Message-ID: <E1CX5MX-0003bj-00@common-lisp.net>

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

Modified Files:
	arp.lisp 
Log Message:
There's no #'false, it's (constantly nil).

Date: Wed Nov 24 23:11:43 2004
Author: ffjeld

Index: movitz/losp/lib/net/arp.lisp
diff -u movitz/losp/lib/net/arp.lisp:1.8 movitz/losp/lib/net/arp.lisp:1.9
--- movitz/losp/lib/net/arp.lisp:1.8	Wed Nov 24 18:27:42 2004
+++ movitz/losp/lib/net/arp.lisp	Wed Nov 24 23:11:43 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Mar 20 15:01:15 2003
 ;;;;                
-;;;; $Id: arp.lisp,v 1.8 2004/11/24 17:27:42 ffjeld Exp $
+;;;; $Id: arp.lisp,v 1.9 2004/11/24 22:11:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -79,7 +79,7 @@
 
 (defvar *ne2000* nil)
 
-(defun polling-arp (ip &optional (breaker #'false))
+(defun polling-arp (ip &optional (breaker (constantly nil)))
   (loop with ip = (ip4-address ip) and nic = *ip4-nic* and transmit-time = 0
       for packet = (muerte.ethernet:receive nic)
       until (funcall breaker)




From ffjeld at common-lisp.net  Thu Nov 25 02:10:00 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Nov 2004 03:10:00 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/tftp.lisp 
Message-ID: <E1CX956-0007GY-00@common-lisp.net>

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

Modified Files:
	tftp.lisp 
Log Message:
minor edit.

Date: Thu Nov 25 03:09:56 2004
Author: ffjeld

Index: movitz/losp/lib/net/tftp.lisp
diff -u movitz/losp/lib/net/tftp.lisp:1.2 movitz/losp/lib/net/tftp.lisp:1.3
--- movitz/losp/lib/net/tftp.lisp:1.2	Wed Nov 24 17:22:21 2004
+++ movitz/losp/lib/net/tftp.lisp	Thu Nov 25 03:09:55 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Oct  6 12:42:51 2004
 ;;;;                
-;;;; $Id: tftp.lisp,v 1.2 2004/11/24 16:22:21 ffjeld Exp $
+;;;; $Id: tftp.lisp,v 1.3 2004/11/25 02:09:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -64,7 +64,7 @@
 				 (data-length (length data-vector))
 				 (breaker (lambda ()
 					    (eql #\esc (muerte.x86-pc.keyboard:poll-char)))))
-  "Low-level TFTP write data-vector to file-name on host ip using *ip4-nic*.
+  "TFTP write data-vector to file-name on host ip using *ip4-nic*.
 The host's MAC is looked up by ARP unless provided."
   (let ((speak (if quiet nil *query-io*))
 	(ip (ip4-address ip)))




From ffjeld at common-lisp.net  Thu Nov 25 02:10:40 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Nov 2004 03:10:40 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1CX95k-0007H4-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Make (Setf char) and (setf schar) more safe.

Date: Thu Nov 25 03:10:39 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.48 movitz/losp/muerte/arrays.lisp:1.49
--- movitz/losp/muerte/arrays.lisp:1.48	Tue Nov 23 20:30:23 2004
+++ movitz/losp/muerte/arrays.lisp	Thu Nov 25 03:10:38 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.48 2004/11/23 19:30:23 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.49 2004/11/25 02:10:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -518,6 +518,8 @@
 	  :index index :type :character))
 
 (defun (setf char) (value string index)
+  (check-type string string)
+  (check-type value character)
   (assert (below index (array-dimension string 0)))
   (setf (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data)
 		:index index :type :character) value))
@@ -531,6 +533,7 @@
 
 (defun (setf schar) (value string index)
   (check-type string string)
+  (check-type value character)
   (assert (below index (length string)))
   (setf (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data)
 		:index index :type :character)




From ffjeld at common-lisp.net  Thu Nov 25 02:11:36 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Nov 2004 03:11:36 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp 
Message-ID: <E1CX96e-0007Hv-00@common-lisp.net>

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

Modified Files:
	pci.lisp 
Log Message:
A bit more PCI probing code. I'm starting to figure this out.

Date: Thu Nov 25 03:11:34 2004
Author: ffjeld

Index: movitz/losp/x86-pc/pci.lisp
diff -u movitz/losp/x86-pc/pci.lisp:1.5 movitz/losp/x86-pc/pci.lisp:1.6
--- movitz/losp/x86-pc/pci.lisp:1.5	Tue Nov 23 14:45:51 2004
+++ movitz/losp/x86-pc/pci.lisp	Thu Nov 25 03:11:34 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Dec 14 22:33:42 2003
 ;;;;                
-;;;; $Id: pci.lisp,v 1.5 2004/11/23 13:45:51 ffjeld Exp $
+;;;; $Id: pci.lisp,v 1.6 2004/11/25 02:11:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,6 +18,28 @@
 
 (provide :x86-pc/pci)
 
+(defun pci-word (designator)
+  "Map an integer or 4-character string to an (unsigned-byte 32)."
+  (etypecase designator
+    ((unsigned-byte 32)
+     designator)
+    ((signed-byte 32)
+     (ldb (byte 32 0) designator))
+    (string
+     (loop for c across designator as i upfrom 0 by 8
+	 summing (ash (char-code c) i)))))
+
+(defun pci-string (integer)
+  "Map a 32-bit value to a 4-character string."
+  (check-type integer (or (signed-byte 32)
+			  (unsigned-byte 32)))
+  (let ((string (make-string 4)))
+    (setf (char string 0) (code-char (ldb (byte 8 0) integer))
+	  (char string 1) (code-char (ldb (byte 8 8) integer))
+	  (char string 2) (code-char (ldb (byte 8 16) integer))
+	  (char string 3) (code-char (ldb (byte 8 24) integer)))
+    string))
+
 (defun find-bios32-base ()
   (loop for bios32 from #xe0000 to #xffff0 by 16
       if (and (= (memref-int bios32) #x5f32335f)
@@ -29,54 +51,123 @@
       return bios32))
 
 (defvar *bios32-base* nil)
+(defvar *pcibios-entry* nil)
+
+(defun find-bios32-pci ()
+  (let ((bios32-base (find-bios32-base)))
+    (assert bios32-base "No bios32 found.")
+    (multiple-value-bind (eax ebx ecx edx)
+	(pci-far-call (memref-int bios32-base :offset 4)
+		      :eax (pci-word "$PCI"))
+      (declare (ignore ecx))
+      (ecase (ldb (byte 8 0) eax)
+	(#x80 (error "The PCI bios32 service isn't present."))
+	(#x81 (error "The PCI bios32 service doesn't exist."))
+	(#x00 (+ ebx edx))))))
+
+(defun pci-bios-present ()
+  (multiple-value-bind (eax ebx ecx edx cf)
+      (pci-far-call (find-bios32-pci) :eax #xb101)
+    (values (pci-string edx)
+	    (ldb (byte 8 8) eax)	; AH: Present status
+	    (ldb (byte 8 0) eax)	; AL: Hardware mechanism
+	    (ldb (byte 8 8) ebx)	; BH: Interface Level Major Version
+	    (ldb (byte 8 0) ebx)	; BL: Interface Level Minor Version
+	    (ldb (byte 8 0) ecx))))	; CL: Number of last PCI bus in the system
+		
+(defun find-pci-device (vendor device &optional (index 0))
+  (multiple-value-bind (eax ebx ecx edx cf)
+      (pci-far-call (find-bios32-pci)
+		    :eax #xb102
+		    :ecx device
+		    :edx vendor
+		    :esi index)
+    (unless cf
+      (values (ldb (byte 8 8) ebx)	; Bus
+	      (ldb (byte 5 3) ebx)	; Device
+	      (ldb (byte 3 0) ebx)	; Function
+	      (ecase (ldb (byte 8 8) eax)
+		(#x00 :successful)
+		(#x86 :device-not-found)
+		(#x83 :bad-vendor-id))))))
+
+(defun find-pci-class-code (class-code &optional (index 0))
+  (multiple-value-bind (eax ebx ecx edx cf)
+      (pci-far-call (find-bios32-pci)
+		    :eax #xb103
+		    :ecx class-code
+		    :esi index)
+    (declare (ignore ecx edx))
+    (unless cf
+      (values (ldb (byte 8 8) ebx)	; Bus
+	      (ldb (byte 5 3) ebx)	; Device
+	      (ldb (byte 3 0) ebx)	; Function
+	      (ecase (ldb (byte 8 8) eax)
+		(#x00 :successful)
+		(#x86 :device-not-found))))))
 
-(defun init-pci ()
-  (setf *bios32-base*
-    (find-bios32-base))
-  (if (not *bios32-base*)
-      (error "No PCI BIOS32 found.")
-    (let ((entry (memref-int *bios32-base* :offset 4))
-	  (revision (memref-int *bios32-base* :offset 8 :type :unsigned-byte8))
-	  (length (memref-int *bios32-base* :offset 9 :type :unsigned-byte8)))
-      (values entry revision length))))
 
-(defun pci-far-call (address &key (eax 0) (ebx 0) (cs 8))
+(defun pci-far-call (address &key (cs 8) (eax 0) (ebx 0) (ecx 0) (edx 0) (esi 0))
   "Make a 'far call' to cs:address with the provided values for eax and ebx.
-Returns the values of registers AL, EBX, ECX, and EDX. (Well, for now only the
-lower 30 bits are actually returned.) The stack discipline is broken during
-this call, so we disable interrupts in a somewhat feeble attempt to avoid trouble."
+Returns the values of registers AL, EBX, ECX, and EDX, and status of CF.
+ (NB: For now only the lower 30 bits of registers are actually returned.)
+The stack discipline is broken during this call, so we disable interrupts
+in a somewhat feeble attempt to avoid trouble."
+  (check-type address (unsigned-byte 32))
   (without-interrupts
     (with-inline-assembly (:returns :multiple-values)
+      ;; Enter atomically mode
+      (:declare-label-set restart-pci-far-call (restart))
+      (:locally (:pushl (:edi (:edi-offset :dynamic-env))))
+      (:pushl 'restart-pci-far-call)
+      (:locally (:pushl (:edi (:edi-offset :atomically-continuation))))
+      (:pushl :ebp)
+     restart
+      (:movl (:esp) :ebp)
+      (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation))))
+
       (:load-lexical (:lexical-binding cs) :untagged-fixnum-ecx)
       (:pushl :ecx)			; Code segment
       (:load-lexical (:lexical-binding address) :untagged-fixnum-ecx)
       (:pushl :ecx)			; Code address
-      (:load-lexical (:lexical-binding ebx) :untagged-fixnum-ecx)
-      (:pushl :ecx)			; EBX
       (:load-lexical (:lexical-binding eax) :untagged-fixnum-ecx)
-      (:movl :ecx :eax)
+      (:pushl :ecx)			; push EAX
+      (:load-lexical (:lexical-binding ebx) :untagged-fixnum-ecx)
+      (:pushl :ecx)			; push EBX
+      (:load-lexical (:lexical-binding edx) :untagged-fixnum-ecx)
+      (:pushl :ecx)			; push EDX
+      (:load-lexical (:lexical-binding esi) :untagged-fixnum-ecx)
+      (:pushl :ecx)			; push ESI
+      (:load-lexical (:lexical-binding ecx) :untagged-fixnum-ecx)
+      (:popl :esi)
+      (:popl :edx)
       (:popl :ebx)
+      (:popl :eax)
       (:call-segment (:esp))
       (:leal (:esp 8) :esp)
-      (:andl #xff :eax)
-      (:shll 2 :eax)
-      (:shll 2 :ebx)
-      (:shll 2 :ecx)
-      (:shll 2 :edx)
-      (:locally (:movl :ecx (:edi (:edi-offset values) 0)))
-      (:locally (:movl :edx (:edi (:edi-offset values) 4)))
-      (:movl 4 :ecx)
-      (:stc))))
-
-(defun pci-directory (eax &optional (ebx 0))
-  "Calling with '$PCI' should find the PCI directory."
-  (unless *bios32-base*
-    (init-pci))
-  (let ((eax (etypecase eax
-	       ((unsigned-byte 32)
-		eax)
-	       (string
-		(loop for c across eax as i upfrom 0 by 8
-		    summing (ash (char-code c) i))))))
-    (pci-far-call (memref-int *bios32-base* :offset 4)
-		  :eax eax :ebx ebx)))
+      (:locally (:movl :edi (:edi (:edi-offset values) 8)))
+      (:jnc 'cf=0)
+      (:locally (:pushl (:edi (:edi-offset t-symbol))))
+      (:locally (:popl (:edi (:edi-offset values) 8)))
+     cf=0
+      (:pushl :eax)
+      (:pushl :ebx)
+      (:pushl :edx)
+      (:locally (:movl 3 (:edi (:edi-offset num-values))))
+      (:call-local-pf box-u32-ecx)	; ECX
+      (:locally (:movl :eax (:edi (:edi-offset values) 0)))
+      (:popl :ecx)			; EDX
+      (:call-local-pf box-u32-ecx)
+      (:locally (:movl :eax (:edi (:edi-offset values) 4)))
+      (:popl :ecx)			; EBX
+      (:call-local-pf box-u32-ecx)
+      (:locally (:movl :eax (:edi (:edi-offset scratch1))))
+      (:popl :ecx)			; EAX
+      (:call-local-pf box-u32-ecx)
+      (:locally (:movl (:edi (:edi-offset scratch1)) :ebx))
+      (:movl 5 :ecx)
+      (:movl (:ebp -4) :esi)
+      (:stc)
+      ;; Exit atomical-mode
+      (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
+      (:leal (:esp 16) :esp))))




From ffjeld at common-lisp.net  Thu Nov 25 15:06:04 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Nov 2004 16:06:04 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp 
Message-ID: <E1CXLC8-0001YV-00@common-lisp.net>

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

Modified Files:
	ip4.lisp 
Log Message:
*** empty log message ***
Date: Thu Nov 25 16:06:03 2004
Author: ffjeld

Index: movitz/losp/lib/net/ip4.lisp
diff -u movitz/losp/lib/net/ip4.lisp:1.14 movitz/losp/lib/net/ip4.lisp:1.15
--- movitz/losp/lib/net/ip4.lisp:1.14	Wed Nov 24 18:28:01 2004
+++ movitz/losp/lib/net/ip4.lisp	Thu Nov 25 16:06:02 2004
@@ -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.14 2004/11/24 17:28:01 ffjeld Exp $
+;;;; $Id: ip4.lisp,v 1.15 2004/11/25 15:06:02 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -492,8 +492,9 @@
   (unless *ip4-router*
     (setf *ip4-router* (ip4-address :129.242.16.1)))
   ;; This is to announce our presence on the LAN..
-  (polling-arp *ip4-router* (lambda ()
-			      (eql #\esc (muerte.x86-pc.keyboard:poll-char))))
+  (assert (polling-arp *ip4-router* (lambda ()
+				      (eql #\esc (muerte.x86-pc.keyboard:poll-char))))
+      () "Unable to resolve ~/ip4:pprint-ip4/ by ARP." *ip4-router*)
   (values *ip4-nic* *ip4-ip*))
 
 (defun ip4-test ()




From ffjeld at common-lisp.net  Thu Nov 25 16:45:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Nov 2004 17:45:20 +0100
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1CXMkC-0002tl-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Added -non-header variation of the malloc primitive-functions.

Date: Thu Nov 25 17:45:14 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.81 movitz/image.lisp:1.82
--- movitz/image.lisp:1.81	Tue Nov 23 17:10:38 2004
+++ movitz/image.lisp	Thu Nov 25 17:45:13 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.81 2004/11/23 16:10:38 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.82 2004/11/25 16:45:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -308,6 +308,16 @@
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-tag :primitive-function)
    (cons-commit-non-pointer
+    :binary-type code-vector-word
+    :map-binary-write 'movitz-intern-code-vector
+    :map-binary-read-delayed 'movitz-word-code-vector
+    :binary-tag :primitive-function)
+   (get-cons-pointer-non-header
+    :binary-type code-vector-word
+    :map-binary-write 'movitz-intern-code-vector
+    :map-binary-read-delayed 'movitz-word-code-vector
+    :binary-tag :primitive-function)
+   (cons-commit-non-header
     :binary-type code-vector-word
     :map-binary-write 'movitz-intern-code-vector
     :map-binary-read-delayed 'movitz-word-code-vector




From ffjeld at common-lisp.net  Thu Nov 25 16:45:42 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Nov 2004 17:45:42 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1CXMkY-0002uo-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Added -non-header variation of the malloc primitive-functions.

Date: Thu Nov 25 17:45:37 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.50 movitz/losp/muerte/basic-macros.lisp:1.51
--- movitz/losp/muerte/basic-macros.lisp:1.50	Tue Nov 23 17:02:34 2004
+++ movitz/losp/muerte/basic-macros.lisp	Thu Nov 25 17:45:33 2004
@@ -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.50 2004/11/23 16:02:34 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.51 2004/11/25 16:45:33 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1109,7 +1109,34 @@
 	 , at code
 	 ,@(when fixed-size-p
 	     `((:load-lexical (:lexical-binding ,size-var) :ecx)))
-	 (:call-local-pf cons-commit)
+	 (:call-local-pf cons-commit-non-pointer)
+	 (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
+	 (:leal (:esp 16) :esp)))))
+
+(defmacro with-non-header-allocation-assembly
+    ((size-form &key object-register size-register fixed-size-p labels) &body code)
+  (assert (eq object-register :eax))
+  (assert (or fixed-size-p (eq size-register :ecx)))
+  (let ((size-var (gensym "malloc-size-")))
+    `(let ((,size-var ,size-form))
+       (with-inline-assembly (:returns :eax :labels (retry-alloc retry-jumper , at labels))
+	 (:declare-label-set retry-jumper (retry-alloc))
+	 ;; Set up atomically continuation.
+	 (:locally (:pushl (:edi (:edi-offset :dynamic-env))))
+	 (:pushl 'retry-jumper)
+	 ;; ..this allows us to detect recursive atomicallies.
+	 (:locally (:pushl (:edi (:edi-offset :atomically-continuation))))
+	 (:pushl :ebp)
+	retry-alloc
+	 (:movl (:esp) :ebp)
+	 (:load-lexical (:lexical-binding ,size-var) :eax)
+	 (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation))))
+	 ;; Now inside atomically section.
+	 (:call-local-pf get-cons-pointer-non-header)
+	 , at code
+	 ,@(when fixed-size-p
+	     `((:load-lexical (:lexical-binding ,size-var) :ecx)))
+	 (:call-local-pf cons-commit-non-header)
 	 (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
 	 (:leal (:esp 16) :esp)))))
 




From ffjeld at common-lisp.net  Thu Nov 25 16:45:55 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Nov 2004 17:45:55 +0100
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1CXMkl-0002vN-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Added -non-header variation of the malloc primitive-functions.

Date: Thu Nov 25 17:45:48 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.55 movitz/losp/muerte/primitive-functions.lisp:1.56
--- movitz/losp/muerte/primitive-functions.lisp:1.55	Tue Nov 23 17:08:58 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Thu Nov 25 17:45:47 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.55 2004/11/23 16:08:58 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.56 2004/11/25 16:45:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -314,6 +314,18 @@
   (with-inline-assembly (:returns :multiple-values)
     (:locally (:jmp (:edi (:edi-offset cons-commit))))))
 
+(define-primitive-function get-cons-pointer-non-header ()
+  "Return in EAX the next object location with space for EAX non-pointer words, with tag 6.
+Preserve ECX."
+  (with-inline-assembly (:returns :multiple-values)
+    (:locally (:jmp (:edi (:edi-offset get-cons-pointer))))))
+
+(define-primitive-function cons-commit-non-header ()
+  "Return in EAX the next object location with space for EAX non-pointer words, with tag 6.
+Preserve ECX."
+  (with-inline-assembly (:returns :multiple-values)
+    (:locally (:jmp (:edi (:edi-offset cons-commit))))))
+
 (defun malloc-initialize (buffer-start buffer-size)
   "BUFFER-START is the location from which to allocate.
 BUFFER-SIZE is the number of words in the buffer."
@@ -377,7 +389,7 @@
     ;; Be defensive: Check that EAX is LISTP.
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
-    (:jnz '(:sub-program () (:int 50)))
+    (:jnz '(:sub-program () (:int 63)))
     (:cmpl :ebp :eax)			; is cons above stack-frame?
     (:jge 'return-ok)
     (:cmpl :esp :eax)			; is cons below stack-frame?




From ffjeld at common-lisp.net  Thu Nov 25 16:46:06 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Nov 2004 17:46:06 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp 
Message-ID: <E1CXMkw-0002wI-00@common-lisp.net>

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

Modified Files:
	symbols.lisp 
Log Message:
Added -non-header variation of the malloc primitive-functions.

Date: Thu Nov 25 17:46:02 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.26 movitz/losp/muerte/symbols.lisp:1.27
--- movitz/losp/muerte/symbols.lisp:1.26	Tue Nov 23 17:09:34 2004
+++ movitz/losp/muerte/symbols.lisp	Thu Nov 25 17:46:01 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 23:55:41 2001
 ;;;;                
-;;;; $Id: symbols.lisp,v 1.26 2004/11/23 16:09:34 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.27 2004/11/25 16:46:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -148,8 +148,8 @@
   (let ((sxhash (sxhash name)))
     (macrolet
 	((do-it ()
-	   `(with-non-pointer-allocation-assembly (6 :fixed-size-p t
-						     :object-register :eax)
+	   `(with-non-header-allocation-assembly
+		(6 :fixed-size-p t :object-register :eax)
 	      (:addl ,(- (movitz:tag :symbol) (movitz:tag :other)) :eax)
 	      (:load-lexical (:lexical-binding package) :ebx)
 	      (:movl :ebx (:eax (:offset movitz-symbol package)))
@@ -182,8 +182,8 @@
   (if (or (eq nil symbol)
 	  (not copy-properties))
       (%create-symbol (symbol-name symbol))
-    (with-allocation-assembly (6 :object-register :eax
-				 :fixed-size-p t)
+    (with-non-header-allocation-assembly
+	(6 :object-register :eax :fixed-size-p t)
       (:addl 1 :eax)
       (:load-lexical (:lexical-binding symbol) :ebx)
       ;; 0
@@ -204,7 +204,6 @@
       ;; 5
       (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 20) :ecx)
       (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 20)))))
-
 
 (defun symbol-flags (symbol)
   (etypecase symbol




From ffjeld at common-lisp.net  Thu Nov 25 18:05:19 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Nov 2004 19:05:19 +0100
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1CXNzb-00049y-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Renamed the malloc primitive functions.

Date: Thu Nov 25 19:05:17 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.82 movitz/image.lisp:1.83
--- movitz/image.lisp:1.82	Thu Nov 25 17:45:13 2004
+++ movitz/image.lisp	Thu Nov 25 19:05:17 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.82 2004/11/25 16:45:13 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.83 2004/11/25 18:05:17 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -290,7 +290,7 @@
     :initform 0)
    (values
     :binary-type #.(* 4 +movitz-multiple-values-limit+))
-   (get-cons-pointer
+   (cons-pointer
     :binary-type code-vector-word
     :initform nil
     :map-binary-write 'movitz-intern-code-vector
@@ -302,7 +302,7 @@
     :map-binary-write 'movitz-intern-code-vector
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-tag :primitive-function)
-   (get-cons-pointer-non-pointer
+   (cons-non-pointer
     :binary-type code-vector-word
     :map-binary-write 'movitz-intern-code-vector
     :map-binary-read-delayed 'movitz-word-code-vector
@@ -312,7 +312,7 @@
     :map-binary-write 'movitz-intern-code-vector
     :map-binary-read-delayed 'movitz-word-code-vector
     :binary-tag :primitive-function)
-   (get-cons-pointer-non-header
+   (cons-non-header
     :binary-type code-vector-word
     :map-binary-write 'movitz-intern-code-vector
     :map-binary-read-delayed 'movitz-word-code-vector




From ffjeld at common-lisp.net  Thu Nov 25 18:05:26 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Nov 2004 19:05:26 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1CXNzi-0004AG-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Renamed the malloc primitive functions.

Date: Thu Nov 25 19:05:23 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.42 movitz/losp/los0-gc.lisp:1.43
--- movitz/losp/los0-gc.lisp:1.42	Mon Oct 11 15:51:52 2004
+++ movitz/losp/los0-gc.lisp	Thu Nov 25 19:05:23 2004
@@ -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.42 2004/10/11 13:51:52 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.43 2004/11/25 18:05:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -132,7 +132,7 @@
 	(do-it)))))
   
 
-(define-primitive-function los0-get-cons-pointer ()
+(define-primitive-function los0-cons-pointer ()
   "Return in EAX the next object location with space for EAX words, with tag 6.
 Preserve ECX."
   (macrolet
@@ -250,7 +250,7 @@
 		      (setf (%run-time-context-slot ',slot context) code-vector)))))
       (install-primitive los0-fast-cons muerte::fast-cons)
       (install-primitive los0-box-u32-ecx muerte::box-u32-ecx)
-      (install-primitive los0-get-cons-pointer muerte::get-cons-pointer)
+      (install-primitive los0-cons-pointer muerte::cons-pointer)
       (install-primitive los0-cons-commit muerte::cons-commit))
     (if (eq context (current-run-time-context))
 	(setf (%run-time-context-slot 'muerte::nursery-space)




From ffjeld at common-lisp.net  Thu Nov 25 18:05:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Nov 2004 19:05:38 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1CXNzu-0004Af-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Renamed the malloc primitive functions.

Date: Thu Nov 25 19:05:33 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.51 movitz/losp/muerte/basic-macros.lisp:1.52
--- movitz/losp/muerte/basic-macros.lisp:1.51	Thu Nov 25 17:45:33 2004
+++ movitz/losp/muerte/basic-macros.lisp	Thu Nov 25 19:05:32 2004
@@ -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.51 2004/11/25 16:45:33 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.52 2004/11/25 18:05:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1078,7 +1078,7 @@
 	 (:load-lexical (:lexical-binding ,size-var) :eax)
 	 (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation))))
 	 ;; Now inside atomically section.
-	 (:call-local-pf get-cons-pointer)
+	 (:call-local-pf cons-pointer)
 	 , at code
 	 ,@(when fixed-size-p
 	     `((:load-lexical (:lexical-binding ,size-var) :ecx)))
@@ -1105,7 +1105,7 @@
 	 (:load-lexical (:lexical-binding ,size-var) :eax)
 	 (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation))))
 	 ;; Now inside atomically section.
-	 (:call-local-pf get-cons-pointer-non-pointer)
+	 (:call-local-pf cons-non-pointer)
 	 , at code
 	 ,@(when fixed-size-p
 	     `((:load-lexical (:lexical-binding ,size-var) :ecx)))
@@ -1132,7 +1132,7 @@
 	 (:load-lexical (:lexical-binding ,size-var) :eax)
 	 (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation))))
 	 ;; Now inside atomically section.
-	 (:call-local-pf get-cons-pointer-non-header)
+	 (:call-local-pf cons-non-header)
 	 , at code
 	 ,@(when fixed-size-p
 	     `((:load-lexical (:lexical-binding ,size-var) :ecx)))




From ffjeld at common-lisp.net  Thu Nov 25 18:05:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Nov 2004 19:05:43 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/bignums.lisp 
Message-ID: <E1CXNzy-0004Aw-00@common-lisp.net>

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

Modified Files:
	bignums.lisp 
Log Message:
Renamed the malloc primitive functions.

Date: Thu Nov 25 19:05:40 2004
Author: ffjeld

Index: movitz/losp/muerte/bignums.lisp
diff -u movitz/losp/muerte/bignums.lisp:1.12 movitz/losp/muerte/bignums.lisp:1.13
--- movitz/losp/muerte/bignums.lisp:1.12	Mon Oct 11 15:52:21 2004
+++ movitz/losp/muerte/bignums.lisp	Thu Nov 25 19:05:40 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 19:42:57 2004
 ;;;;                
-;;;; $Id: bignums.lisp,v 1.12 2004/10/11 13:52:21 ffjeld Exp $
+;;;; $Id: bignums.lisp,v 1.13 2004/11/25 18:05:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -129,7 +129,7 @@
 	    ;; Now inside atomically section.
 	    (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+))
 		   :eax)		; Number of words
-	    (:call-local-pf get-cons-pointer)
+	    (:call-local-pf cons-non-pointer)
 	    (:load-lexical (:lexical-binding bignum) :ebx) ; bignum
 	    (:movzxw (:ebx (:offset movitz-bignum length)) :ecx)
 	    (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
@@ -158,7 +158,7 @@
 	    (:addl #x40000 (:eax ,movitz:+other-type-offset+))
 	    (:addl ,movitz:+movitz-fixnum-factor+ :ecx)
 	   no-expansion
-	    (:call-local-pf cons-commit)
+	    (:call-local-pf cons-commit-non-pointer)
 	    ;; Exit atomically block.
 	    (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
 	    (:leal (:esp 16) :esp)




From ffjeld at common-lisp.net  Thu Nov 25 18:05:56 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Nov 2004 19:05:56 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1CXO0C-0004Bb-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Renamed the malloc primitive functions.

Date: Thu Nov 25 19:05:49 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.103 movitz/losp/muerte/integers.lisp:1.104
--- movitz/losp/muerte/integers.lisp:1.103	Wed Nov 24 11:08:41 2004
+++ movitz/losp/muerte/integers.lisp	Thu Nov 25 19:05:48 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.103 2004/11/24 10:08:41 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.104 2004/11/25 18:05:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -526,7 +526,7 @@
 
 		   (:leal ((:ecx 1) ,(* 1 movitz:+movitz-fixnum-factor+))
 			  :eax)		; Number of words
-		   (:call-local-pf get-cons-pointer)
+		   (:call-local-pf cons-pointer)
 		   (:load-lexical (:lexical-binding y) :ebx) ; bignum
 		   (:movzxw (:ebx (:offset movitz-bignum length)) :ecx)
 		   (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
@@ -557,7 +557,7 @@
 		   (:subl #x40000 (:eax ,movitz:+other-type-offset+))
 		   (:subl ,movitz:+movitz-fixnum-factor+ :ecx)
 		  no-expansion
-		   (:call-local-pf cons-commit)
+		   (:call-local-pf cons-commit-non-pointer)
 		   (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
 		   (:leal (:esp 16) :esp)
 		   
@@ -607,7 +607,7 @@
 		     (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation))))
 		     ;; Now inside atomically section.
 		     
-		     (:call-local-pf get-cons-pointer)
+		     (:call-local-pf cons-non-pointer)
 		     (:load-lexical (:lexical-binding y) :ebx) ; bignum
 		     (:movzxw (:ebx (:offset movitz-bignum length)) :ecx)
 		     (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+)
@@ -658,7 +658,7 @@
 		     (:addl #x40000 (:eax ,movitz:+other-type-offset+))
 		     (:addl ,movitz:+movitz-fixnum-factor+ :ecx)
 		    no-expansion
-		     (:call-local-pf cons-commit)
+		     (:call-local-pf cons-commit-non-pointer)
 		     (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
 		     (:leal (:esp 16) :esp)
 		    pfix-pbig-done)
@@ -1080,7 +1080,7 @@
 		     (:leal (:eax :ebx ,(* 4 (+ 31 32))) :eax)
 		     (:andl ,(logxor #xffffffff (* 31 4)) :eax)
 		     (:shrl 5 :eax)
-		     (:call-local-pf get-cons-pointer) ; New bignum into EAX
+		     (:call-local-pf cons-non-pointer) ; New bignum into EAX
 
 		     (:load-lexical (:lexical-binding y) :ebx) ; bignum
 		     (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
@@ -1121,7 +1121,7 @@
 		     (:movl :ebx :eax)
 		     (:movl :edi :edx)
 		     (:cld)		; EAX, EDX, and ESI are GC roots again.
-		     (:call-local-pf cons-commit)
+		     (:call-local-pf cons-commit-non-pointer)
 		     (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
 		     (:leal (:esp 16) :esp)
 		     (:compile-form (:result-mode :ebx) x)
@@ -1255,7 +1255,7 @@
 		     (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation))))
 		     ;; Now inside atomically section.
 		     
-		     (:call-local-pf get-cons-pointer) ; New bignum into EAX
+		     (:call-local-pf cons-non-pointer) ; New bignum into EAX
 
 		     (:store-lexical (:lexical-binding r) :eax :type bignum) ; XXX breaks GC invariant!
 		     (:compile-form (:result-mode :ebx) number)
@@ -1307,7 +1307,7 @@
 		     (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
 		     (:jmp 'fixnum-result) ; don't commit the bignum
 		    no-more-shrinkage
-		     (:call-local-pf cons-commit)
+		     (:call-local-pf cons-commit-non-pointer)
 		    fixnum-result
 		     ;; Exit atomically block.
 		     (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
@@ -1772,7 +1772,7 @@
 	       (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation))))
 	       ;; Now inside atomically section.
 	       
-	       (:call-local-pf get-cons-pointer)
+	       (:call-local-pf cons-non-pointer)
 	       (:shll 16 :ecx)
 	       (:orl ,(movitz:tag :bignum 0) :ecx)
 	       (:movl :ecx (:eax ,movitz:+other-type-offset+))
@@ -1780,7 +1780,7 @@
 	       (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)
 		       ,(* 1 movitz:+movitz-fixnum-factor+)) ; add 1 for header.
 		      :ecx)
-	       (:call-local-pf cons-commit)
+	       (:call-local-pf cons-commit-non-pointer)
 	       (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
 	       (:leal (:esp 16) :esp)
 	       ;; Have fresh bignum in EAX, now fill it with ones.
@@ -1982,7 +1982,7 @@
 		     ;; Now add 1 for index->size, 1 for header, and 1 for tmp storage before shift.
 		     (:addl ,(* 3 movitz:+movitz-fixnum-factor+) :eax)
 		     (:pushl :eax)
-		     (:call-local-pf get-cons-pointer)
+		     (:call-local-pf cons-non-pointer)
 		     ;; (:store-lexical (:lexical-binding r) :eax :type t)
 		     (:popl :ecx)
 		     (:subl ,(* 2 movitz:+movitz-fixnum-factor+) :ecx) ; for tmp storage and header.
@@ -2088,7 +2088,7 @@
 		     (:movl :ebx :eax)
 		     (:leal (:ecx ,movitz:+movitz-fixnum-factor+)
 			    :ecx)
-		     (:call-local-pf cons-commit)
+		     (:call-local-pf cons-commit-non-pointer)
 		    return-fixnum
 		     (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
 		     (:leal (:esp 16) :esp)




From ffjeld at common-lisp.net  Thu Nov 25 18:06:23 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Nov 2004 19:06:23 +0100
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1CXO0d-0004Bw-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Renamed the malloc primitive functions.

Date: Thu Nov 25 19:06:04 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.56 movitz/losp/muerte/primitive-functions.lisp:1.57
--- movitz/losp/muerte/primitive-functions.lisp:1.56	Thu Nov 25 17:45:47 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Thu Nov 25 19:06:02 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.56 2004/11/25 16:45:47 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.57 2004/11/25 18:06:02 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -262,7 +262,7 @@
 
 ;;;;;;;;;;;;;; Heap allocation protocol
 
-(define-primitive-function get-cons-pointer ()
+(define-primitive-function cons-pointer ()
   "Return in EAX the next object location with space for EAX words, with tag 6.
 Preserve ECX."
   (macrolet
@@ -296,17 +296,17 @@
 Preserve EAX and EBX."
   (macrolet
       ((do-it ()
-	 ;; Since get-cons-pointer is implemented as an (already committed)
+	 ;; Since cons-pointer is implemented as an (already committed)
 	 ;; malloc, this is a no-op.
 	 `(with-inline-assembly (:returns :multiple-values)
 	    (:ret))))
     (do-it)))
 
-(define-primitive-function get-cons-pointer-non-pointer ()
+(define-primitive-function cons-non-pointer ()
   "Return in EAX the next object location with space for EAX non-pointer words, with tag 6.
 Preserve ECX."
   (with-inline-assembly (:returns :multiple-values)
-    (:locally (:jmp (:edi (:edi-offset get-cons-pointer))))))
+    (:locally (:jmp (:edi (:edi-offset cons-pointer))))))
 
 (define-primitive-function cons-commit-non-pointer ()
   "Return in EAX the next object location with space for EAX non-pointer words, with tag 6.
@@ -314,11 +314,11 @@
   (with-inline-assembly (:returns :multiple-values)
     (:locally (:jmp (:edi (:edi-offset cons-commit))))))
 
-(define-primitive-function get-cons-pointer-non-header ()
+(define-primitive-function cons-non-header ()
   "Return in EAX the next object location with space for EAX non-pointer words, with tag 6.
 Preserve ECX."
   (with-inline-assembly (:returns :multiple-values)
-    (:locally (:jmp (:edi (:edi-offset get-cons-pointer))))))
+    (:locally (:jmp (:edi (:edi-offset cons-pointer))))))
 
 (define-primitive-function cons-commit-non-header ()
   "Return in EAX the next object location with space for EAX non-pointer words, with tag 6.




From ffjeld at common-lisp.net  Fri Nov 26 00:02:40 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Nov 2004 01:02:40 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp 
Message-ID: <E1CXTZQ-0001Mu-00@common-lisp.net>

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

Modified Files:
	pci.lisp 
Log Message:
Now, scan-pci-bus prints some info about each device it can find on
that bus.

Date: Fri Nov 26 01:02:39 2004
Author: ffjeld

Index: movitz/losp/x86-pc/pci.lisp
diff -u movitz/losp/x86-pc/pci.lisp:1.6 movitz/losp/x86-pc/pci.lisp:1.7
--- movitz/losp/x86-pc/pci.lisp:1.6	Thu Nov 25 03:11:34 2004
+++ movitz/losp/x86-pc/pci.lisp	Fri Nov 26 01:02:39 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Dec 14 22:33:42 2003
 ;;;;                
-;;;; $Id: pci.lisp,v 1.6 2004/11/25 02:11:34 ffjeld Exp $
+;;;; $Id: pci.lisp,v 1.7 2004/11/26 00:02:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -53,64 +53,9 @@
 (defvar *bios32-base* nil)
 (defvar *pcibios-entry* nil)
 
-(defun find-bios32-pci ()
-  (let ((bios32-base (find-bios32-base)))
-    (assert bios32-base "No bios32 found.")
-    (multiple-value-bind (eax ebx ecx edx)
-	(pci-far-call (memref-int bios32-base :offset 4)
-		      :eax (pci-word "$PCI"))
-      (declare (ignore ecx))
-      (ecase (ldb (byte 8 0) eax)
-	(#x80 (error "The PCI bios32 service isn't present."))
-	(#x81 (error "The PCI bios32 service doesn't exist."))
-	(#x00 (+ ebx edx))))))
-
-(defun pci-bios-present ()
-  (multiple-value-bind (eax ebx ecx edx cf)
-      (pci-far-call (find-bios32-pci) :eax #xb101)
-    (values (pci-string edx)
-	    (ldb (byte 8 8) eax)	; AH: Present status
-	    (ldb (byte 8 0) eax)	; AL: Hardware mechanism
-	    (ldb (byte 8 8) ebx)	; BH: Interface Level Major Version
-	    (ldb (byte 8 0) ebx)	; BL: Interface Level Minor Version
-	    (ldb (byte 8 0) ecx))))	; CL: Number of last PCI bus in the system
-		
-(defun find-pci-device (vendor device &optional (index 0))
-  (multiple-value-bind (eax ebx ecx edx cf)
-      (pci-far-call (find-bios32-pci)
-		    :eax #xb102
-		    :ecx device
-		    :edx vendor
-		    :esi index)
-    (unless cf
-      (values (ldb (byte 8 8) ebx)	; Bus
-	      (ldb (byte 5 3) ebx)	; Device
-	      (ldb (byte 3 0) ebx)	; Function
-	      (ecase (ldb (byte 8 8) eax)
-		(#x00 :successful)
-		(#x86 :device-not-found)
-		(#x83 :bad-vendor-id))))))
-
-(defun find-pci-class-code (class-code &optional (index 0))
-  (multiple-value-bind (eax ebx ecx edx cf)
-      (pci-far-call (find-bios32-pci)
-		    :eax #xb103
-		    :ecx class-code
-		    :esi index)
-    (declare (ignore ecx edx))
-    (unless cf
-      (values (ldb (byte 8 8) ebx)	; Bus
-	      (ldb (byte 5 3) ebx)	; Device
-	      (ldb (byte 3 0) ebx)	; Function
-	      (ecase (ldb (byte 8 8) eax)
-		(#x00 :successful)
-		(#x86 :device-not-found))))))
-
-
-(defun pci-far-call (address &key (cs 8) (eax 0) (ebx 0) (ecx 0) (edx 0) (esi 0))
+(defun pci-far-call (address &key (cs 8) (eax 0) (ebx 0) (ecx 0) (edx 0) (esi 0) (edi 0))
   "Make a 'far call' to cs:address with the provided values for eax and ebx.
-Returns the values of registers AL, EBX, ECX, and EDX, and status of CF.
- (NB: For now only the lower 30 bits of registers are actually returned.)
+Returns the values of registers EAX, EBX, ECX, and EDX, and status of CF.
 The stack discipline is broken during this call, so we disable interrupts
 in a somewhat feeble attempt to avoid trouble."
   (check-type address (unsigned-byte 32))
@@ -125,7 +70,7 @@
      restart
       (:movl (:esp) :ebp)
       (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation))))
-
+      (:pushl :edi)			; Save EDI so we can restore it later.
       (:load-lexical (:lexical-binding cs) :untagged-fixnum-ecx)
       (:pushl :ecx)			; Code segment
       (:load-lexical (:lexical-binding address) :untagged-fixnum-ecx)
@@ -138,13 +83,17 @@
       (:pushl :ecx)			; push EDX
       (:load-lexical (:lexical-binding esi) :untagged-fixnum-ecx)
       (:pushl :ecx)			; push ESI
+      (:load-lexical (:lexical-binding edi) :untagged-fixnum-ecx)
+      (:pushl :ecx)			; push EDI
       (:load-lexical (:lexical-binding ecx) :untagged-fixnum-ecx)
+      (:popl :edi)
       (:popl :esi)
       (:popl :edx)
       (:popl :ebx)
       (:popl :eax)
       (:call-segment (:esp))
-      (:leal (:esp 8) :esp)
+      (:leal (:esp 8) :esp)		; Skip cs:address
+      (:popl :edi)			; First of all, restore EDI!
       (:locally (:movl :edi (:edi (:edi-offset values) 8)))
       (:jnc 'cf=0)
       (:locally (:pushl (:edi (:edi-offset t-symbol))))
@@ -171,3 +120,153 @@
       ;; Exit atomical-mode
       (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
       (:leal (:esp 16) :esp))))
+
+(defun find-bios32-pci ()
+  (let ((bios32-base (find-bios32-base)))
+    (assert bios32-base "No bios32 found.")
+    (multiple-value-bind (eax ebx ecx edx)
+	(pci-far-call (memref-int bios32-base :offset 4)
+		      :eax (pci-word "$PCI"))
+      (declare (ignore ecx))
+      (ecase (ldb (byte 8 0) eax)
+	(#x80 (error "The PCI bios32 service isn't present."))
+	(#x81 (error "The PCI bios32 service doesn't exist."))
+	(#x00 (+ ebx edx))))))
+
+(defun pci-bios-present ()
+  (multiple-value-bind (eax ebx ecx edx cf)
+      (pci-far-call (find-bios32-pci) :eax #xb101)
+    (values (pci-string edx)
+	    (ldb (byte 8 8) eax)	; AH: Present status
+	    (ldb (byte 8 0) eax)	; AL: Hardware mechanism
+	    (ldb (byte 8 8) ebx)	; BH: Interface Level Major Version
+	    (ldb (byte 8 0) ebx)	; BL: Interface Level Minor Version
+	    (ldb (byte 8 0) ecx))))	; CL: Number of last PCI bus in the system
+		
+(defun find-pci-device (vendor device &optional (index 0))
+  (multiple-value-bind (eax ebx ecx edx cf)
+      (pci-far-call (find-bios32-pci)
+		    :eax #xb102
+		    :ecx device
+		    :edx vendor
+		    :esi index)
+    (unless cf
+      (values (ldb (byte 8 8) ebx)	; Bus
+	      (ldb (byte 5 3) ebx)	; Device
+	      (ldb (byte 3 0) ebx)	; Function
+	      (ecase (ldb (byte 8 8) eax)
+		(#x00 :successful)
+		(#x86 :device-not-found)
+		(#x83 :bad-vendor-id))))))
+
+(defun find-pci-class-code (class-code &optional (index 0))
+  (multiple-value-bind (eax ebx ecx edx cf)
+      (pci-far-call (find-bios32-pci)
+		    :eax #xb103
+		    :ecx class-code
+		    :esi index)
+    (declare (ignore ecx edx))
+    (unless cf
+      (values (ldb (byte 8 8) ebx)	; Bus
+	      (ldb (byte 5 3) ebx)	; Device
+	      (ldb (byte 3 0) ebx)	; Function
+	      (pci-return-code eax)))))
+
+(defun pci-return-code (code)
+  (ecase (ldb (byte 8 8) code)
+    (#x00 :successful)
+    (#x81 :function-not-supported)
+    (#x83 :bad-vendor-id)
+    (#x86 :device-not-found)
+    (#x87 :bad-register-number)))
+
+(defun pci-location (bus device function)
+  "Compute 16-bit location from bus, device, and function numbers."
+  (dpb bus (byte 8 8) (dpb device (byte 5 3) (ldb (byte 3 0) function))))
+
+(defun pci-class (code)
+  "Return the symbolic class-code sub-class code, and interface, if known."
+  (let* ((decode-table
+	  #((:pre-pci2.0-device
+	     :non-vga :vga-compatible)
+	    (:mass-storage
+	     :scsi :ide :floppy :ipi :raid)
+	    (:network
+	     :ethernet :token-ring :fddi :atm)
+	    (:display
+	     (:non-xga :vga :8514) :xga)
+	    (:multimedia
+	     :video :audio)
+	    (:memory
+	     :ram :flash)
+	    (:bridge
+	     :host/pci :pci/isa :pci/eisa :pci/micro-channel
+	     :pci/pci :pci/pcmcia :pci/nubus :pci/cardbus)
+	    (:simple-communication
+	     (:serial-port :xt :16450 :16550)
+	     (:parallel-port :generic :bi-directional :ecp-1.x))
+	    (:base-system-peripheral
+	     (:pic :generic :isa :eisa)
+	     (:dma :generic :isa :eisa)
+	     (:timer :generic :isa :eisa)
+	     (:rtc :generic :isa))
+	    (:input
+	     :keyboard :digitizer :mouse)
+	    (:docking-station
+	     :generic)
+	    (:processor
+	     :386 :486 :pentium nil nil nil nil nil nil nil nil nil nil nil nil nil
+	     :alpha nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	     :powerpc nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	     :co-processor)
+	    (:serial-bus
+	     :firewire :access.bus :ssa :usb :fibre-channel)))
+	 (class-code (ldb (byte 8 16) code))
+	 (class-table (and (< class-code (length decode-table))
+			   (svref decode-table class-code)))
+	 (sub-class-table (nth (ldb (byte 8 8) code) (cdr class-table)))
+	 (sub-class sub-class-table)
+	 (sub-class-if (when (consp sub-class)
+			 (setf sub-class (pop sub-class-table))
+			 (nth (ldb (byte 8 0) code) sub-class-table))))
+    (values (car class-table) sub-class sub-class-if)))
+
+(defun pci-bios-read-configuration-word (bus device function register)
+  (multiple-value-bind (eax ebx ecx edx cf)
+      (pci-far-call (find-bios32-pci)
+		    :eax #xb109
+		    :ebx (pci-location bus device function)
+		    :edi register)
+    (declare (ignore ebx edx))
+    (unless cf
+      (values (ldb (byte 16 0) ecx) (pci-return-code eax)))))
+
+(defun pci-bios-read-configuration-dword (bus device function register)
+  (multiple-value-bind (eax ebx ecx edx cf)
+      (pci-far-call (find-bios32-pci)
+		    :eax #xb10a
+		    :ebx (pci-location bus device function)
+		    :edi register)
+    (declare (ignore ebx edx))
+    (unless cf
+      (values ecx (pci-return-code eax)))))
+
+(defun scan-pci-bus (bus)
+  (loop for device from 0 to 31
+      do (multiple-value-bind (vendor-id return-code)
+	     (pci-bios-read-configuration-word bus device 0 0)
+	   (when (and vendor-id
+		      (not (= vendor-id #xffff))
+		      (eq :successful return-code))
+	     (let ((device-id (pci-bios-read-configuration-word bus device 0 2))
+		   (status (pci-bios-read-configuration-word bus device 0 6))
+		   (class-rev (pci-bios-read-configuration-dword bus device 0 8)))
+	       (format *query-io*
+		       "~&~D: Vendor #x~X, ID #x~X, Class #x~X, Rev. ~D, Status #x~X.~%"
+		       device vendor-id device-id
+		       (ldb (byte 24 8) class-rev)
+		       (ldb (byte 8 0) class-rev)
+		       status)
+	       (format *query-io* "    Class:~{ ~@[~A~]~}"
+		       (multiple-value-list (pci-class (ldb (byte 24 8) class-rev))))))))
+  (values))
\ No newline at end of file




From ffjeld at common-lisp.net  Fri Nov 26 14:59:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Nov 2004 15:59:16 +0100
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1CXhZ6-0005SS-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Renamed the scavenging operators to map-header-vals and
map-stack-vector. Added map-lisp-vals.

Date: Fri Nov 26 15:59:15 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.42 movitz/packages.lisp:1.43
--- movitz/packages.lisp:1.42	Wed Nov 24 17:22:43 2004
+++ movitz/packages.lisp	Fri Nov 26 15:59:14 2004
@@ -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.42 2004/11/24 16:22:43 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.43 2004/11/26 14:59:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1140,8 +1140,9 @@
 	   #:package-object-internal-symbols
 	   #:package-object-external-symbols
 
-	   #:map-heap-words
-	   #:map-stack-words
+	   #:map-lisp-vals
+	   #:map-header-vals
+	   #:map-stack-vector
 
 	   #:%memory-map%
 	   #:%memory-map-roots%




From ffjeld at common-lisp.net  Fri Nov 26 14:59:28 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Nov 2004 15:59:28 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1CXhZI-0005Sr-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Renamed the scavenging operators to map-header-vals and
map-stack-vector. Added map-lisp-vals.

Date: Fri Nov 26 15:59:19 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.43 movitz/losp/los0-gc.lisp:1.44
--- movitz/losp/los0-gc.lisp:1.43	Thu Nov 25 19:05:23 2004
+++ movitz/losp/los0-gc.lisp	Fri Nov 26 15:59:18 2004
@@ -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.43 2004/11/25 18:05:23 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.44 2004/11/26 14:59:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -304,8 +304,8 @@
 	     (if (object-in-space-p oldspace x)
 		 nil
 	       x)))
-      (map-heap-words #'zap-oldspace 0 (malloc-end))
-      (map-stack-words #'zap-oldspace nil (current-stack-frame))
+      (map-header-vals #'zap-oldspace 0 (malloc-end))
+      (map-stack-vector #'zap-oldspace nil (current-stack-frame))
       (initialize-space oldspace)
       (values))))
 
@@ -354,16 +354,16 @@
 			   forward-x))))))))
       ;; Scavenge roots
       (dolist (range muerte::%memory-map-roots%)
-	(map-heap-words evacuator (car range) (cdr range)))
-      (map-stack-words evacuator nil (current-stack-frame))
+	(map-header-vals evacuator (car range) (cdr range)))
+      (map-stack-vector evacuator nil (current-stack-frame))
       ;; Scan newspace, Cheney style.
       (loop with newspace-location = (+ 2 (object-location newspace))
 	  with scan-pointer = 2
 	  as fresh-pointer = (space-fresh-pointer newspace)
 	  while (< scan-pointer fresh-pointer)
-	  do (map-heap-words evacuator
-			     (+ newspace-location scan-pointer)
-			     (+ newspace-location (space-fresh-pointer newspace)))
+	  do (map-header-vals evacuator
+			      (+ newspace-location scan-pointer)
+			      (+ newspace-location (space-fresh-pointer newspace)))
 	     (setf scan-pointer fresh-pointer))
 
       ;; Consistency check..
@@ -394,13 +394,13 @@
 new object: ~Z: ~S
 oldspace: ~Z, newspace: ~Z, i: ~D"
 			     old old new new oldspace newspace i))))))
-	    (map-heap-words (lambda (x y)
-			      (declare (ignore y))
-			      (when (location-in-object-p (space-other (%run-time-context-slot 'nursery-space))
-							  (object-location x))
-				(break "Seeing old object in values-vector: ~Z" x))
-			      x)
-			    #x38 #xb8)
+	    (map-header-vals (lambda (x y)
+			       (declare (ignore y))
+			       (when (location-in-object-p (space-other (%run-time-context-slot 'nursery-space))
+							   (object-location x))
+				 (break "Seeing old object in values-vector: ~Z" x))
+			       x)
+			     #x38 #xb8)
 	    (let* ((stack (%run-time-context-slot 'muerte::nursery-space))
 		   (stack-start (- (length stack) (muerte::current-control-stack-depth))))
 	      (do ((i 0 (+ i 3)))
@@ -442,14 +442,14 @@
       (handler-bind
 	  ((serious-condition (lambda (c)
 				(when (and continuep
-					   (find-restart 'muerte::continue-map-heap-words))
+					   (find-restart 'muerte::continue-map-header-vals))
 				  (warn "Automatic continue from scanning error: ~A" c)
-				  (invoke-restart 'muerte::continue-map-heap-words)))))
+				  (invoke-restart 'muerte::continue-map-header-vals)))))
 	(dolist (range muerte::%memory-map-roots%)
-	  (map-heap-words #'searcher (car range) (cdr range)))
+	  (map-header-vals #'searcher (car range) (cdr range)))
 	(let ((nursery (%run-time-context-slot 'muerte::nursery-space)))
-	  (map-heap-words #'searcher
-			  (+ 4 (object-location nursery))
-			  (+ 4 (object-location nursery) (space-fresh-pointer nursery))))
-	(map-stack-words #'searcher nil (current-stack-frame))))
+	  (map-header-vals #'searcher
+			   (+ 4 (object-location nursery))
+			   (+ 4 (object-location nursery) (space-fresh-pointer nursery))))
+	(map-stack-vector #'searcher nil (current-stack-frame))))
     results))




From ffjeld at common-lisp.net  Fri Nov 26 14:59:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Nov 2004 15:59:38 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1CXhZS-0005T9-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Renamed the scavenging operators to map-header-vals and
map-stack-vector. Added map-lisp-vals.

Date: Fri Nov 26 15:59:36 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.35 movitz/losp/muerte/scavenge.lisp:1.36
--- movitz/losp/muerte/scavenge.lisp:1.35	Tue Nov 23 17:09:17 2004
+++ movitz/losp/muerte/scavenge.lisp	Fri Nov 26 15:59:31 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.35 2004/11/23 16:09:17 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.36 2004/11/26 14:59:31 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -29,9 +29,18 @@
 
 (defvar *scan*)				; debugging
 (defvar *scan-last*)			; debugging
-(defvar *map-heap-words-verbose* nil)
+(defvar *map-header-vals-verbose* nil)
 
-(defun map-heap-words (function start-location end-location)
+(defun map-lisp-vals (function start-location end-location)
+  (with-funcallable (do-map function)
+    (loop for location from start-location below end-location
+	as object = (memref location 0)
+	do (when (typep object 'pointer)
+	     (let ((new-object (do-map object)))
+	       (unless (eq object new-object)
+		 (setf (memref location 0) new-object)))))))
+
+(defun map-header-vals (function start-location end-location)
   "Map function over each potential pointer word between
 start-location and end-location."
   (macrolet ((scavenge-typep (x primary)
@@ -42,12 +51,12 @@
 				(byte 8 8)
 				(movitz:tag primary))))
 		 `(= ,code ,x))))
-    (do ((verbose *map-heap-words-verbose*)
+    (do ((verbose *map-header-vals-verbose*)
 	 (*scan-last* nil)		; Last scanned object, for debugging.
 	 (scan start-location (1+ scan)))
 	((>= scan end-location))
-      (with-simple-restart (continue-map-heap-words
-			    "Continue map-heap-words at location ~S." (1+ scan))
+      (with-simple-restart (continue-map-header-vals
+			    "Continue map-header-vals at location ~S." (1+ scan))
 	(let ((x (memref scan 0 :type :unsigned-byte16))
 	      (x2 (memref scan 1 :type :unsigned-byte16)))
 	  (when verbose
@@ -85,7 +94,7 @@
 		   (code-vector (funobj-code-vector funobj))
 		   (num-jumpers (funobj-num-jumpers funobj)))
 	      (check-type code-vector code-vector)
-	      (map-heap-words function (+ scan 5) (+ scan 7)) ; scan funobj's lambda-list and name
+	      (map-header-vals function (+ scan 5) (+ scan 7)) ; scan funobj's lambda-list and name
 	      (let ((new-code-vector (funcall function code-vector scan)))
 		(check-type new-code-vector code-vector)
 		(unless (eq code-vector new-code-vector)
@@ -148,142 +157,143 @@
 		(setf (memref scan 0) new)))))))))
   (values))
 
-(defun map-stack-words (function stack start-frame)
+(defun map-stack-vector (function stack start-frame &optional (map-region #'map-header-vals))
   "Map function over the potential pointer words of a stack, starting
 at the start-stack-frame location."
-  (loop with next-frame with next-nether-frame
-      for nether-frame = start-frame then (or next-nether-frame frame)
-      and frame = (stack-frame-uplink stack start-frame) then (or next-frame
-								  (stack-frame-uplink stack frame))
-      while (plusp frame)
-      do (setf next-frame nil next-nether-frame nil)
-      do (flet ((scavenge-funobj-code-vector (funobj)
-		  "Funobj 0 is assumed to be the DIT code-vector."
-		  (if (eq 0 funobj)
-		      (symbol-value 'default-interrupt-trampoline)
-		    (funobj-code-vector funobj))))
-	   (let ((funobj (funcall function (stack-frame-funobj stack frame) frame)))
-	     ;; If nether-frame is a DIT-frame, there are 4 more words to be skipped.
-	     (when (eq 0 (stack-frame-ref stack nether-frame -1))
-	       (incf nether-frame 4))
-	     (typecase funobj
-	       ((or function null)
-		(assert (= 0 (funobj-frame-num-unboxed funobj)))
-		(map-heap-words function (+ nether-frame 2) frame))
-	       ((eql 0)			; A dit interrupt-frame?
-		(let* ((dit-frame frame)
-		       (casf-frame (dit-frame-casf stack dit-frame)))
-		  ;; 1. Scavenge the dit-frame
-		  (cond
-		   ((let ((atomically (dit-frame-ref stack dit-frame :atomically-continuation
-						     :unsigned-byte32)))
-		      (and (not (= 0 atomically))
-			   (= 0 (ldb (byte 2 0) atomically))))
-		    ;; Interrupt occurred inside an (non-pf) atomically, so none of the
-		    ;; registers are active.
-		    (map-heap-words function (+ nether-frame 2)
-				    (+ dit-frame 1 (dit-frame-index :tail-marker))))
-		   ((logbitp 10 (dit-frame-ref stack dit-frame :eflags :unsigned-byte32))
-		    ;; DF flag was 1, so EAX and EDX are not GC roots.
-		    #+ignore (warn "Interrupt in uncommon mode at ~S"
-				   (dit-frame-ref stack dit-frame :eip :unsigned-byte32))
-		    (map-heap-words function ; Assume nothing in the dit-frame above the location ..
-				    (+ nether-frame 2) ; ..of EDX holds pointers.
-				    (+ dit-frame (dit-frame-index :edx))))
-		   (t #+ignore (warn "Interrupt in COMMON mode!")
-		      (map-heap-words function ; Assume nothing in the dit-frame above the location ..
-				      (+ nether-frame 2) ; ..of ECX holds pointers.
-				      (+ dit-frame (dit-frame-index :ecx)))))
-		  ;; 2. Pop to (dit-)frame's CASF
-		  (setf nether-frame dit-frame
-			frame (dit-frame-casf stack frame))
-		  (let ((casf-funobj (funcall function (stack-frame-funobj stack frame) frame))
-			(interrupted-ebp (dit-frame-ref stack dit-frame :ebp))
-			(interrupted-esp (dit-frame-esp stack dit-frame)))
+  (with-funcallable (map-region)
+    (loop with next-frame with next-nether-frame
+	for nether-frame = start-frame then (or next-nether-frame frame)
+	and frame = (stack-frame-uplink stack start-frame) then (or next-frame
+								    (stack-frame-uplink stack frame))
+	while (plusp frame)
+	do (setf next-frame nil next-nether-frame nil)
+	do (flet ((scavenge-funobj-code-vector (funobj)
+		    "Funobj 0 is assumed to be the DIT code-vector."
+		    (if (eq 0 funobj)
+			(symbol-value 'default-interrupt-trampoline)
+		      (funobj-code-vector funobj))))
+	     (let ((funobj (funcall function (stack-frame-funobj stack frame) frame)))
+	       ;; If nether-frame is a DIT-frame, there are 4 more words to be skipped.
+	       (when (eq 0 (stack-frame-ref stack nether-frame -1))
+		 (incf nether-frame 4))
+	       (typecase funobj
+		 ((or function null)
+		  (assert (= 0 (funobj-frame-num-unboxed funobj)))
+		  (map-region function (+ nether-frame 2) frame))
+		 ((eql 0)		; A dit interrupt-frame?
+		  (let* ((dit-frame frame)
+			 (casf-frame (dit-frame-casf stack dit-frame)))
+		    ;; 1. Scavenge the dit-frame
 		    (cond
-		     #+ignore
-		     ((eq nil casf-funobj)
-		      (warn "Scanning interrupt in PF: ~S"
-			    (dit-frame-ref stack dit-frame :eip :unsigned-byte32)))
-		     ((or (eq 0 casf-funobj)
-			  (typep casf-funobj 'function))
-		      (let ((casf-code-vector (scavenge-funobj-code-vector casf-funobj)))
-			;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii.
-			(cond
-			 ((< interrupted-ebp interrupted-esp)
+		     ((let ((atomically (dit-frame-ref stack dit-frame :atomically-continuation
+						       :unsigned-byte32)))
+			(and (not (= 0 atomically))
+			     (= 0 (ldb (byte 2 0) atomically))))
+		      ;; Interrupt occurred inside an (non-pf) atomically, so none of the
+		      ;; registers are active.
+		      (map-region function (+ nether-frame 2)
+				  (+ dit-frame 1 (dit-frame-index :tail-marker))))
+		     ((logbitp 10 (dit-frame-ref stack dit-frame :eflags :unsigned-byte32))
+		      ;; DF flag was 1, so EAX and EDX are not GC roots.
+		      #+ignore (warn "Interrupt in uncommon mode at ~S"
+				     (dit-frame-ref stack dit-frame :eip :unsigned-byte32))
+		      (map-region function ; Assume nothing in the dit-frame above the location ..
+				  (+ nether-frame 2) ; ..of EDX holds pointers.
+				  (+ dit-frame (dit-frame-index :edx))))
+		     (t #+ignore (warn "Interrupt in COMMON mode!")
+			(map-region function ; Assume nothing in the dit-frame above the location ..
+				    (+ nether-frame 2) ; ..of ECX holds pointers.
+				    (+ dit-frame (dit-frame-index :ecx)))))
+		    ;; 2. Pop to (dit-)frame's CASF
+		    (setf nether-frame dit-frame
+			  frame (dit-frame-casf stack frame))
+		    (let ((casf-funobj (funcall function (stack-frame-funobj stack frame) frame))
+			  (interrupted-ebp (dit-frame-ref stack dit-frame :ebp))
+			  (interrupted-esp (dit-frame-esp stack dit-frame)))
+		      (cond
+		       #+ignore
+		       ((eq nil casf-funobj)
+			(warn "Scanning interrupt in PF: ~S"
+			      (dit-frame-ref stack dit-frame :eip :unsigned-byte32)))
+		       ((or (eq 0 casf-funobj)
+			    (typep casf-funobj 'function))
+			(let ((casf-code-vector (scavenge-funobj-code-vector casf-funobj)))
+			  ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii.
 			  (cond
+			   ((< interrupted-ebp interrupted-esp)
+			    (cond
+			     ((location-in-object-p casf-code-vector
+						    (dit-frame-ref stack dit-frame :eip :location))
+			      (warn "DIT at throw situation, in target EIP=~S"
+				    (dit-frame-ref stack dit-frame :eip :unsigned-byte32))
+			      (map-region function interrupted-esp frame))
+			     ((location-in-object-p (scavenge-funobj-code-vector (dit-frame-ref stack
+												dit-frame
+												:scratch1))
+						    (dit-frame-ref stack dit-frame :eip :location))
+			      (warn "DIT at throw situation, in thrower EIP=~S"
+				    (dit-frame-ref stack dit-frame :eip :unsigned-byte32))
+			      (map-region function interrupted-esp frame))
+			     (t (error "DIT with EBP<ESP, EBP=~S, ESP=~S"
+				       interrupted-ebp
+				       interrupted-esp))))
 			   ((location-in-object-p casf-code-vector
 						  (dit-frame-ref stack dit-frame :eip :location))
-			    (warn "DIT at throw situation, in target EIP=~S"
-				  (dit-frame-ref stack dit-frame :eip :unsigned-byte32))
-			    (map-heap-words function interrupted-esp frame))
-			   ((location-in-object-p (scavenge-funobj-code-vector (dit-frame-ref stack
-											      dit-frame
-											      :scratch1))
-						  (dit-frame-ref stack dit-frame :eip :location))
-			    (warn "DIT at throw situation, in thrower EIP=~S"
-				  (dit-frame-ref stack dit-frame :eip :unsigned-byte32))
-			    (map-heap-words function interrupted-esp frame))
-			   (t (error "DIT with EBP<ESP, EBP=~S, ESP=~S"
-				     interrupted-ebp
-				     interrupted-esp))))
-			 ((location-in-object-p casf-code-vector
-						(dit-frame-ref stack dit-frame :eip :location))
-			  (cond
-			   ((let ((x0-tag (ldb (byte 3 0)
-					       (memref interrupted-esp 0 :type :unsigned-byte8))))
-			      (and (member x0-tag '(1 5 6 7))
-				   (location-in-object-p casf-code-vector
-							 (memref interrupted-esp 0 :type :location))))
-			    ;; When code-vector migration is implemented...
-			    (warn "Scanning at ~S X0 call ~S in ~S."
-				  (dit-frame-ref stack dit-frame :eip :unsigned-byte32)
-				  (memref interrupted-esp 0 :type :unsigned-byte32)
-				  (funobj-name casf-funobj))
-			    #+ignore (map-heap-words function (+ interrupted-esp 1) frame)
-			    (when (eq 0 (stack-frame-ref stack frame -1))
-			      (break "X1 call in DIT-frame."))
-			    (setf next-frame frame
-				  next-nether-frame (+ interrupted-esp 1 -2)))
-			   ((let ((x1-tag (ldb (byte 3 0)
-					       (memref interrupted-esp 4 :type :unsigned-byte8))))
-			      (and (member x1-tag '(1 5 6 7))
-				   (location-in-object-p casf-code-vector
-							 (memref interrupted-esp 4 :type :location))))
-			    ;; When code-vector migration is implemented...
-			    (warn "Scanning at ~S X1 call ~S in ~S."
-				  (dit-frame-ref stack dit-frame :eip :unsigned-byte32)
-				  (memref interrupted-esp 4 :type :unsigned-byte32)
-				  (funobj-name casf-funobj))
-			    (when (eq 0 (stack-frame-ref stack frame -1))
-			      (break "X1 call in DIT-frame."))
-			    #+ignore (map-heap-words function (+ interrupted-esp 2) frame)
+			    (cond
+			     ((let ((x0-tag (ldb (byte 3 0)
+						 (memref interrupted-esp 0 :type :unsigned-byte8))))
+				(and (member x0-tag '(1 5 6 7))
+				     (location-in-object-p casf-code-vector
+							   (memref interrupted-esp 0 :type :location))))
+			      ;; When code-vector migration is implemented...
+			      (warn "Scanning at ~S X0 call ~S in ~S."
+				    (dit-frame-ref stack dit-frame :eip :unsigned-byte32)
+				    (memref interrupted-esp 0 :type :unsigned-byte32)
+				    (funobj-name casf-funobj))
+			      (map-region function (+ interrupted-esp 1) frame)
+			      (when (eq 0 (stack-frame-ref stack frame -1))
+				(break "X1 call in DIT-frame."))
+			      (setf next-frame frame
+				    next-nether-frame (+ interrupted-esp 1 -2)))
+			     ((let ((x1-tag (ldb (byte 3 0)
+						 (memref interrupted-esp 4 :type :unsigned-byte8))))
+				(and (member x1-tag '(1 5 6 7))
+				     (location-in-object-p casf-code-vector
+							   (memref interrupted-esp 4 :type :location))))
+			      ;; When code-vector migration is implemented...
+			      (warn "Scanning at ~S X1 call ~S in ~S."
+				    (dit-frame-ref stack dit-frame :eip :unsigned-byte32)
+				    (memref interrupted-esp 4 :type :unsigned-byte32)
+				    (funobj-name casf-funobj))
+			      (when (eq 0 (stack-frame-ref stack frame -1))
+				(break "X1 call in DIT-frame."))
+			      (map-region function (+ interrupted-esp 2) frame)
+			      (setf next-frame frame
+				    next-nether-frame (+ interrupted-esp 2 -2)))
+			     (t ;; Situation i. Nothing special on stack, scavenge frame normally.
+			      ;; (map-region function interrupted-esp frame)
+			      (setf next-frame frame
+				    next-nether-frame (- interrupted-esp 2))
+			      )))
+			   ((eq casf-frame (memref interrupted-esp 0 :type :location))
+			    ;; Situation ii. esp(0)=CASF, esp(1)=code-vector
+			    (assert (location-in-object-p casf-code-vector
+							  (memref interrupted-esp 4 :type :location))
+
+				() "Stack discipline situation ii. invariant broken. CASF=#x~X, ESP=~S, EBP=~S"
+				casf-frame interrupted-esp interrupted-ebp)
+			    (map-region function (+ interrupted-esp 2) frame)
 			    (setf next-frame frame
 				  next-nether-frame (+ interrupted-esp 2 -2)))
-			   (t ;; Situation i. Nothing special on stack, scavenge frame normally.
-			    ;; (map-heap-words function interrupted-esp frame)
+			   (t ;; Situation iii. esp(0)=code-vector.
+			    (assert (location-in-object-p casf-code-vector
+							  (memref interrupted-esp 0 :type :location))
+				() "Stack discipline situation iii. invariant broken. CASF=#x~X"
+				casf-frame)
+			    (map-region function (+ interrupted-esp 1) frame)
 			    (setf next-frame frame
-				  next-nether-frame (- interrupted-esp 2))
-			    )))
-			 ((eq casf-frame (memref interrupted-esp 0 :type :location))
-			  ;; Situation ii. esp(0)=CASF, esp(1)=code-vector
-			  (assert (location-in-object-p casf-code-vector
-							(memref interrupted-esp 4 :type :location))
-
-			      () "Stack discipline situation ii. invariant broken. CASF=#x~X, ESP=~S, EBP=~S"
-			      casf-frame interrupted-esp interrupted-ebp)
-			  #+ignore (map-heap-words function (+ interrupted-esp 2) frame)
-			  (setf next-frame frame
-				next-nether-frame (+ interrupted-esp 2 -2)))
-			 (t ;; Situation iii. esp(0)=code-vector.
-			  (assert (location-in-object-p casf-code-vector
-							(memref interrupted-esp 0 :type :location))
-			      () "Stack discipline situation iii. invariant broken. CASF=#x~X"
-			      casf-frame)
-			  #+ignore (map-heap-words function (+ interrupted-esp 1) frame)
-			  (setf next-frame frame
-				next-nether-frame (+ interrupted-esp 1 -2))))))
-		     (t (error "DIT-frame interrupted unknown CASF funobj: ~S" casf-funobj))))))
-	       (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj))))))
+				  next-nether-frame (+ interrupted-esp 1 -2))))))
+		       (t (error "DIT-frame interrupted unknown CASF funobj: ~S" casf-funobj))))))
+		 (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj)))))))
   (values))
 




From ffjeld at common-lisp.net  Fri Nov 26 15:00:24 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Nov 2004 16:00:24 +0100
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1CXhaC-0005Uf-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
*** empty log message ***
Date: Fri Nov 26 16:00:14 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.32 movitz/losp/los0.lisp:1.33
--- movitz/losp/los0.lisp:1.32	Wed Nov 24 17:24:16 2004
+++ movitz/losp/los0.lisp	Fri Nov 26 15:59:59 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.32 2004/11/24 16:24:16 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.33 2004/11/26 14:59:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1200,15 +1200,15 @@
 	  (error "Double interrupt.")))
       #+ignore
       (dolist (range muerte::%memory-map-roots%)
-	(map-heap-words (lambda (x type)
-			  (declare (ignore type))
+	(map-header-vals (lambda (x type)
+			   (declare (ignore type))
+			   x)
+			 (car range) (cdr range)))
+      (map-stack-vector (lambda (x foo)
+			  (declare (ignore foo))
 			  x)
-			(car range) (cdr range)))
-      (map-stack-words (lambda (x foo)
-			 (declare (ignore foo))
-			 x)
-		       nil
-		       (current-stack-frame))
+			nil
+			(current-stack-frame))
       (with-inline-assembly (:returns :nothing)
 	(:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*)
 	(:shrl 2 :ecx)
@@ -1305,7 +1305,7 @@
     (idt-init)
     #+ignore
     (install-los0-consing :kb-size 500)
-    (install-los0-consing :kb-size (max 100 (truncate (- extended-memsize 1024 2048) 2))))
+    (install-los0-consing :kb-size (max 100 (truncate (- extended-memsize 2048) 2))))
 
   (setf *debugger-function* #'los0-debugger)
   (clos-bootstrap)




From ffjeld at common-lisp.net  Tue Nov 30 14:16:19 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Nov 2004 15:16:19 +0100 (CET)
Subject: [movitz-cvs] CVS update: movitz/movitz-mode.el 
Message-ID: <20041130141619.B00DA88450@common-lisp.net>

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

Modified Files:
	movitz-mode.el 
Log Message:
*** empty log message ***
Date: Tue Nov 30 15:16:18 2004
Author: ffjeld

Index: movitz/movitz-mode.el
diff -u movitz/movitz-mode.el:1.7 movitz/movitz-mode.el:1.8
--- movitz/movitz-mode.el:1.7	Tue Jun  8 00:10:54 2004
+++ movitz/movitz-mode.el	Tue Nov 30 15:16:18 2004
@@ -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.7 2004/06/07 22:10:54 ffjeld Exp $
+;;;; $Id: movitz-mode.el,v 1.8 2004/11/30 14:16:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -101,15 +101,19 @@
   (fi:eval-in-lisp "(movitz::dump-image)")
 ;;;  (with-current-buffer "*common-lisp*"
 ;;;    (fi:inferior-lisp-newline))
-  (if dont-run-bochs-p
-      (message "Dumping Movitz image...done. Bootblock ID: %d."
-	       (fi:eval-in-lisp "movitz::*bootblock-build*"))
-    (message "Dumping Movitz image...done. Bootblock ID: %d. Running bochs on \"%s\"..."
-	     (fi:eval-in-lisp "movitz::*bootblock-build*")
-	     display-shortcut)
+  (cond
+   (dont-run-bochs-p
+    (message "Dumping Movitz image...done. Bootblock ID: %d. Running qemu.."
+	     (fi:eval-in-lisp "movitz::*bootblock-build*"))
     (call-process "/bin/sh" nil 0 nil "-c"
-		  (format "DISPLAY=\"%s\" cd ~/clnet/movitz && ~/tmp/bochs-cvs/bochs -nocp > bochs-parameters"
-			  display-shortcut))))
+		  (format "DISPLAY=\"%s\" cd ~/clnet/movitz && qemu -fda los0-image -boot a"
+			  display-shortcut)))
+   (t (message "Dumping Movitz image...done. Bootblock ID: %d. Running bochs on \"%s\"..."
+	       (fi:eval-in-lisp "movitz::*bootblock-build*")
+	       display-shortcut)
+      (call-process "/bin/sh" nil 0 nil "-c"
+		    (format "DISPLAY=\"%s\" cd ~/clnet/movitz && ~/tmp/bochs-cvs/bochs -nocp > bochs-parameters"
+			    display-shortcut)))))
 
 (defun movitz-compile-file ()
   (interactive)



From ffjeld at common-lisp.net  Tue Nov 30 14:16:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Nov 2004 15:16:43 +0100 (CET)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/ne2k.lisp 
Message-ID: <20041130141643.646B48844F@common-lisp.net>

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

Modified Files:
	ne2k.lisp 
Log Message:
This makes Qemu work.

Date: Tue Nov 30 15:16:40 2004
Author: ffjeld

Index: movitz/losp/x86-pc/ne2k.lisp
diff -u movitz/losp/x86-pc/ne2k.lisp:1.13 movitz/losp/x86-pc/ne2k.lisp:1.14
--- movitz/losp/x86-pc/ne2k.lisp:1.13	Wed Nov 24 17:20:30 2004
+++ movitz/losp/x86-pc/ne2k.lisp	Tue Nov 30 15:16:38 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 17 15:16:00 2002
 ;;;;                
-;;;; $Id: ne2k.lisp,v 1.13 2004/11/24 16:20:30 ffjeld Exp $
+;;;; $Id: ne2k.lisp,v 1.14 2004/11/30 14:16:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -217,6 +217,7 @@
 	(%io-port-write-succession (asic-io-base device) packet 2 start end :16-bit))
       (setf (io-register8x2 dp8390 ($page0-write tbcr1) ($page0-write tbcr0)) packet-length
 	    (dp8390 ($page0-write cr)) ($command transmit start abort-complete))
+      #+ignore
       (loop while (= (dp8390 ($page0-read cr))
 		     ($command start transmit abort-complete)))))
   nil)



From ffjeld at common-lisp.net  Tue Nov 30 14:17:02 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Nov 2004 15:17:02 +0100 (CET)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp 
Message-ID: <20041130141702.9F8EF8844C@common-lisp.net>

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

Modified Files:
	pci.lisp 
Log Message:
Changed pci-far-call a bit.

Date: Tue Nov 30 15:16:57 2004
Author: ffjeld

Index: movitz/losp/x86-pc/pci.lisp
diff -u movitz/losp/x86-pc/pci.lisp:1.7 movitz/losp/x86-pc/pci.lisp:1.8
--- movitz/losp/x86-pc/pci.lisp:1.7	Fri Nov 26 01:02:39 2004
+++ movitz/losp/x86-pc/pci.lisp	Tue Nov 30 15:16:57 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Dec 14 22:33:42 2003
 ;;;;                
-;;;; $Id: pci.lisp,v 1.7 2004/11/26 00:02:39 ffjeld Exp $
+;;;; $Id: pci.lisp,v 1.8 2004/11/30 14:16:57 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -55,7 +55,7 @@
 
 (defun pci-far-call (address &key (cs 8) (eax 0) (ebx 0) (ecx 0) (edx 0) (esi 0) (edi 0))
   "Make a 'far call' to cs:address with the provided values for eax and ebx.
-Returns the values of registers EAX, EBX, ECX, and EDX, and status of CF.
+Returns the boolean status of CF, and the values of registers EAX, EBX, ECX, and EDX.
 The stack discipline is broken during this call, so we disable interrupts
 in a somewhat feeble attempt to avoid trouble."
   (check-type address (unsigned-byte 32))
@@ -94,26 +94,27 @@
       (:call-segment (:esp))
       (:leal (:esp 8) :esp)		; Skip cs:address
       (:popl :edi)			; First of all, restore EDI!
-      (:locally (:movl :edi (:edi (:edi-offset values) 8)))
+      (:locally (:movl :edi (:edi (:edi-offset scratch2))))
       (:jnc 'cf=0)
       (:locally (:pushl (:edi (:edi-offset t-symbol))))
-      (:locally (:popl (:edi (:edi-offset values) 8)))
+      (:locally (:popl (:edi (:edi-offset scratch2))))
      cf=0
       (:pushl :eax)
       (:pushl :ebx)
       (:pushl :edx)
       (:locally (:movl 3 (:edi (:edi-offset num-values))))
       (:call-local-pf box-u32-ecx)	; ECX
-      (:locally (:movl :eax (:edi (:edi-offset values) 0)))
+      (:locally (:movl :eax (:edi (:edi-offset values) 4)))
       (:popl :ecx)			; EDX
       (:call-local-pf box-u32-ecx)
-      (:locally (:movl :eax (:edi (:edi-offset values) 4)))
+      (:locally (:movl :eax (:edi (:edi-offset values) 8)))
       (:popl :ecx)			; EBX
       (:call-local-pf box-u32-ecx)
-      (:locally (:movl :eax (:edi (:edi-offset scratch1))))
+      (:locally (:movl :eax (:edi (:edi-offset values) 0)))
       (:popl :ecx)			; EAX
       (:call-local-pf box-u32-ecx)
-      (:locally (:movl (:edi (:edi-offset scratch1)) :ebx))
+      (:movl :eax :ebx)
+      (:locally (:movl (:edi (:edi-offset scratch2)) :eax))
       (:movl 5 :ecx)
       (:movl (:ebp -4) :esi)
       (:stc)
@@ -124,27 +125,28 @@
 (defun find-bios32-pci ()
   (let ((bios32-base (find-bios32-base)))
     (assert bios32-base "No bios32 found.")
-    (multiple-value-bind (eax ebx ecx edx)
+    (multiple-value-bind (cf eax ebx ecx edx)
 	(pci-far-call (memref-int bios32-base :offset 4)
 		      :eax (pci-word "$PCI"))
-      (declare (ignore ecx))
+      (declare (ignore cf ecx))
       (ecase (ldb (byte 8 0) eax)
 	(#x80 (error "The PCI bios32 service isn't present."))
 	(#x81 (error "The PCI bios32 service doesn't exist."))
 	(#x00 (+ ebx edx))))))
 
 (defun pci-bios-present ()
-  (multiple-value-bind (eax ebx ecx edx cf)
+  (multiple-value-bind (cf eax ebx ecx edx)
       (pci-far-call (find-bios32-pci) :eax #xb101)
-    (values (pci-string edx)
-	    (ldb (byte 8 8) eax)	; AH: Present status
-	    (ldb (byte 8 0) eax)	; AL: Hardware mechanism
-	    (ldb (byte 8 8) ebx)	; BH: Interface Level Major Version
-	    (ldb (byte 8 0) ebx)	; BL: Interface Level Minor Version
-	    (ldb (byte 8 0) ecx))))	; CL: Number of last PCI bus in the system
+    (unless cf
+      (values (pci-string edx)
+	      (ldb (byte 8 8) eax)	; AH: Present status
+	      (ldb (byte 8 0) eax)	; AL: Hardware mechanism
+	      (ldb (byte 8 8) ebx)	; BH: Interface Level Major Version
+	      (ldb (byte 8 0) ebx)	; BL: Interface Level Minor Version
+	      (ldb (byte 8 0) ecx)))))	; CL: Number of last PCI bus in the system
 		
 (defun find-pci-device (vendor device &optional (index 0))
-  (multiple-value-bind (eax ebx ecx edx cf)
+  (multiple-value-bind (cf eax ebx)
       (pci-far-call (find-bios32-pci)
 		    :eax #xb102
 		    :ecx device
@@ -160,12 +162,11 @@
 		(#x83 :bad-vendor-id))))))
 
 (defun find-pci-class-code (class-code &optional (index 0))
-  (multiple-value-bind (eax ebx ecx edx cf)
+  (multiple-value-bind (cf eax ebx)
       (pci-far-call (find-bios32-pci)
 		    :eax #xb103
 		    :ecx class-code
 		    :esi index)
-    (declare (ignore ecx edx))
     (unless cf
       (values (ldb (byte 8 8) ebx)	; Bus
 	      (ldb (byte 5 3) ebx)	; Device
@@ -231,36 +232,59 @@
 			 (nth (ldb (byte 8 0) code) sub-class-table))))
     (values (car class-table) sub-class sub-class-if)))
 
-(defun pci-bios-read-configuration-word (bus device function register)
-  (multiple-value-bind (eax ebx ecx edx cf)
+(defun pci-bios-config-space (bus device function register command size)
+  (multiple-value-bind (cf eax ebx ecx)
       (pci-far-call (find-bios32-pci)
-		    :eax #xb109
+		    :eax command
 		    :ebx (pci-location bus device function)
 		    :edi register)
-    (declare (ignore ebx edx))
+    (declare (ignore ebx))
     (unless cf
-      (values (ldb (byte 16 0) ecx) (pci-return-code eax)))))
+      (values (ldb (byte size 0) ecx)
+	      (pci-return-code eax)))))
 
-(defun pci-bios-read-configuration-dword (bus device function register)
-  (multiple-value-bind (eax ebx ecx edx cf)
+(defun (setf pci-bios-config-space) (value bus device function register command size)
+  (declare (ignore size))
+  (multiple-value-bind (cf eax)
       (pci-far-call (find-bios32-pci)
-		    :eax #xb10a
+		    :eax command
 		    :ebx (pci-location bus device function)
+		    :ecx value
 		    :edi register)
-    (declare (ignore ebx edx))
     (unless cf
-      (values ecx (pci-return-code eax)))))
+      (pci-return-code eax))))
+
+(defun pci-bios-config-space-dword (bus device function register)
+  (pci-bios-config-space bus device function register #xb10a 32))
+
+(defun pci-bios-config-space-word (bus device function register)
+  (pci-bios-config-space bus device function register #xb109 16))
+
+(defun pci-bios-config-space-byte (bus device function register)
+  (pci-bios-config-space bus device function register #xb108 8))
+
+(defun (setf pci-bios-config-space-dword) (value bus device function register)
+  (setf (pci-bios-config-space bus device function register #xb10d 32)
+    value))
+
+(defun (setf pci-bios-config-space-word) (value bus device function register)
+  (setf (pci-bios-config-space bus device function register #xb10c 16)
+    value))
+
+(defun (setf pci-bios-config-space-byte) (value bus device function register)
+  (setf (pci-bios-config-space bus device function register #xb10b 8)
+    value))
 
 (defun scan-pci-bus (bus)
   (loop for device from 0 to 31
       do (multiple-value-bind (vendor-id return-code)
-	     (pci-bios-read-configuration-word bus device 0 0)
+	     (pci-bios-config-space-word bus device 0 0)
 	   (when (and vendor-id
 		      (not (= vendor-id #xffff))
 		      (eq :successful return-code))
-	     (let ((device-id (pci-bios-read-configuration-word bus device 0 2))
-		   (status (pci-bios-read-configuration-word bus device 0 6))
-		   (class-rev (pci-bios-read-configuration-dword bus device 0 8)))
+	     (let ((device-id (pci-bios-config-space-word bus device 0 2))
+		   (status (pci-bios-config-space-word bus device 0 6))
+		   (class-rev (pci-bios-config-space-dword bus device 0 8)))
 	       (format *query-io*
 		       "~&~D: Vendor #x~X, ID #x~X, Class #x~X, Rev. ~D, Status #x~X.~%"
 		       device vendor-id device-id