Add a resource module

Resources are loaded as binary or lisp files. A streamed resource is
also planned but not yet implemented.
Resources are shared and loading happens asynchronically,
powered by promises.
Resources are used through proxies that shares a weak pointer.
When a proxy is gc'd, a finalizer is triggered using trivial-garbage to
release the resource.

core/file.lisp

@@ -8,6 +8,26 @@
   (:export #:safe-read #:safe-read-from-string #:load-file))
 (in-package :stoe/core/file)
 
+(let ((safe-readtable (copy-readtable nil)))
+  (dolist (c '(#\# #\=))
+    (set-macro-character c nil nil safe-readtable))
+
+  (defun safe-read (&optional (stream *standard-input*) (eof-error-p t) eof-value recursive-p)
+    (let ((*readtable* safe-readtable))
+      (restartable
+       (read stream eof-error-p eof-value recursive-p))))
+
+  (locally
+      #+sbcl
+      (declare sb-ext::(muffle-conditions style-warning))
+    (defun safe-read-from-string (s &optional (eof-error-p t) eof-value
+                                  &key (start 0) end preserve-whitespace)
+      (let ((*readtable* safe-readtable)
+            (*read-eval* nil))
+        (restartable
+          (read-from-string s eof-error-p eof-value :start start :end end
+                            :preserve-whitespace preserve-whitespace))))))
+
 (defun do-load-file (filepath type)
   "Load the file specified by `filepath' and store it in the object returned."
   (with-open-file (stream filepath :direction :input :element-type type)

core/resources.lisp

@@ -0,0 +1,128 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/core/resources
+    (:use :cl :blackbird
+          :stoe/core/utils
+          :stoe/core/file
+          :stoe/core/modules
+          :stoe/core/jobs)
+  (:export #:resource #:res-path #:res-loaded-p
+           #:shared-resource
+           #:binary-resource #:res-buffer
+           #:stream-resource #:res-stream
+           #:lisp-resource #:res-data
+           #:resource-proxy #:res-deref
+           #:load-bin-resource #:load-stream-resource
+           #:load-lisp-resource #:unload-resource))
+(in-package :stoe/core/resources)
+
+(defvar *resources-db* (make-hash-table :test 'equal))
+
+(defclass resource ()
+  ((path :initarg :path :reader res-path)
+   (loaded :initarg :loaded :initform nil :reader res-loaded-p))
+  (:documentation "Base class for a resource."))
+
+(defclass shared-resource (resource shared-object)
+  ()
+  (:documentation "Base class for a shared resource."))
+
+(defclass binary-resource (shared-resource)
+  ((buffer :initarg :buffer :type '(array (unsigned-byte 8) (*)) :reader res-buffer))
+  (:documentation "Resource containing binary data."))
+
+(defclass stream-resource (resource)
+  ((stream :initarg :stream :accessor res-stream))
+  (:documentation "Streaming resource."))
+
+(defclass lisp-resource (resource)
+  ((data :initarg :data :reader res-data))
+  (:documentation "Resource defined in lisp."))
+
+(defclass resource-proxy ()
+  ((resource :initarg :resource))
+  (:documentation "Proxy class of a resource."))
+
+(defgeneric res-deref (proxy))
+(defmethod res-deref ((proxy resource-proxy))
+  (with-slots (resource) proxy
+    (tg:weak-pointer-value resource)))
+
+(defun initialize (&optional argv)
+  "Initialize resources module."
+  (declare (ignore argv)))
+
+(defun finalize ()
+  "Finalize resources module."
+  (when (> (hash-table-count *resources-db*) 0)
+    (format t "There are still ~d resources in the database~%" (hash-table-count *resources-db*))
+    (loop for res being the hash-values in *resources-db*
+       do (format t "  file ~a is still referenced by ~d proxies~%" (pathname-path (res-path res))
+                  (slot-value res 'refcount)))
+    (clrhash *resources-db*)))
+
+(defun update (delta-time)
+  (declare (ignore delta-time)))
+
+(defmodule stoe/core/resources)
+
+(defun register-resource (res)
+  (assert (null (gethash (res-path res) *resources-db*)))
+  (setf (gethash (res-path res) *resources-db*) res))
+
+(defun unregister-resource (res)
+  (assert (gethash (res-path res) *resources-db*))
+  (remhash (res-path res) *resources-db*))
+
+(defun make-resource (path type)
+  (let ((res (gethash path *resources-db*))
+        (newres nil))
+    (unless res
+      (setf res (make-instance type :path path))
+      (register-resource res)
+      (setf newres t))
+    (values (make-resource-proxy res) newres)))
+
+(defmethod dec-ref :after ((res shared-resource))
+  (with-slots (refcount) res
+    (when (= refcount 0)
+      (unregister-resource res))))
+
+(defun make-resource-proxy (res)
+  (let ((proxy (make-instance 'resource-proxy :resource (tg:make-weak-pointer res))))
+    (tg:finalize proxy (lambda () (dec-ref res)))
+    (inc-ref res)
+    proxy))
+
+(defun load-bin-resource (path)
+  (multiple-value-bind (proxy newres) (make-resource path 'binary-resource)
+    (values proxy (if newres
+                    (alet ((data (load-file path)))
+                      (let ((res (res-deref proxy)))
+                        (with-slots (buffer loaded) res
+                          (setf buffer data)
+                          (setf loaded t))
+                        res))
+                    (promisify (res-deref proxy))))))
+
+(defun load-stream-resource (path)
+  (declare (ignore path)))
+
+(defun load-lisp-resource (path)
+  (multiple-value-bind (proxy newres) (make-resource path 'lisp-resource)
+    (values proxy (if newres
+                      (alet ((s (load-file path :type 'character)))
+                        (let ((res (res-deref proxy)))
+                          (with-slots (data loaded) res
+                            (setf data (safe-read-from-string s))
+                            (setf loaded t))
+                          res))
+                      (promisify (res-deref proxy))))))
+
+(defun unload-resource (proxy)
+  (tg:cancel-finalization proxy)
+  (with-slots (resource) proxy
+    (dec-ref (tg:weak-pointer-value resource))))

core/utils.lisp

@@ -13,8 +13,11 @@
            #:update-current-time #:get-delta-time
            #:make-clock #:clock-time #:clock-delta
            #:update-clock #:compare-clocks
+           #:shared-object #:refcount #:inc-ref #:dec-ref
+           #:error-implementation-unsupported
            #:get-command-line-option
-           #:get-command-line-option-number))
+           #:get-command-line-option-number
+           #:pathname-path))
 (in-package :stoe/core/utils)
 
 (defun safe-first (x)
@@ -124,6 +127,20 @@
   "Return the difference between `clock1' and `clock2'."
   (- (clock-time clock1) (clock-time clock2)))
 
+(defclass shared-object ()
+  ((refcount :initform 0 :reader refcount)))
+
+(defgeneric inc-ref (obj))
+(defmethod inc-ref ((obj shared-object))
+  (with-slots (refcount) obj
+    (incf refcount)))
+
+(defgeneric dec-ref (obj))
+(defmethod dec-ref ((obj shared-object))
+  (with-slots (refcount) obj
+    (when (> refcount 0)
+      (decf refcount))))
+
 (defun error-implementation-unsupported ()
   "Return an error specifying the current lisp implementation is not supported."
   (error "For now, only sbcl is supported."))
@@ -142,3 +159,8 @@
           (assert (numberp value))
           value)
         default)))
+
+(defun pathname-path (path)
+  (with-output-to-string (s)
+    (format s "~{~a/~}~a~@[.~a~]" (cdr (pathname-directory path))
+            (pathname-name path) (pathname-type path))))

stoe.asd

@@ -37,6 +37,7 @@
                     (proclaim '(optimize (debug 3) (safety 3) (speed 0)))
                     (funcall thunk))
   :depends-on ("alexandria"
+               "trivial-garbage"
                "bordeaux-threads"
                "blackbird"
                "cl-opengl"

test/all.lisp

@@ -7,4 +7,5 @@
     (:nicknames :test)
   (:use-reexport
    :stoe/test/job-utils
-   :stoe/test/jobs))
+   :stoe/test/jobs
+   :stoe/test/resources))

test/resources.lisp

@@ -0,0 +1,94 @@
+#|
+  This file is a part of stoe project.
+  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
+|#
+
+(uiop:define-package :stoe/test/resources
+    (:use :cl :prove
+          :stoe/core/utils
+          :stoe/core/resources
+          :stoe/test/job-utils))
+(in-package :stoe/test/resources)
+
+(setq *random-state* (make-random-state))
+(defvar *data-dir* #P".data/")
+(defvar *res-array* (make-array '(10)))
+
+(defun get-resource-path (index &optional (ext "dat"))
+  (merge-pathnames (make-pathname :name (format nil "~2,'0d.~a" index ext)) *data-dir*))
+
+(defun generate-files ()
+  (ensure-directories-exist *data-dir*)
+
+  ;; Make a bunch of files full of random binary+lisp data
+  (loop-with-progress "Generating files" for i below 10
+     do (let ((data (loop for j below (* 1024 1024 (+ 0.5 (random 1.0)))
+                       collect (random 255))))
+          (with-open-file (stream (get-resource-path i) :direction :output
+                                  :element-type '(unsigned-byte 8)
+                                  :if-exists :supersede)
+            (write-sequence data stream))
+          (with-open-file (stream (get-resource-path i "lisp") :direction :output
+                                  :if-exists :supersede)
+            (write data :stream stream))
+          progress-step)))
+
+(generate-files)
+
+(stoe/core/jobs::initialize)
+(stoe/core/resources::initialize)
+
+(plan 43)
+
+(diag "Sync load of binary files")
+(dotimes (i 10)
+  (setf (aref *res-array* i) (load-bin-resource (get-resource-path i)))
+  (is (res-loaded-p (res-deref (aref *res-array* i))) t
+      (format nil "file ~2,'0d.dat loaded in memory" i)))
+
+(setf *res-array* (make-array '(10)))
+(tg:gc :full t)
+(is (hash-table-count stoe/core/resources::*resources-db*) 0 "All resources unloaded")
+
+(dotimes (i 10)
+  (setf (aref *res-array* i) (load-bin-resource (get-resource-path i)))
+  (with-open-file (stream (get-resource-path (+ 10 i)) :direction :output
+                          :element-type '(unsigned-byte 8) :if-exists :supersede)
+    (write-sequence (res-buffer (res-deref (aref *res-array* i))) stream))
+  (is (sb-ext:process-exit-code
+       (sb-ext:run-program "diff" (list (pathname-path (get-resource-path i))
+                                        (pathname-path (get-resource-path (+ 10 i))))
+                           :search t)) 0
+      (format nil "file ~2,'0d.dat integrity" i)))
+
+(diag "Shared load of binary files")
+(dotimes (i 10)
+  (let* ((proxy (load-bin-resource (get-resource-path i)))
+         (res (res-deref proxy)))
+    (is (slot-value res 'refcount) 2 (format nil "file ~2,'0d.dat has 2 refs" i))
+    (unload-resource proxy)
+    (is (slot-value res 'refcount) 1 (format nil "file ~2,'0d.dat has 1 ref" i))
+    (unload-resource (aref *res-array* i))))
+(is (hash-table-count stoe/core/resources::*resources-db*) 0 "All resources unloaded")
+
+(diag "Async load of binary files")
+(with-new-job-thread 2
+  (let (promise-list readyp)
+    (dotimes (i 10)
+      (multiple-value-bind (proxy promise) (load-bin-resource (get-resource-path i))
+        (setf (aref *res-array* i) proxy)
+        (push promise promise-list)))
+    (bb:alet ((res-list (bb:all promise-list)))
+      (setf readyp t))
+    (sleep 5)
+    (is readyp t "Load 10 files asynchronically")))
+
+(stoe/core/resources::finalize)
+(setf *res-array* nil)
+(tg:gc :full t)
+
+(finalize)
+
+(stoe/core/jobs::finalize)
+
+(uiop:delete-directory-tree *data-dir* :validate t)