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