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

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

08 May '05

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 <frodef(a)acm.org> ;;;; 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)

1 0

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

08 May '05

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))

1 0

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

08 May '05

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 <frodef(a)acm.org> ;;;; 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 <table> 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))))

1 0

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

08 May '05

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 <frodef(a)acm.org> ;;;; 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)))

1 0

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

08 May '05

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 <frodef(a)acm.org> ;;;; 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))))

1 0

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

08 May '05

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 <frodef(a)acm.org> ;;;; 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 <table> 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)))

1 0

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

08 May '05

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."

1 0

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

08 May '05

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 <frodef(a)acm.org> ;;;; 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

1 0

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

08 May '05

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

1 0

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

06 May '05

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 <frodef(a)acm.org> ;;;; 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)

1 0