[MLton] Re: Type of _address?

Wesley W. Terpstra wesley@terpstra.ca
Thu, 21 Jul 2005 17:20:32 +0200


--1yeeQ81UyVL57Vl7
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline

On Thu, Jul 21, 2005 at 09:40:59AM -0400, Matthew Fluet wrote:
> Actually, the way to get it working for all the codegens would be to 
> incorporate exported symbols into  mlton/atoms/ffi.{sig,fun}.  That is the 
> module that takes care of accumulating exported functions in order to 
> declare them in headers and the C-code.  

Done!
It exports into the headers and the C-code now. :-)

> Then you could drop the cty and export fields from Prim.FFI_symbol.  

I needed to keep cty for doing 'extern'. export is gone.
The final change is that _import # is dead.

> I'll try to shepherd the patch in over the next couple of days.

Ok, here you go.
Please review it.

Finally, we can write code like:
   val (geti, seti) = _symbol "burn_in_hell" define: int;
   val (gets, sets) = _symbol "burn_in_hell": string;
   val () = print ("I want to crash like C: " ^ 
                   Int.toString (geti (sets ("boom"))) ^ "\n")
Look at all the fun we've been missing out on!

-- 
Wesley W. Terpstra

--1yeeQ81UyVL57Vl7
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="symbol.patch"

? x
? mlton/14420.sml
? mlton/codegen/x86-codegen/DEADJOE
Index: basis-library/libs/primitive.mlb
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/primitive.mlb,v
retrieving revision 1.4
diff -u -r1.4 primitive.mlb
--- basis-library/libs/primitive.mlb	4 Nov 2004 01:16:04 -0000	1.4
+++ basis-library/libs/primitive.mlb	21 Jul 2005 15:00:22 -0000
@@ -3,6 +3,7 @@
    "allowImport true"
    "allowPrim true"
    "allowRebindEquals true"
+   "allowSymbol true"
    "deadCode true"
    "sequenceUnit true"
    "warnMatch true"
Index: basis-library/misc/primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.155
diff -u -r1.155 primitive.sml
--- basis-library/misc/primitive.sml	13 Jul 2005 01:30:10 -0000	1.155
+++ basis-library/misc/primitive.sml	21 Jul 2005 15:00:23 -0000
@@ -241,7 +241,7 @@
 	 struct
 	    type t = Pointer.t
 
-	    val gcState = _import "gcStateAddress": t;
+	    val gcState = #1 _symbol "gcStateAddress": t; ()
 	 end
       
       structure CallStack =
@@ -310,10 +310,9 @@
 
       structure CommandLine =
 	 struct
-	    val argc = fn () => _import "CommandLine_argc": int;
-	    val argv = fn () => _import "CommandLine_argv": CStringArray.t;
-	    val commandName =
-	       fn () => _import "CommandLine_commandName": CString.t;
+	    val argc = #1 _symbol "CommandLine_argc": int;
+	    val argv = #1 _symbol "CommandLine_argv": CStringArray.t;
+	    val commandName = #1 _symbol "CommandLine_commandName": CString.t;
 	 end
 
       structure Date =
@@ -374,19 +373,19 @@
 
       structure FFI =
 	 struct
-	    val getOp = fn () => _import "MLton_FFI_op": int;
-	    val int8Array = _import "MLton_FFI_Int8": Pointer.t;
-	    val int16Array = _import "MLton_FFI_Int16": Pointer.t;
-	    val int32Array = _import "MLton_FFI_Int32": Pointer.t;
-	    val int64Array = _import "MLton_FFI_Int64": Pointer.t;
+	    val getOp = #1 _symbol "MLton_FFI_op": int;
+	    val int8Array = #1 _symbol "MLton_FFI_Int8": Pointer.t; ()
+	    val int16Array = #1 _symbol "MLton_FFI_Int16": Pointer.t; ()
+	    val int32Array = #1 _symbol "MLton_FFI_Int32": Pointer.t; ()
+	    val int64Array = #1 _symbol "MLton_FFI_Int64": Pointer.t; ()
 	    val numExports = _build_const "MLton_FFI_numExports": int;
-	    val pointerArray = _import "MLton_FFI_Pointer": Pointer.t;
-	    val real32Array = _import "MLton_FFI_Real32": Pointer.t;
-	    val real64Array = _import "MLton_FFI_Real64": Pointer.t;
-	    val word8Array = _import "MLton_FFI_Word8": Pointer.t;
-	    val word16Array = _import "MLton_FFI_Word16": Pointer.t;
-	    val word32Array = _import "MLton_FFI_Word32": Pointer.t;
-	    val word64Array = _import "MLton_FFI_Word64": Pointer.t;
+	    val pointerArray = #1 _symbol "MLton_FFI_Pointer": Pointer.t; ()
+	    val real32Array = #1 _symbol "MLton_FFI_Real32": Pointer.t; ()
+	    val real64Array = #1 _symbol "MLton_FFI_Real64": Pointer.t; ()
+	    val word8Array = #1 _symbol "MLton_FFI_Word8": Pointer.t; ()
+	    val word16Array = #1 _symbol "MLton_FFI_Word16": Pointer.t; ()
+	    val word32Array = #1 _symbol "MLton_FFI_Word32": Pointer.t; ()
+	    val word64Array = #1 _symbol "MLton_FFI_Word64": Pointer.t; ()
 	 end
 
       structure GC =
@@ -984,7 +983,7 @@
 			val forkIsEnabled =
 			   case host of
 			      Cygwin =>
-				 _import "MLton_Platform_CygwinUseMmap": bool;
+				 #1 _symbol "MLton_Platform_CygwinUseMmap": bool; ()
 			    | MinGW => false
 			    | _ => true
 
