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