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/IO/clean-io.sml
ViewVC logotype

Annotation of /sml/trunk/src/cml/src/IO/clean-io.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 651 - (view) (download)

1 : monnier 2 (* clean-io.sml
2 :     *
3 :     * COPYRIGHT (c) 1997 Bell Labs, Lucent Technologies.
4 :     * COPYRIGHT (c) 1996 AT&T Research.
5 :     *
6 :     * This module keeps track of open I/O streams, and handles the proper
7 :     * cleaning of them. It is a modified version of the SML/NJ module
8 :     * of the same name (in boot/IO/clean-io.sml). Unlike the SML/NJ version,
9 :     * we only do cleanup at shutdown/exit time (we do not try to support the
10 :     * persistence of CML streams across invocations of RunCML.doit), and only
11 :     * require a single clean-up function (this flushes the standard streams,
12 :     * and closes all others). These operations should only be called while
13 :     * CML is running, since they use synchronization primitives.
14 :     *
15 :     * NOTE: there is currently a problem with removing the cleaners for streams
16 :     * that get dropped by the application, but the system limit on open files
17 :     * will limit this.
18 :     *
19 :     *)
20 :    
21 :     structure CleanIO :> sig
22 :    
23 :     type tag
24 :    
25 :     val osInitHook : (unit -> unit) ref
26 :     (* this function gets invoked as the first action during the IO
27 :     * initialization. It is meant to support any OS specific initialization
28 :     * that might be necessary.
29 :     *)
30 :    
31 :     val stdStrmHook : (unit -> unit) ref
32 :     (* this function is defined in TextIOFn, and is called after the osHook.
33 :     * It is used to rebuild the standard streams.
34 :     *)
35 :    
36 :     val addCleaner : (unit -> unit) -> tag
37 :    
38 :     val rebindCleaner : (tag * (unit -> unit)) -> unit
39 :    
40 :     val removeCleaner : tag -> unit
41 :    
42 :     end = struct
43 :    
44 :     structure SV = SyncVar
45 :    
46 :     type tag = unit ref
47 :    
48 :     type cleaner = {
49 :     tag : tag, (* unique ID for this cleaner *)
50 :     close : unit -> unit (* called AtExit and AtShutdown *)
51 :     }
52 :    
53 :     val osInitHook = ref(fn () => ())
54 :     val stdStrmHook = ref(fn () => ())
55 :    
56 :     val cleaners = SV.mVarInit ([] : cleaner list)
57 :    
58 :     fun addCleaner close = let
59 :     val tag = ref()
60 :     val cleanerRec = {tag = tag, close = close}
61 :     in
62 :     SV.mPut (cleaners, cleanerRec :: SV.mTake cleaners);
63 :     tag
64 :     end
65 :    
66 :     fun getTag ({tag, ...} : cleaner) = tag
67 :    
68 :     fun rebindCleaner (t, close) = let
69 :     fun f [] = raise Fail "rebindCleaner: tag not found"
70 :     | f (x :: r) = let
71 :     val t' = getTag x
72 :     in
73 :     if (t' = t)
74 :     then {tag=t, close=close} :: r
75 :     else x :: f r
76 :     end
77 :     in
78 :     SV.mPut (cleaners, f (SV.mTake cleaners))
79 :     end
80 :    
81 :     fun removeCleaner t = let
82 :     fun f [] = [] (* should we raise an exception here? *)
83 :     | f (x :: r) = if (getTag x = t) then r else x :: f r
84 :     in
85 :     SV.mPut (cleaners, f (SV.mTake cleaners))
86 :     end
87 :    
88 :     fun doClean () = let
89 :     fun doit [] = ()
90 :     | doit ({tag, close}::r) = ((close()) handle _ => (); doit r)
91 :     in
92 :     doit (SV.mGet cleaners)
93 :     end
94 :    
95 :     structure C = CleanUp
96 :    
97 :     fun cleanUp (C.AtShutdown | C.AtExit) = doClean ()
98 :     | cleanUp (C.AtInit | C.AtInitFn) = (
99 :     (!osInitHook)();
100 :     (!stdStrmHook)())
101 :    
102 :     val _ = C.addCleaner ("IO", C.atAll, cleanUp)
103 :    
104 :     end (* CleanIO *)
105 :    

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