[MLton-devel] cvs commit: _export
Stephen Weeks
sweeks@users.sourceforge.net
Tue, 24 Jun 2003 13:14:23 -0700
sweeks 03/06/24 13:14:23
Modified: basis-library/misc primitive.sml
basis-library/mlton ffi.sig ffi.sml
doc changelog
doc/examples/ffi .cvsignore Makefile
doc/user-guide ffi.tex macros.tex
mlton mlton-stubs-1997.cm mlton-stubs.cm mlton.cm
mlton/ast ast-core.fun ast-core.sig
mlton/atoms atoms.fun atoms.sig prim.fun prim.sig sources.cm
mlton/backend ssa-to-rssa.fun
mlton/codegen/c-codegen c-codegen.fun c-codegen.sig
sources.cm
mlton/codegen/x86-codegen x86-codegen.fun x86-codegen.sig
mlton/elaborate elaborate-core.fun elaborate-core.sig
mlton/front-end ml.grm ml.lex
mlton/main compile.sig compile.sml main.sml
regression ffi.sml
runtime types.h
Added: doc/examples/ffi export.sml ffi-export.c ffi-import.c
import.sml
mlton/atoms ffi.fun ffi.sig
Removed: doc/examples/ffi ffi.c ffi.h main.sml
Log:
Added _export, which allows calls from C to SML.
Revision Changes Path
1.58 +31 -1 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -r1.57 -r1.58
--- primitive.sml 24 Jun 2003 17:35:52 -0000 1.57
+++ primitive.sml 24 Jun 2003 20:14:20 -0000 1.58
@@ -230,6 +230,36 @@
_prim "Exn_setTopLevelHandler": (exn -> unit) -> unit;
end
+ structure FFI =
+ struct
+ val getBool = _ffi "MLton_FFI_getBool": int -> bool;
+ val getChar = _ffi "MLton_FFI_getChar": int -> char;
+ val getInt8 = _ffi "MLton_FFI_getInt8": int -> Int8.int;
+ val getInt16 = _ffi "MLton_FFI_getInt16": int -> Int16.int;
+ val getInt32 = _ffi "MLton_FFI_getInt32": int -> Int32.int;
+ val getInt64 = _ffi "MLton_FFI_getInt64": int -> Int64.int;
+ val getOp = _ffi "MLton_FFI_getOp": unit -> int;
+ val getPointer = fn z => _prim "FFI_getPointer": int -> 'a; z
+ val getReal32 = _ffi "MLton_FFI_getReal32": int -> Real32.real;
+ val getReal64 = _ffi "MLton_FFI_getReal64": int -> Real64.real;
+ val getWord8 = _ffi "MLton_FFI_getWord8": int -> Word8.word;
+ val getWord16 = _ffi "MLton_FFI_getWord16": int -> Word16.word;
+ val getWord32 = _ffi "MLton_FFI_getWord32": int -> Word32.word;
+ val numExports = _build_const "MLton_FFI_numExports": int;
+ val setBool = _ffi "MLton_FFI_setBool": bool -> unit;
+ val setChar = _ffi "MLton_FFI_setChar": char -> unit;
+ val setInt8 = _ffi "MLton_FFI_setInt8": Int8.int -> unit;
+ val setInt16 = _ffi "MLton_FFI_setInt16": Int16.int -> unit;
+ val setInt32 = _ffi "MLton_FFI_setInt32": Int32.int -> unit;
+ val setInt64 = _ffi "MLton_FFI_setInt64": Int64.int -> unit;
+ val setPointer = fn z => _prim "FFI_setPointer": 'a -> unit; z
+ val setReal32 = _ffi "MLton_FFI_setReal32": Real32.real -> unit;
+ val setReal64 = _ffi "MLton_FFI_setReal64": Real64.real -> unit;
+ val setWord8 = _ffi "MLton_FFI_setWord8": Word8.word -> unit;
+ val setWord16 = _ffi "MLton_FFI_setWord16": Word16.word -> unit;
+ val setWord32 = _ffi "MLton_FFI_setWord32": Word32.word -> unit;
+ end
+
structure GC =
struct
val collect = _prim "GC_collect": unit -> unit;
@@ -241,8 +271,8 @@
structure IEEEReal =
struct
- val setRoundingMode = _ffi "IEEEReal_setRoundingMode": int -> unit;
val getRoundingMode = _ffi "IEEEReal_getRoundingMode": unit -> int;
+ val setRoundingMode = _ffi "IEEEReal_setRoundingMode": int -> unit;
end
structure Int8 =
1.2 +27 -1 mlton/basis-library/mlton/ffi.sig
Index: ffi.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/ffi.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- ffi.sig 25 Mar 2003 04:31:22 -0000 1.1
+++ ffi.sig 24 Jun 2003 20:14:21 -0000 1.2
@@ -1,4 +1,30 @@
signature MLTON_FFI =
sig
- val handleCallFromC: (unit -> unit) -> unit
+ val atomicBegin: unit -> unit
+ val atomicEnd: unit -> unit
+ val getBool: int -> bool
+ val getChar: int -> char
+ val getInt8: int -> Int8.int
+ val getInt16: int -> Int16.int
+ val getInt32: int -> Int32.int
+ val getInt64: int -> Int64.int
+ val getPointer: int -> 'a
+ val getReal32: int -> Real32.real
+ val getReal64: int -> Real64.real
+ val getWord8: int -> Word8.word
+ val getWord16: int -> Word16.word
+ val getWord32: int -> Word32.word
+ val register: int * (unit -> unit) -> unit
+ val setBool: bool -> unit
+ val setChar: char -> unit
+ val setInt8: Int8.int -> unit
+ val setInt16: Int16.int -> unit
+ val setInt32: Int32.int -> unit
+ val setInt64: Int64.int -> unit
+ val setPointer: 'a -> unit
+ val setReal32: Real32.real -> unit
+ val setReal64: Real64.real -> unit
+ val setWord8: Word8.word -> unit
+ val setWord16: Word16.word -> unit
+ val setWord32: Word32.word -> unit
end
1.4 +18 -9 mlton/basis-library/mlton/ffi.sml
Index: ffi.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/ffi.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- ffi.sml 19 Jun 2003 19:21:28 -0000 1.3
+++ ffi.sml 24 Jun 2003 20:14:21 -0000 1.4
@@ -1,13 +1,22 @@
-structure MLtonFFI =
+structure MLtonFFI: MLTON_FFI =
struct
-local
- open MLtonThread
-in
- fun handleCallFromC f =
- setCallFromCHandler (fn () => (atomicBegin();
- f ();
- atomicEnd()))
-end
+structure Prim = Primitive.FFI
+
+open Prim
+
+val atomicBegin = MLtonThread.atomicBegin
+val atomicEnd = MLtonThread.atomicEnd
+
+val register =
+ let
+ val exports = Array.array (Prim.numExports, fn () =>
+ raise Fail "undefined export\n")
+ val _ =
+ MLtonThread.setCallFromCHandler
+ (fn () => Array.sub (exports, Prim.getOp ()) ())
+ in
+ fn (i, f) => Array.update (exports, i, f)
+ end
end
1.44 +3 -0 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -r1.43 -r1.44
--- changelog 18 Jun 2003 17:40:50 -0000 1.43
+++ changelog 24 Jun 2003 20:14:21 -0000 1.44
@@ -2,6 +2,9 @@
At this point, the only missing basis library function is "use".
+* 2003-06-24
+ - Added _export, for calling from C to SML.
+
* 2003-06-18
- Regularization of options.
-diag --> -diag-pass
1.2 +5 -2 mlton/doc/examples/ffi/.cvsignore
Index: .cvsignore
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/.cvsignore,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- .cvsignore 26 Oct 2001 19:21:39 -0000 1.1
+++ .cvsignore 24 Jun 2003 20:14:21 -0000 1.2
@@ -1,2 +1,5 @@
-ffi.o
-main
+export
+export.h
+import
+
+
1.5 +8 -6 mlton/doc/examples/ffi/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/Makefile,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- Makefile 26 Aug 2002 00:59:41 -0000 1.4
+++ Makefile 24 Jun 2003 20:14:21 -0000 1.5
@@ -1,14 +1,16 @@
mlton = mlton
.PHONY: all
-all: main
- main
+all: import export
-main: ffi.o main.sml ffi.h
- $(mlton) main.sml ffi.o
+export: export.sml ffi-export.c
+ $(mlton) export.sml ffi-export.c
-ffi.o: ffi.c ffi.h
- $(mlton) -stop o ffi.c
+import: import.sml ffi-import.o
+ $(mlton) import.sml ffi-import.o
+
+ffi-import.o:
+ $(mlton) -stop o ffi-import.c
clean:
../../../bin/clean
1.1 mlton/doc/examples/ffi/export.sml
Index: export.sml
===================================================================
val e = _export "f": int * real -> char;
val _ = e (fn (i, r) =>
(print (concat ["i = ", Int.toString i,
" r = ", Real.toString r, "\n"])
; #"g"))
val g = _ffi "g": unit -> unit;
val _ = g ()
val _ = g ()
val e = _export "f2": Word8.word -> word array;
val _ = e (fn w => Array.tabulate (10, fn _ => Word8.toLargeWord w))
val g2 = _ffi "g2": unit -> word array;
val a = g2 ()
val _ = print (concat ["0wx", Word.toString (Array.sub (a, 0)), "\n"])
val _ = print "success\n"
1.1 mlton/doc/examples/ffi/ffi-export.c
Index: ffi-export.c
===================================================================
#include <stdio.h>
#include "export.h"
void g () {
Char c;
fprintf (stderr, "g starting\n");
c = f (13, 17.15);
fprintf (stderr, "g done char = %c\n", c);
}
Pointer g2 () {
Pointer res;
fprintf (stderr, "g2 starting\n");
res = f2 (0xFF);
fprintf (stderr, "g2 done\n");
return res;
}
1.1 mlton/doc/examples/ffi/ffi-import.c
Index: ffi-import.c
===================================================================
#include "libmlton.h"
Int FFI_INT = 13;
Char ffi (Pointer a1, Pointer a2, Int n) {
double *ds = (double*)a1;
int *p = (int*)a2;
int i;
double sum;
sum = 0.0;
for (i = 0; i < GC_arrayNumElements (a1); ++i) {
sum += ds[i];
ds[i] += n;
}
*p = (int)sum;
return 'c';
}
1.1 mlton/doc/examples/ffi/import.sml
Index: import.sml
===================================================================
(* main.sml *)
(*
* For now, all the uses of _const are commented out until we figure out if/how
* support for these will be added back to MLton.
*)
(* val bool0 = _const "BOOL0": bool;
* val bool1 = _const "BOOL1": bool;
* val int0 = _const "INT0": int;
* val int1 = _const "INT1": int;
* val int2 = _const "INT2": int;
* val real0 = _const "REAL0": real;
* val real1 = _const "REAL1": real;
* val string0 = _const "STRING0": string;
* val word0 = _const "WORD0": word;
* val word1 = _const "WORD1": word;
*
* val _ =
* if bool0 = false
* andalso bool1 = true
* andalso int0 = ~1
* andalso int1 = 0
* andalso int2 = 1
* andalso Real.== (real0, ~1.234)
* andalso Real.== (real1, 1.234)
* andalso string0 = "hello there\nhow are you\n"
* andalso word0 = 0wx0
* andalso word1 = 0wxFFFFFFFF
* then ()
* else raise Fail "bug"
*)
(* Declare ffi to be implemented by calling the C function ffi. *)
val ffi = _ffi "ffi": real array * int ref * int -> char;
open Array
(* val size = _const "FFI_SIZE": int; *)
val size = 10
val a = tabulate (size, fn i => real i)
val r = ref 0
val n = 17
(* Call the C function *)
val c = ffi (a, r, n)
val n = _ffi "FFI_INT": int;
val _ = print (concat [Int.toString n, "\n"])
val _ =
print (if c = #"c" andalso !r = 45
then "success\n"
else "fail\n")
1.9 +107 -119 mlton/doc/user-guide/ffi.tex
Index: ffi.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/ffi.tex,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- ffi.tex 12 Mar 2003 20:35:42 -0000 1.8
+++ ffi.tex 24 Jun 2003 20:14:21 -0000 1.9
@@ -2,13 +2,13 @@
{\mlton}'s FFI is {\em not} part of Standard ML and it is quite
possible that this interface will change. That having been said, with
-{\mlton} it is easy to access C global variables and make calls to C
-functions from within SML, at least when dealing with
-simple types like {\tt char}, {\tt double}, {\tt int}, and {\tt word}.
-It is not possible to call C macros or to call SML from C.
-
-Suppose you would like to call a C function with the following prototype
-from SML:
+{\mlton} it is easy to access C global variables and to make calls
+from SML to C and from C to SML, at least when dealing with simple
+types like {\tt char}, {\tt int}, {\tt real}, and {\tt word}.
+
+\subsection{Calling from SML to C}
+Suppose you would like SML to call a C function with the following
+prototype:
\begin{verbatim}
int foo (double d, unsigned char c);
\end{verbatim}
@@ -23,108 +23,115 @@
char}, and {\tt i} of type {\tt int}. Then, the C statement
\mbox{\tt i = foo(d, c)} is executed and {\tt i} is returned.
-The general form of an \verb+_ffi+ declaration is:
+The general form of an \verb+_ffi+ expresion is:
\begin{center}
{\tt \_ffi "}C global variable or function name{\tt ": }ty{\tt ;}
\end{center}
-The semicolon is not optional. Here is a grammar for the types that
-are currently allowed.
-\begin{latexonly}
-\begin{center}
-\begin{tabular}{l}
-\production{\mbox{ty}}
- {u $\alt$ t\ \mbox{\tt *}\ \ldots\ \mbox{\tt *}\ t\ \mbox{\tt ->}\ u}
-\production{u}
- {\mbox{\tt bool} $\alt$ \mbox{\tt char} $\alt$ \mbox{\tt int} $\alt$ \mbox{\tt real} $\alt$ \mbox{\tt string} $\alt$ \mbox{\tt unit} $\alt$ \mbox{\tt word} $\alt$ \mbox{\tt word8}}
-\production{t}
- {u $\alt$ u\ \mbox{\tt array} $\alt$ u\ \mbox{\tt ref}
- $\alt$ u\ \mbox{\tt vector}}
-\quad $\alt$ \mbox{\tt CharArray.array} $\alt$ \mbox{\tt CharVector.vector} \\
-\quad $\alt$ \mbox{\tt IntArray.array} $\alt$ \mbox{\tt IntVector.vector} \\
-\quad $\alt$ \mbox{\tt Int32Array.array} $\alt$ \mbox{\tt Int32Vector.vector} \\
-\quad $\alt$ \mbox{\tt RealArray.array} $\alt$ \mbox{\tt RealVector.vector} \\
-\quad $\alt$ \mbox{\tt Real64Array.array} $\alt$ \mbox{\tt Real64Vector.vector} \\
-\quad $\alt$ \mbox{\tt Word8Array.array} $\alt$ \mbox{\tt Word8Vector.vector} \\
-\quad $\alt$ \mbox{\tt Word32Array.array} $\alt$ \mbox{\tt Word32Vector.vector} \\
-\end{tabular}
-\end{center}
-\end{latexonly}
-\begin{htmlonly}
-\begin{center}
-\begin{tabular}{l}
-\production{\mbox{ty}}
- {u \alt t\ \mbox{\tt *}\ \ldots\ \mbox{\tt *}\ t\ \mbox{\tt ->}\ u}
-\production{u}
- {\mbox{\tt bool} \alt \mbox{\tt char} \alt \mbox{\tt int} \alt \mbox{\tt real} \alt \mbox{\tt string} \alt \mbox{\tt unit} \alt \mbox{\tt word} \alt \mbox{\tt word8}}
-\production{t}
- {u \alt u\ \mbox{\tt array} \alt u\ \mbox{\tt ref}
- \alt u\ \mbox{\tt vector}}
-\quad \alt \mbox{\tt CharArray.array} \alt \mbox{\tt CharVector.vector} \\
-\quad \alt \mbox{\tt IntArray.array} \alt \mbox{\tt IntVector.vector} \\
-\quad \alt \mbox{\tt Int32Array.array} \alt \mbox{\tt Int32Vector.vector} \\
-\quad \alt \mbox{\tt RealArray.array} \alt \mbox{\tt RealVector.vector} \\
-\quad \alt \mbox{\tt Real64Array.array} \alt \mbox{\tt Real64Vector.vector} \\
-\quad \alt \mbox{\tt Word8Array.array} \alt \mbox{\tt Word8Vector.vector} \\
-\quad \alt \mbox{\tt Word32Array.array} \alt \mbox{\tt Word32Vector.vector} \\
-\end{tabular}
-\end{center}
-\end{htmlonly}
+The semicolon is not optional.
+
+An example in the {\tt examples/ffi} directory demonstrates the use of
+{\ffi} expressions. The {\tt Makefile} demonstrates how to call
+{\mlton} to include and link with the appropriate files. Running {\tt
+make import} will produce an executable, {\tt import}, that should
+output {\tt success} when run.
+\begin{verbatim}
+% make import
+mlton -stop o ffi-import.c
+mlton import.sml ffi-import.o
+% import
+13
+success
+\end{verbatim}
+
+\subsection{Calling from C to SML}
+Suppose you would like export from SML a funtion of type {\tt real *
+char -> int} as the C function {\tt foo}. {\mlton} extends the syntax
+of SML to allow expressions like the following:
+\begin{verbatim}
+_export "foo": real * char -> int;
+\end{verbatim}
+This expression exports a C function named {\tt foo}, with prototype
+\begin{verbatim}
+Int32 foo (Real64 x0, Char x1);
+\end{verbatim}
+The {\export} expression denotes a function of type {\tt (real * char
+-> int) -> unit}, that when called with a function {\tt f} arranges
+for the exported {\tt foo} function to call {\tt f} when {\tt foo} is
+called. So, for example, the following expression both exports and
+defines {\tt foo}.
+\begin{verbatim}
+_export "foo": real * char -> int;
+(fn (x, c) => 13 + Real.floor x + Char.ord c)
+\end{verbatim}
+
+{\mlton} generate a C header file at compile time with prototypes for
+all of the exported functions. You can use this header to type check
+your C code. An example in the {\tt examples/ffi} directory
+demonstrates the use of {\export} expressions and the header file.
+Running {\tt make export} will produce an executable, {\tt export},
+that should output {\tt success} when run.
+
+\begin{verbatim}
+% make export
+mlton export.sml ffi-export.c
+% ./export
+g starting
+i = 13 r = 17.15
+g done char = g
+g starting
+i = 13 r = 17.15
+g done char = g
+g2 starting
+g2 done
+0wxFF
+success
+\end{verbatim}
+
+Notice that {\tt ffi-export.c} includes {\tt export.h}, the header
+file generated by {\mlton}.
+
+\subsection{FFI types}
+
+{\mlton} only allows a values of certain SML types to be passed
+between SML and C. The following types are allowed: {\tt bool}, {\tt
+char}, {\tt int}, {\tt real}, {\tt string}, {\tt unit}, {\tt word}.
+Strings are not null terminated, unless you manually do so from the
+SML side. All of the different sizes of integers, reals, and words
+are supported as well: {\tt Int32.int}, {\tt Real64.real}, {\tt
+Word8.word}, {\tt Word32.word}. Arrays, refs, and vectors of the
+above types are also allowed. Because in {\mlton}, monomorphic arrays
+and vectors are exactly the same as their polymorphic counterpart
+these are also allowed. Unfortunately, passing tuples or datatypes is
+not allowed because that would interfere with representation
+optimizations.
+
+The file {\tt types.h} in the MLton include directory includes
+typedefs for the C types corresponding to the SML types.
Here is the mapping between SML types and C types.
+
\begin{center}
-\begin{tabular}{ll}
-SML type & C type\\
+\begin{tabular}{lll}
+SML type & C typedef & C type\\
\hline
-{\tt bool} & {\tt int} (0 is false, nonzero is true) \\
-{\tt char} & {\tt unsigned char} \\
-{\tt int} & {\tt int} \\
-{\tt real} & {\tt double} \\
-{\tt string} & {\tt char *} \\
-{\tt unit} & {\tt void} \\
-{\tt word} & {\tt unsigned int} \\
-{\tt word8} & {\tt unsigned char} \\
-{\tt array} & {\tt char *} \\
-{\tt ref} & {\tt char *} \\
-{\tt vector} & {\tt char *} \\
+{\tt array} & {\tt Pointer} & {\tt char *} \\
+{\tt bool} & {\tt Bool} & {\tt long} \\
+{\tt char} & {\tt Char} & {\tt unsigned char} \\
+{\tt int} & {\tt Int32} & {\tt long} \\
+{\tt real} & {\tt Real64} & {\tt double} \\
+{\tt ref} & {\tt Pointer} & {\tt char *} \\
+{\tt string} & {\tt Pointer} & {\tt char *} \\
+{\tt unit} & {\tt Unit} & {\tt void} \\
+{\tt vector} & Pointer & {\tt char *} \\
+{\tt Word8.word} & {\tt Word8} & {\tt unsigned char} \\
+{\tt word} & {\tt Word32} & {\tt unsigned int} \\
\end{tabular}
\end{center}
-Passing or returning tuples or datatypes is not allowed because the
-representation of these is decided late in the compilation
-process and because optimizations can cause the representation to
-change. Arrays, refs, and vectors may only be passed as arguments and
-not returned as results because C functions are not allowed to
-allocate in the SML heap. Although the C type of an array, ref, or
-vector is always {\tt char*}, in reality, the object is layed out in
-the natural C representation.
-%You are responsible for doing the cast
-%if you want to keep the C compiler from complaining.
-Strings are just
-like char arrays, and are not null terminated, unless you manually do
-so from the SML side.
-
-% This section is no longer relevant, with the changes in place for
-% cross compiling. Let's wait and see what we actually add before updating
-% the docs
-%\subsec{Compile-time constants}{compile-time-constant}
-
-%{\mlton}'s \verb+_prim+ facility provides access to compile-time constants,
-%which can be defined either via C include ({\tt .h}) files or on the command
-%line with the {\tt -D} command-line option.
-%The facility supports constants of type {\tt bool}, {\tt int}, {\tt real},
-%{\tt string}, and {\tt word}.
-%For example, the basis library
-%implementation contains the following lines.
-%\begin{verbatim}
-%type syserror = int
-%val acces = _prim "Posix_Error_acces": syserror;
-%\end{verbatim}
-%This defines the SML variable {\tt acces} to be an int whose value is the value
-%of the C constant (macro) \verb+Posix_Error_access+, which is obtained from the
-%(automatically) included file {\tt posix-constants.h}. At compile-time, {\mlton}
-%generates a C file that prints the values of all \verb+_prim+ constants, calls
-%{\tt gcc} to produce an executable, runs the executable, and reads the result.
-%The \verb+_prim+ expressions are then replaced by appropriate constants, which
-%are available to the rest of the compilation process.
+
+Although the C type of an array, ref, or vector is always {\tt
+Pointer}, in reality, the object is layed out in the natural C
+representation. Your C code should cast to the appropriate C type if
+you want to keep the C compiler from complaining.
\subsection{Type checking programs that use {\tt \_ffi}}
@@ -152,22 +159,3 @@
cast is constrained to the actual type of the foreign function or primitive. Of
course, you should never actually run the code, but it's sufficient for type
checking.
-
-\subsection{FFI Example}
-
-The example in the {\tt examples/ffi} directory demonstrates the use of
-{\ffi} declarations. The {\tt Makefile} demonstrates how
-to call {\mlton} to include and link with the appropriate files. Running {\tt
-make} should produce an executable, {\tt ffi}, which should output {\tt success}
-when run.
-%You should also read \secref{compile-time-options} to familiarize
-%yourself with the {\mlton} options governing include files and linking ({\tt
-%-include}, {\tt -I}, {\tt -l}, and {\tt -L}).
-
-\begin{verbatim}
-% mlton -stop o ffi.c
-% mlton main.sml ffi.o
-% main
-13
-success
-\end{verbatim}
1.16 +1 -0 mlton/doc/user-guide/macros.tex
Index: macros.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/macros.tex,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- macros.tex 18 Jan 2003 18:42:26 -0000 1.15
+++ macros.tex 24 Jun 2003 20:14:21 -0000 1.16
@@ -3,6 +3,7 @@
\newcommand{\alternative}[1]{ & | & #1\\}
\newcommand{\alt}{\ |\ }
\newcommand{\doc}{\mbox{\tt doc/mlton}}
+\newcommand{\export}{{\tt \_export}}
\newcommand{\ffi}{{\tt \_ffi}}
\newcommand{\filelink}[1]{\htmladdnormallink{{\tt #1}}{file:#1}}
\newcommand{\kit}{ML Kit}
1.18 +2 -0 mlton/mlton/mlton-stubs-1997.cm
Index: mlton-stubs-1997.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs-1997.cm,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- mlton-stubs-1997.cm 23 Jun 2003 04:58:54 -0000 1.17
+++ mlton-stubs-1997.cm 24 Jun 2003 20:14:21 -0000 1.18
@@ -180,6 +180,7 @@
atoms/int-x.sig
atoms/const.sig
atoms/prim.sig
+atoms/ffi.sig
atoms/atoms.sig
atoms/hash-type.sig
xml/xml-type.sig
@@ -263,6 +264,7 @@
atoms/prim.fun
atoms/int-x.fun
atoms/generic-scheme.fun
+atoms/ffi.fun
atoms/const.fun
atoms/cons.fun
atoms/atoms.fun
1.23 +2 -0 mlton/mlton/mlton-stubs.cm
Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- mlton-stubs.cm 23 Jun 2003 04:58:54 -0000 1.22
+++ mlton-stubs.cm 24 Jun 2003 20:14:21 -0000 1.23
@@ -179,6 +179,7 @@
atoms/int-x.sig
atoms/const.sig
atoms/prim.sig
+atoms/ffi.sig
atoms/atoms.sig
atoms/hash-type.sig
xml/xml-type.sig
@@ -262,6 +263,7 @@
atoms/prim.fun
atoms/int-x.fun
atoms/generic-scheme.fun
+atoms/ffi.fun
atoms/const.fun
atoms/cons.fun
atoms/atoms.fun
1.68 +2 -0 mlton/mlton/mlton.cm
Index: mlton.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton.cm,v
retrieving revision 1.67
retrieving revision 1.68
diff -u -r1.67 -r1.68
--- mlton.cm 23 Jun 2003 04:58:54 -0000 1.67
+++ mlton.cm 24 Jun 2003 20:14:21 -0000 1.68
@@ -145,6 +145,7 @@
atoms/int-x.sig
atoms/const.sig
atoms/prim.sig
+atoms/ffi.sig
atoms/atoms.sig
atoms/hash-type.sig
xml/xml-type.sig
@@ -228,6 +229,7 @@
atoms/prim.fun
atoms/int-x.fun
atoms/generic-scheme.fun
+atoms/ffi.fun
atoms/const.fun
atoms/cons.fun
atoms/atoms.fun
1.11 +1 -1 mlton/mlton/ast/ast-core.fun
Index: ast-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- ast-core.fun 25 Feb 2003 02:44:52 -0000 1.10
+++ ast-core.fun 24 Jun 2003 20:14:21 -0000 1.11
@@ -244,7 +244,7 @@
structure PrimKind =
struct
- datatype t = BuildConst | Const | FFI | Prim
+ datatype t = BuildConst | Const | Export | FFI | Prim
end
datatype expNode =
1.7 +24 -23 mlton/mlton/ast/ast-core.sig
Index: ast-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- ast-core.sig 10 Apr 2002 07:02:18 -0000 1.6
+++ ast-core.sig 24 Jun 2003 20:14:21 -0000 1.7
@@ -46,20 +46,20 @@
sharing type Item.pat = t
datatype node =
- Wild
- | Var of {fixop: Fixop.t, name: Longvid.t}
+ App of Longcon.t * t
| Const of Const.t
- | Tuple of t vector
- | Record of {items: Item.t vector,
- flexible: bool}
- | List of t list
- | FlatApp of t vector
- | App of Longcon.t * t
| Constraint of t * Type.t
+ | FlatApp of t vector
| Layered of {fixop: Fixop.t,
var: Var.t,
constraint: Type.t option,
pat: t}
+ | List of t list
+ | Record of {items: Item.t vector,
+ flexible: bool}
+ | Tuple of t vector
+ | Var of {fixop: Fixop.t, name: Longvid.t}
+ | Wild
include WRAPPED sharing type node' = node
sharing type obj = t
@@ -81,7 +81,7 @@
structure PrimKind:
sig
- datatype t = BuildConst | Const | FFI | Prim
+ datatype t = BuildConst | Const | Export | FFI | Prim
end
structure Exp:
@@ -90,29 +90,30 @@
type match
type t
datatype node =
- Const of Const.t
- | Var of {name: Longvid.t, fixop: Fixop.t}
- | Fn of match
- | FlatApp of t vector
+ Andalso of t * t
| App of t * t
| Case of t * match
- | Let of dec * t
- | Seq of t vector
- | Record of t Record.t
- | List of t list
- | Selector of Record.Field.t
+ | Const of Const.t
| Constraint of t * Type.t
+ | FlatApp of t vector
+ | Fn of match
| Handle of t * match
- | Raise of {exn: t,
- filePos: string}
| If of t * t * t
- | Andalso of t * t
+ | Let of dec * t
+ | List of t list
| Orelse of t * t
- | While of {test: t,
- expr: t}
| Prim of {kind: PrimKind.t,
name: string,
ty: Type.t}
+ | Raise of {exn: t,
+ filePos: string}
+ | Record of t Record.t
+ | Selector of Record.Field.t
+ | Seq of t vector
+ | Var of {fixop: Fixop.t,
+ name: Longvid.t}
+ | While of {expr: t,
+ test: t}
include WRAPPED sharing type node' = node
sharing type obj = t
1.8 +3 -0 mlton/mlton/atoms/atoms.fun
Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- atoms.fun 23 Jun 2003 04:58:55 -0000 1.7
+++ atoms.fun 24 Jun 2003 20:14:21 -0000 1.8
@@ -40,6 +40,9 @@
end
structure Con = Con (structure AstId = Ast.Con
structure Var = Var)
+ structure Ffi = Ffi (structure IntSize = IntSize
+ structure RealSize = RealSize
+ structure WordSize = WordSize)
structure IntX = IntX (structure IntSize = IntSize)
structure RealX = RealX (structure RealSize = RealSize)
structure WordX = WordX (structure WordSize = WordSize)
1.8 +13 -9 mlton/mlton/atoms/atoms.sig
Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- atoms.sig 23 Jun 2003 04:58:55 -0000 1.7
+++ atoms.sig 24 Jun 2003 20:14:21 -0000 1.8
@@ -20,6 +20,7 @@
structure Con: CON
structure Cons: SET
structure Const: CONST
+ structure Ffi: FFI
structure IntX: INT_X
structure Prim: PRIM
structure ProfileExp: PROFILE_EXP
@@ -53,9 +54,10 @@
sharing Ast.Var = Var.AstId
sharing Con = Prim.Con
sharing Const = Prim.Const
- sharing IntSize = IntX.IntSize = Prim.IntSize = Tycon.IntSize
+ sharing IntSize = Ffi.IntSize = IntX.IntSize = Prim.IntSize = Tycon.IntSize
sharing IntX = Const.IntX
- sharing RealSize = Prim.RealSize = RealX.RealSize = Tycon.RealSize
+ sharing RealSize = Ffi.RealSize = Prim.RealSize = RealX.RealSize
+ = Tycon.RealSize
sharing RealX = Const.RealX
sharing Record = Ast.Record
sharing Scheme = Prim.Scheme
@@ -63,7 +65,8 @@
sharing SourceInfo = ProfileExp.SourceInfo
sharing Tycon = Scheme.Tycon
sharing Tyvar = Ast.Tyvar
- sharing WordSize = Prim.WordSize = Tycon.WordSize = WordX.WordSize
+ sharing WordSize = Ffi.WordSize = Prim.WordSize = Tycon.WordSize
+ = WordX.WordSize
sharing WordX = Const.WordX
sharing type Con.t = Cons.Element.t
sharing type Tycon.t = Tycons.Element.t
@@ -80,17 +83,18 @@
include ATOMS'
sharing Ast = Atoms.Ast
- sharing Const = Atoms.Const
- sharing Var = Atoms.Var
sharing Con = Atoms.Con
+ sharing Cons = Atoms.Cons
+ sharing Const = Atoms.Const
+ sharing Ffi = Atoms.Ffi
sharing Prim = Atoms.Prim
sharing ProfileExp = Atoms.ProfileExp
- sharing Tycon = Atoms.Tycon
- sharing Tyvar = Atoms.Tyvar
sharing Record = Atoms.Record
sharing SourceInfo = Atoms.SourceInfo
- sharing Vars = Atoms.Vars
- sharing Cons = Atoms.Cons
+ sharing Tycon = Atoms.Tycon
sharing Tycons = Atoms.Tycons
+ sharing Tyvar = Atoms.Tyvar
sharing Tyvars = Atoms.Tyvars
+ sharing Var = Atoms.Var
+ sharing Vars = Atoms.Vars
end
1.52 +6 -0 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -r1.51 -r1.52
--- prim.fun 24 Jun 2003 17:29:37 -0000 1.51
+++ prim.fun 24 Jun 2003 20:14:22 -0000 1.52
@@ -69,6 +69,8 @@
| Exn_setInitExtra (* implement exceptions *)
| Exn_setTopLevelHandler (* implement exceptions *)
| FFI of string (* ssa to rssa *)
+ | FFI_getPointer
+ | FFI_setPointer
| GC_collect (* ssa to rssa *)
| GC_pack (* ssa to rssa *)
| GC_unpack (* ssa to rssa *)
@@ -354,6 +356,8 @@
(Exn_setInitExtra, SideEffect, "Exn_setInitExtra"),
(Exn_setTopLevelHandler, SideEffect, "Exn_setTopLevelHandler"),
(Exn_setTopLevelHandler, SideEffect, "Exn_setTopLevelHandler"),
+ (FFI_getPointer, DependsOnState, "FFI_getPointer"),
+ (FFI_setPointer, SideEffect, "FFI_setPointer"),
(GC_collect, SideEffect, "GC_collect"),
(GC_pack, SideEffect, "GC_pack"),
(GC_unpack, SideEffect, "GC_unpack"),
@@ -734,6 +738,8 @@
| Exn_extra => one result
| Exn_setExtendExtra => one (#2 (dearrow (arg 0)))
| Exn_setInitExtra => one (arg 0)
+ | FFI_getPointer => one result
+ | FFI_setPointer => one (arg 0)
| MLton_bogus => one result
| MLton_deserialize => one result
| MLton_eq => one (arg 0)
1.41 +2 -0 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -r1.40 -r1.41
--- prim.sig 24 Jun 2003 17:29:37 -0000 1.40
+++ prim.sig 24 Jun 2003 20:14:22 -0000 1.41
@@ -54,6 +54,8 @@
| Exn_setInitExtra (* implement exceptions *)
| Exn_setTopLevelHandler (* implement exceptions *)
| FFI of string (* ssa to rssa *)
+ | FFI_getPointer
+ | FFI_setPointer
| GC_collect (* ssa to rssa *)
| GC_pack (* ssa to rssa *)
| GC_unpack (* ssa to rssa *)
1.13 +3 -0 mlton/mlton/atoms/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- sources.cm 23 Jun 2003 04:58:55 -0000 1.12
+++ sources.cm 24 Jun 2003 20:14:22 -0000 1.13
@@ -14,6 +14,7 @@
signature INT_X
signature CON
signature CONST
+signature FFI
signature GENERIC_SCHEME
signature HASH_ID
signature HASH_TYPE
@@ -50,6 +51,8 @@
cons.sig
const.fun
const.sig
+ffi.fun
+ffi.sig
generic-scheme.fun
generic-scheme.sig
hash-type.fun
1.1 mlton/mlton/atoms/ffi.fun
Index: ffi.fun
===================================================================
functor Ffi (S: FFI_STRUCTS): FFI =
struct
open S
structure Type =
struct
datatype t =
Bool
| Char
| Int of IntSize.t
| Pointer
| Real of RealSize.t
| Word of WordSize.t
fun memo (f: t -> 'a): t -> 'a =
let
val bool = f Bool
val char = f Char
val int = IntSize.memoize (f o Int)
val pointer = f Pointer
val real = RealSize.memoize (f o Real)
val word = WordSize.memoize (f o Word)
in
fn Bool => bool
| Char => char
| Int s => int s
| Pointer => pointer
| Real s => real s
| Word s => word s
end
val toString =
memo
(fn u =>
case u of
Bool => "Bool"
| Char => "Char"
| Int s => concat ["Int", IntSize.toString s]
| Pointer => "Pointer"
| Real s => concat ["Real", RealSize.toString s]
| Word s => concat ["Word", WordSize.toString s])
end
val exports: {args: Type.t vector,
id: int,
name: string,
res: Type.t} list ref = ref []
fun numExports () = List.length (!exports)
local
val exportCounter = Counter.new 0
in
fun addExport {args, name, res} =
let
val id = Counter.next exportCounter
val _ = List.push (exports, {args = args,
id = id,
name = name,
res = res})
in
id
end
end
val headers: string list ref = ref []
fun declareHeaders {print} =
List.foreach (!headers, fn s => (print s; print ";\n"))
fun declareExports {print} =
let
val maxMap = Type.memo (fn _ => ref ~1)
fun bump (t, i) =
let
val r = maxMap t
in
r := Int.max (!r, i)
end
val _ =
List.foreach
(!exports, fn {args, res, ...} =>
let
val map = Type.memo (fn _ => Counter.new 0)
in
Vector.foreach (args, fn t => bump (t, Counter.next (map t)))
; bump (res, 0)
end)
(* Declare the arrays and functions used for parameter passing. *)
val _ =
Type.memo
(fn t =>
let
val n = !(maxMap t)
in
if n >= 0
then
let
val size = Int.toString (1 + n)
val t = Type.toString t
in
print (concat [t, " MLton_FFI_", t, "[", size, "];\n"])
; print (concat [t, " MLton_FFI_get", t, " (Int i) {\n",
"\treturn MLton_FFI_", t, "[i];\n",
"}\n"])
; print (concat
[t, " MLton_FFI_set", t, " (", t, " x) {\n",
"\tMLton_FFI_", t, "[0] = x;\n",
"}\n"])
end
else ()
end)
val _ = print "Int MLton_FFI_op;\n"
val _ = print (concat ["Int MLton_FFI_getOp () {\n",
"\treturn MLton_FFI_op;\n",
"}\n"])
in
List.foreach
(!exports, fn {args, id, name, res} =>
let
val varCounter = Counter.new 0
val map = Type.memo (fn _ => Counter.new 0)
val args =
Vector.map
(args, fn t =>
let
val index = Counter.next (map t)
val x = concat ["x", Int.toString (Counter.next varCounter)]
val t = Type.toString t
in
(x,
concat [t, " ", x],
concat ["\tMLton_FFI_", t, "[", Int.toString index, "] = ",
x, ";\n"])
end)
val header =
concat [Type.toString res,
" ", name, " (",
concat (List.separate (Vector.toListMap (args, #2), ", ")),
")"]
val _ = List.push (headers, header)
in
print (concat [header, " {\n"])
; print (concat ["\tMLton_FFI_op = ", Int.toString id, ";\n"])
; Vector.foreach (args, fn (_, _, set) => print set)
; print ("\tMLton_callFromC ();\n")
; print (concat ["\treturn MLton_FFI_", Type.toString res, "[0];\n"])
; print "}\n"
end)
end
end
1.1 mlton/mlton/atoms/ffi.sig
Index: ffi.sig
===================================================================
type int = Int.t
type word = Word.t
signature FFI_STRUCTS =
sig
structure IntSize: INT_SIZE
structure RealSize: REAL_SIZE
structure WordSize: WORD_SIZE
end
signature FFI =
sig
include FFI_STRUCTS
structure Type:
sig
datatype t =
Bool
| Char
| Int of IntSize.t
| Pointer
| Real of RealSize.t
| Word of WordSize.t
val memo: (t -> 'a) -> t -> 'a
val toString: t -> string
end
val addExport: {args: Type.t vector,
name: string,
res: Type.t} -> int
val declareExports: {print: string -> unit} -> unit
(* declareHeaders should be called after declareExports. *)
val declareHeaders: {print: string -> unit} -> unit
val numExports: unit -> int
end
1.41 +13 -0 mlton/mlton/backend/ssa-to-rssa.fun
Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -r1.40 -r1.41
--- ssa-to-rssa.fun 23 Jun 2003 04:58:57 -0000 1.40
+++ ssa-to-rssa.fun 24 Jun 2003 20:14:22 -0000 1.41
@@ -56,6 +56,15 @@
val intInfXorb = make ("IntInf_do_xorb", 2)
end
+ val getPointer =
+ vanilla {name = "MLton_FFI_getPointer",
+ returnTy = SOME Type.pointer}
+
+ val setPointer =
+ vanilla {name = "MLton_FFI_setPointer",
+ returnTy = NONE}
+
+
local
fun make name = vanilla {name = name,
returnTy = SOME Type.defaultInt}
@@ -1064,6 +1073,10 @@
name = name,
returnTy = Option.map (toRtype ty,
Type.toRuntime)})
+ | FFI_getPointer =>
+ simpleCCall CFunction.getPointer
+ | FFI_setPointer =>
+ simpleCCall CFunction.setPointer
| GC_collect =>
ccall
{args = (Vector.new5
1.58 +20 -2 mlton/mlton/codegen/c-codegen/c-codegen.fun
Index: c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -r1.57 -r1.58
--- c-codegen.fun 23 Jun 2003 04:58:58 -0000 1.57
+++ c-codegen.fun 24 Jun 2003 20:14:22 -0000 1.58
@@ -143,7 +143,7 @@
fun callNoSemi (f: string, xs: string list, print: string -> unit): unit
= (print f
- ; print "("
+ ; print " ("
; (case xs
of [] => ()
| x :: xs => (print x
@@ -232,6 +232,7 @@
fun outputDeclarations
{additionalMainArgs: string list,
includes: string list,
+ outputH,
print: string -> unit,
program = (Program.T
{chunks, frameLayouts, frameOffsets, intInfs, maxFrameSize,
@@ -239,6 +240,20 @@
rest: unit -> unit
}: unit =
let
+ fun declareExports () =
+ if Ffi.numExports () > 0
+ then
+ let
+ val _ = Ffi.declareExports {print = print}
+ val {print, done} = outputH ()
+ val _ = print "#include \"types.h\"\n"
+ val _ = Ffi.declareHeaders {print = print}
+ val _ = done ()
+ in
+ ()
+ end
+ else
+ ()
fun declareLoadSaveGlobals () =
let
val _ =
@@ -386,6 +401,7 @@
in
outputIncludes (includes, print)
; declareGlobals ("", print)
+ ; declareExports ()
; declareLoadSaveGlobals ()
; declareIntInfs ()
; declareStrings ()
@@ -477,7 +493,8 @@
main = {chunkLabel, label}, ...},
outputC: unit -> {file: File.t,
print: string -> unit,
- done: unit -> unit}} =
+ done: unit -> unit},
+ outputH} =
let
datatype status = None | One | Many
val {get = labelInfo: Label.t -> {block: Block.t,
@@ -1242,6 +1259,7 @@
val _ =
outputDeclarations {additionalMainArgs = additionalMainArgs,
includes = ["c-main.h"],
+ outputH = outputH,
program = program,
print = print,
rest = rest}
1.7 +6 -1 mlton/mlton/codegen/c-codegen/c-codegen.sig
Index: c-codegen.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- c-codegen.sig 14 May 2003 02:50:11 -0000 1.6
+++ c-codegen.sig 24 Jun 2003 20:14:22 -0000 1.7
@@ -10,6 +10,7 @@
signature C_CODEGEN_STRUCTS =
sig
+ structure Ffi: FFI
structure Machine: MACHINE
end
@@ -20,10 +21,14 @@
val output: {program: Machine.Program.t,
outputC: unit -> {file: File.t,
print: string -> unit,
- done: unit -> unit}
+ done: unit -> unit},
+ outputH: unit -> {done: unit -> unit,
+ print: string -> unit}
} -> unit
val outputDeclarations: {additionalMainArgs: string list,
includes: string list,
+ outputH: unit -> {done: unit -> unit,
+ print: string -> unit},
print: string -> unit,
program: Machine.Program.t,
rest: unit -> unit
1.4 +1 -0 mlton/mlton/codegen/c-codegen/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/sources.cm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- sources.cm 6 Jul 2002 17:22:06 -0000 1.3
+++ sources.cm 24 Jun 2003 20:14:22 -0000 1.4
@@ -12,6 +12,7 @@
is
+../../atoms/sources.cm
../../control/sources.cm
../../../lib/mlton/sources.cm
../../backend/sources.cm
1.41 +2 -0 mlton/mlton/codegen/x86-codegen/x86-codegen.fun
Index: x86-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-codegen.fun,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -r1.40 -r1.41
--- x86-codegen.fun 23 Jun 2003 04:58:58 -0000 1.40
+++ x86-codegen.fun 24 Jun 2003 20:14:22 -0000 1.41
@@ -81,6 +81,7 @@
structure Type = Machine.Type
fun output {program as Machine.Program.T {chunks, frameLayouts, main, ...},
outputC,
+ outputH,
outputS}: unit
= let
val reserveEsp =
@@ -178,6 +179,7 @@
CCodegen.outputDeclarations
{additionalMainArgs = additionalMainArgs,
includes = ["x86-main.h"],
+ outputH = outputH,
print = print,
program = program,
rest = rest}
1.6 +2 -0 mlton/mlton/codegen/x86-codegen/x86-codegen.sig
Index: x86-codegen.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-codegen.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- x86-codegen.sig 14 May 2003 02:50:11 -0000 1.5
+++ x86-codegen.sig 24 Jun 2003 20:14:22 -0000 1.6
@@ -23,6 +23,8 @@
outputC: unit -> {file: File.t,
print: string -> unit,
done: unit -> unit},
+ outputH: unit -> {done: unit -> unit,
+ print: string -> unit},
outputS: unit -> {file: File.t,
print: string -> unit,
done: unit -> unit}}
1.18 +175 -8 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- elaborate-core.fun 2 Jun 2003 23:54:39 -0000 1.17
+++ elaborate-core.fun 24 Jun 2003 20:14:22 -0000 1.18
@@ -42,15 +42,16 @@
structure Con = Con
structure Cdec = Dec
structure Cexp = Exp
+ structure Ffi = Ffi
structure Cmatch = Match
structure Cpat = Pat
structure Cprim = Prim
- structure Ctype = Type
structure Cvar = Var
structure Scheme = Scheme
structure SourceInfo = SourceInfo
structure Tycon = Tycon
structure Type = Type
+ structure Ctype = Type
structure Tyvar = Tyvar
end
@@ -323,6 +324,164 @@
val info = Trace.info "elaborateDec"
val elabExpInfo = Trace.info "elaborateExp"
+structure Ffi =
+ struct
+ open Ffi
+
+ structure Type =
+ struct
+ open Type
+
+ val bogus = Bool
+
+ val nullary =
+ [(Bool, Ctype.bool),
+ (Char, Ctype.con (Tycon.char, Vector.new0 ()))]
+ @ List.map (IntSize.all, fn s => (Int s, Ctype.int s))
+ @ List.map (RealSize.all, fn s => (Real s, Ctype.real s))
+ @ List.map (WordSize.all, fn s => (Word s, Ctype.word s))
+
+ fun peekNullary t =
+ List.peek (nullary, fn (_, t') => Ctype.equals (t, t'))
+
+ val unary = [Tycon.array, Tycon.reff, Tycon.vector]
+
+ fun fromCtype (t: Ctype.t): t option =
+ case peekNullary t of
+ NONE =>
+ (case Ctype.deconOpt t of
+ NONE => NONE
+ | SOME (tycon, ts) =>
+ if List.exists (unary, fn tycon' =>
+ Tycon.equals (tycon, tycon'))
+ andalso 1 = Vector.length ts
+ andalso isSome (peekNullary
+ (Vector.sub (ts, 0)))
+ then SOME Pointer
+ else NONE)
+ | SOME (t, _) => SOME t
+ end
+
+ fun parseCtype (ty: Ctype.t): (Type.t vector * Type.t) option =
+ case Ctype.dearrowOpt ty of
+ NONE => NONE
+ | SOME (t1, t2) =>
+ let
+ fun finish (ts: Type.t vector) =
+ case Type.fromCtype t2 of
+ NONE => NONE
+ | SOME t => SOME (ts, t)
+ in
+ case Ctype.detupleOpt t1 of
+ NONE =>
+ (case Type.fromCtype t1 of
+ NONE => NONE
+ | SOME u => finish (Vector.new1 u))
+ | SOME ts =>
+ let
+ val us = Vector.map (ts, Type.fromCtype)
+ in
+ if Vector.forall (us, isSome)
+ then finish (Vector.map (us, valOf))
+ else NONE
+ end
+ end
+ end
+
+fun export (name: string, ty: Type.t, region: Region.t): Aexp.t =
+ let
+ val (args, exportId, res) =
+ case Ffi.parseCtype ty of
+ NONE =>
+ (Control.error
+ (region,
+ let
+ open Layout
+ in
+ seq [str "invalid type for exported function: ",
+ Type.layout ty]
+ end,
+ Layout.empty)
+ ; (Vector.new0 (), 0, Ffi.Type.bogus))
+ | SOME (us, t) =>
+ let
+ val id = Ffi.addExport {args = us,
+ name = name,
+ res = t}
+ in
+ (us, id, t)
+ end
+ open Ast
+ val filePos = "<export>"
+ fun strid name = Strid.fromString (name, region)
+ fun id name =
+ Aexp.longvid
+ (Longvid.long ([strid "MLton", strid "FFI"],
+ Vid.fromString (name, region)))
+ fun int (i: int): Aexp.t =
+ Aexp.const (Aconst.makeRegion (Aconst.Int (IntInf.fromInt i), region))
+ val f = Var.fromString ("f", region)
+ in
+ Exp.fnn
+ (Match.T
+ {filePos = filePos,
+ rules =
+ Vector.new1
+ (Pat.var f,
+ Exp.app
+ (id "register",
+ Exp.tuple
+ (Vector.new2
+ (int exportId,
+ Exp.fnn
+ (Match.T
+ {filePos = filePos,
+ rules =
+ Vector.new1
+ (Pat.tuple (Vector.new0 ()),
+ let
+ val map = Ffi.Type.memo (fn _ => Counter.new 0)
+ val varCounter = Counter.new 0
+ val (args, decs) =
+ Vector.unzip
+ (Vector.map
+ (args, fn u =>
+ let
+ val x =
+ Var.fromString
+ (concat ["x",
+ Int.toString (Counter.next varCounter)],
+ region)
+ val dec =
+ Dec.vall (Vector.new0 (),
+ x,
+ Exp.app
+ (id (concat
+ ["get", Ffi.Type.toString u]),
+ int (Counter.next (map u))))
+ in
+ (x, dec)
+ end))
+ val resVar = Var.fromString ("res", region)
+ fun newVar () = Var.fromString ("none", region)
+ in
+ Exp.lett
+ (Vector.concat
+ [decs,
+ Vector.map
+ (Vector.new4
+ ((newVar (), Exp.app (id "atomicEnd", Exp.unit)),
+ (resVar, Exp.app (Exp.var f,
+ Exp.tuple (Vector.map (args, Exp.var)))),
+ (newVar (), Exp.app (id "atomicBegin", Exp.unit)),
+ (newVar (),
+ Exp.app (id (concat ["set", Ffi.Type.toString res]),
+ Exp.var resVar))),
+ fn (x, e) => Dec.vall (Vector.new0 (), x, e))],
+ Exp.tuple (Vector.new0 ()))
+ end)})))))})
+ end
+
fun elaborateDec (d, nest, E) =
let
fun elabType t = elaborateType (t, Lookup.fromEnv E)
@@ -779,14 +938,22 @@
let
val ty = elabType ty
datatype z = datatype Ast.PrimKind.t
+ val simple = doit o Cexp.Prim
in
- doit
- (Cexp.Prim
- (case kind of
- BuildConst => Cprim.buildConstant (name, ty)
- | Const => Cprim.constant (name, ty)
- | FFI => Cprim.ffi (name, ty)
- | Prim => Cprim.new (name, ty)))
+ case kind of
+ BuildConst => simple (Cprim.buildConstant (name, ty))
+ | Const => simple (Cprim.constant (name, ty))
+ | Export =>
+ let
+ val ty = Scheme.ty ty
+ in
+ doit
+ (Cexp.Constraint
+ (elabExp' (export (name, ty, region), nest),
+ Type.arrow (ty, Type.unit)))
+ end
+ | FFI => simple (Cprim.ffi (name, ty))
+ | Prim => simple (Cprim.new (name, ty))
end
| Aexp.Raise {exn, filePos} =>
doit (Cexp.Raise {exn = elabExp exn, filePos = filePos})
1.4 +3 -0 mlton/mlton/elaborate/elaborate-core.sig
Index: elaborate-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- elaborate-core.sig 26 Feb 2003 00:17:35 -0000 1.3
+++ elaborate-core.sig 24 Jun 2003 20:14:22 -0000 1.4
@@ -5,6 +5,9 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
+type int = Int.t
+type word = Word.t
+
signature ELABORATE_CORE_STRUCTS =
sig
structure Ast: AST
1.10 +3 -1 mlton/mlton/front-end/ml.grm
Index: ml.grm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.grm,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- ml.grm 23 Jun 2003 04:58:59 -0000 1.9
+++ ml.grm 24 Jun 2003 20:14:22 -0000 1.10
@@ -226,7 +226,7 @@
| ASTERISK | COLON | COLONGT | COMMA | LBRACE | LBRACKET | LPAREN | RBRACE
| RBRACKET | RPAREN | ORELSE | ANDALSO | FUNSIG
(* primitives *)
- | PRIM | FFI | CONST | BUILD_CONST
+ | BUILD_CONST | CONST | EXPORT | FFI | PRIM
%nonterm
aexp of Exp.node
@@ -910,6 +910,8 @@
(Exp.Prim {kind = PrimKind.BuildConst, name = STRING, ty = ty})
| CONST STRING COLON ty SEMICOLON
(Exp.Prim {kind = PrimKind.Const, name = STRING, ty = ty})
+ | EXPORT STRING COLON ty SEMICOLON
+ (Exp.Prim {kind = PrimKind.Export, name = STRING, ty = ty})
| FFI STRING COLON ty SEMICOLON
(Exp.Prim {kind = PrimKind.FFI, name = STRING, ty = ty})
| PRIM STRING COLON ty SEMICOLON
1.10 +6 -6 mlton/mlton/front-end/ml.lex
Index: ml.lex
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.lex,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- ml.lex 23 Jun 2003 04:58:59 -0000 1.9
+++ ml.lex 24 Jun 2003 20:14:22 -0000 1.10
@@ -135,16 +135,16 @@
%%
<INITIAL>{ws} => (continue ());
<INITIAL>{eol} => (Source.newline (source, yypos); continue ());
-<INITIAL>"_overload" => (tok (Tokens.OVERLOAD, source, yypos,
- yypos + size yytext));
-<INITIAL>"_prim" => (tok (Tokens.PRIM, source, yypos,
- yypos + size yytext));
<INITIAL>"_const" => (tok (Tokens.CONST, source, yypos,
yypos + size yytext));
<INITIAL>"_build_const" => (tok (Tokens.BUILD_CONST, source, yypos,
yypos + size yytext));
-<INITIAL>"_ffi" => (tok (Tokens.FFI, source, yypos,
- yypos + size yytext));
+<INITIAL>"_export" => (tok (Tokens.EXPORT, source, yypos, yypos + size yytext));
+<INITIAL>"_ffi" => (tok (Tokens.FFI, source, yypos, yypos + size yytext));
+<INITIAL>"_overload" => (tok (Tokens.OVERLOAD, source, yypos,
+ yypos + size yytext));
+<INITIAL>"_prim" => (tok (Tokens.PRIM, source, yypos,
+ yypos + size yytext));
<INITIAL>"_" => (tok (Tokens.WILD, source, yypos, yypos + 1));
<INITIAL>"," => (tok (Tokens.COMMA, source, yypos, yypos + 1));
<INITIAL>"{" => (tok (Tokens.LBRACE, source, yypos, yypos + 1));
1.6 +2 -0 mlton/mlton/main/compile.sig
Index: compile.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- compile.sig 10 Apr 2002 07:02:20 -0000 1.5
+++ compile.sig 24 Jun 2003 20:14:22 -0000 1.6
@@ -11,6 +11,8 @@
outputC: unit -> {file: File.t,
print: string -> unit,
done: unit -> unit},
+ outputH: unit -> {print: string -> unit,
+ done: unit -> unit},
outputS: unit -> {file: File.t,
print: string -> unit,
done: unit -> unit},
1.54 +8 -3 mlton/mlton/main/compile.sml
Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.53
retrieving revision 1.54
diff -u -r1.53 -r1.54
--- compile.sml 23 Jun 2003 05:45:41 -0000 1.53
+++ compile.sml 24 Jun 2003 20:14:22 -0000 1.54
@@ -28,6 +28,7 @@
open Atoms
in
structure Const = Const
+ structure Ffi = Ffi
structure IntX = IntX
end
structure CoreML = CoreML (open Atoms
@@ -67,7 +68,8 @@
structure Backend = Backend (structure Ssa = Ssa
structure Machine = Machine
fun funcToLabel f = f)
-structure CCodegen = CCodegen (structure Machine = Machine)
+structure CCodegen = CCodegen (structure Ffi = Ffi
+ structure Machine = Machine)
structure x86Codegen = x86Codegen (structure CCodegen = CCodegen
structure Machine = Machine)
@@ -371,6 +373,7 @@
("MLton_native", bool (!Native.native)),
("MLton_profile_isOn", bool (!profile <> ProfileNone)),
("MLton_safe", bool (!safe)),
+ ("MLton_FFI_numExports", int (Ffi.numExports ())),
("TextIO_bufSize", int (!textIOBufSize))]
end
fun lookupBuildConstant (c: string) =
@@ -471,7 +474,7 @@
machine
end
-fun compile {input: File.t list, outputC, outputS, docc}: unit =
+fun compile {input: File.t list, outputC, outputH, outputS, docc}: unit =
let
val machine =
Control.trace (Control.Top, "pre codegen")
@@ -482,11 +485,13 @@
Control.trace (Control.Top, "x86 code gen")
x86Codegen.output {program = machine,
outputC = outputC,
+ outputH = outputH,
outputS = outputS}
else
Control.trace (Control.Top, "C code gen")
CCodegen.output {program = machine,
- outputC = outputC}
+ outputC = outputC,
+ outputH = outputH}
val _ = Control.message (Control.Detail, PropertyList.stats)
val _ = Control.message (Control.Detail, HashSet.stats)
in ()
1.139 +12 -1 mlton/mlton/main/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.138
retrieving revision 1.139
diff -u -r1.138 -r1.139
--- main.sml 18 Jun 2003 17:40:50 -0000 1.138
+++ main.sml 24 Jun 2003 20:14:22 -0000 1.139
@@ -579,7 +579,6 @@
f
end
fun suffix s = concat [base, s]
- fun file (b, suf) = (if b then suffix else temp) suf
fun maybeOut suf =
case !output of
NONE => suffix suf
@@ -777,12 +776,24 @@
in Layout.output (l, out)
; Out.newline out
end)
+ fun outputH () =
+ let
+ val file = suffix ".h"
+ val out = Out.openOut file
+ fun done () = Out.close out
+ fun print s = Out.output (out, s)
+ val _ = outputHeader' (Control.C, out)
+ in
+ {done = done,
+ print = print}
+ end
val _ =
trace (Top, "Compile SML")
Compile.compile
{input = files,
docc = docc,
outputC = make (Control.C, ".c"),
+ outputH = outputH,
outputS = make (Control.Assembly,
if !debug then ".s" else ".S")}
(* Shrink the heap before calling gcc. *)
1.2 +0 -1 mlton/regression/ffi.sml
Index: ffi.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/ffi.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- ffi.sml 14 May 2003 16:45:55 -0000 1.1
+++ ffi.sml 24 Jun 2003 20:14:23 -0000 1.2
@@ -1,2 +1 @@
-val _ = MLton.FFI.handleCallFromC (fn () => print "call")
val _ = print "ok\n"
1.2 +1 -0 mlton/runtime/types.h
Index: types.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/types.h,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- types.h 23 Jun 2003 04:59:01 -0000 1.1
+++ types.h 24 Jun 2003 20:14:23 -0000 1.2
@@ -8,6 +8,7 @@
typedef char *Pointer;
typedef float Real32;
typedef double Real64;
+typedef void Unit;
typedef unsigned char Word8;
typedef unsigned short Word16;
typedef unsigned long Word32;
-------------------------------------------------------
This SF.Net email is sponsored by: INetU
Attention Web Developers & Consultants: Become An INetU Hosting Partner.
Refer Dedicated Servers. We Manage Them. You Get 10% Monthly Commission!
INetU Dedicated Managed Hosting http://www.inetu.net/partner/index.php
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel