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

Annotation of /sml/trunk/src/cm/link.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 357 - (view) (download)

1 : blume 314 (* test implementation of functor LinkCM *)
2 : blume 274
3 : blume 301 functor LinkCM (structure HostMachDepVC : MACHDEP_VC) = struct
4 : blume 274
5 : blume 276 local
6 : blume 355 structure AutoLoad = AutoLoad
7 : blume 276 structure YaccTool = YaccTool
8 :     structure LexTool = LexTool
9 :     structure BurgTool = BurgTool
10 :     val _ = EnvConfig.init ()
11 : blume 301
12 :     structure E = GenericVC.Environment
13 :     structure SE = GenericVC.StaticEnv
14 : blume 316 structure ER = GenericVC.EnvRef
15 :     structure BE = GenericVC.BareEnvironment
16 : blume 301 structure CMSE = GenericVC.CMStaticEnv
17 :     structure S = GenericVC.Symbol
18 : blume 327 structure CoerceEnv = GenericVC.CoerceEnv
19 : blume 301
20 : blume 336 val os = SMLofNJ.SysInfo.getOSKind ()
21 :    
22 :     structure SSV = SpecificSymValFn (structure MachDepVC = HostMachDepVC
23 :     val os = os)
24 :    
25 : blume 317 (* For testing purposes, I need to have access to the old basis
26 :     * library. This is done via the "primitives" mechanism. Eventually,
27 :     * the basis will be accessed as a genuine library. The "primitives"
28 :     * mechanism is really meant to serve a different purpose.
29 :     *
30 :     * We split the existing pervasive environment into two parts:
31 : blume 318 * 1. All ML module definitions -- this is the part that will
32 : blume 317 * become available via a primitive called "basis".
33 :     * 2. The remaining (non-modular) bindings. Those will be
34 :     * used as our "pervasive" environment.
35 :     *
36 :     * I didn't bother to split dynamic or symbolic environments.
37 :     * To function properly this is not necessary, and the whole thing
38 :     * will soon go away anyhow.
39 :     *)
40 : blume 301 fun split e = let
41 :     val sym = E.symbolicPart e
42 :     val dyn = E.dynamicPart e
43 :     val stat = E.staticPart e
44 : blume 327 val bstat = CoerceEnv.es2bs stat
45 : blume 301 fun f ((s, b), (mods, nomods)) =
46 :     case S.nameSpace s of
47 :     (S.STRspace | S.SIGspace | S.FCTspace | S.FSIGspace) =>
48 :     (SE.bind (s, b, mods), nomods)
49 :     | _ => (mods, SE.bind (s, b, nomods))
50 :     val (bmods, bnomods) = SE.fold f (SE.empty, SE.empty) bstat
51 :     val mods = CMSE.CM bmods
52 :     val nomods = CMSE.CM bnomods
53 :     fun mk s = E.mkenv { static = s, dynamic = dyn, symbolic = sym }
54 :     in
55 :     { mod = mk mods, nomod = mk nomods }
56 :     end
57 :    
58 : blume 317 (* Instantiate the persistent state functor; this includes
59 :     * the binfile cache and the dynamic value cache *)
60 : blume 301 structure FullPersstate =
61 :     FullPersstateFn (structure MachDepVC = HostMachDepVC)
62 :    
63 : blume 317 (* Create two arguments appropriate for being passed to
64 :     * CompileGenericFn. One instantiation of that functor
65 :     * is responsible for "recompile" traversals, the other one
66 :     * does "link" traversals. Notice how the two share the same
67 :     * underlying state. *)
68 : blume 301 structure Recomp = RecompFn (structure PS = FullPersstate)
69 :     structure Exec = ExecFn (structure PS = FullPersstate)
70 :    
71 : blume 317 (* make the two traversals *)
72 : blume 301 structure RecompTraversal = CompileGenericFn (structure CT = Recomp)
73 :     structure ExecTraversal = CompileGenericFn (structure CT = Exec)
74 :    
75 : blume 317 (* The StabilizeFn functor needs a way of converting bnodes to
76 :     * dependency-analysis environments. This can be achieved quite
77 :     * conveniently by a "recompile" traversal for bnodes. *)
78 : blume 310 fun bn2statenv gp i = #1 (#stat (valOf (RecompTraversal.bnode gp i)))
79 : blume 355 handle Option => raise Fail "bn2statenv"
80 : blume 310
81 : blume 317 (* exec_group is basically the same as ExecTraversal.group with
82 :     * two additional actions to be taken:
83 :     * 1. Before executing the code, we announce the priviliges
84 :     * that are being invoked. (For the time being, we assume
85 :     * that everybody has every conceivable privilege, but at the
86 :     * very least we announce which ones are being made use of.)
87 :     * 2. After we are done we must make the values of "shared"
88 :     * compilation units permanent. *)
89 : blume 315 fun exec_group gp (g as GroupGraph.GROUP { required = rq, ... }) =
90 : blume 314 (if StringSet.isEmpty rq then ()
91 :     else Say.say ("$Execute: required privileges are:\n" ::
92 :     map (fn s => (" " ^ s ^ "\n")) (StringSet.listItems rq));
93 : blume 315 ExecTraversal.group gp g
94 : blume 355 before FullPersstate.rememberShared ())
95 : blume 314
96 : blume 317 fun recomp_runner gp g = isSome (RecompTraversal.group gp g)
97 : blume 315
98 : blume 317 (* This function combines the actions of "recompile" and "exec".
99 :     * When successful, it combines the results (thus forming a full
100 :     * environment) and adds it to the toplevel environment. *)
101 : blume 316 fun make_runner gp g =
102 : blume 317 case RecompTraversal.group gp g of
103 : blume 316 NONE => false
104 :     | SOME { stat, sym} =>
105 :     (case exec_group gp g of
106 :     NONE => false
107 :     | SOME dyn => let
108 :     val delta = E.mkenv { static = stat, symbolic = sym,
109 :     dynamic = dyn }
110 :     val base = #get ER.topLevel ()
111 : blume 327 val new = BE.concatEnv (CoerceEnv.e2b delta, base)
112 : blume 316 in
113 :     #set ER.topLevel new;
114 :     Say.vsay ["[New bindings added.]\n"];
115 :     true
116 :     end)
117 :    
118 : blume 355 fun loadit gp m =
119 :     case RecompTraversal.impexpmap gp m of
120 :     NONE => NONE
121 :     | SOME { stat, sym } => let
122 :     fun exec () =
123 :     ExecTraversal.impexpmap gp m
124 :     before FullPersstate.rememberShared ()
125 :     in
126 :     case exec () of
127 :     NONE => NONE
128 :     | SOME dyn => let
129 :     val e = E.mkenv { static = stat, symbolic = sym,
130 :     dynamic =dyn }
131 :     val be = GenericVC.CoerceEnv.e2b e
132 :     in
133 :     SOME be
134 :     end
135 :     end
136 :    
137 :     val theParam = ref (NONE: GeneralParams.param option)
138 :     fun param () =
139 :     case !theParam of
140 :     SOME p => p
141 :     | NONE => let
142 :     val { mod = basis, nomod = perv } =
143 :     split (#get ER.pervasive ())
144 :     val corenv = #get ER.core ()
145 :     val bpspec = let
146 :     val bogus = GenericVC.PersStamps.fromBytes
147 :     (Byte.stringToBytes "0123456789abcdef")
148 :     in
149 :     { name = "basis",
150 :     env = basis,
151 :     pidInfo = { statpid = bogus, sympid = bogus,
152 :     ctxt = GenericVC.CMStaticEnv.empty } }
153 :     end
154 :     val primconf = Primitive.configuration [bpspec]
155 :     val pcmode = PathConfig.hardwire
156 :     [("smlnj-lib.cm", "/home/blume/ML/current/lib")]
157 :     val fnpolicy =
158 :     FilenamePolicy.colocate
159 :     { os = os, arch = HostMachDepVC.architecture }
160 :     val keep_going = EnvConfig.getSet StdConfig.keep_going NONE
161 :     val p = { primconf = primconf,
162 :     fnpolicy = fnpolicy,
163 :     pcmode = pcmode,
164 :     symenv = SSV.env,
165 :     keep_going = keep_going,
166 :     pervasive = perv,
167 :     corenv = corenv,
168 :     pervcorepids = PidSet.empty }
169 :     in
170 :     theParam := SOME p;
171 :     p
172 :     end
173 :    
174 :     val al_greg = GroupReg.new ()
175 :     fun al_ginfo () = { param = param (),
176 :     groupreg = al_greg,
177 :     errcons = GenericVC.ErrorMsg.defaultConsumer () }
178 :    
179 :     val al_manager = AutoLoad.mkManager (fn m => loadit (al_ginfo ()) m)
180 :    
181 :     fun manager (ast, _, ter) = al_manager (ast, ter)
182 :    
183 :     val _ = HostMachDepVC.Interact.installCompManager (SOME manager)
184 :    
185 : blume 317 (* Instantiate the stabilization mechanism. *)
186 : blume 357 structure Stabilize =
187 :     StabilizeFn (val bn2statenv = bn2statenv
188 :     val getPid = FullPersstate.pid_fetch_sml
189 :     fun warmup (i, p) = () (* FIXME *)
190 :     val recomp = recomp_runner)
191 : blume 311
192 : blume 317 (* Access to the stabilization mechanism is integrated into the
193 :     * parser. I'm not sure if this is the cleanest way, but it works
194 :     * well enough. *)
195 : blume 311 structure Parse = ParseFn (structure Stabilize = Stabilize)
196 : blume 316
197 : blume 317 (* this is just a dummy argument to "run" (see below). *)
198 : blume 316 fun stabilize_runner gp g = true
199 : blume 276 in
200 : blume 274 structure CM = struct
201 : blume 301
202 : blume 310 fun run sflag f s = let
203 : blume 354 val c = SrcPath.cwdContext ()
204 :     val p = SrcPath.native { context = c, spec = s }
205 : blume 274 in
206 : blume 355 case Parse.parse NONE (param ()) sflag p of
207 : blume 316 NONE => false
208 : blume 314 | SOME (g, gp) => f gp g
209 : blume 274 end
210 : blume 286
211 : blume 316 fun stabilize recursively = run (SOME recursively) stabilize_runner
212 :     val recomp = run NONE recomp_runner
213 :     val make = run NONE make_runner
214 : blume 355
215 :     fun autoload s = let
216 :     val c = SrcPath.cwdContext ()
217 :     val p = SrcPath.native { context = c, spec = s }
218 :     in
219 :     case Parse.parse (SOME al_greg) (param ()) NONE p of
220 :     NONE => false
221 :     | SOME (g, _) =>
222 :     (AutoLoad.register (GenericVC.EnvRef.topLevel, g);
223 :     true)
224 :     end
225 : blume 274 end
226 :    
227 :     structure CMB = struct
228 : blume 327 structure BootstrapCompile =
229 : blume 329 BootstrapCompileFn (structure MachDepVC = HostMachDepVC
230 : blume 336 val os = os)
231 : blume 353 fun make st =
232 : blume 349 BootstrapCompile.compile
233 : blume 357 { dirbase = "xxx",
234 : blume 331 pcmodespec = "pathconfig",
235 : blume 357 initgspec = "init.cmi",
236 : blume 354 maingspec = "root.cm",
237 : blume 353 stabilize = st }
238 : blume 274 fun setRetargetPervStatEnv x = ()
239 :     fun wipeOut () = ()
240 :     fun make' _ = ()
241 :     end
242 : blume 276 end
243 : blume 274 end
244 :    
245 :     signature CMTOOLS = sig end
246 :     signature COMPILATION_MANAGER = sig end

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