genfft.ml

FFTW, a collection of fast C routines to compute the Discrete Fourier Transform in one or more dime

(*
 * Copyright (c) 1997-1999, 2003 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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *
 *)

(* $Id: genfft.ml,v 1.79 2003/03/16 23:43:46 stevenj Exp $ *)

(* This file contains the entry point for the genfft program: it
   parses the command-line parameters and calls the rest of the
   program as needed to generate the requested code. *)

open Util
open To_c
open Expr

let optimize expr =
  let _ = info "simplifiying..." in
  let simple =  Exprdag.simplify_to_alist expr in
  let _ = info "scheduling..." in
  let scheduled = Schedule.schedule simple in
  let _ = info "annotating..." in
  let annotated = Asched.annotate scheduled in
  let _ = info "unparsing..." in
  annotated

let make_expr name = Var (Variable.make_named name)

let iarray = "input"
let oarray = "output"
let istride = "istride"
let ostride = "ostride"
let twiddle_order = "twiddle_order"

type codelet_type = TWIDDLE | NO_TWIDDLE | REAL2HC | HC2HC | HC2REAL
                    | REALEVEN | REALODD | REALEVEN2 | REALODD2
                    | REALEVEN_TWIDDLE | REALODD_TWIDDLE
		    | MP3MDCT  (* mdct used in mp3 encoding *)

let rec list_to_c = function
    [] -> ""
  | [a] -> (string_of_int a)
  | a :: b -> (string_of_int a) ^ ", " ^ (list_to_c b)

let codelet_description n dir ty f =
  let Fcn (_, name, _, _) = f 
  and (ctype, itype) = match ty with
    TWIDDLE -> "FFTW_TWIDDLE", 0
  | NO_TWIDDLE -> "FFTW_NOTW", 1
  | REAL2HC -> "FFTW_REAL2HC", 2
  | HC2HC -> "FFTW_HC2HC", 3
  | HC2REAL -> "FFTW_HC2REAL", 4
  | REALEVEN -> "FFTW_REALEVEN", 5
  | REALODD -> "FFTW_REALODD", 6
  | REALEVEN2 -> "FFTW_REALEVEN2", 7
  | REALODD2 -> "FFTW_REALODD2", 8
  | REALEVEN_TWIDDLE -> "FFTW_REALEVEN_TWIDDLE", 9
  | REALODD_TWIDDLE -> "FFTW_REALODD_TWIDDLE", 10
  | MP3MDCT -> "FFTW_MP3MDCT", 11
  and (cdir, idir) = match dir with
    Fft.FORWARD -> "FFTW_FORWARD", 0
  | Fft.BACKWARD -> "FFTW_BACKWARD", 1

  and (_, num_twiddle, tw_o) = Twiddle.twiddle_policy ()
  in let (declare_order, order, nt) =
    match ty with
      TWIDDLE -> ("static const int " ^ twiddle_order ^ "[] = {" ^
		  (list_to_c (tw_o n)) ^ "};\n"),
	twiddle_order,
	num_twiddle n
    | NO_TWIDDLE -> "", "(const int *) 0", 0
    | REAL2HC -> "", "(const int *) 0", 0
    | HC2HC -> 
	("static const int " ^ twiddle_order ^ "[] = {" ^
		  (list_to_c (tw_o n)) ^ "};\n"),
	twiddle_order,
	num_twiddle n
    | HC2REAL -> "", "(const int *) 0", 0
    | REALEVEN -> "", "(const int *) 0", 0
    | REALODD -> "", "(const int *) 0", 0
    | REALEVEN2 -> "", "(const int *) 0", 0
    | REALODD2 -> "", "(const int *) 0", 0
    | REALEVEN_TWIDDLE -> 
        ("static const int " ^ twiddle_order ^ "[] = {" ^
                  (list_to_c (tw_o n)) ^ "};\n"),
        twiddle_order,
        num_twiddle n
    | REALODD_TWIDDLE -> 
        ("static const int " ^ twiddle_order ^ "[] = {" ^
                  (list_to_c (tw_o n)) ^ "};\n"),
        twiddle_order,
        num_twiddle n
    | MP3MDCT -> "", "(const int *) 0", 0

  (* this should be replaced by CRC/MD5 of the codelet *)
  and signature = 11 * (2 * n + idir) + itype 

  in "\n\n" ^ declare_order ^
  "fftw_codelet_desc " ^ name ^ "_desc = {\n" ^
  "\"" ^ name ^ "\",\n" ^
  "(void (*)()) " ^ name ^ ",\n" ^
  (string_of_int n) ^ ",\n" ^
  cdir ^ ",\n" ^
  ctype ^ ",\n" ^
  (string_of_int signature) ^ ",\n" ^
  (string_of_int nt) ^ ",\n" ^
  order ^ ",\n" ^
  "};\n"

