Menu
▾
▴
[MLton-commit] r7541
|
From: Matthew F. <fl...@ml...> - 2011-06-10 12:46:05
|
Check sizes of word constants in case expressions in SSA and SSA2 ILs.
----------------------------------------------------------------------
U mlton/trunk/mlton/ssa/analyze.fun
U mlton/trunk/mlton/ssa/analyze2.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/ssa/analyze.fun
===================================================================
--- mlton/trunk/mlton/ssa/analyze.fun 2011-06-10 19:45:59 UTC (rev 7540)
+++ mlton/trunk/mlton/ssa/analyze.fun 2011-06-10 19:46:02 UTC (rev 7541)
@@ -1,4 +1,5 @@
-(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2011 Matthew Fluet.
+ * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -126,23 +127,34 @@
end
| Case {test, cases, default, ...} =>
- let val test = value test
+ let
+ val test = value test
fun ensureNullary j =
if 0 = Vector.length (labelValues j)
then ()
else Error.bug (concat ["Analyze.loopTransfer: Case:",
Label.toString j,
" must be nullary"])
- fun doit (s, cs, filter: 'a * 'b -> unit) =
- (filter (test, s)
- ; Vector.foreach (cs, fn (_, j) => ensureNullary j))
+ fun ensureSize (w, s) =
+ if WordSize.equals (s, WordX.size w)
+ then ()
+ else Error.bug (concat ["Analyze.loopTransfer: Case:",
+ WordX.toString w,
+ " must be size ",
+ WordSize.toString s])
+ fun doitWord (s, cs) =
+ (ignore (filterWord (test, s))
+ ; Vector.foreach (cs, fn (w, j) =>
+ (ensureSize (w, s)
+ ; ensureNullary j)))
+ fun doitCon cs =
+ Vector.foreach (cs, fn (c, j) =>
+ filter (test, c, labelValues j))
datatype z = datatype Cases.t
val _ =
case cases of
- Con cases =>
- Vector.foreach (cases, fn (c, j) =>
- filter (test, c, labelValues j))
- | Word (s, cs) => doit (s, cs, filterWord)
+ Con cs => doitCon cs
+ | Word (s, cs) => doitWord (s, cs)
val _ = Option.app (default, ensureNullary)
in ()
end
Modified: mlton/trunk/mlton/ssa/analyze2.fun
===================================================================
--- mlton/trunk/mlton/ssa/analyze2.fun 2011-06-10 19:45:59 UTC (rev 7540)
+++ mlton/trunk/mlton/ssa/analyze2.fun 2011-06-10 19:46:02 UTC (rev 7541)
@@ -1,4 +1,5 @@
-(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2011 Matthew Fluet.
+ * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -123,35 +124,46 @@
end
| Case {test, cases, default, ...} =>
- let val test = value test
+ let
+ val test = value test
+ fun ensureSize (w, s) =
+ if WordSize.equals (s, WordX.size w)
+ then ()
+ else Error.bug (concat ["Analyze.loopTransfer: Case:",
+ WordX.toString w,
+ " must be size ",
+ WordSize.toString s])
fun ensureNullary j =
if 0 = Vector.length (labelValues j)
then ()
else Error.bug (concat ["Analyze2.loopTransfer: Case:",
Label.toString j,
" must be nullary"])
- fun doit (s, cs, filter: 'a * 'b -> unit) =
- (filter (test, s)
- ; Vector.foreach (cs, fn (_, j) => ensureNullary j))
+ fun doitWord (s, cs) =
+ (ignore (filterWord (test, s))
+ ; Vector.foreach (cs, fn (w, j) =>
+ (ensureSize (w, s)
+ ; ensureNullary j)))
+ fun doitCon cs =
+ Vector.foreach
+ (cs, fn (c, j) =>
+ let
+ val v = labelValues j
+ val variant =
+ case Vector.length v of
+ 0 => NONE
+ | 1 => SOME (Vector.sub (v, 0))
+ | _ => Error.bug "Analyze2.loopTransfer: Case:conApp with >1 arg"
+ in
+ filter {con = c,
+ test = test,
+ variant = variant}
+ end)
datatype z = datatype Cases.t
val _ =
case cases of
- Con cases =>
- Vector.foreach
- (cases, fn (c, j) =>
- let
- val v = labelValues j
- val variant =
- case Vector.length v of
- 0 => NONE
- | 1 => SOME (Vector.sub (v, 0))
- | _ => Error.bug "Analyze2.loopTransfer: Case:conApp with >1 arg"
- in
- filter {con = c,
- test = test,
- variant = variant}
- end)
- | Word (s, cs) => doit (s, cs, filterWord)
+ Con cs => doitCon cs
+ | Word (s, cs) => doitWord (s, cs)
val _ = Option.app (default, ensureNullary)
in ()
end
|
