Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv2466
Modified Files: ll-testing.lisp Log Message: Now there is make-thread.
Date: Wed Apr 27 01:46:14 2005 Author: ffjeld
Index: movitz/losp/ll-testing.lisp diff -u movitz/losp/ll-testing.lisp:1.4 movitz/losp/ll-testing.lisp:1.5 --- movitz/losp/ll-testing.lisp:1.4 Wed Apr 27 00:23:14 2005 +++ movitz/losp/ll-testing.lisp Wed Apr 27 01:46:13 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Thu Apr 14 08:18:43 2005 ;;;; -;;;; $Id: ll-testing.lisp,v 1.4 2005/04/26 22:23:14 ffjeld Exp $ +;;;; $Id: ll-testing.lisp,v 1.5 2005/04/26 23:46:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -104,7 +104,7 @@ (values (+ (control-stack-ebp stack) stack-base) (+ (control-stack-esp stack) stack-base))))
-(defun make-thread (segment-descriptor-table) +(defun alloc-context (segment-descriptor-table) (let* ((fs-index 8) (thread (muerte::clone-run-time-context :name 'subthread))) (setf (segment-descriptor segment-descriptor-table fs-index) @@ -116,7 +116,6 @@ (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) @@ -143,11 +142,16 @@ (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*) +(defun make-thread (&optional (name (gensym "thread-")) (function #'invoke-debugger) &rest 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 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))) @@ -164,33 +168,25 @@ (if (>= (length stack) 200) 100 0)))) - (values thread fs stack)))) + (values thread fs))))
-(defun stack-bootstrapper (&rest args) - (declare (ignore args)) - (with-inline-assembly (:returns :nothing) (:break)) +(defun stack-bootstrapper (&rest ignore) + (declare (ignore ignore)) (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) + (args (stack-frame-ref nil frame 2))) (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.") + (check-type args list) + (apply function args))) + (error "Nothing left to do for ~S." (current-run-time-context)) (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 args stack) (control-stack-push function stack) (control-stack-enter-frame stack #'stack-bootstrapper) ;; Now pretend stack-bootstrapper called yield. First, the return address @@ -202,7 +198,8 @@ stack)
-(defun yield (target-rtc fs) +(defun yield (target-rtc fs &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))) @@ -211,21 +208,24 @@ (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.") + (assert (eq (stack-frame-funobj nil ebp) + (asm-register :esi)) () + "Will not yield to a non-yield frame.") ;; 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) ;; 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) + (with-inline-assembly (:returns :eax) (:load-lexical (:lexical-binding fs) :untagged-fixnum-ecx) + (:load-lexical (:lexical-binding value) :eax) + (:cli) (:movw :cx :fs) - (:load-lexical (:lexical-binding ebp) :eax) - (:load-lexical (:lexical-binding esp) :ebx) - (:movl :eax :ebp) - (:movl :ebx :esp) + (:locally (:movl (:edi (:edi-offset scratch1)) :ebp)) + (:locally (:movl (:edi (:edi-offset scratch2)) :esp)) (:popfl)))))
(defun stack-yield (stack esp ebp &key eax ebx ecx edx esi eflags (dynamic-env 0) cushion)