let fftw_no_twiddle_gen n dir =
  let _ = info "generating..." in
  let asch = optimize (Fft.no_twiddle_gen_expr n Symmetry.no_sym dir)
  and ns = string_of_int n
  and (name, sign) = match dir with
    Fft.FORWARD -> "fftw_no_twiddle_", (-1)
  | Fft.BACKWARD -> "fftwi_no_twiddle_", 1
  and unparse_var = 
    Variable.make_unparser (iarray, Some istride) 
      (oarray, Some ostride) ("BUG", None)
  in let tree = 
	Fcn ("void", name ^ ns,
	     [Decl ("const fftw_complex *", iarray);
	      Decl ("fftw_complex *", oarray);
	      Decl ("int", istride);
	      Decl ("int", ostride)],
	     Asch asch)
  in let desc = codelet_description n dir NO_TWIDDLE tree
  in ((make_c_unparser unparse_var) tree) ^ desc

let athena_no_twiddle_gen n dir =
  let _ = info "generating..." in
  let asch = optimize (Fft.no_twiddle_gen_expr n Symmetry.no_sym dir)
  and ns = string_of_int n
  and (name, sign) = match dir with
    Fft.FORWARD -> "athfft_", (-1)
  | Fft.BACKWARD -> "athffti_", 1
  and unparse_var = 
    Variable.make_unparser (iarray, None) 
      (iarray, None) ("BUG", None)
  in let tree = 
	Fcn ("void", name ^ ns,
	     [Decl ("fftw_complex *", iarray)],
	     Asch asch)
  and prologue = 
    "#include \"athfft.h\"\n\n" ^
    (if dir == Fft.FORWARD then
      "int ath_permutation_" ^ ns ^ "(int i) { return i; }\n\n\n"
    else "")

  in prologue ^ ((make_c_unparser unparse_var) tree)

let no_twiddle_gen n dir =
  if (!Magic.athenafft) then
    athena_no_twiddle_gen n dir
  else
    fftw_no_twiddle_gen n dir

let real_oarray = "real_output"
let imag_oarray = "imag_output"
let real_ostride = "real_ostride"
let imag_ostride = "imag_ostride"

let real2hc_gen n =
  let _ = info "generating..." in
  let dir = Fft.FORWARD in
  let asch = optimize (Fft.no_twiddle_gen_expr n Symmetry.real_sym dir)
  and ns = string_of_int n
  and (name, sign) = "fftw_real2hc_", (-1)
  and unparse_var = 
    Variable.make_real2hc_unparser (iarray, Some istride) 
      (real_oarray, Some real_ostride) 
      (imag_oarray, Some imag_ostride) 
  in let tree = 
	Fcn ("void", name ^ ns,
	     [Decl ("const fftw_real *", iarray);
	      Decl ("fftw_real *", real_oarray);
	      Decl ("fftw_real *", imag_oarray);
	      Decl ("int", istride);
	      Decl ("int", real_ostride);
	       Decl ("int", imag_ostride)],
	     Asch asch)
  in let desc = codelet_description n dir REAL2HC tree
  in ((make_c_unparser unparse_var) tree) ^ desc


let real_iarray = "real_input"
let imag_iarray = "imag_input"
let real_istride = "real_istride"
let imag_istride = "imag_istride"

let hc2real_gen n =
  let _ = info "generating..." in
  let dir = Fft.BACKWARD in
  let asch = optimize (Fft.no_twiddle_gen_expr n Symmetry.hermitian_sym dir)
  and ns = string_of_int n
  and (name, sign) = "fftw_hc2real_", 1
  and unparse_var = 
    Variable.make_hc2real_unparser (real_iarray, Some real_istride) 
      (imag_iarray, Some imag_istride) 
      (oarray, Some ostride) 
  in let tree = 
	Fcn ("void", name ^ ns,
	     [Decl ("const fftw_real *", real_iarray);
	      Decl ("const fftw_real *", imag_iarray);
	      Decl ("fftw_real *", oarray);
	      Decl ("int", real_istride);
	      Decl ("int", imag_istride);
	       Decl ("int", ostride)],
	     Asch asch)
  in let desc = codelet_description n dir HC2REAL tree
  in ((make_c_unparser unparse_var) tree) ^ desc

