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

Annotation of /sml/trunk/src/cm/compile/full-persstate-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 387 - (view) (download)

1 : blume 295 (*
2 :     * Build a new "full" persistent state.
3 :     *
4 :     * (C) 1999 Lucent Technologies, Bell Laboratories
5 :     *
6 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :     *)
8 : blume 360 local
9 :     structure E = GenericVC.Environment
10 :     structure EM = GenericVC.ErrorMsg
11 :     structure PP = PrettyPrint
12 : blume 362 structure DynE = DynamicEnv
13 : blume 360
14 :     type env = GenericVC.Environment.dynenv
15 :     in
16 :     functor FullPersstateFn (structure MachDepVC : MACHDEP_VC
17 : blume 372 val system_values: env ref) :>
18 :     FULL_PERSSTATE where MachDepVC = MachDepVC =
19 : blume 295 struct
20 : blume 360 type env = env
21 : blume 301
22 : blume 303 datatype ord_key =
23 :     SML of SmlInfo.info
24 :     | STABLE of BinInfo.info
25 : blume 301
26 : blume 303 fun compare (SML _, STABLE _) = LESS
27 :     | compare (STABLE _, SML _) = GREATER
28 :     | compare (SML i, SML i') = SmlInfo.compare (i, i')
29 :     | compare (STABLE i, STABLE i') = BinInfo.compare (i, i')
30 :    
31 : blume 320 structure K = struct
32 :     type ord_key = ord_key
33 :     val compare = compare
34 :     end
35 : blume 303
36 : blume 320 structure Map = BinaryMapFn (K)
37 :    
38 :     structure Set = BinarySetFn (K)
39 :    
40 :     type persentry = env * Set.set ref
41 :     type tmpentry = env * ord_key list
42 :    
43 : blume 372 type ts = tmpentry Map.map ref
44 :    
45 : blume 320 val persmap = ref (Map.empty: persentry option Map.map)
46 :    
47 : blume 372 fun start () = ref Map.empty
48 :    
49 : blume 387 fun sh_mode (SML i) = SmlInfo.sh_mode i
50 :     | sh_mode (STABLE i) = BinInfo.sh_mode i
51 : blume 320
52 :     fun discard (k, m) =
53 :     case Map.find (m, k) of
54 :     NONE => m
55 :     | SOME NONE => m
56 :     | SOME (SOME (_, ref dl)) =>
57 :     Set.foldl discard (Map.insert (m, k, NONE)) dl
58 :    
59 :     fun discard_pers i = persmap := discard (i, !persmap)
60 :    
61 : blume 362 fun sysval NONE = NONE
62 :     | sysval (SOME pid) =
63 :     SOME (DynE.bind (pid, DynE.look (!system_values) pid,
64 :     DynE.empty))
65 :     handle DynE.Unbound => NONE
66 : blume 360
67 : blume 362 fun stable_value_present (i, popt) =
68 :     isSome (sysval popt) orelse isSome (Map.find (!persmap, STABLE i))
69 : blume 360
70 : blume 295 local
71 :     structure RecompPersstate =
72 :     RecompPersstateFn (structure MachDepVC = MachDepVC
73 : blume 301 val discard_code = false
74 : blume 362 val stable_value_present =
75 :     stable_value_present
76 :     val new_smlinfo = discard_pers o SML)
77 : blume 361 val reset_recomp = RecompPersstate.reset
78 : blume 363 val transfer_state_recomp = RecompPersstate.transfer_state
79 : blume 295 in
80 :     open RecompPersstate
81 : blume 361 fun reset () =
82 :     (reset_recomp ();
83 : blume 372 persmap := Map.empty)
84 : blume 363 fun transfer_state (si, bi) =
85 :     (transfer_state_recomp (si, bi);
86 :     discard_pers (SML si))
87 : blume 301 end
88 : blume 295
89 : blume 320 infix o'
90 : blume 372 fun (f o' g) (x, y, z, w) = f (g x, y, z, w)
91 : blume 295
92 : blume 372 fun exec_look (k, gp, popt, tmpmap: ts) = let
93 : blume 354 fun descr (SML i) = SmlInfo.descr i
94 : blume 320 | descr (STABLE i) = BinInfo.describe i
95 : blume 303 fun error (SML i) = SmlInfo.error gp i
96 : blume 306 | error (STABLE i) = BinInfo.error i
97 : blume 303 in
98 : blume 362 case sysval popt of
99 :     SOME e => SOME e
100 :     | NONE =>
101 :     (case Map.find (!tmpmap, k) of
102 :     NONE =>
103 :     (case Map.find (!persmap, k) of
104 :     NONE => NONE
105 :     | SOME NONE =>
106 : blume 387 (case sh_mode k of
107 :     Sharing.SHARE true =>
108 : blume 372 error k EM.WARN
109 :     (concat ["re-instantiating ",
110 :     descr k,
111 :     " (sharing may be lost)"])
112 :     EM.nullErrorBody
113 :     | _ => ();
114 :     NONE)
115 : blume 362 | SOME (SOME (e, _)) =>
116 : blume 387 (case sh_mode k of
117 :     Sharing.DONTSHARE =>
118 : blume 372 (discard_pers k; NONE)
119 :     | _ => SOME e))
120 : blume 362 | SOME (e, _) => SOME e)
121 : blume 303 end
122 : blume 295
123 : blume 320 val exec_look_sml = exec_look o' SML
124 :     val exec_look_stable = exec_look o' STABLE
125 : blume 302
126 : blume 372 fun exec_memo (k, e, d, tmpmap: ts) =
127 :     tmpmap := Map.insert (!tmpmap, k, (e, d))
128 : blume 295
129 : blume 372 fun exec_memo_sml (i, e, sl, bl, tmpmap) =
130 :     exec_memo (SML i, e, map STABLE bl @ map SML sl, tmpmap)
131 : blume 302
132 : blume 372 fun exec_memo_stable (i, e, il, tmpmap) =
133 :     exec_memo (STABLE i, e, map STABLE il, tmpmap)
134 : blume 320
135 : blume 372 fun finish (tmpmap: ts) = let
136 :     (* We keep non-shared bindings in tmpmap; this is necessary for
137 :     * those partial traversals that the autoloader does.
138 :     * Non-shared bindings will eventually go away when the
139 :     * traversal state is dropped. *)
140 :     fun retainShared (k, (e, d), (pm, tm)) = let
141 :     val m = discard (k, pm)
142 : blume 320 in
143 : blume 387 case sh_mode k of
144 :     Sharing.DONTSHARE => (pm, Map.insert (tm, k, (e, d)))
145 : blume 372 | _ => (Map.insert (m, k, SOME (e, ref Set.empty)), tm)
146 : blume 320 end
147 : blume 372 val pm = !persmap
148 :     val tm = !tmpmap
149 :     val (pm', tm') = Map.foldli retainShared (pm, Map.empty) tm
150 : blume 320 fun addDep (k, (e, d)) = let
151 :     fun addOneDep k' =
152 : blume 372 case Map.find (pm', k') of
153 : blume 320 NONE => ()
154 :     | SOME NONE => ()
155 :     | SOME (SOME (_, r as ref s)) => r := Set.add (s, k)
156 :     in
157 :     app addOneDep d
158 :     end
159 : blume 302 in
160 : blume 372 tmpmap := tm';
161 :     persmap := pm';
162 : blume 320 Map.appi addDep tm
163 : blume 302 end
164 : blume 295 end
165 : blume 360 end

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