1 (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
2 * Jagannathan, and Stephen Weeks.
3 * Copyright (C) 1997-2000 NEC Research Institute.
5 * MLton is released under a BSD-style license.
6 * See the file MLton-LICENSE for details.
9 functor CommonBlock (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM =
15 fun transform (Program.T {globals, datatypes, functions, main}) =
17 val shrink = shrinkFunction {globals = globals}
20 fun make transfer = let
21 val l = Label.newNoname ()
24 args = Vector.new0 (),
25 statements = Vector.new0 (),
29 fun makeRaise var = make (Raise (Vector.new1 var))
30 fun makeReturn var = make (Return (Vector.new1 var))
31 fun makeGoto (dst, var) = make (Goto {dst = dst, args = Vector.new1 var})
33 fun makeNullaryGoto dst = Goto {dst = dst, args = Vector.new0 ()}
36 Var.t -> {returner: (Func.t * Label.t) option ref,
37 raiser: (Func.t * Label.t) option ref,
38 gotoers: (Func.t * (Label.t * Label.t) list ref) option ref} option,
39 set = setVarInfo, ...} =
41 (Var.plist, Property.initConst NONE)
45 (globals, fn Statement.T {var, ...} =>
46 setVarInfo(valOf var, SOME {returner = ref NONE,
50 fun eliminateFunction f =
52 val {args, blocks, mayInline, name, returns, raises, start} =
54 val newBlocks = ref []
56 fun common (sel, make) var =
68 List.push(newBlocks, b) ;
76 if Func.equals(name, name')
81 val commonReturner = common (#returner, makeReturn)
82 val commonRaiser = common (#raiser, makeRaise)
84 fun commonGotoers (k, var) =
87 | SOME {gotoers, ...} =>
91 val b = makeGoto (k, var)
94 List.push(newBlocks, b) ;
95 List.push(info, (k, l)) ;
102 gotoers := SOME (name, info);
108 | SOME (name', info') =>
109 if Func.equals(name, name')
110 then case List.peek (!info', fn (k', _) =>
111 Label.equals(k', k)) of
112 NONE => install info'
113 | SOME (_, l') => SOME l'
119 (blocks, fn Block.T {label, args, statements, transfer} =>
121 val doit = fn SOME l => makeNullaryGoto l
124 if Vector.isEmpty statements
125 then case transfer of
126 Goto {dst, args = xs} =>
127 if Vector.length xs = 1
128 then doit (commonGotoers
129 (dst, Vector.first xs))
132 if Vector.length xs = 1
133 then doit (commonReturner
137 if Vector.length xs = 1
138 then doit (commonRaiser
144 Block.T {label = label,
146 statements = statements,
149 val blocks = Vector.concat [Vector.fromList (!newBlocks), blocks]
151 shrink (Function.new {args = args,
153 mayInline = mayInline,
161 Program.T {datatypes = datatypes,
163 functions = List.revMap (functions, eliminateFunction),
165 val _ = Program.clearTop program