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