/[slime]/slime/swank-abcl.lisp
ViewVC logotype

Diff of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.4 by asimon, Sun Jun 27 11:07:31 2004 UTC revision 1.5 by asimon, Sun Jun 27 12:18:51 2004 UTC
# Line 339  Should work (with a patched xref.lisp) b Line 339  Should work (with a patched xref.lisp) b
339    
340  (defvar *mailbox-lock* (ext:make-thread-lock))  (defvar *mailbox-lock* (ext:make-thread-lock))
341    
 (defstruct (mailbox (:conc-name mailbox.))  
   (mutex (ext:make-thread-lock))  
   (queue '() :type list))  
   
342  (defvar *thread-mailbox* (make-hash-table))  (defvar *thread-mailbox* (make-hash-table))
343    
   
344  (defun mailbox (thread)  (defun mailbox (thread)
345    "Return THREAD's mailbox."    "Return THREAD's mailbox."
346    (ext:with-thread-lock (*mailbox-lock*)    (ext:with-thread-lock (*mailbox-lock*)
347      (or (gethash thread *thread-mailbox*)      (or (gethash thread *thread-mailbox*)
348          (setf (gethash thread *thread-mailbox*)          (setf (gethash thread *thread-mailbox*)
349                (make-mailbox)))))                (ext:make-mailbox)))))
350    
351  (defimplementation send (thread message)  (defimplementation send (thread object)
352    (let* ((mbox (mailbox thread))    (ext:mailbox-send (mailbox thread) object))
          (mutex (mailbox.mutex mbox)))  
     #+nil  
     (mp:process-wait-with-timeout  
      "yielding before sending" 0.1  
      (lambda ()  
        (mp:with-process-lock (mutex)  
          (< (length (mailbox.queue mbox)) 10))))  
     ;(sleep 0.1)  
     (ext:with-thread-lock (mutex)  
       (setf (mailbox.queue mbox)  
             (nconc (mailbox.queue mbox) (list message))))))  
353    
354  (defimplementation receive ()  (defimplementation receive ()
355    (let* ((mbox (mailbox (ext:current-thread)))    (ext:mailbox-read (mailbox (ext:current-thread))))
          (mutex (mailbox.mutex mbox)))  
     #+nil(mp:process-wait "receive" #'mailbox.queue mbox)  
     (loop until (mailbox.queue mbox) do (sleep 0.1)) ;;FIXME  
     (ext:with-thread-lock (mutex)  
       (pop (mailbox.queue mbox)))))  
   
   
356    
357  (defimplementation quit-lisp ()  (defimplementation quit-lisp ()
358    (ext:exit))    (ext:exit))

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

  ViewVC Help
Powered by ViewVC 1.1.5