pentium.ml

用于FFT,来自MIT的源码

open Schedule
open Expr
open Variable
open Asched
module Pentium = struct
  let fresh = Variable.make_temporary
  let nreg() = !Magic.nreg

  let rec aschedule_to_alist = function
      ADone -> []
    | AInstr a -> [a]
    | ASeq (a, b) ->
	(annotated_to_alist a) @ (annotated_to_alist b)
  and annotated_to_alist (Annotate (_, _, _, _, a)) =
    aschedule_to_alist a

  let rec to_asched = function
    | [] -> ADone
    | [a] -> AInstr a
    | l -> 
	let n2 = (List.length l) / 2 in
	let rec loop n a b =
	  if n = 0 then
	    (List.rev b, a)
	  else
	    match a with
	      [] -> failwith "loop"
	    | x :: y -> loop (n - 1) y (x :: b)
	in let (a, b) = loop n2 l []
	in ASeq (Annotate([], [], [],  0, to_asched a),
		 Annotate ([], [], [], 0, to_asched b))

  let rec myassoc x = function
    [] -> None
  | (a,b)::l -> if a = x then Some b else myassoc x l

  let rec substitute_var sublist = function
    | Var x as y -> (match myassoc x sublist with
	None -> y
      |	Some v -> v)
    | Plus l -> Plus (List.map (substitute_var sublist) l)
    | Uminus x -> Uminus (substitute_var sublist x)
    | Times (a, b) -> Times (substitute_var sublist a,
			     substitute_var sublist b)
    | x -> x

  let rec inline_loads s = function
      [] -> []
    | (Assign (v, x)) :: b ->
	match x with
	  Var t when is_input t && not (is_output v)
	  -> inline_loads ((v, x) :: s) b
	| _ -> 
	    Assign (v, substitute_var s x) :: inline_loads s b

  let rec canonicalize_stores = function
      [] -> []
    | (Assign (_, Var _)) as a :: b ->
	a :: canonicalize_stores b
    | (Assign (v, x)) :: b when is_output v ->
	let t = fresh () in
	Assign (t, x) ::
	Assign (v, Var t) ::
	canonicalize_stores b
    | a :: b ->
	a :: canonicalize_stores b

  let rec canonicalize = function
      [] -> []
    | (Assign (v, x)) :: r -> match x with
	Plus [Var a; Var b] when is_input a && is_input b ->
	  let t = fresh () in
	  Assign (t, Var a) ::
	  Assign (v, Plus [Var t; Var b]) ::
	  canonicalize r
      | Plus [Var a; Uminus (Var b)] when is_input a && is_input b ->
	  let t = fresh () in
	  Assign (t, Var a) ::
	  Assign (v, Plus [Var t; Uminus (Var b)]) ::
	  canonicalize r
      |	Times (Var a, Var b) when not (is_temporary a) 
	    && not (is_temporary b) ->
	  let t = fresh () in
	  if (is_twiddle a) then
	    Assign (t, Var b) ::
	    Assign (v, Times (Var t, Var a)) ::
	    canonicalize r
	  else
	    Assign (t, Var a) ::
	    Assign (v, Times (Var t, Var b)) ::
	    canonicalize r
      |	_ ->
	  (Assign (v, x)) :: 
	  canonicalize r

  type register = V of variable | FR of int
  type memory = M of variable | C of Number.number
  type datum = REG of register | MEM of memory
  type pentium_instr = 
    | FLD of register * datum
    | FADD of register * register * datum
    | FSUB of register * register * datum
    | FSUBR of register * register * datum
    | FMUL of register * register * datum
    | FST of  memory * register

  let rec var_to_datum x =
    if (is_temporary x) then
      REG (V x)
    else
      MEM (M x)

  let rec pentiumize = function
      [] -> []
    | (Assign (v, x)) :: r -> 
	(match x with
	  Var a when is_temporary v && not (is_temporary a) ->
	    FLD (V v, MEM (M a))
	| Var a when is_output v && is_temporary a ->
	    FST (M v, V a) 
	| Times (Var a, Num b) when is_temporary v && is_temporary a ->
	    FMUL (V v, V a, MEM (C b))
	| Times (Num b, Var a) when is_temporary v && is_temporary a ->
	    FMUL (V v, V a, MEM (C b))
	| Times (Var a, Var b) when is_temporary a && is_temporary b ->
	    FMUL (V v, V a, REG (V b))
	| Times (Var a, Var b) when is_temporary a && 
	    not (is_temporary b) ->
	    FMUL (V v, V a, MEM (M b))
	| Times (Var b, Var a) when is_temporary a &&
	    not (is_temporary b) ->
	    FMUL (V v, V a, MEM (M b))
        | Plus [Var a; Uminus (Var b)] when is_temporary a ->
	    FSUB (V v, V a, var_to_datum b) 
	| Plus [Var a; Var b] when is_temporary a ->
	    FADD (V v, V a, var_to_datum b)
        | Plus [Var a; Uminus (Var b)] when is_temporary b ->
	    FSUBR (V v, V b, var_to_datum a) 
	| Plus [Var a; Var b] when is_temporary b ->
	    FADD (V v, V b, var_to_datum a)
	| Plus _  -> failwith "plus"
	| Uminus _ -> failwith "uminus"
	| Times _ -> failwith "times"
	| _ -> failwith "pentiumize"
	) :: pentiumize r


  let unparser = make_unparser ("input", None)  ("input", None) ("twiddle", None)
  let register_file = Array.init (64) (fun i -> make_named_temporary "R")
  let fixed_reg i = register_file.(i)

  let reg_to_string = function
    | V v -> (unparser v)
    | FR i -> "st" ^ (string_of_int i) 
  let mem_to_string = function
    | M v -> (unparser v)
    | C n -> Number.unparse n
  let datum_to_string = function
      REG r -> reg_to_string r
    | MEM m -> mem_to_string m

  let gets = " = "
  let pentium_to_string = function
      FLD (a, b) -> (reg_to_string a) ^ gets ^ (datum_to_string b)
    | FST (a, b) -> (mem_to_string a) ^ gets ^ (reg_to_string b)
    | FADD (a, b, c) -> (reg_to_string a) ^ gets ^ (reg_to_string b)
	^ " + " ^ (datum_to_string c)
    | FSUB (a, b, c) -> (reg_to_string a) ^ gets ^ (reg_to_string b)
	^ " - " ^ (datum_to_string c)
    | FSUBR (a, b, c) -> (reg_to_string a) ^ gets ^ (datum_to_string c)
	^ " - " ^ (reg_to_string b)
    | FMUL (a, b, c) -> (reg_to_string a) ^ gets ^ (reg_to_string b)
	^ " * " ^ (datum_to_string c)
	
  let dump_pentium =
    List.iter (fun x ->
      print_string (pentium_to_string x);
      print_string ";\n")

  let uses_var =
    let same_reg v = function
	V a -> same a v
      |	_ -> false
    in let same_datum v = function
	REG a -> same_reg v a
      |	_ -> false
    in fun v instr -> match instr with
      FST (_, b) -> same_reg v b
    | FADD (_, b, c) -> same_reg v b || same_datum v c
    | FSUB (_, b, c) -> same_reg v b || same_datum v c
    | FSUBR (_, b, c) -> same_reg v b || same_datum v c
    | FMUL (_, b, c) -> same_reg v b || same_datum v c
    | _ -> false

  let substitute_instr sublist = 
    let substitute_reg sublist = function
	V a as y -> (match myassoc a sublist with
	  None -> y
	| Some v -> v)
      |	x -> x in
    let substitute_datum sublist = function
	REG a -> REG (substitute_reg sublist a)
      | x -> x in
    function
      FADD (a, b, c) ->
	FADD (a, substitute_reg sublist b, substitute_datum sublist c)
    | FSUB (a, b, c) ->
	FSUB (a, substitute_reg sublist b, substitute_datum sublist c)
    | FSUBR (a, b, c) ->
	FSUBR (a, substitute_reg sublist b, substitute_datum sublist c)
    | FMUL (a, b, c) ->
	FMUL (a, substitute_reg sublist b, substitute_datum sublist c)
    | FST (a, b) ->
	FST (a, substitute_reg sublist b)
    | FLD (a, b) -> 
	FLD (a, substitute_datum sublist b)
      
  let rec introduce_duplicates sublist =
    let doit sublist instr (V b) r =
      if List.exists (uses_var b) r then
	let t = fresh () in
	FLD (V t, REG (V b)) ::
	instr ::
	introduce_duplicates ((b, V t) :: sublist) r
      else
	instr :: introduce_duplicates sublist r
    in function
	[] -> []
      |	t :: r ->
	  match (substitute_instr sublist t) with
	    FADD (a, b, c) as i ->
	      doit sublist i b r
	  | FSUB (a, b, c) as i ->
	      doit sublist i b r
	  | FSUBR (a, b, c) as i ->
	      doit sublist i b r
	  | FMUL (a, b, c) as i ->
	      doit sublist i b r
	  | x ->
	      x :: introduce_duplicates sublist r

  let preschedule ilist =
    let latency = function
      |	FADD _ -> !Magic.latency
      |	FSUB _ -> !Magic.latency
      |	FSUBR _ -> !Magic.latency
      |	FMUL _ -> 2 * !Magic.latency
      |	_ -> !Magic.load_latency
    in let execution_time = function
      |	FST _ -> 1
      |	_ -> 1
    in let ready_reg t ready_times = function
      |	V v -> 
	  (match myassoc v ready_times with
	    Some t' -> t >= t'
	  | None -> false)
      |	_ -> true
    in let ready_datum t ready_times = function
      |	MEM _ -> true
      |	REG r -> ready_reg t ready_times r
    in let ready_instr t ready_times mb = function
      |	FLD (_, a) -> ready_datum t ready_times a
      |	FST (_, a) -> ready_reg (t - 1) ready_times a
      |	FADD (_, b, c) -> 
	  ready_reg t ready_times b && ready_datum t ready_times c
      |	FSUB (_, b, c) -> 
	  ready_reg t ready_times b && ready_datum t ready_times c
      |	FSUBR (_, b, c) -> 
	  ready_reg t ready_times b && ready_datum t ready_times c
      |	FMUL (_, b, c) -> 
	  not mb &&