--- 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];