@@ -1309,11 +1308,11 @@
 		  val atan2 = _prim "Real64_Math_atan2": real * real -> real;
 		  val cos = _prim "Real64_Math_cos": real -> real;
 		  val cosh = _import "cosh": real -> real;
-		  val e = _import "Real64_Math_e": real;
+		  val e = #1 _symbol "Real64_Math_e": real; ()
 		  val exp = _prim "Real64_Math_exp": real -> real;
 		  val ln = _prim "Real64_Math_ln": real -> real;
 		  val log10 = _prim "Real64_Math_log10": real -> real;
-		  val pi = _import "Real64_Math_pi": real;
+		  val pi = #1 _symbol "Real64_Math_pi": real; ()
 		  val pow = _import "pow": real * real -> real;
 		  val sin = _prim "Real64_Math_sin": real -> real;
 		  val sinh = _import "sinh": real -> real;
@@ -1339,9 +1338,9 @@
 	       _import "Real64_gdtoa": real * int * int * int ref -> CString.t;
 	    val fromInt = _prim "WordS32_toReal64": int -> real;
 	    val ldexp = _prim "Real64_ldexp": real * int -> real;
-	    val maxFinite = _import "Real64_maxFinite": real;
-	    val minNormalPos = _import "Real64_minNormalPos": real;
-	    val minPos = _import "Real64_minPos": real;
+	    val maxFinite = #1 _symbol "Real64_maxFinite": real; ()
+	    val minNormalPos = #1 _symbol "Real64_minNormalPos": real; ()
+	    val minPos = #1 _symbol "Real64_minPos": real; ()
 	    val modf = _import "Real64_modf": real * real ref -> real;
 	    val nextAfter = _import "Real64_nextAfter": real * real -> real;
 	    val round = _prim "Real64_round": real -> real;
@@ -1383,11 +1382,11 @@
 		  val atan2 = _prim "Real32_Math_atan2": real * real -> real;
 		  val cos = _prim "Real32_Math_cos": real -> real;
 		  val cosh = unary Real64.Math.cosh
-		  val e = _import "Real32_Math_e": real;
+		  val e = #1 _symbol "Real32_Math_e": real; ()
 		  val exp = _prim "Real32_Math_exp": real -> real;
 		  val ln = _prim "Real32_Math_ln": real -> real;
 		  val log10 = _prim "Real32_Math_log10": real -> real;
-		  val pi = _import "Real32_Math_pi": real;
+		  val pi = #1 _symbol "Real32_Math_pi": real; ()
 		  val pow = binary Real64.Math.pow
 		  val sin = _prim "Real32_Math_sin": real -> real;
 		  val sinh = unary Real64.Math.sinh
@@ -1414,9 +1413,9 @@
 	       _import "Real32_gdtoa": real * int * int * int ref -> CString.t;
 	    val fromInt = _prim "WordS32_toReal32": int -> real;
 	    val ldexp = _prim "Real32_ldexp": real * int -> real;
-	    val maxFinite = _import "Real32_maxFinite": real;
-	    val minNormalPos = _import "Real32_minNormalPos": real;
-	    val minPos = _import "Real32_minPos": real;
+	    val maxFinite = #1 _symbol "Real32_maxFinite": real; ()
+	    val minNormalPos = #1 _symbol "Real32_minNormalPos": real; ()
+	    val minPos = #1 _symbol "Real32_minPos": real; ()
 	    val modf = _import "Real32_modf": real * real ref -> real;
 	    val signBit = _import "Real32_signBit": real -> bool;
 	    val strto = _import "Real32_strto": NullString.t -> real;
Index: basis-library/posix/primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/primitive.sml,v
retrieving revision 1.39
diff -u -r1.39 primitive.sml
--- basis-library/posix/primitive.sml	19 Jul 2005 12:41:06 -0000	1.39
+++ basis-library/posix/primitive.sml	21 Jul 2005 15:00:23 -0000
@@ -299,7 +299,7 @@
 	       end
 
 	    val ctermid = _import "Posix_ProcEnv_ctermid" : unit -> cstring;
-	    val environ = _import "Posix_ProcEnv_environ" : cstringArray;
+	    val environ = #1 _symbol "Posix_ProcEnv_environ" : cstringArray; ()
 	    val getenv = _import "Posix_ProcEnv_getenv" : NullString.t -> cstring;
 	    val isatty = _import "Posix_ProcEnv_isatty" : fd -> bool;
 	    val sysconf = _import "Posix_ProcEnv_sysconf" : int -> int;
Index: mlton/ast/ast-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.fun,v
retrieving revision 1.33
diff -u -r1.33 ast-core.fun
--- mlton/ast/ast-core.fun	19 Jun 2005 21:33:41 -0000	1.33
+++ mlton/ast/ast-core.fun	21 Jul 2005 15:00:24 -0000
@@ -270,27 +270,40 @@
 	    val layout = Layout.str o toString
 	 end
 
+      structure SymAttribute =
+	 struct
+	    datatype t = Define
+
+	    val toString: t -> string =
+	       fn Define => "define"
+
+	    val layout = Layout.str o toString
+	 end
+
       datatype t =
-	 BuildConst of {name: string}
+	 Address of {name: string}
+       | BuildConst of {name: string}
        | CommandLineConst of {name: string, value: Const.t}
        | Const of {name: string}
        | Export of {attributes: Attribute.t list, name: string}
        | IImport of {attributes: Attribute.t list}
        | Import of {attributes: Attribute.t list, name: string}
-       | Symbol of {name: string}
        | Prim of {name: string}
