Commit | Line | Data |
---|---|---|
7f918cf1 CE |
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 |