[MLton-commit] r5232

Wesley Terpstra wesley at mlton.org
Sat Feb 17 07:45:19 PST 2007


recover memory from registered functions on close
----------------------------------------------------------------------

U   mltonlib/trunk/ca/terpstra/sqlite3/buffer.sml
U   mltonlib/trunk/ca/terpstra/sqlite3/prim.sig
U   mltonlib/trunk/ca/terpstra/sqlite3/prim.sml
U   mltonlib/trunk/ca/terpstra/sqlite3/query.sml
U   mltonlib/trunk/ca/terpstra/sqlite3/sql.sig
U   mltonlib/trunk/ca/terpstra/sqlite3/sql.sml

----------------------------------------------------------------------

Modified: mltonlib/trunk/ca/terpstra/sqlite3/buffer.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/buffer.sml	2007-02-17 14:43:00 UTC (rev 5231)
+++ mltonlib/trunk/ca/terpstra/sqlite3/buffer.sml	2007-02-17 15:45:18 UTC (rev 5232)
@@ -42,7 +42,7 @@
       fun free ({ buf, free }, i) = (
 (*
          case Array.sub (!buf, i) of
-            FREE _ => raise "Free of unused space in Buffer.free"
+            FREE _ => raise Fail "Free of unused space in Buffer.free"
           | FULL _ =>
 *)
          Array.update (!buf, i, FREE (IntX.fromInt (!free)));

Modified: mltonlib/trunk/ca/terpstra/sqlite3/prim.sig
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/prim.sig	2007-02-17 14:43:00 UTC (rev 5231)
+++ mltonlib/trunk/ca/terpstra/sqlite3/prim.sig	2007-02-17 15:45:18 UTC (rev 5232)
@@ -79,9 +79,10 @@
       
       type aggregate = { step:  context * value vector -> unit,
                          final: context -> unit }
-      val createFunction:  db * string * (context * value vector -> unit) * int -> unit
-      val createCollation: db * string * (string * string -> order) -> unit
-      val createAggregate: db * string * (unit -> aggregate) * int -> unit
+      type hook
+      val createFunction:  db * string * (context * value vector -> unit) * int -> hook
+      val createCollation: db * string * (string * string -> order) -> hook
+      val createAggregate: db * string * (unit -> aggregate) * int -> hook
       
       val lastInsertRowid: db -> Int64.int
       val changes: db -> int
@@ -114,4 +115,7 @@
        | DROP_VTABLE of { table: string, module: string, db: string  }
        | FUNCTION of { function: string }
       val setAuthorizer: db * (request -> access) option -> unit
+      
+      (* Only do this after closing the database or unbinding the fn *)
+      val unhook: hook -> unit
    end

Modified: mltonlib/trunk/ca/terpstra/sqlite3/prim.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/prim.sml	2007-02-17 14:43:00 UTC (rev 5231)
+++ mltonlib/trunk/ca/terpstra/sqlite3/prim.sml	2007-02-17 15:45:18 UTC (rev 5232)
@@ -259,8 +259,7 @@
       
       type callback = Context.t * Value.t vector -> unit
       
-      (* !!! somehow record the ids to free in the db handle? *)
-      
+      datatype hook = UFN of int | COLL of int | AGGR of int
       (************************************************* Scalar functions *)
       val fnt = Buffer.empty ()
       fun fnCallback (context, numargs, args) =
@@ -281,9 +280,15 @@
       val fnCallbackPtr = _address "mlton_sqlite3_ufnhook" : FnPtr.t;
       
       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))
