[movitz-cvs] CVS update: movitz/image.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Thu Jul 29 00:13:00 UTC 2004
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv23046
Modified Files:
image.lisp
Log Message:
Re-arranged many details about *movitz-nil*, movitz-null, and how it
relates to the cons and symbol binary-classes etc. This should now be
slightly less messy, and slightly more efficient.
Date: Wed Jul 28 17:13:00 2004
Author: ffjeld
Index: movitz/image.lisp
diff -u movitz/image.lisp:1.53 movitz/image.lisp:1.54
--- movitz/image.lisp:1.53 Wed Jul 28 03:00:33 2004
+++ movitz/image.lisp Wed Jul 28 17:13:00 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.53 2004/07/28 10:00:33 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.54 2004/07/29 00:13:00 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -119,16 +119,21 @@
:map-binary-read-delayed 'movitz-word-code-vector
:binary-tag :primitive-function)
;; function global constants
- (unbound-function
- :binary-type word
- :binary-tag :global-function
- :map-binary-read-delayed 'movitz-word
- :map-binary-write 'movitz-intern)
+;;; (unbound-function
+;;; :binary-type word
+;;; :binary-tag :global-function
+;;; :map-binary-read-delayed 'movitz-word
+;;; :map-binary-write 'movitz-intern)
;; per thread parameters
(dynamic-env
:binary-type lu32
:initform 0)
;; More per-thread parameters
+ (unwind-protect-tag
+ :binary-type word
+ :map-binary-read-delayed 'movitz-word
+ :map-binary-write 'movitz-read-and-intern
+ :initform 'muerte::unwind-protect-tag)
(restart-tag
:binary-type word
:map-binary-read-delayed 'movitz-word
@@ -141,18 +146,8 @@
:binary-type word ; in order for the bound instruction to work.
:initform #x100000)
;;
- (unbound-value
- :binary-type word
- :map-binary-read-delayed 'movitz-word
- :map-binary-write 'movitz-read-and-intern
- :initform 'muerte::unbound)
- (unwind-protect-tag
- :binary-type word
- :map-binary-read-delayed 'movitz-word
- :map-binary-write 'movitz-read-and-intern
- :initform 'muerte::unwind-protect-tag)
(boolean-one :binary-type :label)
- (not-nil ; not-nil, t-symbol and null-cons must be consecutive.
+ (not-nil ; not-nil, t-symbol and not-not-nil must be consecutive.
:binary-type word
:initform nil
:map-binary-write 'movitz-read-and-intern
@@ -163,13 +158,21 @@
:initarg :t-symbol
:map-binary-write 'movitz-intern
:map-binary-read-delayed 'movitz-word)
- (null-cons
- :binary-type movitz-nil
- :initarg :null-cons)
- (null-sym
- :binary-type movitz-nil-symbol
+ (not-not-nil
+ :binary-type word
+ :initform nil
+ :map-binary-write 'movitz-read-and-intern
+ :map-binary-read-delayed 'movitz-word)
+ ;; (null-cons :binary-type :label)
+ (null-symbol
+ :binary-type movitz-symbol
:reader movitz-run-time-context-null-symbol
- :initarg :null-sym)
+ :initarg :null-symbol)
+ (unbound-value
+ :binary-type word
+ :map-binary-read-delayed 'movitz-word
+ :map-binary-write 'movitz-read-and-intern
+ :initform 'muerte::unbound)
;; primitive functions global constants
(dynamic-find-binding
:map-binary-write 'movitz-intern-code-vector
@@ -480,7 +483,7 @@
:map-binary-write 'movitz-intern-code-vector
:map-binary-read-delayed 'movitz-word-code-vector
:binary-tag :primitive-function))
- (:slot-align null-cons -1))
+ (:slot-align null-symbol -5))
(defun atomically-status-simple-pf (pf-name reset-status-p &rest registers)
(bt:enum-value 'movitz::atomically-status
@@ -511,15 +514,17 @@
(defun global-constant-offset (slot-name)
(check-type slot-name symbol)
-
- (slot-offset 'movitz-run-time-context
- (intern (symbol-name slot-name) :movitz)))
+ (let ((slot-name (find-symbol (symbol-name slot-name) :movitz)))
+ (assert slot-name)
+ (if (not (eq slot-name 'unbound-function))
+ (slot-offset 'movitz-run-time-context slot-name)
+ (+ (slot-offset 'movitz-run-time-context 'null-symbol)
+ (slot-offset 'movitz-symbol 'function-value)))))
(defun make-movitz-run-time-context ()
(make-instance 'movitz-run-time-context
:t-symbol (movitz-read 't)
- :null-cons *movitz-nil*
- :null-sym (movitz-nil-sym *movitz-nil*)))
+ :null-symbol *movitz-nil*))
(defclass image ()
((ds-segment-base
@@ -560,6 +565,9 @@
:accessor image-symbol-hash-key-counter)
(nil-word
:accessor image-nil-word)
+ (nil-object
+ :initarg :nil-object
+ :accessor image-nil-object)
(t-symbol
:accessor image-t-symbol)
(bootblock
@@ -639,7 +647,7 @@
()
"The MOVITZ-HEAP-OBJECT-OTHER type ~A is malformed!" (type-of object))
(etypecase object
- (movitz-nil
+ (movitz-null
(image-nil-word image))
(movitz-heap-object
(+ (movitz-object-offset object)
@@ -778,6 +786,7 @@
(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
@@ -785,8 +794,8 @@
(copy-hash-table (function-code-sizes *image*))
(make-hash-table :test #'equal)))))
(setf (image-nil-word *image*)
- (1+ (- (slot-offset 'movitz-run-time-context 'null-cons)
- (slot-offset 'movitz-run-time-context 'run-time-context-start))))
+ (+ 5 (- (slot-offset 'movitz-run-time-context 'null-symbol)
+ (slot-offset 'movitz-run-time-context 'run-time-context-start))))
(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."
@@ -914,10 +923,13 @@
;; do (warn "sp: ~S ~S" symbol plist)
do (let ((x (movitz-read symbol)))
(typecase x
+ (movitz-null)
(movitz-symbol
(setf (movitz-plist x)
- (movitz-read (translate-program plist :cl :muerte.cl))))
- (movitz-nil)
+ (movitz-read (translate-program (loop for (property value) on plist by #'cddr
+ unless (member property '(special constantp))
+ append (list property value))
+ :cl :muerte.cl))))
(t (warn "not a symbol for plist: ~S has ~S" symbol plist)))))
;; pull in global properties
(loop for var in (image-compile-time-variables *image*)
@@ -1479,7 +1491,7 @@
(defun movitz-make-upload-form (object &optional (quotep t))
"Not completed."
(typecase object
- ((or movitz-nil null) "()")
+ ((or movitz-null null) "()")
(cons
(format nil "(list~{ ~A~})"
(mapcar #'movitz-make-upload-form object)))
@@ -1547,7 +1559,7 @@
(symbol expr)
(array expr)
(cons (mapcar #'movitz-print expr))
- ((or movitz-nil movitz-run-time-context) nil)
+ ((or (satisfies movitz-null) movitz-run-time-context) nil)
(movitz-fixnum
(movitz-fixnum-value expr))
(movitz-std-instance expr)
More information about the Movitz-cvs
mailing list