1 (* Copyright (C) 2004-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh
2 * Jagannathan, and Stephen Weeks.
4 * MLton is released under a BSD-style license.
5 * See the file MLton-LICENSE for details.
8 functor Ffi (S: FFI_STRUCTS): FFI =
13 structure Convention = CFunction.Convention
14 structure SymbolScope = CFunction.SymbolScope
17 val scopes: (Word.t * String.t * SymbolScope.t) HashSet.t =
18 HashSet.new {hash = #1}
20 fun checkScope {name, symbolScope} =
22 val hash = String.hash name
24 (#3 o HashSet.lookupOrInsert)
26 fn (hash', name', _) =>
27 hash = hash' andalso name = name',
29 (hash, name, symbolScope))
33 val exports: {args: CType.t vector,
34 convention: Convention.t,
38 symbolScope: SymbolScope.t} list ref = ref []
39 val symbols: {name: string,
41 symbolScope: SymbolScope.t} list ref = ref []
43 fun numExports () = List.length (!exports)
46 val exportCounter = Counter.new 0
48 fun addExport {args, convention, name, res, symbolScope} =
50 val id = Counter.next exportCounter
51 val _ = List.push (exports, {args = args,
52 convention = convention,
56 symbolScope = symbolScope})
60 fun addSymbol {name, ty, symbolScope} =
61 ignore (List.push (symbols, {name = name,
63 symbolScope = symbolScope}))
66 val headers: string list ref = ref []
68 fun declareExports {print} =
70 val _ = print "PRIVATE Pointer MLton_FFI_opArgsResPtr;\n"
73 (!symbols, fn {name, ty, symbolScope} =>
75 val (headerSymbolScope, symbolScope) =
77 SymbolScope.External =>
78 Error.bug "Ffi.declareExports.symbols: External"
79 | SymbolScope.Private => ("MLLIB_PRIVATE", "PRIVATE")
80 | SymbolScope.Public => ("MLLIB_PUBLIC", "PUBLIC")
82 concat [headerSymbolScope,
84 CType.toString ty, " ",
87 concat [symbolScope, " ",
88 CType.toString ty, " ",
91 List.push (headers, headerDecl);
95 (!exports, fn {args, convention, id, name, res, symbolScope} =>
101 val x = concat ["x", Int.toString i]
102 val t = CType.toString t
105 concat ["\tlocalOpArgsRes[", Int.toString (i + 1), "] = ",
106 "(Pointer)(&", x, ");\n"])
108 val (headerSymbolScope, symbolScope) =
110 SymbolScope.External =>
111 Error.bug "Ffi.declareExports.exports: External"
112 | SymbolScope.Private => ("MLLIB_PRIVATE","PRIVATE")
113 | SymbolScope.Public => ("MLLIB_PUBLIC","PUBLIC")
117 | SOME t => CType.toString t,
118 if convention <> Convention.Cdecl
119 then concat [" __attribute__ ((",
120 Convention.toString convention,
124 concat (List.separate (Vector.toListMap (args, #1), ", ")),
127 1 + (Vector.length args)
128 + (case res of NONE => 0 | SOME _ => 1)
130 List.push (headers, concat [headerSymbolScope, "(", prototype, ";)"])
131 ; print (concat [symbolScope, " ", prototype, " {\n"])
132 ; print (concat ["\tPointer localOpArgsRes[", Int.toString n,"];\n"])
133 ; print (concat ["\tMLton_FFI_opArgsResPtr = (Pointer)(localOpArgsRes);\n"])
134 ; print (concat ["\tInt32 localOp = ", Int.toString id, ";\n",
135 "\tlocalOpArgsRes[0] = (Pointer)(&localOp);\n"])
136 ; Vector.foreach (args, fn (_, set) => print set)
140 print (concat ["\t", CType.toString t, " localRes;\n",
141 "\tlocalOpArgsRes[", Int.toString (Vector.length args + 1), "] = ",
142 "(Pointer)(&localRes);\n"]))
143 ; print ("\tMLton_callFromC ();\n")
146 | SOME _ => print "\treturn localRes;\n")
151 fun declareHeaders {print} =
152 (declareExports {print = fn _ => ()}
153 ; List.foreach (!headers, fn s => (print s; print "\n")))