Chris@19: (* Chris@19: * Copyright (c) 1997-1999 Massachusetts Institute of Technology Chris@19: * Copyright (c) 2003, 2007-14 Matteo Frigo Chris@19: * Copyright (c) 2003, 2007-14 Massachusetts Institute of Technology Chris@19: * Chris@19: * This program is free software; you can redistribute it and/or modify Chris@19: * it under the terms of the GNU General Public License as published by Chris@19: * the Free Software Foundation; either version 2 of the License, or Chris@19: * (at your option) any later version. Chris@19: * Chris@19: * This program is distributed in the hope that it will be useful, Chris@19: * but WITHOUT ANY WARRANTY; without even the implied warranty of Chris@19: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Chris@19: * GNU General Public License for more details. Chris@19: * Chris@19: * You should have received a copy of the GNU General Public License Chris@19: * along with this program; if not, write to the Free Software Chris@19: * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Chris@19: * Chris@19: *) Chris@19: Chris@19: (* This file contains the instruction scheduler, which finds an Chris@19: efficient ordering for a given list of instructions. Chris@19: Chris@19: The scheduler analyzes the DAG (directed acyclic graph) formed by Chris@19: the instruction dependencies, and recursively partitions it. The Chris@19: resulting schedule data structure expresses a "good" ordering Chris@19: and structure for the computation. Chris@19: Chris@19: The scheduler makes use of utilties in Dag and other packages to Chris@19: manipulate the Dag and the instruction list. *) Chris@19: Chris@19: open Dag Chris@19: (************************************************* Chris@19: * Dag scheduler Chris@19: *************************************************) Chris@19: let to_assignment node = (Expr.Assign (node.assigned, node.expression)) Chris@19: let makedag l = Dag.makedag Chris@19: (List.map (function Expr.Assign (v, x) -> (v, x)) l) Chris@19: Chris@19: let return x = x Chris@19: let has_color c n = (n.color = c) Chris@19: let set_color c n = (n.color <- c) Chris@19: let has_either_color c1 c2 n = (n.color = c1 || n.color = c2) Chris@19: Chris@19: let infinity = 100000 Chris@19: Chris@19: let cc dag inputs = Chris@19: begin Chris@19: Dag.for_all dag (fun node -> Chris@19: node.label <- infinity); Chris@19: Chris@19: (match inputs with Chris@19: a :: _ -> bfs dag a 0 Chris@19: | _ -> failwith "connected"); Chris@19: Chris@19: return Chris@19: ((List.map to_assignment (List.filter (fun n -> n.label < infinity) Chris@19: (Dag.to_list dag))), Chris@19: (List.map to_assignment (List.filter (fun n -> n.label == infinity) Chris@19: (Dag.to_list dag)))) Chris@19: end Chris@19: Chris@19: let rec connected_components alist = Chris@19: let dag = makedag alist in Chris@19: let inputs = Chris@19: List.filter (fun node -> Util.null node.predecessors) Chris@19: (Dag.to_list dag) in Chris@19: match cc dag inputs with Chris@19: (a, []) -> [a] Chris@19: | (a, b) -> a :: connected_components b Chris@19: Chris@19: let single_load node = Chris@19: match (node.input_variables, node.predecessors) with Chris@19: ([x], []) -> Chris@19: Variable.is_constant x || Chris@19: (!Magic.locations_are_special && Variable.is_locative x) Chris@19: | _ -> false Chris@19: Chris@19: let loads_locative node = Chris@19: match (node.input_variables, node.predecessors) with Chris@19: | ([x], []) -> Variable.is_locative x Chris@19: | _ -> false Chris@19: Chris@19: let partition alist = Chris@19: let dag = makedag alist in Chris@19: let dag' = Dag.to_list dag in Chris@19: let inputs = Chris@19: List.filter (fun node -> Util.null node.predecessors) dag' Chris@19: and outputs = Chris@19: List.filter (fun node -> Util.null node.successors) dag' Chris@19: and special_inputs = List.filter single_load dag' in Chris@19: begin Chris@19: Chris@19: let c = match !Magic.schedule_type with Chris@19: | 1 -> RED; (* all nodes in the input partition *) Chris@19: | -1 -> BLUE; (* all nodes in the output partition *) Chris@19: | _ -> BLACK; (* node color determined by bisection algorithm *) Chris@19: in Dag.for_all dag (fun node -> node.color <- c); Chris@19: Chris@19: Util.for_list inputs (set_color RED); Chris@19: Chris@19: (* Chris@19: The special inputs are those input nodes that load a single Chris@19: location or twiddle factor. Special inputs can end up either Chris@19: in the blue or in the red part. These inputs are special Chris@19: because they inherit a color from their neighbors: If a red Chris@19: node needs a special input, the special input becomes red, but Chris@19: if all successors of a special input are blue, the special Chris@19: input becomes blue. Outputs are always blue, whether they be Chris@19: special or not. Chris@19: Chris@19: Because of the processing of special inputs, however, the final Chris@19: partition might end up being composed only of blue nodes (which Chris@19: is incorrect). In this case we manually reset all inputs Chris@19: (whether special or not) to be red. Chris@19: *) Chris@19: Chris@19: Util.for_list special_inputs (set_color YELLOW); Chris@19: Chris@19: Util.for_list outputs (set_color BLUE); Chris@19: Chris@19: let rec loopi donep = Chris@19: match (List.filter Chris@19: (fun node -> (has_color BLACK node) && Chris@19: List.for_all (has_either_color RED YELLOW) node.predecessors) Chris@19: dag') with Chris@19: [] -> if (donep) then () else loopo true Chris@19: | i -> Chris@19: begin Chris@19: Util.for_list i (fun node -> Chris@19: begin Chris@19: set_color RED node; Chris@19: Util.for_list node.predecessors (set_color RED); Chris@19: end); Chris@19: loopo false; Chris@19: end Chris@19: Chris@19: and loopo donep = Chris@19: match (List.filter Chris@19: (fun node -> (has_either_color BLACK YELLOW node) && Chris@19: List.for_all (has_color BLUE) node.successors) Chris@19: dag') with Chris@19: [] -> if (donep) then () else loopi true Chris@19: | o -> Chris@19: begin Chris@19: Util.for_list o (set_color BLUE); Chris@19: loopi false; Chris@19: end Chris@19: Chris@19: in loopi false; Chris@19: Chris@19: (* fix the partition if it is incorrect *) Chris@19: if not (List.exists (has_color RED) dag') then Chris@19: Util.for_list inputs (set_color RED); Chris@19: Chris@19: return Chris@19: ((List.map to_assignment (List.filter (has_color RED) dag')), Chris@19: (List.map to_assignment (List.filter (has_color BLUE) dag'))) Chris@19: end Chris@19: Chris@19: type schedule = Chris@19: Done Chris@19: | Instr of Expr.assignment Chris@19: | Seq of (schedule * schedule) Chris@19: | Par of schedule list Chris@19: Chris@19: Chris@19: Chris@19: (* produce a sequential schedule determined by the user *) Chris@19: let rec sequentially = function Chris@19: [] -> Done Chris@19: | a :: b -> Seq (Instr a, sequentially b) Chris@19: Chris@19: let schedule = Chris@19: let rec schedule_alist = function Chris@19: | [] -> Done Chris@19: | [a] -> Instr a Chris@19: | alist -> match connected_components alist with Chris@19: | ([a]) -> schedule_connected a Chris@19: | l -> Par (List.map schedule_alist l) Chris@19: Chris@19: and schedule_connected alist = Chris@19: match partition alist with Chris@19: | (a, b) -> Seq (schedule_alist a, schedule_alist b) Chris@19: Chris@19: in fun x -> Chris@19: let () = Util.info "begin schedule" in Chris@19: let res = schedule_alist x in Chris@19: let () = Util.info "end schedule" in Chris@19: res Chris@19: Chris@19: Chris@19: (* partition a dag into two parts: Chris@19: Chris@19: 1) the set of loads from locatives and their successors, Chris@19: 2) all other nodes Chris@19: Chris@19: This step separates the ``body'' of the dag, which computes the Chris@19: actual fft, from the ``precomputations'' part, which computes e.g. Chris@19: twiddle factors. Chris@19: *) Chris@19: let partition_precomputations alist = Chris@19: let dag = makedag alist in Chris@19: let dag' = Dag.to_list dag in Chris@19: let loads = List.filter loads_locative dag' in Chris@19: begin Chris@19: Chris@19: Dag.for_all dag (set_color BLUE); Chris@19: Util.for_list loads (set_color RED); Chris@19: Chris@19: let rec loop () = Chris@19: match (List.filter Chris@19: (fun node -> (has_color RED node) && Chris@19: List.exists (has_color BLUE) node.successors) Chris@19: dag') with Chris@19: [] -> () Chris@19: | i -> Chris@19: begin Chris@19: Util.for_list i Chris@19: (fun node -> Chris@19: Util.for_list node.successors (set_color RED)); Chris@19: loop () Chris@19: end Chris@19: Chris@19: in loop (); Chris@19: Chris@19: return Chris@19: ((List.map to_assignment (List.filter (has_color BLUE) dag')), Chris@19: (List.map to_assignment (List.filter (has_color RED) dag'))) Chris@19: end Chris@19: Chris@19: let isolate_precomputations_and_schedule alist = Chris@19: let (a, b) = partition_precomputations alist in Chris@19: Seq (schedule a, schedule b) Chris@19: