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

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

22 May '05

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

1 0

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

09 May '05

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

1 0

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

09 May '05

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

1 0

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

09 May '05

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 <header part> <variable-length part> 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)

1 0

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

1 0

[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

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.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-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 <frodef(a)acm.org> ;;;; 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)))

1 0

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

06 May '05

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

1 0

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

05 May '05

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

1 0

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

05 May '05

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

1 0

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

05 May '05

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

1 0

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

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-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 <frodef(a)acm.org> ;;;; 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 ,@format-arguments) ,@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 ()

1 0

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

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-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 <frodef(a)acm.org> ;;;; 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."

1 0

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

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-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 <frodef(a)acm.org> ;;;; 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

1 0

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

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-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 <frodef(a)acm.org> ;;;; 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 ,@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)

1 0

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

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-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 <frodef(a)acm.org> ;;;; 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

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs May 2005