[hcoop/debian/mlton.git] / mlton / ssa / multi.fun

(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-2000 NEC Research Institute.
 *
 * MLton is released under a BSD-style license.
 * See the file MLton-LICENSE for details.
 *)

(*
Defn:
A label is exactly-multi-threaded if it may be executed by two
different threads during some run of the program.  The initial call to
main counts as one thread.

Defn:
A label is actually-multi-used if it may be executed more than once
during the execution of the program.
*)

functor Multi (S: MULTI_STRUCTS): MULTI =
struct

open S
open Exp Transfer

structure Graph = DirectedGraph
local open Graph
in
  structure Node = Node
end

structure Calls =
  struct
    datatype t = T of value ref
    and value = Zero | One | Many
    fun new (): t = T (ref Zero)
    fun inc (T r)
      = case !r 
          of Zero => r := One
           | _ => r := Many
    val isMany
      = fn (T (ref Many)) => true
         | _ => false
  end

structure ThreadCopyCurrent =
  struct
    structure L = TwoPointLattice (val bottom = "false"
                                   val top = "true")
    open L
    val force = makeTop
    val does = isTop
    val when = addHandler
  end

structure MultiThreaded =
  struct
    structure L = TwoPointLattice (val bottom = "false"
                                   val top = "true")
    open L
    val force = makeTop
    val is = isTop
    val when = addHandler
  end

structure MultiUsed =
  struct
    structure L = TwoPointLattice (val bottom = "false"
                                   val top = "true")
    open L
    val force = makeTop
    val is = isTop
    val when = addHandler
  end


structure FuncInfo =
  struct
    datatype t = T of {calls: Calls.t,
                       threadCopyCurrent: ThreadCopyCurrent.t,
                       multiThreaded: MultiThreaded.t,
                       multiUsed: MultiUsed.t}

    local
       fun make f (T r) = f r
    in
      val calls = make #calls
      val threadCopyCurrent = make #threadCopyCurrent
      val multiThreaded = make #multiThreaded
      val multiUsed = make #multiUsed
    end

    fun new (): t = T {calls = Calls.new (),
                       threadCopyCurrent = ThreadCopyCurrent.new (),
                       multiUsed = MultiUsed.new (),
                       multiThreaded = MultiThreaded.new ()}
  end

structure LabelInfo =
  struct
    datatype t = T of {threadCopyCurrent: ThreadCopyCurrent.t,
                       multiThreaded: MultiThreaded.t,
                       multiUsed: MultiUsed.t}

    local
       fun make f (T r) = f r
     in
       val threadCopyCurrent = make #threadCopyCurrent
       val multiThreaded = make #multiThreaded
       val multiUsed = make #multiUsed
     end

     fun new (): t = T {threadCopyCurrent = ThreadCopyCurrent.new (),
                        multiThreaded = MultiThreaded.new (),
                        multiUsed = MultiUsed.new ()}
   end

structure VarInfo =
  struct
    datatype t = T of {multiThreaded: MultiThreaded.t,
                       multiUsed: MultiUsed.t}

    local
       fun make f (T r) = f r
     in
       val multiThreaded = make #multiThreaded
       val multiUsed = make #multiUsed
     end

     fun new (): t = T {multiThreaded = MultiThreaded.new (),
                        multiUsed = MultiUsed.new ()}
   end

