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
18 ChangeLog
@@ -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
28 client.cl
@@ -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
18 examples/chat.cl
@@ -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
50 parse.cl
@@ -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)))))))
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
View
265 proxy.cl
@@ -35,6 +35,38 @@
(in-package :net.aserve)
+(check-smp-consistency)
+
+(defmacro with-mp-locked-connection-cache ((s) &rest body)
+ (smp-case
+ ((t :macros) `(with-locked-structure (,s :-smp :without-scheduling)
+ ,@body))
+ (nil `(si::without-scheduling ,s ,@body)))) ;; in a #-smp block
+
+(defmacro with-mp-locked-pcache-ent ((s) &rest body)
+ (smp-case
+ ((t :macros) `(with-locked-structure (,s :-smp :without-scheduling)
+ ,@body))
+ (nil `(si::without-scheduling ,s ,@body)))) ;; in a #-smp block
+
+(defmacro with-fast-mp-locked-pcache-ent ((s) &rest body)
+ (smp-case
+ ((t :macros) `(with-locked-structure (,s :-smp :atomically)
+ ,@body))
+ (nil `(excl::atomically ,s ,@body)))) ;; in a #-smp block
+
+(defmacro with-mp-locked-pcache ((s) &rest body)
+ (smp-case
+ ((t :macros) `(with-locked-structure (,s :-smp :without-scheduling)
+ ,@body))
+ (nil `(si::without-scheduling ,s ,@body)))) ;; in a #-smp block
+
+(defmacro with-mp-locked-pcache-queue ((s) &rest body)
+ (smp-case
+ ((t :macros) `(with-locked-structure (,s :-smp :without-scheduling)
+ ,@body))
+ (nil `(si::without-scheduling ,s ,@body)))) ;; in a #-smp block
+
; denotes a request from the browser
(defconstant *browser-level* 100) ;
@@ -57,16 +89,22 @@
(defparameter *connections-used-cached* 0) ; number of cached connections used
; the cache
(defparameter *connection-cache-queue* (cons nil nil)) ; (first . last) queue of conn-cache objects
-(defparameter *connection-cache-expire* 10) ; number of seconds to live
+(defparameter *connection-cache-expire* 10) ; number of seconds to live
+(defparameter *connection-cache-lock*
+ (smp-case
+ ((t :macros) (excl::make-basic-lock :name "connection-cache"))
+ (nil nil)))
; number of seconds we wait for a connect before we consider it timed
; out. Given the chance Linux seems to wait forever for a connection
; so we need to shut it down ourselves.
(defparameter *connection-timed-out-wait* 30)
-(defstruct pcache
+(defstruct (pcache
+ #+smp-macros (:include synchronizing-structure)
+ )
;; proxy cache
table ; hash table mapping to pcache-ent objects
disk-caches ; list of pcache-disk items
@@ -164,7 +202,9 @@
;
-(defstruct pcache-ent
+(defstruct (pcache-ent
+ #+smp-macros (:include synchronizing-structure)
+ )
key ; the string form of the uri
uri ; the actual uri
last-modified-string ; last modified time from the header
@@ -974,7 +1014,8 @@ cached connection = ~s~%" cond cached-connection))
(incf *connections-cached*)
- (mp:without-scheduling
+ (with-mp-locked-connection-cache (*connection-cache-lock*)
+ (incf *connections-cached*)
(let ((start (first-valid-entry now queue)))
(if* (null start)
@@ -1012,7 +1053,7 @@ cached connection = ~s~%" cond cached-connection))
;; build a new one if there isn't one cached
(let ((now (get-universal-time))
(queue *connection-cache-queue*))
- (mp:without-scheduling
+ (with-mp-locked-connection-cache (*connection-cache-lock*)
(let ((start (first-valid-entry now queue))
(prev nil))
(loop
@@ -1842,7 +1883,7 @@ cached connection = ~s~%" cond cached-connection))
;; attempt to increase the use count of this entry by one.
;; If successful return true.
;; If the entry is dead return nil
- (excl::atomically
+ (with-fast-mp-locked-pcache-ent (pcache-ent)
(excl::fast
(let ((val (pcache-ent-use pcache-ent)))
(if* val
@@ -1851,7 +1892,7 @@ cached connection = ~s~%" cond cached-connection))
(defun unlock-pcache-ent (pcache-ent)
;; reduce the use count of this entry
- (mp:without-scheduling
+ (with-mp-locked-pcache-ent (pcache-ent)
(let ((val (pcache-ent-use pcache-ent)))
(if* val
then (if* (and (zerop (excl::fast
@@ -1865,6 +1906,7 @@ cached connection = ~s~%" cond cached-connection))
(let ((queueobj (pcache-ent-queueobj pcache-ent)))
(move-pcache-ent pcache-ent queueobj queueobj)))
+#+ignore ;; fixed below for thread safety
(defun move-pcache-ent (pcache-ent fromq toq)
;; move the pcache-ent between queues
;; fromq and toq can be nil or the same.
@@ -1907,14 +1949,82 @@ cached connection = ~s~%" cond cached-connection))
(setf (pcache-ent-queueobj pcache-ent) toq))))
-
-
+;; This is the new version, fixed for thread safety
+(defun move-pcache-ent (pcache-ent fromq toq)
+ ;; move the pcache-ent between queues
+ ;; fromq and toq can be nil or the same.
+ ;;
+ ;; to handle errors detected inside a locked block, we
+ ;; set up a flag that we can check after leaving the locked code
+ (let ((error-flag nil))
+ (if* (eq fromq toq)
+ then ;; just shifting it to the head of the queue it's in
+ (if* (null fromq)
+ then (setq error-flag :noqueue)
+ elseif (eq (pcache-ent-state pcache-ent) :dead) ; debugging
+ then (setq error-flag :dead)
+ else (with-mp-locked-pcache-queue (fromq)
+ (let* ((prev (pcache-ent-prev pcache-ent))
+ (next (pcache-ent-next pcache-ent))
+ (mru-head (queueobj-mru toq))
+ (mru (pcache-ent-next mru-head)))
+ ;; unlink and relink, or report error
+ (if* (or (null prev) (null next))
+ then (setq error-flag :unlinked)
+ else (setf (pcache-ent-next prev) next
+ (pcache-ent-prev next) prev
+ (pcache-ent-next mru-head) pcache-ent
+ (pcache-ent-prev pcache-ent) mru-head
+ (pcache-ent-next pcache-ent) mru
+ (pcache-ent-prev mru) pcache-ent)))))
+ else ;; toq != fromq; we're changing one or more queue counts
+ (when fromq
+ ;; it's leaving the queue fromq
+ (with-mp-locked-pcache-queue (fromq)
+ (let ((prev (pcache-ent-prev pcache-ent))
+ (next (pcache-ent-next pcache-ent)))
+ ;; unlink
+ (if* (or (null prev) (null next))
+ then (setq error-flag :unlinked)
+ else (setf (pcache-ent-next prev) next
+ (pcache-ent-prev next) prev)
+ (decf (queueobj-items fromq))
+ (decf (queueobj-bytes fromq)
+ (pcache-ent-data-length pcache-ent))
+ (decf (queueobj-blocks fromq)
+ (pcache-ent-blocks pcache-ent))))))
+ (when (and (null error-flag) toq)
+ ;; link into the toq, at the mru position
+ (if* (eq (pcache-ent-state pcache-ent) :dead)
+ then (setq error-flag :dead)
+ else (with-mp-locked-pcache-queue (toq)
+ (let* ((mru-head (queueobj-mru toq))
+ (mru (pcache-ent-next mru-head)))
+ (setf (pcache-ent-next mru-head) pcache-ent
+ (pcache-ent-prev pcache-ent) mru-head
+ (pcache-ent-next pcache-ent) mru
+ (pcache-ent-prev mru) pcache-ent))
+ (incf (queueobj-items toq))
+ (incf (queueobj-bytes toq)
+ (pcache-ent-data-length pcache-ent))
+ (incf (queueobj-blocks toq)
+ (pcache-ent-blocks pcache-ent)))))
+ (if* (null error-flag)
+ then (setf (pcache-ent-queueobj pcache-ent) toq)))
+ ;; we've either made changes or set error-flag non-nil
+ (case error-flag
+ (:noqueue
+ (error "attempt to move a pcache-ent without specifying a queue"))
+ (:dead (break "shouldn't be dead during move"))
+ (:unlinked
+ (error "attempt to shift an unlinked pcache-ent")))))
+
(defun kill-pcache-ent (pcache-ent &optional (pcache (wserver-pcache
*wserver*)))
; make this entry dead
- (mp::without-scheduling
+ (with-mp-locked-pcache (pcache)
; stop any scanning of this uri
(setf (pcache-ent-level pcache-ent) -1)
@@ -2158,6 +2268,7 @@ cached connection = ~s~%" cond cached-connection))
(loop
(if* (<= needed 0) then (return))
+ #+ignore ;; recoded below
(block main
(setq ent-todo nil)
@@ -2173,6 +2284,16 @@ cached connection = ~s~%" cond cached-connection))
then (setq ent-todo lru)
(return-from main))))))
+ ;; this is the new version
+ (with-mp-locked-pcache (pcache)
+ (setq ent-todo nil)
+ (do ((lru (pcache-ent-prev lru-head) (pcache-ent-prev lru)))
+ ((eq lru mru-head)
+ (setq needed 0))
+ (if* (lock-pcache-ent lru)
+ then (setq ent-todo lru)
+ (return))))
+
(if* ent-todo
then ; move this one to disk or kill it off
(if* (dolist (dc disk-caches t)
@@ -2192,10 +2313,17 @@ cached connection = ~s~%" cond cached-connection))
;; flush all the deal items from the cache, returning
;; their resource
(let (ent)
- (excl::atomically
- (excl::fast
- (setf ent (pcache-dead-ent pcache)
- (pcache-dead-ent pcache) nil)))
+ (smp-case
+ (nil
+ (atomically-fast
+ (setf ent (pcache-dead-ent pcache)
+ (pcache-dead-ent pcache) nil)))
+ ((t :macros)
+ (loop
+ (setq ent (pcache-dead-ent pcache))
+ (excl::fast
+ (when (atomic-conditional-setf (pcache-dead-ent pcache) nil ent)
+ (return))))))
; now we have an exclusive link to the dead entries
; which we can free at our leisure
@@ -2210,10 +2338,16 @@ cached connection = ~s~%" cond cached-connection))
then (return-free-blocks (pcache-ent-pcache-disk ent)
diskloc)))
(setq ent (pcache-ent-next ent)))
- (excl::atomically
- (excl::fast
- (decf (the fixnum (pcache-dead-items pcache))
- (the fixnum count)))))))
+ (smp-case
+ (nil
+ (atomically-fast
+ (decf (the fixnum (pcache-dead-items pcache))
+ (the fixnum count))))
+ ((t :macros)
+ (excl::fast
+ (decf-atomic (the fixnum (pcache-dead-items pcache))
+ (the fixnum count)))))
+ )))
@@ -2267,7 +2401,7 @@ cached connection = ~s~%" cond cached-connection))
(store-data-on-disk pcache-ent pcache-disk to-store-list)
(log-proxy (pcache-ent-key pcache-ent) 0 :wd nil)
(let ((ans
- (mp:without-scheduling
+ (with-mp-locked-pcache-ent (pcache-ent)
(if* (and (null (pcache-ent-state pcache-ent))
(eql 1 (pcache-ent-use pcache-ent)))
then ; we are tre sole user of this entry so we cna
@@ -2307,65 +2441,78 @@ cached connection = ~s~%" cond cached-connection))
(free-header-blocks buffs)
ans))))
+(defun ensure-pcache-in-memory (pcache-ent)
+ (smp-case
+ (t
+ (with-locked-structure (pcache-ent)
+ (if* (pcache-ent-disk-location pcache-ent)
+ then (retrieve-pcache-from-disk pcache-ent))))
+ ((nil :macros)
+ (if* (pcache-ent-disk-location pcache-ent)
+ then (retrieve-pcache-from-disk pcache-ent)))))
+
+
(defun retrieve-pcache-from-disk (pcache-ent)
;; read the cache entry back in from the disk
+ ;; This is now called with the pcache-ent locked in smp lisps,
+ ;; so the flagval test isn't needed in smp at all
+
; ensure the loading flag to true and set flagval
; to the value before we set the flag.
; If the value was nil and thus we set it to true, then
; we are the process responsible for loading in the data
;
- (let ((flagval (excl::atomically
- (excl::fast
- (let ((val (pcache-ent-loading-flag pcache-ent)))
- (if* (null val)
- then (setf (pcache-ent-loading-flag pcache-ent) t))
- val)))))
+ #-smp
+ (let ((flagval (atomically-fast
+ (let ((val (pcache-ent-loading-flag pcache-ent)))
+ (if* (null val)
+ then (setf (pcache-ent-loading-flag pcache-ent) t))
+ val))))
(if* flagval
then (mp:process-wait "cache entry to be loaded"
#'(lambda (pcache-ent)
(null (pcache-ent-loading-flag pcache-ent)))
pcache-ent)
(return-from retrieve-pcache-from-disk))
-
- ; it's our job to load in the entry
- (let* ((block-list (pcache-ent-disk-location pcache-ent))
- (pcache-disk (pcache-ent-pcache-disk pcache-ent))
- (stream (pcache-disk-stream pcache-disk))
- (bytes (+ (pcache-ent-data-length pcache-ent)
- *header-block-size*))
- (res))
- (dlogmess (format nil "retrieve ~s in blocks ~s~%"
- (pcache-ent-key pcache-ent)
- block-list))
- (log-proxy (pcache-ent-key pcache-ent) 0 :rd nil)
-
- (mp:with-process-lock ((pcache-disk-lock pcache-disk))
- ; get a lock so we're the only thread doing operations
- ; on the stream to the cache
- (dolist (ent block-list)
- (file-position stream (* (car ent) *header-block-size*))
- (dotimes (i (1+ (- (cdr ent) (car ent))))
- (let ((buff (get-header-block)))
- (read-sequence buff stream :end (min *header-block-size*
- bytes))
- (decf bytes *header-block-size*)
- (push buff res))))
- (setf (pcache-ent-data pcache-ent) (nreverse res))
+ )
+ ;; it's our job to load in the entry
+ (let* ((block-list (pcache-ent-disk-location pcache-ent))
+ (pcache-disk (pcache-ent-pcache-disk pcache-ent))
+ (stream (pcache-disk-stream pcache-disk))
+ (bytes (+ (pcache-ent-data-length pcache-ent)
+ *header-block-size*))
+ (res))
+ (dlogmess (format nil "retrieve ~s in blocks ~s~%"
+ (pcache-ent-key pcache-ent)
+ block-list))
+ (log-proxy (pcache-ent-key pcache-ent) 0 :rd nil)
+
+ (mp:with-process-lock ((pcache-disk-lock pcache-disk))
+ ;; get a lock so we're the only thread doing operations
+ ;; on the stream to the cache
+ (dolist (ent block-list)
+ (file-position stream (* (car ent) *header-block-size*))
+ (dotimes (i (1+ (- (cdr ent) (car ent))))
+ (let ((buff (get-header-block)))
+ (read-sequence buff stream :end (min *header-block-size*
+ bytes))
+ (decf bytes *header-block-size*)
+ (push buff res))))
+ (setf (pcache-ent-data pcache-ent) (nreverse res))
- (return-free-blocks pcache-disk block-list)
+ (return-free-blocks pcache-disk block-list)
- ; insert in the memory ru list
- (most-recently-used-ent pcache-ent)
+ ;; insert in the memory ru list
+ (most-recently-used-ent pcache-ent)
- ; insert in memory
+ ;; insert in memory
- (excl::atomically
- (excl::fast
- (setf (pcache-ent-disk-location pcache-ent) nil
- (pcache-ent-pcache-disk pcache-ent) nil
- (pcache-ent-loading-flag pcache-ent) nil)))))))
+ (atomically-fast
+ (setf (pcache-ent-disk-location pcache-ent) nil
+ (pcache-ent-pcache-disk pcache-ent) nil
+ (pcache-ent-loading-flag pcache-ent) nil)))))

0 comments on commit ae3e7ba

Please sign in to comment.