comparison lab3/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 | CASEARM (n, x) -> f (ref_count x)
57 | _ -> ()
58
59 (* |rename_labs| -- replace each label by its equivalent *)
60 let rename_labs =
61 function
62 LABEL x -> LABEL (rename x)
63 | JUMP x -> JUMP (rename x)
64 | JUMPC (w, x) -> JUMPC (w, rename x)
65 | CASEARM (n, x) -> CASEARM (n, rename x)
66 | i -> i
67
68 let opposite =
69 function Eq -> Neq | Neq -> Eq | Lt -> Geq
70 | Leq -> Gt | Gt -> Leq | Geq -> Lt
71 | _ -> failwith "opposite"
72
73 (* |ruleset| -- simplify and introduce abbreviations *)
74 let ruleset replace =
75 function
76 LOCAL a :: CONST b :: OFFSET :: _ ->
77 replace 3 [LOCAL (a+b)]
78 | CONST a :: OFFSET :: CONST b :: OFFSET :: _ ->
79 replace 4 [CONST (a+b); OFFSET]
80 | CONST 0 :: OFFSET :: _ ->
81 replace 2 []
82
83 | GLOBAL x :: LOADW :: _ ->
84 replace 2 [LDGW x]
85 | GLOBAL x :: STOREW :: _ ->
86 replace 2 [STGW x]
87 | LOCAL n :: LOADW :: _ ->
88 replace 2 [LDLW n]
89 | LOCAL n :: STOREW :: _ ->
90 replace 2 [STLW n]
91 | CONST n :: OFFSET :: LOADW :: _ ->
92 replace 3 [LDNW n]
93 | CONST n :: OFFSET :: STOREW :: _ ->
94 replace 3 [STNW n]
95
96 | CONST x :: CONST n :: BOUND _ :: _ when x >= 0 && x < n ->
97 replace 3 [CONST x]
98
99 | LINE n :: LABEL a :: _ ->
100 replace 2 [LABEL a; LINE n]
101 | LINE n :: LINE m :: _ ->
102 replace 1 []
103 | LABEL a :: LABEL b :: _ ->
104 equate a b; replace 2 [LABEL a]
105 | LABEL a :: JUMP b :: _ when not (same_lab a b) ->
106 equate a b; replace 2 [JUMP b]
107 | JUMPC (w, a) :: JUMP b :: LABEL c :: _ when same_lab a c ->
108 replace 2 [JUMPC (opposite w, b)]
109 | JUMP a :: LABEL b :: _ when same_lab a b ->
110 replace 1 []
111 | JUMP a :: LABEL b :: _ ->
112 ()
113 | JUMP a :: _ :: _ ->
114 replace 2 [JUMP a]
115 | LABEL a :: _ when !(ref_count a) = 0 ->
116 replace 1 []
117
118 | _ -> ()
119
120 (* |take n [x1; x2; ...] = [x1; x2; ...; xn]| *)
121 let rec take n =
122 function
123 [] -> []
124 | x::xs -> if n = 0 then [] else x :: take (n-1) xs
125
126 (* |drop n [x1; x2; ...] = [x_{n+1}; x_{n+2}; ...]| *)
127 let rec drop n =
128 function
129 [] -> []
130 | x::xs -> if n = 0 then x::xs else drop (n-1) xs
131
132 (* |optstep| -- apply rules at one place in the buffer *)
133 let optstep rules changed code =
134 let ch = ref true in
135 let replace n c =
136 changed := true; ch := true;
137 if !debug > 0 then
138 printf "! $ --> $\n" [fList(fInst) (take n !code); fList(fInst) c];
139 List.iter (do_refs decr) (take n !code);
140 List.iter (do_refs incr) c;
141 code := c @ drop n !code in
142 while !ch do
143 ch := false; rules replace !code
144 done
145
146 (* |rewrite| -- iterate over the code and apply rules *)
147 let rewrite rules prog =
148 let code1 = ref prog and code2 = ref [] in
149 let changed = ref true in
150 while !changed do
151 changed := false;
152 while !code1 <> [] do
153 optstep rules changed code1;
154 if !code1 <> [] then begin
155 code2 := rename_labs (List.hd !code1) :: !code2;
156 code1 := List.tl !code1
157 end
158 done;
159 code1 := List.rev !code2;
160 code2 := []
161 done;
162 !code1
163
164 (* |optimise| -- rewrite list of instructions *)
165 let optimise prog =
166 match Keiko.canon prog with
167 SEQ code ->
168 List.iter (do_refs incr) code;
169 let code2 = rewrite ruleset code in
170 Hashtbl.clear label_tab;
171 SEQ code2
172 | _ -> failwith "optimise"