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/cm/compile/exec.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/compile/exec.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 295 - (view) (download)

1 : blume 295 (*
2 :     * Build an argument for the generic compilation functor.
3 :     * This gives a traversal that executes the code in each node as
4 :     * necessary (and builds the dynamic environment).
5 :     * A traversal requires prior successful traversal using the
6 :     * "RecompFn" functor (using the same persistent state).
7 :     *
8 :     * (C) 1999 Lucent Technologies, Bell Laboratories
9 :     *
10 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
11 :     *)
12 :     functor ExecFn (structure PS : FULL_PERSSTATE) : COMPILATION_TYPE = struct
13 :    
14 :     structure E = GenericVC.Environment
15 :     structure DTS = DynTStamp
16 :     structure DE = GenericVC.DynamicEnv
17 :     structure BF = PS.MachDepVC.Binfile
18 :     structure PP = PrettyPrint
19 :     structure EM = GenericVC.ErrorMsg
20 :    
21 :     type env = { dyn: unit -> E.dynenv, dts: DTS.dts }
22 :     type benv = env
23 :     type envdelta = env
24 :    
25 :     datatype lookstable_result =
26 :     FOUND of envdelta
27 :     | NOTFOUND of benv option
28 :    
29 :     fun layer ({ dyn = d, dts = s }, { dyn = d', dts = s' }) =
30 :     { dyn = fn () => DE.atop (d (), d' ()), dts = DTS.join (s, s') }
31 :    
32 :     fun filter (e, _) = e
33 :     fun nofilter e = e
34 :    
35 :     val blayer = layer
36 :     val bfilter = filter
37 :     val bnofilter = nofilter
38 :    
39 :     fun primitive c p =
40 :     { dyn = fn () => E.dynamicPart (Primitive.env c p),
41 :     dts = DTS.ancient }
42 :    
43 :     fun thunkify { dyn, dts } = { dyn = fn () => dyn, dts = dts }
44 :    
45 :     fun lookstable (i, mkenv) =
46 :     case mkenv () of
47 :     NONE => NOTFOUND NONE
48 :     | SOME (e as { dyn, dts }) =>
49 :     (case PS.exec_look_stable (i, dts) of
50 :     SOME memo => FOUND (thunkify memo)
51 :     | NONE => NOTFOUND (SOME e))
52 :    
53 :     fun execute (bfc, { dyn = mkdyn, dts }, share, error, descr, memo) = let
54 :     val (tryshare, mustshare) =
55 :     case share of
56 :     NONE => (true, false)
57 :     | SOME true => (true, true)
58 :     | SOME false => (false, false)
59 :     fun doit () = let
60 :     val dts' = if tryshare then DTS.current ()
61 :     else DTS.noshare descr
62 :     val e = BF.exec (bfc, mkdyn ())
63 :     val m = { dyn = E.dynamicPart e, dts = DTS.join (dts, dts') }
64 :     in
65 :     memo m;
66 :     SOME (thunkify m)
67 :     end handle exn => let
68 :     fun pphist pps =
69 :     (PP.add_string pps (General.exnMessage exn);
70 :     PP.add_newline pps)
71 :     in
72 :     error "exception in module initialization code" pphist;
73 :     NONE
74 :     end
75 :     in
76 :     if mustshare then
77 :     case DTS.can'tShare dts of
78 :     NONE => doit ()
79 :     | SOME sl => let
80 :     fun pphist [] pps = ()
81 :     | pphist (h :: t) pps =
82 :     (PP.add_string pps h;
83 :     PP.add_newline pps;
84 :     pphist t pps)
85 :     in
86 :     error
87 :     "cannot share state: dependence on non-shareable modules"
88 :     (pphist sl);
89 :     NONE
90 :     end
91 :     else doit ()
92 :     end
93 :    
94 :     fun dostable (i, e, gp) =
95 :     execute (PS.bfc_fetch_stable i, e,
96 :     BinInfo.share i,
97 :     BinInfo.error i EM.COMPLAIN,
98 :     BinInfo.describe i,
99 :     fn m => PS.exec_memo_stable (i, m))
100 :    
101 :     fun looksml (i, { dyn, dts }) =
102 :     Option.map thunkify (PS.exec_look_sml (i, dts))
103 :    
104 :     fun dosml (i, e, gp) =
105 :     execute (PS.bfc_fetch_sml i, e,
106 :     SmlInfo.share i,
107 :     SmlInfo.error i EM.COMPLAIN,
108 :     SmlInfo.name i,
109 :     fn m => PS.exec_memo_sml (i, m))
110 :     end

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