[MLton] Re: Type of _address?
Wesley W. Terpstra
wesley@terpstra.ca
Thu, 21 Jul 2005 15:23:49 +0200
--bp/iNruPH9dso1Pn
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline
Content-Transfer-Encoding: quoted-printable
On Thu, Jul 21, 2005 at 07:53:27AM -0400, Matthew Fluet wrote:
> Is there really a problem with just having
> extern symbol;
> if the address-of operation is always cast?
Well, I just get really scared when I see something like that.
There are platforms where pointers to different types are different, and
casts don't always seem to work. I don't really understand the magic behind
the scenes for alignment, bounce functions, etc. What I know is that if I
keep the right type where it should be, then it 'just works'. If I start
trying to cast pointers, invariably people have filed bug reports against
my package on platforms I don't have.
Since we intend to make _address part of the documented API, I think it
makes sense to cover the eventuality of having to deal with those systems.
Even if we make no use of the type field yet, we have the option to later.
> For example, the C-codegen for _import * inserts a cast to a function
> pointer type.
I think this is particularily questionable. Casting an int (what you get if
you say nothing) to a function is almost certainly a bad idea. I think some
systems have distinct address spaces for data and code. OTOH, for now I have
elected to use CType.Pointer for functions. ;-) If there is a platform that
breaks in the future, the porter has the hook needed to fix it.
> > I am considering changing the _address syntax from:
> > _address "x": MLton.Pointer.t;
> > to: _address "x": MLton.Pointer.t, int;
> >
> > My reason for this is that I recall doing an 'extern foo;' caused troub=
le on
> > hppa for profiling. I wonder if it will cause trouble in this case too.=
=2E.
> > (ie: a char* pointer differs from an int* pointer)
>=20
> That seems to make sense. OTOH, the point of importing an address withou=
t=20
> the pointed-to type information is that one could then use arbitrary=20
> MLton.Pointer.{get,set}* functions on it. The disconcerting bit is that=
=20
> the pointed-to type will now have absolutely no influence on the=20
> elaborated type.
Sure, and here I invoke your rule of: you are using the FFI, you had better
have a good idea what you're doing! If you are using the FFI to unsafely
cast between two different C types, well---you asked for what you get. =3D)
> > Err - rather, I just made _import # use CType.Pointer.
>=20
> I think that is fine. In fact, since _import # has never been a=20
> documented feature, then I think we could safely just drop it without=20
> going through deprecation.
Dropping it would eliminate a small bug I introduced to keep it backwards
compatible: _import # secretly accepts a tuple now. If Stephen also says
kill _import #, then it's just a deletion from the grammar and the two
commented alternative cases in elaborate-core.fun.
I've managed to get 'define' working for the c-codegen, but I have no idea
what to do about the x86-codegen. I looked at gcc's output and it seems to:
=2Eglobl yoursym
.data (only if the type was long long)
.align x (x =3D size in bytes)
.type yoursym, @object
.size yoursym, x (x =3D size in bytes)
.quad 0x098098098 (if was a long long)
.long 3234 (if was a long)
.value 4343 (if was a short)
.byte 454 (if was a char)
Would you mind adding this last bit to the patch?
I've attached what I have so far.
It now includes 'allowFFI' to enable allow{Export,Import,Address,Symbol}.
The _address now takes two types just like _symbol *. _symbol * and "x"
both appear to work and are now using opaque types (thanks Stephen). I
also changed the entire basis to use _symbol.
=46rom what I can do, I think it's good enough for a first commit, except t=
hat
the FFI_Symbol { export=3Dtrue } case is silently ignored by the x86-codege=
n.
--=20
Wesley W. Terpstra
--bp/iNruPH9dso1Pn
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="symbol.patch"
? x
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 13:09:35 -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 13:09:36 -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 13:09:36 -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 13:09:37 -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 13:09:37 -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/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 13:09:37 -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, export: bool} (* codegen *)
| GC_collect (* ssa to rssa *)
| IntInf_add (* ssa to rssa *)
| IntInf_andb (* ssa to rssa *)
@@ -486,7 +486,8 @@
| 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, export} =>
+ FFI_Symbol {name = name, cty = cty, export = export}
| GC_collect => GC_collect
| IntInf_add => IntInf_add
| IntInf_andb => IntInf_andb
@@ -631,6 +632,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 13:09:37 -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, export: bool} (* 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, export: bool} -> '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 13:09:37 -0000
@@ -442,14 +442,17 @@
fun declareFFI (Chunk.T {blocks, ...}, {print: string -> unit}) =
let
- val seen = String.memoize (fn _ => ref false)
- fun doit (name: string, declare: unit -> string): unit =
+ datatype condition = EXTERNAL | EXPORTED | NONE
+ val seen = String.memoize (fn _ => ref NONE)
+ fun doit (name: string, export: bool, declare: unit -> string): unit =
let
val r = seen name
in
- if !r
- then ()
- else (r := true; print (declare ()))
+ case (export, !r) of
+ (true, NONE) => (r := EXPORTED; print (declare ()))
+ | (false, NONE) => (r := EXTERNAL; print (declare ()))
+ | (true, EXTERNAL) => (r := EXPORTED; print (declare ()))
+ | _ => ()
end
in
Vector.foreach
@@ -461,13 +464,15 @@
case s of
Statement.PrimApp {prim, ...} =>
(case Prim.name prim of
- Prim.Name.FFI_Symbol {name, ...} =>
+ Prim.Name.FFI_Symbol {name, cty, export} =>
doit
- (name, fn () =>
- (* Only take address of FFI_Symbol,
- * so no need for a type specifier
- *)
- concat ["extern ", name, ";\n"])
+ (name, export, fn () =>
+ concat [
+ if export then "" else "extern ",
+ CType.toString cty,
+ " ",
+ name,
+ ";\n"])
| _ => ())
| _ => ())
val _ =
@@ -480,7 +485,7 @@
case target of
Direct "Thread_returnToC" => ()
| Direct name =>
- doit (name, fn () =>
+ doit (name, true, fn () =>
concat [CFunction.cPrototype func, ";\n"])
| Indirect => ()
end
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 13:09:38 -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 13:09:38 -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.151
diff -u -r1.151 elaborate-core.fun
--- mlton/elaborate/elaborate-core.fun 19 Jun 2005 21:33:58 -0000 1.151
+++ mlton/elaborate/elaborate-core.fun 21 Jul 2005 13:09:38 -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
@@ -889,101 +890,266 @@
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
-fun symbol {name: string,
- ty: Type.t,
- region: Region.t}: Type.t Prim.t =
- case Type.toCType ty of
+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.deTupleOpt etyt of
+ SOME v => (Vector.sub (v, 0), Vector.sub (v, 1))
+ | NONE => (etyt, Type.pointer) (* fallback for _import # *)
+
+ val (typ, ty) =
+ case Type.deTupleOpt tyt of
+ SOME v => (Vector.sub (v, 0), Vector.sub (v, 1))
+ | NONE => (tyt, tyt) (* fallback for _import # *)
+
+ 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,
+ export = false},
+ 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 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 [] => false | _ => true
+ val ptr =
+ primApp {args = Vector.new0 (),
+ prim = Prim.ffiSymbol {name = name, cty = cty, export = export},
+ 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 etyv = Type.deTuple etyt
+ val etyp = Vector.sub (etyv, 0)
+ val ety = Vector.sub (etyv, 1)
+
+ val tyv = Type.deTuple tyt
+ val typ = Vector.sub (tyv, 0)
+ val ty = Vector.sub (tyv, 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)
+ str "invalid type for _symbol (must be pointer)",
+ Type.layoutPretty typ)
in
- Prim.bogus
+ primApp {args = Vector.new0 (), prim = Prim.bogus, result = tyt}
end
+ 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, export = false},
+ 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
@@ -2268,23 +2434,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
@@ -2387,7 +2536,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} =>
@@ -2487,24 +2642,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 13:09:38 -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,27 @@
name = string},
ty = ty})
| IMPORT ASTERISK attributes COLON ty SEMICOLON
- (Exp.Prim {kind = PrimKind.IImport {attributes = attributes},
- ty = ty})
+ (Exp.Prim {kind = PrimKind.IImport {attributes = attributes},
+ ty = ty})
| IMPORT HASH string COLON ty SEMICOLON
- (Exp.Prim {kind = PrimKind.Symbol {name = string},
- ty = ty})
+ (Control.warning
+ (reg (IMPORTleft, SEMICOLONright),
+ Layout.str "_import # is deprecated. Use _address",
+ Layout.empty)
+ ; Exp.Prim {kind = PrimKind.Address {name = string},
+ 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 +1066,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 13:09:38 -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));
--bp/iNruPH9dso1Pn--