module Sound.DF.CGen (
code_gen, dl_gen ) where
import Data.List
import Sound.DF.Node
import Sound.DF.Graph
import System.Cmd
import System.FilePath
code_gen :: Node -> String
code_gen n =
let as = analyse (tsort n)
ns = map fst as
hd = [ "#include <stdio.h>"
, "#include <stdlib.h>"
, "#include <stdbool.h>"
, "#include <math.h>"
, "#include <jack.dl.h>"]
c = [hd, cdef, cstate ns, dsp_init ns, dsp_step as ns]
in (unlines . concat) c
dl_gen :: FilePath -> Node -> IO ()
dl_gen fn n =
do let c = fn <.> "c"
so = fn <.> "so"
gcc = "gcc -g --std=c99 -O2 -shared -I ~/include "
cmd = gcc ++ c ++ " -o " ++ so
writeFile c (code_gen n)
system cmd
return ()
clabel :: String -> (NodeID, PortID) -> String
clabel p (k, n) = concat [p, "_", show k, "_", show n]
ccall :: String -> [String] -> String
ccall s as = concat ([s, "("] ++ intersperse "," as ++ [");"])
d_ccall :: String -> Node -> [String] -> [String]
d_ccall s n as = [ "/*" ++ show n ++ "*/"
, ccall s as ]
ctype :: Type -> String
ctype Real_Type = "float"
ctype Integer_Type = "long int"
ctype Boolean_Type = "bool"
type CVar = (String, String, Maybe Double, Bool)
cvar_from_constant :: NodeID -> String -> Constant -> Bool -> CVar
cvar_from_constant k c (Real_Constant i) st =
(ctype Real_Type, clabel c (k, 0), Just i, st)
cvar_from_constant k c (Integer_Constant i) st =
(ctype Integer_Type, clabel c (k, 0), Just (fromIntegral i), st)
cvars_n :: (NodeID, Node) -> [CVar]
cvars_n (k, S i) =
[cvar_from_constant k "n" i False]
cvars_n (k, R (R_ID j) (Left i)) =
[cvar_from_constant j "r" i True
,cvar_from_constant k "n" i False]
cvars_n (k, R (R_ID _) (Right _)) =
[("float", clabel "n" (k, 0), Nothing, False)]
cvars_n (k, (A _ _ o)) =
let f (p, t) = let t' = port_data_type t
in (ctype t', clabel "n" (k, p), Nothing, False)
in map f (zip [0 .. length o 1] o)
cvars_n (_, (M _ _)) = undefined
cvars_n (_, (P _ _)) = undefined
cvars :: [(NodeID, Node)] -> [CVar]
cvars = concatMap cvars_n
is_stateful :: CVar -> Bool
is_stateful (_, _, _, st) = st
stateful_cvars :: [(NodeID, Node)] -> [CVar]
stateful_cvars = filter is_stateful . cvars
non_stateful_cvars :: [(NodeID, Node)] -> [CVar]
non_stateful_cvars = filter (not . is_stateful) . cvars
cstate :: [(NodeID, Node)] -> [String]
cstate ns =
let f (t, n, _, _) = t ++ " " ++ n ++ ";"
in "struct df_state {" : map f (stateful_cvars ns) ++ ["};"]
cstate_init :: String -> [(NodeID, Node)] -> [String]
cstate_init s ns =
let f (_, n, Just i, _) = s ++ "->" ++ n ++ " = " ++ show i ++ ";"
f (_, _, Nothing, _) = error "cstate_init"
in map f (stateful_cvars ns)
non_state_decl :: [(NodeID, Node)] -> [String]
non_state_decl ns =
let f (ty, n, _, _) = ty ++ " " ++ n ++ ";"
in map f (non_stateful_cvars ns)
dsp_init :: [(NodeID, Node)] -> [String]
dsp_init ns =
let a = [ "void *dsp_init(struct world *w, int g)"
, "{"
, "struct df_state *s = malloc(sizeof(struct df_state));" ]
b = [ "return (void*)s;"
, "}"]
in a ++ cstate_init "s" ns ++ b
dsp_step :: [((NodeID, Node), [Edge])] -> [(NodeID, Node)] -> [String]
dsp_step as ns =
let s = "void dsp_step(struct world *w, int g, void *ptr, int nf)"
f (t, n, _, _) = t ++ " " ++ n ++ " = s->" ++ n ++ ";"
g (_, n, _, _) = "s->" ++ n ++ " = " ++ n ++ ";"
ss = [ [ s
, "{"
, "struct df_state *s = (struct df_state *)ptr;"
, "/* load state */" ]
, map f (stateful_cvars ns)
, [ "/* non-stateful variables */" ]
, non_state_decl ns
, [ "/* algorithm */"
, "for(int i = 0; i < nf; i++) {" ]
, concatMap cgen as
, [ "}"
, "/* store state */" ]
, map g (stateful_cvars ns)
, [ "}" ] ]
in concat ss
cgen :: ((NodeID, Node), [Edge]) -> [String]
cgen ((k, n@(S (Real_Constant x))), []) =
d_ccall "df_real_constant" n [clabel "n" (k, 0), show x]
cgen ((k, n@(S (Integer_Constant x))), []) =
d_ccall "df_integer_constant" n [clabel "n" (k, 0), show x]
cgen ((k, n@(R (R_ID j) (Left _))), []) =
d_ccall "df_rec_r" n [clabel "n" (k, 0), clabel "r" (j, 0)]
cgen ((_, n@(R (R_ID j) (Right _))), [(s, _)]) =
d_ccall "df_rec_w" n [clabel "r" (j, 0), clabel "n" s]
cgen ((k, n@(A a _ o)), es) =
let o_l = map (clabel "n") (zip (repeat k) [0 .. length o 1])
i_l = map (clabel "n". fst) es
in d_ccall a n (o_l ++ i_l)
cgen ((_, (P _ _)), _) =
[]
cgen c = error ("cgen: " ++ show c)
cdef :: [String]
cdef =
["/* reader */"
,"#define df_integer_constant(o_0,i_0) { o_0 = i_0; }"
,"#define df_real_constant(o_0,i_0) { o_0 = i_0; }"
,"#define df_rec_r(o_0,i_0) { o_0 = i_0; }"
,"#define df_rec_w(o_0,i_0) { o_0 = i_0; }"
,"/* instance Num */"
,"#define df_add(o_0,i_0,i_1) { o_0 = (i_0) + (i_1); }"
,"#define df_mul(o_0,i_0,i_1) { o_0 = (i_0) * (i_1); }"
,"#define df_sub(o_0,i_0,i_1) { o_0 = (i_0) - (i_1); }"
,"#define df_negate(o_0,i_0) { o_0 = -(i_0); }"
,"#define df_fabs(o_0,i_0) { o_0 = fabsf(i_0); }"
,"#define df_iabs(o_0,i_0) { o_0 = labs(i_0); }"
,"#define df_signum(o_0,i_0) { o_0 = i_0 > 0 ? 1 (i_0 < 0 ? -1 : 0); } }"
,"/* instance Fractional */"
,"#define df_div(o_0,i_0,i_1) { o_0 = (i_0) / (i_1); }"
,"#define df_recip(o_0,i_0) { o_0 = 1.0 / i_0; }"
,"/* instance Floating */"
,"#define df_exp(o_0,i_0) { o_0 = expf(i_0); }"
,"#define df_sqrt(o_0,i_0) { o_0 = sqrtf(i_0); }"
,"#define df_log(o_0,i_0) { o_0 = logf(i_0); }"
,"#define df_pow(o_0,i_0,i_1) { o_0 = powf(i_0,i_1); }"
,"#define df_sin(o_0,i_0) { o_0 = sinf(i_0); }"
,"#define df_cos(o_0,i_0) { o_0 = cosf(i_0); }"
,"#define df_tan(o_0,i_0) { o_0 = tanf(i_0); }"
,"/* instance Ord */"
,"#define df_lt(o_0,i_0,i_1) { o_0 = i_0 < i_1 ? true : false; }"
,"#define df_lte(o_0,i_0,i_1) { o_0 = i_0 <= i_1 ? true : false; }"
,"#define df_gt(o_0,i_0,i_1) { o_0 = i_0 > i_1 ? true : false; }"
,"#define df_gte(o_0,i_0,i_1) { o_0 = i_0 >= i_1 ? true : false; }"
,"#define df_max(o_0,i_0,i_1) { o_0 = i_0 > i_1 ? i_0 : i_1; }"
,"#define df_min(o_0,i_0,i_1) { o_0 = i_0 < i_1 ? i_0 : i_1; }"
,"/* instance Eq */"
,"#define df_eq(o_0,i_0,i_1) { o_0 = i_0 == i_1 ? true : false; }"
,"/* instance RealFrac */"
,"#define df_floor(o_0,i_0) { o_0 = floorf(i_0); }"
,"#define df_lrint(o_0,i_0) { o_0 = lrintf(i_0); }"
,"/* Control */"
,"#define df_and(o_0,i_0,i_1) { o_0 = i_0 && i_1 ? true : false; }"
,"#define df_or(o_0,i_0,i_1) { o_0 = i_0 || i_1 ? true : false; }"
,"#define df_select2(o_0,i_0,i_1,i_2) { o_0 = i_0 ? i_1 : i_2; }"
,"/* World|Environment */"
,"#define df_sample_rate(o_0) { o_0 = w_sr(w); }"
,"#define df_b_read(o_0,i_0,i_1) { o_0=w_b_read1(w,i_0,i_1); }"
,"#define df_b_write(i_0,i_1,i_2) { w_b_write1(w,i_0,i_1,i_2); }"
,"#define df_random(o_0,i_0) { o_0 = ((float)rand() / (float)RAND_MAX); }"
,"#define df_out1(i_0) { w_out1(w,i,i_0); }"
,"#define df_out2(i_0,i_1) { w_out2(w,i,i_0,i_1); }"
,"#define df_out3(i_0,i_1,i_2) { w_out3(w,i,i_0,i_1,i_2); }"
]