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

Parent Directory | Revision Log

---

Revision 298 - (view) (download)

1 :	blume	295	(*
2 :			* Build an argument for the generic compilation functor.
3 :			* This gives a traversal that loads from binfiles, stable archives,
4 :			* or compiles sml source code. The "binfile content" cache gets
5 :			* warmed up that way, too. (The "ExecFn" functor takes advantage of
6 :			* this fact.)
7 :			*
8 :			* (C) 1999 Lucent Technologies, Bell Laboratories
9 :			*
10 :			* Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
11 :			*)
12 :			functor RecompFn (structure PS : RECOMP_PERSSTATE) : COMPILATION_TYPE = struct
13 :
14 :			structure MachDepVC = PS.MachDepVC
15 :			structure E = GenericVC.Environment
16 :			structure PID = GenericVC.PersStamps
17 :			structure BF = MachDepVC.Binfile
18 :	blume	297	structure PP = PrettyPrint
19 :			structure EM = GenericVC.ErrorMsg
20 :	blume	295
21 :			type pid = PID.persstamp
22 :
23 :			type statenv = E.staticEnv
24 :			type symenv = E.symenv
25 :
26 :			type benv = statenv
27 :			type env = { stat: statenv, sym: symenv, pids: PidSet.set }
28 :
29 :			type 'e wpid = 'e * pid
30 :
31 :			type envdelta = { stat: statenv wpid, sym: symenv wpid, ctxt: statenv }
32 :
33 :			type memorecord = { bfc: BF.bfContent, ctxt: statenv }
34 :
35 :			structure FilterMap = BinaryMapFn
36 :			(struct
37 :			type ord_key = pid * SymbolSet.set
38 :			fun compare ((u, f), (u', f')) =
39 :			case PID.compare (u, u') of
40 :			EQUAL => SymbolSet.compare (f, f')
41 :			| unequal => unequal
42 :			end)
43 :
44 :			(* persistent state! *)
45 :			val filtermap = ref (FilterMap.empty: pid FilterMap.map)
46 :
47 :			fun blayer (be, be') = E.layerStatic (be, be')
48 :
49 :			fun layer ({ stat, sym, pids }, { stat = stat', sym = sym', pids = p' }) =
50 :			{ stat = E.layerStatic (stat, stat'),
51 :			sym = E.layerSymbolic (sym, sym'),
52 :			pids = PidSet.union (pids, p') }
53 :
54 :			fun bfilter (d: envdelta, s) =
55 :			E.filterStaticEnv (#1 (#stat d), SymbolSet.listItems s)
56 :
57 :			fun pidset (p1, p2) =
58 :			PidSet.add (PidSet.singleton p1, p2)
59 :
60 :			fun filter (d, s) = let
61 :			val stat = bfilter (d, s)
62 :			val (sym, sympid) = #sym d
63 :			val statpid = #2 (#stat d)
64 :			val ctxt = #ctxt d
65 :			val key = (statpid, s)
66 :			val statpid' =
67 :			case FilterMap.find (!filtermap, key) of
68 :			SOME statpid' => statpid'
69 :			| NONE => let
70 :			val statpid' = GenericVC.MakePid.makePid (ctxt, stat)
71 :			in
72 :			filtermap := FilterMap.insert (!filtermap, key, statpid');
73 :			statpid'
74 :			end
75 :			in
76 :			{ stat = stat, sym = sym, pids = pidset (statpid', sympid) }
77 :			end
78 :
79 :			fun bnofilter (d: envdelta) = #1 (#stat d)
80 :
81 :			fun nofilter (d: envdelta) = let
82 :			val (stat, statpid) = #stat d
83 :			val (sym, sympid) = #sym d
84 :			in
85 :			{ stat = stat, sym = sym, pids = pidset (statpid, sympid) }
86 :			end
87 :
88 :			fun primitive c p = let
89 :			val e = Primitive.env c p
90 :			val { statpid, sympid, ctxt } = Primitive.pidInfo c p
91 :			in
92 :			{ stat = (E.staticPart e, statpid),
93 :			sym = (E.symbolicPart e, sympid),
94 :			ctxt = ctxt }
95 :			end
96 :
97 :			fun memo2envdelta { bfc, ctxt } =
98 :			{ stat = (BF.senvOf bfc, BF.staticPidOf bfc),
99 :			sym = (BF.symenvOf bfc, BF.lambdaPidOf bfc),
100 :			ctxt = ctxt }
101 :
102 :	blume	298	fun dostable (i, mkenv, gp) = let
103 :			fun load be = let
104 :			val fnp = #fnpolicy gp
105 :			val stable = FilenamePolicy.mkStablePath fnp (BinInfo.group i)
106 :			val os = BinInfo.offset i
107 :			val descr = BinInfo.describe i
108 :			val _ = Say.vsay (concat ["[consulting ", descr, "]\n"])
109 :			val s = AbsPath.openBinIn stable
110 :			fun load () = let
111 :			val _ = Seek.seek (s, os)
112 :			val bfc = BF.read { stream = s, name = descr, senv = be,
113 :			keep_code = true }
114 :			val memo = { bfc = bfc, ctxt = be }
115 :			in
116 :			BinIO.closeIn s;
117 :			PS.recomp_memo_stable (i, memo);
118 :			memo2envdelta memo
119 :			end
120 :	blume	295	in
121 :	blume	298	SOME (load ()) handle exn => let
122 :			fun pphist pps =
123 :			(PP.add_string pps (General.exnMessage exn);
124 :			PP.add_newline pps)
125 :			in
126 :			BinIO.closeIn s;
127 :			BinInfo.error gp i EM.COMPLAIN
128 :			"unable to load stable library module" pphist;
129 :			NONE
130 :			end
131 :	blume	295	end
132 :			in
133 :	blume	298	case PS.recomp_look_stable i of
134 :			SOME memo => SOME (memo2envdelta memo)
135 :			| NONE =>
136 :			(case mkenv () of
137 :			NONE => NONE
138 :			| SOME be => load be)
139 :	blume	295	end
140 :
141 :	blume	298	fun dosml (i, { stat, sym, pids }, gp) =
142 :			case Option.map memo2envdelta (PS.recomp_look_sml (i, pids, gp)) of
143 :			SOME d => SOME d
144 :			| NONE => let
145 :			val mkBinPath = FilenamePolicy.mkBinPath (#fnpolicy gp)
146 :			val binpath = mkBinPath (SmlInfo.sourcepath i)
147 :			val binname = AbsPath.name binpath
148 :			fun delete () = OS.FileSys.remove binname handle _ => ()
149 :	blume	295
150 :	blume	298	fun save bfc = let
151 :			val s = AbsPath.openBinOut binpath
152 :			fun writer () = BF.write { stream = s, content = bfc,
153 :			keep_code = true }
154 :			in
155 :			Interrupt.guarded writer
156 :			handle exn => (BinIO.closeOut s; raise exn);
157 :			BinIO.closeOut s;
158 :			Say.vsay (concat ["wrote ", binname, "]\n"])
159 :			end handle e as Interrupt.Interrupt => (delete (); raise e)
160 :			| exn => let
161 :			fun pphist pps =
162 :			(PP.add_string pps (General.exnMessage exn);
163 :			PP.add_newline pps)
164 :			in
165 :			delete ();
166 :			SmlInfo.error gp i EM.WARN
167 :			("failed to write " ^ binname) pphist
168 :			end
169 :	blume	297
170 :	blume	298	fun load () = let
171 :			val s = AbsPath.openBinIn binpath
172 :			fun read () = BF.read { stream = s, name = binname,
173 :			senv = stat,keep_code = true }
174 :			in
175 :			SOME (Interrupt.guarded read)
176 :			handle exn => (BinIO.closeIn s; raise exn)
177 :			end handle e as Interrupt.Interrupt => raise e
178 :			| _ => NONE
179 :	blume	297
180 :	blume	298	fun compile () = Dummy.f ()
181 :	blume	297
182 :	blume	298	fun isValid x =
183 :			PidSet.equal (PidSet.addList (PidSet.empty, BF.cmDataOf x),
184 :			pids)
185 :			in
186 :			case load () of
187 :			NONE => compile ()
188 :			| SOME bfc =>
189 :			if isValid bfc then let
190 :			val memo = { bfc = bfc, ctxt = stat }
191 :			in
192 :			Say.vsay (concat ["[", binname, " loaded]\n"]);
193 :			PS.recomp_memo_sml (i, memo);
194 :			SOME (memo2envdelta memo)
195 :			end
196 :			else compile ()
197 :			end
198 :	blume	295	end

---

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