[MLton-devel] cvs commit: attributes in _import and _export expressions
Stephen Weeks
sweeks@users.sourceforge.net
Fri, 18 Jul 2003 18:23:28 -0700
sweeks 03/07/18 18:23:28
Modified: basis-library/misc primitive.sml
basis-library/mlton syslog.sml
basis-library/posix primitive.sml
bin check-basis
doc changelog
doc/examples/ffi import.sml
doc/user-guide ffi.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 ffi.fun ffi.sig prim.fun
prim.sig sources.cm
mlton/backend allocate-registers.fun backend.fun backend.sig
limit-check.fun machine-atoms.fun machine-atoms.sig
machine.fun machine.sig representation.fun rssa.fun
rssa.sig runtime.fun runtime.sig sources.cm
ssa-to-rssa.fun ssa-to-rssa.sig
mlton/codegen/c-codegen c-codegen.fun c-codegen.sig
mlton/codegen/x86-codegen x86-codegen.fun
x86-entry-transfer.fun x86-generate-transfers.fun
x86-jump-info.fun x86-loop-info.fun
x86-mlton-basic.fun x86-mlton-basic.sig
x86-mlton.fun x86-pseudo.sig x86-translate.fun
x86.fun x86.sig
mlton/elaborate elaborate-core.fun
mlton/front-end ml.grm ml.lex
runtime gc.h mlton-basis.h
Added: mlton/atoms c-function.fun c-function.sig c-type.fun
c-type.sig
Removed: mlton/backend c-function.fun c-function.sig mtype.fun
mtype.sig
Log:
Renamed _ffi as _import. Left around _ffi for now. We'll remove it
in a release or two.
Added attributes to _import and _export declarations. These now look
like:
_import "name" <attribute>*: <ty>;
_export "name" <attribute>*: <ty>;
Here are the allowed attributes.
<attribute> ::= cdecl | stdcall
cdecl, which we have always used, is the default, and means to use the
default C calling convention. stdcall is only meaningful on
Cygwin/Windows and means to use the stdcall convention associated with
the Windows API and other libraries, like OpenGL.
Added checking for appropriate C types to _import. We used to only
check _export. This uncovered a couple of places in the basis library
where we pass types that are not allowed according to the MLton User
Guide: namely thread, prethread, and char vector array. For now, I've
added a hack to the elaborator to allow these.
CFunctions now keep track of the calling convention (Cdecl or Stdcall)
and the argument types.
Moved the CFunction stuff from the backend to the frontend. This is
actually a good thing, because it means that we will easily be able to
add source-level attributes for other things like "mayGC",
"modifiesFrontier", etc. For now, MLton is conservative and assumes
that all C functions can modify the frontier and the stackTop and
mayGC (see elaborate-core.fun). It's probably a bit much to add
attributes for all those things, and may even be a bit much that we
keep track of it within MLton. An alternative approach would be to do
what Haskell does and to have "safe" and "unsafe" attributes, where
unsafe means that the C function doesn't do anything tricky like
modify the frontier, the stack, switch threads, or GC. Hence a simple
and fast (and unsafe in general) call to C can be made. safe is the
default. Anyways, something to keep in mind for the future.
With the move, Prim.Name.FFI now takes a CFunction instead of a
string. I alse created a new primitive name, FFI_Symbol, for imports
that aren't functions.
The x86 codegen mod was pretty easy -- I just turned off the stack pop
when the convention is stdcall. Hopefully that doesn't mess up
anything.
Revision Changes Path
1.64 +201 -201 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -r1.63 -r1.64
--- primitive.sml 8 Jul 2003 01:29:31 -0000 1.63
+++ primitive.sml 19 Jul 2003 01:23:25 -0000 1.64
@@ -92,17 +92,17 @@
struct
structure Debug =
struct
- val enter = _ffi "Debug_enter": string -> unit;
- val leave = _ffi "Debug_leave": string -> unit;
+ val enter = _import "Debug_enter": string -> unit;
+ val leave = _import "Debug_leave": string -> unit;
end
end
structure Primitive =
struct
val detectOverflow = _build_const "MLton_detectOverflow": bool;
- val enterLeave = _ffi "MLton_enterLeave": unit -> unit;
+ val enterLeave = _import "MLton_enterLeave": unit -> unit;
val eq = fn z => _prim "MLton_eq": 'a * 'a -> bool; z
- val errno = _ffi "MLton_errno": unit -> int;
+ val errno = _import "MLton_errno": unit -> int;
val halt = _prim "MLton_halt": int -> unit;
val handlesSignals = _prim "MLton_handlesSignals": bool;
val installSignalHandler =
@@ -113,9 +113,9 @@
structure Stdio =
struct
- val print = _ffi "Stdio_print": string -> unit;
+ val print = _import "Stdio_print": string -> unit;
val sprintf =
- _ffi "Stdio_sprintf": char array * nullString * real -> int;
+ _import "Stdio_sprintf": char array * nullString * real -> int;
end
structure Array =
@@ -143,9 +143,9 @@
struct
type t = pointer
- val sub = _ffi "C_CS_sub": t * int -> char;
+ val sub = _import "C_CS_sub": t * int -> char;
val update =
- _ffi "C_CS_update": t * int * char -> unit; (* primitive *)
+ _import "C_CS_update": t * int * char -> unit; (* primitive *)
val charArrayToWord8Array =
_prim "C_CS_charArrayToWord8Array":
char array -> word8 array;
@@ -156,7 +156,7 @@
struct
type t = pointer
- val sub = _ffi "C_CSS_sub": t * int -> CS.t;
+ val sub = _import "C_CSS_sub": t * int -> CS.t;
end
end
@@ -176,9 +176,9 @@
structure CommandLine =
struct
- val argc = fn () => _ffi "CommandLine_argc": int;
- val argv = fn () => _ffi "CommandLine_argv": cstringArray;
- val commandName = fn () => _ffi "CommandLine_commandName": cstring;
+ val argc = fn () => _import "CommandLine_argc": int;
+ val argv = fn () => _import "CommandLine_argv": cstringArray;
+ val commandName = fn () => _import "CommandLine_commandName": cstring;
end
structure Cpointer =
@@ -193,34 +193,34 @@
structure Tm =
struct
- val sec = _ffi "Date_Tm_sec": unit -> int;
- val min = _ffi "Date_Tm_min": unit -> int;
- val hour = _ffi "Date_Tm_hour": unit -> int;
- val mday = _ffi "Date_Tm_mday": unit -> int;
- val mon = _ffi "Date_Tm_mon": unit -> int;
- val year = _ffi "Date_Tm_year": unit -> int;
- val wday = _ffi "Date_Tm_wday": unit -> int;
- val yday = _ffi "Date_Tm_yday": unit -> int;
- val isdst = _ffi "Date_Tm_isdst": unit -> int;
-
- val setSec = _ffi "Date_Tm_setSec": int -> unit;
- val setMin = _ffi "Date_Tm_setMin": int -> unit;
- val setHour = _ffi "Date_Tm_setHour": int -> unit;
- val setMday = _ffi "Date_Tm_setMday": int -> unit;
- val setMon = _ffi "Date_Tm_setMon": int -> unit;
- val setYear = _ffi "Date_Tm_setYear": int -> unit;
- val setWday = _ffi "Date_Tm_setWday": int -> unit;
- val setYday = _ffi "Date_Tm_setYday": int -> unit;
- val setIsdst = _ffi "Date_Tm_setIsdst": int -> unit;
+ val sec = _import "Date_Tm_sec": unit -> int;
+ val min = _import "Date_Tm_min": unit -> int;
+ val hour = _import "Date_Tm_hour": unit -> int;
+ val mday = _import "Date_Tm_mday": unit -> int;
+ val mon = _import "Date_Tm_mon": unit -> int;
+ val year = _import "Date_Tm_year": unit -> int;
+ val wday = _import "Date_Tm_wday": unit -> int;
+ val yday = _import "Date_Tm_yday": unit -> int;
+ val isdst = _import "Date_Tm_isdst": unit -> int;
+
+ val setSec = _import "Date_Tm_setSec": int -> unit;
+ val setMin = _import "Date_Tm_setMin": int -> unit;
+ val setHour = _import "Date_Tm_setHour": int -> unit;
+ val setMday = _import "Date_Tm_setMday": int -> unit;
+ val setMon = _import "Date_Tm_setMon": int -> unit;
+ val setYear = _import "Date_Tm_setYear": int -> unit;
+ val setWday = _import "Date_Tm_setWday": int -> unit;
+ val setYday = _import "Date_Tm_setYday": int -> unit;
+ val setIsdst = _import "Date_Tm_setIsdst": int -> unit;
end
- val ascTime = _ffi "Date_ascTime": unit -> cstring;
- val gmTime = _ffi "Date_gmTime": time ref -> unit;
- val localOffset = _ffi "Date_localOffset": unit -> int;
- val localTime = _ffi "Date_localTime": time ref -> unit;
- val mkTime = _ffi "Date_mkTime": unit -> time;
+ val ascTime = _import "Date_ascTime": unit -> cstring;
+ val gmTime = _import "Date_gmTime": time ref -> unit;
+ val localOffset = _import "Date_localOffset": unit -> int;
+ val localTime = _import "Date_localTime": time ref -> unit;
+ val mkTime = _import "Date_mkTime": unit -> time;
val strfTime =
- _ffi "Date_strfTime": char array * size * nullString -> size;
+ _import "Date_strfTime": char array * size * nullString -> size;
end
structure Debug = Primitive.Debug
@@ -250,47 +250,47 @@
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 getBool = _import "MLton_IMPORT_getBool": int -> bool;
+ val getChar = _import "MLton_IMPORT_getChar": int -> char;
+ val getInt8 = _import "MLton_IMPORT_getInt8": int -> Int8.int;
+ val getInt16 = _import "MLton_IMPORT_getInt16": int -> Int16.int;
+ val getInt32 = _import "MLton_IMPORT_getInt32": int -> Int32.int;
+ val getInt64 = _import "MLton_IMPORT_getInt64": int -> Int64.int;
+ val getOp = _import "MLton_IMPORT_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 getReal32 = _import "MLton_IMPORT_getReal32": int -> Real32.real;
+ val getReal64 = _import "MLton_IMPORT_getReal64": int -> Real64.real;
+ val getWord8 = _import "MLton_IMPORT_getWord8": int -> Word8.word;
+ val getWord16 = _import "MLton_IMPORT_getWord16": int -> Word16.word;
+ val getWord32 = _import "MLton_IMPORT_getWord32": int -> Word32.word;
+ val numExports = _build_const "MLton_IMPORT_numExports": int;
+ val setBool = _import "MLton_IMPORT_setBool": bool -> unit;
+ val setChar = _import "MLton_IMPORT_setChar": char -> unit;
+ val setInt8 = _import "MLton_IMPORT_setInt8": Int8.int -> unit;
+ val setInt16 = _import "MLton_IMPORT_setInt16": Int16.int -> unit;
+ val setInt32 = _import "MLton_IMPORT_setInt32": Int32.int -> unit;
+ val setInt64 = _import "MLton_IMPORT_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;
+ val setReal32 = _import "MLton_IMPORT_setReal32": Real32.real -> unit;
+ val setReal64 = _import "MLton_IMPORT_setReal64": Real64.real -> unit;
+ val setWord8 = _import "MLton_IMPORT_setWord8": Word8.word -> unit;
+ val setWord16 = _import "MLton_IMPORT_setWord16": Word16.word -> unit;
+ val setWord32 = _import "MLton_IMPORT_setWord32": Word32.word -> unit;
end
structure GC =
struct
val collect = _prim "GC_collect": unit -> unit;
val pack = _prim "GC_pack": unit -> unit;
- val setMessages = _ffi "GC_setMessages": bool -> unit;
- val setSummary = _ffi "GC_setSummary": bool -> unit;
+ val setMessages = _import "GC_setMessages": bool -> unit;
+ val setSummary = _import "GC_setSummary": bool -> unit;
val unpack = _prim "GC_unpack": unit -> unit;
end
structure IEEEReal =
struct
- val getRoundingMode = _ffi "IEEEReal_getRoundingMode": unit -> int;
- val setRoundingMode = _ffi "IEEEReal_setRoundingMode": int -> unit;
+ val getRoundingMode = _import "IEEEReal_getRoundingMode": unit -> int;
+ val setRoundingMode = _import "IEEEReal_setRoundingMode": int -> unit;
end
structure Int8 =
@@ -416,22 +416,22 @@
val maxInt' : int = 0x7FFFFFFFFFFFFFFF
val minInt' : int = ~0x8000000000000000
- val op +? = _ffi "Int64_add": int * int -> int;
- val op *? = _ffi "Int64_mul": int * int -> int;
- val op -? = _ffi "Int64_sub": int * int -> int;
+ val op +? = _import "Int64_add": int * int -> int;
+ val op *? = _import "Int64_mul": int * int -> int;
+ val op -? = _import "Int64_sub": int * int -> int;
val ~? = fn i => 0 -? i
- val op < = _ffi "Int64_lt": int * int -> bool;
- val op <= = _ffi "Int64_le": int * int -> bool;
- val op > = _ffi "Int64_gt": int * int -> bool;
- val op >= = _ffi "Int64_ge": int * int -> bool;
- val quot = _ffi "Int64_quot": int * int -> int;
- val rem = _ffi "Int64_rem": int * int -> int;
- val geu = _ffi "Int64_geu": int * int -> bool;
- val gtu = _ffi "Int64_gtu": int * int -> bool;
- val fromInt = _ffi "Int32_toInt64": Int.int -> int;
- val fromWord = _ffi "Word32_toInt64": word -> int;
- val toInt = _ffi "Int64_toInt32": int -> Int.int;
- val toWord = _ffi "Int64_toWord32": int -> word;
+ val op < = _import "Int64_lt": int * int -> bool;
+ val op <= = _import "Int64_le": int * int -> bool;
+ val op > = _import "Int64_gt": int * int -> bool;
+ val op >= = _import "Int64_ge": int * int -> bool;
+ val quot = _import "Int64_quot": int * int -> int;
+ val rem = _import "Int64_rem": int * int -> int;
+ val geu = _import "Int64_geu": int * int -> bool;
+ val gtu = _import "Int64_gtu": int * int -> bool;
+ val fromInt = _import "Int32_toInt64": Int.int -> int;
+ val fromWord = _import "Word32_toInt64": word -> int;
+ val toInt = _import "Int64_toInt32": int -> Int.int;
+ val toWord = _import "Int64_toWord32": int -> word;
val ~ =
if detectOverflow
@@ -495,7 +495,7 @@
val quot = _prim "IntInf_quot": int * int * word -> int;
val rem = _prim "IntInf_rem": int * int * word -> int;
val smallMul =
- _ffi "IntInf_smallMul": word * word * word ref -> word;
+ _import "IntInf_smallMul": word * word * word ref -> word;
val - = _prim "IntInf_sub": int * int * word -> int;
val toString
= _prim "IntInf_toString": int * Int.int * word -> string;
@@ -510,7 +510,7 @@
val prof = _const "Itimer_prof": which;
val real = _const "Itimer_real": which;
- val set = _ffi "Itimer_set": which * int * int * int * int -> unit;
+ val set = _import "Itimer_set": which * int * int * int * int -> unit;
val virtual = _const "Itimer_virtual": which;
end
@@ -555,16 +555,16 @@
type t = word
val dummy:t = 0w0
- val free = _ffi "MLton_Profile_Data_free": t -> unit;
- val malloc = _ffi "MLton_Profile_Data_malloc": unit -> t;
+ val free = _import "MLton_Profile_Data_free": t -> unit;
+ val malloc = _import "MLton_Profile_Data_malloc": unit -> t;
val write =
- _ffi "MLton_Profile_Data_write"
+ _import "MLton_Profile_Data_write"
: t * word (* fd *) -> unit;
end
- val current = _ffi "MLton_Profile_current": unit -> Data.t;
- val done = _ffi "MLton_Profile_done": unit -> unit;
+ val current = _import "MLton_Profile_current": unit -> Data.t;
+ val done = _import "MLton_Profile_done": unit -> unit;
val setCurrent =
- _ffi "MLton_Profile_setCurrent": Data.t -> unit;
+ _import "MLton_Profile_setCurrent": Data.t -> unit;
end
structure Rlimit =
@@ -588,36 +588,36 @@
val virtualMemorySize =
_const "MLton_Rlimit_virtualMemorySize": t;
- val get = _ffi "MLton_Rlimit_get": t -> int;
- val getHard = _ffi "MLton_Rlimit_getHard": unit -> rlim;
- val getSoft = _ffi "MLton_Rlimit_getSoft": unit -> rlim;
- val set = _ffi "MLton_Rlimit_set": t * rlim * rlim -> int;
+ val get = _import "MLton_Rlimit_get": t -> int;
+ val getHard = _import "MLton_Rlimit_getHard": unit -> rlim;
+ val getSoft = _import "MLton_Rlimit_getSoft": unit -> rlim;
+ val set = _import "MLton_Rlimit_set": t * rlim * rlim -> int;
end
structure Rusage =
struct
- val ru = _ffi "MLton_Rusage_ru": unit -> unit;
- val self_utime_sec = _ffi "MLton_Rusage_self_utime_sec": unit -> int;
- val self_utime_usec = _ffi "MLton_Rusage_self_utime_usec": unit -> int;
- val self_stime_sec = _ffi "MLton_Rusage_self_stime_sec": unit -> int;
- val self_stime_usec = _ffi "MLton_Rusage_self_stime_usec": unit -> int;
- val children_utime_sec = _ffi "MLton_Rusage_children_utime_sec": unit -> int;
- val children_utime_usec = _ffi "MLton_Rusage_children_utime_usec": unit -> int;
- val children_stime_sec = _ffi "MLton_Rusage_children_stime_sec": unit -> int;
- val children_stime_usec = _ffi "MLton_Rusage_children_stime_usec": unit -> int;
- val gc_utime_sec = _ffi "MLton_Rusage_gc_utime_sec": unit -> int;
- val gc_utime_usec = _ffi "MLton_Rusage_gc_utime_usec": unit -> int;
- val gc_stime_sec = _ffi "MLton_Rusage_gc_stime_sec": unit -> int;
- val gc_stime_usec = _ffi "MLton_Rusage_gc_stime_usec": unit -> int;
+ val ru = _import "MLton_Rusage_ru": unit -> unit;
+ val self_utime_sec = _import "MLton_Rusage_self_utime_sec": unit -> int;
+ val self_utime_usec = _import "MLton_Rusage_self_utime_usec": unit -> int;
+ val self_stime_sec = _import "MLton_Rusage_self_stime_sec": unit -> int;
+ val self_stime_usec = _import "MLton_Rusage_self_stime_usec": unit -> int;
+ val children_utime_sec = _import "MLton_Rusage_children_utime_sec": unit -> int;
+ val children_utime_usec = _import "MLton_Rusage_children_utime_usec": unit -> int;
+ val children_stime_sec = _import "MLton_Rusage_children_stime_sec": unit -> int;
+ val children_stime_usec = _import "MLton_Rusage_children_stime_usec": unit -> int;
+ val gc_utime_sec = _import "MLton_Rusage_gc_utime_sec": unit -> int;
+ val gc_utime_usec = _import "MLton_Rusage_gc_utime_usec": unit -> int;
+ val gc_stime_sec = _import "MLton_Rusage_gc_stime_sec": unit -> int;
+ val gc_stime_usec = _import "MLton_Rusage_gc_stime_usec": unit -> int;
end
structure Process =
struct
val spawne =
- _ffi "MLton_Process_spawne"
+ _import "MLton_Process_spawne"
: nullString * nullString array * nullString array -> int;
val spawnp =
- _ffi "MLton_Process_spawnp"
+ _import "MLton_Process_spawnp"
: nullString * nullString array -> int;
end
@@ -633,10 +633,10 @@
structure Net =
struct
- val htonl = _ffi "Net_htonl": int -> int;
- val ntohl = _ffi "Net_ntohl": int -> int;
- val htons = _ffi "Net_htons": int -> int;
- val ntohs = _ffi "Net_ntohs": int -> int;
+ val htonl = _import "Net_htonl": int -> int;
+ val ntohl = _import "Net_ntohl": int -> int;
+ val htons = _import "Net_htons": int -> int;
+ val ntohs = _import "Net_ntohs": int -> int;
end
structure NetHostDB =
@@ -647,65 +647,65 @@
val inAddrLen = _const "NetHostDB_inAddrLen": int;
val INADDR_ANY = _const "NetHostDB_INADDR_ANY": int;
type addr_family = int
- val entryName = _ffi "NetHostDB_Entry_name": unit -> cstring;
- val entryNumAliases = _ffi "NetHostDB_Entry_numAliases": unit -> int;
- val entryAliasesN = _ffi "NetHostDB_Entry_aliasesN": int -> cstring;
- val entryAddrType = _ffi "NetHostDB_Entry_addrType": unit -> int;
- val entryLength = _ffi "NetHostDB_Entry_length": unit -> int;
- val entryNumAddrs = _ffi "NetHostDB_Entry_numAddrs": unit -> int;
+ val entryName = _import "NetHostDB_Entry_name": unit -> cstring;
+ val entryNumAliases = _import "NetHostDB_Entry_numAliases": unit -> int;
+ val entryAliasesN = _import "NetHostDB_Entry_aliasesN": int -> cstring;
+ val entryAddrType = _import "NetHostDB_Entry_addrType": unit -> int;
+ val entryLength = _import "NetHostDB_Entry_length": unit -> int;
+ val entryNumAddrs = _import "NetHostDB_Entry_numAddrs": unit -> int;
val entryAddrsN =
- _ffi "NetHostDB_Entry_addrsN": int * pre_in_addr -> unit;
+ _import "NetHostDB_Entry_addrsN": int * pre_in_addr -> unit;
val getByAddress =
- _ffi "NetHostDB_getByAddress": in_addr * int -> bool;
- val getByName = _ffi "NetHostDB_getByName": nullString -> bool;
+ _import "NetHostDB_getByAddress": in_addr * int -> bool;
+ val getByName = _import "NetHostDB_getByName": nullString -> bool;
val getHostName =
- _ffi "NetHostDB_getHostName": char array * int -> int;
+ _import "NetHostDB_getHostName": char array * int -> int;
end
structure NetProtDB =
struct
- val entryName = _ffi "NetProtDB_Entry_name": unit -> cstring;
- val entryNumAliases = _ffi "NetProtDB_Entry_numAliases": unit -> int;
- val entryAliasesN = _ffi "NetProtDB_Entry_aliasesN": int -> cstring;
- val entryProtocol = _ffi "NetProtDB_Entry_protocol": unit -> int;
- val getByName = _ffi "NetProtDB_getByName": nullString -> bool;
- val getByNumber = _ffi "NetProtDB_getByNumber": int -> bool;
+ val entryName = _import "NetProtDB_Entry_name": unit -> cstring;
+ val entryNumAliases = _import "NetProtDB_Entry_numAliases": unit -> int;
+ val entryAliasesN = _import "NetProtDB_Entry_aliasesN": int -> cstring;
+ val entryProtocol = _import "NetProtDB_Entry_protocol": unit -> int;
+ val getByName = _import "NetProtDB_getByName": nullString -> bool;
+ val getByNumber = _import "NetProtDB_getByNumber": int -> bool;
end
structure NetServDB =
struct
- val entryName = _ffi "NetServDB_Entry_name": unit -> cstring;
- val entryNumAliases = _ffi "NetServDB_Entry_numAliases": unit -> int;
- val entryAliasesN = _ffi "NetServDB_Entry_aliasesN": int -> cstring;
- val entryPort = _ffi "NetServDB_Entry_port": unit -> int;
- val entryProtocol = _ffi "NetServDB_Entry_protocol": unit -> cstring;
- val getByName = _ffi "NetServDB_getByName": nullString * nullString -> bool;
- val getByNameNull = _ffi "NetServDB_getByNameNull": nullString -> bool;
- val getByPort = _ffi "NetServDB_getByPort": int * nullString -> bool;
- val getByPortNull = _ffi "NetServDB_getByPortNull": int -> bool;
+ val entryName = _import "NetServDB_Entry_name": unit -> cstring;
+ val entryNumAliases = _import "NetServDB_Entry_numAliases": unit -> int;
+ val entryAliasesN = _import "NetServDB_Entry_aliasesN": int -> cstring;
+ val entryPort = _import "NetServDB_Entry_port": unit -> int;
+ val entryProtocol = _import "NetServDB_Entry_protocol": unit -> cstring;
+ val getByName = _import "NetServDB_getByName": nullString * nullString -> bool;
+ val getByNameNull = _import "NetServDB_getByNameNull": nullString -> bool;
+ val getByPort = _import "NetServDB_getByPort": int * nullString -> bool;
+ val getByPortNull = _import "NetServDB_getByPortNull": int -> bool;
end
structure OS =
struct
structure FileSys =
struct
- val tmpnam = _ffi "OS_FileSys_tmpnam": unit -> cstring;
+ val tmpnam = _import "OS_FileSys_tmpnam": unit -> cstring;
end
structure IO =
struct
val POLLIN = _const "OS_IO_POLLIN": word;
val POLLPRI = _const "OS_IO_POLLPRI": word;
val POLLOUT = _const "OS_IO_POLLOUT": word;
- val poll = _ffi "OS_IO_poll": int vector * word vector *
+ val poll = _import "OS_IO_poll": int vector * word vector *
int * int * word array -> int;
end
end
structure PackReal =
struct
- val subVec = _ffi "PackReal_subVec": word8 vector * int -> real;
+ val subVec = _import "PackReal_subVec": word8 vector * int -> real;
val update =
- _ffi "PackReal_update": word8 array * int * real -> unit;
+ _import "PackReal_update": word8 array * int * real -> unit;
end
structure Ptrace =
@@ -735,9 +735,9 @@
val SETFPREGS = _const "Ptrace_SETFPREGS": int;
val SYSCALL = _const "Ptrace_SYSCALL": int;
- val ptrace2 = _ffi "Ptrace_ptrace2": int * pid -> int;
+ val ptrace2 = _import "Ptrace_ptrace2": int * pid -> int;
val ptrace4 =
- _ffi "Ptrace_ptrace4": int * pid * word * word ref -> int;
+ _import "Ptrace_ptrace4": int * pid * word * word ref -> int;
end
structure Real =
@@ -753,18 +753,18 @@
val atan = _prim "Real64_Math_atan": real -> real;
val atan2 = _prim "Real64_Math_atan2": real * real -> real;
val cos = _prim "Real64_Math_cos": real -> real;
- val cosh = _ffi "cosh": real -> real;
- val e = _ffi "Real64_Math_e": real;
+ val cosh = _import "cosh": real -> real;
+ val e = _import "Real64_Math_e": 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 = _ffi "Real64_Math_pi": real;
- val pow = _ffi "pow": real * real -> real;
+ val pi = _import "Real64_Math_pi": real;
+ val pow = _import "pow": real * real -> real;
val sin = _prim "Real64_Math_sin": real -> real;
- val sinh = _ffi "sinh": real -> real;
+ val sinh = _import "sinh": real -> real;
val sqrt = _prim "Real64_Math_sqrt": real -> real;
val tan = _prim "Real64_Math_tan": real -> real;
- val tanh = _ffi "tanh": real -> real;
+ val tanh = _import "tanh": real -> real;
end
val * = _prim "Real64_mul": real * real -> real;
@@ -780,24 +780,24 @@
val >= = _prim "Real64_ge": real * real -> bool;
val ?= = _prim "Real64_qequal": real * real -> bool;
val abs = _prim "Real64_abs": real -> real;
- val class = _ffi "Real64_class": real -> int;
- val copySign = _ffi "copysign": real * real -> real;
- val frexp = _ffi "frexp": real * int ref -> real;
+ val class = _import "Real64_class": real -> int;
+ val copySign = _import "copysign": real * real -> real;
+ val frexp = _import "frexp": real * int ref -> real;
val gdtoa =
- _ffi "Real64_gdtoa": real * int * int * int ref -> cstring;
+ _import "Real64_gdtoa": real * int * int * int ref -> cstring;
val fromInt = _prim "Int32_toReal64": int -> real;
- val isFinite = _ffi "Real64_isFinite": real -> bool;
- val isNan = _ffi "Real64_isNan": real -> bool;
- val isNormal = _ffi "Real64_isNormal": real -> bool;
+ val isFinite = _import "Real64_isFinite": real -> bool;
+ val isNan = _import "Real64_isNan": real -> bool;
+ val isNormal = _import "Real64_isNormal": real -> bool;
val ldexp = _prim "Real64_ldexp": real * int -> real;
- val maxFinite = _ffi "Real64_maxFinite": real;
- val minNormalPos = _ffi "Real64_minNormalPos": real;
- val minPos = _ffi "Real64_minPos": real;
- val modf = _ffi "modf": real * real ref -> real;
- val nextAfter = _ffi "Real64_nextAfter": real * real -> real;
+ val maxFinite = _import "Real64_maxFinite": real;
+ val minNormalPos = _import "Real64_minNormalPos": real;
+ val minPos = _import "Real64_minPos": real;
+ val modf = _import "modf": real * real ref -> real;
+ val nextAfter = _import "Real64_nextAfter": real * real -> real;
val round = _prim "Real64_round": real -> real;
- val signBit = _ffi "Real64_signBit": real -> bool;
- val strtod = _ffi "Real64_strtod": nullString -> real;
+ val signBit = _import "Real64_signBit": real -> bool;
+ val strtod = _import "Real64_strtod": nullString -> real;
val toInt = _prim "Real64_toInt": real -> int;
val ~ = _prim "Real64_neg": real -> real;
end
@@ -838,19 +838,19 @@
type write_data = word8 array
val setSockOpt =
- _ffi "Socket_Ctl_setSockOpt": sock * level * optname *
+ _import "Socket_Ctl_setSockOpt": sock * level * optname *
read_data * int ->
int;
val getSockOpt =
- _ffi "Socket_Ctl_getSockOpt": sock * level * optname *
+ _import "Socket_Ctl_getSockOpt": sock * level * optname *
write_data * int ref ->
int;
val setIOCtl =
- _ffi "Socket_Ctl_getsetIOCtl": sock * request *
+ _import "Socket_Ctl_getsetIOCtl": sock * request *
read_data ->
int;
val getIOCtl =
- _ffi "Socket_Ctl_getsetIOCtl": sock * request *
+ _import "Socket_Ctl_getsetIOCtl": sock * request *
write_data ->
int;
end
@@ -871,52 +871,52 @@
val ERROR = _const "Socket_Ctl_SO_ERROR": optname;
val getPeerName =
- _ffi "Socket_Ctl_getPeerName": sock * pre_sock_addr * int ref -> int;
+ _import "Socket_Ctl_getPeerName": sock * pre_sock_addr * int ref -> int;
val getSockName =
- _ffi "Socket_Ctl_getSockName": sock * pre_sock_addr * int ref -> int;
+ _import "Socket_Ctl_getSockName": sock * pre_sock_addr * int ref -> int;
val NBIO = _const "Socket_Ctl_FIONBIO": request;
val NREAD = _const "Socket_Ctl_FIONREAD": request;
val ATMARK = _const "Socket_Ctl_SIOCATMARK": request;
end
- val familyOfAddr = _ffi "Socket_familyOfAddr": sock_addr -> AF.addr_family;
- val bind = _ffi "Socket_bind": sock * sock_addr * int -> int;
- val listen = _ffi "Socket_listen": sock * int -> int;
- val connect = _ffi "Socket_connect": sock * sock_addr * int -> int;
- val accept = _ffi "Socket_accept": sock * pre_sock_addr * int ref -> int;
- val close = _ffi "Socket_close": sock -> int;
+ val familyOfAddr = _import "Socket_familyOfAddr": sock_addr -> AF.addr_family;
+ val bind = _import "Socket_bind": sock * sock_addr * int -> int;
+ val listen = _import "Socket_listen": sock * int -> int;
+ val connect = _import "Socket_connect": sock * sock_addr * int -> int;
+ val accept = _import "Socket_accept": sock * pre_sock_addr * int ref -> int;
+ val close = _import "Socket_close": sock -> int;
type how = int
val SHUT_RD = _const "Socket_SHUT_RD": how;
val SHUT_WR = _const "Socket_SHUT_WR": how;
val SHUT_RDWR = _const "Socket_SHUT_RDWR": how;
- val shutdown = _ffi "Socket_shutdown": sock * how -> int;
+ val shutdown = _import "Socket_shutdown": sock * how -> int;
type flags = word
val MSG_DONTROUTE = _const "Socket_MSG_DONTROUTE": flags;
val MSG_OOB = _const "Socket_MSG_OOB": flags;
val MSG_PEEK = _const "Socket_MSG_PEEK": flags;
- val send = _ffi "Socket_send": sock * word8 vector *
+ val send = _import "Socket_send": sock * word8 vector *
int * int * word -> int;
- val sendTo = _ffi "Socket_sendTo": sock * word8 vector *
+ val sendTo = _import "Socket_sendTo": sock * word8 vector *
int * int * word *
sock_addr * int -> int;
- val recv = _ffi "Socket_recv": sock * word8 array *
+ val recv = _import "Socket_recv": sock * word8 array *
int * int * word -> int;
- val recvFrom = _ffi "Socket_recvFrom": sock * word8 array *
+ val recvFrom = _import "Socket_recvFrom": sock * word8 array *
int * int * word *
pre_sock_addr * int ref -> int;
structure GenericSock =
struct
val socket =
- _ffi "GenericSock_socket": AF.addr_family *
+ _import "GenericSock_socket": AF.addr_family *
SOCK.sock_type *
int -> int;
val socketPair =
- _ffi "GenericSock_socketPair": AF.addr_family *
+ _import "GenericSock_socketPair": AF.addr_family *
SOCK.sock_type *
int *
int ref * int ref -> int;
@@ -924,12 +924,12 @@
structure INetSock =
struct
- val toAddr = _ffi "INetSock_toAddr": NetHostDB.in_addr * int *
+ val toAddr = _import "INetSock_toAddr": NetHostDB.in_addr * int *
pre_sock_addr * int ref -> unit;
- val fromAddr = _ffi "INetSock_fromAddr": sock_addr -> unit;
- val getInAddr = _ffi "INetSock_getInAddr": NetHostDB.pre_in_addr ->
+ val fromAddr = _import "INetSock_fromAddr": sock_addr -> unit;
+ val getInAddr = _import "INetSock_getInAddr": NetHostDB.pre_in_addr ->
unit;
- val getPort = _ffi "INetSock_getPort": unit -> int;
+ val getPort = _import "INetSock_getPort": unit -> int;
structure UDP =
struct
end
@@ -942,11 +942,11 @@
end
structure UnixSock =
struct
- val toAddr = _ffi "UnixSock_toAddr": nullString * int *
+ val toAddr = _import "UnixSock_toAddr": nullString * int *
pre_sock_addr * int ref -> unit;
- val pathLen = _ffi "UnixSock_pathLen": sock_addr -> int;
+ val pathLen = _import "UnixSock_pathLen": sock_addr -> int;
val fromAddr =
- _ffi "UnixSock_fromAddr"
+ _import "UnixSock_fromAddr"
: sock_addr * char array * int -> unit;
structure Strm =
struct
@@ -996,24 +996,24 @@
* switching to a copy.
*)
val copyCurrent = _prim "Thread_copyCurrent": unit -> unit;
- val current = _ffi "Thread_current": unit -> thread;
- val finishHandler = _ffi "Thread_finishHandler": unit -> unit;
+ val current = _import "Thread_current": unit -> thread;
+ val finishHandler = _import "Thread_finishHandler": unit -> unit;
val returnToC = _prim "Thread_returnToC": unit -> unit;
- val saved = _ffi "Thread_saved": unit -> thread;
- val savedPre = _ffi "Thread_saved": unit -> preThread;
+ val saved = _import "Thread_saved": unit -> thread;
+ val savedPre = _import "Thread_saved": unit -> preThread;
val setCallFromCHandler =
- _ffi "Thread_setCallFromCHandler": thread -> unit;
- val setHandler = _ffi "Thread_setHandler": thread -> unit;
- val setSaved = _ffi "Thread_setSaved": thread -> unit;
- val startHandler = _ffi "Thread_startHandler": unit -> unit;
+ _import "Thread_setCallFromCHandler": thread -> unit;
+ val setHandler = _import "Thread_setHandler": thread -> unit;
+ val setSaved = _import "Thread_setSaved": thread -> unit;
+ val startHandler = _import "Thread_startHandler": unit -> unit;
val switchTo = _prim "Thread_switchTo": thread -> unit;
end
structure Time =
struct
- val gettimeofday = _ffi "Time_gettimeofday": unit -> int;
- val sec = _ffi "Time_sec": unit -> int;
- val usec = _ffi "Time_usec": unit -> int;
+ val gettimeofday = _import "Time_gettimeofday": unit -> int;
+ val sec = _import "Time_sec": unit -> int;
+ val usec = _import "Time_usec": unit -> int;
end
structure Vector =
@@ -1147,8 +1147,8 @@
structure World =
struct
- val isOriginal = _ffi "World_isOriginal": unit -> bool;
- val makeOriginal = _ffi "World_makeOriginal": unit -> unit;
+ val isOriginal = _import "World_isOriginal": unit -> bool;
+ val makeOriginal = _import "World_makeOriginal": unit -> unit;
val save = _prim "World_save": word (* filedes *) -> unit;
end
end
1.4 +4 -4 mlton/basis-library/mlton/syslog.sml
Index: syslog.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/syslog.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- syslog.sml 29 Dec 2002 01:22:58 -0000 1.3
+++ syslog.sml 19 Jul 2003 01:23:25 -0000 1.4
@@ -56,19 +56,19 @@
let
val optf =
Word32.toInt (foldl Word32.orb 0w0 (map Word32.fromInt opt))
- val sys_strdup = _ffi "strdup" : string -> word ;
- val sys_openlog = _ffi "openlog" : word * int * int -> unit ;
+ val sys_strdup = _import "strdup" : string -> word ;
+ val sys_openlog = _import "openlog" : word * int * int -> unit ;
in
sys_openlog (sys_strdup (zt s), optf, fac)
end
fun closelog () =
- let val sys_closelog = _ffi "closelog" : unit -> unit ;
+ let val sys_closelog = _import "closelog" : unit -> unit ;
in sys_closelog ()
end
fun log (lev, msg) =
- let val sys_syslog = _ffi "syslog" : int * string * string -> unit ;
+ let val sys_syslog = _import "syslog" : int * string * string -> unit ;
in sys_syslog (lev, "%s\000", zt msg)
end
1.15 +165 -167 mlton/basis-library/posix/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/primitive.sml,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- primitive.sml 1 Jun 2003 00:31:29 -0000 1.14
+++ primitive.sml 19 Jul 2003 01:23:25 -0000 1.15
@@ -26,9 +26,9 @@
struct
type syserror = int
- val getErrno = _ffi "Posix_Error_getErrno": unit -> int;
- val clearErrno = _ffi "Posix_Error_clearErrno": unit -> unit;
- val strerror = _ffi "Posix_Error_strerror": syserror -> cstring;
+ val getErrno = _import "Posix_Error_getErrno": unit -> int;
+ val clearErrno = _import "Posix_Error_clearErrno": unit -> unit;
+ val strerror = _import "Posix_Error_strerror": syserror -> cstring;
val acces = _const "Posix_Error_acces": syserror;
val again = _const "Posix_Error_again": syserror;
@@ -151,22 +151,22 @@
val vtalrm = _const "Posix_Signal_vtalrm": signal;
val block = _const "Posix_Signal_block": how;
- val default = _ffi "Posix_Signal_default": signal -> int;
- val handleGC = _ffi "Posix_Signal_handleGC": unit -> unit;
- val handlee = _ffi "Posix_Signal_handle": signal -> int;
- val ignore = _ffi "Posix_Signal_ignore": signal -> int;
+ val default = _import "Posix_Signal_default": signal -> int;
+ val handleGC = _import "Posix_Signal_handleGC": unit -> unit;
+ val handlee = _import "Posix_Signal_handle": signal -> int;
+ val ignore = _import "Posix_Signal_ignore": signal -> int;
val isDefault =
- _ffi "Posix_Signal_isDefault": signal * bool ref -> int;
- val isGCPending = _ffi "Posix_Signal_isGCPending": unit -> bool;
- val isPending = _ffi "Posix_Signal_isPending": signal -> bool;
+ _import "Posix_Signal_isDefault": signal * bool ref -> int;
+ val isGCPending = _import "Posix_Signal_isGCPending": unit -> bool;
+ val isPending = _import "Posix_Signal_isPending": signal -> bool;
val numSignals = _const "Posix_Signal_numSignals": int;
val setmask = _const "Posix_Signal_setmask": how;
- val sigaddset = _ffi "Posix_Signal_sigaddset": signal -> int;
- val sigdelset = _ffi "Posix_Signal_sigdelset": signal -> int;
- val sigemptyset = _ffi "Posix_Signal_sigemptyset": unit -> int;
- val sigfillset = _ffi "Posix_Signal_sigfillset": unit -> int;
- val sigprocmask = _ffi "Posix_Signal_sigprocmask": how -> int;
- val suspend = _ffi "Posix_Signal_suspend": unit -> int;
+ val sigaddset = _import "Posix_Signal_sigaddset": signal -> int;
+ val sigdelset = _import "Posix_Signal_sigdelset": signal -> int;
+ val sigemptyset = _import "Posix_Signal_sigemptyset": unit -> int;
+ val sigfillset = _import "Posix_Signal_sigfillset": unit -> int;
+ val sigprocmask = _import "Posix_Signal_sigprocmask": how -> int;
+ val suspend = _import "Posix_Signal_suspend": unit -> int;
val unblock = _const "Posix_Signal_unblock": how;
end
@@ -182,25 +182,25 @@
type pid = pid
type status = int
- val alarm = _ffi "Posix_Process_alarm": int -> int;
+ val alarm = _import "Posix_Process_alarm": int -> int;
val exece =
- _ffi "Posix_Process_exece"
+ _import "Posix_Process_exece"
: nullString * nullString array * nullString array -> int;
val execp =
- _ffi "Posix_Process_execp": nullString * nullString array -> int;
- val exit = _ffi "Posix_Process_exit": int -> unit;
- val exitStatus = _ffi "Posix_Process_exitStatus": status -> int;
- val fork = _ffi "Posix_Process_fork": unit -> pid;
- val ifExited = _ffi "Posix_Process_ifExited": status -> bool;
- val ifSignaled = _ffi "Posix_Process_ifSignaled": status -> bool;
- val ifStopped = _ffi "Posix_Process_ifStopped": status -> bool;
- val kill = _ffi "Posix_Process_kill": pid * signal -> int;
- val pause = _ffi "Posix_Process_pause": unit -> int;
- val sleep = _ffi "Posix_Process_sleep": int -> int;
- val stopSig = _ffi "Posix_Process_stopSig": status -> signal;
- val termSig = _ffi "Posix_Process_termSig": status -> signal;
+ _import "Posix_Process_execp": nullString * nullString array -> int;
+ val exit = _import "Posix_Process_exit": int -> unit;
+ val exitStatus = _import "Posix_Process_exitStatus": status -> int;
+ val fork = _import "Posix_Process_fork": unit -> pid;
+ val ifExited = _import "Posix_Process_ifExited": status -> bool;
+ val ifSignaled = _import "Posix_Process_ifSignaled": status -> bool;
+ val ifStopped = _import "Posix_Process_ifStopped": status -> bool;
+ val kill = _import "Posix_Process_kill": pid * signal -> int;
+ val pause = _import "Posix_Process_pause": unit -> int;
+ val sleep = _import "Posix_Process_sleep": int -> int;
+ val stopSig = _import "Posix_Process_stopSig": status -> signal;
+ val termSig = _import "Posix_Process_termSig": status -> signal;
val waitpid =
- _ffi "Posix_Process_waitpid": pid * status ref * int -> pid;
+ _import "Posix_Process_waitpid": pid * status ref * int -> pid;
end
structure ProcEnv =
@@ -240,54 +240,54 @@
type uid = uid
datatype file_desc = datatype file_desc
- val getegid = _ffi "Posix_ProcEnv_getegid": unit -> gid;
- val geteuid = _ffi "Posix_ProcEnv_geteuid": unit -> uid;
- val getgid = _ffi "Posix_ProcEnv_getgid": unit -> gid;
- val getgroups = _ffi "Posix_ProcEnv_getgroups": gid array -> int;
- val getlogin = _ffi "Posix_ProcEnv_getlogin": unit -> cstring;
- val getpgrp = _ffi "Posix_ProcEnv_getpgrp": unit -> pid;
- val getpid = _ffi "Posix_ProcEnv_getpid": unit -> pid;
- val getppid = _ffi "Posix_ProcEnv_getppid": unit -> pid;
- val getuid = _ffi "Posix_ProcEnv_getuid": unit -> uid;
+ val getegid = _import "Posix_ProcEnv_getegid": unit -> gid;
+ val geteuid = _import "Posix_ProcEnv_geteuid": unit -> uid;
+ val getgid = _import "Posix_ProcEnv_getgid": unit -> gid;
+ val getgroups = _import "Posix_ProcEnv_getgroups": gid array -> int;
+ val getlogin = _import "Posix_ProcEnv_getlogin": unit -> cstring;
+ val getpgrp = _import "Posix_ProcEnv_getpgrp": unit -> pid;
+ val getpid = _import "Posix_ProcEnv_getpid": unit -> pid;
+ val getppid = _import "Posix_ProcEnv_getppid": unit -> pid;
+ val getuid = _import "Posix_ProcEnv_getuid": unit -> uid;
val setenv =
- _ffi "Posix_ProcEnv_setenv": nullString * nullString -> int;
- val setgid = _ffi "Posix_ProcEnv_setgid": gid -> int;
- val setpgid = _ffi "Posix_ProcEnv_setpgid": pid * pid -> int;
- val setsid = _ffi "Posix_ProcEnv_setsid": unit -> pid;
- val setuid = _ffi "Posix_ProcEnv_setuid": uid -> int;
+ _import "Posix_ProcEnv_setenv": nullString * nullString -> int;
+ val setgid = _import "Posix_ProcEnv_setgid": gid -> int;
+ val setpgid = _import "Posix_ProcEnv_setpgid": pid * pid -> int;
+ val setsid = _import "Posix_ProcEnv_setsid": unit -> pid;
+ val setuid = _import "Posix_ProcEnv_setuid": uid -> int;
structure Uname =
struct
- val uname = _ffi "Posix_ProcEnv_Uname_uname": unit -> int;
+ val uname = _import "Posix_ProcEnv_Uname_uname": unit -> int;
val sysname =
- _ffi "Posix_ProcEnv_Uname_sysname": unit -> cstring;
+ _import "Posix_ProcEnv_Uname_sysname": unit -> cstring;
val nodename =
- _ffi "Posix_ProcEnv_Uname_nodename": unit -> cstring;
+ _import "Posix_ProcEnv_Uname_nodename": unit -> cstring;
val release =
- _ffi "Posix_ProcEnv_Uname_release": unit -> cstring;
+ _import "Posix_ProcEnv_Uname_release": unit -> cstring;
val version =
- _ffi "Posix_ProcEnv_Uname_version": unit -> cstring;
+ _import "Posix_ProcEnv_Uname_version": unit -> cstring;
val machine =
- _ffi "Posix_ProcEnv_Uname_machine": unit -> cstring;
+ _import "Posix_ProcEnv_Uname_machine": unit -> cstring;
end
type clock_t = word
structure Tms =
struct
- val utime = _ffi "Posix_ProcEnv_Tms_utime": unit -> clock_t;
- val stime = _ffi "Posix_ProcEnv_Tms_stime": unit -> clock_t;
- val cutime = _ffi "Posix_ProcEnv_Tms_cutime": unit -> clock_t;
- val cstime = _ffi "Posix_ProcEnv_Tms_cstime": unit -> clock_t;
+ val utime = _import "Posix_ProcEnv_Tms_utime": unit -> clock_t;
+ val stime = _import "Posix_ProcEnv_Tms_stime": unit -> clock_t;
+ val cutime = _import "Posix_ProcEnv_Tms_cutime": unit -> clock_t;
+ val cstime = _import "Posix_ProcEnv_Tms_cstime": unit -> clock_t;
end
- val ctermid = _ffi "Posix_ProcEnv_ctermid" : unit -> cstring;
- val environ = _ffi "Posix_ProcEnv_environ" : cstringArray;
- val getenv = _ffi "Posix_ProcEnv_getenv" : nullString -> cstring;
- val isatty = _ffi "Posix_ProcEnv_isatty" : fd -> bool;
- val sysconf = _ffi "Posix_ProcEnv_sysconf" : int -> int;
- val times = _ffi "Posix_ProcEnv_times" : unit -> clock_t;
- val ttyname = _ffi "Posix_ProcEnv_ttyname" : fd -> cstring;
+ val ctermid = _import "Posix_ProcEnv_ctermid" : unit -> cstring;
+ val environ = _import "Posix_ProcEnv_environ" : cstringArray;
+ val getenv = _import "Posix_ProcEnv_getenv" : nullString -> cstring;
+ val isatty = _import "Posix_ProcEnv_isatty" : fd -> bool;
+ val sysconf = _import "Posix_ProcEnv_sysconf" : int -> int;
+ val times = _import "Posix_ProcEnv_times" : unit -> clock_t;
+ val ttyname = _import "Posix_ProcEnv_ttyname" : fd -> cstring;
end
structure FileSys =
@@ -369,101 +369,101 @@
type dirstream = pointer
val closedir =
- _ffi "Posix_FileSys_Dirstream_closedir": dirstream -> int;
+ _import "Posix_FileSys_Dirstream_closedir": dirstream -> int;
val opendir =
- _ffi "Posix_FileSys_Dirstream_opendir"
+ _import "Posix_FileSys_Dirstream_opendir"
: nullString -> dirstream;
val readdir =
- _ffi "Posix_FileSys_Dirstream_readdir"
+ _import "Posix_FileSys_Dirstream_readdir"
: dirstream -> cstring;
val rewinddir =
- _ffi "Posix_FileSys_Dirstream_rewinddir"
+ _import "Posix_FileSys_Dirstream_rewinddir"
: dirstream -> unit;
end
structure Stat =
struct
- val dev = _ffi "Posix_FileSys_Stat_dev": unit -> dev;
- val ino = _ffi "Posix_FileSys_Stat_ino": unit -> ino;
- val mode = _ffi "Posix_FileSys_Stat_mode": unit -> word;
- val nlink = _ffi "Posix_FileSys_Stat_nlink": unit -> int;
- val uid = _ffi "Posix_FileSys_Stat_uid": unit -> uid;
- val gid = _ffi "Posix_FileSys_Stat_gid": unit -> gid;
- val size = _ffi "Posix_FileSys_Stat_size": unit -> int;
+ val dev = _import "Posix_FileSys_Stat_dev": unit -> dev;
+ val ino = _import "Posix_FileSys_Stat_ino": unit -> ino;
+ val mode = _import "Posix_FileSys_Stat_mode": unit -> word;
+ val nlink = _import "Posix_FileSys_Stat_nlink": unit -> int;
+ val uid = _import "Posix_FileSys_Stat_uid": unit -> uid;
+ val gid = _import "Posix_FileSys_Stat_gid": unit -> gid;
+ val size = _import "Posix_FileSys_Stat_size": unit -> int;
val atime =
- _ffi "Posix_FileSys_Stat_atime": unit -> time;
+ _import "Posix_FileSys_Stat_atime": unit -> time;
val mtime =
- _ffi "Posix_FileSys_Stat_mtime": unit -> time;
+ _import "Posix_FileSys_Stat_mtime": unit -> time;
val ctime =
- _ffi "Posix_FileSys_Stat_ctime": unit -> time;
- val fstat = _ffi "Posix_FileSys_Stat_fstat": fd -> int;
+ _import "Posix_FileSys_Stat_ctime": unit -> time;
+ val fstat = _import "Posix_FileSys_Stat_fstat": fd -> int;
val lstat =
- _ffi "Posix_FileSys_Stat_lstat": nullString -> int;
+ _import "Posix_FileSys_Stat_lstat": nullString -> int;
val stat =
- _ffi "Posix_FileSys_Stat_stat": nullString -> int;
+ _import "Posix_FileSys_Stat_stat": nullString -> int;
end
structure Utimbuf =
struct
val setActime =
- _ffi "Posix_FileSys_Utimbuf_setActime": time -> unit;
+ _import "Posix_FileSys_Utimbuf_setActime": time -> unit;
val setModtime =
- _ffi "Posix_FileSys_Utimbuf_setModTime": time -> unit;
+ _import "Posix_FileSys_Utimbuf_setModTime": time -> unit;
val utime =
- _ffi "Posix_FileSys_Utimbuf_utime": nullString -> int;
+ _import "Posix_FileSys_Utimbuf_utime": nullString -> int;
end
val access =
- _ffi "Posix_FileSys_access": nullString * word -> int;
- val chdir = _ffi "Posix_FileSys_chdir": nullString -> int;
+ _import "Posix_FileSys_access": nullString * word -> int;
+ val chdir = _import "Posix_FileSys_chdir": nullString -> int;
val chmod =
- _ffi "Posix_FileSys_chmod": nullString * mode -> int;
+ _import "Posix_FileSys_chmod": nullString * mode -> int;
val chown =
- _ffi "Posix_FileSys_chown": nullString * uid * gid -> int;
+ _import "Posix_FileSys_chown": nullString * uid * gid -> int;
val fchmod =
- _ffi "Posix_FileSys_fchmod": fd * mode -> int;
+ _import "Posix_FileSys_fchmod": fd * mode -> int;
val fchown =
- _ffi "Posix_FileSys_fchown": fd * uid * gid -> int;
+ _import "Posix_FileSys_fchown": fd * uid * gid -> int;
val fpathconf =
- _ffi "Posix_FileSys_fpathconf": fd * int -> int;
+ _import "Posix_FileSys_fpathconf": fd * int -> int;
val ftruncate =
- _ffi "Posix_FileSys_ftruncate": fd * int -> int;
+ _import "Posix_FileSys_ftruncate": fd * int -> int;
val getcwd =
- _ffi "Posix_FileSys_getcwd": char array * size -> cstring;
+ _import "Posix_FileSys_getcwd": char array * size -> cstring;
val link =
- _ffi "Posix_FileSys_link": nullString * nullString -> int;
+ _import "Posix_FileSys_link": nullString * nullString -> int;
val mkdir =
- _ffi "Posix_FileSys_mkdir": nullString * word -> int;
+ _import "Posix_FileSys_mkdir": nullString * word -> int;
val mkfifo =
- _ffi "Posix_FileSys_mkfifo": nullString * word -> int;
+ _import "Posix_FileSys_mkfifo": nullString * word -> int;
val openn =
- _ffi "Posix_FileSys_open": nullString * word * mode -> fd;
+ _import "Posix_FileSys_open": nullString * word * mode -> fd;
val pathconf =
- _ffi "Posix_FileSys_pathconf": nullString * int -> int;
+ _import "Posix_FileSys_pathconf": nullString * int -> int;
val readlink =
- _ffi "Posix_FileSys_readlink"
+ _import "Posix_FileSys_readlink"
: nullString * word8 array * int -> int;
val rename =
- _ffi "Posix_FileSys_rename": nullString * nullString -> int;
- val rmdir = _ffi "Posix_FileSys_rmdir": nullString -> int;
+ _import "Posix_FileSys_rename": nullString * nullString -> int;
+ val rmdir = _import "Posix_FileSys_rmdir": nullString -> int;
val symlink =
- _ffi "Posix_FileSys_symlink"
+ _import "Posix_FileSys_symlink"
: nullString * nullString -> int;
- val umask = _ffi "Posix_FileSys_umask": word -> word;
- val unlink = _ffi "Posix_FileSys_unlink": nullString -> int;
+ val umask = _import "Posix_FileSys_umask": word -> word;
+ val unlink = _import "Posix_FileSys_unlink": nullString -> int;
structure ST =
struct
- val isDir = _ffi "Posix_FileSys_ST_isDir": word -> bool;
- val isChr = _ffi "Posix_FileSys_ST_isChr": word -> bool;
- val isBlk = _ffi "Posix_FileSys_ST_isBlk": word -> bool;
- val isReg = _ffi "Posix_FileSys_ST_isReg": word -> bool;
+ val isDir = _import "Posix_FileSys_ST_isDir": word -> bool;
+ val isChr = _import "Posix_FileSys_ST_isChr": word -> bool;
+ val isBlk = _import "Posix_FileSys_ST_isBlk": word -> bool;
+ val isReg = _import "Posix_FileSys_ST_isReg": word -> bool;
val isFIFO =
- _ffi "Posix_FileSys_ST_isFIFO": word -> bool;
+ _import "Posix_FileSys_ST_isFIFO": word -> bool;
val isLink =
- _ffi "Posix_FileSys_ST_isLink": word -> bool;
+ _import "Posix_FileSys_ST_isLink": word -> bool;
val isSock =
- _ffi "Posix_FileSys_ST_isSock": word -> bool;
+ _import "Posix_FileSys_ST_isSock": word -> bool;
end
end
@@ -498,36 +498,36 @@
structure FLock =
struct
- val fcntl = _ffi "Posix_IO_FLock_fcntl": fd * int -> int;
- val typ = _ffi "Posix_IO_FLock_typ": unit -> int;
- val whence = _ffi "Posix_IO_FLock_whence": unit -> int;
- val start = _ffi "Posix_IO_FLock_start": unit -> int;
- val len = _ffi "Posix_IO_FLock_len": unit -> int;
- val pid = _ffi "Posix_IO_FLock_pid": unit -> int;
- val setType = _ffi "Posix_IO_FLock_setType": int -> unit;
+ val fcntl = _import "Posix_IO_FLock_fcntl": fd * int -> int;
+ val typ = _import "Posix_IO_FLock_typ": unit -> int;
+ val whence = _import "Posix_IO_FLock_whence": unit -> int;
+ val start = _import "Posix_IO_FLock_start": unit -> int;
+ val len = _import "Posix_IO_FLock_len": unit -> int;
+ val pid = _import "Posix_IO_FLock_pid": unit -> int;
+ val setType = _import "Posix_IO_FLock_setType": int -> unit;
val setWhence =
- _ffi "Posix_IO_FLock_setWhence": int -> unit;
+ _import "Posix_IO_FLock_setWhence": int -> unit;
val setStart =
- _ffi "Posix_IO_FLock_setStart": int -> unit;
- val setLen = _ffi "Posix_IO_FLock_setLen": int -> unit;
- val setPid = _ffi "Posix_IO_FLock_setPid": int -> unit;
+ _import "Posix_IO_FLock_setStart": int -> unit;
+ val setLen = _import "Posix_IO_FLock_setLen": int -> unit;
+ val setPid = _import "Posix_IO_FLock_setPid": int -> unit;
end
- val close = _ffi "Posix_IO_close": fd -> int;
- val dup = _ffi "Posix_IO_dup": fd -> fd;
- val dup2 = _ffi "Posix_IO_dup2": fd * fd -> fd;
- val fcntl2 = _ffi "Posix_IO_fcntl2": fd * int -> int;
- val fcntl3 = _ffi "Posix_IO_fcntl3": fd * int * int -> int;
- val fsync = _ffi "Posix_IO_fsync": fd -> int;
- val lseek = _ffi "Posix_IO_lseek": fd * int * int -> int;
- val pipe = _ffi "Posix_IO_pipe": fd array -> int;
- val readChar = _ffi "Posix_IO_read":
+ val close = _import "Posix_IO_close": fd -> int;
+ val dup = _import "Posix_IO_dup": fd -> fd;
+ val dup2 = _import "Posix_IO_dup2": fd * fd -> fd;
+ val fcntl2 = _import "Posix_IO_fcntl2": fd * int -> int;
+ val fcntl3 = _import "Posix_IO_fcntl3": fd * int * int -> int;
+ val fsync = _import "Posix_IO_fsync": fd -> int;
+ val lseek = _import "Posix_IO_lseek": fd * int * int -> int;
+ val pipe = _import "Posix_IO_pipe": fd array -> int;
+ val readChar = _import "Posix_IO_read":
fd * char array * int * size -> ssize;
- val writeChar = _ffi "Posix_IO_write":
+ val writeChar = _import "Posix_IO_write":
fd * char vector * int * size -> ssize;
- val readWord8 = _ffi "Posix_IO_read":
+ val readWord8 = _import "Posix_IO_read":
fd * word8 array * int * size -> ssize;
- val writeWord8 = _ffi "Posix_IO_write":
+ val writeWord8 = _import "Posix_IO_write":
fd * word8 vector * int * size -> ssize;
end
@@ -538,25 +538,25 @@
structure Passwd =
struct
- val name = _ffi "Posix_SysDB_Passwd_name": unit -> cstring;
- val uid = _ffi "Posix_SysDB_Passwd_uid": unit -> uid;
- val gid = _ffi "Posix_SysDB_Passwd_gid": unit -> gid;
- val dir = _ffi "Posix_SysDB_Passwd_dir": unit -> cstring;
- val shell = _ffi "Posix_SysDB_Passwd_shell": unit -> cstring;
+ val name = _import "Posix_SysDB_Passwd_name": unit -> cstring;
+ val uid = _import "Posix_SysDB_Passwd_uid": unit -> uid;
+ val gid = _import "Posix_SysDB_Passwd_gid": unit -> gid;
+ val dir = _import "Posix_SysDB_Passwd_dir": unit -> cstring;
+ val shell = _import "Posix_SysDB_Passwd_shell": unit -> cstring;
end
- val getpwnam = _ffi "Posix_SysDB_getpwnam": nullString -> bool;
- val getpwuid = _ffi "Posix_SysDB_getpwuid": uid -> bool;
+ val getpwnam = _import "Posix_SysDB_getpwnam": nullString -> bool;
+ val getpwuid = _import "Posix_SysDB_getpwuid": uid -> bool;
structure Group =
struct
- val name = _ffi "Posix_SysDB_Group_name": unit -> cstring;
- val gid = _ffi "Posix_SysDB_Group_gid": unit -> gid;
- val mem = _ffi "Posix_SysDB_Group_mem": unit -> cstringArray;
+ val name = _import "Posix_SysDB_Group_name": unit -> cstring;
+ val gid = _import "Posix_SysDB_Group_gid": unit -> gid;
+ val mem = _import "Posix_SysDB_Group_mem": unit -> cstringArray;
end
- val getgrgid = _ffi "Posix_SysDB_getgrgid": gid -> bool;
- val getgrnam = _ffi "Posix_SysDB_getgrnam": nullString -> bool;
+ val getgrgid = _import "Posix_SysDB_getgrgid": gid -> bool;
+ val getgrnam = _import "Posix_SysDB_getgrnam": nullString -> bool;
end
structure TTY =
@@ -676,38 +676,36 @@
struct
type flag = word
- val iflag = _ffi "Posix_TTY_Termios_iflag": unit -> flag;
- val oflag = _ffi "Posix_TTY_Termios_oflag": unit -> flag;
- val cflag = _ffi "Posix_TTY_Termios_cflag": unit -> flag;
- val lflag = _ffi "Posix_TTY_Termios_lflag": unit -> flag;
- val cc = _ffi "Posix_TTY_Termios_cc": unit -> cstring;
+ val iflag = _import "Posix_TTY_Termios_iflag": unit -> flag;
+ val oflag = _import "Posix_TTY_Termios_oflag": unit -> flag;
+ val cflag = _import "Posix_TTY_Termios_cflag": unit -> flag;
+ val lflag = _import "Posix_TTY_Termios_lflag": unit -> flag;
+ val cc = _import "Posix_TTY_Termios_cc": unit -> cstring;
val ospeed =
- _ffi "Posix_TTY_Termios_cfgetospeed": unit -> speed;
+ _import "Posix_TTY_Termios_cfgetospeed": unit -> speed;
val ispeed =
- _ffi "Posix_TTY_Termios_cfgetispeed": unit -> speed;
+ _import "Posix_TTY_Termios_cfgetispeed": unit -> speed;
val setiflag =
- _ffi "Posix_TTY_Termios_setiflag": flag -> unit;
+ _import "Posix_TTY_Termios_setiflag": flag -> unit;
val setoflag =
- _ffi "Posix_TTY_Termios_setoflag": flag -> unit;
+ _import "Posix_TTY_Termios_setoflag": flag -> unit;
val setcflag =
- _ffi "Posix_TTY_Termios_setcflag": flag -> unit;
+ _import "Posix_TTY_Termios_setcflag": flag -> unit;
val setlflag =
- _ffi "Posix_TTY_Termios_setlflag": flag -> unit;
+ _import "Posix_TTY_Termios_setlflag": flag -> unit;
val setospeed =
- _ffi "Posix_TTY_Termios_setospeed": speed -> int;
+ _import "Posix_TTY_Termios_setospeed": speed -> int;
val setispeed =
- _ffi "Posix_TTY_Termios_setispeed": speed -> int;
+ _import "Posix_TTY_Termios_setispeed": speed -> int;
end
- val getattr =
- _ffi "Posix_TTY_getattr": fd -> int;
- val setattr =
- _ffi "Posix_TTY_setattr": fd * TC.set_action -> int;
- val sendbreak = _ffi "Posix_TTY_sendbreak": fd * int -> int;
- val drain = _ffi "Posix_TTY_drain": fd -> int;
- val flush = _ffi "Posix_TTY_flush": fd * TC.queue_sel -> int;
- val flow = _ffi "Posix_TTY_flow": fd * TC.flow_action -> int;
- val getpgrp = _ffi "Posix_TTY_getpgrp": fd -> pid;
- val setpgrp = _ffi "Posix_TTY_setpgrp": fd * pid -> int;
+ val getattr = _import "Posix_TTY_getattr": fd -> int;
+ val setattr = _import "Posix_TTY_setattr": fd * TC.set_action -> int;
+ val sendbreak = _import "Posix_TTY_sendbreak": fd * int -> int;
+ val drain = _import "Posix_TTY_drain": fd -> int;
+ val flush = _import "Posix_TTY_flush": fd * TC.queue_sel -> int;
+ val flow = _import "Posix_TTY_flow": fd * TC.flow_action -> int;
+ val getpgrp = _import "Posix_TTY_getpgrp": fd -> pid;
+ val setpgrp = _import "Posix_TTY_setpgrp": fd * pid -> int;
end
end
1.17 +2 -2 mlton/bin/check-basis
Index: check-basis
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/check-basis,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- check-basis 24 Jun 2003 19:16:24 -0000 1.16
+++ check-basis 19 Jul 2003 01:23:25 -0000 1.17
@@ -27,8 +27,8 @@
sed 's/_const/PRIM/' |
sed 's/_prim\(.*\);/(PRIM\1)/' |
sed 's/_prim/PRIM/' |
- sed 's/_ffi\(.*\);/(PRIM\1)/' |
- sed 's/_ffi/PRIM/' |
+ sed 's/_import\(.*\);/(PRIM\1)/' |
+ sed 's/_import/PRIM/' |
sed 's/fun bigIntConstant x = x/fun bigIntConstant(x:smallInt):bigInt = raise Fail "bigIntConstant"/' |
sed 's/#"\([^"\]*\(\\.[^"\]*\)*\)"/#ZZZ\1ZZZ/g' |
sed 's/\([^\]\)"\([^"\]*\(\\.[^"\]*\)*\)"/\1(STRING_CONST "\2")/g' |
1.61 +10 -1 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -r1.60 -r1.61
--- changelog 16 Jul 2003 16:25:50 -0000 1.60
+++ changelog 19 Jul 2003 01:23:25 -0000 1.61
@@ -1,4 +1,13 @@
-Here are the changes since version 20030711.
+Here are the changes since version 20030716.
+
+* 2003-07-??
+ - Renamed _ffi as _import. The old _ffi will remain for a while,
+ but is deprecated and should be replaced with _import.
+ - Added attributes to _export and _import. For now, the only
+ attributes are "cdecl" and "stdcall".
+
+--------------------------------------------------------------------------------
+Here are the changes from version 20030711 to 20030716.
Summary:
+ Fixed several serious bugs with the 20030711 release.
1.2 +2 -33 mlton/doc/examples/ffi/import.sml
Index: import.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/import.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- import.sml 24 Jun 2003 20:14:21 -0000 1.1
+++ import.sml 19 Jul 2003 01:23:25 -0000 1.2
@@ -1,38 +1,7 @@
(* 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;
+val ffi = _import "ffi": real array * int ref * int -> char;
open Array
(* val size = _const "FFI_SIZE": int; *)
@@ -44,7 +13,7 @@
(* Call the C function *)
val c = ffi (a, r, n)
-val n = _ffi "FFI_INT": int;
+val n = _import "FFI_INT": int;
val _ = print (concat [Int.toString n, "\n"])
1.15 +19 -8 mlton/doc/user-guide/ffi.tex
Index: ffi.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/ffi.tex,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- ffi.tex 9 Jul 2003 01:03:41 -0000 1.14
+++ ffi.tex 19 Jul 2003 01:23:25 -0000 1.15
@@ -14,7 +14,7 @@
\end{verbatim}
{\mlton} extends the syntax of SML to allow expressions like the following:
\begin{verbatim}
-_ffi "foo": real * char -> int;
+_import "foo": real * char -> int;
\end{verbatim}
This expression denotes a function of type {\tt real * char -> int}
whose behavior is implemented by calling the C function whose name is
@@ -23,12 +23,21 @@
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+ expresion is:
+The general form of an \verb+_import+ expresion is:
\begin{center}
-{\tt \_ffi "}C global variable or function name{\tt ": }ty{\tt ;}
+{\tt \_import "}C global variable or function name{\tt "}{\it attribute}
+...{\tt : }{\it ty}{\tt ;}
\end{center}
The semicolon is not optional.
+The function name is followed by a (possiblye empty) sequence of
+``attributes'', analogous to C {\tt\_\_attribute\_\_} specifiers. For
+now, the only attributes supported are {\tt cdecl} and {\tt stdcall}.
+These specify the calling convention of the C function on a
+Cygwin/Windows system, and are ignored on all other systems. The
+default is {\tt cdecl}. But you must use {\tt stdcall} in order to
+correctly call Windows API functions.
+
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
@@ -51,7 +60,9 @@
\begin{verbatim}
_export "foo": real * char -> int;
\end{verbatim}
-This expression exports a C function named {\tt foo}, with prototype
+As with {\tt \_import}, a sequence of attributes may follow the
+function name. The above expression exports a C function named {\tt
+foo}, with prototype
\begin{verbatim}
Int32 foo (Real64 x0, Char x1);
\end{verbatim}
@@ -133,19 +144,19 @@
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}}
+\subsection{Type checking programs that use {\tt \_import}}
Because {\mlton} has relaxed type checking, it is necessary to
-type check programs that use {\tt \_ffi} with another SML compiler.
+type check programs that use {\tt \_import} with another SML compiler.
This can be done by a standard process using a Makefile and {\tt sed}.
Suppose that you have a file, {\tt mlxtest.cm}, that describes your
{\mlton} project, and that it refers to a file, {\tt mlx.sml}, that
-uses {\tt \_ffi}. The following Makefile will let you type-check your
+uses {\tt \_import}. The following Makefile will let you type-check your
code with {\smlnj} by typing {\tt make typecheck}.
\begin{verbatim}
nj: *.sml *.cm
- cat mlx.sml | sed -e 's/_ffi/Unsafe.cast/' >mlx-nj.sml
+ cat mlx.sml | sed -e 's/_import/Unsafe.cast/' >mlx-nj.sml
cat mlxtest.cm | sed -e 's/mlx.sml/mlx-nj.sml/' >sources.cm
typecheck: nj
1.23 +6 -6 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.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- mlton-stubs-1997.cm 8 Jul 2003 22:38:59 -0000 1.22
+++ mlton-stubs-1997.cm 19 Jul 2003 01:23:25 -0000 1.23
@@ -175,6 +175,8 @@
atoms/scheme.sig
atoms/real-x.sig
atoms/profile-exp.sig
+atoms/c-type.sig
+atoms/c-function.sig
atoms/cons.sig
atoms/int-x.sig
atoms/const.sig
@@ -186,11 +188,11 @@
xml/xml-tree.sig
xml/sxml-tree.sig
xml/sxml-tree.fun
+../lib/mlton/basic/counter.sig
+../lib/mlton/basic/counter.sml
../lib/mlton/basic/dot-color.sml
../lib/mlton/basic/dot.sig
../lib/mlton/basic/dot.sml
-../lib/mlton/basic/counter.sig
-../lib/mlton/basic/counter.sml
../lib/mlton/basic/tree.sig
../lib/mlton/basic/tree.sml
../lib/mlton/basic/directed-graph.sig
@@ -266,6 +268,8 @@
atoms/ffi.fun
atoms/const.fun
atoms/cons.fun
+atoms/c-type.fun
+atoms/c-function.fun
atoms/atoms.fun
ssa/ssa-tree.sig
ssa/direct-exp.sig
@@ -344,15 +348,11 @@
atoms/hash-type.fun
ssa/ssa-tree.fun
ssa/ssa.fun
-backend/mtype.sig
-backend/c-function.sig
backend/runtime.sig
backend/profile-label.sig
backend/machine-atoms.sig
backend/switch.sig
backend/switch.fun
-backend/mtype.fun
-backend/c-function.fun
backend/runtime.fun
backend/err.sml
backend/machine.sig
1.28 +6 -6 mlton/mlton/mlton-stubs.cm
Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- mlton-stubs.cm 8 Jul 2003 22:38:59 -0000 1.27
+++ mlton-stubs.cm 19 Jul 2003 01:23:25 -0000 1.28
@@ -174,6 +174,8 @@
atoms/scheme.sig
atoms/real-x.sig
atoms/profile-exp.sig
+atoms/c-type.sig
+atoms/c-function.sig
atoms/cons.sig
atoms/int-x.sig
atoms/const.sig
@@ -185,11 +187,11 @@
xml/xml-tree.sig
xml/sxml-tree.sig
xml/sxml-tree.fun
+../lib/mlton/basic/counter.sig
+../lib/mlton/basic/counter.sml
../lib/mlton/basic/dot-color.sml
../lib/mlton/basic/dot.sig
../lib/mlton/basic/dot.sml
-../lib/mlton/basic/counter.sig
-../lib/mlton/basic/counter.sml
../lib/mlton/basic/tree.sig
../lib/mlton/basic/tree.sml
../lib/mlton/basic/directed-graph.sig
@@ -265,6 +267,8 @@
atoms/ffi.fun
atoms/const.fun
atoms/cons.fun
+atoms/c-type.fun
+atoms/c-function.fun
atoms/atoms.fun
ssa/ssa-tree.sig
ssa/direct-exp.sig
@@ -343,15 +347,11 @@
atoms/hash-type.fun
ssa/ssa-tree.fun
ssa/ssa.fun
-backend/mtype.sig
-backend/c-function.sig
backend/runtime.sig
backend/profile-label.sig
backend/machine-atoms.sig
backend/switch.sig
backend/switch.fun
-backend/mtype.fun
-backend/c-function.fun
backend/runtime.fun
backend/err.sml
backend/machine.sig
1.70 +6 -6 mlton/mlton/mlton.cm
Index: mlton.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton.cm,v
retrieving revision 1.69
retrieving revision 1.70
diff -u -r1.69 -r1.70
--- mlton.cm 7 Jul 2003 22:50:28 -0000 1.69
+++ mlton.cm 19 Jul 2003 01:23:25 -0000 1.70
@@ -141,6 +141,8 @@
atoms/scheme.sig
atoms/real-x.sig
atoms/profile-exp.sig
+atoms/c-type.sig
+atoms/c-function.sig
atoms/cons.sig
atoms/int-x.sig
atoms/const.sig
@@ -152,11 +154,11 @@
xml/xml-tree.sig
xml/sxml-tree.sig
xml/sxml-tree.fun
+../lib/mlton/basic/counter.sig
+../lib/mlton/basic/counter.sml
../lib/mlton/basic/dot-color.sml
../lib/mlton/basic/dot.sig
../lib/mlton/basic/dot.sml
-../lib/mlton/basic/counter.sig
-../lib/mlton/basic/counter.sml
../lib/mlton/basic/tree.sig
../lib/mlton/basic/tree.sml
../lib/mlton/basic/directed-graph.sig
@@ -232,6 +234,8 @@
atoms/ffi.fun
atoms/const.fun
atoms/cons.fun
+atoms/c-type.fun
+atoms/c-function.fun
atoms/atoms.fun
ssa/ssa-tree.sig
ssa/direct-exp.sig
@@ -310,15 +314,11 @@
atoms/hash-type.fun
ssa/ssa-tree.fun
ssa/ssa.fun
-backend/mtype.sig
-backend/c-function.sig
backend/runtime.sig
backend/profile-label.sig
backend/machine-atoms.sig
backend/switch.sig
backend/switch.fun
-backend/mtype.fun
-backend/c-function.fun
backend/runtime.fun
backend/err.sml
backend/machine.sig
1.12 +17 -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.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- ast-core.fun 24 Jun 2003 20:14:21 -0000 1.11
+++ ast-core.fun 19 Jul 2003 01:23:26 -0000 1.12
@@ -244,7 +244,23 @@
structure PrimKind =
struct
- datatype t = BuildConst | Const | Export | FFI | Prim
+ structure Attribute =
+ struct
+ datatype t = Cdecl | Stdcall
+
+ val toString: t -> string =
+ fn Cdecl => "cdecl"
+ | Stdcall => "stdcall"
+
+ val layout = Layout.str o toString
+ end
+
+ datatype t =
+ BuildConst
+ | Const
+ | Export of Attribute.t list
+ | Import of Attribute.t list
+ | Prim
end
datatype expNode =
1.8 +13 -1 mlton/mlton/ast/ast-core.sig
Index: ast-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- ast-core.sig 24 Jun 2003 20:14:21 -0000 1.7
+++ ast-core.sig 19 Jul 2003 01:23:26 -0000 1.8
@@ -81,7 +81,19 @@
structure PrimKind:
sig
- datatype t = BuildConst | Const | Export | FFI | Prim
+ structure Attribute:
+ sig
+ datatype t = Cdecl | Stdcall
+
+ val layout: t -> Layout.t
+ end
+
+ datatype t =
+ BuildConst
+ | Const
+ | Export of Attribute.t list
+ | Import of Attribute.t list
+ | Prim
end
structure Exp:
1.9 +9 -4 mlton/mlton/atoms/atoms.fun
Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- atoms.fun 24 Jun 2003 20:14:21 -0000 1.8
+++ atoms.fun 19 Jul 2003 01:23:26 -0000 1.9
@@ -40,9 +40,12 @@
end
structure Con = Con (structure AstId = Ast.Con
structure Var = Var)
- structure Ffi = Ffi (structure IntSize = IntSize
- structure RealSize = RealSize
- structure WordSize = WordSize)
+ structure CType = CType (structure IntSize = IntSize
+ structure RealSize = RealSize
+ structure WordSize = WordSize)
+ structure CFunction = CFunction (structure CType = CType)
+ structure Ffi = Ffi (structure CFunction = CFunction
+ structure CType = CType)
structure IntX = IntX (structure IntSize = IntSize)
structure RealX = RealX (structure RealSize = RealSize)
structure WordX = WordX (structure WordSize = WordSize)
@@ -50,7 +53,9 @@
structure IntX = IntX
structure RealX = RealX
structure WordX = WordX)
- structure Prim = Prim (structure Con = Con
+ structure Prim = Prim (structure CFunction = CFunction
+ structure CType = CType
+ structure Con = Con
structure Const = Const
structure IntSize = IntSize
structure Longid = Ast.Longvid
1.9 +8 -3 mlton/mlton/atoms/atoms.sig
Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- atoms.sig 24 Jun 2003 20:14:21 -0000 1.8
+++ atoms.sig 19 Jul 2003 01:23:26 -0000 1.9
@@ -17,6 +17,8 @@
sig
include ATOMS_STRUCTS
+ structure CFunction: C_FUNCTION
+ structure CType: C_TYPE
structure Con: CON
structure Cons: SET
structure Const: CONST
@@ -52,11 +54,14 @@
sharing Ast.Tycon = Tycon.AstId
sharing Ast.Tyvar = Scheme.Tyvar
sharing Ast.Var = Var.AstId
+ sharing CFunction = Ffi.CFunction = Prim.CFunction
+ sharing CFunction.CType = CType = Ffi.CType = Prim.CType
sharing Con = Prim.Con
sharing Const = Prim.Const
- sharing IntSize = Ffi.IntSize = IntX.IntSize = Prim.IntSize = Tycon.IntSize
+ sharing IntSize = CType.IntSize = IntX.IntSize = Prim.IntSize =
+ Tycon.IntSize
sharing IntX = Const.IntX
- sharing RealSize = Ffi.RealSize = Prim.RealSize = RealX.RealSize
+ sharing RealSize = CType.RealSize = Prim.RealSize = RealX.RealSize
= Tycon.RealSize
sharing RealX = Const.RealX
sharing Record = Ast.Record
@@ -65,7 +70,7 @@
sharing SourceInfo = ProfileExp.SourceInfo
sharing Tycon = Scheme.Tycon
sharing Tyvar = Ast.Tyvar
- sharing WordSize = Ffi.WordSize = Prim.WordSize = Tycon.WordSize
+ sharing WordSize = CType.WordSize = Prim.WordSize = Tycon.WordSize
= WordX.WordSize
sharing WordX = Const.WordX
sharing type Con.t = Cons.Element.t
1.4 +21 -51 mlton/mlton/atoms/ffi.fun
Index: ffi.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/ffi.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- ffi.fun 9 Jul 2003 01:03:41 -0000 1.3
+++ ffi.fun 19 Jul 2003 01:23:26 -0000 1.4
@@ -3,59 +3,24 @@
open S
-structure Type =
- struct
- datatype t =
- Bool
- | Char
- | Int of IntSize.t
- | Pointer
- | Real of RealSize.t
- | Word of WordSize.t
+structure Convention = CFunction.Convention
- 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,
+val exports: {args: CType.t vector,
+ convention: Convention.t,
id: int,
name: string,
- res: Type.t option} list ref = ref []
+ res: CType.t option} list ref = ref []
fun numExports () = List.length (!exports)
local
val exportCounter = Counter.new 0
in
- fun addExport {args, name, res} =
+ fun addExport {args, convention, name, res} =
let
val id = Counter.next exportCounter
val _ = List.push (exports, {args = args,
+ convention = convention,
id = id,
name = name,
res = res})
@@ -68,7 +33,7 @@
fun declareExports {print} =
let
- val maxMap = Type.memo (fn _ => ref ~1)
+ val maxMap = CType.memo (fn _ => ref ~1)
fun bump (t, i) =
let
val r = maxMap t
@@ -79,14 +44,14 @@
List.foreach
(!exports, fn {args, res, ...} =>
let
- val map = Type.memo (fn _ => Counter.new 0)
+ val map = CType.memo (fn _ => Counter.new 0)
in
Vector.foreach (args, fn t => bump (t, Counter.next (map t)))
; Option.app (res, fn t => bump (t, 0))
end)
(* Declare the arrays and functions used for parameter passing. *)
val _ =
- Type.memo
+ CType.memo
(fn t =>
let
val n = !(maxMap t)
@@ -95,7 +60,7 @@
then
let
val size = Int.toString (1 + n)
- val t = Type.toString t
+ val t = CType.toString t
in
print (concat [t, " MLton_FFI_", t, "[", size, "];\n"])
; print (concat [t, " MLton_FFI_get", t, " (Int i) {\n",
@@ -114,17 +79,17 @@
"}\n"])
in
List.foreach
- (!exports, fn {args, id, name, res} =>
+ (!exports, fn {args, convention, id, name, res} =>
let
val varCounter = Counter.new 0
- val map = Type.memo (fn _ => Counter.new 0)
+ val map = CType.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
+ val t = CType.toString t
in
(x,
concat [t, " ", x],
@@ -134,8 +99,13 @@
val header =
concat [case res of
NONE => "void"
- | SOME t => Type.toString t,
- " ", name, " (",
+ | SOME t => CType.toString t,
+ if convention <> Convention.Cdecl
+ then concat [" __attribute__ ((",
+ Convention.toString convention,
+ ")) "]
+ else " ",
+ name, " (",
concat (List.separate (Vector.toListMap (args, #2), ", ")),
")"]
val _ = List.push (headers, header)
@@ -148,7 +118,7 @@
NONE => ()
| SOME t =>
print (concat
- ["\treturn MLton_FFI_", Type.toString t, "[0];\n"]))
+ ["\treturn MLton_FFI_", CType.toString t, "[0];\n"]))
; print "}\n"
end)
end
1.3 +6 -20 mlton/mlton/atoms/ffi.sig
Index: ffi.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/ffi.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- ffi.sig 24 Jun 2003 22:58:39 -0000 1.2
+++ ffi.sig 19 Jul 2003 01:23:26 -0000 1.3
@@ -3,34 +3,20 @@
signature FFI_STRUCTS =
sig
- structure IntSize: INT_SIZE
- structure RealSize: REAL_SIZE
- structure WordSize: WORD_SIZE
+ structure CFunction: C_FUNCTION
+ structure CType: C_TYPE
+ sharing CFunction.CType = CType
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,
+ val addExport: {args: CType.t vector,
+ convention: CFunction.Convention.t,
name: string,
- res: Type.t option} -> int
+ res: CType.t option} -> 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.55 +30 -12 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.54
retrieving revision 1.55
diff -u -r1.54 -r1.55
--- prim.fun 2 Jul 2003 15:08:16 -0000 1.54
+++ prim.fun 19 Jul 2003 01:23:26 -0000 1.55
@@ -68,7 +68,9 @@
| Exn_setExtendExtra (* implement exceptions *)
| Exn_setInitExtra (* implement exceptions *)
| Exn_setTopLevelHandler (* implement exceptions *)
- | FFI of string (* ssa to rssa *)
+ | FFI of CFunction.t (* ssa to rssa *)
+ | FFI_Symbol of {name: string,
+ ty: CType.t}
| FFI_getPointer
| FFI_setPointer
| GC_collect (* ssa to rssa *)
@@ -451,7 +453,8 @@
case n of
BuildConstant s => s
| Constant s => s
- | FFI s => s
+ | FFI f => CFunction.name f
+ | FFI_Symbol {name, ...} => name
| _ => (case List.peek (strings, fn (n', _, _) => n = n') of
NONE => Error.bug "Prim.toString missing name"
| SOME (_, _, s) => s)
@@ -490,6 +493,19 @@
val mayOverflow = Name.mayOverflow o name
val mayRaise = Name.mayRaise o name
+structure CType =
+ struct
+ open CType
+
+ val toType =
+ memo (fn t =>
+ case t of
+ Int s => Type.int s
+ | Pointer => Type.pointer
+ | Real s => Type.real s
+ | Word s => Type.word s)
+ end
+
structure Scheme =
struct
open Scheme
@@ -533,12 +549,11 @@
let
val k =
case n of
- Name.FFI _ =>
- (if isSome (Scheme.numArgs s)
- then Kind.SideEffect
- else Kind.DependsOnState)
+ Name.FFI _ => Kind.SideEffect
+ | Name.FFI_Symbol _ => Kind.DependsOnState
| _ => (case List.peek (Name.strings, fn (n', _, _) => n = n') of
- NONE => Error.bug "strange name"
+ NONE => Error.bug (concat ["strange name: ",
+ Name.toString n])
| SOME (_, k, _) => k)
in
new (n, k, s)
@@ -631,14 +646,17 @@
val wordToIntX = make (Name.Word_toIntX, word, int)
end
- fun ffi (name: string, s: Scheme.t) =
- new (Name.FFI name, s)
+ fun ffi (f: CFunction.t, s: Scheme.t) =
+ new (Name.FFI f, s)
+
+ fun newNullary f = new0 (Name.FFI f, unit --> unit)
- fun newNullary (name: string) = new0 (Name.FFI name, unit --> unit)
+ val allocTooLarge = newNullary CFunction.allocTooLarge
- val allocTooLarge = newNullary "MLton_allocTooLarge"
+ fun ffiSymbol (z as {ty, ...}) =
+ new (Name.FFI_Symbol z, Scheme.fromType (CType.toType ty))
end
-
+
val new: string * Scheme.t -> t =
fn (name, scheme) =>
let
1.42 +16 -8 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- prim.sig 24 Jun 2003 20:14:22 -0000 1.41
+++ prim.sig 19 Jul 2003 01:23:26 -0000 1.42
@@ -9,6 +9,8 @@
signature PRIM_STRUCTS =
sig
+ structure CFunction: C_FUNCTION
+ structure CType: C_TYPE
structure Con: CON
structure Const: CONST
structure IntSize: INT_SIZE
@@ -16,10 +18,13 @@
structure Scheme: SCHEME
structure Type: TYPE
structure WordSize: WORD_SIZE
- sharing IntSize = Const.IntX.IntSize = Type.Tycon.IntSize
- sharing RealSize = Const.RealX.RealSize = Type.Tycon.RealSize
+ sharing CFunction.CType = CType
+ sharing IntSize = CType.IntSize = Const.IntX.IntSize = Type.Tycon.IntSize
+ sharing RealSize = CType.RealSize = Const.RealX.RealSize
+ = Type.Tycon.RealSize
sharing Type = Scheme.Type
- sharing WordSize = Const.WordX.WordSize = Type.Tycon.WordSize
+ sharing WordSize = CType.WordSize = Const.WordX.WordSize
+ = Type.Tycon.WordSize
end
signature PRIM =
@@ -53,9 +58,11 @@
| Exn_setExtendExtra (* implement exceptions *)
| Exn_setInitExtra (* implement exceptions *)
| Exn_setTopLevelHandler (* implement exceptions *)
- | FFI of string (* ssa to rssa *)
- | FFI_getPointer
- | FFI_setPointer
+ | FFI of CFunction.t (* ssa to rssa *)
+ | FFI_Symbol of {name: string,
+ ty: CType.t} (* codegen *)
+ | FFI_getPointer (* ssa to rssa *)
+ | FFI_setPointer (* ssa to rssa *)
| GC_collect (* ssa to rssa *)
| GC_pack (* ssa to rssa *)
| GC_unpack (* ssa to rssa *)
@@ -261,7 +268,8 @@
deref: 'a -> 'a,
devector: 'a -> 'a,
deweak: 'a -> 'a} -> 'a vector
- val ffi: string * Scheme.t -> t
+ val ffi: CFunction.t * Scheme.t -> t
+ val ffiSymbol: {name: string, ty: CType.t} -> t
val gcCollect: t
val intInfEqual: t
val intAdd: IntSize.t -> t
@@ -291,7 +299,7 @@
val maySideEffect: t -> bool
val name: t -> Name.t
val new: string * Scheme.t -> t
- val newNullary: string -> t (* new of type unit -> unit *)
+ val newNullary: CFunction.t -> t (* new of type unit -> unit *)
val numArgs: t -> int option
val reff: t
val scheme: t -> Scheme.t
1.14 +6 -0 mlton/mlton/atoms/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- sources.cm 24 Jun 2003 20:14:22 -0000 1.13
+++ sources.cm 19 Jul 2003 01:23:26 -0000 1.14
@@ -12,6 +12,8 @@
signature ID
signature ID_NO_AST
signature INT_X
+signature C_FUNCTION
+signature C_TYPE
signature CON
signature CONST
signature FFI
@@ -47,6 +49,10 @@
atoms.fun
atoms.sig
+c-function.sig
+c-function.fun
+c-type.sig
+c-type.fun
cons.fun
cons.sig
const.fun
1.1 mlton/mlton/atoms/c-function.fun
Index: c-function.fun
===================================================================
functor CFunction (S: C_FUNCTION_STRUCTS): C_FUNCTION =
struct
open S
structure Convention =
struct
datatype t =
Cdecl
| Stdcall
val toString =
fn Cdecl => "cdecl"
| Stdcall => "stdcall"
val layout = Layout.str o toString
end
datatype t = T of {args: CType.t vector,
bytesNeeded: int option,
convention: Convention.t,
ensuresBytesFree: bool,
mayGC: bool,
maySwitchThreads: bool,
modifiesFrontier: bool,
modifiesStackTop: bool,
name: string,
return: CType.t option}
fun layout (T {args, bytesNeeded, convention, ensuresBytesFree, mayGC,
maySwitchThreads, modifiesFrontier, modifiesStackTop, name,
return}) =
Layout.record
[("args", Vector.layout CType.layout args),
("bytesNeeded", Option.layout Int.layout bytesNeeded),
("convention", Convention.layout convention),
("ensuresBytesFree", Bool.layout ensuresBytesFree),
("mayGC", Bool.layout mayGC),
("maySwitchThreads", Bool.layout maySwitchThreads),
("modifiesFrontier", Bool.layout modifiesFrontier),
("modifiesStackTop", Bool.layout modifiesStackTop),
("name", String.layout name),
("return", Option.layout CType.layout return)]
local
fun make f (T r) = f r
in
val args = make #args
val bytesNeeded = make #bytesNeeded
val convention = make #convention
val ensuresBytesFree = make #ensuresBytesFree
val mayGC = make #mayGC
val maySwitchThreads = make #maySwitchThreads
val modifiesFrontier = make #modifiesFrontier
val modifiesStackTop = make #modifiesStackTop
val name = make #name
val return = make #return
end
fun equals (f, f') = name f = name f'
fun isOk (T {ensuresBytesFree, mayGC, maySwitchThreads, modifiesFrontier,
modifiesStackTop, return, ...}): bool =
(if maySwitchThreads
then mayGC andalso Option.isNone return
else true)
andalso
(if ensuresBytesFree orelse maySwitchThreads
then mayGC
else true)
andalso
(if mayGC
then (modifiesFrontier andalso modifiesStackTop)
else true)
val isOk = Trace.trace ("CFunction.isOk", layout, Bool.layout) isOk
val equals =
Trace.trace2 ("CFunction.equals", layout, layout, Bool.layout) equals
datatype z = datatype CType.t
datatype z = datatype Convention.t
local
open CType
in
datatype z = datatype IntSize.t
datatype z = datatype WordSize.t
end
val Int32 = Int I32
val Word32 = Word W32
local
fun make b =
T {args = let
open CType
in
Vector.new5 (Pointer, Word32, Int32, Pointer, Int32)
end,
bytesNeeded = NONE,
convention = Cdecl,
ensuresBytesFree = true,
mayGC = true,
maySwitchThreads = b,
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_gc",
return = NONE}
val t = make true
val f = make false
in
fun gc {maySwitchThreads = b} = if b then t else f
end
fun vanilla {args, name, return} =
T {args = args,
bytesNeeded = NONE,
convention = Cdecl,
ensuresBytesFree = false,
mayGC = false,
maySwitchThreads = false,
modifiesFrontier = false,
modifiesStackTop = false,
name = name,
return = return}
val allocTooLarge =
vanilla {args = Vector.new0 (),
name = "MLton_allocTooLarge",
return = NONE}
val bug = vanilla {args = Vector.new1 Pointer,
name = "MLton_bug",
return = NONE}
val profileEnter =
vanilla {args = Vector.new1 Pointer,
name = "GC_profileEnter",
return = NONE}
val profileInc =
vanilla {args = Vector.new2 (Pointer, Word32),
name = "GC_profileInc",
return = NONE}
val profileLeave =
vanilla {args = Vector.new1 Pointer,
name = "GC_profileLeave",
return = NONE}
val size =
vanilla {args = Vector.new1 Pointer,
name = "MLton_size",
return = SOME CType.defaultInt}
val returnToC =
T {args = Vector.new0 (),
bytesNeeded = NONE,
convention = Cdecl,
ensuresBytesFree = false,
modifiesFrontier = true,
modifiesStackTop = true,
mayGC = true,
maySwitchThreads = true,
name = "Thread_returnToC",
return = NONE}
fun prototype (T {args, convention, name, return, ...}) =
let
val c = Counter.new 0
fun arg t = concat [CType.toString t, " x", Int.toString (Counter.next c)]
in
concat [case return of
NONE => "void"
| SOME t => CType.toString t,
if convention <> Convention.Cdecl
then concat [" __attribute__ ((",
Convention.toString convention,
")) "]
else " ",
name, " (",
concat (List.separate (Vector.toListMap (args, arg), ", ")),
")"]
end
end
1.1 mlton/mlton/atoms/c-function.sig
Index: c-function.sig
===================================================================
type int = Int.t
signature C_FUNCTION_STRUCTS =
sig
structure CType: C_TYPE
end
signature C_FUNCTION =
sig
include C_FUNCTION_STRUCTS
structure Convention:
sig
datatype t = Cdecl | Stdcall
val layout: t -> Layout.t
val toString: t -> string
end
datatype t = T of {
args: CType.t vector,
(* bytesNeeded = SOME i means that the i'th
* argument to the function is a word that
* specifies the number of bytes that must be
* free in order for the C function to succeed.
* Limit check insertion is responsible for
* making sure that the bytesNeeded is available.
*)
bytesNeeded: int option,
convention: Convention.t,
ensuresBytesFree: bool,
mayGC: bool,
maySwitchThreads: bool,
modifiesFrontier: bool,
modifiesStackTop: bool,
name: string,
return: CType.t option}
val allocTooLarge: t
val args: t -> CType.t vector
val bug: t
val bytesNeeded: t -> int option
val ensuresBytesFree: t -> bool
val equals: t * t -> bool
val gc: {maySwitchThreads: bool} -> t
val isOk: t -> bool
val layout: t -> Layout.t
val mayGC: t -> bool
val maySwitchThreads: t -> bool
val modifiesFrontier: t -> bool
val modifiesStackTop: t -> bool
val name: t -> string
val profileEnter: t
val profileInc: t
val profileLeave: t
val prototype: t -> string
(* returnToC is not really a C function. Calls to it must be handled
* specially by each codegen to ensure that the C stack is handled
* correctly. However, for the purposes of everything up to the
* backend it looks like a call to C.
*)
val returnToC: t
val return: t -> CType.t option
val size: t
val vanilla: {args: CType.t vector,
name: string,
return: CType.t option} -> t
end
1.1 mlton/mlton/atoms/c-type.fun
Index: c-type.fun
===================================================================
functor CType (S: C_TYPE_STRUCTS): C_TYPE =
struct
open S
datatype z = datatype IntSize.t
datatype z = datatype WordSize.t
datatype t =
Int of IntSize.t
| Pointer
| Real of RealSize.t
| Word of WordSize.t
val bool = Int I32
val char = Word W8
val defaultInt = Int IntSize.default
val defaultReal = Real RealSize.default
val defaultWord = Word WordSize.default
val pointer = Pointer
val all =
List.map (IntSize.all, Int)
@ [Pointer]
@ List.map (RealSize.all, Real)
@ List.map (WordSize.all, Word)
val equals: t * t -> bool =
fn (Int s, Int s') => IntSize.equals (s, s')
| (Pointer, Pointer) => true
| (Real s, Real s') => RealSize.equals (s, s')
| (Word s, Word s') => WordSize.equals (s, s')
| _ => false
val isPointer: t -> bool =
fn Pointer => true
| _ => false
fun memo (f: t -> 'a): t -> 'a =
let
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 Int s => int s
| Pointer => pointer
| Real s => real s
| Word s => word s
end
val toString =
memo
(fn u =>
case u of
Int s => concat ["Int", IntSize.toString s]
| Pointer => "Pointer"
| Real s => concat ["Real", RealSize.toString s]
| Word s => concat ["Word", WordSize.toString s])
val layout = Layout.str o toString
fun size (t: t): int =
case t of
Int s => IntSize.bytes s
| Pointer => 4
| Real s => RealSize.bytes s
| Word s => WordSize.bytes s
fun name t =
case t of
Int s => concat ["I", IntSize.toString s]
| Pointer => "P"
| Real s => concat ["R", RealSize.toString s]
| Word s => concat ["W", WordSize.toString s]
local
fun align a b =
let
open Word
val a = fromInt a - 0w1
in
toInt (andb (notb a, a + fromInt b))
end
in
val align4 = align 4
val align8 = align 8
val align: t * int -> int = fn (ty, n) => align (size ty) n
end
end
1.1 mlton/mlton/atoms/c-type.sig
Index: c-type.sig
===================================================================
type int = Int.t
signature C_TYPE_STRUCTS =
sig
structure IntSize: INT_SIZE
structure RealSize: REAL_SIZE
structure WordSize: WORD_SIZE
end
signature C_TYPE =
sig
include C_TYPE_STRUCTS
datatype t =
Int of IntSize.t
| Pointer
| Real of RealSize.t
| Word of WordSize.t
val align4: int -> int
val align8: int -> int
val align: t * int -> int (* align an address *)
val all: t list
val bool: t
val char: t
val defaultInt: t
val defaultReal: t
val defaultWord: t
val equals: t * t -> bool
val isPointer: t -> bool
val memo: (t -> 'a) -> t -> 'a
(* name: R{32,64} I{8,16,32,64] P W[8,16,32] *)
val name: t -> string
val pointer: t
val layout: t -> Layout.t
val size: t -> int (* bytes *)
val toString: t -> string
end
1.29 +13 -12 mlton/mlton/backend/allocate-registers.fun
Index: allocate-registers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/allocate-registers.fun,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- allocate-registers.fun 23 Jun 2003 05:59:34 -0000 1.28
+++ allocate-registers.fun 19 Jul 2003 01:23:26 -0000 1.29
@@ -28,6 +28,7 @@
local
open Machine
in
+ structure CType = CType
structure Operand = Operand
structure Register = Register
structure Runtime = Runtime
@@ -158,8 +159,8 @@
* that the register indices that the codegens use are based on
* runtime types.
*)
- datatype t = T of Runtime.Type.t -> {alloc: Register.t list,
- next: int} ref
+ datatype t = T of CType.t -> {alloc: Register.t list,
+ next: int} ref
fun layout (T f) =
List.layout
@@ -167,11 +168,11 @@
let
val {alloc, next} = ! (f t)
in
- Layout.record [("ty", Runtime.Type.layout t),
+ Layout.record [("ty", CType.layout t),
("next", Int.layout next),
("alloc", List.layout Register.layout alloc)]
end)
- Runtime.Type.all
+ CType.all
fun compress {next, alloc} =
let
@@ -194,19 +195,19 @@
fun new (rs: Register.t list): t =
let
fun sameType (r, r') =
- Runtime.Type.equals
- (Type.toRuntime (Register.ty r),
- Type.toRuntime (Register.ty r'))
+ CType.equals
+ (Type.toCType (Register.ty r),
+ Type.toCType (Register.ty r'))
val rss = List.equivalence (rs, sameType)
in
- T (Runtime.Type.memo
+ T (CType.memo
(fn t =>
case List.peek (rss, fn rs =>
case rs of
[] => false
| r :: _ =>
- Runtime.Type.equals
- (t, Type.toRuntime (Register.ty r))) of
+ CType.equals
+ (t, Type.toCType (Register.ty r))) of
NONE => ref {alloc = [], next = 0}
| SOME rs =>
ref
@@ -221,7 +222,7 @@
fun get (T f, ty: Type.t) =
let
- val t = Type.toRuntime ty
+ val t = Type.toCType ty
val r = f t
val {alloc, next} = !r
val reg = Register.new (ty, SOME next)
@@ -504,7 +505,7 @@
in
case !Control.align of
Control.Align4 => size
- | Control.Align8 => Runtime.Type.align8 size
+ | Control.Align8 => CType.align8 size
end
val _ =
Vector.foreach (args, fn (x, _) =>
1.57 +5 -4 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -r1.56 -r1.57
--- backend.fun 7 Jul 2003 22:50:28 -0000 1.56
+++ backend.fun 19 Jul 2003 01:23:26 -0000 1.57
@@ -33,7 +33,6 @@
local
open Runtime
in
- structure CFunction = CFunction
structure GCField = GCField
end
val wordSize = Runtime.wordSize
@@ -44,6 +43,8 @@
local
open Rssa
in
+ structure CFunction = CFunction
+ structure CType = CType
structure Const = Const
structure Func = Func
structure Function = Function
@@ -1000,7 +1001,7 @@
fun chunkToMachine (Chunk.T {chunkLabel, blocks}) =
let
val blocks = Vector.fromList (!blocks)
- val regMax = Runtime.Type.memo (fn _ => ref ~1)
+ val regMax = CType.memo (fn _ => ref ~1)
val regsNeedingIndex =
Vector.fold
(blocks, [], fn (b, ac) =>
@@ -1012,7 +1013,7 @@
NONE => r :: ac
| SOME i =>
let
- val z = regMax (Type.toRuntime (Register.ty r))
+ val z = regMax (Type.toCType (Register.ty r))
val _ =
if i > !z
then z := i
@@ -1025,7 +1026,7 @@
List.foreach
(regsNeedingIndex, fn r =>
let
- val z = regMax (Type.toRuntime (Register.ty r))
+ val z = regMax (Type.toCType (Register.ty r))
val i = 1 + !z
val _ = z := i
val _ = Register.setIndex (r, i)
1.10 +1 -0 mlton/mlton/backend/backend.sig
Index: backend.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- backend.sig 23 Jun 2003 04:58:56 -0000 1.9
+++ backend.sig 19 Jul 2003 01:23:26 -0000 1.10
@@ -12,6 +12,7 @@
sig
structure Machine: MACHINE
structure Ssa: SSA
+ sharing Machine.CFunction = Ssa.CFunction
sharing Machine.IntX = Ssa.IntX
sharing Machine.Label = Ssa.Label
sharing Machine.Prim = Ssa.Prim
1.39 +10 -8 mlton/mlton/backend/limit-check.fun
Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- limit-check.fun 23 Jun 2003 04:58:56 -0000 1.38
+++ limit-check.fun 19 Jul 2003 01:23:26 -0000 1.39
@@ -129,14 +129,16 @@
val l = Label.newNoname ()
val _ = r := SOME l
val cfunc =
- CFunction.make {bytesNeeded = NONE,
- ensuresBytesFree = false,
- mayGC = false,
- maySwitchThreads = false,
- modifiesFrontier = false,
- modifiesStackTop = false,
- name = "MLton_allocTooLarge",
- returnTy = NONE}
+ CFunction.T {args = Vector.new0 (),
+ bytesNeeded = NONE,
+ convention = CFunction.Convention.Cdecl,
+ ensuresBytesFree = false,
+ mayGC = false,
+ maySwitchThreads = false,
+ modifiesFrontier = false,
+ modifiesStackTop = false,
+ name = "MLton_allocTooLarge",
+ return = NONE}
val _ =
newBlocks :=
Block.T {args = Vector.new0 (),
1.10 +19 -21 mlton/mlton/backend/machine-atoms.fun
Index: machine-atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- machine-atoms.fun 23 Jun 2003 04:58:56 -0000 1.9
+++ machine-atoms.fun 19 Jul 2003 01:23:26 -0000 1.10
@@ -259,33 +259,31 @@
pointers = {enum = Vector.new0 (), pointers = pointers}}
local
- structure R = Runtime.Type
+ structure C = CType
in
- val fromRuntime: Runtime.Type.t -> t =
- fn t =>
- case R.dest t of
- R.Int s => int s
- | R.Pointer => cpointer
- | R.Real s => real s
- | R.Word s => word s
+ val fromCType: CType.t -> t =
+ fn C.Int s => int s
+ | C.Pointer => cpointer
+ | C.Real s => real s
+ | C.Word s => word s
- val toRuntime: t -> Runtime.Type.t =
- fn CPointer => R.pointer
+ val toCType: t -> CType.t =
+ fn CPointer => C.pointer
| EnumPointers {enum, pointers} =>
if 0 = Vector.length pointers
- then R.defaultInt
- else R.pointer
- | ExnStack => R.defaultWord
- | Int s => R.int s
- | IntInf => R.pointer
- | Label _ => R.defaultWord
- | MemChunk _ => R.pointer
- | Real s => R.real s
- | Word s => R.word s
+ then C.defaultInt
+ else C.pointer
+ | ExnStack => C.defaultWord
+ | Int s => C.Int s
+ | IntInf => C.Pointer
+ | Label _ => C.defaultWord
+ | MemChunk _ => C.pointer
+ | Real s => C.Real s
+ | Word s => C.Word s
- val name = R.name o toRuntime
+ val name = C.name o toCType
- fun align (t: t, n: int): int = R.align (toRuntime t, n)
+ fun align (t: t, n: int): int = C.align (toCType t, n)
end
val equals =
1.12 +8 -5 mlton/mlton/backend/machine-atoms.sig
Index: machine-atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- machine-atoms.sig 23 Jun 2003 04:58:56 -0000 1.11
+++ machine-atoms.sig 19 Jul 2003 01:23:26 -0000 1.12
@@ -9,6 +9,8 @@
signature MACHINE_ATOMS_STRUCTS =
sig
+ structure CFunction: C_FUNCTION
+ structure CType: C_TYPE
structure IntSize: INT_SIZE
structure IntX: INT_X
structure Label: HASH_ID
@@ -19,9 +21,10 @@
structure SourceInfo: SOURCE_INFO
structure WordSize: WORD_SIZE
structure WordX: WORD_X
- sharing IntSize = IntX.IntSize = Prim.IntSize = Runtime.IntSize
- sharing RealSize = Prim.RealSize = RealX.RealSize = Runtime.RealSize
- sharing WordSize = Prim.WordSize = Runtime.WordSize = WordX.WordSize
+ sharing CType = CFunction.CType = Runtime.CType
+ sharing IntSize = CType.IntSize = IntX.IntSize = Prim.IntSize
+ sharing RealSize = CType.RealSize = Prim.RealSize = RealX.RealSize
+ sharing WordSize = CType.WordSize = Prim.WordSize = WordX.WordSize
end
signature MACHINE_ATOMS =
@@ -75,7 +78,7 @@
val defaultWord: t
val equals: t * t -> bool
val exnStack: t
- val fromRuntime: Runtime.Type.t -> t
+ val fromCType: CType.t -> t
val int: IntSize.t -> t
val intInf: t
val isPointer: t -> bool
@@ -88,7 +91,7 @@
val size: t -> int
val stack: t
val thread: t
- val toRuntime: t -> Runtime.Type.t
+ val toCType: t -> CType.t
val toString: t -> string
val word: WordSize.t -> t
val wordVector: t
1.51 +8 -13 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -r1.50 -r1.51
--- machine.fun 7 Jul 2003 22:50:28 -0000 1.50
+++ machine.fun 19 Jul 2003 01:23:26 -0000 1.51
@@ -19,13 +19,10 @@
datatype z = datatype RealSize.t
datatype z = datatype WordSize.t
-structure Runtime = Runtime (structure IntSize = IntSize
- structure RealSize = RealSize
- structure WordSize = WordSize)
+structure Runtime = Runtime (structure CType = CType)
local
open Runtime
in
- structure CFunction = CFunction
structure GCField = GCField
end
@@ -92,8 +89,7 @@
(case (indexOpt r, indexOpt r') of
(SOME i, SOME i') => i = i'
| _ => false)
- andalso Runtime.Type.equals (Type.toRuntime (ty r),
- Type.toRuntime (ty r'))
+ andalso CType.equals (Type.toCType (ty r), Type.toCType (ty r'))
val equals =
Trace.trace2 ("Register.equals", layout, layout, Bool.layout) equals
@@ -128,7 +124,7 @@
val nonRootCounter = Counter.new 0
fun numberOfNonRoot () = Counter.value nonRootCounter
- val memo = Runtime.Type.memo (fn _ => Counter.new 0)
+ val memo = CType.memo (fn _ => Counter.new 0)
fun numberOfType t = Counter.value (memo t)
fun new {isRoot, ty} =
@@ -136,7 +132,7 @@
val isRoot = isRoot orelse not (Type.isPointer ty)
val counter =
if isRoot
- then memo (Type.toRuntime ty)
+ then memo (Type.toCType ty)
else nonRootCounter
val g = T {index = Counter.next counter,
isRoot = isRoot,
@@ -603,7 +599,7 @@
struct
datatype t = T of {blocks: Block.t vector,
chunkLabel: ChunkLabel.t,
- regMax: Runtime.Type.t -> int}
+ regMax: CType.t -> int}
fun layout (T {blocks, ...}) =
let
@@ -1409,13 +1405,12 @@
andalso (Option.equals
(fi, fi', FrameInfo.equals))
andalso
- (case (dst, CFunction.returnTy f) of
+ (case (dst, CFunction.return f) of
(NONE, _) => true
| (SOME x, SOME ty) =>
- Runtime.Type.equals
+ CType.equals
(ty,
- Type.toRuntime
- (Operand.ty x))
+ Type.toCType (Operand.ty x))
| _ => false)
| _ => false
end
1.39 +10 -8 mlton/mlton/backend/machine.sig
Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- machine.sig 7 Jul 2003 22:50:28 -0000 1.38
+++ machine.sig 19 Jul 2003 01:23:26 -0000 1.39
@@ -10,15 +10,19 @@
signature MACHINE_STRUCTS =
sig
+ structure CFunction: C_FUNCTION
+ structure CType: C_TYPE
structure IntX: INT_X
structure Label: HASH_ID
structure Prim: PRIM
structure SourceInfo: SOURCE_INFO
structure RealX: REAL_X
structure WordX: WORD_X
- sharing IntX.IntSize = Prim.IntSize
- sharing RealX.RealSize = Prim.RealSize
- sharing WordX.WordSize = Prim.WordSize
+ sharing CFunction = Prim.CFunction
+ sharing CFunction.CType = CType = Prim.CType = Prim.CFunction.CType
+ sharing CType.IntSize = IntX.IntSize = Prim.IntSize
+ sharing CType.RealSize = RealX.RealSize = Prim.RealSize
+ sharing CType.WordSize = WordX.WordSize = Prim.WordSize
end
signature MACHINE =
@@ -31,8 +35,6 @@
sharing PointerTycon = Switch.PointerTycon
sharing Type = Switch.Type
sharing WordX = Switch.WordX
- structure CFunction: C_FUNCTION
- sharing CFunction = Runtime.CFunction
structure ChunkLabel: ID_NO_AST
structure Register:
@@ -59,7 +61,7 @@
val layout: t -> Layout.t
val new: {isRoot: bool, ty: Type.t} -> t
val numberOfNonRoot: unit -> int
- val numberOfType: Runtime.Type.t -> int
+ val numberOfType: CType.t -> int
val toString: t -> string
val ty: t -> Type.t
end
@@ -208,10 +210,10 @@
T of {blocks: Block.t vector,
chunkLabel: ChunkLabel.t,
(* Register.index r
- * <= regMax (Type.toRuntime (Register.ty r))
+ * <= regMax (Type.toCType (Register.ty r))
* for all registers in the chunk.
*)
- regMax: Runtime.Type.t -> int}
+ regMax: CType.t -> int}
end
structure ProfileInfo:
1.17 +2 -3 mlton/mlton/backend/representation.fun
Index: representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- representation.fun 24 Jun 2003 17:31:25 -0000 1.16
+++ representation.fun 19 Jul 2003 01:23:26 -0000 1.17
@@ -16,6 +16,7 @@
local
open Rssa
in
+ structure CType = CType
structure IntSize = IntSize
structure ObjectType = ObjectType
structure PointerTycon = PointerTycon
@@ -282,9 +283,7 @@
if isNormal
then
let
- val offset =
- Runtime.Type.align
- (Runtime.Type.pointer, offset)
+ val offset = CType.align (CType.pointer, offset)
in
if !Control.align = Control.Align8
andalso
1.34 +1 -1 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- rssa.fun 23 Jun 2003 04:58:57 -0000 1.33
+++ rssa.fun 19 Jul 2003 01:23:26 -0000 1.34
@@ -67,7 +67,7 @@
| Line => Type.int IntSize.default
| Offset {ty, ...} => ty
| PointerTycon _ => Type.word WordSize.default
- | Runtime z => Type.fromRuntime (GCField.ty z)
+ | Runtime z => Type.fromCType (GCField.ty z)
| SmallIntInf _ => Type.IntInf
| Var {ty, ...} => ty
1.26 +0 -2 mlton/mlton/backend/rssa.sig
Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- rssa.sig 23 Jun 2003 04:58:57 -0000 1.25
+++ rssa.sig 19 Jul 2003 01:23:26 -0000 1.26
@@ -36,8 +36,6 @@
sharing PointerTycon = Switch.PointerTycon
sharing Type = Switch.Type
sharing WordX = Switch.WordX
- structure CFunction: C_FUNCTION
- sharing CFunction = Runtime.CFunction
structure Operand:
sig
1.15 +12 -16 mlton/mlton/backend/runtime.fun
Index: runtime.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- runtime.fun 23 Jun 2003 04:58:57 -0000 1.14
+++ runtime.fun 19 Jul 2003 01:23:26 -0000 1.15
@@ -9,10 +9,6 @@
open S
-structure Type = Mtype (S)
-
-structure CFunction = CFunction (structure Type = Type)
-
structure GCField =
struct
datatype t =
@@ -32,18 +28,18 @@
val equals: t * t -> bool = op =
val ty =
- fn CanHandle => Type.defaultInt
- | CardMap => Type.pointer
- | CurrentThread => Type.pointer
- | ExnStack => Type.defaultWord
- | Frontier => Type.pointer
- | Limit => Type.pointer
- | LimitPlusSlop => Type.pointer
- | MaxFrameSize => Type.defaultWord
- | SignalIsPending => Type.defaultInt
- | StackBottom => Type.pointer
- | StackLimit => Type.pointer
- | StackTop => Type.pointer
+ fn CanHandle => CType.defaultInt
+ | CardMap => CType.pointer
+ | CurrentThread => CType.pointer
+ | ExnStack => CType.defaultWord
+ | Frontier => CType.pointer
+ | Limit => CType.pointer
+ | LimitPlusSlop => CType.pointer
+ | MaxFrameSize => CType.defaultWord
+ | SignalIsPending => CType.defaultInt
+ | StackBottom => CType.pointer
+ | StackLimit => CType.pointer
+ | StackTop => CType.pointer
val canHandleOffset: int ref = ref 0
val cardMapOffset: int ref = ref 0
1.24 +2 -10 mlton/mlton/backend/runtime.sig
Index: runtime.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.sig,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- runtime.sig 23 Jun 2003 04:58:57 -0000 1.23
+++ runtime.sig 19 Jul 2003 01:23:26 -0000 1.24
@@ -10,21 +10,13 @@
signature RUNTIME_STRUCTS =
sig
- structure IntSize: INT_SIZE
- structure RealSize: REAL_SIZE
- structure WordSize: WORD_SIZE
+ structure CType: C_TYPE
end
signature RUNTIME =
sig
include RUNTIME_STRUCTS
- structure Type: MTYPE
- sharing IntSize = Type.IntSize
- sharing RealSize = Type.RealSize
- sharing WordSize = Type.WordSize
- structure CFunction: C_FUNCTION
- sharing Type = CFunction.Type
structure GCField:
sig
datatype t =
@@ -57,7 +49,7 @@
stackLimit: int,
stackTop: int} -> unit
val toString: t -> string
- val ty: t -> Type.t
+ val ty: t -> CType.t
end
structure ObjectType:
sig
1.16 +0 -4 mlton/mlton/backend/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/sources.cm,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- sources.cm 23 Jun 2003 04:58:57 -0000 1.15
+++ sources.cm 19 Jul 2003 01:23:26 -0000 1.16
@@ -26,8 +26,6 @@
allocate-registers.sig
backend.fun
backend.sig
-c-function.fun
-c-function.sig
chunkify.fun
chunkify.sig
equivalence-graph.fun
@@ -43,8 +41,6 @@
machine.sig
machine-atoms.fun
machine-atoms.sig
-mtype.fun
-mtype.sig
parallel-move.fun
parallel-move.sig
profile.fun
1.42 +156 -93 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.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- ssa-to-rssa.fun 24 Jun 2003 20:14:22 -0000 1.41
+++ ssa-to-rssa.fun 19 Jul 2003 01:23:26 -0000 1.42
@@ -23,148 +23,222 @@
structure GCField = GCField
end
+datatype z = datatype IntSize.t
datatype z = datatype WordSize.t
structure CFunction =
struct
- open CFunction
+ open CFunction
+
+ local
+ open CType
+ in
+ val Int32 = Int I32
+ val Word32 = Word W32
+ end
+
+ datatype z = datatype CType.t
+ datatype z = datatype Convention.t
local
fun make (name, i) =
- CFunction.make {bytesNeeded = SOME i,
- ensuresBytesFree = false,
- mayGC = false,
- maySwitchThreads = false,
- modifiesFrontier = true,
- modifiesStackTop = false,
- name = name,
- returnTy = SOME Type.pointer}
+ CFunction.T {args = Vector.new3 (Pointer, Pointer, Word32),
+ bytesNeeded = SOME i,
+ convention = Cdecl,
+ ensuresBytesFree = false,
+ mayGC = false,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = false,
+ name = name,
+ return = SOME CType.pointer}
in
val intInfAdd = make ("IntInf_do_add", 2)
val intInfAndb = make ("IntInf_do_andb", 2)
- val intInfArshift = make ("IntInf_do_arshift", 2)
val intInfGcd = make ("IntInf_do_gcd", 2)
- val intInfLshift = make ("IntInf_do_lshift", 2)
val intInfMul = make ("IntInf_do_mul", 2)
- val intInfNeg = make ("IntInf_do_neg", 1)
- val intInfNotb = make ("IntInf_do_notb", 1)
val intInfOrb = make ("IntInf_do_orb", 2)
val intInfQuot = make ("IntInf_do_quot", 2)
val intInfRem = make ("IntInf_do_rem", 2)
val intInfSub = make ("IntInf_do_sub", 2)
- val intInfToString = make ("IntInf_do_toString", 2)
val intInfXorb = make ("IntInf_do_xorb", 2)
end
- val getPointer =
- vanilla {name = "MLton_FFI_getPointer",
- returnTy = SOME Type.pointer}
+ local
+ fun make (name, i) =
+ CFunction.T {args = Vector.new3 (Pointer, Word32, Word32),
+ bytesNeeded = SOME i,
+ convention = Cdecl,
+ ensuresBytesFree = false,
+ mayGC = false,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = false,
+ name = name,
+ return = SOME CType.pointer}
+ in
+ val intInfArshift = make ("IntInf_do_arshift", 2)
+ val intInfLshift = make ("IntInf_do_lshift", 2)
+ end
- val setPointer =
- vanilla {name = "MLton_FFI_setPointer",
- returnTy = NONE}
-
+ local
+ fun make (name, i) =
+ CFunction.T {args = Vector.new2 (Pointer, Word32),
+ bytesNeeded = SOME i,
+ convention = Cdecl,
+ ensuresBytesFree = false,
+ mayGC = false,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = false,
+ name = name,
+ return = SOME CType.pointer}
+ in
+ val intInfNeg = make ("IntInf_do_neg", 1)
+ val intInfNotb = make ("IntInf_do_notb", 1)
+ end
+
+ val intInfToString =
+ CFunction.T {args = Vector.new3 (Pointer, Int32, Word32),
+ bytesNeeded = SOME 2,
+ convention = Cdecl,
+ ensuresBytesFree = false,
+ mayGC = false,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = false,
+ name = "IntInf_do_toString",
+ return = SOME Pointer}
local
- fun make name = vanilla {name = name,
- returnTy = SOME Type.defaultInt}
+ fun make name = vanilla {args = Vector.new2 (Pointer, Pointer),
+ name = name,
+ return = SOME CType.defaultInt}
in
val intInfCompare = make "IntInf_compare"
val intInfEqual = make "IntInf_equal"
end
-
+
+ val getPointer =
+ vanilla {args = Vector.new1 Int32,
+ name = "MLton_FFI_getPointer",
+ return = SOME Pointer}
+
+ val setPointer =
+ vanilla {args = Vector.new1 Pointer,
+ name = "MLton_FFI_setPointer",
+ return = NONE}
+
val copyCurrentThread =
- make {bytesNeeded = NONE,
- ensuresBytesFree = false,
- mayGC = true,
- maySwitchThreads = false,
- modifiesFrontier = true,
- modifiesStackTop = true,
- name = "GC_copyCurrentThread",
- returnTy = NONE}
+ T {args = Vector.new1 Pointer,
+ bytesNeeded = NONE,
+ convention = Cdecl,
+ ensuresBytesFree = false,
+ mayGC = true,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = "GC_copyCurrentThread",
+ return = NONE}
val copyThread =
- make {bytesNeeded = NONE,
- ensuresBytesFree = false,
- mayGC = true,
- maySwitchThreads = false,
- modifiesFrontier = true,
- modifiesStackTop = true,
- name = "GC_copyThread",
- returnTy = SOME Type.pointer}
+ T {args = Vector.new2 (Pointer, Pointer),
+ bytesNeeded = NONE,
+ convention = Cdecl,
+ ensuresBytesFree = false,
+ mayGC = true,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = "GC_copyThread",
+ return = SOME Pointer}
val exit =
- make {bytesNeeded = NONE,
+ T {args = Vector.new1 Int32,
+ bytesNeeded = NONE,
+ convention = Cdecl,
ensuresBytesFree = false,
mayGC = false,
maySwitchThreads = false,
modifiesFrontier = true,
modifiesStackTop = true,
name = "MLton_exit",
- returnTy = NONE}
+ return = NONE}
val gcArrayAllocate =
- make {bytesNeeded = NONE,
- ensuresBytesFree = true,
+ T {args = Vector.new4 (Pointer, Word32, Word32, Word32),
+ bytesNeeded = NONE,
+ convention = Cdecl,
+ ensuresBytesFree = true,
+ mayGC = true,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = "GC_arrayAllocate",
+ return = SOME Pointer}
+
+ local
+ fun make name =
+ T {args = Vector.new1 Pointer,
+ bytesNeeded = NONE,
+ convention = Cdecl,
+ ensuresBytesFree = false,
mayGC = true,
maySwitchThreads = false,
modifiesFrontier = true,
modifiesStackTop = true,
- name = "GC_arrayAllocate",
- returnTy = SOME Type.pointer}
-
- local
- fun make name =
- CFunction.make {bytesNeeded = NONE,
- ensuresBytesFree = false,
- mayGC = true,
- maySwitchThreads = false,
- modifiesFrontier = true,
- modifiesStackTop = true,
- name = name,
- returnTy = NONE}
+ name = name,
+ return = NONE}
in
val pack = make "GC_pack"
val unpack = make "GC_unpack"
end
val threadSwitchTo =
- make {bytesNeeded = NONE,
+ T {args = Vector.new2 (Pointer, Word32),
+ bytesNeeded = NONE,
+ convention = Cdecl,
ensuresBytesFree = true,
mayGC = true,
maySwitchThreads = true,
modifiesFrontier = true,
modifiesStackTop = true,
name = "Thread_switchTo",
- returnTy = NONE}
+ return = NONE}
val weakCanGet =
- vanilla {name = "GC_weakCanGet",
- returnTy = SOME Type.bool}
+ vanilla {args = Vector.new1 Pointer,
+ name = "GC_weakCanGet",
+ return = SOME CType.bool}
val weakGet =
- vanilla {name = "GC_weakGet",
- returnTy = SOME Type.pointer}
+ vanilla {args = Vector.new1 Pointer,
+ name = "GC_weakGet",
+ return = SOME Pointer}
val weakNew =
- make {bytesNeeded = NONE,
- ensuresBytesFree = false,
- mayGC = true,
- maySwitchThreads = false,
- modifiesFrontier = true,
- modifiesStackTop = true,
- name = "GC_weakNew",
- returnTy = SOME Type.pointer}
+ T {args = Vector.new3 (Pointer, Word32, Pointer),
+ bytesNeeded = NONE,
+ convention = Cdecl,
+ ensuresBytesFree = false,
+ mayGC = true,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = "GC_weakNew",
+ return = SOME Pointer}
val worldSave =
- make {bytesNeeded = NONE,
- ensuresBytesFree = false,
- mayGC = true,
- maySwitchThreads = false,
- modifiesFrontier = true,
- modifiesStackTop = true,
- name = "GC_saveWorld",
- returnTy = NONE}
+ T {args = Vector.new2 (Pointer, Int32),
+ bytesNeeded = NONE,
+ convention = Cdecl,
+ ensuresBytesFree = false,
+ mayGC = true,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = "GC_saveWorld",
+ return = NONE}
end
datatype z = datatype Operand.t
@@ -863,7 +937,7 @@
prefix: Transfer.t -> (Statement.t list
* Transfer.t)} =
let
- val (formals, returnTy) =
+ val (formals, return) =
case dst () of
NONE => (Vector.new0 (), NONE)
| SOME (x, t) =>
@@ -1058,21 +1132,10 @@
(case targ () of
NONE => none ()
| SOME ty => arrayUpdate ty)
- | FFI name =>
+ | FFI f =>
if Option.isNone (Prim.numArgs prim)
then normal ()
- else
- simpleCCall
- (CFunction.make
- {bytesNeeded = NONE,
- ensuresBytesFree = false,
- modifiesFrontier = callsFromC,
- modifiesStackTop = callsFromC,
- mayGC = callsFromC,
- maySwitchThreads = false,
- name = name,
- returnTy = Option.map (toRtype ty,
- Type.toRuntime)})
+ else simpleCCall f
| FFI_getPointer =>
simpleCCall CFunction.getPointer
| FFI_setPointer =>
1.8 +1 -0 mlton/mlton/backend/ssa-to-rssa.sig
Index: ssa-to-rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- ssa-to-rssa.sig 2 Jan 2003 17:45:15 -0000 1.7
+++ ssa-to-rssa.sig 19 Jul 2003 01:23:27 -0000 1.8
@@ -12,6 +12,7 @@
sig
structure Rssa: RSSA
structure Ssa: SSA
+ sharing Rssa.CFunction = Ssa.CFunction
sharing Rssa.Const = Ssa.Const
sharing Rssa.Func = Ssa.Func
sharing Rssa.Label = Ssa.Label
1.62 +28 -56 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.61
retrieving revision 1.62
diff -u -r1.61 -r1.62
--- c-codegen.fun 17 Jul 2003 00:01:28 -0000 1.61
+++ c-codegen.fun 19 Jul 2003 01:23:27 -0000 1.62
@@ -14,6 +14,8 @@
open Machine
in
structure Block = Block
+ structure CFunction = CFunction
+ structure CType = CType
structure Chunk = Chunk
structure ChunkLabel = ChunkLabel
structure FrameInfo = FrameInfo
@@ -48,7 +50,6 @@
local
open Runtime
in
- structure CFunction = CFunction
structure GCField = GCField
end
@@ -193,8 +194,8 @@
| _ => false
end
-fun creturn (t: Runtime.Type.t): string =
- concat ["CReturn", Runtime.Type.name t]
+fun creturn (t: CType.t): string =
+ concat ["CReturn", CType.name t]
fun outputIncludes (includes, print) =
(List.foreach (includes, fn i => (print "#include <";
@@ -213,13 +214,13 @@
val _ = print (concat [prefix, "struct GC_state gcState;\n"])
val _ =
List.foreach
- (Runtime.Type.all, fn t =>
+ (CType.all, fn t =>
let
- val s = Runtime.Type.toString t
+ val s = CType.toString t
in
print (concat [prefix, s, " global", s,
" [", C.int (Global.numberOfType t), "];\n"])
- ; print (concat [prefix, s, " CReturn", Runtime.Type.name t, ";\n"])
+ ; print (concat [prefix, s, " CReturn", CType.name t, ";\n"])
end)
val _ =
print (concat [prefix, "Pointer globalPointerNonRoot [",
@@ -248,16 +249,16 @@
val _ =
(print "static void saveGlobals (int fd) {\n"
; (List.foreach
- (Runtime.Type.all, fn t =>
+ (CType.all, fn t =>
print (concat ["\tSaveArray (global",
- Runtime.Type.toString t, ", fd);\n"])))
+ CType.toString t, ", fd);\n"])))
; print "}\n")
val _ =
(print "static void loadGlobals (FILE *file) {\n"
; (List.foreach
- (Runtime.Type.all, fn t =>
+ (CType.all, fn t =>
print (concat ["\tLoadArray (global",
- Runtime.Type.toString t, ", file);\n"])))
+ CType.toString t, ", file);\n"])))
; print "}\n")
in
()
@@ -680,10 +681,7 @@
")"]
fun app (): string =
case Prim.name prim of
- Prim.Name.FFI s =>
- (case Prim.numArgs prim of
- NONE => s
- | SOME _ => call ())
+ Prim.Name.FFI_Symbol {name, ...} => name
| _ => call ()
in
case dst of
@@ -726,51 +724,26 @@
case s of
Statement.PrimApp {prim, ...} =>
(case Prim.name prim of
- Prim.Name.FFI name =>
+ Prim.Name.FFI_Symbol {name, ty} =>
doit
(name, fn () =>
- let
- val ty =
- Prim.Type.toC
- (Prim.Scheme.ty
- (Prim.scheme prim))
- in
- concat
- ["extern ", ty, " ", name, ";\n"]
- end)
+ concat
+ ["extern ", CType.toString ty,
+ " ", name, ";\n"])
| _ => ())
| _ => ())
val _ =
case transfer of
Transfer.CCall {args, func, ...} =>
let
- val {name, returnTy, ...} = CFunction.dest func
+ val CFunction.T {name, ...} = func
in
if name = "Thread_returnToC"
then ()
else
- doit
- (name, fn () =>
- let
- val res =
- case returnTy of
- NONE => "void"
- | SOME t => CFunction.Type.toString t
- val c = Counter.new 0
- fun arg z =
- concat [Type.toC (Operand.ty z),
- " x",
- Int.toString (Counter.next c)]
- in
- (concat
- [res, " ",
- CFunction.name func,
- " (",
- concat (List.separate
- (Vector.toListMap (args, arg),
- ", ")),
- ");\n"])
- end)
+ doit (name, fn () =>
+ concat [CFunction.prototype func,
+ ";\n"])
end
| _ => ()
in
@@ -944,7 +917,7 @@
["\t",
move {dst = operandToString x,
dstIsMem = Operand.isMem x,
- src = creturn (Type.toRuntime ty),
+ src = creturn (Type.toCType ty),
srcIsMem = false,
ty = ty}])
end)))
@@ -1040,11 +1013,10 @@
end
| CCall {args, frameInfo, func, return} =>
let
- val {maySwitchThreads,
- modifiesFrontier,
- modifiesStackTop,
- name, returnTy, ...} =
- CFunction.dest func
+ val CFunction.T {maySwitchThreads,
+ modifiesFrontier,
+ modifiesStackTop,
+ name, return = returnTy, ...} = func
val (args, afterCall) =
case frameInfo of
NONE =>
@@ -1189,10 +1161,10 @@
end
fun declareRegisters () =
List.foreach
- (Runtime.Type.all, fn t =>
+ (CType.all, fn t =>
let
- val pre = concat ["\t", Runtime.Type.toString t, " ",
- Runtime.Type.name t, "_"]
+ val pre = concat ["\t", CType.toString t, " ",
+ CType.name t, "_"]
in
Int.for (0, 1 + regMax t, fn i =>
print (concat [pre, C.int i, ";\n"]))
1.9 +2 -0 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.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- c-codegen.sig 17 Jul 2003 00:01:29 -0000 1.8
+++ c-codegen.sig 19 Jul 2003 01:23:27 -0000 1.9
@@ -12,6 +12,8 @@
sig
structure Ffi: FFI
structure Machine: MACHINE
+ sharing Machine.CType = Machine.Prim.CFunction.CType
+ sharing Ffi.CFunction = Machine.CFunction
end
signature C_CODEGEN =
1.45 +10 -7 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.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- x86-codegen.fun 17 Jul 2003 00:01:29 -0000 1.44
+++ x86-codegen.fun 19 Jul 2003 01:23:27 -0000 1.45
@@ -9,10 +9,13 @@
struct
open S
+ structure CType = Machine.CType
+
structure x86
- = x86(structure Label = Machine.Label
- structure ProfileLabel = Machine.ProfileLabel
- structure Runtime = Machine.Runtime)
+ = x86 (structure CFunction = Machine.CFunction
+ structure Label = Machine.Label
+ structure ProfileLabel = Machine.ProfileLabel
+ structure Runtime = Machine.Runtime)
structure x86MLtonBasic
= x86MLtonBasic(structure x86 = x86
@@ -73,7 +76,7 @@
then Int.toString n
else if n = Int.minInt
then "(int)0x80000000" (* because of goofy gcc warning *)
- else "-" ^ String.dropPrefix(Int.toString n, 1)
+ else concat ["-", String.dropPrefix (Int.toString n, 1)]
(* This overflows on Int32.minInt: Int32.toString(~ n) *)
end
@@ -164,7 +167,7 @@
end
fun declareLocals () =
List.foreach
- (Runtime.Type.all,
+ (CType.all,
fn t =>
let
val m =
@@ -173,8 +176,8 @@
Int.max (max, regMax t))
val m = m + 1
in
- print (concat [Runtime.Type.toString t,
- " local", Runtime.Type.toString t,
+ print (concat [CType.toString t,
+ " local", CType.toString t,
"[", Int.toString m, "];\n"])
end)
fun rest () =
1.8 +1 -1 mlton/mlton/codegen/x86-codegen/x86-entry-transfer.fun
Index: x86-entry-transfer.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-entry-transfer.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- x86-entry-transfer.fun 11 Jul 2002 02:16:49 -0000 1.7
+++ x86-entry-transfer.fun 19 Jul 2003 01:23:27 -0000 1.8
@@ -41,7 +41,7 @@
| _ => false
fun isCReturn l f = case get l
of SOME (Block.T {entry = Entry.CReturn {func, ...}, ...})
- => Runtime.CFunction.equals (f, func)
+ => CFunction.equals (f, func)
| _ => false
val b = List.forall
(blocks,
1.42 +7 -7 mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun
Index: x86-generate-transfers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- x86-generate-transfers.fun 15 May 2003 14:50:57 -0000 1.41
+++ x86-generate-transfers.fun 19 Jul 2003 01:23:27 -0000 1.42
@@ -1075,10 +1075,10 @@
end
| CCall {args, dstsize, frameInfo, func, return, target}
=> let
- val {maySwitchThreads,
- modifiesFrontier,
- modifiesStackTop,
- name, ...} = CFunction.dest func
+ val CFunction.T {convention,
+ maySwitchThreads,
+ modifiesFrontier,
+ modifiesStackTop, ...} = func
val stackTopMinusWordDeref
= x86MLton.gcState_stackTopMinusWordDerefOperand ()
val {dead, ...}
@@ -1087,7 +1087,6 @@
val c_stackP = x86MLton.c_stackPContentsOperand
val c_stackPDerefDouble = x86MLton.c_stackPDerefDoubleOperand
val applyFFTemp = x86MLton.applyFFTempContentsOperand
-
val (pushArgs, size_args)
= List.fold
(args, (AppendList.empty, 0),
@@ -1287,8 +1286,9 @@
(Assembly.directive_fltreturn
{memloc = MemLoc.cReturnTempContents dstsize})
| _ => Error.bug "CCall")
- val fixCStack
- = if size_args > 0
+ val fixCStack =
+ if size_args > 0
+ andalso convention = CFunction.Convention.Cdecl
then (AppendList.single
(Assembly.instruction_binal
{oper = Instruction.ADD,
1.12 +1 -1 mlton/mlton/codegen/x86-codegen/x86-jump-info.fun
Index: x86-jump-info.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-jump-info.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- x86-jump-info.fun 25 Mar 2003 04:31:25 -0000 1.11
+++ x86-jump-info.fun 19 Jul 2003 01:23:27 -0000 1.12
@@ -66,7 +66,7 @@
| Entry.Cont {label, ...} => forceNear (jumpInfo, label)
| Entry.Handler {label, ...} => forceNear (jumpInfo, label)
| Entry.CReturn {label, func, ...}
- => if Runtime.CFunction.maySwitchThreads func
+ => if CFunction.maySwitchThreads func
then forceNear (jumpInfo, label)
else ();
List.foreach
1.14 +1 -1 mlton/mlton/codegen/x86-codegen/x86-loop-info.fun
Index: x86-loop-info.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-loop-info.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- x86-loop-info.fun 12 Feb 2003 05:11:27 -0000 1.13
+++ x86-loop-info.fun 19 Jul 2003 01:23:27 -0000 1.14
@@ -113,7 +113,7 @@
| Raise {...}
=> ()
| CCall {return, func, ...}
- => Option.app (return, if Runtime.CFunction.mayGC func
+ => Option.app (return, if CFunction.mayGC func
then doit''
else doit')
end)
1.20 +12 -8 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun
Index: x86-mlton-basic.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- x86-mlton-basic.fun 23 Jun 2003 04:58:58 -0000 1.19
+++ x86-mlton-basic.fun 19 Jul 2003 01:23:27 -0000 1.20
@@ -12,8 +12,10 @@
open x86
structure Runtime = Machine.Runtime
+ structure CFunction = Machine.CFunction
+ structure CType = CFunction.CType
local
- open Runtime
+ open CType
in
structure IntSize = IntSize
structure RealSize = RealSize
@@ -36,7 +38,7 @@
val intInfOverheadBytes = Runtime.intInfOverheadSize
local
- datatype z = datatype Runtime.Type.dest
+ datatype z = datatype CType.t
datatype z = datatype x86.Size.t
in
fun toX86Size' t =
@@ -69,8 +71,8 @@
| W16 => WORD
| W32 => LONG
end
- val toX86Size = fn t => toX86Size' (Runtime.Type.dest t)
- fun toX86Scale t = x86.Scale.fromBytes (Runtime.Type.size t)
+ val toX86Size = toX86Size'
+ fun toX86Scale t = x86.Scale.fromBytes (CType.size t)
end
(*
@@ -285,10 +287,11 @@
val localW_base =
WordSize.memoize
(fn s => Label.fromString (concat ["localWord", WordSize.toString s]))
- datatype z = datatype Runtime.Type.dest
+ datatype z = datatype CType.t
+ datatype z = datatype IntSize.t
in
fun local_base ty =
- case Runtime.Type.dest ty of
+ case ty of
Int s => localI_base s
| Pointer => localP_base
| Real s => localR_base s
@@ -309,10 +312,11 @@
make ("Real", RealSize.memoize, RealSize.toString)
val (globalW_base, globalW_num) =
make ("Word", WordSize.memoize, WordSize.toString)
- datatype z = datatype Runtime.Type.dest
+ datatype z = datatype CType.t
+ datatype z = datatype IntSize.t
in
fun global_base ty =
- case Runtime.Type.dest ty of
+ case ty of
Int s => globalI_base s
| Pointer => globalP_base
| Real s => globalR_base s
1.25 +7 -6 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig
Index: x86-mlton-basic.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- x86-mlton-basic.sig 15 May 2003 14:50:57 -0000 1.24
+++ x86-mlton-basic.sig 19 Jul 2003 01:23:27 -0000 1.25
@@ -12,8 +12,9 @@
sig
structure x86 : X86_PSEUDO
structure Machine: MACHINE
+ sharing x86.CFunction = Machine.CFunction
sharing x86.Label = Machine.Label
- sharing type x86.ProfileLabel.t = Machine.ProfileLabel.t
+ sharing x86.ProfileLabel = Machine.ProfileLabel
sharing x86.Runtime = Machine.Runtime
end
@@ -36,8 +37,8 @@
val arrayHeaderBytes : int
val intInfOverheadBytes : int
- val toX86Size : x86.Runtime.Type.t -> x86.Size.t
- val toX86Scale : x86.Runtime.Type.t -> x86.Scale.t
+ val toX86Size : x86.CFunction.CType.t -> x86.Size.t
+ val toX86Scale : x86.CFunction.CType.t -> x86.Scale.t
(*
* Memory classes
@@ -87,8 +88,8 @@
val statusTempContentsOperand : x86.Operand.t
(* Static arrays defined in main.h and x86-main.h *)
- val local_base : x86.Runtime.Type.t -> x86.Label.t
- val global_base : x86.Runtime.Type.t -> x86.Label.t
+ val local_base : x86.CFunction.CType.t -> x86.Label.t
+ val global_base : x86.CFunction.CType.t -> x86.Label.t
val globalPointerNonRoot_base : x86.Label.t
(* Static functions defined in main.h *)
@@ -102,7 +103,7 @@
(* gcState relative locations defined in gc.h *)
val gcState_label: x86.Label.t
- val gcState_offset: {offset: int, ty: x86.Runtime.Type.t} -> x86.Operand.t
+ val gcState_offset: {offset: int, ty: x86.CFunction.CType.t} -> x86.Operand.t
val gcState_exnStackContents: unit -> x86.MemLoc.t
val gcState_exnStackContentsOperand: unit -> x86.Operand.t
val gcState_frontierContents: unit -> x86.MemLoc.t
1.46 +35 -28 mlton/mlton/codegen/x86-codegen/x86-mlton.fun
Index: x86-mlton.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.fun,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- x86-mlton.fun 25 Jun 2003 23:15:31 -0000 1.45
+++ x86-mlton.fun 19 Jul 2003 01:23:27 -0000 1.46
@@ -568,37 +568,33 @@
size = dstsize}],
transfer = NONE}]
end
- | FFI s
- => (case Prim.numArgs prim
- of NONE
- => let
- val (dst,dstsize) = getDst ()
-
- val memloc
- = x86.MemLoc.makeContents
- {base = Immediate.label (Label.fromString s),
- size = dstsize,
- class = Classes.CStatic}
- in
- AppendList.fromList
- [Block.mkBlock'
- {entry = NONE,
- statements
- = [case Size.class dstsize
- of Size.INT
- => Assembly.instruction_mov
- {dst = dst,
- src = Operand.memloc memloc,
- size = dstsize}
- | Size.FLT
+ | FFI_Symbol {name, ...}
+ => let
+ val (dst,dstsize) = getDst ()
+ val memloc
+ = x86.MemLoc.makeContents
+ {base = Immediate.label (Label.fromString name),
+ size = dstsize,
+ class = Classes.CStatic}
+ in
+ AppendList.fromList
+ [Block.mkBlock'
+ {entry = NONE,
+ statements
+ = [case Size.class dstsize
+ of Size.INT
+ => Assembly.instruction_mov
+ {dst = dst,
+ src = Operand.memloc memloc,
+ size = dstsize}
+ | Size.FLT
=> Assembly.instruction_pfmov
{dst = dst,
src = Operand.memloc memloc,
size = dstsize}
- | _ => Error.bug "prim: FFI"],
- transfer = NONE}]
- end
- | SOME _ => Error.bug "prim: FFI")
+ | _ => Error.bug "prim: FFI"],
+ transfer = NONE}]
+ end
| Int_ge _ => cmp Instruction.GE
| Int_gt _ => cmp Instruction.G
| Int_le _ => cmp Instruction.LE
@@ -1216,7 +1212,18 @@
return: x86.Label.t option,
transInfo: transInfo}
= let
- val {name, returnTy, ...} = CFunction.dest func
+ val CFunction.T {convention, name, return = returnTy, ...} = func
+ val name =
+ if convention = CFunction.Convention.Stdcall
+ then
+ let
+ val argsSize =
+ Vector.fold (args, 0, fn ((_, s), ac) =>
+ ac + x86.Size.toBytes s)
+ in
+ concat [name, "@", Int.toString argsSize]
+ end
+ else name
val dstsize = Option.map (returnTy, toX86Size)
val comment_begin
= if !Control.Native.commented > 0
1.18 +4 -2 mlton/mlton/codegen/x86-codegen/x86-pseudo.sig
Index: x86-pseudo.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-pseudo.sig,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- x86-pseudo.sig 15 May 2003 14:50:57 -0000 1.17
+++ x86-pseudo.sig 19 Jul 2003 01:23:27 -0000 1.18
@@ -10,8 +10,10 @@
signature X86_PSEUDO =
sig
+ structure CFunction: C_FUNCTION
structure Label : HASH_ID
structure Runtime: RUNTIME
+ sharing CFunction.CType = Runtime.CType
val tracer : string -> ('a -> 'b) ->
(('a -> 'b) * (unit -> unit))
@@ -408,7 +410,7 @@
frameInfo: FrameInfo.t} -> t
val creturn: {dst: (Operand.t * Size.t) option,
frameInfo: FrameInfo.t option,
- func: Runtime.CFunction.t,
+ func: CFunction.t,
label: Label.t} -> t
val func: {label: Label.t,
live: MemLocSet.t} -> t
@@ -451,7 +453,7 @@
val ccall : {args: (Operand.t * Size.t) list,
dstsize: Size.t option,
frameInfo: FrameInfo.t option,
- func: Runtime.CFunction.t,
+ func: CFunction.t,
return: Label.t option,
target: Label.t} -> t
end
1.45 +9 -9 mlton/mlton/codegen/x86-codegen/x86-translate.fun
Index: x86-translate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-translate.fun,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- x86-translate.fun 25 Jun 2003 23:15:31 -0000 1.44
+++ x86-translate.fun 19 Jul 2003 01:23:27 -0000 1.45
@@ -55,7 +55,7 @@
fun toX86MemLoc (g: t) =
let
- val ty = Machine.Type.toRuntime (ty g)
+ val ty = Machine.Type.toCType (ty g)
val base =
x86.Immediate.label
(if isRoot g
@@ -76,14 +76,14 @@
struct
open Machine.Operand
- val toX86Size = x86MLton.toX86Size o Type.toRuntime o ty
+ val toX86Size = x86MLton.toX86Size o Type.toCType o ty
val rec toX86Operand =
fn ArrayOffset {base, index, ty} =>
let
val base = toX86Operand base
val index = toX86Operand index
- val ty = Type.toRuntime ty
+ val ty = Type.toCType ty
val memloc =
case (x86.Operand.deMemloc base,
x86.Operand.deImmediate index,
@@ -113,7 +113,7 @@
| Cast (z, _) => toX86Operand z
| Contents {oper, ty} =>
let
- val ty = Type.toRuntime ty
+ val ty = Type.toCType ty
val base = toX86Operand oper
val offset = x86.Immediate.const_int 0
val size = x86MLton.toX86Size ty
@@ -147,14 +147,14 @@
| Line => x86MLton.fileLine ()
| Offset {base = GCState, offset, ty} =>
let
- val ty = Type.toRuntime ty
+ val ty = Type.toCType ty
in
x86MLton.gcState_offset {offset = offset, ty = ty}
end
| Offset {base, offset, ty} =>
let
val base = toX86Operand base
- val ty = Type.toRuntime ty
+ val ty = Type.toCType ty
val memloc =
case x86.Operand.deMemloc base of
SOME base =>
@@ -173,7 +173,7 @@
| Real _ => Error.bug "toX86Operand: Real unimplemented"
| Register r =>
let
- val ty = Machine.Type.toRuntime (Register.ty r)
+ val ty = Machine.Type.toCType (Register.ty r)
val base = x86.Immediate.label (x86MLton.local_base ty)
in
x86.Operand.memloc
@@ -187,7 +187,7 @@
| SmallIntInf ii => x86.Operand.immediate_const_word ii
| StackOffset {offset, ty} =>
let
- val ty = Type.toRuntime ty
+ val ty = Type.toCType ty
val memloc =
x86.MemLoc.simple
{base = x86MLton.gcState_stackTopContents (),
@@ -414,7 +414,7 @@
= let
val size =
x86MLton.toX86Size
- (Type.toRuntime (Operand.ty value))
+ (Type.toCType (Operand.ty value))
val value = Operand.toX86Operand value
val dst
= let
1.39 +3 -1 mlton/mlton/codegen/x86-codegen/x86.fun
Index: x86.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.fun,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- x86.fun 11 Apr 2003 04:31:10 -0000 1.38
+++ x86.fun 19 Jul 2003 01:23:27 -0000 1.39
@@ -49,6 +49,8 @@
structure CFunction = CFunction
end
+ structure CType = CFunction.CType
+
structure Label =
struct
open Label
@@ -1198,7 +1200,7 @@
size = size,
class = class}
local
- open Runtime.Type
+ open CType
val cReturnTempBYTE = Label.fromString "cReturnTempB"
val cReturnTempBYTEContents
= makeContents {base = Immediate.label cReturnTempBYTE,
1.27 +8 -4 mlton/mlton/codegen/x86-codegen/x86.sig
Index: x86.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.sig,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- x86.sig 15 May 2003 14:50:58 -0000 1.26
+++ x86.sig 19 Jul 2003 01:23:27 -0000 1.27
@@ -10,15 +10,19 @@
signature X86_STRUCTS =
sig
+ structure CFunction: C_FUNCTION
structure Label: HASH_ID
structure ProfileLabel: PROFILE_LABEL
structure Runtime: RUNTIME
+ sharing CFunction.CType = Runtime.CType
end
signature X86 =
sig
+ structure CFunction: C_FUNCTION
structure Label: HASH_ID
structure Runtime: RUNTIME
+ sharing CFunction.CType = Runtime.CType
val tracer : string -> ('a -> 'b) ->
(('a -> 'b) * (unit -> unit))
@@ -1038,7 +1042,7 @@
live: MemLocSet.t}
| CReturn of {dst: (Operand.t * Size.t) option,
frameInfo: FrameInfo.t option,
- func: Runtime.CFunction.t,
+ func: CFunction.t,
label: Label.t}
val cont : {label: Label.t,
@@ -1046,7 +1050,7 @@
frameInfo: FrameInfo.t} -> t
val creturn: {dst: (Operand.t * Size.t) option,
frameInfo: FrameInfo.t option,
- func: Runtime.CFunction.t,
+ func: CFunction.t,
label: Label.t} -> t
val func : {label: Label.t,
live: MemLocSet.t} -> t
@@ -1127,7 +1131,7 @@
| CCall of {args: (Operand.t * Size.t) list,
dstsize: Size.t option,
frameInfo: FrameInfo.t option,
- func: Runtime.CFunction.t,
+ func: CFunction.t,
return: Label.t option,
target: Label.t}
@@ -1160,7 +1164,7 @@
val ccall: {args: (Operand.t * Size.t) list,
dstsize: Size.t option,
frameInfo: FrameInfo.t option,
- func: Runtime.CFunction.t,
+ func: CFunction.t,
return: Label.t option,
target: Label.t} -> t
end
1.22 +140 -55 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- elaborate-core.fun 5 Jul 2003 23:30:26 -0000 1.21
+++ elaborate-core.fun 19 Jul 2003 01:23:28 -0000 1.22
@@ -31,6 +31,8 @@
structure Fixop = Fixop
structure Longvid = Longvid
structure Longtycon = Longtycon
+ structure PrimKind = PrimKind
+ structure Attribute = PrimKind.Attribute
structure Record = Record
structure SortedRecord = SortedRecord
structure Strid = Strid
@@ -39,19 +41,21 @@
local open CoreML
in
+ structure CFunction = CFunction
+ structure Convention = CFunction.Convention
+ structure CType = CType
structure Con = Con
structure Cdec = Dec
structure Cexp = Exp
- structure Ffi = Ffi
structure Cmatch = Match
structure Cpat = Pat
structure Cprim = Prim
structure Cvar = Var
+ structure Ffi = Ffi
structure Scheme = Scheme
structure SourceInfo = SourceInfo
structure Tycon = Tycon
structure Type = Type
- structure Ctype = Type
structure Tyvar = Tyvar
end
@@ -324,66 +328,57 @@
val info = Trace.info "elaborateDec"
val elabExpInfo = Trace.info "elaborateExp"
-structure Ffi =
+structure CType =
struct
- open Ffi
-
- structure Type =
- struct
- open Type
+ open CoreML.CType
- val bogus = Bool
-
- val nullary =
- [(Bool, Ctype.bool),
- (Char, Ctype.con (Tycon.char, Vector.new0 ())),
- (Pointer, Ctype.pointer)]
- @ 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) option =
- case Ctype.dearrowOpt ty of
+ val nullary =
+ [(bool, Type.bool),
+ (char, Type.con (Tycon.char, Vector.new0 ())),
+ (pointer, Type.pointer),
+ (pointer, Type.preThread),
+ (pointer, Type.thread)]
+ @ List.map (IntSize.all, fn s => (Int s, Type.int s))
+ @ List.map (RealSize.all, fn s => (Real s, Type.real s))
+ @ List.map (WordSize.all, fn s => (Word s, Type.word s))
+
+ val unary = [Tycon.array, Tycon.reff, Tycon.vector]
+
+ fun fromType (t: Type.t): t option =
+ case List.peek (nullary, fn (_, t') => Type.equals (t, t')) of
+ NONE =>
+ (case Type.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 (fromType (Vector.sub (ts, 0)))
+ then SOME Pointer
+ else NONE)
+ | SOME (t, _) => SOME t
+
+ fun parse (ty: Type.t): (t vector * t option) option =
+ case Type.dearrowOpt ty of
NONE => NONE
| SOME (t1, t2) =>
let
- fun finish (ts: Type.t vector) =
- case Type.fromCtype t2 of
+ fun finish (ts: t vector) =
+ case fromType t2 of
NONE =>
- if Ctype.equals (t2, Ctype.unit)
+ if Type.equals (t2, Type.unit)
then SOME (ts, NONE)
else NONE
| SOME t => SOME (ts, SOME t)
in
- case Ctype.detupleOpt t1 of
+ case Type.detupleOpt t1 of
NONE =>
- (case Type.fromCtype t1 of
+ (case fromType t1 of
NONE => NONE
| SOME u => finish (Vector.new1 u))
| SOME ts =>
let
- val us = Vector.map (ts, Type.fromCtype)
+ val us = Vector.map (ts, fromType)
in
if Vector.forall (us, isSome)
then finish (Vector.map (us, valOf))
@@ -392,10 +387,92 @@
end
end
-fun export (name: string, ty: Type.t, region: Region.t): Aexp.t =
+fun parseAttributes (attributes: Attribute.t list): Convention.t option =
+ case attributes of
+ [] => SOME Convention.Cdecl
+ | [a] =>
+ SOME (case a of
+ Attribute.Cdecl => Convention.Cdecl
+ | Attribute.Stdcall =>
+ if !Control.hostOS = Control.Cygwin
+ then Convention.Stdcall
+ else Convention.Cdecl)
+ | _ => NONE
+
+fun import {attributes: Attribute.t list,
+ name: string,
+ ty: Type.t,
+ region: Region.t}: Cprim.t =
+ let
+ fun error l = Control.error (region, l, Layout.empty)
+ fun invalidAttributes () =
+ error (let
+ open Layout
+ in
+ seq [str "invalid attributes for import: ",
+ List.layout Attribute.layout attributes]
+ end)
+ in
+ case CType.parse ty of
+ NONE =>
+ (case CType.fromType ty of
+ NONE =>
+ (error (let
+ open Layout
+ in
+ seq [str "invalid type for import: ",
+ Type.layout ty]
+ end)
+ ; Cprim.bogus)
+ | SOME t =>
+ case attributes of
+ [] => Cprim.ffiSymbol {name = name, ty = t}
+ | _ =>
+ let
+ val _ = invalidAttributes ()
+ in
+ Cprim.bogus
+ end)
+ | SOME (args, result) =>
+ let
+ val convention =
+ case parseAttributes attributes of
+ NONE => (invalidAttributes ()
+ ; Convention.Cdecl)
+ | SOME c => c
+ val func =
+ CFunction.T {args = args,
+ bytesNeeded = NONE,
+ convention = convention,
+ ensuresBytesFree = false,
+ modifiesFrontier = true (* callsFromC *),
+ modifiesStackTop = true (* callsFromC *),
+ mayGC = true (* callsFromC *),
+ maySwitchThreads = false,
+ name = name,
+ return = result}
+ in
+ Cprim.ffi (func, Scheme.fromType ty)
+ end
+ end
+
+fun export {attributes, name: string, region: Region.t, ty: Type.t}: Aexp.t =
let
+ fun error l = Control.error (region, l, Layout.empty)
+ fun invalidAttributes () =
+ error (let
+ open Layout
+ in
+ seq [str "invalid attributes for export: ",
+ List.layout Attribute.layout attributes]
+ end)
+ val convention =
+ case parseAttributes attributes of
+ NONE => (invalidAttributes ()
+ ; Convention.Cdecl)
+ | SOME c => c
val (args, exportId, res) =
- case Ffi.parseCtype ty of
+ case CType.parse ty of
NONE =>
(Control.error
(region,
@@ -410,6 +487,7 @@
| SOME (us, t) =>
let
val id = Ffi.addExport {args = us,
+ convention = convention,
name = name,
res = t}
in
@@ -441,7 +519,7 @@
Vector.new1
(Pat.tuple (Vector.new0 ()),
let
- val map = Ffi.Type.memo (fn _ => Counter.new 0)
+ val map = CType.memo (fn _ => Counter.new 0)
val varCounter = Counter.new 0
val (args, decs) =
Vector.unzip
@@ -458,7 +536,7 @@
x,
Exp.app
(id (concat
- ["get", Ffi.Type.toString u]),
+ ["get", CType.toString u]),
int (Counter.next (map u))))
in
(x, dec)
@@ -479,7 +557,7 @@
(case res of
NONE => Exp.unit
| SOME t =>
- Exp.app (id (concat ["set", Ffi.Type.toString t]),
+ Exp.app (id (concat ["set", CType.toString t]),
Exp.var resVar)))),
fn (x, e) => Dec.vall (Vector.new0 (), x, e))],
Exp.tuple (Vector.new0 ()))
@@ -947,7 +1025,7 @@
case kind of
BuildConst => simple (Cprim.buildConstant (name, ty))
| Const => simple (Cprim.constant (name, ty))
- | Export =>
+ | Export attributes =>
let
val ty = Scheme.ty ty
in
@@ -957,11 +1035,18 @@
(E, fn () =>
(Env.openStructure (E,
valOf (!Env.Structure.ffi))
- ; elabExp' (export (name, ty, region),
+ ; elabExp' (export {attributes = attributes,
+ name = name,
+ region = region,
+ ty = ty},
nest))),
Type.arrow (ty, Type.unit)))
end
- | FFI => simple (Cprim.ffi (name, ty))
+ | Import attributes =>
+ simple (import {attributes = attributes,
+ name = name,
+ region = region,
+ ty = Scheme.ty ty})
| Prim => simple (Cprim.new (name, ty))
end
| Aexp.Raise {exn, filePos} =>
1.11 +25 -8 mlton/mlton/front-end/ml.grm
Index: ml.grm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.grm,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- ml.grm 24 Jun 2003 20:14:22 -0000 1.10
+++ ml.grm 19 Jul 2003 01:23:28 -0000 1.11
@@ -178,10 +178,10 @@
type rvb = {pat: Pat.t,
match: Match.t}
-fun ensureNonqualified (s,region) =
+fun ensureNonqualified (s, region) =
if String.contains (s, #".")
- then (error (region, "expected nonqualified id") ;
- "<bogus>")
+ then (error (region, "expected nonqualified id")
+ ; "<bogus>")
else s
fun cons1 (x, (l, r, y)) = (x :: l, r, y)
@@ -225,8 +225,8 @@
| STRUCTURE | THEN | TYPE | VAL | WHERE | WHILE | WILD | WITH | WITHTYPE
| ASTERISK | COLON | COLONGT | COMMA | LBRACE | LBRACKET | LPAREN | RBRACE
| RBRACKET | RPAREN | ORELSE | ANDALSO | FUNSIG
- (* primitives *)
- | BUILD_CONST | CONST | EXPORT | FFI | PRIM
+ (* Extensions *)
+ | BUILD_CONST | CONST | EXPORT | FFI | IMPORT | PRIM
%nonterm
aexp of Exp.node
@@ -238,6 +238,7 @@
| app_exp of Exp.t list
| app_exp1 of Exp.t list
| arg_fct of Strexp.t
+ | attributes of PrimKind.Attribute.t list
| clause of clause
| clauses of clause list
| clausesTop of clauses
@@ -910,12 +911,28 @@
(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})
+ (Exp.Prim {kind = PrimKind.Import [], name = STRING, ty = ty})
+ | EXPORT STRING attributes COLON ty SEMICOLON
+ (Exp.Prim {kind = PrimKind.Export attributes,
+ name = STRING,
+ ty = ty})
+ | IMPORT STRING attributes COLON ty SEMICOLON
+ (Exp.Prim {kind = PrimKind.Import attributes,
+ name = STRING,
+ ty = ty})
| PRIM STRING COLON ty SEMICOLON
(Exp.Prim {kind = PrimKind.Prim, name = STRING, ty = ty})
+
+attributes : ([])
+ | id attributes (case #1 id of
+ "cdecl" =>
+ PrimKind.Attribute.Cdecl :: attributes
+ | "stdcall" =>
+ PrimKind.Attribute.Stdcall :: attributes
+ | _ => (error (reg (idleft, idright),
+ concat ["invalid attribute", #1 id])
+ ; attributes))
exp_2c : exp COMMA exp_2c (exp :: exp_2c)
| exp COMMA exp ([exp1, exp2])
1.11 +1 -0 mlton/mlton/front-end/ml.lex
Index: ml.lex
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.lex,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- ml.lex 24 Jun 2003 20:14:22 -0000 1.10
+++ ml.lex 19 Jul 2003 01:23:28 -0000 1.11
@@ -141,6 +141,7 @@
yypos + size yytext));
<INITIAL>"_export" => (tok (Tokens.EXPORT, source, yypos, yypos + size yytext));
<INITIAL>"_ffi" => (tok (Tokens.FFI, source, yypos, yypos + size yytext));
+<INITIAL>"_import" => (tok (Tokens.IMPORT, source, yypos, yypos + size yytext));
<INITIAL>"_overload" => (tok (Tokens.OVERLOAD, source, yypos,
yypos + size yytext));
<INITIAL>"_prim" => (tok (Tokens.PRIM, source, yypos,
1.65 +2 -0 mlton/runtime/gc.h
Index: gc.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.h,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -r1.64 -r1.65
--- gc.h 7 Jul 2003 22:50:29 -0000 1.64
+++ gc.h 19 Jul 2003 01:23:28 -0000 1.65
@@ -671,6 +671,8 @@
void GC_switchToThread (GC_state s, GC_thread t);
+void GC_unpack (GC_state s);
+
bool GC_weakCanGet (pointer p);
pointer GC_weakGet (pointer p);
pointer GC_weakNew (GC_state s, W32 header, pointer p);
1.27 +0 -1 mlton/runtime/mlton-basis.h
Index: mlton-basis.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/mlton-basis.h,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- mlton-basis.h 5 Jul 2003 19:38:38 -0000 1.26
+++ mlton-basis.h 19 Jul 2003 01:23:28 -0000 1.27
@@ -101,7 +101,6 @@
/* MLton */
/* ------------------------------------------------- */
-void MLton_arrayTooLarge ();
/* print a bug message and exit (2) */
void MLton_bug (Pointer msg);
-------------------------------------------------------
This SF.net email is sponsored by: VM Ware
With VMware you can run multiple operating systems on a single machine.
WITHOUT REBOOTING! Mix Linux / Windows / Novell virtual machines at the
same time. Free trial click here: http://www.vmware.com/wl/offer/345/0
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel