[MLton] cvs commit: Improved FFI.
Matthew Fluet
fluet@mlton.org
Sat, 23 Jul 2005 04:55:44 -0700
fluet 05/07/23 04:55:42
Modified: basis-library/libs primitive.mlb
basis-library/misc primitive.sml
basis-library/posix primitive.sml
bin regression
doc changelog
doc/examples/ffi Makefile export.sml ffi-export.c import.sml
import2.sml
mlton/ast ast-core.fun ast-core.sig
mlton/atoms ffi.fun ffi.sig prim.fun prim.sig
mlton/codegen/c-codegen c-codegen.fun
mlton/control control-flags.sig control-flags.sml
mlton/elaborate elaborate-core.fun scope.fun
mlton/front-end ml.grm ml.lex
Log:
MAIL Improved FFI.
Incorporated Wesley's patch for improved FFI. After the discussion on
the list regarding C pointers, I went ahead and eliminated _address
infavor of _symbol, which provides the address, getter, and setter.
So, the FFI system now looks like:
_import "symbol" [cdecl | stdcall] : cfTy; ==> cfTy
_import * [cdecl | stdcall] : ptrTy -> cfTy; ==> ptrTy -> cfTy
_export "symbol" [cdecl | stdcall] : cfTy; ==> cfTy -> unit
_symbol "symbol" [define] : ptrTy, cbTy; ==> ptrTy * (unit -> cbTy) * (cbTy -> unit)
_symbol * : ptrTy, cbTy; ==> (ptrTy -> cbTy) * (ptrTy * cbTy -> unit)
I'm tempted to revise _import * to
_import * [cdecl | stdcall] : ptrTy, cfTy; ==> ptrTy -> cfTy
but I don't think it is crucial.
Revision Changes Path
1.5 +1 -0 mlton/basis-library/libs/primitive.mlb
Index: primitive.mlb
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/primitive.mlb,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- primitive.mlb 4 Nov 2004 01:16:04 -0000 1.4
+++ primitive.mlb 23 Jul 2005 11:55:33 -0000 1.5
@@ -3,6 +3,7 @@
"allowImport true"
"allowPrim true"
"allowRebindEquals true"
+ "allowSymbol true"
"deadCode true"
"sequenceUnit true"
"warnMatch true"
1.156 +27 -28 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.155
retrieving revision 1.156
diff -u -r1.155 -r1.156
--- primitive.sml 13 Jul 2005 01:30:10 -0000 1.155
+++ primitive.sml 23 Jul 2005 11:55:34 -0000 1.156
@@ -241,7 +241,7 @@
struct
type t = Pointer.t
- val gcState = _import "gcStateAddress": t;
+ val gcState = #2 _symbol "gcStateAddress": Pointer.t, t; ()
end
structure CallStack =
@@ -310,10 +310,9 @@
structure CommandLine =
struct
- val argc = fn () => _import "CommandLine_argc": int;
- val argv = fn () => _import "CommandLine_argv": CStringArray.t;
- val commandName =
- fn () => _import "CommandLine_commandName": CString.t;
+ val argc = #2 _symbol "CommandLine_argc": Pointer.t, int;
+ val argv = #2 _symbol "CommandLine_argv": Pointer.t, CStringArray.t;
+ val commandName = #2 _symbol "CommandLine_commandName": Pointer.t, CString.t;
end
structure Date =
@@ -374,19 +373,19 @@
structure FFI =
struct
- val getOp = fn () => _import "MLton_FFI_op": int;
- val int8Array = _import "MLton_FFI_Int8": Pointer.t;
- val int16Array = _import "MLton_FFI_Int16": Pointer.t;
- val int32Array = _import "MLton_FFI_Int32": Pointer.t;
- val int64Array = _import "MLton_FFI_Int64": Pointer.t;
+ val getOp = #2 _symbol "MLton_FFI_op": Pointer.t, int;
+ val int8Array = #2 _symbol "MLton_FFI_Int8": Pointer.t, Pointer.t; ()
+ val int16Array = #2 _symbol "MLton_FFI_Int16": Pointer.t, Pointer.t; ()
+ val int32Array = #2 _symbol "MLton_FFI_Int32": Pointer.t, Pointer.t; ()
+ val int64Array = #2 _symbol "MLton_FFI_Int64": Pointer.t, Pointer.t; ()
val numExports = _build_const "MLton_FFI_numExports": int;
- val pointerArray = _import "MLton_FFI_Pointer": Pointer.t;
- val real32Array = _import "MLton_FFI_Real32": Pointer.t;
- val real64Array = _import "MLton_FFI_Real64": Pointer.t;
- val word8Array = _import "MLton_FFI_Word8": Pointer.t;
- val word16Array = _import "MLton_FFI_Word16": Pointer.t;
- val word32Array = _import "MLton_FFI_Word32": Pointer.t;
- val word64Array = _import "MLton_FFI_Word64": Pointer.t;
+ val pointerArray = #2 _symbol "MLton_FFI_Pointer": Pointer.t, Pointer.t; ()
+ val real32Array = #2 _symbol "MLton_FFI_Real32": Pointer.t, Pointer.t; ()
+ val real64Array = #2 _symbol "MLton_FFI_Real64": Pointer.t, Pointer.t; ()
+ val word8Array = #2 _symbol "MLton_FFI_Word8": Pointer.t, Pointer.t; ()
+ val word16Array = #2 _symbol "MLton_FFI_Word16": Pointer.t, Pointer.t; ()
+ val word32Array = #2 _symbol "MLton_FFI_Word32": Pointer.t, Pointer.t; ()
+ val word64Array = #2 _symbol "MLton_FFI_Word64": Pointer.t, Pointer.t; ()
end
structure GC =
@@ -984,7 +983,7 @@
val forkIsEnabled =
case host of
Cygwin =>
- _import "MLton_Platform_CygwinUseMmap": bool;
+ #2 _symbol "MLton_Platform_CygwinUseMmap": Pointer.t, bool; ()
| MinGW => false
| _ => true
@@ -1309,11 +1308,11 @@
val atan2 = _prim "Real64_Math_atan2": real * real -> real;
val cos = _prim "Real64_Math_cos": real -> real;
val cosh = _import "cosh": real -> real;
- val e = _import "Real64_Math_e": real;
+ val e = #2 _symbol "Real64_Math_e": Pointer.t, real; ()
val exp = _prim "Real64_Math_exp": real -> real;
val ln = _prim "Real64_Math_ln": real -> real;
val log10 = _prim "Real64_Math_log10": real -> real;
- val pi = _import "Real64_Math_pi": real;
+ val pi = #2 _symbol "Real64_Math_pi": Pointer.t, real; ()
val pow = _import "pow": real * real -> real;
val sin = _prim "Real64_Math_sin": real -> real;
val sinh = _import "sinh": real -> real;
@@ -1339,9 +1338,9 @@
_import "Real64_gdtoa": real * int * int * int ref -> CString.t;
val fromInt = _prim "WordS32_toReal64": int -> real;
val ldexp = _prim "Real64_ldexp": real * int -> real;
- val maxFinite = _import "Real64_maxFinite": real;
- val minNormalPos = _import "Real64_minNormalPos": real;
- val minPos = _import "Real64_minPos": real;
+ val maxFinite = #2 _symbol "Real64_maxFinite": Pointer.t, real; ()
+ val minNormalPos = #2 _symbol "Real64_minNormalPos": Pointer.t, real; ()
+ val minPos = #2 _symbol "Real64_minPos": Pointer.t, real; ()
val modf = _import "Real64_modf": real * real ref -> real;
val nextAfter = _import "Real64_nextAfter": real * real -> real;
val round = _prim "Real64_round": real -> real;
@@ -1383,11 +1382,11 @@
val atan2 = _prim "Real32_Math_atan2": real * real -> real;
val cos = _prim "Real32_Math_cos": real -> real;
val cosh = unary Real64.Math.cosh
- val e = _import "Real32_Math_e": real;
+ val e = #2 _symbol "Real32_Math_e": Pointer.t, real; ()
val exp = _prim "Real32_Math_exp": real -> real;
val ln = _prim "Real32_Math_ln": real -> real;
val log10 = _prim "Real32_Math_log10": real -> real;
- val pi = _import "Real32_Math_pi": real;
+ val pi = #2 _symbol "Real32_Math_pi": Pointer.t, real; ()
val pow = binary Real64.Math.pow
val sin = _prim "Real32_Math_sin": real -> real;
val sinh = unary Real64.Math.sinh
@@ -1414,9 +1413,9 @@
_import "Real32_gdtoa": real * int * int * int ref -> CString.t;
val fromInt = _prim "WordS32_toReal32": int -> real;
val ldexp = _prim "Real32_ldexp": real * int -> real;
- val maxFinite = _import "Real32_maxFinite": real;
- val minNormalPos = _import "Real32_minNormalPos": real;
- val minPos = _import "Real32_minPos": real;
+ val maxFinite = #2 _symbol "Real32_maxFinite": Pointer.t, real; ()
+ val minNormalPos = #2 _symbol "Real32_minNormalPos": Pointer.t, real; ()
+ val minPos = #2 _symbol "Real32_minPos": Pointer.t, real; ()
val modf = _import "Real32_modf": real * real ref -> real;
val signBit = _import "Real32_signBit": real -> bool;
val strto = _import "Real32_strto": NullString.t -> real;
1.40 +1 -1 mlton/basis-library/posix/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/primitive.sml,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- primitive.sml 19 Jul 2005 12:41:06 -0000 1.39
+++ primitive.sml 23 Jul 2005 11:55:34 -0000 1.40
@@ -299,7 +299,7 @@
end
val ctermid = _import "Posix_ProcEnv_ctermid" : unit -> cstring;
- val environ = _import "Posix_ProcEnv_environ" : cstringArray;
+ val environ = #2 _symbol "Posix_ProcEnv_environ" : Pointer.t, cstringArray; ()
val getenv = _import "Posix_ProcEnv_getenv" : NullString.t -> cstring;
val isatty = _import "Posix_ProcEnv_isatty" : fd -> bool;
val sysconf = _import "Posix_ProcEnv_sysconf" : int -> int;
1.106 +1 -2 mlton/bin/regression
Index: regression
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/regression,v
retrieving revision 1.105
retrieving revision 1.106
diff -u -r1.105 -r1.106
--- regression 15 Dec 2004 22:43:49 -0000 1.105
+++ regression 23 Jul 2005 11:55:35 -0000 1.106
@@ -127,8 +127,7 @@
\$(SML_LIB)/basis/mlton.mlb
\$(SML_LIB)/basis/sml-nj.mlb
ann
- \"allowExport true\"
- \"allowImport true\"
+ \"allowFFI true\"
\"allowOverload true\"
\"warnMatch false\"
in $f.sml
1.168 +6 -0 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.167
retrieving revision 1.168
diff -u -r1.167 -r1.168
--- changelog 21 Jul 2005 15:09:11 -0000 1.167
+++ changelog 23 Jul 2005 11:55:36 -0000 1.168
@@ -1,4 +1,10 @@
Here are the changes since version 20041109.
+
+* 2005-07-23
+ - Overhaul of FFI.
+ Deprecated _import of C base types.
+ Added _symbol for address, getter, and setter of C base types.
+ See documentation for more detail.
* 2005-07-21
- Update mllex and mlyacc with SML/NJ 110.55 versions. This
1.22 +1 -1 mlton/doc/examples/ffi/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/Makefile,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- Makefile 18 Jan 2005 17:56:27 -0000 1.21
+++ Makefile 23 Jul 2005 11:55:36 -0000 1.22
@@ -1,6 +1,6 @@
PATH = ../../../build/bin:$(shell echo $$PATH)
-mlton = mlton -default-ann 'allowExport true' -default-ann 'allowImport true'
+mlton = mlton -default-ann 'allowFFI true'
.PHONY: all
all: import import2 export iimport test_quot
1.8 +5 -0 mlton/doc/examples/ffi/export.sml
Index: export.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/export.sml,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- export.sml 15 Jan 2004 16:06:32 -0000 1.7
+++ export.sml 23 Jul 2005 11:55:37 -0000 1.8
@@ -24,6 +24,11 @@
val g4 = _import "g4": int -> unit;
val _ = e (fn i => if i = 0 then () else g4 (i - 1))
val _ = g4 13
+
+val (_, _, zzzSet) = _symbol "zzz" define: MLton.Pointer.t, int;
+val () = zzzSet 42
+val g5 = _import "g5": unit -> unit;
+val _ = g5 ()
val _ = print "success\n"
1.5 +6 -0 mlton/doc/examples/ffi/ffi-export.c
Index: ffi-export.c
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/ffi-export.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- ffi-export.c 15 Jan 2004 16:06:32 -0000 1.4
+++ ffi-export.c 23 Jul 2005 11:55:37 -0000 1.5
@@ -27,3 +27,9 @@
fprintf (stderr, "g4 (%d)\n", i);
f4 (i);
}
+
+void g5 () {
+ fprintf (stderr, "g5 ()\n");
+ fprintf (stderr, "zzz = %i\n", zzz);
+ fprintf (stderr, "g5 done\n");
+}
1.3 +2 -2 mlton/doc/examples/ffi/import.sml
Index: import.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/import.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- import.sml 19 Jul 2003 01:23:25 -0000 1.2
+++ import.sml 23 Jul 2005 11:55:37 -0000 1.3
@@ -13,9 +13,9 @@
(* Call the C function *)
val c = ffi (a, r, n)
-val n = _import "FFI_INT": int;
+val (addrN, getN, setN) = _symbol "FFI_INT": MLton.Pointer.t, int;
-val _ = print (concat [Int.toString n, "\n"])
+val _ = print (concat [Int.toString (getN ()), "\n"])
val _ =
print (if c = #"c" andalso !r = 45
1.3 +13 -17 mlton/doc/examples/ffi/import2.sml
Index: import2.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/import2.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- import2.sml 6 Mar 2005 22:09:44 -0000 1.2
+++ import2.sml 23 Jul 2005 11:55:37 -0000 1.3
@@ -1,7 +1,7 @@
(* main.sml *)
(* Declare ffi to be implemented by calling the C function ffi. *)
-val ffi_addr = _import # "ffi" : MLton.Pointer.t;
+val (ffi_addr, _, _) = _symbol "ffi" : MLton.Pointer.t, MLton.Pointer.t;
val ffi_schema = _import * : MLton.Pointer.t -> real array * int ref * int -> char;
open Array
@@ -19,13 +19,13 @@
then "success\n"
else "fail\n")
-val n = _import "FFI_INT": int;
+val n = #2 (_symbol "FFI_INT": MLton.Pointer.t, int;) ()
val _ = print (concat [Int.toString n, "\n"])
-val w = _import "FFI_WORD": word;
+val w = #2 (_symbol "FFI_WORD": MLton.Pointer.t, word;) ()
val _ = print (concat [Word.toString w, "\n"])
-val b = _import "FFI_BOOL": bool;
+val b = #2 (_symbol "FFI_BOOL": MLton.Pointer.t, bool;) ()
val _ = print (concat [Bool.toString b, "\n"])
-val r = _import "FFI_REAL": real;
+val r = #2 (_symbol "FFI_REAL": MLton.Pointer.t, real;) ()
val _ = print (concat [Real.toString r, "\n"])
signature OPAQUE =
@@ -55,24 +55,20 @@
val toString = Real.toString
end
-val n = _import "FFI_INT": OpaqueInt.t;
-val _ = print (concat [OpaqueInt.toString n, "\n"])
-val w = _import "FFI_WORD": OpaqueWord.t;
-val _ = print (concat [OpaqueWord.toString w, "\n"])
-val b = _import "FFI_BOOL": OpaqueBool.t;
-val _ = print (concat [OpaqueBool.toString b, "\n"])
-val r = _import "FFI_REAL": OpaqueReal.t;
-val _ = print (concat [OpaqueReal.toString r, "\n"])
+val (n_addr, n, _) = _symbol "FFI_INT": MLton.Pointer.t, OpaqueInt.t;
+val _ = print (concat [OpaqueInt.toString (n ()), "\n"])
+val (w_addr, w, _) = _symbol "FFI_WORD": MLton.Pointer.t, OpaqueWord.t;
+val _ = print (concat [OpaqueWord.toString (w ()), "\n"])
+val (b_addr, b, _) = _symbol "FFI_BOOL": MLton.Pointer.t, OpaqueBool.t;
+val _ = print (concat [OpaqueBool.toString (b ()), "\n"])
+val (r_addr, r, _) = _symbol "FFI_REAL": MLton.Pointer.t, OpaqueReal.t;
+val _ = print (concat [OpaqueReal.toString (r ()), "\n"])
-val n_addr = _import # "FFI_INT": MLton.Pointer.t;
val n = MLton.Pointer.getInt32 (n_addr, 0);
val _ = print (concat [Int.toString n, "\n"])
-val w_addr = _import # "FFI_WORD": MLton.Pointer.t;
val w = MLton.Pointer.getWord32 (w_addr, 0);
val _ = print (concat [Word.toString w, "\n"])
-val b_addr = _import # "FFI_BOOL": MLton.Pointer.t;
val b = (MLton.Pointer.getInt32 (n_addr, 0)) <> 0
val _ = print (concat [Bool.toString b, "\n"])
-val r_addr = _import # "FFI_REAL": MLton.Pointer.t;
val r = MLton.Pointer.getReal64 (r_addr, 0)
val _ = print (concat [Real.toString r, "\n"])
1.34 +38 -14 mlton/mlton/ast/ast-core.fun
Index: ast-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- ast-core.fun 19 Jun 2005 21:33:41 -0000 1.33
+++ ast-core.fun 23 Jul 2005 11:55:37 -0000 1.34
@@ -259,7 +259,7 @@
structure PrimKind =
struct
- structure Attribute =
+ structure ImportExportAttribute =
struct
datatype t = Cdecl | Stdcall
@@ -270,15 +270,40 @@
val layout = Layout.str o toString
end
+ structure SymbolAttribute =
+ struct
+ datatype t = Define
+
+ val toString: t -> string =
+ fn Define => "define"
+
+ val layout = Layout.str o toString
+ end
+
datatype t =
- BuildConst of {name: string}
- | CommandLineConst of {name: string, value: Const.t}
- | Const of {name: string}
- | Export of {attributes: Attribute.t list, name: string}
- | IImport of {attributes: Attribute.t list}
- | Import of {attributes: Attribute.t list, name: string}
- | Symbol of {name: string}
- | Prim of {name: string}
+ BuildConst of {name: string,
+ ty: Type.t}
+ | CommandLineConst of {name: string,
+ ty: Type.t,
+ value: Const.t}
+ | Const of {name: string,
+ ty: Type.t}
+ | Export of {attributes: ImportExportAttribute.t list,
+ name: string,
+ cfTy: Type.t}
+ | IImport of {attributes: ImportExportAttribute.t list,
+ cfTy: Type.t}
+ | Import of {attributes: ImportExportAttribute.t list,
+ name: string,
+ cfTy: Type.t}
+ | ISymbol of {cbTy: Type.t,
+ ptrTy: Type.t}
+ | Prim of {name: string,
+ ty: Type.t}
+ | Symbol of {attributes: SymbolAttribute.t list,
+ name: string,
+ cbTy: Type.t,
+ ptrTy: Type.t}
fun name pk =
case pk of
@@ -288,9 +313,9 @@
| Export {name, ...} => name
| IImport {...} => "<iimport>"
| Import {name, ...} => name
- | Symbol {name, ...} => name
+ | ISymbol {...} => "<isymbol>"
| Prim {name, ...} => name
-
+ | Symbol {name, ...} => name
end
structure Priority =
@@ -328,8 +353,7 @@
| Andalso of exp * exp
| Orelse of exp * exp
| While of {test: exp, expr: exp}
- | Prim of {kind: PrimKind.t,
- ty: Type.t}
+ | Prim of PrimKind.t
and decNode =
Abstype of {body: dec,
datBind: DatBind.t}
@@ -441,7 +465,7 @@
| Orelse (e, e') =>
delimit (mayAlign [layoutExpF e,
seq [str "orelse ", layoutExpF e']])
- | Prim {kind, ...} => str (PrimKind.name kind)
+ | Prim kind => str (PrimKind.name kind)
| Raise exn => delimit (seq [str "raise ", layoutExpF exn])
| Record r =>
let
1.21 +32 -11 mlton/mlton/ast/ast-core.sig
Index: ast-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.sig,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- ast-core.sig 12 Jan 2005 21:56:00 -0000 1.20
+++ ast-core.sig 23 Jul 2005 11:55:38 -0000 1.21
@@ -85,22 +85,44 @@
structure PrimKind:
sig
- structure Attribute:
+ structure ImportExportAttribute:
sig
datatype t = Cdecl | Stdcall
val layout: t -> Layout.t
end
+
+ structure SymbolAttribute:
+ sig
+ datatype t = Define
+
+ val layout: t -> Layout.t
+ end
datatype t =
- BuildConst of {name: string}
- | CommandLineConst of {name: string, value: Const.t}
- | Const of {name: string}
- | Export of {attributes: Attribute.t list, name: string}
- | IImport of {attributes: Attribute.t list}
- | Import of {attributes: Attribute.t list, name: string}
- | Symbol of {name: string}
- | Prim of {name: string}
+ BuildConst of {name: string,
+ ty: Type.t}
+ | CommandLineConst of {name: string,
+ ty: Type.t,
+ value: Const.t}
+ | Const of {name: string,
+ ty: Type.t}
+ | Export of {attributes: ImportExportAttribute.t list,
+ name: string,
+ cfTy: Type.t}
+ | IImport of {attributes: ImportExportAttribute.t list,
+ cfTy: Type.t}
+ | Import of {attributes: ImportExportAttribute.t list,
+ name: string,
+ cfTy: Type.t}
+ | ISymbol of {cbTy: Type.t,
+ ptrTy: Type.t}
+ | Prim of {name: string,
+ ty: Type.t}
+ | Symbol of {attributes: SymbolAttribute.t list,
+ name: string,
+ cbTy: Type.t,
+ ptrTy: Type.t}
end
structure Priority:
@@ -129,8 +151,7 @@
| Let of dec * t
| List of t vector
| Orelse of t * t
- | Prim of {kind: PrimKind.t,
- ty: Type.t}
+ | Prim of PrimKind.t
| Raise of t
| Record of t Record.t
| Selector of Record.Field.t
1.8 +12 -0 mlton/mlton/atoms/ffi.fun
Index: ffi.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/ffi.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- ffi.fun 4 Apr 2004 06:50:14 -0000 1.7
+++ ffi.fun 23 Jul 2005 11:55:38 -0000 1.8
@@ -17,6 +17,8 @@
id: int,
name: string,
res: CType.t option} list ref = ref []
+val symbols: {name: string,
+ ty: CType.t} list ref = ref []
fun numExports () = List.length (!exports)
@@ -34,6 +36,8 @@
in
id
end
+ fun addSymbol {name, ty} =
+ ignore (List.push (symbols, {name=name, ty=ty}))
end
val headers: string list ref = ref []
@@ -77,6 +81,14 @@
end)
val _ = print "Int MLton_FFI_op;\n"
in
+ List.foreach
+ (!symbols, fn {name, ty} =>
+ let
+ val decl = CType.toString ty ^ " " ^ name;
+ in
+ List.push (headers, "extern " ^ decl);
+ print (decl ^ ";\n")
+ end);
List.foreach
(!exports, fn {args, convention, id, name, res} =>
let
1.7 +2 -0 mlton/mlton/atoms/ffi.sig
Index: ffi.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/ffi.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- ffi.sig 12 Apr 2004 17:52:48 -0000 1.6
+++ ffi.sig 23 Jul 2005 11:55:38 -0000 1.7
@@ -21,6 +21,8 @@
convention: CFunction.Convention.t,
name: string,
res: CType.t option} -> int
+ val addSymbol: {ty: CType.t,
+ name: string} -> unit
val declareExports: {print: string -> unit} -> unit
val declareHeaders: {print: string -> unit} -> unit
val numExports: unit -> int
1.102 +18 -2 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.101
retrieving revision 1.102
diff -u -r1.101 -r1.102
--- prim.fun 19 Jun 2005 21:33:43 -0000 1.101
+++ prim.fun 23 Jul 2005 11:55:38 -0000 1.102
@@ -46,7 +46,7 @@
| Exn_setExtendExtra (* implement exceptions *)
| Exn_setInitExtra (* implement exceptions *)
| FFI of 'a CFunction.t (* ssa to rssa *)
- | FFI_Symbol of {name: string} (* codegen *)
+ | FFI_Symbol of {name: string, cty: CType.t} (* codegen *)
| GC_collect (* ssa to rssa *)
| IntInf_add (* ssa to rssa *)
| IntInf_andb (* ssa to rssa *)
@@ -486,7 +486,7 @@
| Exn_setExtendExtra => Exn_setExtendExtra
| Exn_setInitExtra => Exn_setInitExtra
| FFI func => FFI (CFunction.map (func, f))
- | FFI_Symbol {name} => FFI_Symbol {name = name}
+ | FFI_Symbol {name, cty} => FFI_Symbol {name = name, cty = cty}
| GC_collect => GC_collect
| IntInf_add => IntInf_add
| IntInf_andb => IntInf_andb
@@ -631,6 +631,22 @@
| Word16 => Pointer_getWord (WordSize.fromBits (Bits.fromInt 16))
| Word32 => Pointer_getWord (WordSize.fromBits (Bits.fromInt 32))
| Word64 => Pointer_getWord (WordSize.fromBits (Bits.fromInt 64))
+ end
+fun pointerSet ctype =
+ let datatype z = datatype CType.t
+ in
+ case ctype of
+ Int8 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 8))
+ | Int16 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 16))
+ | Int32 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 32))
+ | Int64 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 64))
+ | Pointer => Pointer_setPointer
+ | Real32 => Pointer_setReal RealSize.R32
+ | Real64 => Pointer_setReal RealSize.R64
+ | Word8 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 8))
+ | Word16 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 16))
+ | Word32 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 32))
+ | Word64 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 64))
end
val reff = Ref_ref
1.76 +3 -2 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.75
retrieving revision 1.76
diff -u -r1.75 -r1.76
--- prim.sig 6 Mar 2005 22:09:44 -0000 1.75
+++ prim.sig 23 Jul 2005 11:55:38 -0000 1.76
@@ -35,7 +35,7 @@
| Exn_setExtendExtra (* implement exceptions *)
| Exn_setInitExtra (* implement exceptions *)
| FFI of 'a CFunction.t (* ssa to rssa *)
- | FFI_Symbol of {name: string} (* codegen *)
+ | FFI_Symbol of {name: string, cty: CType.t} (* codegen *)
| GC_collect (* ssa to rssa *)
| IntInf_add (* ssa to rssa *)
| IntInf_andb (* ssa to rssa *)
@@ -215,7 +215,7 @@
deWeak: 'b -> 'b,
result: 'b} -> 'b vector
val ffi: 'a CFunction.t -> 'a t
- val ffiSymbol: {name: string} -> 'a t
+ val ffiSymbol: {name: string, cty: CType.t} -> 'a t
val fromString: string -> 'a t
val gcCollect: 'a t
val intInfEqual: 'a t
@@ -239,6 +239,7 @@
*)
val maySideEffect: 'a t -> bool
val pointerGet: CType.t -> 'a t
+ val pointerSet: CType.t -> 'a t
val name: 'a t -> 'a Name.t
val reff: 'a t
val serialize: 'a t
1.107 +2 -5 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.106
retrieving revision 1.107
diff -u -r1.106 -r1.107
--- c-codegen.fun 19 Jun 2005 21:33:48 -0000 1.106
+++ c-codegen.fun 23 Jul 2005 11:55:39 -0000 1.107
@@ -461,13 +461,10 @@
case s of
Statement.PrimApp {prim, ...} =>
(case Prim.name prim of
- Prim.Name.FFI_Symbol {name, ...} =>
+ Prim.Name.FFI_Symbol {name, cty} =>
doit
(name, fn () =>
- (* Only take address of FFI_Symbol,
- * so no need for a type specifier
- *)
- concat ["extern ", name, ";\n"])
+ concat ["extern ", CType.toString cty, " ", name, ";\n"])
| _ => ())
| _ => ())
val _ =
1.4 +2 -1 mlton/mlton/control/control-flags.sig
Index: control-flags.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control-flags.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- control-flags.sig 19 Jul 2005 12:41:09 -0000 1.3
+++ control-flags.sig 23 Jul 2005 11:55:39 -0000 1.4
@@ -65,6 +65,7 @@
val allowOverload: (bool,bool) t
val allowPrim: (bool,bool) t
val allowRebindEquals: (bool,bool) t
+ val allowSymbol: (bool,bool) t
val deadCode: (bool,bool) t
val forceUsed: (unit,bool) t
val ffiStr: (string,string option) t
@@ -305,4 +306,4 @@
(*------------------------------------*)
(* End Flags *)
(*------------------------------------*)
-end
\ No newline at end of file
+end
1.5 +24 -1 mlton/mlton/control/control-flags.sml
Index: control-flags.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control-flags.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- control-flags.sml 19 Jul 2005 12:41:09 -0000 1.4
+++ control-flags.sml 23 Jul 2005 11:55:39 -0000 1.5
@@ -263,6 +263,9 @@
[arg'] => Bool.fromString arg'
| _ => NONE},
ac)
+
+ fun setCur (T {cur, ...}, x) = cur := x
+ fun setDef (T {def, ...}, x) = def := x
in
val ac =
{parseId = fn _ => NONE,
@@ -281,8 +284,28 @@
makeBool ({name = "allowOverload", default = false, expert = false}, ac)
val (allowRebindEquals, ac) =
makeBool ({name = "allowRebindEquals", default = false, expert = true}, ac)
+ val (allowSymbol, ac) =
+ makeBool ({name = "allowSymbol", default = false, expert = false}, ac)
val (deadCode, ac) =
makeBool ({name = "deadCode", default = false, expert = false}, ac)
+ val (allowFFI, ac) =
+ make ({default = false,
+ expert = false,
+ toString = Bool.toString,
+ name = "allowFFI",
+ newCur = fn (_, b) => (setCur (allowExport, b)
+ ; setCur (allowImport, b)
+ ; setCur (allowSymbol, b)
+ ; b),
+ newDef = fn (_, b) => (setDef (allowExport, b)
+ ; setDef (allowImport, b)
+ ; setDef (allowSymbol, b)
+ ; b),
+ parseArgs = fn args' =>
+ case args' of
+ [arg'] => Bool.fromString arg'
+ | _ => NONE},
+ ac)
val (forceUsed, ac) =
make ({default = false,
expert = false,
@@ -769,4 +792,4 @@
val _ = defaults ()
-end
\ No newline at end of file
+end
1.153 +472 -237 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.152
retrieving revision 1.153
diff -u -r1.152 -r1.153
--- elaborate-core.fun 21 Jul 2005 05:57:57 -0000 1.152
+++ elaborate-core.fun 23 Jul 2005 11:55:40 -0000 1.153
@@ -38,7 +38,8 @@
structure Longvid = Longvid
structure Longtycon = Longtycon
structure PrimKind = PrimKind
- structure Attribute = PrimKind.Attribute
+ structure ImportExportAttribute = PrimKind.ImportExportAttribute
+ structure SymbolAttribute = PrimKind.SymbolAttribute
structure Priority = Priority
structure Record = Record
structure SortedRecord = SortedRecord
@@ -822,13 +823,13 @@
end
end
-fun parseAttributes (attributes: Attribute.t list): Convention.t option =
+fun parseIEAttributes (attributes: ImportExportAttribute.t list): Convention.t option =
case attributes of
[] => SOME Convention.Cdecl
| [a] =>
SOME (case a of
- Attribute.Cdecl => Convention.Cdecl
- | Attribute.Stdcall =>
+ ImportExportAttribute.Cdecl => Convention.Cdecl
+ | ImportExportAttribute.Stdcall =>
if let
open Control
in
@@ -841,7 +842,7 @@
else Convention.Cdecl)
| _ => NONE
-fun import {attributes: Attribute.t list,
+fun import {attributes: ImportExportAttribute.t list,
name: string option,
region: Region.t,
ty: Type.t}: Type.t Prim.t =
@@ -849,15 +850,16 @@
fun error l = Control.error (region, l, Layout.empty)
fun invalidAttributes () =
error (seq [str "invalid attributes for import: ",
- List.layout Attribute.layout attributes])
+ List.layout ImportExportAttribute.layout attributes])
+ fun invalidType () =
+ Control.error (region,
+ str "invalid type for import",
+ Type.layoutPretty ty)
in
case Type.parse ty of
NONE =>
let
- val () =
- Control.error (region,
- str "invalid type for import",
- Type.layoutPretty ty)
+ val () = invalidType ()
in
Prim.bogus
end
@@ -865,7 +867,7 @@
let
datatype z = datatype CFunction.Target.t
val convention =
- case parseAttributes attributes of
+ case parseIEAttributes attributes of
NONE => (invalidAttributes ()
; Convention.Cdecl)
| SOME c => c
@@ -895,116 +897,273 @@
NONE => Indirect
| SOME name => Direct name),
writesStackTop = true}
-
in
Prim.ffi func
end
end
-fun fetchSymbol {attributes: Attribute.t list,
- name: string,
- primApp: {args: Cexp.t vector,
- prim: Type.t Prim.t,
- result: Type.t} -> Cexp.t,
- ty: Type.t,
- region: Region.t}: Cexp.t =
+fun primApp {args, prim, result: Type.t} =
let
- fun error l = Control.error (region, l, Layout.empty)
- fun invalidAttributes () =
- error (seq [str "invalid attributes for import: ",
- List.layout Attribute.layout attributes])
- val bogus = primApp {args = Vector.new0 (),
- prim = Prim.bogus,
- result = ty}
+ val targs = Prim.extractTargs (prim,
+ {args = Vector.map (args, Cexp.ty),
+ deArray = Type.deArray,
+ deArrow = Type.deArrow,
+ deVector = Type.deVector,
+ deWeak = Type.deWeak,
+ result = result})
in
- case Type.toCType ty of
- NONE =>
- let
- val () =
- Control.error
- (region,
- str "invalid type for import",
- Type.layoutPretty ty)
- in
- bogus
- end
- | SOME {ctype, ...} =>
- (case attributes of
- [] =>
- let
- val isBool =
- case Type.deConOpt ty of
- NONE => false
- | SOME (c,_) => Tycon.equals (c, Tycon.bool)
- val addrTy =
- Type.word (WordSize.pointer ())
- val addrExp =
- primApp
- {args = Vector.new0 (),
- prim = Prim.ffiSymbol {name = name},
- result = addrTy}
- val zeroExp =
- Cexp.make
- (Cexp.Const
- (fn () => Const.word (WordX.zero WordSize.default)),
- Type.defaultWord)
- val fetchTy =
- if isBool then Type.defaultWord else ty
- val fetchExp =
- primApp
- {args = Vector.new2 (addrExp,zeroExp),
- prim = Prim.pointerGet ctype,
- result = fetchTy}
- in
- if isBool
- then Cexp.casee
- {kind = "",
- lay = fn () => Layout.empty,
- noMatch = Cexp.Impossible,
- region = Region.bogus,
- rules = Vector.new2
- ({exp = Cexp.truee,
- lay = NONE,
- pat = Cpat.falsee},
- {exp = Cexp.falsee,
- lay = NONE,
- pat = Cpat.truee}),
- test = primApp
- {args = Vector.new2 (fetchExp, zeroExp),
- prim = Prim.wordEqual WordSize.default,
- result = ty},
- warnMatch = false}
- else fetchExp
- end
- | _ =>
- (invalidAttributes ()
- ; bogus))
+ Cexp.make (Cexp.PrimApp {args = args,
+ prim = prim,
+ targs = targs},
+ result)
end
-fun symbol {name: string,
- ty: Type.t,
- region: Region.t}: Type.t Prim.t =
- case Type.toCType ty of
- SOME {ctype = CType.Pointer, ...} =>
- Prim.ffiSymbol {name = name}
- | _ =>
- let
- val () =
- Control.error (region,
- str "invalid type for import",
- Type.layoutPretty ty)
- in
- Prim.bogus
- end
+local
+ val zeroExp = Cexp.make (Cexp.Const
+ (fn () => Const.word (WordX.zero WordSize.default)),
+ Type.defaultWord)
+ val oneExp = Cexp.make (Cexp.Const
+ (fn () => Const.word (WordX.one WordSize.default)),
+ Type.defaultWord)
+
+ fun address {ctypeCbTy: CType.t,
+ expandedPtrTy: Type.t,
+ name: string}: Cexp.t =
+ primApp {args = Vector.new0 (),
+ prim = Prim.ffiSymbol {name = name,
+ cty = ctypeCbTy},
+ result = expandedPtrTy}
+
+ fun fetch {ctypeCbTy, isBool,
+ expandedCbTy,
+ ptrExp: Cexp.t}: Cexp.t =
+ let
+ val fetchExp =
+ primApp {args = Vector.new2 (ptrExp, zeroExp),
+ prim = Prim.pointerGet ctypeCbTy,
+ result = if isBool
+ then Type.defaultWord
+ else expandedCbTy}
+ in
+ if not isBool then fetchExp else
+ Cexp.casee {kind = "",
+ lay = fn () => Layout.empty,
+ noMatch = Cexp.Impossible,
+ region = Region.bogus,
+ rules = Vector.new2
+ ({exp = Cexp.truee, lay = NONE, pat = Cpat.falsee},
+ {exp = Cexp.falsee, lay = NONE, pat = Cpat.truee}),
+ test = primApp
+ {args = Vector.new2 (fetchExp, zeroExp),
+ prim = Prim.wordEqual WordSize.default,
+ result = expandedCbTy},
+ warnMatch = false}
+ end
+
+ fun store {ctypeCbTy, isBool,
+ ptrExp: Cexp.t, valueExp: Cexp.t}: Cexp.t =
+ let
+ val valueExp =
+ if not isBool then valueExp else
+ Cexp.casee {kind = "",
+ lay = fn () => Layout.empty,
+ noMatch = Cexp.Impossible,
+ region = Region.bogus,
+ rules = Vector.new2
+ ({exp = oneExp, lay = NONE, pat = Cpat.truee},
+ {exp = zeroExp, lay = NONE, pat = Cpat.falsee}),
+ test = valueExp,
+ warnMatch = false}
+ in
+ primApp {args = Vector.new3 (ptrExp, zeroExp, valueExp),
+ prim = Prim.pointerSet ctypeCbTy,
+ result = Type.unit}
+ end
+in
+ fun symbolDirect {attributes: SymbolAttribute.t list,
+ elabedCbTy: Type.t,
+ expandedCbTy: Type.t,
+ elabedPtrTy: Type.t,
+ expandedPtrTy: Type.t,
+ name: string,
+ region: Region.t}: Cexp.t =
+ let
+ val ctypeCbTy =
+ case Type.toCType expandedCbTy of
+ SOME {ctype, ...} => ctype
+ | NONE =>
+ (Control.error
+ (region, str "invalid type for _symbol object",
+ Type.layoutPretty elabedCbTy)
+ ; CType.Pointer)
+ val isBool =
+ case Type.deConOpt expandedCbTy of
+ NONE => false
+ | SOME (c,_) => Tycon.equals (c, Tycon.bool)
+ val ctypePtrTy =
+ case Type.toCType expandedPtrTy of
+ SOME {ctype = CType.Pointer, ...} => CType.Pointer
+ | _ =>
+ (Control.error
+ (region, str "invalid type for _symbol ptr",
+ Type.layoutPretty elabedCbTy)
+ ; CType.Pointer)
+ val addrExp =
+ address {ctypeCbTy = ctypeCbTy,
+ expandedPtrTy = expandedPtrTy,
+ name = name}
+ val () =
+ if List.exists (attributes, fn attr =>
+ attr = SymbolAttribute.Define)
+ then Ffi.addSymbol {name = name, ty = ctypeCbTy}
+ else ()
+ val getArg = Var.newNoname ()
+ val setArg = Var.newNoname ()
+ fun wrap (e, t) = Cexp.make (Cexp.node e, t)
+ in
+ (Cexp.tuple o Vector.new3)
+ (wrap (addrExp, elabedPtrTy),
+ wrap ((Cexp.lambda o Lambda.make)
+ {arg = getArg,
+ argType = Type.unit,
+ body = fetch {ctypeCbTy = ctypeCbTy,
+ isBool = isBool,
+ expandedCbTy = expandedCbTy,
+ ptrExp = addrExp},
+ mayInline = true},
+ Type.arrow (Type.unit, elabedCbTy)),
+ wrap ((Cexp.lambda o Lambda.make)
+ {arg = setArg,
+ argType = elabedCbTy,
+ body = store {ctypeCbTy = ctypeCbTy,
+ isBool = isBool,
+ ptrExp = addrExp,
+ valueExp = Cexp.var (setArg, expandedCbTy)},
+ mayInline = true},
+ Type.arrow (elabedCbTy, Type.unit)))
+ end
-fun export {attributes, name: string, region: Region.t, ty: Type.t}: Aexp.t =
+ fun symbolIndirect {elabedCbTy: Type.t,
+ expandedCbTy: Type.t,
+ elabedPtrTy: Type.t,
+ expandedPtrTy: Type.t,
+ region: Region.t}: Cexp.t =
+ let
+ val ctypeCbTy =
+ case Type.toCType expandedCbTy of
+ SOME {ctype, ...} => ctype
+ | NONE =>
+ (Control.error
+ (region, str "invalid type for _symbol object",
+ Type.layoutPretty elabedCbTy)
+ ; CType.Pointer)
+ val isBool =
+ case Type.deConOpt expandedCbTy of
+ NONE => false
+ | SOME (c,_) => Tycon.equals (c, Tycon.bool)
+ val ctypePtrTy =
+ case Type.toCType expandedPtrTy of
+ SOME {ctype = CType.Pointer, ...} => CType.Pointer
+ | _ =>
+ (Control.error
+ (region, str "invalid type for _symbol ptr",
+ Type.layoutPretty elabedCbTy)
+ ; CType.Pointer)
+ fun wrap (e, t) = Cexp.make (Cexp.node e, t)
+ val getArg = Var.newNoname ()
+ val setArg = Var.newNoname ()
+ val elabedSetArgTy =
+ Type.tuple (Vector.new2 (elabedPtrTy, elabedCbTy))
+ val setArgPtr = Var.newNoname ()
+ val setArgValue = Var.newNoname ()
+ val setPat =
+ Cpat.tuple (Vector.new2 (Cpat.var (setArgPtr, expandedPtrTy),
+ Cpat.var (setArgValue, expandedCbTy)))
+ val setExp = store {ctypeCbTy = ctypeCbTy,
+ isBool = isBool,
+ ptrExp = Cexp.var (setArgPtr, expandedPtrTy),
+ valueExp = Cexp.var (setArgValue, expandedCbTy)}
+ val setBody =
+ Cexp.casee {kind = "",
+ lay = fn () => Layout.empty,
+ noMatch = Cexp.Impossible,
+ region = Region.bogus,
+ rules = Vector.new1 ({exp = setExp, lay = NONE, pat = setPat}),
+ test = Cexp.var (setArg, elabedSetArgTy),
+ warnMatch = false}
+ in
+ (Cexp.tuple o Vector.new2)
+ (wrap ((Cexp.lambda o Lambda.make)
+ {arg = getArg,
+ argType = expandedPtrTy,
+ body = fetch {ctypeCbTy = ctypeCbTy,
+ expandedCbTy = expandedCbTy,
+ isBool = isBool,
+ ptrExp = Cexp.var (getArg, expandedPtrTy)},
+ mayInline = true},
+ Type.arrow (elabedPtrTy, elabedCbTy)),
+ wrap ((Cexp.lambda o Lambda.make)
+ {arg = setArg,
+ argType = elabedCbTy,
+ body = setBody,
+ mayInline = true},
+ Type.arrow (elabedSetArgTy, Type.unit)))
+ end
+
+ fun importSymbol {attributes: ImportExportAttribute.t list,
+ elabedCbTy: Type.t,
+ expandedCbTy: Type.t,
+ name: string,
+ region: Region.t}: Cexp.t =
+ let
+ val () =
+ Control.warning
+ (region,
+ str "_import of non-function is deprecated, use _symbol",
+ empty)
+ fun error l = Control.error (region, l, Layout.empty)
+ fun invalidAttributes () =
+ error (seq [str "invalid attributes for import: ",
+ List.layout ImportExportAttribute.layout attributes])
+ val () =
+ if List.isEmpty attributes
+ then ()
+ else invalidAttributes ()
+ val ctypeCbTy =
+ case Type.toCType elabedCbTy of
+ SOME {ctype, ...} => ctype
+ | NONE =>
+ (Control.error
+ (region, str "invalid type for import",
+ Type.layoutPretty elabedCbTy)
+ ; CType.Pointer)
+ val isBool =
+ case Type.deConOpt expandedCbTy of
+ NONE => false
+ | SOME (c,_) => Tycon.equals (c, Tycon.bool)
+ val addrExp =
+ address {ctypeCbTy = ctypeCbTy,
+ expandedPtrTy = Type.word (WordSize.pointer ()),
+ name = name}
+ in
+ fetch {ctypeCbTy = ctypeCbTy,
+ isBool = isBool,
+ expandedCbTy = expandedCbTy,
+ ptrExp = addrExp}
+ end
+end
+
+fun export {attributes: ImportExportAttribute.t list,
+ name: string,
+ region: Region.t,
+ ty: Type.t}: Aexp.t =
let
fun error l = Control.error (region, l, Layout.empty)
fun invalidAttributes () =
error (seq [str "invalid attributes for export: ",
- List.layout Attribute.layout attributes])
+ List.layout ImportExportAttribute.layout attributes])
val convention =
- case parseAttributes attributes of
+ case parseIEAttributes attributes of
NONE => (invalidAttributes ()
; Convention.Cdecl)
| SOME c => c
@@ -2263,58 +2422,46 @@
in
Cexp.orElse (ce, ce')
end
- | Aexp.Prim {kind, ty} =>
+ | Aexp.Prim kind =>
let
- val ty = elabType ty
- fun expandTy ty =
- Type.hom
- (ty, {con = Type.con,
- expandOpaque = true,
- record = Type.record,
- replaceSynonyms = false,
- var = Type.var})
- val expandedTy = expandTy ty
+ fun elabAndExpandTy ty =
+ let
+ val elabedTy = elabType ty
+ val expandedTy =
+ Type.hom
+ (elabedTy, {con = Type.con,
+ expandOpaque = true,
+ record = Type.record,
+ replaceSynonyms = false,
+ var = Type.var})
+ in
+ (elabedTy, expandedTy)
+ end
(* We use expandedTy to get the underlying primitive right
* but we use wrap in the end to make the result of the
* final expression be ty, because that is what the rest
* of the code expects to see.
*)
fun wrap (e, t) = Cexp.make (Cexp.node e, t)
- fun primApp {args, prim, result: Type.t} =
- let
- val targs =
- Prim.extractTargs
- (prim,
- {args = Vector.map (args, Cexp.ty),
- deArray = Type.deArray,
- deArrow = Type.deArrow,
- deVector = Type.deVector,
- deWeak = Type.deWeak,
- result = result})
- in
- Cexp.make (Cexp.PrimApp {args = args,
- prim = prim,
- targs = targs},
- result)
- end
- fun etaExtra (extra, ty, expandedTy,
- p: Type.t Prim.t): Cexp.t =
+ fun etaExtra {elabedTy, expandedTy,
+ extra,
+ prim: Type.t Prim.t} : Cexp.t =
case Type.deArrowOpt expandedTy of
NONE =>
wrap (primApp {args = extra,
- prim = p,
- result = ty},
- ty)
+ prim = prim,
+ result = elabedTy},
+ elabedTy)
| SOME (argType, bodyType) =>
let
val arg = Var.newNoname ()
fun app args =
primApp {args = Vector.concat [extra, args],
- prim = p,
+ prim = prim,
result = bodyType}
val body =
case Type.deTupleOpt argType of
- NONE =>
+ NONE =>
app (Vector.new1
(Cexp.var (arg, argType)))
| SOME ts =>
@@ -2329,16 +2476,15 @@
lay = fn _ => Layout.empty,
noMatch = Cexp.Impossible,
region = Region.bogus,
- rules =
- Vector.new1
- {exp = app (Vector.map
- (vars, Cexp.var)),
- lay = NONE,
- pat =
- (Cpat.tuple
- (Vector.map (vars, Cpat.var)))},
- test = Cexp.var (arg, argType),
- warnMatch = warnMatch ()}
+ rules = Vector.new1
+ {exp = app (Vector.map
+ (vars, Cexp.var)),
+ lay = NONE,
+ pat = Cpat.tuple
+ (Vector.map
+ (vars, Cpat.var))},
+ test = Cexp.var (arg, argType),
+ warnMatch = false}
end
in
Cexp.make (Cexp.Lambda
@@ -2346,11 +2492,17 @@
argType = argType,
body = body,
mayInline = true}),
- ty)
+ elabedTy)
end
- fun eta (p: Type.t Prim.t): Cexp.t =
- etaExtra (Vector.new0 (), ty, expandedTy, p)
- fun lookConst {default: string option, name: string} =
+ fun eta {elabedTy, expandedTy,
+ prim: Type.t Prim.t} : Cexp.t =
+ etaExtra {elabedTy = elabedTy,
+ expandedTy = expandedTy,
+ extra = Vector.new0 (),
+ prim = prim}
+ fun lookConst {default: string option,
+ elabedTy, expandedTy,
+ name: string} =
let
fun bug () =
let
@@ -2391,22 +2543,34 @@
val finish =
fn () => ! Const.lookup ({default = default,
name = name}, ct)
- in
- Cexp.make (Cexp.Const finish, ty)
- end
+ in
+ Cexp.make (Cexp.Const finish, elabedTy)
+ end
end
val check = fn (c, n) => check (c, n, region)
datatype z = datatype Ast.PrimKind.t
in
case kind of
- BuildConst {name} =>
- (check (ElabControl.allowConstant, "_build_const")
- ; lookConst {default = NONE, name = name})
- | CommandLineConst {name, value} =>
+ BuildConst {name, ty} =>
+ let
+ val () =
+ check (ElabControl.allowConstant,
+ "_build_const")
+ val (elabedTy, expandedTy) =
+ elabAndExpandTy ty
+ in
+ lookConst {default = NONE,
+ elabedTy = elabedTy,
+ expandedTy = expandedTy,
+ name = name}
+ end
+ | CommandLineConst {name, ty, value} =>
let
val () =
check (ElabControl.allowConstant,
"_command_line_const")
+ val (elabedTy, expandedTy) =
+ elabAndExpandTy ty
val value =
elabConst
(value,
@@ -2417,106 +2581,177 @@
| c => Const.toString c,
{false = "false", true = "true"})
in
- lookConst {default = SOME value, name = name}
+ lookConst {default = SOME value,
+ elabedTy = elabedTy,
+ expandedTy = expandedTy,
+ name = name}
end
- | Const {name} =>
- (check (ElabControl.allowConstant, "_const")
- ; lookConst {default = NONE, name = name})
- | Export {attributes, name} =>
- (check (ElabControl.allowExport, "_export")
- ; let
- val e =
- Env.scope
- (E, fn () =>
- (Env.openStructure
- (E, valOf (!Env.Structure.ffi))
- ; elab (export {attributes = attributes,
- name = name,
- region = region,
- ty = expandedTy})))
- val _ =
- unify
- (Cexp.ty e,
- Type.arrow (expandedTy, Type.unit),
- fn (l1, l2) =>
- let
- open Layout
- in
- (region,
- str "_export unify bug",
- align [seq [str "inferred: ", l1],
- seq [str "expanded: ", l2]])
- end)
- in
- wrap (e, Type.arrow (ty, Type.unit))
- end)
- | IImport {attributes} =>
+ | Const {name, ty} =>
+ let
+ val () =
+ check (ElabControl.allowConstant,
+ "_const")
+ val (elabedTy, expandedTy) =
+ elabAndExpandTy ty
+ in
+ lookConst {default = NONE,
+ elabedTy = elabedTy,
+ expandedTy = expandedTy,
+ name = name}
+ end
+ | Export {attributes, cfTy, name} =>
let
val () =
- check (ElabControl.allowImport, "_import")
+ check (ElabControl.allowExport,
+ "_export")
+ val (elabedTy, expandedTy) =
+ elabAndExpandTy cfTy
+ val exp =
+ Env.scope
+ (E, fn () =>
+ (Env.openStructure
+ (E, valOf (!Env.Structure.ffi))
+ ; elab (export {attributes = attributes,
+ name = name,
+ region = region,
+ ty = expandedTy})))
+ val _ =
+ unify
+ (Cexp.ty exp,
+ Type.arrow (expandedTy, Type.unit),
+ fn (l1, l2) =>
+ let
+ open Layout
+ in
+ (region,
+ str "_export unify bug",
+ align [seq [str "inferred: ", l1],
+ seq [str "expanded: ", l2]])
+ end)
in
- case (Type.deArrowOpt ty,
- Type.deArrowOpt expandedTy) of
- (SOME ty, SOME expandedTy) =>
+ wrap (exp, Type.arrow (elabedTy, Type.unit))
+ end
+ | IImport {attributes, cfTy} =>
+ let
+ val () =
+ check (ElabControl.allowImport,
+ "_import")
+ val (elabedCfTy, expandedCfTy) =
+ elabAndExpandTy cfTy
+ in
+ case (Type.deArrowOpt elabedCfTy,
+ Type.deArrowOpt expandedCfTy) of
+ (SOME elabedTy, SOME expandedTy) =>
let
- val ((fptrTy,ty),
- (fptrExpandedTy,expandedTy)) =
- (ty, expandedTy)
+ val ((elabedFPtrTy,elabedCfTy),
+ (expandedFPtrTy,expandedCfTy)) =
+ (elabedTy, expandedTy)
val () =
- case Type.toCType fptrExpandedTy of
+ case Type.toCType expandedFPtrTy of
SOME {ctype = CType.Pointer, ...} => ()
| _ =>
Control.error
(region,
str "invalid type for import",
- Type.layoutPretty fptrExpandedTy)
+ Type.layoutPretty expandedFPtrTy)
val fptr = Var.newNoname ()
- val fptrArg = Cexp.var (fptr, fptrTy)
+ val fptrArg = Cexp.var (fptr, expandedFPtrTy)
in
Cexp.make
(Cexp.Lambda
(Lambda.make
{arg = fptr,
- argType = fptrTy,
- body = etaExtra (Vector.new1 fptrArg,
- ty, expandedTy,
- import
- {attributes = attributes,
- name = NONE,
- region = region,
- ty = expandedTy}),
+ argType = elabedFPtrTy,
+ body = etaExtra
+ {elabedTy = elabedCfTy,
+ expandedTy = expandedCfTy,
+ extra = Vector.new1 fptrArg,
+ prim = import
+ {attributes = attributes,
+ name = NONE,
+ region = region,
+ ty = expandedCfTy}},
mayInline = true}),
- Type.arrow (fptrTy, ty))
+ Type.arrow (elabedFPtrTy, elabedCfTy))
end
| _ =>
(Control.error
(region,
str "invalid type for import",
- Type.layoutPretty ty);
- eta Prim.bogus)
+ Type.layoutPretty elabedCfTy);
+ eta {elabedTy = elabedCfTy,
+ expandedTy = expandedCfTy,
+ prim = Prim.bogus})
+ end
+ | Import {attributes, name, cfTy} =>
+ let
+ val () =
+ check (ElabControl.allowImport,
+ "_import")
+ val (elabedCfTy, expandedCfTy) =
+ elabAndExpandTy cfTy
+ in
+ case Type.deArrowOpt expandedCfTy of
+ NONE =>
+ importSymbol {attributes = attributes,
+ elabedCbTy = elabedCfTy,
+ expandedCbTy = expandedCfTy,
+ name = name,
+ region = region}
+ | SOME _ =>
+ eta ({elabedTy = elabedCfTy,
+ expandedTy = expandedCfTy,
+ prim = import {attributes = attributes,
+ name = SOME name,
+ region = region,
+ ty = expandedCfTy}})
+ end
+ | ISymbol {cbTy, ptrTy} =>
+ let
+ val () =
+ check (ElabControl.allowSymbol,
+ "_symbol")
+ val (elabedCbTy, expandedCbTy) =
+ elabAndExpandTy cbTy
+ val (elabedPtrTy, expandedPtrTy) =
+ elabAndExpandTy ptrTy
+ in
+ symbolIndirect {elabedCbTy = elabedCbTy,
+ expandedCbTy = expandedCbTy,
+ elabedPtrTy = elabedPtrTy,
+ expandedPtrTy = expandedPtrTy,
+ region = region}
+ end
+ | Prim {name, ty} =>
+ let
+ val () =
+ check (ElabControl.allowPrim,
+ "_prim")
+ val (elabedTy, expandedTy) =
+ elabAndExpandTy ty
+ in
+ eta {elabedTy = elabedTy,
+ expandedTy = expandedTy,
+ prim = Prim.fromString name}
+ end
+ | Symbol {attributes, cbTy, ptrTy, name} =>
+ let
+ val () =
+ check (ElabControl.allowSymbol,
+ "_symbol")
+ val (elabedCbTy, expandedCbTy) =
+ elabAndExpandTy cbTy
+ val (elabedPtrTy, expandedPtrTy) =
+ elabAndExpandTy ptrTy
+ in
+ symbolDirect {attributes = attributes,
+ elabedCbTy = elabedCbTy,
+ expandedCbTy = expandedCbTy,
+ elabedPtrTy = elabedPtrTy,
+ expandedPtrTy = expandedPtrTy,
+ name = name,
+ region = region}
end
- | Import {attributes, name} =>
- (check (ElabControl.allowImport, "_import")
- ; (case Type.deArrowOpt expandedTy of
- NONE =>
- wrap (fetchSymbol {attributes = attributes,
- name = name,
- primApp = primApp,
- region = region,
- ty = expandedTy}, ty)
- | SOME _ =>
- eta (import {attributes = attributes,
- name = SOME name,
- region = region,
- ty = expandedTy})))
- | Symbol {name} =>
- (check (ElabControl.allowImport, "_import")
- ; eta (symbol {name = name,
- region = region,
- ty = expandedTy}))
- | Prim {name} =>
- (check (ElabControl.allowPrim, "_prim")
- ; eta (Prim.fromString name))
end
| Aexp.Raise exn =>
let
1.14 +38 -4 mlton/mlton/elaborate/scope.fun
Index: scope.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/scope.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- scope.fun 19 Jun 2005 21:33:58 -0000 1.13
+++ scope.fun 23 Jul 2005 11:55:40 -0000 1.14
@@ -215,6 +215,43 @@
in
loop p
end
+ fun loopPrimKind (kind: PrimKind.t, d: 'down): PrimKind.t * 'up =
+ let
+ datatype z = datatype PrimKind.t
+ fun do1 ((a, u), f) = (f a, u)
+ fun do2 ((a1, u1), (a2, u2), f) =
+ (f (a1, a2), combineUp (u1, u2))
+ in
+ case kind of
+ BuildConst {name, ty} =>
+ do1 (loopTy (ty, d), fn ty =>
+ BuildConst {name = name, ty = ty})
+ | CommandLineConst {name, ty, value} =>
+ do1 (loopTy (ty, d), fn ty =>
+ CommandLineConst {name = name, ty = ty, value = value})
+ | Const {name, ty} =>
+ do1 (loopTy (ty, d), fn ty =>
+ Const {name = name, ty = ty})
+ | Export {attributes, name, cfTy} =>
+ do1 (loopTy (cfTy, d), fn cfTy =>
+ Export {attributes = attributes, name = name, cfTy = cfTy})
+ | IImport {attributes, cfTy} =>
+ do1 (loopTy (cfTy, d), fn cfTy =>
+ IImport {attributes = attributes, cfTy = cfTy})
+ | Import {attributes, name, cfTy} =>
+ do1 (loopTy (cfTy, d), fn cfTy =>
+ Import {attributes = attributes, name = name, cfTy = cfTy})
+ | ISymbol {cbTy, ptrTy} =>
+ do2 (loopTy (cbTy, d), loopTy (ptrTy, d), fn (cbTy, ptrTy) =>
+ ISymbol {cbTy = cbTy, ptrTy = ptrTy})
+ | Prim {name, ty} =>
+ do1 (loopTy (ty, d), fn ty =>
+ Prim {name = name, ty = ty})
+ | Symbol {attributes, name, cbTy, ptrTy} =>
+ do2 (loopTy (cbTy, d), loopTy (ptrTy, d), fn (cbTy, ptrTy) =>
+ Symbol {attributes = attributes, name = name,
+ cbTy = cbTy, ptrTy = ptrTy})
+ end
fun loopDec (d: Dec.t, down: 'down): Dec.t * 'up =
let
fun doit n = Dec.makeRegion (n, Dec.region d)
@@ -389,10 +426,7 @@
| Let (dec, e) => do2 (loopDec (dec, d), loop e, Let)
| List ts => doVec (ts, List)
| Orelse (e1, e2) => do2 (loop e1, loop e2, Orelse)
- | Prim {kind, ty} =>
- do1 (loopTy (ty, d), fn ty =>
- Prim {kind = kind,
- ty = ty})
+ | Prim kind => do1 (loopPrimKind (kind, d), Prim)
| Raise exn => do1 (loop exn, Raise)
| Record r =>
let
1.45 +49 -30 mlton/mlton/front-end/ml.grm
Index: ml.grm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.grm,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- ml.grm 19 Jul 2005 16:52:28 -0000 1.44
+++ ml.grm 23 Jul 2005 11:55:41 -0000 1.45
@@ -232,7 +232,9 @@
| RBRACKET | REC | RPAREN | SEMICOLON | SHARING | SIG | SIGNATURE | STRUCT
| STRUCTURE | THEN | TYPE | VAL | WHERE | WHILE | WILD | WITH | WITHTYPE
(* Extensions *)
- | BUILD_CONST | COMMAND_LINE_CONST | CONST | EXPORT | IMPORT | PRIM
+ | BUILD_CONST | COMMAND_LINE_CONST | CONST
+ | EXPORT | IMPORT | SYMBOL
+ | PRIM
%nonterm
aexp of Exp.node
@@ -244,7 +246,7 @@
| app_exp of Exp.t list
| app_exp1 of Exp.t list
| arg_fct of Strexp.t
- | attributes of PrimKind.Attribute.t list
+ | ieattributes of PrimKind.ImportExportAttribute.t list
| clause of clause
| clauses of clause list
| clausesTop of clauses
@@ -365,6 +367,7 @@
| strexpnode of Strexp.node
| strid of Strid.t
| string of string
+ | symattributes of PrimKind.SymbolAttribute.t list
| tlabel of (Field.t * Type.t)
| tlabels of (Field.t * Type.t) list
| topdec of Topdec.t
@@ -1007,45 +1010,61 @@
exp_psleft,
exp_psright)))
| BUILD_CONST string COLON ty SEMICOLON
- (Exp.Prim {kind = PrimKind.BuildConst {name = string},
- ty = ty})
+ (Exp.Prim (PrimKind.BuildConst {name = string, ty = ty}))
| COMMAND_LINE_CONST string COLON ty EQUALOP constOrBool SEMICOLON
- (Exp.Prim {kind = PrimKind.CommandLineConst {name = string,
- value = constOrBool},
- ty = ty})
+ (Exp.Prim (PrimKind.CommandLineConst {name = string,
+ ty = ty,
+ value = constOrBool}))
| CONST string COLON ty SEMICOLON
- (Exp.Prim {kind = PrimKind.Const {name = string},
- ty = ty})
- | EXPORT string attributes COLON ty SEMICOLON
- (Exp.Prim {kind = PrimKind.Export {attributes = attributes,
- name = string},
- ty = ty})
- | IMPORT string attributes COLON ty SEMICOLON
- (Exp.Prim {kind = PrimKind.Import {attributes = attributes,
- name = string},
- ty = ty})
- | IMPORT ASTERISK attributes COLON ty SEMICOLON
- (Exp.Prim {kind = PrimKind.IImport {attributes = attributes},
- ty = ty})
- | IMPORT HASH string COLON ty SEMICOLON
- (Exp.Prim {kind = PrimKind.Symbol {name = string},
- ty = ty})
+ (Exp.Prim (PrimKind.Const {name = string, ty = ty}))
+ | EXPORT string ieattributes COLON ty SEMICOLON
+ (Exp.Prim (PrimKind.Export {attributes = ieattributes,
+ name = string,
+ cfTy = ty}))
+ | IMPORT string ieattributes COLON ty SEMICOLON
+ (Exp.Prim (PrimKind.Import {attributes = ieattributes,
+ cfTy = ty,
+ name = string}))
+ | IMPORT ASTERISK ieattributes COLON ty SEMICOLON
+ (Exp.Prim (PrimKind.IImport {attributes = ieattributes,
+ cfTy = ty}))
| PRIM string COLON ty SEMICOLON
- (Exp.Prim {kind = PrimKind.Prim {name = string},
- ty = ty})
+ (Exp.Prim (PrimKind.Prim {name = string,
+ ty = ty}))
+ | SYMBOL string symattributes COLON ty COMMA ty SEMICOLON
+ (Exp.Prim (PrimKind.Symbol {attributes = symattributes,
+ cbTy = ty2,
+ ptrTy = ty1,
+ name = string}))
+ | SYMBOL ASTERISK COLON ty COMMA ty SEMICOLON
+ (Exp.Prim (PrimKind.ISymbol {cbTy = ty2,
+ ptrTy = ty1}))
-attributes
+ieattributes
:
([])
- | id attributes
+ | id ieattributes
(let
val id = Symbol.toString (#1 id)
in
case id of
- "cdecl" => PrimKind.Attribute.Cdecl :: attributes
- | "stdcall" => PrimKind.Attribute.Stdcall :: attributes
+ "cdecl" => PrimKind.ImportExportAttribute.Cdecl :: ieattributes
+ | "stdcall" => PrimKind.ImportExportAttribute.Stdcall :: ieattributes
| _ => (error (reg (idleft, idright), concat ["invalid attribute", id])
- ; attributes)
+ ; ieattributes)
+ end)
+
+symattributes
+ :
+ ([])
+ | id symattributes
+ (let
+ val id = Symbol.toString (#1 id)
+ in
+ case id of
+ "define" => PrimKind.SymbolAttribute.Define :: symattributes
+ | _ => (error (reg (idleft, idright), concat ["invalid attribute", id])
+ ; symattributes)
end)
exp_2c : exp COMMA exp_2c (exp :: exp_2c)
1.22 +2 -0 mlton/mlton/front-end/ml.lex
Index: ml.lex
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.lex,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- ml.lex 19 Jul 2005 16:52:28 -0000 1.21
+++ ml.lex 23 Jul 2005 11:55:41 -0000 1.22
@@ -151,6 +151,8 @@
(tok (Tokens.IMPORT, source, yypos, yypos + size yytext));
<INITIAL>"_overload" =>
(tok (Tokens.OVERLOAD, source, yypos, yypos + size yytext));
+<INITIAL>"_symbol" =>
+ (tok (Tokens.SYMBOL, source, yypos, yypos + size yytext));
<INITIAL>"_prim" =>
(tok (Tokens.PRIM, source, yypos, yypos + size yytext));
<INITIAL>"_" => (tok (Tokens.WILD, source, yypos, yypos + 1));