doc/examples/finalizable/finalizable.sml

   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)