+       | ISymbol of {attributes: SymAttribute.t list}
+       | Symbol of {attributes: SymAttribute.t list, name: string}
 
       fun name pk =
 	 case pk of
-	    BuildConst {name, ...} => name
+	    Address {name, ...} => name
+	  | BuildConst {name, ...} => name
 	  | CommandLineConst {name, ...} => name
 	  | Const {name, ...} => name
 	  | Export {name, ...} => name
 	  | IImport {...} => "<iimport>"
 	  | Import {name, ...} => name
-	  | Symbol {name, ...} => name
 	  | Prim {name, ...} => name
-
+	  | Symbol {name, ...} => name
+	  | ISymbol {...} => "<isymbol>"
    end
 
 structure Priority =
Index: mlton/ast/ast-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.sig,v
retrieving revision 1.20
diff -u -r1.20 ast-core.sig
--- mlton/ast/ast-core.sig	12 Jan 2005 21:56:00 -0000	1.20
+++ mlton/ast/ast-core.sig	21 Jul 2005 15:00:24 -0000
@@ -91,16 +91,25 @@
 		     
 		  val layout: t -> Layout.t
 	       end
+            
+            structure SymAttribute:
+               sig
+                  datatype t = Define
+		     
+		  val layout: t -> Layout.t
+               end
 	    
 	    datatype t =
-	       BuildConst of {name: string}
+	       Address of {name: string}
+	     | BuildConst of {name: string}
 	     | CommandLineConst of {name: string, value: Const.t}
 	     | Const of {name: string}
 	     | Export of {attributes: Attribute.t list, name: string}
 	     | IImport of {attributes: Attribute.t list}
 	     | Import of {attributes: Attribute.t list, name: string}
-	     | Symbol of {name: string}
 	     | Prim of {name: string}
+	     | ISymbol of {attributes: SymAttribute.t list}
+	     | Symbol of {attributes: SymAttribute.t list, name: string}
 	 end
 
       structure Priority:
Index: mlton/atoms/ffi.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/ffi.fun,v
retrieving revision 1.7
diff -u -r1.7 ffi.fun
--- mlton/atoms/ffi.fun	4 Apr 2004 06:50:14 -0000	1.7
+++ mlton/atoms/ffi.fun	21 Jul 2005 15:00:24 -0000
@@ -17,6 +17,8 @@
 	      id: int,
 	      name: string,
 	      res: CType.t option} list ref = ref []
+val symbols: {ty: CType.t,
+              name: string} list ref = ref []
 
 fun numExports () = List.length (!exports)
 
@@ -34,6 +36,8 @@
       in
 	 id
       end
+   fun addSymbol {ty, name} = 
+      ignore (List.push (symbols, {ty=ty, name=name}))
 end
 
 val headers: string list ref = ref []
@@ -77,6 +81,14 @@
 	  end)
       val _ = print "Int MLton_FFI_op;\n"
    in
+      List.foreach
+      (!symbols, fn {ty, name} =>
+       let
+          val decl = CType.toString ty ^ " " ^ name;
+       in
+         List.push (headers, "extern " ^ decl);
+         print (decl ^ ";\n")
+       end);
       List.foreach
       (!exports, fn {args, convention, id, name, res} =>
        let
Index: mlton/atoms/ffi.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/ffi.sig,v
retrieving revision 1.6
diff -u -r1.6 ffi.sig
--- mlton/atoms/ffi.sig	12 Apr 2004 17:52:48 -0000	1.6
+++ mlton/atoms/ffi.sig	21 Jul 2005 15:00:24 -0000
@@ -21,6 +21,8 @@
 		      convention: CFunction.Convention.t,
 		      name: string,
 		      res: CType.t option} -> int
+      val addSymbol: {ty: CType.t,
+                      name: string} -> unit
       val declareExports: {print: string -> unit} -> unit
       val declareHeaders: {print: string -> unit} -> unit
       val numExports: unit -> int
Index: mlton/atoms/prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.101
diff -u -r1.101 prim.fun
--- mlton/atoms/prim.fun	19 Jun 2005 21:33:43 -0000	1.101
+++ mlton/atoms/prim.fun	21 Jul 2005 15:00:25 -0000
@@ -46,7 +46,7 @@
  | Exn_setExtendExtra (* implement exceptions *)
  | Exn_setInitExtra (* implement exceptions *)
  | FFI of 'a CFunction.t (* ssa to rssa *)
- | FFI_Symbol of {name: string} (* codegen *)
+ | FFI_Symbol of {name: string, cty: CType.t} (* codegen *)
  | GC_collect (* ssa to rssa *)
  | IntInf_add (* ssa to rssa *)
  | IntInf_andb (* ssa to rssa *)
@@ -486,7 +486,7 @@
     | Exn_setExtendExtra => Exn_setExtendExtra
     | Exn_setInitExtra => Exn_setInitExtra
     | FFI func => FFI (CFunction.map (func, f))
-    | FFI_Symbol {name} => FFI_Symbol {name = name}
+    | FFI_Symbol {name, cty} => FFI_Symbol {name = name, cty = cty}
     | GC_collect => GC_collect
     | IntInf_add => IntInf_add
     | IntInf_andb => IntInf_andb
@@ -631,6 +631,22 @@
        | Word16 => Pointer_getWord (WordSize.fromBits (Bits.fromInt 16))
        | Word32 => Pointer_getWord (WordSize.fromBits (Bits.fromInt 32))
        | Word64 => Pointer_getWord (WordSize.fromBits (Bits.fromInt 64))
