[MLton-commit] r5218
Wesley Terpstra
wesley at mlton.org
Fri Feb 16 08:38:20 PST 2007
free space used by aggregates. use state in place
----------------------------------------------------------------------
U mltonlib/trunk/ca/terpstra/sqlite3/buffer.sig
U mltonlib/trunk/ca/terpstra/sqlite3/buffer.sml
U mltonlib/trunk/ca/terpstra/sqlite3/function.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-16 15:23:37 UTC (rev 5217)
+++ mltonlib/trunk/ca/terpstra/sqlite3/buffer.sig 2007-02-16 16:38:20 UTC (rev 5218)
@@ -5,6 +5,5 @@
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-16 15:23:37 UTC (rev 5217)
+++ mltonlib/trunk/ca/terpstra/sqlite3/buffer.sml 2007-02-16 16:38:20 UTC (rev 5218)
@@ -1,22 +1,50 @@
structure Buffer :> BUFFER =
struct
- type 'a t = 'a option array ref * int ref
+ (* Use a smaller int type to allow representation optimization *)
+ structure IntX = Int30
+ type intx = IntX.int
- fun empty () = (ref (Array.tabulate (32, fn _ => NONE)), ref 0)
+ datatype 'a free = FREE of intx | FULL of 'a
+ type 'a t = { buf: 'a free array ref, free: int ref }
- fun subOpt ((a, s), i) = if i >= !s then NONE else Array.sub (!a, i)
- fun sub (a, i) = valOf (subOpt (a, i))
+ fun empty () = {
+ buf = ref (Array.tabulate (32, fn i => FREE (IntX.fromInt (i-1)))),
+ free = ref 31 }
- fun double (a, s) =
- a := Array.tabulate (!s * 2, fn i => subOpt ((a, s), i))
+ fun subOpt ({ buf, free=_ }, i) =
+ if i >= Array.length (!buf) then NONE else
+ case Array.sub (!buf, i) of
+ FREE _ => NONE
+ | FULL x => SOME x
- fun push ((a, s), v) = (
- if !s = Array.length (!a) then double (a, s) else ();
- Array.update (!a, !s, SOME v);
- !s before s := !s + 1
- )
+ fun sub (b, i) = valOf (subOpt (b, i))
- fun update ((a, _), i, v) = Array.update (!a, i, SOME v)
+ fun double { buf, free } =
+ let
+ val oldlen = Array.length (!buf)
+ val newlen = oldlen * 2
+ fun get i = if i = oldlen then FREE ~1 else
+ if i > oldlen then FREE (IntX.fromInt (i-1)) else
+ Array.sub (!buf, i)
+ val () = buf := Array.tabulate (newlen, get)
+ in
+ free := newlen-1
+ end
- fun free ((a, _), i) = () (* !!! fixme !!! *)
+ fun push (b as { buf, free }, v) = (
+ if !free = ~1 then double b else ();
+ case Array.sub (!buf, !free) of
+ FULL _ => raise Fail "Buggy free list in Buffer.push"
+ | FREE n => (
+ Array.update (!buf, !free, FULL v);
+ !free before free := IntX.toInt n + 1))
+
+ fun free ({ buf, free }, i) = (
+(*
+ case Array.sub (!buf, i) of
+ FREE _ => raise "Free of unused space in Buffer.free"
+ | FULL _ =>
+*)
+ Array.update (!buf, i, FREE (IntX.fromInt (!free)));
+ free := i)
end
Modified: mltonlib/trunk/ca/terpstra/sqlite3/function.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/function.sml 2007-02-16 15:23:37 UTC (rev 5217)
+++ mltonlib/trunk/ca/terpstra/sqlite3/function.sml 2007-02-16 16:38:20 UTC (rev 5218)
@@ -1,7 +1,7 @@
structure Function =
struct
type scalar = (Prim.context * Prim.value vector -> unit) * int
- type aggregate = Prim.aggregate * int
+ type aggregate = (unit -> Prim.aggregate) * int
type ('a, 'b, 'c) folder = {
init: unit -> 'a,
@@ -39,22 +39,17 @@
fun fnN z = fnMap Prim.resultN z
fun aggrMap r = Fold.fold ((iI0, iF0, iN0),
- fn (iI, iF, _) => fn { init, step, finish } =>
- let
- fun finish1 c = r (c, finish (init ()))
- fun step1 x =
- let
- val acc = ref (init ())
- fun stepX (_, v) =
- (acc := step (!acc, iF v);
- Prim.AGGREGATE (stepX, finishX))
- and finishX c = r (c, finish (!acc))
- in
- stepX x
- end
- in
- (Prim.AGGREGATE (step1, finish1), iI)
- end)
+ fn (iI, iF, _) =>
+ fn { init, step, finish } =>
+ (fn () =>
+ let
+ val a = ref (init ())
+ fun finalX c = r (c, finish (!a))
+ fun stepX (_, v) = a := step (!a, iF v)
+ in
+ { step = stepX, final = finalX }
+ end,
+ iI))
fun aggrB z = aggrMap Prim.resultB z
fun aggrR z = aggrMap Prim.resultR z
fun aggrI z = aggrMap Prim.resultI z
Modified: mltonlib/trunk/ca/terpstra/sqlite3/prim.sig
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/prim.sig 2007-02-16 15:23:37 UTC (rev 5217)
+++ mltonlib/trunk/ca/terpstra/sqlite3/prim.sig 2007-02-16 16:38:20 UTC (rev 5218)
@@ -79,9 +79,9 @@
val resultS: context * string -> unit
val resultX: context * storage -> unit
- datatype aggregate =
- AGGREGATE of (context * value vector -> aggregate) * (context -> unit)
+ 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 * aggregate * int -> unit
+ val createAggregate: db * string * (unit -> aggregate) * int -> unit
end
Modified: mltonlib/trunk/ca/terpstra/sqlite3/prim.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/prim.sml 2007-02-16 15:23:37 UTC (rev 5217)
+++ mltonlib/trunk/ca/terpstra/sqlite3/prim.sml 2007-02-16 16:38:20 UTC (rev 5218)
@@ -290,11 +290,11 @@
fnCallbackPtr, FnPtr.null, FnPtr.null))
(************************************************* Aggregate functions *)
- datatype aggregate =
- AGGREGATE of (Context.t * Value.t vector -> aggregate) *
- (Context.t -> unit)
- val aginit = Buffer.empty ()
- val agstep = Buffer.empty ()
+ type aggregate = {
+ step: Context.t * Value.t vector -> unit,
+ final: Context.t -> unit }
+ val aggen = Buffer.empty ()
+ val agtbl = Buffer.empty ()
fun fetchAggr context =
let
val magic = 0wxa72b (* new records are zero, we mark them magic *)
@@ -303,24 +303,24 @@
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 ig = Word.toInt (Puser_data context)
+ val ag = Buffer.sub (aggen, ig) ()
+ val it = Buffer.push (agtbl, ag)
val () = MLton.Pointer.setWord32 (ptr, 0, magic)
- val () = MLton.Pointer.setWord32 (ptr, 1, Word32.fromInt ids)
+ val () = MLton.Pointer.setWord32 (ptr, 1, Word32.fromInt it)
in
- ids
+ it
end
end
fun agStepCallback (context, numargs, args) =
let
- val ids = fetchAggr context
+ val it = 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 AGGREGATE (step, _) = Buffer.sub (agstep, ids)
+ val { step, final=_ } = Buffer.sub (agtbl, it)
in
- Buffer.update (agstep, ids, step (context, args))
+ step (context, args)
handle Error x => error ("fatal: " ^ x)
handle Retry x => error ("retry: " ^ x)
handle Abort x => error ("abort: " ^ x)
@@ -328,16 +328,16 @@
end
fun agFinalCallback context =
let
- val ids = fetchAggr context
+ val it = fetchAggr context
fun error s = Presult_error (context, CStr.fromString s, String.size s)
- val AGGREGATE (_, final) = Buffer.sub (agstep, ids)
+ val { step=_, final } = Buffer.sub (agtbl, it)
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)
+ Buffer.free (agtbl, it)
end
val () = _export "mlton_sqlite3_uagstep" : (Context.t * int * MLton.Pointer.t -> unit) -> unit;
agStepCallback
@@ -346,9 +346,9 @@
val agStepCallbackPtr = _address "mlton_sqlite3_uagstep" : FnPtr.t;
val agFinalCallbackPtr = _address "mlton_sqlite3_uagfinal" : FnPtr.t;
- fun createAggregate (db, name, aggr, n) =
+ fun createAggregate (db, name, gen, n) =
code (db, Pcreate_function (db, CStr.fromString name, n, 1,
- Word.fromInt (Buffer.push (aginit, aggr)),
+ Word.fromInt (Buffer.push (aggen, gen)),
FnPtr.null, agStepCallbackPtr, agFinalCallbackPtr))
(************************************************* Collation functions *)
More information about the MLton-commit
mailing list