src/IRTS/CodegenC.hs · Idris-dev

git.iko.soy/Idris-dev

on e88a135 help sign in

Idris-dev/src/IRTS/CodegenC.hs

243 lines 11 kB history raw

1module IRTS.CodegenC where

3import IRTS.Bytecode

4import IRTS.Lang

5import IRTS.Simplified

6import Core.TT

7import Paths_idris

8import Util.System

10import Data.Char

11import System.Process

12import System.Exit

13import System.IO

14import System.Directory

15import Control.Monad

17data DbgLevel = NONE | DEBUG | TRACE

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

20 String -> -- output file name

21 Bool -> -- 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 then mprog else "")

36 (tmpn, tmph) <- tempfile

37 hPutStr tmph cout

38 hFlush tmph

39 hClose tmph

40 let useclang = False

41 comp <- getCC

42 let gcc = comp ++ " -I. " ++ objs ++ " -x c " ++

43 (if exec then "" else " - c ") ++

44 gccDbg dbg ++

45 " " ++ tmpn ++

46 " `idris --link` `idris --include` " ++ libs ++

47 " -o " ++ out

48 -- putStrLn cout

49 exit <- system gcc

50 when (exit /= ExitSuccess) $

51 putStrLn ("FAILURE: " ++ gcc)

53headers [] = "#include <idris_rts.h>\n#include <idris_stdfgn.h>\n#include<assert.h>\n"

54headers (x : xs) = "#include <" ++ x ++ ">\n" ++ headers xs

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

57debug _ = ""

59gccDbg DEBUG = "-g"

60gccDbg TRACE = "-O2"

61gccDbg _ = "-O2"

63cname :: Name -> String

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

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

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

68indent i = take (i * 4) (repeat ' ')

70creg RVal = "RVAL"

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

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

73creg Tmp = "REG1"

75toDecl :: Name -> String

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

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

79toC f code

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

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

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

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

85bcc :: Int -> BC -> String

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

87bcc i (ASSIGNCONST l c)

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

89 where

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

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

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

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

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

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

96 mkConst _ = "MKINT(42424242)"

97bcc i (MKCON l tag args)

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

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

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

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

102

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

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

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

106 setArgs i [] = ""

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

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

109

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

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

112bcc i (CASE r code def)

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

114 concatMap (showCase i) code ++

115 showDef i def ++

116 indent i ++ "}\n"

117 where

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

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

120 showDef i Nothing = ""

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

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

123bcc i (CONSTCASE r code def)

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

125 concatMap (showCase i) code ++

126 showDef i def ++

127 indent i ++ "}\n"

128 where

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

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

131 showDef i Nothing = ""

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

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

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

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

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

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

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

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

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

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

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

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

144bcc i (FOREIGNCALL l LANG_C rty fn args)

145 = indent i ++

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

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

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

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

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

151

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

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

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

155c_irts FUnit l x = x

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

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

158c_irts FAny l x = l ++ x

159

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

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

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

163irts_c FUnit x = x

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

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

166irts_c FAny x = x

167

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

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

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

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

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

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

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

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

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

177

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

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

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

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

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

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

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

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

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

187

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

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

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

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

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

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

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

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

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

197

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

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

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

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

202

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

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

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

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

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

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

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

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

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

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

213

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

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

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

217

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

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

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

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

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

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

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

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

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

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

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

229

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

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

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

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

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

235

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

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

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

239

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

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

242doOp v LNoOp [x] = ""

243doOp _ _ _ = "FAIL"