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