@@ -1,10 +1,68 @@
11module RTS.CodegenC where
22
33import Core.TT
4+import Core.Evaluate
5+import Core.CaseTree
6+
47import RTS.PreC
58import RTS.SC
9+import RTS.Bytecode
10+
11+import Idris.AbsSyntax
612
713import Data.Char
14+import Data.List
15+import Control.Monad.State
16+import System.Process
17+import System.IO
18+import System.Directory
19+import System.Environment
20+
21+import Paths_idris
22+
23+compileC :: FilePath -> Term -> Idris ()
24+compileC f tm
25+ = do checkMVs
26+ let tmnames = namesUsed (STerm tm)
27+ used <- mapM (allNames []) tmnames
28+ i <- get
29+ let entry = mainFn (idris_scprims i) tm
30+ scs' <- mkDecls tm (concat used)
31+ let scs = scs' ++ entry
32+ objs <- getObjectFiles
33+ libs <- getLibs
34+ hdrs <- getHdrs
35+ ddir <- liftIO $ getDataDir
36+ -- if any includes exist in the data directory, use that
37+ hdrs' <- liftIO $ mapM (inDir ddir) hdrs
38+ let bcs = bcdefs scs
39+ let pcs = preCdefs bcs
40+ let code = cdefs pcs
41+ liftIO $ writeFile (f ++ ".c") code
42+ where checkMVs = do i <- get
43+ case idris_metavars i \\ primDefs of
44+ [] -> return ()
45+ ms -> fail $ "There are undefined metavariables: " ++ show ms
46+ inDir d h = do let f = d ++ "/" ++ h
47+ ex <- doesFileExist f
48+ if ex then return f else return h
49+
50+
51+mainFn ps tm = toSC ps (MN 0 "_main", Function undefined tm)
52+
53+allNames :: [Name] -> Name -> Idris [Name]
54+allNames ns n | n `elem` ns = return []
55+allNames ns n = do i <- get
56+ case lookupCtxt Nothing n (idris_callgraph i) of
57+ [ns'] -> do more <- mapM (allNames (n:ns)) ns'
58+ return (nub (n : concat more))
59+ _ -> return [n]
60+
61+mkDecls :: Term -> [Name] -> Idris [(Name, SCDef)]
62+mkDecls t used
63+ = do i <- getIState
64+ let ds = filter (\ (n, d) -> n `elem` used) $ ctxtAlist (tt_ctxt i)
65+ return $ concatMap (toSC (idris_scprims i)) ds
866
967cdefs :: [(Name, (Int, PreC))] -> String
1068cdefs xs = concatMap (\ (n, (i, c)) -> proto n) xs ++ "\n" ++
@@ -12,7 +70,8 @@ cdefs xs = concatMap (\ (n, (i, c)) -> proto n) xs ++ "\n" ++
1270
1371codegenC :: Name -> Int -> PreC -> String
1472codegenC n args prec
15− = "void " ++ cname n ++ "(VM* vm) {\n" ++
73+ = "/* " ++ show prec ++ " */\n\n" ++
74+ "void " ++ cname n ++ "(VM* vm) {\n" ++
1675 concatMap (cg 1) prec ++ "}\n\n"
1776
1877indent i = take (i * 4) (repeat ' ')
@@ -23,6 +82,7 @@ reg (LVar v) = "*(vm->stack-" ++ show v ++ ")"
2382catom :: CAtom -> String
2483catom (CL l) = reg (LVar l)
2584catom (CC (I i)) = "MKINT(" ++ show i ++ ")"
85+catom (CC v) = "const(" ++ show v ++ ")"
2686catom (CP n) = cname n
2787
2888assignCon i r tag args