git.iko.soy/Idris-dev
on fcb66ca help sign in
Idris-dev/src/IRTS/CodegenC.hs
439 lines 22 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 Data.List (intercalate)
14import System.Process
15import System.Exit
16import System.IO
17import System.Directory
18import System.FilePath ((</>), (<.>))
19import Control.Monad
21codegenC :: [(Name, SDecl)] ->
22 String -> -- output file name
23 OutputType -> -- 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 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 == Executable) then mprog else "")
38 case exec of
39 Raw -> writeFile out cout
40 _ -> do
41 (tmpn, tmph) <- tempfile
42 hPutStr tmph cout
43 hFlush tmph
44 hClose tmph
45 let useclang = False
46 comp <- getCC
47 libFlags <- getLibFlags
48 incFlags <- getIncFlags
49 let gcc = comp ++ " " ++
50 gccDbg dbg ++
51 " -I. " ++ objs ++ " -x c " ++
52 (if (exec == Executable) then "" else " -c ") ++
53 " " ++ tmpn ++
54 " " ++ libFlags ++
55 " " ++ incFlags ++
56 " " ++ libs ++
57 " -o " ++ out
58-- putStrLn gcc
59 exit <- system gcc
60 when (exit /= ExitSuccess) $
61 putStrLn ("FAILURE: " ++ gcc)
63headers xs =
64 concatMap
65 (\h -> "#include <" ++ h ++ ">\n")
66 (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h", "gmp.h", "assert.h"])
68debug TRACE = "#define IDRIS_TRACE\n\n"
69debug _ = ""
71gccDbg DEBUG = "-g"
72gccDbg TRACE = "-O2"
73gccDbg _ = "-O2"
75cname :: Name -> String
76cname n = "_idris_" ++ concatMap cchar (show n)
77 where cchar x | isAlpha x || isDigit x = [x]
78 | otherwise = "_" ++ show (fromEnum x) ++ "_"
80indent :: Int -> String
81indent n = replicate (n*4) ' '
83creg RVal = "RVAL"
84creg (L i) = "LOC(" ++ show i ++ ")"
85creg (T i) = "TOP(" ++ show i ++ ")"
86creg Tmp = "REG1"
88toDecl :: Name -> String
89toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"
91toC :: Name -> [BC] -> String
92toC f code
93 = -- "/* " ++ show code ++ "*/\n\n" ++
94 "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++
95 indent 1 ++ "INITFRAME;\n" ++
96 concatMap (bcc 1) code ++ "}\n\n"
98bcc :: Int -> BC -> String
99bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
100bcc i (ASSIGNCONST l c)
101 = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"
102 where
103 mkConst (I i) = "MKINT(" ++ show i ++ ")"
104 mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")"
105 | otherwise = "MKBIGC(vm,\"" ++ show i ++ "\")"
106 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"
107 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"
108 mkConst (Str s) = "MKSTR(vm, " ++ show s ++ ")"
109 mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ ")"
110 mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ ")"
111 mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ ")"
112 mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ ")"
113 mkConst _ = "MKINT(42424242)"
114bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
115bcc i (MKCON l tag args)
116 = indent i ++ "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ "," ++
117 show (length args) ++ ", 0);\n" ++
118 indent i ++ setArgs 0 args ++ "\n" ++
119 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"
121-- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++
122-- show (length args) ++ concatMap showArg args ++ ");\n"
123 where showArg r = ", " ++ creg r
124 setArgs i [] = ""
125 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++
126 "); " ++ setArgs (i + 1) xs
128bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++
129 ", " ++ show a ++ ");\n"
130bcc i (PROJECTINTO r t idx)
131 = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"
132bcc i (CASE True r code def)
133 | length code < 4 = showCase i def code
134 where
135 showCode :: Int -> [BC] -> String
136 showCode i bc = "{\n" ++ indent i ++ concatMap (bcc (i + 1)) bc ++
137 indent i ++ "}\n"
139 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String
140 showCase i Nothing [(t, c)] = showCode i c
141 showCase i (Just def) [] = showCode i def
142 showCase i def ((t, c) : cs)
143 = "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c
144 ++ "else " ++ showCase i def cs
146bcc i (CASE safe r code def)
147 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++
148 concatMap (showCase i) code ++
149 showDef i def ++
150 indent i ++ "}\n"
151 where
152 ctag True = "CTAG"
153 ctag False = "TAG"
155 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
156 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"
157 showDef i Nothing = ""
158 showDef i (Just c) = indent i ++ "default:\n"
159 ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"
160bcc i (CONSTCASE r code def)
161 | intConsts code
162-- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++
163-- concatMap (showCase i) code ++
164-- showDef i def ++
165-- indent i ++ "}\n"
166 = concatMap (iCase (creg r)) code ++
167 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
168 | strConsts code
169 = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++
170 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
171 | bigintConsts code
172 = concatMap (biCase (creg r)) code ++
173 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
174 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code
175 where
176 intConsts ((I _, _ ) : _) = True
177 intConsts ((Ch _, _ ) : _) = True
178 intConsts _ = False
180 bigintConsts ((BI _, _ ) : _) = True
181 bigintConsts _ = False
183 strConsts ((Str _, _ ) : _) = True
184 strConsts _ = False
186 strCase sv (s, bc) =
187 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++
188 concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
189 biCase bv (BI b, bc) =
190 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"
191 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
192 iCase v (I b, bc) =
193 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"
194 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
195 iCase v (Ch b, bc) =
196 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"
197 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
199 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
200 ++ concatMap (bcc (i+1)) bc ++
201 indent (i + 1) ++ "break;\n"
202 showDef i Nothing = ""
203 showDef i (Just c) = indent i ++ "default:\n"
204 ++ concatMap (bcc (i+1)) c ++
205 indent (i + 1) ++ "break;\n"
206 showDefS i Nothing = ""
207 showDefS i (Just c) = concatMap (bcc (i+1)) c
209bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"
210bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"
211bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"
212bcc i REBASE = indent i ++ "REBASE;\n"
213bcc i (RESERVE 0) = ""
214bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"
215bcc i (ADDTOP 0) = ""
216bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"
217bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
218bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
219bcc i STOREOLD = indent i ++ "STOREOLD;\n"
220bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"
221bcc i (FOREIGNCALL l LANG_C rty fn args)
222 = indent i ++
223 c_irts rty (creg l ++ " = ")
224 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
225 where fcall (t, arg) = irts_c t (creg arg)
226bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed
227bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0); exit(-1);"
228-- bcc i _ = indent i ++ "// not done yet\n"
232c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
233c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x
234c_irts (FArith (ATInt (ITFixed ity))) l x
235 = l ++ "idris_b" ++ show (nativeTyWidth ity) ++ "const(vm, " ++ x ++ ")"
236c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"
237c_irts FUnit l x = x
238c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"
239c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"
240c_irts FAny l x = l ++ x
242irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"
243irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x
244irts_c (FArith (ATInt (ITFixed ity))) x
245 = "(" ++ x ++ "->info.bits" ++ show (nativeTyWidth ity) ++ ")"
246irts_c FString x = "GETSTR(" ++ x ++ ")"
247irts_c FUnit x = x
248irts_c FPtr x = "GETPTR(" ++ x ++ ")"
249irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"
250irts_c FAny x = x
252bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"
254bitCoerce v op input output arg
255 = v ++ "idris_b" ++ show (nativeTyWidth input) ++ op ++ show (nativeTyWidth output) ++ "(vm, " ++ creg arg ++ ")"
257signedTy :: NativeTy -> String
258signedTy t = "int" ++ show (nativeTyWidth t) ++ "_t"
260doOp v (LPlus (ATInt ITNative)) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"
261doOp v (LMinus (ATInt ITNative)) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
262doOp v (LTimes (ATInt ITNative)) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"
263doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
264doOp v (LSDiv (ATInt ITNative)) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
265doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
266doOp v (LSRem (ATInt ITNative)) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
267doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"
268doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"
269doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"
270doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"
271doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
272doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
273doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"
274doOp v (LEq (ATInt ITNative)) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
275doOp v (LLt (ATInt ITNative)) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
276doOp v (LLe (ATInt ITNative)) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
277doOp v (LGt (ATInt ITNative)) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
278doOp v (LGe (ATInt ITNative)) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
280doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r]
281doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r]
282doOp v (LTimes (ATInt ITChar)) [l, r] = doOp v (LTimes (ATInt ITNative)) [l, r]
283doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r]
284doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r]
285doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r]
286doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r]
287doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r]
288doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r]
289doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r]
290doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r]
291doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r]
292doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r]
293doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x]
294doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r]
295doOp v (LLt (ATInt ITChar)) [l, r] = doOp v (LLt (ATInt ITNative)) [l, r]
296doOp v (LLe (ATInt ITChar)) [l, r] = doOp v (LLe (ATInt ITNative)) [l, r]
297doOp v (LGt (ATInt ITChar)) [l, r] = doOp v (LGt (ATInt ITNative)) [l, r]
298doOp v (LGe (ATInt ITChar)) [l, r] = doOp v (LGe (ATInt ITNative)) [l, r]
300doOp v (LPlus ATFloat) [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"
301doOp v (LMinus ATFloat) [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
302doOp v (LTimes ATFloat) [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"
303doOp v (LSDiv ATFloat) [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
304doOp v (LEq ATFloat) [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
305doOp v (LLt ATFloat) [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
306doOp v (LLe ATFloat) [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
307doOp v (LGt ATFloat) [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
308doOp v (LGe ATFloat) [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
310doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"
311doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"
312doOp v (LPlus (ATInt ITBig)) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
313doOp v (LMinus (ATInt ITBig)) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
314doOp v (LTimes (ATInt ITBig)) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
315doOp v (LSDiv (ATInt ITBig)) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
316doOp v (LSRem (ATInt ITBig)) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
317doOp v (LEq (ATInt ITBig)) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
318doOp v (LLt (ATInt ITBig)) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
319doOp v (LLe (ATInt ITBig)) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
320doOp v (LGt (ATInt ITBig)) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
321doOp v (LGe (ATInt ITBig)) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
323doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
324doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
325doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
326doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"
328doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"
329doOp v (LFloatInt ITNative) [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"
330doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"
331doOp v (LTrunc ITBig ITNative) [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"
332doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"
333doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"
334doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"
335doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"
336doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"
337doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"
339doOp v LReadStr [x] = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"
340doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"
341doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)"
343doOp v (LLt (ATInt (ITFixed ty))) [x, y] = bitOp v "Lt" ty [x, y]
344doOp v (LLe (ATInt (ITFixed ty))) [x, y] = bitOp v "Lte" ty [x, y]
345doOp v (LEq (ATInt (ITFixed ty))) [x, y] = bitOp v "Eq" ty [x, y]
346doOp v (LGe (ATInt (ITFixed ty))) [x, y] = bitOp v "Gte" ty [x, y]
347doOp v (LGt (ATInt (ITFixed ty))) [x, y] = bitOp v "Gt" ty [x, y]
349doOp v (LSHL (ITFixed ty)) [x, y] = bitOp v "Shl" ty [x, y]
350doOp v (LLSHR (ITFixed ty)) [x, y] = bitOp v "LShr" ty [x, y]
351doOp v (LASHR (ITFixed ty)) [x, y] = bitOp v "AShr" ty [x, y]
352doOp v (LAnd (ITFixed ty)) [x, y] = bitOp v "And" ty [x, y]
353doOp v (LOr (ITFixed ty)) [x, y] = bitOp v "Or" ty [x, y]
354doOp v (LXOr (ITFixed ty)) [x, y] = bitOp v "Xor" ty [x, y]
355doOp v (LCompl (ITFixed ty)) [x] = bitOp v "Compl" ty [x]
357doOp v (LPlus (ATInt (ITFixed ty))) [x, y] = bitOp v "Plus" ty [x, y]
358doOp v (LMinus (ATInt (ITFixed ty))) [x, y] = bitOp v "Minus" ty [x, y]
359doOp v (LTimes (ATInt (ITFixed ty))) [x, y] = bitOp v "Times" ty [x, y]
360doOp v (LUDiv (ITFixed ty)) [x, y] = bitOp v "UDiv" ty [x, y]
361doOp v (LSDiv (ATInt (ITFixed ty))) [x, y] = bitOp v "SDiv" ty [x, y]
362doOp v (LURem (ITFixed ty)) [x, y] = bitOp v "URem" ty [x, y]
363doOp v (LSRem (ATInt (ITFixed ty))) [x, y] = bitOp v "SRem" ty [x, y]
365doOp v (LSExt (ITFixed from) ITBig) [x]
366 = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
367doOp v (LZExt ITNative ITBig) [x]
368 = v ++ "MKBIGSI(vm, GETINT(" ++ creg x ++ "))"
369doOp v (LSExt ITNative (ITFixed to)) [x]
370 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
371doOp v (LSExt ITChar (ITFixed to)) [x]
372 = doOp v (LSExt ITNative (ITFixed to)) [x]
373doOp v (LSExt (ITFixed from) ITNative) [x]
374 = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ "))"
375doOp v (LSExt (ITFixed from) ITChar) [x]
376 = doOp v (LSExt (ITFixed from) ITNative) [x]
377doOp v (LSExt (ITFixed from) (ITFixed to)) [x]
378 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "S" from to x
379doOp v (LZExt ITNative (ITFixed to)) [x]
380 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ ")"
381doOp v (LZExt ITChar (ITFixed to)) [x]
382 = doOp v (LZExt ITNative (ITFixed to)) [x]
383doOp v (LZExt (ITFixed from) ITNative) [x]
384 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
385doOp v (LZExt (ITFixed from) ITChar) [x]
386 = doOp v (LZExt (ITFixed from) ITNative) [x]
387doOp v (LZExt (ITFixed from) ITBig) [x]
388 = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
389doOp v (LZExt ITNative ITBig) [x]
390 = v ++ "MKBIGUI(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
391doOp v (LZExt (ITFixed from) (ITFixed to)) [x]
392 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "Z" from to x
393doOp v (LTrunc ITNative (ITFixed to)) [x]
394 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
395doOp v (LTrunc ITChar (ITFixed to)) [x]
396 = doOp v (LTrunc ITNative (ITFixed to)) [x]
397doOp v (LTrunc (ITFixed from) ITNative) [x]
398 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
399doOp v (LTrunc (ITFixed from) ITChar) [x]
400 = doOp v (LTrunc (ITFixed from) ITNative) [x]
401doOp v (LTrunc ITBig (ITFixed to)) [x]
402 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"
403doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]
404 | nativeTyWidth from > nativeTyWidth to = bitCoerce v "T" from to x
406doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)
407doOp v LFLog [x] = v ++ flUnOp "log" (creg x)
408doOp v LFSin [x] = v ++ flUnOp "sin" (creg x)
409doOp v LFCos [x] = v ++ flUnOp "cos" (creg x)
410doOp v LFTan [x] = v ++ flUnOp "tan" (creg x)
411doOp v LFASin [x] = v ++ flUnOp "asin" (creg x)
412doOp v LFACos [x] = v ++ flUnOp "acos" (creg x)
413doOp v LFATan [x] = v ++ flUnOp "atan" (creg x)
414doOp v LFSqrt [x] = v ++ flUnOp "sqrt" (creg x)
415doOp v LFFloor [x] = v ++ flUnOp "floor" (creg x)
416doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x)
418doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"
419doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"
420doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")"
421doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")"
422doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")"
424doOp v LStdIn [] = v ++ "MKPTR(vm, stdin)"
425doOp v LStdOut [] = v ++ "MKPTR(vm, stdout)"
426doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)"
428doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
429doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
430doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"
431doOp v (LChInt ITNative) args = v ++ creg (last args)
432doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args
433doOp v (LIntCh ITNative) args = v ++ creg (last args)
434doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args
435doOp v LNoOp args = v ++ creg (last args)
436doOp _ op _ = "FAIL /* " ++ show op ++ " */"
438flUnOp :: String -> String -> String
439flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"