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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (view) (download)

1 : monnier 2 (* export-fn-fn.sml
2 :     *
3 :     * COPYRIGHT (c) 1997 Bell Labs, Lucent Technologies.
4 :     * COPYRIGHT (c) 1989-1991 John H. Reppy
5 :     *)
6 :    
7 :     functor ExportFnFn (G : OS_GLUE) : sig
8 :    
9 :     val pollK : unit SMLofNJ.Cont.cont
10 :     val pauseK : unit SMLofNJ.Cont.cont
11 :    
12 :     datatype ('a, 'b) pair = PAIR of ('a * 'b)
13 :    
14 :     val wrapForExport :
15 :     (((string * string list) -> OS.Process.status) * Time.time option)
16 :     -> (string, string list) pair
17 :     -> OS.Process.status
18 :    
19 :     end = struct
20 :    
21 :     structure S = Scheduler
22 :     structure CU = CleanUp
23 :     structure Cont = SMLofNJ.Cont
24 :    
25 :     val pollK : unit Cont.cont = Cont.isolate (fn _ => (
26 :     S.atomicBegin();
27 :     G.pollOS();
28 :     S.atomicDispatch()))
29 :    
30 :     val pauseK : unit Cont.cont = Cont.isolate (fn _ => (
31 :     S.atomicBegin();
32 :     (* first, we poll the OS to schedule any ready threads *)
33 :     G.pollOS();
34 :     (* check for ready threads orelse pause *)
35 :     if (not (Q.isEmpty S.rdyQ1) orelse G.pause())
36 :     then S.atomicDispatch()
37 :     else (
38 :     S.atomicEnd();
39 :     Cont.throw (! S.shutdownHook) (true, OS.Process.failure))))
40 :    
41 :     datatype ('a, 'b) pair = PAIR of ('a * 'b)
42 :     type cmdt = (string, string list) pair -> OS.Process.status
43 :     val exportFn' : (string * cmdt) -> unit =
44 :     Unsafe.CInterface.c_function "SMLNJ-RunT" "exportFn"
45 :    
46 :     fun wrapForExport (f, tq) (PAIR args) = let
47 :     val _ = (
48 :     SMLofNJ.Internals.initSigTbl ();
49 :     Thread.reset true;
50 :     G.init();
51 :     S.schedulerHook := pollK;
52 :     S.pauseHook := pauseK)
53 :     fun initialProc () =
54 :     OS.Process.exit(f args handle _ => OS.Process.failure)
55 :     val (cleanUp, sts) = Cont.callcc (fn doneK => (
56 :     S.shutdownHook := doneK;
57 :     case tq of (SOME tq) => S.startTimer tq | _ => S.restartTimer();
58 :     CU.startServers();
59 :     CU.clean CU.AtInitFn;
60 :     CML.spawn initialProc;
61 :     CML.exit ()))
62 :     in
63 :     CU.clean CU.AtExit;
64 :     CU.shutdownServers();
65 :     G.shutdown();
66 :     S.stopTimer();
67 :     Thread.reset false;
68 :     sts
69 :     end
70 :    
71 :     end

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