[MLton-commit] r5214
Wesley Terpstra
wesley at mlton.org
Thu Feb 15 18:01:43 PST 2007
primitive hooks for aggregate functions
----------------------------------------------------------------------
U mltonlib/trunk/ca/terpstra/sqlite3/buffer.sig
U mltonlib/trunk/ca/terpstra/sqlite3/buffer.sml
U mltonlib/trunk/ca/terpstra/sqlite3/prim.sig
U mltonlib/trunk/ca/terpstra/sqlite3/prim.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/ca/terpstra/sqlite3/buffer.sig
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/buffer.sig 2007-02-15 23:52:00 UTC (rev 5213)
+++ mltonlib/trunk/ca/terpstra/sqlite3/buffer.sig 2007-02-16 02:01:42 UTC (rev 5214)
@@ -5,4 +5,6 @@
val subOpt: 'a t * int -> 'a option
val sub: 'a t * int -> 'a
val push: 'a t * 'a -> int
+ val update: 'a t * int * 'a -> unit
+ val free: 'a t * int -> unit
end
Modified: mltonlib/trunk/ca/terpstra/sqlite3/buffer.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/buffer.sml 2007-02-15 23:52:00 UTC (rev 5213)
+++ mltonlib/trunk/ca/terpstra/sqlite3/buffer.sml 2007-02-16 02:01:42 UTC (rev 5214)
@@ -15,4 +15,8 @@
Array.update (!a, !s, SOME v);
!s before s := !s + 1
)
+
+ fun update ((a, _), i, v) = Array.update (!a, i, SOME v)
+
+ fun free ((a, _), i) = () (* !!! fixme !!! *)
end
Modified: mltonlib/trunk/ca/terpstra/sqlite3/prim.sig
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/prim.sig 2007-02-15 23:52:00 UTC (rev 5213)
+++ mltonlib/trunk/ca/terpstra/sqlite3/prim.sig 2007-02-16 02:01:42 UTC (rev 5214)
@@ -79,10 +79,9 @@
val resultS: context * string -> unit
val resultX: context * storage -> unit
+ datatype aggregate =
+ AGGR of (context * value vector -> aggregate) * (context -> unit)
val createFunction: db * string * (context * value vector -> unit) * int -> unit
val createCollation: db * string * (string * string -> order) -> unit
-(*
- val createAggregate: db * string * ((context * value vector -> unit) *
- (context -> unit)) option -> unit
-*)
+ val createAggregate: db * string * aggregate * int -> unit
end
Modified: mltonlib/trunk/ca/terpstra/sqlite3/prim.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/prim.sml 2007-02-15 23:52:00 UTC (rev 5213)
+++ mltonlib/trunk/ca/terpstra/sqlite3/prim.sml 2007-02-16 02:01:42 UTC (rev 5214)
@@ -58,6 +58,7 @@
val Pcreate_function = _import "sqlite3_create_function" : DB.t * CStr.t * int * int * word * FnPtr.t * FnPtr.t * FnPtr.t -> int;
val Pcreate_collation = _import "sqlite3_create_collation" : DB.t * CStr.t * int * word * FnPtr.t -> int;
val Puser_data = _import "sqlite3_user_data" : Context.t -> word;
+ val Paggregate_context = _import "sqlite3_aggregate_context" : Context.t * int -> MLton.Pointer.t;
(* fetch user function values *)
val Pvalue_blob = _import "sqlite3_value_blob" : Value.t -> Blob.out;
@@ -262,7 +263,9 @@
type callback = Context.t * Value.t vector -> unit
- (* !!! Space leak !!! *)
+ (* !!! somehow record the ids to free in the db handle? *)
+
+ (************************************************* Scalar functions *)
val fnt = Buffer.empty ()
fun fnCallback (context, numargs, args) =
let
@@ -281,16 +284,74 @@
fnCallback
val fnCallbackPtr = _address "mlton_sqlite3_ufnhook" : FnPtr.t;
-(*
- fun createFunction (db, name, NONE, _) =
- code (db, Pcreate_function (db, CStr.fromString name, 0, 1, 0w0,
- FnPtr.null, FnPtr.null, FnPtr.null))
-*)
fun createFunction (db, name, f, n) =
code (db, Pcreate_function (db, CStr.fromString name, n, 1,
Word.fromInt (Buffer.push (fnt, f)),
fnCallbackPtr, FnPtr.null, FnPtr.null))
+
+ (************************************************* Aggregate functions *)
+ datatype aggregate =
+ AGGR of (Context.t * Value.t vector -> aggregate) *
+ (Context.t -> unit)
+ val aginit = Buffer.empty ()
+ val agstep = Buffer.empty ()
+ fun fetchAggr context =
+ let
+ val magic = 0wxa72b (* new records are zero, we mark them magic *)
+ val ptr = Paggregate_context (context, 8)
+ in
+ if MLton.Pointer.getWord32 (ptr, 0) = magic
+ then Word32.toInt (MLton.Pointer.getWord32 (ptr, 1)) else
+ let
+ val idi = Word.toInt (Puser_data context)
+ val aggr = Buffer.sub (aginit, idi)
+ val ids = Buffer.push (agstep, aggr)
+ val () = MLton.Pointer.setWord32 (ptr, 0, magic)
+ val () = MLton.Pointer.setWord32 (ptr, 1, Word32.fromInt ids)
+ in
+ ids
+ end
+ end
+ fun agStepCallback (context, numargs, args) =
+ let
+ val ids = fetchAggr context
+ fun get i = Value.fromPtr (MLton.Pointer.getPointer (args, i))
+ val args = Vector.tabulate (numargs, get)
+ fun error s = Presult_error (context, CStr.fromString s, String.size s)
+ val AGGR (step, _) = Buffer.sub (agstep, ids)
+ in
+ Buffer.update (agstep, ids, step (context, args))
+ handle Error x => error ("fatal: " ^ x)
+ handle Retry x => error ("retry: " ^ x)
+ handle Abort x => error ("abort: " ^ x)
+ handle _ => error "unknown SML exception raised"
+ end
+ fun agFinalCallback context =
+ let
+ val ids = fetchAggr context
+ fun error s = Presult_error (context, CStr.fromString s, String.size s)
+ val AGGR (_, final) = Buffer.sub (agstep, ids)
+ in
+ final context
+ handle Error x => error ("fatal: " ^ x)
+ handle Retry x => error ("retry: " ^ x)
+ handle Abort x => error ("abort: " ^ x)
+ handle _ => error "unknown SML exception raised";
+ Buffer.free (agstep, ids)
+ end
+ val () = _export "mlton_sqlite3_uagstep" : (Context.t * int * MLton.Pointer.t -> unit) -> unit;
+ agStepCallback
+ val () = _export "mlton_sqlite3_uagfinal" : (Context.t -> unit) -> unit;
+ agFinalCallback
+ val agStepCallbackPtr = _address "mlton_sqlite3_uagstep" : FnPtr.t;
+ val agFinalCallbackPtr = _address "mlton_sqlite3_uagfinal" : FnPtr.t;
+
+ fun createAggregate (db, name, aggr, n) =
+ code (db, Pcreate_function (db, CStr.fromString name, n, 1,
+ Word.fromInt (Buffer.push (aginit, aggr)),
+ FnPtr.null, agStepCallbackPtr, agFinalCallbackPtr))
+ (************************************************* Collation functions *)
val colt = Buffer.empty ()
fun colCallback (uarg, s1l, s1p, s2l, s2p) =
let
More information about the MLton-commit
mailing list