May 2005 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp
by ffjeld＠common-lisp.net 05 May '05

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv14053 Modified Files: basic-functions.lisp Log Message: Removed global-properties from run-time-context. Put the hash-table of all packages in *packages* instead. Date: Thu May 5 15:21:48 2005 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.17 movitz/losp/muerte/basic-functions.lisp:1.18 --- movitz/losp/muerte/basic-functions.lisp:1.17 Wed Apr 20 08:52:26 2005 +++ movitz/losp/muerte/basic-functions.lisp Thu May 5 15:21:46 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.17 2005/04/20 06:52:26 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.18 2005/05/05 13:21:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -326,9 +326,6 @@ (compiled-function x) (t (error "Not a function: ~S" x)))) - -(defun get-global-property (property) - (getf (load-global-constant global-properties) property)) (define-compiler-macro object-location (object) "The location is the object's address divided by fixnum-factor."

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by ffjeld＠common-lisp.net 05 May '05

05 May '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv14036 Modified Files: image.lisp Log Message: Removed global-properties from run-time-context. Put the hash-table of all packages in *packages* instead. Date: Thu May 5 15:21:40 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.96 movitz/image.lisp:1.97 --- movitz/image.lisp:1.96 Thu May 5 15:02:37 2005 +++ movitz/image.lisp Thu May 5 15:21:40 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.96 2005/05/05 13:02:37 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.97 2005/05/05 13:21:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -428,13 +428,7 @@ :accessor movitz-run-time-context-interrupt-descriptor-table :initform (make-array 256 :initial-element 'muerte::default-interrupt-trampoline) :map-binary-read-delayed 'movitz-word - :map-binary-write 'map-interrupt-trampolines-to-idt) - (global-properties - :binary-type word - :initform nil - :accessor movitz-run-time-context-global-properties - :map-binary-write 'movitz-intern - :map-binary-read-delayed 'movitz-word)) + :map-binary-write 'map-interrupt-trampolines-to-idt)) (:slot-align null-symbol -5)) (defun atomically-continuation-simple-pf (pf-name) @@ -940,12 +934,8 @@ do (let ((mname (movitz-read var)) (mvalue (movitz-read (symbol-value var)))) (setf (movitz-symbol-value mname) mvalue))) - (setf (movitz-run-time-context-global-properties run-time-context) - (movitz-read (list :packages (make-packages-hash) - :trampoline-funcall%1op (find-primitive-function - 'muerte::trampoline-funcall%1op) - :trampoline-funcall%2op (find-primitive-function - 'muerte::trampoline-funcall%2op))))) + (setf (movitz-symbol-value (movitz-read 'muerte::*packages*)) + (movitz-read (make-packages-hash)))) (with-binary-file (stream path :check-stream t :direction :output

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by ffjeld＠common-lisp.net 05 May '05

05 May '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12628 Modified Files: image.lisp Log Message: Removed toplevel-funobj from run-time-context. Date: Thu May 5 15:02:37 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.95 movitz/image.lisp:1.96 --- movitz/image.lisp:1.95 Thu May 5 00:47:58 2005 +++ movitz/image.lisp Thu May 5 15:02:37 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.95 2005/05/04 22:47:58 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.96 2005/05/05 13:02:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -429,12 +429,6 @@ :initform (make-array 256 :initial-element 'muerte::default-interrupt-trampoline) :map-binary-read-delayed 'movitz-word :map-binary-write 'map-interrupt-trampolines-to-idt) - (toplevel-funobj - :binary-type word - :initform nil - :accessor movitz-run-time-context-toplevel-funobj - :map-binary-write 'movitz-intern - :map-binary-read-delayed 'movitz-word) (global-properties :binary-type word :initform nil @@ -885,7 +879,7 @@ (stable-sort (copy-list (image-load-time-funobjs *image*)) #'> :key #'third)) (let* ((toplevel-funobj (make-toplevel-funobj *image*))) (setf (image-toplevel-funobj *image*) toplevel-funobj - (movitz-run-time-context-toplevel-funobj (image-run-time-context *image*)) toplevel-funobj) + #+ignore ((movitz-run-time-context-toplevel-funobj (image-run-time-context *image*)) toplevel-funobj)) (format t "~&;; load-sequence:~%~<~A~>~%" (mapcar #'second (image-load-time-funobjs *image*))) (movitz-intern toplevel-funobj) (let ((init-code-address (+ (movitz-intern-code-vector (movitz-funobj-code-vector toplevel-funobj)) @@ -1056,7 +1050,8 @@ (file-start-position (file-position stream)) (pad-size 0)) (declare (special *record-all-funobjs*)) - (loop for p upfrom (- (image-start-address image) (image-ds-segment-base image)) by 8 + (loop with prev-obj + for p upfrom (- (image-start-address image) (image-ds-segment-base image)) by 8 until (>= p (image-cons-pointer image)) summing (let ((obj (image-memref image p nil))) @@ -1068,7 +1063,8 @@ (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)) + "pad-delta ~S for ~S (prev ~S), p: ~S, new-pos: ~S" + pad-delta obj prev-obj p new-pos)) (incf pad-size pad-delta)) (set-file-position stream new-pos obj)) ;; (warn "Dump at address #x~X, filepos #x~X: ~A" p (file-position stream) obj) @@ -1085,17 +1081,18 @@ (:code (incf code-vectors-numof) (incf code-vectors-size write-size)))) (movitz-funobj (incf funobjs-numof) - (incf funobjs-size write-size)) + (incf funobjs-size write-size)) (movitz-symbol (incf symbols-numof) - (incf symbols-size write-size) - (when (movitz-eql *movitz-nil* (movitz-symbol-package obj)) - (incf gensyms-numof))) + (incf symbols-size write-size) + (when (movitz-eql *movitz-nil* (movitz-symbol-package obj)) + (incf gensyms-numof))) (movitz-cons (incf conses-numof) - (incf conses-size write-size))) + (incf conses-size write-size))) (assert (= write-size (sizeof obj) (- (file-position stream) old-pos)) () "Inconsistent write-size(~D)/sizeof(~D)/file-position delta(~D) ~ for object ~S." write-size (sizeof obj) (- (file-position stream) old-pos) obj) + (setf prev-obj obj) write-size)))) finally (let ((total-size (file-position stream)) @@ -1582,7 +1579,9 @@ (defmethod make-toplevel-funobj ((*image* symbolic-image)) (declare (special *image*)) (let ((toplevel-code (loop for (funobj) in (image-load-time-funobjs *image*) - collect `(muerte::simple-funcall ,funobj)))) + collect `(muerte::simple-funcall ,funobj))) + ;; We need toplevel-funobj's identity in the code below. + (toplevel-funobj (make-instance 'movitz-funobj-pass1))) (make-compiled-funobj 'muerte::toplevel-function () '((muerte::without-function-prelude)) `(muerte.cl:progn @@ -1631,8 +1630,9 @@ (:pushl 0) (:pushl 0) (:movl :esp :ebp) - - (:globally (:movl (:edi (:edi-offset toplevel-funobj)) :esi)) + + (:movl '(:funcall ,(lambda () (movitz-intern toplevel-funobj))) + :esi) (:pushl :esi) (:pushl :edi) (:cmpl #x2badb002 :eax) @@ -1658,7 +1658,7 @@ ,@toplevel-code (muerte::halt-cpu)) - nil t))) + nil t :funobj toplevel-funobj))) (defun mkasm-write-word-eax-ebx () (let ((loop-label (make-symbol "write-word-loop"))

1 0

[movitz-cvs] CVS update: movitz/losp/ll-testing.lisp
by ffjeld＠common-lisp.net 05 May '05

05 May '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv28126 Modified Files: ll-testing.lisp Log Message: Make thread isn't really supposed to be here. Date: Thu May 5 12:28:53 2005 Author: ffjeld Index: movitz/losp/ll-testing.lisp diff -u movitz/losp/ll-testing.lisp:1.6 movitz/losp/ll-testing.lisp:1.7 --- movitz/losp/ll-testing.lisp:1.6 Sat Apr 30 00:36:49 2005 +++ movitz/losp/ll-testing.lisp Thu May 5 12:28:52 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Apr 14 08:18:43 2005 ;;;; -;;;; $Id: ll-testing.lisp,v 1.6 2005/04/29 22:36:49 ffjeld Exp $ +;;;; $Id: ll-testing.lisp,v 1.7 2005/05/05 10:28:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -139,34 +139,34 @@ :esi function))) stack) -(defun make-thread (&key (name (gensym "thread-")) (function #'invoke-debugger) (args '(nil))) - "Make a thread and initialize its stack to apply function to args." - (let* ((fs-index 8) ; a vacant spot in the global segment descriptor table.. - (fs (* 8 fs-index)) - (thread (muerte::clone-run-time-context :name name)) - (segment-descriptor-table (symbol-value 'muerte.init::*segment-descriptor-table*))) - (setf (segment-descriptor segment-descriptor-table fs-index) - (segment-descriptor segment-descriptor-table (truncate (segment-register :fs) 8))) - (setf (segment-descriptor-base-location segment-descriptor-table fs-index) - (+ (object-location thread) (muerte::location-physical-offset))) - (let ((cushion nil) - (stack (control-stack-init-for-yield (make-array 4094 :element-type '(unsigned-byte 32)) - function args))) - (multiple-value-bind (ebp esp) - (control-stack-fixate stack) - (setf (control-stack-fs stack) fs - (control-stack-ebp stack) ebp - (control-stack-esp stack) esp)) - (setf (%run-time-context-slot 'dynamic-env thread) 0 - (%run-time-context-slot 'stack-vector thread) stack - (%run-time-context-slot 'stack-top thread) (+ 2 (object-location stack) - (length stack)) - (%run-time-context-slot 'stack-bottom thread) (+ (object-location stack) 2 - (or cushion - (if (>= (length stack) 200) - 100 - 0)))) - (values thread)))) +;;;(defun make-thread (&key (name (gensym "thread-")) (function #'invoke-debugger) (args '(nil))) +;;; "Make a thread and initialize its stack to apply function to args." +;;; (let* ((fs-index 8) ; a vacant spot in the global segment descriptor table.. +;;; (fs (* 8 fs-index)) +;;; (thread (muerte::clone-run-time-context :name name)) +;;; (segment-descriptor-table (symbol-value 'muerte.init::*segment-descriptor-table*))) +;;; (setf (segment-descriptor segment-descriptor-table fs-index) +;;; (segment-descriptor segment-descriptor-table (truncate (segment-register :fs) 8))) +;;; (setf (segment-descriptor-base-location segment-descriptor-table fs-index) +;;; (+ (object-location thread) (muerte::location-physical-offset))) +;;; (let ((cushion nil) +;;; (stack (control-stack-init-for-yield (make-array 4094 :element-type '(unsigned-byte 32)) +;;; function args))) +;;; (multiple-value-bind (ebp esp) +;;; (control-stack-fixate stack) +;;; (setf (control-stack-fs stack) fs +;;; (control-stack-ebp stack) ebp +;;; (control-stack-esp stack) esp)) +;;; (setf (%run-time-context-slot 'dynamic-env thread) 0 +;;; (%run-time-context-slot 'stack-vector thread) stack +;;; (%run-time-context-slot 'stack-top thread) (+ 2 (object-location stack) +;;; (length stack)) +;;; (%run-time-context-slot 'stack-bottom thread) (+ (object-location stack) 2 +;;; (or cushion +;;; (if (>= (length stack) 200) +;;; 100 +;;; 0)))) +;;; (values thread)))) (defun stack-bootstrapper (&rest ignore) (declare (ignore ignore))

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by ffjeld＠common-lisp.net 05 May '05

05 May '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv2314 Modified Files: image.lisp Log Message: re-arranged movitz-run-time-context a bit. Date: Thu May 5 00:47:59 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.94 movitz/image.lisp:1.95 --- movitz/image.lisp:1.94 Tue May 3 22:12:53 2005 +++ movitz/image.lisp Thu May 5 00:47:58 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.94 2005/05/03 20:12:53 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.95 2005/05/04 22:47:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,11 +22,6 @@ :initform :run-time-context) (padding :binary-type 3) - (name - :binary-type word - :initform :bootup - :map-binary-write 'movitz-read-and-intern - :map-binary-read-delayed 'movitz-word) (class :binary-type word :map-binary-write 'movitz-intern @@ -38,8 +33,14 @@ :map-binary-write 'movitz-read-and-intern :map-binary-read-delayed 'movitz-word :initarg :slots - :initform #() + :initform #(:init nil) :accessor run-time-context-slots) + (scratch1 + :binary-type word + :initform 0) + (scratch2 + :binary-type word + :initform 0) (fast-car :binary-type code-vector-word :initform nil @@ -58,12 +59,6 @@ :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) - (fast-cdddr - :binary-type code-vector-word - :initform nil - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function) (fast-car-ebx :binary-type code-vector-word :initform nil @@ -118,11 +113,6 @@ :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) - ;; per thread parameters - (dynamic-env - :binary-type word - :initform 0) - ;; More per-thread parameters (unwind-protect-tag :binary-type word :map-binary-read-delayed 'movitz-word @@ -133,6 +123,11 @@ :map-binary-read-delayed 'movitz-word :map-binary-write 'movitz-read-and-intern :initform 'muerte::restart-protect-tag) + (new-unbound-value + :binary-type word + :map-binary-read-delayed 'movitz-word + :map-binary-write 'movitz-read-and-intern + :initform 'unbound) (stack-bottom ; REMEMBER BOCHS! :binary-type word :initform #x0ff000) @@ -162,11 +157,6 @@ :binary-type movitz-symbol :reader movitz-run-time-context-null-symbol :initarg :null-symbol) - (new-unbound-value - :binary-type word - :map-binary-read-delayed 'movitz-word - :map-binary-write 'movitz-read-and-intern - :initform 'unbound) ;; primitive functions global constants (pop-current-values :binary-type code-vector-word @@ -288,21 +278,37 @@ :binary-tag :global-function :map-binary-write 'movitz-intern :map-binary-read-delayed 'movitz-word) - (complicated-class-of - :binary-type word - :binary-tag :global-function - :map-binary-read-delayed 'movitz-word - :map-binary-write 'movitz-intern) (complicated-compare :binary-type word :binary-tag :global-function :map-binary-read-delayed 'movitz-word :map-binary-write 'movitz-intern) + (dynamic-env + :binary-type word + :initform 0) + (the-class-t + :binary-type word + :initform t + :map-binary-write (lambda (x type) + (declare (ignore type)) + (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) + 'word)) + :map-binary-read-delayed 'movitz-word) + (copy-funobj + :binary-type word + ;; :accessor movitz-run-time-context-copy-funobj + :initform 'muerte::copy-funobj + :map-binary-write (lambda (name type) + (declare (ignore type)) + (movitz-intern (movitz-env-named-function name)))) + + (num-values :binary-type word ; Fixnum :initform 0) (values :binary-type #.(* 4 +movitz-multiple-values-limit+)) + (cons-pointer :binary-type code-vector-word :initform nil @@ -349,46 +355,6 @@ map)) 'word))) :map-binary-read-delayed 'movitz-word) - ;; Some well-known classes - (the-class-t - :binary-type word - :initform t - :map-binary-write (lambda (x type) - (declare (ignore type)) - (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) - 'word)) - :map-binary-read-delayed 'movitz-word) - (exception-handlers - :binary-type word - :map-binary-write 'movitz-intern - :map-binary-read-delayed 'movitz-word - :initarg :exception-handlers - :accessor movitz-run-time-context-exception-handlers) - (interrupt-descriptor-table - :binary-type word - :accessor movitz-run-time-context-interrupt-descriptor-table - :initform (make-array 256 :initial-element 'muerte::default-interrupt-trampoline) - :map-binary-read-delayed 'movitz-word - :map-binary-write 'map-interrupt-trampolines-to-idt) - (toplevel-funobj - :binary-type word - :initform nil - :accessor movitz-run-time-context-toplevel-funobj - :map-binary-write 'movitz-intern - :map-binary-read-delayed 'movitz-word) - (global-properties - :binary-type word - :initform nil - :accessor movitz-run-time-context-global-properties - :map-binary-write 'movitz-intern - :map-binary-read-delayed 'movitz-word) - (copy-funobj - :binary-type word - ;; :accessor movitz-run-time-context-copy-funobj - :initform 'muerte::copy-funobj - :map-binary-write (lambda (name type) - (declare (ignore type)) - (movitz-intern (movitz-env-named-function name)))) (physical-address-offset :binary-type lu32 :initform (image-ds-segment-base *image*)) @@ -399,22 +365,10 @@ :map-binary-read-delayed (lambda (x type) (declare (ignore x type)) (movitz-read nil))) - (stack-vector - :binary-type word - :initform nil - :map-binary-write 'movitz-read-and-intern - :map-binary-read-delayed (lambda (x type) - (declare (ignore x type)) - (movitz-read nil))) (self :binary-type word :initform 6 :map-binary-read-delayed 'movitz-word) - (parent - :binary-type word - :initform nil - :map-binary-write 'movitz-read-and-intern - :map-binary-read-delayed 'movitz-word) (protect-non-pointer-area :binary-type lu32 :initform 3) @@ -436,12 +390,6 @@ :binary-type lu32 :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 :binary-type code-vector-word :map-binary-write 'movitz-intern-code-vector @@ -456,7 +404,43 @@ :binary-type code-vector-word :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function)) + :binary-tag :primitive-function) + (complicated-class-of + :binary-type word + :binary-tag :global-function + :map-binary-read-delayed 'movitz-word + :map-binary-write 'movitz-intern) + (stack-vector + :binary-type word + :initform nil + :map-binary-write 'movitz-read-and-intern + :map-binary-read-delayed (lambda (x type) + (declare (ignore x type)) + (movitz-read nil))) + (exception-handlers + :binary-type word + :map-binary-write 'movitz-intern + :map-binary-read-delayed 'movitz-word + :initarg :exception-handlers + :accessor movitz-run-time-context-exception-handlers) + (interrupt-descriptor-table + :binary-type word + :accessor movitz-run-time-context-interrupt-descriptor-table + :initform (make-array 256 :initial-element 'muerte::default-interrupt-trampoline) + :map-binary-read-delayed 'movitz-word + :map-binary-write 'map-interrupt-trampolines-to-idt) + (toplevel-funobj + :binary-type word + :initform nil + :accessor movitz-run-time-context-toplevel-funobj + :map-binary-write 'movitz-intern + :map-binary-read-delayed 'movitz-word) + (global-properties + :binary-type word + :initform nil + :accessor movitz-run-time-context-global-properties + :map-binary-write 'movitz-intern + :map-binary-read-delayed 'movitz-word)) (:slot-align null-symbol -5)) (defun atomically-continuation-simple-pf (pf-name)

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 05 May '05

05 May '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv2290 Modified Files: compiler.lisp Log Message: Don't use fast-cdddr. Date: Thu May 5 00:47:39 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.137 movitz/compiler.lisp:1.138 --- movitz/compiler.lisp:1.137 Mon Apr 18 00:24:20 2005 +++ movitz/compiler.lisp Thu May 5 00:47:38 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.137 2005/04/17 22:24:20 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.138 2005/05/04 22:47:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2317,6 +2317,7 @@ (setq p `((:call (:edi ,(global-constant-offset newf)))) next-pc (nthcdr 2 pc)) (explain nil "Changed [~S ~S] to ~S" i i2 newf))) + #+ignore ((and (global-funcall-p i '(fast-cdr)) (global-funcall-p i2 '(fast-cdr)) (global-funcall-p i3 '(fast-cdr)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp
by ffjeld＠common-lisp.net 05 May '05

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2265 Modified Files: run-time-context.lisp Log Message: More dead code. Date: Thu May 5 00:47:18 2005 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.20 movitz/losp/muerte/run-time-context.lisp:1.21 --- movitz/losp/muerte/run-time-context.lisp:1.20 Wed May 4 09:43:27 2005 +++ movitz/losp/muerte/run-time-context.lisp Thu May 5 00:47:17 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.20 2005/05/04 07:43:27 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.21 2005/05/04 22:47:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,9 +28,7 @@ ((name :initarg :name :initform :anonymous - :accessor run-time-context-name) - (stack-vector - :initarg :stack-vector)) + :accessor run-time-context-name)) (:metaclass run-time-context-class) (:size #.(bt:sizeof 'movitz::movitz-run-time-context)) (:slot-map #.(movitz::slot-map 'movitz::movitz-run-time-context @@ -148,18 +146,18 @@ (%run-time-context-slot 'atomically-continuation context) 0) context)) -(defun %run-time-context-install-stack (context - &optional (control-stack - (make-array 8192 :element-type '(unsigned-byte 32))) - (cushion 1024)) - (check-type control-stack vector) - (assert (< cushion (array-dimension control-stack 0))) - (setf (%run-time-context-slot 'control-stack context) control-stack) - (setf (%run-time-context-slot 'stack-top context) - (+ (object-location control-stack) 8 - (* 4 (array-dimension control-stack 0)))) - (setf (%run-time-context-slot 'stack-bottom context) - (+ (object-location control-stack) 8 - (* 4 cushion))) - control-stack) +;;;(defun %run-time-context-install-stack (context +;;; &optional (control-stack +;;; (make-array 8192 :element-type '(unsigned-byte 32))) +;;; (cushion 1024)) +;;; (check-type control-stack vector) +;;; (assert (< cushion (array-dimension control-stack 0))) +;;; (setf (%run-time-context-slot 'control-stack context) control-stack) +;;; (setf (%run-time-context-slot 'stack-top context) +;;; (+ (object-location control-stack) 8 +;;; (* 4 (array-dimension control-stack 0)))) +;;; (setf (%run-time-context-slot 'stack-bottom context) +;;; (+ (object-location control-stack) 8 +;;; (* 4 cushion))) +;;; control-stack)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/cons.lisp
by ffjeld＠common-lisp.net 05 May '05

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2238 Modified Files: cons.lisp Log Message: Dead code. Date: Thu May 5 00:47:02 2005 Author: ffjeld Index: movitz/losp/muerte/cons.lisp diff -u movitz/losp/muerte/cons.lisp:1.9 movitz/losp/muerte/cons.lisp:1.10 --- movitz/losp/muerte/cons.lisp:1.9 Thu Feb 3 10:15:46 2005 +++ movitz/losp/muerte/cons.lisp Thu May 5 00:47:02 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.9 2005/02/03 09:15:46 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.10 2005/05/04 22:47:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -74,26 +74,6 @@ (:leal (:eax -1) :ecx) (:testb 3 :cl) (:jnz '(:sub-program () (:int 61))) - (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* - :movl (:eax 3) :eax) - (:ret))) - -(define-primitive-function fast-cdddr () - "This is the actual CDR code." - (with-inline-assembly (:returns :eax) - (:leal (:eax -1) :ecx) - (:testb 3 :cl) - (:jnz '(:sub-program (not-cons) (:int 61))) - (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* - :movl (:eax 3) :eax) - (:leal (:eax -1) :ecx) - (:testb 3 :cl) - (:jnz '(:sub-program (not-cons) (:int 61))) - (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* - :movl (:eax 3) :eax) - (:leal (:eax -1) :ecx) - (:testb 3 :cl) - (:jnz '(:sub-program (not-cons) (:int 61))) (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* :movl (:eax 3) :eax) (:ret)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp
by ffjeld＠common-lisp.net 05 May '05

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2199 Modified Files: inspect.lisp Log Message: Dead code. Date: Thu May 5 00:46:44 2005 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.51 movitz/losp/muerte/inspect.lisp:1.52 --- movitz/losp/muerte/inspect.lisp:1.51 Mon Apr 25 00:10:26 2005 +++ movitz/losp/muerte/inspect.lisp Thu May 5 00:46:44 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.51 2005/04/24 22:10:26 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.52 2005/05/04 22:46:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -53,10 +53,10 @@ (dit-frame-casf stack frame)) (t (stack-frame-ref stack frame 0)))) -(defun stack-vector-designator (stack) - (etypecase stack - (null (%run-time-context-slot 'stack-vector)) - (vector stack))) +;;;(defun stack-vector-designator (stack) +;;; (etypecase stack +;;; (null (%run-time-context-slot 'stack-vector)) +;;; (vector stack))) (define-compiler-macro current-stack-frame () `(with-inline-assembly (:returns :eax)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp
by ffjeld＠common-lisp.net 04 May '05

04 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23533 Modified Files: los-closette.lisp Log Message: Cleaned up print-unreadable-object and its usage a bit. Date: Wed May 4 10:00:42 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.30 movitz/losp/muerte/los-closette.lisp:1.31 --- movitz/losp/muerte/los-closette.lisp:1.30 Wed May 4 00:15:09 2005 +++ movitz/losp/muerte/los-closette.lisp Wed May 4 10:00:42 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.30 2005/05/03 22:15:09 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.31 2005/05/04 08:00:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1667,18 +1667,16 @@ (write object :stream stream))) (defmethod print-object ((object class) stream) - (print-unreadable-object (object stream :identity nil) - (format stream "~W ~W" (class-name (class-of object)) (class-name object))) + (print-unreadable-object (object stream :identity nil :type t) + (write (class-name object) :stream stream)) object) (defmethod print-object ((object standard-object) stream) - (print-unreadable-object (object stream :identity t) - (write (class-name (class-of object)) - :stream stream)) + (print-unreadable-object (object stream :identity t :type t)) object) (defmethod print-object ((object structure-object) stream) - (let* ((class (class-of object))) + (let ((class (class-of object))) (format stream "#S(~S" (class-name class)) (dolist (slot (class-slots class)) (format stream " :~A ~S" @@ -1704,8 +1702,9 @@ object) (defmethod print-object ((x illegal-object) stream) - (error "Won't print illegal-object ~Z." x) - ;; (print-unreadable-object (x stream :type t :identity t)) + (if *print-safely* + (print-unreadable-object (x stream :type t :identity t)) + (error "Won't print illegal-object ~Z." x)) x) ;;;

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/print.lisp
by ffjeld＠common-lisp.net 04 May '05

04 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23404 Modified Files: print.lisp Log Message: Cleaned up print-unreadable-object and its usage a bit. Date: Wed May 4 10:00:39 2005 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.18 movitz/losp/muerte/print.lisp:1.19 --- movitz/losp/muerte/print.lisp:1.18 Fri Feb 25 09:00:11 2005 +++ movitz/losp/muerte/print.lisp Wed May 4 10:00:39 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.18 2005/02/25 08:00:11 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.19 2005/05/04 08:00:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -46,12 +46,14 @@ (defvar *never-use-print-object* :after-clos-bootstrapped) -(defun init-print-unreadable (object stream &optional type-p) +(defun init-print-unreadable (object stream &optional type-p bodyless-p) (when *print-readably* (error 'print-not-readable :object object)) (write-string "#<" stream) (when type-p - (write (type-of object) :stream stream)) + (write (type-of object) :stream stream) + (unless bodyless-p + (write-char #\space stream))) nil) (defmacro print-unreadable-object ((object stream &key type identity) &body body) @@ -60,7 +62,8 @@ `(let ((,stream-var ,stream) (,object-var ,object)) (init-print-unreadable ,object-var ,stream-var - ,@(when type (list type))) + ,@(when type (list type)) + ,@(when (and type (null body)) (list t))) ,@body ,(when identity `(when ,identity @@ -194,7 +197,7 @@ (handler-case (internal-write object) (serious-condition (c) (print-unreadable-object (c *standard-output* :type t :identity t) - (format t " (while printing ~Z)" object)))))))) + (format t "(while printing ~Z)" object)))))))) (defun internal-write (object) (let ((stream *standard-output*)) @@ -311,8 +314,7 @@ (write-char #\space stream)) (write (aref object i))) (write-char #\) stream)))) - (t (print-unreadable-object (object stream :identity t) - (princ (type-of object) stream)))))) + (t (print-unreadable-object (object stream :identity t :type t)))))) (standard-gf-instance (print-unreadable-object (object stream) (format stream "gf ~S" (funobj-name object))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp
by ffjeld＠common-lisp.net 04 May '05

04 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21525 Modified Files: run-time-context.lisp Log Message: *** empty log message *** Date: Wed May 4 09:43:27 2005 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.19 movitz/losp/muerte/run-time-context.lisp:1.20 --- movitz/losp/muerte/run-time-context.lisp:1.19 Wed May 4 08:17:21 2005 +++ movitz/losp/muerte/run-time-context.lisp Wed May 4 09:43:27 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.19 2005/05/04 06:17:21 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.20 2005/05/04 07:43:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -27,6 +27,7 @@ (defclass run-time-context (t) ((name :initarg :name + :initform :anonymous :accessor run-time-context-name) (stack-vector :initarg :stack-vector)) @@ -92,8 +93,8 @@ (let ((slot-location (slot-definition-location slot))) (check-type slot-location positive-fixnum) (lambda (instance) - (unbound-protect (svref (%run-time-context-slot 'slots instance) slot-location) - (slot-unbound-trampoline instance slot-location))))) + (with-unbound-protect (svref (%run-time-context-slot 'slots instance) slot-location) + (slot-unbound-trampoline instance slot-location))))) (defmethod compute-effective-slot-writer ((class run-time-context-class) slot) (let ((slot-location (slot-definition-location slot))) @@ -104,7 +105,7 @@ (defmethod print-object ((x run-time-context) stream) (print-unreadable-object (x stream :type t :identity t) - (format stream " ~S" (%run-time-context-slot 'name x))) + (format stream "~S" (run-time-context-name x))) x) ;;; @@ -142,7 +143,7 @@ (name :anonymous)) (check-type parent run-time-context) (let ((context (%shallow-copy-object parent (movitz-type-word-size 'movitz-run-time-context)))) - (setf (%run-time-context-slot 'name context) name + (setf (%run-time-context-slot 'slots context) (copy-seq (%run-time-context-slot 'slots parent)) (%run-time-context-slot 'self context) context (%run-time-context-slot 'atomically-continuation context) 0) context))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp
by ffjeld＠common-lisp.net 04 May '05

04 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15096 Modified Files: run-time-context.lisp Log Message: Use with-unbound-protect. Date: Wed May 4 08:17:21 2005 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.18 movitz/losp/muerte/run-time-context.lisp:1.19 --- movitz/losp/muerte/run-time-context.lisp:1.18 Tue May 3 23:25:34 2005 +++ movitz/losp/muerte/run-time-context.lisp Wed May 4 08:17:21 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.18 2005/05/03 21:25:34 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.19 2005/05/04 06:17:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -39,11 +39,9 @@ (defmethod slot-value-using-class ((class run-time-context-class) object (slot standard-effective-slot-definition)) - (let ((x (svref (%run-time-context-slot 'slots object) - (slot-definition-location slot)))) - (if (eq x (load-global-constant new-unbound-value)) - (slot-unbound class object (slot-definition-name slot)) - x))) + (with-unbound-protect (svref (%run-time-context-slot 'slots object) + (slot-definition-location slot)) + (slot-unbound class object (slot-definition-name slot)))) (defmethod (setf slot-value-using-class) (new-value (class run-time-context-class) object (slot standard-effective-slot-definition))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp
by ffjeld＠common-lisp.net 04 May '05

04 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6026 Modified Files: basic-macros.lisp Log Message: Let's rename it with-unbound-protect. Date: Wed May 4 00:15:38 2005 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.60 movitz/losp/muerte/basic-macros.lisp:1.61 --- movitz/losp/muerte/basic-macros.lisp:1.60 Tue May 3 23:25:30 2005 +++ movitz/losp/muerte/basic-macros.lisp Wed May 4 00:15:38 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.60 2005/05/03 21:25:30 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.61 2005/05/03 22:15:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -690,7 +690,7 @@ (t form))) -(defmacro unbound-protect (x &optional error-continuation &environment env) +(defmacro with-unbound-protect (x &body error-continuation &environment env) (cond ((movitz:movitz-constantp x env) `(values ,x)) @@ -700,14 +700,14 @@ (:compile-form (:result-mode :register) ,x) (:cmpl -1 (:result-register)) (:jo '(:sub-program (unbound) - (:compile-form (:result-mode :eax) ,error-continuation) + (:compile-form (:result-mode :eax) (progn ,@error-continuation)) (:jmp ',unbound-continue))) ,unbound-continue))) (t (let ((var (gensym))) `(let ((,var ,x)) (if (not (eq ,var (load-global-constant new-unbound-value))) ,var - ,error-continuation)))))) + (progn ,@error-continuation))))))) (define-compiler-macro current-run-time-context () `(with-inline-assembly (:returns :register)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp
by ffjeld＠common-lisp.net 04 May '05

04 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5864 Modified Files: los-closette.lisp Log Message: Let's rename it with-unbound-protect. Date: Wed May 4 00:15:10 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.29 movitz/losp/muerte/los-closette.lisp:1.30 --- movitz/losp/muerte/los-closette.lisp:1.29 Tue May 3 23:34:57 2005 +++ movitz/losp/muerte/los-closette.lisp Wed May 4 00:15:09 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.29 2005/05/03 21:34:57 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.30 2005/05/03 22:15:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -926,25 +926,6 @@ (define-effective-slot-reader standard-effective-slot-reader%6 6) (define-effective-slot-reader standard-effective-slot-reader%7 7) - -#+ignore -(defun compute-effective-slot-writer (class slot-definition) - (let* ((slot-name (slot-definition-name slot-definition)) - (slot (find-slot class slot-name))) - (assert slot (slot-name) - "No slot named ~S in class ~S." slot-name class) - (let ((slot-location (slot-definition-location slot))) - (assert slot-location) - (etypecase class - (standard-class - (lambda (value instance) - (setf (standard-instance-access instance slot-location) - value))) - (funcallable-standard-class - (lambda (value instance) - (setf (svref (std-gf-instance-slots instance) slot-location) - value))))))) - (defun make-emfun (method next-emf) "Make an effective method function from method that will have next-emf as its target for call-next-method." @@ -1262,23 +1243,20 @@ (return slot)))) (defun std-slot-value (instance slot-name) + "Used while bootstrapping." (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 new-unbound-value) val) - (error "The slot ~S is unbound in the object ~S." - slot-name instance) - val))) + (slots (std-instance-slots instance))) + (with-unbound-protect (svref slots location) + (error "The slot ~S is unbound in the object ~S." + slot-name instance)))) (defun std-gf-slot-value (instance slot-name) (let ((slot (find-slot (std-gf-instance-class instance) slot-name t))) (let* ((location (slot-definition-location slot)) - (slots (std-gf-instance-slots instance)) - (val (svref slots location))) - (if (eq (load-global-constant new-unbound-value) val) - (error "The slot ~S is unbound in the object ~S." - slot-name instance) - val)))) + (slots (std-gf-instance-slots instance))) + (with-unbound-protect (svref slots location) + (error "The slot ~S is unbound in the object ~S." + slot-name instance))))) (defun slot-value (object slot-name) (let* ((class (class-of object)) @@ -1289,19 +1267,15 @@ (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 new-unbound-value)) - (slot-unbound class object (slot-definition-name slot)) - x))) + (with-unbound-protect (standard-instance-access object (slot-definition-location slot)) + (slot-unbound class object (slot-definition-name slot)))) (defmethod slot-value-using-class ((class funcallable-standard-class) object (slot standard-effective-slot-definition)) (let* ((location (slot-definition-location slot)) - (slots (std-gf-instance-slots object)) - (val (svref slots location))) - (if (eq (load-global-constant new-unbound-value) val) - (slot-unbound class object (slot-definition-name slot)) - val))) + (slots (std-gf-instance-slots object))) + (with-unbound-protect (svref slots location) + (slot-unbound class object (slot-definition-name slot))))) (defmethod slot-value-using-class ((class structure-class) object slot) (structure-ref object (structure-slot-location slot))) @@ -1415,15 +1389,15 @@ (svref *standard-effective-slot-readers* slot-location)) (symbol-function (svref *standard-effective-slot-readers* slot-location)) (lambda (instance) - (unbound-protect (standard-instance-access instance slot-location) - (slot-unbound-trampoline instance slot-location)))))) + (with-unbound-protect (standard-instance-access instance slot-location) + (slot-unbound-trampoline instance slot-location)))))) (defmethod compute-effective-slot-reader ((class funcallable-standard-class) slot) (let ((slot-location (slot-definition-location slot))) (check-type slot-location positive-fixnum) (lambda (instance) - (unbound-protect (svref (std-gf-instance-slots instance) slot-location) - (slot-unbound-trampoline instance slot-location))))) + (with-unbound-protect (svref (std-gf-instance-slots instance) slot-location) + (slot-unbound-trampoline instance slot-location))))) (defmethod compute-effective-slot-writer ((class standard-class) slot) (let ((slot-location (slot-definition-location slot))) @@ -1757,10 +1731,8 @@ (location (get class-name slot-name))) ;; (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 new-unbound-value)) - (error "The slot ~S is unbound in the ~S ~Z." slot-name class-name slot) - x)))) + (with-unbound-protect (standard-instance-access slot location) + (error "The slot ~S is unbound in the ~S ~Z." slot-name class-name slot)))) (defun bootstrap-class-name (class) (standard-instance-access class 0)) @@ -1849,8 +1821,7 @@ (std-slot-value method 'function))) (method-specializers (lambda (method) - (std-slot-value method 'specializers))) - ) + (std-slot-value method 'specializers)))) (case (funobj-name gf) ((compute-applicable-methods-using-classes) (std-compute-applicable-methods-using-classes gf classes))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp
by ffjeld＠common-lisp.net 03 May '05

03 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2499 Modified Files: los-closette.lisp Log Message: Minor edits. Date: Tue May 3 23:34:58 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.28 movitz/losp/muerte/los-closette.lisp:1.29 --- movitz/losp/muerte/los-closette.lisp:1.28 Tue May 3 22:07:50 2005 +++ movitz/losp/muerte/los-closette.lisp Tue May 3 23:34:57 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.28 2005/05/03 20:07:50 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.29 2005/05/03 21:34:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -877,12 +877,11 @@ (with-inline-assembly (:returns :multiple-values) (:compile-form (:result-mode :eax) instance) (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* - :movl (:eax (:offset movitz-std-instance slots)) - :eax) + :movl (:eax (:offset movitz-std-instance slots)) :eax) (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* :movl (:eax (:offset movitz-basic-vector data ,(* location 4))) :eax) (#.movitz:*compiler-global-segment-prefix* - :cmpl -1 :eax) + :cmpl -1 :eax) (:jo '(:sub-program (unbound) (:compile-form (:result-mode :multiple-values) (slot-unbound-trampoline instance ,location)) @@ -893,8 +892,7 @@ (with-inline-assembly (:returns :multiple-values) (:compile-form (:result-mode :eax) instance) (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* - :movl (:eax (:offset movitz-std-instance slots)) - :eax) + :movl (:eax (:offset movitz-std-instance slots)) :eax) (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* :movl (:eax (:offset movitz-basic-vector data ,(* location 4))) :eax) (#.movitz:*compiler-global-segment-prefix* @@ -973,10 +971,6 @@ (defclass sequence (t) () (:metaclass built-in-class)) (defclass array (t) () (:metaclass built-in-class)) (defclass character (t) () (:metaclass built-in-class)) -;;;(defclass hash-table (t) () (:metaclass built-in-class)) -;;;(defclass package (t) () (:metaclass built-in-class)) -;;;(defclass pathname (t) () (:metaclass built-in-class)) -;;;(defclass readtable (t) () (:metaclass built-in-class)) (defclass list (sequence) () (:metaclass built-in-class)) (defclass null (symbol list) () (:metaclass built-in-class)) (defclass cons (list) () (:metaclass built-in-class)) @@ -1001,15 +995,6 @@ (defclass infant-object (t) () (:metaclass built-in-class)) (defclass unbound-value (t) () (:metaclass built-in-class)) -;;;(defclass run-time-context (t) -;;; () -;;; (:metaclass built-in-class) -;;; (:size #.(bt:sizeof 'movitz::movitz-run-time-context)) -;;; (:slot-map #.(movitz::slot-map 'movitz::movitz-run-time-context -;;; (cl:+ (bt:slot-offset 'movitz::movitz-run-time-context -;;; 'movitz::run-time-context-start) -;;; 0)))) - (defclass stream () ()) ;;; @@ -1080,7 +1065,6 @@ (define-slot-writer-method (setf class-prototype-value) (class prototype)) (defmethod class-slots ((class class)) nil) -;; (defmethod class-slots ((class std-slotted-class)) nil) (define-slot-reader-method method-optional-arguments-p (standard-method optional-arguments-p)) (define-slot-reader-method method-function (standard-method function)) @@ -1091,9 +1075,6 @@ (defmethod method-lambda-list ((method standard-method)) (funobj-lambda-list (method-function method))) -;;;(define-slot-reader-method generic-function-name (standard-generic-function name)) -;;;(define-slot-reader-method generic-function-lambda-list (standard-generic-function lambda-list)) - ;;;; (defclass structure-class (class) @@ -1463,11 +1444,6 @@ ;;; compute-applicable-methods-using-classes (defun std-compute-applicable-methods-using-classes (gf classes) - #+ignore (warn "camuc of: ~S for classes ~S" - (funobj-name gf) - (mapcar (lambda (c) - (standard-instance-access c 0)) - classes)) (flet ((method-specific< (method1 method2) (do ((cspec1 (method-specializers method1) (cdr cspec1)) (cspec2 (method-specializers method2) (cdr cspec2)) @@ -1551,7 +1527,6 @@ (defun std-compute-effective-method-function (gf methods) (declare (ignore gf)) - ;; (warn "comp-eff-mf for ~S" (funobj-name gf)) (list 'standard-combine methods)) (defmethod compute-effective-method ((generic-function standard-generic-function)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp
by ffjeld＠common-lisp.net 03 May '05

03 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1341 Modified Files: run-time-context.lisp Log Message: Minor cleanup. Date: Tue May 3 23:25:34 2005 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.17 movitz/losp/muerte/run-time-context.lisp:1.18 --- movitz/losp/muerte/run-time-context.lisp:1.17 Tue May 3 22:10:35 2005 +++ movitz/losp/muerte/run-time-context.lisp Tue May 3 23:25:34 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.17 2005/05/03 20:10:35 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.18 2005/05/03 21:25:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,10 +20,6 @@ (in-package muerte) -(define-compiler-macro current-run-time-context () - `(with-inline-assembly (:returns :register) - (:locally (:movl (:edi (:edi-offset self)) (:result-register))))) - ;;;; (defclass run-time-context-class (std-slotted-class built-in-class) ()) @@ -144,43 +140,6 @@ (code-vector-word (setf (memref context -6 :index (third slot) :type :code-vector) value))))) -(defun %run-time-context-segment-base (slot-name - &optional (context (current-run-time-context))) - (check-type context run-time-context) - (let ((slot (find-run-time-context-slot context slot-name))) - (ecase (second slot) - (segment-descriptor - (let ((index8 (* 4 (third slot))) - (index16 (* 2 (third slot)))) - (+ (memref context (+ -6 2) :index index16 :type :unsigned-byte16) - (ash (memref context (+ -6 4) :index index8 :type :unsigned-byte8) 16) - (ash (memref context (+ -6 7) :index index8 :type :unsigned-byte8) 24))))))) - -(defun (setf %run-time-context-segment-base) (value slot-name - &optional (context (current-run-time-context))) - (check-type context run-time-context) - (let ((slot (find-run-time-context-slot context slot-name))) - (ecase (second slot) - (segment-descriptor - (let ((index8 (* 4 (third slot))) - (index16 (* 2 (third slot)))) - (setf (memref context (+ -6 2) :index index16 :type :unsigned-byte16) (ldb (byte 16 0) value) - (memref context (+ -6 4) :index index8 :type :unsigned-byte8) (ldb (byte 8 16) value) - (memref context (+ -6 7) :index index8 :type :unsigned-byte8) (ldb (byte 6 24) value))))) - value)) - -(defun %run-time-context-ref (edi-offset) - "Get a run-time-context slot by its EDI-relative offset." - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) edi-offset) - (:leal (:eax #.(cl:* 1 movitz:+movitz-fixnum-factor+)) :ecx) - (:sarl #.movitz:+movitz-fixnum-shift+ :ecx) - (:testb 3 :cl) - (:jnz '(:sub-program () - (:compile-form (:result-mode :ignore) - (error "Illegal edi-offset ~S" edi-offset)))) - (:locally (:movl (:edi :ecx -1) :eax)))) - (defun clone-run-time-context (&key (parent (current-run-time-context)) (name :anonymous)) (check-type parent run-time-context) @@ -189,21 +148,6 @@ (%run-time-context-slot 'self context) context (%run-time-context-slot 'atomically-continuation context) 0) context)) - -;;;(defun switch-to-context (context) -;;; (check-type context run-time-context) -;;; (with-inline-assembly (:returns :nothing) -;;; (:compile-form (:result-mode :eax) context) -;;; (:movw #.(cl:1- (cl:* 8 8)) (:esp -6)) -;;; (:addl #.(cl:+ -6 (movitz::global-constant-offset 'movitz::segment-descriptor-table)) -;;; :eax) -;;; (:addl :edi :eax) -;;; (:locally (:addl (:edi (:edi-offset physical-address-offset)) :eax)) -;;; (:movl :eax (:esp -4)) -;;; (:lgdt (:esp -6)) -;;; (:movw #x28 :ax) -;;; (:movw :ax :fs) -;;; (:locally (:movl (:edi (:edi-offset self)) :eax)))) (defun %run-time-context-install-stack (context &optional (control-stack

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp
by ffjeld＠common-lisp.net 03 May '05

03 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1322 Modified Files: basic-macros.lisp Log Message: Minor cleanup. Date: Tue May 3 23:25:30 2005 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.59 movitz/losp/muerte/basic-macros.lisp:1.60 --- movitz/losp/muerte/basic-macros.lisp:1.59 Mon May 2 23:33:29 2005 +++ movitz/losp/muerte/basic-macros.lisp Tue May 3 23:25:30 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.59 2005/05/02 21:33:29 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.60 2005/05/03 21:25:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -708,6 +708,10 @@ (if (not (eq ,var (load-global-constant new-unbound-value))) ,var ,error-continuation)))))) + +(define-compiler-macro current-run-time-context () + `(with-inline-assembly (:returns :register) + (:locally (:movl (:edi (:edi-offset self)) (:result-register))))) #+ignore (define-compiler-macro apply (&whole form function &rest args)

1 0

[movitz-cvs] CVS update: movitz/losp/los0.lisp
by ffjeld＠common-lisp.net 03 May '05

03 May '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv27492 Modified Files: los0.lisp Log Message: *** empty log message *** Date: Tue May 3 22:13:09 2005 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.40 movitz/losp/los0.lisp:1.41 --- movitz/losp/los0.lisp:1.40 Sun Apr 24 18:46:03 2005 +++ movitz/losp/los0.lisp Tue May 3 22:13:07 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.40 2005/04/24 16:46:03 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.41 2005/05/03 20:13:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1317,35 +1317,13 @@ data))) (muerte.ip4:tftp/ethernet-write :129.242.19.132 "movitz-screendump.txt" data :quiet t - :mac (muerte.ip4::polling-arp ip4::*ip4-router* - (lambda () - (eql #\escape (muerte.x86-pc.keyboard:poll-char))))))) - -(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)) + :mac (muerte.ip4::polling-arp + muerte.ip4::*ip4-router* + (lambda () + (eql #\escape (muerte.x86-pc.keyboard:poll-char))))))) (defvar *segment-descriptor-table*) -(defun threading () - (let* ((thread (muerte::clone-run-time-context :name 'subthread)) - (stack (make-array 1022 :element-type '(unsigned-byte 32)))) - (setf (segment-descriptor *segment-descriptor-table* 8) - (segment-descriptor *segment-descriptor-table* (truncate (segment-register :fs) 8))) - (warn "Thread ~S FS base: ~S" - thread - (setf (segment-descriptor-base-location *segment-descriptor-table* 8) - (+ (object-location thread) - (muerte::location-physical-offset)))) - (format *terminal-io* "~&Switching...") - (setf (segment-register :fs) (* 8 8)) - (format *terminal-io* "ok.~%") - (values thread stack))) (defun genesis () ;; (install-shallow-binding) @@ -1358,7 +1336,7 @@ (format t "Extended memory: ~D KB~%" extended-memsize) (idt-init) - + (setf *segment-descriptor-table* ; Ensure we have a GDT with 16 entries, in static-space. (muerte::install-global-segment-table (muerte::dump-global-segment-table :entries 16)))

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by ffjeld＠common-lisp.net 03 May '05

03 May '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv27472 Modified Files: image.lisp Log Message: *** empty log message *** Date: Tue May 3 22:12:53 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.93 movitz/image.lisp:1.94 --- movitz/image.lisp:1.93 Sun May 1 01:22:14 2005 +++ movitz/image.lisp Tue May 3 22:12:53 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.93 2005/04/30 23:22:14 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.94 2005/05/03 20:12:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1586,6 +1586,7 @@ (array expr) (cons (mapcar #'movitz-print expr)) ((or (satisfies movitz-null) movitz-run-time-context) nil) + (movitz-unbound-value 'unbound) (movitz-fixnum (movitz-fixnum-value expr)) (movitz-std-instance expr)

1 0

[movitz-cvs] CVS update: movitz/stream-image.lisp
by ffjeld＠common-lisp.net 03 May '05

03 May '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv27452 Modified Files: stream-image.lisp Log Message: *** empty log message *** Date: Tue May 3 22:12:43 2005 Author: ffjeld Index: movitz/stream-image.lisp diff -u movitz/stream-image.lisp:1.12 movitz/stream-image.lisp:1.13 --- movitz/stream-image.lisp:1.12 Wed Apr 20 08:51:57 2005 +++ movitz/stream-image.lisp Tue May 3 22:12:42 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Aug 27 14:46:50 2001 ;;;; -;;;; $Id: stream-image.lisp,v 1.12 2005/04/20 06:51:57 ffjeld Exp $ +;;;; $Id: stream-image.lisp,v 1.13 2005/05/03 20:12:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -70,9 +70,12 @@ (image-nil-object image)) (:symbol ;; (warn "loading new symbol at ~S" word) - (setf (image-stream-position image) - (- word (tag :symbol))) - (read-binary 'movitz-symbol (image-stream image))) + (if (= word #x7fffffff) + (make-instance 'movitz-unbound-value) + (progn + (setf (image-stream-position image) + (- word (tag :symbol))) + (read-binary 'movitz-symbol (image-stream image))))) (:other (setf (image-stream-position image) (+ 0 (extract-pointer word)))

1 0

[movitz-cvs] CVS update: movitz/procfs-image.lisp
by ffjeld＠common-lisp.net 03 May '05

03 May '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv27398 Modified Files: procfs-image.lisp Log Message: *** empty log message *** Date: Tue May 3 22:11:44 2005 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.23 movitz/procfs-image.lisp:1.24 --- movitz/procfs-image.lisp:1.23 Sun Apr 24 22:36:44 2005 +++ movitz/procfs-image.lisp Tue May 3 22:11:43 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.23 2005/04/24 20:36:44 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.24 2005/05/03 20:11:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -130,7 +130,9 @@ (map 'vector #'movitz-print (movitz-vector-symbolic-data expr))) (movitz-cons (cons (movitz-print (movitz-car expr)) - (movitz-print (movitz-cdr expr)))))) + (movitz-print (movitz-cdr expr)))) + (movitz-funobj + expr))) (defmethod report-gdtr ((image bochs-image))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp
by ffjeld＠common-lisp.net 03 May '05

03 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27348 Modified Files: run-time-context.lisp Log Message: We now have a run-time-context-class metaclass, so that run-time-context can act as a CLOS instance. Date: Tue May 3 22:10:36 2005 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.16 movitz/losp/muerte/run-time-context.lisp:1.17 --- movitz/losp/muerte/run-time-context.lisp:1.16 Wed Apr 27 01:43:56 2005 +++ movitz/losp/muerte/run-time-context.lisp Tue May 3 22:10:35 2005 @@ -10,11 +10,12 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.16 2005/04/26 23:43:56 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.17 2005/05/03 20:10:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (require :muerte/basic-macros) +(require :muerte/los-closette) (provide :muerte/run-time-context) (in-package muerte) @@ -23,6 +24,97 @@ `(with-inline-assembly (:returns :register) (:locally (:movl (:edi (:edi-offset self)) (:result-register))))) +;;;; + +(defclass run-time-context-class (std-slotted-class built-in-class) ()) + +(defclass run-time-context (t) + ((name + :initarg :name + :accessor run-time-context-name) + (stack-vector + :initarg :stack-vector)) + (:metaclass run-time-context-class) + (:size #.(bt:sizeof 'movitz::movitz-run-time-context)) + (:slot-map #.(movitz::slot-map 'movitz::movitz-run-time-context + (cl:+ (bt:slot-offset 'movitz::movitz-run-time-context + 'movitz::run-time-context-start) + 0)))) + +(defmethod slot-value-using-class ((class run-time-context-class) object + (slot standard-effective-slot-definition)) + (let ((x (svref (%run-time-context-slot 'slots object) + (slot-definition-location slot)))) + (if (eq x (load-global-constant new-unbound-value)) + (slot-unbound class object (slot-definition-name slot)) + x))) + +(defmethod (setf slot-value-using-class) (new-value (class run-time-context-class) object + (slot standard-effective-slot-definition)) + (let ((location (slot-definition-location slot)) + (slots (%run-time-context-slot 'slots object))) + (setf (svref slots location) new-value))) + +(defmethod slot-boundp-using-class ((class run-time-context-class) object + (slot standard-effective-slot-definition)) + (not (eq (load-global-constant new-unbound-value) + (svref (%run-time-context-slot 'slots object) + (slot-definition-location slot))))) + +(defmethod allocate-instance ((class run-time-context-class) &rest initargs) + (declare (dynamic-extent initargs) (ignore initargs)) + (let ((x (clone-run-time-context))) + (setf (%run-time-context-slot 'class x) class) + (setf (%run-time-context-slot 'slots x) + (allocate-slot-storage (count-if 'instance-slot-p (class-slots class)) + (load-global-constant new-unbound-value))) + x)) + +(defmethod initialize-instance ((instance run-time-context) &rest initargs) + (declare (dynamic-extent initargs)) + (apply 'shared-initialize instance t initargs)) + +(defmethod shared-initialize ((instance run-time-context) slot-names &rest all-keys) + (declare (dynamic-extent all-keys)) + (dolist (slot (class-slots (class-of instance))) + (let ((slot-name (slot-definition-name slot))) + (multiple-value-bind (init-key init-value foundp) + (get-properties all-keys (slot-definition-initargs slot)) + (declare (ignore init-key)) + (if foundp + (setf (slot-value instance slot-name) init-value) + (when (and (not (slot-boundp instance slot-name)) + (not (null (slot-definition-initfunction slot))) + (or (eq slot-names t) + (member slot-name slot-names))) + (let ((initfunction (slot-definition-initfunction slot))) + (setf (slot-value instance slot-name) + (etypecase initfunction + (cons (cadr initfunction)) ; '(quote <obj>) + (function (funcall initfunction)))))))))) + instance) + +(defmethod compute-effective-slot-reader ((class run-time-context-class) slot) + (let ((slot-location (slot-definition-location slot))) + (check-type slot-location positive-fixnum) + (lambda (instance) + (unbound-protect (svref (%run-time-context-slot 'slots instance) slot-location) + (slot-unbound-trampoline instance slot-location))))) + +(defmethod compute-effective-slot-writer ((class run-time-context-class) slot) + (let ((slot-location (slot-definition-location slot))) + (check-type slot-location positive-fixnum) + (lambda (value instance) + (setf (svref (%run-time-context-slot 'slots instance) slot-location) + value)))) + +(defmethod print-object ((x run-time-context) stream) + (print-unreadable-object (x stream :type t :identity t) + (format stream " ~S" (%run-time-context-slot 'name x))) + x) + +;;; + (defun current-run-time-context () (current-run-time-context)) @@ -40,27 +132,6 @@ (memref context -6 :index (third slot) :type :code-vector)) (lu32 (memref context -6 :index (third slot) :type :unsigned-byte32))))) - -(define-compiler-macro (setf %run-time-context-slot) (&whole form &environment env value slot-name - &optional (context '(current-run-time-context))) - (if (not (and (movitz:movitz-constantp slot-name env) - (equal context '(current-run-time-context)))) - form - (let ((slot-name (movitz:movitz-eval slot-name env))) - (ecase (bt:binary-slot-type 'movitz::movitz-run-time-context (intern (symbol-name slot-name) :movitz)) - (movitz:word - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) ,value) - (:locally (:movl :eax (:edi (:edi-offset ,slot-name)))))) - (movitz:lu32 - `(with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-form (:result-mode :untagged-fixnum-ecx) ,value) - (:locally (:movl :ecx (:edi (:edi-offset ,slot-name)))))) - (movitz:code-vector-word - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) ,value) - (:leal (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) :ecx) - (:locally (:movl :ecx (:edi (:edi-offset ,slot-name)))))))))) (defun (setf %run-time-context-slot) (value slot-name &optional (context (current-run-time-context))) (check-type context run-time-context)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp
by ffjeld＠common-lisp.net 03 May '05

03 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27309 Modified Files: more-macros.lisp Log Message: Compiler-macro for %run-time-context-slot. Date: Tue May 3 22:09:50 2005 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.24 movitz/losp/muerte/more-macros.lisp:1.25 --- movitz/losp/muerte/more-macros.lisp:1.24 Tue Jan 4 17:56:19 2005 +++ movitz/losp/muerte/more-macros.lisp Tue May 3 22:09:50 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.24 2005/01/04 16:56:19 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.25 2005/05/03 20:09:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -331,22 +331,65 @@ (define-compiler-macro %run-time-context-slot (&whole form &environment env slot-name &optional (context '(current-run-time-context))) + (if (not (and (movitz:movitz-constantp slot-name env))) + form + (let* ((slot-name (movitz::eval-form slot-name env)) + (slot-type (bt:binary-slot-type 'movitz::movitz-run-time-context + (intern (symbol-name slot-name) :movitz)))) + (if (equal context '(current-run-time-context)) + (ecase slot-type + (movitz::word + `(with-inline-assembly (:returns :eax) + (:locally (:movl (:edi (:edi-offset ,slot-name)) :eax)))) + (movitz::code-vector-word + `(with-inline-assembly (:returns :eax) + (:movl ,(ldb (byte 32 0) (- movitz::+code-vector-word-offset+)) :eax) + (:locally (:addl (:edi (:edi-offset ,slot-name)) :eax)))) + (movitz::lu32 + `(with-inline-assembly (:returns :untagged-fixnum-ecx) + (:locally (:movl (:edi (:edi-offset ,slot-name)) :ecx))))) + (ecase slot-type + (movitz::word + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) ,context) + (,movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :movl (:eax :edi (:offset movitz-run-time-context ,slot-name + ,(- (movitz:tag :other)))) :eax))) + (movitz::code-vector-word + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) ,context) + (:movl ,(ldb (byte 32 0) (- movitz::+code-vector-word-offset+)) :eax) + (,movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :addl (:eax :edi (:offset movitz-run-time-context ,slot-name + ,(- (movitz:tag :other)))) :eax))) + (movitz::lu32 + `(with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-form (:result-mode :eax) ,context) + (,movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :movl (:eax :edi (:offset movitz-run-time-context ,slot-name + ,(- (movitz:tag :other)))) :ecx)))))))) + + +(define-compiler-macro (setf %run-time-context-slot) (&whole form &environment env value slot-name + &optional (context '(current-run-time-context))) (if (not (and (movitz:movitz-constantp slot-name env) (equal context '(current-run-time-context)))) form - (let ((slot-name (movitz::eval-form slot-name env))) - (ecase (bt:binary-slot-type 'movitz::movitz-run-time-context - (intern (symbol-name slot-name) :movitz)) - (movitz::word + (let ((slot-name (movitz:movitz-eval slot-name env))) + (ecase (bt:binary-slot-type 'movitz::movitz-run-time-context (intern (symbol-name slot-name) :movitz)) + (movitz:word `(with-inline-assembly (:returns :eax) - (:locally (:movl (:edi (:edi-offset ,slot-name)) :eax)))) - (movitz::code-vector-word - `(with-inline-assembly (:returns :eax) - (:movl ,(ldb (byte 32 0) (- movitz::+code-vector-word-offset+)) :eax) - (:locally (:addl (:edi (:edi-offset ,slot-name)) :eax)))) - (movitz::lu32 + (:compile-form (:result-mode :eax) ,value) + (:locally (:movl :eax (:edi (:edi-offset ,slot-name)))))) + (movitz:lu32 `(with-inline-assembly (:returns :untagged-fixnum-ecx) - (:locally (:movl (:edi (:edi-offset ,slot-name)) :ecx)))))))) + (:compile-form (:result-mode :untagged-fixnum-ecx) ,value) + (:locally (:movl :ecx (:edi (:edi-offset ,slot-name)))))) + (movitz:code-vector-word + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) ,value) + (:leal (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) :ecx) + (:locally (:movl :ecx (:edi (:edi-offset ,slot-name)))))))))) (define-compiler-macro read-time-stamp-counter () `(with-inline-assembly-case ()

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/common-lisp.lisp
by ffjeld＠common-lisp.net 03 May '05

03 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27254 Modified Files: common-lisp.lisp Log Message: Do run-time-context after los-closette. Date: Tue May 3 22:08:15 2005 Author: ffjeld Index: movitz/losp/muerte/common-lisp.lisp diff -u movitz/losp/muerte/common-lisp.lisp:1.12 movitz/losp/muerte/common-lisp.lisp:1.13 --- movitz/losp/muerte/common-lisp.lisp:1.12 Tue Jul 27 15:54:07 2004 +++ movitz/losp/muerte/common-lisp.lisp Tue May 3 22:08:14 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, 2002-2004, +;;;; Copyright (C) 20012000, 2002-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: common-lisp.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:41:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: common-lisp.lisp,v 1.12 2004/07/27 13:54:07 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.13 2005/05/03 20:08:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -30,11 +30,11 @@ (require :muerte/characters) (require :muerte/arrays) (require :muerte/sequences) -(require :muerte/run-time-context) (require :muerte/inspect) (require :muerte/strings) (require :muerte/print) (require :muerte/los-closette) +(require :muerte/run-time-context) (require :muerte/defstruct) (require :muerte/hash-tables) (require :muerte/ratios)

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs May 2005