src/IRTS/CodegenC.hs · Idris-dev

git.iko.soy/Idris-dev

on ed85b4e help sign in

Idris-dev/src/IRTS/CodegenC.hs

298 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 System.FilePath ((</>), (<.>))

18import Control.Monad

20codegenC :: [(Name, SDecl)] ->

21 String -> -- output file name

22 OutputType -> -- generate executable if True, only .o if False

23 [FilePath] -> -- include files

24 String -> -- extra object files

25 String -> -- extra compiler flags

26 DbgLevel ->

27 IO ()

28codegenC defs out exec incs objs libs dbg

29 = do -- print defs

30 let bc = map toBC defs

31 let h = concatMap toDecl (map fst bc)

32 let cc = concatMap (uncurry toC) bc

33 d <- getDataDir

34 mprog <- readFile (d </> "rts" </> "idris_main" <.> "c")

35 let cout = headers incs ++ debug dbg ++ h ++ cc ++

36 (if (exec == Executable) then mprog else "")

37 case exec of

38 Raw -> writeFile out cout

39 _ -> do

40 (tmpn, tmph) <- tempfile

41 hPutStr tmph cout

42 hFlush tmph

43 hClose tmph

44 let useclang = False

45 comp <- getCC

46 libFlags <- getLibFlags

47 incFlags <- getIncFlags

48 let gcc = comp ++ " " ++

49 gccDbg dbg ++

50 " -I. " ++ objs ++ " -x c " ++

51 (if (exec == Executable) then "" else " -c ") ++

52 " " ++ tmpn ++

53 " " ++ libFlags ++

54 " " ++ incFlags ++

55 " " ++ libs ++

56 " -o " ++ out

57-- putStrLn gcc

58 exit <- system gcc

59 when (exit /= ExitSuccess) $

60 putStrLn ("FAILURE: " ++ gcc)

62headers xs =

63 concatMap

64 (\h -> "#include <" ++ h ++ ">\n")

65 (xs ++ ["idris_rts.h", "idris_stdfgn.h", "gmp.h", "assert.h"])

67debug TRACE = "#define IDRIS_TRACE\n\n"

68debug _ = ""

70gccDbg DEBUG = "-g"

71gccDbg TRACE = "-O2"

72gccDbg _ = "-O2"

74cname :: Name -> String

75cname n = "_idris_" ++ concatMap cchar (show n)

76 where cchar x | isAlpha x || isDigit x = [x]

77 | otherwise = "_" ++ show (fromEnum x) ++ "_"

79indent :: Int -> String

80indent n = replicate (n*4) ' '

82creg RVal = "RVAL"

83creg (L i) = "LOC(" ++ show i ++ ")"

84creg (T i) = "TOP(" ++ show i ++ ")"

85creg Tmp = "REG1"

87toDecl :: Name -> String

88toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"

90toC :: Name -> [BC] -> String

91toC f code

92 = -- "/* " ++ show code ++ "*/\n\n" ++

93 "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++

94 indent 1 ++ "INITFRAME;\n" ++

95 concatMap (bcc 1) code ++ "}\n\n"

97bcc :: Int -> BC -> String

98bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

99bcc i (ASSIGNCONST l c)

100 = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"

101 where

102 mkConst (I i) = "MKINT(" ++ show i ++ ")"

103 mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")"

104 | otherwise = "MKBIGC(vm,\"" ++ show i ++ "\")"

105 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"

106 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"

107 mkConst (Str s) = "MKSTR(vm, " ++ show s ++ ")"

108 mkConst _ = "MKINT(42424242)"

109bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

110bcc i (MKCON l tag args)

111 = indent i ++ creg Tmp ++ " = allocCon(vm, " ++ show (length args) ++

112 ", 0); " ++ "SETTAG(" ++ creg Tmp ++ ", " ++ show tag ++ ");\n" ++

113 indent i ++ setArgs 0 args ++ "\n" ++

114 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"

115

116-- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++

117-- show (length args) ++ concatMap showArg args ++ ");\n"

118 where showArg r = ", " ++ creg r

119 setArgs i [] = ""

120 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++

121 "); " ++ setArgs (i + 1) xs

122

123bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++

124 ", " ++ show a ++ ");\n"

125bcc i (PROJECTINTO r t idx)

126 = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"

127bcc i (CASE r code def)

128 = indent i ++ "switch(TAG(" ++ creg r ++ ")) {\n" ++

129 concatMap (showCase i) code ++

130 showDef i def ++

131 indent i ++ "}\n"

132 where

133 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"

134 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"

135 showDef i Nothing = ""

136 showDef i (Just c) = indent i ++ "default:\n"

137 ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"

138bcc i (CONSTCASE r code def)

139 | intConsts code

140 = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++

141 concatMap (showCase i) code ++

142 showDef i def ++

143 indent i ++ "}\n"

144 | strConsts code

145 = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++

146 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"

147 | bigintConsts code

148 = concatMap (biCase (creg r)) code ++

149 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"

150 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code

151 where

152 intConsts ((I _, _ ) : _) = True

153 intConsts ((Ch _, _ ) : _) = True

154 intConsts _ = False

155

156 bigintConsts ((BI _, _ ) : _) = True

157 bigintConsts _ = False

158

159 strConsts ((Str _, _ ) : _) = True

