Menu
▾
▴
[MLton-commit] r7542
|
From: Matthew F. <fl...@ml...> - 2011-06-10 12:46:08
|
Fixed bug in SSA/SSA2 type checking of case expressions over words.
Allow an SSA/SSA2 case expression over words to be exhaustive without
a default.
----------------------------------------------------------------------
U mlton/trunk/doc/changelog
U mlton/trunk/mlton/ssa/type-check.fun
U mlton/trunk/mlton/ssa/type-check2.fun
----------------------------------------------------------------------
Modified: mlton/trunk/doc/changelog
===================================================================
--- mlton/trunk/doc/changelog 2011-06-10 19:46:02 UTC (rev 7541)
+++ mlton/trunk/doc/changelog 2011-06-10 19:46:06 UTC (rev 7542)
@@ -1,5 +1,9 @@
Here are the changes from version 2010608 to version YYYYMMDD.
+* 2011-06-10
+ - Fixed bug in SSA/SSA2 type checking of case expressions over
+ words.
+
* 2011-06-04
- Remove bytecode codegen.
- Remove support for .cm files as input.
Modified: mlton/trunk/mlton/ssa/type-check.fun
===================================================================
--- mlton/trunk/mlton/ssa/type-check.fun 2011-06-10 19:46:02 UTC (rev 7541)
+++ mlton/trunk/mlton/ssa/type-check.fun 2011-06-10 19:46:06 UTC (rev 7542)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2009 Matthew Fluet.
+(* Copyright (C) 2009,2011 Matthew Fluet.
* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
@@ -108,27 +108,29 @@
| Call {func, args, ...} => (getFunc func; getVars args)
| Case {test, cases, default, ...} =>
let
- fun doit (cases: ('a * 'b) vector,
- equals: 'a * 'a -> bool,
- toWord: 'a -> word): unit =
+ fun doitWord (ws, cases) =
let
- val table = HashSet.new {hash = toWord}
+ val table = HashSet.new {hash = WordX.hash}
val _ =
Vector.foreach
(cases, fn (x, _) =>
let
- val _ =
+ val _ =
HashSet.insertIfNew
- (table, toWord x, fn y => equals (x, y),
- fn () => x,
+ (table, WordX.hash x, fn y => WordX.equals (x, y),
+ fn () => x,
fn _ => Error.bug "Ssa.TypeCheck.loopTransfer: redundant branch in case")
in
()
end)
+ val numCases = Int.toIntInf (Vector.length cases)
in
- if isSome default
- then ()
- else Error.bug "Ssa.TypeCheck.loopTransfer: case has no default"
+ case (IntInf.equals (numCases, WordSize.cardinality ws), isSome default) of
+ (true, true) =>
+ Error.bug "Ssa.TypeCheck.loopTransfer: exhaustive case has default"
+ | (false, false) =>
+ Error.bug "Ssa.TypeCheck.loopTransfer: non-exhaustive case has no default"
+ | _ => ()
end
fun doitCon cases =
let
@@ -159,8 +161,7 @@
val _ =
case cases of
Cases.Con cs => doitCon cs
- | Cases.Word (_, cs) =>
- doit (cs, WordX.equals, Word.fromIntInf o WordX.toIntInf)
+ | Cases.Word (ws, cs) => doitWord (ws, cs)
in
()
end
Modified: mlton/trunk/mlton/ssa/type-check2.fun
===================================================================
--- mlton/trunk/mlton/ssa/type-check2.fun 2011-06-10 19:46:02 UTC (rev 7541)
+++ mlton/trunk/mlton/ssa/type-check2.fun 2011-06-10 19:46:06 UTC (rev 7542)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2009 Matthew Fluet.
+(* Copyright (C) 2009,2011 Matthew Fluet.
* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
@@ -132,27 +132,29 @@
| Call {func, args, ...} => (getFunc func; getVars args)
| Case {test, cases, default, ...} =>
let
- fun doit (cases: ('a * 'b) vector,
- equals: 'a * 'a -> bool,
- toWord: 'a -> word): unit =
+ fun doitWord (ws, cases) =
let
- val table = HashSet.new {hash = toWord}
+ val table = HashSet.new {hash = WordX.hash}
val _ =
Vector.foreach
(cases, fn (x, _) =>
let
- val _ =
+ val _ =
HashSet.insertIfNew
- (table, toWord x, fn y => equals (x, y),
- fn () => x,
- fn _ => Error.bug "Ssa2.TypeCheck2.loopTransfer: redundant branch in case")
+ (table, WordX.hash x, fn y => WordX.equals (x, y),
+ fn () => x,
+ fn _ => Error.bug "Ssa2.TypeCheck.loopTransfer: redundant branch in case")
in
()
end)
+ val numCases = Int.toIntInf (Vector.length cases)
in
- if isSome default
- then ()
- else Error.bug "Ssa2.TypeCheck2.loopTransfer: case has no default"
+ case (IntInf.equals (numCases, WordSize.cardinality ws), isSome default) of
+ (true, true) =>
+ Error.bug "Ssa2.TypeCheck.loopTransfer: exhaustive case has default"
+ | (false, false) =>
+ Error.bug "Ssa2.TypeCheck.loopTransfer: non-exhaustive case has no default"
+ | _ => ()
end
fun doitCon cases =
let
@@ -186,8 +188,7 @@
val _ =
case cases of
Cases.Con cs => doitCon cs
- | Cases.Word (_, cs) =>
- doit (cs, WordX.equals, Word.fromIntInf o WordX.toIntInf)
+ | Cases.Word (ws, cs) => doitWord (ws, cs)
in
()
end
|
