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/glue/run-cml-fn.sml
ViewVC logotype

Annotation of /sml/trunk/src/cml/src/glue/run-cml-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 9 - (view) (download)

1 : monnier 2 (* run-cml-fn.sml
2 :     *
3 :     * COPYRIGHT (c) 1996 AT&T Research.
4 :     * COPYRIGHT (c) 1989-1991 John H. Reppy
5 :     *)
6 :    
7 :     functor RunCMLFn (G : OS_GLUE) : sig
8 :    
9 :     val doit : ((unit -> unit) * Time.time option) -> OS.Process.status
10 :    
11 :     val isRunning : unit -> bool
12 :    
13 :     val shutdown : OS.Process.status -> 'a
14 :    
15 :     val exportFn :
16 :     (string * (string * string list -> OS.Process.status) * Time.time option)
17 :     -> unit
18 :    
19 :     include CML_CLEANUP
20 :    
21 :     end = struct
22 :    
23 :     structure S = Scheduler
24 :     structure Sig = Signals
25 :     structure CU = CleanUp
26 :    
27 :     structure E = ExportFnFn (G);
28 :    
29 :     open CU
30 :    
31 :     val runningFlg = Running.isRunning
32 :    
33 :     fun isRunning () = !runningFlg
34 :    
35 :     fun shutdown sts = if !runningFlg
36 :     then SMLofNJ.Cont.throw (! S.shutdownHook) (true, sts)
37 :     else raise Fail "CML is not running"
38 :    
39 :    
40 :     val interruptK : unit SMLofNJ.Cont.cont =
41 :     SMLofNJ.Cont.isolate (fn _ => shutdown OS.Process.failure)
42 :    
43 :     fun doit (initialProc, tq) = let
44 :     val saveIntHandler = Sig.inqHandler Sig.sigINT
45 :     val savePrintFn = !SMLofNJ.Internals.prHook
46 :     val _ = (
47 :     if !runningFlg
48 :     then raise Fail "CML is already running"
49 :     else runningFlg := true;
50 :     Thread.reset true;
51 :     G.init();
52 :     S.schedulerHook := E.pollK;
53 :     S.pauseHook := E.pauseK)
54 :     val (cleanUp, sts) = SMLofNJ.Cont.callcc (fn doneK => (
55 :     ignore (
56 :     Sig.setHandler (Sig.sigINT, Sig.HANDLER(fn _ => interruptK)));
57 :     S.shutdownHook := doneK;
58 :     case tq of (SOME tq) => S.startTimer tq | _ => S.restartTimer();
59 :     CU.clean CU.AtInit;
60 :     CML.spawn initialProc;
61 : monnier 8 S.dispatch()))
62 : monnier 2 in
63 :     CU.clean CU.AtShutdown;
64 :     G.shutdown();
65 :     S.stopTimer();
66 :     Thread.reset false;
67 :     runningFlg := false;
68 :     SMLofNJ.Internals.prHook := savePrintFn;
69 :     ignore (Sig.setHandler (Sig.sigINT, saveIntHandler));
70 :     sts
71 :     end
72 :    
73 :     type cmdt = (string, string list) E.pair -> OS.Process.status
74 :     val exportFn' : (string * cmdt) -> unit =
75 :     Unsafe.CInterface.c_function "SMLNJ-RunT" "exportFn"
76 :    
77 :     fun exportFn (fileName, main, timeQ) = (
78 :     if !runningFlg
79 :     then raise Fail "Cannot exportFn while CML is running"
80 :     else runningFlg := true;
81 :     Signals.maskSignals Signals.MASKALL;
82 :     (* run the SML/NJ AtExportFn cleaners to eliminate space-leaks *)
83 :     SMLofNJ.Internals.CleanUp.clean SMLofNJ.Internals.CleanUp.AtExportFn;
84 :     (* strip out any unecessary stuff from the CML Cleanup state. *)
85 :     CU.exportFnCleanup ();
86 :     (* unlink the SML print function *)
87 :     SMLofNJ.Internals.prHook := (fn _ => ());
88 :     (* unlink the perv structure *)
89 :     Unsafe.pStruct := Unsafe.Object.toObject ();
90 :     (* now export the wrapped main function *)
91 :     exportFn' (fileName, E.wrapForExport (main, timeQ)))
92 :    
93 :     end

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