1 (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
2 * Jagannathan, and Stephen Weeks.
3 * Copyright (C) 1997-2000 NEC Research Institute.
5 * MLton is released under a BSD-style license.
6 * See the file MLton-LICENSE for details.
9 functor x86LoopInfo(S: X86_LOOP_INFO_STRUCTS) : X86_LOOP_INFO =
14 structure Graph = DirectedGraph
15 structure Node = Graph.Node
16 structure LoopForest = Graph.LoopForest
18 val tracer = x86.tracer
20 datatype t = T of {getLoopInfo : Label.t ->
22 loopLabels: Label.t list,
25 fun createLoopInfo {chunk = Chunk.T {blocks, ...}, farLoops}
29 val {get = getNodeInfo : unit Node.t -> Label.t,
30 set = setNodeInfo, ...}
33 Property.initRaise ("x86LoopInfo:getNodeInfo", Node.layout))
35 val {get = getInfo : Label.t -> unit Node.t,
39 Property.initFun (fn l => let
40 val n = Graph.newNode G
41 val _ = setNodeInfo(n, l)
46 val {get = getLoopInfo :
49 loopLabels: Label.t list,
51 set = setLoopInfo, ...}
54 Property.initRaise ("x86LoopInfo:getLoopInfo", Label.layout))
56 val rootLabel = Label.newString "root"
57 val root = getInfo rootLabel
60 = ignore (Graph.addEdge (G, edge))
65 fn Block.T {entry, transfer, ...}
67 val label = Entry.label entry
68 val node = getInfo label
72 val node' = getInfo target
74 addEdge {from = node, to = node'}
78 val node' = getInfo target
81 then addEdge {from = node, to = node'}
82 else addEdge {from = root, to = node'}
85 datatype z = datatype Transfer.t
88 then addEdge {from = root, to = node}
93 | Iff {truee, falsee, ...}
96 | Switch {cases, default, ...}
98 Transfer.Cases.foreach(cases, doit' o #2))
101 | NonTail {return, handler, ...}
104 of SOME handler => doit'' handler
110 | CCall {return, func, ...}
111 => Option.app (return, if CFunction.mayGC func
117 val lf = Graph.loopForestSteensgaard (G, {root = root})
119 fun doit (f: unit LoopForest.t,
123 val {loops, notInLoop} = LoopForest.dest f
124 val notInLoop = Vector.toListMap (notInLoop, getNodeInfo)
125 val path' = List.rev path
130 (l, {loopHeader = Vector.contains (headers, l, Label.equals),
131 loopLabels = notInLoop,
132 loopPath = path'})) ;
134 (loops, fn (i,{headers, child}) =>
136 Vector.map (headers, getNodeInfo),
139 val _ = doit (lf, Vector.new0 (), [])
141 T {getLoopInfo = getLoopInfo}
144 val (createLoopInfo, createLoopInfo_msg)
149 fun getLoopDistance (T {getLoopInfo, ...}, from, to)
150 = (case (#loopPath (getLoopInfo from), #loopPath (getLoopInfo to))
156 = fn ([], pto) => SOME (List.length pto)
157 | (pfrom, []) => SOME (~(List.length pfrom))
160 then check (pfrom, pto)
165 fun getLoopLabels (T {getLoopInfo, ...}, label) = #loopLabels (getLoopInfo label)
166 fun isLoopHeader (T {getLoopInfo, ...}, l) = #loopHeader (getLoopInfo l)