cannam@127: (* cannam@127: * Copyright (c) 1997-1999 Massachusetts Institute of Technology cannam@127: * Copyright (c) 2003, 2007-14 Matteo Frigo cannam@127: * Copyright (c) 2003, 2007-14 Massachusetts Institute of Technology cannam@127: * cannam@127: * This program is free software; you can redistribute it and/or modify cannam@127: * it under the terms of the GNU General Public License as published by cannam@127: * the Free Software Foundation; either version 2 of the License, or cannam@127: * (at your option) any later version. cannam@127: * cannam@127: * This program is distributed in the hope that it will be useful, cannam@127: * but WITHOUT ANY WARRANTY; without even the implied warranty of cannam@127: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the cannam@127: * GNU General Public License for more details. cannam@127: * cannam@127: * You should have received a copy of the GNU General Public License cannam@127: * along with this program; if not, write to the Free Software cannam@127: * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA cannam@127: * cannam@127: *) cannam@127: cannam@127: (* Here, we take a schedule (produced by schedule.ml) ordering a cannam@127: sequence of instructions, and produce an annotated schedule. The cannam@127: annotated schedule has the same ordering as the original schedule, cannam@127: but is additionally partitioned into nested blocks of temporary cannam@127: variables. The partitioning is computed via a heuristic algorithm. cannam@127: cannam@127: The blocking allows the C code that we generate to consist of cannam@127: nested blocks that help communicate variable lifetimes to the cannam@127: compiler. *) cannam@127: cannam@127: open Schedule cannam@127: open Expr cannam@127: open Variable cannam@127: cannam@127: type annotated_schedule = cannam@127: Annotate of variable list * variable list * variable list * int * aschedule cannam@127: and aschedule = cannam@127: ADone cannam@127: | AInstr of assignment cannam@127: | ASeq of (annotated_schedule * annotated_schedule) cannam@127: cannam@127: let addelem a set = if not (List.memq a set) then a :: set else set cannam@127: let union l = cannam@127: let f x = addelem x (* let is source of polymorphism *) cannam@127: in List.fold_right f l cannam@127: cannam@127: (* set difference a - b *) cannam@127: let diff a b = List.filter (fun x -> not (List.memq x b)) a cannam@127: cannam@127: let rec minimize f = function cannam@127: [] -> failwith "minimize" cannam@127: | [n] -> n cannam@127: | n :: rest -> cannam@127: let x = minimize f rest in cannam@127: if (f x) >= (f n) then n else x cannam@127: cannam@127: (* find all variables used inside a scheduling unit *) cannam@127: let rec find_block_vars = function cannam@127: Done -> [] cannam@127: | (Instr (Assign (v, x))) -> v :: (find_vars x) cannam@127: | Par a -> List.flatten (List.map find_block_vars a) cannam@127: | Seq (a, b) -> (find_block_vars a) @ (find_block_vars b) cannam@127: cannam@127: let uniq l = cannam@127: List.fold_right (fun a b -> if List.memq a b then b else a :: b) l [] cannam@127: cannam@127: let has_related x = List.exists (Variable.same_class x) cannam@127: cannam@127: let rec overlap a b = Util.count (fun y -> has_related y b) a cannam@127: cannam@127: (* reorder a list of schedules so as to maximize overlap of variables *) cannam@127: let reorder l = cannam@127: let rec loop = function cannam@127: [] -> [] cannam@127: | (a, va) :: b -> cannam@127: let c = cannam@127: List.map cannam@127: (fun (a, x) -> ((a, x), (overlap va x, List.length x))) b in cannam@127: let c' = cannam@127: Sort.list cannam@127: (fun (_, (a, la)) (_, (b, lb)) -> cannam@127: la < lb || a > b) cannam@127: c in cannam@127: let b' = List.map (fun (a, _) -> a) c' in cannam@127: a :: (loop b') in cannam@127: let l' = List.map (fun x -> x, uniq (find_block_vars x)) l in cannam@127: (* start with smallest block --- does this matter ? *) cannam@127: match l' with cannam@127: [] -> [] cannam@127: | _ -> cannam@127: let m = minimize (fun (_, x) -> (List.length x)) l' in cannam@127: let l'' = Util.remove m l' in cannam@127: loop (m :: l'') cannam@127: cannam@127: (* remove Par blocks *) cannam@127: let rec linearize = function cannam@127: | Seq (a, Done) -> linearize a cannam@127: | Seq (Done, a) -> linearize a cannam@127: | Seq (a, b) -> Seq (linearize a, linearize b) cannam@127: cannam@127: (* try to balance nested Par blocks *) cannam@127: | Par [a] -> linearize a cannam@127: | Par l -> cannam@127: let n2 = (List.length l) / 2 in cannam@127: let rec loop n a b = cannam@127: if n = 0 then cannam@127: (List.rev b, a) cannam@127: else cannam@127: match a with cannam@127: [] -> failwith "loop" cannam@127: | x :: y -> loop (n - 1) y (x :: b) cannam@127: in let (a, b) = loop n2 (reorder l) [] cannam@127: in linearize (Seq (Par a, Par b)) cannam@127: cannam@127: | x -> x cannam@127: cannam@127: let subset a b = cannam@127: List.for_all (fun x -> List.exists (fun y -> x == y) b) a cannam@127: cannam@127: let use_same_vars (Assign (av, ax)) (Assign (bv, bx)) = cannam@127: is_temporary av && cannam@127: is_temporary bv && cannam@127: (let va = Expr.find_vars ax and vb = Expr.find_vars bx in cannam@127: subset va vb && subset vb va) cannam@127: cannam@127: let store_to_same_class (Assign (av, ax)) (Assign (bv, bx)) = cannam@127: is_locative av && cannam@127: is_locative bv && cannam@127: Variable.same_class av bv cannam@127: cannam@127: let loads_from_same_class (Assign (av, ax)) (Assign (bv, bx)) = cannam@127: match (ax, bx) with cannam@127: | (Load a), (Load b) when cannam@127: Variable.is_locative a && Variable.is_locative b cannam@127: -> Variable.same_class a b cannam@127: | _ -> false cannam@127: cannam@127: (* extract instructions from schedule *) cannam@127: let rec sched_to_ilist = function cannam@127: | Done -> [] cannam@127: | Instr a -> [a] cannam@127: | Seq (a, b) -> (sched_to_ilist a) @ (sched_to_ilist b) cannam@127: | _ -> failwith "sched_to_ilist" (* Par blocks removed by linearize *) cannam@127: cannam@127: let rec find_friends friendp insn friends foes = function cannam@127: | [] -> (friends, foes) cannam@127: | a :: b -> cannam@127: if (a == insn) || (friendp a insn) then cannam@127: find_friends friendp insn (a :: friends) foes b cannam@127: else cannam@127: find_friends friendp insn friends (a :: foes) b cannam@127: cannam@127: (* schedule all instructions in the equivalence class determined cannam@127: by friendp at the point where the last one cannam@127: is executed *) cannam@127: let rec delay_friends friendp sched = cannam@127: let rec recur insns = function cannam@127: | Done -> (Done, insns) cannam@127: | Instr a -> cannam@127: let (friends, foes) = find_friends friendp a [] [] insns in cannam@127: (Schedule.sequentially friends), foes cannam@127: | Seq (a, b) -> cannam@127: let (b', insnsb) = recur insns b in cannam@127: let (a', insnsa) = recur insnsb a in cannam@127: (Seq (a', b')), insnsa cannam@127: | _ -> failwith "delay_friends" cannam@127: in match recur (sched_to_ilist sched) sched with cannam@127: | (s, []) -> s (* assert that all insns have been used *) cannam@127: | _ -> failwith "delay_friends" cannam@127: cannam@127: (* schedule all instructions in the equivalence class determined cannam@127: by friendp at the point where the first one cannam@127: is executed *) cannam@127: let rec anticipate_friends friendp sched = cannam@127: let rec recur insns = function cannam@127: | Done -> (Done, insns) cannam@127: | Instr a -> cannam@127: let (friends, foes) = find_friends friendp a [] [] insns in cannam@127: (Schedule.sequentially friends), foes cannam@127: | Seq (a, b) -> cannam@127: let (a', insnsa) = recur insns a in cannam@127: let (b', insnsb) = recur insnsa b in cannam@127: (Seq (a', b')), insnsb cannam@127: | _ -> failwith "anticipate_friends" cannam@127: in match recur (sched_to_ilist sched) sched with cannam@127: | (s, []) -> s (* assert that all insns have been used *) cannam@127: | _ -> failwith "anticipate_friends" cannam@127: cannam@127: let collect_buddy_stores buddy_list sched = cannam@127: let rec recur sched delayed_stores = match sched with cannam@127: | Done -> (sched, delayed_stores) cannam@127: | Instr (Assign (v, x)) -> cannam@127: begin cannam@127: try cannam@127: let buddies = List.find (List.memq v) buddy_list in cannam@127: let tmp = Variable.make_temporary () in cannam@127: let i = Seq(Instr (Assign (tmp, x)), cannam@127: Instr (Assign (v, Times (NaN MULTI_A, Load tmp)))) cannam@127: and delayed_stores = (v, Load tmp) :: delayed_stores in cannam@127: try cannam@127: (Seq (i, cannam@127: Instr (Assign cannam@127: (List.hd buddies, cannam@127: Times (NaN MULTI_B, cannam@127: Plus (List.map cannam@127: (fun buddy -> cannam@127: List.assq buddy cannam@127: delayed_stores) cannam@127: buddies))) ))) cannam@127: , delayed_stores cannam@127: with Not_found -> (i, delayed_stores) cannam@127: with Not_found -> (sched, delayed_stores) cannam@127: end cannam@127: | Seq (a, b) -> cannam@127: let (newa, delayed_stores) = recur a delayed_stores in cannam@127: let (newb, delayed_stores) = recur b delayed_stores in cannam@127: (Seq (newa, newb), delayed_stores) cannam@127: | _ -> failwith "collect_buddy_stores" cannam@127: in let (sched, _) = recur sched [] in cannam@127: sched cannam@127: cannam@127: let schedule_for_pipeline sched = cannam@127: let update_readytimes t (Assign (v, _)) ready_times = cannam@127: (v, (t + !Magic.pipeline_latency)) :: ready_times cannam@127: and readyp t ready_times (Assign (_, x)) = cannam@127: List.for_all cannam@127: (fun var -> cannam@127: try cannam@127: (List.assq var ready_times) <= t cannam@127: with Not_found -> false) cannam@127: (List.filter Variable.is_temporary (Expr.find_vars x)) cannam@127: in cannam@127: let rec recur sched t ready_times delayed_instructions = cannam@127: let (ready, not_ready) = cannam@127: List.partition (readyp t ready_times) delayed_instructions cannam@127: in match ready with cannam@127: | a :: b -> cannam@127: let (sched, t, ready_times, delayed_instructions) = cannam@127: recur sched (t+1) (update_readytimes t a ready_times) cannam@127: (b @ not_ready) cannam@127: in cannam@127: (Seq (Instr a, sched)), t, ready_times, delayed_instructions cannam@127: | _ -> (match sched with cannam@127: | Done -> (sched, t, ready_times, delayed_instructions) cannam@127: | Instr a -> cannam@127: if (readyp t ready_times a) then cannam@127: (sched, (t+1), (update_readytimes t a ready_times), cannam@127: delayed_instructions) cannam@127: else cannam@127: (Done, t, ready_times, (a :: delayed_instructions)) cannam@127: | Seq (a, b) -> cannam@127: let (a, t, ready_times, delayed_instructions) = cannam@127: recur a t ready_times delayed_instructions cannam@127: in cannam@127: let (b, t, ready_times, delayed_instructions) = cannam@127: recur b t ready_times delayed_instructions cannam@127: in (Seq (a, b)), t, ready_times, delayed_instructions cannam@127: | _ -> failwith "schedule_for_pipeline") cannam@127: in let rec recur_until_done sched t ready_times delayed_instructions = cannam@127: let (sched, t, ready_times, delayed_instructions) = cannam@127: recur sched t ready_times delayed_instructions cannam@127: in match delayed_instructions with cannam@127: | [] -> sched cannam@127: | _ -> cannam@127: (Seq (sched, cannam@127: (recur_until_done Done (t+1) ready_times cannam@127: delayed_instructions))) cannam@127: in recur_until_done sched 0 [] [] cannam@127: cannam@127: let rec rewrite_declarations force_declarations cannam@127: (Annotate (_, _, declared, _, what)) = cannam@127: let m = !Magic.number_of_variables in cannam@127: cannam@127: let declare_it declared = cannam@127: if (force_declarations || List.length declared >= m) then cannam@127: ([], declared) cannam@127: else cannam@127: (declared, []) cannam@127: cannam@127: in match what with cannam@127: ADone -> Annotate ([], [], [], 0, what) cannam@127: | AInstr i -> cannam@127: let (u, d) = declare_it declared cannam@127: in Annotate ([], u, d, 0, what) cannam@127: | ASeq (a, b) -> cannam@127: let ma = rewrite_declarations false a cannam@127: and mb = rewrite_declarations false b cannam@127: in let Annotate (_, ua, _, _, _) = ma cannam@127: and Annotate (_, ub, _, _, _) = mb cannam@127: in let (u, d) = declare_it (declared @ ua @ ub) cannam@127: in Annotate ([], u, d, 0, ASeq (ma, mb)) cannam@127: cannam@127: let annotate list_of_buddy_stores schedule = cannam@127: let rec analyze live_at_end = function cannam@127: Done -> Annotate (live_at_end, [], [], 0, ADone) cannam@127: | Instr i -> (match i with cannam@127: Assign (v, x) -> cannam@127: let vars = (find_vars x) in cannam@127: Annotate (Util.remove v (union live_at_end vars), [v], [], cannam@127: 0, AInstr i)) cannam@127: | Seq (a, b) -> cannam@127: let ab = analyze live_at_end b in cannam@127: let Annotate (live_at_begin_b, defined_b, _, depth_a, _) = ab in cannam@127: let aa = analyze live_at_begin_b a in cannam@127: let Annotate (live_at_begin_a, defined_a, _, depth_b, _) = aa in cannam@127: let defined = List.filter is_temporary (defined_a @ defined_b) in cannam@127: let declarable = diff defined live_at_end in cannam@127: let undeclarable = diff defined declarable cannam@127: and maxdepth = max depth_a depth_b in cannam@127: Annotate (live_at_begin_a, undeclarable, declarable, cannam@127: List.length declarable + maxdepth, cannam@127: ASeq (aa, ab)) cannam@127: | _ -> failwith "really_analyze" cannam@127: cannam@127: in cannam@127: let () = Util.info "begin annotate" in cannam@127: let x = linearize schedule in cannam@127: cannam@127: let x = cannam@127: if (!Magic.schedule_for_pipeline && !Magic.pipeline_latency > 0) then cannam@127: schedule_for_pipeline x cannam@127: else cannam@127: x cannam@127: in cannam@127: cannam@127: let x = cannam@127: if !Magic.reorder_insns then cannam@127: linearize(anticipate_friends use_same_vars x) cannam@127: else cannam@127: x cannam@127: in cannam@127: cannam@127: (* delay stores to the real and imaginary parts of the same number *) cannam@127: let x = cannam@127: if !Magic.reorder_stores then cannam@127: linearize(delay_friends store_to_same_class x) cannam@127: else cannam@127: x cannam@127: in cannam@127: cannam@127: (* move loads of the real and imaginary parts of the same number *) cannam@127: let x = cannam@127: if !Magic.reorder_loads then cannam@127: linearize(anticipate_friends loads_from_same_class x) cannam@127: else cannam@127: x cannam@127: in cannam@127: cannam@127: let x = collect_buddy_stores list_of_buddy_stores x in cannam@127: let x = analyze [] x in cannam@127: let res = rewrite_declarations true x in cannam@127: let () = Util.info "end annotate" in cannam@127: res cannam@127: cannam@127: let rec dump print (Annotate (_, _, _, _, code)) = cannam@127: dump_code print code cannam@127: and dump_code print = function cannam@127: | ADone -> () cannam@127: | AInstr x -> print ((assignment_to_string x) ^ "\n") cannam@127: | ASeq (a, b) -> dump print a; dump print b