fixed epoll_wait not timing out on sbcl and clozurecl

vii · Nov 12, 2008 · 446f95d · 446f95d
1 parent d03a791
commit 446f95d
Show file tree

Hide file tree

Showing 14 changed files with 189 additions and 68 deletions.
diff --git a/src/datastore/datastore.lisp b/src/datastore/datastore.lisp
@@ -75,7 +75,7 @@
 		   (remf ret option))
 		 (list* (slot-name slot-def) initform ret)))
 	   (guarded-slot-accessor (slot-name)
-	    (concat-sym '- slot-name))
+	    (concat-sym name '- slot-name))
 	   (real-slot-accessor (slot-name)
 	     (concat-sym-from-sym-package name 'unlogged- name '- slot-name))
 	   (real-constructor ()

diff --git a/src/demo/demo.lisp b/src/demo/demo.lisp
@@ -0,0 +1,70 @@
+(in-package #:tpd2.demo)
+
+(defrecord message
+    (forum-name :index t)
+  text
+  (author :index t)
+  (time :initform (get-universal-time)))
+
+
+(defmyclass (forum (:include simple-channel))
+    name)
+
+(defvar *fora* (list
+		(make-forum :name "Ubuntu") 
+		(make-forum :name "Gentoo")
+		(make-forum :name "Debian")))
+
+(defun css ())
+
+(with-site (:page-body-start (lambda(title)
+			       (declare (ignore title))
+			       `(<div :class "header"	
+				      (<h1  
+					   (<A :href (page-link "/tlug") 
+					       :class "inherit" 
+					       (<span :style (css-attrib :color "red") "TLUG") " demo" ))
+				      (output-object-to-ml (webapp-frame))))
+			     :page-head (lambda(title)
+					  `(<head
+					    (<title (output-raw-ml ,title))
+					    (css)
+					    (webapp-default-page-head-contents))))
+  (defpage "/tlug" ()
+    (webapp "Select forum"
+      (webapp-select-one ""
+			 *fora*
+			 :display (lambda(forum) (<span (its name forum)))
+			 :replace
+			 (lambda(forum)
+			   (webapp ()
+			     (webapp-display forum)))))))
+
+(my-defun forum 'object-to-ml ()
+  (<div :class "forum"
+	(<h3 (my name))
+	(html-action-form "Post a message"
+	    (text)
+	  (make-message :forum-name (my name)
+			:text text
+			:author (frame-username (webapp-frame)))
+	  (my 'channel-notify)
+	  (values))
+
+	(<div :class "messages"
+	      (output-object-to-ml
+	       (datastore-retrieve-indexed 'message 'forum-name (my name))))
+	(output-raw-ml (call-next-method))))
+
+(defun time-string (ut)
+  (multiple-value-bind
+	(second minute hour date month year day daylight-p zone)
+      (decode-universal-time ut 0)
+    (declare (ignore day daylight-p zone))
+    (format nil "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D UTC" year month date hour minute second)))
+
+(my-defun message 'object-to-ml ()
+  (<div :class "message"
+	(<p (my text) (<span :class "message-attribution" " by " (my author) " at " (time-string (my time))))))
+
+
diff --git a/src/demo/modify.lisp b/src/demo/modify.lisp
@@ -0,0 +1,12 @@
+(in-package #:tpd2.demo)
+
+(defun find-forum (name)
+  (find name *fora* :test 'equalp :key 'forum-name))
+
+(my-defun message 'object-to-ml ()
+  (<div :class "message"
+	(<p (my text) (<span :class "message-attribution" " by " (my author) " at " (time-string (my time))))
+	(when (equalp (frame-username (webapp-frame)) (my author))
+	  (<p (html-action-link "Delete"
+				(datastore-delete me)
+				(its notify (find-forum (my forum-name))))))))
diff --git a/src/game/web.lisp b/src/game/web.lisp
@@ -347,7 +347,7 @@
      :name "MOPOKO-EVENT-LOOP")))
 
 (defpage "/test" (name)
-  (<p "hello " (<b name)))
+  (<h1 "Hello " name))
 
 (defpage "/test-plain" ()
   (<p "hello dude" ))
diff --git a/src/http/dispatcher.lisp b/src/http/dispatcher.lisp
@@ -20,8 +20,10 @@
     body))
 
 
-(defun respond-http (con done &key (code (force-byte-vector 200)) (banner (force-byte-vector "OK"))
+(defun-speedy respond-http (con done &key (code (force-byte-vector 200)) (banner (force-byte-vector "OK"))
 		     headers body)
+  (declare (type sendbuf body))
+  (declare (dynamic-extent body))
   (send con done (build-http-response :code code :banner banner :headers headers :body body)))
 
 

diff --git a/src/io/con.lisp b/src/io/con.lisp
@@ -76,6 +76,7 @@
 	  (my 'hangup))))
 
 (my-defun con 'recv (done amount)
+  (declare (type fixnum amount))
   (cond
     ((>= (recvbuf-available-to-eat (my recv)) amount)
      (funcall done (recvbuf-eat (my recv) amount)))

diff --git a/src/io/epoll.lisp b/src/io/epoll.lisp
@@ -42,27 +42,27 @@
   (setf (my postpone-registration) t)
 
   (let ((nevents
-	 (syscall-epoll_wait (my fd) (my events) (my max-events) 
+	 (syscall-noretry-epoll_wait (my fd) (my events) (my max-events) 
 			     (if timeout 
 				 (floor (* 1000 timeout))
 				 -1))))
-    (assert (>= (my max-events) nevents))
-    (dotimes (i nevents)
-      (let ((event (cffi:mem-aref (my events) 'epoll-event i)))
-	(cffi:with-foreign-slots ((events data) event epoll-event)
-	  (cffi:with-foreign-slots ((fd) data epoll-data)
-	    (awhen (my 'mux-find-fd fd)
-	      (con-run it)
-	      (unless (and (zerop (logand (logior +POLLERR+ +POLLHUP+) events))
-			  (or (zerop (logand +POLLRDHUP+ events)) (not (zerop (logand +POLLIN+ events)))))
-		(con-fail it)))))))
-    (setf (my postpone-registration) nil)
-    (adolist (my postponed-registrations)
-      (my 'mux-add it))
-    (setf (my postponed-registrations) nil)
+    (when nevents
+      (assert (>= (my max-events) nevents))
+      (dotimes (i nevents)
+	(let ((event (cffi:mem-aref (my events) 'epoll-event i)))
+	  (cffi:with-foreign-slots ((events data) event epoll-event)
+	    (cffi:with-foreign-slots ((fd) data epoll-data)
+	      (awhen (my 'mux-find-fd fd)
+		(con-run it)
+		(unless (and (zerop (logand (logior +POLLERR+ +POLLHUP+) events))
+			     (or (zerop (logand +POLLRDHUP+ events)) (not (zerop (logand +POLLIN+ events)))))
+		  (con-fail it)))))))
+      (setf (my postpone-registration) nil)
+      (adolist (my postponed-registrations)
+	(my 'mux-add it))
+      (setf (my postponed-registrations) nil)))
 
-    (values)))
-
+    (values))
 
 (defvar *global-epoll* (make-epoll))
 
@@ -84,10 +84,20 @@
 (defun events-pending-p ()
   (not (mux-empty *global-epoll*)))
 
+
+
 (defun wait-for-next-event (&optional timeout)
   (with-shorthand-accessor (my epoll *global-epoll*)
     (my wait timeout)))
 
+#+tpd2-io-wait-for-next-event-check-timeout
+(defun wait-for-next-event (&optional timeout)
+  (with-shorthand-accessor (my epoll *global-epoll*)
+    (let ((time (get-universal-time)))
+      (my wait timeout)
+      (when (and timeout (> (get-universal-time) (+ timeout time 2)))
+	(warn "Timeout took too long: waited ~As for ~As" (- (get-universal-time) time) timeout )))))
+
 (defun event-loop ()
   (loop for timeout = (next-timeout)
 	while (or timeout (events-pending-p)) do

diff --git a/src/io/recvbuf.lisp b/src/io/recvbuf.lisp
@@ -1,13 +1,16 @@
 (in-package #:tpd2.io)
 
+(deftype recvbuf-small-integer ()
+  `(integer 0 #x10000000))
+
 (defstruct recvbuf
   (store (make-byte-vector 1024) :type simple-byte-vector)
-  (read-idx 0 :type (integer 0 #x1000000))
-  (write-idx 0 :type (integer 0 #x1000000)))
+  (read-idx 0 :type recvbuf-small-integer)
+  (write-idx 0 :type recvbuf-small-integer))
 
 (my-defun recvbuf len ()
   (my-declare-fast-inline)
-  (length (my store)))
+  (the recvbuf-small-integer (length (my store))))
 
 (my-defun recvbuf half-full-or-more ()
   (my-declare-fast-inline)
@@ -24,10 +27,10 @@
 
 (my-defun recvbuf available-to-eat ()
   (my-declare-fast-inline)
-  (- (my write-idx) (my read-idx)))
+  (the recvbuf-small-integer (- (my write-idx) (my read-idx))))
 
 (my-defun recvbuf prepare-read (&optional (size 1024))
-  (declare (type fixnum size))
+  (declare (type recvbuf-small-integer size))
   (when (> size (- (my len) (my read-idx)))
     (cond 
       ((= (my write-idx) (my read-idx))

diff --git a/src/io/syscalls.lisp b/src/io/syscalls.lisp
@@ -80,7 +80,8 @@
   (addr :uint32))
 
 (eval-always
- (cffi:defcvar ("errno" +syscall-error-number+) :int))
+  (declaim (inline %var-accessor-errno))
+  (cffi:defcvar ("errno" errno) :int))
 
 (cffi:defcfun strerror :string
   (errno :int))
@@ -95,7 +96,9 @@
  (defun syscall-name (name)
    (string-downcase (force-string name)))
  (defun direct-syscall-sym (name)
-   (concat-sym-from-sym-package 'direct-syscall-sym 'syscall-direct- name)))
+   (concat-sym-from-sym-package 'direct-syscall-sym 'syscall-direct- name))
+ (defun noretry-syscall-sym (name)
+   (concat-sym-from-sym-package 'noretry-syscall-sym 'syscall-noretry- name)))
 
 (defmacro def-syscall (name &rest args)
   `(cffi:defcfun (,(syscall-name name)  ,(direct-syscall-sym name))
@@ -104,24 +107,30 @@
 
 (defmacro def-simple-syscall (name &rest args)
   (let ((direct-sym (direct-syscall-sym name))
+	(noretry-sym (noretry-syscall-sym name))
 	(syscall-name (syscall-name name))
 	(arg-names (mapcar #'first args))
 	(func (concat-sym-from-sym-package 'def-simple-syscall 'syscall- name)))
     `(progn
-       (declaim (inline ,func ,direct-sym))
-       (declaim (ftype (function (,@(mapcar (constantly t) arg-names)) (or null syscall-return-integer)))
-		(ftype (function (,@(mapcar (constantly t) arg-names)) syscall-return-integer)))
+       (declaim (inline ,func ,direct-sym ,noretry-sym))
+       (declaim (ftype (function (,@(mapcar (constantly t) arg-names)) (or null syscall-return-integer)) ,noretry-sym)
+		(ftype (function (,@(mapcar (constantly t) arg-names)) syscall-return-integer) ,func ,direct-sym))
        (def-syscall ,name ,@args)
+       (defun ,noretry-sym ,arg-names
+	 (declare (optimize speed (safety 0)))
+	 (let ((val (,direct-sym ,@arg-names)))
+	   (cond ((or (/= val -1) (= errno +EAGAIN+) (= errno +EINPROGRESS+))
+		  val)
+		 ((= errno +EINTR+)
+		  nil)
+		 (t
+		  (error 'syscall-failed :errno errno :syscall ,syscall-name)))))
+
        (defun ,func ,arg-names
 	 (declare (optimize speed (safety 0)))
 	 (loop
-	       (let ((val (,direct-sym ,@arg-names)))
-		 (cond ((or (/= val -1) (= +syscall-error-number+ +EAGAIN+) (= +syscall-error-number+ +EINPROGRESS+))
-			(return val))
-		       ((= +syscall-error-number+ +EINTR+)
-			nil)
-		       (t
-			(error 'syscall-failed :errno +syscall-error-number+ :syscall ,syscall-name)))))))))
+	       (let ((val (,noretry-sym ,@arg-names)))
+		 (when val (return val))))))))
 
 
 (def-simple-syscall close
@@ -429,14 +438,13 @@
     (syscall-setsockopt fd level optname
 			on (cffi:foreign-type-size :int))))
 
-
 (defun sockaddr-address-string-with-ntop (sa)
-  (cffi:with-foreign-pointer-as-string (str 200 str-size)
+  (cffi:with-foreign-pointer-as-string ((str str-size) 200)
     (unless (inet_ntop (cffi:foreign-slot-value sa 'sockaddr_in 'family)
 		       (cffi:foreign-slot-pointer sa 'sockaddr_in 'addr)
 		       str
 		       str-size)
-      (error "Cannot convert address: ~A" (strerror +syscall-error-number+)))))
+      (error "Cannot convert address: ~A" (strerror errno)))))
 
 #+tpd2-old-sockaddr-address-string
 (defun sockaddr-address-string (sa)
@@ -517,15 +525,15 @@
     (make-precise-time :sec (+ sec +unix-epoch-to-universal-time-offset+) :usec usec)))
 
 (my-defun precise-time 'print-object (stream)
-	  (if *print-readably*
-	      (call-next-method)
-	      (format stream "~D.~6,'0D" (my sec) (my usec))))
+  (if *print-readably*
+      (call-next-method)
+      (format stream "~D.~6,'0D" (my sec) (my usec))))
 
 (my-defun precise-time after (old-time)
-	  (check-type old-time precise-time)
-	  (let ((usec (- (my usec) (its usec old-time))))
-	    (let ((one-over (if (> 0 usec) 1 0)))
-	      (make-precise-time :sec (- (my sec) (its sec old-time) one-over) :usec (+ usec (* 1000000 one-over))))))
+  (check-type old-time precise-time)
+  (let ((usec (- (my usec) (its usec old-time))))
+    (let ((one-over (if (> 0 usec) 1 0)))
+      (make-precise-time :sec (- (my sec) (its sec old-time) one-over) :usec (+ usec (* 1000000 one-over))))))
 
 
 (def-simple-syscall epoll_create

diff --git a/src/lib/timeout.lisp b/src/lib/timeout.lisp
@@ -33,9 +33,10 @@
 (declaim (inline time-for-delay))
 (defun time-for-delay (delay)
   (declare (optimize speed))
-  (when delay
-    (debug-assert (> (length (quick-queue-entries *timeouts*)) (* delay 2)))
-    (+ (get-universal-time) delay)))
+  (let ((delay (floor delay)))
+    (when delay
+      (debug-assert (> (length (quick-queue-entries *timeouts*)) (* delay 2)))
+      (+ (get-universal-time) delay))))
 
 
 

diff --git a/src/lib/utils.lisp b/src/lib/utils.lisp
@@ -1,16 +1,18 @@
 (in-package #:tpd2.lib)
 
-
+(declaim (ftype (function (t) simple-byte-vector) apply-byte-vector-cat))
 (defun-speedy byte-vector-cat (&rest args)
   (apply-byte-vector-cat args))
 
-(defun-speedy apply-byte-vector-cat (args)
-  (let ((vecs (mapcar (lambda(x)(force-byte-vector x)) args)))
-    (let ((len (reduce '+ (mapcar 'length vecs))))
+(defun apply-byte-vector-cat (args)
+  (let ((vecs (mapcar (lambda(x)(force-simple-byte-vector x)) args)))
+    (let ((len (reduce '+ (mapcar (lambda(x)(length (the simple-byte-vector x))) vecs))))
       (let ((ret (make-byte-vector len)) (i 0))
 	(loop for v in vecs do
-	      (replace ret v :start1 i)
-	      (incf i (length v)))
+	      (locally
+		  (declare (type simple-byte-vector ret v) (type (integer 0 #. most-positive-fixnum) i))
+		(replace ret v :start1 i)
+		(incf i (length v))))
 	ret))))
 
 #-ccl ; compacting gc makes this unreliable
@@ -35,10 +37,9 @@
 
 (declaim (inline random-elt))
 (defun random-elt (sequence)
-  (declare (optimize speed))
-  (when sequence
-    (elt sequence (random (length sequence)))))
-
+  (let ((len (length sequence)))
+    (unless (zerop len)
+      (elt sequence (random len)))))
 
 
 (defun read-safely (&rest args)
@@ -49,4 +50,4 @@
 
 (defun backtrace-description (err)
   (format nil "ERROR ~A:~&~A" (with-output-to-string (*standard-output*) (describe err)) 
-	  (hunchentoot:get-backtrace err)))
+	  (trivial-backtrace:get-backtrace err)))