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/benchmarks/todo/cml-sieve/run.sml
ViewVC logotype

Annotation of /sml/trunk/benchmarks/todo/cml-sieve/run.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 193 - (view) (download)

1 : monnier 193 (* run.sml
2 :     *
3 :     * COPYRIGHT (c) 1990 by John H. Reppy. See COPYRIGHT file for details.
4 :     *
5 :     * Code to support top-level interactive use of CML.
6 :     *)
7 :    
8 :     signature RUN_CML =
9 :     sig
10 :    
11 :     structure CML : CONCUR_ML
12 :    
13 :     (* log/unlog channels and servers for initialization and termination *)
14 :     exception Unlog
15 :     val logChannel : (string * 'a CML.chan) -> unit
16 :     val unlogChannel : string -> unit
17 :     val logServer : (string * (unit -> unit) * (unit -> unit)) -> unit
18 :     val unlogServer : string -> unit
19 :     val unlogAll : unit -> unit
20 :    
21 :     (* run the system *)
22 :     val doit : ((unit -> unit) * int option) -> unit
23 :     exception Running
24 :    
25 :     (* export a CML program *)
26 :     val exportFn : (string * ((string list * string list) -> unit) * int option)
27 :     -> unit
28 :    
29 :     (* shutdown a run *)
30 :     val shutdown : unit -> 'a
31 :     exception NotRunning
32 :    
33 :     end (* RUN_CML *)
34 :    
35 :     functor RunCML (CML : INTERNAL_CML) : RUN_CML =
36 :     struct
37 :    
38 :     exception Unlog
39 :    
40 :     local
41 :     datatype item = ITEM of {
42 :     key : string,
43 :     init : unit -> unit,
44 :     shut : unit -> unit
45 :     }
46 :     val chanList = ref ([] : item list)
47 :     val serverList = ref ([] : item list)
48 :     fun unlogItem l name = let
49 :     fun f [] = raise Unlog
50 :     | f ((x as ITEM{key, ...})::r) = if (name = key) then r else (x :: (f r))
51 :     in
52 :     l := f(!l)
53 :     end
54 :     fun appInit l () = revapp (fn ITEM{init, ...} => init()) (!l)
55 :     in
56 :     fun unlogAll () = (chanList := []; serverList := [])
57 :    
58 :     val unlogChannel = unlogItem chanList
59 :     fun logChannel(name, ch) = let
60 :     fun f () = CML.resetChan ch
61 :     in
62 :     (unlogChannel name) handle Unlog => ();
63 :     chanList := ITEM{key=name, init=f, shut=f} :: (!chanList)
64 :     end
65 :    
66 :     val unlogServer = unlogItem serverList
67 :     fun logServer (name, f, g) = (
68 :     (unlogServer name) handle Unlog => ();
69 :     serverList := ITEM{key=name, init=f, shut=g} :: (!serverList))
70 :     fun cleanChannels () = (CML.resetChan CML.errCh; appInit chanList ())
71 :     val startServers = appInit serverList
72 :     fun shutdownServers () = let
73 :     fun shut (ITEM{key, shut, ...}) = CML.sync (CML.choose [
74 :     CML.threadWait(CML.spawn shut),
75 :     CML.wrap(CML.timeout(CML.TIME{sec=5, usec=0}),
76 :     fn () => CML.reportError("shutdown "^key^" timeout"))
77 :     ])
78 :     in
79 :     app shut (!serverList)
80 :     end
81 :     end (* local *)
82 :    
83 :     (* run the system *)
84 :     local
85 :     val setitimer = System.Unsafe.CInterface.setitimer
86 :     val running = ref false
87 :     fun msToTime NONE = NONE
88 :     | msToTime (SOME t) = SOME(
89 :     if t < 10
90 :     then CML.TIME{sec=0, usec=10000}
91 :     else CML.TIME{sec=(t quot 1000), usec=((t rem 1000)*1000)})
92 :     in
93 :    
94 :     exception Running
95 :     fun doit (initialProc, timeq) = let
96 :     open System.Signals
97 :     val _ = if (!running) then raise Running else ();
98 :     val saveHdlr = inqHandler SIGINT
99 :     val tq = msToTime timeq
100 :     in
101 :     callcc (fn done => (
102 :     setHandler(SIGINT,
103 :     SOME(fn _ => (CML.reportError "\nInterrupt"; CML.restartTimer(); done)));
104 :     CML.initQueues ();
105 :     cleanChannels ();
106 :     CML.shutdown := throw done;
107 :     running := true;
108 :     CML.timerOn tq;
109 :     startServers();
110 :     CML.spawn initialProc;
111 :     CML.exit()));
112 :     (* here on shutdown or ^C *)
113 :     setHandler(SIGINT, saveHdlr);
114 :     shutdownServers ();
115 :     CML.timerOff();
116 :     cleanChannels ();
117 :     running := false
118 :     end
119 :    
120 :     fun exportFn (name, f, timeq) = let
121 :     fun cmd args = doit (fn () => (f args), timeq)
122 :     in
123 :     IO.exportFn (name, cmd)
124 :     end
125 :    
126 :     exception NotRunning
127 :     fun shutdown () = (if !running then (!CML.shutdown)() else (); raise NotRunning)
128 :    
129 :     (* hook our termination code into the SML/NJ shutdown facility *)
130 :     val _ = let open System.Unsafe.CleanUp
131 :     fun clean CleanForQuit = if !running
132 :     then (shutdownServers(); CML.timerOff(); running := false)
133 :     else ()
134 :     | clean _ = ()
135 :     in
136 :     addCleaner ("ConcurML", clean)
137 :     end
138 :    
139 :     end (* local *)
140 :    
141 :     structure CML : CONCUR_ML = CML
142 :    
143 :     end (* functor RunCML *)

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