+   end
+fun pointerSet ctype =
+   let datatype z = datatype CType.t
+   in
+      case ctype of
+	 Int8 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 8))
+       | Int16 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 16))
+       | Int32 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 32))
+       | Int64 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 64))
+       | Pointer => Pointer_setPointer
+       | Real32 => Pointer_setReal RealSize.R32
+       | Real64 => Pointer_setReal RealSize.R64
+       | Word8 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 8))
+       | Word16 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 16))
+       | Word32 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 32))
+       | Word64 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 64))
    end
 
 val reff = Ref_ref
Index: mlton/atoms/prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.75
diff -u -r1.75 prim.sig
--- mlton/atoms/prim.sig	6 Mar 2005 22:09:44 -0000	1.75
+++ mlton/atoms/prim.sig	21 Jul 2005 15:00:25 -0000
@@ -35,7 +35,7 @@
 	     | Exn_setExtendExtra (* implement exceptions *)
 	     | Exn_setInitExtra (* implement exceptions *)
 	     | FFI of 'a CFunction.t (* ssa to rssa *)
-	     | FFI_Symbol of {name: string} (* codegen *)
+	     | FFI_Symbol of {name: string, cty: CType.t} (* codegen *)
 	     | GC_collect (* ssa to rssa *)
 	     | IntInf_add (* ssa to rssa *)
 	     | IntInf_andb (* ssa to rssa *)
@@ -215,7 +215,7 @@
 				deWeak: 'b -> 'b,
 				result: 'b} -> 'b vector
       val ffi: 'a CFunction.t -> 'a t
-      val ffiSymbol: {name: string} -> 'a t
+      val ffiSymbol: {name: string, cty: CType.t} -> 'a t
       val fromString: string -> 'a t
       val gcCollect: 'a t
       val intInfEqual: 'a t
@@ -239,6 +239,7 @@
        *)
       val maySideEffect: 'a t -> bool
       val pointerGet: CType.t -> 'a t
+      val pointerSet: CType.t -> 'a t
       val name: 'a t -> 'a Name.t
       val reff: 'a t
       val serialize: 'a t
Index: mlton/codegen/c-codegen/c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.106
diff -u -r1.106 c-codegen.fun
--- mlton/codegen/c-codegen/c-codegen.fun	19 Jun 2005 21:33:48 -0000	1.106
+++ mlton/codegen/c-codegen/c-codegen.fun	21 Jul 2005 15:00:25 -0000
@@ -461,13 +461,10 @@
 	      case s of
 		 Statement.PrimApp {prim, ...} =>
 		    (case Prim.name prim of
-			Prim.Name.FFI_Symbol {name, ...} =>
+			Prim.Name.FFI_Symbol {name, cty} =>
 			   doit
 			   (name, fn () =>
-			    (* Only take address of FFI_Symbol,
-			     * so no need for a type specifier
-			     *)
-			    concat ["extern ", name, ";\n"])
+			    concat ["extern ", CType.toString cty, " ", name, ";\n"])
 		      | _ => ())
 	       | _ => ())
 	  val _ =
Index: mlton/control/control-flags.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control-flags.sig,v
retrieving revision 1.3
diff -u -r1.3 control-flags.sig
--- mlton/control/control-flags.sig	19 Jul 2005 12:41:09 -0000	1.3
+++ mlton/control/control-flags.sig	21 Jul 2005 15:00:25 -0000
@@ -59,12 +59,14 @@
 	 sig
 	    type ('args, 'st) t
 
+	    val allowAddress: (bool,bool) t
 	    val allowConstant: (bool,bool) t
 	    val allowExport: (bool,bool) t
 	    val allowImport: (bool,bool) t
 	    val allowOverload: (bool,bool) t
 	    val allowPrim: (bool,bool) t
 	    val allowRebindEquals: (bool,bool) t
+	    val allowSymbol: (bool,bool) t
 	    val deadCode: (bool,bool) t
 	    val forceUsed: (unit,bool) t
 	    val ffiStr: (string,string option) t
Index: mlton/control/control-flags.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control-flags.sml,v
retrieving revision 1.4
diff -u -r1.4 control-flags.sml
--- mlton/control/control-flags.sml	19 Jul 2005 12:41:09 -0000	1.4
+++ mlton/control/control-flags.sml	21 Jul 2005 15:00:25 -0000
@@ -263,12 +263,17 @@
 				  [arg'] => Bool.fromString arg'
 				| _ => NONE}, 
 		  ac)
+	
+	fun setCur (T {cur, ...}, x) = cur := x
+	fun setDef (T {def, ...}, x) = def := x
       in
 	 val ac =
 	    {parseId = fn _ => NONE,
 	     parseIdAndArgs = fn _ => NONE,
 	     withDef = fn () => (fn () => ()),
 	     snapshot = fn () => fn () => (fn () => ())}
+	 val (allowAddress, ac) =
+	    makeBool ({name = "allowAddress", default = false, expert = false}, ac)
 	 val (allowConstant, ac) =
 	    makeBool ({name = "allowConstant", default = false, expert = true}, ac)
 	 val (allowExport, ac) =
@@ -281,8 +286,30 @@
 	    makeBool ({name = "allowOverload", default = false, expert = false}, ac)
 	 val (allowRebindEquals, ac) =
 	    makeBool ({name = "allowRebindEquals", default = false, expert = true}, ac)
+	 val (allowSymbol, ac) =
+	    makeBool ({name = "allowSymbol", default = false, expert = false}, ac)
 	 val (deadCode, ac) =
 	    makeBool ({name = "deadCode", default = false, expert = false}, ac)