+         let
+            val id = Buffer.push (fnt, f)
+            val r = Pcreate_function (
+                       db, CStr.fromString name, n, 1, Word.fromInt id,
+                       fnCallbackPtr, FnPtr.null, FnPtr.null)
+         in
+            code (db, r); 
+            UFN id
+         end
       
       (************************************************* Aggregate functions *)
       type aggregate = {
@@ -343,10 +348,16 @@
       val agFinalCallbackPtr = _address "mlton_sqlite3_uagfinal" : FnPtr.t;
       
       fun createAggregate (db, name, gen, n) =
-             code (db, Pcreate_function (db, CStr.fromString name, n, 1, 
-                                         Word.fromInt (Buffer.push (aggen, gen)),
-                                         FnPtr.null, agStepCallbackPtr, agFinalCallbackPtr))
-
+         let
+            val id = Buffer.push (aggen, gen)
+            val r = Pcreate_function (
+                       db, CStr.fromString name, n, 1, Word.fromInt id,
+                       FnPtr.null, agStepCallbackPtr, agFinalCallbackPtr)
+         in
+             code (db, r); 
+             AGGR id
+         end
+         
       (************************************************* Collation functions *)
       val colt = Buffer.empty ()
       fun colCallback (uarg, s1l, s1p, s2l, s2p) =
@@ -368,10 +379,18 @@
                   colCallback
       val colCallbackPtr = _address "mlton_sqlite3_colhook" : FnPtr.t;
       fun createCollation (db, name, f) =
-             code (db, Pcreate_collation (db, CStr.fromString name, 1,
-                                          Word.fromInt (Buffer.push (colt, f)),
-                                          colCallbackPtr))
+         let
+            val id = Buffer.push (colt, f)
+            val r = Pcreate_collation (
+                       db, CStr.fromString name, 1, Word.fromInt id,
+                       colCallbackPtr)
+         in
+            code (db, r);
+            COLL id
+         end
       
+      (************************************************* End of user functions *)
+      
       val lastInsertRowid = PlastInsertRowid
       val changes = Pchanges
       val totalChanges = PtotalChanges
@@ -443,6 +462,10 @@
       
       fun setAuthorizer _ = ()
       
+      fun unhook (UFN  x) = Buffer.free (fnt, x)
+        | unhook (COLL x) = Buffer.free (colt, x)
+        | unhook (AGGR x) = Buffer.free (aggen, x)
+      
       type db = DB.t
       type query = Query.t
       type value = Value.t

Modified: mltonlib/trunk/ca/terpstra/sqlite3/query.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/query.sml	2007-02-17 14:43:00 UTC (rev 5231)
+++ mltonlib/trunk/ca/terpstra/sqlite3/query.sml	2007-02-17 15:45:18 UTC (rev 5232)
@@ -86,8 +86,8 @@
               Ring.remove l
               )
       in
-         fun prepare dbl qt =
-            case Ring.get dbl of { db, query=_, available=_, used=_ } =>
+         fun prepare { ring, hooks } qt =
+            case Ring.get ring of { db, query=_, available=_, used=_ } =>
             Fold.fold (([qt], oF0, oN0, oI0, iF0, iN0),
                        fn (ql, oF, _, oI, iF, _) => 
                        let
@@ -104,7 +104,7 @@
                                             Ring.add ({ db = db, 
                                                         query = qs, 
                                                         available = ref [q], 
-                                                        used = ref 0 }, dbl))
+                                                        used = ref 0 }, ring))
                               val out = { pool = pool, iF = iF, oF = oF }
                            in
                               MLton.Finalizable.addFinalizer (pool, close);

Modified: mltonlib/trunk/ca/terpstra/sqlite3/sql.sig
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/sql.sig	2007-02-17 14:43:00 UTC (rev 5231)
+++ mltonlib/trunk/ca/terpstra/sqlite3/sql.sig	2007-02-17 15:45:18 UTC (rev 5232)
@@ -189,7 +189,10 @@
             (* get/set auxdata? could be useful *)
          end
       
-      (* SQL.Error exceptions in callbacks are propogated ok. Others not. *)
+      (* SQL.Error exceptions in callbacks are propogated ok. Others not.
+       * If you want to change the method later, do it inside your function.
+       * Once registered, a function stays bound until closeDB.
+       *)
       val registerFunction:  db * string * Function.scalar -> unit
       val registerAggregate: db * string * Function.aggregate -> unit
       val registerCollation: db * string * (string * string -> order) -> unit