fun multi (p as Program.T {functions, main, ...})
  = let
      val usesThreadsOrConts 
        = Program.hasPrim (p, fn p =>
                           case Prim.name p of
                              Prim.Name.Thread_switchTo => true
                            | _ => false)

      (* funcNode *)
      val {get = funcNode: Func.t -> unit Node.t,
           set = setFuncNode, 
           rem = remFuncNode, ...}
        = Property.getSetOnce
          (Func.plist, Property.initRaise ("Multi.funcNode", Func.layout))

      (* nodeFunction *)
      val {get = nodeFunction: unit Node.t -> Function.t,
           set = setNodeFunction, ...}
        = Property.getSetOnce 
          (Node.plist, Property.initRaise ("Multi.nodeFunc", Node.layout))

      (* funcInfo *)
      val {get = funcInfo: Func.t -> FuncInfo.t, ...}
        = Property.get
          (Func.plist, Property.initFun (fn _ => FuncInfo.new ()))

      (* labelInfo *)
      val {get = labelInfo: Label.t -> LabelInfo.t, ...}
        = Property.get
          (Label.plist, Property.initFun (fn _ => LabelInfo.new ()))

      (* varInfo *)
      val {get = varInfo: Var.t -> VarInfo.t, ...}
        = Property.get
          (Var.plist, Property.initFun (fn _ => VarInfo.new ()))

      (* construct call graph
       * compute calls
       * compute threadCopyCurrent
       *)
      val G = Graph.new ()
      fun newNode () = Graph.newNode G
      fun addEdge edge = ignore (Graph.addEdge (G, edge))
      val _ = List.foreach
              (functions, fn f =>
               let
                 val n = newNode ()
               in 
                 setFuncNode (Function.name f, n) ;
                 setNodeFunction (n, f)
               end)
      val _ = Calls.inc (FuncInfo.calls (funcInfo main))
      val _ = List.foreach
              (functions, fn f =>
               let
                 val {name = f, blocks, ...} = Function.dest f
                 val fi = funcInfo f
               in
                 Vector.foreach
                 (blocks, fn Block.T {label, transfer, ...} =>
                  let
                    val li = labelInfo label
                  in
                    case transfer
                      of Call {func = g, ...}
                       => let
                            val gi = funcInfo g
                          in 
                            Calls.inc (FuncInfo.calls gi) ;
                            addEdge {from = funcNode f,
                                     to = funcNode g} ;
                            if usesThreadsOrConts
                              then ThreadCopyCurrent.when
                                   (FuncInfo.threadCopyCurrent gi,
                                    fn () =>
                                    (ThreadCopyCurrent.force
                                     (LabelInfo.threadCopyCurrent li) ;
                                     ThreadCopyCurrent.force
                                     (FuncInfo.threadCopyCurrent fi)))
                              else ()
                          end
                      | Runtime {prim, ...}
                      => if usesThreadsOrConts
                            andalso
                            (case Prim.name prim of
                                Prim.Name.Thread_copyCurrent => true
                              | _ => false)
                           then (ThreadCopyCurrent.force
                                 (LabelInfo.threadCopyCurrent li) ;
                                 ThreadCopyCurrent.force
                                 (FuncInfo.threadCopyCurrent fi))
                           else ()
                      | _ => ()
                  end)
               end)
      val () = Graph.removeDuplicateEdges G
      val rec forceMultiThreadedVar
        = fn x =>
          let
            val vi = varInfo x
          in
            MultiThreaded.force (VarInfo.multiThreaded vi) ;
            MultiUsed.force (VarInfo.multiUsed vi)
          end
      val rec forceMultiUsedVar
        = fn x =>
          let
            val vi = varInfo x
          in
            MultiUsed.force (VarInfo.multiUsed vi)
          end
      val rec forceMultiThreadedFunc
        = fn f =>
          let
            val fi = funcInfo f
          in
            MultiThreaded.force (FuncInfo.multiThreaded fi) ;
            MultiUsed.force (FuncInfo.multiUsed fi)
          end
      val rec forceMultiUsedFunc
        = fn f =>
          let
            val fi = funcInfo f
          in
            MultiUsed.force (FuncInfo.multiUsed fi)
          end
      val rec forceMultiThreadedBlock
        = fn Block.T {label, args, statements, transfer} =>
          let
            val li = labelInfo label
          in
            if MultiThreaded.is (LabelInfo.multiThreaded li)
              then ()
              else (MultiThreaded.force (LabelInfo.multiThreaded li) ;
                    MultiUsed.force (LabelInfo.multiUsed li) ;
                    Vector.foreach (args, forceMultiThreadedVar o #1) ;
                    Vector.foreach 
                    (statements, fn Statement.T {var, ...} =>
                     Option.app (var, forceMultiThreadedVar)) ;
                    Transfer.foreachFunc
                    (transfer, forceMultiThreadedFunc))
          end
      val rec forceMultiThreadedBlockDFS
        = fn controlFlow as {graph = _, labelNode, nodeBlock} =>
          fn block as Block.T {label, transfer, ...} =>
          let
            val li = labelInfo label
          in
            if MultiThreaded.is (LabelInfo.multiThreaded li)
              then ()
              else (forceMultiThreadedBlock block ;
                    Transfer.foreachLabel
                    (transfer, fn l =>
                     forceMultiThreadedBlockDFS controlFlow 
                     (nodeBlock (labelNode l))))
          end
      val rec forceMultiUsedBlock
        = fn Block.T {label, args, statements, transfer} =>
          let
            val li = labelInfo label
          in
            if MultiUsed.is (LabelInfo.multiUsed li)
              then ()
              else (MultiUsed.force (LabelInfo.multiUsed li) ;
                    Vector.foreach (args, forceMultiUsedVar o #1) ;
                    Vector.foreach 
                    (statements, fn Statement.T {var, ...} =>
                     Option.app (var, forceMultiUsedVar)) ;
                    Transfer.foreachFunc
                    (transfer, forceMultiUsedFunc))
          end
      val rec visitBlock
        = fn controlFlow as {graph = _, labelNode, nodeBlock} =>
          fn Block.T {label, transfer, ...} =>
          if ThreadCopyCurrent.does (LabelInfo.threadCopyCurrent (labelInfo label))
            then Transfer.foreachLabel
                 (transfer, fn l =>
                  forceMultiThreadedBlockDFS controlFlow 
                  (nodeBlock (labelNode l)))
            else ()
      val rec visitForceMultiUsedBlock
        = fn controlFlow =>
          fn block =>
          (forceMultiUsedBlock block ;
           visitBlock controlFlow block)

      val rec forceMultiThreadedFunc
        = fn f =>
          let
            val {args, blocks, ...} = Function.dest f
          in
            Vector.foreach
            (args, forceMultiThreadedVar o #1) ;
            Vector.foreach
            (blocks, forceMultiThreadedBlock)
          end
      val rec forceMultiUsedFunc
        = fn f =>
          let
            val {args, blocks, ...} = Function.dest f
          in
            Vector.foreach
            (args, forceMultiUsedVar o #1) ;
            Vector.foreach
            (blocks, forceMultiUsedBlock)
          end

      fun visitFunc multiUsed f
        = let
            val _ = remFuncNode (Function.name f)

            val fi = funcInfo (Function.name f)
            val _ = if multiUsed
                       orelse
                       Calls.isMany (FuncInfo.calls fi)
                      then MultiUsed.force (FuncInfo.multiUsed fi)
                      else ()
          in
            if MultiThreaded.is (FuncInfo.multiThreaded fi)
              then forceMultiThreadedFunc f
            else if MultiUsed.is (FuncInfo.multiUsed fi)
              then (forceMultiUsedFunc f ;
                    if usesThreadsOrConts
                      then let
                             val _ = MultiThreaded.when
                                     (FuncInfo.multiThreaded fi,
                                      fn () => forceMultiThreadedFunc f)
                             val controlFlow = Function.controlFlow f
                           in
                             Vector.foreach
                             (Function.blocks f, visitBlock controlFlow)
                           end
                      else ())
              else if usesThreadsOrConts
                     then let   
                            val _ = MultiThreaded.when
                                    (FuncInfo.multiThreaded fi,
                                     fn () => forceMultiThreadedFunc f)
                            val _ = MultiUsed.when
                                    (FuncInfo.multiUsed fi,
                                     fn () => forceMultiUsedFunc f)
                            val controlFlow as {graph, nodeBlock, ...}
                              = Function.controlFlow f
                          in
                            List.foreach
                            (Graph.stronglyConnectedComponents graph,
                             fn [] => ()
                              | [n] => if Node.hasEdge {from = n, to = n}
                                         then visitForceMultiUsedBlock controlFlow
                                              (nodeBlock n)
                                         else visitBlock controlFlow
                                              (nodeBlock n)
                              | ns => List.foreach
                                      (ns, fn n =>
                                       visitForceMultiUsedBlock controlFlow
                                       (nodeBlock n)))
                          end
                     else let   
                            val _ = MultiUsed.when
                                    (FuncInfo.multiUsed fi,
                                     fn () => forceMultiUsedFunc f)
                            val {graph, nodeBlock, ...} = Function.controlFlow f
                          in
                            List.foreach
                            (Graph.stronglyConnectedComponents graph,
                             fn [] => ()
                              | [n] => if Node.hasEdge {from = n, to = n}
                                         then forceMultiUsedBlock (nodeBlock n)
                                         else ()
                              | ns => List.foreach 
                                      (ns, fn n =>
                                       forceMultiUsedBlock (nodeBlock n)))
                          end
          end

      val _ = List.foreach
              (Graph.stronglyConnectedComponents G,
               fn [] => ()
                | [n] =>
                     visitFunc (Node.hasEdge {from = n, to = n}) (nodeFunction n)
                | ns => List.foreach 
                        (ns, fn n =>
                         visitFunc true (nodeFunction n)))

(*
      val _ = Control.diagnostics
              (fn display =>
               let open Layout
               in 
                 display (Layout.str "\n\nMulti:") ;
                 display (seq [Layout.str "usesThreadsOrConts: ",
                               Bool.layout usesThreadsOrConts]) ;
                 List.foreach
                 (functions, fn f =>
                  let 
                    val {name = f, blocks, ...} = Function.dest f
                  in 
                    display (seq [Func.layout f,
                                  str ": ",
                                  FuncInfo.layout (funcInfo f)]) ;
                    Vector.foreach
                    (blocks, fn Block.T {label, ...} =>
                     display (seq [Label.layout label,
                                   str ": ",
                                   LabelInfo.layout (labelInfo label)]))
                  end)
               end)
*)
    in
      {
       usesThreadsOrConts = usesThreadsOrConts,

       funcDoesThreadCopyCurrent 
       = ThreadCopyCurrent.does o FuncInfo.threadCopyCurrent o funcInfo,
       funcIsMultiThreaded 
       = MultiThreaded.is o FuncInfo.multiThreaded o funcInfo,
       funcIsMultiUsed 
       = MultiUsed.is o FuncInfo.multiUsed o funcInfo,

       labelDoesThreadCopyCurrent 
       = ThreadCopyCurrent.does o LabelInfo.threadCopyCurrent o labelInfo,
       labelIsMultiThreaded 
       = MultiThreaded.is o LabelInfo.multiThreaded o labelInfo,
       labelIsMultiUsed 
       = MultiUsed.is o LabelInfo.multiUsed o labelInfo,

       varIsMultiDefed
       = MultiUsed.is o VarInfo.multiUsed o varInfo
       }
    end
end
Commit	Line	Data
7f918cf1 CE	1	(* Copyright (C) 1999-2006 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	(*
	10	Defn:
	11	A label is exactly-multi-threaded if it may be executed by two
	12	different threads during some run of the program. The initial call to
	13	main counts as one thread.
	14
	15	Defn:
	16	A label is actually-multi-used if it may be executed more than once
	17	during the execution of the program.
	18	*)
	19
	20	functor Multi (S: MULTI_STRUCTS): MULTI =
	21	struct
	22
	23	open S
	24	open Exp Transfer
	25
	26	structure Graph = DirectedGraph
	27	local open Graph
	28	in
	29	structure Node = Node
	30	end
	31
	32	structure Calls =
	33	struct
	34	datatype t = T of value ref
	35	and value = Zero \| One \| Many
	36	fun new (): t = T (ref Zero)
	37	fun inc (T r)
	38	= case !r
	39	of Zero => r := One
	40	\| _ => r := Many
	41	val isMany
	42	= fn (T (ref Many)) => true
	43	\| _ => false
	44	end
	45
	46	structure ThreadCopyCurrent =
	47	struct
	48	structure L = TwoPointLattice (val bottom = "false"
	49	val top = "true")
	50	open L
	51	val force = makeTop
	52	val does = isTop
	53	val when = addHandler
	54	end
	55
	56	structure MultiThreaded =
	57	struct
	58	structure L = TwoPointLattice (val bottom = "false"
	59	val top = "true")
	60	open L
	61	val force = makeTop
	62	val is = isTop
	63	val when = addHandler
	64	end
65
66	structure MultiUsed =
67	struct
68	structure L = TwoPointLattice (val bottom = "false"
69	val top = "true")
70	open L
71	val force = makeTop
72	val is = isTop
73	val when = addHandler
74	end
75
76
77	structure FuncInfo =
78	struct
79	datatype t = T of {calls: Calls.t,
80	threadCopyCurrent: ThreadCopyCurrent.t,
81	multiThreaded: MultiThreaded.t,
82	multiUsed: MultiUsed.t}
83
84	local
85	fun make f (T r) = f r
86	in
87	val calls = make #calls
88	val threadCopyCurrent = make #threadCopyCurrent
89	val multiThreaded = make #multiThreaded
90	val multiUsed = make #multiUsed
91	end
92
93	fun new (): t = T {calls = Calls.new (),
94	threadCopyCurrent = ThreadCopyCurrent.new (),
95	multiUsed = MultiUsed.new (),
96	multiThreaded = MultiThreaded.new ()}
97	end
98
99	structure LabelInfo =
100	struct
101	datatype t = T of {threadCopyCurrent: ThreadCopyCurrent.t,
102	multiThreaded: MultiThreaded.t,
103	multiUsed: MultiUsed.t}
104
105	local
106	fun make f (T r) = f r
107	in
108	val threadCopyCurrent = make #threadCopyCurrent
109	val multiThreaded = make #multiThreaded
110	val multiUsed = make #multiUsed
111	end
112
113	fun new (): t = T {threadCopyCurrent = ThreadCopyCurrent.new (),
114	multiThreaded = MultiThreaded.new (),
115	multiUsed = MultiUsed.new ()}
116	end
117
118	structure VarInfo =
119	struct
120	datatype t = T of {multiThreaded: MultiThreaded.t,
121	multiUsed: MultiUsed.t}
122
123	local
124	fun make f (T r) = f r
125	in
126	val multiThreaded = make #multiThreaded
127	val multiUsed = make #multiUsed
128	end
129
130	fun new (): t = T {multiThreaded = MultiThreaded.new (),
131	multiUsed = MultiUsed.new ()}
132	end
133
134	fun multi (p as Program.T {functions, main, ...})
135	= let
136	val usesThreadsOrConts
137	= Program.hasPrim (p, fn p =>
138	case Prim.name p of
139	Prim.Name.Thread_switchTo => true
140	\| _ => false)
141
142	(* funcNode *)
143	val {get = funcNode: Func.t -> unit Node.t,
144	set = setFuncNode,
145	rem = remFuncNode, ...}
146	= Property.getSetOnce
147	(Func.plist, Property.initRaise ("Multi.funcNode", Func.layout))
148
149	(* nodeFunction *)
150	val {get = nodeFunction: unit Node.t -> Function.t,
151	set = setNodeFunction, ...}
152	= Property.getSetOnce
153	(Node.plist, Property.initRaise ("Multi.nodeFunc", Node.layout))
154
155	(* funcInfo *)
156	val {get = funcInfo: Func.t -> FuncInfo.t, ...}
157	= Property.get
158	(Func.plist, Property.initFun (fn _ => FuncInfo.new ()))
159
160	(* labelInfo *)
161	val {get = labelInfo: Label.t -> LabelInfo.t, ...}
162	= Property.get
163	(Label.plist, Property.initFun (fn _ => LabelInfo.new ()))
164
165	(* varInfo *)
166	val {get = varInfo: Var.t -> VarInfo.t, ...}
167	= Property.get
168	(Var.plist, Property.initFun (fn _ => VarInfo.new ()))
169
170	(* construct call graph
171	* compute calls
172	* compute threadCopyCurrent
173	*)
174	val G = Graph.new ()
175	fun newNode () = Graph.newNode G
176	fun addEdge edge = ignore (Graph.addEdge (G, edge))
177	val _ = List.foreach
178	(functions, fn f =>
179	let
180	val n = newNode ()
181	in
182	setFuncNode (Function.name f, n) ;
183	setNodeFunction (n, f)
184	end)
185	val _ = Calls.inc (FuncInfo.calls (funcInfo main))
186	val _ = List.foreach
187	(functions, fn f =>
188	let
189	val {name = f, blocks, ...} = Function.dest f
190	val fi = funcInfo f
191	in
192	Vector.foreach
193	(blocks, fn Block.T {label, transfer, ...} =>
194	let
195	val li = labelInfo label
196	in
197	case transfer
198	of Call {func = g, ...}
199	=> let
200	val gi = funcInfo g
201	in
202	Calls.inc (FuncInfo.calls gi) ;
203	addEdge {from = funcNode f,
204	to = funcNode g} ;
205	if usesThreadsOrConts
206	then ThreadCopyCurrent.when
207	(FuncInfo.threadCopyCurrent gi,
208	fn () =>
209	(ThreadCopyCurrent.force
210	(LabelInfo.threadCopyCurrent li) ;
211	ThreadCopyCurrent.force
212	(FuncInfo.threadCopyCurrent fi)))
213	else ()
214	end
215	\| Runtime {prim, ...}
216	=> if usesThreadsOrConts
217	andalso
218	(case Prim.name prim of
219	Prim.Name.Thread_copyCurrent => true
220	\| _ => false)
221	then (ThreadCopyCurrent.force
222	(LabelInfo.threadCopyCurrent li) ;
223	ThreadCopyCurrent.force
224	(FuncInfo.threadCopyCurrent fi))
225	else ()
226	\| _ => ()
227	end)
228	end)
229	val () = Graph.removeDuplicateEdges G
230	val rec forceMultiThreadedVar
231	= fn x =>
232	let
233	val vi = varInfo x
234	in
235	MultiThreaded.force (VarInfo.multiThreaded vi) ;
236	MultiUsed.force (VarInfo.multiUsed vi)
237	end
238	val rec forceMultiUsedVar
239	= fn x =>
240	let
241	val vi = varInfo x
242	in
243	MultiUsed.force (VarInfo.multiUsed vi)
244	end
245	val rec forceMultiThreadedFunc
246	= fn f =>
247	let
248	val fi = funcInfo f
249	in
250	MultiThreaded.force (FuncInfo.multiThreaded fi) ;
251	MultiUsed.force (FuncInfo.multiUsed fi)
252	end
253	val rec forceMultiUsedFunc
254	= fn f =>
255	let
256	val fi = funcInfo f
257	in
258	MultiUsed.force (FuncInfo.multiUsed fi)
259	end
260	val rec forceMultiThreadedBlock
261	= fn Block.T {label, args, statements, transfer} =>
262	let
263	val li = labelInfo label
264	in
265	if MultiThreaded.is (LabelInfo.multiThreaded li)
266	then ()
267	else (MultiThreaded.force (LabelInfo.multiThreaded li) ;
268	MultiUsed.force (LabelInfo.multiUsed li) ;
269	Vector.foreach (args, forceMultiThreadedVar o #1) ;
270	Vector.foreach
271	(statements, fn Statement.T {var, ...} =>
272	Option.app (var, forceMultiThreadedVar)) ;
273	Transfer.foreachFunc
274	(transfer, forceMultiThreadedFunc))
275	end
276	val rec forceMultiThreadedBlockDFS
277	= fn controlFlow as {graph = _, labelNode, nodeBlock} =>
278	fn block as Block.T {label, transfer, ...} =>
279	let
280	val li = labelInfo label
281	in
282	if MultiThreaded.is (LabelInfo.multiThreaded li)
283	then ()
284	else (forceMultiThreadedBlock block ;
285	Transfer.foreachLabel
286	(transfer, fn l =>
287	forceMultiThreadedBlockDFS controlFlow
288	(nodeBlock (labelNode l))))
289	end
290	val rec forceMultiUsedBlock
291	= fn Block.T {label, args, statements, transfer} =>
292	let
293	val li = labelInfo label
294	in
295	if MultiUsed.is (LabelInfo.multiUsed li)
296	then ()
297	else (MultiUsed.force (LabelInfo.multiUsed li) ;
298	Vector.foreach (args, forceMultiUsedVar o #1) ;
299	Vector.foreach
300	(statements, fn Statement.T {var, ...} =>
301	Option.app (var, forceMultiUsedVar)) ;
302	Transfer.foreachFunc
303	(transfer, forceMultiUsedFunc))
304	end
305	val rec visitBlock
306	= fn controlFlow as {graph = _, labelNode, nodeBlock} =>
307	fn Block.T {label, transfer, ...} =>
308	if ThreadCopyCurrent.does (LabelInfo.threadCopyCurrent (labelInfo label))
309	then Transfer.foreachLabel
310	(transfer, fn l =>
311	forceMultiThreadedBlockDFS controlFlow
312	(nodeBlock (labelNode l)))
313	else ()
314	val rec visitForceMultiUsedBlock
315	= fn controlFlow =>
316	fn block =>
317	(forceMultiUsedBlock block ;
318	visitBlock controlFlow block)
319
320	val rec forceMultiThreadedFunc
321	= fn f =>
322	let
323	val {args, blocks, ...} = Function.dest f
324	in
325	Vector.foreach
326	(args, forceMultiThreadedVar o #1) ;
327	Vector.foreach
328	(blocks, forceMultiThreadedBlock)
329	end
330	val rec forceMultiUsedFunc
331	= fn f =>
332	let
333	val {args, blocks, ...} = Function.dest f
334	in
335	Vector.foreach
336	(args, forceMultiUsedVar o #1) ;
337	Vector.foreach
338	(blocks, forceMultiUsedBlock)
339	end
340
341	fun visitFunc multiUsed f
342	= let
343	val _ = remFuncNode (Function.name f)
344
345	val fi = funcInfo (Function.name f)
346	val _ = if multiUsed
347	orelse
348	Calls.isMany (FuncInfo.calls fi)
349	then MultiUsed.force (FuncInfo.multiUsed fi)
350	else ()
351	in
352	if MultiThreaded.is (FuncInfo.multiThreaded fi)
353	then forceMultiThreadedFunc f
354	else if MultiUsed.is (FuncInfo.multiUsed fi)
355	then (forceMultiUsedFunc f ;
356	if usesThreadsOrConts
357	then let
358	val _ = MultiThreaded.when
359	(FuncInfo.multiThreaded fi,
360	fn () => forceMultiThreadedFunc f)
361	val controlFlow = Function.controlFlow f
362	in
363	Vector.foreach
364	(Function.blocks f, visitBlock controlFlow)
365	end
366	else ())
367	else if usesThreadsOrConts
368	then let
369	val _ = MultiThreaded.when
370	(FuncInfo.multiThreaded fi,
371	fn () => forceMultiThreadedFunc f)
372	val _ = MultiUsed.when
373	(FuncInfo.multiUsed fi,
374	fn () => forceMultiUsedFunc f)
375	val controlFlow as {graph, nodeBlock, ...}
376	= Function.controlFlow f
377	in
378	List.foreach
379	(Graph.stronglyConnectedComponents graph,
380	fn [] => ()
381	\| [n] => if Node.hasEdge {from = n, to = n}
382	then visitForceMultiUsedBlock controlFlow
383	(nodeBlock n)
384	else visitBlock controlFlow
385	(nodeBlock n)
386	\| ns => List.foreach
387	(ns, fn n =>
388	visitForceMultiUsedBlock controlFlow
389	(nodeBlock n)))
390	end
391	else let
392	val _ = MultiUsed.when
393	(FuncInfo.multiUsed fi,
394	fn () => forceMultiUsedFunc f)
395	val {graph, nodeBlock, ...} = Function.controlFlow f
396	in
397	List.foreach
398	(Graph.stronglyConnectedComponents graph,
399	fn [] => ()
400	\| [n] => if Node.hasEdge {from = n, to = n}
401	then forceMultiUsedBlock (nodeBlock n)
402	else ()
403	\| ns => List.foreach
404	(ns, fn n =>
405	forceMultiUsedBlock (nodeBlock n)))
406	end
407	end
408
409	val _ = List.foreach
410	(Graph.stronglyConnectedComponents G,
411	fn [] => ()
412	\| [n] =>
413	visitFunc (Node.hasEdge {from = n, to = n}) (nodeFunction n)
414	\| ns => List.foreach
415	(ns, fn n =>
416	visitFunc true (nodeFunction n)))
417
418	(*
419	val _ = Control.diagnostics
420	(fn display =>
421	let open Layout
422	in
423	display (Layout.str "\n\nMulti:") ;
424	display (seq [Layout.str "usesThreadsOrConts: ",
425	Bool.layout usesThreadsOrConts]) ;
426	List.foreach
427	(functions, fn f =>
428	let
429	val {name = f, blocks, ...} = Function.dest f
430	in
431	display (seq [Func.layout f,
432	str ": ",
433	FuncInfo.layout (funcInfo f)]) ;
434	Vector.foreach
435	(blocks, fn Block.T {label, ...} =>
436	display (seq [Label.layout label,
437	str ": ",
438	LabelInfo.layout (labelInfo label)]))
439	end)
440	end)
441	*)
442	in
443	{
444	usesThreadsOrConts = usesThreadsOrConts,
445
446	funcDoesThreadCopyCurrent
447	= ThreadCopyCurrent.does o FuncInfo.threadCopyCurrent o funcInfo,
448	funcIsMultiThreaded
449	= MultiThreaded.is o FuncInfo.multiThreaded o funcInfo,
450	funcIsMultiUsed
451	= MultiUsed.is o FuncInfo.multiUsed o funcInfo,
452
453	labelDoesThreadCopyCurrent
454	= ThreadCopyCurrent.does o LabelInfo.threadCopyCurrent o labelInfo,
455	labelIsMultiThreaded
456	= MultiThreaded.is o LabelInfo.multiThreaded o labelInfo,
457	labelIsMultiUsed
458	= MultiUsed.is o LabelInfo.multiUsed o labelInfo,
459
460	varIsMultiDefed
461	= MultiUsed.is o VarInfo.multiUsed o varInfo
462	}
463	end
464	end