--- a/doc/changelog
+++ b/doc/changelog
@@ -1,5 +1,20 @@
Here are the changes from version 2010608 to version YYYYMMDD.
+* 2011-06-14
+ - Fixed bug in SSA/SSA2 shrinker that could erroneously turn a
+ non-tail function call with a Bug transfer as its continuation
+ into a tail function call.
+
+* 2011-06-10
+ - Fixed bug in translation from SSA2 to RSSA with case expressions
+ over non-primitive-sized words.
+ - Fixed bug in SSA/SSA2 type checking of case expressions over
+ words.
+
+* 2011-05-03
+ - Fixed a bug with the treatment of as-patterns, which should not
+ allow the redefinition of constructor status.
+
* 2011-02-18
- Fixed bug with treatment of nan in common subexpression
elimination SSA optimization.
--- a/doc/examples/finalizable/finalizable.sml
+++ b/doc/examples/finalizable/finalizable.sml
@@ -8,15 +8,16 @@
end
functor CList (structure F: MLTON_FINALIZABLE
+ structure P: MLTON_POINTER
structure Prim:
sig
- val cons: int * Word32.word -> Word32.word
- val free: Word32.word -> unit
- val sing: int -> Word32.word
- val sum: Word32.word -> int
+ val cons: int * P.t -> P.t
+ val free: P.t -> unit
+ val sing: int -> P.t
+ val sum: P.t -> int
end): CLIST =
struct
- type t = Word32.word F.t
+ type t = P.t F.t
fun cons (n: int, l: t) =
F.withValue
@@ -77,12 +78,13 @@
structure CList =
CList (structure F = MLton.Finalizable
+ structure P = MLton.Pointer
structure Prim =
struct
- val cons = _import "listCons": int * Word32.word -> Word32.word;
- val free = _import "listFree": Word32.word -> unit;
- val sing = _import "listSing": int -> Word32.word;
- val sum = _import "listSum": Word32.word -> int;
+ val cons = _import "listCons": int * P.t -> P.t;
+ val free = _import "listFree": P.t -> unit;
+ val sing = _import "listSing": int -> P.t;
+ val sum = _import "listSum": P.t -> int;
end)
structure S = Test (structure CList = CList
--- a/ide/enscript/sml_all.st
+++ b/ide/enscript/sml_all.st
@@ -88,6 +88,11 @@
*/
state sml_string
{
+ /\\\\(\s|\n)/ {
+ language_print ($0);
+ call (sml_string_gap);
+ }
+
/\\\\./ {
language_print ($0);
}
@@ -96,6 +101,22 @@
language_print ($0);
return;
}
+
+ LANGUAGE_SPECIALS {
+ language_print ($0);
+ }
+}
+
+state sml_string_gap
+{
+ /(\s|\n)/ {
+ language_print ($0);
+ }
+
+ /\\\\/ {
+ language_print ($0);
+ return;
+ }
LANGUAGE_SPECIALS {
language_print ($0);
--- a/ide/enscript/sml_simple.st
+++ b/ide/enscript/sml_simple.st
@@ -77,6 +77,11 @@
*/
state sml_string extends Highlight
{
+ /\\\\(\s|\n)/ {
+ language_print ($0);
+ call (sml_string_gap);
+ }
+
/\\\\./ {
language_print ($0);
}
@@ -85,6 +90,18 @@
language_print ($0);
return;
}
+}
+
+state sml_string_gap extends Highlight
+{
+ /(\s|\n)/ {
+ language_print ($0);
+ }
+
+ /\\\\/ {
+ language_print ($0);
+ return;
+ }
}
/*
--- a/mllex/lexgen.sml
+++ b/mllex/lexgen.sml
@@ -1,3 +1,6 @@
+(* Modified by Matthew Fluet on 2011-06-17.
+ * Use simple file name (rather than absolute paths) in line directives in output.
+ *)
(* Modified by Vesa Karvonen on 2007-12-19.
* Create line directives in output.
*)
@@ -295,7 +298,7 @@
val OutFile = ref ""
fun fmtLineDir {line, col} file =
String.concat ["(*#line ", Int.toString line, ".", Int.toString (col+1),
- " \"", OS.FileSys.fullPath file, "\"*)"]
+ " \"", file, "\"*)"]
val sayPos =
fn SOME pos => say (fmtLineDir pos (!InFile))
| NONE => (say (fmtLineDir {line = !LexOutLine, col = 0} (!OutFile));
@@ -1284,7 +1287,7 @@
fun lexGen(infile) =
let val outfile = infile ^ ".sml"
- val () = (InFile := infile; OutFile := outfile)
+ val () = (InFile := OS.Path.file infile; OutFile := OS.Path.file outfile)
fun PrintLexer (ends) =
let val sayln = fn x => (say x; say "\n")
in case !ArgCode
--- a/mlton/backend/ssa-to-rssa.fun
+++ b/mlton/backend/ssa-to-rssa.fun
@@ -599,12 +599,18 @@
src = Operand.word (WordX.one cardElemSize)}]
end
+fun convertWordSize (ws: WordSize.t): WordSize.t =
+ WordSize.roundUpToPrim ws
+
+fun convertWordX (w: WordX.t): WordX.t =
+ WordX.resize (w, convertWordSize (WordX.size w))
+
fun convertConst (c: Const.t): Const.t =
let
datatype z = datatype Const.t
in
case c of
- Word w => Word (WordX.resize (w, WordSize.roundUpToPrim (WordX.size w)))
+ Word w => Word (convertWordX w)
| _ => c
end
@@ -688,16 +694,21 @@
(ss, t)
end
| _ => Error.bug "SsaToRssa.translateCase: strange type"))
- | S.Cases.Word (s, cs) =>
- ([],
- Switch
- (Switch.T
- {cases = (QuickSort.sortVector
- (cs, fn ((w, _), (w', _)) =>
- WordX.le (w, w', {signed = false}))),
- default = default,
- size = s,
- test = varOp test}))
+ | S.Cases.Word (s, cases) =>
+ let
+ val cases =
+ QuickSort.sortVector
+ (Vector.map (cases, fn (w, l) => (convertWordX w, l)),
+ fn ((w, _), (w', _)) => WordX.le (w, w', {signed = false}))
+ in
+ ([],
+ Switch
+ (Switch.T
+ {cases = cases,
+ default = default,
+ size = convertWordSize s,
+ test = varOp test}))
+ end
fun eta (l: Label.t, kind: Kind.t): Label.t =
let
val {args, ...} = labelInfo l
--- a/mlton/control/source.sml
+++ b/mlton/control/source.sml
@@ -1,4 +1,5 @@
-(* Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2011 Matthew Fluet.
+ * Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -11,7 +12,8 @@
datatype t = T of {file: File.t ref,
lineNum: int ref,
- lineStart: int ref}
+ lineStart: int ref,
+ origDir: Dir.t}
fun getPos (T {file, lineNum, lineStart, ...}, n) =
SourcePos.make {column = n - !lineStart,
@@ -20,10 +22,18 @@
fun lineStart (s as T {lineStart, ...}) = getPos (s, !lineStart)
-fun lineDirective (T {file, lineNum, lineStart},
+fun lineDirective (T {file, lineNum, lineStart, origDir},
f,
{lineNum = n, lineStart = s}) =
- (Option.app (f, fn f => file := f)
+ (Option.app (f, fn f =>
+ let
+ val f =
+ if OS.Path.isAbsolute f
+ then f
+ else OS.Path.mkCanonical (OS.Path.concat (origDir, f))
+ in
+ file := f
+ end)
; lineNum := n
; lineStart := s)
@@ -34,7 +44,8 @@
* starts at position ~1, which will translate position 0 to
* column 1.
*)
- lineStart = ref ~1}
+ lineStart = ref ~1,
+ origDir = File.dirOf file}
fun newline (T {lineStart, lineNum, ...}, n) =
(Int.inc lineNum
--- a/mlton/core-ml/dead-code.fun
+++ b/mlton/core-ml/dead-code.fun
@@ -1,4 +1,5 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2011 Matthew Fluet.
+ * Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -24,7 +25,7 @@
then escape true
else ())
; false))
- fun decIsWild (d: Dec.t): bool =
+ fun decIsWildOrUnit (d: Dec.t): bool =
case d of
Val {rvbs, vbs, ...} =>
0 = Vector.length rvbs
@@ -43,7 +44,6 @@
| Val {rvbs, vbs, ...} =>
Vector.exists (rvbs, varIsUsed o #var)
orelse Vector.exists (vbs, patVarIsUsed o #pat)
- orelse decIsWild d
fun useVar x = setVarIsUsed (x, true)
fun useExp (e: Exp.t): unit = Exp.foreachVar (e, useVar)
fun useLambda (l: Lambda.t): unit =
@@ -66,7 +66,7 @@
in
if deadCode
then List.fold (rev decs, [], fn (dec, decs) =>
- if decIsWild dec orelse decIsNeeded dec
+ if decIsWildOrUnit dec orelse decIsNeeded dec
then (useDec dec; dec :: decs)
else decs)
else (List.foreach (decs, useDec)
--- a/mlton/elaborate/elaborate-core.fun
+++ b/mlton/elaborate/elaborate-core.fun
@@ -1,4 +1,4 @@
-(* Copyright (C) 2009-2010 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.
@@ -556,7 +556,21 @@
case constraint of
NONE => Type.new ()
| SOME t => elaborateType (t, Lookup.fromEnv E)
- val x = bindToType (x, t)
+ val xc = Avid.toCon (Avid.fromVar x)
+ val x =
+ case Env.peekLongcon (E, Ast.Longcon.short xc) of
+ NONE => bindToType (x, t)
+ | SOME _ =>
+ let
+ val _ =
+ Control.error
+ (region,
+ seq [str "constructor can not be redefined by as: ",
+ Avar.layout x],
+ seq [str "in: ", lay ()])
+ in
+ Var.fromAst x
+ end
val pat' = loop pat
val _ =
unifyPatternConstraint (Cpat.ty pat',
--- a/mlton/main/main.fun
+++ b/mlton/main/main.fun
@@ -188,8 +188,10 @@
case !Control.Target.arch of
Alpha => true
| AMD64 => true
+ | ARM => true
| HPPA => true
| IA64 => true
+ | MIPS => true
| Sparc => true
| S390 => true
| _ => false
--- a/mlton/ssa/analyze.fun
+++ b/mlton/ssa/analyze.fun
@@ -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
--- a/mlton/ssa/analyze2.fun
+++ b/mlton/ssa/analyze2.fun
@@ -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
--- a/mlton/ssa/shrink.fun
+++ b/mlton/ssa/shrink.fun
@@ -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.
@@ -460,7 +460,17 @@
Goto {canMove = canMove',
dst = m,
args = ps}
- | Bug => Bug
+ | Bug =>
+ if (case returns of
+ NONE => true
+ | SOME ts =>
+ Vector.equals
+ (ts, args, fn (t, (_, t')) =>
+ Type.equals (t, t')))
+ then Bug
+ else Goto {canMove = canMove',
+ dst = m,
+ args = ps}
| Case _ =>
Goto {canMove = canMove',
dst = m,
@@ -707,7 +717,7 @@
Transfer.layout))
val traceSimplifyCase =
Trace.trace
- ("Ssa2.Shrink2.simplifyCase",
+ ("Ssa.Shrink2.simplifyCase",
fn {canMove, cases, default, test, ...} =>
Layout.record [("canMove", List.layout Statement.layout canMove),
("cantSimplify", Layout.str "fn () => ..."),
--- a/mlton/ssa/shrink2.fun
+++ b/mlton/ssa/shrink2.fun
@@ -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.
@@ -465,8 +465,18 @@
Goto {canMove = canMove',
dst = m,
args = ps}
- | Bug => Bug
- | Case _ =>
+ | Bug =>
+ if (case returns of
+ NONE => true
+ | SOME ts =>
+ Vector.equals
+ (ts, args, fn (t, (_, t')) =>
+ Type.equals (t, t')))
+ then Bug
+ else Goto {canMove = canMove',
+ dst = m,
+ args = ps}
+ | Case _ =>
Goto {canMove = canMove',
dst = m,
args = ps}
--- a/mlton/ssa/type-check.fun
+++ b/mlton/ssa/type-check.fun
@@ -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.
@@ -48,7 +48,7 @@
end
val (bindTycon, getTycon, getTycon', _) = make' (Tycon.layout, Tycon.plist)
- val (bindCon, getCon, getCon', _) = make' (Con.layout, Con.plist)
+ val (bindCon, getCon, _) = make (Con.layout, Con.plist)
val (bindVar, getVar, getVar', unbindVar) = make' (Var.layout, Var.plist)
fun getVars xs = Vector.foreach (xs, getVar)
val (bindLabel, getLabel, unbindLabel) = make (Label.layout, Label.plist)
@@ -110,57 +110,47 @@
let
fun doit (cases: ('a * 'b) vector,
equals: 'a * 'a -> bool,
- toWord: 'a -> word): unit =
+ hash: 'a -> word,
+ numExhaustiveCases: IntInf.t) =
let
- val table = HashSet.new {hash = toWord}
+ val table = HashSet.new {hash = hash}
val _ =
Vector.foreach
(cases, fn (x, _) =>
let
- val _ =
+ val _ =
HashSet.insertIfNew
- (table, toWord x, fn y => equals (x, y),
- fn () => x,
+ (table, hash x, fn y => 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, numExhaustiveCases), 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 doitWord (ws, cases) =
+ doit (cases, WordX.equals, WordX.hash, WordSize.cardinality ws)
fun doitCon cases =
let
- val numCons =
+ val numExhaustiveCases =
case Type.dest (getVar' test) of
- Type.Datatype t => getTycon' t
+ Type.Datatype t => Int.toIntInf (getTycon' t)
| _ => Error.bug "Ssa.TypeCheck.loopTransfer: case test is not a datatype"
- val cons = Array.array (numCons, false)
- val _ =
- Vector.foreach
- (cases, fn (con, _) =>
- let
- val i = getCon' con
- in
- if Array.sub (cons, i)
- then Error.bug "Ssa.TypeCheck.loopTransfer: redundant branch in case"
- else Array.update (cons, i, true)
- end)
in
- case (Array.forall (cons, fn b => b), 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"
- | _ => ()
+ doit (cases, Con.equals, Con.hash, numExhaustiveCases)
end
val _ = getVar test
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
@@ -211,11 +201,11 @@
val _ = Vector.foreach
(datatypes, fn Datatype.T {tycon, cons} =>
(bindTycon (tycon, Vector.length cons)
- ; Vector.foreachi (cons, fn (i, {con, ...}) =>
- bindCon (con, i))))
+ ; Vector.foreach (cons, fn {con, ...} =>
+ bindCon con)))
val _ = Vector.foreach
(datatypes, fn Datatype.T {cons, ...} =>
- Vector.foreach (cons, fn {args, ...} =>
+ Vector.foreach (cons, fn {args, ...} =>
Vector.foreach (args, loopType)))
val _ = Vector.foreach (globals, loopStatement)
val _ = List.foreach (functions, bindFunc o Function.name)
--- a/mlton/ssa/type-check2.fun
+++ b/mlton/ssa/type-check2.fun
@@ -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.
@@ -49,7 +49,7 @@
end
val (bindTycon, getTycon, getTycon', _) = make' (Tycon.layout, Tycon.plist)
- val (bindCon, getCon, getCon', _) = make' (Con.layout, Con.plist)
+ val (bindCon, getCon, _) = make (Con.layout, Con.plist)
val (bindVar, getVar, getVar', unbindVar) = make' (Var.layout, Var.plist)
fun getVars xs = Vector.foreach (xs, getVar)
val (bindFunc, getFunc, _) = make (Func.layout, Func.plist)
@@ -134,60 +134,47 @@
let
fun doit (cases: ('a * 'b) vector,
equals: 'a * 'a -> bool,
- toWord: 'a -> word): unit =
+ hash: 'a -> word,
+ numExhaustiveCases: IntInf.t) =
let
- val table = HashSet.new {hash = toWord}
+ val table = HashSet.new {hash = 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, hash x, fn y => 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 "Ssa2.TypeCheck2.loopTransfer: case has no default"
+ case (IntInf.equals (numCases, numExhaustiveCases), 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 doitWord (ws, cases) =
+ doit (cases, WordX.equals, WordX.hash, WordSize.cardinality ws)
fun doitCon cases =
let
- val numCons =
+ val numExhaustiveCases =
case Type.dest (getVar' test) of
- Type.Datatype t => getTycon' t
- | _ => Error.bug (concat
- ["Ssa2.TypeCheck2.loopTransfer: case test ",
- Var.toString test,
- " is not a datatype"])
- val cons = Array.array (numCons, false)
- val _ =
- Vector.foreach
- (cases, fn (con, _) =>
- let
- val i = getCon' con
- in
- if Array.sub (cons, i)
- then Error.bug "Ssa2.TypeCheck2.loopTransfer: redundant branch in case"
- else Array.update (cons, i, true)
- end)
+ Type.Datatype t => Int.toIntInf (getTycon' t)
+ | _ => Error.bug "Ssa.TypeCheck.loopTransfer: case test is not a datatype"
in
- case (Array.forall (cons, fn b => b), isSome default) of
- (true, true) =>
- Error.bug "Ssa2.TypeCheck2.loopTransfer: exhaustive case has default"
- | (false, false) =>
- Error.bug "Ssa2.TypeCheck2.loopTransfer: non-exhaustive case has no default"
- | _ => ()
+ doit (cases, Con.equals, Con.hash, numExhaustiveCases)
end
val _ = getVar test
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
@@ -238,11 +225,11 @@
val _ = Vector.foreach
(datatypes, fn Datatype.T {tycon, cons} =>
(bindTycon (tycon, Vector.length cons)
- ; Vector.foreachi (cons, fn (i, {con, ...}) =>
- bindCon (con, i))))
+ ; Vector.foreach (cons, fn {con, ...} =>
+ bindCon con)))
val _ = Vector.foreach
(datatypes, fn Datatype.T {cons, ...} =>
- Vector.foreach (cons, fn {args, ...} =>
+ Vector.foreach (cons, fn {args, ...} =>
Prod.foreach (args, loopType)))
val _ = Vector.foreach (globals, loopStatement)
val _ = List.foreach (functions, bindFunc o Function.name)
--- a/mlyacc/src/yacc.sml
+++ b/mlyacc/src/yacc.sml
@@ -1,3 +1,6 @@
+(* Modified by Matthew Fluet on 2011-06-17.
+ * Use simple file name (rather than absolute paths) in line directives in output.
+ *)
(* Modified by Vesa Karvonen on 2007-12-18.
* Create line directives in output.
*)
@@ -777,8 +780,8 @@
in let val result = TextIO.openOut (spec ^ ".sml")
val sigs = TextIO.openOut (spec ^ ".sig")
- val specPath = OS.FileSys.fullPath spec
- val resultPath = OS.FileSys.fullPath (spec ^ ".sml")
+ val specFile = OS.Path.file spec
+ val resultFile = specFile ^ ".sml"
val line = ref 1
val col = ref 0
val pr = fn s => TextIO.output(result,s)
@@ -793,8 +796,8 @@
String.concat ["(*#line ", Int.toString line, ".",
Int.toString (col+1), " \"", path, "\"*)"]
val fmtPos =
- fn NONE => (fmtLineDir {line = !line, col = 0} resultPath) ^ "\n"
- | SOME pos => fmtLineDir pos specPath
+ fn NONE => (fmtLineDir {line = !line, col = 0} resultFile) ^ "\n"
+ | SOME pos => fmtLineDir pos specFile
val termvoid = makeUniqueId "VOID"
val ntvoid = makeUniqueId "ntVOID"
val hasType = fn s => case symbolType s
--- /dev/null
+++ b/regression/weird-word1.ok
@@ -0,0 +1 @@
+0wx8
--- /dev/null
+++ b/regression/weird-word1.sml
@@ -0,0 +1,26 @@
+fun fib (w: Word5.word) : Word5.word =
+ if w <= 0wx1
+ then 0wx1
+ else fib (w - 0wx1) + fib (w - 0wx2)
+
+val s =
+ case (fib 0wx5) of
+ 0wx0 => "0wx0"
+ | 0wx1 => "0wx1"
+ | 0wx2 => "0wx2"
+ | 0wx3 => "0wx3"
+ | 0wx4 => "0wx4"
+ | 0wx5 => "0wx5"
+ | 0wx6 => "0wx6"
+ | 0wx7 => "0wx7"
+ | 0wx8 => "0wx8"
+ | 0wx9 => "0wx9"
+ | 0wxA => "0wxA"
+ | 0wxB => "0wxB"
+ | 0wxC => "0wxC"
+ | 0wxD => "0wxD"
+ | 0wxE => "0wxE"
+ | 0wxF => "0wxF"
+ | _ => "zzz"
+
+val _ = print (concat [s, "\n"])
--- /dev/null
+++ b/regression/weird-word2.ok
@@ -0,0 +1 @@
+0wx8
--- /dev/null
+++ b/regression/weird-word2.sml
@@ -0,0 +1,41 @@
+fun fib (w: Word5.word) : Word5.word =
+ if w <= 0wx1
+ then 0wx1
+ else fib (w - 0wx1) + fib (w - 0wx2)
+
+val s =
+ case (fib 0wx5) of
+ 0wx0 => "0wx0"
+ | 0wx1 => "0wx1"
+ | 0wx2 => "0wx2"
+ | 0wx3 => "0wx3"
+ | 0wx4 => "0wx4"
+ | 0wx5 => "0wx5"
+ | 0wx6 => "0wx6"
+ | 0wx7 => "0wx7"
+ | 0wx8 => "0wx8"
+ | 0wx9 => "0wx9"
+ | 0wxA => "0wxA"
+ | 0wxB => "0wxB"
+ | 0wxC => "0wxC"
+ | 0wxD => "0wxD"
+ | 0wxE => "0wxE"
+ | 0wxF => "0wxF"
+ | 0wx10 => "0wx10"
+ | 0wx11 => "0wx11"
+ | 0wx12 => "0wx12"
+ | 0wx13 => "0wx13"
+ | 0wx14 => "0wx14"
+ | 0wx15 => "0wx15"
+ | 0wx16 => "0wx16"
+ | 0wx17 => "0wx17"
+ | 0wx18 => "0wx18"
+ | 0wx19 => "0wx19"
+ | 0wx1A => "0wx1A"
+ | 0wx1B => "0wx1B"
+ | 0wx1C => "0wx1C"
+ | 0wx1D => "0wx1D"
+ | 0wx1E => "0wx1E"
+ | 0wx1F => "0wx1F"
+
+val _ = print (concat [s, "\n"])
--- a/runtime/basis/MLton/bug.c
+++ b/runtime/basis/MLton/bug.c
@@ -4,9 +4,7 @@
void MLton_bug (String8_t msg) {
uintmax_t size = GC_getArrayLength ((pointer)msg);
fprintf (stderr, "MLton bug: ");
- unless (0 == size)
- while (1 != fwrite ((const void*)msg, (size_t)size, 1, stderr))
- /* nothing */;
+ fwrite ((const void*)msg, (size_t)size, 1, stderr);
fprintf (stderr, "\nPlease send a bug report to MLton@mlton.org.\n");
exit (2);
}
--- a/runtime/basis/Posix/Signal.c
+++ b/runtime/basis/Posix/Signal.c
@@ -104,7 +104,7 @@
}
void Posix_Signal_sigsuspend (void) {
- int res;
+ int __attribute__ ((unused)) res;
res = sigsuspend (&Posix_Signal_sigset);
assert (-1 == res);
--- a/runtime/basis/Real/gdtoa.c
+++ b/runtime/basis/Real/gdtoa.c
@@ -14,10 +14,8 @@
int i;
ULong L[1];
char *result;
- ULong sign;
memcpy(L, &f, sizeof(Real32_t));
- sign = L[0] & 0x80000000L;
bits[0] = L[0] & 0x7fffff;
if (0 != (ex = (L[0] >> 23) & 0xff))
bits[0] |= 0x800000;
@@ -40,7 +38,6 @@
int i;
ULong L[2];
char *result;
- ULong sign;
int x0, x1;
if (isBigEndian()) {
@@ -51,7 +48,6 @@
x1 = 0;
}
memcpy(L, &d, sizeof(Real64_t));
- sign = L[x0] & 0x80000000L;
bits[0] = L[x1];
bits[1] = L[x0] & 0xfffff;
if (0 != (ex = (L[x0] >> 20) & 0x7ff))
--- a/runtime/basis/Real/strto.c
+++ b/runtime/basis/Real/strto.c
@@ -4,9 +4,8 @@
Real32_t Real32_strto (NullString8_t s, C_Int_t rounding) {
char *endptr;
Real32_t res;
- int ret;
- ret = gdtoa__strtorf ((const char*)s, &endptr, (int)rounding, &res);
+ gdtoa__strtorf ((const char*)s, &endptr, (int)rounding, &res);
assert (NULL != endptr);
return res;
}
@@ -14,9 +13,8 @@
Real64_t Real64_strto (NullString8_t s, C_Int_t rounding) {
char *endptr;
Real64_t res;
- int ret;
- ret = gdtoa__strtord ((const char*)s, &endptr, (int)rounding, &res);
+ gdtoa__strtord ((const char*)s, &endptr, (int)rounding, &res);
assert (NULL != endptr);
return res;
}
--- a/runtime/basis/Stdio.c
+++ b/runtime/basis/Stdio.c
@@ -2,18 +2,12 @@
void Stdio_printStderr (String8_t s) {
uintmax_t size = GC_getArrayLength ((pointer)s);
- if (0 == size)
- return;
- while (1 != fwrite ((const void*)s, (size_t)size, 1, stderr))
- /* nothing */;
+ fwrite ((const void*)s, (size_t)size, 1, stderr);
}
void Stdio_printStdout (String8_t s) {
uintmax_t size = GC_getArrayLength ((pointer)s);
- if (0 == size)
- return;
- while (1 != fwrite ((const void*)s, (size_t)size, 1, stdout))
- /* nothing */;
+ fwrite ((const void*)s, (size_t)size, 1, stdout);
}
void Stdio_print (String8_t s) {
--- a/runtime/gc/copy-thread.c
+++ b/runtime/gc/copy-thread.c
@@ -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.
*
@@ -35,7 +36,7 @@
GC_thread fromThread;
GC_stack fromStack;
GC_thread toThread;
- GC_stack toStack;
+ GC_stack __attribute__ ((unused)) toStack;
if (DEBUG_THREADS)
fprintf (stderr, "GC_copyCurrentThread\n");
@@ -57,7 +58,7 @@
GC_thread fromThread;
GC_stack fromStack;
GC_thread toThread;
- GC_stack toStack;
+ GC_stack __attribute__ ((unused)) toStack;
if (DEBUG_THREADS)
fprintf (stderr, "GC_copyThread ("FMTPTR")\n", (uintptr_t)p);
--- a/runtime/gc/heap.c
+++ b/runtime/gc/heap.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2009-2010 Matthew Fluet.
+/* Copyright (C) 2009-2011 Matthew Fluet.
* Copyright (C) 2005-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
@@ -41,7 +41,7 @@
size_t liveMapsSize, liveWithMapsSize;
size_t currentMapsSize, currentWithMapsSize;
size_t resSize, resWithMapsSize;
- size_t syslimSize, syslimMapsSize, syslimWithMapsSize;
+ size_t syslimSize, __attribute__ ((unused)) syslimMapsSize, syslimWithMapsSize;
double ratio;
syslimWithMapsSize = alignDown (SIZE_MAX, s->sysvals.pageSize);
@@ -553,12 +553,11 @@
*/
void resizeHeapSecondary (GC_state s) {
size_t primarySize, primaryWithMapsSize;
- size_t secondarySize, secondaryWithMapsSize;
+ size_t secondarySize;
primarySize = s->heap.size;
primaryWithMapsSize = s->heap.withMapsSize;
secondarySize = s->secondaryHeap.size;
- secondaryWithMapsSize = s->secondaryHeap.withMapsSize;
if (DEBUG_RESIZING)
fprintf (stderr, "secondaryHeapResize\n");
if (0 == secondarySize)
--- a/runtime/gc/init-world.c
+++ b/runtime/gc/init-world.c
@@ -1,4 +1,5 @@
-/* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
+/* Copyright (C) 2011 Matthew Fluet.
+ * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -51,7 +52,7 @@
size_t bytes;
bool neg;
__mpz_struct resmpz;
- int ans;
+ __attribute__ ((unused)) int ans;
assert (isFrontierAligned (s, s->frontier));
for (i = 0; i < s->intInfInitsLength; i++) {
--- a/runtime/gc/invariant.c
+++ b/runtime/gc/invariant.c
@@ -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.
*
@@ -42,6 +43,8 @@
assert (layout->size <= s->maxFrameSize);
offsets = layout->offsets;
+ for (unsigned int j = 0; j < offsets[0]; ++j)
+ assert (offsets[j + 1] < layout->size);
}
}
/* Generational */
--- a/runtime/gc/profiling.c
+++ b/runtime/gc/profiling.c
@@ -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.
*
@@ -76,7 +77,6 @@
void enterForProfiling (GC_state s, GC_sourceSeqIndex sourceSeqIndex) {
uint32_t i;
- GC_profileData p;
GC_sourceIndex sourceIndex;
uint32_t *sourceSeq;
@@ -84,7 +84,6 @@
fprintf (stderr, "enterForProfiling ("FMTSSI")\n", sourceSeqIndex);
assert (s->profiling.stack);
assert (sourceSeqIndex < s->sourceMaps.sourceSeqsLength);
- p = s->profiling.data;
sourceSeq = s->sourceMaps.sourceSeqs[sourceSeqIndex];
for (i = 1; i <= sourceSeq[0]; i++) {
sourceIndex = sourceSeq[i];
@@ -123,10 +122,8 @@
}
void leaveSourceForProfiling (GC_state s, GC_profileMasterIndex i) {
- GC_profileData p;
GC_profileStack ps;
- p = s->profiling.data;
ps = getProfileStackInfo (s, i);
assert (ps->numOccurrences > 0);
ps->numOccurrences--;
@@ -136,7 +133,6 @@
void leaveForProfiling (GC_state s, GC_sourceSeqIndex sourceSeqIndex) {
int32_t i;
- GC_profileData p;
GC_sourceIndex sourceIndex;
uint32_t *sourceSeq;
@@ -144,7 +140,6 @@
fprintf (stderr, "leaveForProfiling ("FMTSSI")\n", sourceSeqIndex);
assert (s->profiling.stack);
assert (sourceSeqIndex < s->sourceMaps.sourceSeqsLength);
- p = s->profiling.data;
sourceSeq = s->sourceMaps.sourceSeqs[sourceSeqIndex];
for (i = sourceSeq[0]; i > 0; i--) {
sourceIndex = sourceSeq[i];
![[patchlogo]](http://patch-tracker.debian.org/static/img/swirlpatch.png)