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

Parent Directory | Revision Log

---

Revision 295 - (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 :
19 :			type pid = PID.persstamp
20 :
21 :			type statenv = E.staticEnv
22 :			type symenv = E.symenv
23 :
24 :			type benv = statenv
25 :			type env = { stat: statenv, sym: symenv, pids: PidSet.set }
26 :
27 :			type 'e wpid = 'e * pid
28 :
29 :			type envdelta = { stat: statenv wpid, sym: symenv wpid, ctxt: statenv }
30 :
31 :			datatype lookstable_result =
32 :			FOUND of envdelta
33 :			| NOTFOUND of benv option
34 :
35 :			type memorecord = { bfc: BF.bfContent, ctxt: statenv }
36 :
37 :			structure FilterMap = BinaryMapFn
38 :			(struct
39 :			type ord_key = pid * SymbolSet.set
40 :			fun compare ((u, f), (u', f')) =
41 :			case PID.compare (u, u') of
42 :			EQUAL => SymbolSet.compare (f, f')
43 :			| unequal => unequal
44 :			end)
45 :
46 :			(* persistent state! *)
47 :			val filtermap = ref (FilterMap.empty: pid FilterMap.map)
48 :
49 :			fun blayer (be, be') = E.layerStatic (be, be')
50 :
51 :			fun layer ({ stat, sym, pids }, { stat = stat', sym = sym', pids = p' }) =
52 :			{ stat = E.layerStatic (stat, stat'),
53 :			sym = E.layerSymbolic (sym, sym'),
54 :			pids = PidSet.union (pids, p') }
55 :
56 :			fun bfilter (d: envdelta, s) =
57 :			E.filterStaticEnv (#1 (#stat d), SymbolSet.listItems s)
58 :
59 :			fun pidset (p1, p2) =
60 :			PidSet.add (PidSet.singleton p1, p2)
61 :
62 :			fun filter (d, s) = let
63 :			val stat = bfilter (d, s)
64 :			val (sym, sympid) = #sym d
65 :			val statpid = #2 (#stat d)
66 :			val ctxt = #ctxt d
67 :			val key = (statpid, s)
68 :			val statpid' =
69 :			case FilterMap.find (!filtermap, key) of
70 :			SOME statpid' => statpid'
71 :			| NONE => let
72 :			val statpid' = GenericVC.MakePid.makePid (ctxt, stat)
73 :			in
74 :			filtermap := FilterMap.insert (!filtermap, key, statpid');
75 :			statpid'
76 :			end
77 :			in
78 :			{ stat = stat, sym = sym, pids = pidset (statpid', sympid) }
79 :			end
80 :
81 :			fun bnofilter (d: envdelta) = #1 (#stat d)
82 :
83 :			fun nofilter (d: envdelta) = let
84 :			val (stat, statpid) = #stat d
85 :			val (sym, sympid) = #sym d
86 :			in
87 :			{ stat = stat, sym = sym, pids = pidset (statpid, sympid) }
88 :			end
89 :
90 :			fun primitive c p = let
91 :			val e = Primitive.env c p
92 :			val { statpid, sympid, ctxt } = Primitive.pidInfo c p
93 :			in
94 :			{ stat = (E.staticPart e, statpid),
95 :			sym = (E.symbolicPart e, sympid),
96 :			ctxt = ctxt }
97 :			end
98 :
99 :			fun memo2envdelta { bfc, ctxt } =
100 :			{ stat = (BF.senvOf bfc, BF.staticPidOf bfc),
101 :			sym = (BF.symenvOf bfc, BF.lambdaPidOf bfc),
102 :			ctxt = ctxt }
103 :
104 :			fun lookstable (i, mkenv) =
105 :			case PS.recomp_look_stable i of
106 :			SOME memo => FOUND (memo2envdelta memo)
107 :			| NONE => NOTFOUND (mkenv ())
108 :
109 :			fun dostable (i, be, gp: GeneralParams.params) = let
110 :			val stable = BinInfo.stablePath i
111 :			val os = BinInfo.offset i
112 :			val descr = BinInfo.describe i
113 :			val _ = Say.vsay (concat ["[consulting ", descr, "]\n"])
114 :			val s = AbsPath.openBinIn stable
115 :			fun load () = let
116 :			val _ = Seek.seek (s, os)
117 :			val bfc = BF.read { stream = s, name = descr, senv = be,
118 :			keep_code = true }
119 :			val memo = { bfc = bfc, ctxt = be }
120 :			in
121 :			BinIO.closeIn s;
122 :			PS.recomp_memo_stable (i, memo);
123 :			memo2envdelta memo
124 :			end
125 :			in
126 :			SOME (load ()) handle exn => let
127 :			fun pphist pps =
128 :			(PrettyPrint.add_string pps (General.exnMessage exn);
129 :			PrettyPrint.add_newline pps)
130 :			in
131 :			BinIO.closeIn s;
132 :			BinInfo.error i GenericVC.ErrorMsg.COMPLAIN
133 :			"unable to load stable library module" pphist;
134 :			NONE
135 :			end
136 :			end
137 :
138 :			fun looksml (i, e: env) =
139 :			Option.map memo2envdelta (PS.recomp_look_sml (i, #pids e))
140 :
141 :			fun dosml (i, e, gp) =
142 :			Dummy.f ()
143 :			end

---

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