[cl-muproc-devel] [Patch] Reorganisation of impl-dependent functions: proposal
Klaus Harbo
klaus at mu.dk
Mon May 29 20:52:35 UTC 2006
Rudi Schlatte wrote:
>
> Sure, perhaps that way is better than what I am planning now - there
> might well be a Lisp where there's no possibility of disallowing a
> fresh thread from running. In that case, it might be necessary to let
> the new muproc initialize the global state itself. In any case,
> having your code will be helpful.
>
Hi Rudi --
> Btw, some tests in gensrv1-test.lisp fail for me on Mac lispworks
> personal 4.4. I haven't investigated the failures at all but wanted
> to ask: does gensrv1-test pass for you?
Yes, it does:
CL-USER> (push #p"~/lab/devel-muproc/" asdf:*central-registry*)
(#P"/mu/home/klaus/lab/devel-muproc/"
#P"/mu/home/klaus/lisp/sys/asdf-registry/"
#P"/mu/lisp/sys/asdf-registry/")
CL-USER> (push #p"~/lab/devel-muproc/tests/" asdf:*central-registry*)
(#P"/mu/home/klaus/lab/devel-muproc/tests/"
#P"/mu/home/klaus/lab/devel-muproc/"
#P"/mu/home/klaus/lisp/sys/asdf-registry/"
#P"/mu/lisp/sys/asdf-registry/")
CL-USER> (asl :cl-muproc)
; loading system definition from
;;; ...elided...
NIL
CL-USER> (asl :cl-muproc-test)
; loading system definition from
;;; ...elided...
NIL
CL-USER> (muproc-test::do-tests)
Doing 27 pending tests of 27 tests total.
MUPROC-TEST::SIMPLE-1 MUPROC-TEST::SIMPLE-2 MUPROC-TEST::SIMPLE-3
MUPROC-TEST::SIMPLE-4 MUPROC-TEST::SIMPLE-5
MUPROC-TEST::MUPROC-EXIT-LINK-1 MUPROC-TEST::NORMAL-EXIT-LINK-2
MUPROC-TEST::LINKED-EXITS-3 MUPROC-TEST::RIPPLING-LINKED-EXITS-4
MUPROC-TEST::RIPPLING-LINKED-EXITS-4A MUPROC-TEST::REGISTER-1
MUPROC-TEST::COMPUTATION-1 MUPROC-TEST::UNIQUE-MUPROC-NAMES-1
MUPROC-TEST::UNIQUE-MUPROC-NAMES-2 MUPROC-TEST::SEND-TO-TERMINATED-1
MUPROC-TEST::SEND-TO-TERMINATED-2 MUPROC-TEST::MUPROC-SEND-1
MUPROC-TEST::MUPROC-MONITOR-1 MUPROC-TEST::INTERRUPT-1
MUPROC-TEST::TWO-INSTANCES-1 MUPROC-TEST::TWO-INSTANCES-2
MUPROC-TEST::TWO-INSTANCES-3 MUPROC-TEST::DEFAULT-INSTANCE-1
MUPROC-TEST::DEFAULT-INSTANCE-2 MUPROC-TEST::CAST-1
MUPROC-TEST::PORT-NAME-1 MUPROC-TEST::HANDLE-TERM-1
No tests failed.
T
Some of the tests above are in gensrv1-test (this is the code you
submitted, passing the test, btw).
I dug a bit in the archives and found the code appended at the end.
It's been a few months since I worked with this code, but the gist/idea
of it is that instead of the SPAWNING Lisp process ensuring that all
muproc invariants are established before the SPAWNED Lisp process gets
to run, the invariants are established in the SPAWNED process instead.
That way it we don't need the critical section (without-scheduling
etc.). I believe this could work on both native and green thread based
implementations. And, just to make it absolutely clear: I did not
finish work on this code, it may very well contain flawed logic, missing
code, or whatever! Still, when I did work with it, it did seem like a
promising way to proceed.
HTH,
-Klaus.
PS. Yes, the macrolet below is not strictly necessary, I was just
trying to keep the amount of clutter down!
;;; sketch of refactored muproc-spawn -- BEWARE: NOT TESTED
;;;
(defun wrapper-function (parent-process inport errorstream
initial-bindings init-fn arglist)
"The LISP process function, that is `wrapper-function' executes in
the newly created LISP process. Sets up for muproc process, calls the
primary muproc function and termination hooks, and detects and reports
errors occurring in the `muproc' process. NOTE: Should only be called
from `muproc-spawn'."
(macrolet ((with-muproc-bindings (&body body)
`(progv
(append '(*muproc-inport* *muproc-errorstream*
*named-ports* *pending-input*
*muproc-packet* *muproc-mumsg* *timers*
muproc.compat::*without-scheduling*)
(mapcar #'car initial-bindings))
(append (list inport
errorstream
(make-hash-table :test #'eq) ;; named-ports
(make-pending-input-array) ;; pending-input
:unbound-value ;; *muproc-packet*
:unbound-value ;; *muproc-mumsg*
nil ;; timers
nil ;; w/o-sched
)
(mapcar #'cdr initial-bindings))
, at body)))
(with-muproc-bindings
(let ((signalling-arg))
(%with-debugging-stack%
(let ((me (muproc-current-process)))
(setf (muproc-port me) inport)
(muproc-set-trap-exits trap-exits)
(register-muproc-name name me)
(when link
(muproc-link parent-process me)))
(handler-case ;; for handling any errors occurring in the
run-time system
(unwind-protect
(handler-case ;; handle conditions originating in
muproc user code
(progn
(apply init-fn arglist)
(muproc-exit :normal-exit))
(muproc-linked-exit-condition (link-term-cond)
;; INV: The muproc is linked to a muproc which
is terminating.
(dbgformat 1 "Linked exit of ~s due to ~s."
(muproc-name) link-term-cond)
(setf signalling-arg
(list :linked-to-exit (muproc-name
(condition-muproc link-term-cond))
:for-reason (condition-reason
link-term-cond))))
(muproc-externally-terminated-condition (term-cond)
;; INV: (muproc-kill ...) was called
(dbgformat 0 "~a was terminated due to ~s."
(muproc-name) term-cond)
(setf signalling-arg (condition-reason term-cond)))
(muproc-exit-condition (exit-cond) ;; handling...
;; INV: (muproc-exit ...) was called
(dbgformat 1 "Got normal exit condition ~a."
exit-cond)
(setf signalling-arg (condition-reason exit-cond)))
(error (err)
(dbgformat 0 "Error occurred in muproc ~a: ~a."
(muproc-name) err)
(setf signalling-arg (cons :error-in-process err))))
(unwind-muproc signalling-arg))
(error (err)
(muproc-log-errorstream "Internal error in ~a: ~a.~%"
(muproc-name) err))))))))
(defun muproc-spawn (name init-fn arglist &key errorstream
inport initial-bindings link trap-exits
;; TODO - fixme -- figure out to deal with muproc
priorities in a portable manner
#+lispworks (priority (%process-priority%
(muproc-current-process)))
#-lispworks (error "muproc priorities needs
figuring out")
)
"`muproc-spawn' is used to start new muproc processes. `name' must
be a symbol, `init-fn' must be the process function, and `arglist'
must be a list matching the lambda list of `init-fn'. `:errorstream'
must be specified and must be a stream. `:initial-bindings' can be
used to specify initial bindings for the created process, in which
case it must be a list of conses, with the `car' being the name of the
special variable to be bound, and the `cdr' being a form whose value
when evaluated will be the initial binding of the symbol in the `car'.
`link' indicates whether the submitting process is to be linked to the
submitted process. `trap-exists' indicates whether the newly created
muproc is to trap exits messages from linked muprocs, or receive a
terminating condition signal on linked process exits."
;; ERRORSTREAM
(when (not errorstream)
(unless (boundp '*muproc-errorstream*)
(error "Errorstream not specified and muproc:*muproc-errorstream*
not bound."))
(setf errorstream *muproc-errorstream*))
(unless (typep errorstream 'stream)
(error "Errorstream not a stream: ~a." errorstream))
;; NAME
(unless (symbolp name)
(error "Muproc name not a symbol: ~s." name))
(let ((process-name (format nil "muproc-~d[~a~a]"
(next-muproc-id) (if (keywordp name) ":"
"") name)))
(setf inport (or inport (make-instance 'muproc-port :name (format
nil "IN<~a>" name))))
(unless (typep inport 'muproc-port)
(error "Bad INPORT: ~a not a port." inport))
#+lispworks (unless (typep priority 'fixnum)
(error "Process priority not a fixnum: ~a." priority))
(%with-exclusive-access% ;;%without-scheduling%
(%process-run-function%
process-name
#+lispworks (list :priority priority) ;; LW process options
#'wrapper-function (muproc-current-process) inport errorstream
initial-bindings init-fn arglist))))
More information about the cl-muproc-devel
mailing list