annotate ppc/peepopt.ml @ 1:b5139af1a420 tip basis

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