comparison lab4/jumpopt.ml @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:bfdcc3820b32
1 (* lab4/jumpopt.ml *)
2 (* Copyright (c) 2017 J. M. Spivey *)
3
4 open Optree
5
6 (* Disjoint sets of labels *)
7
8 type labdata =
9 LabDef of labrec (* An extant label *)
10 | Equiv of codelab (* A label that's been merged *)
11
12 and labrec =
13 { y_id : codelab; (* Name of the label *)
14 y_refct : int ref } (* Reference count *)
15
16 let label_tab = Hashtbl.create 257
17
18 (* |get_label| -- find or create a label *)
19 let get_label x =
20 try Hashtbl.find label_tab x with
21 Not_found ->
22 let y = LabDef { y_id = x; y_refct = ref 0 } in
23 Hashtbl.add label_tab x y; y
24
25 (* |find_label| -- find equivalent of a label *)
26 let rec find_label x =
27 match get_label x with
28 LabDef y -> y
29 | Equiv x' -> find_label x'
30
31 let rename x = let y = find_label x in y.y_id
32
33 let ref_count x = let y = find_label x in y.y_refct
34
35 (* same_lab -- test if two labels are equal *)
36 let same_lab x1 x2 =
37 let y1 = find_label x1 and y2 = find_label x2 in
38 y1.y_id = y2.y_id
39
40 (* equate -- make two labels equal *)
41 let equate x1 x2 =
42 let y1 = find_label x1 and y2 = find_label x2 in
43 if y1.y_id = y2.y_id then failwith "equate";
44 y2.y_refct := !(y1.y_refct) + !(y2.y_refct);
45 Hashtbl.add label_tab y1.y_id (Equiv y2.y_id)
46
47 (* do_refs -- call function on each label *)
48 let do_refs f =
49 function
50 <JUMP x> -> f (ref_count x)
51 | <JUMPC (w, x), _, _> -> f (ref_count x)
52 | <JCASE (labs, def), _> ->
53 List.iter (fun x -> f (ref_count x)) labs;
54 f (ref_count def)
55 | _ -> ()
56
57 (* rename_labs -- replace each label by its equivalent *)
58 let rename_labs =
59 function
60 <LABEL x> -> <LABEL (rename x)>
61 | <JUMP x> -> <JUMP (rename x)>
62 | <JUMPC (w, x), t1, t2> -> <JUMPC (w, rename x), t1, t2>
63 | <JCASE (labs, def), t1> ->
64 <JCASE (List.map rename labs, rename def), t1>
65 | t -> t
66
67 (* optstep -- optimise to fixpoint at current location *)
68 let optstep changed code =
69 let ch = ref true in
70
71 let replace n inserted =
72 changed := true; ch := true;
73 let deleted = Util.take n !code in
74 List.iter (do_refs decr) deleted;
75 List.iter (do_refs incr) inserted;
76 code := inserted @ Util.drop n !code in
77
78 let delete n = replace (n+1) (Util.take n !code) in
79
80 while !ch do
81 ch := false;
82 match !code with
83 <JUMP lab1> :: <LABEL lab2> :: _ ->
84 (* Remove a jump to the next instruction *)
85 if same_lab lab1 lab2 then delete 0
86 | <JUMP lab1> :: <LINE n> :: <LABEL lab2> :: _ ->
87 (* Keep a potentially useful line number *)
88 replace 3 [<JUMP lab1>; <LABEL lab2>; <LINE n>]
89 | <JUMP lab> :: _ :: _ ->
90 (* Eliminate dead code *)
91 delete 1
92 | <JUMPC (w, lab1), t1, t2> :: <JUMP lab2> :: <LABEL lab3> :: _ ->
93 (* Simplify a jump over a jump *)
94 if same_lab lab1 lab3 then
95 replace 2 [<JUMPC (negate w, lab2), t1, t2>]
96 | <LABEL lab1> :: <JUMP lab2> :: _ ->
97 (* One jump leads to another *)
98 if not (same_lab lab1 lab2) then begin
99 delete 0; equate lab1 lab2
100 end
101 | <LABEL lab1> :: <LABEL lab2> :: _ ->
102 (* Merge identical labels *)
103 delete 0; equate lab1 lab2
104 | <LABEL lab> :: _ ->
105 (* Delete unused labels *)
106 if !(ref_count lab) = 0 then delete 0
107
108 (* Tidy up line numbers *)
109 | <LINE m> :: <LINE n> :: _ ->
110 delete 0
111 | <LINE n> :: <LABEL lab> :: _ ->
112 replace 2 [<LABEL lab>; <LINE n>]
113 | <LINE n> :: <JUMP lab> :: _ ->
114 replace 2 [<JUMP lab>; <LINE n>]
115 | <LINE n> :: [] ->
116 delete 0
117 | <NOP> :: _ ->
118 delete 0
119
120 | _ -> ()
121 done
122
123 let optimise prog =
124 Hashtbl.clear label_tab;
125 let init = prog in
126 List.iter (do_refs incr) init;
127 let buf1 = ref init and buf2 = ref [] in
128 let changed = ref true in
129 while !changed do
130 changed := false;
131 while !buf1 <> [] do
132 optstep changed buf1;
133 if !buf1 <> [] then begin
134 buf2 := List.hd !buf1 :: !buf2;
135 buf1 := List.tl !buf1
136 end
137 done;
138 buf1 := List.rev !buf2;
139 buf2 := []
140 done;
141 List.map rename_labs !buf1
142