cannam@167: (* cannam@167: * Copyright (c) 1997-1999 Massachusetts Institute of Technology cannam@167: * Copyright (c) 2003, 2007-14 Matteo Frigo cannam@167: * Copyright (c) 2003, 2007-14 Massachusetts Institute of Technology cannam@167: * cannam@167: * This program is free software; you can redistribute it and/or modify cannam@167: * it under the terms of the GNU General Public License as published by cannam@167: * the Free Software Foundation; either version 2 of the License, or cannam@167: * (at your option) any later version. cannam@167: * cannam@167: * This program is distributed in the hope that it will be useful, cannam@167: * but WITHOUT ANY WARRANTY; without even the implied warranty of cannam@167: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the cannam@167: * GNU General Public License for more details. cannam@167: * cannam@167: * You should have received a copy of the GNU General Public License cannam@167: * along with this program; if not, write to the Free Software cannam@167: * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA cannam@167: * cannam@167: *) cannam@167: cannam@167: (* cannam@167: * This module contains the definition of a C-like abstract cannam@167: * syntax tree, and functions to convert ML values into C cannam@167: * programs cannam@167: *) cannam@167: cannam@167: open Expr cannam@167: open Annotate cannam@167: open List cannam@167: cannam@167: let realtype = "R" cannam@167: let realtypep = realtype ^ " *" cannam@167: let extended_realtype = "E" cannam@167: let constrealtype = "const " ^ realtype cannam@167: let constrealtypep = constrealtype ^ " *" cannam@167: cannam@167: let stridetype = "stride" cannam@167: cannam@167: (*********************************** cannam@167: * C program structure cannam@167: ***********************************) cannam@167: type c_decl = cannam@167: | Decl of string * string cannam@167: | Tdecl of string (* arbitrary text declaration *) cannam@167: cannam@167: and c_ast = cannam@167: | Asch of annotated_schedule cannam@167: | Simd_leavefun cannam@167: | Return of c_ast cannam@167: | For of c_ast * c_ast * c_ast * c_ast cannam@167: | If of c_ast * c_ast cannam@167: | Block of (c_decl list) * (c_ast list) cannam@167: | Binop of string * c_ast * c_ast cannam@167: | Expr_assign of c_ast * c_ast cannam@167: | Stmt_assign of c_ast * c_ast cannam@167: | Comma of c_ast * c_ast cannam@167: | Integer of int cannam@167: | CVar of string cannam@167: | CCall of string * c_ast cannam@167: | CPlus of c_ast list cannam@167: | ITimes of c_ast * c_ast cannam@167: | CUminus of c_ast cannam@167: and c_fcn = Fcn of string * string * (c_decl list) * c_ast cannam@167: cannam@167: cannam@167: let ctimes = function cannam@167: | (Integer 1), a -> a cannam@167: | a, (Integer 1) -> a cannam@167: | a, b -> ITimes (a, b) cannam@167: cannam@167: (* cannam@167: * C AST unparser cannam@167: *) cannam@167: let foldr_string_concat l = fold_right (^) l "" cannam@167: cannam@167: let rec unparse_expr_c = cannam@167: let yes x = x and no x = "" in cannam@167: cannam@167: let rec unparse_plus maybe = cannam@167: let maybep = maybe " + " in cannam@167: function cannam@167: | [] -> "" cannam@167: | (Uminus (Times (a, b))) :: (Uminus c) :: d -> cannam@167: maybep ^ (op "FNMA" a b c) ^ (unparse_plus yes d) cannam@167: | (Uminus c) :: (Uminus (Times (a, b))) :: d -> cannam@167: maybep ^ (op "FNMA" a b c) ^ (unparse_plus yes d) cannam@167: | (Uminus (Times (a, b))) :: c :: d -> cannam@167: maybep ^ (op "FNMS" a b c) ^ (unparse_plus yes d) cannam@167: | c :: (Uminus (Times (a, b))) :: d -> cannam@167: maybep ^ (op "FNMS" a b c) ^ (unparse_plus yes d) cannam@167: | (Times (a, b)) :: (Uminus c) :: d -> cannam@167: maybep ^ (op "FMS" a b c) ^ (unparse_plus yes d) cannam@167: | (Uminus c) :: (Times (a, b)) :: d -> cannam@167: maybep ^ (op "FMS" a b c) ^ (unparse_plus yes d) cannam@167: | (Times (a, b)) :: c :: d -> cannam@167: maybep ^ (op "FMA" a b c) ^ (unparse_plus yes d) cannam@167: | c :: (Times (a, b)) :: d -> cannam@167: maybep ^ (op "FMA" a b c) ^ (unparse_plus yes d) cannam@167: | (Uminus a :: b) -> cannam@167: " - " ^ (parenthesize a) ^ (unparse_plus yes b) cannam@167: | (a :: b) -> cannam@167: maybep ^ (parenthesize a) ^ (unparse_plus yes b) cannam@167: and parenthesize x = match x with cannam@167: | (Load _) -> unparse_expr_c x cannam@167: | (Num _) -> unparse_expr_c x cannam@167: | _ -> "(" ^ (unparse_expr_c x) ^ ")" cannam@167: and op nam a b c = cannam@167: nam ^ "(" ^ (unparse_expr_c a) ^ ", " ^ (unparse_expr_c b) ^ ", " ^ cannam@167: (unparse_expr_c c) ^ ")" cannam@167: cannam@167: in function cannam@167: | Load v -> Variable.unparse v cannam@167: | Num n -> Number.to_konst n cannam@167: | Plus [] -> "0.0 /* bug */" cannam@167: | Plus [a] -> " /* bug */ " ^ (unparse_expr_c a) cannam@167: | Plus a -> (unparse_plus no a) cannam@167: | Times (a, b) -> (parenthesize a) ^ " * " ^ (parenthesize b) cannam@167: | Uminus (Plus [a; Uminus b]) -> unparse_plus no [b; Uminus a] cannam@167: | Uminus a -> "- " ^ (parenthesize a) cannam@167: | _ -> failwith "unparse_expr_c" cannam@167: cannam@167: and unparse_expr_generic = cannam@167: let rec u x = unparse_expr_generic x cannam@167: and unary op a = Printf.sprintf "%s(%s)" op (u a) cannam@167: and binary op a b = Printf.sprintf "%s(%s, %s)" op (u a) (u b) cannam@167: and ternary op a b c = Printf.sprintf "%s(%s, %s, %s)" op (u a) (u b) (u c) cannam@167: and quaternary op a b c d = cannam@167: Printf.sprintf "%s(%s, %s, %s, %s)" op (u a) (u b) (u c) (u d) cannam@167: and unparse_plus = function cannam@167: | [(Uminus (Times (a, b))); Times (c, d)] -> quaternary "FNMMS" a b c d cannam@167: | [Times (c, d); (Uminus (Times (a, b)))] -> quaternary "FNMMS" a b c d cannam@167: | [Times (c, d); (Times (a, b))] -> quaternary "FMMA" a b c d cannam@167: | [(Uminus (Times (a, b))); c] -> ternary "FNMS" a b c cannam@167: | [c; (Uminus (Times (a, b)))] -> ternary "FNMS" a b c cannam@167: | [(Uminus c); (Times (a, b))] -> ternary "FMS" a b c cannam@167: | [(Times (a, b)); (Uminus c)] -> ternary "FMS" a b c cannam@167: | [c; (Times (a, b))] -> ternary "FMA" a b c cannam@167: | [(Times (a, b)); c] -> ternary "FMA" a b c cannam@167: | [a; Uminus b] -> binary "SUB" a b cannam@167: | [a; b] -> binary "ADD" a b cannam@167: | a :: b :: c -> binary "ADD" a (Plus (b :: c)) cannam@167: | _ -> failwith "unparse_plus" cannam@167: in function cannam@167: | Load v -> Variable.unparse v cannam@167: | Num n -> Number.to_konst n cannam@167: | Plus a -> unparse_plus a cannam@167: | Times (a, b) -> binary "MUL" a b cannam@167: | Uminus a -> unary "NEG" a cannam@167: | _ -> failwith "unparse_expr" cannam@167: cannam@167: and unparse_expr x = cannam@167: if !Magic.generic_arith then cannam@167: unparse_expr_generic x cannam@167: else cannam@167: unparse_expr_c x cannam@167: cannam@167: and unparse_assignment (Assign (v, x)) = cannam@167: (Variable.unparse v) ^ " = " ^ (unparse_expr x) ^ ";\n" cannam@167: cannam@167: and unparse_annotated force_bracket = cannam@167: let rec unparse_code = function cannam@167: ADone -> "" cannam@167: | AInstr i -> unparse_assignment i cannam@167: | ASeq (a, b) -> cannam@167: (unparse_annotated false a) ^ (unparse_annotated false b) cannam@167: and declare_variables l = cannam@167: let rec uvar = function cannam@167: [] -> failwith "uvar" cannam@167: | [v] -> (Variable.unparse v) ^ ";\n" cannam@167: | a :: b -> (Variable.unparse a) ^ ", " ^ (uvar b) cannam@167: in let rec vvar l = cannam@167: let s = if !Magic.compact then 15 else 1 in cannam@167: if (List.length l <= s) then cannam@167: match l with cannam@167: [] -> "" cannam@167: | _ -> extended_realtype ^ " " ^ (uvar l) cannam@167: else cannam@167: (vvar (Util.take s l)) ^ (vvar (Util.drop s l)) cannam@167: in vvar (List.filter Variable.is_temporary l) cannam@167: in function cannam@167: Annotate (_, _, decl, _, code) -> cannam@167: if (not force_bracket) && (Util.null decl) then cannam@167: unparse_code code cannam@167: else "{\n" ^ cannam@167: (declare_variables decl) ^ cannam@167: (unparse_code code) ^ cannam@167: "}\n" cannam@167: cannam@167: and unparse_decl = function cannam@167: | Decl (a, b) -> a ^ " " ^ b ^ ";\n" cannam@167: | Tdecl x -> x cannam@167: cannam@167: and unparse_ast = cannam@167: let rec unparse_plus = function cannam@167: | [] -> "" cannam@167: | (CUminus a :: b) -> " - " ^ (parenthesize a) ^ (unparse_plus b) cannam@167: | (a :: b) -> " + " ^ (parenthesize a) ^ (unparse_plus b) cannam@167: and parenthesize x = match x with cannam@167: | (CVar _) -> unparse_ast x cannam@167: | (CCall _) -> unparse_ast x cannam@167: | (Integer _) -> unparse_ast x cannam@167: | _ -> "(" ^ (unparse_ast x) ^ ")" cannam@167: cannam@167: in cannam@167: function cannam@167: | Asch a -> (unparse_annotated true a) cannam@167: | Simd_leavefun -> "" (* used only in SIMD code *) cannam@167: | Return x -> "return " ^ unparse_ast x ^ ";" cannam@167: | For (a, b, c, d) -> cannam@167: "for (" ^ cannam@167: unparse_ast a ^ "; " ^ unparse_ast b ^ "; " ^ unparse_ast c cannam@167: ^ ")" ^ unparse_ast d cannam@167: | If (a, d) -> cannam@167: "if (" ^ cannam@167: unparse_ast a cannam@167: ^ ")" ^ unparse_ast d cannam@167: | Block (d, s) -> cannam@167: if (s == []) then "" cannam@167: else cannam@167: "{\n" ^ cannam@167: foldr_string_concat (map unparse_decl d) ^ cannam@167: foldr_string_concat (map unparse_ast s) ^ cannam@167: "}\n" cannam@167: | Binop (op, a, b) -> (unparse_ast a) ^ op ^ (unparse_ast b) cannam@167: | Expr_assign (a, b) -> (unparse_ast a) ^ " = " ^ (unparse_ast b) cannam@167: | Stmt_assign (a, b) -> (unparse_ast a) ^ " = " ^ (unparse_ast b) ^ ";\n" cannam@167: | Comma (a, b) -> (unparse_ast a) ^ ", " ^ (unparse_ast b) cannam@167: | Integer i -> string_of_int i cannam@167: | CVar s -> s cannam@167: | CCall (s, x) -> s ^ "(" ^ (unparse_ast x) ^ ")" cannam@167: | CPlus [] -> "0 /* bug */" cannam@167: | CPlus [a] -> " /* bug */ " ^ (unparse_ast a) cannam@167: | CPlus (a::b) -> (parenthesize a) ^ (unparse_plus b) cannam@167: | ITimes (a, b) -> (parenthesize a) ^ " * " ^ (parenthesize b) cannam@167: | CUminus a -> "- " ^ (parenthesize a) cannam@167: cannam@167: and unparse_function = function cannam@167: Fcn (typ, name, args, body) -> cannam@167: let rec unparse_args = function cannam@167: [Decl (a, b)] -> a ^ " " ^ b cannam@167: | (Decl (a, b)) :: s -> a ^ " " ^ b ^ ", " cannam@167: ^ unparse_args s cannam@167: | [] -> "" cannam@167: | _ -> failwith "unparse_function" cannam@167: in cannam@167: (typ ^ " " ^ name ^ "(" ^ unparse_args args ^ ")\n" ^ cannam@167: unparse_ast body) cannam@167: cannam@167: cannam@167: (************************************************************* cannam@167: * traverse a a function and return a list of all expressions, cannam@167: * in the execution order cannam@167: **************************************************************) cannam@167: let rec fcn_to_expr_list = fun (Fcn (_, _, _, body)) -> ast_to_expr_list body cannam@167: and acode_to_expr_list = function cannam@167: AInstr (Assign (_, x)) -> [x] cannam@167: | ASeq (a, b) -> cannam@167: (asched_to_expr_list a) @ (asched_to_expr_list b) cannam@167: | _ -> [] cannam@167: and asched_to_expr_list (Annotate (_, _, _, _, code)) = cannam@167: acode_to_expr_list code cannam@167: and ast_to_expr_list = function cannam@167: Asch a -> asched_to_expr_list a cannam@167: | Block (_, a) -> flatten (map ast_to_expr_list a) cannam@167: | For (_, _, _, body) -> ast_to_expr_list body cannam@167: | If (_, body) -> ast_to_expr_list body cannam@167: | _ -> [] cannam@167: cannam@167: (*********************** cannam@167: * Extracting Constants cannam@167: ***********************) cannam@167: cannam@167: (* add a new key & value to a list of (key,value) pairs, where cannam@167: the keys are floats and each key is unique up to almost_equal *) cannam@167: cannam@167: let extract_constants f = cannam@167: let constlist = flatten (map expr_to_constants (ast_to_expr_list f)) cannam@167: in map cannam@167: (fun n -> cannam@167: Tdecl cannam@167: ("DK(" ^ (Number.to_konst n) ^ ", " ^ (Number.to_string n) ^ cannam@167: ");\n")) cannam@167: (unique_constants constlist) cannam@167: cannam@167: (****************************** cannam@167: Extracting operation counts cannam@167: ******************************) cannam@167: cannam@167: let count_stack_vars = cannam@167: let rec count_acode = function cannam@167: | ASeq (a, b) -> max (count_asched a) (count_asched b) cannam@167: | _ -> 0 cannam@167: and count_asched (Annotate (_, _, decl, _, code)) = cannam@167: (length decl) + (count_acode code) cannam@167: and count_ast = function cannam@167: | Asch a -> count_asched a cannam@167: | Block (d, a) -> (length d) + (Util.max_list (map count_ast a)) cannam@167: | For (_, _, _, body) -> count_ast body cannam@167: | If (_, body) -> count_ast body cannam@167: | _ -> 0 cannam@167: in function (Fcn (_, _, _, body)) -> count_ast body cannam@167: cannam@167: let count_memory_acc f = cannam@167: let rec count_var v = cannam@167: if (Variable.is_locative v) then 1 else 0 cannam@167: and count_acode = function cannam@167: | AInstr (Assign (v, _)) -> count_var v cannam@167: | ASeq (a, b) -> (count_asched a) + (count_asched b) cannam@167: | _ -> 0 cannam@167: and count_asched = function cannam@167: Annotate (_, _, _, _, code) -> count_acode code cannam@167: and count_ast = function cannam@167: | Asch a -> count_asched a cannam@167: | Block (_, a) -> (Util.sum_list (map count_ast a)) cannam@167: | Comma (a, b) -> (count_ast a) + (count_ast b) cannam@167: | For (_, _, _, body) -> count_ast body cannam@167: | If (_, body) -> count_ast body cannam@167: | _ -> 0 cannam@167: and count_acc_expr_func acc = function cannam@167: | Load v -> acc + (count_var v) cannam@167: | Plus a -> fold_left count_acc_expr_func acc a cannam@167: | Times (a, b) -> fold_left count_acc_expr_func acc [a; b] cannam@167: | Uminus a -> count_acc_expr_func acc a cannam@167: | _ -> acc cannam@167: in let (Fcn (typ, name, args, body)) = f cannam@167: in (count_ast body) + cannam@167: fold_left count_acc_expr_func 0 (fcn_to_expr_list f) cannam@167: cannam@167: let good_for_fma = To_alist.good_for_fma cannam@167: cannam@167: let build_fma = function cannam@167: | [a; Times (b, c)] when good_for_fma (b, c) -> Some (a, b, c) cannam@167: | [Times (b, c); a] when good_for_fma (b, c) -> Some (a, b, c) cannam@167: | [a; Uminus (Times (b, c))] when good_for_fma (b, c) -> Some (a, b, c) cannam@167: | [Uminus (Times (b, c)); a] when good_for_fma (b, c) -> Some (a, b, c) cannam@167: | _ -> None cannam@167: cannam@167: let rec count_flops_expr_func (adds, mults, fmas) = function cannam@167: | Plus [] -> (adds, mults, fmas) cannam@167: | Plus ([_; _] as a) -> cannam@167: begin cannam@167: match build_fma a with cannam@167: | None -> cannam@167: fold_left count_flops_expr_func cannam@167: (adds + (length a) - 1, mults, fmas) a cannam@167: | Some (a, b, c) -> cannam@167: fold_left count_flops_expr_func (adds, mults, fmas+1) [a; b; c] cannam@167: end cannam@167: | Plus (a :: b) -> cannam@167: count_flops_expr_func (adds, mults, fmas) (Plus [a; Plus b]) cannam@167: | Times (NaN MULTI_A,_) -> (adds, mults, fmas) cannam@167: | Times (NaN MULTI_B,_) -> (adds, mults, fmas) cannam@167: | Times (NaN I,b) -> count_flops_expr_func (adds, mults, fmas) b cannam@167: | Times (NaN CONJ,b) -> count_flops_expr_func (adds, mults, fmas) b cannam@167: | Times (a,b) -> fold_left count_flops_expr_func (adds, mults+1, fmas) [a; b] cannam@167: | CTimes (a,b) -> cannam@167: fold_left count_flops_expr_func (adds+1, mults+2, fmas) [a; b] cannam@167: | CTimesJ (a,b) -> cannam@167: fold_left count_flops_expr_func (adds+1, mults+2, fmas) [a; b] cannam@167: | Uminus a -> count_flops_expr_func (adds, mults, fmas) a cannam@167: | _ -> (adds, mults, fmas) cannam@167: cannam@167: let count_flops f = cannam@167: fold_left count_flops_expr_func (0, 0, 0) (fcn_to_expr_list f) cannam@167: cannam@167: let count_constants f = cannam@167: length (unique_constants (flatten (map expr_to_constants (fcn_to_expr_list f)))) cannam@167: cannam@167: let arith_complexity f = cannam@167: let (a, m, fmas) = count_flops f cannam@167: and v = count_stack_vars f cannam@167: and c = count_constants f cannam@167: and mem = count_memory_acc f cannam@167: in (a, m, fmas, v, c, mem) cannam@167: cannam@167: (* print the operation costs *) cannam@167: let print_cost f = cannam@167: let Fcn (_, _, _, _) = f cannam@167: and (a, m, fmas, v, c, mem) = arith_complexity f cannam@167: in cannam@167: "/*\n"^ cannam@167: " * This function contains " ^ cannam@167: (string_of_int (a + fmas)) ^ " FP additions, " ^ cannam@167: (string_of_int (m + fmas)) ^ " FP multiplications,\n" ^ cannam@167: " * (or, " ^ cannam@167: (string_of_int a) ^ " additions, " ^ cannam@167: (string_of_int m) ^ " multiplications, " ^ cannam@167: (string_of_int fmas) ^ " fused multiply/add),\n" ^ cannam@167: " * " ^ (string_of_int v) ^ " stack variables, " ^ cannam@167: (string_of_int c) ^ " constants, and " ^ cannam@167: (string_of_int mem) ^ " memory accesses\n" ^ cannam@167: " */\n" cannam@167: cannam@167: (***************************************** cannam@167: * functions that create C arrays cannam@167: *****************************************) cannam@167: type stride = cannam@167: | SVar of string cannam@167: | SConst of string cannam@167: | SInteger of int cannam@167: | SNeg of stride cannam@167: cannam@167: type sstride = cannam@167: | Simple of int cannam@167: | Constant of (string * int) cannam@167: | Composite of (string * int) cannam@167: | Negative of sstride cannam@167: cannam@167: let rec simplify_stride stride i = cannam@167: match (stride, i) with cannam@167: (_, 0) -> Simple 0 cannam@167: | (SInteger n, i) -> Simple (n * i) cannam@167: | (SConst s, i) -> Constant (s, i) cannam@167: | (SVar s, i) -> Composite (s, i) cannam@167: | (SNeg x, i) -> cannam@167: match (simplify_stride x i) with cannam@167: | Negative y -> y cannam@167: | y -> Negative y cannam@167: cannam@167: let rec cstride_to_string = function cannam@167: | Simple i -> string_of_int i cannam@167: | Constant (s, i) -> cannam@167: if !Magic.lisp_syntax then cannam@167: "(* " ^ s ^ " " ^ (string_of_int i) ^ ")" cannam@167: else cannam@167: s ^ " * " ^ (string_of_int i) cannam@167: | Composite (s, i) -> cannam@167: if !Magic.lisp_syntax then cannam@167: "(* " ^ s ^ " " ^ (string_of_int i) ^ ")" cannam@167: else cannam@167: "WS(" ^ s ^ ", " ^ (string_of_int i) ^ ")" cannam@167: | Negative x -> "-" ^ cstride_to_string x cannam@167: cannam@167: let aref name index = cannam@167: if !Magic.lisp_syntax then cannam@167: Printf.sprintf "(aref %s %s)" name index cannam@167: else cannam@167: Printf.sprintf "%s[%s]" name index cannam@167: cannam@167: let array_subscript name stride k = cannam@167: aref name (cstride_to_string (simplify_stride stride k)) cannam@167: cannam@167: let varray_subscript name vstride stride v i = cannam@167: let vindex = simplify_stride vstride v cannam@167: and iindex = simplify_stride stride i cannam@167: in cannam@167: let index = cannam@167: match (vindex, iindex) with cannam@167: (Simple vi, Simple ii) -> string_of_int (vi + ii) cannam@167: | (Simple 0, x) -> cstride_to_string x cannam@167: | (x, Simple 0) -> cstride_to_string x cannam@167: | _ -> (cstride_to_string vindex) ^ " + " ^ (cstride_to_string iindex) cannam@167: in aref name index cannam@167: cannam@167: let real_of s = "c_re(" ^ s ^ ")" cannam@167: let imag_of s = "c_im(" ^ s ^ ")" cannam@167: cannam@167: let flops_of f = cannam@167: let (add, mul, fma) = count_flops f in cannam@167: Printf.sprintf "{ %d, %d, %d, 0 }" add mul fma