[MLton-commit] r4550
Matthew Fluet
MLton@mlton.org
Fri, 19 May 2006 15:04:23 -0700
Reworked the treatment of compile-time constants so that they are
elaborated into the program at the proper size.
This should fix the XML type errors on platforms with word constants
that are not 32-bits.
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/mlton/ast/char-size.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/ast/char-size.sig
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/ast/real-size.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/ast/real-size.sig
U mlton/branches/on-20050822-x86_64-branch/mlton/ast/word-size.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/ast/word-size.sig
U mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const-type.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const-type.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/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/elaborate/elaborate-core.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/type-env.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/main/compile.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/main/lookup-constant.fun
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/ast/char-size.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/ast/char-size.fun 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/char-size.fun 2006-05-19 22:04:19 UTC (rev 4550)
@@ -10,36 +10,36 @@
open S
-datatype t = C1 | C2 | C4
+datatype t = C8 | C16 | C32
-val all = [C1, C2, C4]
+val all = [C8, C16, C32]
fun bits s =
Bits.fromInt
(case s of
- C1 => 8
- | C2 => 16
- | C4 => 32)
+ C8 => 8
+ | C16 => 16
+ | C32 => 32)
val equals = op =
fun fromBits b =
case Bits.toInt b of
- 8 => C1
- | 16 => C2
- | 32 => C4
+ 8 => C8
+ | 16 => C16
+ | 32 => C32
| _ => Error.bug "CharSize.frombits"
val memoize =
fn f =>
let
- val c1 = f C1
- val c2 = f C2
- val c4 = f C4
+ val c8 = f C8
+ val c16 = f C16
+ val c32 = f C32
in
- fn C1 => c1
- | C2 => c2
- | C4 => c4
+ fn C8 => c8
+ | C16 => c16
+ | C32 => c32
end
val cardinality = memoize (fn s => IntInf.pow (2, Bits.toInt (bits s)))
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/ast/char-size.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/ast/char-size.sig 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/char-size.sig 2006-05-19 22:04:19 UTC (rev 4550)
@@ -13,7 +13,7 @@
sig
include CHAR_SIZE_STRUCTS
- datatype t = C1 | C2 | C4
+ datatype t = C8 | C16 | C32
val all: t list
val bits: t -> Bits.t
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 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.fun 2006-05-19 22:04:19 UTC (rev 4550)
@@ -50,35 +50,39 @@
memo
(fn s =>
case Vector.peek (all, fn (_, s') => equalsA (s, s')) of
- NONE => Error.bug "PrimTycons.make"
+ NONE => Error.bug "PrimTycons.make.fromSize"
| SOME (tycon, _) => tycon)
fun is t = Vector.exists (all, fn (t', _) => equals (t, t'))
+ fun de t =
+ case Vector.peek (all, fn (t', _) => equals (t, t')) of
+ NONE => Error.bug "PrimTycons.make.de"
+ | SOME (_, s') => s'
val prims =
Vector.toListMap (all, fn (tycon, _) =>
(tycon, Arity 0, admitsEquality))
in
- (fromSize, all, is, prims)
+ (fromSize, all, is, de, prims)
end
in
- val (char, _, isCharX, primChars) =
+ val (char, _, isCharX, deCharX, primChars) =
let
open CharSize
in
make ("char", all, bits, equals, memoize, Sometimes)
end
- val (int, ints, isIntX, primInts) =
+ val (int, ints, isIntX, deIntX, primInts) =
let
open IntSize
in
make ("int", all, bits, equals, memoize, Sometimes)
end
- val (real, reals, isRealX, primReals) =
+ val (real, reals, isRealX, deRealX, primReals) =
let
open RealSize
in
make ("real", all, bits, equals, memoize, Never)
end
- val (word, words, isWordX, primWords) =
+ val (word, words, isWordX, deWordX, primWords) =
let
open WordSize
in
@@ -88,7 +92,7 @@
val defaultChar = fn () =>
case !Control.defaultChar of
- "char8" => char CharSize.C1
+ "char8" => char CharSize.C8
| _ => Error.bug "PrimTycons.defaultChar"
val defaultInt = fn () =>
case !Control.defaultInt of
@@ -112,6 +116,7 @@
| _ => Error.bug "PrimTycons.defaultWord"
val isIntX = fn c => equals (c, intInf) orelse isIntX c
+val deIntX = fn c => if equals (c, intInf) then NONE else SOME (deIntX c)
val prims =
[(array, Arity 1, Always),
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 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/prim-tycons.sig 2006-05-19 22:04:19 UTC (rev 4550)
@@ -37,10 +37,14 @@
val arrow: tycon
val bool: tycon
val char: CharSize.t -> tycon
+ val deCharX: tycon -> CharSize.t
val defaultChar: unit -> tycon
val defaultInt: unit -> tycon
val defaultReal: unit -> tycon
val defaultWord: unit -> tycon
+ val deIntX: tycon -> IntSize.t option
+ val deRealX: tycon -> RealSize.t
+ val deWordX: tycon -> WordSize.t
val exn: tycon
val int: IntSize.t -> tycon
val ints: (tycon * IntSize.t) vector
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/ast/real-size.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/ast/real-size.fun 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/real-size.fun 2006-05-19 22:04:19 UTC (rev 4550)
@@ -14,8 +14,6 @@
val all = [R32, R64]
-val default = R64
-
val compare =
fn (R32, R32) => EQUAL
| (R32, _) => LESS
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/ast/real-size.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/ast/real-size.sig 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/real-size.sig 2006-05-19 22:04:19 UTC (rev 4550)
@@ -19,7 +19,6 @@
val bits: t -> Bits.t
val bytes: t -> Bytes.t
val compare: t * t -> Relation.t
- val default: t
val equals: t * t -> bool
val layout: t -> Layout.t
val memoize: (t -> 'a) -> t -> 'a
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/ast/word-size.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/ast/word-size.fun 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/word-size.fun 2006-05-19 22:04:19 UTC (rev 4550)
@@ -34,6 +34,8 @@
val byte = fromBits (Bits.fromInt 8)
+val bool = fromBits (Bits.fromInt 32)
+
val allVector = Vector.tabulate (65, fn i =>
if isValidSize i
then SOME (fromBits (Bits.fromInt i))
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/ast/word-size.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/ast/word-size.sig 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/ast/word-size.sig 2006-05-19 22:04:19 UTC (rev 4550)
@@ -20,6 +20,7 @@
val + : t * t -> t
val all: t list
val bits: t -> Bits.t
+ val bool: t
val bytes: t -> Bytes.t
val byte: t
val cardinality: t -> IntInf.t
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const-type.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const-type.fun 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const-type.fun 2006-05-19 22:04:19 UTC (rev 4550)
@@ -11,12 +11,12 @@
open S
-datatype t = Bool | Real | String | Word
+datatype t = Bool | Real of RealSize.t | String | Word of WordSize.t
val toString =
fn Bool => "Bool"
- | Real => "Real"
+ | Real rs => "Real" ^ (RealSize.toString rs)
| String => "String"
- | Word => "Word"
+ | Word ws => "Word" ^ (WordSize.toString ws)
end
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const-type.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const-type.sig 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const-type.sig 2006-05-19 22:04:19 UTC (rev 4550)
@@ -8,13 +8,15 @@
signature CONST_TYPE_STRUCTS =
sig
+ structure RealSize: REAL_SIZE
+ structure WordSize: WORD_SIZE
end
signature CONST_TYPE =
sig
include CONST_TYPE_STRUCTS
- datatype t = Bool | Real | String | Word
+ datatype t = Bool | Real of RealSize.t | String | Word of WordSize.t
val toString: t -> string
end
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const.fun 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const.fun 2006-05-19 22:04:19 UTC (rev 4550)
@@ -11,7 +11,10 @@
open S
-structure ConstType = ConstType ()
+structure ConstType = ConstType (struct
+ structure RealSize = RealX.RealSize
+ structure WordSize = WordX.WordSize
+ end)
structure SmallIntInf =
struct
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const.sig 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/atoms/const.sig 2006-05-19 22:04:19 UTC (rev 4550)
@@ -20,6 +20,8 @@
include CONST_STRUCTS
structure ConstType: CONST_TYPE
+ sharing ConstType.RealSize = RealX.RealSize
+ sharing ConstType.WordSize = WordX.WordSize
structure SmallIntInf:
sig
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 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/atoms/type-ops.fun 2006-05-19 22:04:19 UTC (rev 4550)
@@ -33,7 +33,6 @@
val word = WordSize.memoize (fn s => nullary (Tycon.word s))
end
-val defaultReal = real RealSize.default
val defaultWord = word WordSize.default
local
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 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/atoms/type-ops.sig 2006-05-19 22:04:19 UTC (rev 4550)
@@ -50,7 +50,6 @@
val deVector: t -> t
val deWeak: t -> t
val deWeakOpt: t -> t option
- val defaultReal: t
val defaultWord: t
val exn: t
val intInf: t
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/elaborate-core.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/elaborate-core.fun 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/elaborate-core.fun 2006-05-19 22:04:19 UTC (rev 4550)
@@ -2616,11 +2616,15 @@
if Tycon.equals (c, Tycon.bool)
then ConstType.Bool
else if Tycon.isIntX c
- then ConstType.Word
+ then case Tycon.deIntX c of
+ NONE => bug ()
+ | SOME is =>
+ ConstType.Word
+ (WordSize.fromBits (IntSize.bits is))
else if Tycon.isRealX c
- then ConstType.Real
+ then ConstType.Real (Tycon.deRealX c)
else if Tycon.isWordX c
- then ConstType.Word
+ then ConstType.Word (Tycon.deWordX c)
else if Tycon.equals (c, Tycon.vector)
andalso 1 = Vector.length ts
andalso
@@ -2628,7 +2632,8 @@
(Vector.sub (ts, 0))) of
NONE => false
| SOME (c, _) =>
- Tycon.isCharX c)
+ Tycon.isCharX c
+ andalso (Tycon.deCharX c = CharSize.C8))
then ConstType.String
else bug ()
val finish =
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/type-env.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/type-env.fun 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/elaborate/type-env.fun 2006-05-19 22:04:19 UTC (rev 4550)
@@ -771,7 +771,7 @@
open Ops Type
fun char s = con (Tycon.char s, Vector.new0 ())
- val string = con (Tycon.vector, Vector.new1 (char CharSize.C1))
+ val string = con (Tycon.vector, Vector.new1 (char CharSize.C8))
val unit = tuple (Vector.new0 ())
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/main/compile.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/main/compile.fun 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/main/compile.fun 2006-05-19 22:04:19 UTC (rev 4550)
@@ -445,7 +445,7 @@
let
fun get (name: string): Bytes.t =
case lookupConstant ({default = NONE, name = name},
- ConstType.Word) of
+ ConstType.Word WordSize.default) of
Const.Word w => Bytes.fromInt (WordX.toInt w)
| _ => Error.bug "Compile.elaborate: GC_state offset must be an int"
in
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/main/lookup-constant.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/main/lookup-constant.fun 2006-05-17 21:18:10 UTC (rev 4549)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/main/lookup-constant.fun 2006-05-19 22:04:19 UTC (rev 4550)
@@ -16,7 +16,6 @@
structure RealX = RealX
structure WordX = WordX
end
-structure RealSize = RealX.RealSize
structure WordSize = WordX.WordSize
val buildConstants: (string * (unit -> string)) list =
@@ -61,7 +60,7 @@
List.map (gcFields, fn s =>
{name = s,
value = concat ["offsetof (struct GC_state, ", s, ")"],
- ty = ConstType.Word})
+ ty = ConstType.Word WordSize.default})
fun build (constants, out) =
let
@@ -85,9 +84,15 @@
val (format, value) =
case ty of
Bool => ("%s", concat [value, "? \"true\" : \"false\""])
- | Real => ("%.20f", value)
+ | Real _ => ("%.20f", value)
| String => ("%s", value)
- | Word => ("%u", value)
+ | Word ws =>
+ (case WordSize.prim (WordSize.roundUpToPrim ws) of
+ WordSize.W8 => "%\"PRIu8\""
+ | WordSize.W16 => "%\"PRIu16\""
+ | WordSize.W32 => "%\"PRIu32\""
+ | WordSize.W64 => "%\"PRIu64\"",
+ value)
in
concat ["fprintf (stdout, \"", name, " = ", format, "\\n\", ",
value, ");"]
@@ -158,19 +163,16 @@
Bool =>
(case Bool.fromString value of
NONE => error "bool"
- | SOME b =>
- Const.Word (WordX.fromIntInf
- (if b then 1 else 0, WordSize.default)))
- | Real =>
- (case RealX.make (value, RealSize.default) of
+ | SOME b => Const.Word (WordX.fromIntInf (if b then 1 else 0, WordSize.bool)))
+ | Real rs =>
+ (case RealX.make (value, rs) of
NONE => error "real"
| SOME r => Const.Real r)
| String => Const.string value
- | Word =>
+ | Word ws =>
(case IntInf.fromString value of
- NONE => error "int"
- | SOME i =>
- Const.Word (WordX.fromIntInf (i, WordSize.default)))
+ NONE => error "word"
+ | SOME i => Const.Word (WordX.fromIntInf (i, ws)))
end
in
lookupConstant