[MLton] cvs commit: added MLton.Pointer
sweeks@mlton.org
sweeks@mlton.org
Mon, 1 Dec 2003 10:22:21 -0800
sweeks 03/12/01 10:22:20
Modified: basis-library/libs build
basis-library/libs/basis-2002/top-level basis.sig
basis-library/misc C.sml primitive.sml
basis-library/mlton ffi.sig mlton.sig mlton.sml
basis-library/posix error.sml file-sys.sml primitive.sml
proc-env.sml
include c-chunk.h
mlton/ast word-size.fun word-size.sig
mlton/atoms prim.fun prim.sig
mlton/backend machine-atoms.fun machine-atoms.sig
machine.fun representation.fun rssa.fun
signal-check.fun ssa-to-rssa.fun
mlton/codegen/c-codegen c-codegen.fun
mlton/codegen/x86-codegen x86-mlton.fun
mlton/ssa ssa-tree.fun ssa-tree.sig
Added: basis-library/mlton pointer.sig pointer.sml
Log:
MAIL added MLton.Pointer
Added structure MLton.Pointer. It has all the operations I proposed
in my earlier mail except for phantom types. I didn't put those in
because they can now be done in user programs because the FFI looks
under opaque types.
Added get and set functions at all the types Int{8,16,32,64},
Real{32,64}, Word{8,16,32,64}. I made them slightly more general than
before, treating the pointer as an array and allowing an array
offset.
val getInt32: t * int -> Int32.int
val setInt32: t * int * Int32.int -> unit
So, if in C we have "int *a" where a points to some array, then in SML
we can do
val a = _import "a": MLton.Pointer.t;
val _ = MLton.Pointer.getInt32 (a, 13)
You can follow a pointer by using offset 0.
Adding get* and set* required a family of new Pointer_ primitives in
the compiler. These are implemented in SsaToRssa, which is when the
ArrayOffset operand is first introduced.
I went ahead and implemented MLton.Pointer.t as Word32.word, which
made it easy to do some stuff without adding more primitives.
Eliminating the built in pointer type also let me remove some code
from the compiler. If we decide that we don't like having the
knowledge of the word size of pointers in the basis library, then it
will be easy enough to add a couple of primitives and the primitive
type. Although if we do, I would recommend replacing the primitive
type in the front end with the appropriate word size instead of
pushing it all the way to the backend as we used to.
Eliminating the CPointer type from Rssa and Machine did create more
places for type unsafety in those ILs since we now must allow unsafe
pointer get and set on Word32s. I don't know how much of a loss this
really is.
Revision Changes Path
1.27 +2 -0 mlton/basis-library/libs/build
Index: build
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/build,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- build 16 Nov 2003 14:21:08 -0000 1.26
+++ build 1 Dec 2003 18:22:16 -0000 1.27
@@ -199,6 +199,8 @@
mlton/int-inf.sig
mlton/platform.sig
mlton/platform.sml
+mlton/pointer.sig
+mlton/pointer.sml
mlton/proc-env.sig
mlton/proc-env.sml
mlton/profile.sig
1.25 +0 -1 mlton/basis-library/libs/basis-2002/top-level/basis.sig
Index: basis.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/basis.sig,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- basis.sig 24 Nov 2003 02:57:32 -0000 1.24
+++ basis.sig 1 Dec 2003 18:22:16 -0000 1.25
@@ -541,7 +541,6 @@
where type exn = exn
where type int = int
where type order = order
- where type MLton.pointer = MLton.pointer
where type real = real
where type string = string
where type substring = substring
1.5 +1 -1 mlton/basis-library/misc/C.sml
Index: C.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/C.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- C.sml 23 Jun 2003 04:25:55 -0000 1.4
+++ C.sml 1 Dec 2003 18:22:17 -0000 1.5
@@ -57,7 +57,7 @@
struct
open Prim.CSS
- val length = makeLength (sub, Primitive.Cpointer.isNull)
+ val length = makeLength (sub, Primitive.Pointer.isNull)
val toArrayOfLength =
fn (css, n) => toArrayOfLength (css, CS.toString o sub, n)
1.88 +42 -10 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.87
retrieving revision 1.88
diff -u -r1.87 -r1.88
--- primitive.sml 29 Nov 2003 09:33:24 -0000 1.87
+++ primitive.sml 1 Dec 2003 18:22:17 -0000 1.88
@@ -52,7 +52,6 @@
end
structure LargeInt = IntInf
datatype list = datatype list
-type pointer = pointer (* C integer, not SML heap pointer *)
structure Real32 =
struct
@@ -97,6 +96,11 @@
type real = Real.real
type word = Word.word
+structure Pointer =
+ struct
+ type t = Word32.word
+ end
+
exception Bind = Bind
exception Fail of string
exception Match = Match
@@ -150,7 +154,7 @@
(* char* *)
structure CS =
struct
- type t = pointer
+ type t = Pointer.t
val sub = _import "C_CS_sub": t * int -> char;
val update =
@@ -163,7 +167,7 @@
(* char** *)
structure CSS =
struct
- type t = pointer
+ type t = Pointer.t
val sub = _import "C_CSS_sub": t * int -> CS.t;
end
@@ -191,11 +195,6 @@
val commandName = fn () => _import "CommandLine_commandName": cstring;
end
- structure Cpointer =
- struct
- val isNull = _prim "Cpointer_isNull": pointer -> bool;
- end
-
structure Date =
struct
type time = int
@@ -265,7 +264,6 @@
val getInt32 = _import "MLton_FFI_getInt32": int -> Int32.int;
val getInt64 = _import "MLton_FFI_getInt64": int -> Int64.int;
val getOp = _import "MLton_FFI_getOp": unit -> int;
- val getPointer = fn z => _prim "FFI_getPointer": int -> 'a; z
val getReal32 = _import "MLton_FFI_getReal32": int -> Real32.real;
val getReal64 = _import "MLton_FFI_getReal64": int -> Real64.real;
val getWord8 = _import "MLton_FFI_getWord8": int -> Word8.word;
@@ -276,7 +274,6 @@
val setInt16 = _import "MLton_FFI_setInt16": Int16.int -> unit;
val setInt32 = _import "MLton_FFI_setInt32": Int32.int -> unit;
val setInt64 = _import "MLton_FFI_setInt64": Int64.int -> unit;
- val setPointer = fn z => _prim "FFI_setPointer": 'a -> unit; z
val setReal32 = _import "MLton_FFI_setReal32": Real32.real -> unit;
val setReal64 = _import "MLton_FFI_setReal64": Real64.real -> unit;
val setWord8 = _import "MLton_FFI_setWord8": Word8.word -> unit;
@@ -720,6 +717,41 @@
_import "PackReal64_update": word8 array * int * real -> unit;
val updateRev =
_import "PackReal64_updateRev": word8 array * int * real -> unit;
+ end
+
+ structure Pointer =
+ struct
+ open Pointer
+
+ val null: t = 0w0
+ fun isNull p = p = null
+
+ val getInt8 = _prim "Pointer_getInt8": t * int -> Int8.int;
+ val getInt16 = _prim "Pointer_getInt16": t * int -> Int16.int;
+ val getInt32 = _prim "Pointer_getInt32": t * int -> Int32.int;
+ val getInt64 = _prim "Pointer_getInt64": t * int -> Int64.int;
+ val getReal32 = _prim "Pointer_getReal32": t * int -> Real32.real;
+ val getReal64 = _prim "Pointer_getReal64": t * int -> Real64.real;
+ val getWord8 = _prim "Pointer_getWord8": t * int -> Word8.word;
+ val getWord16 = _prim "Pointer_getWord16": t * int -> Word16.word;
+ val getWord32 = _prim "Pointer_getWord32": t * int -> Word32.word;
+ val getWord64 = _prim "Pointer_getWord64": t * int -> Word64.word;
+ val setInt8 = _prim "Pointer_setInt8": t * int * Int8.int -> unit;
+ val setInt16 = _prim "Pointer_setInt16": t * int * Int16.int -> unit;
+ val setInt32 = _prim "Pointer_setInt32": t * int * Int32.int -> unit;
+ val setInt64 = _prim "Pointer_setInt64": t * int * Int64.int -> unit;
+ val setReal32 =
+ _prim "Pointer_setReal32": t * int * Real32.real -> unit;
+ val setReal64 =
+ _prim "Pointer_setReal64": t * int * Real64.real -> unit;
+ val setWord8 =
+ _prim "Pointer_setWord8": t * int * Word8.word -> unit;
+ val setWord16 =
+ _prim "Pointer_setWord16": t * int * Word16.word -> unit;
+ val setWord32 =
+ _prim "Pointer_setWord32": t * int * Word32.word -> unit;
+ val setWord64 =
+ _prim "Pointer_setWord64": t * int * Word64.word -> unit;
end
structure Ptrace =
1.3 +0 -2 mlton/basis-library/mlton/ffi.sig
Index: ffi.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/ffi.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- ffi.sig 24 Jun 2003 20:14:21 -0000 1.2
+++ ffi.sig 1 Dec 2003 18:22:17 -0000 1.3
@@ -8,7 +8,6 @@
val getInt16: int -> Int16.int
val getInt32: int -> Int32.int
val getInt64: int -> Int64.int
- val getPointer: int -> 'a
val getReal32: int -> Real32.real
val getReal64: int -> Real64.real
val getWord8: int -> Word8.word
@@ -21,7 +20,6 @@
val setInt16: Int16.int -> unit
val setInt32: Int32.int -> unit
val setInt64: Int64.int -> unit
- val setPointer: 'a -> unit
val setReal32: Real32.real -> unit
val setReal64: Real64.real -> unit
val setWord8: Word8.word -> unit
1.28 +1 -2 mlton/basis-library/mlton/mlton.sig
Index: mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sig,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- mlton.sig 26 Jun 2003 19:17:30 -0000 1.27
+++ mlton.sig 1 Dec 2003 18:22:17 -0000 1.28
@@ -10,8 +10,6 @@
signature MLTON =
sig
- type pointer
-
val cleanAtExit: unit -> unit
(* val deserialize: Word8Vector.vector -> 'a *)
(* Pointer equality. The usual caveats about lack of a well-defined
@@ -33,6 +31,7 @@
structure IntInf: MLTON_INT_INF
structure Itimer: MLTON_ITIMER
structure Platform: MLTON_PLATFORM
+ structure Pointer: MLTON_POINTER
structure ProcEnv: MLTON_PROC_ENV
structure Process: MLTON_PROCESS
structure Profile: MLTON_PROFILE
1.28 +1 -0 mlton/basis-library/mlton/mlton.sml
Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sml,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- mlton.sml 6 Sep 2003 19:42:43 -0000 1.27
+++ mlton.sml 1 Dec 2003 18:22:17 -0000 1.28
@@ -55,6 +55,7 @@
structure IntInf = IntInf
structure Itimer = MLtonItimer
structure Platform = MLtonPlatform
+structure Pointer = MLtonPointer
structure ProcEnv = MLtonProcEnv
structure Process = MLtonProcess
structure Ptrace = MLtonPtrace
1.1 mlton/basis-library/mlton/pointer.sig
Index: pointer.sig
===================================================================
signature MLTON_POINTER =
sig
type t
val add: t * word -> t
val diff: t * t -> word
val getInt8: t * int -> Int8.int
val getInt16: t * int -> Int16.int
val getInt32: t * int -> Int32.int
val getInt64: t * int -> Int64.int
val getReal32: t * int -> Real32.real
val getReal64: t * int -> Real64.real
val getWord8: t * int -> Word8.word
val getWord16: t * int -> Word16.word
val getWord32: t * int -> Word32.word
val getWord64: t * int -> Word64.word
val isNull: t -> bool
val null: t
val setInt8: t * int * Int8.int -> unit
val setInt16: t * int * Int16.int -> unit
val setInt32: t * int * Int32.int -> unit
val setInt64: t * int * Int64.int -> unit
val setReal32: t * int * Real32.real -> unit
val setReal64: t * int * Real64.real -> unit
val setWord8: t * int * Word8.word -> unit
val setWord16: t * int * Word16.word -> unit
val setWord32: t * int * Word32.word -> unit
val setWord64: t * int * Word64.word -> unit
val sub: t * word -> t
end
1.1 mlton/basis-library/mlton/pointer.sml
Index: pointer.sml
===================================================================
structure MLtonPointer: MLTON_POINTER =
struct
open Primitive.Pointer
val add = Word.+
val diff = Word.-
val sub = Word.-
end
1.4 +1 -1 mlton/basis-library/posix/error.sml
Index: error.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/error.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- error.sml 24 Nov 2002 01:19:39 -0000 1.3
+++ error.sml 1 Dec 2003 18:22:17 -0000 1.4
@@ -27,7 +27,7 @@
fun errorMsg (n: int) =
let val cs = strerror n
- in if Primitive.Cpointer.isNull cs
+ in if Primitive.Pointer.isNull cs
then "Unknown error"
else C.CS.toString cs
end
1.9 +3 -3 mlton/basis-library/posix/file-sys.sml
Index: file-sys.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/file-sys.sml,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- file-sys.sml 25 Sep 2003 01:43:26 -0000 1.8
+++ file-sys.sml 1 Dec 2003 18:22:17 -0000 1.9
@@ -53,7 +53,7 @@
fun opendir s =
let val d = Prim.opendir (String.nullTerm s)
- in if Primitive.Cpointer.isNull d
+ in if Primitive.Pointer.isNull d
then Error.error ()
else DS (ref (SOME d))
end
@@ -65,7 +65,7 @@
let
val _ = Error.clearErrno ()
val cs = Prim.readdir d
- in if Primitive.Cpointer.isNull cs
+ in if Primitive.Pointer.isNull cs
then if Error.getErrno () = 0
then NONE
else Error.error ()
@@ -118,7 +118,7 @@
fun extract a = extractToChar (a, #"\000")
in
fun getcwd () =
- if Primitive.Cpointer.isNull (Prim.getcwd (!buffer, !size))
+ if Primitive.Pointer.isNull (Prim.getcwd (!buffer, !size))
then (size := 2 * !size
; buffer := make ()
; getcwd ())
1.17 +1 -1 mlton/basis-library/posix/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/primitive.sml,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- primitive.sml 25 Sep 2003 01:43:26 -0000 1.16
+++ primitive.sml 1 Dec 2003 18:22:17 -0000 1.17
@@ -366,7 +366,7 @@
structure Dirstream =
struct
- type dirstream = pointer
+ type dirstream = Pointer.t
val closedir =
_import "Posix_FileSys_Dirstream_closedir": dirstream -> int;
1.6 +3 -3 mlton/basis-library/posix/proc-env.sml
Index: proc-env.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/proc-env.sml,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- proc-env.sml 22 Sep 2003 19:25:30 -0000 1.5
+++ proc-env.sml 1 Dec 2003 18:22:17 -0000 1.6
@@ -47,7 +47,7 @@
fun getlogin () =
let val cs = Prim.getlogin ()
- in if Primitive.Cpointer.isNull cs
+ in if Primitive.Pointer.isNull cs
then raise (Error.SysErr ("no login name", NONE))
else CS.toString cs
end
@@ -110,7 +110,7 @@
fun getenv name =
let val cs = Prim.getenv (String.nullTerm name)
- in if Primitive.Cpointer.isNull cs
+ in if Primitive.Pointer.isNull cs
then NONE
else SOME (CS.toString cs)
end
@@ -121,7 +121,7 @@
fun ttyname (FD n) =
let val cs = Prim.ttyname n
- in if Primitive.Cpointer.isNull cs
+ in if Primitive.Pointer.isNull cs
then Error.error ()
else CS.toString cs
end
1.17 +0 -6 mlton/include/c-chunk.h
Index: c-chunk.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-chunk.h,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- c-chunk.h 29 Nov 2003 09:33:24 -0000 1.16
+++ c-chunk.h 1 Dec 2003 18:22:17 -0000 1.17
@@ -197,12 +197,6 @@
} while (0)
/* ------------------------------------------------- */
-/* Cpointer */
-/* ------------------------------------------------- */
-
-#define Cpointer_isNull(x) (NULL == (void*)(x))
-
-/* ------------------------------------------------- */
/* Int */
/* ------------------------------------------------- */
1.4 +2 -0 mlton/mlton/ast/word-size.fun
Index: word-size.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/word-size.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- word-size.fun 13 Oct 2003 18:48:36 -0000 1.3
+++ word-size.fun 1 Dec 2003 18:22:18 -0000 1.4
@@ -9,6 +9,8 @@
val default = W32
+fun pointer () = W32
+
val max: t -> LargeWord.t =
fn W8 => Word.toLarge 0wxFF
| W16 => Word.toLarge 0wxFFFF
1.4 +1 -0 mlton/mlton/ast/word-size.sig
Index: word-size.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/word-size.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- word-size.sig 13 Oct 2003 18:48:36 -0000 1.3
+++ word-size.sig 1 Dec 2003 18:22:18 -0000 1.4
@@ -19,6 +19,7 @@
val equals: t * t -> bool
val max: t -> LargeWord.t
val memoize: (t -> 'a) -> t -> 'a
+ val pointer: unit -> t
val size: t -> int
val toString: t -> string
end
1.66 +23 -9 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.65
retrieving revision 1.66
diff -u -r1.65 -r1.66
--- prim.fun 10 Oct 2003 00:01:31 -0000 1.65
+++ prim.fun 1 Dec 2003 18:22:18 -0000 1.66
@@ -46,7 +46,6 @@
| Array_update (* backend *)
| C_CS_charArrayToWord8Array (* type inference *)
| Char_toWord8 (* type inference *)
- | Cpointer_isNull (* codegen *)
| Exn_extra (* implement exceptions *)
| Exn_keepHistory (* a compile-time boolean *)
| Exn_name (* implement exceptions *)
@@ -56,8 +55,6 @@
| FFI of CFunction.t (* ssa to rssa *)
| FFI_Symbol of {name: string,
ty: CType.t} (* codegen *)
- | FFI_getPointer (* ssa to rssa *)
- | FFI_setPointer (* ssa to rssa *)
| GC_collect (* ssa to rssa *)
| GC_pack (* ssa to rssa *)
| GC_unpack (* ssa to rssa *)
@@ -123,6 +120,12 @@
| MLton_serialize (* unused *)
| MLton_size (* ssa to rssa *)
| MLton_touch (* backend *)
+ | Pointer_getInt of IntSize.t (* backend *)
+ | Pointer_getReal of RealSize.t (* backend *)
+ | Pointer_getWord of WordSize.t (* backend *)
+ | Pointer_setInt of IntSize.t (* backend *)
+ | Pointer_setReal of RealSize.t (* backend *)
+ | Pointer_setWord of WordSize.t (* backend *)
| Real_Math_acos of RealSize.t (* codegen *)
| Real_Math_asin of RealSize.t (* codegen *)
| Real_Math_atan of RealSize.t (* codegen *)
@@ -265,7 +268,7 @@
(Int_subCheck, SideEffect, "subCheck")],
fn (makeName, kind, str) =>
(makeName s, kind, concat ["Int", IntSize.toString s, "_", str]))
-
+
fun reals (s: RealSize.t) =
List.map
([(Real_Math_acos, Functional, "Math_acos"),
@@ -336,15 +339,12 @@
(C_CS_charArrayToWord8Array, DependsOnState,
"C_CS_charArrayToWord8Array"),
(Char_toWord8, Functional, "Char_toWord8"),
- (Cpointer_isNull, Functional, "Cpointer_isNull"),
(Exn_extra, Functional, "Exn_extra"),
(Exn_name, Functional, "Exn_name"),
(Exn_setExtendExtra, SideEffect, "Exn_setExtendExtra"),
(Exn_setInitExtra, SideEffect, "Exn_setInitExtra"),
(Exn_setTopLevelHandler, SideEffect, "Exn_setTopLevelHandler"),
(Exn_setTopLevelHandler, SideEffect, "Exn_setTopLevelHandler"),
- (FFI_getPointer, DependsOnState, "FFI_getPointer"),
- (FFI_setPointer, SideEffect, "FFI_setPointer"),
(GC_collect, SideEffect, "GC_collect"),
(GC_pack, SideEffect, "GC_pack"),
(GC_unpack, SideEffect, "GC_unpack"),
@@ -436,6 +436,22 @@
coerces (Word_toWord, word, word),
coercesX (Word_toWordX, word, word)]
end
+ @ let
+ fun doit (name, all, toString, get, set) =
+ List.concatMap
+ (all, fn s =>
+ [(get s, DependsOnState,
+ concat ["Pointer_get", name, toString s]),
+ (set s, SideEffect,
+ concat ["Pointer_set", name, toString s])])
+ in
+ List.concat [doit ("Int", IntSize.all, IntSize.toString,
+ Pointer_getInt, Pointer_setInt),
+ doit ("Real", RealSize.all, RealSize.toString,
+ Pointer_getReal, Pointer_setReal),
+ doit ("Word", WordSize.all, WordSize.toString,
+ Pointer_getWord, Pointer_setWord)]
+ end
fun toString n =
case n of
@@ -606,8 +622,6 @@
| Exn_extra => one result
| Exn_setExtendExtra => one (#2 (deArrow (arg 0)))
| Exn_setInitExtra => one (arg 0)
- | FFI_getPointer => one result
- | FFI_setPointer => one (arg 0)
| MLton_bogus => one result
| MLton_deserialize => one result
| MLton_eq => one (arg 0)
1.50 +6 -3 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.49
retrieving revision 1.50
diff -u -r1.49 -r1.50
--- prim.sig 10 Oct 2003 00:01:31 -0000 1.49
+++ prim.sig 1 Dec 2003 18:22:18 -0000 1.50
@@ -37,7 +37,6 @@
| Array_update (* backend *)
| C_CS_charArrayToWord8Array (* type inference *)
| Char_toWord8 (* type inference *)
- | Cpointer_isNull (* codegen *)
| Exn_extra (* implement exceptions *)
| Exn_keepHistory (* a compile-time boolean *)
| Exn_name (* implement exceptions *)
@@ -47,8 +46,6 @@
| FFI of CFunction.t (* ssa to rssa *)
| FFI_Symbol of {name: string,
ty: CType.t} (* codegen *)
- | FFI_getPointer (* ssa to rssa *)
- | FFI_setPointer (* ssa to rssa *)
| GC_collect (* ssa to rssa *)
| GC_pack (* ssa to rssa *)
| GC_unpack (* ssa to rssa *)
@@ -114,6 +111,12 @@
| MLton_serialize (* unused *)
| MLton_size (* ssa to rssa *)
| MLton_touch (* backend *)
+ | Pointer_getInt of IntSize.t (* backend *)
+ | Pointer_getReal of RealSize.t (* backend *)
+ | Pointer_getWord of WordSize.t (* backend *)
+ | Pointer_setInt of IntSize.t (* backend *)
+ | Pointer_setReal of RealSize.t (* backend *)
+ | Pointer_setWord of WordSize.t (* backend *)
| Real_Math_acos of RealSize.t (* codegen *)
| Real_Math_asin of RealSize.t (* codegen *)
| Real_Math_atan of RealSize.t (* codegen *)
1.11 +15 -21 mlton/mlton/backend/machine-atoms.fun
Index: machine-atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- machine-atoms.fun 19 Jul 2003 01:23:26 -0000 1.10
+++ machine-atoms.fun 1 Dec 2003 18:22:18 -0000 1.11
@@ -55,8 +55,7 @@
structure TypeAndMemChunk =
struct
datatype ty =
- CPointer
- | EnumPointers of {enum: int vector,
+ EnumPointers of {enum: int vector,
pointers: PointerTycon.t vector}
| ExnStack
| Int of IntSize.t
@@ -76,8 +75,7 @@
open Layout
in
case t of
- CPointer => str "cpointer"
- | EnumPointers {enum, pointers} =>
+ EnumPointers {enum, pointers} =>
if 0 = Vector.length enum
andalso 1 = Vector.length pointers
then PointerTycon.layout (Vector.sub (pointers, 0))
@@ -105,8 +103,7 @@
fun equalsTy (t, t'): bool =
case (t, t') of
- (CPointer, CPointer) => true
- | (EnumPointers {enum = e, pointers = p},
+ (EnumPointers {enum = e, pointers = p},
EnumPointers {enum = e', pointers = p'}) =>
e = e'
andalso (MLton.eq (p, p')
@@ -133,8 +130,7 @@
val double: int = 8
in
val size =
- fn CPointer => word
- | EnumPointers _ => word
+ fn EnumPointers _ => word
| ExnStack => word
| Int s => IntSize.bytes s
| IntInf => word
@@ -146,8 +142,7 @@
fun isOkTy (t: ty): bool =
case t of
- CPointer => true
- | EnumPointers {enum, pointers} =>
+ EnumPointers {enum, pointers} =>
Vector.isSorted (enum, op <=)
andalso Vector.isSorted (pointers, PointerTycon.<=)
andalso (0 = Vector.length pointers
@@ -220,7 +215,7 @@
val bool = EnumPointers {enum = Vector.new2 (0, 1),
pointers = Vector.new0 ()}
- val cpointer = CPointer
+ fun cPointer () = Word (WordSize.pointer ())
val defaultInt = Int IntSize.default
val defaultWord = Word WordSize.default
val exnStack = ExnStack
@@ -230,6 +225,11 @@
val real = Real
val word = Word
+ fun isCPointer t =
+ case t of
+ Word s => WordSize.equals (s, WordSize.pointer ())
+ | _ => false
+
fun pointer pt =
EnumPointers {enum = Vector.new0 (),
pointers = Vector.new1 pt}
@@ -263,19 +263,18 @@
in
val fromCType: CType.t -> t =
fn C.Int s => int s
- | C.Pointer => cpointer
+ | C.Pointer => cPointer ()
| C.Real s => real s
| C.Word s => word s
val toCType: t -> CType.t =
- fn CPointer => C.pointer
- | EnumPointers {enum, pointers} =>
+ fn EnumPointers {enum, pointers} =>
if 0 = Vector.length pointers
then C.defaultInt
else C.pointer
| ExnStack => C.defaultWord
| Int s => C.Int s
- | IntInf => C.Pointer
+ | IntInf => C.pointer
| Label _ => C.defaultWord
| MemChunk _ => C.pointer
| Real s => C.Real s
@@ -484,12 +483,7 @@
andalso Type.size from = Type.size to
andalso
case from of
- CPointer =>
- (case to of
- Int _ => true
- | Word _ => true
- | _ => false)
- | EnumPointers (ep as {enum, pointers}) =>
+ EnumPointers (ep as {enum, pointers}) =>
(case to of
EnumPointers ep' => castEnumIsOk (ep, ep')
| IntInf =>
1.13 +3 -3 mlton/mlton/backend/machine-atoms.sig
Index: machine-atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.sig,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- machine-atoms.sig 19 Jul 2003 01:23:26 -0000 1.12
+++ machine-atoms.sig 1 Dec 2003 18:22:18 -0000 1.13
@@ -54,12 +54,11 @@
structure Type:
sig
datatype t =
- CPointer
(* The ints in an enum are in increasing order without dups.
* The pointers are in increasing order (of index in objectTypes
* vector) without dups.
*)
- | EnumPointers of {enum: int vector,
+ EnumPointers of {enum: int vector,
pointers: PointerTycon.t vector}
| ExnStack
| Int of IntSize.t
@@ -72,7 +71,7 @@
val align: t * int -> int (* align an address *)
val bool: t
val containsPointer: t * PointerTycon.t -> bool
- val cpointer: t
+ val cPointer: unit -> t
val dePointer: t -> PointerTycon.t option
val defaultInt: t
val defaultWord: t
@@ -81,6 +80,7 @@
val fromCType: CType.t -> t
val int: IntSize.t -> t
val intInf: t
+ val isCPointer: t -> bool
val isPointer: t -> bool
val isReal: t -> bool
val label: Label.t -> t
1.52 +7 -10 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -r1.51 -r1.52
--- machine.fun 19 Jul 2003 01:23:26 -0000 1.51
+++ machine.fun 1 Dec 2003 18:22:18 -0000 1.52
@@ -251,9 +251,9 @@
fn ArrayOffset {ty, ...} => ty
| Cast (_, ty) => ty
| Contents {ty, ...} => ty
- | File => Type.cpointer
+ | File => Type.cPointer ()
| Frontier => Type.defaultWord
- | GCState => Type.cpointer
+ | GCState => Type.cPointer ()
| Global g => Global.ty g
| Int i => Type.int (IntX.size i)
| Label l => Type.label l
@@ -978,8 +978,7 @@
tyconTy = tyconTy}))
| Contents {oper, ...} =>
(checkOperand (oper, alloc)
- ; Type.equals (Operand.ty oper,
- Type.cpointer))
+ ; Type.isCPointer (Operand.ty oper))
| File => true
| Frontier => true
| GCState => true
@@ -1038,8 +1037,7 @@
Type.equals (Operand.ty index, Type.defaultInt)
andalso
case Operand.ty base of
- Type.CPointer => true (* needed for card marking *)
- | Type.EnumPointers {enum, pointers} =>
+ Type.EnumPointers {enum, pointers} =>
0 = Vector.length enum
andalso
Vector.forall
@@ -1062,7 +1060,7 @@
Type.equals (ty', Type.word W8)))
end
| _ => false)
- | _ => false
+ | t => Type.isCPointer t
and offsetIsOk {base, offset, ty} =
let
fun memChunkIsOk (MemChunk.T {components, ...}) =
@@ -1074,8 +1072,7 @@
in
case Operand.ty base of
- Type.CPointer => true
- | Type.EnumPointers {enum, pointers} =>
+ Type.EnumPointers {enum, pointers} =>
0 = Vector.length enum
andalso
((* Array_toVector header update. *)
@@ -1091,7 +1088,7 @@
ObjectType.Normal m => memChunkIsOk m
| _ => false))
| Type.MemChunk m => memChunkIsOk m
- | _ => false
+ | t => Type.isCPointer t
end
fun checkOperands (v, a) =
Vector.foreach (v, fn z => checkOperand (z, a))
1.19 +0 -1 mlton/mlton/backend/representation.fun
Index: representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.fun,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- representation.fun 9 Oct 2003 18:17:32 -0000 1.18
+++ representation.fun 1 Dec 2003 18:22:19 -0000 1.19
@@ -542,7 +542,6 @@
| Datatype tycon => convertDatatype tycon
| Int s => SOME (R.Type.int s)
| IntInf => SOME R.Type.intInf
- | Pointer => SOME R.Type.cpointer
| PreThread => SOME R.Type.thread
| Real s => SOME (R.Type.real s)
| Ref t =>
1.37 +4 -5 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- rssa.fun 12 Sep 2003 01:22:56 -0000 1.36
+++ rssa.fun 1 Dec 2003 18:22:19 -0000 1.37
@@ -61,8 +61,8 @@
| Word8Vector _ => Type.word8Vector
end
| EnsuresBytesFree => Type.word WordSize.default
- | File => Type.cpointer
- | GCState => Type.cpointer
+ | File => Type.cPointer ()
+ | GCState => Type.cPointer ()
| Line => Type.int IntSize.default
| Offset {ty, ...} => ty
| PointerTycon _ => Type.word WordSize.default
@@ -1057,8 +1057,7 @@
Type.equals (Operand.ty index, Type.defaultInt)
andalso
case Operand.ty base of
- Type.CPointer => true (* needed for card marking *)
- | Type.EnumPointers {enum, pointers} =>
+ Type.EnumPointers {enum, pointers} =>
0 = Vector.length enum
andalso
Vector.forall
@@ -1081,7 +1080,7 @@
Type.equals (ty', Type.word W8)))
end
| _ => false)
- | _ => false
+ | t => Type.isCPointer t
end
and offsetIsOk {base, offset, ty} =
let
1.18 +3 -4 mlton/mlton/backend/signal-check.fun
Index: signal-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/signal-check.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- signal-check.fun 23 Jun 2003 04:58:57 -0000 1.17
+++ signal-check.fun 1 Dec 2003 18:22:20 -0000 1.18
@@ -78,10 +78,9 @@
val compare =
Vector.new1
(Statement.PrimApp
- {args = Vector.new2 (Operand.Cast
- (Operand.Runtime Runtime.GCField.Limit,
- Type.defaultWord),
- Operand.word (WordX.zero WordSize.default)),
+ {args = (Vector.new2
+ (Operand.Runtime Runtime.GCField.Limit,
+ Operand.word (WordX.zero (WordSize.pointer ())))),
dst = SOME (res, Type.bool),
prim = Prim.eq})
val compareTransfer =
1.52 +37 -36 mlton/mlton/backend/ssa-to-rssa.fun
Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -r1.51 -r1.52
--- ssa-to-rssa.fun 29 Nov 2003 09:59:36 -0000 1.51
+++ ssa-to-rssa.fun 1 Dec 2003 18:22:20 -0000 1.52
@@ -844,8 +844,7 @@
val c = Operand.Const
in
case t of
- Type.CPointer => Error.bug "bogus CPointer"
- | Type.EnumPointers (ep as {enum, ...}) =>
+ Type.EnumPointers (ep as {enum, ...}) =>
Operand.Cast (Operand.int (IntX.one IntSize.default), t)
| Type.ExnStack => Error.bug "bogus ExnStack"
| Type.Int s => c (Const.int (IntX.zero s))
@@ -1148,6 +1147,16 @@
end
else add (Move {dst = arrayOffset ty,
src = varOp (a 2)})
+ fun pointerGet ty =
+ move (ArrayOffset {base = varOp (a 0),
+ index = varOp (a 1),
+ ty = ty})
+ fun pointerSet ty =
+ add (Move {dst = ArrayOffset {base = varOp (a 0),
+ index = varOp (a 1),
+ ty = ty},
+ src = varOp (a 2)})
+
fun refAssign (ty, src) =
let
val addr = varOp (a 0)
@@ -1200,10 +1209,6 @@
NONE => none ()
| SOME ty => arrayUpdate ty)
| FFI f => simpleCCall f
- | FFI_getPointer =>
- simpleCCall CFunction.getPointer
- | FFI_setPointer =>
- simpleCCall CFunction.setPointer
| GC_collect =>
ccall
{args = (Vector.new5
@@ -1312,6 +1317,12 @@
NONE => move (Operand.bool true)
| SOME _ => normal ())
| MLton_size => simpleCCall CFunction.size
+ | Pointer_getInt s => pointerGet (Type.Int s)
+ | Pointer_getReal s => pointerGet (Type.Real s)
+ | Pointer_getWord s => pointerGet (Type.Word s)
+ | Pointer_setInt s => pointerSet (Type.Int s)
+ | Pointer_setReal s => pointerSet (Type.Real s)
+ | Pointer_setWord s => pointerSet (Type.Word s)
| Ref_assign =>
(case targ () of
NONE => none ()
@@ -1337,34 +1348,26 @@
split
(Vector.new0 (), Kind.Jump, ss, fn l =>
let
- fun doit (dst, prim, a, b) =
- let
- val tmp = Var.newNoname ()
- in
- Vector.new2
- (Statement.PrimApp
- {args = Vector.new2 (a, b),
- dst = SOME (tmp,
- Type.defaultWord),
- prim = prim},
- Statement.Move
- {dst = (Operand.Cast
- (Operand.Runtime dst,
- Type.defaultWord)),
- src = (Operand.Var
- {var = tmp,
- ty = Type.defaultWord})})
- end
datatype z = datatype GCField.t
+ val tmp = Var.newNoname ()
+ val size = WordSize.pointer ()
+ val ty = Type.cPointer ()
val statements =
- doit (Limit,
- Prim.wordSub WordSize.default,
- Operand.Runtime LimitPlusSlop,
- Operand.word
- (WordX.make
- (LargeWord.fromInt
- Runtime.limitSlop,
- WordSize.default)))
+ Vector.new2
+ (Statement.PrimApp
+ {args = (Vector.new2
+ (Operand.Runtime LimitPlusSlop,
+ Operand.word
+ (WordX.make
+ (LargeWord.fromInt
+ Runtime.limitSlop,
+ size)))),
+ dst = SOME (tmp, ty),
+ prim = Prim.wordSub size},
+ Statement.Move
+ {dst = Operand.Runtime Limit,
+ src = Operand.Var {var = tmp,
+ ty = ty}})
val l' =
newBlock
{args = Vector.new0 (),
@@ -1394,12 +1397,10 @@
val statements =
Vector.new1
(Statement.Move
- {dst = (Operand.Cast
- (Operand.Runtime Limit,
- Type.defaultWord)),
+ {dst = Operand.Runtime Limit,
src =
Operand.word
- (WordX.zero WordSize.default)})
+ (WordX.zero (WordSize.pointer ()))})
val l'' =
newBlock
{args = Vector.new0 (),
1.71 +1 -2 mlton/mlton/codegen/c-codegen/c-codegen.fun
Index: c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.70
retrieving revision 1.71
diff -u -r1.70 -r1.71
--- c-codegen.fun 29 Nov 2003 09:33:24 -0000 1.70
+++ c-codegen.fun 1 Dec 2003 18:22:20 -0000 1.71
@@ -422,8 +422,7 @@
in
fun toC (t: t): string =
case t of
- CPointer => pointer
- | EnumPointers {pointers, ...} =>
+ EnumPointers {pointers, ...} =>
if 0 = Vector.length pointers
then int I32
else pointer
1.53 +1 -20 mlton/mlton/codegen/x86-codegen/x86-mlton.fun
Index: x86-mlton.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.fun,v
retrieving revision 1.52
retrieving revision 1.53
diff -u -r1.52 -r1.53
--- x86-mlton.fun 21 Oct 2003 19:00:41 -0000 1.52
+++ x86-mlton.fun 1 Dec 2003 18:22:20 -0000 1.53
@@ -632,26 +632,7 @@
AppendList.appends
[comment_begin,
(case Prim.name prim of
- Cpointer_isNull
- => let
- val (dst,dstsize) = getDst1 ()
- val (src,srcsize) = getSrc1 ()
- in
- AppendList.fromList
- [Block.mkBlock'
- {entry = NONE,
- statements
- = [Assembly.instruction_cmp
- {src1 = src,
- src2 = Operand.immediate_const_int 0,
- size = srcsize},
- Assembly.instruction_setcc
- {condition = Instruction.E,
- dst = dst,
- size = dstsize}],
- transfer = NONE}]
- end
- | FFI_Symbol {name, ...}
+ FFI_Symbol {name, ...}
=> let
val (dst,dstsize) = getDst1 ()
val memloc
1.61 +0 -3 mlton/mlton/ssa/ssa-tree.fun
Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -r1.60 -r1.61
--- ssa-tree.fun 9 Oct 2003 18:17:34 -0000 1.60
+++ ssa-tree.fun 1 Dec 2003 18:22:20 -0000 1.61
@@ -29,7 +29,6 @@
| Datatype of Tycon.t
| Int of IntSize.t
| IntInf
- | Pointer
| PreThread
| Real of RealSize.t
| Ref of t
@@ -58,7 +57,6 @@
@ List.map (Tycon.ints, fn (t, s) =>
(t, nullary (Int s)))
@ [(Tycon.intInf, nullary IntInf),
- (Tycon.pointer, nullary Pointer),
(Tycon.preThread, nullary PreThread)]
@ List.map (Tycon.reals, fn (t, s) =>
(t, nullary (Real s)))
@@ -94,7 +92,6 @@
| Datatype t => Tycon.layout t
| Int s => str (concat ["int", IntSize.toString s])
| IntInf => str "IntInf.int"
- | Pointer => str "pointer"
| PreThread => str "preThread"
| Real s => str (concat ["real", RealSize.toString s])
| Ref t => seq [layout t, str " ref"]
1.49 +0 -1 mlton/mlton/ssa/ssa-tree.sig
Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- ssa-tree.sig 23 Jun 2003 04:58:59 -0000 1.48
+++ ssa-tree.sig 1 Dec 2003 18:22:20 -0000 1.49
@@ -65,7 +65,6 @@
| Datatype of Tycon.t
| Int of IntSize.t
| IntInf
- | Pointer
| PreThread
| Real of RealSize.t
| Ref of t