Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

fixed epoll_wait not timing out on sbcl and clozurecl

  • Loading branch information...
commit 446f95d509608ec34650cbbd312a798ba15a21d4 1 parent d03a791
@vii authored
View
2  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 ()
View
70 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))))))
+
+
View
12 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))))))))
View
2  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" ))
View
4 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)))
View
1  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)))
View
44 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
View
13 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))
View
52 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
View
7 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))))
View
23 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)))
View
16 src/ml/output.lisp
@@ -2,17 +2,21 @@
(defstruct (raw-ml-sendbuf (:include sendbuf)))
+(declaim (ftype (function (simple-byte-vector) simple-byte-vector) really-escape-string))
+(defun really-escape-string (value)
+ (declare (type simple-byte-vector value))
+ (match-replace-all value
+ (#\< "&lt;")
+ (#\> "&gt;")
+ (#\& "&amp;")
+ (#\' "&#39;"))) ; &apos; is *not* HTML but only XML
+
(defun-consistent escape-data (value)
(typecase value
(raw-ml-sendbuf
value)
(t
- (match-replace-all (force-simple-byte-vector value)
- (#\< "&lt;")
- (#\> "&gt;")
- (#\& "&amp;")
- (#\' "&#39;")) ; &apos; is *not* HTML but only XML
- )))
+ (really-escape-string (force-simple-byte-vector value)))))
(defmacro output-escaped-ml (&rest args)
`(with-ml-output
View
6 src/packages.lisp
@@ -282,6 +282,7 @@
#:channel
#:channel-notify
#:channel-update
+ #:find-channel
#:message-channel
#:simple-channel
@@ -361,6 +362,11 @@
(:nicknames #:tpd2.game.dating)
(:use #:tpd2.game #:tpd2.ml #:tpd2.lib #:teepeedee2.webapp #:common-lisp #:tpd2.ml.html))
+(defpackage #:teepeedee2.demo
+ (:nicknames #:tpd2.demo)
+ (:use #:common-lisp #:teepeedee2.lib #:teepeedee2.webapp #:tpd2.ml #:tpd2.ml.html #:tpd2.datastore))
+
+
#.`
(defpackage #:teepeedee2
View
5 teepeedee2.asd
@@ -13,6 +13,9 @@
do
(pushnew addon asdf:*central-registry* :test #'equal))
+#+sbcl
+(setf sb-ext:*inline-expansion-limit* 50)
+
(pushnew "../cl-irregsexp/" asdf:*central-registry* :test #'equal)
#+comment-out
@@ -123,5 +126,5 @@
:fiveam
:cl-utilities
:cl-irregsexp
- :hunchentoot
+ :trivial-backtrace
:parenscript))
Please sign in to comment.
Something went wrong with that request. Please try again.