[movitz-cvs] CVS update: movitz/image.lisp

Frode Vatvedt Fjeld ffjeld at common-lisp.net
Fri Apr 29 22:36:02 UTC 2005


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

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

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

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




More information about the Movitz-cvs mailing list