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/cleanup.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 9 - (view) (download)

1 : monnier 2 (* cleanup.sml
2 :     *
3 :     * COPYRIGHT (c) 1997 Bell Labs, Lucent Technologies.
4 :     * COPYRIGHT (c) 1996 AT&T Research.
5 :     *)
6 :    
7 :     structure CleanUp : sig
8 :    
9 :     include CML_CLEANUP
10 :    
11 :     val clean : when -> unit
12 :    
13 :     val exportFnCleanup : unit -> unit
14 :    
15 :     end = struct
16 :    
17 :     datatype when = AtInit | AtInitFn | AtShutdown | AtExit
18 :     (* The CML clean-up times are somewhat different than the SML/NJ
19 :     * times.
20 :     *
21 :     * AtInit initialization of a program that is being run
22 :     * under RunCML.doit.
23 :     * AtInitFn initialization of a stand-alone program that was
24 :     * generated by exportFn.
25 :     * AtShutdown normal program exit of a CML program running
26 :     * under RunCML.doit.
27 :     * AtExit normal program exit of a stand-alone CML program.
28 :     *
29 :     * Note that the clean-up routines run while CML is still active. It
30 :     * may also be useful for an application to register clean-up routines
31 :     * with SML/NJ (AtExportFn actions are the most useful).
32 :     *)
33 :    
34 :     (* at all times *)
35 :     val atAll = [AtExit, AtShutdown, AtInit, AtInitFn]
36 :    
37 :     val hooks = ref ([] : (string * when list * (when -> unit)) list)
38 :    
39 :     local
40 :     structure SV = SyncVar
41 :     val lockV = SV.mVarInit ()
42 :     in
43 :     fun lock () = SV.mTake lockV
44 :     fun unlock () = SV.mPut(lockV, ())
45 :     fun protect f x = if !Running.isRunning
46 :     then let
47 :     val _ = lock()
48 :     val res = (f x) handle ex => (unlock(); raise ex)
49 :     in
50 :     unlock (); res
51 :     end
52 :     else f x
53 :     end (* local *)
54 :    
55 :     (* return the list of hooks that apply at when. *)
56 :     fun filter when = let
57 :     fun f [] = []
58 :     | f ((item as (_, whenLst, _))::r) =
59 :     if (List.exists when whenLst) then item :: (f r) else (f r)
60 :     in
61 :     f (!hooks)
62 :     end
63 :    
64 :     (* apply the clean-up function for the given time. In some cases, this
65 :     * causes the list of hooks to be redefined.
66 :     * NOTE: we reverse the order of application at initialization time.
67 :     *)
68 :     fun clean when = let
69 :     val _ = lock()
70 :     val cleanFns = (case when
71 :     of (AtInit | AtInitFn) => List.rev (filter (fn w => (w = when)))
72 :     | _ => filter (fn w => (w = when))
73 :     (* end case *))
74 :     fun initFnPred AtExit = true
75 :     | initFnPred _ = false
76 :     fun doCleaner (_, _, f) = CML.select [
77 :     CML.joinEvt(CML.spawnc f when),
78 :     CML.timeOutEvt(Time.fromSeconds 1)
79 :     ]
80 : monnier 8 (*DEBUG*
81 :     fun doCleaner (tag, _, f) = (
82 :     Debug.sayDebugTS(concat["do Cleaner \"", tag, "\"\n"]);
83 :     CML.select [
84 :     CML.wrap(CML.joinEvt(CML.spawnc f when), fn _ => Debug.sayDebugTS " done\n"),
85 :     CML.wrap(CML.timeOutEvt(Time.fromSeconds 1), fn _ => Debug.sayDebugTS " timeout\n")
86 :     ])
87 :     *DEBUG*)
88 : monnier 2 in
89 :     (* remove uneccesary clean-up routines *)
90 :     case when
91 :     of AtInitFn => hooks := filter initFnPred
92 :     | _ => ()
93 :     (* end case *);
94 :     unlock();
95 :     (* now apply the clean-up routines *)
96 :     List.app doCleaner cleanFns
97 :     end
98 :    
99 :     (* find and remove the named hook from the hook list; return the hook
100 :     * and the new hook list; if the named hook doesn't exist, then return NONE.
101 :     *)
102 :     fun removeHook name = let
103 :     fun remove [] = NONE
104 :     | remove ((hook as (name', whenLst, cleanFn)) :: r) =
105 :     if (name = name')
106 :     then SOME((whenLst, cleanFn), r)
107 :     else (case (remove r)
108 :     of NONE => NONE
109 :     | SOME(hook', r') => SOME(hook', hook::r')
110 :     (* end case *))
111 :     in
112 :     remove (! hooks)
113 :     end
114 :    
115 :     (* add the named cleaner. This returns the previous definition, or NONE. *)
116 :     fun addCleaner (arg as (name, _, _)) = (case (removeHook name)
117 :     of NONE => (hooks := arg :: !hooks; NONE)
118 :     | (SOME(oldHook, hookLst)) => (
119 :     hooks := arg :: hookLst; SOME oldHook)
120 :     (* end case *))
121 :     val addCleaner = protect addCleaner
122 :    
123 :     (* remove and return the named cleaner; return NONE if it is not found *)
124 :     fun removeCleaner name = (case (removeHook name)
125 :     of NONE => NONE
126 :     | (SOME(oldHook, hookLst)) => (
127 :     hooks := hookLst; SOME oldHook)
128 :     (* end case *))
129 :     val removeCleaner = protect removeCleaner
130 :    
131 :     exception Unlog
132 :    
133 :     datatype item = ITEM of {
134 :     key : string,
135 :     init : unit -> unit,
136 :     shut : unit -> unit
137 :     }
138 :    
139 :     val chanList = ref ([] : item list)
140 :     val mboxList = ref ([] : item list)
141 :     val serverList = ref ([] : item list)
142 :    
143 :     fun unlogItem l name = let
144 :     fun f [] = raise Unlog
145 :     | f ((x as ITEM{key, ...})::r) = if (name = key) then r else (x :: (f r))
146 :     in
147 :     l := f(!l)
148 :     end
149 :    
150 : monnier 8 fun appInit l = List.app (fn ITEM{init, ...} => init()) (List.rev (!l))
151 : monnier 2
152 :     fun unlogAll () = (chanList := []; mboxList := []; serverList := [])
153 :    
154 :     val unlogChannel = protect (unlogItem chanList)
155 :     fun logChannel (name, ch) = let
156 :     fun f () = Channel.resetChan ch
157 :     in
158 :     (unlogChannel name) handle Unlog => ();
159 :     chanList := ITEM{key=name, init=f, shut=f} :: (!chanList)
160 :     end
161 :     val logChannel = fn x => protect logChannel x
162 :    
163 :     val unlogMailbox = protect (unlogItem mboxList)
164 :     fun logMailbox (name, mb) = let
165 :     fun f () = Mailbox.resetMbox mb
166 :     in
167 :     (unlogMailbox name) handle Unlog => ();
168 :     mboxList := ITEM{key=name, init=f, shut=f} :: (!mboxList)
169 :     end
170 :     val logChannel = fn x => protect logChannel x
171 :    
172 :     val unlogServer = protect (unlogItem serverList)
173 :    
174 :     fun logServer (name, f, g) = (
175 :     (unlogServer name) handle Unlog => ();
176 :     serverList := ITEM{key=name, init=f, shut=g} :: (!serverList))
177 :     val logServer = protect logServer
178 :    
179 : monnier 8 fun startServers () = appInit serverList
180 : monnier 2
181 :     fun shutdownServers () = let
182 :     fun shut (ITEM{key, shut, ...}) = CML.select [
183 :     CML.joinEvt(CML.spawn shut),
184 :     CML.timeOutEvt(Time.fromSeconds 2)
185 :     ]
186 :     in
187 :     app shut (!serverList)
188 :     end
189 :    
190 : monnier 8 fun cleanServers (AtInit | AtInitFn) = startServers()
191 :     | cleanServers (AtShutdown | AtExit) = shutdownServers()
192 :    
193 : monnier 2 (* clean the logged channels and mailboxes. *)
194 : monnier 8 fun cleanChannels _ = (appInit chanList; appInit mboxList)
195 : monnier 2
196 : monnier 8 (* Add the standard cleaners *)
197 :     val _ = (
198 :     addCleaner ("Channels&Mailboxes", [AtInit,AtShutdown], cleanChannels);
199 :     addCleaner ("Servers", atAll, cleanServers))
200 : monnier 2
201 :     (* remove useless cleaners and clear the channel/mailbox logs
202 :     * prior to exporting a stand-alone CML program.
203 :     *)
204 :     fun exportFnCleanup () = let
205 :     fun exportFnPred (AtInitFn | AtExit) = true
206 :     | exportFnPred _ = false
207 :     in
208 :     cleanChannels ();
209 :     chanList := []; mboxList := [];
210 :     hooks := filter exportFnPred
211 :     end
212 :    
213 :     end (* CleanUp *)
214 :    

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