mlton/backend/signal-check.fun

   1 (* Copyright (C) 2009 Matthew Fluet.
   2  * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 functor SignalCheck (S: RSSA_TRANSFORM_STRUCTS): RSSA_TRANSFORM =
  11 struct
  12
  13 open S
  14 open Rssa
  15
  16 structure CFunction =
  17    struct
  18       open CFunction Type.BuiltInCFunction
  19    end
  20
  21 structure Graph = DirectedGraph
  22 local
  23    open Graph
  24 in
  25    structure Node = Node
  26    structure Forest = LoopForest
  27 end
  28
  29 fun insertInFunction (f: Function.t): Function.t =
  30    let
  31       val {args, blocks, name, raises, returns, start} =
  32          Function.dest f
  33       val {get = labelIndex: Label.t -> int, set = setLabelIndex, ...} =
  34          Property.getSetOnce
  35          (Label.plist, Property.initRaise ("index", Label.layout))
  36       val _ =
  37          Vector.foreachi (blocks, fn (i, Block.T {label, ...}) =>
  38                           setLabelIndex (label, i))
  39       val g = Graph.new ()
  40       val n = Vector.length blocks
  41       val {get = nodeIndex: unit Node.t -> int, set = setNodeIndex, ...} =
  42          Property.getSetOnce
  43          (Node.plist, Property.initRaise ("index", Node.layout))
  44       val nodes =
  45          Vector.tabulate (n, fn i =>
  46                           let
  47                              val n = Graph.newNode g
  48                              val _ = setNodeIndex (n, i)
  49                           in
  50                              n
  51                           end)
  52       val isHeader = Array.new (n, false)
  53       fun indexNode i = Vector.sub (nodes, i)
  54       val labelNode = indexNode o labelIndex
  55       val _ =
  56          Vector.foreachi
  57          (blocks, fn (i, Block.T {transfer, ...}) =>
  58           let
  59              val from = indexNode i
  60           in
  61              if (case transfer of
  62                     Transfer.CCall {func, ...} =>
  63                        CFunction.maySwitchThreads func
  64                   | _ => false)
  65                 then ()
  66              else
  67                 Transfer.foreachLabel
  68                 (transfer, fn to =>
  69                  (ignore o Graph.addEdge)
  70                  (g, {from = from, to = labelNode to}))
  71           end)
  72       val extra: Block.t list ref = ref []
  73       fun addSignalCheck (Block.T {args, kind, label, statements, transfer})
  74          : unit =
  75          let
  76             val collect = Label.newNoname ()
  77             val collectReturn = Label.newNoname ()
  78             val dontCollect = Label.newNoname ()
  79             val res = Var.newNoname ()
  80             val compare =
  81                Vector.new1
  82                (Statement.PrimApp
  83                 {args = (Vector.new2
  84                          (Operand.Runtime Runtime.GCField.Limit,
  85                           Operand.null)),
  86                  dst = SOME (res, Type.bool),
  87                  prim = Prim.cpointerEqual})
  88             val compareTransfer =
  89                Transfer.ifBool
  90                (Operand.Var {var = res, ty = Type.bool},
  91                 {falsee = dontCollect,
  92                  truee = collect})
  93             val func = CFunction.gc {maySwitchThreads = true}
  94             val _ =
  95                extra :=
  96                Block.T {args = args,
  97                         kind = kind,
  98                         label = label,
  99                         statements = compare,
 100                         transfer = compareTransfer}
 101                :: (Block.T
 102                    {args = Vector.new0 (),
 103                     kind = Kind.Jump,
 104                     label = collect,
 105                     statements = Vector.new0 (),
 106                     transfer =
 107                     Transfer.CCall
 108                     {args = Vector.new3 (Operand.GCState,
 109                                          Operand.word (WordX.zero (WordSize.csize ())),
 110                                          Operand.bool false),
 111                      func = func,
 112                      return = SOME collectReturn}})
 113                :: (Block.T
 114                    {args = Vector.new0 (),
 115                     kind = Kind.CReturn {func = func},
 116                     label = collectReturn,
 117                     statements = Vector.new0 (),
 118                     transfer =
 119                     Transfer.Goto {dst = dontCollect,
 120                                    args = Vector.new0 ()}})
 121                :: Block.T {args = Vector.new0 (),
 122                            kind = Kind.Jump,
 123                            label = dontCollect,
 124                            statements = statements,
 125                            transfer = transfer}
 126                :: !extra
 127          in
 128             ()
 129          end
 130       (* Create extra blocks with signal checks for all blocks that are
 131        * loop headers.
 132        *)
 133       fun loop (f: unit Forest.t) =
 134          let
 135             val {loops, ...} = Forest.dest f
 136          in
 137             Vector.foreach
 138             (loops, fn {headers, child} =>
 139              let
 140                 val _ =
 141                    Vector.foreach
 142                    (headers, fn n =>
 143                     let
 144                        val i = nodeIndex n
 145                        val _ = Array.update (isHeader, i, true)
 146                     in
 147                        addSignalCheck (Vector.sub (blocks, i))
 148                     end)
 149                 val _ = loop child
 150              in
 151                 ()
 152              end)
 153          end
 154       (* Add a signal check at the function entry. *)
 155       val newStart = Label.newNoname ()
 156       val _ =
 157          addSignalCheck
 158          (Block.T {args = Vector.new0 (),
 159                    kind = Kind.Jump,
 160                    label = newStart,
 161                    statements = Vector.new0 (),
 162                    transfer = Transfer.Goto {args = Vector.new0 (),
 163                                              dst = start}})
 164       val () = loop (Graph.loopForestSteensgaard (g, {root = labelNode start}))
 165       val blocks =
 166          Vector.keepAllMap
 167          (blocks, fn b as Block.T {label, ...} =>
 168           if Array.sub (isHeader, labelIndex label)
 169              then NONE
 170           else SOME b)
 171       val blocks = Vector.concat [blocks, Vector.fromList (!extra)]
 172       val f = Function.new {args = args,
 173                             blocks = blocks,
 174                             name = name,
 175                             raises = raises,
 176                             returns = returns,
 177                             start = newStart}
 178       val _ = Function.clear f
 179    in
 180       f
 181    end
 182
 183 fun transform p =
 184    let
 185       val Program.T {functions, handlesSignals, main, objectTypes} = p
 186    in
 187       if not handlesSignals
 188          then p
 189       else
 190          Program.T {functions = List.revMap (functions, insertInFunction),
 191                     handlesSignals = handlesSignals,
 192                     main = main,
 193                     objectTypes = objectTypes}
 194    end
 195
 196 end