movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[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

[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-serv27216 Modified Files: los-closette.lisp Log Message: Cleaned up compute-effective-slot-reader/writer: made it a generic function. Date: Tue May 3 22:07:51 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.27 movitz/losp/muerte/los-closette.lisp:1.28 --- movitz/losp/muerte/los-closette.lisp:1.27 Sun May 1 01:22:19 2005 +++ movitz/losp/muerte/los-closette.lisp Tue May 3 22:07:50 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.27 2005/04/30 23:22:19 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.28 2005/05/03 20:07:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -872,23 +872,40 @@ (defmacro define-effective-slot-reader (name location) - `(defun ,name (instance) - (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) - (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* - :movl (:eax (:offset movitz-basic-vector data ,(* location 4))) :eax) - (#.movitz:*compiler-global-segment-prefix* - :cmpl :eax ,(movitz::make-indirect-reference :edi (movitz::global-constant-offset - 'new-unbound-value))) - (:je '(:sub-program (unbound) - (:compile-form (:result-mode :multiple-values) - (slot-unbound-trampoline instance ,location)) - (:jmp 'done))) - (:clc) - done))) + (if movitz::*compiler-use-into-unbound-protocol* + `(defun ,name (instance) + (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) + (#.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) + (:jo '(:sub-program (unbound) + (:compile-form (:result-mode :multiple-values) + (slot-unbound-trampoline instance ,location)) + (:jmp 'done))) + (:clc) + done)) + `(defun ,name (instance) + (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) + (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :movl (:eax (:offset movitz-basic-vector data ,(* location 4))) :eax) + (#.movitz:*compiler-global-segment-prefix* + :cmpl :eax ,(movitz::make-indirect-reference :edi (movitz::global-constant-offset + 'new-unbound-value))) + (:je '(:sub-program (unbound) + (:compile-form (:result-mode :multiple-values) + (slot-unbound-trampoline instance ,location)) + (:jmp 'done))) + (:clc) + done)))) (defparameter *standard-effective-slot-readers* #(standard-effective-slot-reader%0 @@ -911,30 +928,8 @@ (define-effective-slot-reader standard-effective-slot-reader%6 6) (define-effective-slot-reader standard-effective-slot-reader%7 7) -(defun compute-effective-slot-reader (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))) - (check-type slot-location (integer 0 #xffff)) - (etypecase class - (standard-class - (if (and (< slot-location (length *standard-effective-slot-readers*)) - (svref *standard-effective-slot-readers* slot-location)) - (symbol-function (svref *standard-effective-slot-readers* slot-location)) - (lambda (instance) - (let ((x (standard-instance-access instance slot-location))) - (if (not (eq x (load-global-constant new-unbound-value))) - x - (slot-unbound-trampoline instance slot-location)))))) - (funcallable-standard-class - (lambda (instance) - (let ((x (svref (std-gf-instance-slots instance) slot-location))) - (if (not (eq x (load-global-constant new-unbound-value))) - x - (slot-unbound-trampoline instance slot-location))))))))) +#+ignore (defun compute-effective-slot-writer (class slot-definition) (let* ((slot-name (slot-definition-name slot-definition)) (slot (find-slot class slot-name))) @@ -1211,7 +1206,7 @@ (push indicator initargs))))))) initargs) -(defmethod make-instance ((class standard-class) &rest initargs) +(defmethod make-instance ((class std-slotted-class) &rest initargs) (declare (dynamic-extent initargs)) (let ((defaulted-initargs (compute-defaulted-initargs class initargs))) (apply 'initialize-instance @@ -1274,10 +1269,14 @@ (define-slot-reader-method slot-definition-initform (standard-slot-definition initform)) -(defun find-slot (class slot-name) +(defun find-slot (class slot-name &optional error-instance operation new-value) (dolist (slot (if (eq class *the-class-standard-class*) *the-slots-of-standard-class* - (class-slots class)) #+ignore (error "The slot ~S doesn't exist in ~S." slot-name class)) + (class-slots class)) + (case error-instance + ((nil)) + ((t) (error "No slot named ~S in class ~S." slot-name class)) + (t (slot-missing class error-instance slot-name operation new-value)))) (when (eql slot-name (slot-definition-name slot)) (return slot)))) @@ -1291,8 +1290,7 @@ val))) (defun std-gf-slot-value (instance slot-name) - (let ((slot (find-slot (std-gf-instance-class instance) slot-name))) - (assert slot) + (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))) @@ -1396,6 +1394,7 @@ (when (eql slot-name (slot-definition-name slot)) (return t))))) + ;;; Specializers (defun eql-specializer-p (specializer) @@ -1426,6 +1425,41 @@ (typep object specializer))) +;;;; + +(defmethod compute-effective-slot-reader ((class standard-class) slot) + (let ((slot-location (slot-definition-location slot))) + (check-type slot-location positive-fixnum) + (if (and (< slot-location (length *standard-effective-slot-readers*)) + (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)))))) + +(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))))) + +(defmethod compute-effective-slot-writer ((class standard-class) slot) + (let ((slot-location (slot-definition-location slot))) + (check-type slot-location positive-fixnum) + (lambda (value instance) + (setf (standard-instance-access instance slot-location) + value)))) + +(defmethod compute-effective-slot-writer ((class funcallable-standard-class) slot) + (let ((slot-location (slot-definition-location slot))) + (check-type slot-location positive-fixnum) + (lambda (value instance) + (setf (svref (std-gf-instance-slots instance) slot-location) + value)))) + + + ;;; compute-applicable-methods-using-classes (defun std-compute-applicable-methods-using-classes (gf classes) @@ -1560,8 +1594,12 @@ *standard-slot-value-using-class*) (class-of object) object (accessor-method-slot-definition primary-method)))))) - (compute-effective-slot-reader (specializer-class (car specializers)) - (accessor-method-slot-definition primary-method))) + (let* ((class (specializer-class (car specializers))) + (slot (find-slot class + (slot-definition-name + (accessor-method-slot-definition primary-method)) + t))) + (compute-effective-slot-reader class slot))) ((and (typep primary-method 'standard-writer-method) ;; May we shortcut this writer method? (or (not *standard-setf-slot-value-using-class*) ; still bootstrapping.. @@ -1573,8 +1611,12 @@ *standard-setf-slot-value-using-class*) value (class-of object) object (accessor-method-slot-definition primary-method)))))) - (compute-effective-slot-writer (specializer-class (cadr specializers)) - (accessor-method-slot-definition primary-method))) + (let* ((class (specializer-class (cadr specializers))) + (slot (find-slot class + (slot-definition-name + (accessor-method-slot-definition primary-method)) + t))) + (compute-effective-slot-writer class slot))) (t (compute-primary-emfun primaries)))) ((null reverse-afters) (let ((emfun (compute-primary-emfun primaries)) @@ -1901,32 +1943,3 @@ (values)))) -;;;; - -(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 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)

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs