[MLton-commit] r6265
Matthew Fluet
fluet at mlton.org
Fri Dec 14 09:57:57 PST 2007
Better type-checking of representation types in big-endian targets
----------------------------------------------------------------------
U mlton/trunk/mlton/backend/rep-type.fun
U mlton/trunk/mlton/control/bits.sml
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/backend/rep-type.fun
===================================================================
--- mlton/trunk/mlton/backend/rep-type.fun 2007-12-14 17:48:44 UTC (rev 6264)
+++ mlton/trunk/mlton/backend/rep-type.fun 2007-12-14 17:57:57 UTC (rev 6265)
@@ -392,8 +392,15 @@
andalso Bits.isByteAligned b
end
| Normal {ty, ...} =>
- not (Type.isUnit ty)
- andalso Bits.isWord32Aligned (Type.width ty)
+ let
+ val b = Bits.+ (Type.width ty,
+ Type.width (Type.objptrHeader ()))
+ in
+ not (Type.isUnit ty)
+ andalso (case !Control.align of
+ Control.Align4 => Bits.isWord32Aligned b
+ | Control.Align8 => Bits.isWord64Aligned b)
+ end
| Stack => true
| Weak t => Type.isObjptr t
| WeakGone => true
@@ -629,41 +636,115 @@
Prim.toString prim])
end
-fun checkOffset {base, offset, result} =
+fun checkOffset {base, isVector, offset, result} =
+ Exn.withEscape (fn escape =>
let
fun getTys ty =
case node ty of
Seq tys => Vector.toList tys
| _ => [ty]
- fun loop (offset, tys) =
- case tys of
- [] => false
- | ty::tys =>
- if Bits.equals (offset, Bits.zero)
- then let
- fun loop (resTys, eltTys) =
- case (resTys, eltTys) of
- ([], _) => true
- | (_, []) => false
- | (resTy::resTys, eltTy::eltTys) =>
- (case (node resTy, resTys, node eltTy) of
- (Bits, [], Bits) =>
- Bits.<= (width resTy, width eltTy)
- | _ => (equals (resTy, eltTy))
- andalso (loop (resTys, eltTys)))
- in
- loop (getTys result, ty::tys)
- end
- else if Bits.>= (offset, width ty)
- then loop (Bits.- (offset, width ty), tys)
- else (case node ty of
- Bits => loop (Bits.zero, (bits (Bits.- (width ty, offset))) :: tys)
- | _ => false)
+
+ fun dropTys (tys, bits) =
+ let
+ fun loop (tys, bits) =
+ if Bits.equals (bits, Bits.zero)
+ then tys
+ else (case tys of
+ [] => escape false
+ | ty::tys =>
+ let
+ val b = width ty
+ in
+ if Bits.>= (bits, b)
+ then loop (tys, Bits.- (bits, b))
+ else (case node ty of
+ Bits => (Type.bits (Bits.- (b, bits))) :: tys
+ | _ => escape false)
+ end)
+ in
+ if Bits.< (bits, Bits.zero)
+ then escape false
+ else loop (tys, bits)
+ end
+ val dropTys =
+ Trace.trace2
+ ("RepType.checkOffset.dropTys",
+ List.layout Type.layout, Bits.layout,
+ List.layout Type.layout)
+ dropTys
+ fun takeTys (tys, bits) =
+ let
+ fun loop (tys, bits, acc) =
+ if Bits.equals (bits, Bits.zero)
+ then acc
+ else (case tys of
+ [] => escape false
+ | ty::tys =>
+ let
+ val b = width ty
+ in
+ if Bits.>= (bits, b)
+ then loop (tys, Bits.- (bits, b), ty :: acc)
+ else (case node ty of
+ Bits => (Type.bits bits) :: acc
+ | _ => escape false)
+ end)
+ in
+ if Bits.< (bits, Bits.zero)
+ then escape false
+ else List.rev (loop (tys, bits, []))
+ end
+ fun extractTys (tys, dropBits, takeBits) =
+ takeTys (dropTys (tys, dropBits), takeBits)
+
+ fun equalsTys (tys1, tys2) =
+ case (tys1, tys2) of
+ ([], []) => true
+ | (ty1::tys1, ty2::tys2) =>
+ equals (ty1, ty2)
+ andalso equalsTys (tys1, tys2)
+ | _ => false
+
+ val alignBits =
+ case !Control.align of
+ Control.Align4 => Bits.inWord32
+ | Control.Align8 => Bits.inWord64
+
+ val baseBits = width base
+ val baseTys = getTys base
+
+ val offsetBytes = offset
+ val offsetBits = Bytes.toBits offsetBytes
+
+ val resultBits = width result
+ val resultTys = getTys result
+
+ val adjOffsetBits =
+ if Control.Target.bigEndian ()
+ andalso Bits.< (resultBits, Bits.inWord32)
+ andalso Bits.> (baseBits, resultBits)
+ then let
+ val paddedComponentBits =
+ if isVector
+ then Bits.min (baseBits, Bits.inWord32)
+ else Bits.inWord32
+ val paddedComponentOffsetBits =
+ Bits.alignDown (offsetBits, {alignment = paddedComponentBits})
+ in
+ Bits.+ (paddedComponentOffsetBits,
+ Bits.- (paddedComponentBits,
+ Bits.- (Bits.+ (resultBits, offsetBits),
+ paddedComponentOffsetBits)))
+ end
+ else offsetBits
in
- if Control.Target.bigEndian ()
- then true
- else loop (Bytes.toBits offset, getTys base)
- end
+ List.exists
+ ([Bits.inWord8, Bits.inWord16, Bits.inWord32, Bits.inWord64], fn primBits =>
+ Bits.equals (resultBits, primBits)
+ andalso Bits.isAligned (offsetBits, {alignment = Bits.min (primBits, alignBits)}))
+ andalso
+ equalsTys (resultTys, extractTys (baseTys, adjOffsetBits, resultBits))
+ end)
fun offsetIsOk {base, offset, tyconTy, result} =
case node base of
@@ -680,6 +761,7 @@
andalso (case tyconTy (Vector.sub (opts, 0)) of
ObjectType.Normal {ty, ...} =>
checkOffset {base = ty,
+ isVector = false,
offset = offset,
result = result}
| _ => false)
@@ -717,6 +799,7 @@
NONE => scale = Scale.One
| SOME s => scale = s)
andalso (checkOffset {base = elt,
+ isVector = true,
offset = offset,
result = result})
| _ => false)
Modified: mlton/trunk/mlton/control/bits.sml
===================================================================
--- mlton/trunk/mlton/control/bits.sml 2007-12-14 17:48:44 UTC (rev 6264)
+++ mlton/trunk/mlton/control/bits.sml 2007-12-14 17:57:57 UTC (rev 6265)
@@ -25,6 +25,7 @@
val > : t * t -> bool
val >= : t * t -> bool
(* val align: t * {alignment: t} -> t *)
+ val alignDown: t * {alignment: t} -> t
(* val alignWord32: t -> t *)
(* val alignWord64: t -> t *)
val compare: t * t -> Relation.t
@@ -32,14 +33,20 @@
val fromInt: int -> t
val fromIntInf: IntInf.t -> t
val inByte: t
+ val inWord8: t
+ val inWord16: t
val inWord32: t
val inWord64: t
- (* val isAligned: t * {alignment: t} -> bool *)
+ val isAligned: t * {alignment: t} -> bool
val isByteAligned: t -> bool
+ (* val isWord8Aligned: t -> bool *)
+ (* val isWord16Aligned: t -> bool *)
val isWord32Aligned: t -> bool
- (* val isWord64Aligned: t -> bool *)
+ val isWord64Aligned: t -> bool
val isZero: t -> bool
val layout: t -> Layout.t
+ val max: t * t -> t
+ val min: t * t -> t
val one: t
val toBytes: t -> bytes
val toInt: t -> int
@@ -61,6 +68,9 @@
val > : t * t -> bool
val >= : t * t -> bool
val align: t * {alignment: t} -> t
+ (* val alignDown: t * {alignment: t} -> t *)
+ (* val alignWord8: t -> t *)
+ (* val alignWord16: t -> t *)
val alignWord32: t -> t
val alignWord64: t -> t
val compare: t * t -> Relation.t
@@ -68,6 +78,8 @@
val fromInt: int -> t
val fromIntInf: IntInf.t -> t
val fromWord: word -> t
+ (* val inWord8: t *)
+ (* val inWord16: t *)
val inWord32: t
val inWord64: t
(* val isAligned: t * {alignment: t} -> bool *)
@@ -76,6 +88,7 @@
val isZero: t -> bool
val layout: t -> Layout.t
val max: t * t -> t
+ val min: t * t -> t
val one: t
val toBits: t -> Bits.t
val toInt: t -> int
@@ -100,19 +113,28 @@
in
b - rem (b, a)
end
+ fun alignDown (b, {alignment = a}) =
+ let
+ in
+ b - rem (b, a)
+ end
structure Bits =
struct
open IntInf
val inByte: bits = 8
+ val inWord8: bits = 8
+ val inWord16: bits = 16
val inWord32: bits = 32
val inWord64: bits = 64
fun isAligned (b, {alignment = a}) = 0 = rem (b, a)
fun isByteAligned b = isAligned (b, {alignment = inByte})
+ (* fun isWord8Aligned b = isAligned (b, {alignment = inWord8}) *)
+ (* fun isWord16Aligned b = isAligned (b, {alignment = inWord16}) *)
fun isWord32Aligned b = isAligned (b, {alignment = inWord32})
- (* fun isWord64Aligned b = isAligned (b, {alignment = inWord64}) *)
+ fun isWord64Aligned b = isAligned (b, {alignment = inWord64})
fun toBytes b =
if isByteAligned b
@@ -121,7 +143,8 @@
val toWord = Word.fromIntInf
- (* val align = align *)
+ (* val align = align *)
+ val alignDown = alignDown
(* fun alignWord32 b = align (b, {alignment = inWord32}) *)
(* fun alignWord64 b = align (b, {alignment = inWord64}) *)
end
@@ -130,12 +153,16 @@
struct
open IntInf
+ (* val inWord8: bytes = 1 *)
+ (* val inWord16: bytes = 2 *)
val inWord32: bytes = 4
val inWord64: bytes = 8
val fromWord = Word.toIntInf
fun isAligned (b, {alignment = a}) = 0 = rem (b, a)
+ (* fun isWord8Aligned b = isAligned (b, {alignment = inWord8}) *)
+ (* fun isWord16Aligned b = isAligned (b, {alignment = inWord16}) *)
fun isWord32Aligned b = isAligned (b, {alignment = inWord32})
(* fun isWord64Aligned b = isAligned (b, {alignment = inWord64}) *)
@@ -144,7 +171,9 @@
val toWord = Word.fromIntInf
val align = align
-
+ (* val alignDown = alignDown *)
+ (* fun alignWord8 b = align (b, {alignment = inWord8}) *)
+ (* fun alignWord16 b = align (b, {alignment = inWord16}) *)
fun alignWord32 b = align (b, {alignment = inWord32})
fun alignWord64 b = align (b, {alignment = inWord64})
end
More information about the MLton-commit
mailing list