Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2004-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * | |
4 | * MLton is released under a BSD-style license. | |
5 | * See the file MLton-LICENSE for details. | |
6 | *) | |
7 | ||
8 | functor Ffi (S: FFI_STRUCTS): FFI = | |
9 | struct | |
10 | ||
11 | open S | |
12 | ||
13 | structure Convention = CFunction.Convention | |
14 | structure SymbolScope = CFunction.SymbolScope | |
15 | ||
16 | local | |
17 | val scopes: (Word.t * String.t * SymbolScope.t) HashSet.t = | |
18 | HashSet.new {hash = #1} | |
19 | in | |
20 | fun checkScope {name, symbolScope} = | |
21 | let | |
22 | val hash = String.hash name | |
23 | in | |
24 | (#3 o HashSet.lookupOrInsert) | |
25 | (scopes, hash, | |
26 | fn (hash', name', _) => | |
27 | hash = hash' andalso name = name', | |
28 | fn () => | |
29 | (hash, name, symbolScope)) | |
30 | end | |
31 | end | |
32 | ||
33 | val exports: {args: CType.t vector, | |
34 | convention: Convention.t, | |
35 | id: int, | |
36 | name: string, | |
37 | res: CType.t option, | |
38 | symbolScope: SymbolScope.t} list ref = ref [] | |
39 | val symbols: {name: string, | |
40 | ty: CType.t, | |
41 | symbolScope: SymbolScope.t} list ref = ref [] | |
42 | ||
43 | fun numExports () = List.length (!exports) | |
44 | ||
45 | local | |
46 | val exportCounter = Counter.new 0 | |
47 | in | |
48 | fun addExport {args, convention, name, res, symbolScope} = | |
49 | let | |
50 | val id = Counter.next exportCounter | |
51 | val _ = List.push (exports, {args = args, | |
52 | convention = convention, | |
53 | id = id, | |
54 | name = name, | |
55 | res = res, | |
56 | symbolScope = symbolScope}) | |
57 | in | |
58 | id | |
59 | end | |
60 | fun addSymbol {name, ty, symbolScope} = | |
61 | ignore (List.push (symbols, {name = name, | |
62 | ty = ty, | |
63 | symbolScope = symbolScope})) | |
64 | end | |
65 | ||
66 | val headers: string list ref = ref [] | |
67 | ||
68 | fun declareExports {print} = | |
69 | let | |
70 | val _ = print "PRIVATE Pointer MLton_FFI_opArgsResPtr;\n" | |
71 | in | |
72 | List.foreach | |
73 | (!symbols, fn {name, ty, symbolScope} => | |
74 | let | |
75 | val (headerSymbolScope, symbolScope) = | |
76 | case symbolScope of | |
77 | SymbolScope.External => | |
78 | Error.bug "Ffi.declareExports.symbols: External" | |
79 | | SymbolScope.Private => ("MLLIB_PRIVATE", "PRIVATE") | |
80 | | SymbolScope.Public => ("MLLIB_PUBLIC", "PUBLIC") | |
81 | val headerDecl = | |
82 | concat [headerSymbolScope, | |
83 | "(extern ", | |
84 | CType.toString ty, " ", | |
85 | name, ";)"] | |
86 | val decl = | |
87 | concat [symbolScope, " ", | |
88 | CType.toString ty, " ", | |
89 | name] | |
90 | in | |
91 | List.push (headers, headerDecl); | |
92 | print (decl ^ ";\n") | |
93 | end); | |
94 | List.foreach | |
95 | (!exports, fn {args, convention, id, name, res, symbolScope} => | |
96 | let | |
97 | val args = | |
98 | Vector.mapi | |
99 | (args, fn (i,t) => | |
100 | let | |
101 | val x = concat ["x", Int.toString i] | |
102 | val t = CType.toString t | |
103 | in | |
104 | (concat [t, " ", x], | |
105 | concat ["\tlocalOpArgsRes[", Int.toString (i + 1), "] = ", | |
106 | "(Pointer)(&", x, ");\n"]) | |
107 | end) | |
108 | val (headerSymbolScope, symbolScope) = | |
109 | case symbolScope of | |
110 | SymbolScope.External => | |
111 | Error.bug "Ffi.declareExports.exports: External" | |
112 | | SymbolScope.Private => ("MLLIB_PRIVATE","PRIVATE") | |
113 | | SymbolScope.Public => ("MLLIB_PUBLIC","PUBLIC") | |
114 | val prototype = | |
115 | concat [case res of | |
116 | NONE => "void" | |
117 | | SOME t => CType.toString t, | |
118 | if convention <> Convention.Cdecl | |
119 | then concat [" __attribute__ ((", | |
120 | Convention.toString convention, | |
121 | ")) "] | |
122 | else " ", | |
123 | name, " (", | |
124 | concat (List.separate (Vector.toListMap (args, #1), ", ")), | |
125 | ")"] | |
126 | val n = | |
127 | 1 + (Vector.length args) | |
128 | + (case res of NONE => 0 | SOME _ => 1) | |
129 | in | |
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) | |
137 | ; (case res of | |
138 | NONE => () | |
139 | | SOME t => | |
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") | |
144 | ; (case res of | |
145 | NONE => () | |
146 | | SOME _ => print "\treturn localRes;\n") | |
147 | ; print "}\n" | |
148 | end) | |
149 | end | |
150 | ||
151 | fun declareHeaders {print} = | |
152 | (declareExports {print = fn _ => ()} | |
153 | ; List.foreach (!headers, fn s => (print s; print "\n"))) | |
154 | ||
155 | end |