furnace/extern/fftw/genfft/annotate.ml

362 lines
12 KiB
OCaml
Raw Normal View History

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