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: (* Here, we take a schedule (produced by schedule.ml) ordering a
Chris@19:    sequence of instructions, and produce an annotated schedule.  The
Chris@19:    annotated schedule has the same ordering as the original schedule,
Chris@19:    but is additionally partitioned into nested blocks of temporary
Chris@19:    variables.  The partitioning is computed via a heuristic algorithm.
Chris@19: 
Chris@19:    The blocking allows the C code that we generate to consist of
Chris@19:    nested blocks that help communicate variable lifetimes to the
Chris@19:    compiler. *)
Chris@19: 
Chris@19: open Schedule
Chris@19: open Expr
Chris@19: open Variable
Chris@19: 
Chris@19: type annotated_schedule = 
Chris@19:     Annotate of variable list * variable list * variable list * int * aschedule
Chris@19: and aschedule = 
Chris@19:     ADone
Chris@19:   | AInstr of assignment
Chris@19:   | ASeq of (annotated_schedule * annotated_schedule)
Chris@19: 
Chris@19: let addelem a set = if not (List.memq a set) then a :: set else set
Chris@19: let union l = 
Chris@19:   let f x = addelem x   (* let is source of polymorphism *)
Chris@19:   in List.fold_right f l
Chris@19: 
Chris@19: (* set difference a - b *)
Chris@19: let diff a b = List.filter (fun x -> not (List.memq x b)) a
Chris@19: 
Chris@19: let rec minimize f = function
Chris@19:     [] -> failwith "minimize"
Chris@19:   | [n] -> n
Chris@19:   | n :: rest ->
Chris@19:       let x = minimize f rest in
Chris@19:       if (f x) >= (f n) then n else x
Chris@19: 
Chris@19: (* find all variables used inside a scheduling unit *)
Chris@19: let rec find_block_vars = function
Chris@19:     Done -> []
Chris@19:   | (Instr (Assign (v, x))) -> v :: (find_vars x)
Chris@19:   | Par a -> List.flatten (List.map find_block_vars a)
Chris@19:   | Seq (a, b) -> (find_block_vars a) @ (find_block_vars b)
Chris@19: 
Chris@19: let uniq l = 
Chris@19:   List.fold_right (fun a b -> if List.memq a b then b else a :: b) l []
Chris@19: 
Chris@19: let has_related x = List.exists (Variable.same_class x)
Chris@19: 
Chris@19: let rec overlap a b = Util.count (fun y -> has_related y b) a
Chris@19: 
Chris@19: (* reorder a list of schedules so as to maximize overlap of variables *)
Chris@19: let reorder l =
Chris@19:   let rec loop = function
Chris@19:       [] -> []
Chris@19:     | (a, va) :: b ->
Chris@19: 	let c = 
Chris@19: 	  List.map 
Chris@19: 	    (fun (a, x) -> ((a, x), (overlap va x, List.length x))) b in
Chris@19: 	let c' =
Chris@19: 	  Sort.list 
Chris@19: 	    (fun (_, (a, la)) (_, (b, lb)) -> 
Chris@19: 	      la < lb or a > b)
Chris@19: 	    c in
Chris@19: 	let b' = List.map (fun (a, _) -> a) c' in
Chris@19: 	a :: (loop b') in
Chris@19:   let l' = List.map (fun x -> x, uniq (find_block_vars x)) l in
Chris@19:   (* start with smallest block --- does this matter ? *)
Chris@19:   match l' with
Chris@19:     [] -> []
Chris@19:   | _ ->  
Chris@19:       let m = minimize (fun (_, x) -> (List.length x)) l' in
Chris@19:       let l'' = Util.remove m l' in
Chris@19:       loop (m :: l'')
Chris@19: 
Chris@19: (* remove Par blocks *)
Chris@19: let rec linearize = function
Chris@19:   | Seq (a, Done) -> linearize a
Chris@19:   | Seq (Done, a) -> linearize a
Chris@19:   | Seq (a, b) -> Seq (linearize a, linearize b)
Chris@19: 
Chris@19:   (* try to balance nested Par blocks *)
Chris@19:   | Par [a] -> linearize a
Chris@19:   | Par l -> 
Chris@19:       let n2 = (List.length l) / 2 in
Chris@19:       let rec loop n a b =
Chris@19: 	if n = 0 then
Chris@19: 	  (List.rev b, a)
Chris@19: 	else
Chris@19: 	  match a with
Chris@19: 	    [] -> failwith "loop"
Chris@19: 	  | x :: y -> loop (n - 1) y (x :: b)
Chris@19:       in let (a, b) = loop n2 (reorder l) []
Chris@19:       in linearize (Seq (Par a, Par b))
Chris@19: 
Chris@19:   | x -> x 
Chris@19: 
Chris@19: let subset a b =
Chris@19:   List.for_all (fun x -> List.exists (fun y -> x == y) b) a
Chris@19: 
Chris@19: let use_same_vars (Assign (av, ax)) (Assign (bv, bx)) =
Chris@19:   is_temporary av &&
Chris@19:   is_temporary bv &&
Chris@19:   (let va = Expr.find_vars ax and vb = Expr.find_vars bx in
Chris@19:    subset va vb && subset vb va)
Chris@19: 
Chris@19: let store_to_same_class (Assign (av, ax)) (Assign (bv, bx)) =
Chris@19:   is_locative av &&
Chris@19:   is_locative bv &&
Chris@19:   Variable.same_class av bv
Chris@19: 
Chris@19: let loads_from_same_class (Assign (av, ax)) (Assign (bv, bx)) =
Chris@19:   match (ax, bx) with
Chris@19:     | (Load a), (Load b) when 
Chris@19: 	Variable.is_locative a && Variable.is_locative b 
Chris@19: 	-> Variable.same_class a b
Chris@19:     | _ -> false
Chris@19: 
Chris@19: (* extract instructions from schedule *)
Chris@19: let rec sched_to_ilist = function
Chris@19:   | Done -> []
Chris@19:   | Instr a -> [a]
Chris@19:   | Seq (a, b) -> (sched_to_ilist a) @ (sched_to_ilist b)
Chris@19:   | _ -> failwith "sched_to_ilist" (* Par blocks removed by linearize *)
Chris@19: 
Chris@19: let rec find_friends friendp insn friends foes = function
Chris@19:   | [] -> (friends, foes)
Chris@19:   | a :: b -> 
Chris@19:       if (a == insn) || (friendp a insn) then
Chris@19: 	find_friends friendp insn (a :: friends) foes b
Chris@19:       else
Chris@19: 	find_friends friendp insn friends (a :: foes) b
Chris@19: 
Chris@19: (* schedule all instructions in the equivalence class determined
Chris@19:    by friendp at the point where the last one
Chris@19:    is executed *)
Chris@19: let rec delay_friends friendp sched =
Chris@19:   let rec recur insns = function
Chris@19:     | Done -> (Done, insns)
Chris@19:     | Instr a ->
Chris@19: 	let (friends, foes) = find_friends friendp a [] [] insns in
Chris@19: 	(Schedule.sequentially friends), foes
Chris@19:     | Seq (a, b) ->
Chris@19: 	let (b', insnsb) = recur insns b in
Chris@19: 	let (a', insnsa) = recur insnsb a in
Chris@19: 	(Seq (a', b')), insnsa
Chris@19:     | _ -> failwith "delay_friends"
Chris@19:   in match recur (sched_to_ilist sched) sched with
Chris@19:   | (s, []) -> s (* assert that all insns have been used *)
Chris@19:   | _ -> failwith "delay_friends"
Chris@19: 
Chris@19: (* schedule all instructions in the equivalence class determined
Chris@19:    by friendp at the point where the first one
Chris@19:    is executed *)
Chris@19: let rec anticipate_friends friendp sched =
Chris@19:   let rec recur insns = function
Chris@19:     | Done -> (Done, insns)
Chris@19:     | Instr a ->
Chris@19: 	let (friends, foes) = find_friends friendp a [] [] insns in
Chris@19: 	(Schedule.sequentially friends), foes
Chris@19:     | Seq (a, b) ->
Chris@19: 	let (a', insnsa) = recur insns a in
Chris@19: 	let (b', insnsb) = recur insnsa b in
Chris@19: 	(Seq (a', b')), insnsb
Chris@19:     | _ -> failwith "anticipate_friends"
Chris@19:   in match recur (sched_to_ilist sched) sched with
Chris@19:   | (s, []) -> s (* assert that all insns have been used *)
Chris@19:   | _ -> failwith "anticipate_friends"
Chris@19: 
Chris@19: let collect_buddy_stores buddy_list sched =
Chris@19:   let rec recur sched delayed_stores = match sched with
Chris@19:     | Done -> (sched, delayed_stores)
Chris@19:     | Instr (Assign (v, x)) ->
Chris@19: 	begin
Chris@19: 	  try
Chris@19: 	    let buddies = List.find (List.memq v) buddy_list in 
Chris@19: 	    let tmp = Variable.make_temporary () in
Chris@19: 	    let i = Seq(Instr (Assign (tmp, x)),
Chris@19: 			Instr (Assign (v, Times (NaN MULTI_A, Load tmp))))
Chris@19: 	    and delayed_stores = (v, Load tmp) :: delayed_stores in
Chris@19: 	      try
Chris@19: 		(Seq (i,
Chris@19: 		      Instr (Assign 
Chris@19: 			       (List.hd buddies,
Chris@19: 				Times (NaN MULTI_B,
Chris@19: 				       Plus (List.map 
Chris@19: 					       (fun buddy ->
Chris@19: 						  List.assq buddy 
Chris@19: 						    delayed_stores)
Chris@19: 					       buddies))) )))
Chris@19: 		  , delayed_stores
Chris@19: 	      with Not_found -> (i, delayed_stores)
Chris@19: 	  with Not_found -> (sched, delayed_stores)
Chris@19: 	end
Chris@19:     | Seq (a, b) ->
Chris@19: 	let (newa, delayed_stores) = recur a delayed_stores in
Chris@19: 	let (newb, delayed_stores) = recur b delayed_stores in
Chris@19: 	  (Seq (newa, newb), delayed_stores)
Chris@19:     | _ -> failwith "collect_buddy_stores"
Chris@19:   in let (sched, _) = recur sched [] in
Chris@19:     sched
Chris@19: 
Chris@19: let schedule_for_pipeline sched =
Chris@19:   let update_readytimes t (Assign (v, _)) ready_times = 
Chris@19:     (v, (t + !Magic.pipeline_latency)) :: ready_times
Chris@19:   and readyp t ready_times (Assign (_, x)) =
Chris@19:     List.for_all 
Chris@19:       (fun var -> 
Chris@19: 	 try 
Chris@19: 	   (List.assq var ready_times) <= t
Chris@19: 	 with Not_found -> false)
Chris@19:       (List.filter Variable.is_temporary (Expr.find_vars x))
Chris@19:   in
Chris@19:   let rec recur sched t ready_times delayed_instructions =
Chris@19:     let (ready, not_ready) = 
Chris@19:       List.partition (readyp t ready_times) delayed_instructions 
Chris@19:     in match ready with
Chris@19:       | a :: b -> 
Chris@19: 	  let (sched, t, ready_times, delayed_instructions) =
Chris@19: 	    recur sched (t+1) (update_readytimes t a ready_times)
Chris@19: 	      (b @ not_ready)
Chris@19: 	  in
Chris@19: 	    (Seq (Instr a, sched)), t, ready_times, delayed_instructions
Chris@19:       | _ -> (match sched with
Chris@19: 		| Done -> (sched, t, ready_times, delayed_instructions)
Chris@19: 		| Instr a ->
Chris@19: 		    if (readyp t ready_times a) then
Chris@19: 		      (sched, (t+1), (update_readytimes t a ready_times),
Chris@19: 		       delayed_instructions)
Chris@19: 		    else
Chris@19: 		      (Done, t, ready_times, (a :: delayed_instructions))
Chris@19: 		| Seq (a, b) ->
Chris@19: 		    let (a, t, ready_times, delayed_instructions) =
Chris@19: 		      recur a t ready_times delayed_instructions 
Chris@19: 		    in
Chris@19: 		    let (b, t, ready_times, delayed_instructions) =
Chris@19: 		      recur b t ready_times delayed_instructions 
Chris@19: 		    in (Seq (a, b)), t, ready_times, delayed_instructions
Chris@19: 	        | _ -> failwith "schedule_for_pipeline")
Chris@19:   in let rec recur_until_done sched t ready_times delayed_instructions =
Chris@19:       let (sched, t, ready_times, delayed_instructions) = 
Chris@19: 	recur sched t ready_times delayed_instructions
Chris@19:       in match delayed_instructions with
Chris@19: 	| [] -> sched
Chris@19: 	| _ -> 
Chris@19: 	    (Seq (sched,
Chris@19: 		  (recur_until_done Done (t+1) ready_times 
Chris@19: 		     delayed_instructions)))
Chris@19:   in recur_until_done sched 0 [] []
Chris@19:   
Chris@19: let rec rewrite_declarations force_declarations 
Chris@19:     (Annotate (_, _, declared, _, what)) =
Chris@19:   let m = !Magic.number_of_variables in
Chris@19: 
Chris@19:   let declare_it declared =
Chris@19:     if (force_declarations or List.length declared >= m) then
Chris@19:       ([], declared)
Chris@19:     else
Chris@19:       (declared, [])
Chris@19: 
Chris@19:   in match what with
Chris@19:     ADone -> Annotate ([], [], [], 0, what)
Chris@19:   | AInstr i -> 
Chris@19:       let (u, d) = declare_it declared
Chris@19:       in Annotate ([], u, d, 0, what)
Chris@19:   | ASeq (a, b) ->
Chris@19:       let ma = rewrite_declarations false a
Chris@19:       and mb = rewrite_declarations false b
Chris@19:       in let Annotate (_, ua, _, _, _) = ma
Chris@19:       and Annotate (_, ub, _, _, _) = mb
Chris@19:       in let (u, d) = declare_it (declared @ ua @ ub)
Chris@19:       in Annotate ([], u, d, 0, ASeq (ma, mb))
Chris@19: 
Chris@19: let annotate list_of_buddy_stores schedule =
Chris@19:   let rec analyze live_at_end = function
Chris@19:       Done -> Annotate (live_at_end, [], [], 0, ADone)
Chris@19:     | Instr i -> (match i with
Chris@19: 	Assign (v, x) -> 
Chris@19: 	  let vars = (find_vars x) in
Chris@19: 	  Annotate (Util.remove v (union live_at_end vars), [v], [],
Chris@19: 		    0, AInstr i))
Chris@19:     | Seq (a, b) ->
Chris@19: 	let ab = analyze live_at_end b in
Chris@19: 	let Annotate (live_at_begin_b, defined_b, _, depth_a, _) = ab in
Chris@19: 	let aa = analyze live_at_begin_b a in
Chris@19: 	let Annotate (live_at_begin_a, defined_a, _, depth_b, _) = aa in
Chris@19: 	let defined = List.filter is_temporary (defined_a @ defined_b) in
Chris@19: 	let declarable = diff defined live_at_end in
Chris@19: 	let undeclarable = diff defined declarable 
Chris@19: 	and maxdepth = max depth_a depth_b in
Chris@19: 	Annotate (live_at_begin_a, undeclarable, declarable, 
Chris@19: 		  List.length declarable + maxdepth,
Chris@19: 		  ASeq (aa, ab))
Chris@19:     | _ -> failwith "really_analyze"
Chris@19: 
Chris@19:   in 
Chris@19:   let () = Util.info "begin annotate" in
Chris@19:   let x = linearize schedule in
Chris@19: 
Chris@19:   let x =
Chris@19:     if (!Magic.schedule_for_pipeline && !Magic.pipeline_latency > 0) then
Chris@19:       schedule_for_pipeline x 
Chris@19:     else
Chris@19:       x
Chris@19:   in
Chris@19: 
Chris@19:   let x = 
Chris@19:     if !Magic.reorder_insns then 
Chris@19:       linearize(anticipate_friends use_same_vars x) 
Chris@19:     else 
Chris@19:       x
Chris@19:   in
Chris@19: 
Chris@19:   (* delay stores to the real and imaginary parts of the same number *)
Chris@19:   let x = 
Chris@19:     if !Magic.reorder_stores then 
Chris@19:       linearize(delay_friends store_to_same_class x) 
Chris@19:     else
Chris@19:       x
Chris@19:   in
Chris@19: 
Chris@19:   (* move loads of the real and imaginary parts of the same number *)
Chris@19:   let x = 
Chris@19:     if !Magic.reorder_loads then 
Chris@19:       linearize(anticipate_friends loads_from_same_class x) 
Chris@19:     else 
Chris@19:       x
Chris@19:   in
Chris@19: 
Chris@19:   let x = collect_buddy_stores list_of_buddy_stores x in
Chris@19:   let x = analyze [] x in
Chris@19:   let res = rewrite_declarations true x in
Chris@19:   let () = Util.info "end annotate" in
Chris@19:   res
Chris@19: 
Chris@19: let rec dump print (Annotate (_, _, _, _, code)) =
Chris@19:   dump_code print code
Chris@19: and dump_code print = function
Chris@19:   | ADone -> ()
Chris@19:   | AInstr x -> print ((assignment_to_string x) ^ "\n")
Chris@19:   | ASeq (a, b) -> dump print a; dump print b