| 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 |