+	 val (allowFFI, ac) =
+	    make ({default = false,
+	           expert = false,
+	           toString = Bool.toString,
+	           name = "allowFFI",
+	           newCur = fn (_, b) => (setCur (allowAddress, b)
+	          			  ; setCur (allowExport, b)
+	          			  ; setCur (allowImport, b)
+	          			  ; setCur (allowSymbol, b)
+	          			  ; b),
+	           newDef = fn (_, b) => (setDef (allowAddress, b)
+	          			  ; setDef (allowExport, b)
+	          			  ; setDef (allowImport, b)
+	          			  ; setDef (allowSymbol, b)
+	          			  ; b),
+		   parseArgs = fn args' =>
+		               case args' of
+				  [arg'] => Bool.fromString arg'
+				| _ => NONE}, 
+		  ac)
 	 val (forceUsed, ac) =
 	    make ({default = false,
 		   expert = false,
Index: mlton/elaborate/elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.152
diff -u -r1.152 elaborate-core.fun
--- mlton/elaborate/elaborate-core.fun	21 Jul 2005 05:57:57 -0000	1.152
+++ mlton/elaborate/elaborate-core.fun	21 Jul 2005 15:00:25 -0000
@@ -39,6 +39,7 @@
    structure Longtycon = Longtycon
    structure PrimKind = PrimKind
    structure Attribute = PrimKind.Attribute
+   structure SymAttribute = PrimKind.SymAttribute
    structure Priority = Priority
    structure Record = Record
    structure SortedRecord = SortedRecord
@@ -901,101 +902,259 @@
 	    end
    end
 
-fun fetchSymbol {attributes: Attribute.t list,
-		 name: string,
-		 primApp: {args: Cexp.t vector, 
-			   prim: Type.t Prim.t, 
-			   result: Type.t} -> Cexp.t,
-		 ty: Type.t,
-		 region: Region.t}: Cexp.t =
+fun primApp {args, prim, result: Type.t} =
    let
-      fun error l = Control.error (region, l, Layout.empty)
-      fun invalidAttributes () =
-	 error (seq [str "invalid attributes for import: ",
-		     List.layout Attribute.layout attributes])
-      val bogus = primApp {args = Vector.new0 (), 
-			   prim = Prim.bogus,
-			   result = ty}
+      val targs = Prim.extractTargs (prim,
+			             {args = Vector.map (args, Cexp.ty),
+			              deArray = Type.deArray,
+			              deArrow = Type.deArrow,
+			              deVector = Type.deVector,
+			              deWeak = Type.deWeak,
+				      result = result})
    in
-      case Type.toCType ty of
-	 NONE => 
-	    let
-	       val () =
-		  Control.error 
-		  (region,
-		   str "invalid type for import",
-		   Type.layoutPretty ty)
-	    in
-	       bogus
-	    end
-       | SOME {ctype, ...} => 
-	    (case attributes of
-		[] => 
-		   let
-		      val isBool =
-			 case Type.deConOpt ty of
-			    NONE => false
-			  | SOME (c,_) => Tycon.equals (c, Tycon.bool)
-		      val addrTy = 
-			 Type.word (WordSize.pointer ())
-		      val addrExp = 
-			 primApp
-			 {args = Vector.new0 (),
-			  prim = Prim.ffiSymbol {name = name},
-			  result = addrTy}
-		      val zeroExp =
-			 Cexp.make
-			 (Cexp.Const
-			  (fn () => Const.word (WordX.zero WordSize.default)),
-			  Type.defaultWord)
-		      val fetchTy =
-			 if isBool then Type.defaultWord else ty
-		      val fetchExp = 
-			 primApp 
-			 {args = Vector.new2 (addrExp,zeroExp),
-			  prim = Prim.pointerGet ctype,
-			  result = fetchTy}
-		   in
-		      if isBool 
-			 then Cexp.casee
-			      {kind = "",
-			       lay = fn () => Layout.empty,
-			       noMatch = Cexp.Impossible,
-			       region = Region.bogus,
-			       rules = Vector.new2
-			               ({exp = Cexp.truee,
-					 lay = NONE,
-					 pat = Cpat.falsee},
-					{exp = Cexp.falsee,
-					 lay = NONE,
-					 pat = Cpat.truee}),
-			       test = primApp
-				      {args = Vector.new2 (fetchExp, zeroExp),
-				       prim = Prim.wordEqual WordSize.default,
-				       result = ty},
-				      warnMatch = false}
-			 else fetchExp
-		   end
-	      | _ => 
-		   (invalidAttributes ()
-		    ; bogus))
+      Cexp.make (Cexp.PrimApp {args = args,
+			       prim = prim,
+			       targs = targs},
+                 result)
+   end
+
+val zeroExp = Cexp.make (Cexp.Const
+			 (fn () => Const.word (WordX.zero WordSize.default)),
+			 Type.defaultWord)
+val oneExp = Cexp.make (Cexp.Const
+			(fn () => Const.word (WordX.one WordSize.default)),
+			Type.defaultWord)
+
+fun address {name: string,
+	     tyt: Type.t,
+	     etyt: Type.t,
+	     region: Region.t}: Cexp.t =
+  let
+     val (etyp, ety) = 
+       case Type.deTuple etyt of
+          v => (Vector.sub (v, 0), Vector.sub (v, 1))
+     
+     val (typ, ty) =
+       case Type.deTuple tyt of
+          v => (Vector.sub (v, 0), Vector.sub (v, 1))
+     
+     val cty = 
+         case Type.toCType ety of
+            SOME {ctype, ...} => ctype
+          | NONE => 
+               case Type.deArrowOpt ety of
+                  SOME _ => CType.Pointer (* this might break future ports *)
+                | NONE =>
+                     (Control.error (region,
+                                     str "_address taken of non c-type",
+                                     Type.layoutPretty ty)
+                      ; CType.Pointer) (* sane default for the error-case *)
+   in
+     case Type.toCType etyp of
+        SOME {ctype = CType.Pointer, ...} =>
+           primApp {args = Vector.new0 (),
+                    prim = Prim.ffiSymbol {name = name, cty = cty},
+                    result = typ}
+      | _ =>
+	   (Control.error (region,
+	  	           str "invalid type for _address (must be pointer)",
+		           Type.layoutPretty typ)
+            ; primApp {args = Vector.new0 (), prim = Prim.bogus, result = typ})
    end
 
-fun symbol {name: string,
-	    ty: Type.t,
-	    region: Region.t}: Type.t Prim.t =
-   case Type.toCType ty of
+fun fetchSymbol {ptr: Cexp.t,
+                 ty: Type.t,
+                 ety: Type.t,
+                 region: Region.t}: Cexp.t =
+   case Type.toCType ety of
+      NONE => 
+        let
+	   val () = Control.error (region,
+	                           str "invalid type for _symbol",
+	                           Type.layoutPretty ty)
+	in
+           primApp {args = Vector.new0 (), prim = Prim.bogus, result = ty}
+	end
+    | SOME {ctype, ...} => 
+	let
+	   val isBool =
+              case Type.deConOpt ety of
+	         NONE => false
+	       | SOME (c,_) => Tycon.equals (c, Tycon.bool)
+           val fetchExp = 
+              primApp {args = Vector.new2 (ptr, zeroExp),
+		       prim = Prim.pointerGet ctype,
+		       result = if isBool then Type.defaultWord else ty}
+        in
+          if not isBool then fetchExp else
+          Cexp.casee {kind = "",
+		      lay = fn () => Layout.empty,
+		      noMatch = Cexp.Impossible,
+		      region = Region.bogus,
+		      rules = Vector.new2
+                            ({exp = Cexp.truee,  lay = NONE, pat = Cpat.falsee},
+		             {exp = Cexp.falsee, lay = NONE, pat = Cpat.truee}),
+		      test = primApp
+		             {args = Vector.new2 (fetchExp, zeroExp),
+		              prim = Prim.wordEqual WordSize.default,
+		              result = ty},
+                      warnMatch = false}
+	end
+
+fun storeSymbol {ptr: Cexp.t,
+                 value: Var.t,
+                 ety: Type.t,
+                 region: Region.t}: Cexp.t =
+   case Type.toCType ety of
+      NONE => 
+        (* do not give an error b/c fetchSymbol did *)
+        primApp {args = Vector.new0 (), prim = Prim.bogus, result = Type.unit}
+    | SOME {ctype, ...} => 
+	let
+	   val isBool =
+              case Type.deConOpt ety of
+	         NONE => false
+	       | SOME (c,_) => Tycon.equals (c, Tycon.bool)
+           val varExp = Cexp.var (value, ety)
+           val varExp =
+              if not isBool then varExp else
+              Cexp.casee {kind = "",
+                          lay = fn () => Layout.empty,
+                          noMatch = Cexp.Impossible,
+                          region = Region.bogus,
+                          rules = Vector.new2
+                            ({exp = oneExp,  lay = NONE, pat = Cpat.truee},
+		             {exp = zeroExp, lay = NONE, pat = Cpat.falsee}),
+                          test = varExp,
+                          warnMatch = false}
+        in
+           primApp {args = Vector.new3 (ptr, zeroExp, varExp),
+		    prim = Prim.pointerSet ctype,
+		    result = Type.unit}
+	end
+
+fun symbolName {attributes: SymAttribute.t list,
+                name: string,
+                ty: Type.t,
+                ety: Type.t,
+                region: Region.t}: Cexp.t =
+  let
+     val getarg = Var.newNoname ()
+     val setarg = Var.newNoname ()
+     val cty = 
+         case Type.toCType ety of
+            SOME {ctype, ...} => ctype
+          | NONE => CType.Pointer (* sane default for the error-case *)
+     val export =
+         case attributes of [] => () | _ => 
+         Ffi.addSymbol { name = name, ty = cty }
+     val ptr =
+         primApp {args = Vector.new0 (),
+		  prim = Prim.ffiSymbol {name = name, cty = cty },
+		  result = Type.word (WordSize.pointer ())}
+  in
+     Cexp.tuple (Vector.new2 (
+        Cexp.lambda (
+           Lambda.make { arg = getarg,
+                         argType = Type.unit,
+                         body = fetchSymbol { ptr=ptr, ty=ty, ety=ety, region=region },
+                         mayInline = true}),
+        Cexp.lambda (
+           Lambda.make { arg = setarg,
+                         argType = ty,
+                         body = storeSymbol { ptr=ptr, value=setarg, ety=ety, region=region },
+                         mayInline = true})))
+  end
+
+fun symbolStar {attributes: SymAttribute.t list,
+                tyt: Type.t,
+                etyt: Type.t,
+                region: Region.t}: Cexp.t =
+  let
+     val (etyp, ety) = 
+       case Type.deTuple etyt of
+          v => (Vector.sub (v, 0), Vector.sub (v, 1))
+     
+     val (typ, ty) =
+       case Type.deTuple tyt of
+          v => (Vector.sub (v, 0), Vector.sub (v, 1))
+    
+     val () = 
+        case attributes of [] => () | _ =>
+           Control.error (region,
+                          str "define option unsupported for _symbol *",
+                          empty)
+     
+     val getarg  = Var.newNoname ()
+     val setarg  = Var.newNoname ()
+     val setarg1 = Var.newNoname ()
+     val setarg2 = Var.newNoname ()
+     
+     val getptr = Cexp.var (getarg,  Type.word (WordSize.pointer ()))
+     val setptr = Cexp.var (setarg1, Type.word (WordSize.pointer ()))
+     
+     val fetchExp = fetchSymbol { ptr=getptr, ty=ty, ety=ety, region=region }
+     val storeExp = storeSymbol { ptr=setptr, value=setarg2, ety=ety, region=region }
+     
+     val setpat  = Cpat.tuple (Vector.new2 (Cpat.var (setarg1, etyp), 
+                                            Cpat.var (setarg2, ety)))
+     val setbody = Cexp.casee {kind = "",
+                               lay = fn () => Layout.empty,
+                               noMatch = Cexp.Impossible,
+                               region = Region.bogus,
+                               rules = Vector.new1
+                                  ({exp = storeExp, lay = NONE, pat = setpat}),
+                               test = Cexp.var (setarg, etyt),
+                               warnMatch = false}
+  in
+   case Type.toCType etyp of
       SOME {ctype = CType.Pointer, ...} =>
-	 Prim.ffiSymbol {name = name}
+         Cexp.tuple (Vector.new2 (
+            Cexp.lambda (
+               Lambda.make { arg = getarg,
+                             argType = typ,
+                             body = fetchExp,
+                             mayInline = true}),
+            Cexp.lambda (
+               Lambda.make { arg = setarg,
+                             argType = tyt,
+                             body = setbody,
+                             mayInline = true})))
     | _ =>
-	 let
-	    val () =
-	       Control.error (region,
-			      str "invalid type for import",
-			      Type.layoutPretty ty)
-	 in
-	    Prim.bogus
-	 end
+	 (Control.error (region,
+			 str "invalid type for _symbol (must be pointer)",
+			 Type.layoutPretty typ)
+          ; primApp {args = Vector.new0 (), prim = Prim.bogus, result = tyt})
+  end
+
+fun importSymbol {attributes: Attribute.t list,
+		  name: string,
+		  ty: Type.t,
+		  ety: Type.t,
+		  region: Region.t}: Cexp.t =
+   let
+     val cty = 
+         case Type.toCType ety of
+            SOME {ctype, ...} => ctype
+          | NONE => CType.Pointer (* sane default for the error-case *)
+      val addrExp = 
+         primApp {args = Vector.new0 (),
+		  prim = Prim.ffiSymbol {name = name, cty = cty },
+		  result = Type.word (WordSize.pointer ())}
+   in
+      case attributes of
+         [] => 
+          (Control.warning (region,
+                            str "_import of constant is deprecated. Use _symbol",
+			    empty);
+           fetchSymbol { ptr=addrExp, ty=ty, ety=ety, region=region })
+       | _ => 
+          (Control.error (region, 
+                          seq [str "invalid attributes for import: ",
+		               List.layout Attribute.layout attributes],
+                          empty);
+           primApp {args = Vector.new0 (), prim = Prim.bogus, result = ty})
+   end
 
 fun export {attributes, name: string, region: Region.t, ty: Type.t}: Aexp.t =
    let
@@ -2280,23 +2439,6 @@
 		       * of the code expects to see.
 		       *)
 		      fun wrap (e, t) = Cexp.make (Cexp.node e, t)
-		      fun primApp {args, prim, result: Type.t} =
-			 let
-			    val targs =
-			       Prim.extractTargs
-			       (prim,
-				{args = Vector.map (args, Cexp.ty),
-				 deArray = Type.deArray,
-				 deArrow = Type.deArrow,
-				 deVector = Type.deVector,
-				 deWeak = Type.deWeak,
-				 result = result})
-			 in
-			    Cexp.make (Cexp.PrimApp {args = args,
-						     prim = prim,
-						     targs = targs},
-				       result)
-			 end
 		      fun etaExtra (extra, ty, expandedTy,
 				    p: Type.t Prim.t): Cexp.t =
 			 case Type.deArrowOpt expandedTy of
@@ -2399,7 +2541,13 @@
 		      datatype z = datatype Ast.PrimKind.t
 		   in
 		      case kind of
-			 BuildConst {name} =>
+		         Address {name} =>
+			    (check (ElabControl.allowAddress, "_address")
+			     ; address {name = name,
+                                        region = region,
+					tyt = ty,
+					etyt = expandedTy})
+	               | BuildConst {name} =>
 			    (check (ElabControl.allowConstant, "_build_const")
 			     ; lookConst {default = NONE, name = name})
 		       | CommandLineConst {name, value} =>
@@ -2499,24 +2647,32 @@
 			    (check (ElabControl.allowImport, "_import")
 			     ; (case Type.deArrowOpt expandedTy of
 				   NONE => 
-				      wrap (fetchSymbol {attributes = attributes,
-							 name = name,
-							 primApp = primApp,
-							 region = region,
-							 ty = expandedTy}, ty)
+                                       importSymbol {attributes = attributes,
+						     name = name,
+						     region = region,
+						     ty = ty,
+						     ety = expandedTy}
 				 | SOME _ =>
-				      eta (import {attributes = attributes,
-						   name = SOME name,
-						   region = region,
-						   ty = expandedTy})))
-		       | Symbol {name} =>
-			    (check (ElabControl.allowImport, "_import")
-			     ; eta (symbol {name = name,
-					    region = region,
-					    ty = expandedTy}))
+                                       eta (import {attributes = attributes,
+					            name = SOME name,
+						    region = region,
+						    ty = expandedTy})))
 		       | Prim {name} => 
 			    (check (ElabControl.allowPrim, "_prim")
 			     ; eta (Prim.fromString name))
