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