regression/mutex.sml

   1 open Posix.Signal MLton.Signal
   2
   3 fun for (start, stop, f) =
   4    let
   5       fun loop i =
   6          if i >= stop
   7             then ()
   8          else (f i; loop (i + 1))
   9    in
  10       loop start
  11    end
  12
  13 structure Queue:
  14    sig
  15       type 'a t
  16
  17       val new: unit -> 'a t
  18       val enque: 'a t * 'a -> unit
  19       val deque: 'a t -> 'a option
  20    end =
  21    struct
  22       datatype 'a t = T of {front: 'a list ref, back: 'a list ref}
  23
  24       fun new () = T {front = ref [], back = ref []}
  25
  26       fun enque (T {back, ...}, x) = back := x :: !back
  27
  28       fun deque (T {front, back}) =
  29          case !front of
  30             [] => (case !back of
  31                       [] => NONE
  32                     | l => let val l = rev l
  33                            in case l of
  34                               [] => raise Fail "deque"
  35                             | x :: l => (back := []; front := l; SOME x)
  36                            end)
  37           | x :: l => (front := l; SOME x)
  38    end
  39
  40 structure Thread:
  41    sig
  42       val exit: unit -> 'a
  43       val run: unit -> unit
  44       val spawn: (unit -> unit) -> unit
  45       val yield: unit -> unit
  46       structure Mutex:
  47          sig
  48             type t
  49
  50             val new: unit -> t
  51             val lock: t -> unit
  52             val unlock: t -> unit
  53          end
  54    end =
  55    struct
  56       open MLton
  57       open Itimer Signal Thread
  58
  59       val topLevel: Thread.Runnable.t option ref = ref NONE
  60
  61       local
  62          val threads: Thread.Runnable.t Queue.t = Queue.new ()
  63       in
  64          fun ready t = Queue.enque (threads, t)
  65          fun next () : Thread.Runnable.t =
  66             case Queue.deque threads of
  67                NONE => valOf (!topLevel)
  68              | SOME t => t
  69       end
  70
  71       fun 'a exit (): 'a = switch (fn _ =>
  72                                    (print "exiting\n"
  73                                     ; next ()))
  74
  75       fun new (f: unit -> unit): Thread.Runnable.t =
  76          Thread.prepare
  77          (Thread.new (fn () => ((f () handle _ => exit ())
  78                                 ; exit ())),
  79           ())
  80
  81       fun schedule t = (ready t; next ())
  82
  83       fun yield (): unit = switch (fn t => schedule (Thread.prepare (t, ())))
  84
  85       val spawn = ready o new
  86
  87       fun setItimer t =
  88          Itimer.set (Itimer.Real,
  89                      {value = t,
  90                       interval = t})
  91
  92       fun run (): unit =
  93          (switch (fn t =>
  94                   (topLevel := SOME (Thread.prepare (t, ()))
  95                    ; new (fn () =>
  96                           (setHandler (alrm, Handler.handler schedule)
  97                            ; setItimer (Time.fromMilliseconds 10)))))
  98           ; setItimer Time.zeroTime
  99           ; setHandler (alrm, Handler.ignore)
 100           ; topLevel := NONE)
 101
 102       structure Mutex =
 103          struct
 104             datatype t = T of {locked: bool ref,
 105                                waiting: unit Thread.t Queue.t}
 106
 107             fun new () =
 108                T {locked = ref false,
 109                   waiting = Queue.new ()}
 110
 111             fun lock (T {locked, waiting, ...}) =
 112                let
 113                   fun loop () =
 114                      (Thread.atomicBegin ()
 115                       ; if !locked
 116                            then (Thread.atomicEnd ()
 117                                  ; switch (fn t =>
 118                                            (Queue.enque (waiting, t)
 119                                             ; next ()))
 120                                  ; loop ())
 121                         else (locked := true
 122                               ; Thread.atomicEnd ()))
 123                in loop ()
 124                end
 125
 126             fun safeUnlock (T {locked, waiting, ...}) =
 127                (locked := false
 128                 ; (case Queue.deque waiting of
 129                       NONE => ()
 130                     | SOME t => ready (Thread.prepare (t,()))))
 131
 132             fun unlock (m: t) =
 133                (Thread.atomicBegin ()
 134                 ; safeUnlock m
 135                 ; Thread.atomicEnd ())
 136          end
 137    end
 138
 139 open Thread
 140
 141 fun main (name, args) =
 142    let
 143       val m = Mutex.new ()
 144       val gotIt = ref false
 145       val _ =
 146          for (0, 10, fn _ =>
 147               Thread.spawn
 148               (fn () =>
 149                let
 150                   val _ = print "starting\n"
 151                   fun loop i =
 152                      if i = 0
 153                         then ()
 154                      else (Mutex.lock m
 155                            ; if !gotIt
 156                                 then raise Fail "bug"
 157                              else (gotIt := true
 158                                    ; for (0, 100000, fn _ => ())
 159                                    ; gotIt := false
 160                                    ; Mutex.unlock m
 161                                    ; loop (i - 1)))
 162                in loop 10000
 163                end))
 164    in
 165       run ()
 166    end
 167
 168 val _ = main ( CommandLine.name (), CommandLine.arguments () )