@@ -204,6 +207,7 @@
             
             (* Number of prepared queries not yet garbage collected *)
             val preparedQueries: db -> int
+            val registeredFunctions: db -> int
             
             datatype access = ALLOW | DENY | IGNORE
             datatype request =

Modified: mltonlib/trunk/ca/terpstra/sqlite3/sql.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/sql.sml	2007-02-17 14:43:00 UTC (rev 5231)
+++ mltonlib/trunk/ca/terpstra/sqlite3/sql.sml	2007-02-17 15:45:18 UTC (rev 5232)
@@ -1,7 +1,7 @@
 structure SQL :> SQL =
    struct
       type column = Prim.column
-      type db = Query.pool Ring.t
+      type db = { ring: Query.pool Ring.t, hooks: Prim.hook list ref }
       datatype storage = datatype Prim.storage
       
       exception Retry = Prim.Retry
@@ -13,19 +13,20 @@
       
       val version = Prim.version
       
-      fun getDB dbl = 
-         case Ring.get dbl of { db, query=_, available=_, used } => 
+      fun getDB { ring, hooks=_ } = 
+         case Ring.get ring of { db, query=_, available=_, used } => 
          if !used = ~1 then raise Error "Database closed" else db
       
-      fun openDB file = 
-         Ring.new { db = Prim.openDB file,
-                    query = "database",
-                    available = ref [],
-                    used = ref 0 }
+      fun openDB file = {
+         ring = Ring.new { db = Prim.openDB file,
+                           query = "database",
+                           available = ref [],
+                           used = ref 0 },
+         hooks = ref [] }
       
-      fun closeDB dbl = 
+      fun closeDB (dbh as { ring, hooks }) = 
          let
-            val db = getDB dbl (* raises if closed *)
+            val db = getDB dbh (* raises if closed *)
             fun notInUse { db=_, query=_, available=_, used } = !used = 0
             
             val exn = ref NONE
@@ -38,8 +39,12 @@
                available := [];
                used := ~1)
          in
-            if Ring.fold (fn (l, a) => notInUse l andalso a) true dbl
-            then (Ring.app close dbl; reraise (!exn); Prim.closeDB db)
+            if Ring.fold (fn (l, a) => notInUse l andalso a) true ring
+            then (Ring.app close ring; 
+                  reraise (!exn); 
+                  Prim.closeDB db;
+                  List.app Prim.unhook (!hooks);
+                  hooks := [])
             else raise Error "Database in use"
          end
       
@@ -126,14 +131,14 @@
             end
       end
       
-      fun registerFunction (db, s, (f, i)) = 
-         Prim.createFunction (getDB db, s, f, i)
+      fun registerFunction (db as { ring=_, hooks }, s, (f, i)) = 
+         hooks := Prim.createFunction (getDB db, s, f, i) :: !hooks
          
-      fun registerAggregate (db, s, (a, i)) = 
-         Prim.createAggregate (getDB db, s, a, i)
+      fun registerAggregate (db as { ring=_, hooks }, s, (a, i)) = 
+         hooks := Prim.createAggregate (getDB db, s, a, i) :: !hooks
       
-      fun registerCollation (db, s, c) = 
-         Prim.createCollation (getDB db, s, c)
+      fun registerCollation (db as { ring=_, hooks }, s, c) = 
+         hooks := Prim.createCollation (getDB db, s, c) :: !hooks
       
       structure SQLite = 
          struct
@@ -142,8 +147,10 @@
             val totalChanges = Prim.totalChanges o getDB
             val transactionActive = not o Prim.getAutocommit o getDB
             
-            fun preparedQueries dbl =
-               Ring.fold (fn (_, x) => x + 1) ~1 dbl
+            fun preparedQueries { ring, hooks=_ } =
+               Ring.fold (fn (_, x) => x + 1) ~1 ring
+            fun registeredFunctions { ring=_, hooks } =
+               List.length (!hooks)
             
             datatype access = datatype Prim.access
             datatype request = datatype Prim.request




More information about the MLton-commit mailing list