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 323 - (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 :     structure YaccTool = YaccTool
7 :     structure LexTool = LexTool
8 :     structure BurgTool = BurgTool
9 :     val _ = EnvConfig.init ()
10 : blume 301
11 :     structure E = GenericVC.Environment
12 :     structure SE = GenericVC.StaticEnv
13 : blume 316 structure ER = GenericVC.EnvRef
14 :     structure BE = GenericVC.BareEnvironment
15 : blume 301 structure CMSE = GenericVC.CMStaticEnv
16 :     structure S = GenericVC.Symbol
17 :    
18 : blume 317 (* For testing purposes, I need to have access to the old basis
19 :     * library. This is done via the "primitives" mechanism. Eventually,
20 :     * the basis will be accessed as a genuine library. The "primitives"
21 :     * mechanism is really meant to serve a different purpose.
22 :     *
23 :     * We split the existing pervasive environment into two parts:
24 : blume 318 * 1. All ML module definitions -- this is the part that will
25 : blume 317 * become available via a primitive called "basis".
26 :     * 2. The remaining (non-modular) bindings. Those will be
27 :     * used as our "pervasive" environment.
28 :     *
29 :     * I didn't bother to split dynamic or symbolic environments.
30 :     * To function properly this is not necessary, and the whole thing
31 :     * will soon go away anyhow.
32 :     *)
33 : blume 301 fun split e = let
34 :     val sym = E.symbolicPart e
35 :     val dyn = E.dynamicPart e
36 :     val stat = E.staticPart e
37 :     val bstat = CMSE.unCM stat
38 :     fun f ((s, b), (mods, nomods)) =
39 :     case S.nameSpace s of
40 :     (S.STRspace | S.SIGspace | S.FCTspace | S.FSIGspace) =>
41 :     (SE.bind (s, b, mods), nomods)
42 :     | _ => (mods, SE.bind (s, b, nomods))
43 :     val (bmods, bnomods) = SE.fold f (SE.empty, SE.empty) bstat
44 :     val mods = CMSE.CM bmods
45 :     val nomods = CMSE.CM bnomods
46 :     fun mk s = E.mkenv { static = s, dynamic = dyn, symbolic = sym }
47 :     in
48 :     { mod = mk mods, nomod = mk nomods }
49 :     end
50 :    
51 : blume 317 (* Instantiate the persistent state functor; this includes
52 :     * the binfile cache and the dynamic value cache *)
53 : blume 301 structure FullPersstate =
54 :     FullPersstateFn (structure MachDepVC = HostMachDepVC)
55 :    
56 : blume 317 (* Create two arguments appropriate for being passed to
57 :     * CompileGenericFn. One instantiation of that functor
58 :     * is responsible for "recompile" traversals, the other one
59 :     * does "link" traversals. Notice how the two share the same
60 :     * underlying state. *)
61 : blume 301 structure Recomp = RecompFn (structure PS = FullPersstate)
62 :     structure Exec = ExecFn (structure PS = FullPersstate)
63 :    
64 : blume 317 (* make the two traversals *)
65 : blume 301 structure RecompTraversal = CompileGenericFn (structure CT = Recomp)
66 :     structure ExecTraversal = CompileGenericFn (structure CT = Exec)
67 :    
68 : blume 317 (* The StabilizeFn functor needs a way of converting bnodes to
69 :     * dependency-analysis environments. This can be achieved quite
70 :     * conveniently by a "recompile" traversal for bnodes. *)
71 : blume 310 fun bn2statenv gp i = #1 (#stat (valOf (RecompTraversal.bnode gp i)))
72 :    
73 : blume 317 (* exec_group is basically the same as ExecTraversal.group with
74 :     * two additional actions to be taken:
75 :     * 1. Before executing the code, we announce the priviliges
76 :     * that are being invoked. (For the time being, we assume
77 :     * that everybody has every conceivable privilege, but at the
78 :     * very least we announce which ones are being made use of.)
79 :     * 2. After we are done we must make the values of "shared"
80 :     * compilation units permanent. *)
81 : blume 315 fun exec_group gp (g as GroupGraph.GROUP { required = rq, ... }) =
82 : blume 314 (if StringSet.isEmpty rq then ()
83 :     else Say.say ("$Execute: required privileges are:\n" ::
84 :     map (fn s => (" " ^ s ^ "\n")) (StringSet.listItems rq));
85 : blume 315 ExecTraversal.group gp g
86 : blume 320 before FullPersstate.rememberShared gp)
87 : blume 314
88 : blume 317 fun recomp_runner gp g = isSome (RecompTraversal.group gp g)
89 : blume 315
90 : blume 317 (* This function combines the actions of "recompile" and "exec".
91 :     * When successful, it combines the results (thus forming a full
92 :     * environment) and adds it to the toplevel environment. *)
93 : blume 316 fun make_runner gp g =
94 : blume 317 case RecompTraversal.group gp g of
95 : blume 316 NONE => false
96 :     | SOME { stat, sym} =>
97 :     (case exec_group gp g of
98 :     NONE => false
99 :     | SOME dyn => let
100 :     val delta = E.mkenv { static = stat, symbolic = sym,
101 :     dynamic = dyn }
102 :     val base = #get ER.topLevel ()
103 :     val new = BE.concatEnv (ER.unCMenv delta, base)
104 :     in
105 :     #set ER.topLevel new;
106 :     Say.vsay ["[New bindings added.]\n"];
107 :     true
108 :     end)
109 :    
110 : blume 317 (* Instantiate the stabilization mechanism. *)
111 : blume 311 structure Stabilize = StabilizeFn (val bn2statenv = bn2statenv
112 : blume 316 val recomp = recomp_runner)
113 : blume 311
114 : blume 317 (* Access to the stabilization mechanism is integrated into the
115 :     * parser. I'm not sure if this is the cleanest way, but it works
116 :     * well enough. *)
117 : blume 311 structure Parse = ParseFn (structure Stabilize = Stabilize)
118 : blume 316
119 : blume 317 (* this is just a dummy argument to "run" (see below). *)
120 : blume 316 fun stabilize_runner gp g = true
121 : blume 276 in
122 : blume 274 structure CM = struct
123 : blume 301
124 : blume 310 fun run sflag f s = let
125 : blume 274 val c = AbsPath.cwdContext ()
126 :     val p = AbsPath.native { context = AbsPath.cwdContext (),
127 :     spec = s }
128 : blume 317 val { mod = basis, nomod = perv } = split (#get ER.pervasive ())
129 : blume 316 val corenv = #get ER.core ()
130 : blume 323 val bpspec = let
131 :     val bogus = GenericVC.PersStamps.fromBytes
132 :     (Byte.stringToBytes "0123456789abcdef")
133 :     in
134 :     { name = "basis",
135 :     env = basis,
136 :     pidInfo = { statpid = bogus, sympid = bogus,
137 :     ctxt = GenericVC.CMStaticEnv.empty } }
138 :     end
139 :     val primconf = Primitive.configuration [bpspec]
140 : blume 321 val pcmode = PathConfig.hardwire
141 :     [("smlnj-lib.cm", "/home/blume/ML/current/lib")]
142 : blume 322 val fnpolicy =
143 :     FilenamePolicy.colocate { os = SMLofNJ.SysInfo.getOSKind (),
144 :     arch = HostMachDepVC.architecture }
145 : blume 301 val param = { primconf = primconf,
146 : blume 322 fnpolicy = fnpolicy,
147 : blume 321 pcmode = pcmode,
148 : blume 314 keep_going = true,
149 : blume 301 pervasive = perv,
150 :     corenv = corenv }
151 : blume 274 in
152 : blume 314 case Parse.parse param sflag p of
153 : blume 316 NONE => false
154 : blume 314 | SOME (g, gp) => f gp g
155 : blume 274 end
156 : blume 286
157 : blume 316 fun stabilize recursively = run (SOME recursively) stabilize_runner
158 :     val recomp = run NONE recomp_runner
159 :     val make = run NONE make_runner
160 : blume 274 end
161 :    
162 :     structure CMB = struct
163 :     fun setRetargetPervStatEnv x = ()
164 :     fun wipeOut () = ()
165 :     fun make' _ = ()
166 :     end
167 : blume 276 end
168 : blume 274 end
169 :    
170 :     signature CMTOOLS = sig end
171 :     signature COMPILATION_MANAGER = sig end

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