view src/fftw-3.3.5/genfft/simd.ml @ 127:7867fa7e1b6b

Current fftw source

(*
 * Copyright (c) 1997-1999 Massachusetts Institute of Technology
 * Copyright (c) 2003, 2007-14 Matteo Frigo
 * Copyright (c) 2003, 2007-14 Massachusetts Institute of Technology
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 *
 *)

open Expr
open List
open Printf
open Variable
open Annotate
open Simdmagic
open C

let realtype = "V"
let realtypep = realtype ^ " *"
let constrealtype = "const " ^ realtype
let constrealtypep = constrealtype ^ " *"
let alignment_mod = 2

(*
 * SIMD C AST unparser 
 *)
let foldr_string_concat l = fold_right (^) l ""

let rec unparse_by_twiddle nam tw src = 
  sprintf "%s(&(%s),%s)" nam (Variable.unparse tw) (unparse_expr src)

and unparse_store dst = function
  | Times (NaN MULTI_A, x) ->
      sprintf "STM%d(&(%s),%s,%s,&(%s));\n" 
	!Simdmagic.store_multiple
	(Variable.unparse dst) (unparse_expr x)
	(Variable.vstride_of_locative dst)
	(Variable.unparse_for_alignment alignment_mod dst)
  | Times (NaN MULTI_B, Plus stuff) ->
      sprintf "STN%d(&(%s)%s,%s);\n" 
	!Simdmagic.store_multiple
	(Variable.unparse dst) 
	(List.fold_right (fun x a -> "," ^ (unparse_expr x) ^ a) stuff "")
	(Variable.vstride_of_locative dst)
  | src_expr -> 
      sprintf "ST(&(%s),%s,%s,&(%s));\n" 
	(Variable.unparse dst) (unparse_expr src_expr) 
	(Variable.vstride_of_locative dst)
	(Variable.unparse_for_alignment alignment_mod dst)

and unparse_expr =
  let rec unparse_plus = function
    | [a] -> unparse_expr a

    | (Uminus (Times (NaN I, b))) :: c :: d -> op2 "VFNMSI" [b] (c :: d)
    | c :: (Uminus (Times (NaN I, b))) :: d -> op2 "VFNMSI" [b] (c :: d)
    | (Uminus (Times (NaN CONJ, b))) :: c :: d -> op2 "VFNMSCONJ" [b] (c :: d)
    | c :: (Uminus (Times (NaN CONJ, b))) :: d -> op2 "VFNMSCONJ" [b] (c :: d)
    | (Times (NaN I, b)) :: c :: d -> op2 "VFMAI" [b] (c :: d)
    | c :: (Times (NaN I, b)) :: d -> op2 "VFMAI" [b] (c :: d)
    | (Times (NaN CONJ, b)) :: (Uminus c) :: d -> op2 "VFMSCONJ" [b] (c :: d)
    | (Uminus c) :: (Times (NaN CONJ, b)) :: d -> op2 "VFMSCONJ" [b] (c :: d)
    | (Times (NaN CONJ, b)) :: c :: d -> op2 "VFMACONJ" [b] (c :: d)
    | c :: (Times (NaN CONJ, b)) :: d -> op2 "VFMACONJ" [b] (c :: d)
    | (Times (NaN _, b)) :: (Uminus c) :: d -> failwith "VFMS NaN"
    | (Uminus c) :: (Times (NaN _, b)) :: d -> failwith "VFMS NaN"

    | (Uminus (Times (a, b))) :: c :: d -> op3 "VFNMS" a b (c :: d)
    | c :: (Uminus (Times (a, b))) :: d -> op3 "VFNMS" a b (c :: d)
    | (Times (a, b)) :: (Uminus c) :: d -> op3 "VFMS" a b (c :: negate d)
    | (Uminus c) :: (Times (a, b)) :: d -> op3 "VFMS" a b (c :: negate d)
    | (Times (a, b)) :: c :: d          -> op3 "VFMA" a b (c :: d)
    | c :: (Times (a, b)) :: d          -> op3 "VFMA" a b (c :: d)

    | (Uminus a :: b)                   -> op2 "VSUB" b [a]
    | (b :: Uminus a :: c)              -> op2 "VSUB" (b :: c) [a]
    | (a :: b)                          -> op2 "VADD" [a] b
    | [] -> failwith "unparse_plus"
  and op3 nam a b c =
    nam ^ "(" ^ (unparse_expr a) ^ ", " ^ (unparse_expr b) ^ ", " ^
    (unparse_plus c) ^ ")"
  and op2 nam a b = 
    nam ^ "(" ^ (unparse_plus a) ^ ", " ^ (unparse_plus b) ^ ")"
  and op1 nam a = 
    nam ^ "(" ^ (unparse_expr a) ^ ")"
  and negate = function
    | [] -> []
    | (Uminus x) :: y -> x :: negate y
    | x :: y -> (Uminus x) :: negate y

  in function
    | CTimes(Load tw, src) 
	when Variable.is_constant tw && !Magic.generate_bytw ->
	unparse_by_twiddle "BYTW" tw src
    | CTimesJ(Load tw, src) 
	when Variable.is_constant tw && !Magic.generate_bytw ->
	unparse_by_twiddle "BYTWJ" tw src
    | Load v when is_locative(v) ->
	sprintf "LD(&(%s), %s, &(%s))" (Variable.unparse v) 
	  (Variable.vstride_of_locative v)
	  (Variable.unparse_for_alignment alignment_mod v)
    | Load v when is_constant(v) -> sprintf "LDW(&(%s))" (Variable.unparse v)
    | Load v  -> Variable.unparse v
    | Num n -> sprintf "LDK(%s)" (Number.to_konst n)
    | NaN n -> failwith "NaN in unparse_expr"
    | Plus [] -> "0.0 /* bug */"
    | Plus [a] -> " /* bug */ " ^ (unparse_expr a)
    | Plus a -> unparse_plus a
    | Times(NaN I,b) -> op1 "VBYI" b
    | Times(NaN CONJ,b) -> op1 "VCONJ" b
    | Times(a,b) ->
	sprintf "VMUL(%s, %s)" (unparse_expr a) (unparse_expr b)
    | CTimes(a,Times(NaN I, b)) ->
	sprintf "VZMULI(%s, %s)" (unparse_expr a) (unparse_expr b)
    | CTimes(a,b) ->
	sprintf "VZMUL(%s, %s)" (unparse_expr a) (unparse_expr b)
    | CTimesJ(a,Times(NaN I, b)) ->
	sprintf "VZMULIJ(%s, %s)" (unparse_expr a) (unparse_expr b)
    | CTimesJ(a,b) ->
	sprintf "VZMULJ(%s, %s)" (unparse_expr a) (unparse_expr b)
    | Uminus a when !Magic.vneg -> op1 "VNEG" a
    | Uminus a -> failwith "SIMD Uminus"
    | _ -> failwith "unparse_expr"

