Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/cml/src/core-cml/thread.sml
ViewVC logotype

Annotation of /sml/trunk/src/cml/src/core-cml/thread.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1325 - (view) (download)

1 : monnier 8 (* thread.sml
2 : monnier 2 *
3 :     * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :     * COPYRIGHT (c) 1989-1991 John H. Reppy
5 :     *)
6 :    
7 :     structure Thread : sig
8 :     include THREAD
9 :     val defaultExnHandler : (exn -> unit) ref
10 :     val reset : bool -> unit
11 :     end = struct
12 :    
13 :     structure R = RepTypes
14 :     structure S = Scheduler
15 :    
16 : monnier 8 datatype thread_id = datatype R.thread_id
17 :     datatype cvar = datatype R.cvar
18 :     datatype cvar_state = datatype R.cvar_state
19 : monnier 2
20 :     type 'a event = 'a R.event
21 :    
22 :     local
23 :     val tidCount = ref 0
24 :     fun cvar () = CVAR(ref(CVAR_unset []))
25 :     in
26 :    
27 :     fun reset running = (
28 :     tidCount := 0;
29 :     S.reset running)
30 :    
31 :     fun exnHandler (exn : exn) = ()
32 :    
33 :     val defaultExnHandler = ref exnHandler
34 :    
35 :     fun newTId () = let val n = !tidCount
36 :     in
37 :     tidCount := n+1;
38 :     TID{
39 :     id = n,
40 :     alert = ref false,
41 :     done_comm = ref false,
42 :     exnHandler = ref(! defaultExnHandler),
43 : jhr 1325 props = ref[],
44 : monnier 2 dead = cvar()
45 :     }
46 :     end
47 :     end (* local *)
48 :    
49 :     fun sameTid (TID{id=a, ...}, TID{id=b, ...}) = (a = b)
50 :    
51 :     fun compareTid (TID{id=a, ...}, TID{id=b, ...}) = Int.compare(a, b)
52 :    
53 :     fun hashTid (TID{id, ...}) = Word.fromInt id
54 :    
55 : monnier 8 val tidToString = R.tidToString
56 : monnier 2
57 :     fun notifyAndDispatch (TID{dead, ...}) = (
58 :     S.atomicBegin(); Event.atomicCVarSet dead; S.atomicDispatch())
59 :    
60 :     fun doHandler (TID{exnHandler, ...}, exn) =
61 :     ((!exnHandler) exn) handle _ => ()
62 :    
63 :     (** Eventually, this should be:
64 :     fun spawnc f x = let
65 :     val _ = S.atomicBegin()
66 :     val id = newTId()
67 :     fun thread () = (
68 :     (f x) handle ex => doHandler(id, ex);
69 :     notifyAndDispatch id)
70 :     in
71 :     SMLofNJ.Cont.callcc (fn parentK => (
72 :     S.enqueueAndSwitchCurThread(parentK, id);
73 :     S.atomicEnd();
74 :     SMLofNJ.Cont.throw (SMLofNJ.Cont.isolate thread) ()));
75 :     id
76 :     end
77 :     **)
78 :     fun spawnc f x = let
79 :     val _ = S.atomicBegin()
80 :     val id = newTId()
81 :     in
82 :     SMLofNJ.Cont.callcc (fn parentK => (
83 :     S.enqueueAndSwitchCurThread(parentK, id);
84 :     S.atomicEnd();
85 :     (f x) handle ex => doHandler(id, ex);
86 :     notifyAndDispatch id));
87 :     id
88 :     end
89 :    
90 :     fun spawn f = spawnc f ()
91 :    
92 :     fun joinEvt (TID{dead, ...}) = Event.cvarGetEvt dead
93 :    
94 :     val getTid = S.getCurThread
95 :    
96 : jhr 1325 fun exit () = let
97 :     val (tid as TID{props, ...}) = getTid()
98 :     in
99 :     props := [];
100 :     notifyAndDispatch tid
101 :     end
102 : monnier 2
103 :     fun yield () = SMLofNJ.Cont.callcc (fn k => (
104 :     S.atomicBegin();
105 :     S.atomicYield k))
106 :    
107 : jhr 1325 (* thread-local data *)
108 :     local
109 :     fun mkProp () = let
110 :     exception E of 'a
111 :     fun cons (a, l) = E a :: l
112 :     fun peek [] = NONE
113 :     | peek (E a :: _) = SOME a
114 :     | peek (_ :: l) = peek l
115 :     fun delete [] = []
116 :     | delete (E a :: r) = r
117 :     | delete (x :: r) = x :: delete r
118 :     in
119 :     { cons = cons, peek = peek, delete = delete }
120 :     end
121 :     fun mkFlag () = let
122 :     exception E
123 :     fun peek [] = false
124 :     | peek (E :: _) = true
125 :     | peek (_ :: l) = peek l
126 :     fun set (l, flg) = let
127 :     fun set ([], _) = if flg then E::l else l
128 :     | set (E::r, xs) = if flg then l else List.revAppend(xs, r)
129 :     | set (x::r, xs) = set (r, x::xs)
130 :     in
131 :     set (l, [])
132 :     end
133 :     in
134 :     { set = set, peek = peek }
135 :     end
136 :     fun getProps () = let val TID{props, ...} = getTid() in props end
137 :     in
138 :     fun newThreadProp (init : unit -> 'b) = let
139 :     val {peek, cons, delete} = mkProp()
140 :     fun peekFn () = peek(!(getProps()))
141 :     fun getF () = let
142 :     val h = getProps()
143 :     in
144 :     case peek(!h)
145 :     of NONE => let val b = init() in h := cons(b, !h); b end
146 :     | (SOME b) => b
147 :     (* end case *)
148 :     end
149 :     fun clrF () = let
150 :     val h = getProps()
151 :     in
152 :     h := delete(!h)
153 :     end
154 :     fun setFn x = let
155 :     val h = getProps()
156 :     in
157 :     h := cons(x, delete(!h))
158 :     end
159 :     in
160 :     {peekFn = peekFn, getFn = getF, clrFn = clrF, setFn = setFn}
161 :     end
162 :    
163 :     fun newThreadFlag () = let
164 :     val {peek, set} = mkFlag()
165 :     fun getF ()= peek(!(getProps()))
166 :     fun setF flg = let
167 :     val h = getProps()
168 :     in
169 :     h := set(!h, flg)
170 :     end
171 :     in
172 :     {getFn = getF, setFn = setF}
173 :     end
174 :     end (* local *)
175 :    
176 : monnier 2 end;

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0