Commit | Line | Data |
---|---|---|
7f918cf1 CE |
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 () ) |