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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 399 - (view) (download)

1 : blume 399 local
2 :     structure GP = GeneralParams
3 :     structure DG = DependencyGraph
4 :     structure GG = GroupGraph
5 :     structure E = GenericVC.Environment
6 :     structure DE = DynamicEnv
7 :     structure EM = GenericVC.ErrorMsg
8 :     structure PP = PrettyPrint
9 :    
10 :     type env = E.dynenv
11 :     in
12 :     signature LINK = sig
13 :     val registerGroup : GG.group -> unit
14 :    
15 :     (* Evict value from cache if it exists *)
16 :     val evict : SmlInfo.info -> unit
17 :    
18 :     (* Check all values and evict those that depended on other
19 :     * meanwhile evicted ones. *)
20 :     val cleanup : unit -> unit
21 :    
22 :     val newTraversal : GG.group ->
23 :     { group: GP.info -> env option,
24 :     exports: (GP.info -> env option) SymbolMap.map }
25 :    
26 :     val sysval : GenericVC.PersStamps.persstamp option -> env option
27 :    
28 :     (* discard persistent state *)
29 :     val reset : unit -> unit
30 :     end
31 :    
32 :     functor LinkFn (structure MachDepVC : MACHDEP_VC
33 :     val system_values : env ref) :> LINK = struct
34 :    
35 :     structure BF = MachDepVC.Binfile
36 :    
37 :     type bfun = GP.info -> E.dynenv -> E.dynenv
38 :    
39 :     datatype bnode =
40 :     B of bfun * bnode list
41 :    
42 :     val stablemap = ref (StableMap.empty: bnode StableMap.map)
43 :    
44 :     val emptyStatic = E.staticPart E.emptyEnv
45 :     val emptyDyn = E.dynamicPart E.emptyEnv
46 :    
47 :     fun sysval NONE = NONE
48 :     | sysval (SOME pid) =
49 :     SOME (DynamicEnv.bind (pid,
50 :     DynamicEnv.look (!system_values) pid,
51 :     DynamicEnv.empty))
52 :     handle DynamicEnv.Unbound => NONE
53 :    
54 :     fun execute (bfc, de, error, descr) = let
55 :     fun exec () = let
56 :     val e = BF.exec (bfc, de)
57 :     in
58 :     E.dynamicPart e
59 :     end handle exn => let
60 :     fun ppb pps =
61 :     (PP.add_newline pps;
62 :     PP.add_string pps (General.exnMessage exn);
63 :     PP.add_newline pps)
64 :     in
65 :     error ("link-time error in " ^ descr) ppb;
66 :     raise exn
67 :     end
68 :     in
69 :     case sysval (BF.exportPidOf bfc) of
70 :     NONE => exec ()
71 :     | SOME de => de
72 :     end
73 :    
74 :     fun memoize thunk = let
75 :     val r = ref (fn _ => raise Fail "Link:memoize")
76 :     fun firsttime gp = let
77 :     val v = thunk gp
78 :     in
79 :     r := (fn _ => v);
80 :     v
81 :     end
82 :     in
83 :     r := firsttime;
84 :     fn gp => !r gp
85 :     end
86 :    
87 :     fun registerGroup g = let
88 :     val GG.GROUP { grouppath, kind, sublibs, ... } = g
89 :     val visited = ref SrcPathSet.empty
90 :     fun registerStableLib (GG.GROUP { exports, ... }) = let
91 :     val localmap = ref StableMap.empty
92 :     fun link (i, e) = let
93 :     val stable = BinInfo.stablename i
94 :     val os = BinInfo.offset i
95 :     val descr = BinInfo.describe i
96 :     val _ = Say.vsay ["[linking with ", descr, "]\n"]
97 :     fun work s =
98 :     (Seek.seek (s, os);
99 :     (* We can use an empty static env because no
100 :     * unpickling will be done. *)
101 :     BF.read { stream = s, name = descr,
102 :     senv = emptyStatic })
103 :     (* We handle no errors here because failure to load a
104 :     * stable library module is serious and should lead to
105 :     * a complete abort (which it does if we don't do something
106 :     * about it). *)
107 :     val bfc = SafeIO.perform { openIt =
108 :     fn () => BinIO.openIn stable,
109 :     closeIt = BinIO.closeIn,
110 :     work = work,
111 :     cleanup = fn () => () }
112 :     val epid = BF.exportPidOf bfc
113 :     in
114 :     execute (bfc, e, BinInfo.error i EM.COMPLAIN, descr)
115 :     end
116 :     fun bn (DG.PNODE p) =
117 :     B (fn (gp: GP.info) => fn _ =>
118 :     E.dynamicPart (Primitive.env
119 :     (#primconf (#param gp)) p),
120 :     [])
121 :     | bn (DG.BNODE n) = let
122 :     val { bininfo = i, localimports, globalimports } = n
123 :     fun new () = let
124 :     val e0 = (fn (gp: GP.info) =>
125 :     E.dynamicPart (#pervasive (#param gp)),
126 :     [])
127 :     fun join (B (f, []), (e, l)) =
128 :     (fn gp => DE.atop (f gp emptyDyn, e gp), l)
129 :     | join (b, (e, l)) = (e, b :: l)
130 :     val ge = foldl join e0 (map fbn globalimports)
131 :     val le = foldl join ge (map bn localimports)
132 :     in
133 :     case (BinInfo.sh_mode i, le) of
134 :     (Sharing.SHARE _, (e, [])) => let
135 :     fun thunk gp = link (i, e gp)
136 :     val m_thunk = memoize thunk
137 :     in
138 :     B (fn gp => fn _ => m_thunk gp, [])
139 :     end
140 :     | (Sharing.SHARE _, _) =>
141 :     EM.impossible "Link: sh_mode inconsistent"
142 :     | (Sharing.DONTSHARE, (e, l)) =>
143 :     B (fn gp => fn e' =>
144 :     link (i, (DE.atop (e', e gp))),
145 :     l)
146 :     end
147 :     in
148 :     case StableMap.find (!stablemap, i) of
149 :     SOME x => x
150 :     | NONE =>
151 :     (case StableMap.find (!localmap, i) of
152 :     SOME x => x
153 :     | NONE => let
154 :     val x = new ()
155 :     in
156 :     localmap :=
157 :     StableMap.insert (!localmap, i, x);
158 :     x
159 :     end)
160 :     end
161 :    
162 :     and fbn (_, n) = bn n
163 :    
164 :     fun sbn (DG.SB_SNODE n) =
165 :     EM.impossible "Link:SNODE in stable lib"
166 :     | sbn (DG.SB_BNODE (DG.PNODE _, _)) = ()
167 :     | sbn (DG.SB_BNODE (n as DG.BNODE b, _)) = let
168 :     val x = bn n
169 :     val i = #bininfo b
170 :     in
171 :     stablemap := StableMap.insert (!stablemap, i, x)
172 :     end
173 :    
174 :     fun fsbn (_, n) = sbn n
175 :     fun impexp (n, _) = fsbn n
176 :     in
177 :     SymbolMap.app impexp exports
178 :     end
179 :     in
180 :     if SrcPathSet.member (!visited, grouppath) then ()
181 :     else (visited := SrcPathSet.add (!visited, grouppath);
182 :     app registerGroup sublibs;
183 :     case kind of
184 :     GG.STABLELIB => registerStableLib g
185 :     | _ => ())
186 :     end
187 :    
188 :     type smemo = E.dynenv * SmlInfo.info list
189 :    
190 :     val smlmap = ref (SmlInfoMap.empty: smemo SmlInfoMap.map)
191 :    
192 :     fun evict i = (smlmap := #1 (SmlInfoMap.remove (!smlmap, i)))
193 :     handle LibBase.NotFound => ()
194 :    
195 :     fun cleanup () = let
196 :     val visited = ref SmlInfoSet.empty
197 :     fun visit i =
198 :     if SmlInfoSet.member (!visited, i) then true
199 :     else
200 :     case SmlInfoMap.find (!smlmap, i) of
201 :     NONE => false
202 :     | SOME (_, l) => let
203 :     val bl = map visit l
204 :     val b = List.all (fn x => x) bl
205 :     in
206 :     if b then
207 :     (visited := SmlInfoSet.add (!visited, i);
208 :     true)
209 :     else (evict i; false)
210 :     end
211 :     in
212 :     app (visit o #1) (SmlInfoMap.listItemsi (!smlmap))
213 :     end
214 :    
215 :     fun newTraversal group = let
216 :     in
217 :     Dummy.f ()
218 :     end
219 :    
220 :     fun reset () = (stablemap := StableMap.empty;
221 :     smlmap := SmlInfoMap.empty)
222 :     end
223 :     end

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