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