1(* 2 * Copyright (c) 1997-1999 Massachusetts Institute of Technology 3 * Copyright (c) 2003, 2007-14 Matteo Frigo 4 * Copyright (c) 2003, 2007-14 Massachusetts Institute of Technology 5 * 6 * This program is free software; you can redistribute it and/or modify 7 * it under the terms of the GNU General Public License as published by 8 * the Free Software Foundation; either version 2 of the License, or 9 * (at your option) any later version. 10 * 11 * This program is distributed in the hope that it will be useful, 12 * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 * GNU General Public License for more details. 15 * 16 * You should have received a copy of the GNU General Public License 17 * along with this program; if not, write to the Free Software 18 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 19 * 20 *) 21 22(* Here, we take a schedule (produced by schedule.ml) ordering a 23 sequence of instructions, and produce an annotated schedule. The 24 annotated schedule has the same ordering as the original schedule, 25 but is additionally partitioned into nested blocks of temporary 26 variables. The partitioning is computed via a heuristic algorithm. 27 28 The blocking allows the C code that we generate to consist of 29 nested blocks that help communicate variable lifetimes to the 30 compiler. *) 31 32open Schedule 33open Expr 34open Variable 35 36type annotated_schedule = 37 Annotate of variable list * variable list * variable list * int * aschedule 38and aschedule = 39 ADone 40 | AInstr of assignment 41 | ASeq of (annotated_schedule * annotated_schedule) 42 43let addelem a set = if not (List.memq a set) then a :: set else set 44let union l = 45 let f x = addelem x (* let is source of polymorphism *) 46 in List.fold_right f l 47 48(* set difference a - b *) 49let diff a b = List.filter (fun x -> not (List.memq x b)) a 50 51let rec minimize f = function 52 [] -> failwith "minimize" 53 | [n] -> n 54 | n :: rest -> 55 let x = minimize f rest in 56 if (f x) >= (f n) then n else x 57 58(* find all variables used inside a scheduling unit *) 59let rec find_block_vars = function 60 Done -> [] 61 | (Instr (Assign (v, x))) -> v :: (find_vars x) 62 | Par a -> List.flatten (List.map find_block_vars a) 63 | Seq (a, b) -> (find_block_vars a) @ (find_block_vars b) 64 65let uniq l = 66 List.fold_right (fun a b -> if List.memq a b then b else a :: b) l [] 67 68let has_related x = List.exists (Variable.same_class x) 69 70let rec overlap a b = Util.count (fun y -> has_related y b) a 71 72(* reorder a list of schedules so as to maximize overlap of variables *) 73let reorder l = 74 let rec loop = function 75 [] -> [] 76 | (a, va) :: b -> 77 let c = 78 List.map 79 (fun (a, x) -> ((a, x), (overlap va x, List.length x))) b in 80 let c' = 81 List.sort 82 (fun (_, (a, la)) (_, (b, lb)) -> 83 if la < lb || a > b then -1 else 1) 84 c in 85 let b' = List.map (fun (a, _) -> a) c' in 86 a :: (loop b') in 87 let l' = List.map (fun x -> x, uniq (find_block_vars x)) l in 88 (* start with smallest block --- does this matter ? *) 89 match l' with 90 [] -> [] 91 | _ -> 92 let m = minimize (fun (_, x) -> (List.length x)) l' in 93 let l'' = Util.remove m l' in 94 loop (m :: l'') 95 96(* remove Par blocks *) 97let rec linearize = function 98 | Seq (a, Done) -> linearize a 99 | Seq (Done, a) -> linearize a 100 | Seq (a, b) -> Seq (linearize a, linearize b) 101 102 (* try to balance nested Par blocks *) 103 | Par [a] -> linearize a 104 | Par l -> 105 let n2 = (List.length l) / 2 in 106 let rec loop n a b = 107 if n = 0 then 108 (List.rev b, a) 109 else 110 match a with 111 [] -> failwith "loop" 112 | x :: y -> loop (n - 1) y (x :: b) 113 in let (a, b) = loop n2 (reorder l) [] 114 in linearize (Seq (Par a, Par b)) 115 116 | x -> x 117 118let subset a b = 119 List.for_all (fun x -> List.exists (fun y -> x == y) b) a 120 121let use_same_vars (Assign (av, ax)) (Assign (bv, bx)) = 122 is_temporary av && 123 is_temporary bv && 124 (let va = Expr.find_vars ax and vb = Expr.find_vars bx in 125 subset va vb && subset vb va) 126 127let store_to_same_class (Assign (av, ax)) (Assign (bv, bx)) = 128 is_locative av && 129 is_locative bv && 130 Variable.same_class av bv 131 132let loads_from_same_class (Assign (av, ax)) (Assign (bv, bx)) = 133 match (ax, bx) with 134 | (Load a), (Load b) when 135 Variable.is_locative a && Variable.is_locative b 136 -> Variable.same_class a b 137 | _ -> false 138 139(* extract instructions from schedule *) 140let rec sched_to_ilist = function 141 | Done -> [] 142 | Instr a -> [a] 143 | Seq (a, b) -> (sched_to_ilist a) @ (sched_to_ilist b) 144 | _ -> failwith "sched_to_ilist" (* Par blocks removed by linearize *) 145 146let rec find_friends friendp insn friends foes = function 147 | [] -> (friends, foes) 148 | a :: b -> 149 if (a == insn) || (friendp a insn) then 150 find_friends friendp insn (a :: friends) foes b 151 else 152 find_friends friendp insn friends (a :: foes) b 153 154(* schedule all instructions in the equivalence class determined 155 by friendp at the point where the last one 156 is executed *) 157let rec delay_friends friendp sched = 158 let rec recur insns = function 159 | Done -> (Done, insns) 160 | Instr a -> 161 let (friends, foes) = find_friends friendp a [] [] insns in 162 (Schedule.sequentially friends), foes 163 | Seq (a, b) -> 164 let (b', insnsb) = recur insns b in 165 let (a', insnsa) = recur insnsb a in 166 (Seq (a', b')), insnsa 167 | _ -> failwith "delay_friends" 168 in match recur (sched_to_ilist sched) sched with 169 | (s, []) -> s (* assert that all insns have been used *) 170 | _ -> failwith "delay_friends" 171 172(* schedule all instructions in the equivalence class determined 173 by friendp at the point where the first one 174 is executed *) 175let rec anticipate_friends friendp sched = 176 let rec recur insns = function 177 | Done -> (Done, insns) 178 | Instr a -> 179 let (friends, foes) = find_friends friendp a [] [] insns in 180 (Schedule.sequentially friends), foes 181 | Seq (a, b) -> 182 let (a', insnsa) = recur insns a in 183 let (b', insnsb) = recur insnsa b in 184 (Seq (a', b')), insnsb 185 | _ -> failwith "anticipate_friends" 186 in match recur (sched_to_ilist sched) sched with 187 | (s, []) -> s (* assert that all insns have been used *) 188 | _ -> failwith "anticipate_friends" 189 190let collect_buddy_stores buddy_list sched = 191 let rec recur sched delayed_stores = match sched with 192 | Done -> (sched, delayed_stores) 193 | Instr (Assign (v, x)) -> 194 begin 195 try 196 let buddies = List.find (List.memq v) buddy_list in 197 let tmp = Variable.make_temporary () in 198 let i = Seq(Instr (Assign (tmp, x)), 199 Instr (Assign (v, Times (NaN MULTI_A, Load tmp)))) 200 and delayed_stores = (v, Load tmp) :: delayed_stores in 201 try 202 (Seq (i, 203 Instr (Assign 204 (List.hd buddies, 205 Times (NaN MULTI_B, 206 Plus (List.map 207 (fun buddy -> 208 List.assq buddy 209 delayed_stores) 210 buddies))) ))) 211 , delayed_stores 212 with Not_found -> (i, delayed_stores) 213 with Not_found -> (sched, delayed_stores) 214 end 215 | Seq (a, b) -> 216 let (newa, delayed_stores) = recur a delayed_stores in 217 let (newb, delayed_stores) = recur b delayed_stores in 218 (Seq (newa, newb), delayed_stores) 219 | _ -> failwith "collect_buddy_stores" 220 in let (sched, _) = recur sched [] in 221 sched 222 223let schedule_for_pipeline sched = 224 let update_readytimes t (Assign (v, _)) ready_times = 225 (v, (t + !Magic.pipeline_latency)) :: ready_times 226 and readyp t ready_times (Assign (_, x)) = 227 List.for_all 228 (fun var -> 229 try 230 (List.assq var ready_times) <= t 231 with Not_found -> false) 232 (List.filter Variable.is_temporary (Expr.find_vars x)) 233 in 234 let rec recur sched t ready_times delayed_instructions = 235 let (ready, not_ready) = 236 List.partition (readyp t ready_times) delayed_instructions 237 in match ready with 238 | a :: b -> 239 let (sched, t, ready_times, delayed_instructions) = 240 recur sched (t+1) (update_readytimes t a ready_times) 241 (b @ not_ready) 242 in 243 (Seq (Instr a, sched)), t, ready_times, delayed_instructions 244 | _ -> (match sched with 245 | Done -> (sched, t, ready_times, delayed_instructions) 246 | Instr a -> 247 if (readyp t ready_times a) then 248 (sched, (t+1), (update_readytimes t a ready_times), 249 delayed_instructions) 250 else 251 (Done, t, ready_times, (a :: delayed_instructions)) 252 | Seq (a, b) -> 253 let (a, t, ready_times, delayed_instructions) = 254 recur a t ready_times delayed_instructions 255 in 256 let (b, t, ready_times, delayed_instructions) = 257 recur b t ready_times delayed_instructions 258 in (Seq (a, b)), t, ready_times, delayed_instructions 259 | _ -> failwith "schedule_for_pipeline") 260 in let rec recur_until_done sched t ready_times delayed_instructions = 261 let (sched, t, ready_times, delayed_instructions) = 262 recur sched t ready_times delayed_instructions 263 in match delayed_instructions with 264 | [] -> sched 265 | _ -> 266 (Seq (sched, 267 (recur_until_done Done (t+1) ready_times 268 delayed_instructions))) 269 in recur_until_done sched 0 [] [] 270 271let rec rewrite_declarations force_declarations 272 (Annotate (_, _, declared, _, what)) = 273 let m = !Magic.number_of_variables in 274 275 let declare_it declared = 276 if (force_declarations || List.length declared >= m) then 277 ([], declared) 278 else 279 (declared, []) 280 281 in match what with 282 ADone -> Annotate ([], [], [], 0, what) 283 | AInstr i -> 284 let (u, d) = declare_it declared 285 in Annotate ([], u, d, 0, what) 286 | ASeq (a, b) -> 287 let ma = rewrite_declarations false a 288 and mb = rewrite_declarations false b 289 in let Annotate (_, ua, _, _, _) = ma 290 and Annotate (_, ub, _, _, _) = mb 291 in let (u, d) = declare_it (declared @ ua @ ub) 292 in Annotate ([], u, d, 0, ASeq (ma, mb)) 293 294let annotate list_of_buddy_stores schedule = 295 let rec analyze live_at_end = function 296 Done -> Annotate (live_at_end, [], [], 0, ADone) 297 | Instr i -> (match i with 298 Assign (v, x) -> 299 let vars = (find_vars x) in 300 Annotate (Util.remove v (union live_at_end vars), [v], [], 301 0, AInstr i)) 302 | Seq (a, b) -> 303 let ab = analyze live_at_end b in 304 let Annotate (live_at_begin_b, defined_b, _, depth_a, _) = ab in 305 let aa = analyze live_at_begin_b a in 306 let Annotate (live_at_begin_a, defined_a, _, depth_b, _) = aa in 307 let defined = List.filter is_temporary (defined_a @ defined_b) in 308 let declarable = diff defined live_at_end in 309 let undeclarable = diff defined declarable 310 and maxdepth = max depth_a depth_b in 311 Annotate (live_at_begin_a, undeclarable, declarable, 312 List.length declarable + maxdepth, 313 ASeq (aa, ab)) 314 | _ -> failwith "really_analyze" 315 316 in 317 let () = Util.info "begin annotate" in 318 let x = linearize schedule in 319 320 let x = 321 if (!Magic.schedule_for_pipeline && !Magic.pipeline_latency > 0) then 322 schedule_for_pipeline x 323 else 324 x 325 in 326 327 let x = 328 if !Magic.reorder_insns then 329 linearize(anticipate_friends use_same_vars x) 330 else 331 x 332 in 333 334 (* delay stores to the real and imaginary parts of the same number *) 335 let x = 336 if !Magic.reorder_stores then 337 linearize(delay_friends store_to_same_class x) 338 else 339 x 340 in 341 342 (* move loads of the real and imaginary parts of the same number *) 343 let x = 344 if !Magic.reorder_loads then 345 linearize(anticipate_friends loads_from_same_class x) 346 else 347 x 348 in 349 350 let x = collect_buddy_stores list_of_buddy_stores x in 351 let x = analyze [] x in 352 let res = rewrite_declarations true x in 353 let () = Util.info "end annotate" in 354 res 355 356let rec dump print (Annotate (_, _, _, _, code)) = 357 dump_code print code 358and dump_code print = function 359 | ADone -> () 360 | AInstr x -> print ((assignment_to_string x) ^ "\n") 361 | ASeq (a, b) -> dump print a; dump print b 362