+                       | ISymbol {attributes} =>
+                            (check (ElabControl.allowSymbol, "_symbol")
+                             ; symbolStar {attributes = attributes,
+                                           region = region,
+                                           tyt = ty,
+                                           etyt = expandedTy})
+                       | Symbol {attributes, name} =>
+                            (check (ElabControl.allowSymbol, "_symbol")
+			     ; symbolName {name = name,
+			                   attributes = attributes,
+					   region = region,
+					   ty = ty,
+					   ety = expandedTy})
 		   end
 	      | Aexp.Raise exn =>
 		   let
Index: mlton/front-end/ml.grm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.grm,v
retrieving revision 1.44
diff -u -r1.44 ml.grm
--- mlton/front-end/ml.grm	19 Jul 2005 16:52:28 -0000	1.44
+++ mlton/front-end/ml.grm	21 Jul 2005 15:00:25 -0000
@@ -232,7 +232,8 @@
     | RBRACKET | REC | RPAREN | SEMICOLON | SHARING | SIG | SIGNATURE | STRUCT
     | STRUCTURE | THEN | TYPE | VAL | WHERE | WHILE | WILD | WITH | WITHTYPE
       (* Extensions *)
-    | BUILD_CONST | COMMAND_LINE_CONST | CONST | EXPORT | IMPORT | PRIM
+    | ADDRESS | BUILD_CONST | COMMAND_LINE_CONST | CONST | EXPORT | IMPORT 
+    | SYMBOL | PRIM
 
 %nonterm
          aexp of Exp.node
@@ -365,6 +366,7 @@
        | strexpnode of Strexp.node
        | strid of Strid.t
        | string of string
+       | symattributes of PrimKind.SymAttribute.t list
        | tlabel of (Field.t * Type.t)
        | tlabels  of (Field.t * Type.t) list
        | topdec of Topdec.t
@@ -1006,6 +1008,11 @@
 	    (Exp.Let (decs, Exp.makeRegion' (Exp.Seq (Vector.fromList exp_ps),
 					     exp_psleft,
 					     exp_psright)))
+        | ADDRESS string COLON ty COMMA ty SEMICOLON
+          (Exp.Prim {kind = PrimKind.Address {name = string},
+                     ty = Type.makeRegion' (
+                             Type.tuple (Vector.new2 (ty1, ty2)),
+                             ty1left, ty2right)})
         | BUILD_CONST string COLON ty SEMICOLON
 	  (Exp.Prim {kind = PrimKind.BuildConst {name = string}, 
                      ty = ty})
@@ -1025,14 +1032,20 @@
                                              name = string},
 		     ty = ty})
 	| IMPORT ASTERISK attributes COLON ty SEMICOLON
-	  (Exp.Prim {kind = PrimKind.IImport {attributes = attributes},
-		     ty = ty})
-	| IMPORT HASH string COLON ty SEMICOLON
-	  (Exp.Prim {kind = PrimKind.Symbol {name = string},
-		     ty = ty})
+          (Exp.Prim {kind = PrimKind.IImport {attributes = attributes},
+		      ty = ty})
         | PRIM string COLON ty SEMICOLON
 	  (Exp.Prim {kind = PrimKind.Prim {name = string}, 
                      ty = ty})
+        | SYMBOL string symattributes COLON ty SEMICOLON
+          (Exp.Prim {kind = PrimKind.Symbol {attributes = symattributes,
+                                             name = string},
+                     ty = ty})
+        | SYMBOL ASTERISK symattributes COLON ty COMMA ty SEMICOLON
+          (Exp.Prim {kind = PrimKind.ISymbol {attributes = symattributes},
+                     ty = Type.makeRegion' (
+                             Type.tuple (Vector.new2 (ty1, ty2)),
+                             ty1left, ty2right)})
 
 attributes
    :
@@ -1046,6 +1059,19 @@
 	  | "stdcall" => PrimKind.Attribute.Stdcall :: attributes
 	  | _ => (error (reg (idleft, idright), concat ["invalid attribute", id])
 		  ; attributes)
+      end)
+
+symattributes
+   :
+     ([])
+   | id symattributes
+     (let
+	 val id = Symbol.toString (#1 id)
+      in
+	 case id of
+	    "define" => PrimKind.SymAttribute.Define :: symattributes
+	  | _ => (error (reg (idleft, idright), concat ["invalid attribute", id])
+		  ; symattributes)
       end)
 
 exp_2c	: exp COMMA exp_2c	(exp :: exp_2c)
Index: mlton/front-end/ml.lex
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.lex,v
retrieving revision 1.21
diff -u -r1.21 ml.lex
--- mlton/front-end/ml.lex	19 Jul 2005 16:52:28 -0000	1.21
+++ mlton/front-end/ml.lex	21 Jul 2005 15:00:25 -0000
@@ -139,6 +139,8 @@
 %%
 <INITIAL>{ws}	=> (continue ());
 <INITIAL>{eol}	=> (Source.newline (source, yypos); continue ());
+<INITIAL>"_address" =>
+   (tok (Tokens.ADDRESS, source, yypos, yypos + size yytext));
 <INITIAL>"_build_const" =>
    (tok (Tokens.BUILD_CONST, source, yypos, yypos + size yytext));
 <INITIAL>"_command_line_const" =>
@@ -151,6 +153,8 @@
    (tok (Tokens.IMPORT, source, yypos, yypos + size yytext));
 <INITIAL>"_overload" =>
    (tok (Tokens.OVERLOAD, source, yypos, yypos + size yytext));
+<INITIAL>"_symbol" =>
+   (tok (Tokens.SYMBOL, source, yypos, yypos + size yytext));
 <INITIAL>"_prim" =>
    (tok (Tokens.PRIM, source, yypos, yypos + size yytext));
 <INITIAL>"_"	=> (tok (Tokens.WILD, source, yypos, yypos + 1));

--1yeeQ81UyVL57Vl7--