Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* ast-to-spec.sml |
2 | * 2005 Matthew Fluet (mfluet@acm.org) | |
3 | * Adapted for MLton. | |
4 | *) | |
5 | ||
6 | (* | |
7 | * ast-to-spec.sml - Conversion from CKIT "ast" to a "spec" (see spec.sml). | |
8 | * | |
9 | * (C) 2001, Lucent Technologies, Bell Labs | |
10 | * | |
11 | * author: Matthias Blume (blume@research.bell-labs.com) | |
12 | *) | |
13 | structure AstToSpec = struct | |
14 | ||
15 | structure A = Ast | |
16 | structure B = Bindings | |
17 | ||
18 | structure SS = StringSet | |
19 | structure SM = StringMap | |
20 | ||
21 | datatype context = CONTEXT of { gensym: unit -> string, anon: bool } | |
22 | ||
23 | exception VoidType | |
24 | exception Ellipsis | |
25 | exception Duplicate of string | |
26 | exception SkipFunction of string | |
27 | ||
28 | fun bug m = raise Fail ("AstToSpec: bug: " ^ m) | |
29 | fun err m = raise Fail ("AstToSpec: error: " ^ m) | |
30 | fun warn m = TextIO.output (TextIO.stdErr, "AstToSpec: warning: " ^ m) | |
31 | ||
32 | fun build { bundle, sizes: Sizes.sizes, collect_enums, | |
33 | cfiles, match, allSU, eshift, gensym_suffix } = | |
34 | let | |
35 | ||
36 | val curLoc = ref "?" | |
37 | ||
38 | fun warnLoc m = warn (concat [!curLoc, ": ", m]) | |
39 | ||
40 | val { ast, tidtab, errorCount, warningCount, | |
41 | auxiliaryInfo = { aidtab, implicits, env } } = bundle | |
42 | ||
43 | fun realFunctionDefComing sy = let | |
44 | fun isTheDef (A.DECL (A.FunctionDef (id, _, _), _, _)) = | |
45 | Symbol.equal (#name id, sy) | |
46 | | isTheDef _ = false | |
47 | in | |
48 | List.exists isTheDef ast | |
49 | end | |
50 | ||
51 | val srcOf = SourceMap.locToString | |
52 | ||
53 | fun isThisFile SourceMap.UNKNOWN = false | |
54 | | isThisFile (SourceMap.LOC { srcFile, ... }) = | |
55 | List.exists (fn f => f = srcFile) cfiles orelse | |
56 | match srcFile | |
57 | ||
58 | fun includedSU (tag, loc) = (allSU orelse isThisFile loc) | |
59 | fun includedEnum (tag, loc) = isThisFile loc | |
60 | ||
61 | fun includedTy (n, loc) = isThisFile loc | |
62 | ||
63 | fun isFunction t = TypeUtil.isFunction tidtab t | |
64 | fun getFunction t = TypeUtil.getFunction tidtab t | |
65 | fun getCoreType t = TypeUtil.getCoreType tidtab t | |
66 | ||
67 | fun constness t = | |
68 | if TypeUtil.isConst tidtab t then Spec.RO | |
69 | else case getCoreType t of | |
70 | A.Array (_, t) => constness t | |
71 | | _ => Spec.RW | |
72 | ||
73 | val sizerec = { sizes = sizes, err = err, warn = warn, bug = bug } | |
74 | ||
75 | fun sizeOf t = #bytes (Sizeof.byteSizeOf sizerec tidtab t) | |
76 | ||
77 | val bytebits = #bits (#char sizes) | |
78 | val intbits = #bits (#int sizes) | |
79 | val intalign = #align (#int sizes) | |
80 | ||
81 | fun getField (m, l) = Sizeof.getField sizerec (m, l) | |
82 | ||
83 | fun fieldOffsets t = | |
84 | case Sizeof.fieldOffsets sizerec tidtab t of | |
85 | NONE => bug "no field offsets" | |
86 | | SOME l => l | |
87 | ||
88 | val structs = ref [] | |
89 | val unions = ref [] | |
90 | val gtys = ref SM.empty | |
91 | val gvars = ref SM.empty | |
92 | val gfuns = ref SM.empty | |
93 | val named_enums = ref SM.empty | |
94 | val anon_enums = ref SM.empty | |
95 | ||
96 | val seen_structs = ref SS.empty | |
97 | val seen_unions = ref SS.empty | |
98 | ||
99 | val nexttag = ref 0 | |
100 | val tags = Tidtab.uidtab () : (string * bool) Tidtab.uidtab | |
101 | ||
102 | fun mk_context_td tdname = | |
103 | let val next = ref 0 | |
104 | in | |
105 | CONTEXT | |
106 | { gensym = | |
107 | fn () => let | |
108 | val n = !next | |
109 | in | |
110 | next := n + 1; | |
111 | concat ["'", | |
112 | if n = 0 then "" else Int.toString n, | |
113 | tdname] | |
114 | end, | |
115 | anon = false } | |
116 | end | |
117 | ||
118 | fun mk_context_su (parent_tag, anon) = | |
119 | let val next = ref 0 | |
120 | in | |
121 | CONTEXT { gensym = | |
122 | fn () => let | |
123 | val n = !next | |
124 | in | |
125 | next := n + 1; | |
126 | concat [parent_tag, "'", Int.toString n] | |
127 | end, | |
128 | anon = anon } | |
129 | end | |
130 | ||
131 | val tl_context = | |
132 | let val next = ref 0 | |
133 | in | |
134 | CONTEXT { gensym = | |
135 | fn () => let | |
136 | val n = !next | |
137 | in | |
138 | next := n + 1; | |
139 | Int.toString n | |
140 | end, | |
141 | anon = true } | |
142 | end | |
143 | ||
144 | fun tagname (SOME t, _, _) = (t, false) | |
145 | | tagname (NONE, CONTEXT { gensym, anon }, tid) = | |
146 | (case Tidtab.find (tags, tid) of | |
147 | SOME ta => ta | |
148 | | NONE => let | |
149 | val t = gensym () | |
150 | in | |
151 | Tidtab.insert (tags, tid, (t, anon)); | |
152 | (t, anon) | |
153 | end) | |
154 | ||
155 | fun reported_tagname (t, false) = t | |
156 | | reported_tagname (t, true) = t ^ gensym_suffix | |
157 | ||
158 | fun valty C A.Void = raise VoidType | |
159 | | valty C A.Ellipses = raise Ellipsis | |
160 | | valty C (A.Qual (q, t)) = valty C t | |
161 | | valty C (A.Numeric (_, _, A.SIGNED, A.CHAR, _)) = Spec.BASIC Spec.SCHAR | |
162 | | valty C (A.Numeric (_, _, A.UNSIGNED, A.CHAR, _)) = Spec.BASIC Spec.UCHAR | |
163 | | valty C (A.Numeric (_, _, A.SIGNED, A.SHORT, _)) = Spec.BASIC Spec.SSHORT | |
164 | | valty C (A.Numeric (_, _, A.UNSIGNED, A.SHORT, _)) = Spec.BASIC Spec.USHORT | |
165 | | valty C (A.Numeric (_, _, A.SIGNED, A.INT, _)) = Spec.BASIC Spec.SINT | |
166 | | valty C (A.Numeric (_, _, A.UNSIGNED, A.INT, _)) = Spec.BASIC Spec.UINT | |
167 | | valty C (A.Numeric (_, _, A.SIGNED, A.LONG, _)) = Spec.BASIC Spec.SLONG | |
168 | | valty C (A.Numeric (_, _, A.UNSIGNED, A.LONG, _)) = Spec.BASIC Spec.ULONG | |
169 | | valty C (A.Numeric (_, _, A.SIGNED, A.LONGLONG, _)) = | |
170 | Spec.BASIC Spec.SLONGLONG | |
171 | | valty C (A.Numeric (_, _, A.UNSIGNED, A.LONGLONG, _)) = | |
172 | Spec.BASIC Spec.ULONGLONG | |
173 | | valty C (A.Numeric (_, _, _, A.FLOAT, _)) = Spec.BASIC Spec.FLOAT | |
174 | | valty C (A.Numeric (_, _, _, A.DOUBLE, _)) = Spec.BASIC Spec.DOUBLE | |
175 | | valty C (A.Numeric (_, _, _, A.LONGDOUBLE, _)) = | |
176 | Spec.UNIMPLEMENTED "long double" | |
177 | | valty C (A.Array (NONE, t)) = valty C (A.Pointer t) | |
178 | | valty C (A.Array (SOME (n, _), t)) = | |
179 | let val d = Int.fromLarge n | |
180 | in | |
181 | if d < 0 then err "negative dimension" | |
182 | else Spec.ARR { t = valty C t, d = d, esz = sizeOf t } | |
183 | end | |
184 | | valty C (A.Pointer t) = | |
185 | (case getCoreType t of | |
186 | A.Void => Spec.VOIDPTR | |
187 | | A.Function f => fptrty C f | |
188 | | _ => Spec.PTR (cobj C t)) | |
189 | | valty C (A.Function f) = fptrty C f | |
190 | | valty C (A.StructRef tid) = typeref (tid, Spec.STRUCT, C) | |
191 | | valty C (A.UnionRef tid) = typeref (tid, Spec.UNION, C) | |
192 | | valty C (A.EnumRef tid) = typeref (tid, fn t => Spec.ENUM (t, false), C) | |
193 | | valty C (A.TypeRef tid) = | |
194 | typeref (tid, fn _ => bug "missing typedef info", C) | |
195 | | valty C A.Error = err "Error type" | |
196 | ||
197 | and valty_nonvoid C t = valty C t | |
198 | handle VoidType => err "void variable type" | |
199 | ||
200 | and fun_valty_nonvoid C t = | |
201 | case valty_nonvoid C t of | |
202 | Spec.STRUCT tag => | |
203 | raise SkipFunction "struct argument not supported" | |
204 | | Spec.UNION tag => | |
205 | raise SkipFunction "union argument not supported" | |
206 | | ty => ty | |
207 | ||
208 | and typeref (tid, otherwise, C) = | |
209 | case Tidtab.find (tidtab, tid) of | |
210 | NONE => bug "tid not bound in tidtab" | |
211 | | SOME { name = SOME n, ntype = NONE, ... } => otherwise n | |
212 | | SOME { name = NONE, ntype = NONE, ... } => | |
213 | bug "both name and ntype missing in tidtab binding" | |
214 | | SOME { name, ntype = SOME nct, location, ... } => | |
215 | (case nct of | |
216 | B.Struct (tid, members) => | |
217 | structty (tid, name, C, members, location) | |
218 | | B.Union (tid, members) => | |
219 | unionty (tid, name, C, members, location) | |
220 | | B.Enum (tid, edefs) => | |
221 | enumty (tid, name, C, edefs, location) | |
222 | | B.Typedef (_, t) => let | |
223 | val n = | |
224 | case name of | |
225 | NONE => bug "missing name in typedef" | |
226 | | SOME n => n | |
227 | val C' = mk_context_td n | |
228 | val res = valty C' t | |
229 | fun sameName { src, name, spec } = name = n | |
230 | in | |
231 | if includedTy (n, location) andalso | |
232 | not (SM.inDomain (!gtys, n)) then | |
233 | gtys := SM.insert (!gtys, n, | |
234 | { src = srcOf location, | |
235 | name = n, spec = res }) | |
236 | else (); | |
237 | res | |
238 | end) | |
239 | ||
240 | and enumty (tid, name, C, edefs, location) = let | |
241 | val (tag_stem, anon) = tagname (name, C, tid) | |
242 | val tag = reported_tagname (tag_stem, anon) | |
243 | fun one ({ name, uid, location, ctype, kind }, i) = | |
244 | { name = Symbol.name name, spec = i } | |
245 | val enums = if anon then anon_enums else named_enums | |
246 | in | |
247 | enums := SM.insert (!enums, tag, | |
248 | { src = srcOf location, | |
249 | tag = tag, | |
250 | anon = anon, | |
251 | descr = tag, | |
252 | exclude = not (includedEnum (tag, location)), | |
253 | spec = map one edefs }); | |
254 | Spec.ENUM (tag, anon) | |
255 | end | |
256 | ||
257 | and structty (tid, name, C, members, location) = let | |
258 | val (tag_stem, anon) = tagname (name, C, tid) | |
259 | val tag = reported_tagname (tag_stem, anon) | |
260 | val ty = Spec.STRUCT tag | |
261 | val C' = mk_context_su (tag_stem, anon) | |
262 | in | |
263 | if SS.member (!seen_structs, tag) then () | |
264 | else let | |
265 | val _ = seen_structs := SS.add (!seen_structs, tag) | |
266 | ||
267 | val fol = fieldOffsets (A.StructRef tid) | |
268 | val ssize = sizeOf (A.StructRef tid) | |
269 | ||
270 | fun bfspec (offset, bits, shift, (c, t)) = let | |
271 | val offset = offset | |
272 | val bits = Word.fromLargeInt bits | |
273 | val shift = eshift (shift, intbits, bits) | |
274 | val r = { offset = offset, | |
275 | constness = c, | |
276 | bits = bits, | |
277 | shift = shift } | |
278 | in | |
279 | case t of | |
280 | Spec.BASIC Spec.UINT => Spec.UBF r | |
281 | | Spec.BASIC Spec.SINT => Spec.SBF r | |
282 | | _ => err "non-int bitfield" | |
283 | end | |
284 | ||
285 | fun synthetic (synth, (_, false), _) = ([], synth) | |
286 | | synthetic (synth, (endp, true), startp) = | |
287 | if endp = startp then ([], synth) | |
288 | else ([{ name = Int.toString synth, | |
289 | spec = Spec.OFIELD | |
290 | { offset = endp, | |
291 | spec = (Spec.RW, | |
292 | Spec.ARR { t = Spec.BASIC Spec.UCHAR, | |
293 | d = startp - endp, | |
294 | esz = 1 }), | |
295 | synthetic = true } }], | |
296 | synth+1) | |
297 | ||
298 | fun build ([], synth, gap) = | |
299 | #1 (synthetic (synth, gap, ssize)) | |
300 | | build ((t, SOME m, NONE) :: rest, synth, gap) = | |
301 | let val bitoff = #bitOffset (getField (m, fol)) | |
302 | val bytoff = bitoff div bytebits | |
303 | val (filler, synth) = | |
304 | synthetic (synth, gap, bytoff) | |
305 | val endp = bytoff + sizeOf t | |
306 | in | |
307 | if bitoff mod bytebits <> 0 then | |
308 | bug "non-bitfield not on byte boundary" | |
309 | else | |
310 | filler @ | |
311 | { name = Symbol.name (#name m), | |
312 | spec = Spec.OFIELD | |
313 | { offset = bytoff, | |
314 | spec = cobj C' t, | |
315 | synthetic = false } } :: | |
316 | build (rest, synth, (endp, false)) | |
317 | end | |
318 | | build ((t, SOME m, SOME b) :: rest, synth, gap) = | |
319 | let val bitoff = #bitOffset (getField (m, fol)) | |
320 | val bytoff = | |
321 | (intalign * (bitoff div intalign)) | |
322 | div bytebits | |
323 | val gap = (#1 gap, true) | |
324 | in | |
325 | { name = Symbol.name (#name m), | |
326 | spec = bfspec (bytoff, b, | |
327 | bitoff mod intalign, | |
328 | cobj C' t) } :: | |
329 | build (rest, synth, gap) | |
330 | end | |
331 | | build ((t, NONE, SOME _) :: rest, synth, gap) = | |
332 | build (rest, synth, (#1 gap, true)) | |
333 | | build ((_, NONE, NONE) :: _, _, _) = | |
334 | bug "unnamed struct member (not bitfield)" | |
335 | ||
336 | val fields = build (members, 0, (0, false)) | |
337 | in | |
338 | structs := { src = srcOf location, | |
339 | tag = tag, | |
340 | anon = anon, | |
341 | size = Word.fromInt ssize, | |
342 | exclude = not (includedSU (tag, location)), | |
343 | fields = fields } :: !structs | |
344 | end; | |
345 | ty | |
346 | end | |
347 | ||
348 | and unionty (tid, name, C, members, location) = let | |
349 | val (tag_stem, anon) = tagname (name, C, tid) | |
350 | val tag = reported_tagname (tag_stem, anon) | |
351 | val C' = mk_context_su (tag_stem, anon) | |
352 | val ty = Spec.UNION tag | |
353 | val lsz = ref 0 | |
354 | fun mkField (t, m: A.member) = let | |
355 | val sz = sizeOf t | |
356 | in | |
357 | { name = Symbol.name (#name m), | |
358 | spec = Spec.OFIELD { offset = 0, | |
359 | spec = cobj C' t, | |
360 | synthetic = false } } | |
361 | end | |
362 | in | |
363 | if SS.member (!seen_unions, tag) then () | |
364 | else let | |
365 | val _ = seen_unions := SS.add (!seen_unions, tag) | |
366 | val all = map mkField members | |
367 | in | |
368 | unions := { src = srcOf location, | |
369 | tag = tag, | |
370 | anon = anon, | |
371 | size = Word.fromInt (sizeOf (A.UnionRef tid)), | |
372 | exclude = not (includedSU (tag, location)), | |
373 | all = all } :: !unions | |
374 | end; | |
375 | ty | |
376 | end | |
377 | ||
378 | and cobj C t = (constness t, valty_nonvoid C t) | |
379 | ||
380 | and fptrty C f = Spec.FPTR (cft C f) | |
381 | ||
382 | and cft C (res, args) = | |
383 | { res = case getCoreType res of | |
384 | A.Void => NONE | |
385 | | _ => SOME (valty_nonvoid C res), | |
386 | args = case args of | |
387 | [(arg, _)] => (case getCoreType arg of | |
388 | A.Void => [] | |
389 | | _ => [fun_valty_nonvoid C arg]) | |
390 | | _ => let fun build [] = [] | |
391 | | build [(x, _)] = | |
392 | ([fun_valty_nonvoid C x] | |
393 | handle Ellipsis => | |
394 | (warnLoc | |
395 | ("varargs not supported; \ | |
396 | \ignoring the ellipsis\n"); | |
397 | [])) | |
398 | | build ((x, _) :: xs) = | |
399 | fun_valty_nonvoid C x :: build xs | |
400 | in | |
401 | build args | |
402 | end } | |
403 | ||
404 | fun ft_argnames (res, args) = | |
405 | let val optids = map (fn (_, optid) => optid) args | |
406 | in | |
407 | if List.exists (not o isSome) optids then NONE | |
408 | else SOME (map valOf optids) | |
409 | end | |
410 | ||
411 | fun functionName (f: A.id, ailo: A.id list option) = let | |
412 | val n = Symbol.name (#name f) | |
413 | val anlo = Option.map (map (Symbol.name o #name)) ailo | |
414 | in | |
415 | if n = "_init" orelse n = "_fini" orelse | |
416 | SM.inDomain (!gfuns, n) then () | |
417 | else let | |
418 | fun doit () = | |
419 | (case getFunction (#ctype f) of | |
420 | SOME fs => | |
421 | gfuns := SM.insert (!gfuns, n, | |
422 | { src = !curLoc, | |
423 | name = n, | |
424 | spec = cft tl_context fs, | |
425 | argnames = anlo }) | |
426 | | NONE => bug "function without function type") | |
427 | handle SkipFunction reason => | |
428 | warnLoc (reason ^ "; skipping function\n") | |
429 | in | |
430 | case #stClass f of | |
431 | A.EXTERN => doit () | |
432 | | A.DEFAULT => doit () | |
433 | | A.AUTO => () | |
434 | | A.REGISTER => () | |
435 | | A.STATIC => () | |
436 | end | |
437 | end | |
438 | ||
439 | fun varDecl (v: A.id) = let | |
440 | fun doit () = | |
441 | (case getFunction (#ctype v) of | |
442 | SOME fs => if realFunctionDefComing (#name v) then () | |
443 | else functionName (v, ft_argnames fs) | |
444 | | NONE => | |
445 | let val n = Symbol.name (#name v) | |
446 | in | |
447 | if SM.inDomain (!gvars, n) then () | |
448 | else gvars := SM.insert | |
449 | (!gvars, n, | |
450 | { src = !curLoc, name = n, | |
451 | spec = cobj tl_context | |
452 | (#ctype v) }) | |
453 | end) | |
454 | in | |
455 | case #stClass v of | |
456 | A.EXTERN => doit () | |
457 | | A.DEFAULT => doit () | |
458 | | A.AUTO => () | |
459 | | A.REGISTER => () | |
460 | | A.STATIC => () | |
461 | end | |
462 | ||
463 | fun dotid tid = | |
464 | (* Spec.SINT is an arbitrary choice; the value gets | |
465 | * ignored anyway *) | |
466 | (ignore (typeref (tid, fn _ => Spec.BASIC Spec.SINT, tl_context)) | |
467 | handle VoidType => ()) (* ignore type aliases for void *) | |
468 | ||
469 | fun declaration (A.TypeDecl { tid, ... }) = dotid tid | |
470 | | declaration (A.VarDecl (v, _)) = varDecl v | |
471 | ||
472 | fun coreExternalDecl (A.ExternalDecl d) = declaration d | |
473 | | coreExternalDecl (A.FunctionDef (f, argids, _)) = | |
474 | functionName (f, SOME argids) | |
475 | | coreExternalDecl (A.ExternalDeclExt _) = () | |
476 | ||
477 | fun externalDecl (A.DECL (d, _, l)) = | |
478 | if isThisFile l then (curLoc := SourceMap.locToString l; | |
479 | coreExternalDecl d) | |
480 | else () | |
481 | ||
482 | fun doast l = app externalDecl l | |
483 | ||
484 | fun gen_enums () = let | |
485 | val ael = SM.listItems (!anon_enums) | |
486 | val nel = SM.listItems (!named_enums) | |
487 | infix $ | |
488 | fun x $ [] = [x] | |
489 | | x $ y = x :: ", " :: y | |
490 | fun onev (v as { name, spec }, m) = | |
491 | if SM.inDomain (m, name) then raise Duplicate name | |
492 | else SM.insert (m, name, v) | |
493 | fun onee ({ src, tag, anon, spec, descr, exclude }, (m, sl)) = | |
494 | (foldl onev m spec, src $ sl) | |
495 | in | |
496 | if collect_enums then | |
497 | let val (m, sl) = foldl onee (SM.empty, []) ael | |
498 | in | |
499 | if SM.isEmpty m then nel | |
500 | else { src = concat (rev sl), | |
501 | tag = "'", | |
502 | anon = false, | |
503 | descr = "collected from unnamed enumerations", | |
504 | exclude = false, | |
505 | spec = SM.listItems m } | |
506 | :: nel | |
507 | end handle Duplicate name => | |
508 | (warn (concat ["constant ", name, | |
509 | " defined more than once;\ | |
510 | \ disabling `-collect'\n"]); | |
511 | ael @ nel) | |
512 | else ael @ nel | |
513 | end | |
514 | in | |
515 | doast ast; | |
516 | app (dotid o #1) (Tidtab.listItemsi tidtab); | |
517 | { structs = !structs, | |
518 | unions = !unions, | |
519 | gtys = SM.listItems (!gtys), | |
520 | gvars = SM.listItems (!gvars), | |
521 | gfuns = SM.listItems (!gfuns), | |
522 | enums = gen_enums () } : Spec.spec | |
523 | end | |
524 | end |