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