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

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

Parent Directory Parent Directory | Revision Log 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