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