and unparse_decl x = C.unparse_decl x

and unparse_ast ast = 
  let rec unparse_assignment = function
    | Assign (v, x) when Variable.is_locative v ->
	unparse_store v x
    | Assign (v, x) -> 
	(Variable.unparse v) ^ " = " ^ (unparse_expr x) ^ ";\n"

  and unparse_annotated force_bracket = 
    let rec unparse_code = function
      | ADone -> ""
      | AInstr i -> unparse_assignment i
      | ASeq (a, b) -> 
	  (unparse_annotated false a) ^ (unparse_annotated false b)
    and declare_variables l = 
      let rec uvar = function
	  [] -> failwith "uvar"
	|	[v] -> (Variable.unparse v) ^ ";\n"
	| a :: b -> (Variable.unparse a) ^ ", " ^ (uvar b)
      in let rec vvar l = 
	let s = if !Magic.compact then 15 else 1 in
	if (List.length l <= s) then
	  match l with
	    [] -> ""
	  | _ -> realtype ^ " " ^ (uvar l)
	else
	  (vvar (Util.take s l)) ^ (vvar (Util.drop s l))
      in vvar (List.filter Variable.is_temporary l)
    in function
        Annotate (_, _, decl, _, code) ->
          if (not force_bracket) && (Util.null decl) then 
            unparse_code code
          else "{\n" ^
            (declare_variables decl) ^
            (unparse_code code) ^
	    "}\n"

(* ---- *)
  and unparse_plus = function
    | [] -> ""
    | (CUminus a :: b) -> " - " ^ (parenthesize a) ^ (unparse_plus b)
    | (a :: b) -> " + " ^ (parenthesize a) ^ (unparse_plus b)
  and parenthesize x = match x with
  | (CVar _) -> unparse_ast x
  | (CCall _) -> unparse_ast x
  | (Integer _) -> unparse_ast x
  | _ -> "(" ^ (unparse_ast x) ^ ")"

  in match ast with 
  | Asch a -> (unparse_annotated true a)
  | Return x -> "return " ^ unparse_ast x ^ ";"
  | Simd_leavefun -> "VLEAVE();"
  | For (a, b, c, d) ->
      "for (" ^
      unparse_ast a ^ "; " ^ unparse_ast b ^ "; " ^ unparse_ast c
      ^ ")" ^ unparse_ast d
  | If (a, d) ->
      "if (" ^
      unparse_ast a 
      ^ ")" ^ unparse_ast d
  | Block (d, s) ->
      if (s == []) then ""
      else 
        "{\n"                                      ^ 
        foldr_string_concat (map unparse_decl d)   ^ 
        foldr_string_concat (map unparse_ast s)    ^
        "}\n"      
  | x -> C.unparse_ast x

and unparse_function = function
    Fcn (typ, name, args, body) ->
      let rec unparse_args = function
          [Decl (a, b)] -> a ^ " " ^ b 
	| (Decl (a, b)) :: s -> a ^ " " ^ b  ^ ", "
            ^  unparse_args s
	| [] -> ""
	| _ -> failwith "unparse_function"
      in 
      (typ ^ " " ^ name ^ "(" ^ unparse_args args ^ ")\n" ^
       unparse_ast body)

let extract_constants f =
  let constlist = flatten (map expr_to_constants (C.ast_to_expr_list f))
  in map
       (fun n ->
	  Tdecl 
	    ("DVK(" ^ (Number.to_konst n) ^ ", " ^ (Number.to_string n) ^ 
	       ");\n"))
       (unique_constants constlist)