[MLton-commit] r5541
Matthew Fluet
fluet at mlton.org
Sun Apr 29 20:28:33 PDT 2007
Improved typing for RSSA & Machine.
* Check primops, offsets, and array offsets
* Distinguished cpointer type carried through compiler
Also handle resizing of Real32 by using casts.
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/ffi.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/ffi.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/pointer.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-basis.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/util/CUtil.sml
U mlton/branches/on-20050822-x86_64-branch/include/c-chunk.h
U mlton/branches/on-20050822-x86_64-branch/mlton/Makefile
U mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.sig
U mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const.sig
U mlton/branches/on-20050822-x86_64-branch/mlton/atoms/hash-type.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/atoms/prim.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/atoms/prim.sig
U mlton/branches/on-20050822-x86_64-branch/mlton/atoms/type-ops.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/atoms/type-ops.sig
U mlton/branches/on-20050822-x86_64-branch/mlton/backend/backend.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/backend/limit-check.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/backend/machine.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/backend/machine.sig
U mlton/branches/on-20050822-x86_64-branch/mlton/backend/packed-representation.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/backend/rep-type.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/backend/rssa.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/backend/rssa.sig
U mlton/branches/on-20050822-x86_64-branch/mlton/backend/scale.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/backend/scale.sig
U mlton/branches/on-20050822-x86_64-branch/mlton/backend/signal-check.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/backend/ssa-to-rssa.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/codegen/bytecode/bytecode.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/codegen/c-codegen/c-codegen.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/codegen/x86-codegen/x86-mlton.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/codegen/x86-codegen/x86-translate.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/elaborate-core.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/elaborate-env.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/type-env.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/type-env.sig
U mlton/branches/on-20050822-x86_64-branch/mlton/main/compile.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/match-compile/match-compile.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/ssa/poly-equal.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/ssa/ref-flatten.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/ssa/ssa-to-ssa2.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/ssa/ssa-tree.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/ssa/ssa-tree.sig
U mlton/branches/on-20050822-x86_64-branch/mlton/ssa/ssa-tree2.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/ssa/ssa-tree2.sig
A mlton/branches/on-20050822-x86_64-branch/runtime/basis/cpointer.c
A mlton/branches/on-20050822-x86_64-branch/runtime/basis/cpointer.h
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/ffi.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/ffi.sig 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/ffi.sig 2007-04-30 03:28:24 UTC (rev 5541)
@@ -15,11 +15,12 @@
val getChar16: int -> Char16.char
val getChar32: int -> Char32.char
*)
+ val getCPointer: int -> MLtonPointer.t
val getInt8: int -> Int8.int
val getInt16: int -> Int16.int
val getInt32: int -> Int32.int
val getInt64: int -> Int64.int
- val getPointer: int -> 'a
+ val getObjptr: int -> 'a
val getReal32: int -> Real32.real
val getReal64: int -> Real64.real
val getWord8: int -> Word8.word
@@ -33,11 +34,12 @@
val setChar16: Char16.char -> unit
val setChar32: Char32.char -> unit
*)
+ val setCPointer: MLtonPointer.t -> unit
val setInt8: Int8.int -> unit
val setInt16: Int16.int -> unit
val setInt32: Int32.int -> unit
val setInt64: Int64.int -> unit
- val setPointer: 'a -> unit
+ val setObjptr: 'a -> unit
val setReal32: Real32.real -> unit
val setReal64: Real64.real -> unit
val setWord8: Word8.word -> unit
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/ffi.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/ffi.sml 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/ffi.sml 2007-04-30 03:28:24 UTC (rev 5541)
@@ -17,6 +17,8 @@
(fn i => get (p, C_Ptrdiff.fromInt i),
fn x => set (p, C_Ptrdiff.fromInt 0, x))
in
+ fun getCPointer i = Pointer.getCPointer (Prim.cpointerArray, C_Ptrdiff.fromInt i)
+ fun setCPointer x = Pointer.setCPointer (Prim.cpointerArray, C_Ptrdiff.fromInt 0, x)
val (getInt8, setInt8) =
make (Prim.int8Array, Pointer.getInt8, Pointer.setInt8)
val (getInt16, setInt16) =
@@ -25,8 +27,8 @@
make (Prim.int32Array, Pointer.getInt32, Pointer.setInt32)
val (getInt64, setInt64) =
make (Prim.int64Array, Pointer.getInt64, Pointer.setInt64)
- fun getPointer i = Pointer.getPointer (Prim.pointerArray, C_Ptrdiff.fromInt i)
- fun setPointer x = Pointer.setPointer (Prim.pointerArray, C_Ptrdiff.fromInt 0, x)
+ fun getObjptr i = Pointer.getObjptr (Prim.objptrArray, C_Ptrdiff.fromInt i)
+ fun setObjptr x = Pointer.setObjptr (Prim.objptrArray, C_Ptrdiff.fromInt 0, x)
val (getReal32, setReal32) =
make (Prim.real32Array, Pointer.getReal32, Pointer.setReal32)
val (getReal64, setReal64) =
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/pointer.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/pointer.sml 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/pointer.sml 2007-04-30 03:28:24 UTC (rev 5541)
@@ -10,10 +10,9 @@
open Primitive.MLton.Pointer
-fun add (p, t) = fromWord (C_Pointer.+ (toWord p, C_Pointer.fromWord t))
-fun compare (p, p') = C_Pointer.compare (toWord p, toWord p')
-fun diff (p, p') = C_Pointer.toWord (C_Pointer.- (toWord p, toWord p'))
-fun sub (p, t) = fromWord (C_Pointer.- (toWord p, C_Pointer.fromWord t))
+val add = fn (p, t) => add (p, C_Size.fromWord t)
+val sub = fn (p, t) => sub (p, C_Size.fromWord t)
+val diff = fn (p, p') => C_Size.toWord (diff (p, p'))
local
fun wrap f (p, i) =
@@ -23,7 +22,7 @@
val getInt16 = wrap getInt16
val getInt32 = wrap getInt32
val getInt64 = wrap getInt64
- val getPointer = wrap getPointer
+ val getPointer = wrap getCPointer
val getReal32 = wrap getReal32
val getReal64 = wrap getReal64
val getWord8 = wrap getWord8
@@ -40,7 +39,7 @@
val setInt16 = wrap setInt16
val setInt32 = wrap setInt32
val setInt64 = wrap setInt64
- val setPointer = wrap setPointer
+ val setPointer = wrap setCPointer
val setReal32 = wrap setReal32
val setReal64 = wrap setReal64
val setWord8 = wrap setWord8
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-basis.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-basis.sml 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-basis.sml 2007-04-30 03:28:24 UTC (rev 5541)
@@ -434,7 +434,7 @@
(* Primitive Basis (MLton Extensions) *)
structure Pointer =
struct
- type t = pointer
+ type t = cpointer
end
structure Thread =
struct
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml 2007-04-30 03:28:24 UTC (rev 5541)
@@ -109,13 +109,14 @@
structure FFI =
struct
+ val cpointerArray = #1 _symbol "MLton_FFI_CPointer": Pointer.t GetSet.t; ()
val getOp = #1 _symbol "MLton_FFI_op": Int32.t GetSet.t;
val int8Array = #1 _symbol "MLton_FFI_Int8": Pointer.t GetSet.t; ()
val int16Array = #1 _symbol "MLton_FFI_Int16": Pointer.t GetSet.t; ()
val int32Array = #1 _symbol "MLton_FFI_Int32": Pointer.t GetSet.t; ()
val int64Array = #1 _symbol "MLton_FFI_Int64": Pointer.t GetSet.t; ()
val numExports = _build_const "MLton_FFI_numExports": Int32.int;
- val pointerArray = #1 _symbol "MLton_FFI_Pointer": Pointer.t GetSet.t; ()
+ val objptrArray = #1 _symbol "MLton_FFI_Objptr": Pointer.t GetSet.t; ()
val real32Array = #1 _symbol "MLton_FFI_Real32": Pointer.t GetSet.t; ()
val real64Array = #1 _symbol "MLton_FFI_Real64": Pointer.t GetSet.t; ()
val word8Array = #1 _symbol "MLton_FFI_Word8": Pointer.t GetSet.t; ()
@@ -221,55 +222,53 @@
open Pointer
type pointer = t
+ val add =
+ _prim "CPointer_add": pointer * C_Size.word -> pointer;
+ val sub =
+ _prim "CPointer_add": pointer * C_Size.word -> pointer;
+ val diff =
+ _prim "CPointer_diff": pointer * pointer -> C_Size.word;
+ val < = _prim "CPointer_lt": pointer * pointer -> bool;
local
- structure S =
- C_Pointer_ChooseWordN
- (type 'a t = 'a -> t
- val fWord8 = _prim "WordU8_extdToWord8": Primitive.Word8.word -> pointer;
- val fWord16 = _prim "WordU16_extdToWord16": Primitive.Word16.word -> pointer;
- val fWord32 = _prim "WordU32_extdToWord32": Primitive.Word32.word -> pointer;
- val fWord64 = _prim "WordU64_extdToWord64": Primitive.Word64.word -> pointer;)
+ structure S = IntegralComparisons(type t = pointer
+ val < = <)
in
- val fromWord = S.f
+ open S
end
- local
- structure S =
- C_Pointer_ChooseWordN
- (type 'a t = t -> 'a
- val fWord8 = _prim "WordU8_extdToWord8": pointer -> Primitive.Word8.word;
- val fWord16 = _prim "WordU16_extdToWord16": pointer -> Primitive.Word16.word;
- val fWord32 = _prim "WordU32_extdToWord32": pointer -> Primitive.Word32.word;
- val fWord64 = _prim "WordU64_extdToWord64": pointer -> Primitive.Word64.word;)
- in
- val toWord = S.f
- end
+ val fromWord =
+ _prim "CPointer_fromWord": C_Size.word -> pointer;
+ val toWord =
+ _prim "CPointer_toWord": pointer -> C_Size.word;
+
val null: t = fromWord 0w0
fun isNull p = p = null
- val getInt8 = _prim "Pointer_getWord8": t * C_Ptrdiff.t -> Int8.int;
- val getInt16 = _prim "Pointer_getWord16": t * C_Ptrdiff.t -> Int16.int;
- val getInt32 = _prim "Pointer_getWord32": t * C_Ptrdiff.t -> Int32.int;
- val getInt64 = _prim "Pointer_getWord64": t * C_Ptrdiff.t -> Int64.int;
- val getPointer = _prim "Pointer_getPointer": t * C_Ptrdiff.t -> 'a;
- val getReal32 = _prim "Pointer_getReal32": t * C_Ptrdiff.t -> Real32.real;
- val getReal64 = _prim "Pointer_getReal64": t * C_Ptrdiff.t -> Real64.real;
- val getWord8 = _prim "Pointer_getWord8": t * C_Ptrdiff.t -> Word8.word;
- val getWord16 = _prim "Pointer_getWord16": t * C_Ptrdiff.t -> Word16.word;
- val getWord32 = _prim "Pointer_getWord32": t * C_Ptrdiff.t -> Word32.word;
- val getWord64 = _prim "Pointer_getWord64": t * C_Ptrdiff.t -> Word64.word;
- val setInt8 = _prim "Pointer_setWord8": t * C_Ptrdiff.t * Int8.int -> unit;
- val setInt16 = _prim "Pointer_setWord16": t * C_Ptrdiff.t * Int16.int -> unit;
- val setInt32 = _prim "Pointer_setWord32": t * C_Ptrdiff.t * Int32.int -> unit;
- val setInt64 = _prim "Pointer_setWord64": t * C_Ptrdiff.t * Int64.int -> unit;
- val setPointer = _prim "Pointer_setPointer": t * C_Ptrdiff.t * 'a -> unit;
- val setReal32 = _prim "Pointer_setReal32": t * C_Ptrdiff.t * Real32.real -> unit;
- val setReal64 = _prim "Pointer_setReal64": t * C_Ptrdiff.t * Real64.real -> unit;
- val setWord8 = _prim "Pointer_setWord8": t * C_Ptrdiff.t * Word8.word -> unit;
- val setWord16 = _prim "Pointer_setWord16": t * C_Ptrdiff.t * Word16.word -> unit;
- val setWord32 = _prim "Pointer_setWord32": t * C_Ptrdiff.t * Word32.word -> unit;
- val setWord64 = _prim "Pointer_setWord64": t * C_Ptrdiff.t * Word64.word -> unit;
+ val getCPointer = _prim "CPointer_getCPointer": t * C_Ptrdiff.t -> t;
+ val getInt8 = _prim "CPointer_getWord8": t * C_Ptrdiff.t -> Int8.int;
+ val getInt16 = _prim "CPointer_getWord16": t * C_Ptrdiff.t -> Int16.int;
+ val getInt32 = _prim "CPointer_getWord32": t * C_Ptrdiff.t -> Int32.int;
+ val getInt64 = _prim "CPointer_getWord64": t * C_Ptrdiff.t -> Int64.int;
+ val getObjptr = _prim "CPointer_getObjptr": t * C_Ptrdiff.t -> 'a;
+ val getReal32 = _prim "CPointer_getReal32": t * C_Ptrdiff.t -> Real32.real;
+ val getReal64 = _prim "CPointer_getReal64": t * C_Ptrdiff.t -> Real64.real;
+ val getWord8 = _prim "CPointer_getWord8": t * C_Ptrdiff.t -> Word8.word;
+ val getWord16 = _prim "CPointer_getWord16": t * C_Ptrdiff.t -> Word16.word;
+ val getWord32 = _prim "CPointer_getWord32": t * C_Ptrdiff.t -> Word32.word;
+ val getWord64 = _prim "CPointer_getWord64": t * C_Ptrdiff.t -> Word64.word;
+ val setCPointer = _prim "CPointer_setCPointer": t * C_Ptrdiff.t * t -> unit;
+ val setInt8 = _prim "CPointer_setWord8": t * C_Ptrdiff.t * Int8.int -> unit;
+ val setInt16 = _prim "CPointer_setWord16": t * C_Ptrdiff.t * Int16.int -> unit;
+ val setInt32 = _prim "CPointer_setWord32": t * C_Ptrdiff.t * Int32.int -> unit;
+ val setInt64 = _prim "CPointer_setWord64": t * C_Ptrdiff.t * Int64.int -> unit;
+ val setObjptr = _prim "CPointer_setObjptr": t * C_Ptrdiff.t * 'a -> unit;
+ val setReal32 = _prim "CPointer_setReal32": t * C_Ptrdiff.t * Real32.real -> unit;
+ val setReal64 = _prim "CPointer_setReal64": t * C_Ptrdiff.t * Real64.real -> unit;
+ val setWord8 = _prim "CPointer_setWord8": t * C_Ptrdiff.t * Word8.word -> unit;
+ val setWord16 = _prim "CPointer_setWord16": t * C_Ptrdiff.t * Word16.word -> unit;
+ val setWord32 = _prim "CPointer_setWord32": t * C_Ptrdiff.t * Word32.word -> unit;
+ val setWord64 = _prim "CPointer_setWord64": t * C_Ptrdiff.t * Word64.word -> unit;
end
structure Profile =
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/util/CUtil.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/util/CUtil.sml 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/util/CUtil.sml 2007-04-30 03:28:24 UTC (rev 5541)
@@ -76,11 +76,11 @@
type t = C_StringArray.t
fun sub (css: t, i) =
- Pointer.getPointer
+ (Pointer.toWord o Pointer.getCPointer)
(Pointer.fromWord css,
C_Ptrdiff.fromInt i)
- val length = makeLength (sub, Pointer.isNull)
+ val length = makeLength (sub, C_Pointer.isNull)
val toArrayOfLength =
fn (css, n) =>
Modified: mlton/branches/on-20050822-x86_64-branch/include/c-chunk.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/include/c-chunk.h 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/include/c-chunk.h 2007-04-30 03:28:24 UTC (rev 5541)
@@ -208,6 +208,7 @@
#endif
#include "basis-ffi.h"
#include "basis/coerce.h"
+#include "basis/cpointer.h"
#include "basis/Real/Real-ops.h"
#include "basis/Real/Math-fns.h"
#include "basis/Word/Word-ops.h"
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/Makefile
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/Makefile 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/Makefile 2007-04-30 03:28:24 UTC (rev 5541)
@@ -25,6 +25,7 @@
FILE := mlton.mlb
FLAGS += -default-ann 'sequenceNonUnit warn'
FLAGS += -default-ann 'warnUnused true'
+ FLAGS += -type-check true -show-types true
else
ifeq (cygwin, $(HOST_OS))
# The stubs don't work on Cygwin, since they define spawn in terms of
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.fun 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.fun 2007-04-30 03:28:24 UTC (rev 5541)
@@ -30,11 +30,11 @@
in
val array = make "array"
val arrow = make "->"
- val bool = make "bool"
+ val bool = make "bool"
+ val cpointer = make "cpointer"
val exn = make "exn"
val intInf = make "intInf"
val list = make "list"
- val pointer = make "pointer"
val reff = make "ref"
val thread = make "thread"
val tuple = make "*"
@@ -114,10 +114,10 @@
List.map ([(array, Arity 1, Always),
(arrow, Arity 2, Never),
(bool, Arity 0, Sometimes),
+ (cpointer, Arity 0, Always),
(exn, Arity 0, Never),
(intInf, Arity 0, Sometimes),
(list, Arity 1, Sometimes),
- (pointer, Arity 0, Always),
(reff, Arity 1, Always),
(thread, Arity 0, Never),
(tuple, Nary, Sometimes),
@@ -133,10 +133,10 @@
val array = #2 array
val arrow = #2 arrow
val bool = #2 bool
+val cpointer = #2 cpointer
val exn = #2 exn
val intInf = #2 intInf
val list = #2 list
-val pointer = #2 pointer
val reff = #2 reff
val thread = #2 thread
val tuple = #2 tuple
@@ -169,7 +169,7 @@
| _ => Error.bug "PrimTycons.defaultWord"
val isBool = fn c => equals (c, bool)
-val isPointer = fn c => equals (c, pointer)
+val isCPointer = fn c => equals (c, cpointer)
val isIntX = fn c => equals (c, intInf) orelse isIntX c
val deIntX = fn c => if equals (c, intInf) then NONE else SOME (deIntX c)
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.sig 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.sig 2007-04-30 03:28:24 UTC (rev 5541)
@@ -46,6 +46,7 @@
val arrow: tycon
val bool: tycon
val char: CharSize.t -> tycon
+ val cpointer: tycon
val deCharX: tycon -> CharSize.t
val defaultChar: unit -> tycon
val defaultInt: unit -> tycon
@@ -60,15 +61,14 @@
val intInf: tycon
val isBool: tycon -> bool
val isCharX: tycon -> bool
+ val isCPointer: tycon -> bool
val isIntX: tycon -> bool
- val isPointer: tycon -> bool
val isRealX: tycon -> bool
val isWordX: tycon -> bool
val layoutApp:
tycon * (Layout.t * ({isChar: bool} * BindingStrength.t)) vector
-> Layout.t * ({isChar: bool} * BindingStrength.t)
val list: tycon
- val pointer: tycon
val prims: {admitsEquality: AdmitsEquality.t,
kind: Kind.t,
name: string,
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const.fun 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const.fun 2007-04-30 03:28:24 UTC (rev 5541)
@@ -41,12 +41,14 @@
datatype t =
IntInf of IntInf.t
+ | Null
| Real of RealX.t
| Word of WordX.t
| WordVector of WordXVector.t
+val intInf = IntInf
+val null = Null
val real = Real
-val intInf = IntInf
val word = Word
val wordVector = WordVector
@@ -58,6 +60,7 @@
in
val layout =
fn IntInf i => IntInf.layout i
+ | Null => str "NULL"
| Real r => RealX.layout r
| Word w => WordX.layout w
| WordVector v => wrap ("\"", "\"", WordXVector.toString v)
@@ -68,6 +71,7 @@
fun hash (c: t): word =
case c of
IntInf i => String.hash (IntInf.toString i)
+ | Null => 0wx0
| Real r => RealX.hash r
| Word w => Word.fromIntInf (WordX.toIntInf w)
| WordVector v => String.hash (WordXVector.toString v)
@@ -75,6 +79,7 @@
fun equals (c, c') =
case (c, c') of
(IntInf i, IntInf i') => IntInf.equals (i, i')
+ | (Null, Null) => true
| (Real r, Real r') => RealX.equals (r, r')
| (Word w, Word w') => WordX.equals (w, w')
| (WordVector v, WordVector v') => WordXVector.equals (v, v')
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const.sig 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const.sig 2007-04-30 03:28:24 UTC (rev 5541)
@@ -32,6 +32,7 @@
datatype t =
IntInf of IntInf.t
+ | Null
| Real of RealX.t
| Word of WordX.t
| WordVector of WordXVector.t
@@ -45,6 +46,7 @@
*)
val lookup: ({default: string option,
name: string} * ConstType.t -> t) ref
+ val null: t
val real: RealX.t -> t
val string: string -> t
val toString: t -> string
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/atoms/hash-type.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/atoms/hash-type.fun 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/atoms/hash-type.fun 2007-04-30 03:28:24 UTC (rev 5541)
@@ -142,6 +142,7 @@
in
case c of
IntInf _ => intInf
+ | Null => cpointer
| Real r => real (RealX.size r)
| Word w => word (WordX.size w)
| WordVector v => vector (word (WordXVector.elementSize v))
@@ -235,7 +236,6 @@
val cint = word (WordSize.cint ())
val compareRes = word WordSize.compareRes
val csize = word (WordSize.csize ())
- val cpointer = word (WordSize.cpointer ())
val cptrdiff = word (WordSize.cptrdiff ())
val seqIndex = word (WordSize.seqIndex ())
val shiftArg = word WordSize.shiftArg
@@ -245,7 +245,7 @@
fun intInfBinary () = done ([intInf, intInf, csize], intInf)
fun intInfShift () = done ([intInf, shiftArg, csize], intInf)
fun intInfUnary () = done ([intInf, csize], intInf)
- fun real3 s = done ([real s, real s, real s], real s)
+ fun realTernary s = done ([real s, real s, real s], real s)
val word8Array = array word8
fun wordShift s = done ([word s, shiftArg], word s)
in
@@ -256,6 +256,21 @@
| Array_sub => oneTarg (fn t => ([array t, seqIndex], t))
| Array_toVector => oneTarg (fn t => ([array t], vector t))
| Array_update => oneTarg (fn t => ([array t, seqIndex, t], unit))
+ | CPointer_add => done ([cpointer, csize], cpointer)
+ | CPointer_diff => done ([cpointer, cpointer], csize)
+ | CPointer_equal => done ([cpointer, cpointer], bool)
+ | CPointer_fromWord => done ([csize], cpointer)
+ | CPointer_getCPointer => done ([cpointer, cptrdiff], cpointer)
+ | CPointer_getObjptr => oneTarg (fn t => ([cpointer, cptrdiff], t))
+ | CPointer_getReal s => done ([cpointer, cptrdiff], real s)
+ | CPointer_getWord s => done ([cpointer, cptrdiff], word s)
+ | CPointer_lt => done ([cpointer, cpointer], bool)
+ | CPointer_setCPointer => done ([cpointer, cptrdiff, cpointer], unit)
+ | CPointer_setObjptr => oneTarg (fn t => ([cpointer, cptrdiff, t], unit))
+ | CPointer_setReal s => done ([cpointer, cptrdiff, real s], unit)
+ | CPointer_setWord s => done ([cpointer, cptrdiff, word s], unit)
+ | CPointer_sub => done ([cpointer, csize], cpointer)
+ | CPointer_toWord => done ([cpointer], csize)
| Exn_extra => oneTarg (fn t => ([exn], t))
| Exn_name => done ([exn], string)
| Exn_setExtendExtra => oneTarg (fn t => ([arrow (t, t)], unit))
@@ -291,12 +306,6 @@
| MLton_share => oneTarg (fn t => ([t], unit))
| MLton_size => oneTarg (fn t => ([t], csize))
| MLton_touch => oneTarg (fn t => ([t], unit))
- | Pointer_getPointer => oneTarg (fn t => ([cpointer, cptrdiff], t))
- | Pointer_getReal s => done ([cpointer, cptrdiff], real s)
- | Pointer_getWord s => done ([cpointer, cptrdiff], word s)
- | Pointer_setPointer => oneTarg (fn t => ([cpointer, cptrdiff, t], unit))
- | Pointer_setReal s => done ([cpointer, cptrdiff, real s], unit)
- | Pointer_setWord s => done ([cpointer, cptrdiff, word s], unit)
| Real_Math_acos s => realUnary s
| Real_Math_asin s => realUnary s
| Real_Math_atan s => realUnary s
@@ -317,8 +326,8 @@
| Real_le s => realCompare s
| Real_lt s => realCompare s
| Real_mul s => realBinary s
- | Real_muladd s => real3 s
- | Real_mulsub s => real3 s
+ | Real_muladd s => realTernary s
+ | Real_mulsub s => realTernary s
| Real_neg s => realUnary s
| Real_qequal s => realCompare s
| Real_rndToReal (s, s') => done ([real s], real s')
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/atoms/prim.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/atoms/prim.fun 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/atoms/prim.fun 2007-04-30 03:28:24 UTC (rev 5541)
@@ -41,6 +41,21 @@
| Array_sub (* backend *)
| Array_toVector (* backend *)
| Array_update (* backend *)
+ | CPointer_add (* codegen *)
+ | CPointer_diff (* codegen *)
+ | CPointer_equal (* codegen *)
+ | CPointer_fromWord (* codegen *)
+ | CPointer_getCPointer (* ssa to rssa *)
+ | CPointer_getObjptr (* ssa to rssa *)
+ | CPointer_getReal of RealSize.t (* ssa to rssa *)
+ | CPointer_getWord of WordSize.t (* ssa to rssa *)
+ | CPointer_lt (* codegen *)
+ | CPointer_setCPointer (* ssa to rssa *)
+ | CPointer_setObjptr (* ssa to rssa *)
+ | CPointer_setReal of RealSize.t (* ssa to rssa *)
+ | CPointer_setWord of WordSize.t (* ssa to rssa *)
+ | CPointer_sub (* codegen *)
+ | CPointer_toWord (* codegen *)
| Exn_extra (* implement exceptions *)
| Exn_name (* implement exceptions *)
| Exn_setExtendExtra (* implement exceptions *)
@@ -93,12 +108,6 @@
| MLton_serialize (* unused *)
| MLton_size (* ssa to rssa *)
| MLton_touch (* backend *)
- | Pointer_getPointer (* ssa to rssa *)
- | Pointer_getReal of RealSize.t (* ssa to rssa *)
- | Pointer_getWord of WordSize.t (* ssa to rssa *)
- | Pointer_setPointer (* ssa to rssa *)
- | Pointer_setReal of RealSize.t (* ssa to rssa *)
- | Pointer_setWord of WordSize.t (* ssa to rssa *)
| Real_Math_acos of RealSize.t (* codegen *)
| Real_Math_asin of RealSize.t (* codegen *)
| Real_Math_atan of RealSize.t (* codegen *)
@@ -204,8 +213,8 @@
fun cast (c, c', s, s') = coerce ("cast", c, c', s, s')
fun extd (c, c', s, s') = coerce ("extd", c, c', s, s')
fun rnd (c, c', s, s') = coerce ("rnd", c, c', s, s')
- fun pointerGet (ty, s) = concat ["Pointer_get", ty, s]
- fun pointerSet (ty, s) = concat ["Pointer_set", ty, s]
+ fun cpointerGet (ty, s) = concat ["CPointer_get", ty, s]
+ fun cpointerSet (ty, s) = concat ["CPointer_set", ty, s]
in
case n of
Array_array => "Array_array"
@@ -214,6 +223,21 @@
| Array_sub => "Array_sub"
| Array_toVector => "Array_toVector"
| Array_update => "Array_update"
+ | CPointer_add => "CPointer_add"
+ | CPointer_diff => "CPointer_diff"
+ | CPointer_equal => "CPointer_equal"
+ | CPointer_fromWord => "CPointer_fromWord"
+ | CPointer_getCPointer => "CPointer_getCPointer"
+ | CPointer_getObjptr => "CPointer_getObjptr"
+ | CPointer_getReal s => cpointerGet ("Real", RealSize.toString s)
+ | CPointer_getWord s => cpointerGet ("Word", WordSize.toString s)
+ | CPointer_lt => "CPointer_lt"
+ | CPointer_setCPointer => "CPointer_setCPointer"
+ | CPointer_setObjptr => "CPointer_setObjptr"
+ | CPointer_setReal s => cpointerSet ("Real", RealSize.toString s)
+ | CPointer_setWord s => cpointerSet ("Word", WordSize.toString s)
+ | CPointer_sub => "CPointer_sub"
+ | CPointer_toWord => "CPointer_toWord"
| Exn_extra => "Exn_extra"
| Exn_name => "Exn_name"
| Exn_setExtendExtra => "Exn_setExtendExtra"
@@ -251,12 +275,6 @@
| MLton_share => "MLton_share"
| MLton_size => "MLton_size"
| MLton_touch => "MLton_touch"
- | Pointer_getPointer => "Pointer_getPointer"
- | Pointer_getReal s => pointerGet ("Real", RealSize.toString s)
- | Pointer_getWord s => pointerGet ("Word", WordSize.toString s)
- | Pointer_setPointer => "Pointer_setPointer"
- | Pointer_setReal s => pointerSet ("Real", RealSize.toString s)
- | Pointer_setWord s => pointerSet ("Word", WordSize.toString s)
| Real_Math_acos s => real (s, "Math_acos")
| Real_Math_asin s => real (s, "Math_asin")
| Real_Math_atan s => real (s, "Math_atan")
@@ -344,6 +362,21 @@
| (Array_sub, Array_sub) => true
| (Array_toVector, Array_toVector) => true
| (Array_update, Array_update) => true
+ | (CPointer_add, CPointer_add) => true
+ | (CPointer_diff, CPointer_diff) => true
+ | (CPointer_equal, CPointer_equal) => true
+ | (CPointer_fromWord, CPointer_fromWord) => true
+ | (CPointer_getCPointer, CPointer_getCPointer) => true
+ | (CPointer_getObjptr, CPointer_getObjptr) => true
+ | (CPointer_getReal s, CPointer_getReal s') => RealSize.equals (s, s')
+ | (CPointer_getWord s, CPointer_getWord s') => WordSize.equals (s, s')
+ | (CPointer_lt, CPointer_lt) => true
+ | (CPointer_setCPointer, CPointer_setCPointer) => true
+ | (CPointer_setObjptr, CPointer_setObjptr) => true
+ | (CPointer_setReal s, CPointer_setReal s') => RealSize.equals (s, s')
+ | (CPointer_setWord s, CPointer_setWord s') => WordSize.equals (s, s')
+ | (CPointer_sub, CPointer_sub) => true
+ | (CPointer_toWord, CPointer_toWord) => true
| (Exn_extra, Exn_extra) => true
| (Exn_name, Exn_name) => true
| (Exn_setExtendExtra, Exn_setExtendExtra) => true
@@ -381,12 +414,6 @@
| (MLton_share, MLton_share) => true
| (MLton_size, MLton_size) => true
| (MLton_touch, MLton_touch) => true
- | (Pointer_getPointer, Pointer_getPointer) => true
- | (Pointer_getReal s, Pointer_getReal s') => RealSize.equals (s, s')
- | (Pointer_getWord s, Pointer_getWord s') => WordSize.equals (s, s')
- | (Pointer_setPointer, Pointer_setPointer) => true
- | (Pointer_setReal s, Pointer_setReal s') => RealSize.equals (s, s')
- | (Pointer_setWord s, Pointer_setWord s') => WordSize.equals (s, s')
| (Real_Math_acos s, Real_Math_acos s') => RealSize.equals (s, s')
| (Real_Math_asin s, Real_Math_asin s') => RealSize.equals (s, s')
| (Real_Math_atan s, Real_Math_atan s') => RealSize.equals (s, s')
@@ -496,6 +523,21 @@
| Array_sub => Array_sub
| Array_toVector => Array_toVector
| Array_update => Array_update
+ | CPointer_add => CPointer_add
+ | CPointer_diff => CPointer_diff
+ | CPointer_equal => CPointer_equal
+ | CPointer_fromWord => CPointer_fromWord
+ | CPointer_getCPointer => CPointer_getCPointer
+ | CPointer_getObjptr => CPointer_getObjptr
+ | CPointer_getReal z => CPointer_getReal z
+ | CPointer_getWord z => CPointer_getWord z
+ | CPointer_lt => CPointer_lt
+ | CPointer_setCPointer => CPointer_setCPointer
+ | CPointer_setObjptr => CPointer_setObjptr
+ | CPointer_setReal z => CPointer_setReal z
+ | CPointer_setWord z => CPointer_setWord z
+ | CPointer_sub => CPointer_sub
+ | CPointer_toWord => CPointer_toWord
| Exn_extra => Exn_extra
| Exn_name => Exn_name
| Exn_setExtendExtra => Exn_setExtendExtra
@@ -533,12 +575,6 @@
| MLton_share => MLton_share
| MLton_size => MLton_size
| MLton_touch => MLton_touch
- | Pointer_getPointer => Pointer_getPointer
- | Pointer_getReal z => Pointer_getReal z
- | Pointer_getWord z => Pointer_getWord z
- | Pointer_setPointer => Pointer_setPointer
- | Pointer_setReal z => Pointer_setReal z
- | Pointer_setWord z => Pointer_setWord z
| Real_Math_acos z => Real_Math_acos z
| Real_Math_asin z => Real_Math_asin z
| Real_Math_atan z => Real_Math_atan z
@@ -623,6 +659,45 @@
val assign = Ref_assign
val bogus = MLton_bogus
val bug = MLton_bug
+val cpointerAdd = CPointer_add
+val cpointerDiff = CPointer_diff
+val cpointerEqual = CPointer_equal
+fun cpointerGet ctype =
+ let datatype z = datatype CType.t
+ in
+ case ctype of
+ CPointer => CPointer_getCPointer
+ | Int8 => CPointer_getWord (WordSize.fromBits (Bits.fromInt 8))
+ | Int16 => CPointer_getWord (WordSize.fromBits (Bits.fromInt 16))
+ | Int32 => CPointer_getWord (WordSize.fromBits (Bits.fromInt 32))
+ | Int64 => CPointer_getWord (WordSize.fromBits (Bits.fromInt 64))
+ | Objptr => CPointer_getObjptr
+ | Real32 => CPointer_getReal RealSize.R32
+ | Real64 => CPointer_getReal RealSize.R64
+ | Word8 => CPointer_getWord (WordSize.fromBits (Bits.fromInt 8))
+ | Word16 => CPointer_getWord (WordSize.fromBits (Bits.fromInt 16))
+ | Word32 => CPointer_getWord (WordSize.fromBits (Bits.fromInt 32))
+ | Word64 => CPointer_getWord (WordSize.fromBits (Bits.fromInt 64))
+ end
+val cpointerLt = CPointer_lt
+fun cpointerSet ctype =
+ let datatype z = datatype CType.t
+ in
+ case ctype of
+ CPointer => CPointer_setCPointer
+ | Int8 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 8))
+ | Int16 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 16))
+ | Int32 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 32))
+ | Int64 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 64))
+ | Objptr => CPointer_setObjptr
+ | Real32 => CPointer_setReal RealSize.R32
+ | Real64 => CPointer_setReal RealSize.R64
+ | Word8 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 8))
+ | Word16 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 16))
+ | Word32 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 32))
+ | Word64 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 64))
+ end
+val cpointerSub = CPointer_sub
val deref = Ref_deref
val eq = MLton_eq
val equal = MLton_equal
@@ -631,41 +706,7 @@
val intInfEqual = IntInf_equal
val intInfNeg = IntInf_neg
val intInfNotb = IntInf_notb
-fun pointerGet ctype =
- let datatype z = datatype CType.t
- in
- case ctype of
- CPointer => Pointer_getPointer
- | Int8 => Pointer_getWord (WordSize.fromBits (Bits.fromInt 8))
- | Int16 => Pointer_getWord (WordSize.fromBits (Bits.fromInt 16))
- | Int32 => Pointer_getWord (WordSize.fromBits (Bits.fromInt 32))
- | Int64 => Pointer_getWord (WordSize.fromBits (Bits.fromInt 64))
- | Objptr => Error.bug "Prim.pointerGet"
- | Real32 => Pointer_getReal RealSize.R32
- | Real64 => Pointer_getReal RealSize.R64
- | Word8 => Pointer_getWord (WordSize.fromBits (Bits.fromInt 8))
- | 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
- CPointer => Pointer_setPointer
- | 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))
- | Objptr => Error.bug "Prim.pointerSet"
- | 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 realCastToWord = Real_castToWord
val reff = Ref_ref
val touch = MLton_touch
val vectorLength = Vector_length
@@ -673,6 +714,7 @@
val wordAdd = Word_add
val wordAddCheck = Word_addCheck
val wordAndb = Word_andb
+val wordCastToReal = Word_castToReal
val wordEqual = Word_equal
val wordLshift = Word_lshift
val wordLt = Word_lt
@@ -721,6 +763,21 @@
| Array_sub => DependsOnState
| Array_toVector => DependsOnState
| Array_update => SideEffect
+ | CPointer_add => Functional
+ | CPointer_diff => Functional
+ | CPointer_equal => Functional
+ | CPointer_fromWord => Functional
+ | CPointer_getCPointer => DependsOnState
+ | CPointer_getObjptr => DependsOnState
+ | CPointer_getReal _ => DependsOnState
+ | CPointer_getWord _ => DependsOnState
+ | CPointer_lt => Functional
+ | CPointer_setCPointer => SideEffect
+ | CPointer_setObjptr => SideEffect
+ | CPointer_setReal _ => SideEffect
+ | CPointer_setWord _ => SideEffect
+ | CPointer_sub => Functional
+ | CPointer_toWord => Functional
| Exn_extra => Functional
| Exn_name => Functional
| Exn_setExtendExtra => SideEffect
@@ -758,12 +815,6 @@
| MLton_share => SideEffect
| MLton_size => DependsOnState
| MLton_touch => SideEffect
- | Pointer_getPointer => DependsOnState
- | Pointer_getReal _ => DependsOnState
- | Pointer_getWord _ => DependsOnState
- | Pointer_setPointer => SideEffect
- | Pointer_setReal _ => SideEffect
- | Pointer_setWord _ => SideEffect
| Real_Math_acos _ => Functional
| Real_Math_asin _ => Functional
| Real_Math_atan _ => Functional
@@ -916,6 +967,17 @@
Array_sub,
Array_toVector,
Array_update,
+ CPointer_add,
+ CPointer_diff,
+ CPointer_equal,
+ CPointer_fromWord,
+ CPointer_getCPointer,
+ CPointer_getObjptr,
+ CPointer_lt,
+ CPointer_setCPointer,
+ CPointer_setObjptr,
+ CPointer_sub,
+ CPointer_toWord,
Exn_extra,
Exn_name,
Exn_setExtendExtra,
@@ -951,8 +1013,6 @@
MLton_share,
MLton_size,
MLton_touch,
- Pointer_getPointer,
- Pointer_setPointer,
Ref_assign,
Ref_deref,
Ref_ref,
@@ -1006,8 +1066,8 @@
fun doit (all, get, set) =
List.concatMap (all, fn s => [get s, set s])
in
- List.concat [doit (RealSize.all, Pointer_getReal, Pointer_setReal),
- doit (WordSize.prims, Pointer_getWord, Pointer_setWord)]
+ List.concat [doit (RealSize.all, CPointer_getReal, CPointer_setReal),
+ doit (WordSize.prims, CPointer_getWord, CPointer_setWord)]
end
end
@@ -1069,8 +1129,10 @@
| MLton_share => one (arg 0)
| MLton_size => one (arg 0)
| MLton_touch => one (arg 0)
- | Pointer_getPointer => one result
- | Pointer_setPointer => one (arg 2)
+ | CPointer_getCPointer => one result
+ | CPointer_getObjptr => one result
+ | CPointer_setCPointer => one (arg 2)
+ | CPointer_setObjptr => one (arg 2)
| Ref_assign => one (arg 1)
| Ref_deref => one result
| Ref_ref => one (arg 0)
@@ -1170,6 +1232,7 @@
val bool = ApplyResult.Bool
val intInf = ApplyResult.Const o Const.intInf
val intInfConst = intInf o IntInf.fromInt
+ val null = ApplyResult.Const Const.null
fun word (w: WordX.t): ('a, 'b) ApplyResult.t =
ApplyResult.Const (Const.word w)
val f = ApplyResult.falsee
@@ -1223,6 +1286,11 @@
| SOME w => word w)
| (MLton_eq, [c1, c2]) => eq (c1, c2)
| (MLton_equal, [c1, c2]) => equal (c1, c2)
+ | (CPointer_fromWord, [Word w]) =>
+ if WordX.isZero w
+ then null
+ else ApplyResult.Unknown
+ | (CPointer_toWord, [Null]) => word (WordX.zero (WordSize.cpointer ()))
| (Word_add _, [Word w1, Word w2]) => word (WordX.add (w1, w2))
| (Word_addCheck s, [Word w1, Word w2]) => wcheck (op +, s, w1, w2)
| (Word_andb _, [Word w1, Word w2]) => word (WordX.andb (w1, w2))
@@ -1367,7 +1435,16 @@
else Unknown
in
case p of
- Word_add _ => add ()
+ CPointer_add =>
+ if WordX.isZero w
+ then Var x
+ else Unknown
+ | CPointer_sub =>
+ if WordX.isZero w
+ andalso inOrder
+ then Var x
+ else Unknown
+ | Word_add _ => add ()
| Word_addCheck _ => add ()
| Word_andb s =>
if WordX.isZero w
@@ -1517,7 +1594,10 @@
datatype z = datatype ApplyResult.t
in
case p of
- IntInf_compare =>
+ CPointer_diff => word (WordX.zero (WordSize.cpointer ()))
+ | CPointer_equal => t
+ | CPointer_lt => f
+ | IntInf_compare =>
word (WordX.zero WordSize.compareRes)
| IntInf_equal => t
| MLton_eq => t
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/atoms/prim.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/atoms/prim.sig 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/atoms/prim.sig 2007-04-30 03:28:24 UTC (rev 5541)
@@ -31,6 +31,21 @@
| Array_sub (* ssa to ssa2 *)
| Array_toVector (* backend *)
| Array_update (* ssa to ssa2 *)
+ | CPointer_add (* codegen *)
+ | CPointer_diff (* codegen *)
+ | CPointer_equal (* codegen *)
+ | CPointer_fromWord (* codegen *)
+ | CPointer_getCPointer (* ssa to rssa *)
+ | CPointer_getObjptr (* ssa to rssa *)
+ | CPointer_getReal of RealSize.t (* ssa to rssa *)
+ | CPointer_getWord of WordSize.t (* ssa to rssa *)
+ | CPointer_lt (* codegen *)
+ | CPointer_setCPointer (* ssa to rssa *)
+ | CPointer_setObjptr (* ssa to rssa *)
+ | CPointer_setReal of RealSize.t (* ssa to rssa *)
+ | CPointer_setWord of WordSize.t (* ssa to rssa *)
+ | CPointer_sub (* codegen *)
+ | CPointer_toWord (* codegen *)
| Exn_extra (* implement exceptions *)
| Exn_name (* implement exceptions *)
| Exn_setExtendExtra (* implement exceptions *)
@@ -83,12 +98,6 @@
| MLton_share
| MLton_size (* ssa to rssa *)
| MLton_touch (* backend *)
- | Pointer_getPointer (* ssa to rssa *)
- | Pointer_getReal of RealSize.t (* ssa to rssa *)
- | Pointer_getWord of WordSize.t (* ssa to rssa *)
- | Pointer_setPointer (* ssa to rssa *)
- | Pointer_setReal of RealSize.t (* ssa to rssa *)
- | Pointer_setWord of WordSize.t (* ssa to rssa *)
| Real_Math_acos of RealSize.t (* codegen *)
| Real_Math_asin of RealSize.t (* codegen *)
| Real_Math_atan of RealSize.t (* codegen *)
@@ -205,6 +214,13 @@
val assign: 'a t
val bogus: 'a t
val bug: 'a t
+ val cpointerAdd: 'a t
+ val cpointerDiff: 'a t
+ val cpointerEqual: 'a t
+ val cpointerGet: CType.t -> 'a t
+ val cpointerLt: 'a t
+ val cpointerSet: CType.t -> 'a t
+ val cpointerSub: 'a t
val deref: 'a t
val eq: 'a t (* pointer equality *)
val equal: 'a t (* polymorphic equality *)
@@ -237,9 +253,8 @@
* not examples: Array_array, Array_sub, Ref_deref, Ref_ref
*)
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 realCastToWord: RealSize.t * WordSize.t -> 'a t
val reff: 'a t
val toString: 'a t -> string
val touch: 'a t
@@ -248,6 +263,7 @@
val wordAdd: WordSize.t -> 'a t
val wordAddCheck: WordSize.t * {signed: bool} -> 'a t
val wordAndb: WordSize.t -> 'a t
+ val wordCastToReal : WordSize.t * RealSize.t -> 'a t
val wordEqual: WordSize.t -> 'a t
val wordLt: WordSize.t * {signed: bool} -> 'a t
val wordLshift: WordSize.t -> 'a t
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/atoms/type-ops.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/atoms/type-ops.fun 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/atoms/type-ops.fun 2007-04-30 03:28:24 UTC (rev 5541)
@@ -25,6 +25,7 @@
fun nullary tycon = con (tycon, Vector.new0 ())
in
val bool = nullary Tycon.bool
+ val cpointer = nullary Tycon.cpointer
val exn = nullary Tycon.exn
val intInf = nullary Tycon.intInf
val real = RealSize.memoize (fn s => nullary (Tycon.real s))
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/atoms/type-ops.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/atoms/type-ops.sig 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/atoms/type-ops.sig 2007-04-30 03:28:24 UTC (rev 5541)
@@ -32,6 +32,7 @@
val arrow: t * t -> t
val bool: t
val con: tycon * t vector -> t
+ val cpointer: t
val deArray: t -> t
val deArrow: t -> t * t
val deArrowOpt: t -> (t * t) option
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/backend/backend.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/backend/backend.fun 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/backend/backend.fun 2007-04-30 03:28:24 UTC (rev 5541)
@@ -426,6 +426,7 @@
(case Const.SmallIntInf.toWord i of
NONE => globalIntInf i
| SOME w => M.Operand.Word w)
+ | Null => M.Operand.Null
| Real r => realOp r
| Word w => M.Operand.Word w
| WordVector v => globalVector v
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/backend/limit-check.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/backend/limit-check.fun 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/backend/limit-check.fun 2007-04-30 03:28:24 UTC (rev 5541)
@@ -331,7 +331,7 @@
fun stackCheck (maybeFirst, z): Label.t =
let
val (statements, transfer) =
- primApp (lessThan,
+ primApp (Prim.cpointerLt,
Operand.Runtime StackLimit,
Operand.Runtime StackTop,
z)
@@ -378,7 +378,7 @@
{args = Vector.new2 (Operand.Runtime LimitPlusSlop,
Operand.Runtime Frontier),
dst = SOME (res, Type.csize ()),
- prim = Prim.wordSub (WordSize.csize ())}
+ prim = Prim.cpointerDiff}
val (statements, transfer) =
primApp (lessThan,
Operand.Var {var = res, ty = Type.csize ()},
@@ -389,10 +389,9 @@
if handlesSignals
then
frontierCheck (isFirst,
- Prim.wordEqual (WordSize.csize ()),
+ Prim.cpointerEqual,
Operand.Runtime Limit,
- Operand.word (WordX.zero
- (WordSize.csize ())),
+ Operand.null,
{collect = collect,
dontCollect = newBlock (false,
statements,
@@ -410,7 +409,7 @@
ignore
(if Bytes.<= (bytes, Runtime.limitSlop)
then frontierCheck (true,
- lessThan,
+ Prim.cpointerLt,
Operand.Runtime Limit,
Operand.Runtime Frontier,
insert (Operand.word
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/backend/machine.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/backend/machine.fun 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/backend/machine.fun 2007-04-30 03:28:24 UTC (rev 5541)
@@ -210,6 +210,7 @@
| Global of Global.t
| Label of Label.t
| Line
+ | Null
| Offset of {base: t,
offset: Bytes.t,
ty: Type.t}
@@ -229,6 +230,7 @@
| Global g => Global.ty g
| Label l => Type.label l
| Line => Type.cint ()
+ | Null => Type.cpointer ()
| Offset {ty, ...} => ty
| Real r => Type.real (RealX.size r)
| Register r => Register.ty r
@@ -261,6 +263,7 @@
| Global g => Global.layout g
| Label l => Label.layout l
| Line => str "<Line>"
+ | Null => str "NULL"
| Offset {base, offset, ty} =>
seq [str (concat ["O", Type.name ty, " "]),
tuple [layout base, Bytes.layout offset],
@@ -302,8 +305,10 @@
let
fun inter read = interfere (write, read)
in
- case (read, write)
- of (ArrayOffset {base, index, ...}, _) =>
+ case (read, write) of
+ (Cast (z, _), _) => interfere (write, z)
+ | (_, Cast (z, _)) => interfere (z, read)
+ | (ArrayOffset {base, index, ...}, _) =>
inter base orelse inter index
| (Contents {oper, ...}, _) => inter oper
| (Global g, Global g') => Global.equals (g, g')
@@ -1056,6 +1061,7 @@
in true
end handle _ => false)
| Line => true
+ | Null => true
| Offset {base, offset, ty} =>
(checkOperand (base, alloc)
; (Operand.isLocation base
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/backend/machine.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/backend/machine.sig 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/backend/machine.sig 2007-04-30 03:28:24 UTC (rev 5541)
@@ -88,6 +88,7 @@
| Global of Global.t
| Label of Label.t
| Line (* expand by codegen into int constant *)
+ | Null
| Offset of {base: t,
offset: Bytes.t,
ty: Type.t}
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/backend/packed-representation.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/backend/packed-representation.fun 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/backend/packed-representation.fun 2007-04-30 03:28:24 UTC (rev 5541)
@@ -247,7 +247,8 @@
Vector.fold
(components, NONE, fn ({index, rep, ...}, z) =>
let
- val (src, ss) = Statement.resize (src {index = index}, bits)
+ val (src, ss) = Statement.resize (src {index = index},
+ Type.bits bits)
in
case z of
NONE => SOME (src, Rep.width rep, [rev ss])
@@ -349,7 +350,7 @@
Direct {index, ...} =>
let
val (src, ss) =
- Statement.resize (src {index = index}, Type.width (#2 dst))
+ Statement.resize (src {index = index}, #2 dst)
in
ss @ [Bind {dst = dst,
isMutable = false,
@@ -403,7 +404,7 @@
val sz = WordSize.fromBits w
val w' = Type.width dstTy
val sz' = WordSize.fromBits w'
- val (src, ss2) = Statement.resize (src, w')
+ val (src, ss2) = Statement.resize (src, dstTy)
val (src, ss3) =
if Bits.equals (w, w')
(* orelse Type.isZero (Type.dropPrefix (Operand.ty src,
@@ -439,7 +440,8 @@
let
val shift =
WordX.fromIntInf (Bits.toIntInf shift, WordSize.shiftArg)
- val chunkWidth = Type.width (Operand.ty chunk)
+ val chunkTy = Operand.ty chunk
+ val chunkWidth = Type.width chunkTy
val mask =
Operand.word
(WordX.notb
@@ -448,7 +450,7 @@
WordSize.fromBits chunkWidth),
shift)))
val (s1, chunk) = Statement.andb (chunk, mask)
- val (component, s2) = Statement.resize (component, chunkWidth)
+ val (component, s2) = Statement.resize (component, chunkTy)
val (s3, component) = Statement.lshift (component, Operand.word shift)
val (s4, result) = Statement.orb (chunk, component)
in
@@ -488,55 +490,30 @@
NONE => Error.bug "PackedRepresentation.Base.toOperand: eltWidth"
| SOME w => w
in
- case Scale.fromInt (Bytes.toInt eltWidth) of
+ case Scale.fromBytes eltWidth of
NONE =>
let
val seqIndexSize = WordSize.seqIndex ()
- val csizeSize = WordSize.csize ()
- val csizeTy = Type.word csizeSize
- (* vector + (eltWidth * index) + offset *)
- val ind = Var.newNoname ()
- val s0 =
- case WordSize.compare (seqIndexSize, csizeSize) of
- EQUAL =>
- Bind {dst = (ind, csizeTy),
- isMutable = false,
- src = index}
- | GREATER => Error.bug "PackedRepresentation.Base.ToOperand: WordSize.compare (seqIndexSize, csizeSize)"
- | LESS =>
- PrimApp {args = Vector.new1 index,
- dst = SOME (ind, csizeTy),
- prim = (Prim.wordExtdToWord
- (seqIndexSize,
- csizeSize,
- {signed = false}))}
+ val seqIndexTy = Type.word seqIndexSize
val prod = Var.newNoname ()
- val s1 =
+ val s =
PrimApp {args = (Vector.new2
- (Operand.Var {ty = csizeTy,
- var = ind},
+ (index,
Operand.word
(WordX.fromIntInf
(Bytes.toIntInf eltWidth,
- csizeSize)))),
- dst = SOME (prod, csizeTy),
+ seqIndexSize)))),
+ dst = SOME (prod, seqIndexTy),
prim = (Prim.wordMul
- (csizeSize,
+ (seqIndexSize,
{signed = false}))}
- val eltBase = Var.newNoname ()
- val s2 =
- PrimApp {args = (Vector.new2
- (vector,
- Operand.Var {ty = csizeTy,
- var = prod})),
- dst = SOME (eltBase, csizeTy),
- prim = Prim.wordAdd csizeSize}
in
- (Offset {base = Operand.Var {ty = csizeTy,
- var = eltBase},
- offset = offset,
- ty = ty},
- [s0, s1, s2])
+ (ArrayOffset {base = vector,
+ index = Var {var = prod, ty = seqIndexTy},
+ offset = offset,
+ scale = Scale.One,
+ ty = ty},
+ [s])
end
| SOME s =>
(ArrayOffset {base = vector,
@@ -595,7 +572,7 @@
fun move (src, ss) =
let
val (dst, dstTy) = dst
- val (src, ss') = Statement.resize (src, Type.width dstTy)
+ val (src, ss') = Statement.resize (src, dstTy)
in
ss @ ss' @ [Bind {dst = (dst, dstTy),
isMutable = false,
@@ -777,7 +754,7 @@
else let
(* An object needs space for a forwarding objptr. *)
val width' = Bytes.max (width, Runtime.objptrSize ())
- (* Node that with Align8 and objptrSize == 64bits,
+ (* Note that with Align8 and objptrSize == 64bits,
* the following ensures that objptrs will be
* mod 8 aligned.
*)
@@ -1479,7 +1456,7 @@
ConRep.ShiftAndTag {tag, ty, ...} =>
let
val test = Operand.cast (test, Type.padToWidth (ty, testBits))
- val (test, ss) = Statement.resize (test, Type.width ty)
+ val (test, ss) = Statement.resize (test, ty)
val transfer =
Goto {args = if dstHasArg
then Vector.new1 test
@@ -1505,24 +1482,23 @@
| _ => NONE)
val cases = QuickSort.sortVector (cases, fn ((w, _), (w', _)) =>
WordX.le (w, w', {signed = false}))
+ val tagOp =
+ if isObjptr
+ then Operand.cast (test, Type.bits testBits)
+ else test
val (tagOp, ss) =
if isEnum
- then (test, [])
+ then (tagOp, [])
else
let
val mask =
Operand.word (WordX.resize
(WordX.max (tagSize, {signed = false}),
testSize))
- val (s, tag) = Statement.andb (test, mask)
+ val (s, tagOp) = Statement.andb (tagOp, mask)
in
- (tag, [s])
+ (tagOp, [s])
end
- (* CHECK: Shouldn't cast come before mask above? *)
- val tagOp =
- if isObjptr
- then Operand.cast (tagOp, Type.bits testBits)
- else tagOp
val default =
if Vector.length variants = Vector.length cases
then notSmall
@@ -1749,17 +1725,6 @@
in
if i >= objptrBitsAsInt ()
then makeBig ()
- else if (* FIXME: must box Real32 w/ 64bit object pointers,
- * since ShiftAndTag operations aren't bit casts;
- * we end up rounding a Real32 to a Word64.
- *)
- Type.exists
- (ty, fn ty =>
- case Type.deReal ty of
- NONE => false
- | SOME rs => Bytes.< (RealSize.bytes rs,
- objptrBytes ()))
- then makeBig ()
else
let
val {component, selects} =
@@ -2374,7 +2339,8 @@
datatype z = datatype S.Type.dest
in
case S.Type.dest t of
- Datatype tycon =>
+ CPointer => nonObjptr (Type.cpointer ())
+ | Datatype tycon =>
let
val r = tyconRep tycon
fun compute () = TyconRep.rep (#1 (Value.get r))
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/backend/rep-type.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/backend/rep-type.fun 2007-04-27 19:29:03 UTC (rev 5540)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/backend/rep-type.fun 2007-04-30 03:28:24 UTC (rev 5541)
@@ -121,6 +121,7 @@
objptr ObjptrTycon.thread
val word0: t = bits Bits.zero
+ val word8: t = word WordSize.word8
val word32: t = word WordSize.word32
val wordVector: WordSize.t -> t =
@@ -152,16 +153,21 @@
fun seqOnto (ts, ac) =
Vector.foldr
(ts, ac, fn (t, ac) =>
- case ac of
- [] => [t]
- | t' :: ac' =>
- (case (node t, node t') of
- (Seq ts, _) => seqOnto (ts, ac)
- | (Bits, Bits) => bits (Bits.+ (width t, width t')) :: ac'
- | _ => t :: ac))
+ if Bits.equals (width t, Bits.zero)
+ then ac
+ else (case node t of
+ Seq ts => seqOnto (ts, ac)
+ | _ => (case ac of
+ [] => [t]
+ | t' :: ac' =>
+ (case (node t, node t') of
+ (Bits, Bits) =>
+ bits (Bits.+ (width t, width t')) :: ac'
+ | _ => t :: ac))))
in
case seqOnto (ts, []) of
- [t] => t
+ [] => word0
+ | [t] => t
| ts =>
let
val ts = Vector.fromList ts
@@ -262,12 +268,18 @@
| (Word _, Objptr _) => true
| (Seq ts, Objptr _) =>
Vector.forall
- (ts, (fn Bits => true | Word _ => true | _ => false) o node)
+ (ts, (fn Bits => true
+ | Real _ => true
+ | Word _ => true
+ | _ => false) o node)
| (_, Bits) => true
| (_, Word _) => true
| (_, Seq ts) =>
Vector.forall
- (ts, (fn Bits => true | Word _ => true | _ => false) o node)
+ (ts, (fn Bits => true
+ | Real _ => true
+ | Word _ => true
+ | _ => false) o node)
| _ => false)
val isSubtype =
@@ -489,20 +501,226 @@
| StackTop => cpointer ()
end
-fun arrayOffsetIsOk {base,index, offset, tyconTy, result, scale} =
- case (base, index, offset, tyconTy, result, scale) of _ => true
-
fun castIsOk {from, to, tyconTy = _} =
Bits.equals (width from, width to)
fun checkPrimApp {args, prim, result} =
- case (args, Prim.name prim, result) of _ => true
+ let
+ datatype z = datatype Prim.Name.t
+ fun done (argsP, resultP) =
+ let
+ val argsP = Vector.fromList argsP
+ in
+ (Vector.length args = Vector.length argsP)
+ andalso (Vector.forall2 (args, argsP,
+ fn (arg, argP) => argP arg))
+ andalso (case (result, resultP) of
+ (NONE, NONE) => true
+ | (SOME result, SOME resultP) => resultP result
+ | _ => false)
+ end
+ val bits = fn s => fn t => equals (t, bits s)
+ val bool = fn t => equals (t, bool)
+ val cpointer = fn t => equals (t, cpointer ())
+ val objptr = fn t => (case node t of Objptr _ => true | _ => false)
+ val real = fn s => fn t => equals (t, real s)
+ val seq = fn s => fn t =>
+ (case node t
+ of Seq _ => Bits.equals (width t, WordSize.bits s)
+ | _ => false)
+ val word = fn s => fn t => equals (t, word s)
+ val cint = word (WordSize.cint ())
+ val csize = word (WordSize.csize ())
+ val shiftArg = word WordSize.shiftArg
+
+ val or = fn (p1, p
More information about the MLton-commit
mailing list