Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2010,2016 Matthew Fluet. |
2 | * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * Copyright (C) 1997-2000 NEC Research Institute. | |
5 | * | |
6 | * MLton is released under a BSD-style license. | |
7 | * See the file MLton-LICENSE for details. | |
8 | *) | |
9 | ||
10 | functor ElaborateMLBs (S: ELABORATE_MLBS_STRUCTS): ELABORATE_MLBS = | |
11 | struct | |
12 | ||
13 | open S | |
14 | ||
15 | local | |
16 | open Control.Elaborate | |
17 | in | |
18 | val deadCode = fn () => current deadCode | |
19 | end | |
20 | ||
21 | structure ElabControl = Control.Elaborate | |
22 | ||
23 | fun check (c: (bool,bool) ElabControl.t, keyword: string, region) = | |
24 | if ElabControl.current c | |
25 | then () | |
26 | else | |
27 | let | |
28 | open Layout | |
29 | in | |
30 | Control.error | |
31 | (region, | |
32 | str (concat (if ElabControl.expert c | |
33 | then [keyword, " disallowed"] | |
34 | else [keyword, " disallowed, compile with -default-ann '", | |
35 | ElabControl.name c, " true'"])), | |
36 | empty) | |
37 | end | |
38 | ||
39 | local | |
40 | open Ast | |
41 | in | |
42 | structure Basexp = Basexp | |
43 | structure Basdec = Basdec | |
44 | structure Longstrid = Longstrid | |
45 | structure ModIdBind = ModIdBind | |
46 | end | |
47 | ||
48 | local | |
49 | open Env | |
50 | in | |
51 | structure Decs = Decs | |
52 | end | |
53 | ||
54 | structure ElaboratePrograms = ElaboratePrograms (structure Ast = Ast | |
55 | structure CoreML = CoreML | |
56 | structure Decs = Decs | |
57 | structure Env = Env) | |
58 | ||
59 | local | |
60 | open ElaboratePrograms | |
61 | in | |
62 | structure Decs = Decs | |
63 | structure Env = Env | |
64 | end | |
65 | ||
66 | fun elaborateMLB (mlb : Basdec.t, {addPrim}) = | |
67 | let | |
68 | val decs = Buffer.new {dummy = ([], false)} | |
69 | ||
70 | val E = Env.empty () | |
71 | fun withDef f = | |
72 | ElabControl.withDef | |
73 | (fn () => | |
74 | if ElabControl.default ElabControl.forceUsed | |
75 | then Env.forceUsedLocal (E, f) | |
76 | else f ()) | |
77 | ||
78 | val emptySnapshot : (unit -> Env.Basis.t) -> Env.Basis.t = | |
79 | Env.snapshot E | |
80 | val emptySnapshot = fn (f: unit -> Env.Basis.t) => | |
81 | emptySnapshot (fn () => withDef f) | |
82 | ||
83 | val primBasis = | |
84 | emptySnapshot | |
85 | (fn () => | |
86 | (#2 o Env.makeBasis) | |
87 | (E, fn () => | |
88 | let val primDecs = addPrim E | |
89 | in Buffer.add (decs, (primDecs, false)) | |
90 | end)) | |
91 | ||
92 | fun elabProg p = ElaboratePrograms.elaborateProgram (p, {env = E}) | |
93 | ||
94 | val psi : (File.t * Env.Basis.t Promise.t) HashSet.t = | |
95 | HashSet.new {hash = String.hash o #1} | |
96 | ||
97 | val elabBasexpInfo = Trace.info "ElaborateMLBs.elabBasexp" | |
98 | val elabBasdecInfo = Trace.info "ElaborateMLBs.elabBasdec" | |
99 | ||
100 | fun elabBasexp (basexp: Basexp.t) : Env.Basis.t option = | |
101 | Trace.traceInfo' (elabBasexpInfo, | |
102 | Basexp.layout, | |
103 | Layout.ignore) | |
104 | (fn (basexp: Basexp.t) => | |
105 | case Basexp.node basexp of | |
106 | Basexp.Bas basdec => | |
107 | let | |
108 | val ((), B) = | |
109 | Env.makeBasis (E, fn () => elabBasdec basdec) | |
110 | in | |
111 | SOME B | |
112 | end | |
113 | | Basexp.Var basid => Env.lookupBasid (E, basid) | |
114 | | Basexp.Let (basdec, basexp) => | |
115 | Env.scopeAll | |
116 | (E, fn () => | |
117 | (elabBasdec basdec | |
118 | ; elabBasexp basexp))) basexp | |
119 | and elabBasdec (basdec: Basdec.t) : unit = | |
120 | Trace.traceInfo' (elabBasdecInfo, | |
121 | Basdec.layout, | |
122 | Layout.ignore) | |
123 | (fn (basdec: Basdec.t) => | |
124 | case Basdec.node basdec of | |
125 | Basdec.Defs def => | |
126 | let | |
127 | fun doit (lookup, extend, bnds) = | |
128 | Vector.foreach | |
129 | (Vector.map (bnds, fn {lhs, rhs} => | |
130 | {lhs = lhs, rhs = lookup (E, rhs)}), | |
131 | fn {lhs, rhs} => | |
132 | Option.app (rhs, fn z => extend (E, lhs, z))) | |
133 | in | |
134 | case ModIdBind.node def of | |
135 | ModIdBind.Fct bnds => | |
136 | doit (Env.lookupFctid, Env.extendFctid, bnds) | |
137 | | ModIdBind.Sig bnds => | |
138 | doit (Env.lookupSigid, Env.extendSigid, bnds) | |
139 | | ModIdBind.Str bnds => | |
140 | doit (Env.lookupStrid, Env.extendStrid, bnds) | |
141 | end | |
142 | | Basdec.Basis basbinds => | |
143 | let | |
144 | val basbinds = | |
145 | Vector.map | |
146 | (basbinds, fn {name, def} => | |
147 | let val B = elabBasexp def | |
148 | in {B = B, name = name} | |
149 | end) | |
150 | in | |
151 | Vector.foreach | |
152 | (basbinds, fn {name, B, ...} => | |
153 | Option.app (B, fn B => Env.extendBasid (E, name, B))) | |
154 | end | |
155 | | Basdec.Local (basdec1, basdec2) => | |
156 | Env.localAll (E, fn () => | |
157 | elabBasdec basdec1, fn () => | |
158 | elabBasdec basdec2) | |
159 | | Basdec.Seq basdecs => | |
160 | List.foreach(basdecs, elabBasdec) | |
161 | | Basdec.Open basids => | |
162 | Vector.foreach | |
163 | (Vector.map (basids, fn basid => | |
164 | Env.lookupBasid (E, basid)), fn bo => | |
165 | Option.app (bo, fn b => Env.openBasis (E, b))) | |
166 | | Basdec.Prog (_, prog) => | |
167 | let | |
168 | val prog = Promise.force prog | |
169 | in | |
170 | Buffer.add (decs, (Decs.toList (elabProg prog), deadCode ())) | |
171 | end | |
172 | | Basdec.MLB ({fileAbs, ...}, basdec) => | |
173 | let | |
174 | val (_, B) = | |
175 | HashSet.lookupOrInsert | |
176 | (psi, String.hash fileAbs, fn (fileAbs', _) => | |
177 | String.equals (fileAbs, fileAbs'), fn () => | |
178 | let | |
179 | val basdec = Promise.force basdec | |
180 | val B = | |
181 | Promise.delay | |
182 | (fn () => | |
183 | emptySnapshot | |
184 | (fn () => | |
185 | (#2 o Env.makeBasis) | |
186 | (E, fn () => elabBasdec basdec))) | |
187 | in | |
188 | (fileAbs, B) | |
189 | end) | |
190 | val B = Promise.force B | |
191 | handle Promise.Force => | |
192 | (* Basis forms a cycle; | |
193 | * force the AST to generate error message. | |
194 | *) | |
195 | (ignore (Promise.force basdec) | |
196 | ; #2 (Env.makeBasis (E, fn () => ()))) | |
197 | in | |
198 | Env.openBasis (E, B) | |
199 | end | |
200 | | Basdec.Prim => | |
201 | (check (ElabControl.allowPrim, "_prim", Basdec.region basdec) | |
202 | ; Env.openBasis (E, primBasis)) | |
203 | | Basdec.Ann (ann, reg, basdec) => | |
204 | let | |
205 | open ElabControl | |
206 | fun warn () = | |
207 | if !Control.warnAnn | |
208 | then let open Layout | |
209 | in | |
210 | Control.warning | |
211 | (reg, seq [str "unrecognized annotation: ", str ann], | |
212 | empty) | |
213 | end | |
214 | else () | |
215 | in | |
216 | case parseIdAndArgs ann of | |
217 | ElabControl.Bad => | |
218 | (warn () | |
219 | ; elabBasdec basdec) | |
220 | | ElabControl.Good (id, args) => | |
221 | let | |
222 | val restore = Args.processAnn args | |
223 | in | |
224 | Exn.finally | |
225 | (fn () => | |
226 | if equalsId (forceUsed, id) andalso enabled forceUsed | |
227 | then Env.forceUsedLocal (E, fn () => elabBasdec basdec) | |
228 | else if equalsId (ffiStr, id) | |
229 | then let | |
230 | val ffi = valOf (current ffiStr) | |
231 | val ffi = | |
232 | Longstrid.fromSymbols | |
233 | (List.map (String.split (ffi, #"."), | |
234 | Longstrid.Symbol.fromString), | |
235 | reg) | |
236 | in | |
237 | elabBasdec basdec | |
238 | before | |
239 | Option.app | |
240 | (Env.lookupLongstrid (E, ffi), | |
241 | fn S => (Env.Structure.ffi := SOME S | |
242 | ; Env.Structure.forceUsed S)) | |
243 | end | |
244 | else elabBasdec basdec, | |
245 | restore) | |
246 | end | |
247 | | ElabControl.Other => elabBasdec basdec | |
248 | | ElabControl.Proxy (alts, {deprecated}) => | |
249 | let | |
250 | val (ids, args) = List.unzip alts | |
251 | val () = | |
252 | if !Control.warnDeprecated andalso deprecated | |
253 | then | |
254 | let open Layout | |
255 | in | |
256 | Control.warning | |
257 | (reg, seq [str "deprecated annotation: ", str ann, str ", use ", | |
258 | List.layout (str o ElabControl.Id.name) ids], | |
259 | empty) | |
260 | end | |
261 | else () | |
262 | val restores = | |
263 | List.map (args, Args.processAnn) | |
264 | in | |
265 | Exn.finally | |
266 | (fn () => elabBasdec basdec, | |
267 | fn () => List.foreach (List.rev restores, fn restore => restore ())) | |
268 | end | |
269 | ||
270 | end) basdec | |
271 | val _ = withDef (fn () => elabBasdec mlb) | |
272 | in | |
273 | (E, Buffer.toVector decs) | |
274 | end | |
275 | ||
276 | end |