git.iko.soy/Idris-dev
on cbc8a13 help sign in
Idris-dev/src/RTS/CodegenC.hs
219 lines 7.8 kB history raw
1module RTS.CodegenC where
3import Core.TT
4import Core.Evaluate
5import Core.CaseTree
7import RTS.PreC
8import RTS.SC
9import RTS.Bytecode
11import Idris.AbsSyntax
13import Data.Char
14import Data.List
15import Control.Monad.State
16import System.Process
17import System.IO
18import System.Directory
19import System.Environment
20import System.FilePath ((</>))
21import Debug.Trace
23import Paths_idris
25compileC :: FilePath -> Term -> Idris ()
26compileC f tm
27 = do checkMVs
28 let tmnames = namesUsed (STerm tm)
29 used <- mapM (allNames []) tmnames
30 i <- get
31 let entry = mainFn (idris_scprims i) tm
32 scs' <- mkDecls tm (concat used)
33 let scs = scs' ++ entry
34 objs <- getObjectFiles
35 libs <- getLibs
36 hdrs <- getHdrs
37 ddir <- liftIO $ getDataDir
38 -- if any includes exist in the data directory, use that
39 hdrs' <- liftIO $ mapM (inDir ddir) hdrs
40 let bcs = bcdefs scs
41 let pcs = preCdefs bcs
42 let code = cdefs pcs
43 liftIO $ writeFile (f ++ ".c") code
44 where checkMVs = do i <- get
45 case idris_metavars i \\ primDefs of
46 [] -> return ()
47 ms -> fail $ "There are undefined metavariables: " ++ show ms
48 inDir d h = do let f = d </> h
49 ex <- doesFileExist f
50 if ex then return f else return h
53mainFn ps tm = toSC ps (MN 0 "_main", Function undefined tm)
55allNames :: [Name] -> Name -> Idris [Name]
56allNames ns n | n `elem` ns = return []
57allNames ns n = do i <- get
58 case lookupCtxt Nothing n (idris_callgraph i) of
59 [ns'] -> do more <- mapM (allNames (n:ns)) ns'
60 return (nub (n : concat more))
61 _ -> return [n]
63mkDecls :: Term -> [Name] -> Idris [(Name, SCDef)]
64mkDecls t used
65 = do i <- getIState
66 let ds = filter (\ (n, d) -> n `elem` used) $ ctxtAlist (tt_ctxt i)
67 return $ concatMap (toSC (idris_scprims i)) ds
69cdefs :: [(Name, (Int, PreC))] -> String
70cdefs xs = concatMap (\ (n, (i, c)) -> proto n) xs ++ "\n" ++
71 concatMap (\ (n, (i, c)) -> codegenC n i c) xs
73codegenC :: Name -> Int -> PreC -> String
74codegenC n args prec
75 = "/* " ++ show prec ++ " */\n\n" ++
76 "void " ++ cname n ++ "(VM* vm) {\n" ++
77 indent 1 ++ "int i;\n" ++
78 concatMap (cg 1) prec ++ "}\n\n"
80indent i = take (i * 4) (repeat ' ')
82reg RVal = "vm->ret"
83reg (LVar v) = "*(vm->valstack_ptr-" ++ show v ++ ")"
85catom :: CAtom -> String
86catom (CL l) = reg (LVar l)
87catom (CC (I i)) = "MKINT(" ++ show i ++ ")"
88catom (CC v) = "const(" ++ show v ++ ")"
89catom (CP n i) = "MKCLOSURE(" ++ cname n ++ ", " ++ show i ++ ")"
91off o (CL i) = CL (i + o)
92off o x = x
94assignCon i r tag args
95 = indent i ++ reg r ++ " = MKCON(" ++ show tag ++ ", " ++
96 show (length args) ++ ");\n" ++
97 indent i ++ setArgs 0 args ++ "\n"
98 where
99 setArgs i [] = ""
100 setArgs i (a : as) = "SETARG(" ++ reg r ++ ", " ++
101 show i ++ ", " ++ catom a ++ "); "
102 ++ setArgs (i + 1) as
104assignFn i r f args
105 = indent i ++ "EXTEND(" ++ show (length args) ++ ");\n" ++
106 indent i ++ setArgs 1 (map (off (length args)) (reverse args)) ++ "\n" ++
107 indent i ++ cname f ++ "(vm);\n" ++
108 indent i ++ "CLEAR(" ++ show (length args) ++ ");\n" ++
109 case r of
110 RVal -> ""
111 r -> indent i ++ reg r ++ " = " ++ reg RVal ++ "\n"
112 where
113 setArgs i [] = ""
114 setArgs i (a : as) = reg (LVar i) ++ " = " ++ catom a ++ "; "
115 ++ setArgs (i + 1) as
117assignClosure i lazy r atom args
118 = indent i ++ reg r ++ " = APPLY(" ++ catom atom ++ ", " ++ show (length args) ++
119 ");\n" ++
120 indent i ++ setArgs 0 args ++ "\n" ++
121 if not lazy then
122 indent i ++ "if (READY(" ++ reg r ++ ")) {\n" ++
123 indent (i + 1) ++ reg r ++ " = EVAL(" ++ reg r ++ ");\n" ++
124 indent i ++ "} else {\n" ++
125 indent (i + 1) ++ "// do nothing \n" ++
126 indent i ++ "}\n"
127 else ""
128 where
129 setArgs i [] = ""
130 setArgs i (a : as) = "ADDARG(" ++ show i ++ ", " ++ reg r ++ ", " ++ catom a ++ "); "
131 ++ setArgs (i + 1) as
133doTailCall i d f args
134 = indent i ++ "EXTEND(" ++ show (length args) ++ ");\n" ++
135 indent i ++ setArgs 1 (map (off (length args)) (reverse args)) ++ "\n" ++
136 indent i ++ "SLIDE(" ++ show d ++ ", " ++ show (length args) ++ ");\n" ++
137 indent i ++ cname f ++ "(vm); return;\n"
138 where
139 setArgs i [] = ""
140 setArgs i (a : as) = reg (LVar i) ++ " = " ++ catom a ++ "; "
141 ++ setArgs (i + 1) as
143assignFCall i r cfn rt args
144 = indent i ++ reg r ++ " = " ++ fromC rt ++
145 "(" ++
146 cfn ++ "(" ++ showSep ", " (map toCa args) ++ "))" ++ ";\n"
147 where fromC (Just IType) = "MKINT"
148 fromC (Just StrType) = "MKSTR"
149 fromC _ = "MKVAL"
151 toC (Just IType) = "GETINT"
152 toC (Just StrType) = "GETSTR"
153 toC _ = "GETVAL"
155 toCa (a, ty) = toC ty ++ "(" ++ catom a ++ ")"
157assignPrimOp i r p args
158 = indent i ++ reg r ++ " = " ++ op p args ++ ";\n"
160cg :: Int -> CInst -> String
161cg i (ASSIGN r (CCon t args))
162 = assignCon i r t args
163cg i (ASSIGN r (CExactApp f args))
164 = assignFn i r f args
165cg i (ASSIGN r (CApp f args))
166 = assignClosure i False r f args
167cg i (ASSIGN r (CLazy f args))
168 = assignClosure i True r f args
169cg i (ASSIGN r (CFCall cfn rt args))
170 = assignFCall i r cfn rt args
171cg i (ASSIGN r (CPrimOp p args))
172 = assignPrimOp i r p args
173cg i (ASSIGN r (CAtom e)) = indent i ++ reg r ++ " = " ++ catom e ++ ";\n"
174cg i (RESERVE s) = indent i ++ "EXTEND(" ++ show s ++ ");\n"
175cg i (CLEAR s) = indent i ++ "CLEAR(" ++ show s ++ ");\n"
176cg i (EVAL e) = indent i ++ "EVAL(" ++ reg (LVar e) ++ ");\n"
177cg i (PROJECT scr loc num)
178 = indent i ++ "PROJECT(" ++ reg (LVar scr) ++ ", " ++
179 reg (LVar loc) ++ ", " ++ show num ++ ");\n"
180cg i (SWITCH v bs def)
181 = indent i ++ "switch(" ++ sval v ++ ") {\n" ++
182 concatMap branch bs ++
183 indent i ++ "default:\n" ++ concatMap (cg (i+1)) def ++
184 indent (i+1) ++ "break;\n" ++
185 indent i ++ "};\n"
186 where sval (CTag l) = "TAG(" ++ reg (LVar l) ++ ")"
187 sval (CIntVal l) = "GETINT(" ++ reg (LVar l) ++ ")"
189 branch (t, c) = indent i ++ "case " ++ show t ++ ":\n" ++
190 concatMap (cg (i+1)) c ++
191 indent (i+1) ++ "break;\n"
192cg i (TAILCALL d f args) = assignClosure i False RVal f args -- doTailClosure i d f args
193cg i (TAILCALLEXACT d f args) = doTailCall i d f args
194cg i (ERROR s) = indent i ++ "ERROR(" ++ show s ++ ")\n";
195cg i x = trace (show x ++ " not done") $ indent i ++ "NOT DONE;\n"
197cname :: Name -> String
198cname (UN s) = "_I_" ++ toC s
199cname (MN i s) = "_M_I_" ++ show i ++ "_" ++ toC s
200cname (NS n ss) = "_" ++ showSep "_" (map toC ss) ++ cname n
202toC s = concatMap special s
203 where special c | isAlphaNum c = [c]
204 | c == '_' = "__"
205 | otherwise = "_" ++ show (fromEnum c) ++ "_"
207proto :: Name -> String
208proto n = "void " ++ cname n ++ "(VM* vm);\n"
210op AddI [l, r] = "INTOP(+, " ++ catom l ++ ", " ++ catom r ++ ")"
211op SubI [l, r] = "INTOP(-, " ++ catom l ++ ", " ++ catom r ++ ")"
212op MulI [l, r] = "INTOP(*, " ++ catom l ++ ", " ++ catom r ++ ")"
213op DivI [l, r] = "INTOP(/, " ++ catom l ++ ", " ++ catom r ++ ")"
215op ConcatS [l,r] = "CONCAT(" ++ catom l ++ ", " ++ catom r ++ ")"
217op o args = trace (show (op, args) ++ " operator undefined")
218 $ "0 /* Op not defined " ++ show o ++ " */"