Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* gen.sml |
2 | * 2005 Matthew Fluet (mfluet@acm.org) | |
3 | * Adapted for MLton. | |
4 | (* Copyright (C) 2005-2009 Henry Cejtin, Matthew Fluet, Suresh | |
5 | * Jagannathan, and Stephen Weeks. | |
6 | * | |
7 | * MLton is released under a BSD-style license. | |
8 | * See the file MLton-LICENSE for details. | |
9 | *) | |
10 | *) | |
11 | ||
12 | (* | |
13 | * gen.sml - Generating and pretty-printing ML code implementing a | |
14 | * typed interface to a C program. | |
15 | * | |
16 | * (C) 2004 The Fellowship of SML/NJ | |
17 | * | |
18 | * author: Matthias Blume (blume@tti-c.org) | |
19 | *) | |
20 | structure Gen : | |
21 | sig | |
22 | val gen : {cfiles: string list} -> unit | |
23 | end = | |
24 | struct | |
25 | ||
26 | structure Linkage = Control.Linkage | |
27 | ||
28 | structure P = PrettyPrint | |
29 | structure PP = P.PP | |
30 | structure S = Spec | |
31 | ||
32 | structure IM = IntMap | |
33 | structure LIS = LargeIntSet | |
34 | structure SM = StringMap | |
35 | structure SS = StringSet | |
36 | ||
37 | exception Incomplete | |
38 | ||
39 | val Tuple = P.TUPLE | |
40 | fun Record [] = P.Unit | |
41 | | Record l = P.RECORD l | |
42 | val Con = P.CON | |
43 | val Arrow = P.ARROW | |
44 | val Type = P.Type | |
45 | val Unit = P.Unit | |
46 | val ETuple = P.ETUPLE | |
47 | val EUnit = ETuple [] | |
48 | fun ERecord [] = P.ETUPLE [] | |
49 | | ERecord l = P.ERECORD l | |
50 | val EVar = P.EVAR | |
51 | val EApp = P.EAPP | |
52 | val EConstr = P.ECONSTR | |
53 | val ESeq = P.ESEQ | |
54 | val EPrim = P.EPRIM | |
55 | val ELet = P.ELET | |
56 | fun EWord w = EVar ("0wx" ^ Word.toString w) | |
57 | fun EInt i = EVar (Int.toString i) | |
58 | fun ELInt i = EVar (LargeInt.toString i) | |
59 | fun EString s = EVar (concat ["\"", String.toString s, "\""]) | |
60 | ||
61 | fun warn m = Out.output (Out.error, "warning: " ^ m) | |
62 | fun err m = raise Fail (concat ("gen: " :: m)) | |
63 | ||
64 | fun unimp what = raise Fail ("unimplemented type: " ^ what) | |
65 | fun unimp_arg what = raise Fail ("unimplemented argument type: " ^ what) | |
66 | fun unimp_res what = raise Fail ("unimplemented result type: " ^ what) | |
67 | ||
68 | val writeto = "write'to" | |
69 | ||
70 | fun gen args = | |
71 | let | |
72 | val {cfiles} = args | |
73 | ||
74 | val allSU = !Control.allSU | |
75 | val collect_enums = !Control.collect_enums | |
76 | val dir = !Control.dir | |
77 | val enum_cons = !Control.enum_cons | |
78 | val extramembers = !Control.extramembers | |
79 | val gensym = !Control.gensym | |
80 | val libhandle = !Control.libhandle | |
81 | val linkage = !Control.linkage | |
82 | val match = !Control.match | |
83 | val mlbfile = !Control.mlbfile | |
84 | val namedargs = !Control.namedargs | |
85 | val prefix = !Control.prefix | |
86 | val target = valOf (!Control.target) | |
87 | val weight = !Control.weight | |
88 | val width = !Control.width | |
89 | ||
90 | val gensym_suffix = | |
91 | if gensym = "" then "" else "_" ^ gensym | |
92 | val {name = targetName, | |
93 | sizes = targetSizes, | |
94 | endianShift = targetEndianShift} = target | |
95 | val targetName = String.toLower targetName | |
96 | val {heavy = doheavy, light = dolight} = weight | |
97 | ||
98 | val hash_cft = Hash.mkFHasher () | |
99 | val hash_mltype = Hash.mkTHasher () | |
100 | ||
101 | val $? = SM.find | |
102 | val %? = IM.find | |
103 | ||
104 | local | |
105 | val program = "ml-nlffigen" | |
106 | val version = "0.9.1" | |
107 | val author = "Matthias Blume" | |
108 | val email = "blume@tti-c.org" | |
109 | ||
110 | val modifications = [{author = "Matthew Fluet", | |
111 | email = "mfluet@acm.org", | |
112 | note = "Adapted for MLton."}] | |
113 | ||
114 | val credits = | |
115 | concat | |
116 | (["(* [by ", author, "'s ", | |
117 | program, " (version ", version, ") for ", targetName, "] *)"] @ | |
118 | (map (fn {author, email, note} => | |
119 | concat ["\n(* [modified by ", author, | |
120 | " (", email, ") <", note, ">] *)"])) | |
121 | modifications) | |
122 | val commentsto = | |
123 | concat ["(* Send comments and suggestions to ", email, ". Thanks! *)"] | |
124 | val dontedit = "(* This file has been generated automatically. DO NOT EDIT! *)" | |
125 | in | |
126 | fun openPP (f, src) = | |
127 | let | |
128 | val device = CPIFDev.openOut (f, width) | |
129 | val stream = PP.openStream device | |
130 | ||
131 | fun nl () = PP.newline stream | |
132 | fun str s = PP.string stream s | |
133 | fun sp () = PP.space stream 1 | |
134 | fun nsp () = PP.nbSpace stream 1 | |
135 | fun Box a = PP.openBox stream (PP.Abs a) | |
136 | fun HBox () = PP.openHBox stream | |
137 | fun HVBox x = PP.openHVBox stream x | |
138 | fun HOVBox a = PP.openHOVBox stream (PP.Abs a) | |
139 | fun VBox a = PP.openVBox stream (PP.Abs a) | |
140 | fun endBox () = PP.closeBox stream | |
141 | fun ppty t = P.ppType stream t | |
142 | fun ppExp e = P.ppExp stream e | |
143 | fun ppFun x = P.ppFun stream x | |
144 | fun line s = (nl (); str s) | |
145 | fun pr_vdef (v, e) = | |
146 | (nl (); HOVBox 4 | |
147 | ; str "val"; nsp (); str v; nsp (); str "=" ; sp (); ppExp e | |
148 | ; endBox ()) | |
149 | fun pr_fdef (f, args, res) = (nl (); ppFun (f, args, res)) | |
150 | fun pr_decl (keyword, connector) (v, t) = | |
151 | (nl (); HOVBox 4 | |
152 | ; str keyword; nsp (); str v; nsp (); str connector; sp (); ppty t | |
153 | ; endBox ()) | |
154 | val pr_tdef = pr_decl ("type", "=") | |
155 | val pr_vdecl = pr_decl ("val", ":") | |
156 | fun closePP () = (PP.closeStream stream; CPIFDev.closeOut device) | |
157 | in | |
158 | str dontedit; | |
159 | case src of | |
160 | NONE => () | |
161 | | SOME s => | |
162 | (nl (); str (concat ["(* [from code at ", s, "] *)"])); | |
163 | line credits; | |
164 | line commentsto; | |
165 | nl (); | |
166 | {stream = stream, | |
167 | line = line, nl = nl, str = str, sp = sp, nsp = nsp, | |
168 | Box = Box, endBox = endBox, | |
169 | HVBox = HVBox, HBox = HBox, HOVBox = HOVBox, VBox = VBox, | |
170 | ppty = ppty, ppExp = ppExp, ppFun = ppFun, | |
171 | pr_vdef = pr_vdef, pr_fdef = pr_fdef, | |
172 | pr_tdef = pr_tdef, pr_vdecl = pr_vdecl, | |
173 | closePP = closePP} | |
174 | end | |
175 | end | |
176 | ||
177 | local | |
178 | val cpp_tmpl = | |
179 | Option.fold | |
180 | (Process.getEnv "FFIGEN_CPP", | |
181 | defaultCppCmd, | |
182 | fn (cpp_tmpl,_) => cpp_tmpl) | |
183 | val cpp_tmpl = | |
184 | String.substituteFirst | |
185 | (cpp_tmpl, | |
186 | {substring = "%o", | |
187 | replacement = String.concatWith (List.rev (!Control.cppopts), " ")}) | |
188 | ||
189 | fun mkidlsource (cfile,ifile) = | |
190 | let | |
191 | val cpp = | |
192 | List.fold | |
193 | ([{substring = "%s", replacement = cfile}, | |
194 | {substring = "%t", replacement = ifile}], | |
195 | cpp_tmpl, | |
196 | fn (s, subst) => String.substituteFirst (subst, s)) | |
197 | in | |
198 | Process.system cpp | |
199 | end | |
200 | ||
201 | fun getSpec (cfile, s) = | |
202 | File.withTemp | |
203 | (fn ifile => | |
204 | let | |
205 | val () = mkidlsource (cfile, ifile) | |
206 | val astbundle = | |
207 | ParseToAst.fileToAst' | |
208 | Out.error | |
209 | (targetSizes, State.INITIAL) | |
210 | ifile | |
211 | val s' = | |
212 | AstToSpec.build | |
213 | {bundle = astbundle, | |
214 | sizes = targetSizes, | |
215 | collect_enums = collect_enums, | |
216 | cfiles = cfiles, | |
217 | match = match, | |
218 | allSU = allSU, | |
219 | eshift = targetEndianShift, | |
220 | gensym_suffix = gensym_suffix} | |
221 | in | |
222 | S.join (s', s) | |
223 | end) | |
224 | in | |
225 | val spec = List.fold (cfiles, S.empty, getSpec) | |
226 | end | |
227 | val {structs, unions, gvars, gfuns, gtys, enums} = spec | |
228 | ||
229 | val (structs, unions, enums) = | |
230 | let | |
231 | val structs = | |
232 | List.fold (structs, SM.empty, fn (s, m) => SM.insert (m, #tag s, s)) | |
233 | val unions = | |
234 | List.fold (unions, SM.empty, fn (s, m) => SM.insert (m, #tag s, s)) | |
235 | val enums = | |
236 | List.fold (enums, SM.empty, fn (s, m) => SM.insert (m, #tag s, s)) | |
237 | ||
238 | val sdone = ref SS.empty | |
239 | val udone = ref SS.empty | |
240 | val edone = ref SS.empty | |
241 | val smap = ref SM.empty | |
242 | val umap = ref SM.empty | |
243 | val emap = ref SM.empty | |
244 | val ty_queue = ref [] | |
245 | fun ty_sched ty = List.push (ty_queue, ty) | |
246 | fun fs_sched (S.OFIELD { spec = (_, ty), ... }) = ty_sched ty | |
247 | | fs_sched _ = () | |
248 | fun f_sched { name, spec } = fs_sched spec | |
249 | ||
250 | fun xenter (xdone, xall, xmap, xfields) t = | |
251 | if SS.member (!xdone, t) then () | |
252 | else (xdone := SS.add (!xdone, t); | |
253 | case $? (xall, t) of | |
254 | SOME x => (xmap := SM.insert (!xmap, t, x); | |
255 | app f_sched (xfields x)) | |
256 | | NONE => ()) | |
257 | ||
258 | val senter = xenter (sdone, structs, smap, #fields) | |
259 | val uenter = xenter (udone, unions, umap, #all) | |
260 | val eenter = xenter (edone, enums, emap, fn _ => []) | |
261 | ||
262 | fun sinclude (s: S.s) = if #exclude s then () else senter (#tag s) | |
263 | fun uinclude (u: S.u) = if #exclude u then () else uenter (#tag u) | |
264 | fun einclude (e: S.enum) = if #exclude e then () else eenter (#tag e) | |
265 | ||
266 | fun gty {src, name, spec} = ty_sched spec | |
267 | fun gvar {src, name, spec = (_, t)} = ty_sched t | |
268 | fun gfun {src, name, spec, argnames} = ty_sched (S.FPTR spec) | |
269 | fun loop tys = | |
270 | let | |
271 | fun do_ty ty = | |
272 | case ty of | |
273 | S.BASIC _ => () | |
274 | | S.STRUCT t => senter t | |
275 | | S.UNION t => uenter t | |
276 | | S.ENUM (t, anon) => | |
277 | if collect_enums andalso anon | |
278 | then eenter "'" | |
279 | else eenter t | |
280 | | S.VOIDPTR => () | |
281 | | S.FPTR {args, res} => | |
282 | (List.foreach (args, do_ty); Option.app (res, do_ty)) | |
283 | | S.PTR (_, S.STRUCT t) => () | |
284 | | S.PTR (_, S.UNION t) => () | |
285 | | S.PTR (_, t) => do_ty t | |
286 | | S.ARR {t, ... } => do_ty t | |
287 | | S.UNIMPLEMENTED _ => () | |
288 | fun ty_loop tys = | |
289 | case tys of | |
290 | [] => nextround () | |
291 | | ty :: tys => (do_ty ty; ty_loop tys) | |
292 | in | |
293 | case tys of | |
294 | [] => () | |
295 | | _ => (ty_queue := []; ty_loop tys) | |
296 | end | |
297 | and nextround () = loop (!ty_queue) | |
298 | in | |
299 | SM.app sinclude structs; | |
300 | SM.app uinclude unions; | |
301 | SM.app einclude enums; | |
302 | app gty gtys; | |
303 | app gvar gvars; | |
304 | app gfun gfuns; | |
305 | nextround (); | |
306 | (!smap, !umap, !emap) | |
307 | end | |
308 | val (fptr_types,incomplete_structs, incomplete_unions, incomplete_enums) = | |
309 | let | |
310 | fun taginsert (t, ss) = | |
311 | if SS.member (ss, t) then ss else SS.add (ss, t) | |
312 | fun sinsert (t, (f, s, u, e)) = | |
313 | (f, taginsert (t, s), u, e) | |
314 | fun uinsert (t, (f, s, u, e)) = | |
315 | (f, s, taginsert (t, u), e) | |
316 | fun einsert (t, (f, s, u, e)) = | |
317 | (f, s, u, taginsert (t, e)) | |
318 | fun maybe_insert (t, ss, acc, insert) = | |
319 | case $? (ss, t) of | |
320 | SOME _ => acc | |
321 | | NONE => insert (t, acc) | |
322 | ||
323 | fun do_ty (ty, acc) = | |
324 | case ty of | |
325 | S.BASIC _ => acc | |
326 | | S.STRUCT t => maybe_insert (t, structs, acc, sinsert) | |
327 | | S.UNION t => maybe_insert (t, unions, acc, uinsert) | |
328 | | S.ENUM (t, anon) => | |
329 | if collect_enums andalso anon | |
330 | then acc | |
331 | else maybe_insert (t, enums, acc, einsert) | |
332 | | S.VOIDPTR => acc | |
333 | | S.FPTR (cft as {args, res}) => | |
334 | let | |
335 | val acc as (f, s, u, e) = | |
336 | Option.fold (res, List.fold (args, acc, do_ty), do_ty) | |
337 | val cfth = hash_cft cft | |
338 | val i = IM.numItems f | |
339 | in | |
340 | if IM.inDomain (f, cfth) | |
341 | then acc | |
342 | else (IM.insert (f, cfth, (cft, i)), s, u, e) | |
343 | end | |
344 | | S.PTR (_, ty) => do_ty (ty, acc) | |
345 | | S.ARR {t = ty, ...} => do_ty (ty, acc) | |
346 | | S.UNIMPLEMENTED _ => acc | |
347 | ||
348 | fun fs (S.OFIELD {spec = (_, ty), ...}, acc) = do_ty (ty, acc) | |
349 | | fs (_, acc) = acc | |
350 | fun f ({name, spec}, acc) = fs (spec, acc) | |
351 | fun s ({src, tag, size, anon, fields, exclude}, acc) = | |
352 | List.fold (fields, acc, f) | |
353 | fun u ({src, tag, size, anon, all, exclude}, acc) = | |
354 | List.fold (all, acc, f) | |
355 | ||
356 | fun gvar ({src, name, spec = (_, ty)}, acc) = do_ty (ty, acc) | |
357 | fun gfun ({src, name, spec, argnames}, acc) = do_ty (S.FPTR spec, acc) | |
358 | fun gty ({src, name, spec}, acc) = do_ty (spec, acc) | |
359 | ||
360 | fun lfold (l, f, b) = List.fold (l, b, f) | |
361 | fun mfold (m, f, b) = SM.foldl f b m | |
362 | in | |
363 | lfold (gvars, gvar, | |
364 | lfold (gfuns, gfun, | |
365 | lfold (gtys, gty, | |
366 | mfold (structs, s, | |
367 | mfold (unions, u, | |
368 | (IM.empty, SS.empty, SS.empty, SS.empty)))))) | |
369 | end | |
370 | fun s_inc t = SS.member (incomplete_structs, t) | |
371 | fun u_inc t = SS.member (incomplete_unions, t) | |
372 | ||
373 | fun Gstruct n = concat [prefix, "G_", n] | |
374 | fun Fstruct n = concat [prefix, "F_", n] | |
375 | fun fptr_rtti_struct_id i = "FPtrRTTI_" ^ Int.toString i | |
376 | fun Tstruct n = concat [prefix, "T_", n] | |
377 | ||
378 | fun SUETstruct K t = concat [K, "T_", t] | |
379 | val STstruct = SUETstruct "S" | |
380 | val UTstruct = SUETstruct "U" | |
381 | fun Suobj'rw p sut = Con ("su_obj" ^ p, [sut, Type "rw"]) | |
382 | fun Suobj'ro sut = Con ("su_obj'", [sut, Type "ro"]) | |
383 | ||
384 | fun SUEstruct K t = concat [prefix, K, "_", t] | |
385 | val Sstruct = SUEstruct "S" | |
386 | val Ustruct = SUEstruct "U" | |
387 | val Estruct = SUEstruct "E" | |
388 | fun Estruct' (n, anon) = | |
389 | Estruct (if anon andalso collect_enums then "'" else n) | |
390 | ||
391 | fun fieldtype_id n = "t_f_" ^ n | |
392 | fun fieldrtti_id n = "typ_f_" ^ n | |
393 | fun field_id (n, p) = concat ["f_", n, p] | |
394 | ||
395 | fun enum_id n = "e_" ^ n | |
396 | ||
397 | val pending = ref [] | |
398 | val exports = ref [] | |
399 | val files = ref [] | |
400 | ||
401 | local | |
402 | val dir_exists = ref false | |
403 | val checkDir = fn () => | |
404 | if !dir_exists | |
405 | then () | |
406 | else (dir_exists := true; | |
407 | if OS.FileSys.isDir dir handle _ => false | |
408 | then () | |
409 | else OS.FileSys.mkDir dir) | |
410 | in | |
411 | fun smlFileAndExport (file,export,do_export) = | |
412 | let | |
413 | (* We don't want apostrophes in file names -> turn them into minuses. | |
414 | * We also want to use only lowercase characters as some file systems | |
415 | * are case insensitive. | |
416 | *) | |
417 | val base = Vector.map (file, fn #"'" => #"-" | c => Char.toLower c) | |
418 | fun pick i = let | |
419 | val file = OS.Path.joinBaseExt | |
420 | {base = if i=0 then base | |
421 | else concat [base, "-", Int.toString i], | |
422 | ext = SOME "sml"} | |
423 | in | |
424 | if List.exists (!files, fn f => f = file) then pick (i+1) | |
425 | else file | |
426 | end | |
427 | val file = pick 0 | |
428 | val result = OS.Path.joinDirFile {dir = dir, file = file} | |
429 | in | |
430 | checkDir () | |
431 | ; List.push (pending, export) | |
432 | ; (result, fn () => (List.push (files, file) | |
433 | ; if do_export | |
434 | then List.push (exports, export) | |
435 | else () | |
436 | ; ignore (List.pop pending))) | |
437 | end | |
438 | fun descrFile file = | |
439 | let | |
440 | val result = OS.Path.joinDirFile {dir = dir, file = file} | |
441 | in | |
442 | checkDir () | |
443 | ; result | |
444 | end | |
445 | end | |
446 | ||
447 | fun rwro_str S.RW = "rw" | |
448 | | rwro_str S.RO = "ro" | |
449 | fun rwro_type c = Type (rwro_str c) | |
450 | fun rwro_c_type S.RW = Type "'c" | |
451 | | rwro_c_type S.RO = Type "ro" | |
452 | ||
453 | fun dim_ty 0 = Type "dec" | |
454 | | dim_ty n = Con ("dg" ^ Int.toString (n mod 10), | |
455 | [dim_ty (n div 10)]) | |
456 | val dim_ty = fn n => | |
457 | if n < 0 | |
458 | then raise Fail "negative dimension" | |
459 | else dim_ty n | |
460 | ||
461 | fun dim_val n = | |
462 | let | |
463 | fun build 0 = EVar "dec" | |
464 | | build n = EApp (build (n div 10), | |
465 | EVar ("dg" ^ Int.toString (n mod 10))) | |
466 | in | |
467 | EApp (build n, EVar "dim") | |
468 | end | |
469 | ||
470 | fun stem basic_t = | |
471 | case basic_t of | |
472 | S.SCHAR => "schar" | |
473 | | S.UCHAR => "uchar" | |
474 | | S.SSHORT => "sshort" | |
475 | | S.USHORT => "ushort" | |
476 | | S.SINT => "sint" | |
477 | | S.UINT => "uint" | |
478 | | S.SLONG => "slong" | |
479 | | S.ULONG => "ulong" | |
480 | | S.SLONGLONG => "slonglong" | |
481 | | S.ULONGLONG => "ulonglong" | |
482 | | S.FLOAT => "float" | |
483 | | S.DOUBLE => "double" | |
484 | ||
485 | val bytebits = #bits (#char targetSizes) | |
486 | fun sizeof_basic basic_t = | |
487 | case basic_t of | |
488 | S.SCHAR => #bits (#char targetSizes) | |
489 | | S.UCHAR => #bits (#char targetSizes) | |
490 | | S.SSHORT => #bits (#short targetSizes) | |
491 | | S.USHORT => #bits (#short targetSizes) | |
492 | | S.SINT => #bits (#int targetSizes) | |
493 | | S.UINT => #bits (#int targetSizes) | |
494 | | S.SLONG => #bits (#long targetSizes) | |
495 | | S.ULONG => #bits (#long targetSizes) | |
496 | | S.SLONGLONG => #bits (#longlong targetSizes) | |
497 | | S.ULONGLONG => #bits (#longlong targetSizes) | |
498 | | S.FLOAT => #bits (#float targetSizes) | |
499 | | S.DOUBLE => #bits (#double targetSizes) | |
500 | and sizeof t = | |
501 | case t of | |
502 | S.BASIC basic_t => Word.fromInt ((sizeof_basic basic_t) div bytebits) | |
503 | | S.STRUCT t => | |
504 | (case $? (structs, t) of | |
505 | SOME {size, ...} => size | |
506 | | NONE => err ["incomplete struct argument: struct ", t]) | |
507 | | S.UNION t => | |
508 | (case $? (unions, t) of | |
509 | SOME {size, ...} => size | |
510 | | NONE => err ["incomplete union argument: union ", t]) | |
511 | | S.ENUM _ => Word.fromInt ((#bits (#int targetSizes)) div bytebits) | |
512 | | S.VOIDPTR => Word.fromInt ((#bits (#pointer targetSizes)) div bytebits) | |
513 | | S.FPTR _ => Word.fromInt ((#bits (#pointer targetSizes)) div bytebits) | |
514 | | S.PTR _ => Word.fromInt ((#bits (#pointer targetSizes)) div bytebits) | |
515 | | S.ARR {d, esz, ...} => Word.fromInt (d * esz) | |
516 | | S.UNIMPLEMENTED what => unimp what | |
517 | ||
518 | val genStructTable : (String.t * unit Promise.t) HashSet.t = | |
519 | HashSet.new {hash = fn (structname, _) => String.hash structname} | |
520 | fun fillGenStructTable (app, coll, pr_promise) = | |
521 | app (coll, fn elem => | |
522 | let val (structname, promise) = pr_promise elem | |
523 | in | |
524 | (ignore o HashSet.lookupOrInsert) | |
525 | (genStructTable, String.hash structname, | |
526 | fn (s,_) => String.equals (structname, s), | |
527 | fn () => (structname, promise)) | |
528 | end) | |
529 | fun fillGenStructTable' (app, coll, pr_promise) = | |
530 | fillGenStructTable (fn (c, f) => app f c, coll, pr_promise) | |
531 | fun forceGenStruct structname = | |
532 | case HashSet.peek (genStructTable, String.hash structname, | |
533 | fn (s,_) => String.equals (structname, s)) of | |
534 | SOME (_,promise) => (Promise.force promise; structname) | |
535 | | NONE => err ["missing structure: ", structname] | |
536 | ||
537 | fun SUEtag K tag = | |
538 | Type ((forceGenStruct (SUETstruct K tag)) ^ ".tag") | |
539 | val Stag = SUEtag "S" | |
540 | val Utag = SUEtag "U" | |
541 | fun Etag (tag, anon) = | |
542 | SUEtag "E" (if collect_enums andalso anon then "'" else tag) | |
543 | fun SUEtyp K tag = | |
544 | EVar ((forceGenStruct (SUETstruct K tag)) ^ ".typ") | |
545 | val Styp = SUEtyp "S" | |
546 | val Utyp = SUEtyp "U" | |
547 | ||
548 | fun fptr_rtti_qid i = | |
549 | (forceGenStruct (fptr_rtti_struct_id i)) ^ ".typ" | |
550 | fun fptr_mkcall_qid i = | |
551 | (forceGenStruct (fptr_rtti_struct_id i)) ^ ".mkcall" | |
552 | ||
553 | fun witness_fptr_type_p prime {args, res} = | |
554 | let | |
555 | fun top_type ty = | |
556 | case ty of | |
557 | S.STRUCT t => Suobj'ro (Stag t) | |
558 | | S.UNION t => Suobj'ro (Utag t) | |
559 | | ty => witness_type' ty | |
560 | val (res_t, extra_arg_t) = | |
561 | case res of | |
562 | NONE => (Unit, []) | |
563 | | SOME (S.STRUCT t) => | |
564 | let val ot = Suobj'rw "'" (Stag t) | |
565 | in (ot, [ot]) | |
566 | end | |
567 | | SOME (S.UNION t) => | |
568 | let val ot = Suobj'rw "'" (Utag t) | |
569 | in (ot, [ot]) | |
570 | end | |
571 | | SOME ty => (top_type ty, []) | |
572 | val arg_tl = extra_arg_t @ (List.map (args, top_type)) | |
573 | val dom_t = Tuple arg_tl | |
574 | val fct_t = Arrow (dom_t, res_t) | |
575 | in | |
576 | Con ("fptr" ^ prime, [fct_t]) | |
577 | end | |
578 | and witness_type_p prime ty = | |
579 | (case ty of | |
580 | S.BASIC basic_t => Type (stem basic_t) | |
581 | | S.STRUCT t => Con ("su", [Stag t]) | |
582 | | S.UNION t => Con ("su", [Utag t]) | |
583 | | S.ENUM t => Con ("enum", [Etag t]) | |
584 | | S.VOIDPTR => Type "voidptr" | |
585 | | S.FPTR spec => witness_fptr_type_p prime spec | |
586 | | S.PTR (c, ty) => | |
587 | Con ("ptr" ^ prime, | |
588 | [Con ("obj", [witness_type ty, rwro_type c])]) | |
589 | | S.ARR {t = ty, d, ...} => | |
590 | Con ("arr", [witness_type ty, dim_ty d]) | |
591 | | S.UNIMPLEMENTED what => unimp what) | |
592 | and witness_type ty = | |
593 | witness_type_p "" ty | |
594 | and witness_type' ty = | |
595 | witness_type_p "'" ty | |
596 | ||
597 | fun topfunc_type prime ({args, res}, argnames) = | |
598 | let | |
599 | fun top_type ty = | |
600 | case ty of | |
601 | S.BASIC S.SCHAR => Type "MLRep.Char.Signed.int" | |
602 | | S.BASIC S.UCHAR => Type "MLRep.Char.Unsigned.word" | |
603 | | S.BASIC S.SSHORT => Type "MLRep.Short.Signed.int" | |
604 | | S.BASIC S.USHORT => Type "MLRep.Short.Unsigned.word" | |
605 | | S.BASIC S.SINT => Type "MLRep.Int.Signed.int" | |
606 | | S.BASIC S.UINT => Type "MLRep.Int.Unsigned.word" | |
607 | | S.BASIC S.SLONG => Type "MLRep.Long.Signed.int" | |
608 | | S.BASIC S.ULONG => Type "MLRep.Long.Unsigned.word" | |
609 | | S.BASIC S.SLONGLONG => Type "MLRep.LongLong.Signed.int" | |
610 | | S.BASIC S.ULONGLONG => Type "MLRep.LongLong.Unsigned.word" | |
611 | | S.BASIC S.FLOAT => Type "MLRep.Float.real" | |
612 | | S.BASIC S.DOUBLE => Type "MLRep.Double.real" | |
613 | | S.STRUCT t => Con ("su_obj" ^ prime, [Stag t, Type "'c"]) | |
614 | | S.UNION t => Con ("su_obj" ^ prime, [Utag t, Type "'c"]) | |
615 | | S.ENUM _ => Type "MLRep.Int.Signed.int" | |
616 | | ty => witness_type_p prime ty | |
617 | val (res_t, extra_arg_t, extra_argname) = | |
618 | case res of | |
619 | NONE => (Unit, [], []) | |
620 | | SOME (S.STRUCT t) => | |
621 | let val ot = Suobj'rw prime (Stag t) | |
622 | in (ot, [ot], [writeto]) | |
623 | end | |
624 | | SOME (S.UNION t) => | |
625 | let val ot = Suobj'rw prime (Utag t) | |
626 | in (ot, [ot], [writeto]) | |
627 | end | |
628 | | SOME ty => (top_type ty, [], []) | |
629 | val arg_tl = List.map (args, top_type) | |
630 | val arg_t = | |
631 | case (namedargs, argnames) of | |
632 | (true, SOME nl) => | |
633 | (Record o List.zip) | |
634 | (extra_argname @ nl, | |
635 | extra_arg_t @ arg_tl) | |
636 | | _ => Tuple (extra_arg_t @ arg_tl) | |
637 | in | |
638 | Arrow (arg_t, res_t) | |
639 | end | |
640 | ||
641 | fun rtti_type ty = | |
642 | Con ("T.typ", [witness_type ty]) | |
643 | ||
644 | local | |
645 | fun simple v = EVar ("T." ^ v) | |
646 | in | |
647 | fun rtti_val ty = | |
648 | case ty of | |
649 | S.BASIC basic_t => simple (stem basic_t) | |
650 | | S.STRUCT t => | |
651 | if s_inc t then raise Incomplete else Styp t | |
652 | | S.UNION t => | |
653 | if u_inc t then raise Incomplete else Utyp t | |
654 | | S.ENUM t => | |
655 | EConstr (EVar "T.enum", Con ("T.typ", [Con ("enum", [Etag t])])) | |
656 | | S.VOIDPTR => simple "voidptr" | |
657 | | S.FPTR cft => | |
658 | let | |
659 | val cfth = hash_cft cft | |
660 | in | |
661 | case %? (fptr_types, cfth) of | |
662 | SOME (_, i) => EVar (fptr_rtti_qid i) | |
663 | | NONE => raise Fail "fptr type missing" | |
664 | end | |
665 | | S.PTR (S.RW, ty) => | |
666 | EApp (EVar "T.pointer", rtti_val ty) | |
667 | | S.PTR (S.RO, ty) => | |
668 | EApp (EVar "T.ro", EApp (EVar "T.pointer", rtti_val ty)) | |
669 | | S.ARR {t = ty, d, ...} => | |
670 | EApp (EVar "T.arr", ETuple [rtti_val ty, dim_val d]) | |
671 | | S.UNIMPLEMENTED what => raise Incomplete | |
672 | end | |
673 | ||
674 | fun fptr_mkcall spec = | |
675 | let | |
676 | val h = hash_cft spec | |
677 | in | |
678 | case %? (fptr_types, h) of | |
679 | SOME (_, i) => fptr_mkcall_qid i | |
680 | | NONE => raise Fail "missing fptr_type (mkcall)" | |
681 | end | |
682 | ||
683 | fun pr_addr_import (pr_fdef, name, attrs) = | |
684 | pr_fdef ("h", [EUnit], | |
685 | EPrim ("_address \"" ^ name ^ "\" " ^ attrs, | |
686 | Type "CMemory.addr")) | |
687 | ||
688 | fun pr_gvar_promise x = | |
689 | let | |
690 | val {src, name, spec = (c, t)} = x | |
691 | val gstruct = Gstruct name | |
692 | val gstruct_export = "structure " ^ gstruct | |
693 | in | |
694 | (gstruct, | |
695 | Promise.delay | |
696 | (fn () => | |
697 | let | |
698 | val (file, done) = | |
699 | smlFileAndExport ("g-" ^ name, gstruct_export, true) | |
700 | val {closePP, str, nl, Box, VBox, endBox, | |
701 | pr_fdef, pr_vdef, pr_tdef, ...} = | |
702 | openPP (file, SOME src) | |
703 | fun doit () = | |
704 | let | |
705 | val () = pr_tdef ("t", witness_type t) | |
706 | val incomplete = | |
707 | (pr_vdef ("typ", | |
708 | EConstr (rtti_val t, | |
709 | Con ("T.typ", [Type "t"]))) | |
710 | ; false) | |
711 | handle Incomplee => true | |
712 | val obj' = | |
713 | EConstr (EApp (EVar "mk_obj'", EApp (EVar "h", EUnit)), | |
714 | Con ("obj'", [Type "t", rwro_type c])) | |
715 | val dolight = dolight orelse incomplete | |
716 | in | |
717 | if dolight then pr_fdef ("obj'", [EUnit], obj') else (); | |
718 | if doheavy andalso not incomplete | |
719 | then pr_fdef ("obj", [EUnit], | |
720 | EApp (EApp (EVar "Heavy.obj", EVar "typ"), | |
721 | if dolight | |
722 | then EApp (EVar "obj'", EUnit) | |
723 | else obj')) | |
724 | else () | |
725 | end | |
726 | in | |
727 | str "local"; | |
728 | VBox 4; | |
729 | nl (); str "open C.Dim C_Int"; | |
730 | case linkage of | |
731 | Control.Linkage.Archive => | |
732 | pr_addr_import (pr_fdef, name, "public") | |
733 | | Control.Linkage.Dynamic => | |
734 | pr_vdef ("h", EApp (EVar libhandle, EString name)) | |
735 | | Control.Linkage.Shared => | |
736 | pr_addr_import (pr_fdef, name, "external"); | |
737 | endBox (); | |
738 | nl (); str "in"; | |
739 | VBox 4; | |
740 | nl (); str (gstruct_export ^ " = struct"); | |
741 | Box 4; | |
742 | doit (); | |
743 | endBox (); | |
744 | nl (); str "end"; | |
745 | endBox (); | |
746 | nl (); str "end"; nl (); | |
747 | closePP (); | |
748 | done () | |
749 | end)) | |
750 | end | |
751 | val () = fillGenStructTable (List.foreach, gvars, pr_gvar_promise) | |
752 | ||
753 | fun pr_gfun_promise x = | |
754 | let | |
755 | val {src, name, spec as {args, res}, argnames} = x | |
756 | val fstruct = Fstruct name | |
757 | val fstruct_export = "structure " ^ fstruct | |
758 | in | |
759 | (fstruct, | |
760 | Promise.delay | |
761 | (fn () => | |
762 | let | |
763 | val (file, done) = | |
764 | smlFileAndExport ("f-" ^ name, fstruct_export, true) | |
765 | val {closePP, str, nl, Box, VBox, endBox, | |
766 | pr_fdef, pr_vdef, pr_vdecl, ...} = | |
767 | openPP (file, SOME src) | |
768 | fun doit is_light = | |
769 | let | |
770 | val ml_vars = | |
771 | List.mapi | |
772 | (args, fn (i, _) => | |
773 | EVar ("x" ^ Int.toString (i + 1))) | |
774 | fun app0 (what, e) = | |
775 | if is_light then e else EApp (EVar what, e) | |
776 | fun light (what, e) = app0 ("Light." ^ what, e) | |
777 | fun heavy (what, t, e) = | |
778 | if is_light | |
779 | then e | |
780 | else EApp (EApp (EVar ("Heavy." ^ what), rtti_val t), e) | |
781 | fun oneArg (e, t) = | |
782 | case t of | |
783 | S.BASIC basic_t => | |
784 | EApp (EVar ("Cvt.c_" ^ stem basic_t), e) | |
785 | | S.STRUCT _ => EApp (EVar "ro'", light ("obj", e)) | |
786 | | S.UNION _ => EApp (EVar "ro'", light ("obj", e)) | |
787 | | S.ENUM _ => EApp (EVar "Cvt.i2c_enum", e) | |
788 | | S.PTR _ => light ("ptr", e) | |
789 | | S.FPTR _ => light ("fptr", e) | |
790 | | S.VOIDPTR => e | |
791 | | S.UNIMPLEMENTED what => unimp_arg what | |
792 | | S.ARR _ => raise Fail "array argument type" | |
793 | val c_exps = List.map2 (ml_vars, args, oneArg) | |
794 | val (ml_vars, c_exps, extra_argname) = | |
795 | let | |
796 | fun do_su () = | |
797 | let val x0 = EVar "x0" | |
798 | in | |
799 | (x0 :: ml_vars, | |
800 | light ("obj", x0) :: c_exps, | |
801 | [writeto]) | |
802 | end | |
803 | in | |
804 | case res of | |
805 | SOME (S.STRUCT _) => do_su () | |
806 | | SOME (S.UNION _) => do_su () | |
807 | | _ => (ml_vars, c_exps, []) | |
808 | end | |
809 | val call = EApp (EVar "call", | |
810 | ETuple [EApp (EVar "fptr", EUnit), | |
811 | ETuple c_exps]) | |
812 | val ml_res = | |
813 | case res of | |
814 | NONE => call | |
815 | | SOME t => | |
816 | (case t of | |
817 | S.BASIC basic_t => | |
818 | EApp (EVar ("Cvt.ml_" ^ stem basic_t), call) | |
819 | | S.STRUCT _ => heavy ("obj", t, call) | |
820 | | S.UNION _ => heavy ("obj", t, call) | |
821 | | S.ENUM _ => EApp (EVar "Cvt.c2i_enum", call) | |
822 | | S.PTR _ => heavy ("ptr", t, call) | |
823 | | S.FPTR _ => heavy ("fptr", t, call) | |
824 | | S.VOIDPTR => call | |
825 | | S.UNIMPLEMENTED what => unimp_res what | |
826 | | S.ARR _ => raise Fail "array result type") | |
827 | in | |
828 | fn () => | |
829 | pr_fdef (if is_light then "f'" else "f", [ETuple ml_vars], ml_res) | |
830 | end | |
831 | fun do_fsig is_light = | |
832 | let val prime = if is_light then "'" else "" | |
833 | in pr_vdecl ("f" ^ prime, topfunc_type prime (spec, argnames)) | |
834 | end | |
835 | val (do_f_heavy, incomplete) = | |
836 | (if doheavy then doit false else (fn () => ()), false) | |
837 | handle Incomplete => (fn () => (), true) | |
838 | val do_f_light = | |
839 | if dolight orelse incomplete then doit true else (fn () => ()) | |
840 | in | |
841 | str "local"; | |
842 | VBox 4; | |
843 | nl (); str "open C.Dim C_Int"; | |
844 | case linkage of | |
845 | Control.Linkage.Archive => | |
846 | pr_addr_import (pr_fdef, name, "public") | |
847 | | Control.Linkage.Dynamic => | |
848 | pr_vdef ("h", EApp (EVar libhandle, EString name)) | |
849 | | Control.Linkage.Shared => | |
850 | pr_addr_import (pr_fdef, name, "external"); | |
851 | endBox (); | |
852 | nl (); str "in"; | |
853 | VBox 4; | |
854 | nl (); str (fstruct_export ^ " : sig"); | |
855 | Box 4; | |
856 | pr_vdecl ("typ", rtti_type (S.FPTR spec)); | |
857 | pr_vdecl ("fptr", Arrow (Unit, witness_type (S.FPTR spec))); | |
858 | if doheavy andalso not incomplete then do_fsig false else (); | |
859 | if dolight orelse incomplete then do_fsig true else (); | |
860 | endBox (); | |
861 | nl (); str "end = struct"; | |
862 | Box 4; | |
863 | pr_vdef ("typ", rtti_val (S.FPTR spec)); | |
864 | pr_fdef ("fptr", | |
865 | [EUnit], | |
866 | EApp (EVar "mk_fptr", | |
867 | ETuple [EVar (fptr_mkcall spec), | |
868 | EApp (EVar "h", EUnit)])); | |
869 | do_f_heavy (); | |
870 | do_f_light (); | |
871 | endBox (); | |
872 | nl (); str "end"; | |
873 | endBox (); | |
874 | nl (); str "end"; nl (); | |
875 | closePP (); | |
876 | done () | |
877 | end)) | |
878 | end | |
879 | val () = fillGenStructTable (List.foreach, gfuns, pr_gfun_promise) | |
880 | ||
881 | val get_callop = | |
882 | let | |
883 | val ncallops = ref 0 | |
884 | val callops = ref IM.empty | |
885 | fun callop_sid i = "Callop_" ^ Int.toString i | |
886 | fun callop_qid i = callop_sid i ^ ".callop" | |
887 | fun get (ml_args_t, ml_res_t) = | |
888 | let | |
889 | val e_proto_hash = hash_mltype (Arrow (ml_args_t, ml_res_t)) | |
890 | in | |
891 | case %? (!callops, e_proto_hash) of | |
892 | SOME i => callop_qid i | |
893 | | NONE => | |
894 | let | |
895 | val i = !ncallops | |
896 | val sn = callop_sid i | |
897 | val sn_export = "structure " ^ sn | |
898 | val (file, done) = | |
899 | smlFileAndExport | |
900 | ("callop-" ^ Int.toString i, sn_export, false) | |
901 | val {closePP, str, nl, Box, VBox, endBox, | |
902 | pr_fdef, pr_vdef, pr_tdef, ...} = | |
903 | openPP (file, NONE) | |
904 | in | |
905 | ncallops := i + 1; | |
906 | callops := IM.insert (!callops, e_proto_hash, i); | |
907 | str (sn_export ^ " = struct"); | |
908 | Box 4; | |
909 | pr_vdef ("callop", | |
910 | EPrim ("_import *", | |
911 | Arrow (Type "CMemory.addr", | |
912 | Arrow (ml_args_t, | |
913 | ml_res_t)))); | |
914 | endBox (); | |
915 | nl (); str "end"; nl (); | |
916 | closePP (); | |
917 | done (); | |
918 | callop_qid i | |
919 | end | |
920 | end | |
921 | in | |
922 | get | |
923 | end | |
924 | ||
925 | fun pr_fptr_rtti_promise x = | |
926 | let | |
927 | val ({args, res}, i) = x | |
928 | val fstruct = fptr_rtti_struct_id i | |
929 | val fstruct_export = "structure " ^ fstruct | |
930 | in | |
931 | (fstruct, | |
932 | Promise.delay | |
933 | (fn () => | |
934 | let | |
935 | val (file, done) = | |
936 | smlFileAndExport ("fptr-rtti-" ^ (Int.toString i), fstruct_export, false) | |
937 | val {closePP, str, nl, Box, VBox, endBox, | |
938 | pr_fdef, pr_vdef, pr_tdef, ...} = | |
939 | openPP (file, NONE) | |
940 | ||
941 | fun mlty ty = | |
942 | case ty of | |
943 | S.BASIC basic_t => Type ("CMemory.cc_" ^ stem basic_t) | |
944 | | S.STRUCT _ => Type "CMemory.cc_addr" | |
945 | | S.UNION _ => Type "CMemory.cc_addr" | |
946 | | S.ENUM _ => Type "CMemory.cc_sint" | |
947 | | S.VOIDPTR => Type "CMemory.cc_addr" | |
948 | | S.FPTR _ => Type "CMemory.cc_addr" | |
949 | | S.PTR _ => Type "CMemory.cc_addr" | |
950 | | S.ARR _ => raise Fail "unexpected type" | |
951 | | S.UNIMPLEMENTED what => unimp what | |
952 | fun wrap (e, n) = | |
953 | EApp (EVar ("CMemory.wrap_" ^ n), | |
954 | EApp (EVar ("Cvt.ml_" ^ n), e)) | |
955 | fun fldwrap (e, n, alt) = | |
956 | EApp (EVar ("CMemory.wrap_" ^ n), | |
957 | EApp (EVar ("Get." ^ n ^ alt), e)) | |
958 | fun vwrap e = | |
959 | EApp (EVar "CMemory.wrap_addr", | |
960 | EApp (EVar "reveal", e)) | |
961 | fun fwrap e = | |
962 | EApp (EVar "CMemory.wrap_addr", | |
963 | EApp (EVar "freveal", e)) | |
964 | fun pwrap e = | |
965 | EApp (EVar "CMemory.wrap_addr", | |
966 | EApp (EVar "reveal", | |
967 | EApp (EVar "Ptr.inject'", e))) | |
968 | fun fldvwrap (e, alt) = | |
969 | EApp (EVar "CMemory.wrap_addr", | |
970 | EApp (EVar "reveal", | |
971 | EApp (EVar ("Get.voidptr" ^ alt), e))) | |
972 | fun fldfwrap (e, alt) = | |
973 | EApp (EVar "CMemory.wrap_addr", | |
974 | EApp (EVar "freveal", | |
975 | if alt = "'" | |
976 | then EApp (EVar "Get.fptr'", e) | |
977 | else EApp (EVar "Light.fptr", | |
978 | EApp (EVar "Get.fptr", e)))) | |
979 | fun fldpwrap (e, alt) = | |
980 | EApp (EVar "CMemory.wrap_addr", | |
981 | EApp (EVar "reveal", | |
982 | EApp (EVar ("Ptr.inject" ^ alt), | |
983 | EApp (EVar ("Get.ptr" ^ alt), e)))) | |
984 | fun suwrap e = | |
985 | pwrap (EApp (EVar "Ptr.|&!", e)) | |
986 | fun ewrap e = | |
987 | EApp (EVar "CMemory.wrap_sint", | |
988 | EApp (EVar "Cvt.c2i_enum", e)) | |
989 | fun fldewrap (e, alt) = | |
990 | EApp (EVar "CMemory.wrap_sint", | |
991 | EApp (EVar ("Get.enum" ^ alt), e)) | |
992 | ||
993 | val (ml_res_t, | |
994 | extra_arg_v, extra_arg_e, extra_ml_arg_t, | |
995 | res_wrap) = | |
996 | case res of | |
997 | NONE => | |
998 | (Unit, [], [], [], fn r => r) | |
999 | | SOME (S.STRUCT _) => | |
1000 | (Unit, | |
1001 | [EVar "x0"], | |
1002 | [suwrap (EVar "x0")], | |
1003 | [Type "CMemory.cc_addr"], | |
1004 | fn r => ESeq (r, EVar "x0")) | |
1005 | | SOME (S.UNION _) => | |
1006 | (Unit, | |
1007 | [EVar "x0"], | |
1008 | [suwrap (EVar "x0")], | |
1009 | [Type "CMemory.cc_addr"], | |
1010 | fn r => ESeq (r, EVar "x0")) | |
1011 | | SOME t => | |
1012 | let | |
1013 | fun unwrap n r = | |
1014 | EApp (EVar ("Cvt.c_" ^ n), | |
1015 | EApp (EVar ("CMemory.unwrap_" ^ n), r)) | |
1016 | fun punwrap cast r = | |
1017 | EApp (EVar cast, | |
1018 | EApp (EVar "CMemory.unwrap_addr", r)) | |
1019 | fun eunwrap r = | |
1020 | EApp (EVar "Cvt.i2c_enum", | |
1021 | EApp (EVar "CMemory.unwrap_sint", r)) | |
1022 | val res_wrap = | |
1023 | case t of | |
1024 | S.BASIC basic_t => unwrap (stem basic_t) | |
1025 | | S.STRUCT _ => | |
1026 | raise Fail "unexpected result type" | |
1027 | | S.UNION _ => | |
1028 | raise Fail "unexpected result type" | |
1029 | | S.ENUM _ => eunwrap | |
1030 | | S.VOIDPTR => punwrap "vcast" | |
1031 | | S.FPTR _ => punwrap "fcast" | |
1032 | | S.PTR _ => punwrap "pcast" | |
1033 | | S.ARR _ => | |
1034 | raise Fail "unexpected result type" | |
1035 | | S.UNIMPLEMENTED what => unimp_res what | |
1036 | in | |
1037 | (mlty t, [], [], [], res_wrap) | |
1038 | end | |
1039 | ||
1040 | fun doarg (h, p) = | |
1041 | let | |
1042 | fun sel e = ([mlty h], [e], []) | |
1043 | in | |
1044 | case h of | |
1045 | S.BASIC basic_t => sel (wrap (p, stem basic_t)) | |
1046 | | S.STRUCT t => (* sel (suwrap p) *) | |
1047 | raise Fail "struct argument not (yet) supported" | |
1048 | | S.UNION t => (* sel (suwrap p) *) | |
1049 | raise Fail "union argument not (yet) supported" | |
1050 | | S.ENUM _ => sel (ewrap p) | |
1051 | | S.VOIDPTR => sel (vwrap p) | |
1052 | | S.FPTR _ => sel (fwrap p) | |
1053 | | S.PTR _ => sel (pwrap p) | |
1054 | | S.ARR _ => raise Fail "unexpected array argument" | |
1055 | | S.UNIMPLEMENTED what => unimp_arg what | |
1056 | end | |
1057 | and arglist ([], _) = ([], [], []) | |
1058 | | arglist (h :: tl, i) = | |
1059 | let | |
1060 | val p = EVar ("x" ^ Int.toString i) | |
1061 | val (ta, ea, bnds) = arglist (tl, i + 1) | |
1062 | val (ta', ea', bnds') = doarg (h, p) | |
1063 | in | |
1064 | (ta' @ ta, ea' @ ea, bnds' @ bnds) | |
1065 | end | |
1066 | ||
1067 | val (ml_args_tl, args_el, bnds) = arglist (args, 1) | |
1068 | ||
1069 | val ml_args_t = Tuple (extra_ml_arg_t @ ml_args_tl) | |
1070 | ||
1071 | val arg_vl = | |
1072 | List.mapi | |
1073 | (args, fn (i, _) => | |
1074 | EVar ("x" ^ Int.toString (i + 1))) | |
1075 | ||
1076 | val arg_e = ETuple (extra_arg_e @ args_el) | |
1077 | val callop_n = get_callop (ml_args_t, ml_res_t) | |
1078 | in | |
1079 | str "local"; | |
1080 | VBox 4; | |
1081 | nl (); str "open C.Dim C_Int"; | |
1082 | endBox (); | |
1083 | nl (); str "in"; | |
1084 | VBox 4; | |
1085 | nl (); str (fstruct_export ^ " = struct"); | |
1086 | Box 4; | |
1087 | pr_fdef ("mkcall", | |
1088 | [EVar "a", ETuple (extra_arg_v @ arg_vl)], | |
1089 | res_wrap (ELet (bnds, | |
1090 | EApp (EApp (EVar callop_n, | |
1091 | EVar "a"), | |
1092 | arg_e)))); | |
1093 | pr_vdef ("typ", | |
1094 | EConstr (EApp (EVar "mk_fptr_typ", EVar "mkcall"), | |
1095 | rtti_type (S.FPTR {args = args, res = res}))); | |
1096 | endBox (); | |
1097 | nl (); str "end"; | |
1098 | endBox (); | |
1099 | nl (); str "end"; nl (); | |
1100 | closePP (); | |
1101 | done () | |
1102 | end)) | |
1103 | end | |
1104 | val () = fillGenStructTable' (IM.app, fptr_types, pr_fptr_rtti_promise) | |
1105 | ||
1106 | fun pr_gty_promise x = | |
1107 | let | |
1108 | val {src, name, spec} = x | |
1109 | val tstruct = Tstruct name | |
1110 | val tstruct_export = "structure " ^ tstruct | |
1111 | in | |
1112 | (tstruct, | |
1113 | Promise.delay | |
1114 | (fn () => | |
1115 | let | |
1116 | val (file, done) = | |
1117 | smlFileAndExport ("t-" ^ name, tstruct_export, true) | |
1118 | val {closePP, str, nl, Box, VBox, endBox, | |
1119 | pr_vdef, pr_tdef, ...} = | |
1120 | openPP (file, SOME src) | |
1121 | val rtti_val_opt = | |
1122 | (SOME (rtti_val spec)) | |
1123 | handle Incomplete => NONE | |
1124 | in | |
1125 | str "local"; | |
1126 | VBox 4; | |
1127 | nl (); str "open C.Dim C_Int"; | |
1128 | endBox (); | |
1129 | nl (); str "in"; | |
1130 | VBox 4; | |
1131 | nl (); str (tstruct_export ^ " = struct"); | |
1132 | Box 4; | |
1133 | pr_tdef ("t", witness_type spec); | |
1134 | Option.app | |
1135 | (rtti_val_opt, fn rtti_val => | |
1136 | pr_vdef ("typ", EConstr (rtti_val, Con ("T.typ", [Type "t"])))); | |
1137 | endBox (); | |
1138 | nl (); str "end"; | |
1139 | endBox (); | |
1140 | nl (); str "end"; nl (); | |
1141 | closePP (); | |
1142 | done () | |
1143 | end)) | |
1144 | end | |
1145 | val () = fillGenStructTable (List.foreach, gtys, pr_gty_promise) | |
1146 | ||
1147 | datatype sue_szinfo = | |
1148 | T_INC (* generate no RTTI *) | |
1149 | | T_SU of word (* generate struct/union RTTI *) | |
1150 | | T_E (* generate enum RTTI *) | |
1151 | ||
1152 | fun pr_suet_promise x = | |
1153 | let | |
1154 | val (src, tag, anon, tinfo, k, K) = x | |
1155 | val suetstruct = SUETstruct K tag | |
1156 | val suetstruct_export = "structure " ^ suetstruct | |
1157 | in | |
1158 | (suetstruct, | |
1159 | Promise.delay | |
1160 | (fn () => | |
1161 | let | |
1162 | val (file, done) = | |
1163 | smlFileAndExport (k ^ "t-" ^ tag, suetstruct_export, tinfo = T_INC) | |
1164 | val {closePP, str, nl, Box, VBox, endBox, | |
1165 | pr_vdef, pr_tdef, ...} = | |
1166 | openPP (file, src) | |
1167 | val (utildef, tag_t) = | |
1168 | if anon | |
1169 | then | |
1170 | ("structure X :> sig type t end \ | |
1171 | \= struct type t = unit end", | |
1172 | Type "X.t") | |
1173 | else | |
1174 | ("open Tag", | |
1175 | Vector.foldr | |
1176 | (tag, Type k, fn (c, tag_t) => | |
1177 | Con ("t_" ^ String.fromChar c, [tag_t]))) | |
1178 | fun do_susize size = | |
1179 | let in | |
1180 | pr_vdef ("size", | |
1181 | EConstr (EApp (EVar "mk_su_size", EWord size), | |
1182 | Con ("S.size", [Con ("su", [Type "tag"])]))); | |
1183 | pr_vdef ("typ", | |
1184 | EApp (EVar "mk_su_typ", EVar "size")) | |
1185 | end | |
1186 | in | |
1187 | str "local"; | |
1188 | VBox 4; | |
1189 | nl (); str "open C.Dim C_Int"; | |
1190 | nl (); str (concat ["structure ", SUEstruct K tag, " = struct"]); | |
1191 | Box 4; | |
1192 | nl (); str "local"; | |
1193 | VBox 4; | |
1194 | nl (); str utildef; | |
1195 | endBox (); | |
1196 | nl (); str "in"; | |
1197 | VBox 4; | |
1198 | pr_tdef ("tag", tag_t); | |
1199 | endBox (); | |
1200 | nl (); str "end"; | |
1201 | case tinfo of | |
1202 | T_INC => () | |
1203 | | T_SU size => do_susize size | |
1204 | | T_E => (); | |
1205 | endBox (); | |
1206 | nl (); str "end"; | |
1207 | endBox (); | |
1208 | nl (); str "in"; | |
1209 | VBox 4; | |
1210 | nl (); str (concat [suetstruct_export, " = ", SUEstruct K tag]); | |
1211 | endBox (); | |
1212 | nl (); str "end"; nl (); | |
1213 | closePP (); | |
1214 | done () | |
1215 | end)) | |
1216 | end | |
1217 | local | |
1218 | fun pr_st_promise {src, tag, anon, size, fields, exclude} = | |
1219 | pr_suet_promise (SOME src, tag, anon, T_SU size, "s", "S") | |
1220 | fun pr_ut_promise {src, tag, anon, size, all, exclude} = | |
1221 | pr_suet_promise (SOME src, tag, anon, T_SU size, "u", "U") | |
1222 | fun pr_et_promise {src, tag, anon, descr, spec, exclude} = | |
1223 | pr_suet_promise (SOME src, tag, anon, T_E, "e", "E") | |
1224 | in | |
1225 | val () = fillGenStructTable' (SM.app, structs, pr_st_promise) | |
1226 | val () = fillGenStructTable' (SM.app, unions, pr_ut_promise) | |
1227 | val () = fillGenStructTable' (SM.app, enums, pr_et_promise) | |
1228 | end | |
1229 | local | |
1230 | fun pr_i_suet_promise (tag, k, K) = | |
1231 | pr_suet_promise (NONE, tag, false, T_INC, k, K) | |
1232 | fun pr_i_st_promise tag = pr_i_suet_promise (tag, "s", "S") | |
1233 | fun pr_i_ut_promise tag = pr_i_suet_promise (tag, "u", "U") | |
1234 | fun pr_i_et_promise tag = pr_i_suet_promise (tag, "e", "E") | |
1235 | in | |
1236 | val () = fillGenStructTable' (SS.app, incomplete_structs, pr_i_st_promise) | |
1237 | val () = fillGenStructTable' (SS.app, incomplete_unions, pr_i_ut_promise) | |
1238 | val () = fillGenStructTable' (SS.app, incomplete_enums, pr_i_et_promise) | |
1239 | end | |
1240 | ||
1241 | fun pr_su_promise x = | |
1242 | let | |
1243 | val (src, tag, fields, k, K) = x | |
1244 | val sustruct = SUEstruct K tag | |
1245 | val sustruct_export = "structure " ^ sustruct | |
1246 | in | |
1247 | (sustruct, | |
1248 | Promise.delay | |
1249 | (fn () => | |
1250 | let | |
1251 | val (file, done) = | |
1252 | smlFileAndExport (k ^ "-" ^ tag, sustruct_export, true) | |
1253 | val {closePP, str, nl, Box, VBox, endBox, | |
1254 | pr_fdef, pr_vdef, pr_tdef, ...} = | |
1255 | openPP (file, SOME src) | |
1256 | fun pr_field_type {name, spec} = | |
1257 | case spec of | |
1258 | S.OFIELD {spec = (c, ty), synthetic = false, offset} => | |
1259 | pr_tdef (fieldtype_id name, | |
1260 | witness_type ty) | |
1261 | | _ => () | |
1262 | fun pr_field_rtti {name, spec} = | |
1263 | case spec of | |
1264 | S.OFIELD {spec = (c, ty), synthetic = false, offset} => | |
1265 | pr_vdef (fieldrtti_id name, | |
1266 | EConstr (rtti_val ty, | |
1267 | Con ("T.typ", [Type (fieldtype_id name)]))) | |
1268 | | _ => () | |
1269 | fun arg_x prime = | |
1270 | EConstr (EVar "x", | |
1271 | Con ("su_obj" ^ prime, | |
1272 | [Type "tag", Type "'c"])) | |
1273 | fun pr_bf_acc (name, prime, sign, | |
1274 | {offset, constness, bits, shift}) = | |
1275 | let | |
1276 | val maker = | |
1277 | concat ["mk_", rwro_str constness, "_", sign, "bf", prime] | |
1278 | in | |
1279 | pr_fdef (field_id (name, prime), | |
1280 | [arg_x prime], | |
1281 | EApp (EApp (EVar maker, | |
1282 | ETuple [EInt offset, | |
1283 | EWord bits, | |
1284 | EWord shift]), | |
1285 | EVar "x")) | |
1286 | end | |
1287 | fun pr_field_acc' {name, spec} = | |
1288 | case spec of | |
1289 | S.OFIELD {spec = (c, ty), synthetic, offset} => | |
1290 | if synthetic | |
1291 | then () | |
1292 | else pr_fdef (field_id (name, "'"), | |
1293 | [arg_x "'"], | |
1294 | EConstr (EApp (EVar "mk_field'", | |
1295 | ETuple [EInt offset, | |
1296 | EVar "x"]), | |
1297 | Con ("obj'", | |
1298 | [Type (fieldtype_id name), | |
1299 | rwro_c_type c]))) | |
1300 | | S.SBF bf => | |
1301 | pr_bf_acc (name, "'", "s", bf) | |
1302 | | S.UBF bf => | |
1303 | pr_bf_acc (name, "'", "u", bf) | |
1304 | fun pr_field_acc {name, spec} = | |
1305 | case spec of | |
1306 | S.OFIELD {spec = (c, ty), synthetic, offset} => | |
1307 | if synthetic | |
1308 | then () | |
1309 | else let | |
1310 | val maker = | |
1311 | concat ["mk_", rwro_str c, "_field"] | |
1312 | in | |
1313 | pr_fdef (field_id (name, ""), | |
1314 | [arg_x ""], | |
1315 | EApp (EVar maker, | |
1316 | ETuple [EVar (fieldrtti_id name), | |
1317 | EInt offset, | |
1318 | EVar "x"])) | |
1319 | end | |
1320 | | S.SBF bf => | |
1321 | pr_bf_acc (name, "", "s", bf) | |
1322 | | S.UBF bf => | |
1323 | pr_bf_acc (name, "", "u", bf) | |
1324 | fun pr_one_field f = | |
1325 | let | |
1326 | val _ = pr_field_type f | |
1327 | val incomplete = | |
1328 | (pr_field_rtti f; false) | |
1329 | handle Incomplete => true | |
1330 | in | |
1331 | if dolight orelse incomplete then pr_field_acc' f else (); | |
1332 | if doheavy andalso not incomplete then pr_field_acc f else () | |
1333 | end | |
1334 | in | |
1335 | str "local"; | |
1336 | VBox 4; | |
1337 | nl (); str "open C.Dim C_Int"; | |
1338 | endBox (); | |
1339 | nl (); str "in"; | |
1340 | VBox 4; | |
1341 | nl (); str (sustruct_export ^ " = struct"); | |
1342 | Box 4; | |
1343 | nl (); str ("open " ^ (forceGenStruct (SUETstruct K tag))); | |
1344 | List.foreach (fields, pr_one_field); | |
1345 | endBox (); | |
1346 | nl (); str "end"; | |
1347 | endBox (); | |
1348 | nl (); str "end"; nl (); | |
1349 | closePP (); | |
1350 | done () | |
1351 | end)) | |
1352 | end | |
1353 | local | |
1354 | fun pr_s_promise { src, tag, anon, size, fields, exclude } = | |
1355 | pr_su_promise (src, tag, fields, "s", "S") | |
1356 | fun pr_u_promise { src, tag, anon, size, all, exclude } = | |
1357 | pr_su_promise (src, tag, all, "u", "U") | |
1358 | in | |
1359 | val () = fillGenStructTable' (SM.app, structs, pr_s_promise) | |
1360 | val () = fillGenStructTable' (SM.app, unions, pr_u_promise) | |
1361 | end | |
1362 | ||
1363 | fun pr_e_promise x = | |
1364 | let | |
1365 | val {src, tag, anon, descr, spec, exclude} = x | |
1366 | val estruct = Estruct' (tag, anon) | |
1367 | val estruct_export = "structure " ^ estruct | |
1368 | in | |
1369 | (estruct, | |
1370 | Promise.delay | |
1371 | (fn () => | |
1372 | let | |
1373 | val (file, done) = | |
1374 | smlFileAndExport ("e-" ^ tag, estruct_export, true) | |
1375 | val {closePP, str, line, nl, sp, Box, VBox, endBox, | |
1376 | pr_fdef, pr_vdef, pr_tdef, ...} = | |
1377 | openPP (file, SOME src) | |
1378 | fun no_duplicate_values () = | |
1379 | let | |
1380 | fun loop (l, s) = | |
1381 | case l of | |
1382 | [] => true | |
1383 | | {name, spec} :: l => | |
1384 | if LIS.member (s, spec) | |
1385 | then (warn (concat ["enum ", descr, | |
1386 | " has duplicate values;\ | |
1387 | \ using sing,\ | |
1388 | \ not generating constructors\n"]); | |
1389 | false) | |
1390 | else loop (l, LIS.add (s, spec)) | |
1391 | in | |
1392 | loop (spec, LIS.empty) | |
1393 | end | |
1394 | val dodt = enum_cons andalso no_duplicate_values () | |
1395 | fun dt_mlrep () = | |
1396 | let | |
1397 | fun pcl () = | |
1398 | let | |
1399 | fun loop (c, l) = | |
1400 | case l of | |
1401 | [] => () | |
1402 | | {name, spec} :: l => | |
1403 | (str (c ^ enum_id name); nextround l) | |
1404 | and nextround [] = () | |
1405 | | nextround l = (sp (); loop ("| ", l)) | |
1406 | in | |
1407 | Box 2; nl (); | |
1408 | loop (" ", spec); | |
1409 | endBox () | |
1410 | end | |
1411 | fun pfl (fname, arg, res, fini: unit -> unit) = | |
1412 | let | |
1413 | fun loop (pfx, l) = | |
1414 | case l of | |
1415 | [] => () | |
1416 | | v :: l => | |
1417 | (line (concat [pfx, " ", arg v, " => ", res v]); | |
1418 | loop (" |", l)) | |
1419 | in | |
1420 | line (concat ["fun ", fname, " x ="]); | |
1421 | Box 4; | |
1422 | line ("case x of"); | |
1423 | loop (" ", spec); | |
1424 | fini (); | |
1425 | endBox () | |
1426 | end | |
1427 | fun cstr {name, spec} = enum_id name | |
1428 | fun vstr {name, spec} = | |
1429 | LargeInt.toString spec ^ " : MLRep.Int.Signed.int" | |
1430 | in | |
1431 | line "datatype mlrep ="; | |
1432 | pcl (); | |
1433 | pfl ("m2i", cstr, vstr, fn () => ()); | |
1434 | pfl ("i2m", vstr, cstr, | |
1435 | fn () => line " | _ => raise General.Domain") | |
1436 | end | |
1437 | fun int_mlrep () = | |
1438 | let | |
1439 | fun v {name, spec} = | |
1440 | pr_vdef (enum_id name, EConstr (ELInt spec, Type "mlrep")) | |
1441 | val mlx = EConstr (EVar "x", Type "mlrep") | |
1442 | val ty = Type "MLRep.Int.Signed.int" | |
1443 | val ix = EConstr (EVar "x", ty) | |
1444 | in | |
1445 | pr_tdef ("mlrep", ty); | |
1446 | List.foreach (spec, v); | |
1447 | pr_fdef ("m2i", [mlx], ix); | |
1448 | pr_fdef ("i2m", [ix], mlx) | |
1449 | end | |
1450 | fun getset p = | |
1451 | let | |
1452 | fun constr c = Con ("enum_obj" ^ p, [Type "tag", Type c]) | |
1453 | in | |
1454 | pr_fdef ("get" ^ p, | |
1455 | [EConstr (EVar "x", constr "'c")], | |
1456 | EApp (EVar "i2m", | |
1457 | EApp (EVar ("Get.enum" ^ p), EVar "x"))); | |
1458 | pr_fdef ("set" ^ p, | |
1459 | [ETuple [EConstr (EVar "x", constr "rw"), EVar "v"]], | |
1460 | EApp (EVar ("Set.enum" ^ p), | |
1461 | ETuple [EVar "x", EApp (EVar "m2i", EVar "v")])) | |
1462 | end | |
1463 | in | |
1464 | str "local"; | |
1465 | VBox 4; | |
1466 | nl (); str "open C.Dim C_Int"; | |
1467 | endBox (); | |
1468 | nl (); str "in"; | |
1469 | VBox 4; | |
1470 | nl (); str (estruct_export ^ " = struct"); | |
1471 | Box 4; | |
1472 | nl (); str ("open " ^ (forceGenStruct (SUETstruct "E" tag))); | |
1473 | if dodt then dt_mlrep () else int_mlrep (); | |
1474 | ||
1475 | endBox (); | |
1476 | nl (); str "end"; | |
1477 | endBox (); | |
1478 | nl (); str "end"; nl (); | |
1479 | closePP (); | |
1480 | done () | |
1481 | end)) | |
1482 | end | |
1483 | val () = fillGenStructTable' (SM.app, enums, pr_e_promise) | |
1484 | ||
1485 | fun do_mlbfile () = | |
1486 | let | |
1487 | val file = descrFile mlbfile | |
1488 | val () = File.remove file | |
1489 | val {closePP, line, str, nl, VBox, endBox, ... } = | |
1490 | openPP (file, NONE) | |
1491 | in | |
1492 | line "local ann \"allowFFI true\" in"; | |
1493 | VBox 4; | |
1494 | app line ["$(SML_LIB)/basis/basis.mlb", | |
1495 | "$(SML_LIB)/mlnlffi-lib/internals/c-int.mlb"]; | |
1496 | app line (rev extramembers); | |
1497 | app line (rev (!files)); | |
1498 | endBox (); | |
1499 | nl (); str "end in"; | |
1500 | VBox 4; | |
1501 | app line (rev (!exports)); | |
1502 | endBox (); | |
1503 | nl (); str "end"; nl (); | |
1504 | closePP () | |
1505 | end | |
1506 | in | |
1507 | (HashSet.foreach (genStructTable, fn (_, promise) => Promise.force promise) | |
1508 | ; do_mlbfile ()) | |
1509 | handle Promise.Force => | |
1510 | warn ("cyclic dependency: " ^ | |
1511 | (String.concatWith (!pending, " "))) | |
1512 | end | |
1513 | ||
1514 | end |