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

[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