comparison ppc/peepopt.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 (* ppc/peepopt.ml *)
2 (* Copyright (c) 2017 J. M. Spivey *)
3
4 open Keiko
5 open Print
6
7 let debug = ref 0
8
9 (* Disjoint sets of labels *)
10
11 type lab_data =
12 LabDef of labrec (* An extant label *)
13 | Equiv of codelab (* A label that's been merged *)
14
15 and labrec =
16 { y_id: codelab; (* Name of the label *)
17 y_refct: int ref } (* Reference count *)
18
19 (* |label_tab| -- map labels to their equivalents *)
20 let label_tab = Hashtbl.create 257
21
22 (* |get_label| -- get equivalence cell for a label *)
23 let get_label x =
24 try !(Hashtbl.find label_tab x) with
25 Not_found ->
26 let y = LabDef { y_id = x; y_refct = ref 0 } in
27 Hashtbl.add label_tab x (ref y); y
28
29 (* |find_label| -- find data about equivalence class of a label *)
30 let rec find_label x =
31 match get_label x with
32 LabDef y -> y
33 | Equiv x' -> find_label x'
34
35 (* |rename| -- get canonical equivalent of a label *)
36 let rename x = let y = find_label x in y.y_id
37
38 (* |ref_count| -- get reference count cell for a label *)
39 let ref_count x = let y = find_label x in y.y_refct
40
41 (* |same_lab| -- test if two labels are equivalent *)
42 let same_lab x1 x2 = (rename x1 = rename x2)
43
44 (* |equate| -- make two labels equivalent *)
45 let equate x1 x2 =
46 let y1 = find_label x1 and y2 = find_label x2 in
47 if y1.y_id = y2.y_id then failwith "equate";
48 y2.y_refct := !(y1.y_refct) + !(y2.y_refct);
49 Hashtbl.find label_tab y1.y_id := Equiv y2.y_id
50
51 (* |do_refs| -- call function on refcount of each label in an instruction *)
52 let do_refs f =
53 function
54 JUMP x -> f (ref_count x)
55 | JUMPC (w, x) -> f (ref_count x)
56 | JUMPCZ (w, x) -> f (ref_count x)
57 | JCASE labs -> List.iter (fun x -> f (ref_count x)) labs
58 | _ -> ()
59
60 (* |rename_labs| -- replace each label by its equivalent *)
61 let rename_labs =
62 function
63 LABEL x -> LABEL (rename x)
64 | JUMP x -> JUMP (rename x)
65 | JUMPC (w, x) -> JUMPC (w, rename x)
66 | JUMPCZ (w, x) -> JUMPCZ (w, rename x)
67 | JCASE labs -> JCASE (List.map rename labs)
68 | i -> i
69
70 let opposite =
71 function Eq -> Neq | Neq -> Eq | Lt -> Geq
72 | Leq -> Gt | Gt -> Leq | Geq -> Lt
73 | _ -> failwith "opposite"
74
75 (* |ruleset| -- simplify and introduce abbreviations *)
76 let ruleset replace =
77 function
78 LOCAL a :: CONST b :: OFFSET :: _ ->
79 replace 3 [LOCAL (a+b)]
80 | CONST a :: OFFSET :: CONST b :: OFFSET :: _ ->
81 replace 4 [CONST (a+b); OFFSET]
82 | CONST 0 :: OFFSET :: _ ->
83 replace 2 []
84 | CONST a :: CONST b :: BINOP w :: _ ->
85 replace 3 [CONST (do_binop w a b)]
86
87 | LOCAL n :: LOAD s :: _ ->
88 replace 2 [LDL (n, s)]
89 | LOCAL n :: STORE s :: _ ->
90 replace 2 [STL (n, s)]
91 | LOCAL o :: LDNW n :: _ ->
92 replace 2 [LDL (o+n, 4)]
93 | LOCAL o :: STNW n :: _ ->
94 replace 2 [STL (o+n, 4)]
95 | GLOBAL x :: LOAD s :: _ ->
96 replace 2 [LDG (x, s)]
97 | GLOBAL x :: STORE s :: _ ->
98 replace 2 [STG (x, s)]
99 | CONST n :: OFFSET :: LOAD 4 :: _->
100 replace 3 [LDNW n]
101 | CONST n :: OFFSET :: STORE 4 :: _ ->
102 replace 3 [STNW n]
103 | CONST s :: BINOP Times :: OFFSET :: LOAD s1 :: _ when s = s1 ->
104 replace 4 [LDI s]
105 | CONST s :: BINOP Times :: OFFSET :: STORE s1 :: _ when s = s1 ->
106 replace 4 [STI s]
107
108 | CONST 0 :: JUMPC (w, lab) :: _ ->
109 replace 2 [JUMPCZ (w, lab)]
110
111 | LINE n :: LABEL a :: _ ->
112 replace 2 [LABEL a; LINE n]
113 | LINE n :: LINE m :: _ ->
114 replace 1 []
115 | LABEL a :: LABEL b :: _ ->
116 equate a b; replace 2 [LABEL a]
117 | LABEL a :: JUMP b :: _ when not (same_lab a b) ->
118 equate a b; replace 2 [JUMP b]
119 | JUMPC (w, a) :: JUMP b :: LABEL c :: _ when same_lab a c ->
120 replace 2 [JUMPC (opposite w, b)]
121 | JUMP a :: LABEL b :: _ when same_lab a b ->
122 replace 1 []
123 | JUMP a :: LABEL b :: _ ->
124 ()
125 | JUMP a :: _ :: _ ->
126 replace 2 [JUMP a]
127 | RETURN s :: LABEL a :: _ ->
128 ()
129 | RETURN s :: _ :: _ ->
130 replace 2 [RETURN s]
131 | LABEL a :: _ when !(ref_count a) = 0 ->
132 replace 1 []
133
134 | _ -> ()
135
136
137 (* |optstep| -- apply rules at one place in the buffer *)
138 let optstep rules changed code =
139 let ch = ref true in
140 let replace n c =
141 changed := true; ch := true;
142 if !debug > 0 then
143 printf "! $ --> $\n" [fList(fInst) (Util.take n !code); fList(fInst) c];
144 List.iter (do_refs decr) (Util.take n !code);
145 List.iter (do_refs incr) c;
146 code := c @ Util.drop n !code in
147 while !ch do
148 ch := false; rules replace !code
149 done
150
151 (* |rewrite| -- iterate over the code and apply rules *)
152 let rewrite rules prog =
153 let code1 = ref prog and code2 = ref [] in
154 let changed = ref true in
155 while !changed do
156 changed := false;
157 while !code1 <> [] do
158 optstep rules changed code1;
159 if !code1 <> [] then begin
160 code2 := rename_labs (List.hd !code1) :: !code2;
161 code1 := List.tl !code1
162 end
163 done;
164 code1 := List.rev !code2;
165 code2 := []
166 done;
167 !code1
168
169 (* |optimise| -- rewrite list of instructions *)
170 let optimise prog =
171 match Keiko.canon prog with
172 SEQ code ->
173 List.iter (do_refs incr) code;
174 let code2 = rewrite ruleset code in
175 Hashtbl.clear label_tab;
176 SEQ code2
177 | _ -> failwith "optimise"