annotate lab4/share.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
0
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
1 (* lab4/share.ml *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
2 (* Copyright (c) 2017 J. M. Spivey *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
3
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
4 open Print
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
5 open Optree
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
6 open Mach
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
7
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
8 (* |dagnode| -- node in DAG representation of an expression *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
9 type dagnode =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
10 { g_serial: int; (* Serial number *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
11 g_op: inst; (* Operator *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
12 g_rands: dagnode list; (* Operands *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
13 mutable g_refct: int; (* Reference count *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
14 mutable g_temp: int } (* Temp, or -1 if none *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
15
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
16 (* |serial| -- fetch serial number of a node *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
17 let serial g = g.g_serial
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
18
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
19 (* |node_table| -- hash table for value numbering *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
20 let node_table = Hashtbl.create 129
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
21
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
22 (* |node_count| -- counter for numbering nodes *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
23 let node_count = ref 0
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
24
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
25 (* |newnode| -- create a new node *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
26 let newnode op rands =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
27 incr node_count;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
28 List.iter (function g -> g.g_refct <- g.g_refct+1) rands;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
29 { g_serial = !node_count; g_op = op; g_rands = rands;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
30 g_refct = 0; g_temp = -1 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
31
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
32 (* |node| -- create a new node or share an existing one *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
33 let node op rands =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
34 let key = (op, List.map serial rands) in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
35 try Hashtbl.find node_table key with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
36 Not_found ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
37 let n = newnode op rands in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
38 Hashtbl.add node_table key n;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
39 n
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
40
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
41 (* |reset| -- clear the value numbering table *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
42 let reset () =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
43 Hashtbl.clear node_table
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
44
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
45 type arena = Local | Global | Regvar | Unknown
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
46
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
47 (* |alias| -- test if address g1 could be an alias for g2 *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
48 let alias g1 g2 =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
49 let simple =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
50 function LOCAL _ | GLOBAL _ | REGVAR _ -> true | _ -> false in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
51
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
52 let rec arena g =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
53 match g.g_op with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
54 LOCAL _ -> Local
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
55 | GLOBAL _ -> Global
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
56 | REGVAR _ -> Regvar
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
57 | OFFSET -> arena (List.hd g.g_rands)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
58 | _ -> Unknown in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
59
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
60 if simple g1.g_op && simple g2.g_op then
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
61 (* Simple addresses that alias only if they are equal *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
62 g1.g_op = g2.g_op
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
63 else begin
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
64 (* Other addresses can alias only if they are in the same arena *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
65 let a1 = arena g1 and a2 = arena g2 in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
66 a1 = Unknown || a2 = Unknown || a1 = a2
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
67 end
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
68
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
69 (* |kill| -- remove LOAD nodes that satisfy a test *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
70 let kill p =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
71 let deleted = Stack.create () in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
72 let f key g =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
73 match g.g_op with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
74 (LOADC|LOADW) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
75 if p (List.hd g.g_rands) then
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
76 Stack.push key deleted
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
77 | _ -> () in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
78 Hashtbl.iter f node_table;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
79 Stack.iter (Hashtbl.remove node_table) deleted
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
80
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
81 let is_regvar = function <REGVAR _> -> true | _ -> false
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
82
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
83 (* |make_dag| -- convert an expression into a DAG *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
84 let rec make_dag t =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
85 match t with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
86 <STOREW, t1, t2> when not (is_regvar t2) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
87 make_store STOREW LOADW t1 t2
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
88 | <STOREC, t1, t2> when not (is_regvar t2) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
89 make_store STOREC LOADC t1 t2
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
90 | <LABEL lab> ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
91 reset (); node (LABEL lab) []
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
92 | <PCALL n, @ts> ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
93 (* Never share procedure calls *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
94 let gs = List.map make_dag ts in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
95 (* Don't try to do CSE over procedure calls, even for constants *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
96 reset ();
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
97 newnode (PCALL n) gs
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
98 | <(ARG _|SLINK) as op, t> ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
99 newnode op [make_dag t]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
100 | <w, @ts> ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
101 node w (List.map make_dag ts)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
102
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
103 and make_store st ld t1 t2 =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
104 let g1 = make_dag t1 in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
105 let g2 = make_dag t2 in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
106 (* Kill all nodes that might alias the target location *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
107 kill (alias g2);
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
108 (* Add dummy argument to detect use of stored value *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
109 let g3 = node ld [g2] in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
110 node st [g1; g2; g3]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
111
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
112 (* |visit| -- convert dag to tree, sharing the root if worthwhile *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
113 let rec visit g root =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
114 match g.g_op with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
115 TEMP _ | LOCAL _ | REGVAR _ | CONST _ ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
116 build g (* Trivial *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
117 | GLOBAL _ when not Mach.share_globals ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
118 build g
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
119 | PCALL _ ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
120 (* Procedure call -- always moved to top level *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
121 if root then build g else share g
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
122 | _ ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
123 if root || g.g_refct = 1 then build g else share g
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
124
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
125 (* |build| -- convert dag to tree with no sharing at the root *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
126 and build g =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
127 match (g.g_op, g.g_rands) with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
128 (PCALL _, p::args) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
129 (* Don't share constant procedure addresses *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
130 let p' =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
131 match p.g_op with GLOBAL _ -> build p | _ -> visit p false in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
132 let args' = List.map (fun g1 -> visit g1 true) args in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
133 <g.g_op, @(p'::args')>
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
134 | ((STOREC|STOREW), [g1; g2; g3]) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
135 g2.g_refct <- g2.g_refct-1; (* Ignore artificial ref from g3 *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
136 (* If dummy value is used, then make it share with g1 *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
137 let t1 =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
138 if g3.g_refct > 1 then share g1 else visit g1 false in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
139 g3.g_temp <- g1.g_temp;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
140 <g.g_op, t1, visit g2 false>
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
141 | (_, _) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
142 <g.g_op, @(List.map (fun g1 -> visit g1 false) g.g_rands)>
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
143
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
144 (* |share| -- convert dag to tree, sharing the root *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
145 and share g =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
146 if g.g_temp >= 0 then begin
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
147 Regs.inc_temp g.g_temp;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
148 <TEMP g.g_temp>
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
149 end else begin
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
150 let d' = build g in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
151 match d' with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
152 (* No point in sharing register variables *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
153 <(LOADC|LOADW), <REGVAR _>> -> d'
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
154 | _ ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
155 let n = Regs.new_temp 1 in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
156 g.g_temp <- n;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
157 <AFTER, <DEFTMP n, d'>, <TEMP n>>
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
158 end
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
159
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
160 let traverse ts =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
161 reset ();
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
162 (* Convert the trees to a list of roots in a DAG *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
163 let gs = List.map make_dag ts in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
164 (* Then convert the DAG roots back into trees *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
165 canon <SEQ, @(List.map (fun g -> visit g true) gs)>