module Sound.DF.Uniform.LL.CGen where
import Data.Char
import Data.Int
import Data.List
import Data.Maybe
import Data.Typeable
import System.Process
import System.FilePath
import Sound.DF.Uniform.LL.K
import Sound.DF.Uniform.LL.UId
type C_Comment = String
c_comment :: String -> C_Comment
c_comment c = concat ["/* ",c," */"]
type C_Type = String
c_typerep_ctype :: TypeRep -> C_Type
c_typerep_ctype t =
let tbl = [(bool_t,"bool")
,(int32_t,"int32_t")
,(float_t,"float")]
in fromMaybe (error (show ("c_typerep_ctype",t))) (lookup t tbl)
type C_QName = (String,String,String)
var_fld_initialiser :: Var_Fld -> String
var_fld_initialiser v =
case v of
Var_B b -> map toLower (show b)
Var_I i -> show i
Var_F f -> show f
Var_V _ -> error "var_fld_initialiser: vector"
c_init_atom :: C_QName -> Var_Fld -> String
c_init_atom (s,a,p) q = concat [s,a,p," = ",var_fld_initialiser q,";"]
c_init_vec :: (Eq a,Show a) => C_QName -> [a] -> [String]
c_init_vec (s,a,n) l =
let init_arr_1 p q r = concat [s,a,p,"[",q,"] = ",show r,";"]
init_arr p q r = ["for(int i=",show q
,";i < ",show (q + length r)
,";i++) {"
,init_arr_1 p "i" (head r)
,"}"]
f (k,i) = case i of
[i'] -> init_arr_1 n (show k) i'
_ -> concat (init_arr n k i)
l' = group l
in map f (zip (dx_d (map length l')) l')
c_init_var :: C_QName -> Var_Fld -> [String]
c_init_var qn e =
case e of
Var_B _ -> [c_init_atom qn e]
Var_I _ -> [c_init_atom qn e]
Var_F _ -> [c_init_atom qn e]
Var_V [] -> error "c_init_var: Right []"
Var_V l -> c_init_vec qn l
c_array_qual :: Maybe Int -> String -> Bool -> String
c_array_qual vc nm rf =
case vc of
Nothing -> nm
Just n -> if rf
then '*' : nm
else nm ++ bracket ('[',']') (show n)
type C_Call = (Maybe String,String,[(Var_Ty,Id)])
c_call :: C_Call -> String
c_call (tr,s,as) =
let as' = map m_clabel as
c = concat ([s,"("] ++ intersperse "," as' ++ [");"])
in concat [c," ",maybe "" c_comment tr]
data Var_Ty = Rec_Var | Std_Var | Buf_Var Int
deriving (Eq,Show)
var_ty_char :: Var_Ty -> Char
var_ty_char ty =
case ty of
Rec_Var -> 'r'
Std_Var -> 'n'
Buf_Var _ -> 'n'
data Var_Fld = Var_F Float | Var_V [Float] | Var_B Bool | Var_I Int32
type Var = (Var_Ty,TypeRep,Id,Maybe Var_Fld)
var_nm :: Var -> String
var_nm (vc,_,k,_) = clabel (vc,k)
is_stateful :: Var -> Bool
is_stateful (vt,_,_,_) = vt /= Std_Var
is_stateful_atom :: Var -> Bool
is_stateful_atom (vt,_,_,_) = vt == Rec_Var
k_var :: Id -> Var_Ty -> K -> Var
k_var k vt n =
case n of
N _ -> error "k_var: ()"
B b -> (vt,bool_t,k,Just (Var_B b))
I i -> (vt,int32_t,k,Just (Var_F (fromIntegral i)))
F f -> (vt,float_t,k,Just (Var_F f))
V _ -> error "k_var: vec"
buffer_var :: Id -> Vec Float -> Var
buffer_var k (Vec _ n l) = (Buf_Var n,float_t,k,Just (Var_V l))
var_init :: String -> String -> Var -> [String]
var_init s a (vt,_,k,i) =
case i of
Nothing -> error (show ("var_init",s,a,vt,k))
Just i' -> c_init_var (s,a,clabel (vt,k)) i'
var_decl :: Bool -> Var -> String
var_decl rf (vt,ty,k,_) =
let vc = case vt of
Buf_Var n -> Just n
_ -> Nothing
nm = clabel (vt,k)
in c_typerep_ctype ty ++ " " ++ c_array_qual vc nm rf ++ ";"
gen_var_struct :: String -> (Var -> Bool) -> [Var] -> [String]
gen_var_struct nm f vs =
let dc = zipWith var_decl (map f vs) vs
in c_comment nm :
bracket ("struct " ++ nm ++ " {","};") dc
clabel :: (Var_Ty,Id) -> String
clabel (ty,k) = var_ty_char ty : '_' : show k
std_clabel :: Id -> String
std_clabel k = clabel (Std_Var,k)
m_clabel :: (Var_Ty,Id) -> String
m_clabel = ("m." ++) . clabel
c_const :: (Id,K) -> [String]
c_const (k,v) =
case v of
B x -> c_init_var ("m",".",std_clabel k) (Var_B x)
F x -> c_init_var ("m",".",std_clabel k) (Var_F x)
I x -> c_init_var ("m",".",std_clabel k) (Var_I x)
_ -> error "c_const: k"
dsp_fun_decl :: [String]
dsp_fun_decl =
["size_t dsp_memreq();"
,"void dsp_init(void *p);"
,"void dsp_step(df_world *w,int w_nf);"]
cmem :: [Var] -> [String]
cmem = gen_var_struct "df_mem" is_stateful
cstate :: [Var] -> [String]
cstate = gen_var_struct "df_state" (const False) . filter is_stateful
dsp_memreq :: [String]
dsp_memreq =
["size_t dsp_memreq()"
,"{"
,"return (sizeof(struct df_state));"
,"}"]
dsp_init :: [Var] -> [String]
dsp_init vs =
let a = ["void dsp_init(void *p)"
,"{"]
b = ["return;"
,"}"]
c = case filter is_stateful vs of
[] -> []
vs' -> "struct df_state *s = (struct df_state *)p;" :
concatMap (var_init "s" "->") vs'
in a ++ c ++ b
type Instructions = ([(Id,K)],[Var],[C_Call])
dsp_step :: Instructions -> [String]
dsp_step (ks,vs,cc) =
let f v = let nm = var_nm v in "m." ++ nm ++ " = s->" ++ nm ++ ";"
g v = let nm = var_nm v in "s->" ++ nm ++ " = m." ++ nm ++ ";"
in concat [["void dsp_step(df_world *w,int w_nf)"
,"{"
,"struct df_mem m;"]
,let v = filter is_stateful vs
in if null v
then []
else ["struct df_state *s = (struct df_state*)w_state(w);"
,"/* load state */"] ++
map f v
,["/* constants */"]
,concatMap c_const ks
,["/* algorithm */"
,"/* k-rate (fc == 0) */"
,"/* a-rate (fc == 1..) */"
,"for(int fc = 0; fc < w_nf; fc++) {"]
,map c_call cc
,["}"
,"/* store state */"]
,map g (filter is_stateful_atom vs)
,["}"]]
code_gen :: Host -> Instructions -> String
code_gen h (ks,vs,cc) =
let hd = ["#include <stdio.h>"
,"#include <stdint.h>"
,"#include <stdlib.h>"
,"#include <stdbool.h>"
,"#include <math.h>"
,host_include h
,"#include \"/home/rohan/sw/hdf/c/hdf.h\""]
c = [hd
,host_dsp_fun_decl h
,cstate vs
,cmem vs
,dsp_memreq
,dsp_init vs
,dsp_step (ks,vs,cc)]
in (unlines . concat) c
data Host = JACK | SC3 | Text
host_include :: Host -> String
host_include h =
case h of
JACK -> "#include \"/home/rohan/sw/rju/jack-dl.h\""
SC3 -> "#include \"/home/rohan/sw/sc3-rdu/cpp/RDL.h\""
Text -> "#include \"/home/rohan/sw/hdf/c/text-dl.h\""
host_dsp_fun_decl :: Host -> [String]
host_dsp_fun_decl h =
case h of
SC3 -> bracket ("extern \"C\" {","}") dsp_fun_decl
_ -> dsp_fun_decl
host_compiler_cmd :: (Host,FilePath) -> (String,[String])
host_compiler_cmd (h,d) =
case h of
SC3 ->
("g++"
,["-Wall","-g","-O2","-shared","-fPIC"
,"-I",d </> "include/SuperCollider/plugin_interface"
,"-I",d </> "include/SuperCollider/common"])
_ ->
("gcc"
,["-Wall","-g","--std=c99","-O2","-shared","-fPIC"
,"-I",d </> "include"])
host_compiler_cmd_str :: (Host, FilePath) -> String
host_compiler_cmd_str = let f (cmd,arg) = unwords (cmd : arg) in f . host_compiler_cmd
dl_gen :: FilePath -> (Host,FilePath) -> Instructions -> IO ()
dl_gen fn (h,d) i = do
let c = fn <.> "c"
so = fn <.> "so"
(cmd,opt) = host_compiler_cmd (h,d)
opt' = opt ++ [c,"-o",so]
writeFile c (code_gen h i)
_ <- rawSystem cmd opt'
return ()
bracket :: (a,a) -> [a] -> [a]
bracket (i,j) k = i : k ++ [j]
dx_d :: Num n => [n] -> [n]
dx_d = (0 :) . scanl1 (+)