[MLton-commit] r5301
Wesley Terpstra
wesley at mlton.org
Thu Feb 22 17:41:56 PST 2007
ensure finalize is used from the same thread and never inside an authorizer callback
----------------------------------------------------------------------
U mltonlib/trunk/ca/terpstra/sqlite3-sml/demo.sml
U mltonlib/trunk/ca/terpstra/sqlite3-sml/query.sml
U mltonlib/trunk/ca/terpstra/sqlite3-sml/ring.sig
U mltonlib/trunk/ca/terpstra/sqlite3-sml/ring.sml
U mltonlib/trunk/ca/terpstra/sqlite3-sml/sql.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/ca/terpstra/sqlite3-sml/demo.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3-sml/demo.sml 2007-02-23 00:16:44 UTC (rev 5300)
+++ mltonlib/trunk/ca/terpstra/sqlite3-sml/demo.sml 2007-02-23 01:41:53 UTC (rev 5301)
@@ -52,19 +52,14 @@
handle SQL.Error x => die x
end
-(* Authorization functions at the moment are not safe to use.
- * A future SQLite3 library may resolve this problem.
- *)
-(*
local
open SQL.SQLite
- fun auth (INSERT { table, db }) =
- (print (db ^ ":" ^ table ^ ": insert denied\n"); DENY)
+ fun auth (UPDATE { table, db, column }) =
+ (print (db ^ ":" ^ table ^ ":" ^ column ^ ": update denied\n"); DENY)
| auth _ = ALLOW
in
val () = setAuthorizer (db, SOME auth)
end
-*)
fun dumpP (s & i) = print (s ^ " " ^ Int.toString i ^ "\n")
fun dumpV v = (Vector.app (fn s => print (s ^ " ")) v; print "\n")
Modified: mltonlib/trunk/ca/terpstra/sqlite3-sml/query.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3-sml/query.sml 2007-02-23 00:16:44 UTC (rev 5300)
+++ mltonlib/trunk/ca/terpstra/sqlite3-sml/query.sml 2007-02-23 01:41:53 UTC (rev 5301)
@@ -84,6 +84,16 @@
used := !used - 1;
available := pq :: !available))
+ (* Close unused queries, one at a time *)
+ fun cleanup free =
+ let
+ (* Carefully tidy the list up in case of exception *)
+ fun helper [] = ()
+ | helper (x :: r) = (Prim.finalize x; free := r; helper r)
+ in
+ MLton.Thread.atomically (fn () => helper (!free))
+ end
+
fun oF0 _ = ()
fun oN0 (_, n) = n ()
val oI0 = 0
@@ -92,29 +102,28 @@
val iI0 = 1
local
- fun error s =
- TextIO.output (TextIO.stdErr, "Finalization exception " ^ s ^ "\n")
- fun forceClose q =
- Prim.finalize q
- handle Prim.Error x => error ("Error: " ^ x)
- | Prim.Retry x => error ("Retry: " ^ x)
- | Prim.Abort x => error ("Abort: " ^ x)
- | _ => error ("unknown SML")
- fun close l =
+ fun close free l =
case Ring.get l of { db=_, query=_, available, used } =>
if !used <> 0 then raise Prim.Error "SQLite wrapper bug: finalizing in-use query" else
- ( Ring.remove l;
- List.app forceClose (!available);
- available := [];
- used := ~1
- )
+ (* We don't need to lock the free-list or pool-ring:
+ * Operations on them (adds/removes) are in a critical section;
+ * this method is only run from a distinct GC thread.
+ * Also, the available list is never accessed except by the
+ * methods above which operate on a query. This is a finalizer
+ * for the query so there can be no further references.
+ *)
+ (Ring.remove l; free := !available @ !free)
+ (* This is unneeded as the link is no longer referenced anywhere:
+ * (available := []; used := ~1)
+ *)
in
- fun prepare { ring, hooks=_, auth=_ } qt =
+ fun prepare { ring, free, hooks=_, auth=_ } qt =
case Ring.get ring of { db, query=_, available=_, used=_ } =>
Fold.fold (([qt], oF0, oN0, oI0, iF0, iN0, iI0),
fn (ql, oF, _, oI, iF, _, iI) =>
let
val qs = concat (rev ql)
+ val () = cleanup free
val q = Prim.prepare (db, qs)
in
if Prim.cols q < oI
@@ -128,14 +137,13 @@
\ for specified prototype")
else
let
- val atom = MLton.Thread.atomically
- val new = MLton.Finalizable.new
val i = { db = db, query = qs,
available = ref [q], used = ref 0 }
- fun closeA pool = atom (fn () => close pool)
- val pool = atom (fn () => new (Ring.add (i, ring)))
+ val pool = MLton.Thread.atomically
+ (fn () => MLton.Finalizable.new
+ (Ring.add (ring, i)))
in
- MLton.Finalizable.addFinalizer (pool, closeA);
+ MLton.Finalizable.addFinalizer (pool, close free);
{ pool = pool, iF = iF, oF = oF }
end
end)
Modified: mltonlib/trunk/ca/terpstra/sqlite3-sml/ring.sig
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3-sml/ring.sig 2007-02-23 00:16:44 UTC (rev 5300)
+++ mltonlib/trunk/ca/terpstra/sqlite3-sml/ring.sig 2007-02-23 01:41:53 UTC (rev 5301)
@@ -20,7 +20,7 @@
val new: 'a -> 'a t
(* Add a value to the ring, get a handle to the link *)
- val add: 'a * 'a t -> 'a t
+ val add: 'a t * 'a -> 'a t
(* Remove a link from the ring, it is in a new ring *)
val remove: 'a t -> unit
Modified: mltonlib/trunk/ca/terpstra/sqlite3-sml/ring.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3-sml/ring.sml 2007-02-23 00:16:44 UTC (rev 5300)
+++ mltonlib/trunk/ca/terpstra/sqlite3-sml/ring.sml 2007-02-23 01:41:53 UTC (rev 5301)
@@ -28,7 +28,7 @@
self
end
- fun add (x, pred as LINK { prev=_, next=pn, value=_ }) =
+ fun add (pred as LINK { prev=_, next=pn, value=_ }, x) =
let
val succ as LINK { prev=sp, next=_, value=_ } = valOf (!pn)
val self = LINK { value = x, prev = ref (SOME pred),
Modified: mltonlib/trunk/ca/terpstra/sqlite3-sml/sql.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3-sml/sql.sml 2007-02-23 00:16:44 UTC (rev 5300)
+++ mltonlib/trunk/ca/terpstra/sqlite3-sml/sql.sml 2007-02-23 01:41:53 UTC (rev 5301)
@@ -14,7 +14,8 @@
structure SQL :> SQL =
struct
type column = Prim.column
- type db = { ring: Query.pool Ring.t,
+ type db = { ring: Query.pool Ring.t,
+ free: Prim.query list ref,
hooks: Prim.hook list ref,
auth: Prim.hook option ref }
datatype storage = datatype Prim.storage
@@ -28,21 +29,25 @@
val version = Prim.version
- fun getDB { ring, hooks=_, auth=_ } =
+ fun getDB { free, ring, hooks=_, auth=_ } =
case Ring.get ring of { db, query=_, available=_, used } =>
- if !used = ~1 then raise Error "Database closed" else db
+ if !used = ~1 then raise Error "Database closed" else
+ ( Query.cleanup free; db)
fun openDB file = {
ring = Ring.new { db = Prim.openDB file,
query = "database",
available = ref [],
used = ref 0 },
+ free = ref [],
hooks = ref [],
auth = ref NONE }
- fun closeDB (dbh as { ring, hooks, auth }) =
+ fun closeDB { ring, free, hooks, auth } =
let
- val db = getDB dbh (* raises if closed *)
+ val { db, query=_, available=_, used } = Ring.get ring
+ val () = if !used = ~1 then raise Error "Database closed" else ()
+
fun notInUse { db=_, query=_, available=_, used } = !used = 0
val exn = ref NONE
@@ -51,19 +56,17 @@
fun forceClose q = Prim.finalize q handle x => exn := SOME x
fun close { db=_, query=_, available, used } = (
- List.app forceClose (!available);
- available := [];
+ List.app forceClose (!available before available := []);
used := ~1)
fun main () =
if Ring.fold (fn (l, a) => notInUse l andalso a) true ring
then (Ring.app close ring;
+ List.app forceClose (!free before free := []);
reraise (!exn);
Prim.closeDB db;
- List.app Prim.unhook (!hooks);
- hooks := [];
- Option.app Prim.unhook (!auth);
- auth := NONE)
+ List.app Prim.unhook (!hooks before hooks := []);
+ Option.app Prim.unhook (!auth before auth := NONE))
else raise Error "Database in use"
in
MLton.Thread.atomically (fn () => main ())
@@ -152,13 +155,13 @@
end
end
- fun registerFunction (db as { ring=_, hooks, auth=_ }, s, (f, i)) =
+ fun registerFunction (db as { ring=_, free=_, hooks, auth=_ }, s, (f, i)) =
hooks := Prim.createFunction (getDB db, s, f, i) :: !hooks
- fun registerAggregate (db as { ring=_, hooks, auth=_ }, s, (a, i)) =
+ fun registerAggregate (db as { ring=_, free=_, hooks, auth=_ }, s, (a, i)) =
hooks := Prim.createAggregate (getDB db, s, a, i) :: !hooks
- fun registerCollation (db as { ring=_, hooks, auth=_ }, s, c) =
+ fun registerCollation (db as { ring=_, free=_, hooks, auth=_ }, s, c) =
hooks := Prim.createCollation (getDB db, s, c) :: !hooks
structure SQLite =
@@ -168,16 +171,16 @@
val totalChanges = Prim.totalChanges o getDB
val transactionActive = not o Prim.getAutocommit o getDB
- fun preparedQueries { ring, hooks=_, auth=_ } =
+ fun preparedQueries { free=_, ring, hooks=_, auth=_ } =
MLton.Thread.atomically
(fn () => Ring.fold (fn (_, x) => x + 1) ~1 ring)
- fun registeredFunctions { ring=_, hooks, auth=_ } =
+ fun registeredFunctions { free=_, ring=_, hooks, auth=_ } =
List.length (!hooks)
datatype access = datatype Prim.access
datatype request = datatype Prim.request
- fun setAuthorizer (dbh as { ring=_, hooks=_, auth }, f) =
+ fun setAuthorizer (dbh as { ring=_, free=_, hooks=_, auth }, f) =
let
val db = getDB dbh
fun unset h = (Prim.unsetAuthorizer db; Prim.unhook h; auth := NONE)
More information about the MLton-commit
mailing list