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

SCM Repository

[smlnj] Diff of /sml/trunk/src/cm/compile/concur.sml
ViewVC logotype

Diff of /sml/trunk/src/cm/compile/concur.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 453, Tue Oct 26 06:24:34 1999 UTC revision 454, Wed Oct 27 04:41:14 1999 UTC
# Line 21  Line 21 
21    
22      val fork : (unit -> 'a) -> 'a cond  (* termination condition with value *)      val fork : (unit -> 'a) -> 'a cond  (* termination condition with value *)
23      val wait : 'a cond -> 'a      val wait : 'a cond -> 'a
24        val wait' : int -> 'a cond -> 'a
25      val inputReady : TextIO.instream -> unit cond      val inputReady : TextIO.instream -> unit cond
26      val ucond : unit -> unit cond      val ucond : unit -> unit cond
27      val signal : unit cond -> unit      val signal : unit cond -> unit
# Line 31  Line 32 
32    
33  structure Concur :> CONCUR = struct  structure Concur :> CONCUR = struct
34    
35      type tstate = unit SMLofNJ.Cont.cont      type tstate = unit SMLofNJ.Cont.cont * int
36    
37      datatype 'a cstate =      datatype 'a cstate =
38          Arrived of 'a                   (* value *)          Arrived of 'a                   (* value *)
# Line 39  Line 40 
40    
41      type 'a cond = 'a cstate ref      type 'a cond = 'a cstate ref
42    
43      type 'a queue = ('a list * 'a list) ref      (* simple and brain-dead priority queue *)
44        type task_queue = tstate list ref
45    
46      fun enqueue (x, q as ref (front, back)) = q := (front, x :: back)      fun enqueue (x as (_, xu), qr as ref q) = let
47            fun insert [] = [x]
48              | insert ((h as (_, hu)) :: r) =
49                if xu > hu then x :: h :: r else h :: insert r
50        in
51            qr := insert q
52        end
53    
54      fun dequeue (ref ([], [])) = NONE      fun dequeue (ref []) = NONE
55        | dequeue (q as ref (x :: front, back)) = (q := (front, back); SOME x)        | dequeue (qr as ref (h :: t)) = (qr := t; SOME h)
       | dequeue (q as ref ([], back)) = (q := (rev back, []); dequeue q)  
56    
57      val runable : tstate queue = ref ([], [])      val runable : task_queue = ref []
58      val inputs = ref ([]: (unit cond * OS.IO.poll_desc) list)      val inputs = ref ([]: (unit cond * OS.IO.poll_desc) list)
59    
60      fun reset () = (runable := ([], []); inputs := [])      fun reset () = (runable := []; inputs := [])
61    
62      (* we heavily favor non-I/O conditions, but that's ok for our purposes *)      (* we heavily favor non-I/O conditions, but that's ok for our purposes *)
63    
# Line 89  Line 96 
96                          (Say.say                          (Say.say
97                           ["schedule_inputs failed to wake anybody up!\n"];                           ["schedule_inputs failed to wake anybody up!\n"];
98                           raise Fail "concur")                           raise Fail "concur")
99                    | SOME ts => SMLofNJ.Cont.throw ts ()                    | SOME (ts, _) => SMLofNJ.Cont.throw ts ()
100              end              end
101    
102      fun schedule () =      fun schedule () =
103          case dequeue runable of          case dequeue runable of
104              NONE => schedule_inputs ()              NONE => schedule_inputs ()
105            | SOME ts => SMLofNJ.Cont.throw ts ()            | SOME (ts, _) => SMLofNJ.Cont.throw ts ()
106    
107      fun wait (ref (Arrived x)) = x      fun wait' _ (ref (Arrived x)) = x
108        | wait (c as ref (Waiting tsl)) =        | wait' u (c as ref (Waiting tsl)) =
109          (SMLofNJ.Cont.callcc (fn ts => (c := Waiting (ts :: tsl);          (SMLofNJ.Cont.callcc (fn ts => (c := Waiting ((ts, u) :: tsl);
110                                          schedule ()));                                          schedule ()));
111           wait c)           wait' u c)
112    
113        fun wait c = wait' 0 c
114    
115      fun fork worker = let      fun fork worker = let
116          val c = ref (Waiting [])          val c = ref (Waiting [])
117      in      in
118          SMLofNJ.Cont.callcc (fn return =>          SMLofNJ.Cont.callcc (fn return =>
119            (SMLofNJ.Cont.callcc (fn ts => (enqueue (ts, runable);            (SMLofNJ.Cont.callcc (fn ts => (enqueue ((ts, 0), runable);
120                                            SMLofNJ.Cont.throw return c));                                            SMLofNJ.Cont.throw return c));
121             wakeup (c, worker ());             wakeup (c, worker ());
122             schedule ()))             schedule ()))

Legend:
Removed from v.453  
changed lines
  Added in v.454

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