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