Permalink
Browse files

rfr's smpcompat work

  • Loading branch information...
2 parents fff9b8a + 7c2dcdf commit ae3e7bab74a17795870624769ecf7462e55e3460 @dklayer dklayer committed Oct 8, 2009
Showing with 371 additions and 108 deletions.
  1. +18 −0 ChangeLog
  2. +20 −8 client.cl
  3. +13 −5 examples/chat.cl
  4. +84 −0 macs.cl
  5. +8 −8 main.cl
  6. +22 −28 parse.cl
  7. +206 −59 proxy.cl
View
@@ -4,6 +4,15 @@
** Please leave this at the top of the file. Thanks.
*******************************************************************************
+2009-10-08 Robert Rorschach <rfr@franz.com>
+1.2.64
+
+ * macs.cl: track recent changes in the smp macros
+
+ * macs.cl: fix a package error in a macro; defvar-nonbindable
+ replaces defvar-nobind
+ * proxy.cl: restore a dropped #+ignore
+
2009-10-08 Kevin Layer <layer@gemini.franz.com>
1.2.63
(really from Marijn)
@@ -50,6 +59,15 @@
* load.cl: remove removed files from *aserve-other-files*
+2009-06-18 Robert Rorschach <rfr@franz.com>
+
+ * client.cl: compile in 8.1, 8.1+smp-macros, 8.2, 9.0
+ * examples/chat.cl: compile in 8.1, 8.1+smp-macros, 8.2, 9.0
+ * macs.cl: compile in 8.1, 8.1+smp-macros, 8.2, 9.0
+ * main.cl: compile in 8.1, 8.1+smp-macros, 8.2, 9.0; bump version
+ * parse.cl: compile in 8.1, 8.1+smp-macros, 8.2, 9.0
+ * proxy.cl: compile in 8.1, 8.1+smp-macros, 8.2, 9.0
+
2009-05-11 Kevin Layer <layer@gemini.franz.com>
1.2.59
* main.cl (request-query): rfe8332: make request-query-value
View
@@ -46,8 +46,7 @@
(in-package :net.aserve.client)
-
-
+(net.aserve::check-smp-consistency)
(defclass client-request ()
((uri ;; uri we're accessing
@@ -1132,22 +1131,35 @@ or \"foo.com:8000\", not ~s" proxy))
;; buffer pool for string buffers of the right size for a header
;; line
-(defvar *response-header-buffers* nil)
+(net.aserve::defvar-mp *response-header-buffers* nil)
(defun get-header-line-buffer ()
;; return the next header line buffer
(let (buff)
- (excl::atomically
- (excl::fast (setq buff (pop *response-header-buffers*))))
+ (net.aserve::smp-case
+ ((t :macros)
+ (setq buff
+ (pop-atomic *response-header-buffers*)))
+ (nil
+ (excl::atomically ;; in a #-smp form
+ (excl::fast (setq buff (pop *response-header-buffers*))))))
(if* buff
thenret
else (make-array 400 :element-type 'character))))
(defun put-header-line-buffer (buff &optional buff2)
;; put back up to two buffers
- (mp:without-scheduling
- (push buff *response-header-buffers*)
- (if* buff2 then (push buff2 *response-header-buffers*))))
+ (net.aserve::smp-case
+ (nil
+ (mp:without-scheduling ;; in a #-smp form
+ (push buff *response-header-buffers*)
+ (if* buff2 then (push buff2 *response-header-buffers*))))
+ ((t :macros)
+ (progn
+ (push-atomic buff *response-header-buffers*)
+ (if* buff2
+ then (push-atomic buff2 *response-header-buffers*))))
+ ))
View
@@ -39,6 +39,14 @@
:net.html.generator))
(in-package :user)
+(net.aserve::check-smp-consistency)
+
+(defmacro with-mp-locked-controller ((c) &body body)
+ (net.aserve::smp-case
+ ((t :macros) `(with-locked-object (,c :-smp :without-scheduling)
+ ,@body))
+ (nil `(si::without-scheduling ,c ,@body))))
+
(defvar *chat-home-package* :user) ; :user for now while debugging
(defvar *chat-home*) ; home dir for chat info
(defvar *chat-home-pics*) ; home dir for chat pics
@@ -174,7 +182,7 @@
; b = upgrade user
-(defclass master-chat-controller ()
+(defclass master-chat-controller (#+smp mp:lockable-object)
((controllers :initform nil
; list of chat-controller instances
:initarg :controllers
@@ -200,7 +208,7 @@
-(defclass chat-controller ()
+(defclass chat-controller (#+smp mp:lockable-object)
;; describes a whole set of chats
((chats :initform nil
@@ -968,7 +976,7 @@
; create a unique string to indentify this controller
(loop
(setq ustring (make-unique-string))
- (mp:without-scheduling
+ (with-mp-locked-controller (*master-controller*)
(if* (not (member ustring
(ustrings *master-controller*)
:test #'equal))
@@ -1023,7 +1031,7 @@
else (let (ustring)
(loop
(setq ustring (make-unique-string))
- (mp:without-scheduling
+ (with-mp-locked-controller (controller)
(if* (not (member ustring (ustrings controller)
:test #'equal))
then (push ustring (ustrings controller))
@@ -1034,7 +1042,7 @@
:filename
(request-query-value "filename" req)
:ustring ustring)))
- (mp:without-scheduling
+ (with-mp-locked-controller (controller)
(push chat (chats controller)))
(dump-existing-chat *chat-home*)
(with-http-response (req ent)
View
84 macs.cl
@@ -218,6 +218,90 @@
(return-from ,g-blocktag
(progn ,@actions))))))
,@body))))
+
+;;;;;;;;;;;;;; SMP-aware macros
+;;
+;; We cater to three slightly different states:
+;;
+;; #+smp
+;; (smp-case (t form) ...)
+;; The compile and execute environments support SMP;
+;; 9.0 with smp.
+;;
+;; #+(and smp-macros (not smp))
+;; (smp-case (:macros form) ...)
+;; Compile environment recognizes the SMP macros, but compiles
+;; for non-SMP lisp;
+;; >=8.2 but not smp
+;; 8.1 with smp patches.
+;;
+;; #-smp-macros
+;; (smp-case (nil form) ...)
+;; Compile environment does not recognize SMP macros;
+;; 8.1 without smp patches.
+;;
+
+(defmacro smp-case (&rest clauses)
+ (let* ((key
+ #+smp t
+ #+(and smp-macros (not smp)) :macros
+ #-smp-macros nil
+ )
+ (clause (dolist (c clauses)
+ (unless (and (consp c)
+ (consp (cdr c))
+ (null (cddr c)))
+ (error "smp-case clause ~s is badly formed" c))
+ (let ((c-key (car c)))
+ (if* (or (eq c-key key)
+ (and (consp c-key)
+ (member key c-key)))
+ then (return c))))))
+ (unless clause
+ (error "smp-case is missing clause for ~s" key))
+ (second clause)))
+
+(defmacro check-smp-consistency ()
+ (smp-case
+ (nil (when (featurep :smp)
+ (error "This file was compiled to run in a non-smp acl")))
+ (:macros (if* (featurep :smp)
+ then (error "This file was compiled to run in a non-smp acl")
+ elseif (not (featurep :smp-macros))
+ then (error "This file requires the smp-macros patch")))
+ (t (unless (featurep :smp)
+ (error "This file was compiled to run in an smp acl")))))
+
+
+(defmacro atomic-incf (var)
+ (smp-case
+ (t `(incf-atomic ,var))
+ (:macros `(excl::with-delayed-scheduling (incf ,var)))
+ (nil `(si:without-scheduling (incf ,var))))
+ )
+
+(defmacro atomic-decf (var)
+ (smp-case
+ (t `(decf-atomic ,var))
+ (:macros `(excl::with-delayed-scheduling (decf ,var)))
+ (nil `(si:without-scheduling (decf ,var)))))
+
+(defmacro with-locked-server ((s) &body body)
+ (smp-case
+ ((t :macros) `(with-locked-object (,s :-smp :without-scheduling) ,@body))
+ (nil `(si:without-scheduling ,s ,@body))))
+
+(defmacro defvar-mp (v &rest rest)
+ (smp-case
+ ((t :macros) `(defvar-nonbindable ,v ,@rest))
+ (nil `(defvar ,v ,@rest))))
+
+(defmacro atomically-fast (&body body)
+ (smp-case
+ ((t :macros) `(excl::.atomically (excl::fast ,@body)))
+ (nil `(excl::atomically (excl::fast ,@body)))))
+
+;;;;;; end of smp-aware macro definitions
View
16 main.cl
@@ -35,7 +35,9 @@
(in-package :net.aserve)
-(defparameter *aserve-version* '(1 2 63))
+(check-smp-consistency)
+
+(defparameter *aserve-version* '(1 2 64))
(eval-when (eval load)
(require :sock)
@@ -521,12 +523,7 @@ Problems with protocol may occur." (ef-name ef)))))
; safe versions during multiprocessing
-(defmacro atomic-incf (var)
- `(mp:without-scheduling (incf ,var)))
-
-(defmacro atomic-decf (var)
- `(mp:without-scheduling (decf ,var)))
-
+;; atomic-incf and atomic-decf macro definitions moved to aserve/macs.cl
;;;;;;;;; end macros
@@ -1169,6 +1166,9 @@ by keyword symbols and not by strings"
,@excl:*cl-default-special-bindings*))
#'http-accept-thread)))
+;; make-worker-thread wasn't thread-safe before smp. I'm assuming that's
+;; ok, which it will be if only one thread ever calls it, and leaving it
+;; non-thread-safe in the smp version.
(defun make-worker-thread ()
(let* ((name (format nil "~d-aserve-worker" (incf *thread-index*)))
(proc (mp:make-process :name name
@@ -1378,7 +1378,7 @@ by keyword symbols and not by strings"
then (logmess "accept: too many errors, bailing")
(return-from http-accept-thread nil)))))
(ignore-errors (progn
- (mp:without-scheduling
+ (with-locked-server (server)
(if* (eql (wserver-socket server) main-socket)
then (setf (wserver-socket server) nil)))
(close main-socket))))))
View
@@ -38,6 +38,7 @@
(in-package :net.aserve)
+(check-smp-consistency)
;; parseobj -- used for cons-free parsing of strings
(defconstant parseobj-size 20)
@@ -49,19 +50,31 @@
(max parseobj-size)
)
-(defvar *parseobjs* nil)
+(defvar-mp *parseobjs* nil) ;; never bound; this is a global variable
(defun allocate-parseobj ()
- (let (res)
- (mp::without-scheduling
- (if* (setq res (pop *parseobjs*))
- then (setf (parseobj-next res) 0)
- res
- else (make-parseobj)))))
+ (smp-case
+ ((t :macros)
+ (let ((res (pop-atomic *parseobjs*)))
+ (if* res
+ then (setf (parseobj-next res) 0)
+ res
+ else (make-parseobj))))
+ (nil
+ (let (res)
+ (mp::without-scheduling ;; in a #-smp form
+ (if* (setq res (pop *parseobjs*))
+ then (setf (parseobj-next res) 0)
+ res
+ else (make-parseobj)))))))
(defun free-parseobj (po)
- (mp::without-scheduling
- (push po *parseobjs*)))
+ (smp-case
+ ((t :macros)
+ (push-atomic po (si:global-symbol-value '*parseobjs*)))
+ (nil
+ (mp::without-scheduling ;; in a #-smp form
+ (push po *parseobjs*)))))
(defun add-to-parseobj (po start end)
;; add the given start,end pair to the parseobj
@@ -794,22 +807,3 @@
(values root tail
(subseq tail 0 pos)
(subseq tail (1+ pos)))))))
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
Oops, something went wrong.

0 comments on commit ae3e7ba

Please sign in to comment.