[MLton-commit] r5227
Wesley Terpstra
wesley at mlton.org
Fri Feb 16 18:48:05 PST 2007
keep track of all queries in a doubly-linked list that also includes the database handle
----------------------------------------------------------------------
U mltonlib/trunk/ca/terpstra/sqlite3/prim.sig
U mltonlib/trunk/ca/terpstra/sqlite3/query.sml
A mltonlib/trunk/ca/terpstra/sqlite3/ring.sig
A mltonlib/trunk/ca/terpstra/sqlite3/ring.sml
U mltonlib/trunk/ca/terpstra/sqlite3/sql.sig
U mltonlib/trunk/ca/terpstra/sqlite3/sql.sml
U mltonlib/trunk/ca/terpstra/sqlite3/sqlite.mlb
----------------------------------------------------------------------
Modified: mltonlib/trunk/ca/terpstra/sqlite3/prim.sig
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/prim.sig 2007-02-16 22:36:46 UTC (rev 5226)
+++ mltonlib/trunk/ca/terpstra/sqlite3/prim.sig 2007-02-17 02:48:05 UTC (rev 5227)
@@ -115,5 +115,5 @@
| CREATE_VTABLE of { table: string, module: string, db: string }
| DROP_VTABLE of { table: string, module: string, db: string }
| FUNCTION of { function: string }
- val setAuthorizer: (request -> access) option -> unit
+ val setAuthorizer: db * (request -> access) option -> unit
end
Modified: mltonlib/trunk/ca/terpstra/sqlite3/query.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/query.sml 2007-02-16 22:36:46 UTC (rev 5226)
+++ mltonlib/trunk/ca/terpstra/sqlite3/query.sml 2007-02-17 02:48:05 UTC (rev 5227)
@@ -21,71 +21,88 @@
* outstanding queries there are (-1 means closed). The pool saves
* previously allocated prepared statements for quick re-use.
*)
- type ('i, 'o) t = { db: Prim.db,
- query: string,
- pool: Prim.query list ref,
- used: int ref,
+
+ type pool = { db: Prim.db,
+ query: string,
+ available: Prim.query list ref,
+ used: int ref }
+
+ type ('i, 'o) t = { pool: pool Ring.t,
iF: Prim.query * 'i -> unit,
oF: Prim.query -> 'o }
- fun peek { db, query, pool, used, iF, oF } =
- case !pool of
+ fun peek { pool, iF=_, oF=_ } =
+ case Ring.get pool of { db, query, available, used } =>
+ if !used = ~1 then raise Prim.Error "Query.t is closed" else
+ case !available of
x :: r => x
| [] =>
let
val pq = Prim.prepare (db, query)
- val () = pool := pq :: !pool
+ val () = available := pq :: !available
in
pq
end
- fun alloc ({ db, query, pool, used, iF, oF }, i) =
+ fun alloc ({ pool, iF, oF}, i) =
+ case Ring.get pool of { db, query, available, used } =>
+ if !used = ~1 then raise Prim.Error "Query.t is closed" else
let
- val () = if !used = ~1 then raise Prim.Error "Query.t is closed" else ()
- val pq = case !pool of
+ val pq = case !available of
[] => Prim.prepare (db, query)
- | x :: r => (pool := r; x)
+ | x :: r => (available := r; x)
val () = used := !used + 1
val () = iF (pq, i)
in
(pq, oF)
end
- fun release ({ db, query, pool, used, iF, oF }, pq) = (
+ fun release ({ pool, iF=_, oF=_ }, pq) =
+ case Ring.get pool of { db=_, query=_, available, used } => (
if !used = 0 then raise Prim.Error "wrapper bug: too many released statements" else
Prim.reset pq;
Prim.clearbindings pq;
used := !used - 1;
- pool := pq :: !pool)
+ available := pq :: !available)
+ (* We will rewrite this to closeAll soon *)
+ fun close { pool, iF=_, oF=_ } =
+ case Ring.get pool of { db=_, query=_, available, used } =>
+ if !used = 0
+ then (List.app Prim.finalize (!available);
+ available := [];
+ used := ~1)
+ else raise Prim.Error "Query is being processed; cannot close"
+
fun oF0 _ = ()
fun oN0 (q, n) = n ()
val oI0 = 0
fun iF0 (q, ()) = ()
fun iN0 (q, x) = (1, x)
- fun prepare db qs = Fold.fold (([qs], oF0, oN0, oI0, iF0, iN0),
- fn (ql, oF, _, oI, iF, _) =>
- let val qs = concat (rev ql)
- val q = Prim.prepare (db, qs)
- in if Prim.cols q < oI
- then (Prim.finalize q;
- raise Prim.Error "insufficient output columns")
- else { db = db,
- query = qs,
- pool = ref [q],
- used = ref 0,
- iF = iF,
- oF = oF }
- end)
+ fun prepare dbl qt =
+ case Ring.get dbl of { db, query=_, available=_, used=_ } =>
+ Fold.fold (([qt], oF0, oN0, oI0, iF0, iN0),
+ fn (ql, oF, _, oI, iF, _) =>
+ let
+ val qs = concat (rev ql)
+ val q = Prim.prepare (db, qs)
+ in
+ if Prim.cols q < oI
+ then (Prim.finalize q;
+ raise Prim.Error "insufficient output columns \
+ \to satisfy prototype")
+ else { pool = Ring.add ({ db = db,
+ query = qs,
+ available = ref [q],
+ used = ref 0 }, dbl),
+ iF = iF,
+ oF = oF }
+ end)
+
(* terminate an expression with this: *)
val $ = $
- fun close { db, query, pool, used, iF, oF } =
- if !used = 0
- then (List.app Prim.finalize (!pool); pool := [] ; used := ~1)
- else raise Prim.Error "Query is being processed; cannot close"
-
fun iFx f iN (q, a) = case iN (q, a) of (i, x) => f (q, i, x)
fun iNx f iN (q, a & y) = case iN (q, a) of (i, x) => (f (q, i, x); (i+1, y))
fun iMap f = Fold.step1 (fn (qs, (ql, oF, oN, oI, iF, iN)) =>
Added: mltonlib/trunk/ca/terpstra/sqlite3/ring.sig
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/ring.sig 2007-02-16 22:36:46 UTC (rev 5226)
+++ mltonlib/trunk/ca/terpstra/sqlite3/ring.sig 2007-02-17 02:48:05 UTC (rev 5227)
@@ -0,0 +1,20 @@
+signature RING =
+ sig
+ (* handle to a link in the ring *)
+ type 'a t
+
+ (* Create a new ring with just this one element *)
+ val new: 'a -> 'a t
+
+ (* Add a value to the ring, get a handle to the link *)
+ val add: 'a * 'a t -> 'a t
+
+ (* Remove a link from the ring, it is in a new ring *)
+ val remove: 'a t -> unit
+
+ (* Run the method over all links in the ring *)
+ val fold: ('a * 'b -> 'b) -> 'b -> 'a t -> 'b
+
+ (* Retrieve the value in this link *)
+ val get: 'a t -> 'a
+ end
Added: mltonlib/trunk/ca/terpstra/sqlite3/ring.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/ring.sml 2007-02-16 22:36:46 UTC (rev 5226)
+++ mltonlib/trunk/ca/terpstra/sqlite3/ring.sml 2007-02-17 02:48:05 UTC (rev 5227)
@@ -0,0 +1,94 @@
+structure Ring :> RING =
+ struct
+ datatype 'a t = LINK of { prev: 'a t option ref,
+ next: 'a t option ref,
+ value: 'a }
+ fun new x =
+ let
+ (* Grrr! Why can't I use val rec??? *)
+ val prev = ref NONE
+ val next = ref NONE
+ val self = LINK { value = x, prev = prev, next = next }
+ val () = prev := SOME self
+ val () = next := SOME self
+ in
+ self
+ end
+
+ fun add (x, pred as LINK { prev=_, next=pn, value=_ }) =
+ let
+ val succ as LINK { prev=sp, next=_, value=_ } = valOf (!pn)
+ val self = LINK { value = x, prev = ref (SOME pred),
+ next = ref (SOME succ) }
+ val () = pn := SOME self
+ val () = sp := SOME self
+ in
+ self
+ end
+
+ fun remove (self as LINK { prev, next, value=_ }) =
+ let
+ val pred as LINK { prev=_, next=pn, value=_ } = valOf (!prev)
+ val succ as LINK { prev=sp, next=_, value=_ } = valOf (!next)
+ val () = pn := SOME succ
+ val () = sp := SOME pred
+ val () = prev := SOME self
+ val () = next := SOME self
+ in
+ ()
+ end
+
+ fun fold f a0 (self as LINK { prev, next, value }) =
+ let
+ val LINK { prev=_, next=eor, value=_ } = valOf (!prev)
+ fun loop (l, a) =
+ if l = eor then a else
+ case valOf (!l) of LINK { prev=_, next=nl, value=x } =>
+ loop (nl, f (x, a))
+ in
+ loop (next, f (value, a0))
+ end
+
+ fun get (self as LINK { prev=_, next=_, value }) = value
+
+ fun test (self as LINK { prev, next, value }) =
+ let
+ val LINK { prev=_, next=pn, value=_ } = valOf (!prev)
+ val LINK { prev=sp, next=_, value=_ } = valOf (!next)
+ in
+ valOf (!pn) = self andalso valOf (!sp) = self andalso pn <> sp
+ end
+ end
+(*
+fun check l = List.foldl (fn (l, a) => Ring.test l andalso a) true l
+val sum = Ring.fold (fn (x, a) => a + x) 0
+
+val a = Ring.new 6
+val b = Ring.add (2, a)
+val c = Ring.add (5, b)
+val d = Ring.add (1, a)
+val e = Ring.add (3, d)
+val f = Ring.add (4, c)
+val all = [ a, b, c, d, e, f ]
+
+val () = print ("Sum: " ^ Int.toString (sum f) ^ "\n")
+
+val true = check all
+val 21 = sum a
+val 21 = sum e
+
+val () = Ring.remove e
+val true = check all
+val 18 = sum a
+val 3 = sum e
+
+val () = Ring.remove e
+val true = check all
+
+val () = Ring.remove c
+val true = check all
+val 13 = sum a
+val 3 = sum e
+
+val () = print "Ring works!\n"
+*)
Modified: mltonlib/trunk/ca/terpstra/sqlite3/sql.sig
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/sql.sig 2007-02-16 22:36:46 UTC (rev 5226)
+++ mltonlib/trunk/ca/terpstra/sqlite3/sql.sig 2007-02-17 02:48:05 UTC (rev 5227)
@@ -232,7 +232,7 @@
| CREATE_VTABLE of { table: string, module: string, db: string }
| DROP_VTABLE of { table: string, module: string, db: string }
| FUNCTION of { function: string }
- val setAuthorizer: (request -> access) option -> unit
+ val setAuthorizer: db * (request -> access) option -> unit
(* All of these are omitted from the SML binding: *)
(* fun interrupt: db -> unit *) (* too dangerous to expose IMO *)
Modified: mltonlib/trunk/ca/terpstra/sqlite3/sql.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/sql.sml 2007-02-16 22:36:46 UTC (rev 5226)
+++ mltonlib/trunk/ca/terpstra/sqlite3/sql.sml 2007-02-17 02:48:05 UTC (rev 5227)
@@ -1,7 +1,7 @@
structure SQL :> SQL =
struct
type column = Prim.column
- type db = Prim.db
+ type db = Query.pool Ring.t
datatype storage = datatype Prim.storage
exception Retry = Prim.Retry
@@ -16,9 +16,18 @@
fun columns q = Prim.columns (Query.peek q)
fun columnsMeta q = Prim.meta (Query.peek q)
- val openDB = Prim.openDB
- val closeDB = Prim.closeDB
+ fun getDB dbl =
+ case Ring.get dbl of { db, query=_, available=_, used=_ } =>
+ db
+ fun openDB file =
+ Ring.new { db = Prim.openDB file,
+ query = "database",
+ available = ref [],
+ used = ref 0 }
+
+ val closeDB = Prim.closeDB o getDB
+
datatype 'v stop = STOP | CONTINUE of 'v
fun iterStop q i =
@@ -97,19 +106,24 @@
end
end
- fun registerFunction (db, s, (f, i)) = Prim.createFunction (db, s, f, i)
- fun registerAggregate (db, s, (a, i)) = Prim.createAggregate(db, s, a, i)
- val registerCollation = Prim.createCollation
+ fun registerFunction (db, s, (f, i)) =
+ Prim.createFunction (getDB db, s, f, i)
+
+ fun registerAggregate (db, s, (a, i)) =
+ Prim.createAggregate (getDB db, s, a, i)
+ fun registerCollation (db, s, c) =
+ Prim.createCollation (getDB db, s, c)
+
structure SQLite =
struct
- val lastInsertRowId = Prim.lastInsertRowid
- val changes = Prim.changes
- val totalChanges = Prim.totalChanges
- val transactionActive = not o Prim.getAutocommit
+ val lastInsertRowId = Prim.lastInsertRowid o getDB
+ val changes = Prim.changes o getDB
+ val totalChanges = Prim.totalChanges o getDB
+ val transactionActive = not o Prim.getAutocommit o getDB
datatype access = datatype Prim.access
datatype request = datatype Prim.request
- val setAuthorizer = Prim.setAuthorizer
+ fun setAuthorizer (db, f) = Prim.setAuthorizer (getDB db, f)
end
end
Modified: mltonlib/trunk/ca/terpstra/sqlite3/sqlite.mlb
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/sqlite.mlb 2007-02-16 22:36:46 UTC (rev 5226)
+++ mltonlib/trunk/ca/terpstra/sqlite3/sqlite.mlb 2007-02-17 02:48:05 UTC (rev 5227)
@@ -19,6 +19,8 @@
pair.sml
sql.sig
local
+ ring.sig
+ ring.sml
query.sml
function.sml
in
More information about the MLton-commit
mailing list