| 1 | signature CLIST = |
| 2 | sig |
| 3 | type t |
| 4 | |
| 5 | val cons: int * t -> t |
| 6 | val sing: int -> t |
| 7 | val sum: t -> int |
| 8 | end |
| 9 | |
| 10 | functor CList (structure F: MLTON_FINALIZABLE |
| 11 | structure P: MLTON_POINTER |
| 12 | structure Prim: |
| 13 | sig |
| 14 | val cons: int * P.t -> P.t |
| 15 | val free: P.t -> unit |
| 16 | val sing: int -> P.t |
| 17 | val sum: P.t -> int |
| 18 | end): CLIST = |
| 19 | struct |
| 20 | type t = P.t F.t |
| 21 | |
| 22 | fun cons (n: int, l: t) = |
| 23 | F.withValue |
| 24 | (l, fn w' => |
| 25 | let |
| 26 | val c = F.new (Prim.cons (n, w')) |
| 27 | val _ = F.addFinalizer (c, Prim.free) |
| 28 | val _ = F.finalizeBefore (c, l) |
| 29 | in |
| 30 | c |
| 31 | end) |
| 32 | |
| 33 | fun sing n = |
| 34 | let |
| 35 | val c = F.new (Prim.sing n) |
| 36 | val _ = F.addFinalizer (c, Prim.free) |
| 37 | in |
| 38 | c |
| 39 | end |
| 40 | |
| 41 | fun sum c = F.withValue (c, Prim.sum) |
| 42 | end |
| 43 | |
| 44 | functor Test (structure CList: CLIST |
| 45 | structure MLton: sig |
| 46 | structure GC: |
| 47 | sig |
| 48 | val collect: unit -> unit |
| 49 | end |
| 50 | end) = |
| 51 | struct |
| 52 | fun f n = |
| 53 | if n = 1 |
| 54 | then () |
| 55 | else |
| 56 | let |
| 57 | val a = Array.tabulate (n, fn i => i) |
| 58 | val _ = Array.sub (a, 0) + Array.sub (a, 1) |
| 59 | in |
| 60 | f (n - 1) |
| 61 | end |
| 62 | |
| 63 | val l = CList.sing 2 |
| 64 | val l = CList.cons (2,l) |
| 65 | val l = CList.cons (2,l) |
| 66 | val l = CList.cons (2,l) |
| 67 | val l = CList.cons (2,l) |
| 68 | val l = CList.cons (2,l) |
| 69 | val l = CList.cons (2,l) |
| 70 | val _ = MLton.GC.collect () |
| 71 | val _ = f 100 |
| 72 | val _ = print (concat ["listSum(l) = ", |
| 73 | Int.toString (CList.sum l), |
| 74 | "\n"]) |
| 75 | val _ = MLton.GC.collect () |
| 76 | val _ = f 100 |
| 77 | end |
| 78 | |
| 79 | structure CList = |
| 80 | CList (structure F = MLton.Finalizable |
| 81 | structure P = MLton.Pointer |
| 82 | structure Prim = |
| 83 | struct |
| 84 | val cons = _import "listCons": int * P.t -> P.t; |
| 85 | val free = _import "listFree": P.t -> unit; |
| 86 | val sing = _import "listSing": int -> P.t; |
| 87 | val sum = _import "listSum": P.t -> int; |
| 88 | end) |
| 89 | |
| 90 | structure S = Test (structure CList = CList |
| 91 | structure MLton = MLton) |