Update of /project/movitz/cvsroot/movitz/losp
In directory common-lisp.net:/tmp/cvs-serv29766
Modified Files:
ll-testing.lisp
Log Message:
Threads have landed!
Date: Wed Apr 27 00:23:14 2005
Author: ffjeld
Index: movitz/losp/ll-testing.lisp
diff -u movitz/losp/ll-testing.lisp:1.3 movitz/losp/ll-testing.lisp:1.4
--- movitz/losp/ll-testing.lisp:1.3 Mon Apr 18 09:08:58 2005
+++ movitz/losp/ll-testing.lisp Wed Apr 27 00:23:14 2005
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org>
;;;; Created at: Thu Apr 14 08:18:43 2005
;;;;
-;;;; $Id: ll-testing.lisp,v 1.3 2005/04/18 07:08:58 ffjeld Exp $
+;;;; $Id: ll-testing.lisp,v 1.4 2005/04/26 22:23:14 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -43,9 +43,7 @@
(check-type entries (integer 0 *))
(let ((limit (1- (* 8 entries)))
(base (+ 2 (+ (object-location table)
- (memref nil (movitz-type-slot-offset 'movitz-run-time-context
- 'physical-address-offset)
- :type :lisp)))))
+ (location-physical-offset)))))
(%lgdt base limit)
(values table limit))))
@@ -54,8 +52,224 @@
(loop for i from start below end
do (format t "~&~2D: base: #x~8,'0X, limit: #x~5,'0X, type-s-dpl-p: ~8,'0b, avl-x-db-g: ~4,'0b~%"
i
- (segment-descriptor-base table i)
+ (* 4 (segment-descriptor-base-location table i))
(segment-descriptor-limit table i)
(segment-descriptor-type-s-dpl-p table i)
(segment-descriptor-avl-x-db-g table i)))
- (values))
\ No newline at end of file
+ (values))
+
+
+
+(defmacro control-stack-esp (stack)
+ `(stack-frame-ref ,stack 0 1))
+
+(defmacro control-stack-ebp (stack)
+ `(stack-frame-ref ,stack 0 0))
+
+(defun control-stack-init (&optional (stack (make-array 254 :element-type '(unsigned-byte 32))))
+ (let ((i (length stack)))
+ (setf (control-stack-esp stack) i
+ (control-stack-ebp stack) 0)
+ stack))
+
+(defun control-stack-push (value stack &optional (type :lisp))
+ (let ((i (decf (control-stack-esp stack))))
+ (assert (< 1 i (length stack)))
+ (setf (stack-frame-ref stack i 0 type) value)))
+
+(defun control-stack-enter-frame (stack &optional function)
+ (control-stack-push (control-stack-ebp stack) stack)
+ (setf (control-stack-ebp stack) (control-stack-esp stack))
+ (when function
+ (check-type function function)
+ (control-stack-push function stack))
+ stack)
+
+(defun stack-stopper (&rest args)
+ (declare (ignore args))
+ (declare (without-function-prelude))
+ (error "Stack stop.")
+ (format *terminal-io* "~&Stack-stopper halt.")
+ (loop (halt-cpu)))
+
+(defun control-stack-fixate (stack)
+ (let ((stack-base (+ 2 (object-location stack))))
+ (do ((frame (control-stack-ebp stack)))
+ ((zerop (stack-frame-uplink stack frame)))
+ (assert (typep (stack-frame-funobj stack frame) 'function))
+ (let ((previous-frame frame))
+ (setf frame (stack-frame-uplink stack frame))
+ (incf (stack-frame-ref stack previous-frame 0)
+ stack-base)))
+ (values (+ (control-stack-ebp stack) stack-base)
+ (+ (control-stack-esp stack) stack-base))))
+
+(defun make-thread (segment-descriptor-table)
+ (let* ((fs-index 8)
+ (thread (muerte::clone-run-time-context :name 'subthread)))
+ (setf (segment-descriptor segment-descriptor-table fs-index)
+ (segment-descriptor segment-descriptor-table (truncate (segment-register :fs) 8)))
+ (warn "Thread ~S FS base: ~S"
+ thread
+ (setf (segment-descriptor-base-location segment-descriptor-table fs-index)
+ (+ (object-location thread)
+ (muerte::location-physical-offset))))
+ (values thread (* 8 fs-index))))
+
+
+(defun control-stack-bootstrap (stack function &rest args)
+ (declare (dynamic-extent args))
+ (check-type function function)
+ (control-stack-init stack)
+ (control-stack-push 0 stack)
+ (control-stack-enter-frame stack #'stack-stopper)
+ (let ((stack-top (+ (object-location stack) 2 (length stack)))
+ (stack-bottom (+ (object-location stack) 2)))
+ (dolist (arg (cddr args))
+ (control-stack-push arg stack))
+ (control-stack-push (+ 2 1 (object-location (funobj-code-vector #'stack-stopper)))
+ stack) ; XXX The extra word skips the frame-setup.
+ (multiple-value-bind (ebp esp)
+ (control-stack-fixate stack)
+ (stack-yield stack esp ebp
+ :eax (car args)
+ :ebx (cadr args)
+ :ecx (length args)
+ :esi function)))
+ stack)
+
+(defun test-tt ()
+ (multiple-value-bind (thread stack)
+ (muerte.init::threading)
+ (control-stack-bootstrap stack #'format t "Hello world!")))
+
+(defun test-tr (function &rest args)
+ (declare (dynamic-extent args))
+ (assert (= 2 (length args)))
+ (multiple-value-bind (thread fs)
+ (make-thread muerte.init::*segment-descriptor-table*)
+ (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-ebp stack) ebp
+ (control-stack-esp stack) esp))
+ (setf (%run-time-context-slot 'dynamic-env thread) 0
+ (%run-time-context-slot 'stack-vector thread) stack
+ (%run-time-context-slot 'stack-top thread) (+ 2 (object-location stack)
+ (length stack))
+ (%run-time-context-slot 'stack-bottom thread) (+ (object-location stack) 2
+ (or cushion
+ (if (>= (length stack) 200)
+ 100
+ 0))))
+ (values thread fs stack))))
+
+(defun stack-bootstrapper (&rest args)
+ (declare (ignore args))
+ (with-inline-assembly (:returns :nothing) (:break))
+ (let ((frame (current-stack-frame)))
+ (assert (eql 0 (stack-frame-uplink nil frame)))
+ (let ((function (stack-frame-ref nil frame 1))
+ (numargs (stack-frame-ref nil frame 2)))
+ (warn "[~S] bootstrapping function ~S with ~D args." frame function numargs)
+ (check-type function function)
+ (check-type numargs (integer 0 #xffff))
+ (with-inline-assembly (:returns :multiple-values)
+ (:load-lexical (:lexical-binding function) :esi)
+ (:movl (:ebp #x0c) :eax)
+ (:movl (:ebp #x10) :ebx)
+ (:call (:esi (:offset movitz-funobj code-vector%2op))))))
+ (error "Stack bootstrapper stop.")
+ (format *terminal-io* "~&stack-bootstrapper halt.")
+ (loop (halt-cpu)))
+
+(defun control-stack-init-for-yield (stack function args)
+ (check-type function function)
+ (control-stack-init stack)
+ (control-stack-push (second args) stack)
+ (control-stack-push (first args) stack)
+ (control-stack-push (length args) stack)
+ (control-stack-push function stack)
+ (control-stack-enter-frame stack #'stack-bootstrapper)
+ ;; Now pretend stack-bootstrapper called yield. First, the return address
+ (control-stack-push (+ 2 2 (object-location (funobj-code-vector #'stack-bootstrapper)))
+ stack) ; XXX The extra 2 words skip the frame-setup,
+ ; XXX which happens to be 8 bytes..
+ (control-stack-enter-frame stack #'yield)
+ (control-stack-push 0 stack) ; XXX shouldn't need this?
+ stack)
+
+
+(defun yield (target-rtc fs)
+ (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)))
+ (assert (not (eq my-stack target-stack)))
+ (let ((esp (control-stack-esp target-stack))
+ (ebp (control-stack-ebp target-stack)))
+ (assert (location-in-object-p target-stack esp))
+ (assert (location-in-object-p target-stack ebp))
+ (assert (eq (memref ebp -4) (asm-register :esi)) ()
+ "Cannot yield to a non-yield frame.")
+ ;; Push eflags for later..
+ (setf (memref (decf esp) 0) (eflags))
+ ;; Enable someone to yield back here..
+ (setf (control-stack-ebp my-stack) (asm-register :ebp)
+ (control-stack-esp my-stack) (asm-register :esp))
+ (with-inline-assembly (:returns :nothing)
+ (:cli)
+ (:load-lexical (:lexical-binding fs) :untagged-fixnum-ecx)
+ (:movw :cx :fs)
+ (:load-lexical (:lexical-binding ebp) :eax)
+ (:load-lexical (:lexical-binding esp) :ebx)
+ (:movl :eax :ebp)
+ (:movl :ebx :esp)
+ (:popfl)))))
+
+(defun stack-yield (stack esp ebp &key eax ebx ecx edx esi eflags (dynamic-env 0) cushion)
+ "Activate stack for the current run-time-context, and load the indicated CPU state.
+EIP is loaded from ESI's code-vector."
+ (assert (not (eq stack (%run-time-context-slot 'stack-vector))))
+ (assert (location-in-object-p stack esp))
+ (assert (location-in-object-p stack ebp))
+ (assert (or (= 0 dynamic-env) (location-in-object-p stack dynamic-env)))
+ (let ((stack-top (+ (object-location stack) 2 (length stack)))
+ (stack-bottom (+ (object-location stack) 2
+ (or cushion
+ (if (>= (length stack) 200)
+ 100
+ 0)))))
+ (with-inline-assembly (:returns :non-local-exit)
+ (:clc)
+ (:pushfl)
+ (:popl :ebx)
+ (:compile-form (:result-mode :eax) eflags)
+ (:cmpl :edi :eax)
+ (:je 'no-eflags-provided)
+ (:movl :eax :ebx)
+ no-eflags-provided
+ (:locally (:movl :ebx (:edi (:edi-offset raw-scratch0)))) ; Keep eflags in raw-scratch0
+ (:cli) ; Disable interrupts for a little while
+ (:compile-form (:result-mode :eax) stack)
+ (:locally (:movl :eax (:edi (:edi-offset stack-vector))))
+ (:compile-form (:result-mode :eax) dynamic-env)
+ (:locally (:movl :eax (:edi (:edi-offset dynamic-env))))
+ (:compile-two-forms (:eax :ebx) stack-top stack-bottom)
+ (:locally (:movl :eax (:edi (:edi-offset stack-top))))
+ (:locally (:movl :ebx (:edi (:edi-offset stack-bottom))))
+
+ (:compile-two-forms (:eax :ebx) esp ebp)
+ (:locally (:movl :eax (:edi (:edi-offset scratch1))))
+ (:locally (:movl :ebx (:edi (:edi-offset scratch2))))
+
+ (:compile-form (:result-mode :untagged-fixnum-ecx) ecx)
+ (:compile-two-forms (:eax :ebx) eax ebx)
+ (:compile-two-forms (:edx :esi) edx esi)
+ (:locally (:movl (:edi (:edi-offset scratch1)) :esp))
+ (:locally (:movl (:edi (:edi-offset scratch2)) :ebp))
+ (:locally (:pushl (:edi (:edi-offset raw-scratch0)))) ; reset eflags
+ (:popfl)
+ (:jmp (:esi (:offset movitz-funobj code-vector))))))
+
