[Openmcl-devel] Re: Read operation to unmapped address 0x00000020

[Marco Baringer]

Gary Byers <gb at clozure.com> writes:

> Yes, I'd be interested in seeing this if you still have it.

i didn't have the original, but i was able to cause it farily quickly
by sending in 100 simultaneous requests for a few minutes.

-------------- next part --------------
A non-text attachment was scrubbed...
Name: kernel-backtrack
Type: application/octet-stream
Size: 22097 bytes
Desc: not available
URL: <https://lists.clozure.com/pipermail/openmcl-devel/attachments/20050412/8471ea95/attachment.obj>
-------------- next part --------------

here's a listing of the code which is causing this:

i have a thread which reads connections from a socket:

(defun httpd-accept-loop (backend)
  (loop
     ;; loop until we get a start message
     (receive
       ((start) (return))))
  (loop
     while (socket backend)
     for stream = (swank-backend:accept-connection (socket backend))
     do (send (control-thread backend) 'connection stream)))

the control-thread (the one who gets the streams from the accept-loop)
does this:

(defun httpd-controller-loop (backend)
  ;; start the accept-thread
  (send (accept-thread backend) 'start)
  ;; XXX: Leakage: This implementation never removes worker threads
  ;; from swank:*known-processes* (on openmcl).
  (loop
     (receive

       ((shutdown)
        ;; XXX: Not sure we're doing the right thing with the
        ;; socket, what happens if we're accepting a connection when
        ;; we close the socket?
        (loop
           for worker in (workers backend)
           repeat (num-workers backend)
           do (send (thread worker) 'shutdown))
        ;; close the socket
        (close (socket backend))
        (setf (socket backend) nil)
        (return-from httpd-controller-loop (values)))
       
       ((connection ?stream)
        (let ((next-worker (first (workers backend))))
          ;; NB: this only works because we've previously setup (workers
          ;; backend) as a circular list
          (setf (workers backend) (cdr (workers backend)))
          (send (thread next-worker) 'connection backend ?stream)))

       ((error ?worker ?condition)
        ;; remove ?worker from backend's workers
        (ucw.backend.error "Worker thread ~S reported ~S." ?worker ?condition)
        (setf (workers backend) (iterate
                                  (repeat (num-workers backend))
                                  (for worker in (workers backend))
                                  (if (eql ?worker worker)
                                      ;; spawn a new worker thread
                                      ;; to replace this one
                                      (collect (start-worker (make-instance 'httpd-worker)))
                                      ;; a good worker, keep it
                                      (collect worker)))              
              ;; we've recreated the list of workers, need to make it
              ;; circular again
              (cdr (last (workers backend))) (workers backend))))))

while the indiviual worker threads (there were 5 of them in this test) do this:

(defun httpd-worker-loop (worker)
  (loop
     (receive
       ((shutdown) (return-from httpd-worker-loop nil))
       ((connection ?backend ?stream)
        (unless (stop-flag worker)
          (httpd-worker-loop/handle worker ?backend ?stream))))))

(defun httpd-worker-loop/handle (worker backend stream)
  (flet ((abort-worker (condition)
           (send (control-thread backend) 'error worker condition)
           ;; set the stop flag so that if a connection
           ;; comes in before the shutdown message we
           ;; don't end up here again.
           (setf (stop-flag worker) t)
           (send (thread worker) 'shutdown)
           (when *debug-on-error*
             (restart-case
                 (swank:swank-debugger-hook condition nil)
               (kill-worker ()
                 :report "Kill this worker."
                 t)))
           (return-from httpd-worker-loop/handle nil)))
    (handler-bind ((error #'abort-worker))
      (unwind-protect
           (let* ((request (read-request backend stream))
                  (response (make-response request)))
             (handle-request backend request response))
        (ignore-errors
          (close stream))))))

The send/recieve macros are wrappers around slime's send/recieve
functions, which are this:

(defimplementation send (thread message)
  (assert message)
  (let* ((mbox (mailbox thread))
         (mutex (mailbox.mutex mbox)))
    (ccl:with-lock-grabbed (mutex)
      (setf (mailbox.queue mbox)
            (nconc (mailbox.queue mbox) (list message)))
      (ccl:signal-semaphore (mailbox.semaphore mbox)))))

(defimplementation receive ()
  (let* ((mbox (mailbox ccl:*current-process*))
         (mutex (mailbox.mutex mbox)))
    (ccl:wait-on-semaphore (mailbox.semaphore mbox))
    (ccl:with-lock-grabbed (mutex)
      (assert (mailbox.queue mbox))
      (pop (mailbox.queue mbox)))))