[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