160 strConsts _ = False

161

162 strCase sv (s, bc) =

163 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++

164 concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"

165 biCase bv (BI b, bc) =

166 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"

167 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"

168

169 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"

170 ++ concatMap (bcc (i+1)) bc ++

171 indent (i + 1) ++ "break;\n"

172 showDef i Nothing = ""

173 showDef i (Just c) = indent i ++ "default:\n"

174 ++ concatMap (bcc (i+1)) c ++

175 indent (i + 1) ++ "break;\n"

176 showDefS i Nothing = ""

177 showDefS i (Just c) = concatMap (bcc (i+1)) c

178

179bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"

180bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"

181bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"

182bcc i REBASE = indent i ++ "REBASE;\n"

183bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"

184bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"

185bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"

186bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"

187bcc i STOREOLD = indent i ++ "STOREOLD;\n"

188bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"

189bcc i (FOREIGNCALL l LANG_C rty fn args)

190 = indent i ++

191 c_irts rty (creg l ++ " = ")

192 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"

193 where fcall (t, arg) = irts_c t (creg arg)

194bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed

195bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0); exit(-1);"

196-- bcc i _ = indent i ++ "// not done yet\n"

197

198c_irts FInt l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

199c_irts FChar l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

200c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"

201c_irts FUnit l x = x

202c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"

203c_irts FDouble l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

204c_irts FAny l x = l ++ x

205

206irts_c FInt x = "GETINT(" ++ x ++ ")"

207irts_c FChar x = "GETINT(" ++ x ++ ")"

208irts_c FString x = "GETSTR(" ++ x ++ ")"

209irts_c FUnit x = x

210irts_c FPtr x = "GETPTR(" ++ x ++ ")"

211irts_c FDouble x = "GETFLOAT(" ++ x ++ ")"

212irts_c FAny x = x

213

214doOp v LPlus [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"

215doOp v LMinus [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"

216doOp v LTimes [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"

217doOp v LDiv [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"

218doOp v LMod [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"

219doOp v LAnd [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"

220doOp v LOr [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"

221doOp v LXOr [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"

222doOp v LSHL [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"

223doOp v LSHR [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"

224doOp v LCompl [x] = v ++ "INTOP(~," ++ creg x ++ ")"

225doOp v LEq [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"

226doOp v LLt [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"

227doOp v LLe [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"

228doOp v LGt [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"

229doOp v LGe [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"

230

231doOp v LFPlus [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"

232doOp v LFMinus [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"

233doOp v LFTimes [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"

234doOp v LFDiv [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"

235doOp v LFEq [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"

236doOp v LFLt [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"

237doOp v LFLe [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"

238doOp v LFGt [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"

239doOp v LFGe [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"

240

241doOp v LBPlus [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

242doOp v LBMinus [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

243doOp v LBTimes [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

244doOp v LBDiv [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

245doOp v LBMod [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

246doOp v LBEq [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

247doOp v LBLt [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

248doOp v LBLe [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

249doOp v LBGt [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

250doOp v LBGe [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

251

252doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

253doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

254doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

255doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"

256

257doOp v LIntFloat [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"

258doOp v LFloatInt [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"

259doOp v LIntStr [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"

260doOp v LStrInt [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"

261doOp v LIntBig [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"

262doOp v LBigInt [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"

263doOp v LStrBig [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"

264doOp v LBigStr [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"

265doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"

266doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"

267

268doOp v LReadStr [x] = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"

269doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"

270doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)"

271

272doOp v LFExp [x] = v ++ "MKFLOAT(exp(GETFLOAT(" ++ creg x ++ ")))"

273doOp v LFLog [x] = v ++ "MKFLOAT(log(GETFLOAT(" ++ creg x ++ ")))"

274doOp v LFSin [x] = v ++ "MKFLOAT(sin(GETFLOAT(" ++ creg x ++ ")))"

275doOp v LFCos [x] = v ++ "MKFLOAT(cos(GETFLOAT(" ++ creg x ++ ")))"

276doOp v LFTan [x] = v ++ "MKFLOAT(tan(GETFLOAT(" ++ creg x ++ ")))"

277doOp v LFASin [x] = v ++ "MKFLOAT(asin(GETFLOAT(" ++ creg x ++ ")))"

278doOp v LFACos [x] = v ++ "MKFLOAT(acos(GETFLOAT(" ++ creg x ++ ")))"

279doOp v LFATan [x] = v ++ "MKFLOAT(atan(GETFLOAT(" ++ creg x ++ ")))"

280doOp v LFSqrt [x] = v ++ "MKFLOAT(floor(GETFLOAT(" ++ creg x ++ ")))"

281doOp v LFFloor [x] = v ++ "MKFLOAT(ceil(GETFLOAT(" ++ creg x ++ ")))"

282doOp v LFCeil [x] = v ++ "MKFLOAT(sqrt(GETFLOAT(" ++ creg x ++ ")))"

283

284doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"

285doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"

286doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")"

287doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")"

288doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")"

289

290doOp v LStdIn [] = v ++ "MKPTR(vm, stdin)"

291doOp v LStdOut [] = v ++ "MKPTR(vm, stdout)"

292doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)"

293

294doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

295doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

296doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"

297doOp v LNoOp args = v ++ creg (last args)

298doOp _ _ _ = "FAIL"