cannam@95: (* cannam@95: * Copyright (c) 1997-1999 Massachusetts Institute of Technology cannam@95: * Copyright (c) 2003, 2007-11 Matteo Frigo cannam@95: * Copyright (c) 2003, 2007-11 Massachusetts Institute of Technology cannam@95: * cannam@95: * This program is free software; you can redistribute it and/or modify cannam@95: * it under the terms of the GNU General Public License as published by cannam@95: * the Free Software Foundation; either version 2 of the License, or cannam@95: * (at your option) any later version. cannam@95: * cannam@95: * This program is distributed in the hope that it will be useful, cannam@95: * but WITHOUT ANY WARRANTY; without even the implied warranty of cannam@95: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the cannam@95: * GNU General Public License for more details. cannam@95: * cannam@95: * You should have received a copy of the GNU General Public License cannam@95: * along with this program; if not, write to the Free Software cannam@95: * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA cannam@95: * cannam@95: *) cannam@95: cannam@95: open Expr cannam@95: open List cannam@95: open Printf cannam@95: open Variable cannam@95: open Annotate cannam@95: open Simdmagic cannam@95: open C cannam@95: cannam@95: let realtype = "V" cannam@95: let realtypep = realtype ^ " *" cannam@95: let constrealtype = "const " ^ realtype cannam@95: let constrealtypep = constrealtype ^ " *" cannam@95: let alignment_mod = 2 cannam@95: cannam@95: (* cannam@95: * SIMD C AST unparser cannam@95: *) cannam@95: let foldr_string_concat l = fold_right (^) l "" cannam@95: cannam@95: let rec unparse_by_twiddle nam tw src = cannam@95: sprintf "%s(&(%s),%s)" nam (Variable.unparse tw) (unparse_expr src) cannam@95: cannam@95: and unparse_store dst = function cannam@95: | Times (NaN MULTI_A, x) -> cannam@95: sprintf "STM%d(&(%s),%s,%s,&(%s));\n" cannam@95: !Simdmagic.store_multiple cannam@95: (Variable.unparse dst) (unparse_expr x) cannam@95: (Variable.vstride_of_locative dst) cannam@95: (Variable.unparse_for_alignment alignment_mod dst) cannam@95: | Times (NaN MULTI_B, Plus stuff) -> cannam@95: sprintf "STN%d(&(%s)%s,%s);\n" cannam@95: !Simdmagic.store_multiple cannam@95: (Variable.unparse dst) cannam@95: (List.fold_right (fun x a -> "," ^ (unparse_expr x) ^ a) stuff "") cannam@95: (Variable.vstride_of_locative dst) cannam@95: | src_expr -> cannam@95: sprintf "ST(&(%s),%s,%s,&(%s));\n" cannam@95: (Variable.unparse dst) (unparse_expr src_expr) cannam@95: (Variable.vstride_of_locative dst) cannam@95: (Variable.unparse_for_alignment alignment_mod dst) cannam@95: cannam@95: and unparse_expr = cannam@95: let rec unparse_plus = function cannam@95: | [a] -> unparse_expr a cannam@95: cannam@95: | (Uminus (Times (NaN I, b))) :: c :: d -> op2 "VFNMSI" [b] (c :: d) cannam@95: | c :: (Uminus (Times (NaN I, b))) :: d -> op2 "VFNMSI" [b] (c :: d) cannam@95: | (Uminus (Times (NaN CONJ, b))) :: c :: d -> op2 "VFNMSCONJ" [b] (c :: d) cannam@95: | c :: (Uminus (Times (NaN CONJ, b))) :: d -> op2 "VFNMSCONJ" [b] (c :: d) cannam@95: | (Times (NaN I, b)) :: c :: d -> op2 "VFMAI" [b] (c :: d) cannam@95: | c :: (Times (NaN I, b)) :: d -> op2 "VFMAI" [b] (c :: d) cannam@95: | (Times (NaN CONJ, b)) :: (Uminus c) :: d -> op2 "VFMSCONJ" [b] (c :: d) cannam@95: | (Uminus c) :: (Times (NaN CONJ, b)) :: d -> op2 "VFMSCONJ" [b] (c :: d) cannam@95: | (Times (NaN CONJ, b)) :: c :: d -> op2 "VFMACONJ" [b] (c :: d) cannam@95: | c :: (Times (NaN CONJ, b)) :: d -> op2 "VFMACONJ" [b] (c :: d) cannam@95: | (Times (NaN _, b)) :: (Uminus c) :: d -> failwith "VFMS NaN" cannam@95: | (Uminus c) :: (Times (NaN _, b)) :: d -> failwith "VFMS NaN" cannam@95: cannam@95: | (Uminus (Times (a, b))) :: c :: d -> op3 "VFNMS" a b (c :: d) cannam@95: | c :: (Uminus (Times (a, b))) :: d -> op3 "VFNMS" a b (c :: d) cannam@95: | (Times (a, b)) :: (Uminus c) :: d -> op3 "VFMS" a b (c :: negate d) cannam@95: | (Uminus c) :: (Times (a, b)) :: d -> op3 "VFMS" a b (c :: negate d) cannam@95: | (Times (a, b)) :: c :: d -> op3 "VFMA" a b (c :: d) cannam@95: | c :: (Times (a, b)) :: d -> op3 "VFMA" a b (c :: d) cannam@95: cannam@95: | (Uminus a :: b) -> op2 "VSUB" b [a] cannam@95: | (b :: Uminus a :: c) -> op2 "VSUB" (b :: c) [a] cannam@95: | (a :: b) -> op2 "VADD" [a] b cannam@95: | [] -> failwith "unparse_plus" cannam@95: and op3 nam a b c = cannam@95: nam ^ "(" ^ (unparse_expr a) ^ ", " ^ (unparse_expr b) ^ ", " ^ cannam@95: (unparse_plus c) ^ ")" cannam@95: and op2 nam a b = cannam@95: nam ^ "(" ^ (unparse_plus a) ^ ", " ^ (unparse_plus b) ^ ")" cannam@95: and op1 nam a = cannam@95: nam ^ "(" ^ (unparse_expr a) ^ ")" cannam@95: and negate = function cannam@95: | [] -> [] cannam@95: | (Uminus x) :: y -> x :: negate y cannam@95: | x :: y -> (Uminus x) :: negate y cannam@95: cannam@95: in function cannam@95: | CTimes(Load tw, src) cannam@95: when Variable.is_constant tw && !Magic.generate_bytw -> cannam@95: unparse_by_twiddle "BYTW" tw src cannam@95: | CTimesJ(Load tw, src) cannam@95: when Variable.is_constant tw && !Magic.generate_bytw -> cannam@95: unparse_by_twiddle "BYTWJ" tw src cannam@95: | Load v when is_locative(v) -> cannam@95: sprintf "LD(&(%s), %s, &(%s))" (Variable.unparse v) cannam@95: (Variable.vstride_of_locative v) cannam@95: (Variable.unparse_for_alignment alignment_mod v) cannam@95: | Load v when is_constant(v) -> sprintf "LDW(&(%s))" (Variable.unparse v) cannam@95: | Load v -> Variable.unparse v cannam@95: | Num n -> sprintf "LDK(%s)" (Number.to_konst n) cannam@95: | NaN n -> failwith "NaN in unparse_expr" cannam@95: | Plus [] -> "0.0 /* bug */" cannam@95: | Plus [a] -> " /* bug */ " ^ (unparse_expr a) cannam@95: | Plus a -> unparse_plus a cannam@95: | Times(NaN I,b) -> op1 "VBYI" b cannam@95: | Times(NaN CONJ,b) -> op1 "VCONJ" b cannam@95: | Times(a,b) -> cannam@95: sprintf "VMUL(%s, %s)" (unparse_expr a) (unparse_expr b) cannam@95: | CTimes(a,Times(NaN I, b)) -> cannam@95: sprintf "VZMULI(%s, %s)" (unparse_expr a) (unparse_expr b) cannam@95: | CTimes(a,b) -> cannam@95: sprintf "VZMUL(%s, %s)" (unparse_expr a) (unparse_expr b) cannam@95: | CTimesJ(a,Times(NaN I, b)) -> cannam@95: sprintf "VZMULIJ(%s, %s)" (unparse_expr a) (unparse_expr b) cannam@95: | CTimesJ(a,b) -> cannam@95: sprintf "VZMULJ(%s, %s)" (unparse_expr a) (unparse_expr b) cannam@95: | Uminus a when !Magic.vneg -> op1 "VNEG" a cannam@95: | Uminus a -> failwith "SIMD Uminus" cannam@95: | _ -> failwith "unparse_expr" cannam@95: cannam@95: and unparse_decl x = C.unparse_decl x cannam@95: cannam@95: and unparse_ast ast = cannam@95: let rec unparse_assignment = function cannam@95: | Assign (v, x) when Variable.is_locative v -> cannam@95: unparse_store v x cannam@95: | Assign (v, x) -> cannam@95: (Variable.unparse v) ^ " = " ^ (unparse_expr x) ^ ";\n" cannam@95: cannam@95: and unparse_annotated force_bracket = cannam@95: let rec unparse_code = function cannam@95: | ADone -> "" cannam@95: | AInstr i -> unparse_assignment i cannam@95: | ASeq (a, b) -> cannam@95: (unparse_annotated false a) ^ (unparse_annotated false b) cannam@95: and declare_variables l = cannam@95: let rec uvar = function cannam@95: [] -> failwith "uvar" cannam@95: | [v] -> (Variable.unparse v) ^ ";\n" cannam@95: | a :: b -> (Variable.unparse a) ^ ", " ^ (uvar b) cannam@95: in let rec vvar l = cannam@95: let s = if !Magic.compact then 15 else 1 in cannam@95: if (List.length l <= s) then cannam@95: match l with cannam@95: [] -> "" cannam@95: | _ -> realtype ^ " " ^ (uvar l) cannam@95: else cannam@95: (vvar (Util.take s l)) ^ (vvar (Util.drop s l)) cannam@95: in vvar (List.filter Variable.is_temporary l) cannam@95: in function cannam@95: Annotate (_, _, decl, _, code) -> cannam@95: if (not force_bracket) && (Util.null decl) then cannam@95: unparse_code code cannam@95: else "{\n" ^ cannam@95: (declare_variables decl) ^ cannam@95: (unparse_code code) ^ cannam@95: "}\n" cannam@95: cannam@95: (* ---- *) cannam@95: and unparse_plus = function cannam@95: | [] -> "" cannam@95: | (CUminus a :: b) -> " - " ^ (parenthesize a) ^ (unparse_plus b) cannam@95: | (a :: b) -> " + " ^ (parenthesize a) ^ (unparse_plus b) cannam@95: and parenthesize x = match x with cannam@95: | (CVar _) -> unparse_ast x cannam@95: | (CCall _) -> unparse_ast x cannam@95: | (Integer _) -> unparse_ast x cannam@95: | _ -> "(" ^ (unparse_ast x) ^ ")" cannam@95: cannam@95: in match ast with cannam@95: | Asch a -> (unparse_annotated true a) cannam@95: | Return x -> "return " ^ unparse_ast x ^ ";" cannam@95: | Simd_leavefun -> "VLEAVE();" cannam@95: | For (a, b, c, d) -> cannam@95: "for (" ^ cannam@95: unparse_ast a ^ "; " ^ unparse_ast b ^ "; " ^ unparse_ast c cannam@95: ^ ")" ^ unparse_ast d cannam@95: | If (a, d) -> cannam@95: "if (" ^ cannam@95: unparse_ast a cannam@95: ^ ")" ^ unparse_ast d cannam@95: | Block (d, s) -> cannam@95: if (s == []) then "" cannam@95: else cannam@95: "{\n" ^ cannam@95: foldr_string_concat (map unparse_decl d) ^ cannam@95: foldr_string_concat (map unparse_ast s) ^ cannam@95: "}\n" cannam@95: | x -> C.unparse_ast x cannam@95: cannam@95: and unparse_function = function cannam@95: Fcn (typ, name, args, body) -> cannam@95: let rec unparse_args = function cannam@95: [Decl (a, b)] -> a ^ " " ^ b cannam@95: | (Decl (a, b)) :: s -> a ^ " " ^ b ^ ", " cannam@95: ^ unparse_args s cannam@95: | [] -> "" cannam@95: | _ -> failwith "unparse_function" cannam@95: in cannam@95: (typ ^ " " ^ name ^ "(" ^ unparse_args args ^ ")\n" ^ cannam@95: unparse_ast body) cannam@95: cannam@95: let extract_constants f = cannam@95: let constlist = flatten (map expr_to_constants (C.ast_to_expr_list f)) cannam@95: in map cannam@95: (fun n -> cannam@95: Tdecl cannam@95: ("DVK(" ^ (Number.to_konst n) ^ ", " ^ (Number.to_string n) ^ cannam@95: ");\n")) cannam@95: (unique_constants constlist)