--- hunchentoot-0.15.7/port-sbcl.lisp	2008-04-08 17:39:18.000000000 +0300
+++ hunchentoot-thread-pool/port-sbcl.lisp	2008-07-18 03:40:24.109375000 +0300
@@ -53,32 +53,93 @@
 (defvar *incf-mutex* (sb-thread:make-mutex :name "incf-mutex")
   "The mutex used for ATOMIC-INCF.")
 
 (defmacro atomic-incf (place &optional (delta 1))
   "Like INCF but protected by a mutex, so other threads can't
 interfer."
   `(with-lock (*incf-mutex*) (incf ,place ,delta)))
 
+
+;;*** trivial thread pool ***;;
+
+(defvar *thread-pool-lock* (sb-thread:make-mutex :name "thread pool lock"))
+(defvar *thread-pool-monitor* (sb-thread:make-waitqueue))
+(defvar *work-queue* nil)
+(defvar *thread-pool-stopped* nil)
+
+(defun submit-work (work)
+  (sb-thread:with-mutex (*thread-pool-lock*)
+    (setf *work-queue* (append *work-queue* (list work)))
+    (sb-thread:condition-broadcast *thread-pool-monitor*))
+  nil)
+
+(defun pool-worker ()
+  (format t "worker thread started~%")
+  (loop
+     (let ((work))
+       (sb-thread:with-mutex (*thread-pool-lock*)
+         (loop
+            when *thread-pool-stopped* do (format t "stopped; returning ...~%") (return-from pool-worker)
+            when *work-queue* do (setf work (pop *work-queue*)) (return)  
+            else do (sb-thread:condition-wait *thread-pool-monitor* *thread-pool-lock*)))
+       ;(format t "executing work...~%")
+       (funcall work))))
+           
+(defun stop-thread-pool ()
+  (sb-thread:with-mutex (*thread-pool-lock*)
+    (setf *thread-pool-stopped* t)
+    (sb-thread:condition-broadcast *thread-pool-monitor*)))
+
+(defun start-thread-pool (thread-count)
+  (sb-thread:with-mutex (*thread-pool-lock*)
+    (setf *thread-pool-stopped* nil))
+  (dotimes (i thread-count) 
+    (sb-thread:make-thread #'pool-worker)))
+    
+;;*** pool code ends here ***;;;
+
 (defun process-run-function (name function &rest args)
   "See SBCL documentation for SB-THREAD:MAKE-THREAD."
   (declare (ignorable name))
   #+:sb-thread
-  (sb-thread:make-thread (lambda ()
-                           (apply function args))
-                         :name name)
+  ;;my:
+;;  (sb-thread:make-thread (lambda ()
+;;                           (apply function args))
+;;                         :name name)
+  (submit-work (lambda ()
+                 (apply function args)))
+                         
   #-:sb-thread
   (apply function args))
 
 (defun process-kill (process)
   "See SBCL documentation for SB-THREAD:TERMINATE-THREAD."
-  (sb-thread:terminate-thread process))
+  ;;my:
+  (when process ; process-run-function returns NIL in the tread-pooled version
+    (sb-thread:terminate-thread process)))
 
 (define-symbol-macro *current-process*
-  sb-thread:*current-thread*)
+  ;;my:
+  ;sb-thread:*current-thread*
+  nil 
+  ;; so that (delete *current-process* (server-workers server)) 
+  ;; in the server.lisp will delete the NIL returned 
+  ;; by process-run-function
+  )
+
+;; in case the port-sbcl.lisp is recompiled from SLIME,
+;; it is too late to change symbol-macro for *current-process*;
+;; evaluate something like this manually:
+;;
+;; (setf *cleanup-function* 
+;;       (lambda () 
+;;         (setf (server-workers *my-srv*) nil)))
+;;
+;; (setf *cleanup-interval* 20)
 
 (defun process-allow-scheduling ()
   "Used to simulate a function like PROCESS-ALLOW-SCHEDULING
 which can be found in most other Lisps."
   (sleep .1))
 
 (defun resolve-hostname (name)
   "Converts from different types to represent an IP address to
@@ -113,18 +174,29 @@
                              (sb-bsd-sockets:sockopt-reuse-address socket) t)
                        (sb-bsd-sockets:socket-bind socket (resolve-hostname address) service)
                        (sb-bsd-sockets:socket-listen socket 5)
                        (funcall announce socket)
                        (setq done socket)
                        (loop (funcall function (sb-bsd-sockets:socket-accept socket))))
                    (when socket
                      (cl:ignore-errors
-                       (sb-bsd-sockets:socket-close socket))))))))
-      (let ((listener-thread (process-run-function process-name #'open-socket-and-accept)))
+                       (sb-bsd-sockets:socket-close socket)
+                       ;;my:
+                       (stop-thread-pool))))))))
+      ;;my:
+      (start-thread-pool 5)
+      ;; in case the port-sbcl.lisp is recompiled from SLIME
+      ;; after the (non thread-pooled) server is already
+      ;; started, you need to run the above line manually
+
+      (let ((listener-thread 
+               ;;my:
+               ;;(process-run-function process-name #'open-socket-and-accept)))
+               (sb-thread:make-thread #'open-socket-and-accept)))
         (loop until done do (sleep .1))
         (typecase done
           (sb-bsd-sockets:inet-socket listener-thread)
           (t (values nil done)))))))
 
 (defun format-address (address)
   "Converts an array of four integers denoting an IP address into
 the corresponding string representation."
