mlton/atoms/ffi.fun

   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