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