HCoop / hcoop / debian / mlton.git / blame_incremental
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (non-incremental) | history | HEAD
Import Debian changes 20180207-1
[hcoop/debian/mlton.git] / mlnlffigen / gen.sml
... / ...
CommitLineData
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 *)
20structure Gen :
21sig
22 val gen : {cfiles: string list} -> unit
23end =
24struct
25
26structure Linkage = Control.Linkage
27
28structure P = PrettyPrint
29structure PP = P.PP
30structure S = Spec
31
32structure IM = IntMap
33structure LIS = LargeIntSet
34structure SM = StringMap
35structure SS = StringSet
36
37exception Incomplete
38
39val Tuple = P.TUPLE
40fun Record [] = P.Unit
41 | Record l = P.RECORD l
42val Con = P.CON
43val Arrow = P.ARROW
44val Type = P.Type
45val Unit = P.Unit
46val ETuple = P.ETUPLE
47val EUnit = ETuple []
48fun ERecord [] = P.ETUPLE []
49 | ERecord l = P.ERECORD l
50val EVar = P.EVAR
51val EApp = P.EAPP
52val EConstr = P.ECONSTR
53val ESeq = P.ESEQ
54val EPrim = P.EPRIM
55val ELet = P.ELET
56fun EWord w = EVar ("0wx" ^ Word.toString w)
57fun EInt i = EVar (Int.toString i)
58fun ELInt i = EVar (LargeInt.toString i)
59fun EString s = EVar (concat ["\"", String.toString s, "\""])
60
61fun warn m = Out.output (Out.error, "warning: " ^ m)
62fun err m = raise Fail (concat ("gen: " :: m))
63
64fun unimp what = raise Fail ("unimplemented type: " ^ what)
65fun unimp_arg what = raise Fail ("unimplemented argument type: " ^ what)
66fun unimp_res what = raise Fail ("unimplemented result type: " ^ what)
67
68val writeto = "write'to"
69
70fun gen args =
71let
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
1506in
1507 (HashSet.foreach (genStructTable, fn (_, promise) => Promise.force promise)
1508 ; do_mlbfile ())
1509 handle Promise.Force =>
1510 warn ("cyclic dependency: " ^
1511 (String.concatWith (!pending, " ")))
1512end
1513
1514end
mlton packaging