| 1 | (* Copyright (C) 1999-2005, 2008 Henry Cejtin, Matthew Fluet, Suresh |
| 2 | * Jagannathan, and Stephen Weeks. |
| 3 | * Copyright (C) 1997-2000 NEC Research Institute. |
| 4 | * |
| 5 | * MLton is released under a BSD-style license. |
| 6 | * See the file MLton-LICENSE for details. |
| 7 | *) |
| 8 | |
| 9 | (* Change any toplevel function that only calls itself in tail position |
| 10 | * into one with a local loop and no self calls. |
| 11 | *) |
| 12 | functor IntroduceLoops (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM = |
| 13 | struct |
| 14 | |
| 15 | open S |
| 16 | datatype z = datatype Exp.t |
| 17 | datatype z = datatype Transfer.t |
| 18 | |
| 19 | structure Return = |
| 20 | struct |
| 21 | open Return |
| 22 | |
| 23 | fun isTail (z: t): bool = |
| 24 | case z of |
| 25 | Dead => false |
| 26 | | NonTail _ => false |
| 27 | | Tail => true |
| 28 | end |
| 29 | |
| 30 | fun transform (Program.T {datatypes, globals, functions, main}) = |
| 31 | let |
| 32 | val functions = |
| 33 | List.revMap |
| 34 | (functions, fn f => |
| 35 | let |
| 36 | val {args, blocks, mayInline, name, raises, returns, start} = |
| 37 | Function.dest f |
| 38 | val tailCallsItself = ref false |
| 39 | val _ = |
| 40 | Vector.foreach |
| 41 | (blocks, fn Block.T {transfer, ...} => |
| 42 | case transfer of |
| 43 | Call {func, return, ...} => |
| 44 | if Func.equals (name, func) |
| 45 | andalso Return.isTail return |
| 46 | then tailCallsItself := true |
| 47 | else () |
| 48 | | _ => ()) |
| 49 | val (args, start, blocks) = |
| 50 | if !tailCallsItself |
| 51 | then |
| 52 | let |
| 53 | val _ = Control.diagnostics |
| 54 | (fn display => |
| 55 | let open Layout |
| 56 | in |
| 57 | display (Func.layout name) |
| 58 | end) |
| 59 | val newArgs = |
| 60 | Vector.map (args, fn (x, t) => (Var.new x, t)) |
| 61 | val loopName = Label.newString "loop" |
| 62 | val loopSName = Label.newString "loopS" |
| 63 | val blocks = |
| 64 | Vector.toListMap |
| 65 | (blocks, |
| 66 | fn Block.T {label, args, statements, transfer} => |
| 67 | let |
| 68 | val transfer = |
| 69 | case transfer of |
| 70 | Call {func, args, return} => |
| 71 | if Func.equals (name, func) |
| 72 | andalso Return.isTail return |
| 73 | then Goto {dst = loopName, |
| 74 | args = args} |
| 75 | else transfer |
| 76 | | _ => transfer |
| 77 | in |
| 78 | Block.T {label = label, |
| 79 | args = args, |
| 80 | statements = statements, |
| 81 | transfer = transfer} |
| 82 | end) |
| 83 | val blocks = |
| 84 | Vector.fromList |
| 85 | (Block.T |
| 86 | {label = loopSName, |
| 87 | args = Vector.new0 (), |
| 88 | statements = Vector.new0 (), |
| 89 | transfer = Goto {dst = loopName, |
| 90 | args = Vector.map (newArgs, #1)}} :: |
| 91 | Block.T |
| 92 | {label = loopName, |
| 93 | args = args, |
| 94 | statements = Vector.new0 (), |
| 95 | transfer = Goto {dst = start, |
| 96 | args = Vector.new0 ()}} :: |
| 97 | blocks) |
| 98 | in |
| 99 | (newArgs, |
| 100 | loopSName, |
| 101 | blocks) |
| 102 | end |
| 103 | else (args, start, blocks) |
| 104 | in |
| 105 | Function.new {args = args, |
| 106 | blocks = blocks, |
| 107 | mayInline = mayInline, |
| 108 | name = name, |
| 109 | raises = raises, |
| 110 | returns = returns, |
| 111 | start = start} |
| 112 | end) |
| 113 | in |
| 114 | Program.T {datatypes = datatypes, |
| 115 | globals = globals, |
| 116 | functions = functions, |
| 117 | main = main} |
| 118 | end |
| 119 | |
| 120 | end |