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 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