git.iko.soy/Idris-dev
on 449bb27 help sign in
Idris-dev/src/IRTS/CodegenC.hs
280 lines 13 kB history raw
1module IRTS.CodegenC (codegenC) where
3import Idris.AbsSyntax
4import IRTS.Bytecode
5import IRTS.Lang
6import IRTS.Simplified
7import IRTS.CodegenCommon
8import Core.TT
9import Paths_idris
10import Util.System
12import Data.Char
13import System.Process
14import System.Exit
15import System.IO
16import System.Directory
17import Control.Monad
19codegenC :: [(Name, SDecl)] ->
20 String -> -- output file name
21 OutputType -> -- generate executable if True, only .o if False
22 [FilePath] -> -- include files
23 String -> -- extra object files
24 String -> -- extra compiler flags
25 DbgLevel ->
26 IO ()
27codegenC defs out exec incs objs libs dbg
28 = do -- print defs
29 let bc = map toBC defs
30 let h = concatMap toDecl (map fst bc)
31 let cc = concatMap (uncurry toC) bc
32 d <- getDataDir
33 mprog <- readFile (d ++ "/rts/idris_main.c")
34 let cout = headers incs ++ debug dbg ++ h ++ cc ++
35 (if (exec == Executable) then mprog else "")
36 case exec of
37 Raw -> writeFile out cout
38 _ -> do
39 (tmpn, tmph) <- tempfile
40 hPutStr tmph cout
41 hFlush tmph
42 hClose tmph
43 let useclang = False
44 comp <- getCC
45 let gcc = comp ++ " -I. " ++ objs ++ " -x c " ++
46 (if (exec == Executable) then "" else " -c ") ++
47 gccDbg dbg ++
48 " " ++ tmpn ++
49 " `idris --link` `idris --include` " ++ libs ++
50 " -o " ++ out
51 exit <- system gcc
52 when (exit /= ExitSuccess) $
53 putStrLn ("FAILURE: " ++ gcc)
55headers [] = "#include <idris_rts.h>\n#include <idris_stdfgn.h>\n" ++
56 "#include <gmp.h>\n#include <assert.h>\n"
57headers (x : xs) = "#include <" ++ x ++ ">\n" ++ headers xs
59debug TRACE = "#define IDRIS_TRACE\n\n"
60debug _ = ""
62gccDbg DEBUG = "-g"
63gccDbg TRACE = "-O2"
64gccDbg _ = "-O2"
66cname :: Name -> String
67cname n = "_idris_" ++ concatMap cchar (show n)
68 where cchar x | isAlpha x || isDigit x = [x]
69 | otherwise = "_" ++ show (fromEnum x) ++ "_"
71indent i = take (i * 4) (repeat ' ')
73creg RVal = "RVAL"
74creg (L i) = "LOC(" ++ show i ++ ")"
75creg (T i) = "TOP(" ++ show i ++ ")"
76creg Tmp = "REG1"
78toDecl :: Name -> String
79toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"
81toC :: Name -> [BC] -> String
82toC f code
83 = -- "/* " ++ show code ++ "*/\n\n" ++
84 "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++
85 indent 1 ++ "INITFRAME;\n" ++
86 concatMap (bcc 1) code ++ "}\n\n"
88bcc :: Int -> BC -> String
89bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
90bcc i (ASSIGNCONST l c)
91 = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"
92 where
93 mkConst (I i) = "MKINT(" ++ show i ++ ")"
94 mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")"
95 | otherwise = "MKBIGC(vm,\"" ++ show i ++ "\")"
96 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"
97 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"
98 mkConst (Str s) = "MKSTR(vm, " ++ show s ++ ")"
99 mkConst _ = "MKINT(42424242)"
100bcc i (MKCON l tag args)
101 = indent i ++ creg Tmp ++ " = allocCon(vm, " ++ show (length args) ++
102 ", 0); " ++ "SETTAG(" ++ creg Tmp ++ ", " ++ show tag ++ ");\n" ++
103 indent i ++ setArgs 0 args ++ "\n" ++
104 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"
106-- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++
107-- show (length args) ++ concatMap showArg args ++ ");\n"
108 where showArg r = ", " ++ creg r
109 setArgs i [] = ""
110 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++
111 "); " ++ setArgs (i + 1) xs
113bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++
114 ", " ++ show a ++ ");\n"
115bcc i (PROJECTINTO r t idx)
116 = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"
117bcc i (CASE r code def)
118 = indent i ++ "switch(TAG(" ++ creg r ++ ")) {\n" ++
119 concatMap (showCase i) code ++
120 showDef i def ++
121 indent i ++ "}\n"
122 where
123 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
124 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"
125 showDef i Nothing = ""
126 showDef i (Just c) = indent i ++ "default:\n"
127 ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"
128bcc i (CONSTCASE r code def)
129 | intConsts code
130 = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++
131 concatMap (showCase i) code ++
132 showDef i def ++
133 indent i ++ "}\n"
134 | strConsts code
135 = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++
136 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
137 | bigintConsts code
138 = concatMap (biCase (creg r)) code ++
139 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
140 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code
141 where
142 intConsts ((I _, _ ) : _) = True
143 intConsts ((Ch _, _ ) : _) = True
144 intConsts _ = False
146 bigintConsts ((BI _, _ ) : _) = True
147 bigintConsts _ = False
149 strConsts ((Str _, _ ) : _) = True
150 strConsts _ = False
152 strCase sv (s, bc) =
153 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++
154 concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
155 biCase bv (BI b, bc) =
156 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"
157 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
159 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
160 ++ concatMap (bcc (i+1)) bc ++
161 indent (i + 1) ++ "break;\n"
162 showDef i Nothing = ""
163 showDef i (Just c) = indent i ++ "default:\n"
164 ++ concatMap (bcc (i+1)) c ++
165 indent (i + 1) ++ "break;\n"
166 showDefS i Nothing = ""
167 showDefS i (Just c) = concatMap (bcc (i+1)) c
169bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"
170bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"
171bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"
172bcc i REBASE = indent i ++ "REBASE;\n"
173bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"
174bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"
175bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
176bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
177bcc i STOREOLD = indent i ++ "STOREOLD;\n"
178bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"
179bcc i (FOREIGNCALL l LANG_C rty fn args)
180 = indent i ++
181 c_irts rty (creg l ++ " = ")
182 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
183 where fcall (t, arg) = irts_c t (creg arg)
184bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed
185bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0); exit(-1);"
186-- bcc i _ = indent i ++ "// not done yet\n"
188c_irts FInt l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
189c_irts FChar l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
190c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"
191c_irts FUnit l x = x
192c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"
193c_irts FDouble l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"
194c_irts FAny l x = l ++ x
196irts_c FInt x = "GETINT(" ++ x ++ ")"
197irts_c FChar x = "GETINT(" ++ x ++ ")"
198irts_c FString x = "GETSTR(" ++ x ++ ")"
199irts_c FUnit x = x
200irts_c FPtr x = "GETPTR(" ++ x ++ ")"
201irts_c FDouble x = "GETFLOAT(" ++ x ++ ")"
202irts_c FAny x = x
204doOp v LPlus [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"
205doOp v LMinus [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
206doOp v LTimes [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"
207doOp v LDiv [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
208doOp v LEq [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
209doOp v LLt [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
210doOp v LLe [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
211doOp v LGt [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
212doOp v LGe [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
214doOp v LFPlus [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"
215doOp v LFMinus [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
216doOp v LFTimes [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"
217doOp v LFDiv [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
218doOp v LFEq [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
219doOp v LFLt [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
220doOp v LFLe [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
221doOp v LFGt [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
222doOp v LFGe [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
224doOp v LBPlus [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
225doOp v LBMinus [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
226doOp v LBTimes [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
227doOp v LBDiv [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
228doOp v LBEq [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
229doOp v LBLt [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
230doOp v LBLe [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
231doOp v LBGt [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
232doOp v LBGe [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
234doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
235doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
236doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
237doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"
239doOp v LIntFloat [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"
240doOp v LFloatInt [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"
241doOp v LIntStr [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"
242doOp v LStrInt [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"
243doOp v LIntBig [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"
244doOp v LBigInt [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"
245doOp v LStrBig [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"
246doOp v LBigStr [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"
247doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"
248doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"
250doOp v LReadStr [x] = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"
251doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"
252doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)"
254doOp v LFExp [x] = v ++ "MKFLOAT(exp(GETFLOAT(" ++ creg x ++ ")))"
255doOp v LFLog [x] = v ++ "MKFLOAT(log(GETFLOAT(" ++ creg x ++ ")))"
256doOp v LFSin [x] = v ++ "MKFLOAT(sin(GETFLOAT(" ++ creg x ++ ")))"
257doOp v LFCos [x] = v ++ "MKFLOAT(cos(GETFLOAT(" ++ creg x ++ ")))"
258doOp v LFTan [x] = v ++ "MKFLOAT(tan(GETFLOAT(" ++ creg x ++ ")))"
259doOp v LFASin [x] = v ++ "MKFLOAT(asin(GETFLOAT(" ++ creg x ++ ")))"
260doOp v LFACos [x] = v ++ "MKFLOAT(acos(GETFLOAT(" ++ creg x ++ ")))"
261doOp v LFATan [x] = v ++ "MKFLOAT(atan(GETFLOAT(" ++ creg x ++ ")))"
262doOp v LFSqrt [x] = v ++ "MKFLOAT(floor(GETFLOAT(" ++ creg x ++ ")))"
263doOp v LFFloor [x] = v ++ "MKFLOAT(ceil(GETFLOAT(" ++ creg x ++ ")))"
264doOp v LFCeil [x] = v ++ "MKFLOAT(sqrt(GETFLOAT(" ++ creg x ++ ")))"
266doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"
267doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"
268doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")"
269doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")"
270doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")"
272doOp v LStdIn [] = v ++ "MKPTR(vm, stdin)"
273doOp v LStdOut [] = v ++ "MKPTR(vm, stdout)"
274doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)"
276doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
277doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
278doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"
279doOp v LNoOp args = ""
280doOp _ _ _ = "FAIL"