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

Parent Directory | Revision Log

---

Revision 297 - (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 :			datatype lookstable_result =
34 :			FOUND of envdelta
35 :			| NOTFOUND of benv option
36 :
37 :			type memorecord = { bfc: BF.bfContent, ctxt: statenv }
38 :
39 :			structure FilterMap = BinaryMapFn
40 :			(struct
41 :			type ord_key = pid * SymbolSet.set
42 :			fun compare ((u, f), (u', f')) =
43 :			case PID.compare (u, u') of
44 :			EQUAL => SymbolSet.compare (f, f')
45 :			| unequal => unequal
46 :			end)
47 :
48 :			(* persistent state! *)
49 :			val filtermap = ref (FilterMap.empty: pid FilterMap.map)
50 :
51 :			fun blayer (be, be') = E.layerStatic (be, be')
52 :
53 :			fun layer ({ stat, sym, pids }, { stat = stat', sym = sym', pids = p' }) =
54 :			{ stat = E.layerStatic (stat, stat'),
55 :			sym = E.layerSymbolic (sym, sym'),
56 :			pids = PidSet.union (pids, p') }
57 :
58 :			fun bfilter (d: envdelta, s) =
59 :			E.filterStaticEnv (#1 (#stat d), SymbolSet.listItems s)
60 :
61 :			fun pidset (p1, p2) =
62 :			PidSet.add (PidSet.singleton p1, p2)
63 :
64 :			fun filter (d, s) = let
65 :			val stat = bfilter (d, s)
66 :			val (sym, sympid) = #sym d
67 :			val statpid = #2 (#stat d)
68 :			val ctxt = #ctxt d
69 :			val key = (statpid, s)
70 :			val statpid' =
71 :			case FilterMap.find (!filtermap, key) of
72 :			SOME statpid' => statpid'
73 :			| NONE => let
74 :			val statpid' = GenericVC.MakePid.makePid (ctxt, stat)
75 :			in
76 :			filtermap := FilterMap.insert (!filtermap, key, statpid');
77 :			statpid'
78 :			end
79 :			in
80 :			{ stat = stat, sym = sym, pids = pidset (statpid', sympid) }
81 :			end
82 :
83 :			fun bnofilter (d: envdelta) = #1 (#stat d)
84 :
85 :			fun nofilter (d: envdelta) = let
86 :			val (stat, statpid) = #stat d
87 :			val (sym, sympid) = #sym d
88 :			in
89 :			{ stat = stat, sym = sym, pids = pidset (statpid, sympid) }
90 :			end
91 :
92 :			fun primitive c p = let
93 :			val e = Primitive.env c p
94 :			val { statpid, sympid, ctxt } = Primitive.pidInfo c p
95 :			in
96 :			{ stat = (E.staticPart e, statpid),
97 :			sym = (E.symbolicPart e, sympid),
98 :			ctxt = ctxt }
99 :			end
100 :
101 :			fun memo2envdelta { bfc, ctxt } =
102 :			{ stat = (BF.senvOf bfc, BF.staticPidOf bfc),
103 :			sym = (BF.symenvOf bfc, BF.lambdaPidOf bfc),
104 :			ctxt = ctxt }
105 :
106 :	blume	297	fun lookstable (i, mkenv, gp) =
107 :	blume	295	case PS.recomp_look_stable i of
108 :			SOME memo => FOUND (memo2envdelta memo)
109 :			| NONE => NOTFOUND (mkenv ())
110 :
111 :			fun dostable (i, be, gp: GeneralParams.params) = let
112 :	blume	297	val fnp = #fnpolicy gp
113 :			val stable = FilenamePolicy.mkStablePath fnp (BinInfo.group i)
114 :	blume	295	val os = BinInfo.offset i
115 :			val descr = BinInfo.describe i
116 :			val _ = Say.vsay (concat ["[consulting ", descr, "]\n"])
117 :			val s = AbsPath.openBinIn stable
118 :			fun load () = let
119 :			val _ = Seek.seek (s, os)
120 :			val bfc = BF.read { stream = s, name = descr, senv = be,
121 :			keep_code = true }
122 :			val memo = { bfc = bfc, ctxt = be }
123 :			in
124 :			BinIO.closeIn s;
125 :			PS.recomp_memo_stable (i, memo);
126 :			memo2envdelta memo
127 :			end
128 :			in
129 :			SOME (load ()) handle exn => let
130 :			fun pphist pps =
131 :	blume	297	(PP.add_string pps (General.exnMessage exn);
132 :			PP.add_newline pps)
133 :	blume	295	in
134 :			BinIO.closeIn s;
135 :	blume	297	BinInfo.error gp i EM.COMPLAIN
136 :	blume	295	"unable to load stable library module" pphist;
137 :			NONE
138 :			end
139 :			end
140 :
141 :	blume	297	fun looksml (i, e: env, gp) =
142 :			Option.map memo2envdelta (PS.recomp_look_sml (i, #pids e, gp))
143 :	blume	295
144 :	blume	297	fun dosml (i, { stat, sym, pids }, gp) = let
145 :
146 :			val mkBinPath = FilenamePolicy.mkBinPath (#fnpolicy gp)
147 :			val binpath = mkBinPath (SmlInfo.sourcepath i)
148 :			val binname = AbsPath.name binpath
149 :			fun delete () = OS.FileSys.remove binname handle _ => ()
150 :
151 :			fun save bfc = let
152 :			val s = AbsPath.openBinOut binpath
153 :			fun writer () =
154 :			BF.write { stream = s, content = bfc, keep_code = true }
155 :			in
156 :			Interrupt.guarded writer
157 :			handle exn => (BinIO.closeOut s; raise exn);
158 :			BinIO.closeOut s;
159 :			Say.vsay (concat ["wrote ", binname, "]\n"])
160 :			end handle e as Interrupt.Interrupt => (delete (); raise e)
161 :			| exn => let
162 :			fun pphist pps =
163 :			(PP.add_string pps (General.exnMessage exn);
164 :			PP.add_newline pps)
165 :			in
166 :			delete ();
167 :			SmlInfo.error gp i EM.WARN
168 :			("failed to write " ^ binname) pphist
169 :			end
170 :
171 :			fun load () = let
172 :			val s = AbsPath.openBinIn binpath
173 :			fun read () = BF.read { stream = s, name = binname, senv = stat,
174 :			keep_code = true }
175 :			in
176 :			SOME (Interrupt.guarded read)
177 :			handle exn => (BinIO.closeIn s; raise exn)
178 :			end handle e as Interrupt.Interrupt => raise e
179 :			| _ => NONE
180 :			in
181 :	blume	295	Dummy.f ()
182 :	blume	297	end
183 :	blume	295	end

---

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