[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