[MLton] cvs commit: Indirect C calls.
Matthew Fluet
fluet@mlton.org
Wed, 22 Sep 2004 20:13:13 -0700
fluet 04/09/22 20:13:11
Modified: basis-library/mlton pointer.sig pointer.sml
doc changelog
doc/examples/ffi .cvsignore Makefile
doc/user-guide ffi.tex
include x86-main.h
mlton/ast ast-core.fun ast-core.sig prim-tycons.fun
mlton/atoms c-function.fun c-function.sig prim.fun
sources.mlb
mlton/backend limit-check.fun profile.fun rep-type.fun
ssa-to-rssa.fun
mlton/codegen/bytecode bytecode.fun
mlton/codegen/c-codegen c-codegen.fun
mlton/codegen/x86-codegen x86-generate-transfers.fun
x86-liveness.fun x86-mlton-basic.fun
x86-mlton-basic.sig x86-mlton.fun x86-pseudo.sig
x86.fun x86.sig
mlton/control control.sml
mlton/elaborate elaborate-core.fun scope.fun
mlton/front-end ml.grm
Added: doc/examples/ffi iimport.sml
Log:
MAIL Indirect C calls.
Please try out doc/examples/ffi/iimport.sml,
especially on non x86 platforms.
Revision Changes Path
1.4 +1 -0 mlton/basis-library/mlton/pointer.sig
Index: pointer.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/pointer.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- pointer.sig 6 Jan 2004 05:12:27 -0000 1.3
+++ pointer.sig 23 Sep 2004 03:12:51 -0000 1.4
@@ -3,6 +3,7 @@
eqtype t
val add: t * word -> t
+ val compare: t * t -> order
val diff: t * t -> word
val getInt8: t * int -> Int8.int
val getInt16: t * int -> Int16.int
1.3 +1 -0 mlton/basis-library/mlton/pointer.sml
Index: pointer.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/pointer.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- pointer.sml 12 Apr 2004 17:41:45 -0000 1.2
+++ pointer.sml 23 Sep 2004 03:12:51 -0000 1.3
@@ -4,6 +4,7 @@
open Primitive.Pointer
fun add (p, t) = fromWord (Word.+ (toWord p, t))
+fun compare (p, p') = Word.compare (toWord p, toWord p')
fun diff (p, p') = Word.- (toWord p, toWord p')
fun sub (p, t) = fromWord (Word.- (toWord p, t))
1.138 +3 -0 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.137
retrieving revision 1.138
diff -u -r1.137 -r1.138
--- changelog 14 Sep 2004 16:45:04 -0000 1.137
+++ changelog 23 Sep 2004 03:12:51 -0000 1.138
@@ -1,5 +1,8 @@
Here are the changes since version 20040227.
+* 2004-09-22
+ - Extended _import to support indirect function calls.
+
* 2004-09-13
- Made Date.{fromString,scan} accept a space (treated as zero) in
the first character of the day of the month.
1.3 +1 -2 mlton/doc/examples/ffi/.cvsignore
Index: .cvsignore
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/.cvsignore,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- .cvsignore 24 Jun 2003 20:14:21 -0000 1.2
+++ .cvsignore 23 Sep 2004 03:12:52 -0000 1.3
@@ -1,5 +1,4 @@
export
export.h
import
-
-
+dimport
\ No newline at end of file
1.13 +5 -1 mlton/doc/examples/ffi/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/Makefile,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- Makefile 4 Aug 2004 03:15:08 -0000 1.12
+++ Makefile 23 Sep 2004 03:12:52 -0000 1.13
@@ -3,9 +3,10 @@
mlton = mlton -default-ann 'allowExport true, allowImport true'
.PHONY: all
-all: import export
+all: import export iimport
./import
./export
+ ./iimport
export: export.sml ffi-export.c
$(mlton) -export-header export.h -stop tc export.sml
@@ -17,6 +18,9 @@
ffi-import.o:
$(mlton) -stop o ffi-import.c
+
+iimport: iimport.sml
+ $(mlton) -link-opt '-ldl' iimport.sml
clean:
../../../bin/clean
1.1 mlton/doc/examples/ffi/iimport.sml
Index: iimport.sml
===================================================================
signature DYN_LINK =
sig
type hndl
type mode
type fptr
val dlopen : string * mode -> hndl
val dlsym : hndl * string -> fptr
val dlclose : hndl -> unit
val RTLD_LAZY : mode
val RTLD_NOW : mode
end
structure DynLink :> DYN_LINK =
struct
type hndl = MLton.Pointer.t
type mode = Word32.word
type fptr = MLton.Pointer.t
val dlopen =
_import "dlopen" : string * mode -> hndl;
val dlerror =
_import "dlerror": unit -> MLton.Pointer.t;
val dlsym =
_import "dlsym" : hndl * string -> fptr;
val dlclose =
_import "dlclose" : hndl -> Int32.int;
val RTLD_LAZY = 0wx00001 (* Lazy function call binding. *)
val RTLD_NOW = 0wx00002 (* Immediate function call binding. *)
val dlerror = fn () =>
let
val addr = dlerror ()
in
if addr = MLton.Pointer.null
then NONE
else let
fun loop (index, cs) =
let
val w = MLton.Pointer.getWord8 (addr, index)
val c = Byte.byteToChar w
in
if c = #"\000"
then SOME (implode (rev cs))
else loop (index + 1, c::cs)
end
in
loop (0, [])
end
end
val dlopen = fn (filename, mode) =>
let
val filename = filename ^ "\000"
val hndl = dlopen (filename, mode)
in
if hndl = MLton.Pointer.null
then raise Fail (case dlerror () of
NONE => "???"
| SOME s => s)
else hndl
end
val dlsym = fn (hndl, symbol) =>
let
val symbol = symbol ^ "\000"
val fptr = dlsym (hndl, symbol)
in
case dlerror () of
NONE => fptr
| SOME s => raise Fail s
end
val dlclose = fn hndl =>
let
val res = dlclose hndl
in
if res = 0
then ()
else raise Fail (case dlerror () of
NONE => "???"
| SOME s => s)
end
end
val hndl = DynLink.dlopen ("libm.so", DynLink.RTLD_LAZY)
local
val double_to_double =
_import * : DynLink.fptr -> real -> real;
val cos_fptr = DynLink.dlsym (hndl, "cos")
in
val cos = double_to_double cos_fptr
end
val _ = print (concat [" Math.cos(2.0) = ", Real.toString (Math.cos 2.0), "\n",
"libm.so::cos(2.0) = ", Real.toString (cos 2.0), "\n"])
val _ = DynLink.dlclose hndl
1.26 +44 -6 mlton/doc/user-guide/ffi.tex
Index: ffi.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/ffi.tex,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- ffi.tex 7 Sep 2004 00:46:18 -0000 1.25
+++ ffi.tex 23 Sep 2004 03:12:52 -0000 1.26
@@ -26,8 +26,8 @@
The general form of an \verb+_import+ expresion is:
\begin{center}
-{\tt \_import "}C global variable or function name{\tt "} {\it
-attribute} ...{\tt : }{\it ty}{\tt ;}
+{\tt \_import "}C global variable or function name{\tt "}
+{\it attribute} ...{\tt : }{\it ty}{\tt ;}
\end{center}
The semicolon is not optional.
@@ -47,13 +47,51 @@
\begin{verbatim}
% make import
-mlton -stop o ffi-import.c
-mlton import.sml ffi-import.o
+mlton -default-ann 'allowExport true, allowImport true' -stop o ffi-import.c
+mlton -default-ann 'allowExport true, allowImport true' import.sml ffi-import.o
% import
13
success
\end{verbatim}
+\subsubsection{Indirect function calls}
+
+It is also possibe to make indirect function calls; that is, function
+calls through a function pointer. Suppose that you would like to
+indirectly call the C function {\tt foo} described above; we will
+assume that the address of {\tt foo} has been acquired and is
+available in the SML variable {\tt foo\_addr}. {\mlton} extends the
+syntax of SML to allow expressions like the following:
+\begin{verbatim}
+_import * : MLton.Pointer.t -> real * char -> int;
+\end{verbatim}
+This expression denotes a function of type {\tt MLton.Pointer.t -> real
+* char -> int} whose behavior is implemented by calling the C function
+at the address denoted by the {\tt MLton.Pointer.t} argument
+
+The general form of an indirect \verb+_import+ expresion is:
+\begin{center}
+{\tt \_import *} {\it attribute} ...{\tt : }{\it ty}{\tt ;}
+\end{center}
+The semicolon is not optional. {\it ty} must be a function type of the form
+\begin{center}
+{\tt MLton.Pointer.t -> {\it ty}$_1$ * ... * {\it ty}$_n$ -> {\it ty}$_r$}
+\end{center}
+$n$ can be zero, in which case the expression denotes the indirect
+call of an argumentless C function.
+
+An example in the {\tt examples/ffi} directory demonstrates the use of
+indirect {\import} expressions. The example demonstrates how to call
+functions from a dynamic library.
+
+\begin{verbatim}
+% make dimport
+mlton -default-ann 'allowExport true, allowImport true' -link-opt '-ldl' dimport.sml
+% dimport
+ Math.cos(2.0) = ~0.416146836547
+libm.so::cos(2.0) = ~0.416146836547
+\end{verbatim}
+
\subsec{Calling from C to SML}{export}
Suppose you would like export from SML a function of type {\tt real *
char -> int} as the C function {\tt foo}. {\mlton} extends the syntax
@@ -89,9 +127,9 @@
\begin{verbatim}
% make export
-mlton -export-header export.h -stop tc export.sml
+mlton -default-ann 'allowExport true, allowImport true' -export-header export.h -stop tc export.sml
gcc -c ffi-export.c
-mlton export.sml ffi-export.o
+mlton -default-ann 'allowExport true, allowImport true' export.sml ffi-export.o
% ./export
g starting
...
1.16 +1 -0 mlton/include/x86-main.h
Index: x86-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86-main.h,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- x86-main.h 25 Aug 2004 17:51:07 -0000 1.15
+++ x86-main.h 23 Sep 2004 03:12:53 -0000 1.16
@@ -5,6 +5,7 @@
/* Globals */
Word applyFFTemp;
+Word applyFFTemp2;
Word checkTemp;
Word cReturnTemp[16];
Word c_stackP;
1.30 +19 -8 mlton/mlton/ast/ast-core.fun
Index: ast-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.fun,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- ast-core.fun 15 Sep 2004 18:16:26 -0000 1.29
+++ ast-core.fun 23 Sep 2004 03:12:53 -0000 1.30
@@ -271,12 +271,24 @@
end
datatype t =
- BuildConst
- | CommandLineConst of {value: Const.t}
- | Const
- | Export of Attribute.t list
- | Import of Attribute.t list
- | Prim
+ BuildConst of {name: string}
+ | CommandLineConst of {name: string, value: Const.t}
+ | Const of {name: string}
+ | Export of {attributes: Attribute.t list, name: string}
+ | IImport of {attributes: Attribute.t list}
+ | Import of {attributes: Attribute.t list, name: string}
+ | Prim of {name: string}
+
+ fun name pk =
+ case pk of
+ BuildConst {name, ...} => name
+ | CommandLineConst {name, ...} => name
+ | Const {name, ...} => name
+ | Export {name, ...} => name
+ | IImport {...} => "<iimport>"
+ | Import {name, ...} => name
+ | Prim {name, ...} => name
+
end
structure Priority =
@@ -315,7 +327,6 @@
| Orelse of exp * exp
| While of {test: exp, expr: exp}
| Prim of {kind: PrimKind.t,
- name: string,
ty: Type.t}
and decNode =
Abstype of {body: dec,
@@ -428,7 +439,7 @@
| Orelse (e, e') =>
delimit (mayAlign [layoutExpF e,
seq [str "orelse ", layoutExpF e']])
- | Prim {name, ...} => str name
+ | Prim {kind, ...} => str (PrimKind.name kind)
| Raise exn => delimit (seq [str "raise ", layoutExpF exn])
| Record r =>
let
1.19 +7 -7 mlton/mlton/ast/ast-core.sig
Index: ast-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.sig,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- ast-core.sig 15 Sep 2004 18:16:26 -0000 1.18
+++ ast-core.sig 23 Sep 2004 03:12:53 -0000 1.19
@@ -93,12 +93,13 @@
end
datatype t =
- BuildConst
- | CommandLineConst of {value: Const.t}
- | Const
- | Export of Attribute.t list
- | Import of Attribute.t list
- | Prim
+ BuildConst of {name: string}
+ | CommandLineConst of {name: string, value: Const.t}
+ | Const of {name: string}
+ | Export of {attributes: Attribute.t list, name: string}
+ | IImport of {attributes: Attribute.t list}
+ | Import of {attributes: Attribute.t list, name: string}
+ | Prim of {name: string}
end
structure Priority:
@@ -128,7 +129,6 @@
| List of t vector
| Orelse of t * t
| Prim of {kind: PrimKind.t,
- name: string,
ty: Type.t}
| Raise of t
| Record of t Record.t
1.24 +1 -0 mlton/mlton/ast/prim-tycons.fun
Index: prim-tycons.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- prim-tycons.fun 28 Apr 2004 03:17:04 -0000 1.23
+++ prim-tycons.fun 23 Sep 2004 03:12:53 -0000 1.24
@@ -22,6 +22,7 @@
val exn = fromString "exn"
val intInf = fromString "intInf"
val list = fromString "list"
+val pointer = fromString "pointer"
val preThread = fromString "preThread"
val reff = fromString "ref"
val thread = fromString "thread"
1.9 +29 -10 mlton/mlton/atoms/c-function.fun
Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-function.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- c-function.fun 7 Sep 2004 00:46:18 -0000 1.8
+++ c-function.fun 23 Sep 2004 03:12:53 -0000 1.9
@@ -16,6 +16,24 @@
val layout = Layout.str o toString
end
+structure Target =
+ struct
+ datatype t =
+ Direct of string
+ | Indirect
+
+ val toString =
+ fn Direct name => name
+ | Indirect => "*"
+
+ val layout = Layout.str o toString
+
+ val equals =
+ fn (Direct name, Direct name') => name = name'
+ | (Indirect, Indirect) => true
+ | _ => false
+ end
+
datatype 'a t = T of {args: 'a vector,
bytesNeeded: int option,
convention: Convention.t,
@@ -23,15 +41,15 @@
mayGC: bool,
maySwitchThreads: bool,
modifiesFrontier: bool,
- name: string,
prototype: CType.t vector * CType.t option,
readsStackTop: bool,
return: 'a,
+ target: Target.t,
writesStackTop: bool}
fun layout (T {args, bytesNeeded, convention, ensuresBytesFree, mayGC,
- maySwitchThreads, modifiesFrontier, name, readsStackTop,
- return, writesStackTop, ...},
+ maySwitchThreads, modifiesFrontier, readsStackTop,
+ return, target, writesStackTop, ...},
layoutType) =
Layout.record
[("args", Vector.layout layoutType args),
@@ -41,9 +59,9 @@
("mayGC", Bool.layout mayGC),
("maySwitchThreads", Bool.layout maySwitchThreads),
("modifiesFrontier", Bool.layout modifiesFrontier),
- ("name", String.layout name),
("readsStackTop", Bool.layout readsStackTop),
("return", layoutType return),
+ ("target", Target.layout target),
("writesStackTop", Bool.layout writesStackTop)]
local
@@ -51,21 +69,22 @@
in
fun args z = make #args z
fun bytesNeeded z = make #bytesNeeded z
+ fun convention z = make #convention z
fun ensuresBytesFree z = make #ensuresBytesFree z
fun mayGC z = make #mayGC z
fun maySwitchThreads z = make #maySwitchThreads z
fun modifiesFrontier z = make #modifiesFrontier z
- fun name z = make #name z
fun readsStackTop z = make #readsStackTop z
fun return z = make #return z
+ fun target z = make #target z
fun writesStackTop z = make #writesStackTop z
end
-fun equals (f, f') = name f = name f'
+fun equals (f, f') = Target.equals (target f, target f')
fun map (T {args, bytesNeeded, convention, ensuresBytesFree, mayGC,
- maySwitchThreads, modifiesFrontier, name, prototype, readsStackTop,
- return, writesStackTop},
+ maySwitchThreads, modifiesFrontier, prototype, readsStackTop,
+ return, target, writesStackTop},
f) =
T {args = Vector.map (args, f),
bytesNeeded = bytesNeeded,
@@ -74,10 +93,10 @@
mayGC = mayGC,
maySwitchThreads = maySwitchThreads,
modifiesFrontier = modifiesFrontier,
- name = name,
prototype = prototype,
readsStackTop = readsStackTop,
return = f return,
+ target = target,
writesStackTop = writesStackTop}
fun isOk (T {ensuresBytesFree, mayGC, maySwitchThreads, modifiesFrontier,
@@ -104,10 +123,10 @@
mayGC = false,
maySwitchThreads = false,
modifiesFrontier = false,
- name = name,
prototype = prototype,
readsStackTop = false,
return = return,
+ target = Target.Direct name,
writesStackTop = false}
end
1.6 +32 -19 mlton/mlton/atoms/c-function.sig
Index: c-function.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-function.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- c-function.sig 7 Sep 2004 00:46:18 -0000 1.5
+++ c-function.sig 23 Sep 2004 03:12:54 -0000 1.6
@@ -24,28 +24,41 @@
val toString: t -> string
end
+ structure Target:
+ sig
+ datatype t = Direct of string | Indirect
+
+ val layout: t -> Layout.t
+ val toString: t -> string
+ end
+
datatype 'a t = T of {args: 'a 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,
- name: string,
- prototype: CType.t vector * CType.t option,
- readsStackTop: bool,
- return: 'a,
- writesStackTop: bool}
+ (* 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,
+ prototype: CType.t vector * CType.t option,
+ readsStackTop: bool,
+ return: 'a,
+ (* target = Indirect means that the 0'th
+ * argument to the function is a word
+ * that specifies the target.
+ *)
+ target: Target.t,
+ writesStackTop: bool}
val args: 'a t -> 'a vector
val bytesNeeded: 'a t -> int option
+ val convention: 'a t -> Convention.t
val ensuresBytesFree: 'a t -> bool
val equals: 'a t * 'a t -> bool
val isOk: 'a t * {isUnit: 'a -> bool} -> bool
@@ -54,9 +67,9 @@
val mayGC: 'a t -> bool
val maySwitchThreads: 'a t -> bool
val modifiesFrontier: 'a t -> bool
- val name: 'a t -> string
val readsStackTop: 'a t -> bool
val return: 'a t -> 'a
+ val target: 'a t -> Target.t
val writesStackTop: 'a t -> bool
val vanilla: {args: 'a vector,
name: string,
1.94 +1 -1 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.93
retrieving revision 1.94
diff -u -r1.93 -r1.94
--- prim.fun 14 Sep 2004 04:11:40 -0000 1.93
+++ prim.fun 23 Sep 2004 03:12:54 -0000 1.94
@@ -215,7 +215,7 @@
| Exn_name => "Exn_name"
| Exn_setExtendExtra => "Exn_setExtendExtra"
| Exn_setInitExtra => "Exn_setInitExtra"
- | FFI f => CFunction.name f
+ | FFI f => (CFunction.Target.toString o CFunction.target) f
| FFI_Symbol {name, ...} => name
| GC_collect => "GC_collect"
| IntInf_add => "IntInf_add"
1.3 +1 -0 mlton/mlton/atoms/sources.mlb
Index: sources.mlb
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.mlb,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- sources.mlb 15 Sep 2004 18:16:27 -0000 1.2
+++ sources.mlb 23 Sep 2004 03:12:54 -0000 1.3
@@ -25,6 +25,7 @@
c-function.sig
c-function.fun
const-type.sig
+ const-type.fun
const.sig
const.fun
prim.sig
1.56 +1 -1 mlton/mlton/backend/limit-check.fun
Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -r1.55 -r1.56
--- limit-check.fun 7 Sep 2004 00:46:19 -0000 1.55
+++ limit-check.fun 23 Sep 2004 03:12:54 -0000 1.56
@@ -159,10 +159,10 @@
mayGC = false,
maySwitchThreads = false,
modifiesFrontier = false,
- name = "MLton_allocTooLarge",
prototype = (Vector.new0 (), NONE),
readsStackTop = false,
return = Type.unit,
+ target = CFunction.Target.Direct "MLton_allocTooLarge",
writesStackTop = false}
val _ =
newBlocks :=
1.43 +9 -7 mlton/mlton/backend/profile.fun
Index: profile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- profile.fun 7 Sep 2004 00:46:19 -0000 1.42
+++ profile.fun 23 Sep 2004 03:12:54 -0000 1.43
@@ -25,10 +25,10 @@
mayGC = false,
maySwitchThreads = false,
modifiesFrontier = false,
- name = name,
prototype = (prototype, NONE),
readsStackTop = true,
return = unit,
+ target = Target.Direct name,
writesStackTop = false}
in
val profileEnter =
@@ -572,16 +572,18 @@
Cont _ => add pushes
| CReturn {func, ...} =>
let
- val name = CFunction.name func
+ datatype z = datatype CFunction.Target.t
+ val target = CFunction.target func
fun doit si =
add (#1 (enter (pushes, si)))
in
- case name of
- "GC_gc" => doit SourceInfo.gc
- | "GC_arrayAllocate" =>
+ case target of
+ Direct "GC_gc" => doit SourceInfo.gc
+ | Direct "GC_arrayAllocate" =>
doit SourceInfo.gcArrayAllocate
- | "MLton_bug" => add pushes
- | _ => doit (SourceInfo.fromC name)
+ | Direct "MLton_bug" => add pushes
+ | Direct name => doit (SourceInfo.fromC name)
+ | Indirect => doit (SourceInfo.fromC "<indirect>")
end
| Handler => add pushes
| Jump => ()
1.13 +3 -2 mlton/mlton/backend/rep-type.fun
Index: rep-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rep-type.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- rep-type.fun 7 Sep 2004 00:46:19 -0000 1.12
+++ rep-type.fun 23 Sep 2004 03:12:55 -0000 1.13
@@ -468,6 +468,7 @@
open CFunction
datatype z = datatype Convention.t
+ datatype z = datatype Target.t
val bug = vanilla {args = Vector.new1 string,
name = "MLton_bug",
@@ -494,7 +495,6 @@
mayGC = true,
maySwitchThreads = b,
modifiesFrontier = true,
- name = "GC_gc",
prototype = let
open CType
in
@@ -502,7 +502,8 @@
NONE)
end,
readsStackTop = true,
- return = unit,
+ return = unit,
+ target = Direct "GC_gc",
writesStackTop = true}
val t = make true
val f = make false
1.99 +14 -12 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.98
retrieving revision 1.99
diff -u -r1.98 -r1.99
--- ssa-to-rssa.fun 7 Sep 2004 01:16:51 -0000 1.98
+++ ssa-to-rssa.fun 23 Sep 2004 03:12:55 -0000 1.99
@@ -51,6 +51,7 @@
end
datatype z = datatype Convention.t
+ datatype z = datatype Target.t
val copyCurrentThread =
T {args = Vector.new1 gcState,
@@ -60,7 +61,6 @@
mayGC = true,
maySwitchThreads = false,
modifiesFrontier = true,
- name = "GC_copyCurrentThread",
prototype = let
open CType
in
@@ -68,6 +68,7 @@
end,
readsStackTop = true,
return = unit,
+ target = Direct "GC_copyCurrentThread",
writesStackTop = true}
val copyThread =
@@ -78,7 +79,6 @@
mayGC = true,
maySwitchThreads = false,
modifiesFrontier = true,
- name = "GC_copyThread",
prototype = let
open CType
in
@@ -86,6 +86,7 @@
end,
readsStackTop = true,
return = Type.thread,
+ target = Direct "GC_copyThread",
writesStackTop = true}
val exit =
@@ -96,7 +97,6 @@
mayGC = false,
maySwitchThreads = false,
modifiesFrontier = true,
- name = "MLton_exit",
prototype = let
open CType
in
@@ -104,6 +104,7 @@
end,
readsStackTop = true,
return = unit,
+ target = Direct "MLton_exit",
writesStackTop = true}
fun gcArrayAllocate {return} =
@@ -114,7 +115,6 @@
mayGC = true,
maySwitchThreads = false,
modifiesFrontier = true,
- name = "GC_arrayAllocate",
prototype = let
open CType
in
@@ -123,6 +123,7 @@
end,
readsStackTop = true,
return = return,
+ target = Direct "GC_arrayAllocate",
writesStackTop = true}
val returnToC =
@@ -133,7 +134,6 @@
mayGC = true,
maySwitchThreads = true,
modifiesFrontier = true,
- name = "Thread_returnToC",
prototype = let
open CType
in
@@ -141,6 +141,7 @@
end,
readsStackTop = true,
return = unit,
+ target = Direct "Thread_returnToC",
writesStackTop = true}
val threadSwitchTo =
@@ -151,7 +152,6 @@
mayGC = true,
maySwitchThreads = true,
modifiesFrontier = true,
- name = "Thread_switchTo",
prototype = let
open CType
in
@@ -159,6 +159,7 @@
end,
readsStackTop = true,
return = unit,
+ target = Direct "Thread_switchTo",
writesStackTop = true}
fun weakCanGet t =
@@ -189,7 +190,6 @@
mayGC = true,
maySwitchThreads = false,
modifiesFrontier = true,
- name = "GC_weakNew",
prototype = let
open CType
in
@@ -197,6 +197,7 @@
end,
readsStackTop = true,
return = return,
+ target = Direct "GC_weakNew",
writesStackTop = true}
val worldSave =
@@ -207,7 +208,6 @@
mayGC = true,
maySwitchThreads = false,
modifiesFrontier = true,
- name = "GC_saveWorld",
prototype = let
open CType
in
@@ -215,6 +215,7 @@
end,
readsStackTop = true,
return = unit,
+ target = Direct "GC_saveWorld",
writesStackTop = true}
fun share t =
@@ -247,6 +248,7 @@
fun cFunctionRaise (n: t): CFunction.t =
let
datatype z = datatype CFunction.Convention.t
+ datatype z = datatype CFunction.Target.t
val name = toString n
val word = Type.word o WordSize.bits
val vanilla = CFunction.vanilla
@@ -267,7 +269,6 @@
mayGC = false,
maySwitchThreads = false,
modifiesFrontier = true,
- name = name,
prototype = let
open CType
in
@@ -276,6 +277,7 @@
end,
readsStackTop = false,
return = Type.intInf,
+ target = Direct name,
writesStackTop = false}
fun intInfShift () =
CFunction.T {args = Vector.new3 (Type.intInf,
@@ -287,7 +289,6 @@
mayGC = false,
maySwitchThreads = false,
modifiesFrontier = true,
- name = name,
prototype = let
open CType
in
@@ -296,6 +297,7 @@
end,
readsStackTop = false,
return = Type.intInf,
+ target = Direct name,
writesStackTop = false}
fun intInfToString () =
CFunction.T {args = Vector.new3 (Type.intInf,
@@ -307,7 +309,6 @@
mayGC = false,
maySwitchThreads = false,
modifiesFrontier = true,
- name = name,
prototype = let
open CType
in
@@ -316,6 +317,7 @@
end,
readsStackTop = false,
return = Type.string,
+ target = Direct name,
writesStackTop = false}
fun intInfUnary () =
CFunction.T {args = Vector.new2 (Type.intInf, Type.defaultWord),
@@ -325,7 +327,6 @@
mayGC = false,
maySwitchThreads = false,
modifiesFrontier = true,
- name = name,
prototype = let
open CType
in
@@ -334,6 +335,7 @@
end,
readsStackTop = false,
return = Type.intInf,
+ target = Direct name,
writesStackTop = false}
fun wordBinary (s, sg) =
let
1.4 +1 -1 mlton/mlton/codegen/bytecode/bytecode.fun
Index: bytecode.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/bytecode/bytecode.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- bytecode.fun 20 Aug 2004 16:34:44 -0000 1.3
+++ bytecode.fun 23 Sep 2004 03:12:55 -0000 1.4
@@ -307,7 +307,7 @@
let
val CFunction.T {maySwitchThreads,
modifiesFrontier,
- name, return = returnTy, ...} = func
+ return = returnTy, ...} = func
val () = emitOpcode cCall
val () =
Vector.foreach (args, fn a =>
1.93 +65 -12 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.92
retrieving revision 1.93
diff -u -r1.92 -r1.93
--- c-codegen.fun 7 Sep 2004 00:46:19 -0000 1.92
+++ c-codegen.fun 23 Sep 2004 03:12:56 -0000 1.93
@@ -39,8 +39,11 @@
structure CFunction =
struct
open CFunction
-
- fun prototype (T {convention, name, prototype = (args, return), ...}) =
+
+ datatype z = datatype Convention.t
+ datatype z = datatype Target.t
+
+ fun prototype (T {convention, prototype = (args, return), target, ...}) =
let
val attributes =
if convention <> Convention.Cdecl
@@ -48,6 +51,10 @@
Convention.toString convention,
")) "]
else " "
+ val name =
+ case target of
+ Direct name => name
+ | Indirect => Error.bug "prototype of Indirect"
val c = Counter.new 0
fun arg t =
concat [CType.toString t, " x", Int.toString (Counter.next c)]
@@ -58,9 +65,37 @@
in
concat
[return, attributes, name,
- " (", concat (List.separate (Vector.toListMap (args, arg), ", ")),
+ " (",
+ concat (List.separate (Vector.toListMap (args, arg), ", ")),
")"]
end
+
+ fun fptrtype (T {convention, prototype = (args, return), target, ...}) =
+ let
+ val attributes =
+ if convention <> Convention.Cdecl
+ then concat [" __attribute__ ((",
+ Convention.toString convention,
+ ")) "]
+ else " "
+ val () =
+ case target of
+ Direct _ => Error.bug "fptrtype of Direct"
+ | Indirect => ()
+ val c = Counter.new 0
+ fun arg t = CType.toString t
+ val args = Vector.dropPrefix (args, 1)
+ val return =
+ case return of
+ NONE => "void"
+ | SOME t => CType.toString t
+ in
+ concat
+ ["(", return, attributes,
+ "(*)(",
+ concat (List.separate (Vector.toListMap (args, arg), ", ")),
+ "))"]
+ end
end
val traceGotoLabel = Trace.trace ("gotoLabel", Label.layout, Unit.layout)
@@ -681,14 +716,16 @@
case transfer of
Transfer.CCall {func, ...} =>
let
- val CFunction.T {name, ...} = func
+ datatype z = datatype CFunction.Target.t
+ val CFunction.T {target, ...} = func
in
- if name = "Thread_returnToC"
- then ()
- else
- doit (name, fn () =>
- concat [CFunction.prototype func,
- ";\n"])
+ case target of
+ Direct "Thread_returnToC" => ()
+ | Direct name =>
+ doit (name, fn () =>
+ concat [CFunction.prototype func,
+ ";\n"])
+ | Indirect => ()
end
| _ => ()
in
@@ -956,9 +993,9 @@
let
val CFunction.T {maySwitchThreads,
modifiesFrontier,
- name,
readsStackTop,
return = returnTy,
+ target,
writesStackTop,...} = func
val (args, afterCall) =
case frameInfo of
@@ -987,7 +1024,23 @@
if Type.isUnit returnTy
then ()
else print (concat [creturn returnTy, " = "])
- val _ = C.call (name, args, print)
+ datatype z = datatype CFunction.Target.t
+ val _ =
+ case target of
+ Direct name => C.call (name, args, print)
+ | Indirect =>
+ let
+ val (fptr,args) =
+ case args of
+ (fptr::args) => (fptr, args)
+ | _ => Error.bug "indirect ccall: empty args"
+ val name =
+ concat ["(*(",
+ CFunction.fptrtype func, " ",
+ fptr, "))"]
+ in
+ C.call (name, args, print)
+ end
val _ = afterCall ()
val _ =
if modifiesFrontier
1.49 +44 -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.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- x86-generate-transfers.fun 20 Aug 2004 16:34:45 -0000 1.48
+++ x86-generate-transfers.fun 23 Sep 2004 03:12:56 -0000 1.49
@@ -1068,13 +1068,16 @@
{target = x86MLton.gcState_stackTopMinusWordDerefOperand (),
absolute = true})))
end
- | CCall {args, frameInfo, func, return, target}
+ | CCall {args, frameInfo, func, return}
=> let
+ datatype z = datatype CFunction.Convention.t
+ datatype z = datatype CFunction.Target.t
val CFunction.T {convention,
maySwitchThreads,
modifiesFrontier,
readsStackTop,
return = returnTy,
+ target,
writesStackTop, ...} = func
val stackTopMinusWordDeref
= x86MLton.gcState_stackTopMinusWordDerefOperand ()
@@ -1085,6 +1088,24 @@
val c_stackPDerefFloat = x86MLton.c_stackPDerefFloatOperand
val c_stackPDerefDouble = x86MLton.c_stackPDerefDoubleOperand
val applyFFTemp = x86MLton.applyFFTempContentsOperand
+ val applyFFTemp2 = x86MLton.applyFFTemp2ContentsOperand
+ val (fptrArg, args) =
+ case target of
+ Direct _ => (AppendList.empty, args)
+ | Indirect =>
+ let
+ val (fptrArg, args) =
+ case args of
+ fptrArg::args => (fptrArg, args)
+ | _ => Error.bug "CCall"
+ in
+ (AppendList.single
+ (Assembly.instruction_mov
+ {src = #1 fptrArg,
+ dst = applyFFTemp2,
+ size = #2 fptrArg}),
+ args)
+ end
val (pushArgs, size_args)
= List.fold
(args, (AppendList.empty, 0),
@@ -1245,12 +1266,27 @@
remove_classes = ClassSet.empty,
dead_memlocs = LiveSet.toMemLocSet dead,
dead_classes = ClassSet.empty})
- val call
- = AppendList.fromList
- [Assembly.directive_ccall (),
- Assembly.instruction_call
- {target = Operand.label target,
- absolute = false}]
+ val call =
+ case target of
+ Direct name =>
+ let
+ val name =
+ case convention of
+ Cdecl => name
+ | Stdcall => concat [name, "@", Int.toString size_args]
+ in
+ AppendList.fromList
+ [Assembly.directive_ccall (),
+ Assembly.instruction_call
+ {target = Operand.label (Label.fromString name),
+ absolute = false}]
+ end
+ | Indirect =>
+ AppendList.fromList
+ [Assembly.directive_ccall (),
+ Assembly.instruction_call
+ {target = applyFFTemp2,
+ absolute = true}]
val kill
= if isSome frameInfo
then AppendList.single
@@ -1324,6 +1360,7 @@
in
AppendList.appends
[cacheEsp (),
+ fptrArg,
pushArgs,
flush,
call,
1.17 +13 -0 mlton/mlton/codegen/x86-codegen/x86-liveness.fun
Index: x86-liveness.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-liveness.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- x86-liveness.fun 18 Mar 2004 03:22:24 -0000 1.16
+++ x86-liveness.fun 23 Sep 2004 03:12:57 -0000 1.17
@@ -710,6 +710,19 @@
= Liveness.livenessAssembly
{assembly = asm,
live = live}
+ val eq = Liveness.eq(info, info')
+ val () =
+ if eq
+ then ()
+ else (print "asm ::\n";
+ print (Assembly.toString asm);
+ print "\n";
+ print "info ::\n";
+ print (Liveness.toString info);
+ print "\n";
+ print "info' ::\n";
+ print (Liveness.toString info');
+ print "\n")
in
{verified = verified andalso
Liveness.eq(info, info'),
1.32 +7 -0 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.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- x86-mlton-basic.fun 7 Sep 2004 00:46:19 -0000 1.31
+++ x86-mlton-basic.fun 23 Sep 2004 03:12:57 -0000 1.32
@@ -208,6 +208,13 @@
class = Classes.StaticTemp}
val applyFFTempContentsOperand
= Operand.memloc applyFFTempContents
+ val applyFFTemp2 = Label.fromString "applyFFTemp2"
+ val applyFFTemp2Contents
+ = makeContents {base = Immediate.label applyFFTemp2,
+ size = wordSize,
+ class = Classes.StaticTemp}
+ val applyFFTemp2ContentsOperand
+ = Operand.memloc applyFFTemp2Contents
val realTemp1D = Label.fromString "realTemp1D"
val realTemp1ContentsD
1.32 +1 -0 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.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- x86-mlton-basic.sig 25 Apr 2004 06:55:45 -0000 1.31
+++ x86-mlton-basic.sig 23 Sep 2004 03:12:57 -0000 1.32
@@ -85,6 +85,7 @@
(* Static temps defined in x86-main.h *)
val applyFFTempContentsOperand : x86.Operand.t
+ val applyFFTemp2ContentsOperand : x86.Operand.t
val threadTempContentsOperand : x86.Operand.t
val fileTempContentsOperand : x86.Operand.t
val realTemp1ContentsOperand : x86.Size.t -> x86.Operand.t
1.62 +25 -26 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.61
retrieving revision 1.62
diff -u -r1.61 -r1.62
--- x86-mlton.fun 13 May 2004 20:34:51 -0000 1.61
+++ x86-mlton.fun 23 Sep 2004 03:12:58 -0000 1.62
@@ -1430,26 +1430,20 @@
return: x86.Label.t option,
transInfo = {...}: transInfo}
= let
- val CFunction.T {convention, name, ...} = 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 CFunction.T {convention, target, ...} = func
val comment_begin
= if !Control.Native.commented > 0
- then AppendList.single (x86.Block.mkBlock'
- {entry = NONE,
- statements
- = [x86.Assembly.comment
- ("begin ccall: " ^ name)],
- transfer = NONE})
+ then AppendList.single
+ (x86.Block.mkBlock'
+ {entry = NONE,
+ statements =
+ [x86.Assembly.comment
+ (concat
+ ["begin ccall: ",
+ CFunction.Convention.toString convention,
+ " ",
+ CFunction.Target.toString target])],
+ transfer = NONE})
else AppendList.empty
in
AppendList.appends
@@ -1462,8 +1456,7 @@
{args = Vector.toList args,
frameInfo = frameInfo,
func = func,
- return = return,
- target = Label.fromString name})})]
+ return = return})})]
end
fun creturn {dsts: (x86.Operand.t * x86.Size.t) vector,
@@ -1472,7 +1465,7 @@
label: x86.Label.t,
transInfo = {live, liveInfo, ...}: transInfo}
= let
- val name = CFunction.name func
+ val CFunction.T {convention, target, ...} = func
fun default ()
= let
val _ = x86Liveness.LiveInfo.setLiveOperands
@@ -1489,11 +1482,17 @@
end
val comment_end
= if !Control.Native.commented > 0
- then (AppendList.single
- (x86.Block.mkBlock' {entry = NONE,
- statements = [x86.Assembly.comment
- ("end creturn: " ^ name)],
- transfer = NONE}))
+ then AppendList.single
+ (x86.Block.mkBlock'
+ {entry = NONE,
+ statements =
+ [x86.Assembly.comment
+ (concat
+ ["begin creturn: ",
+ CFunction.Convention.toString convention,
+ " ",
+ CFunction.Target.toString target])],
+ transfer = NONE})
else AppendList.empty
in
AppendList.appends [default (), comment_end]
1.24 +1 -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.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- x86-pseudo.sig 12 Apr 2004 17:53:01 -0000 1.23
+++ x86-pseudo.sig 23 Sep 2004 03:12:58 -0000 1.24
@@ -470,8 +470,7 @@
val ccall : {args: (Operand.t * Size.t) list,
frameInfo: FrameInfo.t option,
func: RepType.t CFunction.t,
- return: Label.t option,
- target: Label.t} -> t
+ return: Label.t option} -> t
end
structure ProfileLabel :
1.57 +8 -8 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.56
retrieving revision 1.57
diff -u -r1.56 -r1.57
--- x86.fun 7 Sep 2004 00:46:19 -0000 1.56
+++ x86.fun 23 Sep 2004 03:12:59 -0000 1.57
@@ -3783,7 +3783,7 @@
" ",
Vector.toString (fn (dst,_) => Operand.toString dst) dsts,
" ",
- CFunction.name func,
+ (CFunction.Target.toString o CFunction.target) func,
" ",
case frameInfo of
NONE => ""
@@ -3995,8 +3995,7 @@
| CCall of {args: (Operand.t * Size.t) list,
frameInfo: FrameInfo.t option,
func: RepType.t CFunction.t,
- return: Label.t option,
- target: Label.t}
+ return: Label.t option}
val toString
= fn Goto {target}
@@ -4074,9 +4073,11 @@
fn (memloc, l) => (MemLoc.toString memloc)::l),
", "),
"]"]
- | CCall {args, return, target, ...}
+ | CCall {args, func, return, ...}
=> concat ["CCALL ",
- Label.toString target,
+ (CFunction.Convention.toString o CFunction.convention) func,
+ " ",
+ (CFunction.Target.toString o CFunction.target) func,
"(",
(concat o List.separate)
(List.map(args, fn (oper,_) => Operand.toString oper),
@@ -4130,7 +4131,7 @@
=> Switch {test = replacer {use = true, def = false} test,
cases = cases,
default = default}
- | CCall {args, frameInfo, func, return, target}
+ | CCall {args, frameInfo, func, return}
=> CCall {args = List.map(args,
fn (oper,size) => (replacer {use = true,
def = false}
@@ -4138,8 +4139,7 @@
size)),
frameInfo = frameInfo,
func = func,
- return = return,
- target = target}
+ return = return}
| transfer => transfer
val goto = Goto
1.33 +2 -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.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- x86.sig 12 Apr 2004 17:53:02 -0000 1.32
+++ x86.sig 23 Sep 2004 03:12:59 -0000 1.33
@@ -1166,8 +1166,7 @@
| CCall of {args: (Operand.t * Size.t) list,
frameInfo: FrameInfo.t option,
func: RepType.t CFunction.t,
- return: Label.t option,
- target: Label.t}
+ return: Label.t option}
val toString : t -> string
@@ -1198,8 +1197,7 @@
val ccall: {args: (Operand.t * Size.t) list,
frameInfo: FrameInfo.t option,
func: RepType.t CFunction.t,
- return: Label.t option,
- target: Label.t} -> t
+ return: Label.t option} -> t
end
structure ProfileLabel :
1.145 +6 -13 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.144
retrieving revision 1.145
diff -u -r1.144 -r1.145
--- control.sml 17 Sep 2004 03:49:14 -0000 1.144
+++ control.sml 23 Sep 2004 03:13:01 -0000 1.145
@@ -228,23 +228,17 @@
setDef = fn _ => false,
setAble = fn _ => false}
val (allowConstant, ac) =
- makeBool ({name = "allowConstant", default = false, expert = true},
- ac)
+ makeBool ({name = "allowConstant", default = false, expert = true}, ac)
val (allowExport, ac) =
- makeBool ({name = "allowExport", default = false, expert = false},
- ac)
+ makeBool ({name = "allowExport", default = false, expert = false}, ac)
val (allowImport, ac) =
- makeBool ({name = "allowImport", default = false, expert = false},
- ac)
+ makeBool ({name = "allowImport", default = false, expert = false}, ac)
val (allowPrim, ac) =
makeBool ({name = "allowPrim", default = false, expert = true}, ac)
val (allowOverload, ac) =
- makeBool ({name = "allowOverload", default = false, expert = false},
- ac)
+ makeBool ({name = "allowOverload", default = false, expert = false}, ac)
val (allowRebindEquals, ac) =
- makeBool ({name = "allowRebindEquals", default = false,
- expert = true},
- ac)
+ makeBool ({name = "allowRebindEquals", default = false, expert = true}, ac)
val (deadCode, ac) =
makeBool ({name = "deadCode", default = false, expert = false}, ac)
val (forceUsed, ac) =
@@ -259,8 +253,7 @@
newCur = fn (i,()) => i + 1,
newDef = fn (_,()) => 1}, ac)
val (sequenceUnit, ac) =
- makeBool ({name = "sequenceUnit", default = false, expert = false},
- ac)
+ makeBool ({name = "sequenceUnit", default = false, expert = false}, ac)
val (warnMatch, ac) =
makeBool ({name = "warnMatch", default = true, expert = false}, ac)
val (warnUnused, {setAble, setDef, withAnn, withDef}) =
1.124 +116 -18 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.123
retrieving revision 1.124
diff -u -r1.123 -r1.124
--- elaborate-core.fun 22 Sep 2004 23:37:05 -0000 1.123
+++ elaborate-core.fun 23 Sep 2004 03:13:10 -0000 1.124
@@ -773,6 +773,57 @@
else Convention.Cdecl)
| _ => NONE
+fun dimport {attributes: Attribute.t list,
+ ty: Type.t,
+ region: Region.t}: Type.t Prim.t =
+ let
+ fun error l = Control.error (region, l, Layout.empty)
+ fun invalidAttributes () =
+ error (seq [str "invalid attributes for import: ",
+ List.layout Attribute.layout attributes])
+ in
+ case Type.parse ty of
+ NONE =>
+ let
+ val () =
+ Control.error (region,
+ str "invalid type for import: ",
+ Type.layoutPretty ty)
+ in
+ Prim.bogus
+ end
+ | SOME (args, result) =>
+ let
+ datatype z = datatype CFunction.Target.t
+ val convention =
+ case parseAttributes attributes of
+ NONE => (invalidAttributes ()
+ ; Convention.Cdecl)
+ | SOME c => c
+ val func =
+ CFunction.T {args = Vector.concat
+ [Vector.new1 (Type.word (WordSize.pointer ())),
+ Vector.map (args, #ty)],
+ bytesNeeded = NONE,
+ convention = convention,
+ ensuresBytesFree = false,
+ modifiesFrontier = true,
+ mayGC = true,
+ maySwitchThreads = false,
+ prototype = (Vector.map (args, #ctype),
+ Option.map (result, #ctype)),
+ readsStackTop = true,
+ return = (case result of
+ NONE => Type.unit
+ | SOME {ty, ...} => ty),
+ target = Indirect,
+ writesStackTop = true}
+
+ in
+ Prim.ffi func
+ end
+ end
+
fun import {attributes: Attribute.t list,
name: string,
ty: Type.t,
@@ -806,6 +857,7 @@
end
| SOME (args, result) =>
let
+ datatype z = datatype CFunction.Target.t
val convention =
case parseAttributes attributes of
NONE => (invalidAttributes ()
@@ -819,13 +871,13 @@
mayGC = true,
maySwitchThreads = false,
modifiesFrontier = true,
- name = name,
prototype = (Vector.map (args, #ctype),
Option.map (result, #ctype)),
readsStackTop = true,
return = (case result of
NONE => Type.unit
| SOME {ty, ...} => ty),
+ target = Direct name,
writesStackTop = true}
in
@@ -2101,16 +2153,17 @@
in
Cexp.orElse (ce, ce')
end
- | Aexp.Prim {kind, name, ty} =>
+ | Aexp.Prim {kind, ty} =>
let
val ty = elabType ty
- val expandedTy =
+ fun expandTy ty =
Type.hom
(ty, {con = Type.con,
expandOpaque = true,
record = Type.record,
replaceSynonyms = true,
var = Type.var})
+ val expandedTy = expandTy ty
(* We use expandedTy to get the underlying primitive right
* but we use wrap in the end to make the result of the
* final expression be ty, because that is what the rest
@@ -2134,10 +2187,11 @@
targs = targs},
result)
end
- fun eta (p: Type.t Prim.t): Cexp.t =
+ fun etaExtra (extra, ty, expandedTy,
+ p: Type.t Prim.t): Cexp.t =
case Type.deArrowOpt expandedTy of
NONE =>
- wrap (primApp {args = Vector.new0 (),
+ wrap (primApp {args = extra,
prim = p,
result = ty},
ty)
@@ -2145,7 +2199,7 @@
let
val arg = Var.newNoname ()
fun app args =
- primApp {args = args,
+ primApp {args = Vector.concat [extra, args],
prim = p,
result = bodyType}
val body =
@@ -2184,6 +2238,8 @@
mayInline = true}),
ty)
end
+ fun eta (p: Type.t Prim.t): Cexp.t =
+ etaExtra (Vector.new0 (), ty, expandedTy, p)
fun lookConst {default: string option, name: string} =
let
fun bug () =
@@ -2234,10 +2290,10 @@
datatype z = datatype Ast.PrimKind.t
in
case kind of
- BuildConst =>
+ BuildConst {name} =>
(check (ElabControl.allowConstant, "_build_const")
; lookConst {default = NONE, name = name})
- | CommandLineConst {value} =>
+ | CommandLineConst {name, value} =>
let
val () =
check (ElabControl.allowConstant,
@@ -2254,10 +2310,10 @@
in
lookConst {default = SOME value, name = name}
end
- | Const =>
+ | Const {name} =>
(check (ElabControl.allowConstant, "_const")
; lookConst {default = NONE, name = name})
- | Export attributes =>
+ | Export {attributes, name} =>
(check (ElabControl.allowExport, "_export")
; let
val e =
@@ -2265,12 +2321,10 @@
(E, fn () =>
(Env.openStructure
(E, valOf (!Env.Structure.ffi))
- ; elabExp (export {attributes = attributes,
- name = name,
- region = region,
- ty = expandedTy},
- nest,
- NONE)))
+ ; elab (export {attributes = attributes,
+ name = name,
+ region = region,
+ ty = expandedTy})))
val _ =
unify
(Cexp.ty e,
@@ -2287,13 +2341,57 @@
in
wrap (e, Type.arrow (ty, Type.unit))
end)
- | Import attributes =>
+ | IImport {attributes} =>
+ let
+ val () =
+ check (ElabControl.allowImport, "_import")
+ in
+ case (Type.deArrowOpt ty,
+ Type.deArrowOpt expandedTy) of
+ (SOME ty, SOME expandedTy) =>
+ let
+ val ((fptrTy,ty),
+ (fptrExpandedTy,expandedTy)) =
+ (ty, expandedTy)
+ val () =
+ case Type.toCType fptrExpandedTy of
+ SOME {ctype = CType.Word32, ...} => ()
+ | _ =>
+ Control.error
+ (region,
+ str "invalid type for import: ",
+ Type.layoutPretty fptrExpandedTy)
+ val fptr = Var.newNoname ()
+ val fptrArg = Cexp.var (fptr, fptrTy)
+ in
+ Cexp.make
+ (Cexp.Lambda
+ (Lambda.make
+ {arg = fptr,
+ argType = fptrTy,
+ body = etaExtra (Vector.new1 fptrArg,
+ ty, expandedTy,
+ dimport
+ {attributes = attributes,
+ region = region,
+ ty = expandedTy}),
+ mayInline = true}),
+ Type.arrow (fptrTy, ty))
+ end
+ | _ =>
+ (Control.error
+ (region,
+ str "invalid type for import: ",
+ Type.layoutPretty ty);
+ eta Prim.bogus)
+ end
+ | Import {attributes, name} =>
(check (ElabControl.allowImport, "_import")
; eta (import {attributes = attributes,
name = name,
region = region,
ty = expandedTy}))
- | Prim =>
+ | Prim {name} =>
(check (ElabControl.allowPrim, "_prim")
; eta (Prim.fromString name))
end
1.12 +1 -2 mlton/mlton/elaborate/scope.fun
Index: scope.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/scope.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- scope.fun 19 Feb 2004 22:42:13 -0000 1.11
+++ scope.fun 23 Sep 2004 03:13:11 -0000 1.12
@@ -389,10 +389,9 @@
| Let (dec, e) => do2 (loopDec (dec, d), loop e, Let)
| List ts => doVec (ts, List)
| Orelse (e1, e2) => do2 (loop e1, loop e2, Orelse)
- | Prim {kind, name, ty} =>
+ | Prim {kind, ty} =>
do1 (loopTy (ty, d), fn ty =>
Prim {kind = kind,
- name = name,
ty = ty})
| Raise exn => do1 (loop exn, Raise)
| Record r =>
1.38 +18 -10 mlton/mlton/front-end/ml.grm
Index: ml.grm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.grm,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- ml.grm 15 Sep 2004 18:16:28 -0000 1.37
+++ ml.grm 23 Sep 2004 03:13:11 -0000 1.38
@@ -1012,29 +1012,37 @@
exp_psleft,
exp_psright)))
| BUILD_CONST STRING COLON ty SEMICOLON
- (Exp.Prim {kind = PrimKind.BuildConst, name = STRING, ty = ty})
+ (Exp.Prim {kind = PrimKind.BuildConst {name = STRING},
+ ty = ty})
| COMMAND_LINE_CONST STRING COLON ty EQUALOP constOrBool SEMICOLON
- (Exp.Prim {kind = PrimKind.CommandLineConst {value = constOrBool},
- name = STRING,
+ (Exp.Prim {kind = PrimKind.CommandLineConst {name = STRING,
+ value = constOrBool},
ty = ty})
| CONST STRING COLON ty SEMICOLON
- (Exp.Prim {kind = PrimKind.Const, name = STRING, ty = ty})
+ (Exp.Prim {kind = PrimKind.Const {name = STRING},
+ ty = ty})
| FFI STRING COLON ty SEMICOLON
(Control.warning
(reg (FFIleft, SEMICOLONright),
Layout.str "_ffi is deprecated. Use _import.",
Layout.empty)
- ; Exp.Prim {kind = PrimKind.Import [], name = STRING, ty = ty})
+ ; Exp.Prim {kind = PrimKind.Import {attributes = [],
+ name = STRING},
+ ty = ty})
| EXPORT STRING attributes COLON ty SEMICOLON
- (Exp.Prim {kind = PrimKind.Export attributes,
- name = STRING,
+ (Exp.Prim {kind = PrimKind.Export {attributes = attributes,
+ name = STRING},
ty = ty})
| IMPORT STRING attributes COLON ty SEMICOLON
- (Exp.Prim {kind = PrimKind.Import attributes,
- name = STRING,
+ (Exp.Prim {kind = PrimKind.Import {attributes = attributes,
+ name = STRING},
+ ty = ty})
+ | IMPORT ASTERISK attributes COLON ty SEMICOLON
+ (Exp.Prim {kind = PrimKind.IImport {attributes = attributes},
ty = ty})
| PRIM STRING COLON ty SEMICOLON
- (Exp.Prim {kind = PrimKind.Prim, name = STRING, ty = ty})
+ (Exp.Prim {kind = PrimKind.Prim {name = STRING},
+ ty = ty})
attributes
: