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