git.iko.soy/Idris-dev
on be7bbd7 help sign in
Idris-dev/src/IRTS/CodegenC.hs
509 lines 25 kB history raw
1module IRTS.CodegenC (codegenC) where
3import Idris.AbsSyntax
4import IRTS.Bytecode
5import IRTS.Lang
6import IRTS.Simplified
7import IRTS.System
8import IRTS.CodegenCommon
9import Idris.Core.TT
10import Util.System
12import Numeric
13import Data.Char
14import Data.List (intercalate)
15import System.Process
16import System.Exit
17import System.IO
18import System.Directory
19import System.FilePath ((</>), (<.>))
20import Control.Monad
22codegenC :: CodeGenerator
23codegenC ci = codegenC' (simpleDecls ci)
24 (outputFile ci)
25 (outputType ci)
26 (includes ci)
27 (concatMap mkObj (compileObjs ci))
28 (concatMap mkLib (compileLibs ci) ++
29 concatMap incdir (importDirs ci))
30 (concatMap mkFlag (compilerFlags ci))
31 (debugLevel ci)
33 where mkObj f = f ++ " "
34 mkLib l = "-l" ++ l ++ " "
35 mkFlag l = l ++ " "
36 incdir i = "-I" ++ i ++ " "
38codegenC' :: [(Name, SDecl)] ->
39 String -> -- output file name
40 OutputType -> -- generate executable if True, only .o if False
41 [FilePath] -> -- include files
42 String -> -- extra object files
43 String -> -- extra compiler flags (libraries)
44 String -> -- extra compiler flags (anything)
45 DbgLevel ->
46 IO ()
47codegenC' defs out exec incs objs libs flags dbg
48 = do -- print defs
49 let bc = map toBC defs
50 let h = concatMap toDecl (map fst bc)
51 let cc = concatMap (uncurry toC) bc
52 d <- getDataDir
53 mprog <- readFile (d </> "rts" </> "idris_main" <.> "c")
54 let cout = headers incs ++ debug dbg ++ h ++ cc ++
55 (if (exec == Executable) then mprog else "")
56 case exec of
57 MavenProject -> putStrLn ("FAILURE: output type not supported")
58 Raw -> writeFile out cout
59 _ -> do
60 (tmpn, tmph) <- tempfile
61 hPutStr tmph cout
62 hFlush tmph
63 hClose tmph
64 comp <- getCC
65 libFlags <- getLibFlags
66 incFlags <- getIncFlags
67 let gcc = comp ++ " " ++
68 gccDbg dbg ++ " " ++
69 gccFlags ++
70 " -DHAS_PTHREAD " ++
71 " -I. " ++ objs ++ " -x c " ++
72 (if (exec == Executable) then "" else " -c ") ++
73 " " ++ tmpn ++
74 " " ++ libFlags ++
75 " " ++ incFlags ++
76 " " ++ libs ++
77 " " ++ flags ++
78 " -o " ++ out
79-- putStrLn gcc
80 exit <- system gcc
81 when (exit /= ExitSuccess) $
82 putStrLn ("FAILURE: " ++ gcc)
84headers xs =
85 concatMap
86 (\h -> "#include <" ++ h ++ ">\n")
87 (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h", "assert.h"])
89debug TRACE = "#define IDRIS_TRACE\n\n"
90debug _ = ""
92-- We're using signed integers now. Make sure we get consistent semantics
93-- out of them from gcc. See e.g. http://thiemonagel.de/2010/01/signed-integer-overflow/
94gccFlags = " -fwrapv -fno-strict-overflow"
96gccDbg DEBUG = "-g"
97gccDbg TRACE = "-O2"
98gccDbg _ = "-O2"
100cname :: Name -> String
101cname n = "_idris_" ++ concatMap cchar (showCG n)
102 where cchar x | isAlpha x || isDigit x = [x]
103 | otherwise = "_" ++ show (fromEnum x) ++ "_"
105indent :: Int -> String
106indent n = replicate (n*4) ' '
108creg RVal = "RVAL"
109creg (L i) = "LOC(" ++ show i ++ ")"
110creg (T i) = "TOP(" ++ show i ++ ")"
111creg Tmp = "REG1"
113toDecl :: Name -> String
114toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"
116toC :: Name -> [BC] -> String
117toC f code
118 = -- "/* " ++ show code ++ "*/\n\n" ++
119 "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++
120 indent 1 ++ "INITFRAME;\n" ++
121 concatMap (bcc 1) code ++ "}\n\n"
123showCStr :: String -> String
124showCStr s = '"' : foldr ((++) . showChar) "\"" s
125 where
126 showChar :: Char -> String
127 showChar '"' = "\\\""
128 showChar '\\' = "\\\\"
129 showChar c
130 -- Note: we need the double quotes around the codes because otherwise
131 -- "\n3" would get encoded as "\x0a3", which is incorrect.
132 -- Instead, we opt for "\x0a""3" and let the C compiler deal with it.
133 | ord c < 0x10 = "\"\"\\x0" ++ showHex (ord c) "\"\""
134 | ord c < 0x20 = "\"\"\\x" ++ showHex (ord c) "\"\""
135 | ord c < 0x7f = [c] -- 0x7f = \DEL
136 | ord c < 0x100 = "\"\"\\x" ++ showHex (ord c) "\"\""
137 | otherwise = error $ "non-8-bit character in string literal: " ++ show c
139bcc :: Int -> BC -> String
140bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
141bcc i (ASSIGNCONST l c)
142 = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"
143 where
144 mkConst (I i) = "MKINT(" ++ show i ++ ")"
145 mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")"
146 | otherwise = "MKBIGC(vm,\"" ++ show i ++ "\")"
147 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"
148 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"
149 mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"
150 mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ "U)"
151 mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"
152 mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"
153 mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"
154 mkConst _ = "MKINT(42424242)"
155bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
156bcc i (MKCON l loc tag []) | tag < 256
157 = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"
158bcc i (MKCON l loc tag args)
159 = indent i ++ alloc loc tag ++
160 indent i ++ setArgs 0 args ++ "\n" ++
161 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"
163-- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++
164-- show (length args) ++ concatMap showArg args ++ ");\n"
165 where showArg r = ", " ++ creg r
166 setArgs i [] = ""
167 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++
168 "); " ++ setArgs (i + 1) xs
169 alloc Nothing tag
170 = "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ ", " ++
171 show (length args) ++ ", 0);\n"
172 alloc (Just old) tag
173 = "updateCon(" ++ creg Tmp ++ ", " ++ creg old ++ ", " ++ show tag ++ ", " ++
174 show (length args) ++ ");\n"
176bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++
177 ", " ++ show a ++ ");\n"
178bcc i (PROJECTINTO r t idx)
179 = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"
180bcc i (CASE True r code def)
181 | length code < 4 = showCase i def code
182 where
183 showCode :: Int -> [BC] -> String
184 showCode i bc = "{\n" ++ concatMap (bcc (i + 1)) bc ++
185 indent i ++ "}\n"
187 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String
188 showCase i Nothing [(t, c)] = showCode i c
189 showCase i (Just def) [] = showCode i def
190 showCase i def ((t, c) : cs)
191 = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c
192 ++ indent i ++ "else " ++ showCase i def cs
194bcc i (CASE safe r code def)
195 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++
196 concatMap (showCase i) code ++
197 showDef i def ++
198 indent i ++ "}\n"
199 where
200 ctag True = "CTAG"
201 ctag False = "TAG"
203 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
204 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"
205 showDef i Nothing = ""
206 showDef i (Just c) = indent i ++ "default:\n"
207 ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"
208bcc i (CONSTCASE r code def)
209 | intConsts code
210-- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++
211-- concatMap (showCase i) code ++
212-- showDef i def ++
213-- indent i ++ "}\n"
214 = concatMap (iCase (creg r)) code ++
215 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
216 | strConsts code
217 = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++
218 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
219 | bigintConsts code
220 = concatMap (biCase (creg r)) code ++
221 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
222 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code
223 where
224 intConsts ((I _, _ ) : _) = True
225 intConsts ((Ch _, _ ) : _) = True
226 intConsts _ = False
228 bigintConsts ((BI _, _ ) : _) = True
229 bigintConsts _ = False
231 strConsts ((Str _, _ ) : _) = True
232 strConsts _ = False
234 strCase sv (s, bc) =
235 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++
236 concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
237 biCase bv (BI b, bc) =
238 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"
239 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
240 iCase v (I b, bc) =
241 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"
242 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
243 iCase v (Ch b, bc) =
244 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n"
245 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
247 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
248 ++ concatMap (bcc (i+1)) bc ++
249 indent (i + 1) ++ "break;\n"
250 showDef i Nothing = ""
251 showDef i (Just c) = indent i ++ "default:\n"
252 ++ concatMap (bcc (i+1)) c ++
253 indent (i + 1) ++ "break;\n"
254 showDefS i Nothing = ""
255 showDefS i (Just c) = concatMap (bcc (i+1)) c
257bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"
258bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"
259bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"
260bcc i REBASE = indent i ++ "REBASE;\n"
261bcc i (RESERVE 0) = ""
262bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"
263bcc i (ADDTOP 0) = ""
264bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"
265bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
266bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
267bcc i STOREOLD = indent i ++ "STOREOLD;\n"
268bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"
269bcc i (FOREIGNCALL l LANG_C rty fn args)
270 = indent i ++
271 c_irts rty (creg l ++ " = ")
272 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
273 where fcall (t, arg) = irts_c t (creg arg)
274bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed
275bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0); exit(-1);"
276-- bcc i _ = indent i ++ "// not done yet\n"
280c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
281c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x
282c_irts (FArith (ATInt (ITFixed ity))) l x
283 = l ++ "idris_b" ++ show (nativeTyWidth ity) ++ "const(vm, " ++ x ++ ")"
284c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"
285c_irts FUnit l x = x
286c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"
287c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"
288c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"
289c_irts FAny l x = l ++ x
291irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"
292irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x
293irts_c (FArith (ATInt (ITFixed ity))) x
294 = "(" ++ x ++ "->info.bits" ++ show (nativeTyWidth ity) ++ ")"
295irts_c FString x = "GETSTR(" ++ x ++ ")"
296irts_c FUnit x = x
297irts_c FPtr x = "GETPTR(" ++ x ++ ")"
298irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"
299irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"
300irts_c FAny x = x
302bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"
304bitCoerce v op input output arg
305 = v ++ "idris_b" ++ show (nativeTyWidth input) ++ op ++ show (nativeTyWidth output) ++ "(vm, " ++ creg arg ++ ")"
307signedTy :: NativeTy -> String
308signedTy t = "int" ++ show (nativeTyWidth t) ++ "_t"
310doOp v (LPlus (ATInt ITNative)) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"
311doOp v (LMinus (ATInt ITNative)) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
312doOp v (LTimes (ATInt ITNative)) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"
313doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
314doOp v (LSDiv (ATInt ITNative)) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
315doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
316doOp v (LSRem (ATInt ITNative)) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
317doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"
318doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"
319doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"
320doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"
321doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
322doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
323doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"
324doOp v (LEq (ATInt ITNative)) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
325doOp v (LSLt (ATInt ITNative)) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
326doOp v (LSLe (ATInt ITNative)) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
327doOp v (LSGt (ATInt ITNative)) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
328doOp v (LSGe (ATInt ITNative)) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
329doOp v (LLt ITNative) [l, r] = v ++ "UINTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
330doOp v (LLe ITNative) [l, r] = v ++ "UINTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
331doOp v (LGt ITNative) [l, r] = v ++ "UINTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
332doOp v (LGe ITNative) [l, r] = v ++ "UINTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
334doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r]
335doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r]
336doOp v (LTimes (ATInt ITChar)) [l, r] = doOp v (LTimes (ATInt ITNative)) [l, r]
337doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r]
338doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r]
339doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r]
340doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r]
341doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r]
342doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r]
343doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r]
344doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r]
345doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r]
346doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r]
347doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x]
348doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r]
349doOp v (LSLt (ATInt ITChar)) [l, r] = doOp v (LSLt (ATInt ITNative)) [l, r]
350doOp v (LSLe (ATInt ITChar)) [l, r] = doOp v (LSLe (ATInt ITNative)) [l, r]
351doOp v (LSGt (ATInt ITChar)) [l, r] = doOp v (LSGt (ATInt ITNative)) [l, r]
352doOp v (LSGe (ATInt ITChar)) [l, r] = doOp v (LSGe (ATInt ITNative)) [l, r]
353doOp v (LLt ITChar) [l, r] = doOp v (LLt ITNative) [l, r]
354doOp v (LLe ITChar) [l, r] = doOp v (LLe ITNative) [l, r]
355doOp v (LGt ITChar) [l, r] = doOp v (LGt ITNative) [l, r]
356doOp v (LGe ITChar) [l, r] = doOp v (LGe ITNative) [l, r]
358doOp v (LPlus ATFloat) [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"
359doOp v (LMinus ATFloat) [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
360doOp v (LTimes ATFloat) [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"
361doOp v (LSDiv ATFloat) [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
362doOp v (LEq ATFloat) [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
363doOp v (LSLt ATFloat) [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
364doOp v (LSLe ATFloat) [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
365doOp v (LSGt ATFloat) [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
366doOp v (LSGe ATFloat) [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
368doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"
369doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"
370doOp v (LPlus (ATInt ITBig)) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
371doOp v (LMinus (ATInt ITBig)) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
372doOp v (LTimes (ATInt ITBig)) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
373doOp v (LSDiv (ATInt ITBig)) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
374doOp v (LSRem (ATInt ITBig)) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
375doOp v (LEq (ATInt ITBig)) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
376doOp v (LSLt (ATInt ITBig)) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
377doOp v (LSLe (ATInt ITBig)) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
378doOp v (LSGt (ATInt ITBig)) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
379doOp v (LSGe (ATInt ITBig)) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
381doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
382doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
383doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
384doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"
386doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"
387doOp v (LFloatInt ITNative) [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"
388doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"
389doOp v (LTrunc ITBig ITNative) [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"
390doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"
391doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"
392doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"
393doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"
394doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"
395doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"
397doOp v LReadStr [x] = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"
398doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"
399doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)"
401doOp v (LSLt (ATInt (ITFixed ty))) [x, y] = bitOp v "SLt" ty [x, y]
402doOp v (LSLe (ATInt (ITFixed ty))) [x, y] = bitOp v "SLte" ty [x, y]
403doOp v (LEq (ATInt (ITFixed ty))) [x, y] = bitOp v "Eq" ty [x, y]
404doOp v (LSGe (ATInt (ITFixed ty))) [x, y] = bitOp v "SGte" ty [x, y]
405doOp v (LSGt (ATInt (ITFixed ty))) [x, y] = bitOp v "SGt" ty [x, y]
406doOp v (LLt (ITFixed ty)) [x, y] = bitOp v "Lt" ty [x, y]
407doOp v (LLe (ITFixed ty)) [x, y] = bitOp v "Lte" ty [x, y]
408doOp v (LGe (ITFixed ty)) [x, y] = bitOp v "Gte" ty [x, y]
409doOp v (LGt (ITFixed ty)) [x, y] = bitOp v "Gt" ty [x, y]
411doOp v (LSHL (ITFixed ty)) [x, y] = bitOp v "Shl" ty [x, y]
412doOp v (LLSHR (ITFixed ty)) [x, y] = bitOp v "LShr" ty [x, y]
413doOp v (LASHR (ITFixed ty)) [x, y] = bitOp v "AShr" ty [x, y]
414doOp v (LAnd (ITFixed ty)) [x, y] = bitOp v "And" ty [x, y]
415doOp v (LOr (ITFixed ty)) [x, y] = bitOp v "Or" ty [x, y]
416doOp v (LXOr (ITFixed ty)) [x, y] = bitOp v "Xor" ty [x, y]
417doOp v (LCompl (ITFixed ty)) [x] = bitOp v "Compl" ty [x]
419doOp v (LPlus (ATInt (ITFixed ty))) [x, y] = bitOp v "Plus" ty [x, y]
420doOp v (LMinus (ATInt (ITFixed ty))) [x, y] = bitOp v "Minus" ty [x, y]
421doOp v (LTimes (ATInt (ITFixed ty))) [x, y] = bitOp v "Times" ty [x, y]
422doOp v (LUDiv (ITFixed ty)) [x, y] = bitOp v "UDiv" ty [x, y]
423doOp v (LSDiv (ATInt (ITFixed ty))) [x, y] = bitOp v "SDiv" ty [x, y]
424doOp v (LURem (ITFixed ty)) [x, y] = bitOp v "URem" ty [x, y]
425doOp v (LSRem (ATInt (ITFixed ty))) [x, y] = bitOp v "SRem" ty [x, y]
427doOp v (LSExt (ITFixed from) ITBig) [x]
428 = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
429doOp v (LSExt ITNative (ITFixed to)) [x]
430 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
431doOp v (LSExt ITChar (ITFixed to)) [x]
432 = doOp v (LSExt ITNative (ITFixed to)) [x]
433doOp v (LSExt (ITFixed from) ITNative) [x]
434 = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ "))"
435doOp v (LSExt (ITFixed from) ITChar) [x]
436 = doOp v (LSExt (ITFixed from) ITNative) [x]
437doOp v (LSExt (ITFixed from) (ITFixed to)) [x]
438 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "S" from to x
439doOp v (LZExt ITNative (ITFixed to)) [x]
440 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ ")"
441doOp v (LZExt ITChar (ITFixed to)) [x]
442 = doOp v (LZExt ITNative (ITFixed to)) [x]
443doOp v (LZExt (ITFixed from) ITNative) [x]
444 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
445doOp v (LZExt (ITFixed from) ITChar) [x]
446 = doOp v (LZExt (ITFixed from) ITNative) [x]
447doOp v (LZExt (ITFixed from) ITBig) [x]
448 = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
449doOp v (LZExt ITNative ITBig) [x]
450 = v ++ "MKBIGUI(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
451doOp v (LZExt (ITFixed from) (ITFixed to)) [x]
452 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "Z" from to x
453doOp v (LTrunc ITNative (ITFixed to)) [x]
454 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
455doOp v (LTrunc ITChar (ITFixed to)) [x]
456 = doOp v (LTrunc ITNative (ITFixed to)) [x]
457doOp v (LTrunc (ITFixed from) ITNative) [x]
458 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
459doOp v (LTrunc (ITFixed from) ITChar) [x]
460 = doOp v (LTrunc (ITFixed from) ITNative) [x]
461doOp v (LTrunc ITBig (ITFixed to)) [x]
462 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"
463doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]
464 | nativeTyWidth from > nativeTyWidth to = bitCoerce v "T" from to x
466doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)
467doOp v LFLog [x] = v ++ flUnOp "log" (creg x)
468doOp v LFSin [x] = v ++ flUnOp "sin" (creg x)
469doOp v LFCos [x] = v ++ flUnOp "cos" (creg x)
470doOp v LFTan [x] = v ++ flUnOp "tan" (creg x)
471doOp v LFASin [x] = v ++ flUnOp "asin" (creg x)
472doOp v LFACos [x] = v ++ flUnOp "acos" (creg x)
473doOp v LFATan [x] = v ++ flUnOp "atan" (creg x)
474doOp v LFSqrt [x] = v ++ flUnOp "sqrt" (creg x)
475doOp v LFFloor [x] = v ++ flUnOp "floor" (creg x)
476doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x)
478doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"
479doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"
480doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")"
481doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")"
482doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")"
484doOp v LAllocate [x] = v ++ "idris_allocate(vm, " ++ creg x ++ ")"
485doOp v LAppendBuffer [a, b, c, d, e, f] = v ++ "idris_appendBuffer(vm, " ++ creg a ++ "," ++ creg b ++ "," ++ creg c ++ "," ++ creg d ++ "," ++ creg e ++ "," ++ creg f ++ ")"
486doOp v (LAppend ity en) [a, b, c, d] = v ++ "idris_append" ++ intTyName ity ++ show en ++ "(vm, " ++ creg a ++ "," ++ creg b ++ "," ++ creg c ++ "," ++ creg d ++ ")"
487doOp v (LPeek ity en) [x, y] = v ++ "idris_peek" ++ intTyName ity ++ show en ++ "(vm, " ++ creg x ++ "," ++ creg y ++ ")"
489doOp v LStdIn [] = v ++ "MKPTR(vm, stdin)"
490doOp v LStdOut [] = v ++ "MKPTR(vm, stdout)"
491doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)"
493doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 0 "EVAL") ++ ", " ++ creg x ++ "))"
494doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
495doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"
496doOp v LNullPtr [] = v ++ "MKPTR(vm, NULL)"
497doOp v LRegisterPtr [p, i] = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++
498 "), GETINT(" ++ creg i ++ "))"
499doOp v (LChInt ITNative) args = v ++ creg (last args)
500doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args
501doOp v (LIntCh ITNative) args = v ++ creg (last args)
502doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args
504doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"
505doOp v LNoOp args = v ++ creg (last args)
506doOp _ op _ = "FAIL /* " ++ show op ++ " */"
508flUnOp :: String -> String -> String
509flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"