[MLton] cvs commit: C types now distinguish between signed and unsigned words
Stephen Weeks
sweeks@mlton.org
Mon, 6 Sep 2004 17:46:22 -0700
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))