From ffjeld at common-lisp.net Mon May 2 21:33:30 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 2 May 2005 23:33:30 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: <20050502213330.D7F1588726@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13377 Modified Files: basic-macros.lisp Log Message: Added macro unbound-protect. Date: Mon May 2 23:33:30 2005 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.58 movitz/losp/muerte/basic-macros.lisp:1.59 --- movitz/losp/muerte/basic-macros.lisp:1.58 Wed Apr 27 01:45:00 2005 +++ movitz/losp/muerte/basic-macros.lisp Mon May 2 23:33:29 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.58 2005/04/26 23:45:00 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.59 2005/05/02 21:33:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -688,6 +688,26 @@ (0 nil) (1 `(cons ,(car elements) nil)) (t form))) + + +(defmacro unbound-protect (x &optional error-continuation &environment env) + (cond + ((movitz:movitz-constantp x env) + `(values ,x)) + (movitz::*compiler-use-into-unbound-protocol* + (let ((unbound-continue (gensym "unbound-continue-"))) + `(with-inline-assembly (:returns :register) + (:compile-form (:result-mode :register) ,x) + (:cmpl -1 (:result-register)) + (:jo '(:sub-program (unbound) + (:compile-form (:result-mode :eax) ,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)))))) #+ignore (define-compiler-macro apply (&whole form function &rest args) From ffjeld at common-lisp.net Tue May 3 19:49:26 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 3 May 2005 21:49:26 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp Message-ID: <20050503194926.007DE8871F@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25840 Modified Files: los-closette-compiler.lisp Log Message: Fix movitz-make-instance-run-time-context. Date: Tue May 3 21:49:26 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.15 movitz/losp/muerte/los-closette-compiler.lisp:1.16 --- movitz/losp/muerte/los-closette-compiler.lisp:1.15 Sun May 1 01:22:28 2005 +++ movitz/losp/muerte/los-closette-compiler.lisp Tue May 3 21:49:25 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.15 2005/04/30 23:22:28 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.16 2005/05/03 19:49:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -610,11 +610,12 @@ :direct-superclasses direct-superclasses) class)) - (defun movitz-make-instance-run-time-context (metaclass &rest all-keys &key name direct-superclasses direct-slots size slot-map &allow-other-keys) + (defun movitz-make-instance-run-time-context (metaclass &rest all-keys &key name direct-superclasses direct-slots size slot-map plist &allow-other-keys) (declare (ignore all-keys)) (let ((class (std-allocate-instance metaclass))) (when size (setf (std-slot-value class 'size) size)) - (setf (std-slot-value class 'slot-map) slot-map) + (setf (std-slot-value class 'slot-map) slot-map + (std-slot-value class 'plist) plist) (setf (movitz-class-name class) name) (setf (class-direct-subclasses class) ()) (setf (class-direct-methods class) ()) From ffjeld at common-lisp.net Tue May 3 20:07:51 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 3 May 2005 22:07:51 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp Message-ID: <20050503200751.EAF318871F@common-lisp.net> 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 ;;;; 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) From ffjeld at common-lisp.net Tue May 3 20:08:15 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 3 May 2005 22:08:15 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/common-lisp.lisp Message-ID: <20050503200815.A40D88871F@common-lisp.net> 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) From ffjeld at common-lisp.net Tue May 3 20:09:50 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 3 May 2005 22:09:50 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp Message-ID: <20050503200950.D69E28871F@common-lisp.net> 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 ;;;; 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 () From ffjeld at common-lisp.net Tue May 3 20:10:36 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 3 May 2005 22:10:36 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp Message-ID: <20050503201036.96C338871F@common-lisp.net> 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 ;;;; 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 ) + (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) From ffjeld at common-lisp.net Tue May 3 20:11:44 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 3 May 2005 22:11:44 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp Message-ID: <20050503201144.D75D98871F@common-lisp.net> 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 ;;;; 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)) From ffjeld at common-lisp.net Tue May 3 20:12:44 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 3 May 2005 22:12:44 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/stream-image.lisp Message-ID: <20050503201244.459088871F@common-lisp.net> 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 ;;;; 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))) From ffjeld at common-lisp.net Tue May 3 20:12:54 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 3 May 2005 22:12:54 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: <20050503201254.800628871F@common-lisp.net> 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) From ffjeld at common-lisp.net Tue May 3 20:13:10 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 3 May 2005 22:13:10 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp Message-ID: <20050503201310.C528E8871F@common-lisp.net> 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))) From ffjeld at common-lisp.net Tue May 3 21:25:31 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 3 May 2005 23:25:31 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: <20050503212531.3E7A88871F@common-lisp.net> 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) From ffjeld at common-lisp.net Tue May 3 21:25:35 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 3 May 2005 23:25:35 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp Message-ID: <20050503212535.340CD88735@common-lisp.net> 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 ;;;; 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 From ffjeld at common-lisp.net Tue May 3 21:34:58 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 3 May 2005 23:34:58 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp Message-ID: <20050503213458.93A588871F@common-lisp.net> 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 ;;;; 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) From ffjeld at common-lisp.net Tue May 3 22:15:14 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 4 May 2005 00:15:14 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp Message-ID: <20050503221514.F27528871F@common-lisp.net> 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 ;;;; 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)) From ffjeld at common-lisp.net Tue May 3 22:15:38 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 4 May 2005 00:15:38 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: <20050503221538.E0D5D8871F@common-lisp.net> 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 , at 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 , at error-continuation))))))) (define-compiler-macro current-run-time-context () `(with-inline-assembly (:returns :register) From ffjeld at common-lisp.net Wed May 4 06:17:21 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 4 May 2005 08:17:21 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp Message-ID: <20050504061721.E70708871F@common-lisp.net> 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 ;;;; 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)) From ffjeld at common-lisp.net Wed May 4 07:43:28 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 4 May 2005 09:43:28 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp Message-ID: <20050504074328.4996E8871D@common-lisp.net> 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 ;;;; 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)) From ffjeld at common-lisp.net Wed May 4 08:00:40 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 4 May 2005 10:00:40 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp Message-ID: <20050504080040.5A9398871D@common-lisp.net> 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 ;;;; 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))) , at 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)))) From ffjeld at common-lisp.net Wed May 4 08:00:43 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 4 May 2005 10:00:43 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp Message-ID: <20050504080043.07B508871D@common-lisp.net> 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 ;;;; 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) ;;; From ffjeld at common-lisp.net Wed May 4 22:46:44 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 00:46:44 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp Message-ID: <20050504224644.E3AE088720@common-lisp.net> 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 ;;;; 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) From ffjeld at common-lisp.net Wed May 4 22:47:02 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 00:47:02 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cons.lisp Message-ID: <20050504224702.C36C588720@common-lisp.net> 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))) From ffjeld at common-lisp.net Wed May 4 22:47:18 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 00:47:18 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp Message-ID: <20050504224718.975CD88720@common-lisp.net> 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 ;;;; 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) From ffjeld at common-lisp.net Wed May 4 22:47:39 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 00:47:39 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050504224739.C397C88720@common-lisp.net> 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))) From ffjeld at common-lisp.net Wed May 4 22:47:59 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 00:47:59 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: <20050504224759.9521388720@common-lisp.net> 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) From ffjeld at common-lisp.net Thu May 5 10:28:53 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 12:28:53 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/ll-testing.lisp Message-ID: <20050505102853.013E08871F@common-lisp.net> 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 ;;;; 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)) From ffjeld at common-lisp.net Thu May 5 13:02:38 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 15:02:38 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: <20050505130238.6C1078871F@common-lisp.net> 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 @@ , at 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")) From ffjeld at common-lisp.net Thu May 5 13:21:41 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 15:21:41 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: <20050505132141.90F148871F@common-lisp.net> 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 From ffjeld at common-lisp.net Thu May 5 13:21:48 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 15:21:48 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp Message-ID: <20050505132148.AE8BA88720@common-lisp.net> 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 ;;;; 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." From ffjeld at common-lisp.net Thu May 5 13:21:52 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 15:21:52 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/packages.lisp Message-ID: <20050505132152.E428F8874C@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv14081 Modified Files: packages.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:52 2005 Author: ffjeld Index: movitz/losp/muerte/packages.lisp diff -u movitz/losp/muerte/packages.lisp:1.8 movitz/losp/muerte/packages.lisp:1.9 --- movitz/losp/muerte/packages.lisp:1.8 Sun Apr 17 20:18:18 2005 +++ movitz/losp/muerte/packages.lisp Thu May 5 15:21:50 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 30 15:19:43 2001 ;;;; -;;;; $Id: packages.lisp,v 1.8 2005/04/17 18:18:18 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.9 2005/05/05 13:21:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -30,6 +30,8 @@ shadowing-symbols-list use-list) +(defvar *packages*) ; Set by dump-image. + (defun package-name (object) (package-object-name (find-package object))) @@ -42,9 +44,7 @@ (find-package-string (string name)))) (defun find-package-string (name &optional (start 0) (end (length name)) (key 'identity)) - (values (gethash-string name start end - (get-global-property :packages) - nil key))) + (values (gethash-string name start end *packages* nil key))) (defun assert-package (name) (or (find-package name) @@ -54,7 +54,7 @@ (let (pkgs) (maphash (lambda (k v) (pushnew v pkgs)) - (get-global-property :packages)) + *packages*) pkgs)) (defun find-symbol-string (name start end key &optional (package *package*)) @@ -117,7 +117,7 @@ (symbol-var (gensym)) (loop-tag (gensym)) (end-tag (gensym))) - `(with-hash-table-iterator (,next-package (get-global-property :packages)) + `(with-hash-table-iterator (,next-package *packages*) (do () (nil) (multiple-value-bind (,more-packages-var ,dummy ,package-var) (,next-package) From ffjeld at common-lisp.net Thu May 5 13:59:38 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 15:59:38 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: <20050505135938.DBBE588720@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16813 Modified Files: primitive-functions.lisp Log Message: Fixed class-of for run-time-context objects. Date: Thu May 5 15:59:37 2005 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.63 movitz/losp/muerte/primitive-functions.lisp:1.64 --- movitz/losp/muerte/primitive-functions.lisp:1.63 Thu Feb 3 10:19:02 2005 +++ movitz/losp/muerte/primitive-functions.lisp Thu May 5 15:59:37 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.63 2005/02/03 09:19:02 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.64 2005/05/05 13:59:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -529,18 +529,31 @@ (:movl (:eax ,movitz:+other-type-offset+) :ecx) (:cmpb ,(movitz:tag :std-instance) :cl) (:jne 'not-std-instance) - (:movl (:eax ,(bt:slot-offset 'movitz::movitz-std-instance 'movitz::class)) :eax) + (,movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :movl (:eax ,(bt:slot-offset 'movitz::movitz-std-instance 'movitz::class)) :eax) (:ret) not-std-instance (:cmpw ,(+ (movitz:tag :funobj) (ash (bt:enum-value 'movitz::movitz-funobj-type :generic-function) 8)) :cx) (:jne 'not-std-gf-instance) - (:movl (:eax ,(bt:slot-offset 'movitz::movitz-funobj-standard-gf + (,movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :movl (:eax ,(bt:slot-offset 'movitz::movitz-funobj-standard-gf 'movitz::standard-gf-class)) :eax) (:ret) not-std-gf-instance + + (:cmpb ,(movitz:tag :run-time-context) :cl) + (:jne 'not-rtc) + (,movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :movl (:eax (:offset movitz-run-time-context class + ,(- (movitz::image-nil-word movitz:*image*) + (movitz::tag :other)))) + :eax) + (:ret) + not-rtc + (:globally (:movl (:edi (:edi-offset classes)) :ebx)) (:cmpb ,(movitz:tag :bignum) :cl) (:jne 'not-bignum) @@ -571,8 +584,6 @@ (structure-object-class object)) (character (find-class 'character)) - (run-time-context - (find-class 'run-time-context)) (null (find-class 'null)) (cons From ffjeld at common-lisp.net Thu May 5 15:16:30 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 17:16:30 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: <20050505151630.B77DB8871F@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv23862 Modified Files: packages.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:16:30 2005 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.47 movitz/packages.lisp:1.48 --- movitz/packages.lisp:1.47 Sat Apr 30 23:16:12 2005 +++ movitz/packages.lisp Thu May 5 17:16:29 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.47 2005/04/30 21:16:12 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.48 2005/05/05 15:16:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1088,19 +1088,15 @@ (:use muerte.mop muerte.common-lisp) (:import-from common-lisp cl:nil) (:shadow get-setf-expansion) - (:export translate-program - decode-macro-lambda-list - with-inline-assembly - with-progn-results - make-named-function - without-function-prelude - numargs-case - movitz-accessor - simple-read-from-string + (:export #:translate-program + #:decode-macro-lambda-list + #:with-inline-assembly + #:make-named-function + #:without-function-prelude + #:numargs-case + #:simple-read-from-string #:read-key - print-word - fixnump below - print-unreadable-movitz-object + #:fixnump #:newline #:*print-safely* @@ -1119,17 +1115,9 @@ #:*backtrace-print-level* #:backtrace - #:stack-ref - #:with-each-dynamic-context - #:stack-frame-uplink - #:current-stack-frame - #:current-dynamic-context - #:stack-frame-funobj - #:stack-frame-call-site - #:stack-frame-ref - #:check-stack-limit #:dit-frame-ref - #:dit-frame-casf + #:check-stack-limit + #:current-stack-frame #:interrupt-default-handler #:exception-handler @@ -1157,51 +1145,41 @@ #:movitz-type-slot-offset - vector-element-type - vector-element-size - with-subvector-accessor - svref%unsafe - bvref-u16 - object-location - object-tag - location-in-object-p - inline-malloc - define-compile-time-variable - define-primitive-function - without-gc - with-stack-check - with-symbol-mutex - spin-wait-pause - char-whitespace-p - wrong-argument-count - throw-error - *debugger-function* - *debugger-invoked-stack-frame* - *debugger-condition* - *debugger-dynamic-context* - pprint-clumps - do-trace - do-untrace - malloc-initialize - clos-bootstrap - *forward-generic-function* - halt-cpu + #:object-location + #:object-tag + #:location-in-object-p + #:define-compile-time-variable + #:define-primitive-function + #:without-gc + #:with-stack-check + #:with-symbol-mutex + #:spin-wait-pause + #:char-whitespace-p + #:wrong-argument-count + #:throw-error + #:*debugger-function* + #:*debugger-invoked-stack-frame* + #:*debugger-condition* + #:*debugger-dynamic-context* + #:pprint-clumps + #:do-trace + #:do-untrace + #:malloc-initialize + #:clos-bootstrap + #:*forward-generic-function* + #:halt-cpu - find-restart-by-index - find-restart-from-context - map-active-restarts - with-basic-restart + #:find-restart-by-index + #:find-restart-from-context + #:map-active-restarts + #:with-basic-restart #:dynamic-variable-install #:dynamic-variable-uninstall #:code-vector - #:vector-u8 - #:vector-u16 - #:vector-u32 #:pointer #:basic-restart - #:illegal-object #:run-time-context #:run-time-context-class #:current-run-time-context @@ -1234,35 +1212,23 @@ device-clear-input device-finish-record - translate-program - decode-macro-lambda-list - decode-optional-formal - decode-keyword-formal - parse-declarations-and-body - parse-docstring-declarations-and-body - unfold-circular-list - compute-function-block-name + #:unfold-circular-list + #:translate-program + #:decode-macro-lambda-list + #:decode-optional-formal + #:decode-keyword-formal + #:parse-declarations-and-body + #:parse-docstring-declarations-and-body + #:compute-function-block-name - load-global-constant - load-global-constant-u32 - runtime-context-slot - movitz-accessor - halt-cpu + #:movitz-accessor #:%object-lispval #:%lispval-object #:objects-equalp - word-nibble - &edx - - #:un-backquote - #:backquote-comma - #:backquote-comma-at - #:backquote-comma-dot + #:&edx #:memref #:memref-int - #:memcopy - #:%copy-words #:io-port #:io-register8 @@ -1383,19 +1349,19 @@ #:*compiler-allow-untagged-word-bits* ) (:import-from muerte - #:translate-program - #:decode-macro-lambda-list - #:un-backquote - #:backquote-comma - #:backquote-comma-at - #:backquote-comma-dot - - #:decode-optional-formal - #:decode-keyword-formal - #:parse-declarations-and-body - #:parse-docstring-declarations-and-body - #:unfold-circular-list - #:compute-function-block-name + muerte::translate-program + muerte::decode-macro-lambda-list + muerte::un-backquote + muerte::backquote-comma + muerte::backquote-comma-at + muerte::backquote-comma-dot + + muerte::decode-optional-formal + muerte::decode-keyword-formal + muerte::parse-declarations-and-body + muerte::parse-docstring-declarations-and-body + muerte::unfold-circular-list + muerte::compute-function-block-name )) From ffjeld at common-lisp.net Thu May 5 15:16:34 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 17:16:34 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: <20050505151634.D624388720@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv23883 Modified Files: special-operators.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:16:34 2005 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.51 movitz/special-operators.lisp:1.52 --- movitz/special-operators.lisp:1.51 Wed Apr 27 01:45:48 2005 +++ movitz/special-operators.lisp Thu May 5 17:16:33 2005 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.51 2005/04/26 23:45:48 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.52 2005/05/05 15:16:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -283,7 +283,7 @@ (setf (movitz-symbol-value (movitz-read name)) code-vector) (when symtab-property (setf (movitz-env-get name :symtab) - (translate-program symtab :movitz :muerte))) + (muerte::translate-program symtab :movitz :muerte))) (compiler-values ())))))) (define-special-operator define-prototyped-function (&form form) From ffjeld at common-lisp.net Thu May 5 15:16:41 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 17:16:41 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: <20050505151641.9CA308873B@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv23901 Modified Files: image.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:16:39 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.97 movitz/image.lisp:1.98 --- movitz/image.lisp:1.97 Thu May 5 15:21:40 2005 +++ movitz/image.lisp Thu May 5 17:16:38 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.97 2005/05/05 13:21:40 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.98 2005/05/05 15:16:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -572,8 +572,8 @@ muerte:run-time-context muerte.mop:standard-effective-slot-definition muerte.mop:funcallable-standard-class - muerte:basic-restart - muerte:illegal-object)) + muerte::basic-restart + muerte::illegal-object)) (defun class-object-offset (name) (let ((name (translate-program name :cl :muerte.cl))) From ffjeld at common-lisp.net Thu May 5 15:16:46 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 17:16:46 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/ll-testing.lisp Message-ID: <20050505151646.B19EC88720@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv23925 Modified Files: ll-testing.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:16:46 2005 Author: ffjeld Index: movitz/losp/ll-testing.lisp diff -u movitz/losp/ll-testing.lisp:1.7 movitz/losp/ll-testing.lisp:1.8 --- movitz/losp/ll-testing.lisp:1.7 Thu May 5 12:28:52 2005 +++ movitz/losp/ll-testing.lisp Thu May 5 17:16:45 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Apr 14 08:18:43 2005 ;;;; -;;;; $Id: ll-testing.lisp,v 1.7 2005/05/05 10:28:52 ffjeld Exp $ +;;;; $Id: ll-testing.lisp,v 1.8 2005/05/05 15:16:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -93,18 +93,6 @@ (error "Stack stop.") (format *terminal-io* "~&Stack-stopper halt.") (loop (halt-cpu))) - -(defun control-stack-fixate (stack) - (let ((stack-base (+ 2 (object-location stack)))) - (do ((frame (control-stack-ebp stack))) - ((zerop (stack-frame-uplink stack frame))) - (assert (typep (stack-frame-funobj stack frame) 'function)) - (let ((previous-frame frame)) - (setf frame (stack-frame-uplink stack frame)) - (incf (stack-frame-ref stack previous-frame 0) - stack-base))) - (values (+ (control-stack-ebp stack) stack-base) - (+ (control-stack-esp stack) stack-base)))) (defun alloc-context (segment-descriptor-table) (let* ((fs-index 8) From ffjeld at common-lisp.net Thu May 5 15:16:50 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 17:16:50 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: <20050505151650.2F2EC88720@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv23942 Modified Files: los0-gc.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:16:49 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.50 movitz/losp/los0-gc.lisp:1.51 --- movitz/losp/los0-gc.lisp:1.50 Sat Apr 30 00:37:08 2005 +++ movitz/losp/los0-gc.lisp Thu May 5 17:16:48 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.50 2005/04/29 22:37:08 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.51 2005/05/05 15:16:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -333,17 +333,11 @@ (defparameter *x* #4000(nil)) ; Have this in static space. -(defparameter *xx* #4000(nil)) ; Have this in static space. +;;;(defparameter *xx* #4000(nil)) ; Have this in static space. (defparameter *code-vector-foo* 0) (defvar *old-code-vectors* #250()) (defvar *new-code-vectors* #250()) - -(defun debug (location x) - (setf (dummy x) - (let ((new (shallow-copy x))) - (warn "[~S] Migrating code-vector ~Z => ~Z." location x new) - new))) (defun stop-and-copy (&optional evacuator) (setf (fill-pointer *x*) 0) From ffjeld at common-lisp.net Thu May 5 15:16:55 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 17:16:55 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp Message-ID: <20050505151655.8D8CC8873B@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv23962 Modified Files: los0.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:16:54 2005 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.41 movitz/losp/los0.lisp:1.42 --- movitz/losp/los0.lisp:1.41 Tue May 3 22:13:07 2005 +++ movitz/losp/los0.lisp Thu May 5 17:16:54 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.41 2005/05/03 20:13:07 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.42 2005/05/05 15:16:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,7 +28,8 @@ (require :lib/net/ip4) (require :lib/repl) -(require :ll-testing) +;; (require :ll-testing) +(require :lib/threading) (defpackage muerte.init (:nicknames #:los0) @@ -1040,7 +1041,7 @@ (define-toplevel-command :restart (&optional (r 0) &rest args) (declare (dynamic-extent args)) (let* ((context (or *debugger-dynamic-context* - (current-dynamic-context))) + (muerte::current-dynamic-context))) (restart (typecase r (integer (find-restart-by-index r context)) @@ -1099,7 +1100,7 @@ (defun los0-debugger (condition) (without-interrupts - (let ((*debugger-dynamic-context* (current-dynamic-context)) + (let ((*debugger-dynamic-context* (muerte::current-dynamic-context)) (*standard-output* *debug-io*) (*standard-input* *debug-io*) (*debugger-condition* condition) @@ -1245,11 +1246,11 @@ (:shrl 2 :ecx) ((:gs-override) :addb 1 (:ecx 158)) ((:gs-override) :movb #x40 (:ecx 159))) - (do ((frame (stack-frame-uplink nil (current-stack-frame)) - (stack-frame-uplink nil frame))) + (do ((frame (muerte::stack-frame-uplink nil (muerte::current-stack-frame)) + (muerte::stack-frame-uplink nil frame))) ((plusp frame)) (when (eq (with-inline-assembly (:returns :eax) (:movl :esi :eax)) - (stack-frame-funobj nil frame)) + (muerte::stack-frame-funobj nil frame)) (error "Double interrupt."))) ;;; (dolist (range muerte::%memory-map-roots%) ;;; (map-header-vals (lambda (x type) @@ -1260,7 +1261,7 @@ (declare (ignore foo)) x) nil - (current-stack-frame)) + (muerte::current-stack-frame)) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) (:shrl 2 :ecx) @@ -1337,9 +1338,9 @@ (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))) +;;; (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))) (install-los0-consing :kb-size 500) #+ignore @@ -1665,7 +1666,7 @@ (%symbol-global-value name)) (setf (%symbol-global-value name) (memref env 8))))))) - (install-shallow-env (load-global-constant dynamic-env :thread-local t)))) + (install-shallow-env (%run-time-context-slot 'muerte::dynamic-env)))) (values)) (defun deinstall-shallow-binding (&key quiet) @@ -1679,7 +1680,7 @@ (install muerte::dynamic-unwind-next) (install muerte::dynamic-variable-store) (install muerte::dynamic-variable-lookup)) - (loop for env = (load-global-constant dynamic-env :thread-local t) + (loop for env = (%run-time-context-slot 'muerte::dynamic-env) then (memref env 12) while (plusp env) do (let ((name (memref env 0))) From ffjeld at common-lisp.net Thu May 5 15:16:59 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 17:16:59 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/lib/misc.lisp Message-ID: <20050505151659.98C7E8873D@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv23981 Modified Files: misc.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:16:59 2005 Author: ffjeld Index: movitz/losp/lib/misc.lisp diff -u movitz/losp/lib/misc.lisp:1.7 movitz/losp/lib/misc.lisp:1.8 --- movitz/losp/lib/misc.lisp:1.7 Wed Nov 24 15:20:49 2004 +++ movitz/losp/lib/misc.lisp Thu May 5 17:16:59 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001, 2003-2004, +;;;; Copyright (C) 2001, 2003-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon May 12 17:13:31 2003 ;;;; -;;;; $Id: misc.lisp,v 1.7 2004/11/24 14:20:49 ffjeld Exp $ +;;;; $Id: misc.lisp,v 1.8 2005/05/05 15:16:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,7 +22,7 @@ (defun checksum-octets (packet &optional (start 0) (end (length packet))) "Generate sum of 16-bit big-endian words for a sequence of octets." (typecase packet - (muerte:vector-u8 + ((simple-array (unsigned-byte 8)) (assert (<= 0 start end (length packet))) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :ebx) packet) @@ -49,7 +49,7 @@ end-checksum-loop (:shll #.movitz:+movitz-fixnum-shift+ :eax) (:cld))) - (t (muerte:with-subvector-accessor (packet-ref packet start end) + (t (muerte::with-subvector-accessor (packet-ref packet start end) (cond ((or (and (evenp start) (evenp end)) (and (oddp start) (oddp end))) From ffjeld at common-lisp.net Thu May 5 15:17:07 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 17:17:07 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/textmode-console.lisp Message-ID: <20050505151707.504368871F@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv24004 Modified Files: textmode-console.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:17:06 2005 Author: ffjeld Index: movitz/losp/x86-pc/textmode-console.lisp diff -u movitz/losp/x86-pc/textmode-console.lisp:1.4 movitz/losp/x86-pc/textmode-console.lisp:1.5 --- movitz/losp/x86-pc/textmode-console.lisp:1.4 Sun Nov 14 23:58:16 2004 +++ movitz/losp/x86-pc/textmode-console.lisp Thu May 5 17:17:06 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001, 2003-2004, +;;;; Copyright (C) 2001, 2003-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 8 15:13:24 2003 ;;;; -;;;; $Id: textmode-console.lisp,v 1.4 2004/11/14 22:58:16 ffjeld Exp $ +;;;; $Id: textmode-console.lisp,v 1.5 2005/05/05 15:17:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -66,23 +66,23 @@ nil)) (defmethod (setf console-char) (character (console vga-text-console) x y) - (when (and (below x (console-width console)) - (below y (console-height console))) + (when (and (< x (console-width console)) + (< y (console-height console))) (let ((index (+ x (* y (stride console))))) (setf (memref-int (base console) :index index :type :unsigned-byte16) (logior (ash (color console) 8) (char-code character))))) character) (defmethod console-char ((console vga-text-console) x y) - (when (and (below x (console-width console)) - (below y (console-height console))) + (when (and (< x (console-width console)) + (< y (console-height console))) (let* ((index (+ x (* y (stride console)))) (code (memref-int (base console) :index index :type :unsigned-byte16))) (code-char (ldb (byte 8 0) code))))) (defmethod put-string ((console vga-text-console) string x y &optional (start 0) (end (length string))) - (when (below y (console-height console)) + (when (< y (console-height console)) (loop with color = (ash (color console) 8) with base = (base console) for cursor upfrom (+ x (* y (stride console))) for column from x below (console-width console) @@ -93,7 +93,7 @@ string) (defmethod clear-line ((console vga-text-console) x y) - (when (below y (console-height console)) + (when (< y (console-height console)) (loop with base = (base console) for index upfrom (+ x (* y (stride console))) for column from x below (console-width console) From ffjeld at common-lisp.net Thu May 5 15:17:13 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 17:17:13 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/interrupt.lisp Message-ID: <20050505151713.559558871F@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv24020 Modified Files: interrupt.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:17:12 2005 Author: ffjeld Index: movitz/losp/x86-pc/interrupt.lisp diff -u movitz/losp/x86-pc/interrupt.lisp:1.10 movitz/losp/x86-pc/interrupt.lisp:1.11 --- movitz/losp/x86-pc/interrupt.lisp:1.10 Tue Aug 10 14:59:36 2004 +++ movitz/losp/x86-pc/interrupt.lisp Thu May 5 17:17:12 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri May 4 18:08:50 2001 ;;;; -;;;; $Id: interrupt.lisp,v 1.10 2004/08/10 12:59:36 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.11 2005/05/05 15:17:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,7 +22,7 @@ (defun idt-init () (init-pic8259 32 40) (setf (pic8259-irq-mask) #xffff) - (load-idt (load-global-constant interrupt-descriptor-table)) + (load-idt (muerte::load-global-constant muerte::interrupt-descriptor-table)) nil) (defun timer-init () From ffjeld at common-lisp.net Thu May 5 15:17:17 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 17:17:17 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cpu-id.lisp Message-ID: <20050505151717.196B78871F@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24040 Modified Files: cpu-id.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:17:16 2005 Author: ffjeld Index: movitz/losp/muerte/cpu-id.lisp diff -u movitz/losp/muerte/cpu-id.lisp:1.10 movitz/losp/muerte/cpu-id.lisp:1.11 --- movitz/losp/muerte/cpu-id.lisp:1.10 Wed Mar 9 08:18:14 2005 +++ movitz/losp/muerte/cpu-id.lisp Thu May 5 17:17:15 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Apr 15 22:47:13 2002 ;;;; -;;;; $Id: cpu-id.lisp,v 1.10 2005/03/09 07:18:14 ffjeld Exp $ +;;;; $Id: cpu-id.lisp,v 1.11 2005/05/05 15:17:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -248,7 +248,7 @@ (defun load-idt (idt-vector) (assert (= #.(bt:enum-value 'movitz::movitz-vector-element-type :u32) - (muerte:vector-element-type idt-vector))) + (vector-element-type idt-vector))) (let ((limit (- (* (length idt-vector) 4) 1))) ;; (format t "Load-idt: ~Z / ~D~%" idt-vector limit) From ffjeld at common-lisp.net Thu May 5 15:17:28 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 17:17:28 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp Message-ID: <20050505151728.73ABC8874C@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24054 Modified Files: run-time-context.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:17:22 2005 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.21 movitz/losp/muerte/run-time-context.lisp:1.22 --- movitz/losp/muerte/run-time-context.lisp:1.21 Thu May 5 00:47:17 2005 +++ movitz/losp/muerte/run-time-context.lisp Thu May 5 17:17:22 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.21 2005/05/04 22:47:17 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.22 2005/05/05 15:17:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -27,14 +27,8 @@ (defclass run-time-context (t) ((name :initarg :name - :initform :anonymous :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 - (cl:+ (bt:slot-offset 'movitz::movitz-run-time-context - 'movitz::run-time-context-start) - 0)))) + (:metaclass run-time-context-class)) (defmethod slot-value-using-class ((class run-time-context-class) object (slot standard-effective-slot-definition)) @@ -103,7 +97,8 @@ (defmethod print-object ((x run-time-context) stream) (print-unreadable-object (x stream :type t :identity t) - (format stream "~S" (run-time-context-name x))) + (when (slot-boundp x 'name) + (format stream "~S" (run-time-context-name x)))) x) ;;; From ffjeld at common-lisp.net Thu May 5 15:17:37 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 17:17:37 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp Message-ID: <20050505151737.6FB9588720@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24091 Modified Files: los-closette-compiler.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:17:37 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.16 movitz/losp/muerte/los-closette-compiler.lisp:1.17 --- movitz/losp/muerte/los-closette-compiler.lisp:1.16 Tue May 3 21:49:25 2005 +++ movitz/losp/muerte/los-closette-compiler.lisp Thu May 5 17:17:35 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.16 2005/05/03 19:49:25 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.17 2005/05/05 15:17:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -613,9 +613,15 @@ (defun movitz-make-instance-run-time-context (metaclass &rest all-keys &key name direct-superclasses direct-slots size slot-map plist &allow-other-keys) (declare (ignore all-keys)) (let ((class (std-allocate-instance metaclass))) - (when size (setf (std-slot-value class 'size) size)) - (setf (std-slot-value class 'slot-map) slot-map - (std-slot-value class 'plist) plist) + (setf (std-slot-value class 'size) + (or size (bt:sizeof 'movitz::movitz-run-time-context))) + (setf (std-slot-value class 'slot-map) + (or 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)))) + (setf (std-slot-value class 'plist) plist) (setf (movitz-class-name class) name) (setf (class-direct-subclasses class) ()) (setf (class-direct-methods class) ()) From ffjeld at common-lisp.net Thu May 5 15:21:59 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 17:21:59 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/lib/threading.lisp Message-ID: <20050505152159.D9BBC8871F@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv24227 Modified Files: threading.lisp Log Message: *** empty log message *** Date: Thu May 5 17:21:59 2005 Author: ffjeld Index: movitz/losp/lib/threading.lisp diff -u movitz/losp/lib/threading.lisp:1.1 movitz/losp/lib/threading.lisp:1.2 --- movitz/losp/lib/threading.lisp:1.1 Fri Apr 29 00:05:02 2005 +++ movitz/losp/lib/threading.lisp Thu May 5 17:21:59 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Apr 28 08:30:01 2005 ;;;; -;;;; $Id: threading.lisp,v 1.1 2005/04/28 22:05:02 ffjeld Exp $ +;;;; $Id: threading.lisp,v 1.2 2005/05/05 15:21:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,11 +18,16 @@ (defpackage threading (:use cl muerte) - (:export make-thread + (:export thread + make-thread yield )) -(in-package threading) +(in-package muerte) + +(defclass thread (run-time-context) + () + (:metaclass run-time-context-class)) (defmacro control-stack-ebp (stack) `(stack-frame-ref ,stack 0 0)) @@ -46,6 +51,18 @@ (control-stack-push function stack)) stack) +(defun control-stack-fixate (stack) + (let ((stack-base (+ 2 (object-location stack)))) + (do ((frame (control-stack-ebp stack))) + ((zerop (stack-frame-uplink stack frame))) + (assert (typep (stack-frame-funobj stack frame) 'function)) + (let ((previous-frame frame)) + (setf frame (stack-frame-uplink stack frame)) + (incf (stack-frame-ref stack previous-frame 0) + stack-base))) + (values (+ (control-stack-ebp stack) stack-base) + (+ (control-stack-esp stack) stack-base)))) + (defun stack-bootstrapper (&rest ignore) "Control stacks are initialized with this function as their initial frame." (declare (ignore ignore)) @@ -57,7 +74,7 @@ (check-type args list) (apply function args))) (error "Nothing left to do for ~S." (current-run-time-context)) - (loop (halt-cpu))) + (loop (halt-cpu))) ; just to make sure (defun control-stack-init-for-yield (stack function args) "Make it so that a yield to stack will cause function to be applied to args." @@ -79,7 +96,7 @@ (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*))) + (segment-descriptor-table nil #+ignore (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) @@ -114,8 +131,8 @@ (ebp (control-stack-ebp target-stack))) (assert (location-in-object-p target-stack esp)) (assert (location-in-object-p target-stack ebp)) - (assert (eq (stack-frame-funobj nil ebp) - (asm-register :esi)) () + (assert (eq (muerte::stack-frame-funobj nil ebp) + (muerte::asm-register :esi)) () "Will not yield to a non-yield frame.") ;; Push eflags for later.. (setf (memref (decf esp) 0) (eflags)) @@ -124,8 +141,8 @@ (%run-time-context-slot 'scratch2 target-rtc) esp) ;; Enable someone to yield back here.. (setf (control-stack-fs my-stack) (segment-register :fs) - (control-stack-ebp my-stack) (asm-register :ebp) - (control-stack-esp my-stack) (asm-register :esp)) + (control-stack-ebp my-stack) (muerte::asm-register :ebp) + (control-stack-esp my-stack) (muerte::asm-register :esp)) (with-inline-assembly (:returns :eax) (:load-lexical (:lexical-binding fs) :untagged-fixnum-ecx) (:load-lexical (:lexical-binding value) :eax) @@ -133,4 +150,4 @@ (:movw :cx :fs) (:locally (:movl (:edi (:edi-offset scratch1)) :ebp)) (:locally (:movl (:edi (:edi-offset scratch2)) :esp)) - (:popfl))))) \ No newline at end of file + (:popfl))))) From ffjeld at common-lisp.net Thu May 5 18:01:14 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 20:01:14 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: <20050505180114.D03BA88720@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5076 Modified Files: image.lisp Log Message: Move the non-lisp-val slots to the beginning of run-time-context, and don't have the protect-non-pointer-area stuff. Date: Thu May 5 20:01:14 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.98 movitz/image.lisp:1.99 --- movitz/image.lisp:1.98 Thu May 5 17:16:38 2005 +++ movitz/image.lisp Thu May 5 20:01:13 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.98 2005/05/05 15:16:38 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.99 2005/05/05 18:01:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,6 +22,19 @@ :initform :run-time-context) (padding :binary-type 3) + (atomically-continuation + :binary-type lu32 + :initform 0) + (raw-scratch0 ; A non-GC-root scratch register + :binary-type lu32 + :initform 0) + (pointer-start :binary-type :label) + (scratch1 + :binary-type word + :initform 0) + (scratch2 + :binary-type word + :initform 0) (class :binary-type word :map-binary-write 'movitz-intern @@ -35,12 +48,6 @@ :initarg :slots :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 @@ -369,27 +376,6 @@ :binary-type word :initform 6 :map-binary-read-delayed 'movitz-word) - (protect-non-pointer-area - :binary-type lu32 - :initform 3) - (protect-non-pointer-count - :binary-type lu32 - :initform nil - :map-binary-write (lambda (x type) - (declare (ignore x type)) - (- (bt:slot-offset 'movitz-run-time-context 'non-pointers-end) - (bt:slot-offset 'movitz-run-time-context 'non-pointers-start)))) - (non-pointers-start :binary-type :label) ; ========= NON-POINTER-START ======= - (bochs-flags - :binary-type lu32 - :initform 0) - (raw-scratch0 ; A non-GC-root scratch register - :binary-type lu32 - :initform 0) - (atomically-continuation - :binary-type lu32 - :initform 0) - (non-pointers-end :binary-type :label) ; ========= NON-POINTER-END ======= (ret-trampoline :binary-type code-vector-word :map-binary-write 'movitz-intern-code-vector From ffjeld at common-lisp.net Thu May 5 18:08:21 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 20:08:21 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp Message-ID: <20050505180821.63F31880E0@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5291 Modified Files: more-macros.lisp Log Message: Remove with-bochs-tracing. Date: Thu May 5 20:08:20 2005 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.25 movitz/losp/muerte/more-macros.lisp:1.26 --- movitz/losp/muerte/more-macros.lisp:1.25 Tue May 3 22:09:50 2005 +++ movitz/losp/muerte/more-macros.lisp Thu May 5 20:08:20 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.25 2005/05/03 20:09:50 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.26 2005/05/05 18:08:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -225,17 +225,6 @@ `(if ,eof-errorp (error 'end-of-file :stream ,stream) ,eof-value)) - - -(defmacro with-bochs-tracing ((&optional (value 1)) &body body) - "Bochs magic." - `(let ((old-flags (muerte::%run-time-context-slot 'bochs-flags))) - (unwind-protect - (progn - (setf (muerte::%run-time-context-slot 'bochs-flags) ,value) - , at body) - (setf (muerte::%run-time-context-slot 'bochs-flags) old-flags)))) - (defmacro handler-bind (bindings &body forms) (if (null bindings) From ffjeld at common-lisp.net Thu May 5 18:08:40 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 20:08:40 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: <20050505180840.D21EF880E0@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv5326 Modified Files: los0-gc.lisp Log Message: Disable some of the debugging cruft. Date: Thu May 5 20:08:39 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.51 movitz/losp/los0-gc.lisp:1.52 --- movitz/losp/los0-gc.lisp:1.51 Thu May 5 17:16:48 2005 +++ movitz/losp/los0-gc.lisp Thu May 5 20:08:39 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.51 2005/05/05 15:16:48 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.52 2005/05/05 18:08:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -332,7 +332,7 @@ (values)))) -(defparameter *x* #4000(nil)) ; Have this in static space. +(defparameter *x* #1000(nil)) ; Have this in static space. ;;;(defparameter *xx* #4000(nil)) ; Have this in static space. (defparameter *code-vector-foo* 0) @@ -364,6 +364,7 @@ nil) ((object-in-space-p newspace x) x) + #+ignore ((and (typep x 'code-vector) (not (object-in-space-p oldspace x)) (not (object-in-space-p newspace x)) From ffjeld at common-lisp.net Thu May 5 18:09:29 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 20:09:29 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp Message-ID: <20050505180929.434DC880E0@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv5360 Modified Files: los0.lisp Log Message: *** empty log message *** Date: Thu May 5 20:09:28 2005 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.42 movitz/losp/los0.lisp:1.43 --- movitz/losp/los0.lisp:1.42 Thu May 5 17:16:54 2005 +++ movitz/losp/los0.lisp Thu May 5 20:09:28 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.42 2005/05/05 15:16:54 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.43 2005/05/05 18:09:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1077,9 +1077,9 @@ (t (describe x))) (values)) -(muerte.toplevel:define-toplevel-command :bochs-trace (form) - (muerte::with-bochs-tracing () - (eval form))) +;;;(muerte.toplevel:define-toplevel-command :bochs-trace (form) +;;; (muerte::with-bochs-tracing () +;;; (eval form))) (muerte.toplevel:define-toplevel-command :mapkey (code-char-form) (let* ((code-char (eval code-char-form)) From ffjeld at common-lisp.net Thu May 5 19:35:19 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 21:35:19 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: <20050505193519.91AFB880E0@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv13010 Modified Files: los0-gc.lisp Log Message: Make stop-and-copy work again: Use (simple-array ..) rather than vector-u32. Date: Thu May 5 21:35:18 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.52 movitz/losp/los0-gc.lisp:1.53 --- movitz/losp/los0-gc.lisp:1.52 Thu May 5 20:08:39 2005 +++ movitz/losp/los0-gc.lisp Thu May 5 21:35:18 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.52 2005/05/05 18:08:39 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.53 2005/05/05 19:35:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -346,8 +346,8 @@ (without-interrupts (let* ((space0 (%run-time-context-slot 'nursery-space)) (space1 (space-other space0))) - (check-type space0 vector-u32) - (check-type space1 vector-u32) + (check-type space0 (simple-array (unsigned-byte 32) 1)) + (check-type space1 (simple-array (unsigned-byte 32) 1)) (assert (eq space0 (space-other space1))) (assert (= 2 (space-fresh-pointer space1))) (setf (%run-time-context-slot 'nursery-space) space1) From ffjeld at common-lisp.net Thu May 5 20:51:10 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 22:51:10 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: <20050505205110.B0669880E0@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv19805 Modified Files: los0-gc.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:51:10 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.53 movitz/losp/los0-gc.lisp:1.54 --- movitz/losp/los0-gc.lisp:1.53 Thu May 5 21:35:18 2005 +++ movitz/losp/los0-gc.lisp Thu May 5 22:51:09 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.53 2005/05/05 19:35:18 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.54 2005/05/05 20:51:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -78,8 +78,8 @@ (warn "install..") (install-los0-consing 4) (warn "nursery: ~Z, other: ~Z" - (%run-time-context-slot 'muerte::nursery-space) - (space-other (%run-time-context-slot 'muerte::nursery-space))) + (%run-time-context-slot nil 'muerte::nursery-space) + (space-other (%run-time-context-slot nil 'muerte::nursery-space))) (warn "first cons: ~Z" (funcall 'truncate #x100000000 3)) (warn "second cons: ~Z" (funcall 'truncate #x100000000 3)) (halt-cpu) @@ -243,9 +243,9 @@ (let ((*standard-output* *terminal-io*)) (cond (*gc-running* - (let* ((full-space (%run-time-context-slot 'muerte::nursery-space)) + (let* ((full-space (%run-time-context-slot nil 'muerte::nursery-space)) (hack-space (make-duo-space (duo-space-end-location full-space) 102400))) - (setf (%run-time-context-slot 'muerte::nursery-space) hack-space) + (setf (%run-time-context-slot nil 'muerte::nursery-space) hack-space) (break "Recursive GC triggered. Full-space: ~Z, hack-space: ~Z" full-space hack-space))) (t (let ((*gc-running* t)) @@ -268,16 +268,16 @@ (check-type code-vector code-vector) (if (eq context (current-run-time-context)) ;; The point of this is to not trigger CLOS bootstrapping. - (setf (%run-time-context-slot ',slot) code-vector) - (setf (%run-time-context-slot ',slot context) code-vector))))) + (setf (%run-time-context-slot nil ',slot) code-vector) + (setf (%run-time-context-slot context ',slot) code-vector))))) (install-primitive los0-fast-cons muerte::fast-cons) (install-primitive los0-box-u32-ecx muerte::box-u32-ecx) (install-primitive los0-cons-pointer muerte::cons-pointer) (install-primitive los0-cons-commit muerte::cons-commit)) (if (eq context (current-run-time-context)) - (setf (%run-time-context-slot 'muerte::nursery-space) + (setf (%run-time-context-slot nil 'muerte::nursery-space) actual-duo-space) - (setf (%run-time-context-slot 'muerte::nursery-space context) + (setf (%run-time-context-slot context 'muerte::nursery-space) actual-duo-space)) ;; Pretend that the heap stops here, so that we don't have to scan ;; the entire tail end of memory, which isn't going to be used. @@ -294,13 +294,13 @@ (defun report-nursery (x location) "Write a message if x is inside newspace." - (when (object-in-space-p (%run-time-context-slot 'nursery-space) x) + (when (object-in-space-p (%run-time-context-slot nil 'nursery-space) x) (format t "~&~Z: ~S: ~S from ~S" x (type-of x) x location)) x) (defun report-inactive-space (x location) "Check that x is not pointing into (what is presumably) oldspace." - (when (object-in-space-p (space-other (%run-time-context-slot 'nursery-space)) x) + (when (object-in-space-p (space-other (%run-time-context-slot nil 'nursery-space)) x) (break "~Z: ~S: ~S from ~S" x (type-of x) x location)) x) @@ -318,9 +318,9 @@ #+ignore (defun kill-the-newborns () - (let* ((oldspace (%run-time-context-slot 'nursery-space)) + (let* ((oldspace (%run-time-context-slot nil 'nursery-space)) (newspace (space-other oldspace))) - (setf (%run-time-context-slot 'nursery-space) newspace) + (setf (%run-time-context-slot nil 'nursery-space) newspace) (flet ((zap-oldspace (x location) (declare (ignore location)) (if (object-in-space-p oldspace x) @@ -332,7 +332,7 @@ (values)))) -(defparameter *x* #1000(nil)) ; Have this in static space. +(defparameter *x* #4000(nil)) ; Have this in static space. ;;;(defparameter *xx* #4000(nil)) ; Have this in static space. (defparameter *code-vector-foo* 0) @@ -344,13 +344,13 @@ (setf (fill-pointer *old-code-vectors*) 0) (multiple-value-bind (newspace oldspace) (without-interrupts - (let* ((space0 (%run-time-context-slot 'nursery-space)) + (let* ((space0 (%run-time-context-slot nil 'nursery-space)) (space1 (space-other space0))) (check-type space0 (simple-array (unsigned-byte 32) 1)) (check-type space1 (simple-array (unsigned-byte 32) 1)) (assert (eq space0 (space-other space1))) (assert (= 2 (space-fresh-pointer space1))) - (setf (%run-time-context-slot 'nursery-space) space1) + (setf (%run-time-context-slot nil 'nursery-space) space1) (values space1 space0))) ;; Evacuate-oldspace is to be mapped over every potential pointer. (let ((*code-vector-foo* (incf *code-vector-foo* 2)) @@ -458,13 +458,13 @@ old old new new (objects-equalp old new) oldspace newspace i)))))) (map-header-vals (lambda (x y) (declare (ignore y)) - (when (location-in-object-p (space-other (%run-time-context-slot 'nursery-space)) + (when (location-in-object-p (space-other (%run-time-context-slot nil 'nursery-space)) (object-location x)) (break "Seeing old object in values-vector: ~Z" x)) x) #x38 #xb8) #+ignore - (let* ((stack (%run-time-context-slot 'muerte::stack-vector)) + (let* ((stack (%run-time-context-slot nil 'muerte::stack-vector)) (stack-start (- (length stack) (muerte::current-control-stack-depth)))) (do ((i 0 (+ i 3))) ((>= i (length a))) @@ -538,7 +538,7 @@ (flet ((searcher (x ignore) (declare (ignore ignore)) (when (and (typep x '(or muerte::tag1 muerte::tag6 muerte::tag7)) - (not (eq x (%run-time-context-slot 'muerte::nursery-space))) + (not (eq x (%run-time-context-slot nil 'muerte::nursery-space))) (location-in-object-p x location) (not (member x results))) (push x results) @@ -554,7 +554,7 @@ (invoke-restart 'muerte::continue-map-header-vals))))) (dolist (range muerte::%memory-map-roots%) (map-header-vals #'searcher (car range) (cdr range))) - (let ((nursery (%run-time-context-slot 'muerte::nursery-space))) + (let ((nursery (%run-time-context-slot nil 'muerte::nursery-space))) (map-header-vals #'searcher (+ 4 (object-location nursery)) (+ 4 (object-location nursery) (space-fresh-pointer nursery)))) @@ -563,7 +563,7 @@ (defun report-lispval (lispval &optional breakp newspace) (let* ((location (truncate lispval 4)) - (newspace (or newspace (%run-time-context-slot 'muerte::nursery-space))) + (newspace (or newspace (%run-time-context-slot nil 'muerte::nursery-space))) (oldspace (space-other newspace))) (cond ((location-in-object-p newspace location) From ffjeld at common-lisp.net Thu May 5 20:51:17 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 22:51:17 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp Message-ID: <20050505205117.6891C880E0@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv19822 Modified Files: los0.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:51:12 2005 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.43 movitz/losp/los0.lisp:1.44 --- movitz/losp/los0.lisp:1.43 Thu May 5 20:09:28 2005 +++ movitz/losp/los0.lisp Thu May 5 22:51:12 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.43 2005/05/05 18:09:28 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.44 2005/05/05 20:51:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1517,16 +1517,16 @@ (let ((write-barrier *write-barrier*) (location (object-location object))) (assert (not (location-in-object-p - (los0::space-other (%run-time-context-slot 'nursery-space)) + (los0::space-other (%run-time-context-slot nil 'nursery-space)) location)) () "Write ~S to old-space at ~S." value location) (unless (or (eq object write-barrier) #+ignore - (location-in-object-p (%run-time-context-slot 'nursery-space) + (location-in-object-p (%run-time-context-slot nil 'nursery-space) location) - (location-in-object-p (%run-time-context-slot 'stack-vector) + (location-in-object-p (%run-time-context-slot nil 'stack-vector) location)) - (if (location-in-object-p (%run-time-context-slot 'nursery-space) + (if (location-in-object-p (%run-time-context-slot nil 'nursery-space) location) (vector-push 'stack-actually write-barrier) (vector-push object write-barrier)) @@ -1649,7 +1649,7 @@ (warn "Installing shallow-binding strategy..")) (without-interrupts (macrolet ((install (slot function) - `(setf (%run-time-context-slot ',slot) (symbol-value ',function)))) + `(setf (%run-time-context-slot nil ',slot) (symbol-value ',function)))) (install muerte:dynamic-variable-install dynamic-variable-install-shallow) (install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow) (install muerte::dynamic-unwind-next dynamic-unwind-next-shallow) @@ -1666,7 +1666,7 @@ (%symbol-global-value name)) (setf (%symbol-global-value name) (memref env 8))))))) - (install-shallow-env (%run-time-context-slot 'muerte::dynamic-env)))) + (install-shallow-env (%run-time-context-slot nil 'muerte::dynamic-env)))) (values)) (defun deinstall-shallow-binding (&key quiet) @@ -1674,13 +1674,13 @@ (warn "Deinstalling shallow-binding strategy..")) (without-interrupts (macrolet ((install (slot) - `(setf (%run-time-context-slot ',slot) (symbol-value ',slot)))) + `(setf (%run-time-context-slot nil ',slot) (symbol-value ',slot)))) (install muerte:dynamic-variable-install) (install muerte:dynamic-variable-uninstall) (install muerte::dynamic-unwind-next) (install muerte::dynamic-variable-store) (install muerte::dynamic-variable-lookup)) - (loop for env = (%run-time-context-slot 'muerte::dynamic-env) + (loop for env = (%run-time-context-slot nil 'muerte::dynamic-env) then (memref env 12) while (plusp env) do (let ((name (memref env 0))) From ffjeld at common-lisp.net Thu May 5 20:51:21 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 22:51:21 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp Message-ID: <20050505205121.A139188720@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19843 Modified Files: run-time-context.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:51:20 2005 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.22 movitz/losp/muerte/run-time-context.lisp:1.23 --- movitz/losp/muerte/run-time-context.lisp:1.22 Thu May 5 17:17:22 2005 +++ movitz/losp/muerte/run-time-context.lisp Thu May 5 22:51:19 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.22 2005/05/05 15:17:22 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.23 2005/05/05 20:51:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -32,27 +32,27 @@ (defmethod slot-value-using-class ((class run-time-context-class) object (slot standard-effective-slot-definition)) - (with-unbound-protect (svref (%run-time-context-slot 'slots object) + (with-unbound-protect (svref (%run-time-context-slot object 'slots) (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)) (let ((location (slot-definition-location slot)) - (slots (%run-time-context-slot 'slots object))) + (slots (%run-time-context-slot object 'slots))) (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) + (svref (%run-time-context-slot object 'slots) (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) + (setf (%run-time-context-slot x 'class) class) + (setf (%run-time-context-slot x 'slots) (allocate-slot-storage (count-if 'instance-slot-p (class-slots class)) (load-global-constant new-unbound-value))) x)) @@ -85,14 +85,14 @@ (let ((slot-location (slot-definition-location slot))) (check-type slot-location positive-fixnum) (lambda (instance) - (with-unbound-protect (svref (%run-time-context-slot 'slots instance) slot-location) + (with-unbound-protect (svref (%run-time-context-slot instance 'slots) 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) + (setf (svref (%run-time-context-slot instance 'slots) slot-location) value)))) (defmethod print-object ((x run-time-context) stream) @@ -111,8 +111,9 @@ (when errorp (error "No run-time-context slot named ~S in ~S." slot-name context)))) -(defun %run-time-context-slot (slot-name &optional (context (current-run-time-context))) - (let ((slot (find-run-time-context-slot context slot-name))) +(defun %run-time-context-slot (context slot-name) + (let* ((context (or context (current-run-time-context))) + (slot (find-run-time-context-slot context slot-name))) (ecase (second slot) (word (memref context -6 :index (third slot))) @@ -121,9 +122,10 @@ (lu32 (memref context -6 :index (third slot) :type :unsigned-byte32))))) -(defun (setf %run-time-context-slot) (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))) +(defun (setf %run-time-context-slot) (value context slot-name) + (let* ((context (or context (current-run-time-context))) + (slot (find-run-time-context-slot context slot-name))) + (check-type context run-time-context) (ecase (second slot) (word (setf (memref context -6 :index (third slot)) value)) @@ -136,23 +138,8 @@ (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 '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) + (setf (%run-time-context-slot context 'slots) (copy-seq (%run-time-context-slot parent 'slots)) + (%run-time-context-slot context 'self) context + (%run-time-context-slot context 'atomically-continuation) 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) From ffjeld at common-lisp.net Thu May 5 20:51:29 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 22:51:29 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: <20050505205129.78B2D88741@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19864 Modified Files: interrupt.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:51:28 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.42 movitz/losp/muerte/interrupt.lisp:1.43 --- movitz/losp/muerte/interrupt.lisp:1.42 Wed Apr 27 01:44:18 2005 +++ movitz/losp/muerte/interrupt.lisp Thu May 5 22:51:27 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.42 2005/04/26 23:44:18 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.43 2005/05/05 20:51:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -341,13 +341,13 @@ (with-inline-assembly (:returns :nothing) (:nop)))) (70 (error "Unaligned memref access.")) ((5 55) - (let* ((old-bottom (prog1 (%run-time-context-slot 'stack-bottom) - (setf (%run-time-context-slot 'stack-bottom) 0))) - (stack (%run-time-context-slot 'movitz::stack-vector)) + (let* ((old-bottom (prog1 (%run-time-context-slot nil 'stack-bottom) + (setf (%run-time-context-slot nil 'stack-bottom) 0))) + (stack (%run-time-context-slot nil 'stack-vector)) (real-bottom (- (object-location stack) 2)) (stack-left (- old-bottom real-bottom)) (old-es (segment-register :es)) - (old-dynamic-env (%run-time-context-slot 'dynamic-env)) + (old-dynamic-env (%run-time-context-slot nil 'dynamic-env)) (new-bottom (cond ((< stack-left 50) (princ "Halting CPU due to stack exhaustion.") @@ -362,7 +362,7 @@ (t (+ real-bottom (truncate stack-left 4)))))) ; Cushion the fall.. (unwind-protect (progn - (setf (%run-time-context-slot 'stack-bottom) new-bottom + (setf (%run-time-context-slot nil 'stack-bottom) new-bottom ;; (%run-time-context-slot 'dynamic-env) 0 (segment-register :es) (segment-register :ds)) (format *debug-io* "~&Stack-warning: Bumped stack-bottom by ~D to #x~X. Reset ES.~%" @@ -375,7 +375,7 @@ old-dynamic-env)) (format *debug-io* "~&Stack-warning: Resetting stack-bottom to #x~X.~%" old-bottom) - (setf (%run-time-context-slot 'stack-bottom) old-bottom + (setf (%run-time-context-slot nil 'stack-bottom) old-bottom ;; (%run-time-context-slot 'dynamic-env) old-dynamic-env (segment-register :es) old-es)))) (69 From ffjeld at common-lisp.net Thu May 5 20:51:38 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 22:51:38 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp Message-ID: <20050505205138.E43CD8874A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19896 Modified Files: los-closette.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:51:38 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.31 movitz/losp/muerte/los-closette.lisp:1.32 --- movitz/losp/muerte/los-closette.lisp:1.31 Wed May 4 10:00:42 2005 +++ movitz/losp/muerte/los-closette.lisp Thu May 5 22:51:36 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.31 2005/05/04 08:00:42 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.32 2005/05/05 20:51:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -220,11 +220,11 @@ (check-type class (or null class)) #+ignore (case class-name - ((t) (setf (%run-time-context-slot 'the-class-t) class)) - (null (setf (%run-time-context-slot 'the-class-null) class)) - (symbol (setf (%run-time-context-slot 'the-class-symbol) class)) - (fixnum (setf (%run-time-context-slot 'the-class-fixnum) class)) - (cons (setf (%run-time-context-slot 'the-class-cons) class))) + ((t) (setf (%run-time-context-slot nil 'the-class-t) class)) + (null (setf (%run-time-context-slot nil 'the-class-null) class)) + (symbol (setf (%run-time-context-slot 'nil the-class-symbol) class)) + (fixnum (setf (%run-time-context-slot nil 'the-class-fixnum) class)) + (cons (setf (%run-time-context-slot nil 'the-class-cons) class))) (let ((map (load-global-constant classes))) (when (member class-name (svref map 0)) (setf (svref map (1+ (position class-name (svref map 0)))) From ffjeld at common-lisp.net Thu May 5 20:51:46 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 22:51:46 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: <20050505205146.77B28880E0@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19917 Modified Files: primitive-functions.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:51:45 2005 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.64 movitz/losp/muerte/primitive-functions.lisp:1.65 --- movitz/losp/muerte/primitive-functions.lisp:1.64 Thu May 5 15:59:37 2005 +++ movitz/losp/muerte/primitive-functions.lisp Thu May 5 22:51:43 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.64 2005/05/05 13:59:37 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.65 2005/05/05 20:51:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -360,7 +360,7 @@ (defun malloc-cons-pointer () "Return current cons-pointer in 8-byte units since buffer-start." - (let ((x (%run-time-context-slot 'nursery-space))) + (let ((x (%run-time-context-slot nil 'nursery-space))) (when (typep x 'vector) (truncate (aref x 0) 8))) #+ignore From ffjeld at common-lisp.net Thu May 5 20:51:52 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 22:51:52 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/restarts.lisp Message-ID: <20050505205152.81AB7880E0@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19940 Modified Files: restarts.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:51:51 2005 Author: ffjeld Index: movitz/losp/muerte/restarts.lisp diff -u movitz/losp/muerte/restarts.lisp:1.5 movitz/losp/muerte/restarts.lisp:1.6 --- movitz/losp/muerte/restarts.lisp:1.5 Fri Nov 12 15:52:24 2004 +++ movitz/losp/muerte/restarts.lisp Thu May 5 22:51:51 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001, 2003-2004, +;;;; Copyright (C) 2001, 2003-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 28 09:27:13 2003 ;;;; -;;;; $Id: restarts.lisp,v 1.5 2004/11/12 14:52:24 ffjeld Exp $ +;;;; $Id: restarts.lisp,v 1.6 2005/05/05 20:51:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -33,12 +33,12 @@ (restart-bind ,rest-specs , at body)))))) (defun dynamic-context->basic-restart (context) - (assert (< (%run-time-context-slot 'stack-bottom) + (assert (< (%run-time-context-slot nil 'stack-bottom) context - (%run-time-context-slot 'stack-top))) + (%run-time-context-slot nil 'stack-top))) (assert (eq (load-global-constant restart-tag) (stack-frame-ref nil context 1 :lisp))) - (let ((x (- (%run-time-context-slot 'stack-top) context))) + (let ((x (- (%run-time-context-slot nil 'stack-top) context))) (assert (below x #x1000000)) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) x) From ffjeld at common-lisp.net Thu May 5 20:51:56 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 22:51:56 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: <20050505205156.BC8EE88720@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19956 Modified Files: scavenge.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:51:55 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.49 movitz/losp/muerte/scavenge.lisp:1.50 --- movitz/losp/muerte/scavenge.lisp:1.49 Wed Mar 9 08:24:16 2005 +++ movitz/losp/muerte/scavenge.lisp Thu May 5 22:51:55 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.49 2005/03/09 07:24:16 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.50 2005/05/05 20:51:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -84,6 +84,19 @@ (assert (evenp scan) () "Scanned struct-header ~S at odd location #x~X." x scan) (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))) + ((scavenge-typep x :run-time-context) + (assert (evenp scan) () + "Scanned run-time-context-header ~S at odd location #x~X." + (memref scan 0 :type :unsigned-byte32) scan) + (incf scan) + (let ((non-lispvals #.(cl:truncate (cl:+ -4 (bt:slot-offset 'movitz::movitz-run-time-context + 'movitz::pointer-start) + (movitz::image-nil-word movitz:*image*)) + 4)) + (end (+ scan #.(movitz::movitz-type-word-size 'movitz::movitz-run-time-context)))) + (incf scan non-lispvals) + (map-lisp-vals function scan (1+ end)) + (setf scan end))) ((scavenge-typep x :funobj) (assert (evenp scan) () "Scanned funobj-header ~S at odd location #x~X." @@ -213,7 +226,9 @@ (defun scavenge-find-pf (function location) (loop for (slot-name type) in (slot-value (class-of (current-run-time-context)) 'slot-map) do (when (eq type 'code-vector-word) - (let ((it (scavenge-match-code-vector function (%run-time-context-slot slot-name) location))) + (let ((it (scavenge-match-code-vector function + (%run-time-context-slot nil slot-name) + location))) (when it (return it)))))) (defun scavenge-find-code-vector (function location casf-funobj esi &optional primitive-function-p edx) @@ -234,7 +249,9 @@ (scavenge-match-code-vector function x location))))))) (cond ((scavenge-match-code-vector function (symbol-value 'ret-trampoline) location)) - ((scavenge-match-code-vector function (%run-time-context-slot 'dynamic-jump-next) location)) + ((scavenge-match-code-vector function + (%run-time-context-slot nil 'dynamic-jump-next) + location)) ((eq 0 casf-funobj) (let ((dit-code-vector (symbol-value 'default-interrupt-trampoline))) (cond From ffjeld at common-lisp.net Thu May 5 20:52:04 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 22:52:04 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp Message-ID: <20050505205204.B4B5C880E0@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19977 Modified Files: inspect.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:52:03 2005 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.52 movitz/losp/muerte/inspect.lisp:1.53 --- movitz/losp/muerte/inspect.lisp:1.52 Thu May 5 00:46:44 2005 +++ movitz/losp/muerte/inspect.lisp Thu May 5 22:52:02 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.52 2005/05/04 22:46:44 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.53 2005/05/05 20:52:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -53,11 +53,6 @@ (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))) - (define-compiler-macro current-stack-frame () `(with-inline-assembly (:returns :eax) (:leal ((:ebp ,(truncate movitz::+movitz-fixnum-factor+ 4))) @@ -322,7 +317,11 @@ (std-instance (and (typep y 'std-instance) (test std-instance-class) - (test std-instance-slots))))))))) + (test std-instance-slots))) + (run-time-context + (and (typep y 'run-time-context) + (test %run-time-context-slot 'slots) + (test %run-time-context-slot 'class))))))))) (define-compiler-macro %lispval-object (integer &environment env) "Return the object that is wrapped in the 32-bit integer lispval." From ffjeld at common-lisp.net Thu May 5 20:52:12 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 22:52:12 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp Message-ID: <20050505205212.B2771880E0@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19993 Modified Files: more-macros.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:52:11 2005 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.26 movitz/losp/muerte/more-macros.lisp:1.27 --- movitz/losp/muerte/more-macros.lisp:1.26 Thu May 5 20:08:20 2005 +++ movitz/losp/muerte/more-macros.lisp Thu May 5 22:52:10 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.26 2005/05/05 18:08:20 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.27 2005/05/05 20:52:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -318,14 +318,15 @@ ,format-control , at format-arguments) , at body)) -(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))) +(define-compiler-macro %run-time-context-slot (&whole form &environment env context slot-name) + (if (not (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)) + (if (or (and (movitz:movitz-constantp context env) + (eq nil (movitz:movitz-eval context env))) + (equal context '(current-run-time-context))) (ecase slot-type (movitz::word `(with-inline-assembly (:returns :eax) @@ -359,26 +360,31 @@ ,(- (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)))) +(define-compiler-macro (setf %run-time-context-slot) (&whole form &environment env value context slot-name) + (if (not (movitz:movitz-constantp slot-name env)) 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)))))))))) + (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 (or (and (movitz:movitz-constantp context env) + (eq nil (movitz:movitz-eval context env))) + (equal context '(current-run-time-context))) + (ecase slot-type + (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))))))) + ;; FIXME + form)))) (define-compiler-macro read-time-stamp-counter () `(with-inline-assembly-case () From ffjeld at common-lisp.net Thu May 5 20:52:25 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 22:52:25 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/lib/threading.lisp Message-ID: <20050505205225.9A49B880E0@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv20012 Modified Files: threading.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:52:21 2005 Author: ffjeld Index: movitz/losp/lib/threading.lisp diff -u movitz/losp/lib/threading.lisp:1.2 movitz/losp/lib/threading.lisp:1.3 --- movitz/losp/lib/threading.lisp:1.2 Thu May 5 17:21:59 2005 +++ movitz/losp/lib/threading.lisp Thu May 5 22:52:21 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Apr 28 08:30:01 2005 ;;;; -;;;; $Id: threading.lisp,v 1.2 2005/05/05 15:21:59 ffjeld Exp $ +;;;; $Id: threading.lisp,v 1.3 2005/05/05 20:52:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -26,7 +26,8 @@ (in-package muerte) (defclass thread (run-time-context) - () + ((segment-selector + :initform :segment-selector)) (:metaclass run-time-context-class)) (defmacro control-stack-ebp (stack) @@ -109,11 +110,11 @@ (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) + (setf (%run-time-context-slot thread 'dynamic-env) 0 + (%run-time-context-slot thread 'stack-vector) stack + (%run-time-context-slot thread 'stack-top) (+ 2 (object-location stack) (length stack)) - (%run-time-context-slot 'stack-bottom thread) (+ (object-location stack) 2 + (%run-time-context-slot thread 'stack-bottom) (+ (object-location stack) 2 (or cushion (if (>= (length stack) 200) 100 @@ -123,8 +124,8 @@ (defun yield (target-rtc &optional value) (declare (dynamic-extent values)) (assert (not (eq target-rtc (current-run-time-context)))) - (let ((my-stack (%run-time-context-slot 'stack-vector)) - (target-stack (%run-time-context-slot 'stack-vector target-rtc))) + (let ((my-stack (%run-time-context-slot nil 'stack-vector)) + (target-stack (%run-time-context-slot target-rtc 'stack-vector))) (assert (not (eq my-stack target-stack))) (let ((fs (control-stack-fs target-stack)) (esp (control-stack-esp target-stack)) @@ -137,8 +138,8 @@ ;; Push eflags for later.. (setf (memref (decf esp) 0) (eflags)) ;; Store EBP and ESP so we can get to them after the switch - (setf (%run-time-context-slot 'scratch1 target-rtc) ebp - (%run-time-context-slot 'scratch2 target-rtc) esp) + (setf (%run-time-context-slot target-rtc 'scratch1) ebp + (%run-time-context-slot target-rtc 'scratch2) esp) ;; Enable someone to yield back here.. (setf (control-stack-fs my-stack) (segment-register :fs) (control-stack-ebp my-stack) (muerte::asm-register :ebp) From ffjeld at common-lisp.net Thu May 5 20:52:40 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 22:52:40 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/lib/malloc-init.lisp Message-ID: <20050505205240.856FC88720@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv20034 Modified Files: malloc-init.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:52:40 2005 Author: ffjeld Index: movitz/losp/lib/malloc-init.lisp diff -u movitz/losp/lib/malloc-init.lisp:1.6 movitz/losp/lib/malloc-init.lisp:1.7 --- movitz/losp/lib/malloc-init.lisp:1.6 Mon Oct 11 15:52:01 2004 +++ movitz/losp/lib/malloc-init.lisp Thu May 5 22:52:40 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Jan 9 15:57:22 2002 ;;;; -;;;; $Id: malloc-init.lisp,v 1.6 2004/10/11 13:52:01 ffjeld Exp $ +;;;; $Id: malloc-init.lisp,v 1.7 2005/05/05 20:52:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -19,7 +19,7 @@ (in-package muerte.lib) -(let* ((stack-vector (%run-time-context-slot 'muerte::stack-vector)) +(let* ((stack-vector (%run-time-context-slot nil 'muerte::stack-vector)) ;; We assume the kernel static are ends with the stack-vector. (kernel-end-location (+ 2 (muerte:object-location stack-vector) (array-dimension stack-vector 0))) From ffjeld at common-lisp.net Thu May 5 20:52:51 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 5 May 2005 22:52:51 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: <20050505205251.4333D880E0@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv20059 Modified Files: debugger.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:52:46 2005 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.39 movitz/losp/x86-pc/debugger.lisp:1.40 --- movitz/losp/x86-pc/debugger.lisp:1.39 Mon Apr 25 00:13:54 2005 +++ movitz/losp/x86-pc/debugger.lisp Thu May 5 22:52:45 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.39 2005/04/24 22:13:54 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.40 2005/05/05 20:52:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -460,7 +460,7 @@ (loop with location = (truncate eip 4) for (slot-name type) in (slot-value (class-of context) 'slot-map) do (when (eq type 'code-vector-word) - (let ((code-vector (%run-time-context-slot slot-name))) + (let ((code-vector (%run-time-context-slot nil slot-name))) (when (location-in-object-p code-vector location) (return (values slot-name (code-vector-offset code-vector eip)))))))) @@ -629,7 +629,7 @@ thereis (match-funobj (method-function m) instruction-location (1- limit)))))))) (or (loop for (slot-name type) in (slot-value (class-of (current-run-time-context)) 'slot-map) do (when (and (eq type 'code-vector-word) - (location-in-object-p (%run-time-context-slot slot-name) + (location-in-object-p (%run-time-context-slot nil slot-name) instruction-location)) (return (values slot-name :run-time-context)))) (with-hash-table-iterator (hashis *setf-namespace*) From ffjeld at common-lisp.net Fri May 6 07:12:20 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 6 May 2005 09:12:20 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/lib/threading.lisp Message-ID: <20050506071220.D92578874C@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv5838 Modified Files: threading.lisp Log Message: Started work on segment-descriptor-manager that will hand out segment selectors to interested parties. Date: Fri May 6 09:04:43 2005 Author: ffjeld Index: movitz/losp/lib/threading.lisp diff -u movitz/losp/lib/threading.lisp:1.3 movitz/losp/lib/threading.lisp:1.4 --- movitz/losp/lib/threading.lisp:1.3 Thu May 5 22:52:21 2005 +++ movitz/losp/lib/threading.lisp Fri May 6 08:59:03 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Apr 28 08:30:01 2005 ;;;; -;;;; $Id: threading.lisp,v 1.3 2005/05/05 20:52:21 ffjeld Exp $ +;;;; $Id: threading.lisp,v 1.4 2005/05/06 06:59:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -24,6 +24,27 @@ )) (in-package muerte) + +(defclass segment-descriptor-manager () + ((table + :accessor segment-descriptor-table + :initarg :table + :initform (dump-global-segment-table :entries 32)) + (range-start + :initarg :range-start + :accessor range-start + :initform (1+ (ceiling (reduce #'max '(:cs :ds :es :ss :fs) + :key #'segment-register) + 8))))) + +(defmethod allocate-segment-selector ((manager segment-descriptor-manager) &optional errorp) + (loop with table = (segment-descriptor-table manager) + for s from (range-start manager) below (/ (length table) 2) + do (when (zerop (ldb (byte 1 0) (segment-descriptor-avl-x-db-g table s))) + (setf (ldb (byte 1 0) (segment-descriptor-avl-x-db-g table s)) 1) + (return (* 8 s))) + finally (when errorp + (error "Unable to allocate a segment selector.")))) (defclass thread (run-time-context) ((segment-selector From ffjeld at common-lisp.net Fri May 6 15:39:44 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 6 May 2005 17:39:44 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp Message-ID: <20050506153944.EC5FC88716@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18309 Modified Files: los-closette.lisp Log Message: Right you were.. Date: Fri May 6 17:39:44 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.32 movitz/losp/muerte/los-closette.lisp:1.33 --- movitz/losp/muerte/los-closette.lisp:1.32 Thu May 5 22:51:36 2005 +++ movitz/losp/muerte/los-closette.lisp Fri May 6 17:39:44 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.32 2005/05/05 20:51:36 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.33 2005/05/06 15:39:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -222,7 +222,7 @@ (case class-name ((t) (setf (%run-time-context-slot nil 'the-class-t) class)) (null (setf (%run-time-context-slot nil 'the-class-null) class)) - (symbol (setf (%run-time-context-slot 'nil the-class-symbol) class)) + (symbol (setf (%run-time-context-slot nil 'the-class-symbol) class)) (fixnum (setf (%run-time-context-slot nil 'the-class-fixnum) class)) (cons (setf (%run-time-context-slot nil 'the-class-cons) class))) (let ((map (load-global-constant classes))) From ffjeld at common-lisp.net Fri May 6 20:53:36 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 6 May 2005 22:53:36 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/hash-tables.lisp Message-ID: <20050506205336.D8319880A4@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12933 Modified Files: hash-tables.lisp Log Message: Let's call it --no-hash-key--. Date: Fri May 6 22:53:36 2005 Author: ffjeld Index: movitz/losp/muerte/hash-tables.lisp diff -u movitz/losp/muerte/hash-tables.lisp:1.4 movitz/losp/muerte/hash-tables.lisp:1.5 --- movitz/losp/muerte/hash-tables.lisp:1.4 Mon Oct 11 15:52:37 2004 +++ movitz/losp/muerte/hash-tables.lisp Fri May 6 22:53:36 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Feb 19 19:09:05 2001 ;;;; -;;;; $Id: hash-tables.lisp,v 1.4 2004/10/11 13:52:37 ffjeld Exp $ +;;;; $Id: hash-tables.lisp,v 1.5 2005/05/06 20:53:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -44,7 +44,7 @@ (equal (values #'equal #'sxhash))) (make-hash-table-object :test test - :bucket (make-array (* 2 size) :initial-element '#.movitz::+undefined-hash-key+) + :bucket (make-array (* 2 size) :initial-element '--no-hash-key--) :sxhash sxhash))) (defun hash-table-count (hash-table) @@ -53,7 +53,7 @@ (count 0) (i 0 (+ i 2))) ((>= i length) count) - (unless (eq (svref bucket i) '#.movitz::+undefined-hash-key+) + (unless (eq (svref bucket i) '--no-hash-key--) (incf count)))) (defun hash-table-iterator (bucket index) @@ -61,7 +61,7 @@ (do ((length (array-dimension bucket 0))) ((>= index length) nil) (unless (eq (svref bucket index) - '#.movitz::+undefined-hash-key+) + '--no-hash-key--) (return (+ index 2))) (incf index 2)))) @@ -130,7 +130,7 @@ (do () (nil) (let ((k (svref%unsafe bucket i2))) (cond - ((eq '#.movitz::+undefined-hash-key+ k) + ((eq k '--no-hash-key--) (return (values default nil))) ((funcall test key k) (return (values (svref%unsafe bucket (1+ i2)) t))))) @@ -147,7 +147,7 @@ (do () (nil) (let ((k (svref%unsafe bucket i2))) (cond - ((eq '#.movitz::+undefined-hash-key+ k) + ((eq k '--no-hash-key--) (return nil)) ((eq key0 (car k)) (return (svref%unsafe bucket (1+ i2)))))) @@ -165,7 +165,7 @@ (do () (nil) (let ((k (svref%unsafe bucket i2))) (cond - ((eq '#.movitz::+undefined-hash-key+ k) + ((eq k '--no-hash-key--) (return nil)) ((and (eq key0 (car k)) (eq key1 (cadr k))) (return (svref%unsafe bucket (1+ i2)))))) @@ -183,7 +183,7 @@ ((>= c bucket-length) (error "Hash-table bucket is full, needs rehashing, which isn't implemented.")) (let ((k (svref%unsafe bucket index2))) - (when (or (eq '#.movitz::+undefined-hash-key+ k) + (when (or (eq k '--no-hash-key--) (funcall test k key)) (return (setf (svref%unsafe bucket index2) key (svref%unsafe bucket (1+ index2)) value)))) @@ -197,7 +197,7 @@ (index2 (rem (* 2 (sxhash-subvector key-string start end 8)) bucket-length) (rem (+ 2 index2) bucket-length))) - ((eq '#.movitz::+undefined-hash-key+ + ((eq '--no-hash-key-- (svref%unsafe bucket index2)) (values default nil)) (when ;; (string= key-string (svref bucket index2) :start1 start :end1 end)) @@ -221,19 +221,19 @@ (i 0 (+ i 2))) ((>= i bucket-length) nil) (let ((x (svref bucket index2))) - (when (or (eq '#.movitz::+undefined-hash-key+ x) + (when (or (eq x '--no-hash-key--) (funcall (hash-table-test hash-table) x key)) - (setf (svref bucket index2) '#.movitz::+undefined-hash-key+) + (setf (svref bucket index2) '--no-hash-key--) ;; Now we must rehash any entries that might have been ;; displaced by the one we have now removed. (do ((i (rem (+ index2 2) bucket-length) (rem (+ i 2) bucket-length))) ((= i index2)) (let ((k (svref bucket i))) - (when (eq x '#.movitz::+undefined-hash-key+) + (when (eq x '--no-hash-key--) (return)) (let ((v (svref bucket (1+ i)))) - (setf (svref bucket i) '#.movitz::+undefined-hash-key+) ; remove + (setf (svref bucket i) '--no-hash-key--) ; remove (setf (gethash k hash-table) v)))) ; insert (hopefully this is safe..) (return t))))) @@ -242,7 +242,7 @@ (bucket-length (length bucket)) (i 0 (+ i 2))) ((>= i bucket-length) hash-table) - (setf (svref bucket i) '#.movitz::+undefined-hash-key+))) + (setf (svref bucket i) '--no-hash-key--))) (defun maphash (function hash-table) (with-hash-table-iterator (get-next-entry hash-table) From ffjeld at common-lisp.net Sun May 8 01:16:31 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 8 May 2005 03:16:31 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050508011631.569C988704@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24945 Modified Files: compiler.lisp Log Message: *** empty log message *** Date: Sun May 8 03:16:27 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.138 movitz/compiler.lisp:1.139 --- movitz/compiler.lisp:1.138 Thu May 5 00:47:38 2005 +++ movitz/compiler.lisp Sun May 8 03:16:26 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.138 2005/05/04 22:47:38 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.139 2005/05/08 01:16:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1378,7 +1378,7 @@ (let* ((muerte.cl::*compile-file-pathname* path) (*package* (find-package :muerte)) (funobj (make-instance 'movitz-funobj-pass1 - :name (intern (format nil "file-~A" path) :muerte) + :name (intern (format nil "~A" path) :muerte) :lambda-list (movitz-read nil))) (funobj-env (make-local-movitz-environment nil funobj :type 'funobj-env From ffjeld at common-lisp.net Sun May 8 01:16:42 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 8 May 2005 03:16:42 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: <20050508011642.1E0DB88704@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24971 Modified Files: packages.lisp Log Message: *** empty log message *** Date: Sun May 8 03:16:41 2005 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.48 movitz/packages.lisp:1.49 --- movitz/packages.lisp:1.48 Thu May 5 17:16:29 2005 +++ movitz/packages.lisp Sun May 8 03:16:40 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.48 2005/05/05 15:16:29 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.49 2005/05/08 01:16:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1116,6 +1116,9 @@ #:backtrace #:dit-frame-ref + #:stack-frame-ref + #:stack-frame-uplink + #:stack-frame-funobj #:check-stack-limit #:current-stack-frame #:interrupt-default-handler @@ -1148,6 +1151,7 @@ #:object-location #:object-tag #:location-in-object-p + #:location-physical-offset #:define-compile-time-variable #:define-primitive-function #:without-gc From ffjeld at common-lisp.net Sun May 8 01:17:05 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 8 May 2005 03:17:05 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: <20050508011705.0448F88729@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv25004 Modified Files: storage-types.lisp Log Message: *** empty log message *** Date: Sun May 8 03:17:05 2005 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.51 movitz/storage-types.lisp:1.52 --- movitz/storage-types.lisp:1.51 Sat Apr 30 23:15:43 2005 +++ movitz/storage-types.lisp Sun May 8 03:17:05 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.51 2005/04/30 21:15:43 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.52 2005/05/08 01:17:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -992,7 +992,7 @@ (defconstant +undefined-hash-key+ - 'muerte::hash-table-undefined-key) + 'muerte::--no-hash-key--) (defun movitz-sxhash (object) "Must match the SXHASH function in :cl/hash-tables." From ffjeld at common-lisp.net Sun May 8 01:18:02 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 8 May 2005 03:18:02 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/ll-testing.lisp Message-ID: <20050508011802.AE26188704@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv25040 Modified Files: ll-testing.lisp Log Message: *** empty log message *** Date: Sun May 8 03:18:02 2005 Author: ffjeld Index: movitz/losp/ll-testing.lisp diff -u movitz/losp/ll-testing.lisp:1.8 movitz/losp/ll-testing.lisp:1.9 --- movitz/losp/ll-testing.lisp:1.8 Thu May 5 17:16:45 2005 +++ movitz/losp/ll-testing.lisp Sun May 8 03:18:02 2005 @@ -10,42 +10,32 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Apr 14 08:18:43 2005 ;;;; -;;;; $Id: ll-testing.lisp,v 1.8 2005/05/05 15:16:45 ffjeld Exp $ +;;;; $Id: ll-testing.lisp,v 1.9 2005/05/08 01:18:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :ll-testing) (in-package muerte) -(defun dump-global-segment-table (&key table entries nofill) - "Dump contents of the current global (segment) descriptor table into a vector." - (multiple-value-bind (gdt-base gdt-limit) - (%sgdt) - (let* ((gdt-entries (/ (1+ gdt-limit) 8)) - (entries (or entries gdt-entries))) - (check-type entries (integer 1 8192)) - (let ((table (or table - (make-array (* 2 entries) - :element-type '(unsigned-byte 32) - :initial-element 0)))) - (check-type table (vector (unsigned-byte 32))) - (unless nofill - (loop for i upfrom 0 below (* 2 gdt-entries) - do (setf (aref table i) - (memref gdt-base 0 :index i :type :unsigned-byte32 :physicalp t)))) - table)))) +;;;(defun dump-global-segment-table (&key table entries nofill) +;;; "Dump contents of the current global (segment) descriptor table into a vector." +;;; (multiple-value-bind (gdt-base gdt-limit) +;;; (%sgdt) +;;; (let* ((gdt-entries (/ (1+ gdt-limit) 8)) +;;; (entries (or entries gdt-entries))) +;;; (check-type entries (integer 1 8192)) +;;; (let ((table (or table +;;; (make-array (* 2 entries) +;;; :element-type '(unsigned-byte 32) +;;; :initial-element 0)))) +;;; (check-type table (vector (unsigned-byte 32))) +;;; (unless nofill +;;; (loop for i upfrom 0 below (* 2 gdt-entries) +;;; do (setf (aref table i) +;;; (memref gdt-base 0 :index i :type :unsigned-byte32 :physicalp t)))) +;;; table)))) + -(defun install-global-segment-table (table &optional entries) - "Install as the GDT. -NB! ensure that the table object isn't garbage-collected." - (check-type table (vector (unsigned-byte 32))) - (let ((entries (or entries (truncate (length table) 2)))) - (check-type entries (integer 0 *)) - (let ((limit (1- (* 8 entries))) - (base (+ 2 (+ (object-location table) - (location-physical-offset))))) - (%lgdt base limit) - (values table limit)))) (defun format-segment-table (table &key (start 0) (end (truncate (length table) 2))) From ffjeld at common-lisp.net Sun May 8 01:18:29 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 8 May 2005 03:18:29 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/hash-tables.lisp Message-ID: <20050508011829.DFEAA88704@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25068 Modified Files: hash-tables.lisp Log Message: *** empty log message *** Date: Sun May 8 03:18:29 2005 Author: ffjeld Index: movitz/losp/muerte/hash-tables.lisp diff -u movitz/losp/muerte/hash-tables.lisp:1.5 movitz/losp/muerte/hash-tables.lisp:1.6 --- movitz/losp/muerte/hash-tables.lisp:1.5 Fri May 6 22:53:36 2005 +++ movitz/losp/muerte/hash-tables.lisp Sun May 8 03:18:29 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Feb 19 19:09:05 2001 ;;;; -;;;; $Id: hash-tables.lisp,v 1.5 2005/05/06 20:53:36 ffjeld Exp $ +;;;; $Id: hash-tables.lisp,v 1.6 2005/05/08 01:18:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -60,8 +60,7 @@ (when index (do ((length (array-dimension bucket 0))) ((>= index length) nil) - (unless (eq (svref bucket index) - '--no-hash-key--) + (unless (eq (svref bucket index) '--no-hash-key--) (return (+ index 2))) (incf index 2)))) From ffjeld at common-lisp.net Sun May 8 01:18:43 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 8 May 2005 03:18:43 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: <20050508011843.D711B88704@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25088 Modified Files: interrupt.lisp Log Message: *** empty log message *** Date: Sun May 8 03:18:43 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.43 movitz/losp/muerte/interrupt.lisp:1.44 --- movitz/losp/muerte/interrupt.lisp:1.43 Thu May 5 22:51:27 2005 +++ movitz/losp/muerte/interrupt.lisp Sun May 8 03:18:43 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.43 2005/05/05 20:51:27 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.44 2005/05/08 01:18:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -304,8 +304,7 @@ (case vector (0 (error 'division-by-zero)) (3 (break "Break instruction at ~@Z." $eip)) - (4 (warn "into ~@Z" $eax) - (if (not (eq (load-global-constant new-unbound-value) + (4 (if (not (eq (load-global-constant new-unbound-value) (dereference $eax))) (error "Primitive overflow assertion failed.") (let ((name (dereference $ebx))) From ffjeld at common-lisp.net Sun May 8 01:19:42 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 8 May 2005 03:19:42 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp Message-ID: <20050508011942.7262688704@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25129 Modified Files: segments.lisp Log Message: For the segment-descriptor-table accessors, use "selectors" (as in the quantities loaded into segment registers) rather than indexes. Date: Sun May 8 03:19:42 2005 Author: ffjeld Index: movitz/losp/muerte/segments.lisp diff -u movitz/losp/muerte/segments.lisp:1.13 movitz/losp/muerte/segments.lisp:1.14 --- movitz/losp/muerte/segments.lisp:1.13 Sat Apr 30 00:36:05 2005 +++ movitz/losp/muerte/segments.lisp Sun May 8 03:19:41 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu May 8 14:25:06 2003 ;;;; -;;;; $Id: segments.lisp,v 1.13 2005/04/29 22:36:05 ffjeld Exp $ +;;;; $Id: segments.lisp,v 1.14 2005/05/08 01:19:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -162,13 +162,26 @@ (:cr3 (set-creg :cr3)) (:cr4 (set-creg :cr4))) value)) + +;; + +(defun (setf global-segment-descriptor-table) (table) + "Install
as the GDT. +NB! you need ensure that the table object isn't garbage-collected." + (check-type table (vector (unsigned-byte 32))) + (let ((limit (1- (* 2 (length table)))) + (base (+ 2 (+ (object-location table) + (location-physical-offset))))) + (%lgdt base limit) + table)) -(defun segment-descriptor-base-location (table index) +(defun segment-descriptor-base-location (table selector) (check-type table (and vector (not simple-vector))) (eval-when (:compile-toplevel) (assert (= 4 movitz::+movitz-fixnum-factor+))) ;; XXX This fails for locations above 2GB. - (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (let ((offset (+ (logand selector #xfff8) + (movitz-type-slot-offset 'movitz-basic-vector 'data)))) (logior (ash (memref table (+ 7 offset) :type :unsigned-byte8) 22) (ash (memref table (+ 4 offset) :type :unsigned-byte8) @@ -176,11 +189,12 @@ (ash (memref table (+ 2 offset) :type :unsigned-byte16) -2)))) -(defun (setf segment-descriptor-base-location) (base-location table index) +(defun (setf segment-descriptor-base-location) (base-location table selector) (check-type table (and vector (not simple-vector))) (eval-when (:compile-toplevel) (assert (= 4 movitz::+movitz-fixnum-factor+))) - (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (let ((offset (+ (logand #xfff8 selector) + (movitz-type-slot-offset 'movitz-basic-vector 'data)))) (setf (memref table (+ 7 offset) :type :unsigned-byte8) (ldb (byte 8 22) base-location)) (setf (memref table (+ 4 offset) :type :unsigned-byte8) @@ -189,66 +203,91 @@ (ash (ldb (byte 14 0) base-location) 2)) base-location)) -(defun segment-descriptor-limit (table index) +(defun segment-descriptor-limit (table selector) (check-type table (and vector (not simple-vector))) - (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (let ((offset (+ (logand #xfff8 selector) + (movitz-type-slot-offset 'movitz-basic-vector 'data)))) (dpb (memref table (+ 6 offset) :type :unsigned-byte8) (byte 4 16) (memref table (+ 0 offset) :type :unsigned-byte16)))) -(defun (setf segment-descriptor-limit) (limit table index) +(defun (setf segment-descriptor-limit) (limit table selector) (check-type table (and vector (not simple-vector))) - (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (let ((offset (+ (logand #xfff8 selector) + (movitz-type-slot-offset 'movitz-basic-vector 'data)))) (setf (memref table (+ 6 offset) :type :unsigned-byte8) (ldb (byte 4 16) limit)) (setf (memref table (+ 0 offset) :type :unsigned-byte8) (ldb (byte 16 0) limit)) limit)) -(defun segment-descriptor-type-s-dpl-p (table index) +(defun segment-descriptor-type-s-dpl-p (table selector) "Access bits 40-47 of the segment descriptor." (check-type table (and vector (not simple-vector))) - (memref table (+ 5 (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)) + (memref table (+ 5 (logand #xfff8 selector) + (movitz-type-slot-offset 'movitz-basic-vector 'data)) :type :unsigned-byte8)) -(defun (setf segment-descriptor-type-s-dpl-p) (bits table index) +(defun (setf segment-descriptor-type-s-dpl-p) (bits table selector) "Access bits 40-47 of the segment descriptor." (check-type table (and vector (not simple-vector))) - (setf (memref table (+ 5 (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)) + (setf (memref table (+ 5 (logand #xfff8 selector) + (movitz-type-slot-offset 'movitz-basic-vector 'data)) :type :unsigned-byte8) bits)) -(defun segment-descriptor-avl-x-db-g (table index) +(defun segment-descriptor-avl-x-db-g (table selector) "Access bits 52-55 of the segment descriptor." (check-type table (and vector (not simple-vector))) (ldb (byte 4 4) - (memref table (+ 6 (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)) + (memref table (+ 6 (logand #xfff8 selector) + (movitz-type-slot-offset 'movitz-basic-vector 'data)) :type :unsigned-byte8))) -(defun (setf segment-descriptor-avl-x-db-g) (bits table index) +(defun (setf segment-descriptor-avl-x-db-g) (bits table selector) "Access bits 52-55 of the segment descriptor." (check-type table (and vector (not simple-vector))) (setf (ldb (byte 4 4) - (memref table (+ 6 (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)) + (memref table (+ 6 (logand #xfff8 selector) + (movitz-type-slot-offset 'movitz-basic-vector 'data)) :type :unsigned-byte8)) bits)) -(defun segment-descriptor (table index) +(defun segment-descriptor (table selector) "Access entire segment descriptor as a 64-bit integer." (check-type table (and vector (not simple-vector))) - (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (let ((offset (+ (logand #xfff8 selector) + (movitz-type-slot-offset 'movitz-basic-vector 'data)))) (logior (ash (memref table offset :index 1 :type :unsigned-byte32) 32) (ash (memref table offset :index 0 :type :unsigned-byte32) 0)))) -(defun (setf segment-descriptor) (value table index) +(defun (setf segment-descriptor) (value table selector) "Access entire segment descriptor as a 64-bit integer." (check-type table (and vector (not simple-vector))) - (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (let ((offset (+ (logand #xfff8 selector) + (movitz-type-slot-offset 'movitz-basic-vector 'data)))) (setf (memref table offset :index 1 :type :unsigned-byte32) (ldb (byte 32 32) value)) (setf (memref table offset :index 0 :type :unsigned-byte32) (ldb (byte 32 0) value)) value)) +(defun dump-global-segment-table (&key table entries nofill) + "Dump contents of the current global (segment) descriptor table into a vector." + (multiple-value-bind (gdt-base gdt-limit) + (%sgdt) + (let* ((gdt-entries (/ (1+ gdt-limit) 8)) + (entries (or entries gdt-entries))) + (check-type entries (integer 1 8192)) + (let ((table (or table + (make-array (* 2 entries) + :element-type '(unsigned-byte 32) + :initial-element 0)))) + (check-type table (vector (unsigned-byte 32))) + (unless nofill + (loop for i upfrom 0 below (* 2 gdt-entries) + do (setf (aref table i) + (memref gdt-base 0 :index i :type :unsigned-byte32 :physicalp t)))) + table)))) From ffjeld at common-lisp.net Sun May 8 01:20:02 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 8 May 2005 03:20:02 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp Message-ID: <20050508012002.D809688704@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv25156 Modified Files: los0.lisp Log Message: *** empty log message *** Date: Sun May 8 03:20:02 2005 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.44 movitz/losp/los0.lisp:1.45 --- movitz/losp/los0.lisp:1.44 Thu May 5 22:51:12 2005 +++ movitz/losp/los0.lisp Sun May 8 03:20:02 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.44 2005/05/05 20:51:12 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.45 2005/05/08 01:20:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -44,7 +44,8 @@ ;; #:muerte.ip6 #:muerte.ip4 #:muerte.mop - #:muerte.x86-pc.serial)) + #:muerte.x86-pc.serial + #:threading)) (require :los0-gc) ; Must come after defpackage. @@ -1365,7 +1366,7 @@ (setf *package* (find-package "INIT")) (when muerte::*multiboot-data* (set-textmode +vga-state-90x30+)) - + (cond ((not (cpu-featurep :tsc)) (warn "This CPU has no time-stamp-counter. Timer-related functions will not work.")) @@ -1379,6 +1380,10 @@ *standard-input* s *terminal-io* s *debug-io* s))) + + (setf threading:*segment-descriptor-table-manager* + (make-instance 'threading:segment-descriptor-table-manager)) + ;;; (ignore-errors ;;; (setf (symbol-function 'write-char) ;;; (muerte.x86-pc.serial::make-serial-write-char :baudrate 38400)) From ffjeld at common-lisp.net Sun May 8 01:20:49 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 8 May 2005 03:20:49 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/lib/threading.lisp Message-ID: <20050508012049.0863088704@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv25192 Modified Files: threading.lisp Log Message: (make-instance 'thread) and yield seem to work now.. :) Date: Sun May 8 03:20:48 2005 Author: ffjeld Index: movitz/losp/lib/threading.lisp diff -u movitz/losp/lib/threading.lisp:1.4 movitz/losp/lib/threading.lisp:1.5 --- movitz/losp/lib/threading.lisp:1.4 Fri May 6 08:59:03 2005 +++ movitz/losp/lib/threading.lisp Sun May 8 03:20:48 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Apr 28 08:30:01 2005 ;;;; -;;;; $Id: threading.lisp,v 1.4 2005/05/06 06:59:03 ffjeld Exp $ +;;;; $Id: threading.lisp,v 1.5 2005/05/08 01:20:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -19,36 +19,44 @@ (defpackage threading (:use cl muerte) (:export thread - make-thread yield + *segment-descriptor-table-manager* + segment-descriptor-table-manager + allocate-segment-selector )) -(in-package muerte) +(in-package threading) -(defclass segment-descriptor-manager () +(defvar *segment-descriptor-table-manager*) + +(defclass segment-descriptor-table-manager () ((table - :accessor segment-descriptor-table + :reader segment-descriptor-table :initarg :table - :initform (dump-global-segment-table :entries 32)) + :initform (setf (muerte::global-segment-descriptor-table) + (muerte::dump-global-segment-table :entries 64))) + (clients + :initform (make-array 64)) (range-start :initarg :range-start :accessor range-start - :initform (1+ (ceiling (reduce #'max '(:cs :ds :es :ss :fs) - :key #'segment-register) - 8))))) + :initform (+ 8 (logand #xfff8 (reduce #'max '(:cs :ds :es :ss :fs) + :key #'segment-register)))))) -(defmethod allocate-segment-selector ((manager segment-descriptor-manager) &optional errorp) +(defmethod allocate-segment-selector ((manager segment-descriptor-table-manager) client + &optional (errorp t)) (loop with table = (segment-descriptor-table manager) - for s from (range-start manager) below (/ (length table) 2) - do (when (zerop (ldb (byte 1 0) (segment-descriptor-avl-x-db-g table s))) - (setf (ldb (byte 1 0) (segment-descriptor-avl-x-db-g table s)) 1) - (return (* 8 s))) + with clients = (slot-value manager 'clients) + for selector from (range-start manager) below (* (length table) 2) by 8 + do (when (not (aref clients (truncate selector 8))) + (setf (aref clients (truncate selector 8)) client) + (return selector)) finally (when errorp (error "Unable to allocate a segment selector.")))) (defclass thread (run-time-context) ((segment-selector - :initform :segment-selector)) + :initarg :segment-selector)) (:metaclass run-time-context-class)) (defmacro control-stack-ebp (stack) @@ -60,6 +68,45 @@ (defmacro control-stack-fs (stack) `(stack-frame-ref ,stack 0 2)) +(defmethod initialize-instance :after ((thread thread) + &key (stack-size 2048) segment-selector stack-cushion + (function #'invoke-debugger) (args '(nil)) + &allow-other-keys) + (let ((segment-selector + (or segment-selector + (let ((selector (setf (slot-value thread 'segment-selector) + (allocate-segment-selector *segment-descriptor-table-manager* thread)))) + (setf (segment-descriptor (segment-descriptor-table *segment-descriptor-table-manager*) + selector) + (segment-descriptor (segment-descriptor-table *segment-descriptor-table-manager*) + (segment-register :fs))) + selector)))) + (check-type segment-selector (unsigned-byte 16)) + (setf (segment-descriptor-base-location (segment-descriptor-table *segment-descriptor-table-manager*) + segment-selector) + (+ (object-location thread) (location-physical-offset))) + (let ((stack (control-stack-init-for-yield (make-array stack-size + :element-type '(unsigned-byte 32)) + function args))) + (multiple-value-bind (ebp esp) + (control-stack-fixate stack) + (setf (control-stack-fs stack) segment-selector + (control-stack-ebp stack) ebp + (control-stack-esp stack) esp)) + (setf (%run-time-context-slot thread 'muerte::dynamic-env) 0) + (setf (%run-time-context-slot thread 'muerte::stack-vector) stack) + (setf (%run-time-context-slot thread 'muerte::stack-top) + (+ 2 (object-location stack) + (length stack))) + (setf (%run-time-context-slot thread 'muerte::stack-bottom) + (+ (object-location stack) 2 + (or stack-cushion + (if (>= (length stack) 200) + 100 + 0)))) + (values thread)))) + + (defun control-stack-push (value stack &optional (type :lisp)) (let ((i (decf (control-stack-esp stack)))) (assert (< 1 i (length stack))) @@ -113,40 +160,11 @@ (control-stack-enter-frame stack #'yield) stack) -(defun make-thread (&key (name (gensym "thread-")) (function #'invoke-debugger) args) - "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 nil #+ignore (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 thread 'dynamic-env) 0 - (%run-time-context-slot thread 'stack-vector) stack - (%run-time-context-slot thread 'stack-top) (+ 2 (object-location stack) - (length stack)) - (%run-time-context-slot thread 'stack-bottom) (+ (object-location stack) 2 - (or cushion - (if (>= (length stack) 200) - 100 - 0)))) - (values thread)))) - (defun yield (target-rtc &optional value) (declare (dynamic-extent values)) (assert (not (eq target-rtc (current-run-time-context)))) - (let ((my-stack (%run-time-context-slot nil 'stack-vector)) - (target-stack (%run-time-context-slot target-rtc 'stack-vector))) + (let ((my-stack (%run-time-context-slot nil 'muerte::stack-vector)) + (target-stack (%run-time-context-slot target-rtc 'muerte::stack-vector))) (assert (not (eq my-stack target-stack))) (let ((fs (control-stack-fs target-stack)) (esp (control-stack-esp target-stack)) @@ -159,8 +177,8 @@ ;; Push eflags for later.. (setf (memref (decf esp) 0) (eflags)) ;; Store EBP and ESP so we can get to them after the switch - (setf (%run-time-context-slot target-rtc 'scratch1) ebp - (%run-time-context-slot target-rtc 'scratch2) esp) + (setf (%run-time-context-slot target-rtc 'muerte::scratch1) ebp + (%run-time-context-slot target-rtc 'muerte::scratch2) esp) ;; Enable someone to yield back here.. (setf (control-stack-fs my-stack) (segment-register :fs) (control-stack-ebp my-stack) (muerte::asm-register :ebp) From ffjeld at common-lisp.net Sun May 8 13:41:33 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 8 May 2005 15:41:33 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/lib/threading.lisp Message-ID: <20050508134133.14458880A4@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv20517 Modified Files: threading.lisp Log Message: Use the thread's segment-selector rather than storing FS on the stack. Date: Sun May 8 15:41:32 2005 Author: ffjeld Index: movitz/losp/lib/threading.lisp diff -u movitz/losp/lib/threading.lisp:1.5 movitz/losp/lib/threading.lisp:1.6 --- movitz/losp/lib/threading.lisp:1.5 Sun May 8 03:20:48 2005 +++ movitz/losp/lib/threading.lisp Sun May 8 15:41:32 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Apr 28 08:30:01 2005 ;;;; -;;;; $Id: threading.lisp,v 1.5 2005/05/08 01:20:48 ffjeld Exp $ +;;;; $Id: threading.lisp,v 1.6 2005/05/08 13:41:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,6 +56,7 @@ (defclass thread (run-time-context) ((segment-selector + :reader segment-selector :initarg :segment-selector)) (:metaclass run-time-context-class)) @@ -65,9 +66,6 @@ (defmacro control-stack-esp (stack) `(stack-frame-ref ,stack 0 1)) -(defmacro control-stack-fs (stack) - `(stack-frame-ref ,stack 0 2)) - (defmethod initialize-instance :after ((thread thread) &key (stack-size 2048) segment-selector stack-cushion (function #'invoke-debugger) (args '(nil)) @@ -90,8 +88,7 @@ function args))) (multiple-value-bind (ebp esp) (control-stack-fixate stack) - (setf (control-stack-fs stack) segment-selector - (control-stack-ebp stack) ebp + (setf (control-stack-ebp stack) ebp (control-stack-esp stack) esp)) (setf (%run-time-context-slot thread 'muerte::dynamic-env) 0) (setf (%run-time-context-slot thread 'muerte::stack-vector) stack) @@ -166,7 +163,7 @@ (let ((my-stack (%run-time-context-slot nil 'muerte::stack-vector)) (target-stack (%run-time-context-slot target-rtc 'muerte::stack-vector))) (assert (not (eq my-stack target-stack))) - (let ((fs (control-stack-fs target-stack)) + (let ((fs (segment-selector target-rtc)) (esp (control-stack-esp target-stack)) (ebp (control-stack-ebp target-stack))) (assert (location-in-object-p target-stack esp)) @@ -180,8 +177,7 @@ (setf (%run-time-context-slot target-rtc 'muerte::scratch1) ebp (%run-time-context-slot target-rtc 'muerte::scratch2) esp) ;; Enable someone to yield back here.. - (setf (control-stack-fs my-stack) (segment-register :fs) - (control-stack-ebp my-stack) (muerte::asm-register :ebp) + (setf (control-stack-ebp my-stack) (muerte::asm-register :ebp) (control-stack-esp my-stack) (muerte::asm-register :esp)) (with-inline-assembly (:returns :eax) (:load-lexical (:lexical-binding fs) :untagged-fixnum-ecx) From ffjeld at common-lisp.net Sun May 8 22:02:47 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 9 May 2005 00:02:47 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: <20050508220247.6C5D8880A4@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30557 Modified Files: image.lisp Log Message: Have the values part be last, so that the RTC as a whole follows the
object layout pattern. Date: Mon May 9 00:02:46 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.99 movitz/image.lisp:1.100 --- movitz/image.lisp:1.99 Thu May 5 20:01:13 2005 +++ movitz/image.lisp Mon May 9 00:02:46 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.99 2005/05/05 18:01:13 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.100 2005/05/08 22:02:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -310,12 +310,6 @@ (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 @@ -414,7 +408,12 @@ :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)) + :map-binary-write 'map-interrupt-trampolines-to-idt) + (num-values + :binary-type word ; Fixnum + :initform 0) + (values + :binary-type #.(* 4 +movitz-multiple-values-limit+))) (:slot-align null-symbol -5)) (defun atomically-continuation-simple-pf (pf-name) From ffjeld at common-lisp.net Sun May 8 22:05:14 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 9 May 2005 00:05:14 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/lib/threading.lisp Message-ID: <20050508220514.6BFC0880A4@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv30718 Modified Files: threading.lisp Log Message: I was a bit too quick about using the segment-selector accessor rather than the control-stack-fs operator, since the basic RTC object doesn't have a segment-selector slot. I'll have to come up with a better protocol for this stuff, in general. Date: Mon May 9 00:05:13 2005 Author: ffjeld Index: movitz/losp/lib/threading.lisp diff -u movitz/losp/lib/threading.lisp:1.6 movitz/losp/lib/threading.lisp:1.7 --- movitz/losp/lib/threading.lisp:1.6 Sun May 8 15:41:32 2005 +++ movitz/losp/lib/threading.lisp Mon May 9 00:05:13 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Apr 28 08:30:01 2005 ;;;; -;;;; $Id: threading.lisp,v 1.6 2005/05/08 13:41:32 ffjeld Exp $ +;;;; $Id: threading.lisp,v 1.7 2005/05/08 22:05:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -66,6 +66,9 @@ (defmacro control-stack-esp (stack) `(stack-frame-ref ,stack 0 1)) +(defmacro control-stack-fs (stack) + `(stack-frame-ref ,stack 0 2)) + (defmethod initialize-instance :after ((thread thread) &key (stack-size 2048) segment-selector stack-cushion (function #'invoke-debugger) (args '(nil)) @@ -88,7 +91,8 @@ function args))) (multiple-value-bind (ebp esp) (control-stack-fixate stack) - (setf (control-stack-ebp stack) ebp + (setf (control-stack-fs stack) segment-selector + (control-stack-ebp stack) ebp (control-stack-esp stack) esp)) (setf (%run-time-context-slot thread 'muerte::dynamic-env) 0) (setf (%run-time-context-slot thread 'muerte::stack-vector) stack) @@ -163,7 +167,7 @@ (let ((my-stack (%run-time-context-slot nil 'muerte::stack-vector)) (target-stack (%run-time-context-slot target-rtc 'muerte::stack-vector))) (assert (not (eq my-stack target-stack))) - (let ((fs (segment-selector target-rtc)) + (let ((fs (control-stack-fs target-stack)) (esp (control-stack-esp target-stack)) (ebp (control-stack-ebp target-stack))) (assert (location-in-object-p target-stack esp)) @@ -177,7 +181,8 @@ (setf (%run-time-context-slot target-rtc 'muerte::scratch1) ebp (%run-time-context-slot target-rtc 'muerte::scratch2) esp) ;; Enable someone to yield back here.. - (setf (control-stack-ebp my-stack) (muerte::asm-register :ebp) + (setf (control-stack-fs my-stack) (segment-register :fs) + (control-stack-ebp my-stack) (muerte::asm-register :ebp) (control-stack-esp my-stack) (muerte::asm-register :esp)) (with-inline-assembly (:returns :eax) (:load-lexical (:lexical-binding fs) :untagged-fixnum-ecx) @@ -187,3 +192,4 @@ (:locally (:movl (:edi (:edi-offset scratch1)) :ebp)) (:locally (:movl (:edi (:edi-offset scratch2)) :esp)) (:popfl))))) + From ffjeld at common-lisp.net Mon May 9 06:20:56 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 9 May 2005 08:20:56 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: <20050509062056.66468880A4@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6419 Modified Files: interrupt.lisp Log Message: We _should_ do RET promotion of EIP, I think it was disabled for debugging purposes. Date: Mon May 9 08:20:55 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.44 movitz/losp/muerte/interrupt.lisp:1.45 --- movitz/losp/muerte/interrupt.lisp:1.44 Sun May 8 03:18:43 2005 +++ movitz/losp/muerte/interrupt.lisp Mon May 9 08:20:55 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.44 2005/05/08 01:18:43 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.45 2005/05/09 06:20:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -145,13 +145,13 @@ (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) - ;; Do RET atomicification -;;; (:movl (:ebp ,(dit-frame-offset :eip)) :ecx) -;;; ((:cs-override) :cmpb ,(realpart (ia-x86:asm :ret)) (:ecx)) -;;; (:jne 'not-at-ret-instruction) -;;; (:globally (:movl (:edi (:edi-offset ret-trampoline)) :ecx)) -;;; (:movl :ecx (:ebp ,(dit-frame-offset :eip))) -;;; not-at-ret-instruction + ;; Do RET promotion of EIP. + (:movl (:ebp ,(dit-frame-offset :eip)) :ecx) + ((:cs-override) :cmpb ,(realpart (ia-x86:asm :ret)) (:ecx)) + (:jne 'not-at-ret-instruction) + (:globally (:movl (:edi (:edi-offset ret-trampoline)) :ecx)) + (:movl :ecx (:ebp ,(dit-frame-offset :eip))) + not-at-ret-instruction (:xorl :eax :eax) ; Ensure safe value (:xorl :edx :edx) ; Ensure safe value From ffjeld at common-lisp.net Sat May 21 22:33:41 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 22 May 2005 00:33:41 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp Message-ID: <20050521223341.2307788753@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4727 Modified Files: sequences.lisp Log Message: Added a piece of (map 'string ..) Date: Sun May 22 00:33:40 2005 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.19 movitz/losp/muerte/sequences.lisp:1.20 --- movitz/losp/muerte/sequences.lisp:1.19 Wed Dec 15 14:58:34 2004 +++ movitz/losp/muerte/sequences.lisp Sun May 22 00:33:40 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.19 2004/12/15 13:58:34 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.20 2005/05/21 22:33:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -670,7 +670,25 @@ (declare (dynamic-extent more-sequences) (ignore function first-sequence more-sequences)) (error "MAP not implemented.")))) - + +(defun map-for-string (function first-sequence &rest more-sequences) + (numargs-case + (2 (function first-sequence) + (with-funcallable (mapf function) + (let ((result (make-string (length first-sequence)))) + (sequence-dispatch first-sequence + (vector + (do ((i 0 (1+ i))) + ((>= i (length result)) result) + (setf (char result i) (mapf (aref first-sequence i))))) + (list + (do ((i 0 (1+ i))) + ((>= i (length result)) result) + (setf (char result i) (mapf (pop first-sequence))))))))) + (t (function first-sequence &rest more-sequences) + (declare (ignore function first-sequence more-sequences)) + (error "MAP not implemented.")))) + (defun map (result-type function first-sequence &rest more-sequences) "=> result" @@ -680,6 +698,8 @@ (apply 'map-for-nil function first-sequence more-sequences)) ((eq 'list result-type) (apply 'map-for-list function first-sequence more-sequences)) + ((eq 'string result-type) + (apply 'map-for-string function first-sequence more-sequences)) (t (error "MAP not implemented.")))) (defun fill (sequence item &key (start 0) end) From ffjeld at common-lisp.net Sat May 21 22:36:17 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 22 May 2005 00:36:17 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp Message-ID: <20050521223617.8C65588753@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv4811 Modified Files: ip4.lisp Log Message: *** empty log message *** Date: Sun May 22 00:36:17 2005 Author: ffjeld Index: movitz/losp/lib/net/ip4.lisp diff -u movitz/losp/lib/net/ip4.lisp:1.17 movitz/losp/lib/net/ip4.lisp:1.18 --- movitz/losp/lib/net/ip4.lisp:1.17 Tue Apr 19 08:50:04 2005 +++ movitz/losp/lib/net/ip4.lisp Sun May 22 00:36:16 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 30 13:52:57 2003 ;;;; -;;;; $Id: ip4.lisp,v 1.17 2005/04/19 06:50:04 ffjeld Exp $ +;;;; $Id: ip4.lisp,v 1.18 2005/05/21 22:36:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -30,7 +30,9 @@ #:format-udp-header #:*ip4-nic* #:*ip4-ip* - #:*ip4-router*)) + #:*ip4-router* + + #:with-ip4-header)) (in-package muerte.ip4) @@ -38,6 +40,123 @@ (defvar *ip4-ip* nil) (defvar *ip4-router* nil) +#| RFC 760: http://www.faqs.org/rfcs/rfc760.html + 0 1 2 3 + 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + |Version| IHL |Type of Service| Total Length | + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Identification |Flags| Fragment Offset | + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Time to Live | Protocol | Header Checksum | + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Source Address | + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Destination Address | + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Options | Padding | + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +|# + +(defmacro with-ip4-header ((ip4 packet &key (start 0)) &body body) + (let ((packet-var (gensym "ip4-packet-")) + (start-var (gensym "ip4-packet-start")) + (offset-var (gensym "ip4-packet-offset-"))) + (macrolet ((mmem (offset type) + ```(memref ,packet-var (+ ,',offset ,offset-var) :type ,',type :endian :big))) + `(let* ((,start-var ,start) + (,packet-var (ensure-data-vector ,packet ,start-var 20)) + (,offset-var (+ ,start-var (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (macrolet ((,ip4 (slot) + (ecase slot + (:version + `(ldb (byte 4 4) ,,(mmem 0 :unsigned-byte8))) + (:ihl ; IP header-length in 32-bit units. + `(ldb (byte 4 0) ,,(mmem 0 :unsigned-byte8))) + (:tos ; type-of-service + ,(mmem 1 :unsigned-byte8)) + (:length + ,(mmem 2 :unsigned-byte16)) + (:identification + ,(mmem 4 :unsigned-byte16)) + (:ttl + ,(mmem 8 :unsigned-byte8)) + (:protocol + ,(mmem 9 :unsigned-byte8)) + (:checksum + ,(mmem 10 :unsigned-byte16)) + ((:compute-checksum) + `(logxor #xffff (mem-checksum ,',packet-var ,',offset-var 20) #+ignore + (checksum-octets ,',packet-var ,',start-var (+ 20 ,',start-var)))) + (:source + ,(mmem 12 :unsigned-byte32)) + (:destination + ,(mmem 16 :unsigned-byte32)) + (:address-length 4) + (:address-offset `(+ 12 ,',offset-var)) + (:end `(+ 20 ,',start-var))))) + , at body))))) + +(defmacro with-udp-header ((udp packet &key (start '(ip :end))) &body body) + (let ((packet-var (gensym "udp-packet-")) + (start-var (gensym "udp-packet-start")) + (offset-var (gensym "udp-packet-offset-"))) + (macrolet ((mmem (offset type) + ```(memref ,packet-var (+ ,',offset ,offset-var) :type ,',type :endian :big))) + `(let* ((,start-var ,start) + (,packet-var (ensure-data-vector ,packet ,start-var 20)) + (,offset-var (+ ,start-var (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (macrolet ((,udp (slot &optional arg) + (ecase slot + (:source-port + ,(mmem 0 :unsigned-byte16)) + (:destination-port + ,(mmem 2 :unsigned-byte16)) + (:length + ,(mmem 4 :unsigned-byte16)) + (:checksum + ,(mmem 6 :unsigned-byte16)) + ((:compute-checksum) + `(logxor #xffff + (add-u16-ones-complement (mem-checksum ,',packet-var + (,arg :address-offset) + (* 2 (,arg :address-length))) + +ip-protocol-udp+ + (,',udp :length) + (mem-checksum ,',packet-var ,',offset-var + (,',udp :length))))) + (:end `(+ 8 ,',start-var))))) + , at body))))) + + +(defun mem-checksum (packet offset length) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :ebx) packet) + (:compile-form (:result-mode :ecx) offset) + (:compile-form (:result-mode :esi) length) + ;; (:movl :eax :ecx) ; ecx = start + ;; (:subl :eax :esi) ; esi = (- end start) + ;; (:movl 0 :eax) + (:xorl :eax :eax) + (:testl :esi :esi) + (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) + (:xorl :edx :edx) + (:std) + checksum-loop + (:movw (:ebx 0 :ecx) :ax) + (:xchgb :al :ah) + (:addl 2 :ecx) + (:addl :eax :edx) + (:subl #.(cl:* 2 movitz:+movitz-fixnum-factor+) :esi) + (:jnbe 'checksum-loop) + (:movw :dx :ax) + (:shrl 16 :edx) + (:addw :dx :ax) + (:movl (:ebp -4) :esi) + end-checksum-loop + (:shll #.movitz:+movitz-fixnum-shift+ :eax) + (:cld))) + (defmacro ip4-ref (packet start offset type) `(memref ,packet (+ (muerte:movitz-type-slot-offset 'movitz-basic-vector 'data) ,start ,offset) @@ -457,6 +576,12 @@ (defun ip4-address (specifier &optional (start 0)) (or (ignore-errors (typecase specifier + ((unsigned-byte 32) + (assert (= 0 start)) + (loop with address = (make-array 4 :element-type '(unsigned-byte 8)) + for i from 0 to 3 + do (setf (aref address (- 3 i)) (ldb (byte 8 (* 8 i)) specifier)) + finally (return address))) ((simple-array (unsigned-byte 8) (*)) (if (= start 0) specifier @@ -487,14 +612,17 @@ muerte.x86-pc.ne2k:*ne2k-probe-addresses*))) (assert ethernet ethernet "No ethernet device.") (setf *ip4-nic* ethernet))) - (unless *ip4-ip* - (setf *ip4-ip* (ip4-address ip))) - (unless *ip4-router* - (setf *ip4-router* (ip4-address router))) - ;; This is to announce our presence on the LAN.. - (assert (polling-arp *ip4-router* (lambda () - (eql #\space (muerte.x86-pc.keyboard:poll-char)))) - () "Unable to resolve ~/ip4:pprint-ip4/ by ARP." *ip4-router*) + (when ip + (unless *ip4-ip* + (setf *ip4-ip* (ip4-address ip)))) + (when router + (unless *ip4-router* + (setf *ip4-router* (ip4-address router)))) + (when *ip4-router* + ;; This is to announce our presence on the LAN.. + (assert (polling-arp *ip4-router* (lambda () + (eql #\space (muerte.x86-pc.keyboard:poll-char)))) + () "Unable to resolve ~/ip4:pprint-ip4/ by ARP." *ip4-router*)) (values *ip4-nic* *ip4-ip*)) (defun ip4-test () From ffjeld at common-lisp.net Sat May 21 22:36:33 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 22 May 2005 00:36:33 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/dhcp.lisp Message-ID: <20050521223633.1CAE088753@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv4842 Added Files: dhcp.lisp Log Message: *** empty log message *** Date: Sun May 22 00:36:33 2005 Author: ffjeld From ffjeld at common-lisp.net Sat May 21 22:37:22 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 22 May 2005 00:37:22 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ethernet.lisp Message-ID: <20050521223722.8DE5F88753@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv4858 Modified Files: ethernet.lisp Log Message: *** empty log message *** Date: Sun May 22 00:37:22 2005 Author: ffjeld Index: movitz/losp/lib/net/ethernet.lisp diff -u movitz/losp/lib/net/ethernet.lisp:1.7 movitz/losp/lib/net/ethernet.lisp:1.8 --- movitz/losp/lib/net/ethernet.lisp:1.7 Thu Dec 9 15:18:37 2004 +++ movitz/losp/lib/net/ethernet.lisp Sun May 22 00:37:21 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 17 15:25:31 2002 ;;;; -;;;; $Id: ethernet.lisp,v 1.7 2004/12/09 14:18:37 ffjeld Exp $ +;;;; $Id: ethernet.lisp,v 1.8 2005/05/21 22:37:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -60,6 +60,7 @@ #:+ether-type-mswin-heartbeat+ #:+ether-type-loopback+ + #:with-ether-header )) (in-package muerte.ethernet) @@ -78,6 +79,25 @@ ;;; Packet accessors +(defmacro with-ether-header ((ether packet &key (start 0)) &body body) + (let* ((packet-var (gensym "ether-packet-")) + (offset-var (gensym "ether-packet-offset-")) + (start-var (gensym "ether-packet-start-"))) + `(let* ((,start-var ,start) + (,packet-var (ensure-data-vector ,packet ,start-var 14)) + (,offset-var (+ ,start-var (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (macrolet ((,ether (slot) + (ecase slot + (:source + `(memrange ,',packet-var ,',offset-var 6 6 :unsigned-byte8)) + (:destination + `(memrange ,',packet-var ,',offset-var 0 6 :unsigned-byte8)) + (:type + `(memref ,',packet-var (+ ,',offset-var 12) :type :unsigned-byte16 :endian :big)) + (:end `(+ ,',start-var 14))))) + , at body)))) + + (defmacro packet-ref (packet start offset type) `(memref ,packet (+ (muerte:movitz-type-slot-offset 'movitz-basic-vector 'data) ,start ,offset) @@ -141,6 +161,7 @@ (defconstant +ether-type-loopback+ #x9000) ;;; + (defun format-ethernet-packet (packet source destination type &key (start 0) (source-start 0) (destination-start 0)) From ffjeld at common-lisp.net Sat May 21 22:37:53 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 22 May 2005 00:37:53 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp Message-ID: <20050521223753.D7FBD88753@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4891 Modified Files: arrays.lisp Log Message: *** empty log message *** Date: Sun May 22 00:37:53 2005 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.49 movitz/losp/muerte/arrays.lisp:1.50 --- movitz/losp/muerte/arrays.lisp:1.49 Thu Nov 25 03:10:38 2004 +++ movitz/losp/muerte/arrays.lisp Sun May 22 00:37:53 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.49 2004/11/25 02:10:38 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.50 2005/05/21 22:37:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -853,6 +853,15 @@ (setf (fill-pointer vector) p) (aref vector p))) +(defun vector-read (vector) + "Like vector-pop, only in the other direction." + (let ((x (aref vector (fill-pointer vector)))) + (incf (fill-pointer vector)) + x)) + +(defun vector-read-more-p (vector) + (< (fill-pointer vector) (array-dimension vector 0))) + (defun vector-push-extend (new-element vector &optional extension) (declare (ignore extension)) (check-type vector vector) @@ -916,3 +925,12 @@ ((eq dim '*)) ((= dim (array-dimension x d))) (t (return nil))))))))) + +(defun ensure-data-vector (vector start length) + (let ((end (typecase vector + ((simple-array (unsigned-byte 8) 1) + (array-dimension vector 0)) + (t (error "Not a data vector: ~S" vector))))) + (assert (<= (+ start length) end) (vector) + "Data vector too small.") + vector)) From ffjeld at common-lisp.net Sat May 21 22:38:19 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 22 May 2005 00:38:19 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/lib/misc.lisp Message-ID: <20050521223819.C1EB588753@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv4908 Modified Files: misc.lisp Log Message: *** empty log message *** Date: Sun May 22 00:38:19 2005 Author: ffjeld Index: movitz/losp/lib/misc.lisp diff -u movitz/losp/lib/misc.lisp:1.8 movitz/losp/lib/misc.lisp:1.9 --- movitz/losp/lib/misc.lisp:1.8 Thu May 5 17:16:59 2005 +++ movitz/losp/lib/misc.lisp Sun May 22 00:38:19 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon May 12 17:13:31 2003 ;;;; -;;;; $Id: misc.lisp,v 1.8 2005/05/05 15:16:59 ffjeld Exp $ +;;;; $Id: misc.lisp,v 1.9 2005/05/21 22:38:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,7 +22,7 @@ (defun checksum-octets (packet &optional (start 0) (end (length packet))) "Generate sum of 16-bit big-endian words for a sequence of octets." (typecase packet - ((simple-array (unsigned-byte 8)) + ((simple-array (unsigned-byte 8) 1) (assert (<= 0 start end (length packet))) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :ebx) packet) From ffjeld at common-lisp.net Sat May 21 22:38:29 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 22 May 2005 00:38:29 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: <20050521223829.CC07788753@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4924 Modified Files: packages.lisp Log Message: *** empty log message *** Date: Sun May 22 00:38:29 2005 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.49 movitz/packages.lisp:1.50 --- movitz/packages.lisp:1.49 Sun May 8 03:16:40 2005 +++ movitz/packages.lisp Sun May 22 00:38:29 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.49 2005/05/08 01:16:40 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.50 2005/05/21 22:38:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1233,6 +1233,7 @@ #:memref #:memref-int + #:memrange #:io-port #:io-register8 @@ -1264,6 +1265,9 @@ #:segment-descriptor-limit #:control-register-lo12 #:control-register-hi20 + #:ensure-data-vector + #:vector-read + #:vector-read-more-p )) From ffjeld at common-lisp.net Sat May 21 22:38:40 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 22 May 2005 00:38:40 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: <20050521223840.24C0588753@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4940 Modified Files: image.lisp Log Message: *** empty log message *** Date: Sun May 22 00:38:39 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.100 movitz/image.lisp:1.101 --- movitz/image.lisp:1.100 Mon May 9 00:02:46 2005 +++ movitz/image.lisp Sun May 22 00:38:39 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.100 2005/05/08 22:02:46 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.101 2005/05/21 22:38:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,51 +28,43 @@ (raw-scratch0 ; A non-GC-root scratch register :binary-type lu32 :initform 0) + + (pointer-start :binary-type :label) - (scratch1 - :binary-type word - :initform 0) - (scratch2 - :binary-type word - :initform 0) - (class - :binary-type word - :map-binary-write 'movitz-intern - :map-binary-read-delayed 'movitz-word - :initarg :class - :accessor run-time-context-class) - (slots - :binary-type word - :map-binary-write 'movitz-read-and-intern - :map-binary-read-delayed 'movitz-word - :initarg :slots - :initform #(:init nil) - :accessor run-time-context-slots) - (fast-car + + (ret-trampoline :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-cdr + (cons-commit :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-cddr + (cons-non-pointer :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 + (cons-commit-non-pointer :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-cdr-ebx + (cons-non-header + :binary-type code-vector-word + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (cons-commit-non-header + :binary-type code-vector-word + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + + (cons-pointer :binary-type code-vector-word :initform nil :map-binary-write 'movitz-intern-code-vector @@ -120,50 +112,37 @@ :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) - (unwind-protect-tag - :binary-type word - :map-binary-read-delayed 'movitz-word - :map-binary-write 'movitz-read-and-intern - :initform 'muerte::unwind-protect-tag) - (restart-tag - :binary-type word - :map-binary-read-delayed 'movitz-word - :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) - (stack-top ; stack-top must be right after stack-bottom - :binary-type word ; in order for the bound instruction to work. - :initform #x100000) - ;; - (boolean-one :binary-type :label) - (not-nil ; not-nil, t-symbol and not-not-nil must be consecutive. - :binary-type word + + (fast-car + :binary-type code-vector-word :initform nil - :map-binary-write 'movitz-read-and-intern - :map-binary-read-delayed 'movitz-word) - (boolean-zero :binary-type :label) - (t-symbol - :binary-type word - :initarg :t-symbol - :map-binary-write 'movitz-intern - :map-binary-read-delayed 'movitz-word) - (not-not-nil - :binary-type word + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (fast-cdr + :binary-type code-vector-word :initform nil - :map-binary-write 'movitz-read-and-intern - :map-binary-read-delayed 'movitz-word) - ;; (null-cons :binary-type :label) - (null-symbol - :binary-type movitz-symbol - :reader movitz-run-time-context-null-symbol - :initarg :null-symbol) + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (fast-cddr + :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 + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (fast-cdr-ebx + :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) ;; primitive functions global constants (pop-current-values :binary-type code-vector-word @@ -273,12 +252,41 @@ :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) - (+ - :initform 'muerte.cl:+ + (dynamic-jump-next + :binary-type code-vector-word + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (copy-funobj-code-vector-slots + :binary-type code-vector-word + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + + ;; + (boolean-one :binary-type :label) + (not-nil ; not-nil, t-symbol and not-not-nil must be consecutive. :binary-type word - :binary-tag :global-function + :initform nil + :map-binary-write 'movitz-read-and-intern + :map-binary-read-delayed 'movitz-word) + (boolean-zero :binary-type :label) + (t-symbol + :binary-type word + :initarg :t-symbol :map-binary-write 'movitz-intern :map-binary-read-delayed 'movitz-word) + (not-not-nil + :binary-type word + :initform nil + :map-binary-write 'movitz-read-and-intern + :map-binary-read-delayed 'movitz-word) + ;; (null-cons :binary-type :label) + (null-symbol + :binary-type movitz-symbol + :reader movitz-run-time-context-null-symbol + :initarg :null-symbol) + (complicated-eql :initform 'muerte::complicated-eql :binary-type word @@ -293,6 +301,53 @@ (dynamic-env :binary-type word :initform 0) + + (scratch1 + :binary-type word + :initform 0) + (scratch2 + :binary-type word + :initform 0) + (class + :binary-type word + :map-binary-write 'movitz-intern + :map-binary-read-delayed 'movitz-word + :initarg :class + :accessor run-time-context-class) + (slots + :binary-type word + :map-binary-write 'movitz-read-and-intern + :map-binary-read-delayed 'movitz-word + :initarg :slots + :initform #(:init nil) + :accessor run-time-context-slots) + (unwind-protect-tag + :binary-type word + :map-binary-read-delayed 'movitz-word + :map-binary-write 'movitz-read-and-intern + :initform 'muerte::unwind-protect-tag) + (restart-tag + :binary-type word + :map-binary-read-delayed 'movitz-word + :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) + (stack-top ; stack-top must be right after stack-bottom + :binary-type word ; in order for the bound instruction to work. + :initform #x100000) + (+ + :initform 'muerte.cl:+ + :binary-type word + :binary-tag :global-function + :map-binary-write 'movitz-intern + :map-binary-read-delayed 'movitz-word) (the-class-t :binary-type word :initform t @@ -310,38 +365,6 @@ (movitz-intern (movitz-env-named-function name)))) - (cons-pointer - :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) - (cons-commit - :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) - (cons-non-pointer - :binary-type code-vector-word - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function) - (cons-commit-non-pointer - :binary-type code-vector-word - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function) - (cons-non-header - :binary-type code-vector-word - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function) - (cons-commit-non-header - :binary-type code-vector-word - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function) (classes ; A vector of class meta-objects. :initform nil ; The first element is the map of corresponding names :binary-type word @@ -370,21 +393,6 @@ :binary-type word :initform 6 :map-binary-read-delayed 'movitz-word) - (ret-trampoline - :binary-type code-vector-word - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function) - (dynamic-jump-next - :binary-type code-vector-word - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function) - (copy-funobj-code-vector-slots - :binary-type code-vector-word - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function) (complicated-class-of :binary-type word :binary-tag :global-function @@ -417,7 +425,7 @@ (:slot-align null-symbol -5)) (defun atomically-continuation-simple-pf (pf-name) - (global-constant-offset pf-name) + (ldb (byte 32 0) (global-constant-offset pf-name)) #+ignore (bt:enum-value 'movitz::atomically-status (list* :restart-primitive-function From ffjeld at common-lisp.net Sat May 21 22:38:51 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 22 May 2005 00:38:51 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050521223851.A07B688753@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4956 Modified Files: compiler.lisp Log Message: *** empty log message *** Date: Sun May 22 00:38:51 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.139 movitz/compiler.lisp:1.140 --- movitz/compiler.lisp:1.139 Sun May 8 03:16:26 2005 +++ movitz/compiler.lisp Sun May 22 00:38:51 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.139 2005/05/08 01:16:26 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.140 2005/05/21 22:38:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -6639,7 +6639,8 @@ ((movitz-subtypep type0 '(integer 0 0)) (cond ((eql destination loc1) - (break "NOP add: ~S" instruction)) + #+ignore (break "NOP add: ~S" instruction) + nil) ((and (member destination-location '(:eax :ebx :ecx :edx)) (member loc1 '(:eax :ebx :ecx :edx))) `((:movl ,loc1 ,destination-location))) @@ -6653,7 +6654,8 @@ ;; (warn "zero-add ~S => ~S [~S]" loc0 destination-location result-type) (cond ((eql destination loc0) - (break "NOP add: ~S" instruction)) + #+ignore (break "NOP add: ~S" instruction) + nil) ((and (member destination-location '(:eax :ebx :ecx :edx)) (member loc0 '(:eax :ebx :ecx :edx))) `((:movl ,loc0 ,destination-location))) From ffjeld at common-lisp.net Sat May 21 22:37:33 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 22 May 2005 00:37:33 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: <20050521223733.D90AF88753@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4874 Modified Files: memref.lisp Log Message: *** empty log message *** Date: Sun May 22 00:37:32 2005 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.45 movitz/losp/muerte/memref.lisp:1.46 --- movitz/losp/muerte/memref.lisp:1.45 Fri Apr 15 09:03:47 2005 +++ movitz/losp/muerte/memref.lisp Sun May 22 00:37:32 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.45 2005/04/15 07:03:47 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.46 2005/05/21 22:37:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,15 +18,9 @@ (in-package muerte) -(define-compiler-macro memref (&whole form object offset - &key (index 0) (type :lisp) (localp nil) (endian :host) - (physicalp nil) - &environment env) - (if (or (not (movitz:movitz-constantp type env)) - (not (movitz:movitz-constantp localp env)) - (not (movitz:movitz-constantp endian env)) - (not (movitz:movitz-constantp physicalp env))) - form +(eval-when (:compile-toplevel) + (defun extract-constant-delta (form env) + "Try to extract at compile-time an integer offset from form, repeatedly." (labels ((sub-extract-constant-delta (form) "Try to extract at compile-time an integer offset from form." (cond @@ -49,369 +43,329 @@ (incf x sub-value) (push sub-form f)) finally (return (values x (cons '+ (nreverse f)))))))) - (t #+ignore (warn "extract from: ~S" form) - (values 0 form)))))) - (extract-constant-delta (form) - "Try to extract at compile-time an integer offset from form, repeatedly." - (multiple-value-bind (constant-term variable-term) - (sub-extract-constant-delta form) - (if (= 0 constant-term) - (values 0 variable-term) - (multiple-value-bind (sub-constant-term sub-variable-term) - (extract-constant-delta variable-term) - (values (+ constant-term sub-constant-term) - sub-variable-term)))))) - (multiple-value-bind (constant-index index) - (extract-constant-delta index) - (multiple-value-bind (constant-offset offset) - (extract-constant-delta offset) - (flet ((offset-by (element-size) - (+ constant-offset (* constant-index element-size)))) - #+ignore - (warn "o: ~S, co: ~S, i: ~S, ci: ~S" - offset constant-offset - index constant-index) - (let ((type (movitz:movitz-eval type env)) - (physicalp (movitz:movitz-eval physicalp env))) - (when (and physicalp (not (eq type :unsigned-byte32))) - (warn "(memref physicalp) unsupported for type ~S." type)) - (case type - (:unsigned-byte8 + (t (values 0 form))))))) + (multiple-value-bind (constant-term variable-term) + (sub-extract-constant-delta form) + (if (= 0 constant-term) + (values 0 variable-term) + (multiple-value-bind (sub-constant-term sub-variable-term) + (extract-constant-delta variable-term env) + (values (+ constant-term sub-constant-term) + sub-variable-term))))))) + +(define-compiler-macro memref (&whole form object offset + &key (index 0) (type :lisp) (localp nil) (endian :host) + (physicalp nil) + &environment env) + (if (or (not (movitz:movitz-constantp type env)) + (not (movitz:movitz-constantp localp env)) + (not (movitz:movitz-constantp endian env)) + (not (movitz:movitz-constantp physicalp env))) + form + (multiple-value-bind (constant-index index) + (extract-constant-delta index env) + (multiple-value-bind (constant-offset offset) + (extract-constant-delta offset env) + (flet ((offset-by (element-size) + (+ constant-offset (* constant-index element-size)))) + #+ignore + (warn "o: ~S, co: ~S, i: ~S, ci: ~S" + offset constant-offset + index constant-index) + (let ((type (movitz:movitz-eval type env)) + (physicalp (movitz:movitz-eval physicalp env))) + (when (and physicalp (not (eq type :unsigned-byte32))) + (warn "(memref physicalp) unsupported for type ~S." type)) + (case type + (:unsigned-byte8 + (cond + ((and (eql 0 offset) (eql 0 index)) + `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8)) + (:compile-form (:result-mode :eax) ,object) + (:movzxb (:eax ,(offset-by 1)) :ecx))) + ((eql 0 index) + (let ((object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-"))) + `(let ((,object-var ,object) + (,offset-var ,offset)) + (with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte 8)) + (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object-var ,offset-var) + ;; (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:movzxb (:eax :ecx ,(offset-by 1)) :ecx) + )))) + ((eql 0 offset) + `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8)) + (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object ,index) + (:movzxb (:eax :ecx ,(offset-by 1)) :ecx))) + (t (let ((object-var (gensym "memref-object-"))) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8)) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:addl :ebx :ecx) ; index += offset + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:movzxb (:eax :ecx ,(offset-by 1)) :ecx))))))) + (:unsigned-byte16 + (let* ((endian (ecase (movitz:movitz-eval endian env) + ((:host :little) :little) + (:big :big))) + (endian-fix-ecx (ecase endian + (:little nil) + (:big `((:xchgb :cl :ch)))))) (cond ((and (eql 0 offset) (eql 0 index)) - `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8)) + `(with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte 16)) (:compile-form (:result-mode :eax) ,object) - (:movzxb (:eax ,(offset-by 1)) :ecx))) + (:movzxw (:eax ,(offset-by 2)) :ecx) + , at endian-fix-ecx)) ((eql 0 index) (let ((object-var (gensym "memref-object-")) (offset-var (gensym "memref-offset-"))) `(let ((,object-var ,object) (,offset-var ,offset)) (with-inline-assembly (:returns :untagged-fixnum-ecx - :type (unsigned-byte 8)) - (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object-var ,offset-var) - ;; (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) - (:movzxb (:eax :ecx ,(offset-by 1)) :ecx) - )))) + :type (unsigned-byte 16)) + (:compile-two-forms (:eax :ecx) ,object-var ,offset-var) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) + , at endian-fix-ecx)))) ((eql 0 offset) - `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8)) - (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object ,index) - (:movzxb (:eax :ecx ,(offset-by 1)) :ecx))) - (t (let ((object-var (gensym "memref-object-"))) - `(let ((,object-var ,object)) - (with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8)) - (:compile-two-forms (:ecx :ebx) ,offset ,index) - (:load-lexical (:lexical-binding ,object-var) :eax) - (:addl :ebx :ecx) ; index += offset - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:movzxb (:eax :ecx ,(offset-by 1)) :ecx))))))) - (:unsigned-byte16 - (let* ((endian (ecase (movitz:movitz-eval endian env) - ((:host :little) :little) - (:big :big))) - (endian-fix-ecx (ecase endian - (:little nil) - (:big `((:xchgb :cl :ch)))))) - (cond - ((and (eql 0 offset) (eql 0 index)) - `(with-inline-assembly (:returns :untagged-fixnum-ecx - :type (unsigned-byte 16)) - (:compile-form (:result-mode :eax) ,object) - (:movzxw (:eax ,(offset-by 2)) :ecx) - , at endian-fix-ecx)) - ((eql 0 index) - (let ((object-var (gensym "memref-object-")) - (offset-var (gensym "memref-offset-"))) - `(let ((,object-var ,object) - (,offset-var ,offset)) - (with-inline-assembly (:returns :untagged-fixnum-ecx - :type (unsigned-byte 16)) - (:compile-two-forms (:eax :ecx) ,object-var ,offset-var) - (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) - (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) - , at endian-fix-ecx)))) - ((eql 0 offset) - (let ((object-var (gensym "memref-object-")) - (index-var (gensym "memref-index-"))) - `(let ((,object-var ,object) - (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-ecx - :type (unsigned-byte 16)) - (:compile-two-forms (:eax :ecx) ,object-var ,index-var) - (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) - (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) - , at endian-fix-ecx)))) - (t (let ((object-var (gensym "memref-object-")) - (offset-var (gensym "memref-offset-")) - (index-var (gensym "memref-index-"))) - `(let ((,object-var ,object) - (,offset-var ,offset) - (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-ecx - :type (unsigned-byte 16)) - (:compile-two-forms (:ecx :ebx) ,offset-var ,index-var) - (:leal (:ecx (:ebx 2)) :ecx) - (:load-lexical (:lexical-binding ,object-var) :eax) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) - , at endian-fix-ecx))))))) - (:unsigned-byte14 - (cond - ((and (eq 0 offset) (eq 0 index)) - `(with-inline-assembly (:returns :ecx :type (unsigned-byte 14)) - (:compile-form (:result-mode :eax) ,object) - (:movzxw (:eax ,(offset-by 2)) :ecx) - (:testb ,movitz:+movitz-fixnum-zmask+ :cl) - (:jnz '(:sub-program () (:int 63))))) - ((eq 0 offset) (let ((object-var (gensym "memref-object-")) (index-var (gensym "memref-index-"))) `(let ((,object-var ,object) (,index-var ,index)) - (with-inline-assembly (:returns :ecx) + (with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte 16)) (:compile-two-forms (:eax :ecx) ,object-var ,index-var) (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) - (:testb ,movitz:+movitz-fixnum-zmask+ :cl) - (:jnz '(:sub-program () (:int 63))))))) + , at endian-fix-ecx)))) (t (let ((object-var (gensym "memref-object-")) (offset-var (gensym "memref-offset-")) (index-var (gensym "memref-index-"))) `(let ((,object-var ,object) (,offset-var ,offset) (,index-var ,index)) - (with-inline-assembly (:returns :ecx) + (with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte 16)) (:compile-two-forms (:ecx :ebx) ,offset-var ,index-var) (:leal (:ecx (:ebx 2)) :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) - (:testb ,movitz:+movitz-fixnum-shift+ :cl) - (:jnz '(:sub-program () (:int 63))))))))) - (:unsigned-byte29+3 - ;; Two values: the 29 upper bits as unsigned integer, - ;; and secondly the lower 3 bits as unsigned. - (assert (= 2 movitz::+movitz-fixnum-shift+)) - `(with-inline-assembly (:returns :multiple-values) - (:compile-form (:result-mode :push) ,object) - (:compile-two-forms (:ecx :ebx) ,offset ,index) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:addl :ebx :ecx) - (:popl :eax) ; object - (:movl (:eax :ecx ,(offset-by 4)) :ecx) - (:leal ((:ecx 4)) :ebx) - (:shrl 1 :ecx) - (:andl #b11100 :ebx) - (:andl -4 :ecx) - (:movl :ecx :eax) - (:movl 2 :ecx) - (:stc))) - (:signed-byte30+2 - ;; Two values: the 30 upper bits as signed integer, - ;; and secondly the lower 2 bits as unsigned. - (assert (= 2 movitz::+movitz-fixnum-shift+)) - (let ((fix-ecx `((:leal ((:ecx 4)) :ebx) - (:andl -4 :ecx) - (:andl #b1100 :ebx) - (:movl :ecx :eax) - (:movl 2 :ecx) - (:stc)))) - (cond - ((and (eq 0 offset) (eq 0 index)) - `(with-inline-assembly (:returns :multiple-values) - (:compile-form (:result-mode :eax) ,object) - (:movl (:eax ,(offset-by 4)) :ecx) - , at fix-ecx)) - ((eq 0 offset) - `(with-inline-assembly (:returns :multiple-values) - (:compile-two-forms (:eax :ecx) ,object ,index) - (:movl (:eax :ecx ,(offset-by 4)) :ecx) - , at fix-ecx)) - (t (let ((object-var (gensym "memref-object-"))) - `(let ((,object-var ,object)) - (with-inline-assembly (:returns :multiple-values) - (:compile-two-forms (:ecx :ebx) ,offset ,index) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:load-lexical (:lexical-binding ,object-var) :eax) - (:addl :ebx :ecx) - (:movl (:eax :ecx ,(offset-by 4)) :ecx) - , at fix-ecx)))))) - #+ignore - `(with-inline-assembly (:returns :multiple-values) - (:compile-form (:result-mode :push) ,object) - (:compile-two-forms (:ecx :ebx) ,offset ,index) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:addl :ebx :ecx) - (:popl :eax) ; object - (:movl (:eax :ecx ,(offset-by 4)) :ecx) - (:leal ((:ecx 4)) :ebx) - (:andl #b1100 :ebx) - (:andl -4 :ecx) - (:movl :ecx :eax) - (:movl 2 :ecx) - (:stc))) - (:character - (when (eq 0 index) (warn "memref zero char index!")) - (cond - ((eq 0 offset) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:ebx :ecx) ,object ,index) - (:xorl :eax :eax) - (:movb ,(movitz:tag :character) :al) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale index - (:movb (:ebx :ecx ,(offset-by 1)) :ah))) - (t (let ((object-var (gensym "memref-object-"))) - `(let ((,object-var ,object)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:ecx :ebx) ,offset ,index) - (:addl :ebx :ecx) - (:xorl :eax :eax) - (:movb ,(movitz:tag :character) :al) - (:load-lexical (:lexical-binding ,object-var) :ebx) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale offset+index - (:movb (:ebx :ecx ,(offset-by 1)) :ah))))))) - (:location - (assert (= 4 movitz::+movitz-fixnum-factor+)) + , at endian-fix-ecx))))))) + (:unsigned-byte14 + (cond + ((and (eq 0 offset) (eq 0 index)) + `(with-inline-assembly (:returns :ecx :type (unsigned-byte 14)) + (:compile-form (:result-mode :eax) ,object) + (:movzxw (:eax ,(offset-by 2)) :ecx) + (:testb ,movitz:+movitz-fixnum-zmask+ :cl) + (:jnz '(:sub-program () (:int 63))))) + ((eq 0 offset) + (let ((object-var (gensym "memref-object-")) + (index-var (gensym "memref-index-"))) + `(let ((,object-var ,object) + (,index-var ,index)) + (with-inline-assembly (:returns :ecx) + (:compile-two-forms (:eax :ecx) ,object-var ,index-var) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) + (:testb ,movitz:+movitz-fixnum-zmask+ :cl) + (:jnz '(:sub-program () (:int 63))))))) + (t (let ((object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-")) + (index-var (gensym "memref-index-"))) + `(let ((,object-var ,object) + (,offset-var ,offset) + (,index-var ,index)) + (with-inline-assembly (:returns :ecx) + (:compile-two-forms (:ecx :ebx) ,offset-var ,index-var) + (:leal (:ecx (:ebx 2)) :ecx) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) + (:testb ,movitz:+movitz-fixnum-shift+ :cl) + (:jnz '(:sub-program () (:int 63))))))))) + (:unsigned-byte29+3 + ;; Two values: the 29 upper bits as unsigned integer, + ;; and secondly the lower 3 bits as unsigned. + (assert (= 2 movitz::+movitz-fixnum-shift+)) + `(with-inline-assembly (:returns :multiple-values) + (:compile-form (:result-mode :push) ,object) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:addl :ebx :ecx) + (:popl :eax) ; object + (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (:leal ((:ecx 4)) :ebx) + (:shrl 1 :ecx) + (:andl #b11100 :ebx) + (:andl -4 :ecx) + (:movl :ecx :eax) + (:movl 2 :ecx) + (:stc))) + (:signed-byte30+2 + ;; Two values: the 30 upper bits as signed integer, + ;; and secondly the lower 2 bits as unsigned. + (assert (= 2 movitz::+movitz-fixnum-shift+)) + (let ((fix-ecx `((:leal ((:ecx 4)) :ebx) + (:andl -4 :ecx) + (:andl #b1100 :ebx) + (:movl :ecx :eax) + (:movl 2 :ecx) + (:stc)))) (cond ((and (eq 0 offset) (eq 0 index)) - `(with-inline-assembly (:returns :ecx :type (signed-byte 30)) + `(with-inline-assembly (:returns :multiple-values) (:compile-form (:result-mode :eax) ,object) (:movl (:eax ,(offset-by 4)) :ecx) - (:andl -4 :ecx))) + , at fix-ecx)) ((eq 0 offset) - `(with-inline-assembly (:returns :ecx :type (signed-byte 30)) + `(with-inline-assembly (:returns :multiple-values) (:compile-two-forms (:eax :ecx) ,object ,index) (:movl (:eax :ecx ,(offset-by 4)) :ecx) - (:andl -4 :ecx))) + , at fix-ecx)) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) - (with-inline-assembly (:returns :ecx :type (signed-byte 30)) + (with-inline-assembly (:returns :multiple-values) (:compile-two-forms (:ecx :ebx) ,offset ,index) (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) (:addl :ebx :ecx) (:movl (:eax :ecx ,(offset-by 4)) :ecx) - (:andl -4 :ecx))))))) - (:tag + , at fix-ecx)))))) + #+ignore + `(with-inline-assembly (:returns :multiple-values) + (:compile-form (:result-mode :push) ,object) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:addl :ebx :ecx) + (:popl :eax) ; object + (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (:leal ((:ecx 4)) :ebx) + (:andl #b1100 :ebx) + (:andl -4 :ecx) + (:movl :ecx :eax) + (:movl 2 :ecx) + (:stc))) + (:character + (when (eq 0 index) (warn "memref zero char index!")) + (cond + ((eq 0 offset) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :ecx) ,object ,index) + (:xorl :eax :eax) + (:movb ,(movitz:tag :character) :al) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale index + (:movb (:ebx :ecx ,(offset-by 1)) :ah))) + (t (let ((object-var (gensym "memref-object-"))) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:addl :ebx :ecx) + (:xorl :eax :eax) + (:movb ,(movitz:tag :character) :al) + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale offset+index + (:movb (:ebx :ecx ,(offset-by 1)) :ah))))))) + (:location + (assert (= 4 movitz::+movitz-fixnum-factor+)) + (cond + ((and (eq 0 offset) (eq 0 index)) + `(with-inline-assembly (:returns :ecx :type (signed-byte 30)) + (:compile-form (:result-mode :eax) ,object) + (:movl (:eax ,(offset-by 4)) :ecx) + (:andl -4 :ecx))) + ((eq 0 offset) + `(with-inline-assembly (:returns :ecx :type (signed-byte 30)) + (:compile-two-forms (:eax :ecx) ,object ,index) + (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (:andl -4 :ecx))) + (t (let ((object-var (gensym "memref-object-"))) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :ecx :type (signed-byte 30)) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:addl :ebx :ecx) + (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (:andl -4 :ecx))))))) + (:tag + (assert (= 4 movitz::+movitz-fixnum-factor+)) + (cond + ((and (eq 0 offset) (eq 0 index)) + `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3)) + (:compile-form (:result-mode :eax) ,object) + (:movl (:eax ,(offset-by 4)) :ecx) + (:andl 7 :ecx))) + ((eq 0 offset) + `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3)) + (:compile-two-forms (:eax :ecx) ,object ,index) + (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (:andl 7 :ecx))) + (t (let ((object-var (gensym "memref-object-"))) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3)) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:addl :ebx :ecx) + (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (:andl 7 :ecx))))))) + (:unsigned-byte32 + (let ((prefixes (if (not physicalp) + () + movitz:*compiler-physical-segment-prefix*)) + (fix-endian (ecase (movitz:movitz-eval endian env) + ((:host :little) ()) + (:big `((:bswap :ecx)))))) (assert (= 4 movitz::+movitz-fixnum-factor+)) (cond ((and (eq 0 offset) (eq 0 index)) - `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3)) + `(with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte 32)) (:compile-form (:result-mode :eax) ,object) - (:movl (:eax ,(offset-by 4)) :ecx) - (:andl 7 :ecx))) + (,prefixes :movl (:eax ,(offset-by 4)) :ecx) + , at fix-endian)) ((eq 0 offset) - `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3)) + `(with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte 32)) (:compile-two-forms (:eax :ecx) ,object ,index) - (:movl (:eax :ecx ,(offset-by 4)) :ecx) - (:andl 7 :ecx))) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx) + , at fix-endian)) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) - (with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3)) + (with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte 32)) (:compile-two-forms (:ecx :ebx) ,offset ,index) (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) (:addl :ebx :ecx) - (:movl (:eax :ecx ,(offset-by 4)) :ecx) - (:andl 7 :ecx))))))) - (:unsigned-byte32 - (let ((endian (movitz:movitz-eval endian env)) - (prefixes (if (not physicalp) - () - movitz:*compiler-physical-segment-prefix*))) - (assert (member endian '(:host :little))) - (assert (= 4 movitz::+movitz-fixnum-factor+)) - (cond - ((and (eq 0 offset) (eq 0 index)) - `(with-inline-assembly (:returns :untagged-fixnum-ecx - :type (unsigned-byte 32)) - (:compile-form (:result-mode :eax) ,object) - (,prefixes :movl (:eax ,(offset-by 4)) :ecx))) - ((eq 0 offset) - `(with-inline-assembly (:returns :untagged-fixnum-ecx - :type (unsigned-byte 32)) - (:compile-two-forms (:eax :ecx) ,object ,index) - (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx))) - (t (let ((object-var (gensym "memref-object-"))) - `(let ((,object-var ,object)) - (with-inline-assembly (:returns :untagged-fixnum-ecx - :type (unsigned-byte 32)) - (:compile-two-forms (:ecx :ebx) ,offset ,index) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:load-lexical (:lexical-binding ,object-var) :eax) - (:addl :ebx :ecx) - (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx)))))))) - (:lisp - (let* ((localp (movitz:movitz-eval localp env)) - (prefixes (if localp - nil - movitz:*compiler-nonlocal-lispval-read-segment-prefix*))) - (cond - ((and (eql 0 index) (eql 0 offset)) - `(with-inline-assembly (:returns :register) - (:compile-form (:result-mode :register) ,object) - (,prefixes :movl ((:result-register) ,(offset-by 4)) (:result-register)))) - ((eql 0 offset) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ecx) ,object ,index) - ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) - `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx)) - (,prefixes :movl (:eax :ecx ,(offset-by 4)) :eax))) - ((eql 0 index) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object ,offset) - (,prefixes :movl (:eax :ecx ,(offset-by 4)) :eax))) - (t (assert (not (movitz:movitz-constantp offset env))) - (assert (not (movitz:movitz-constantp index env))) - (let ((object-var (gensym "memref-object-"))) - (assert (= 4 movitz:+movitz-fixnum-factor+)) - `(let ((,object-var ,object)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:ecx :ebx) ,offset ,index) - (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) - (:load-lexical (:lexical-binding ,object-var) :eax) - (:addl :ebx :ecx) - (,prefixes :movl (:eax :ecx ,(offset-by 4)) :eax)))))))) - (:code-vector - ;; A code-vector is like a normal lisp word pointer, - ;; except it's known to point to a code-vector, and - ;; the pointer value is offset by 2. The trick is to - ;; perform this pointer arithmetics while never - ;; keeping a non-lisp-word pointer in a register. + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx) + , at fix-endian))))))) + (:lisp + (let* ((localp (movitz:movitz-eval localp env)) + (prefixes (if localp + nil + movitz:*compiler-nonlocal-lispval-read-segment-prefix*))) (cond ((and (eql 0 index) (eql 0 offset)) - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :ebx) ,object) - (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) - (:addl (:ebx ,(offset-by 4)) :eax))) + `(with-inline-assembly (:returns :register) + (:compile-form (:result-mode :register) ,object) + (,prefixes :movl ((:result-register) ,(offset-by 4)) (:result-register)))) ((eql 0 offset) `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:ebx :ecx) ,object ,index) + (:compile-two-forms (:eax :ecx) ,object ,index) ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx)) - (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) - (:addl (:ebx :ecx ,(offset-by 4)) :eax))) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :eax))) ((eql 0 index) `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:ebx :untagged-fixnum-ecx) ,object ,offset) - (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) - (:addl (:ebx :ecx ,(offset-by 4)) :eax))) - (t (let ((object-var (gensym "memref-object-")) - (offset-var (gensym "memref-offset-")) - (index-var (gensym "memref-index-"))) - `(let ((,object-var ,object) - (,offset-var ,offset) - (,index-var ,index)) - (with-inline-assembly (:returns :eax) - (:load-lexical (:lexical-binding ,offset-var) :untagged-fixnum-ecx) - (:load-lexical (:lexical-binding ,object-var) :ebx) - (:load-lexical (:lexical-binding ,index-var) :edx) - (:addl :edx :ecx) - (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) - (:addl (:ebx :ecx ,(offset-by 4)) :eax))))) - #+ignore - (t (error "variable memref type :code-vector not implemented.")) - #+ignore + (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object ,offset) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :eax))) (t (assert (not (movitz:movitz-constantp offset env))) (assert (not (movitz:movitz-constantp index env))) (let ((object-var (gensym "memref-object-"))) @@ -422,9 +376,60 @@ (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) (:addl :ebx :ecx) - (:movl (:eax :ecx ,(offset-by 4)) :eax))))))) - (t (error "Unknown memref type: ~S" (movitz:movitz-eval type nil nil)) - form))))))))) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :eax)))))))) + (:code-vector + ;; A code-vector is like a normal lisp word pointer, + ;; except it's known to point to a code-vector, and + ;; the pointer value is offset by 2. The trick is to + ;; perform this pointer arithmetics while never + ;; keeping a non-lisp-word pointer in a register. + (cond + ((and (eql 0 index) (eql 0 offset)) + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :ebx) ,object) + (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) + (:addl (:ebx ,(offset-by 4)) :eax))) + ((eql 0 offset) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :ecx) ,object ,index) + ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) + `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx)) + (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) + (:addl (:ebx :ecx ,(offset-by 4)) :eax))) + ((eql 0 index) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :untagged-fixnum-ecx) ,object ,offset) + (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) + (:addl (:ebx :ecx ,(offset-by 4)) :eax))) + (t (let ((object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-")) + (index-var (gensym "memref-index-"))) + `(let ((,object-var ,object) + (,offset-var ,offset) + (,index-var ,index)) + (with-inline-assembly (:returns :eax) + (:load-lexical (:lexical-binding ,offset-var) :untagged-fixnum-ecx) + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:load-lexical (:lexical-binding ,index-var) :edx) + (:addl :edx :ecx) + (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) + (:addl (:ebx :ecx ,(offset-by 4)) :eax))))) + #+ignore + (t (error "variable memref type :code-vector not implemented.")) + #+ignore + (t (assert (not (movitz:movitz-constantp offset env))) + (assert (not (movitz:movitz-constantp index env))) + (let ((object-var (gensym "memref-object-"))) + (assert (= 4 movitz:+movitz-fixnum-factor+)) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:addl :ebx :ecx) + (:movl (:eax :ecx ,(offset-by 4)) :eax))))))) + (t (error "Unknown memref type: ~S" (movitz:movitz-eval type nil nil)) + form)))))))) (defun memref (object offset &key (index 0) (type :lisp) localp (endian :host)) (ecase type @@ -451,374 +456,403 @@ (not (movitz:movitz-constantp localp env)) (not (movitz:movitz-constantp endian env))) form - (case (movitz::eval-form type) - (:character - (cond - ((and (movitz:movitz-constantp value env) - (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - (let ((value (movitz:movitz-eval value env))) - (check-type value movitz::movitz-character) - `(progn - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :ebx) ,object) - (:movb ,(movitz:movitz-intern value) - (:ebx ,(+ (movitz:movitz-eval offset env) - (* 1 (movitz:movitz-eval index env)))))) - ,value))) - ((and (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) ,value ,object) - (:movb :ah (:ebx ,(+ (movitz:movitz-eval offset env) - (* 1 (movitz:movitz-eval index env))))))) - ((movitz:movitz-constantp offset env) - (let ((value-var (gensym "memref-value-"))) - `(let ((,value-var ,value)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:ebx :untagged-fixnum-ecx) ,object ,index) - (:load-lexical (:lexical-binding ,value-var) :eax) - (:movb :ah (:ebx :ecx ,(+ (movitz:movitz-eval offset env)))))))) - (t (let ((object-var (gensym "memref-object-")) - (offset-var (gensym "memref-offset-"))) - `(let ((,object-var ,object) (,offset-var ,offset)) - (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ecx :eax) ,index ,value) - (:load-lexical (:lexical-binding ,offset-var) :ebx) - (:addl :ebx :ecx) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:load-lexical (:lexical-binding ,object-var) :ebx) - (:movb :ah (:ebx :ecx)))))))) - (:unsigned-byte32 - (let ((endian (movitz:movitz-eval endian env))) - (assert (member endian '(:host :little)))) - (assert (= 4 movitz::+movitz-fixnum-factor+)) - (cond - ((and (movitz:movitz-constantp value env) - (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - (let ((value (movitz:movitz-eval value env))) - (check-type value (unsigned-byte 32)) - `(progn - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :ebx) ,object) - (:movl ,value (:ebx ,(+ (movitz:movitz-eval offset env) - (* 4 (movitz:movitz-eval index env)))))) - ,value))) - ((and (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - `(with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,value ,object) - (:movl :ecx (:ebx ,(+ (movitz:movitz-eval offset env) - (* 4 (movitz:movitz-eval index env))))))) - ((and (movitz:movitz-constantp offset env) - (movitz:movitz-constantp value env)) - (let ((value (movitz:movitz-eval value env))) - (check-type value (unsigned-byte 32)) - `(progn - (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ecx :ebx) ,index ,object) - (:movl ,value (:ebx :ecx ,(movitz:movitz-eval offset env)))) - ,value))) - ((movitz:movitz-constantp offset env) - (let ((value-var (gensym "memref-value-")) - (object-var (gensym "memref-object-")) - (index-var (gensym "memref-index-"))) - `(let ((,value-var ,value) - (,object-var ,object) - (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-ecx) - (:compile-two-forms (:ebx :eax) ,object-var ,index-var) - (:movl :ecx (:eax :ebx ,(movitz:movitz-eval offset env))))))) - (t (let ((value-var (gensym "memref-value-")) - (object-var (gensym "memref-object-")) - (offset-var (gensym "memref-offset-")) - (index-var (gensym "memref-index-"))) - (assert (= 4 movitz:+movitz-fixnum-factor+)) - `(let ((,value-var ,value) - (,object-var ,object) - (,offset-var ,offset) - (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:load-lexical (:lexical-binding ,value-var) :eax) - (:call-global-pf unbox-u32) - (:compile-two-forms (:eax :edx) ,index-var ,offset-var) - (:load-lexical (:lexical-binding ,object-var) :ebx) - (:std) - (:sarl ,movitz::+movitz-fixnum-shift+ :edx) - (:addl :eax :edx) ; EDX = offset+index - (:movl :ecx (:ebx :edx)) - (:movl :edi :edx) - (:cld))))))) - (:unsigned-byte16 - (let ((endian (ecase (movitz:movitz-eval endian env) - ((:host :little) :little) - (:big :big)))) - (cond - ((and (movitz:movitz-constantp value env) - (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - (let* ((host-value (movitz:movitz-eval value env)) - (value (ecase endian - (:little host-value) - (:big (dpb (ldb (byte 8 0) host-value) - (byte 8 8) - (ldb (byte 8 8) host-value)))))) - (check-type value (unsigned-byte 16)) - `(progn - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :ebx) ,object) - (:movw ,value (:ebx ,(+ (movitz:movitz-eval offset env) - (* 2 (movitz:movitz-eval index env)))))) - ,value))) - ((and (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - `(with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,value ,object) - ,@(ecase endian - (:little nil) - (:big `((:xchg :cl :ch)))) - (:movw :cx (:ebx ,(+ (movitz:movitz-eval offset env) - (* 2 (movitz:movitz-eval index env))))))) - ((and (movitz:movitz-constantp offset env) - (movitz:movitz-constantp value env)) - (let ((value (movitz:movitz-eval value env)) - (index-var (gensym "memref-index-")) - (object-var (gensym "memref-object-"))) - (check-type value (unsigned-byte 16)) - `(let ((,object-var ,object) - (,index-var ,index)) - (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ecx :ebx) ,index-var ,object-var) - (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) - (:movw ,value (:ebx :ecx ,(movitz:movitz-eval offset env)))) - ,value))) - ((movitz:movitz-constantp offset env) - (let ((value-var (gensym "memref-value-")) - (index-var (gensym "memref-index-")) - (object-var (gensym "memref-object-"))) - (if (<= 16 movitz:*compiler-allow-untagged-word-bits*) - `(let ((,value-var ,value) - (,object-var ,object) - (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-two-forms (:ebx :ecx) ,object-var ,index-var) - (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-eax) - (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) - (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))))) - `(let ((,value-var ,value) - (,object-var ,object) - (,index-var ,index)) - (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ebx :ecx) ,object-var ,index-var) - (:load-lexical (:lexical-binding ,value-var) :eax) - (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) - (:movl :edi :edx) - (:std) - (:shrl ,movitz:+movitz-fixnum-shift+ :eax) - ,@(ecase endian - (:little nil) - (:big `((:xchgb :al :ah)))) - (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))) - (:movl :edi :eax) - (:cld)) - ,value-var)))) - (t (let ((value-var (gensym "memref-value-")) - (object-var (gensym "memref-object-")) - (offset-var (gensym "memref-offset-")) - (index-var (gensym "memref-index-"))) - (if (<= 16 movitz:*compiler-allow-untagged-word-bits*) + (multiple-value-bind (constant-index xindex) + (extract-constant-delta index env) + (multiple-value-bind (constant-offset xoffset) + (extract-constant-delta offset env) + (flet ((offset-by (element-size) + (+ constant-offset (* constant-index element-size)))) + (case (movitz::movitz-eval type env) + (:character + (cond + ((and (movitz:movitz-constantp value env) + (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + (let ((value (movitz:movitz-eval value env))) + (check-type value movitz::movitz-character) + `(progn + (with-inline-assembly (:returns :nothing) + (:compile-form (:result-mode :ebx) ,object) + (:movb ,(movitz:movitz-intern value) + (:ebx ,(+ (movitz:movitz-eval offset env) + (* 1 (movitz:movitz-eval index env)))))) + ,value))) + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) ,value ,object) + (:movb :ah (:ebx ,(+ (movitz:movitz-eval offset env) + (* 1 (movitz:movitz-eval index env))))))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-"))) + `(let ((,value-var ,value)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :untagged-fixnum-ecx) ,object ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:movb :ah (:ebx :ecx ,(+ (movitz:movitz-eval offset env)))))))) + (t (let ((object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-"))) + `(let ((,object-var ,object) (,offset-var ,offset)) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ecx :eax) ,index ,value) + (:load-lexical (:lexical-binding ,offset-var) :ebx) + (:addl :ebx :ecx) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:movb :ah (:ebx :ecx)))))))) + (:unsigned-byte32 + (let ((endian (ecase (movitz:movitz-eval endian env) + ((:host :little) :little) + (:big :big)))) + (assert (= 4 movitz::+movitz-fixnum-factor+)) + (cond + ((and (movitz:movitz-constantp value env) + (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + (let ((value (movitz:movitz-eval value env))) + (check-type value (unsigned-byte 32)) + `(progn + (with-inline-assembly (:returns :nothing) + (:compile-form (:result-mode :ebx) ,object) + (:movl ,value (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env)))))) + ,value))) + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + `(with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,value ,object) + ,@(when (eq endian :big) + `((:bswap :ecx))) + (:movl :ecx (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))))) + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp value env)) + (let ((value (movitz:movitz-eval value env))) + (check-type value (unsigned-byte 32)) + (let ((value (ecase endian + (:little value) + (:big (logior (ash (ldb (byte 8 0) value) 24) + (ash (ldb (byte 8 8) value) 16) + (ash (ldb (byte 8 16) value) 8) + (ash (ldb (byte 8 24) value) 0)))))) + `(progn + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ecx :ebx) ,index ,object) + (:movl ,value (:ebx :ecx ,(movitz:movitz-eval offset env)))) + ,value)))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-")) + (index-var (gensym "memref-index-"))) `(let ((,value-var ,value) (,object-var ,object) - (,offset-var ,offset) (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var) - (:load-lexical (:lexical-binding ,value-var) :eax) - (:andl ,(* movitz:+movitz-fixnum-factor+ #xffff) :eax) - (:leal (:ebx (:ecx 2)) :ecx) - (:shrl ,movitz:+movitz-fixnum-shift+ :eax) - (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) - (:load-lexical (:lexical-binding ,object-var) :ebx) - (:movw :ax (:ebx :ecx)))) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-ecx) + (:compile-two-forms (:ebx :eax) ,object-var ,index-var) + ,@(when (eq endian :big) + `((:bswap :ecx))) + (:movl :ecx (:eax :ebx ,(movitz:movitz-eval offset env))))))) + (t (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-")) + (index-var (gensym "memref-index-"))) + (assert (= 4 movitz:+movitz-fixnum-factor+)) + `(let ((,value-var ,value) + (,object-var ,object) + (,offset-var ,offset) + (,index-var ,index)) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:call-global-pf unbox-u32) + (:compile-two-forms (:eax :edx) ,index-var ,offset-var) + (:load-lexical (:lexical-binding ,object-var) :ebx) + ,@(when (eq endian :big) + `((:bswap :ecx))) + (:std) + (:sarl ,movitz::+movitz-fixnum-shift+ :edx) + (:addl :eax :edx) ; EDX = offset+index + (:movl :ecx (:ebx :edx)) + (:movl :edi :edx) + (:cld)))))))) + (:unsigned-byte16 + (let ((endian (ecase (movitz:movitz-eval endian env) + ((:host :little) :little) + (:big :big)))) + (cond + ((and (movitz:movitz-constantp value env) + (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + (let* ((host-value (movitz:movitz-eval value env)) + (value (ecase endian + (:little host-value) + (:big (dpb (ldb (byte 8 0) host-value) + (byte 8 8) + (ldb (byte 8 8) host-value)))))) + (check-type value (unsigned-byte 16)) + `(progn + (with-inline-assembly (:returns :nothing) + (:compile-form (:result-mode :ebx) ,object) + (:movw ,value (:ebx ,(+ (movitz:movitz-eval offset env) + (* 2 (movitz:movitz-eval index env)))))) + ,value))) + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + `(with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,value ,object) + ,@(ecase endian + (:little nil) + (:big `((:xchg :cl :ch)))) + (:movw :cx (:ebx ,(+ (movitz:movitz-eval offset env) + (* 2 (movitz:movitz-eval index env))))))) + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp value env)) + (let ((value (movitz:movitz-eval value env)) + (index-var (gensym "memref-index-")) + (object-var (gensym "memref-object-"))) + (check-type value (unsigned-byte 16)) + `(let ((,object-var ,object) + (,index-var ,index)) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ecx :ebx) ,index-var ,object-var) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:movw ,value (:ebx :ecx ,(movitz:movitz-eval offset env)))) + ,value))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-")) + (index-var (gensym "memref-index-")) + (object-var (gensym "memref-object-"))) + (if (<= 16 movitz:*compiler-allow-untagged-word-bits*) + `(let ((,value-var ,value) + (,object-var ,object) + (,index-var ,index)) + (with-inline-assembly (:returns :untagged-fixnum-eax) + (:compile-two-forms (:ebx :ecx) ,object-var ,index-var) + (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-eax) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))))) + `(let ((,value-var ,value) + (,object-var ,object) + (,index-var ,index)) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ebx :ecx) ,object-var ,index-var) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:movl :edi :edx) + (:std) + (:shrl ,movitz:+movitz-fixnum-shift+ :eax) + ,@(ecase endian + (:little nil) + (:big `((:xchgb :al :ah)))) + (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))) + (:movl :edi :eax) + (:cld)) + ,value-var)))) + (t (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-")) + (index-var (gensym "memref-index-"))) + (if (<= 16 movitz:*compiler-allow-untagged-word-bits*) + `(let ((,value-var ,value) + (,object-var ,object) + (,offset-var ,offset) + (,index-var ,index)) + (with-inline-assembly (:returns :untagged-fixnum-eax) + (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:andl ,(* movitz:+movitz-fixnum-factor+ #xffff) :eax) + (:leal (:ebx (:ecx 2)) :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :eax) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:movw :ax (:ebx :ecx)))) + `(let ((,value-var ,value) + (,object-var ,object) + (,offset-var ,offset) + (,index-var ,index)) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:leal (:ebx (:ecx 2)) :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:std) + (:shrl ,movitz:+movitz-fixnum-shift+ :eax) + ,@(ecase endian + (:little nil) + (:big `((:xchgb :al :ah)))) + (:movw :ax (:ebx :ecx)) + (:shll ,movitz:+movitz-fixnum-shift+ :eax) + (:movl :edi :edx) + (:cld)) + ,value-var))))))) + (:unsigned-byte8 + (cond + ((and (movitz:movitz-constantp value env) + (eql 0 xoffset) + (eql 0 xindex)) + (let ((value (movitz:movitz-eval value env))) + (check-type value (unsigned-byte 8)) + `(progn + (with-inline-assembly (:returns :nothing) + (:compile-form (:result-mode :ebx) ,object) + (:movb ,value (:ebx ,(offset-by 1)))) + ,value))) + ((eql 0 xindex) + (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-"))) `(let ((,value-var ,value) (,object-var ,object) - (,offset-var ,offset) - (,index-var ,index)) + (,offset-var ,xoffset)) (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var) + (:load-lexical (:lexical-binding ,offset-var) :untagged-fixnum-ecx) (:load-lexical (:lexical-binding ,value-var) :eax) - (:leal (:ebx (:ecx 2)) :ecx) - (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :ebx) - (:std) - (:shrl ,movitz:+movitz-fixnum-shift+ :eax) - ,@(ecase endian - (:little nil) - (:big `((:xchgb :al :ah)))) - (:movw :ax (:ebx :ecx)) - (:shll ,movitz:+movitz-fixnum-shift+ :eax) - (:movl :edi :edx) - (:cld)) - ,value-var))))))) - (:unsigned-byte8 - (cond - ((and (movitz:movitz-constantp value env) - (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - (let ((value (movitz:movitz-eval value env))) - (check-type value (unsigned-byte 8)) - `(progn - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :ebx) ,object) - (:movb ,value (:ebx ,(+ (movitz:movitz-eval offset env) - (* 1 (movitz:movitz-eval index env)))))) - ,value))) - ((and (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - `(with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:ecx :ebx) ,value ,object) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) - (:movb :cl (:ebx ,(+ (movitz:movitz-eval offset env) - (* 1 (movitz:movitz-eval index env))))))) - ((and (movitz:movitz-constantp offset env) - (movitz:movitz-constantp value env)) - (let ((value (movitz:movitz-eval value env))) - (check-type value (unsigned-byte 8)) - `(progn - (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:eax :ecx) ,object ,index) - (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) - (:movb ,value (:eax :ecx ,(movitz:movitz-eval offset env)))) - value))) - ((movitz:movitz-constantp offset env) - (let ((value-var (gensym "memref-value-"))) - `(let ((,value-var ,value)) - (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ebx :ecx) ,object ,index) - (:load-lexical (:lexical-binding ,value-var) :eax) - (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) - (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) ; value into :AH - (:movb :ah (:ebx :ecx ,(movitz:movitz-eval offset env)))) - ,value-var))) - (t (let ((value-var (gensym "memref-value-")) - (object-var (gensym "memref-object-"))) - `(let ((,value-var ,value) (,object-var ,object)) - (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ebx :ecx) ,offset ,index) - (:load-lexical (:lexical-binding ,value-var) :eax) - (:addl :ebx :ecx) - (:load-lexical (:lexical-binding ,object-var) :ebx) ; value into :AH - (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:movb :ah (:ebx :ecx))) - ,value-var))))) - (:unsigned-byte14 - (cond - ((and (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) ,value ,object) - (:andl ,(mask-field (byte 14 2) -1) :eax) - (:movw :ax (:ebx ,(+ (movitz:movitz-eval offset env) - (* 4 (movitz:movitz-eval index env))))))) - ((movitz:movitz-constantp offset env) - (let ((value-var (gensym "memref-value-"))) - `(let ((,value-var ,value)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:ebx :ecx) ,object ,index) - (:load-lexical (:lexical-binding ,value-var) :eax) - ,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2)) - `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) - (:andl ,(mask-field (byte 14 2) -1) :eax) - (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) - (t (let ((value-var (gensym "memref-value-")) - (object-var (gensym "memref-object-"))) - `(let ((,value-var ,value) (,object-var ,object)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index) - (:load-lexical (:lexical-binding ,value-var) :eax) - ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) - `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) - (:addl :ebx :ecx) ; index += offset - (:load-lexical (:lexical-binding ,object-var) :ebx) + (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) + (:movb :ah (:ebx :ecx ,(offset-by 1)))) + ,value-var))) + ((and (eql 0 xoffset) (eql 0 xindex)) + `(with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,value ,object) + (:movb :cl (:ebx ,(offset-by 1))))) + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp value env)) + (let ((value (movitz:movitz-eval value env))) + (check-type value (unsigned-byte 8)) + `(progn + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-two-forms (:eax :ecx) ,object ,index) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:movb ,value (:eax :ecx ,(movitz:movitz-eval offset env)))) + value))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-"))) + `(let ((,value-var ,value)) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ebx :ecx) ,object ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) ; value into :AH + (:movb :ah (:ebx :ecx ,(movitz:movitz-eval offset env)))) + ,value-var))) + (t (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-"))) + `(let ((,value-var ,value) (,object-var ,object)) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ebx :ecx) ,offset ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:addl :ebx :ecx) + (:load-lexical (:lexical-binding ,object-var) :ebx) ; value into :AH + (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:movb :ah (:ebx :ecx))) + ,value-var))))) + (:unsigned-byte14 + (cond + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) ,value ,object) (:andl ,(mask-field (byte 14 2) -1) :eax) - (:movl :ax (:ebx :ecx)))))))) - (:lisp - (let* ((localp (movitz:movitz-eval localp env)) - (prefixes (if localp - nil - movitz:*compiler-nonlocal-lispval-write-segment-prefix*))) - (cond - ((and (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) ,value ,object) - (,prefixes :movl :eax (:ebx ,(+ (movitz:movitz-eval offset env) - (* 4 (movitz:movitz-eval index env))))))) - ((movitz:movitz-constantp offset env) - (let ((value-var (gensym "memref-value-"))) - `(let ((,value-var ,value)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:ebx :ecx) ,object ,index) - (:load-lexical (:lexical-binding ,value-var) :eax) - ,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2)) - `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) - (,prefixes :movl :eax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) - (t (let ((value-var (gensym "memref-value-")) - (object-var (gensym "memref-object-"))) - `(let ((,value-var ,value) (,object-var ,object)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index) - (:load-lexical (:lexical-binding ,value-var) :eax) - ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) - `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) - (:addl :ebx :ecx) ; index += offset - (:load-lexical (:lexical-binding ,object-var) :ebx) - (,prefixes :movl :eax (:ebx :ecx))))))))) - (:code-vector - (let ((prefixes (if localp - nil - movitz:*compiler-nonlocal-lispval-write-segment-prefix*))) - (cond - ((and (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) ,value ,object) - (:movl ,movitz:+code-vector-word-offset+ - (:ebx ,(+ (movitz:movitz-eval offset env) - (* 4 (movitz:movitz-eval index env))))) - (,prefixes - :addl :eax (:ebx ,(+ (movitz:movitz-eval offset env) - (* 4 (movitz:movitz-eval index env))))))) - ((movitz:movitz-constantp offset env) - (let ((value-var (gensym "memref-value-"))) - `(let ((,value-var ,value)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:ebx :ecx) ,object ,index) - (:load-lexical (:lexical-binding ,value-var) :eax) - ,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2)) - `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) - (:movl ,movitz:+code-vector-word-offset+ - (:ebx :ecx ,(movitz:movitz-eval offset env))) - (,prefixes - :addl :eax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) - (t (let ((value-var (gensym "memref-value-")) - (object-var (gensym "memref-object-"))) - `(let ((,value-var ,value) - (,object-var ,object)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index) - (:load-lexical (:lexical-binding ,value-var) :eax) - ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) - `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) - (:addl :ebx :ecx) ; index += offset - (:load-lexical (:lexical-binding ,object-var) :ebx) - (:movl ,movitz:+code-vector-word-offset+ (:ebx :ecx)) - (,prefixes :addl :eax (:ebx :ecx))))))))) - (t ;; (warn "Can't handle inline MEMREF: ~S" form) - form)))) + (:movw :ax (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-"))) + `(let ((,value-var ,value)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :ecx) ,object ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + ,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2)) + `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) + (:andl ,(mask-field (byte 14 2) -1) :eax) + (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) + (t (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-"))) + `(let ((,value-var ,value) (,object-var ,object)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) + `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) + (:addl :ebx :ecx) ; index += offset + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:andl ,(mask-field (byte 14 2) -1) :eax) + (:movl :ax (:ebx :ecx)))))))) + (:lisp + (let* ((localp (movitz:movitz-eval localp env)) + (prefixes (if localp + nil + movitz:*compiler-nonlocal-lispval-write-segment-prefix*))) + (cond + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) ,value ,object) + (,prefixes :movl :eax (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-"))) + `(let ((,value-var ,value)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :ecx) ,object ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + ,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2)) + `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) + (,prefixes :movl :eax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) + (t (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-"))) + `(let ((,value-var ,value) (,object-var ,object)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) + `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) + (:addl :ebx :ecx) ; index += offset + (:load-lexical (:lexical-binding ,object-var) :ebx) + (,prefixes :movl :eax (:ebx :ecx))))))))) + (:code-vector + (let ((prefixes (if localp + nil + movitz:*compiler-nonlocal-lispval-write-segment-prefix*))) + (cond + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) ,value ,object) + (:movl ,movitz:+code-vector-word-offset+ + (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))) + (,prefixes + :addl :eax (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-"))) + `(let ((,value-var ,value)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :ecx) ,object ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + ,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2)) + `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) + (:movl ,movitz:+code-vector-word-offset+ + (:ebx :ecx ,(movitz:movitz-eval offset env))) + (,prefixes + :addl :eax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) + (t (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-"))) + `(let ((,value-var ,value) + (,object-var ,object)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) + `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) + (:addl :ebx :ecx) ; index += offset + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:movl ,movitz:+code-vector-word-offset+ (:ebx :ecx)) + (,prefixes :addl :eax (:ebx :ecx))))))))) + (t ;; (warn "Can't handle inline MEMREF: ~S" form) + form))))))) (defun (setf memref) (value object offset &key (index 0) (type :lisp) localp (endian :host)) (ecase type @@ -1165,3 +1199,34 @@ (defun %copy-words (destination source count &optional (start1 0) (start2 0)) (%copy-words destination source count start1 start2)) + +;; (define-compiler-macro memrange (object )) + +(defun memrange (object offset index length type) + (ecase type + (:unsigned-byte8 + (let ((vector (make-array length :element-type '(unsigned-byte 8)))) + (loop for i upfrom index as j upfrom 0 repeat length + do (setf (aref vector j) (memref object offset :index i :type :unsigned-byte8))) + vector)))) + +(defun (setf memrange) (value object offset index length type) + (ecase type + (:unsigned-byte8 + (etypecase value + ((unsigned-byte 8) + (loop for i upfrom index repeat length + do (setf (memref object offset :index i :type :unsigned-byte8) value))) + (vector + (loop for i upfrom index as x across value repeat length + do (setf (memref object offset :index i :type :unsigned-byte8) x))))) + (:character + (etypecase value + (character + (loop for i upfrom index repeat length + do (setf (memref object offset :index i :type :character) value))) + (string + (loop for i upfrom index as x across value repeat length + do (setf (memref object offset :index i :type :character) x)))))) + value) + From ffjeld at common-lisp.net Mon May 23 16:45:16 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 23 May 2005 18:45:16 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050523164516.981F888704@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26097 Modified Files: compiler.lisp Log Message: *** empty log message *** Date: Mon May 23 18:45:15 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.140 movitz/compiler.lisp:1.141 --- movitz/compiler.lisp:1.140 Sun May 22 00:38:51 2005 +++ movitz/compiler.lisp Mon May 23 18:45:15 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.140 2005/05/21 22:38:51 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.141 2005/05/23 16:45:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3964,10 +3964,6 @@ (:lexical-binding (append (make-immediate-move x :eax) (make-store-lexical result-mode :eax nil funobj frame-map))) - (:untagged-fixnum-eax - (let ((value (movitz-fixnum-value object))) - (check-type value (unsigned-byte 16)) - (make-immediate-move value :eax))) (:untagged-fixnum-ecx (let ((value (movitz-fixnum-value object))) (check-type value (signed-byte 30)) @@ -3981,6 +3977,9 @@ '((:clc))))))) (movitz-heap-object (ecase (result-mode-type result-mode) + (:untagged-fixnum-ecx + (let ((value (movitz-bignum-value object))) + (make-immediate-move (ldb (byte 32 0) value) :ecx))) (:lexical-binding (append `((:movl ,(new-make-compiled-constant-reference movitz-obj funobj) :eax)) From ffjeld at common-lisp.net Mon May 23 22:40:56 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 24 May 2005 00:40:56 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050523224056.499AF88704@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv15839 Modified Files: compiler.lisp Log Message: Fixed make-store-lexical for :untagged-fixnum-ecx. Date: Tue May 24 00:40:55 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.141 movitz/compiler.lisp:1.142 --- movitz/compiler.lisp:1.141 Mon May 23 18:45:15 2005 +++ movitz/compiler.lisp Tue May 24 00:40:55 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.141 2005/05/23 16:45:15 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.142 2005/05/23 22:40:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3694,10 +3694,15 @@ "store-lexical argnum can't be ~A." (function-argument-argnum binding)) `((:movl ,source (:ebp ,(argument-stack-offset binding))))) (:untagged-fixnum-ecx - (append (unless (member source '(:ecx :untagged-fixnum-ecx)) - `((:movl ,source :ecx))) - (unless (eq source :untagged-fixnum-ecx) - `((:sarl ,+movitz-fixnum-shift+ :ecx))))))))))))) + (cond + ((eq source :untagged-fixnum-ecx) + nil) + ((eq source :eax) + `((,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset 'unbox-u32))))) + (t `((:movl ,source :eax) + (,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset 'unbox-u32))))))))))))))) (defun finalize-code (code funobj frame-map) ;; (print-code 'to-be-finalized code) From ffjeld at common-lisp.net Mon May 23 23:30:16 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 24 May 2005 01:30:16 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050523233016.C998A88704@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18807 Modified Files: compiler.lisp Log Message: Fixed make-load-constant of a literal bignum. Date: Tue May 24 01:30:15 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.142 movitz/compiler.lisp:1.143 --- movitz/compiler.lisp:1.142 Tue May 24 00:40:55 2005 +++ movitz/compiler.lisp Tue May 24 01:30:14 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.142 2005/05/23 22:40:55 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.143 2005/05/23 23:30:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3986,9 +3986,17 @@ (let ((value (movitz-bignum-value object))) (make-immediate-move (ldb (byte 32 0) value) :ecx))) (:lexical-binding - (append `((:movl ,(new-make-compiled-constant-reference movitz-obj funobj) - :eax)) - (make-store-lexical result-mode :eax nil funobj frame-map))) + (cond + ((and (typep movitz-obj 'movitz-bignum) + (eq :untagged-fixnum-ecx + (new-binding-location result-mode frame-map :default nil))) + (make-immediate-move (ldb (byte 32 0) (movitz-bignum-value movitz-obj)) + :ecx)) + (t #+ignore (warn "load to ~S at ~S from ~S" + result-mode (new-binding-location result-mode frame-map) movitz-obj) + (append `((:movl ,(new-make-compiled-constant-reference movitz-obj funobj) + :eax)) + (make-store-lexical result-mode :eax nil funobj frame-map))))) (:push `((:pushl ,(new-make-compiled-constant-reference movitz-obj funobj)))) ((:eax :ebx :ecx :edx :esi) From ffjeld at common-lisp.net Mon May 23 23:30:39 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 24 May 2005 01:30:39 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/dhcp.lisp Message-ID: <20050523233039.79B2988704@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv18991 Modified Files: dhcp.lisp Log Message: *** empty log message *** Date: Tue May 24 01:30:38 2005 Author: ffjeld Index: movitz/losp/lib/net/dhcp.lisp diff -u movitz/losp/lib/net/dhcp.lisp:1.1 movitz/losp/lib/net/dhcp.lisp:1.2 --- movitz/losp/lib/net/dhcp.lisp:1.1 Sun May 22 00:36:33 2005 +++ movitz/losp/lib/net/dhcp.lisp Tue May 24 01:30:38 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri May 13 23:24:01 2005 ;;;; -;;;; $Id: dhcp.lisp,v 1.1 2005/05/21 22:36:33 ffjeld Exp $ +;;;; $Id: dhcp.lisp,v 1.2 2005/05/23 23:30:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -103,6 +103,13 @@ (declare (dynamic-extent options)) (loop while options do (ecase (pop options) + (:lease-time + (vector-push 51 packet) + (vector-push 4 packet) + (let ((time (pop options))) + (check-type time (unsigned-byte 32)) + (loop for b from 24 downto 0 by 8 + do (vector-push (ldb (byte 8 b) time) packet)))) (:message-type (vector-push 53 packet) (vector-push 1 packet) @@ -168,6 +175,11 @@ (subseq packet (fill-pointer packet) (incf (fill-pointer packet) length))))) + (51 (assert (= 4 (vector-read packet))) + (cons :lease-time + (loop with time = 0 repeat 4 + do (setf time (+ (* 256 time) (vector-read packet))) + finally (return time)))) (53 (assert (= 1 (vector-read packet))) (cons :message-type (let ((message-type (vector-read packet))) @@ -193,7 +205,7 @@ (fill-pointer packet) (incf (fill-pointer packet) length))))))))) -(defun format-dhcp-request (nic) +(defun format-dhcp-request (nic &rest dhcp-options &key (message-type :dhcpdiscover)) (let ((packet (make-ethernet-packet))) (with-ether-header (ether packet) (setf (ether :source) (mac-address nic) @@ -217,8 +229,8 @@ (dhcp :chaddr) (mac-address nic) (dhcp :magic) +dhcp-magic+) (setf (fill-pointer packet) (dhcp :end)) + (apply #'dhcp-push-options packet dhcp-options) (dhcp-push-options packet - :message-type :dhcpdiscover :client-identifier (mac-address nic) :end) (setf (ip :length) (- (fill-pointer packet) (ether :end)) @@ -230,25 +242,26 @@ packet)))))) (defun dhcp-request (&optional (nic (or *ip4-nic* (ip4-init)))) - (transmit nic (format-dhcp-request nic)) - (loop with packet = (make-ethernet-packet) - when (and (receive nic packet) - (with-ether-header (ether packet) - (format t "~&From ~@/ethernet:pprint-mac/ to ~:/ethernet:pprint-mac/..~%" - packet packet) - (with-ip4-header (ip packet :start (ether :end)) - (warn "Seeing ~/ip4:pprint-ip4/ from ~/ip4:pprint-ip4/." - (ip4-address (ip :destination)) - (ip4-address (ip :source))) - (with-udp-header (udp packet) - (with-dhcp-header (dhcp packet) - (and (= 4 (ip :version)) - (= 17 (ip :protocol)) - (= 68 (udp :destination-port)) - (= +dhcp-magic+ (dhcp :magic)) - (setf (fill-pointer packet) - (dhcp :end)))))))) + (loop with packet = (make-ethernet-packet) + repeat 5 + do (transmit nic (format-dhcp-request nic)) + (sleep 1/2) + when (loop while (receive nic packet) + thereis (with-ether-header (ether packet) + (with-ip4-header (ip packet :start (ether :end)) + (when (and (= 4 (ip :version)) + (= 17 (ip :protocol))) + (warn "Seeing UDP ~/ip4:pprint-ip4/ from ~/ip4:pprint-ip4/." + (ip4-address (ip :destination)) + (ip4-address (ip :source))) + (with-udp-header (udp packet) + (when (= 68 (udp :destination-port)) + (with-dhcp-header (dhcp packet) + (and (= +dhcp-magic+ (dhcp :magic)) + (setf (fill-pointer packet) + (dhcp :end)))))))))) return (values packet (parse-dhcp-options packet)))) + From ffjeld at common-lisp.net Tue May 24 06:32:29 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 24 May 2005 08:32:29 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050524063229.A952B88730@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11719 Modified Files: compiler.lisp Log Message: *** empty log message *** Date: Tue May 24 08:32:28 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.143 movitz/compiler.lisp:1.144 --- movitz/compiler.lisp:1.143 Tue May 24 01:30:14 2005 +++ movitz/compiler.lisp Tue May 24 08:32:27 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.143 2005/05/23 23:30:14 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.144 2005/05/24 06:32:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3990,10 +3990,16 @@ ((and (typep movitz-obj 'movitz-bignum) (eq :untagged-fixnum-ecx (new-binding-location result-mode frame-map :default nil))) + (unless (typep (movitz-bignum-value movitz-obj) '(unsigned-byte 32)) + (warn "Loading non-u32 ~S into ~S." + (movitz-bignum-value movitz-obj) + result-mode)) (make-immediate-move (ldb (byte 32 0) (movitz-bignum-value movitz-obj)) :ecx)) - (t #+ignore (warn "load to ~S at ~S from ~S" - result-mode (new-binding-location result-mode frame-map) movitz-obj) + (t (when (member (new-binding-location result-mode frame-map :default nil) + '(:ebx :ecx :edx :esi)) + (warn "load to ~S at ~S from ~S" + result-mode (new-binding-location result-mode frame-map) movitz-obj)) (append `((:movl ,(new-make-compiled-constant-reference movitz-obj funobj) :eax)) (make-store-lexical result-mode :eax nil funobj frame-map))))) From ffjeld at common-lisp.net Tue May 24 06:33:19 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 24 May 2005 08:33:19 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp Message-ID: <20050524063319.052D088730@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11748 Modified Files: basic-functions.lisp Log Message: Moved some code around, to fix compilation order. Date: Tue May 24 08:33:19 2005 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.18 movitz/losp/muerte/basic-functions.lisp:1.19 --- movitz/losp/muerte/basic-functions.lisp:1.18 Thu May 5 15:21:46 2005 +++ movitz/losp/muerte/basic-functions.lisp Tue May 24 08:33:19 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.18 2005/05/05 13:21:46 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.19 2005/05/24 06:33:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -383,4 +383,48 @@ (place-name (error "The value of ~S, ~S, is not of type ~S." place-name value type)) - (t (error "~S is not of type ~S." value type)))) \ No newline at end of file + (t (error "~S is not of type ~S." value type)))) + +(defun memrange (object offset index length type) + (ecase type + (:unsigned-byte8 + (let ((vector (make-array length :element-type '(unsigned-byte 8)))) + (let ((i index)) + (dotimes (j length) + (setf (aref vector j) + (memref object offset :index i :type :unsigned-byte8)) + (incf i))) + vector)))) + +(defun (setf memrange) (value object offset index length type) + (ecase type + (:unsigned-byte8 + (etypecase value + ((unsigned-byte 8) + (do ((end (+ index length)) + (i index (1+ i))) + ((>= i end)) + (setf (memref object offset :index i :type :unsigned-byte8) value))) + (vector + (do ((end (+ index length)) + (i index (1+ i)) + (j 0 (1+ j))) + ((or (>= i end) (>= j (length value)))) + (setf (memref object offset :index i :type :unsigned-byte8) + (aref value j)))))) + (:character + (etypecase value + (character + (do ((end (+ index length)) + (i index (1+ i))) + ((>= i end)) + (setf (memref object offset :index i :type :character) value))) + (string + (do ((end (+ index length)) + (i index (1+ i)) + (j 0 (1+ j))) + ((or (>= i end) (>= j (length value)))) + (setf (memref object offset :index i :type :character) + (char value j))))))) + value) + From ffjeld at common-lisp.net Tue May 24 06:33:26 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 24 May 2005 08:33:26 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: <20050524063326.5E32D88736@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11765 Modified Files: integers.lisp Log Message: Moved some code around, to fix compilation order. Date: Tue May 24 08:33:25 2005 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.105 movitz/losp/muerte/integers.lisp:1.106 --- movitz/losp/muerte/integers.lisp:1.105 Wed Apr 13 09:26:29 2005 +++ movitz/losp/muerte/integers.lisp Tue May 24 08:33:24 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.105 2005/04/13 07:26:29 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.106 2005/05/24 06:33:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -426,6 +426,13 @@ ((typep size '(integer 1 *)) (list 'integer 0 (1- (ash 1 size)))) (t (error "Illegal size for unsigned-byte.")))) + +(define-typep rational (x &optional (lower-limit '*) (upper-limit '*)) + (and (typep x 'rational) + (or (eq lower-limit '*) + (<= lower-limit x)) + (or (eq upper-limit '*) + (<= x upper-limit)))) (deftype real (&optional (lower-limit '*) (upper-limit '*)) `(or (integer ,lower-limit ,upper-limit) From ffjeld at common-lisp.net Tue May 24 06:33:30 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 24 May 2005 08:33:30 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: <20050524063330.1555B88736@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11780 Modified Files: interrupt.lisp Log Message: Moved some code around, to fix compilation order. Date: Tue May 24 08:33:30 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.45 movitz/losp/muerte/interrupt.lisp:1.46 --- movitz/losp/muerte/interrupt.lisp:1.45 Mon May 9 08:20:55 2005 +++ movitz/losp/muerte/interrupt.lisp Tue May 24 08:33:28 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.45 2005/05/09 06:20:55 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.46 2005/05/24 06:33:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -55,24 +55,8 @@ (defun dit-frame-offset (name) (* 4 (dit-frame-index name)))) -(define-compiler-macro dit-frame-ref (&whole form stack frame reg - &optional (type :lisp) - &environment env) - (if (not (and (movitz:movitz-constantp stack env) - (eq nil (movitz:movitz-eval stack env)))) - form - `(memref ,frame (dit-frame-offset ,reg) :type ,type))) - (defun dit-frame-ref (stack frame reg &optional (type :lisp)) (stack-frame-ref stack (+ frame (dit-frame-index reg)) 0 type)) - -(define-compiler-macro (setf dit-frame-ref) (&whole form value stack frame reg - &optional (type :lisp) - &environment env) - (if (not (and (movitz:movitz-constantp stack env) - (eq nil (movitz:movitz-eval stack env)))) - form - `(setf (memref ,frame (dit-frame-offset ,reg) :type ,type) ,value))) (defun (setf dit-frame-ref) (value stack frame reg &optional (type :lisp)) (setf (stack-frame-ref stack (+ frame (dit-frame-index reg)) 0 type) From ffjeld at common-lisp.net Tue May 24 06:33:37 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 24 May 2005 08:33:37 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: <20050524063337.C172788736@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11796 Modified Files: memref.lisp Log Message: Moved some code around, to fix compilation order. Date: Tue May 24 08:33:37 2005 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.46 movitz/losp/muerte/memref.lisp:1.47 --- movitz/losp/muerte/memref.lisp:1.46 Sun May 22 00:37:32 2005 +++ movitz/losp/muerte/memref.lisp Tue May 24 08:33:35 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.46 2005/05/21 22:37:32 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.47 2005/05/24 06:33:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -563,9 +563,8 @@ (,offset-var ,offset) (,index-var ,index)) (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:load-lexical (:lexical-binding ,value-var) :eax) - (:call-global-pf unbox-u32) (:compile-two-forms (:eax :edx) ,index-var ,offset-var) + (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-ecx) (:load-lexical (:lexical-binding ,object-var) :ebx) ,@(when (eq endian :big) `((:bswap :ecx))) @@ -1202,31 +1201,3 @@ ;; (define-compiler-macro memrange (object )) -(defun memrange (object offset index length type) - (ecase type - (:unsigned-byte8 - (let ((vector (make-array length :element-type '(unsigned-byte 8)))) - (loop for i upfrom index as j upfrom 0 repeat length - do (setf (aref vector j) (memref object offset :index i :type :unsigned-byte8))) - vector)))) - -(defun (setf memrange) (value object offset index length type) - (ecase type - (:unsigned-byte8 - (etypecase value - ((unsigned-byte 8) - (loop for i upfrom index repeat length - do (setf (memref object offset :index i :type :unsigned-byte8) value))) - (vector - (loop for i upfrom index as x across value repeat length - do (setf (memref object offset :index i :type :unsigned-byte8) x))))) - (:character - (etypecase value - (character - (loop for i upfrom index repeat length - do (setf (memref object offset :index i :type :character) value))) - (string - (loop for i upfrom index as x across value repeat length - do (setf (memref object offset :index i :type :character) x)))))) - value) - From ffjeld at common-lisp.net Tue May 24 06:33:40 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 24 May 2005 08:33:40 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp Message-ID: <20050524063340.C149D88751@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11812 Modified Files: more-macros.lisp Log Message: Moved some code around, to fix compilation order. Date: Tue May 24 08:33:40 2005 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.27 movitz/losp/muerte/more-macros.lisp:1.28 --- movitz/losp/muerte/more-macros.lisp:1.27 Thu May 5 22:52:10 2005 +++ movitz/losp/muerte/more-macros.lisp Tue May 24 08:33:40 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.27 2005/05/05 20:52:10 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.28 2005/05/24 06:33:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -404,6 +404,22 @@ (when ,var (sti)))))) +(define-compiler-macro dit-frame-ref (&whole form stack frame reg + &optional (type :lisp) + &environment env) + (if (not (and (movitz:movitz-constantp stack env) + (eq nil (movitz:movitz-eval stack env)))) + form + `(memref ,frame (dit-frame-offset ,reg) :type ,type))) + +(define-compiler-macro (setf dit-frame-ref) (&whole form value stack frame reg + &optional (type :lisp) + &environment env) + (if (not (and (movitz:movitz-constantp stack env) + (eq nil (movitz:movitz-eval stack env)))) + form + `(setf (memref ,frame (dit-frame-offset ,reg) :type ,type) ,value))) + ;;; Some macros that aren't implemented, and we want to give compiler errors. (defmacro define-unimplemented-macro (name) @@ -414,3 +430,4 @@ (define-unimplemented-macro with-open-file) (define-unimplemented-macro restart-case) + From ffjeld at common-lisp.net Tue May 24 06:33:48 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 24 May 2005 08:33:48 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: <20050524063348.7486688730@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11829 Modified Files: typep.lisp Log Message: Moved some code around, to fix compilation order. Date: Tue May 24 08:33:47 2005 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.43 movitz/losp/muerte/typep.lisp:1.44 --- movitz/losp/muerte/typep.lisp:1.43 Fri Apr 15 09:00:31 2005 +++ movitz/losp/muerte/typep.lisp Tue May 24 08:33:46 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.43 2005/04/15 07:00:31 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.44 2005/05/24 06:33:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -585,13 +585,6 @@ (typep x 'code-vector)) ;;; - -(define-typep rational (x &optional (lower-limit '*) (upper-limit '*)) - (and (typep x 'rational) - (or (eq lower-limit '*) - (<= lower-limit x)) - (or (eq upper-limit '*) - (<= x upper-limit)))) (define-typep and (x &rest types) (declare (dynamic-extent types)) From ffjeld at common-lisp.net Tue May 24 07:14:54 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 24 May 2005 09:14:54 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp Message-ID: <20050524071454.28FBF88751@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv13729 Modified Files: ip4.lisp Log Message: *** empty log message *** Date: Tue May 24 09:14:53 2005 Author: ffjeld Index: movitz/losp/lib/net/ip4.lisp diff -u movitz/losp/lib/net/ip4.lisp:1.18 movitz/losp/lib/net/ip4.lisp:1.19 --- movitz/losp/lib/net/ip4.lisp:1.18 Sun May 22 00:36:16 2005 +++ movitz/losp/lib/net/ip4.lisp Tue May 24 09:14:53 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 30 13:52:57 2003 ;;;; -;;;; $Id: ip4.lisp,v 1.18 2005/05/21 22:36:16 ffjeld Exp $ +;;;; $Id: ip4.lisp,v 1.19 2005/05/24 07:14:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -31,8 +31,8 @@ #:*ip4-nic* #:*ip4-ip* #:*ip4-router* - - #:with-ip4-header)) + #:with-ip4-header + #:dhcp-init)) (in-package muerte.ip4) From ffjeld at common-lisp.net Tue May 24 07:15:54 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 24 May 2005 09:15:54 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/dhcp.lisp Message-ID: <20050524071554.DE20D88751@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv14520 Modified Files: dhcp.lisp Log Message: *** empty log message *** Date: Tue May 24 09:15:54 2005 Author: ffjeld Index: movitz/losp/lib/net/dhcp.lisp diff -u movitz/losp/lib/net/dhcp.lisp:1.2 movitz/losp/lib/net/dhcp.lisp:1.3 --- movitz/losp/lib/net/dhcp.lisp:1.2 Tue May 24 01:30:38 2005 +++ movitz/losp/lib/net/dhcp.lisp Tue May 24 09:15:54 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri May 13 23:24:01 2005 ;;;; -;;;; $Id: dhcp.lisp,v 1.2 2005/05/23 23:30:38 ffjeld Exp $ +;;;; $Id: dhcp.lisp,v 1.3 2005/05/24 07:15:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,14 +56,15 @@ +---------------------------------------------------------------+ |# -(defmacro with-dhcp-header ((dhcp packet &key (start '(udp :end))) &body body) +(defmacro with-dhcp-header ((dhcp packet &key start) &body body) (let* ((dhcp-ref (gensym "dhcp-ref-")) (start-var (gensym "dhcp-start-")) (packet-var (gensym "dhcp-packet-")) (offset-var (gensym "dhcp-packet-start-"))) - `(let* ((,start-var ,start) - (,packet-var (ensure-data-vector ,packet ,start-var 232)) + `(let* ((,packet-var ,packet) + (,start-var ,(or start `(fill-pointer ,packet-var))) (,offset-var (+ ,start-var (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (ensure-data-vector ,packet ,start-var 232) (macrolet ((,dhcp-ref (offset type) `(memref ,',packet-var (+ ,',offset-var ,offset) :type ,type :endian :big)) (,dhcp (slot) @@ -77,7 +78,7 @@ (:flags `(,',dhcp-ref 10 :unsigned-byte16)) ((:ciaddr :yiaddr :siaddr :giaddr) - `(,',dhcp-ref ,(+ 12 (position slot '(:ciaddr :yiaddr :siaddr :giaddr))) + `(,',dhcp-ref ,(+ 12 (* 4 (position slot '(:ciaddr :yiaddr :siaddr :giaddr)))) :unsigned-byte32)) (:chaddr `(memrange ,',packet-var 0 (+ ,',offset-var 28) 16 :unsigned-byte8)) @@ -102,7 +103,7 @@ (defun dhcp-push-options (packet &rest options) (declare (dynamic-extent options)) (loop while options - do (ecase (pop options) + do (case (pop options) (:lease-time (vector-push 51 packet) (vector-push 4 packet) @@ -133,16 +134,17 @@ unless (= 0 option) collect (case option - (1 (assert (= 4 (vector-read packet))) + (1 (assert (= 4 (vector-read packet)) () "Wrong length for subnet-mask.") (cons :subnet-mask (subseq packet (fill-pointer packet) (incf (fill-pointer packet) 4)))) (3 (let ((length (vector-read packet))) (cons :routers - (subseq packet - (fill-pointer packet) - (incf (fill-pointer packet) length))))) + (loop repeat (truncate length 4) + collect (subseq packet + (fill-pointer packet) + (incf (fill-pointer packet) 4)))))) (6 (let ((length (vector-read packet))) (cons :dns-servers (subseq packet @@ -160,7 +162,7 @@ (subseq packet (fill-pointer packet) (incf (fill-pointer packet) length)))))) - (28 (assert (= 4 (vector-read packet))) + (28 (assert (= 4 (vector-read packet)) () "Wrong length for broadcast.") (cons :broadcast (subseq packet (fill-pointer packet) @@ -175,7 +177,7 @@ (subseq packet (fill-pointer packet) (incf (fill-pointer packet) length))))) - (51 (assert (= 4 (vector-read packet))) + (51 (assert (= 4 (vector-read packet)) () "Wrong length for lease-time.") (cons :lease-time (loop with time = 0 repeat 4 do (setf time (+ (* 256 time) (vector-read packet))) @@ -205,7 +207,7 @@ (fill-pointer packet) (incf (fill-pointer packet) length))))))))) -(defun format-dhcp-request (nic &rest dhcp-options &key (message-type :dhcpdiscover)) +(defun format-dhcp-request (nic &rest dhcp-options &key (xid 0) (message-type :dhcpdiscover)) (let ((packet (make-ethernet-packet))) (with-ether-header (ether packet) (setf (ether :source) (mac-address nic) @@ -213,7 +215,7 @@ (ether :type) +ether-type-ip4+) (with-ip4-header (ip packet :start (ether :end)) (with-udp-header (udp packet) - (with-dhcp-header (dhcp packet) + (with-dhcp-header (dhcp packet :start (udp :end)) (setf (ip :version) 4 (ip :protocol) 17 (ip :ihl) 5 @@ -226,6 +228,7 @@ (dhcp :hlen ) 6 (dhcp :hops) 0 (dhcp :secs) 0 + (dhcp :xid) xid (dhcp :chaddr) (mac-address nic) (dhcp :magic) +dhcp-magic+) (setf (fill-pointer packet) (dhcp :end)) @@ -241,10 +244,12 @@ (udp :checksum) (udp :compute-checksum ip)) packet)))))) -(defun dhcp-request (&optional (nic (or *ip4-nic* (ip4-init)))) - (loop with packet = (make-ethernet-packet) +(defun dhcp-request (&optional (nic (or *ip4-nic* (ip4-init))) &rest dhcp-options) + (declare (dynamic-extent dhcp-options)) + (loop with packet = (make-ethernet-packet) + with xid = (random 10000) repeat 5 - do (transmit nic (format-dhcp-request nic)) + do (transmit nic (apply #'format-dhcp-request nic :xid xid dhcp-options)) (sleep 1/2) when (loop while (receive nic packet) thereis (with-ether-header (ether packet) @@ -256,15 +261,25 @@ (ip4-address (ip :source))) (with-udp-header (udp packet) (when (= 68 (udp :destination-port)) + (setf (fill-pointer packet) + (udp :end)) (with-dhcp-header (dhcp packet) - (and (= +dhcp-magic+ (dhcp :magic)) - (setf (fill-pointer packet) - (dhcp :end)))))))))) - return (values packet (parse-dhcp-options packet)))) - - - - - - - \ No newline at end of file + (and (= xid (dhcp :xid)) + (= +dhcp-magic+ (dhcp :magic)))))))))) + return packet)) + +(defun dhcp-init () + (let ((packet (dhcp-request))) + (if (not packet) + (warn "DHCP lookup failed.") + (with-dhcp-header (dhcp packet) + (setf (fill-pointer packet) (dhcp :end)) + (let ((options (parse-dhcp-options packet))) + (setf *ip4-ip* (ip4-address (dhcp :yiaddr)) + *ip4-router* (first (cdr (assoc :routers options)))) + (format *terminal-io* "Setting IP ~/ip4:pprint-ip4/ ~@[~A~]~@[.~A~] router ~/ip4:pprint-ip4/." + *ip4-ip* + (cdr (assoc :host-name options)) + (cdr (assoc :domain-name options)) + *ip4-router*))))) + (values)) From ffjeld at common-lisp.net Wed May 25 19:46:07 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 25 May 2005 21:46:07 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp Message-ID: <20050525194607.EF045880DD@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv15239 Modified Files: ip4.lisp Log Message: *** empty log message *** Date: Wed May 25 21:46:07 2005 Author: ffjeld Index: movitz/losp/lib/net/ip4.lisp diff -u movitz/losp/lib/net/ip4.lisp:1.19 movitz/losp/lib/net/ip4.lisp:1.20 --- movitz/losp/lib/net/ip4.lisp:1.19 Tue May 24 09:14:53 2005 +++ movitz/losp/lib/net/ip4.lisp Wed May 25 21:46:07 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 30 13:52:57 2003 ;;;; -;;;; $Id: ip4.lisp,v 1.19 2005/05/24 07:14:53 ffjeld Exp $ +;;;; $Id: ip4.lisp,v 1.20 2005/05/25 19:46:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -242,40 +242,42 @@ (ash x -16))))) (defun ip-input (stack packet start) - (let ((header-size (* 4 (ip-header-length packet start)))) - (cond - ((not (checksum-ok (checksum-octets packet start (+ start header-size)))) - (warn "IP4 header checksum failed (from ~@/ip4:pprint-ip4/ to ~:/ip4:pprint-ip4/ proto ~A len ~D)." - packet packet - (integer-name 'ip-protocol (ip-protocol packet start) nil) - (length packet)) - #+ignore - (loop for y from 0 below (length packet) by 16 - do (fresh-line) - (loop for x from y below (min (length packet) (+ y 16)) - when (zerop (rem x 4)) - do (format t " ") - do (format t " ~2,'0X" (aref packet x))) - (write-string " ") - (loop for x from y below (min (length packet) (+ y 16)) - as c = (code-char (aref packet x)) - do (write-char (if (alphanumericp c) c #\.))))) - ((mismatch packet (address stack) - :start1 (+ start +ip-header-destination+) - :end1 (+ start +ip-header-destination+ 4)) - #+ignore - (warn "IPv4 Packet from ~@/ip4:pprint-ip4/ not for me, but for ~:/ip4:pprint-ip4/." - packet packet)) - (t (named-integer-case ip-protocol (ip-protocol packet start) - (icmp - (icmp-input stack packet start (+ start header-size))) - (udp - (udp-input stack packet start (+ start header-size))) - (tcp - (tcp-input stack packet start (+ start header-size))) - (t (warn "Unknown IPv4 protocol ~A received from ~@/ip4:pprint-ip4/." - (integer-name 'ip-protocol (ip-protocol packet start) nil) - packet))))))) + (with-ip4-header (ip packet :start start) + (let ((header-size (* 4 (ip :ihl)))) + (cond + ((not (or (= 0 (ip :checksum)) + (checksum-ok (checksum-octets packet start (+ start header-size))))) + (warn "IP4 header checksum failed #x~X (from ~@/ip4:pprint-ip4/ to ~:/ip4:pprint-ip4/ proto ~A len ~D)." + (checksum-octets packet start (+ start header-size)) + packet packet + (integer-name 'ip-protocol (ip-protocol packet start) nil) + (length packet)) + (loop for y from 0 below (length packet) by 16 + do (fresh-line) + (loop for x from y below (min (length packet) (+ y 16)) + when (zerop (rem x 4)) + do (format t " ") + do (format t " ~2,'0X" (aref packet x))) + (write-string " ") + (loop for x from y below (min (length packet) (+ y 16)) + as c = (code-char (aref packet x)) + do (write-char (if (alphanumericp c) c #\.))))) + ((mismatch packet (address stack) + :start1 (+ start +ip-header-destination+) + :end1 (+ start +ip-header-destination+ 4)) + #+ignore + (warn "IPv4 Packet from ~@/ip4:pprint-ip4/ not for me, but for ~:/ip4:pprint-ip4/." + packet packet)) + (t (named-integer-case ip-protocol (ip :protocol) + (icmp + (icmp-input stack packet start (+ start header-size))) + (udp + (udp-input stack packet start (+ start header-size))) + (tcp + (tcp-input stack packet start (+ start header-size))) + (t (warn "Unknown IPv4 protocol ~A received from ~@/ip4:pprint-ip4/." + (integer-name 'ip-protocol (ip :protocol) nil) + packet)))))))) @@ -307,7 +309,7 @@ (= +ether-type-ip4+ (arp-prot-type packet start)) (not (mismatch (address stack) packet :start2 (+ start 24) :end2 (+ start 28)))) - (warn "arp request from ~v/ip4:pprint-ip4/." (+ start 14) packet) + (warn "arp request from ~v/ip4:pprint-ip4/ len ~D." (+ start 14) packet (length packet)) (transmit (interface stack) (format-ethernet-packet (format-arp-request nil +arp-op-reply+ (address stack) @@ -316,12 +318,12 @@ :target-hardware-address packet :target-hardware-address-start (+ start 8)) (mac-address (interface stack)) - packet - muerte.ethernet:+ether-type-arp+ - :destination-start (+ start 8)))) + (ether-source packet) + muerte.ethernet:+ether-type-arp+))) (t (unknown-packet stack packet) - #+ignore (warn "ARP request for not me ~/ip4:pprint-ip4/: ~v/ip4:pprint-ip4/." - (address stack) (+ start 24) packet)))) + #+ignore + (warn "ARP request for not me ~/ip4:pprint-ip4/: ~v/ip4:pprint-ip4/." + (address stack) (+ start 24) packet)))) (#.+arp-op-reply+ (warn "Received an ARP reply: ~v/ip4:pprint-ip4/ is ~v/ethernet:pprint-mac/." (+ start 14) packet From ffjeld at common-lisp.net Sun May 29 22:03:04 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 30 May 2005 00:03:04 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp Message-ID: <20050529220304.D4E08880DC@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12156 Modified Files: conditions.lisp Log Message: *** empty log message *** Date: Mon May 30 00:03:04 2005 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.15 movitz/losp/muerte/conditions.lisp:1.16 --- movitz/losp/muerte/conditions.lisp:1.15 Sat Apr 30 00:36:23 2005 +++ movitz/losp/muerte/conditions.lisp Mon May 30 00:03:04 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.15 2005/04/29 22:36:23 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.16 2005/05/29 22:03:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -280,8 +280,9 @@ (setf *debugger-function* #'muerte.init::my-debugger)) (cond ((not *debugger-function*) - (format t "~&No debugger in *debugger-function*. Trying to abort.") - (invoke-restart (or (find-restart 'abort) + (format t "~&No debugger in *debugger-function*. Trying to continue or abort.") + (invoke-restart (or (find-restart 'continue) + (find-restart 'abort) (format t "~%Condition for debugger: ~Z" condition) (format t "~%No abort restart is active. Halting CPU.") (halt-cpu)))) From ffjeld at common-lisp.net Sun May 29 22:03:07 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 30 May 2005 00:03:07 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/packages.lisp Message-ID: <20050529220307.995168875A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12173 Modified Files: packages.lisp Log Message: *** empty log message *** Date: Mon May 30 00:03:06 2005 Author: ffjeld Index: movitz/losp/muerte/packages.lisp diff -u movitz/losp/muerte/packages.lisp:1.9 movitz/losp/muerte/packages.lisp:1.10 --- movitz/losp/muerte/packages.lisp:1.9 Thu May 5 15:21:50 2005 +++ movitz/losp/muerte/packages.lisp Mon May 30 00:03:06 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 30 15:19:43 2001 ;;;; -;;;; $Id: packages.lisp,v 1.9 2005/05/05 13:21:50 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.10 2005/05/29 22:03:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -39,9 +39,11 @@ (package-object-use-list (find-package package-name))) (defun find-package (name) - (if (packagep name) - name - (find-package-string (string name)))) + (typecase name + (package name) + (null (find-package 'common-lisp)) ; This can be practical.. + ((or symbol string) (find-package-string (string name))) + (t (error "Not a package name: ~S" name)))) (defun find-package-string (name &optional (start 0) (end (length name)) (key 'identity)) (values (gethash-string name start end *packages* nil key)))