1(* 2 * Copyright (c) 1997-1999, 2003 Massachusetts Institute of Technology 3 * 4 * This program is free software; you can redistribute it and/or modify 5 * it under the terms of the GNU General Public License as published by 6 * the Free Software Foundation; either version 2 of the License, or 7 * (at your option) any later version. 8 * 9 * This program is distributed in the hope that it will be useful, 10 * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 * GNU General Public License for more details. 13 * 14 * You should have received a copy of the GNU General Public License 15 * along with this program; if not, write to the Free Software 16 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 17 * 18 *) 19 20(* $Id: to_c.ml,v 1.26 2003/03/16 23:43:46 stevenj Exp $ *) 21 22let cvsid = "$Id: to_c.ml,v 1.26 2003/03/16 23:43:46 stevenj Exp $" 23 24open Expr 25open Asched 26open List 27 28(* Here, we have routines for outputting the C source code for FFTW 29 using the abstract syntax tree (AST), symbolic expressions, 30 etcetera, produced by the rest of the generator. *) 31 32let foldr_string_concat l = fold_right (^) l "" 33 34(* output the command line *) 35let cmdline () = 36 fold_right (fun a b -> a ^ " " ^ b) (Array.to_list Sys.argv) "" 37 38let paranoid_alignment_check () = 39 if !Magic.alignment_check then 40 "ASSERT_ALIGNED_DOUBLE;\n" 41 else 42 "" 43 44(*********************************** 45 * C program structure 46 ***********************************) 47type c_decl = Decl of string * string 48type c_ast = 49 Asch of annotated_schedule 50 | For of c_ast * c_ast * c_ast * c_ast 51 | If of c_ast * c_ast 52 | Block of (c_decl list) * (c_ast list) 53 | Binop of string * expr * expr 54 | Expr_assign of expr * expr 55 | Stmt_assign of expr * expr 56 | Comma of c_ast * c_ast 57 58type c_fcn = Fcn of string * string * (c_decl list) * c_ast 59 60let real = "fftw_real" 61 62 63(* 64 * traverse a a function and return a list of all expressions, 65 * in the execution order 66 *) 67let rec fcn_to_expr_list = 68 let rec acode_to_expr_list = function 69 AInstr (Assign (_, x)) -> [x] 70 | ASeq (a, b) -> 71 (asched_to_expr_list a) @ (asched_to_expr_list b) 72 | _ -> [] 73 and asched_to_expr_list (Annotate (_, _, _, _, code)) = 74 acode_to_expr_list code 75 and ast_to_expr_list = function 76 Asch a -> asched_to_expr_list a 77 | Block (_, a) -> flatten (map ast_to_expr_list a) 78 | For (_, _, _, body) -> ast_to_expr_list body 79 | If (_, body) -> ast_to_expr_list body 80 | _ -> [] 81 82 in fun (Fcn (_, _, _, body)) -> ast_to_expr_list body 83 84 85(***************** Extracting Operation Counts ***************) 86 87let count_stack_vars = 88 let rec count_acode = function 89 | ASeq (a, b) -> max (count_asched a) (count_asched b) 90 | _ -> 0 91 and count_asched (Annotate (_, _, decl, _, code)) = 92 (length decl) + (count_acode code) 93 and count_ast = function 94 | Asch a -> count_asched a 95 | Block (d, a) -> (length d) + (Util.max_list (map count_ast a)) 96 | For (_, _, _, body) -> count_ast body 97 | If (_, body) -> count_ast body 98 | _ -> 0 99 in function (Fcn (_, _, _, body)) -> count_ast body 100 101let count_memory_acc f = 102 let rec count_var v = 103 if (Variable.is_input v) or (Variable.is_output v) 104 then 1 105 else 0 106 and count_acode = function 107 | AInstr (Assign (v, _)) -> count_var v 108 | ASeq (a, b) -> (count_asched a) + (count_asched b) 109 | _ -> 0 110 and count_asched = function 111 Annotate (_, _, _, _, code) -> count_acode code 112 and count_ast = function 113 | Asch a -> count_asched a 114 | Block (_, a) -> (Util.sum_list (map count_ast a)) 115 | Comma (a, b) -> (count_ast a) + (count_ast b) 116 | For (_, _, _, body) -> count_ast body 117 | If (_, body) -> count_ast body 118 | _ -> 0 119 and count_acc_expr_func acc = function 120 | Var v -> acc + (count_var v) 121 | Plus a -> fold_left count_acc_expr_func acc a 122 | Times (a, b) -> fold_left count_acc_expr_func acc [a; b] 123 | Uminus a -> count_acc_expr_func acc a 124 | _ -> acc 125 in let (Fcn (typ, name, args, body)) = f 126 in (count_ast body) + 127 fold_left count_acc_expr_func 0 (fcn_to_expr_list f) 128 129let build_fma = function 130 | [a; Times (b, c)] -> Some (a, b, c) 131 | [Times (b, c); a] -> Some (a, b, c) 132 | [a; Uminus (Times (b, c))] -> Some (a, b, c) 133 | [Uminus (Times (b, c)); a] -> Some (a, b, c) 134 | _ -> None 135 136let rec count_flops_expr_func (adds, mults, fmas) = function 137 | Plus [] -> (adds, mults, fmas) 138 | Plus a -> (match build_fma a with 139 None -> 140 let (newadds, newmults, newfmas) = 141 fold_left count_flops_expr_func (adds, mults, fmas) a 142 in (newadds + (length a) - 1, newmults, newfmas) 143 | Some (a, b, c) -> 144 let (newadds, newmults, newfmas) = 145 fold_left count_flops_expr_func (adds, mults, fmas) [a; b; c] 146 in (newadds, newmults, newfmas + 1)) 147 | Times (a,b) -> 148 let (newadds, newmults, newfmas) = 149 fold_left count_flops_expr_func (adds, mults, fmas) [a; b] 150 in (newadds, newmults + 1, newfmas) 151 | Uminus a -> count_flops_expr_func (adds, mults, fmas) a 152 | _ -> (adds, mults, fmas) 153 154let count_flops f = 155 fold_left count_flops_expr_func (0, 0, 0) (fcn_to_expr_list f) 156 157let arith_complexity f = 158 let (a, m, fmas) = count_flops f 159 and v = count_stack_vars f 160 and mem = count_memory_acc f 161 in (a, m, fmas, v, mem) 162 163(* print the operation costs *) 164let print_cost f = 165 let Fcn (_, name, _, _) = f 166 and (a, m, fmas, v, mem) = arith_complexity f 167 in 168 "/*\n"^ 169 " * This function contains " ^ 170 (string_of_int (a + fmas)) ^ " FP additions, " ^ 171 (string_of_int (m + fmas)) ^ " FP multiplications,\n" ^ 172 " * (or, " ^ 173 (string_of_int a) ^ " additions, " ^ 174 (string_of_int m) ^ " multiplications, " ^ 175 (string_of_int fmas) ^ " fused multiply/add),\n" ^ 176 " * " ^ (string_of_int v) ^ " stack variables, and " ^ 177 (string_of_int mem) ^ " memory accesses\n" ^ 178 " */\n" 179 180(***************** Extracting Constants ***************) 181 182(* add a new key & value to a list of (key,value) pairs, where 183 the keys are floats and each key is unique up to almost_equal *) 184 185let add_float_key_value list_so_far k = 186 if exists (fun k2 -> Number.equal k k2) list_so_far then 187 list_so_far 188 else 189 k :: list_so_far 190 191(* find all constants in a given expression *) 192let rec expr_to_constants = function 193 | Num n -> [n] 194 | Plus a -> flatten (map expr_to_constants a) 195 | Times (a, b) -> (expr_to_constants a) @ (expr_to_constants b) 196 | Uminus a -> expr_to_constants a 197 | _ -> [] 198 199let extract_constants f = 200 let constlist = flatten (map expr_to_constants (fcn_to_expr_list f)) 201 in let unique_constants = fold_left add_float_key_value [] constlist 202 in let use_define () = foldr_string_concat 203 (map (function n -> 204 "#define " ^ 205 (Number.unparse n) ^ " " ^ 206 "FFTW_KONST(" ^ (Number.to_string n) ^ ")\n") 207 unique_constants) 208 and use_const () = foldr_string_concat 209 (map (function n -> 210 "static const " ^ real ^ " " ^ 211 (Number.unparse n) ^ " = " ^ 212 "FFTW_KONST(" ^ (Number.to_string n) ^ ");\n") 213 unique_constants) 214 in 215 if !Magic.inline_konstants then 216 use_define () ^ "\n\n" 217 else 218 use_const () ^ "\n\n" 219 220(******************* Unparsing the Abstract Syntax Tree *******************) 221 222(* make an unparser, given a variable unparser *) 223let make_c_unparser unparse_var = 224 225 let rec unparse_expr = 226 let rec unparse_plus = function 227 [] -> "" 228 | (Uminus a :: b) -> " - " ^ (parenthesize a) ^ (unparse_plus b) 229 | (a :: b) -> " + " ^ (parenthesize a) ^ (unparse_plus b) 230 and parenthesize x = match x with 231 | (Var _) -> unparse_expr x 232 | (Integer _) -> unparse_expr x 233 | (Num _) -> unparse_expr x 234 | _ -> "(" ^ (unparse_expr x) ^ ")" 235 236 in function 237 Var x -> unparse_var x 238 | Num n -> Number.unparse n 239 | Integer n -> (string_of_int n) 240 | Plus [] -> "0.0 /* bug */" 241 | Plus [a] -> " /* bug */ " ^ (unparse_expr a) 242 | Plus (a::b) -> (parenthesize a) ^ (unparse_plus b) 243 | Times (a, b) -> (parenthesize a) ^ " * " ^ (parenthesize b) 244 | Uminus a -> "- " ^ (parenthesize a) 245 246 and unparse_decl = function 247 Decl (a, b) -> a ^ " " ^ b ^ ";\n" 248 249 and unparse_assignment (Assign (v, x)) = 250 (unparse_var v) ^ " = " ^ (unparse_expr x) ^ ";\n" 251 252 and unparse_annotated force_bracket = 253 let rec unparse_code = function 254 ADone -> "" 255 | AInstr i -> unparse_assignment i 256 | ASeq (a, b) -> 257 (unparse_annotated false a) ^ (unparse_annotated false b) 258 and declare_variables = function 259 [] -> "" 260 | v :: l when Variable.is_temporary v -> 261 (real ^ " " ^ (unparse_var v) ^ ";\n") ^ (declare_variables l) 262 | s :: l -> (declare_variables l) 263 in function 264 Annotate (_, _, decl, _, code) -> 265 if (not force_bracket) && (Util.null decl) then 266 unparse_code code 267 else "{\n" ^ 268 (declare_variables decl) ^ 269 paranoid_alignment_check() ^ 270 (unparse_code code) ^ 271 "}\n" 272 273 and unparse_ast = function 274 Asch a -> (unparse_annotated true a) 275 | For (a, b, c, d) -> 276 "for (" ^ 277 unparse_ast a ^ "; " ^ unparse_ast b ^ "; " ^ unparse_ast c 278 ^ ")" ^ unparse_ast d 279 | If (a, d) -> 280 "if (" ^ 281 unparse_ast a 282 ^ ")" ^ unparse_ast d 283 | Block (d, s) -> 284 if (s == []) then "" 285 else 286 "{\n" ^ 287 foldr_string_concat (map unparse_decl d) ^ 288 foldr_string_concat (map unparse_ast s) ^ 289 "}\n" 290 | Binop (op, a, b) -> (unparse_expr a) ^ op ^ (unparse_expr b) 291 | Expr_assign (a, b) -> (unparse_expr a) ^ " = " ^ (unparse_expr b) 292 | Stmt_assign (a, b) -> (unparse_expr a) ^ " = " ^ (unparse_expr b) ^ ";\n" 293 | Comma (a, b) -> (unparse_ast a) ^ ", " ^ (unparse_ast b) 294 295 296 and unparse_function = function 297 Fcn (typ, name, args, body) -> 298 let rec unparse_args = function 299 [Decl (a, b)] -> a ^ " " ^ b 300 | (Decl (a, b)) :: s -> a ^ " " ^ b ^ ", " 301 ^ unparse_args s 302 | [] -> "" 303 in 304 (typ ^ " " ^ name ^ "(" ^ unparse_args args ^ ")\n" ^ 305 unparse_ast body) 306 307 in function tree -> 308 "/* Generated by: " ^ (cmdline ()) ^ "*/\n\n" ^ 309 (print_cost tree) ^ 310 (extract_constants tree) ^ 311 "/*\n" ^ 312 " * Generator Id's : \n" ^ 313 " * " ^ Exprdag.cvsid ^ "\n" ^ 314 " * " ^ Fft.cvsid ^ "\n" ^ 315 " * " ^ cvsid ^ "\n" ^ 316 " */\n\n" ^ 317 (unparse_function tree) 318 319 320