1 (* Copyright (C) 2009 Matthew Fluet.
2 * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor RedundantTests (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM =
19 | LT of {signed: bool}
20 | LE of {signed: bool}
23 val equals: t * t -> bool = op =
31 val layout = Layout.str o toString
41 fn Const c => Const.layout c
42 | Var x => Var.layout x
45 fn (Const c, Const c') => Const.equals (c, c')
46 | (Var x, Var x') => Var.equals (x, x')
52 datatype t = T of {rel: Rel.t,
56 fun layout (T {rel, lhs, rhs}) =
58 in seq [Oper.layout lhs, str " ", Rel.layout rel,
59 str " ", Oper.layout rhs]
62 fun equals (T {rel, lhs = l, rhs = r},
63 T {rel = rel', lhs = l', rhs = r'}) =
64 Rel.equals (rel, rel')
65 andalso Oper.equals (l, l')
66 andalso Oper.equals (r, r')
68 fun negate (T {rel, lhs, rhs}): t =
70 datatype z = datatype Rel.t
78 T {rel = rel, lhs = rhs, rhs = lhs}
81 datatype result = False | True | Unknown
83 fun determine (facts: t list, f: t): result =
84 if List.contains (facts, f, equals)
86 else if List.contains (facts, negate f, equals)
93 fun transform (Program.T {globals, datatypes, functions, main}) =
99 | Or of Fact.t * Fact.t
100 val {get = varInfo: Var.t -> varInfo, set = setVarInfo, ...} =
101 Property.getSetOnce (Var.plist, Property.initConst None)
103 Trace.trace ("RedundantTests.setVarInfo",
107 datatype z = datatype Fact.result
108 datatype z = datatype Rel.t
109 fun makeVarInfo {args, prim, targs = _}: varInfo =
113 val x = Vector.sub (args, i)
116 Const c => Oper.Const c
120 Fact (Fact.T {rel = r,
123 fun doit rel = z (rel, 0, 1)
124 datatype z = datatype Prim.Name.t
126 case Prim.name prim of
128 | Word_equal _ => doit EQ
129 | Word_lt (_, sg) => doit (LT sg)
132 fun setConst (x, c) = setVarInfo (x, Const c)
135 (globals, fn Statement.T {var, exp, ...} =>
137 Exp.Const c => Option.app (var, fn x => setConst (x, c))
142 val x = Var.newNoname ()
145 Statement.T {var = SOME x,
147 exp = ConApp {con = c, args = Vector.new0 ()}})
150 val (trueVar, t) = make Con.truee
151 val (falseVar, f) = make Con.falsee
154 val statements = ref []
160 val one = Var.newNoname ()
164 Statement.T {exp = Exp.Const (Const.word (WordX.one s)),
170 val ones = Vector.fromList (!statements)
172 val globals = Vector.concat [Vector.new2 (t, f), ones, globals]
173 val shrink = shrinkFunction {globals = globals}
174 val numSimplified = ref 0
175 fun simplifyFunction f =
177 val {args, blocks, mayInline, name, raises, returns, start} =
183 in seq [str "processing ", Func.layout name]
185 val {get = labelInfo: Label.t -> {ancestor: Label.t option ref,
186 facts: Fact.t list ref,
190 (Label.plist, Property.initFun (fn _ => {ancestor = ref NONE,
194 fun inc l = Int.inc (#inDeg (labelInfo l))
198 (blocks, fn Block.T {transfer, ...} =>
199 Transfer.foreachLabel (transfer, inc))
200 (* Perform analysis, set up facts, and set up ancestor. *)
201 fun loop (Tree.T (Block.T {label, statements, transfer, ...},
207 (statements, fn Statement.T {var, exp, ...} =>
210 Option.app (var, fn x => setConst (x, c))
212 Option.app (var, fn x =>
213 setVarInfo (x, makeVarInfo pa))
217 Case {test, cases, default, ...} =>
221 val {facts, inDeg, ...} = labelInfo l
224 then List.push (facts, f)
231 fun ca i = Vector.sub (v, i)
233 case (Vector.length v, default) of
238 if Con.equals (c, Con.truee)
247 if Con.equals (c, Con.truee)
251 | _ => Error.bug "RedundantTests.simplifyFunction: expected two branches"
253 | _ => Error.bug "RedundantTests.simplifyFunction: expected con"
258 val (l, l') = falseTrue ()
260 add (l, Fact.negate f)
265 val (l, _) = falseTrue ()
267 add (l, Fact.negate f)
268 ; add (l, Fact.negate f')
274 val {ancestor, facts, ...} = labelInfo label
275 val _ = ancestor := ancestor'
276 val ancestor' = if List.isEmpty (!facts)
281 (children, fn tree => loop (tree, ancestor'))
283 val _ = loop (Function.dominatorTree f, NONE)
289 (blocks, fn Block.T {label, ...} =>
291 in display (seq [Label.layout label,
293 List.layout Fact.layout
294 (! (#facts (labelInfo label)))])
296 (* Transformation. *)
297 fun isFact (l: Label.t, p: Fact.t -> bool): bool =
299 fun loop (l: Label.t) =
301 val {ancestor, facts, ...} = labelInfo l
303 List.exists (!facts, p)
304 orelse (case !ancestor of
311 fun determine (l: Label.t, f: Fact.t) =
313 fun loop {ancestor, facts, ...} =
314 case Fact.determine (!facts, f) of
318 | SOME l => loop (labelInfo l))
325 (blocks, fn Block.T {label, args, statements, transfer} =>
329 (statements, fn statement as Statement.T {ty, var, ...} =>
332 (Int.inc numSimplified
336 in seq [Option.layout Var.layout var,
340 ; Statement.T {var = var,
343 fun falsee () = doit falseVar
344 fun truee () = doit trueVar
351 (case determine (label, f) of
353 (case determine (label, f') of
356 | Unknown => statement)
358 | Unknown => statement)
360 (case determine (label, f) of
363 | Unknown => statement)
366 val noChange = (statements, transfer)
367 fun arith (args: Var.t vector,
370 : Statement.t vector * Transfer.t =
372 fun simplify (prim: Type.t Prim.t,
376 val res = Var.newNoname ()
382 {exp = PrimApp {args = Vector.new2 (x, one s),
384 targs = Vector.new0 ()},
387 Goto {args = Vector.new1 res,
390 fun add1 (x: Var.t, s: WordSize.t, sg) =
391 if isFact (label, fn Fact.T {lhs, rel, rhs} =>
392 case (lhs, rel, rhs) of
393 (Oper.Var x', Rel.LT sg', _) =>
396 | (Oper.Var x', Rel.LE sg',
404 (w, WordX.max (s, sg), sg)
405 | _ => Error.bug "RedundantTests.add1: strange fact")
407 then simplify (Prim.wordAdd s, x, s)
409 fun sub1 (x: Var.t, s: WordSize.t, sg) =
410 if isFact (label, fn Fact.T {lhs, rel, rhs} =>
411 case (lhs, rel, rhs) of
412 (_, Rel.LT sg', Oper.Var x') =>
415 | (Oper.Const c, Rel.LE sg',
423 (w, WordX.min (s, sg), sg)
424 | _ => Error.bug "RedundantTests.sub1: strange fact")
426 then simplify (Prim.wordSub s, x, s)
428 fun add (c: Const.t, x: Var.t, (s, sg as {signed})) =
433 else if signed andalso WordX.isNegOne i
436 | _ => Error.bug "RedundantTests.add: strange const"
437 datatype z = datatype Prim.Name.t
439 case Prim.name prim of
442 val x1 = Vector.sub (args, 0)
443 val x2 = Vector.sub (args, 1)
446 Const c => add (c, x2, s)
447 | _ => (case varInfo x2 of
448 Const c => add (c, x1, s)
451 | Word_subCheck (s, sg as {signed}) =>
453 val x1 = Vector.sub (args, 0)
454 val x2 = Vector.sub (args, 1)
461 then sub1 (x1, s, sg)
464 andalso WordX.isNegOne w)
465 then add1 (x1, s, sg)
468 Error.bug "RedundantTests.sub: strage const")
473 val (statements, transfer) =
475 Arith {args, prim, success, ...} =>
476 arith (args, prim, success)
479 Block.T {label = label,
481 statements = statements,
485 shrink (Function.new {args = args,
487 mayInline = mayInline,
497 in seq [str "numSimplified = ", Int.layout (!numSimplified)]
499 val functions = List.revMap (functions, simplifyFunction)
501 Program.T {datatypes = datatypes,
503 functions = functions,
505 val _ = Program.clearTop program