pentium.ml

用于FFT,来自MIT的源码

	  ready_reg t ready_times b && ready_datum t ready_times c
    in let infinity = 100000 
    in let has_all_inputs r = ready_instr infinity r false
    in let is_mult = function
      |	FMUL _ -> true
      |	_ -> false
    in let urgency = function
      |	FST _ -> 4
      |	FMUL _ -> 2
      |	FLD (_, MEM _) -> 1
      |	_ -> 2
    in let clobbers_memory v = function
      |	M x -> Variable.clobbers v x
      |	_ -> false
    (* true if assignment of v clobbers instruction inputs *)
    in let clobbers_instr v = function
      |	FLD (_, MEM a) -> clobbers_memory v a
      |	FADD (_, _, MEM a) -> clobbers_memory v a
      |	FSUB (_, _, MEM a) -> clobbers_memory v a
      |	FSUBR (_, _, MEM a) -> clobbers_memory v a
      |	FMUL (_, _, MEM a) -> clobbers_memory v a
      |	_ -> false
    in let dangerous_store past = function
	FST ((M v), _) -> List.exists (clobbers_instr v) past
      |	_ -> false
    in let dangerous_op past =
      let duplicates v past = 
	List.exists 
	  (function
	      FLD (_, REG (V b)) -> b == v
	    | _ -> false) past 
      in function
      |	FADD (_, V b, _) -> duplicates b past
      |	FSUB (_, V b, _) -> duplicates b past
      |	FSUBR (_, V b, _) -> duplicates b past
      |	FMUL (_, V b, _) -> duplicates b past
      |	_ -> false

    in let grade_instructions t rt multiplier_busy instructions =
      let rec loop ready_times past = function
	| [] -> []
	| i :: b ->
	    let is_ready = ready_instr t ready_times multiplier_busy i in
	    let dangerous =
	      not (has_all_inputs ready_times i) or
	      dangerous_op past i or
	      dangerous_store past i in
	    let grade = 
	      if dangerous then (-1000) else
	      if not is_ready then 0 else  urgency i in
	    (grade, i) :: (loop  ready_times (i :: past) b)
      in loop rt [] instructions
    in let find_best t rt mb instructions =
      let grades = grade_instructions t rt mb instructions in
      let rec loop (best_grade, best_instr) = function
	  [] -> best_instr
	| (grade, instr) :: rest ->
	    if (grade > best_grade) then loop (grade, instr) rest
	    else loop (best_grade, best_instr) rest
      in let ((fg, fi) :: rest) = grades in
      let best = loop (fg, fi) rest in
      (best, Util.filter (fun x -> x != best) instructions)
    in let update_ready_times t rt = function
      |	FLD (V a, _) -> (a, t) :: rt
      |	FADD (V a, _, _) -> (a, t) :: rt
      |	FSUB (V a, _, _) -> (a, t) :: rt
      |	FSUBR (V a, _, _) -> (a, t) :: rt
      |	FMUL (V a, _, _) -> (a, t) :: rt
      |	_ -> rt
    in let rec reorder t ready_times mb = function
	[] -> []
      | l -> 
	  let (first, rest) = find_best t ready_times mb l in
	  let lat = latency first in
	  first :: (reorder (t + execution_time first)
		      (update_ready_times (t+lat) ready_times first) 
		      (is_mult first)
		      rest)
    in reorder 0 [] false ilist

  let reg_to_var = function
      V x -> x
    | FR i -> (fixed_reg i)

  let reg_to_expr x = Var (reg_to_var x)

  let datum_to_expr = function
      REG x -> reg_to_expr x
    | MEM (M x) -> Var x
    | MEM (C x) -> Num x
 
  let rec pentium_to_alist = function
      [] -> []
    | a :: b -> 
	(match a with
	| FLD (a, b) -> Assign (reg_to_var a, datum_to_expr b)
	| FADD (a, b, c) -> Assign (reg_to_var a,
				    Plus [reg_to_expr b; datum_to_expr c])
	| FSUB (a, b, c) -> Assign (reg_to_var a,
				    Plus [reg_to_expr b; 
					   Uminus (datum_to_expr c)])
	| FSUBR (a, b, c) -> Assign (reg_to_var a,
				     Plus [datum_to_expr c;
					    Uminus (reg_to_expr b)])
	| FMUL (a, b, c) -> Assign (reg_to_var a,
				    Times (reg_to_expr b, datum_to_expr c))
	| FST (M v, a) -> Assign (v, reg_to_expr a)
	) :: pentium_to_alist b

  let rec iota n =
    if (n == 0) then [0]
    else (n - 1) :: iota (n - 1)

  let rec next_access v t = function
      [] -> None
    | i :: b ->
	if (uses_var v i) then Some t
	else next_access v (t+1) b
      
  let find_unused_reg allocation =
    let unused = 
      Util.filter 
	(fun n ->
	  List.for_all (fun (a, b) ->
	    match b with
	      FR n' -> n <> n'
	    | _ -> true)
	    allocation)
	(iota (nreg())) in
    match unused with
      [] -> None
    | a :: b -> Some (FR a)
	    
  let find_dead_reg allocation rest =
    let dead = Util.filter 
	(fun (v, r) -> not (List.exists (uses_var v) rest))
	allocation in
    match dead with
      [] -> None
    | (v, r) :: _ -> Some r

  let maximize f =
    let rec loop best best_val = function
	[] -> best
      | a :: b -> 
	  let this_val = f a in
	  if (this_val > best_val) then
	    loop a this_val b
	  else
	    loop best best_val b
    in function
	[] -> failwith "maximize"
      |	a :: b ->
	  loop a (f a) b

  let find_farthest allocation rest =
    let access_times = 
      List.map (fun (v, r) -> (r, next_access v 0 rest)) allocation in
    let (r, t) = maximize (fun (r, t) -> t) access_times in
    r

  let rec variable_in_register r = function
      [] -> failwith "variable_in_register"
    | (v, s) :: b ->
	if (r == s) then v
	else variable_in_register r b

  let choose_reg allocation spill_locations preferred rest =
    let pref_regs = 
      List.map (function (REG x) -> x | _ -> failwith "pref_regs")
	(Util.filter 
	   (function
	     | (REG (FR _)) -> true
	     | _ -> false)
	preferred) in
    let revalloc = List.map (fun (v,x) -> (x,v)) allocation in
    let dying = Util.filter
	(function r -> match myassoc r revalloc with
	  None -> false
	| Some v -> not (List.exists (uses_var v) rest))
	pref_regs
    in
    match dying  with
      _ :: d :: _ when !Magic.recycle2 -> (d, spill_locations, [])
    | d :: _ when !Magic.recycle -> (d, spill_locations, [])
    | _ -> match find_unused_reg allocation with
      Some r -> (r, spill_locations, [])
    | None ->
	match find_dead_reg allocation rest with
	  Some r -> (r, spill_locations, [])
	| None -> 
	    let spilled = find_farthest allocation rest in
	    let sl = fresh () in
	    let var = variable_in_register spilled allocation in
	    (spilled, (var, V sl) :: spill_locations, [FST (M sl, spilled)])

  let allocate var reg allocation =
    (Util.filter (fun (v, r) -> r <> reg) allocation) @ [(var, reg)]
  let rec choose_registers allocation spilled = 
    let continue f dest ops rest =
      let (reg_for_dest, spilled', spillcode)
	  = choose_reg allocation spilled ops rest in
      spillcode @
      (f reg_for_dest) ::
      choose_registers (allocate dest reg_for_dest allocation) spilled' rest
    in function
	[] -> []
      | i :: rest -> 
	  let i' = substitute_instr allocation i in
	  let i' = substitute_instr spilled i' in
	  match i' with
	  | FLD (V a, b) -> 
	      continue (fun r -> FLD (r, b)) a [b] rest
	  | FADD (V a, b, c) -> 
	      continue (fun r -> FADD (r, b, c)) a [REG b; c] rest
	  | FSUB (V a, b, c) -> 
	      continue (fun r -> FSUB (r, b, c)) a [REG b; c] rest
	  | FSUBR (V a, b, c) -> 
	      continue (fun r -> FSUBR (r, b, c)) a [REG b; c] rest
	  | FMUL (V a, b, c) -> 
	      continue (fun r -> FMUL (r, b, c)) a [REG b; c] rest
	  | x ->
	      x :: choose_registers allocation spilled rest

  let addelem a set = if not (List.mem a set) then a :: set else set
  let rec all_variables l = function
      [] -> l
    | (Assign (v, _)) :: b -> all_variables (addelem v l) b

  let store_conflicts a (FST (_, r)) =
    let dest = match a with
      FLD (v, _) -> v
    | FADD (v, _, _) -> v
    | FSUB (v, _, _) -> v
    | FSUBR (v, _, _) -> v
    | FMUL (v, _, _) -> v
    | _ -> failwith "dest" in
    r == dest

  let rec delay_stores delayed = function
      [] -> List.rev delayed
    | a :: rest ->
	match a with
	  FST _ -> delay_stores (a :: delayed) rest
	| _ ->
	    (Util.filter (store_conflicts a) delayed) @ 
	    (a ::
	     (delay_stores 
		(Util.filter (fun s -> not (store_conflicts a s)) delayed)
		rest))

  let doit x =
    let asched = annotate_aux x in
    let alist = (annotated_to_alist asched) in
(*    let alist = inline_loads [] alist in *)
    let alist = canonicalize_stores alist in
    let alist = canonicalize alist in
    let p = pentiumize alist in
(*    let p = introduce_duplicates [] p in  *)
    let p = preschedule p in 
    let p = choose_registers [] [] p in 
    let p = if !Magic.delay_stores then delay_stores [] p else p in
(*    let _ = dump_pentium p in 
    let _ = flush stdout in *)
    let a = pentium_to_alist p in
    Annotate ([], [], all_variables [] a, 0, to_asched a)
end

let annotate =  Pentium.doit