mlton/ssa/introduce-loops.fun

   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