[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
    :