basis-library/util/one.sml

   1 (* Copyright (C) 2006-2006 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  *
   4  * MLton is released under a BSD-style license.
   5  * See the file MLton-LICENSE for details.
   6  *)
   7
   8 structure One:
   9    sig
  10       type 'a t
  11
  12       val make: (unit -> 'a) -> 'a t
  13       val use: 'a t * ('a -> 'b) -> 'b
  14    end =
  15    struct
  16       datatype 'a t = T of {more: unit -> 'a,
  17                             static: 'a,
  18                             staticIsInUse: bool ref}
  19
  20       fun make f = T {more = f,
  21                       static = f (),
  22                       staticIsInUse = ref false}
  23
  24       fun use (T {more, static, staticIsInUse}, f) =
  25          let
  26             val () = Primitive.MLton.Thread.atomicBegin ()
  27             val b = ! staticIsInUse
  28             val d =
  29                if b then
  30                   (Primitive.MLton.Thread.atomicEnd ();
  31                    more ())
  32                else
  33                   (staticIsInUse := true;
  34                    Primitive.MLton.Thread.atomicEnd ();
  35                    static)
  36         in
  37            DynamicWind.wind (fn () => f d,
  38                              fn () => if b then () else staticIsInUse := false)
  39         end
  40    end