2 * 2004 Matthew
Fluet (mfluet@acm
.org
)
3 * Ported to MLton threads
.
8 * COPYRIGHT (c
) 1995 AT
&T Bell Laboratories
.
9 * COPYRIGHT (c
) 1989-1991 John H
. Reppy
12 structure Thread
: THREAD
=
14 structure Assert
= LocalAssert(val assert
= false)
15 structure Debug
= LocalDebug(val debug
= false)
17 structure S
= Scheduler
18 fun debug msg
= Debug
.sayDebug ([S
.atomicMsg
, S
.tidMsg
], msg
)
19 fun debug
' msg
= debug (fn () => msg
)
23 fun generalExit (tid
', clr
') =
25 val () = Assert
.assertNonAtomic
' "Thread.generalExit"
26 val () = debug
' "generalExit" (* NonAtomic
*)
27 val () = Assert
.assertNonAtomic
' "Thread.generalExit"
32 val tid
as TID
{dead
, props
, ...} = S
.getThreadId t
33 val () = Assert
.assert ([], fn () =>
34 concat
["Thread.generalExit ",
35 Option
.getOpt (Option
.map tidToString tid
', "NONE"),
37 tidToString tid
], fn () =>
38 case tid
' of NONE
=> true
39 | SOME tid
' => sameTid (tid
', tid
))
40 val () = if clr
' then props
:= [] else ()
41 val () = Event
.atomicCVarSet dead
47 fun doHandler (TID
{exnHandler
, ...}, exn
) =
48 (debug (fn () => concat
["Exception: ", exnName exn
, " : ", exnMessage exn
])
49 ; ((!exnHandler
) exn
) handle _
=> ())
53 val () = S
.atomicBegin ()
55 ((f x
) handle ex
=> doHandler (tid
, ex
)
56 ; generalExit (SOME tid
, false))
58 val tid
= S
.getThreadId t
59 val () = S
.ready (S
.prep t
)
60 val () = S
.atomicEnd ()
61 val () = debug (fn () => concat
["spawnc ", tidToString tid
]) (* NonAtomic
*)
65 fun spawn f
= spawnc
f ()
67 fun joinEvt (TID
{dead
, ...}) = Event
.cvarGetEvt dead
69 val getTid
= S
.getCurThreadId
73 val () = Assert
.assertNonAtomic
' "Thread.exit"
74 val () = debug
' "exit" (* NonAtomic
*)
75 val () = Assert
.assertNonAtomic
' "Thread.exit"
77 generalExit (NONE
, true)
82 val () = Assert
.assertNonAtomic
' "Thread.yield"
83 val () = debug
' "yield" (* NonAtomic
*)
84 val () = Assert
.assertNonAtomic
' "Thread.yield"
86 S
.readyAndSwitchToNext (fn () => ())
89 (* thread
-local data
*)
94 fun cons (a
, l
) = E a
:: l
96 |
peek (E a
:: _
) = SOME a
97 |
peek (_
:: l
) = peek l
99 |
delete (E _
:: r
) = r
100 |
delete (x
:: r
) = x
:: delete r
110 |
peek (E
:: _
) = true
111 |
peek (_
:: l
) = peek l
114 fun set ([], _
) = if flg
then E
::l
else l
115 |
set (E
::r
, xs
) = if flg
then l
else List.revAppend(xs
, r
)
116 |
set (x
::r
, xs
) = set (r
, x
::xs
)
125 let val TID
{props
, ...} = getTid ()
129 fun newThreadProp (init
: unit
-> 'b
) =
131 val {peek
, cons
, delete
} = mkProp()
132 fun peekFn () = peek(!(getProps()))
134 let val h
= getProps()
137 NONE
=> let val b
= init()
138 in h
:= cons(b
, !h
); b
143 let val h
= getProps()
147 let val h
= getProps()
148 in h
:= cons(x
, delete(!h
))
157 fun newThreadFlag () =
159 val {peek
, set
} = mkFlag()
160 fun getF ()= peek(!(getProps()))
162 let val h
= getProps()