Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
CertiCompil
CompCert-KVX
Commits
95f33ccc
Commit
95f33ccc
authored
Apr 13, 2021
by
Cyril SIX
Browse files
Merge remote-tracking branch 'origin/manuscript' into kvx-work
parents
4b61b098
294df98b
Pipeline
#68317
waiting for manual action with stage
Changes
5
Pipelines
2
Hide whitespace changes
Inline
Side-by-side
backend/Duplicateaux.ml
View file @
95f33ccc
...
...
@@ -340,120 +340,66 @@ let get_inner_loops f code is_loop_header =
)
(
PTree
.
elements
loopmap
)
end
let
get_loop_bodies
code
entrypoint
=
let
predecessors
=
get_predecessors_rtl
code
in
(* Algorithm from Muchnik, Compiler Design & Implementation, Figure 7.21 page 192 *)
let
natural_loop
n
m
=
debug
"Natural Loop from %d to %d
\n
"
(
P
.
to_int
n
)
(
P
.
to_int
m
);
let
in_body
=
ref
(
PTree
.
map
(
fun
n
b
->
false
)
code
)
in
let
body
=
ref
[]
in
let
add_to_body
n
=
begin
in_body
:=
PTree
.
set
n
true
!
in_body
;
body
:=
n
::
!
body
end
in
let
rec
process_node
p
=
debug
" Processing node %d
\n
"
(
P
.
to_int
p
);
List
.
iter
(
fun
pred
->
debug
" Looking at predecessor of %d: %d
\n
"
(
P
.
to_int
p
)
(
P
.
to_int
pred
);
let
is_in_body
=
get_some
@@
PTree
.
get
pred
!
in_body
in
if
(
not
@@
is_in_body
)
then
begin
debug
" --> adding to body
\n
"
;
add_to_body
pred
;
process_node
pred
end
)
(
get_some
@@
PTree
.
get
p
predecessors
)
in
begin
add_to_body
m
;
add_to_body
n
;
(
if
(
m
!=
n
)
then
process_node
m
);
!
body
end
in
let
option_natural_loop
n
=
function
|
None
->
None
|
Some
m
->
Some
(
natural_loop
n
m
)
in
PTree
.
map
option_natural_loop
(
LICMaux
.
get_loop_backedges
code
entrypoint
)
(* Returns a PTree of either None or Some b where b determines the node following the loop, for a cb instruction *)
(* It uses the fact that loops in CompCert are done by a branch (backedge) instruction followed by a cb *)
(* Returns a PTree of either None or Some b where b determines the node in the loop body, for a cb instruction *)
let
get_loop_info
f
is_loop_header
bfs_order
code
=
debug
"GET LOOP INFO
\n
"
;
debug
"==================================
\n
"
;
let
loop_info
=
ref
(
PTree
.
map
(
fun
n
i
->
None
)
code
)
in
let
mark_path
n
lbody
=
let
cb_info
=
ref
PTree
.
empty
in
let
visited
=
ref
(
PTree
.
map
(
fun
n
i
->
false
)
code
)
in
(* Returns true if there is a path from src to dest (not involving jumptables) *)
(* Mark nodes as visited along the way *)
let
explore
src
dest
=
debug
"Trying to dive a path from %d to %d
\n
"
(
P
.
to_int
src
)
(
P
.
to_int
dest
);
(* Memoizing the results to avoid exponential blow-up *)
let
memory
=
ref
PTree
.
empty
in
let
rec
explore_rec
src
=
debug
"explore_rec %d vs %d... "
(
P
.
to_int
src
)
(
P
.
to_int
dest
);
if
(
P
.
to_int
src
)
==
(
P
.
to_int
dest
)
then
(
debug
"FOUND
\n
"
;
true
)
else
if
(
get_some
@@
PTree
.
get
src
!
visited
)
then
(
debug
"VISITED... :(
\n
"
;
false
)
(* if we went out of the innermost loop *)
else
if
(
not
@@
List
.
mem
src
lbody
)
then
(
debug
"Out of innermost...
\n
"
;
false
)
else
begin
let
inst
=
get_some
@@
PTree
.
get
src
code
in
visited
:=
PTree
.
set
src
true
!
visited
;
match
rtl_successors
inst
with
|
[]
->
false
|
[
s
]
->
explore_wrap
s
|
[
s1
;
s2
]
->
let
snapshot_visited
=
ref
!
visited
in
begin
debug
"
\t\t
Split at %d: either %d or %d
\n
"
(
P
.
to_int
src
)
(
P
.
to_int
s1
)
(
P
.
to_int
s2
);
(* Remembering that we tried the ifso node *)
cb_info
:=
PTree
.
set
src
true
!
cb_info
;
match
explore_wrap
s1
with
|
true
->
(
visited
:=
!
snapshot_visited
;
match
explore_wrap
s2
with
|
true
->
begin
(* Both paths lead to a loop: we cannot predict the CB
* (but the explore still succeeds) *)
cb_info
:=
PTree
.
remove
src
!
cb_info
;
true
end
|
false
->
true
(* nothing to do, the explore succeeded *)
)
|
false
->
begin
cb_info
:=
PTree
.
set
src
false
!
cb_info
;
match
explore_wrap
s2
with
|
true
->
true
|
false
->
(
cb_info
:=
PTree
.
remove
src
!
cb_info
;
false
)
end
end
|
_
->
false
let
mark_body
body
=
List
.
iter
(
fun
n
->
match
get_some
@@
PTree
.
get
n
code
with
|
Icond
(
_
,
_
,
ifso
,
ifnot
,
_
)
->
begin
match
PTree
.
get
n
!
loop_info
with
|
None
->
()
|
Some
_
->
let
b1
=
List
.
mem
ifso
body
in
let
b2
=
List
.
mem
ifnot
body
in
if
(
b1
&&
b2
)
then
()
else
if
(
b1
||
b2
)
then
begin
if
b1
then
loop_info
:=
PTree
.
set
n
(
Some
true
)
!
loop_info
else
if
b2
then
loop_info
:=
PTree
.
set
n
(
Some
false
)
!
loop_info
end
end
and
explore_wrap
src
=
begin
match
PTree
.
get
src
!
memory
with
|
Some
b
->
b
|
None
->
let
result
=
explore_rec
src
in
(
memory
:=
PTree
.
set
src
result
!
memory
;
result
)
end
in
explore_wrap
src
(* Goes forward until a CB is encountered
* Returns None if no CB was found, or Some the_cb_node
* Marks nodes as visited along the way *)
in
let
rec
advance_to_cb
src
=
if
(
get_some
@@
PTree
.
get
src
!
visited
)
then
None
else
begin
visited
:=
PTree
.
set
src
true
!
visited
;
match
get_some
@@
PTree
.
get
src
code
with
|
Inop
s
|
Iop
(
_
,
_
,
_
,
s
)
|
Iload
(
_
,_,_,_,_,
s
)
|
Istore
(
_
,_,_,_,
s
)
|
Icall
(
_
,_,_,_,
s
)
|
Ibuiltin
(
_
,_,_,
s
)
->
advance_to_cb
s
|
Icond
_
->
Some
src
|
Ijumptable
_
|
Itailcall
_
|
Ireturn
_
->
None
end
in
begin
debug
"Attempting to find natural loop from HEAD %d..
\n
"
(
P
.
to_int
n
);
match
advance_to_cb
n
with
|
None
->
(
debug
"
\t
No CB found
\n
"
)
|
Some
s
->
(
debug
"
\t
Found a CB! %d
\n
"
(
P
.
to_int
s
);
match
get_some
@@
PTree
.
get
s
!
loop_info
with
|
None
|
Some
_
->
begin
match
get_some
@@
PTree
.
get
s
code
with
|
Icond
(
_
,
_
,
n1
,
n2
,
_
)
->
(
let
b1
=
explore
n1
n
in
let
b2
=
explore
n2
n
in
if
(
b1
&&
b2
)
then
debug
"
\t
Both paths lead back to the head: NONE
\n
"
else
if
(
b1
||
b2
)
then
begin
if
b1
then
begin
debug
"
\t
True path leads to the head: TRUE
\n
"
;
loop_info
:=
PTree
.
set
s
(
Some
true
)
!
loop_info
;
end
else
if
b2
then
begin
debug
"
\t
False path leads to the head: FALSE
\n
"
;
loop_info
:=
PTree
.
set
s
(
Some
false
)
!
loop_info
end
;
debug
"
\t
Setting other CBs encountered..
\n
"
;
List
.
iter
(
fun
(
cb
,
dir
)
->
debug
"
\t\t
%d is %B
\n
"
(
P
.
to_int
cb
)
dir
;
loop_info
:=
PTree
.
set
cb
(
Some
dir
)
!
loop_info
)
(
PTree
.
elements
!
cb_info
)
end
else
debug
"
\t
No path leads back to the head: NONE
\n
"
)
|
_
->
failwith
"
\t
Not an Icond
\n
"
end
(* | Some _ -> ( debug "already loop info there\n" ) FIXME - we don't know yet whether a branch to a loop head is a backedge or not *)
)
end
in
let
iloops
=
get_inner_loops
f
code
is_loop_header
in
begin
List
.
iter
(
fun
il
->
mark_path
il
.
head
il
.
body
)
iloops
;
(* List.iter mark_path @@ List.filter (fun n -> get_some @@ PTree.get n is_loop_header) bfs_order; *)
debug
"==================================
\n
"
;
!
loop_info
end
|
_
->
()
)
body
in
let
bodymap
=
get_loop_bodies
code
f
.
fn_entrypoint
in
List
.
iter
(
fun
(
_
,
obody
)
->
match
obody
with
|
None
->
()
|
Some
body
->
mark_body
body
)
(
PTree
.
elements
bodymap
);
!
loop_info
(* Remark - compared to the original Branch Prediction for Free paper, we don't use the store heuristic *)
let
get_directions
f
code
entrypoint
=
begin
...
...
backend/LICMaux.ml
View file @
95f33ccc
...
...
@@ -41,24 +41,25 @@ let rtl_successors = function
*
* If we come accross an edge to a Processed node, it's a loop!
*)
let
get_loop_
header
s
code
entrypoint
=
begin
debug
"get_loop_
header
s
\n
"
;
let
get_loop_
backedge
s
code
entrypoint
=
begin
debug
"get_loop_
backedge
s
\n
"
;
let
visited
=
ref
(
PTree
.
map
(
fun
n
i
->
Unvisited
)
code
)
and
is_
loop_
header
=
ref
(
PTree
.
map
(
fun
n
i
->
fals
e
)
code
)
in
let
rec
dfs_visit
code
=
function
and
loop_
backedge
=
ref
(
PTree
.
map
(
fun
n
i
->
Non
e
)
code
)
in
let
rec
dfs_visit
code
origin
=
function
|
[]
->
()
|
node
::
ln
->
debug
"ENTERING node %d, REM are %a
\n
"
(
P
.
to_int
node
)
print_intlist
ln
;
match
(
get_some
@@
PTree
.
get
node
!
visited
)
with
|
Visited
->
begin
debug
"
\t
Node %d is already Visited, skipping
\n
"
(
P
.
to_int
node
);
dfs_visit
code
ln
dfs_visit
code
origin
ln
end
|
Processed
->
begin
debug
"Node %d is a loop header
\n
"
(
P
.
to_int
node
);
is_loop_header
:=
PTree
.
set
node
true
!
is_loop_header
;
debug
"The backedge is from %d
\n
"
(
P
.
to_int
@@
get_some
origin
);
loop_backedge
:=
PTree
.
set
node
origin
!
loop_backedge
;
visited
:=
PTree
.
set
node
Visited
!
visited
;
dfs_visit
code
ln
dfs_visit
code
origin
ln
end
|
Unvisited
->
begin
visited
:=
PTree
.
set
node
Processed
!
visited
;
...
...
@@ -67,19 +68,26 @@ let get_loop_headers code entrypoint = begin
|
None
->
failwith
"No such node"
|
Some
i
->
let
next_visits
=
rtl_successors
i
in
begin
debug
"About to visit: %a
\n
"
print_intlist
next_visits
;
dfs_visit
code
next_visits
dfs_visit
code
(
Some
node
)
next_visits
end
);
debug
"Node %d is Visited!
\n
"
(
P
.
to_int
node
);
visited
:=
PTree
.
set
node
Visited
!
visited
;
dfs_visit
code
ln
dfs_visit
code
origin
ln
end
in
begin
dfs_visit
code
[
entrypoint
];
debug
"LOOP
HEADER
S: %a
\n
"
print_ptree_
bool
!
is_loop_header
;
!
is_
loop_
header
dfs_visit
code
None
[
entrypoint
];
debug
"LOOP
BACKEDGE
S: %a
\n
"
print_ptree_
opint
!
loop_backedge
;
!
loop_
backedge
end
end
let
get_loop_headers
code
entrypoint
=
let
backedges
=
get_loop_backedges
code
entrypoint
in
PTree
.
map
(
fun
_
ob
->
match
ob
with
|
None
->
false
|
Some
_
->
true
)
backedges
module
Dominator
=
struct
...
...
backend/Linearizeaux.ml
View file @
95f33ccc
...
...
@@ -126,400 +126,64 @@ let enumerate_aux_flat f reach =
* This is a slight alteration to the above heuristic, ensuring that any
* superblock will be contiguous in memory, while still following the original
* heuristic
*
* Slight change: instead of taking the minimum pc of the superblock, we just take
* the pc of the first block.
* (experimentally this leads to slightly better performance..)
*)
let
get_some
=
function
|
None
->
failwith
"Did not get some"
|
Some
thing
->
thing
exception
EmptyList
let
rec
last_element
=
function
|
[]
->
raise
EmptyList
|
e
::
[]
->
e
|
e'
::
e
::
l
->
last_element
(
e
::
l
)
let
print_plist
l
=
let
rec
f
=
function
|
[]
->
()
|
n
::
l
->
Printf
.
printf
"%d, "
(
P
.
to_int
n
);
f
l
in
begin
if
!
debug_flag
then
begin
Printf
.
printf
"["
;
f
l
;
Printf
.
printf
"]"
end
end
(* adapted from the above join_points function, but with PTree *)
let
get_join_points
code
entry
=
let
reached
=
ref
(
PTree
.
map
(
fun
n
i
->
false
)
code
)
in
let
reached_twice
=
ref
(
PTree
.
map
(
fun
n
i
->
false
)
code
)
in
let
rec
traverse
pc
=
if
get_some
@@
PTree
.
get
pc
!
reached
then
begin
if
not
(
get_some
@@
PTree
.
get
pc
!
reached_twice
)
then
reached_twice
:=
PTree
.
set
pc
true
!
reached_twice
end
else
begin
reached
:=
PTree
.
set
pc
true
!
reached
;
traverse_succs
(
successors_block
@@
get_some
@@
PTree
.
get
pc
code
)
end
and
traverse_succs
=
function
|
[]
->
()
|
[
pc
]
->
traverse
pc
|
pc
::
l
->
traverse
pc
;
traverse_succs
l
in
traverse
entry
;
!
reached_twice
let
forward_sequences
code
entry
=
let
visited
=
ref
(
PTree
.
map
(
fun
n
i
->
false
)
code
)
in
let
join_points
=
get_join_points
code
entry
in
(* returns the list of traversed nodes, and a list of nodes to start traversing next *)
let
rec
traverse_fallthrough
code
node
=
(* debug "Traversing %d..\n" (P.to_int node); *)
if
not
(
get_some
@@
PTree
.
get
node
!
visited
)
then
begin
visited
:=
PTree
.
set
node
true
!
visited
;
match
PTree
.
get
node
code
with
|
None
->
failwith
"No such node"
|
Some
bb
->
let
ln
,
rem
=
match
(
last_element
bb
)
with
|
Lop
_
|
Lload
_
|
Lgetstack
_
|
Lsetstack
_
|
Lstore
_
|
Lcall
_
|
Lbuiltin
_
->
assert
false
|
Ltailcall
_
|
Lreturn
->
begin
(* debug "STOP tailcall/return\n"; *)
([]
,
[]
)
end
|
Lbranch
n
->
if
get_some
@@
PTree
.
get
n
join_points
then
([]
,
[
n
])
else
let
ln
,
rem
=
traverse_fallthrough
code
n
in
(
ln
,
rem
)
|
Lcond
(
_
,
_
,
ifso
,
ifnot
,
info
)
->
(
match
info
with
|
None
->
begin
(* debug "STOP Lcond None\n"; *)
([]
,
[
ifso
;
ifnot
])
end
|
Some
false
->
if
get_some
@@
PTree
.
get
ifnot
join_points
then
([]
,
[
ifso
;
ifnot
])
else
let
ln
,
rem
=
traverse_fallthrough
code
ifnot
in
(
ln
,
[
ifso
]
@
rem
)
|
Some
true
->
if
get_some
@@
PTree
.
get
ifso
join_points
then
([]
,
[
ifso
;
ifnot
])
else
let
ln
,
rem
=
traverse_fallthrough
code
ifso
in
(
ln
,
[
ifnot
]
@
rem
)
)
|
Ljumptable
(
_
,
ln
)
->
begin
(* debug "STOP Ljumptable\n"; *)
([]
,
ln
)
end
in
([
node
]
@
ln
,
rem
)
end
else
([]
,
[]
)
in
let
rec
f
code
=
function
|
[]
->
[]
|
node
::
ln
->
let
fs
,
rem_from_node
=
traverse_fallthrough
code
node
in
[
fs
]
@
((
f
code
rem_from_node
)
@
(
f
code
ln
))
in
(
f
code
[
entry
])
(** Unused code
module PInt = struct
type t = P.t
let compare x y = compare (P.to_int x) (P.to_int y)
end
module PSet = Set.Make(PInt)
module LPInt = struct
type t = P.t list
let rec compare x y =
match x with
| [] -> ( match y with
| [] -> 0
| _ -> 1 )
| e :: l -> match y with
| [] -> -1
| e' :: l' ->
let e_cmp = PInt.compare e e' in
if e_cmp == 0 then compare l l' else e_cmp
end
module LPSet = Set.Make(LPInt)
let iter_lpset f s = Seq.iter f (LPSet.to_seq s)
let first_of = function
| [] -> None
| e :: l -> Some e
let rec last_of = function
| [] -> None
| e :: l -> (match l with [] -> Some e | e :: l -> last_of l)
let can_be_merged code s s' =
let last_s = get_some @@ last_of s in
let first_s' = get_some @@ first_of s' in
match get_some @@ PTree.get last_s code with
| Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _
| Lbuiltin _ | Ltailcall _ | Lreturn -> false
| Lbranch n -> n == first_s'
| Lcond (_, _, ifso, ifnot, info) -> (match info with
| None -> false
| Some false -> ifnot == first_s'
| Some true -> failwith "Inconsistency detected - ifnot is not the preferred branch")
| Ljumptable (_, ln) ->
match ln with
| [] -> false
| n :: ln -> n == first_s'
let merge s s' = Some s
let try_merge code (fs: (BinNums.positive list) list) =
let seqs = ref (LPSet.of_list fs) in
let oldLength = ref (LPSet.cardinal !seqs) in
let continue = ref true in
let found = ref false in
while !continue do
begin
found := false;
iter_lpset (fun s ->
if !found then ()
else iter_lpset (fun s' ->
if (!found || s == s') then ()
else if (can_be_merged code s s') then
begin
seqs := LPSet.remove s !seqs;
seqs := LPSet.remove s' !seqs;
seqs := LPSet.add (get_some (merge s s')) !seqs;
found := true;
end
else ()
) !seqs
) !seqs;
if !oldLength == LPSet.cardinal !seqs then
continue := false
else
oldLength := LPSet.cardinal !seqs
end
done;
!seqs
*)
(** Code adapted from Duplicateaux.get_loop_headers
*
* Getting loop branches with a DFS visit :
* Each node is either Unvisited, Visited, or Processed
* pre-order: node becomes Processed
* post-order: node becomes Visited
*
* If we come accross an edge to a Processed node, it's a loop!
*)
type
pos
=
BinNums
.
positive
module
PP
=
struct
type
t
=
pos
*
pos
let
compare
a
b
=
let
ax
,
ay
=
a
in
let
bx
,
by
=
b
in
let
dx
=
compare
ax
bx
in
if
(
dx
==
0
)
then
compare
ay
by
else
dx
end
module
PPMap
=
Map
.
Make
(
PP
)
type
vstate
=
Unvisited
|
Processed
|
Visited
let
get_loop_edges
code
entry
=
let
visited
=
ref
(
PTree
.
map
(
fun
n
i
->
Unvisited
)
code
)
in
let
is_loop_edge
=
ref
PPMap
.
empty
in
let
rec
dfs_visit
code
from
=
function
|
[]
->
()
|
node
::
ln
->
match
(
get_some
@@
PTree
.
get
node
!
visited
)
with
|
Visited
->
()
|
Processed
->
begin
let
from_node
=
get_some
from
in
is_loop_edge
:=
PPMap
.
add
(
from_node
,
node
)
true
!
is_loop_edge
;
visited
:=
PTree
.
set
node
Visited
!
visited
end
|
Unvisited
->
begin
visited
:=
PTree
.
set
node
Processed
!
visited
;
let
bb
=
get_some
@@
PTree
.
get
node
code
in
let
next_visits
=
(
match
(
last_element
bb
)
with
|
Lop
_
|
Lload
_
|
Lgetstack
_
|
Lsetstack
_
|
Lstore
_
|
Lcall
_
|
Lbuiltin
_
->
assert
false
|
Ltailcall
_
|
Lreturn
->
[]
|
Lbranch
n
->
[
n
]
|
Lcond
(
_
,
_
,
ifso
,
ifnot
,
_
)
->
[
ifso
;
ifnot
]
|
Ljumptable
(
_
,
ln
)
->
ln
)
in
dfs_visit
code
(
Some
node
)
next_visits
;
visited
:=
PTree
.
set
node
Visited
!
visited
;
dfs_visit
code
from
ln
end
in
begin
dfs_visit
code
None
[
entry
];
!
is_loop_edge
end
let
ppmap_is_true
pp
ppmap
=
PPMap
.
mem
pp
ppmap
&&
PPMap
.
find
pp
ppmap
module
Int
=
struct
type
t
=
int
let
compare
x
y
=
compare
x
y
end
module
ISet
=
Set
.
Make
(
Int
)
let
print_iset
s
=
begin
if
!
debug_flag
then
begin
Printf
.
printf
"{"
;
ISet
.
iter
(
fun
e
->
Printf
.
printf
"%d, "
e
)
s
;
Printf
.
printf
"}"
end
end
let
print_depmap
dm
=
begin
if
!
debug_flag
then
begin
Printf
.
printf
"[|"
;
Array
.
iter
(
fun
s
->
print_iset
s
;
Printf
.
printf
", "
)
dm
;
Printf
.
printf
"|]
\n
"
end
end
let
construct_depmap
code
entry
fs
=
let
is_loop_edge
=
get_loop_edges
code
entry
in
let
visited
=
ref
(
PTree
.
map
(
fun
n
i
->
false
)
code
)
in
let
depmap
=
Array
.
map
(
fun
e
->
ISet
.
empty
)
fs
in
let
find_index_of_node
n
=
let
index
=
ref
0
in
begin
Array
.
iteri
(
fun
i
s
->
match
List
.
find_opt
(
fun
e
->
e
==
n
)
s
with
|
Some
_
->
index
:=
i
|
None
->
()
)
fs
;
!
index
end
in
let
check_and_update_depmap
from
target
=
(* debug "From %d to %d\n" (P.to_int from) (P.to_int target); *)
if
not
(
ppmap_is_true
(
from
,
target
)
is_loop_edge
)
then
let
in_index_fs
=
find_index_of_node
from
in
let
out_index_fs
=
find_index_of_node
target
in
if
out_index_fs
!=
in_index_fs
then
depmap
.
(
out_index_fs
)
<-
ISet
.
add
in_index_fs
depmap
.
(
out_index_fs
)
else
()
else
()
in
let
rec
dfs_visit
code
=
function
|
[]
->
()
|
node
::
ln
->
begin
match
(
get_some
@@
PTree
.
get
node
!
visited
)
with
|
true
->
()
|
false
->
begin
visited
:=
PTree
.
set
node
true
!
visited
;
let
bb
=
get_some
@@
PTree
.
get
node
code
in
let
next_visits
=
match
(
last_element
bb
)
with
|
Ltailcall
_
|
Lreturn
->
[]
|
Lbranch
n
->
(
check_and_update_depmap
node
n
;
[
n
])
|
Lcond
(
_
,
_
,
ifso
,
ifnot
,
_
)
->
begin
check_and_update_depmap
node
ifso
;
check_and_update_depmap
node
ifnot
;
[
ifso
;
ifnot
]
end
|
Ljumptable
(
_
,
ln
)
->
begin
List
.
iter
(
fun
n
->
check_and_update_depmap
node
n
)
ln
;
ln
end
(* end of bblocks should not be another value than one of the above *)
|
_
->
failwith
"last_element gave an invalid output"
in
dfs_visit
code
next_visits
end
;
dfs_visit
code
ln
end
in
begin
dfs_visit
code
[
entry
];
depmap
end
let
print_sequence
s
=
if
!
debug_flag
then
begin
Printf
.
printf
"["
;
List
.
iter
(
fun
n
->
Printf
.
printf
"%d, "
(
P
.
to_int
n
))
s
;
Printf
.
printf
"]
\n
"
end
let
print_ssequence
ofs
=
if
!
debug_flag
then
begin
Printf
.
printf
"["
;
List
.
iter
(
fun
s
->
print_sequence
s
)
ofs
;
Printf
.
printf
"]
\n
"
end
let
order_sequences
code
entry
fs
=
let
fs_a
=
Array
.
of_list
fs
in
let
depmap
=
construct_depmap
code
entry
fs_a
in
let
fs_evaluated
=
Array
.
map
(
fun
e
->
false
)
fs_a
in
let
ordered_fs
=
ref
[]
in
let
evaluate
s_id
=
begin
assert
(
not
fs_evaluated
.
(
s_id
));
ordered_fs
:=
fs_a
.
(
s_id
)
::
!
ordered_fs
;
fs_evaluated
.
(
s_id
)
<-
true
;
(* debug "++++++\n";
debug "Scheduling %d\n" s_id;
debug "Initial depmap: "; print_depmap depmap; *)
Array
.
iteri
(
fun
i
deps
->
depmap
.
(
i
)
<-
ISet
.
remove
s_id
deps
)
depmap
;
(* debug "Final depmap: "; print_depmap depmap; *)
let
super_blocks
f
joins
=
let
blocks
=
ref
[]
in
let
visited
=
ref
IntSet
.
empty
in
(* start_block:
pc is the function entry point
or a join point
or the successor of a conditional test *)
let
rec
start_block
pc
=
let
npc
=
P
.
to_int
pc
in
if
not
(
IntSet
.
mem
npc
!
visited
)
then
begin
visited
:=
IntSet
.
add
npc
!
visited
;
in_block
[]
npc
pc
end
in
let
choose_best_of
candidates
=
let
current_best_id
=
ref
None
in
let
current_best_score
=
ref
None
in
begin
List
.
iter
(
fun
id
->