[MLton-commit] r5302
Wesley Terpstra
wesley at mlton.org
Thu Feb 22 18:07:14 PST 2007
make the free list also available to queries so that executing them can check if memory can be freed
----------------------------------------------------------------------
U mltonlib/trunk/ca/terpstra/sqlite3-sml/query.sml
U mltonlib/trunk/ca/terpstra/sqlite3-sml/sql.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/ca/terpstra/sqlite3-sml/query.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3-sml/query.sml 2007-02-23 01:41:53 UTC (rev 5301)
+++ mltonlib/trunk/ca/terpstra/sqlite3-sml/query.sml 2007-02-23 02:07:14 UTC (rev 5302)
@@ -39,23 +39,35 @@
type pool = { db: Prim.db,
query: string,
- available: Prim.query list ref,
+ free: Prim.query list ref, (* common to all queries in the DB *)
+ available: Prim.query list ref, (* specific to this query *)
used: int ref }
type ('i, 'o) t = { pool: pool Ring.t MLton.Finalizable.t,
iF: Prim.query * 'i -> unit,
oF: Prim.query -> 'o }
+ (* 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 accessPool (pool, f) =
MLton.Finalizable.withValue (pool, fn x => f (Ring.get x))
fun peek ({ pool, iF=_, oF=_ }, f) =
- accessPool (pool, fn { db, query, available, used } =>
+ accessPool (pool, fn { db, query, free, available, used } =>
if !used = ~1 then raise Prim.Error "Database closed" else
case !available of
- x :: _ => f x
+ x :: _ => (cleanup free; f x)
| [] =>
let
+ val () = cleanup free
val pq = Prim.prepare (db, query)
val () = available := pq :: !available
in
@@ -63,11 +75,12 @@
end)
fun alloc ({ pool, iF, oF}, i) =
- accessPool (pool, fn { db, query, available, used } =>
+ accessPool (pool, fn { db, query, free, available, used } =>
if !used = ~1 then raise Prim.Error "Database closed" else
let
+ val () = cleanup free
val pq = case !available of
- [] => Prim.prepare (db, query)
+ [] => (cleanup free; Prim.prepare (db, query))
| x :: r => (available := r; x)
val () = used := !used + 1
val () = iF (pq, i)
@@ -76,7 +89,7 @@
end)
fun release ({ pool, iF=_, oF=_ }, pq) =
- accessPool (pool, fn {db=_, query=_, available, used } =>
+ accessPool (pool, fn {db=_, query=_, free=_, available, used } =>
if !used = ~1 then raise Prim.Error "SQLite wrapper bug: cannot release closed query" else
if !used = 0 then raise Prim.Error "SQLite wrapper bug: too many releases" else
( Prim.reset pq;
@@ -84,16 +97,6 @@
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
@@ -102,8 +105,8 @@
val iI0 = 1
local
- fun close free l =
- case Ring.get l of { db=_, query=_, available, used } =>
+ fun close l =
+ case Ring.get l of { db=_, query=_, free, available, used } =>
if !used <> 0 then raise Prim.Error "SQLite wrapper bug: finalizing in-use query" else
(* We don't need to lock the free-list or pool-ring:
* Operations on them (adds/removes) are in a critical section;
@@ -117,8 +120,8 @@
* (available := []; used := ~1)
*)
in
- fun prepare { ring, free, hooks=_, auth=_ } qt =
- case Ring.get ring of { db, query=_, available=_, used=_ } =>
+ fun prepare { ring, hooks=_, auth=_ } qt =
+ case Ring.get ring of { db, query=_, free, available=_, used=_ } =>
Fold.fold (([qt], oF0, oN0, oI0, iF0, iN0, iI0),
fn (ql, oF, _, oI, iF, _, iI) =>
let
@@ -137,13 +140,13 @@
\ for specified prototype")
else
let
- val i = { db = db, query = qs,
+ val i = { db = db, query = qs, free = free,
available = ref [q], used = ref 0 }
val pool = MLton.Thread.atomically
(fn () => MLton.Finalizable.new
(Ring.add (ring, i)))
in
- MLton.Finalizable.addFinalizer (pool, close free);
+ MLton.Finalizable.addFinalizer (pool, close);
{ pool = pool, iF = iF, oF = oF }
end
end)
Modified: mltonlib/trunk/ca/terpstra/sqlite3-sml/sql.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3-sml/sql.sml 2007-02-23 01:41:53 UTC (rev 5301)
+++ mltonlib/trunk/ca/terpstra/sqlite3-sml/sql.sml 2007-02-23 02:07:14 UTC (rev 5302)
@@ -15,7 +15,6 @@
struct
type column = Prim.column
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
@@ -29,33 +28,33 @@
val version = Prim.version
- fun getDB { free, ring, hooks=_, auth=_ } =
- case Ring.get ring of { db, query=_, available=_, used } =>
+ fun getDB { ring, hooks=_, auth=_ } =
+ case Ring.get ring of { db, query=_, free, available=_, used } =>
if !used = ~1 then raise Error "Database closed" else
- ( Query.cleanup free; db)
+ (Query.cleanup free; db)
fun openDB file = {
ring = Ring.new { db = Prim.openDB file,
query = "database",
+ free = ref [],
available = ref [],
used = ref 0 },
- free = ref [],
hooks = ref [],
auth = ref NONE }
- fun closeDB { ring, free, hooks, auth } =
+ fun closeDB { ring, hooks, auth } =
let
- val { db, query=_, available=_, used } = Ring.get ring
+ val { db, query=_, free, available=_, used } = Ring.get ring
val () = if !used = ~1 then raise Error "Database closed" else ()
- fun notInUse { db=_, query=_, available=_, used } = !used = 0
+ fun notInUse { db=_, query=_, free=_, available=_, used } = !used = 0
val exn = ref NONE
fun reraise NONE = ()
| reraise (SOME x) = raise x
fun forceClose q = Prim.finalize q handle x => exn := SOME x
- fun close { db=_, query=_, available, used } = (
+ fun close { db=_, query=_, free=_, available, used } = (
List.app forceClose (!available before available := []);
used := ~1)
@@ -155,13 +154,13 @@
end
end
- fun registerFunction (db as { ring=_, free=_, hooks, auth=_ }, s, (f, i)) =
+ fun registerFunction (db as { ring=_, hooks, auth=_ }, s, (f, i)) =
hooks := Prim.createFunction (getDB db, s, f, i) :: !hooks
- fun registerAggregate (db as { ring=_, free=_, hooks, auth=_ }, s, (a, i)) =
+ fun registerAggregate (db as { ring=_, hooks, auth=_ }, s, (a, i)) =
hooks := Prim.createAggregate (getDB db, s, a, i) :: !hooks
- fun registerCollation (db as { ring=_, free=_, hooks, auth=_ }, s, c) =
+ fun registerCollation (db as { ring=_, hooks, auth=_ }, s, c) =
hooks := Prim.createCollation (getDB db, s, c) :: !hooks
structure SQLite =
@@ -171,16 +170,16 @@
val totalChanges = Prim.totalChanges o getDB
val transactionActive = not o Prim.getAutocommit o getDB
- fun preparedQueries { free=_, ring, hooks=_, auth=_ } =
+ fun preparedQueries { ring, hooks=_, auth=_ } =
MLton.Thread.atomically
(fn () => Ring.fold (fn (_, x) => x + 1) ~1 ring)
- fun registeredFunctions { free=_, ring=_, hooks, auth=_ } =
+ fun registeredFunctions { ring=_, hooks, auth=_ } =
List.length (!hooks)
datatype access = datatype Prim.access
datatype request = datatype Prim.request
- fun setAuthorizer (dbh as { ring=_, free=_, hooks=_, auth }, f) =
+ fun setAuthorizer (dbh as { ring=_, 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