let realeven_gen n =
  let _ = info "generating..." in
  let dir = Fft.FORWARD in
  let asch = optimize (Fft.no_twiddle_gen_expr n Symmetry.realeven_sym dir)
  and ns = string_of_int n
  and (name, sign) = "fftw_realeven_", (-1)
  and unparse_var = 
    Variable.make_realeven_unparser (iarray, Some istride) 
                                    (oarray, Some ostride) 
  in let tree = 
	Fcn ("void", name ^ ns,
	     [Decl ("const fftw_real *", iarray);
	      Decl ("fftw_real *", oarray);
	      Decl ("int", istride);
	      Decl ("int", ostride)],
	     Asch asch)
  in let desc = codelet_description n dir REALEVEN tree
  in ((make_c_unparser unparse_var) tree) ^ desc

let realodd_gen n =
  let _ = info "generating..." in
  let dir = Fft.FORWARD in
  let asch = optimize (Fft.no_twiddle_gen_expr n Symmetry.realodd_sym dir)
  and ns = string_of_int n
  and (name, sign) = "fftw_realodd_", (-1)
  and unparse_var = 
    Variable.make_realodd_unparser (iarray, Some istride) 
                                   (oarray, Some ostride) 
  in let tree = 
	Fcn ("void", name ^ ns,
	     [Decl ("const fftw_real *", iarray);
	      Decl ("fftw_real *", oarray);
	      Decl ("int", istride);
	      Decl ("int", ostride)],
	     Asch asch)
  in let desc = codelet_description n dir REALODD tree
  in ((make_c_unparser unparse_var) tree) ^ desc

let realeven2_gen n =
  let _ = info "generating..." in
  let dir = Fft.FORWARD in
  let asch = optimize (Fft.no_twiddle_gen_expr (2 * n)
                         Symmetry.realeven2_input_sym dir) 
  and ns = string_of_int n
  and (name, sign) = "fftw_realeven2_", (-1)
  and unparse_var = 
    Variable.make_realeven_unparser (iarray, Some istride) 
                                    (oarray, Some ostride) 
  in let tree = 
	Fcn ("void", name ^ ns,
	     [Decl ("const fftw_real *", iarray);
	      Decl ("fftw_real *", oarray);
	      Decl ("int", istride);
	      Decl ("int", ostride)],
	     Asch asch)
  in let desc = codelet_description n dir REALEVEN2 tree
  in ((make_c_unparser unparse_var) tree) ^ desc

let realodd2_gen n =
  let _ = info "generating..." in
  let dir = Fft.FORWARD in
  let asch = optimize (Fft.no_twiddle_gen_expr (2 * n)
			 Symmetry.realodd2_input_sym dir)
  and ns = string_of_int n
  and (name, sign) = "fftw_realodd2_", (-1)
  and unparse_var = 
    Variable.make_realodd2_unparser (iarray, Some istride) 
                                    (oarray, Some ostride) 
  in let tree = 
	Fcn ("void", name ^ ns,
	     [Decl ("const fftw_real *", iarray);
	      Decl ("fftw_real *", oarray);
	      Decl ("int", istride);
	      Decl ("int", ostride)],
	     Asch asch)
  in let desc = codelet_description n dir REALODD2 tree
  in ((make_c_unparser unparse_var) tree) ^ desc

let mp3mdct_gen n =
  let _ = info "generating..." in
  let dir = Fft.FORWARD in
  let asch = optimize (Fft.no_twiddle_gen_expr (4 * n)
                         Symmetry.mp3mdct_input_sym dir) 
  and ns = string_of_int n
  and (name, sign) = "fftw_mp3mdct_", (-1)
  and unparse_var = 
    Variable.make_realeven_unparser (iarray, None) (oarray, None) 
  in let tree = 
	Fcn ("void", name ^ ns,
	     [Decl ("const fftw_real *", iarray);
	      Decl ("fftw_real *", oarray)],
	     Asch asch)
  in let desc = codelet_description n dir MP3MDCT tree
  in ((make_c_unparser unparse_var) tree) ^ desc

let ioarray = "inout"
let iostride = "iostride"
let twarray = "W"

let fftw_twiddle_gen n dir =
  let _ = info "generating..." in
  let asch = optimize (Fft.twiddle_dit_gen_expr n Symmetry.no_sym 
			 Symmetry.no_sym dir)
  and ns = string_of_int n
  and m = "m"
  and dist = "dist"
  and a = "A"
  and i = "i"

  in let me = make_expr m
  and diste = make_expr dist
  and ae = make_expr a
  and ie = make_expr i
  and ioarraye = make_expr ioarray
  and twarraye = make_expr twarray

  and (name, sign) = match dir with
    Fft.FORWARD -> "fftw_twiddle_", (-1)
  | Fft.BACKWARD -> "fftwi_twiddle_", 1