[MLton] cvs commit: C types now distinguish between signed and
unsigned words
Filip Pizlo
pizlo@purdue.edu
Mon, 6 Sep 2004 20:35:44 -0500 (EST)
Question: now that primitive.sml has _prim "MLton_share" in it, which is
not recognized by my version of MLton, how do I bootstrap? Is there a
special option to pass into 'make all-no-docs'?
--
Filip Pizlo
http://bocks.psych.purdue.edu/
pizlo@purdue.edu
On Mon, 6 Sep 2004, Stephen Weeks wrote:
> sweeks 04/09/06 17:46:20
>
> Modified: doc/user-guide ffi.tex
> mlton/atoms atoms.fun atoms.sig c-function.fun
> c-function.sig c-type.fun c-type.sig
> mlton/backend limit-check.fun profile.fun rep-type.fun
> rep-type.sig ssa-to-rssa.fun
> mlton/codegen/c-codegen c-codegen.fun
> mlton/codegen/x86-codegen x86-mlton-basic.fun x86.fun
> mlton/elaborate elaborate-core.fun
> runtime platform.h
> runtime/basis IntInf.c
> Log:
> MAIL C types now distinguish between signed and unsigned words
>
> This distinction is necessary because on some platforms the calling
> convention for signeds and unsigneds is different. This can happen
> when a small word (e.g. 8 bit) is represented in a larger word
> (e.g. 32 bit), in which case the signed version will be passed sign
> extended and the unsigned version will be passed zero extended.
>
> One unfortunate side effect of this change is that the type
> information for a C function (CFunction.t) is now duplicated, because
> we need the CType information to generate the prototype, while we need
> different type information for type checking the ILs. It's not clear
> if this duplication is worth the gain in type checking, especially
> since the C prototype can lie anyways. But, I've left it in for now.
> Of course, another fix would be to make the IL type information
> sufficiently precise that it subsumes the CType information. But
> that's a bit more pervasive of a change than I'm willing to stomach
> right now, plus I think it makes arbitrary distinctions between signed
> and unsigneds.
>
> A quick check reveals that generated C code now has correct prototypes
> for the Word_{quot,rem} functions.
>
> Int8 WordS8_quot (Int8 x1, Int8 x0);
> Int8 WordS8_rem (Int8 x1, Int8 x0);
> Int32 WordS32_quot (Int32 x1, Int32 x0);
> Int32 WordS32_rem (Int32 x1, Int32 x0);
>
> Filip, let us know if the fixed-integer regression now works without
> needing any explicit sign extensions, or if this checkin has caused
> any other problems.
>
> Revision Changes Path
> 1.25 +1 -1 mlton/doc/user-guide/ffi.tex
>
> Index: ffi.tex
> ===================================================================
> RCS file: /cvsroot/mlton/mlton/doc/user-guide/ffi.tex,v
> retrieving revision 1.24
> retrieving revision 1.25
> diff -u -r1.24 -r1.25
> --- ffi.tex 11 Aug 2004 01:57:05 -0000 1.24
> +++ ffi.tex 7 Sep 2004 00:46:18 -0000 1.25
> @@ -132,7 +132,7 @@
> \hline
> {\tt array} & {\tt Pointer} & {\tt char *} \\
> {\tt bool} & {\tt Int32} & {\tt long} \\
> -{\tt char} & {\tt Word8} & {\tt unsigned char} \\
> +{\tt char} & {\tt Int8} & {\tt char} \\
> {\tt Int8.int} & {\tt Int8} & {\tt char} \\
> {\tt Int16.int} & {\tt Int16} & {\tt short} \\
> {\tt Int32.int} & {\tt Int32} & {\tt long} \\
>
>
>
> 1.19 +2 -2 mlton/mlton/atoms/atoms.fun
>
> Index: atoms.fun
> ===================================================================
> RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
> retrieving revision 1.18
> retrieving revision 1.19
> diff -u -r1.18 -r1.19
> --- atoms.fun 1 May 2004 00:49:34 -0000 1.18
> +++ atoms.fun 7 Sep 2004 00:46:18 -0000 1.19
> @@ -21,7 +21,7 @@
> structure RealSize = RealSize
> structure WordSize = WordSize)
> structure Con = Con ()
> - structure CType = CType ()
> + structure CType = CType (structure WordSize = WordSize)
> structure RealX = RealX (structure RealSize = RealSize)
> structure WordX = WordX (structure WordSize = WordSize)
> structure Func =
> @@ -36,7 +36,7 @@
> end
> structure Const = Const (structure RealX = RealX
> structure WordX = WordX)
> - structure CFunction = CFunction ()
> + structure CFunction = CFunction (structure CType = CType)
> structure Prim = Prim (structure CFunction = CFunction
> structure CType = CType
> structure Con = Con
>
>
>
> 1.19 +3 -2 mlton/mlton/atoms/atoms.sig
>
> Index: atoms.sig
> ===================================================================
> RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
> retrieving revision 1.18
> retrieving revision 1.19
> diff -u -r1.18 -r1.19
> --- atoms.sig 1 May 2004 00:49:34 -0000 1.18
> +++ atoms.sig 7 Sep 2004 00:46:18 -0000 1.19
> @@ -42,14 +42,15 @@
> structure WordX: WORD_X
>
> sharing CFunction = Ffi.CFunction = Prim.CFunction
> - sharing CType = Ffi.CType = Prim.CType
> + sharing CType = CFunction.CType = Ffi.CType = Prim.CType
> sharing Con = Prim.Con
> sharing Const = Prim.Const
> sharing IntSize = Tycon.IntSize
> sharing RealSize = Prim.RealSize = RealX.RealSize = Tycon.RealSize
> sharing RealX = Const.RealX
> sharing SourceInfo = ProfileExp.SourceInfo
> - sharing WordSize = Prim.WordSize = Tycon.WordSize = WordX.WordSize
> + sharing WordSize = CType.WordSize = Prim.WordSize = Tycon.WordSize
> + = WordX.WordSize
> sharing WordX = Const.WordX
> end
>
>
>
>
> 1.8 +6 -3 mlton/mlton/atoms/c-function.fun
>
> Index: c-function.fun
> ===================================================================
> RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-function.fun,v
> retrieving revision 1.7
> retrieving revision 1.8
> diff -u -r1.7 -r1.8
> --- c-function.fun 20 Aug 2004 16:34:44 -0000 1.7
> +++ c-function.fun 7 Sep 2004 00:46:18 -0000 1.8
> @@ -24,6 +24,7 @@
> maySwitchThreads: bool,
> modifiesFrontier: bool,
> name: string,
> + prototype: CType.t vector * CType.t option,
> readsStackTop: bool,
> return: 'a,
> writesStackTop: bool}
> @@ -63,8 +64,8 @@
> fun equals (f, f') = name f = name f'
>
> fun map (T {args, bytesNeeded, convention, ensuresBytesFree, mayGC,
> - maySwitchThreads, modifiesFrontier, name, readsStackTop, return,
> - writesStackTop},
> + maySwitchThreads, modifiesFrontier, name, prototype, readsStackTop,
> + return, writesStackTop},
> f) =
> T {args = Vector.map (args, f),
> bytesNeeded = bytesNeeded,
> @@ -74,6 +75,7 @@
> maySwitchThreads = maySwitchThreads,
> modifiesFrontier = modifiesFrontier,
> name = name,
> + prototype = prototype,
> readsStackTop = readsStackTop,
> return = f return,
> writesStackTop = writesStackTop}
> @@ -94,7 +96,7 @@
> andalso readsStackTop andalso writesStackTop)
> else true)
>
> -fun vanilla {args, name, return} =
> +fun vanilla {args, name, prototype, return} =
> T {args = args,
> bytesNeeded = NONE,
> convention = Convention.Cdecl,
> @@ -103,6 +105,7 @@
> maySwitchThreads = false,
> modifiesFrontier = false,
> name = name,
> + prototype = prototype,
> readsStackTop = false,
> return = return,
> writesStackTop = false}
>
>
>
> 1.5 +3 -0 mlton/mlton/atoms/c-function.sig
>
> Index: c-function.sig
> ===================================================================
> RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-function.sig,v
> retrieving revision 1.4
> retrieving revision 1.5
> diff -u -r1.4 -r1.5
> --- c-function.sig 20 Aug 2004 16:34:44 -0000 1.4
> +++ c-function.sig 7 Sep 2004 00:46:18 -0000 1.5
> @@ -9,6 +9,7 @@
>
> signature C_FUNCTION_STRUCTS =
> sig
> + structure CType: C_TYPE
> end
>
> signature C_FUNCTION =
> @@ -38,6 +39,7 @@
> maySwitchThreads: bool,
> modifiesFrontier: bool,
> name: string,
> + prototype: CType.t vector * CType.t option,
> readsStackTop: bool,
> return: 'a,
> writesStackTop: bool}
> @@ -58,5 +60,6 @@
> val writesStackTop: 'a t -> bool
> val vanilla: {args: 'a vector,
> name: string,
> + prototype: CType.t vector * CType.t option,
> return: 'a} -> 'a t
> end
>
>
>
> 1.6 +53 -7 mlton/mlton/atoms/c-type.fun
>
> Index: c-type.fun
> ===================================================================
> RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-type.fun,v
> retrieving revision 1.5
> retrieving revision 1.6
> diff -u -r1.5 -r1.6
> --- c-type.fun 12 Apr 2004 17:52:48 -0000 1.5
> +++ c-type.fun 7 Sep 2004 00:46:18 -0000 1.6
> @@ -1,10 +1,21 @@
> +(* Copyright (C) 2004 Henry Cejtin, Matthew Fluet, Suresh
> + * Jagannathan, and Stephen Weeks.
> + *
> + * MLton is released under the GNU General Public License (GPL).
> + * Please see the file MLton-LICENSE for license information.
> + *)
> +
> functor CType (S: C_TYPE_STRUCTS): C_TYPE =
> struct
>
> open S
>
> datatype t =
> - Pointer
> + Int8
> + | Int16
> + | Int32
> + | Int64
> + | Pointer
> | Real32
> | Real64
> | Word8
> @@ -12,11 +23,14 @@
> | Word32
> | Word64
>
> -val all = [Pointer, Real32, Real64, Word8, Word16, Word32, Word64]
> +val all = [Int8, Int16, Int32, Int64,
> + Pointer,
> + Real32, Real64,
> + Word8, Word16, Word32, Word64]
>
> val bool = Word32
>
> -val char = Word8
> +val char = Int8
>
> val pointer = Pointer
>
> @@ -31,12 +45,20 @@
> val pointer = f Pointer
> val real32 = f Real32
> val real64 = f Real64
> + val int8 = f Int8
> + val int16 = f Int16
> + val int32 = f Int32
> + val int64 = f Int64
> val word8 = f Word8
> val word16 = f Word16
> val word32 = f Word32
> val word64 = f Word64
> in
> - fn Pointer => pointer
> + fn Int8 => int8
> + | Int16 => int16
> + | Int32 => int32
> + | Int64 => int64
> + | Pointer => pointer
> | Real32 => real32
> | Real64 => real64
> | Word8 => word8
> @@ -46,7 +68,11 @@
> end
>
> val toString =
> - fn Pointer => "Pointer"
> + fn Int8 => "Int8"
> + | Int16 => "Int16"
> + | Int32 => "Int32"
> + | Int64 => "Int64"
> + | Pointer => "Pointer"
> | Real32 => "Real32"
> | Real64 => "Real64"
> | Word8 => "Word8"
> @@ -58,7 +84,11 @@
>
> fun size (t: t): Bytes.t =
> case t of
> - Pointer => Bytes.inPointer
> + Int8 => Bytes.fromInt 1
> + | Int16 => Bytes.fromInt 2
> + | Int32 => Bytes.fromInt 4
> + | Int64 => Bytes.fromInt 8
> + | Pointer => Bytes.inPointer
> | Real32 => Bytes.fromInt 4
> | Real64 => Bytes.fromInt 8
> | Word8 => Bytes.fromInt 1
> @@ -68,7 +98,11 @@
>
> fun name t =
> case t of
> - Pointer => "P"
> + Int8 => "I8"
> + | Int16 => "I16"
> + | Int32 => "I32"
> + | Int64 => "I64"
> + | Pointer => "P"
> | Real32 => "R32"
> | Real64 => "R64"
> | Word8 => "W8"
> @@ -78,5 +112,17 @@
>
> fun align (t: t, b: Bytes.t): Bytes.t =
> Bytes.align (b, {alignment = size t})
> +
> +fun word (s: WordSize.t, {signed: bool}): t =
> + case (signed, Bits.toInt (WordSize.bits s)) of
> + (false, 8) => Word8
> + | (true, 8) => Int8
> + | (false, 16) => Word16
> + | (true, 16) => Int16
> + | (false, 32) => Word32
> + | (true, 32) => Int32
> + | (false, 64) => Word64
> + | (true, 64) => Int64
> + | _ => Error.bug "CType.word"
>
> end
>
>
>
> 1.7 +8 -2 mlton/mlton/atoms/c-type.sig
>
> Index: c-type.sig
> ===================================================================
> RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-type.sig,v
> retrieving revision 1.6
> retrieving revision 1.7
> diff -u -r1.6 -r1.7
> --- c-type.sig 28 Apr 2004 03:17:05 -0000 1.6
> +++ c-type.sig 7 Sep 2004 00:46:19 -0000 1.7
> @@ -7,6 +7,7 @@
>
> signature C_TYPE_STRUCTS =
> sig
> + structure WordSize: WORD_SIZE
> end
>
> signature C_TYPE =
> @@ -14,7 +15,11 @@
> include C_TYPE_STRUCTS
>
> datatype t =
> - Pointer
> + Int8
> + | Int16
> + | Int32
> + | Int64
> + | Pointer
> | Real32
> | Real64
> | Word8
> @@ -28,7 +33,7 @@
> val char: t
> val equals: t * t -> bool
> val memo: (t -> 'a) -> t -> 'a
> - (* name: R{32,64} W{8,16,32,64} *)
> + (* name: I{8,16,32,64} R{32,64} W{8,16,32,64} *)
> val name: t -> string
> val layout: t -> Layout.t
> val pointer: t
> @@ -36,4 +41,5 @@
> val size: t -> Bytes.t
> val thread: t
> val toString: t -> string
> + val word: WordSize.t * {signed: bool} -> t
> end
>
>
>
> 1.55 +1 -0 mlton/mlton/backend/limit-check.fun
>
> Index: limit-check.fun
> ===================================================================
> RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
> retrieving revision 1.54
> retrieving revision 1.55
> diff -u -r1.54 -r1.55
> --- limit-check.fun 20 Aug 2004 16:34:44 -0000 1.54
> +++ limit-check.fun 7 Sep 2004 00:46:19 -0000 1.55
> @@ -160,6 +160,7 @@
> maySwitchThreads = false,
> modifiesFrontier = false,
> name = "MLton_allocTooLarge",
> + prototype = (Vector.new0 (), NONE),
> readsStackTop = false,
> return = Type.unit,
> writesStackTop = false}
>
>
>
> 1.42 +8 -4 mlton/mlton/backend/profile.fun
>
> Index: profile.fun
> ===================================================================
> RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
> retrieving revision 1.41
> retrieving revision 1.42
> diff -u -r1.41 -r1.42
> --- profile.fun 20 Aug 2004 16:34:44 -0000 1.41
> +++ profile.fun 7 Sep 2004 00:46:19 -0000 1.42
> @@ -17,7 +17,7 @@
> end
>
> local
> - fun make {args, name} =
> + fun make {args, name, prototype} =
> T {args = args,
> bytesNeeded = NONE,
> convention = Convention.Cdecl,
> @@ -26,19 +26,23 @@
> maySwitchThreads = false,
> modifiesFrontier = false,
> name = name,
> + prototype = (prototype, NONE),
> readsStackTop = true,
> return = unit,
> writesStackTop = false}
> in
> val profileEnter =
> make {args = Vector.new1 gcState,
> - name = "GC_profileEnter"}
> + name = "GC_profileEnter",
> + prototype = Vector.new1 CType.Pointer}
> val profileInc =
> make {args = Vector.new2 (gcState, Word32),
> - name = "GC_profileInc"}
> + name = "GC_profileInc",
> + prototype = Vector.new2 (CType.Pointer, CType.Word32)}
> val profileLeave =
> make {args = Vector.new1 gcState,
> - name = "GC_profileLeave"}
> + name = "GC_profileLeave",
> + prototype = Vector.new1 CType.Pointer}
> end
> end
>
>
>
>
> 1.12 +7 -9 mlton/mlton/backend/rep-type.fun
>
> Index: rep-type.fun
> ===================================================================
> RCS file: /cvsroot/mlton/mlton/mlton/backend/rep-type.fun,v
> retrieving revision 1.11
> retrieving revision 1.12
> diff -u -r1.11 -r1.12
> --- rep-type.fun 31 Aug 2004 04:56:31 -0000 1.11
> +++ rep-type.fun 7 Sep 2004 00:46:19 -0000 1.12
> @@ -150,15 +150,6 @@
> end
> fun w i = word (Bits.fromInt i)
> in
> - val fromCType: CType.t -> t =
> - fn C.Pointer => w 32
> - | C.Real32 => real RealSize.R32
> - | C.Real64 => real RealSize.R64
> - | C.Word8 => w 8
> - | C.Word16 => w 16
> - | C.Word32 => w 32
> - | C.Word64 => w 64
> -
> val rec toCType: t -> CType.t =
> fn t =>
> if isPointer t
> @@ -480,6 +471,7 @@
>
> val bug = vanilla {args = Vector.new1 string,
> name = "MLton_bug",
> + prototype = (Vector.new1 CType.pointer, NONE),
> return = unit}
>
> local
> @@ -503,6 +495,12 @@
> maySwitchThreads = b,
> modifiesFrontier = true,
> name = "GC_gc",
> + prototype = let
> + open CType
> + in
> + (Vector.new5 (Pointer, Word32, bool, Pointer, Word32),
> + NONE)
> + end,
> readsStackTop = true,
> return = unit,
> writesStackTop = true}
>
>
>
> 1.10 +0 -1 mlton/mlton/backend/rep-type.sig
>
> Index: rep-type.sig
> ===================================================================
> RCS file: /cvsroot/mlton/mlton/mlton/backend/rep-type.sig,v
> retrieving revision 1.9
> retrieving revision 1.10
> diff -u -r1.9 -r1.10
> --- rep-type.sig 12 Aug 2004 23:06:03 -0000 1.9
> +++ rep-type.sig 7 Sep 2004 00:46:19 -0000 1.10
> @@ -69,7 +69,6 @@
> val defaultWord: t
> val equals: t * t -> bool
> val exnStack: t
> - val fromCType: CType.t -> t
> val gcState: t
> val intInf: t
> val isCPointer: t -> bool
>
>
>
> 1.97 +155 -26 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.96
> retrieving revision 1.97
> diff -u -r1.96 -r1.97
> --- ssa-to-rssa.fun 31 Aug 2004 04:56:36 -0000 1.96
> +++ ssa-to-rssa.fun 7 Sep 2004 00:46:19 -0000 1.97
> @@ -61,6 +61,11 @@
> maySwitchThreads = false,
> modifiesFrontier = true,
> name = "GC_copyCurrentThread",
> + prototype = let
> + open CType
> + in
> + (Vector.new1 Pointer, NONE)
> + end,
> readsStackTop = true,
> return = unit,
> writesStackTop = true}
> @@ -74,6 +79,11 @@
> maySwitchThreads = false,
> modifiesFrontier = true,
> name = "GC_copyThread",
> + prototype = let
> + open CType
> + in
> + (Vector.new2 (Pointer, Pointer), SOME Pointer)
> + end,
> readsStackTop = true,
> return = Type.thread,
> writesStackTop = true}
> @@ -87,6 +97,11 @@
> maySwitchThreads = false,
> modifiesFrontier = true,
> name = "MLton_exit",
> + prototype = let
> + open CType
> + in
> + (Vector.new1 Word32, NONE)
> + end,
> readsStackTop = true,
> return = unit,
> writesStackTop = true}
> @@ -100,6 +115,12 @@
> maySwitchThreads = false,
> modifiesFrontier = true,
> name = "GC_arrayAllocate",
> + prototype = let
> + open CType
> + in
> + (Vector.new4 (Pointer, Word32, Word32, Word32),
> + SOME Pointer)
> + end,
> readsStackTop = true,
> return = return,
> writesStackTop = true}
> @@ -114,6 +135,11 @@
> maySwitchThreads = false,
> modifiesFrontier = true,
> name = name,
> + prototype = let
> + open CType
> + in
> + (Vector.new1 Pointer, NONE)
> + end,
> readsStackTop = true,
> return = unit,
> writesStackTop = true}
> @@ -131,6 +157,11 @@
> maySwitchThreads = true,
> modifiesFrontier = true,
> name = "Thread_returnToC",
> + prototype = let
> + open CType
> + in
> + (Vector.new0 (), NONE)
> + end,
> readsStackTop = true,
> return = unit,
> writesStackTop = true}
> @@ -144,6 +175,11 @@
> maySwitchThreads = true,
> modifiesFrontier = true,
> name = "Thread_switchTo",
> + prototype = let
> + open CType
> + in
> + (Vector.new2 (Pointer, Word32), NONE)
> + end,
> readsStackTop = true,
> return = unit,
> writesStackTop = true}
> @@ -151,11 +187,21 @@
> fun weakCanGet t =
> vanilla {args = Vector.new1 t,
> name = "GC_weakCanGet",
> + prototype = let
> + open CType
> + in
> + (Vector.new1 Pointer, SOME bool)
> + end,
> return = Type.bool}
>
> fun weakGet {arg, return} =
> vanilla {args = Vector.new1 arg,
> name = "GC_weakGet",
> + prototype = let
> + open CType
> + in
> + (Vector.new1 Pointer, SOME Pointer)
> + end,
> return = return}
>
> fun weakNew {arg, return} =
> @@ -167,7 +213,12 @@
> maySwitchThreads = false,
> modifiesFrontier = true,
> name = "GC_weakNew",
> - readsStackTop = true,
> + prototype = let
> + open CType
> + in
> + (Vector.new3 (Pointer, Word32, Pointer), SOME Pointer)
> + end,
> + readsStackTop = true,
> return = return,
> writesStackTop = true}
>
> @@ -180,6 +231,11 @@
> maySwitchThreads = false,
> modifiesFrontier = true,
> name = "GC_saveWorld",
> + prototype = let
> + open CType
> + in
> + (Vector.new2 (Pointer, Word32), NONE)
> + end,
> readsStackTop = true,
> return = unit,
> writesStackTop = true}
> @@ -187,11 +243,21 @@
> fun share t =
> vanilla {args = Vector.new1 t,
> name = "MLton_share",
> + prototype = let
> + open CType
> + in
> + (Vector.new1 Pointer, NONE)
> + end,
> return = unit}
>
> fun size t =
> vanilla {args = Vector.new1 t,
> name = "MLton_size",
> + prototype = let
> + open CType
> + in
> + (Vector.new1 Pointer, SOME Word32)
> + end,
> return = Word32}
> end
>
> @@ -207,9 +273,13 @@
> val name = toString n
> val word = Type.word o WordSize.bits
> val vanilla = CFunction.vanilla
> - fun coerce (t1, t2) =
> + fun coerce (t1, t2, sg) =
> vanilla {args = Vector.new1 t1,
> name = name,
> + prototype = (Vector.new1
> + (CType.word
> + (WordSize.fromBits (Type.width t1), sg)),
> + SOME (Type.toCType t2)),
> return = t2}
> fun intInfBinary () =
> CFunction.T {args = Vector.new3 (Type.intInf, Type.intInf,
> @@ -221,6 +291,12 @@
> maySwitchThreads = false,
> modifiesFrontier = true,
> name = name,
> + prototype = let
> + open CType
> + in
> + (Vector.new3 (Pointer, Pointer, Word32),
> + SOME Pointer)
> + end,
> readsStackTop = false,
> return = Type.intInf,
> writesStackTop = false}
> @@ -235,6 +311,12 @@
> maySwitchThreads = false,
> modifiesFrontier = true,
> name = name,
> + prototype = let
> + open CType
> + in
> + (Vector.new3 (Pointer, Word32, Word32),
> + SOME Pointer)
> + end,
> readsStackTop = false,
> return = Type.intInf,
> writesStackTop = false}
> @@ -249,6 +331,12 @@
> maySwitchThreads = false,
> modifiesFrontier = true,
> name = name,
> + prototype = let
> + open CType
> + in
> + (Vector.new3 (Pointer, Word32, Word32),
> + SOME Pointer)
> + end,
> readsStackTop = false,
> return = Type.string,
> writesStackTop = false}
> @@ -261,28 +349,56 @@
> maySwitchThreads = false,
> modifiesFrontier = true,
> name = name,
> + prototype = let
> + open CType
> + in
> + (Vector.new2 (Pointer, Word32),
> + SOME Pointer)
> + end,
> readsStackTop = false,
> return = Type.intInf,
> writesStackTop = false}
> - fun wordBinary s =
> + fun wordBinary (s, sg) =
> let
> val t = word s
> in
> vanilla {args = Vector.new2 (t, t),
> name = name,
> + prototype = let
> + val t = CType.word (s, sg)
> + in
> + (Vector.new2 (t, t), SOME t)
> + end,
> return = t}
> end
> - fun wordCompare s =
> + fun wordCompare (s, sg) =
> vanilla {args = Vector.new2 (word s, word s),
> name = name,
> + prototype = let
> + val t = CType.word (s, sg)
> + in
> + (Vector.new2 (t, t), SOME CType.bool)
> + end,
> return = Type.bool}
> - fun wordShift s =
> + fun wordShift (s, sg) =
> vanilla {args = Vector.new2 (word s, Type.defaultWord),
> name = name,
> + prototype = let
> + open CType
> + in
> + (Vector.new2 (word (s, sg), Word32),
> + SOME bool)
> + end,
> return = word s}
> fun wordUnary s =
> vanilla {args = Vector.new1 (word s),
> name = name,
> + prototype = let
> + open CType
> + val t = word (s, {signed = false})
> + in
> + (Vector.new1 t, SOME t)
> + end,
> return = word s}
> in
> case n of
> @@ -292,10 +408,22 @@
> | IntInf_compare =>
> vanilla {args = Vector.new2 (Type.intInf, Type.intInf),
> name = name,
> + prototype = let
> + open CType
> + in
> + (Vector.new2 (Pointer, Pointer),
> + SOME Int32)
> + end,
> return = Type.defaultWord}
> | IntInf_equal =>
> vanilla {args = Vector.new2 (Type.intInf, Type.intInf),
> name = name,
> + prototype = let
> + open CType
> + in
> + (Vector.new2 (Pointer, Pointer),
> + SOME bool)
> + end,
> return = Type.bool}
> | IntInf_gcd => intInfBinary ()
> | IntInf_lshift => intInfShift ()
> @@ -310,30 +438,31 @@
> | IntInf_xorb => intInfBinary ()
> | MLton_bug => CFunction.bug
> | Thread_returnToC => CFunction.returnToC
> - | Word_add s => wordBinary s
> - | Word_andb s => wordBinary s
> - | Word_equal s => wordCompare s
> - | Word_ge (s, _) => wordCompare s
> - | Word_gt (s, _) => wordCompare s
> - | Word_le (s, _) => wordCompare s
> - | Word_lshift s => wordShift s
> - | Word_lt (s, _) => wordCompare s
> - | Word_mul (s, _) => wordBinary s
> + | Word_add s => wordBinary (s, {signed = false})
> + | Word_andb s => wordBinary (s, {signed = false})
> + | Word_equal s => wordCompare (s, {signed = false})
> + | Word_ge z => wordCompare z
> + | Word_gt z => wordCompare z
> + | Word_le z => wordCompare z
> + | Word_lshift s => wordShift (s, {signed = false})
> + | Word_lt z => wordCompare z
> + | Word_mul z => wordBinary z
> | Word_neg s => wordUnary s
> | Word_notb s => wordUnary s
> - | Word_orb s => wordBinary s
> - | Word_quot (s, _) => wordBinary s
> - | Word_rem (s, _) => wordBinary s
> - | Word_rol s => wordShift s
> - | Word_ror s => wordShift s
> - | Word_rshift (s, _) => wordShift s
> - | Word_sub s => wordBinary s
> - | Word_toReal (s1, s2, _) =>
> - coerce (Type.word (WordSize.bits s1), Type.real s2)
> - | Word_toWord (s1, s2, _) =>
> + | Word_orb s => wordBinary (s, {signed = false})
> + | Word_quot z => wordBinary z
> + | Word_rem z => wordBinary z
> + | Word_rol s => wordShift (s, {signed = false})
> + | Word_ror s => wordShift (s, {signed = false})
> + | Word_rshift z => wordShift z
> + | Word_sub s => wordBinary (s, {signed = false})
> + | Word_toReal (s1, s2, sg) =>
> + coerce (Type.word (WordSize.bits s1), Type.real s2, sg)
> + | Word_toWord (s1, s2, sg) =>
> coerce (Type.word (WordSize.bits s1),
> - Type.word (WordSize.bits s2))
> - | Word_xorb s => wordBinary s
> + Type.word (WordSize.bits s2),
> + sg)
> + | Word_xorb s => wordBinary (s, {signed = false})
> | _ => raise Fail "cFunctionRaise"
> end
>
>
>
>
> 1.92 +16 -14 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.91
> retrieving revision 1.92
> diff -u -r1.91 -r1.92
> --- c-codegen.fun 31 Aug 2004 04:56:38 -0000 1.91
> +++ c-codegen.fun 7 Sep 2004 00:46:19 -0000 1.92
> @@ -40,24 +40,26 @@
> struct
> open CFunction
>
> - fun prototype (T {args, convention, name, return, ...}) =
> + fun prototype (T {convention, name, prototype = (args, return), ...}) =
> let
> + val attributes =
> + if convention <> Convention.Cdecl
> + then concat [" __attribute__ ((",
> + Convention.toString convention,
> + ")) "]
> + else " "
> val c = Counter.new 0
> - fun arg t = concat [CType.toString (Type.toCType t),
> - " x", Int.toString (Counter.next c)]
> + fun arg t =
> + concat [CType.toString t, " x", Int.toString (Counter.next c)]
> + val return =
> + case return of
> + NONE => "void"
> + | SOME t => CType.toString t
> in
> concat
> - [if Type.isUnit return
> - then "void"
> - else CType.toString (Type.toCType return),
> - if convention <> Convention.Cdecl
> - then concat [" __attribute__ ((",
> - Convention.toString convention,
> - ")) "]
> - else " ",
> - name, " (",
> - concat (List.separate (Vector.toListMap (args, arg), ", ")),
> - ")"]
> + [return, attributes, name,
> + " (", concat (List.separate (Vector.toListMap (args, arg), ", ")),
> + ")"]
> end
> end
>
>
>
>
> 1.31 +24 -36 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun
>
> Index: x86-mlton-basic.fun
> ===================================================================
> RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun,v
> retrieving revision 1.30
> retrieving revision 1.31
> diff -u -r1.30 -r1.31
> --- x86-mlton-basic.fun 25 Aug 2004 17:51:08 -0000 1.30
> +++ x86-mlton-basic.fun 7 Sep 2004 00:46:19 -0000 1.31
> @@ -301,43 +301,31 @@
>
>
> local
> - fun make name size =
> - Label.fromString (concat ["local", name, size])
> - val r = make "Real"
> - val w = make "Word"
> - datatype z = datatype CType.t
> + fun make prefix =
> + let
> + fun make name size = Label.fromString (concat [prefix, name, size])
> + val r = make "Real"
> + val w = make "Word"
> + datatype z = datatype CType.t
> + in
> + CType.memo
> + (fn t =>
> + case t of
> + Int8 => w "8"
> + | Int16 => w "16"
> + | Int32 => w "32"
> + | Int64 => w "64"
> + | Pointer => Label.fromString (concat [prefix, "Pointer"])
> + | Real32 => r "32"
> + | Real64 => r "64"
> + | Word8 => w "8"
> + | Word16 => w "16"
> + | Word32 => w "32"
> + | Word64 => w "64")
> + end
> in
> - val local_base =
> - CType.memo
> - (fn t =>
> - case t of
> - Pointer => Label.fromString "localPointer"
> - | Real32 => r "32"
> - | Real64 => r "64"
> - | Word8 => w "8"
> - | Word16 => w "16"
> - | Word32 => w "32"
> - | Word64 => w "64")
> - end
> -
> - local
> - fun make name size =
> - Label.fromString (concat ["global", name, size])
> - val r = make "Real"
> - val w = make "Word"
> - datatype z = datatype CType.t
> - in
> - val global_base =
> - CType.memo
> - (fn t =>
> - case t of
> - Pointer => Label.fromString "globalPointer"
> - | Real32 => r "32"
> - | Real64 => r "64"
> - | Word8 => w "8"
> - | Word16 => w "16"
> - | Word32 => w "32"
> - | Word64 => w "64")
> + val local_base = make "local"
> + val global_base = make "global"
> end
>
> val globalPointerNonRoot_base = Label.fromString "globalPointerNonRoot"
>
>
>
> 1.56 +36 -19 mlton/mlton/codegen/x86-codegen/x86.fun
>
> Index: x86.fun
> ===================================================================
> RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.fun,v
> retrieving revision 1.55
> retrieving revision 1.56
> diff -u -r1.55 -r1.56
> --- x86.fun 25 Aug 2004 17:51:08 -0000 1.55
> +++ x86.fun 7 Sep 2004 00:46:19 -0000 1.56
> @@ -126,7 +126,11 @@
> in
> fun fromCType t =
> case t of
> - Pointer => Vector.new1 LONG
> + Int8 => Vector.new1 BYTE
> + | Int16 => Vector.new1 WORD
> + | Int32 => Vector.new1 LONG
> + | Int64 => Vector.new2 (LONG, LONG)
> + | Pointer => Vector.new1 LONG
> | Real32 => Vector.new1 SNGL
> | Real64 => Vector.new1 DBLE
> | Word8 => Vector.new1 BYTE
> @@ -667,7 +671,11 @@
> in
> fun fromCType t =
> case t of
> - Pointer => Four
> + Int8 => One
> + | Int16 => Two
> + | Int32 => Four
> + | Int64 => Eight
> + | Pointer => Four
> | Real32 => Four
> | Real64 => Eight
> | Word8 => One
> @@ -1394,23 +1402,32 @@
> if RepType.isUnit ty
> then []
> else
> - case RepType.toCType ty of
> - Pointer => [{src = register Register.eax,
> - dst = cReturnTempContent (0, LONG)}]
> - | Real32 => [{src = fltregister FltRegister.top,
> - dst = cReturnTempContent (0, SNGL)}]
> - | Real64 => [{src = fltregister FltRegister.top,
> - dst = cReturnTempContent (0, DBLE)}]
> - | Word8 => [{src = register Register.al,
> - dst = cReturnTempContent (0, BYTE)}]
> - | Word16 => [{src = register Register.ax,
> - dst = cReturnTempContent (0, WORD)}]
> - | Word32 => [{src = register Register.eax,
> - dst = cReturnTempContent (0, LONG)}]
> - | Word64 => [{src = register Register.eax,
> - dst = cReturnTempContent (0, LONG)},
> - {src = register Register.edx,
> - dst = cReturnTempContent (4, LONG)}]
> + let
> + fun w (r, s) =
> + [{src = register r, dst = cReturnTempContent (0, s)}]
> + val w8 = w (Register.al, BYTE)
> + val w16 = w (Register.ax, WORD)
> + val w32 = w (Register.eax, LONG)
> + val w64 =[{src = register Register.eax,
> + dst = cReturnTempContent (0, LONG)},
> + {src = register Register.edx,
> + dst = cReturnTempContent (4, LONG)}]
> + in
> + case RepType.toCType ty of
> + Int8 => w8
> + | Int16 => w16
> + | Int32 => w32
> + | Int64 => w64
> + | Pointer => w32
> + | Real32 => [{src = fltregister FltRegister.top,
> + dst = cReturnTempContent (0, SNGL)}]
> + | Real64 => [{src = fltregister FltRegister.top,
> + dst = cReturnTempContent (0, DBLE)}]
> + | Word8 => w8
> + | Word16 => w16
> + | Word32 => w32
> + | Word64 => w64
> + end
> end
> end
>
>
>
>
> 1.119 +16 -5 mlton/mlton/elaborate/elaborate-core.fun
>
> Index: elaborate-core.fun
> ===================================================================
> RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
> retrieving revision 1.118
> retrieving revision 1.119
> diff -u -r1.118 -r1.119
> --- elaborate-core.fun 25 Aug 2004 17:51:10 -0000 1.118
> +++ elaborate-core.fun 7 Sep 2004 00:46:20 -0000 1.119
> @@ -652,10 +652,9 @@
>
> val nullary: (string * CType.t * Tycon.t) list =
> let
> - fun sized (tycon: Bits.t -> Tycon.t) =
> + fun sized (tycon: Bits.t -> Tycon.t, ctypes) =
> List.map
> - ([CType.Word8, CType.Word16, CType.Word32, CType.Word64],
> - fn cty =>
> + (ctypes, fn cty =>
> let
> val c = tycon (Bytes.toBits (CType.size cty))
> val s = Tycon.toString c
> @@ -675,10 +674,20 @@
> ("Char", CType.char, Tycon.char),
> ("Pointer", CType.preThread, Tycon.preThread),
> ("Thread", CType.thread, Tycon.thread)]
> - @ sized (Tycon.int o IntSize.I)
> + @ sized (Tycon.int o IntSize.I,
> + let
> + open CType
> + in
> + [Int8, Int16, Int32, Int64]
> + end)
> @ [("Real32", CType.Real32, Tycon.real RealSize.R32),
> ("Real64", CType.Real64, Tycon.real RealSize.R64)]
> - @ sized (Tycon.word o WordSize.fromBits)
> + @ sized (Tycon.word o WordSize.fromBits,
> + let
> + open CType
> + in
> + [Word8, Word16, Word32, Word64]
> + end)
> end
>
> val nullary =
> @@ -812,6 +821,8 @@
> mayGC = true,
> maySwitchThreads = false,
> name = name,
> + prototype = (Vector.map (args, #ctype),
> + Option.map (result, #ctype)),
> readsStackTop = true,
> return = (case result of
> NONE => Type.unit
>
>
>
> 1.5 +1 -1 mlton/runtime/platform.h
>
> Index: platform.h
> ===================================================================
> RCS file: /cvsroot/mlton/mlton/runtime/platform.h,v
> retrieving revision 1.4
> retrieving revision 1.5
> diff -u -r1.4 -r1.5
> --- platform.h 4 Sep 2004 04:07:12 -0000 1.4
> +++ platform.h 7 Sep 2004 00:46:20 -0000 1.5
> @@ -306,7 +306,7 @@
>
> Word IntInf_smallMul (Word lhs, Word rhs, Pointer carry);
> Int IntInf_compare (Pointer lhs, Pointer rhs);
> -Int IntInf_equal (Pointer lhs, Pointer rhs);
> +Bool IntInf_equal (Pointer lhs, Pointer rhs);
>
> /* ------------------------------------------------- */
> /* Itimer */
>
>
>
> 1.18 +1 -1 mlton/runtime/basis/IntInf.c
>
> Index: IntInf.c
> ===================================================================
> RCS file: /cvsroot/mlton/mlton/runtime/basis/IntInf.c,v
> retrieving revision 1.17
> retrieving revision 1.18
> diff -u -r1.17 -r1.18
> --- IntInf.c 25 Aug 2004 17:51:16 -0000 1.17
> +++ IntInf.c 7 Sep 2004 00:46:20 -0000 1.18
> @@ -330,7 +330,7 @@
> /*
> * Check if two IntInf.int's are equal.
> */
> -Int IntInf_equal (pointer lhs, pointer rhs) {
> +Bool IntInf_equal (pointer lhs, pointer rhs) {
> if (lhs == rhs)
> return TRUE;
> if (eitherIsSmall (lhs, rhs))
>
>
>
> _______________________________________________
> MLton mailing list
> MLton@mlton.org
> http://www.mlton.org/mailman/listinfo/mlton
>