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 303 - (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 :     functor FullPersstateFn (structure MachDepVC : MACHDEP_VC) :> FULL_PERSSTATE =
9 :     struct
10 : blume 301 structure E = GenericVC.Environment
11 :    
12 : blume 303 type env = GenericVC.Environment.dynenv
13 : blume 301
14 : blume 303 datatype ord_key =
15 :     SML of SmlInfo.info
16 :     | STABLE of BinInfo.info
17 : blume 301
18 : blume 303 fun compare (SML _, STABLE _) = LESS
19 :     | compare (STABLE _, SML _) = GREATER
20 :     | compare (SML i, SML i') = SmlInfo.compare (i, i')
21 :     | compare (STABLE i, STABLE i') = BinInfo.compare (i, i')
22 :    
23 :     structure Map =
24 :     BinaryMapFn (struct
25 :     type ord_key = ord_key
26 :     val compare = compare
27 :     end)
28 :    
29 :     val persmap = ref (Map.empty: env Map.map)
30 :     val tmpmap = ref (Map.empty: env Map.map)
31 :    
32 : blume 295 local
33 : blume 303 fun discard_value i =
34 :     persmap := (#1 (Map.remove (!persmap, SML i)))
35 :     handle LibBase.NotFound => ()
36 :    
37 : blume 295 structure RecompPersstate =
38 :     RecompPersstateFn (structure MachDepVC = MachDepVC
39 : blume 301 val discard_code = false
40 :     val discard_value = discard_value)
41 : blume 295 in
42 :     open RecompPersstate
43 : blume 301 end
44 : blume 295
45 : blume 301 infix o' o''
46 :     fun (f o' g) (x, y) = f (g x, y)
47 :     fun (f o'' g) (x, y, z) = f (g x, y, z)
48 : blume 295
49 : blume 301 fun share (SML i) = SmlInfo.share i
50 :     | share (STABLE i) = BinInfo.share i
51 : blume 295
52 : blume 303 fun exec_look (k, newCtxt, gp) = let
53 :     fun error (SML i) = SmlInfo.error gp i
54 :     | error (STABLE i) = BinInfo.error gp i
55 :     fun descr (SML i) = SmlInfo.name i
56 :     | descr (STABLE i) = BinInfo.describe i
57 :     fun didExist () = isSome (Map.find (!persmap, k))
58 :     fun warn_reinst () =
59 :     if share k = SOME true andalso didExist () then
60 :     error k GenericVC.ErrorMsg.WARN
61 :     (concat ["re-instantiating ", descr k,
62 :     " (sharing may be lost)"])
63 :     GenericVC.ErrorMsg.nullErrorBody
64 :     else ()
65 :     in
66 :     case Map.find (!tmpmap, k) of
67 :     NONE =>
68 :     if newCtxt then (warn_reinst (); NONE)
69 :     else (case Map.find (!persmap, k) of
70 :     NONE => NONE
71 :     | SOME e =>
72 :     if share k = SOME false then
73 :     (persmap := #1 (Map.remove (!persmap, k));
74 :     NONE)
75 :     else SOME (e, false))
76 :     | SOME e => SOME (e, true)
77 :     end
78 : blume 295
79 : blume 303 val exec_look_sml = exec_look o'' SML
80 :     val exec_look_stable = exec_look o'' STABLE
81 : blume 302
82 : blume 303 fun exec_memo (k, e) = tmpmap := Map.insert (!tmpmap, k, e)
83 : blume 295
84 : blume 301 val exec_memo_sml = exec_memo o' SML
85 :     val exec_memo_stable = exec_memo o' STABLE
86 : blume 302
87 : blume 303 fun rememberShared () = let
88 :     fun retainShared (k, e, m) =
89 :     if share k = SOME false then m else Map.insert (m, k, e)
90 : blume 302 in
91 : blume 303 persmap := Map.foldli retainShared (!persmap) (!tmpmap);
92 :     tmpmap := Map.empty
93 : blume 302 end
94 : blume 295 end

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