git.iko.soy/Idris-dev
on bb87d4d help sign in
Idris-dev/src/IRTS/CodegenC.hs
511 lines 26 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 -- # Any flags defined here which alter the RTS API must also be added to config.mk
71 " -DHAS_PTHREAD -DIDRIS_ENABLE_STATS" ++
72 " -I. " ++ objs ++ " -x c " ++
73 (if (exec == Executable) then "" else " -c ") ++
74 " " ++ tmpn ++
75 " " ++ libFlags ++
76 " " ++ incFlags ++
77 " " ++ libs ++
78 " " ++ flags ++
79 " -o " ++ out
80-- putStrLn gcc
81 exit <- system gcc
82 when (exit /= ExitSuccess) $
83 putStrLn ("FAILURE: " ++ gcc)
85headers xs =
86 concatMap
87 (\h -> "#include <" ++ h ++ ">\n")
88 (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h", "assert.h"])
90debug TRACE = "#define IDRIS_TRACE\n\n"
91debug _ = ""
93-- We're using signed integers now. Make sure we get consistent semantics
94-- out of them from gcc. See e.g. http://thiemonagel.de/2010/01/signed-integer-overflow/
95gccFlags = " -fwrapv -fno-strict-overflow"
97gccDbg DEBUG = "-g"
98gccDbg TRACE = "-O2"
99gccDbg _ = "-O2"
101cname :: Name -> String
102cname n = "_idris_" ++ concatMap cchar (showCG n)
103 where cchar x | isAlpha x || isDigit x = [x]
104 | otherwise = "_" ++ show (fromEnum x) ++ "_"
106indent :: Int -> String
107indent n = replicate (n*4) ' '
109creg RVal = "RVAL"
110creg (L i) = "LOC(" ++ show i ++ ")"
111creg (T i) = "TOP(" ++ show i ++ ")"
112creg Tmp = "REG1"
114toDecl :: Name -> String
115toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"
117toC :: Name -> [BC] -> String
118toC f code
119 = -- "/* " ++ show code ++ "*/\n\n" ++
120 "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++
121 indent 1 ++ "INITFRAME;\n" ++
122 concatMap (bcc 1) code ++ "}\n\n"
124showCStr :: String -> String
125showCStr s = '"' : foldr ((++) . showChar) "\"" s
126 where
127 showChar :: Char -> String
128 showChar '"' = "\\\""
129 showChar '\\' = "\\\\"
130 showChar c
131 -- Note: we need the double quotes around the codes because otherwise
132 -- "\n3" would get encoded as "\x0a3", which is incorrect.
133 -- Instead, we opt for "\x0a""3" and let the C compiler deal with it.
134 | ord c < 0x10 = "\"\"\\x0" ++ showHex (ord c) "\"\""
135 | ord c < 0x20 = "\"\"\\x" ++ showHex (ord c) "\"\""
136 | ord c < 0x7f = [c] -- 0x7f = \DEL
137 | ord c < 0x100 = "\"\"\\x" ++ showHex (ord c) "\"\""
138 | otherwise = error $ "non-8-bit character in string literal: " ++ show c
140bcc :: Int -> BC -> String
141bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
142bcc i (ASSIGNCONST l c)
143 = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"
144 where
145 mkConst (I i) = "MKINT(" ++ show i ++ ")"
146 mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")"
147 | otherwise = "MKBIGC(vm,\"" ++ show i ++ "\")"
148 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"
149 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"
150 mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"
151 mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ "U)"
152 mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"
153 mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"
154 mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"
155 mkConst _ = "MKINT(42424242)"
156bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
157bcc i (MKCON l loc tag []) | tag < 256
158 = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"
159bcc i (MKCON l loc tag args)
160 = indent i ++ alloc loc tag ++
161 indent i ++ setArgs 0 args ++ "\n" ++
162 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"
164-- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++
165-- show (length args) ++ concatMap showArg args ++ ");\n"
166 where showArg r = ", " ++ creg r
167 setArgs i [] = ""
168 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++
169 "); " ++ setArgs (i + 1) xs
170 alloc Nothing tag
171 = "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ ", " ++
172 show (length args) ++ ", 0);\n"
173 alloc (Just old) tag
174 = "updateCon(" ++ creg Tmp ++ ", " ++ creg old ++ ", " ++ show tag ++ ", " ++
175 show (length args) ++ ");\n"
177bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++
178 ", " ++ show a ++ ");\n"
179bcc i (PROJECTINTO r t idx)
180 = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"
181bcc i (CASE True r code def)
182 | length code < 4 = showCase i def code
183 where
184 showCode :: Int -> [BC] -> String
185 showCode i bc = "{\n" ++ concatMap (bcc (i + 1)) bc ++
186 indent i ++ "}\n"
188 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String
189 showCase i Nothing [(t, c)] = showCode i c
190 showCase i (Just def) [] = showCode i def
191 showCase i def ((t, c) : cs)
192 = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c
193 ++ indent i ++ "else " ++ showCase i def cs
195bcc i (CASE safe r code def)
196 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++
197 concatMap (showCase i) code ++
198 showDef i def ++
199 indent i ++ "}\n"
200 where
201 ctag True = "CTAG"
202 ctag False = "TAG"
204 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
205 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"
206 showDef i Nothing = ""
207 showDef i (Just c) = indent i ++ "default:\n"
208 ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"
209bcc i (CONSTCASE r code def)
210 | intConsts code
211-- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++
212-- concatMap (showCase i) code ++
213-- showDef i def ++
214-- indent i ++ "}\n"
215 = concatMap (iCase (creg r)) code ++
216 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
217 | strConsts code
218 = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++
219 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
220 | bigintConsts code
221 = concatMap (biCase (creg r)) code ++
222 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
223 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code
224 where
225 intConsts ((I _, _ ) : _) = True
226 intConsts ((Ch _, _ ) : _) = True
227 intConsts _ = False
229 bigintConsts ((BI _, _ ) : _) = True
230 bigintConsts _ = False
232 strConsts ((Str _, _ ) : _) = True
233 strConsts _ = False
235 strCase sv (s, bc) =
236 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++
237 concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
238 biCase bv (BI b, bc) =
239 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"
240 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
241 iCase v (I b, bc) =
242 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"
243 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
244 iCase v (Ch b, bc) =
245 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n"
246 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
248 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
249 ++ concatMap (bcc (i+1)) bc ++
250 indent (i + 1) ++ "break;\n"
251 showDef i Nothing = ""
252 showDef i (Just c) = indent i ++ "default:\n"
253 ++ concatMap (bcc (i+1)) c ++
254 indent (i + 1) ++ "break;\n"
255 showDefS i Nothing = ""
256 showDefS i (Just c) = concatMap (bcc (i+1)) c
258bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"
259bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"
260bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"
261bcc i REBASE = indent i ++ "REBASE;\n"
262bcc i (RESERVE 0) = ""
263bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"
264bcc i (ADDTOP 0) = ""
265bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"
266bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
267bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
268bcc i STOREOLD = indent i ++ "STOREOLD;\n"
269bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"
270bcc i (FOREIGNCALL l LANG_C rty fn args)
271 = indent i ++
272 c_irts rty (creg l ++ " = ")
273 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
274 where fcall (t, arg) = irts_c t (creg arg)
275bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed
276bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0); exit(-1);"
277-- bcc i _ = indent i ++ "// not done yet\n"
281c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
282c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x
283c_irts (FArith (ATInt (ITFixed ity))) l x
284 = l ++ "idris_b" ++ show (nativeTyWidth ity) ++ "const(vm, " ++ x ++ ")"
285c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"
286c_irts FUnit l x = x
287c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"
288c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"
289c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"
290c_irts FAny l x = l ++ x
292irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"
293irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x
294irts_c (FArith (ATInt (ITFixed ity))) x
295 = "(" ++ x ++ "->info.bits" ++ show (nativeTyWidth ity) ++ ")"
296irts_c FString x = "GETSTR(" ++ x ++ ")"
297irts_c FUnit x = x
298irts_c FPtr x = "GETPTR(" ++ x ++ ")"
299irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"
300irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"
301irts_c FAny x = x
303bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"
305bitCoerce v op input output arg
306 = v ++ "idris_b" ++ show (nativeTyWidth input) ++ op ++ show (nativeTyWidth output) ++ "(vm, " ++ creg arg ++ ")"
308signedTy :: NativeTy -> String
309signedTy t = "int" ++ show (nativeTyWidth t) ++ "_t"
311doOp v (LPlus (ATInt ITNative)) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"
312doOp v (LMinus (ATInt ITNative)) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
313doOp v (LTimes (ATInt ITNative)) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"
314doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
315doOp v (LSDiv (ATInt ITNative)) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
316doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
317doOp v (LSRem (ATInt ITNative)) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
318doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"
319doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"
320doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"
321doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"
322doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
323doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
324doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"
325doOp v (LEq (ATInt ITNative)) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
326doOp v (LSLt (ATInt ITNative)) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
327doOp v (LSLe (ATInt ITNative)) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
328doOp v (LSGt (ATInt ITNative)) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
329doOp v (LSGe (ATInt ITNative)) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
330doOp v (LLt ITNative) [l, r] = v ++ "UINTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
331doOp v (LLe ITNative) [l, r] = v ++ "UINTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
332doOp v (LGt ITNative) [l, r] = v ++ "UINTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
333doOp v (LGe ITNative) [l, r] = v ++ "UINTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
335doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r]
336doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r]
337doOp v (LTimes (ATInt ITChar)) [l, r] = doOp v (LTimes (ATInt ITNative)) [l, r]
338doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r]
339doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r]
340doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r]
341doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r]
342doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r]
343doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r]
344doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r]
345doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r]
346doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r]
347doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r]
348doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x]
349doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r]
350doOp v (LSLt (ATInt ITChar)) [l, r] = doOp v (LSLt (ATInt ITNative)) [l, r]
351doOp v (LSLe (ATInt ITChar)) [l, r] = doOp v (LSLe (ATInt ITNative)) [l, r]
352doOp v (LSGt (ATInt ITChar)) [l, r] = doOp v (LSGt (ATInt ITNative)) [l, r]
353doOp v (LSGe (ATInt ITChar)) [l, r] = doOp v (LSGe (ATInt ITNative)) [l, r]
354doOp v (LLt ITChar) [l, r] = doOp v (LLt ITNative) [l, r]
355doOp v (LLe ITChar) [l, r] = doOp v (LLe ITNative) [l, r]
356doOp v (LGt ITChar) [l, r] = doOp v (LGt ITNative) [l, r]
357doOp v (LGe ITChar) [l, r] = doOp v (LGe ITNative) [l, r]
359doOp v (LPlus ATFloat) [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"
360doOp v (LMinus ATFloat) [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
361doOp v (LTimes ATFloat) [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"
362doOp v (LSDiv ATFloat) [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
363doOp v (LEq ATFloat) [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
364doOp v (LSLt ATFloat) [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
365doOp v (LSLe ATFloat) [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
366doOp v (LSGt ATFloat) [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
367doOp v (LSGe ATFloat) [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
369doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"
370doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"
371doOp v (LPlus (ATInt ITBig)) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
372doOp v (LMinus (ATInt ITBig)) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
373doOp v (LTimes (ATInt ITBig)) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
374doOp v (LSDiv (ATInt ITBig)) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
375doOp v (LSRem (ATInt ITBig)) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
376doOp v (LEq (ATInt ITBig)) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
377doOp v (LSLt (ATInt ITBig)) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
378doOp v (LSLe (ATInt ITBig)) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
379doOp v (LSGt (ATInt ITBig)) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
380doOp v (LSGe (ATInt ITBig)) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
382doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
383doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
384doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
385doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"
387doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"
388doOp v (LFloatInt ITNative) [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"
389doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"
390doOp v (LTrunc ITBig ITNative) [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"
391doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"
392doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"
393doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"
394doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"
395doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"
396doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"
398doOp v LReadStr [x] = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"
399doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"
400doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)"
402doOp v (LSLt (ATInt (ITFixed ty))) [x, y] = bitOp v "SLt" ty [x, y]
403doOp v (LSLe (ATInt (ITFixed ty))) [x, y] = bitOp v "SLte" ty [x, y]
404doOp v (LEq (ATInt (ITFixed ty))) [x, y] = bitOp v "Eq" ty [x, y]
405doOp v (LSGe (ATInt (ITFixed ty))) [x, y] = bitOp v "SGte" ty [x, y]
406doOp v (LSGt (ATInt (ITFixed ty))) [x, y] = bitOp v "SGt" ty [x, y]
407doOp v (LLt (ITFixed ty)) [x, y] = bitOp v "Lt" ty [x, y]
408doOp v (LLe (ITFixed ty)) [x, y] = bitOp v "Lte" ty [x, y]
409doOp v (LGe (ITFixed ty)) [x, y] = bitOp v "Gte" ty [x, y]
410doOp v (LGt (ITFixed ty)) [x, y] = bitOp v "Gt" ty [x, y]
412doOp v (LSHL (ITFixed ty)) [x, y] = bitOp v "Shl" ty [x, y]
413doOp v (LLSHR (ITFixed ty)) [x, y] = bitOp v "LShr" ty [x, y]
414doOp v (LASHR (ITFixed ty)) [x, y] = bitOp v "AShr" ty [x, y]
415doOp v (LAnd (ITFixed ty)) [x, y] = bitOp v "And" ty [x, y]
416doOp v (LOr (ITFixed ty)) [x, y] = bitOp v "Or" ty [x, y]
417doOp v (LXOr (ITFixed ty)) [x, y] = bitOp v "Xor" ty [x, y]
418doOp v (LCompl (ITFixed ty)) [x] = bitOp v "Compl" ty [x]
420doOp v (LPlus (ATInt (ITFixed ty))) [x, y] = bitOp v "Plus" ty [x, y]
421doOp v (LMinus (ATInt (ITFixed ty))) [x, y] = bitOp v "Minus" ty [x, y]
422doOp v (LTimes (ATInt (ITFixed ty))) [x, y] = bitOp v "Times" ty [x, y]
423doOp v (LUDiv (ITFixed ty)) [x, y] = bitOp v "UDiv" ty [x, y]
424doOp v (LSDiv (ATInt (ITFixed ty))) [x, y] = bitOp v "SDiv" ty [x, y]
425doOp v (LURem (ITFixed ty)) [x, y] = bitOp v "URem" ty [x, y]
426doOp v (LSRem (ATInt (ITFixed ty))) [x, y] = bitOp v "SRem" ty [x, y]
428doOp v (LSExt (ITFixed from) ITBig) [x]
429 = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
430doOp v (LSExt ITNative (ITFixed to)) [x]
431 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
432doOp v (LSExt ITChar (ITFixed to)) [x]
433 = doOp v (LSExt ITNative (ITFixed to)) [x]
434doOp v (LSExt (ITFixed from) ITNative) [x]
435 = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ "))"
436doOp v (LSExt (ITFixed from) ITChar) [x]
437 = doOp v (LSExt (ITFixed from) ITNative) [x]
438doOp v (LSExt (ITFixed from) (ITFixed to)) [x]
439 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "S" from to x
440doOp v (LZExt ITNative (ITFixed to)) [x]
441 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
442doOp v (LZExt ITChar (ITFixed to)) [x]
443 = doOp v (LZExt ITNative (ITFixed to)) [x]
444doOp v (LZExt (ITFixed from) ITNative) [x]
445 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
446doOp v (LZExt (ITFixed from) ITChar) [x]
447 = doOp v (LZExt (ITFixed from) ITNative) [x]
448doOp v (LZExt (ITFixed from) ITBig) [x]
449 = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
450doOp v (LZExt ITNative ITBig) [x]
451 = v ++ "MKBIGUI(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
452doOp v (LZExt (ITFixed from) (ITFixed to)) [x]
453 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "Z" from to x
454doOp v (LTrunc ITNative (ITFixed to)) [x]
455 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
456doOp v (LTrunc ITChar (ITFixed to)) [x]
457 = doOp v (LTrunc ITNative (ITFixed to)) [x]
458doOp v (LTrunc (ITFixed from) ITNative) [x]
459 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
460doOp v (LTrunc (ITFixed from) ITChar) [x]
461 = doOp v (LTrunc (ITFixed from) ITNative) [x]
462doOp v (LTrunc ITBig (ITFixed to)) [x]
463 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"
464doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]
465 | nativeTyWidth from > nativeTyWidth to = bitCoerce v "T" from to x
467doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)
468doOp v LFLog [x] = v ++ flUnOp "log" (creg x)
469doOp v LFSin [x] = v ++ flUnOp "sin" (creg x)
470doOp v LFCos [x] = v ++ flUnOp "cos" (creg x)
471doOp v LFTan [x] = v ++ flUnOp "tan" (creg x)
472doOp v LFASin [x] = v ++ flUnOp "asin" (creg x)
473doOp v LFACos [x] = v ++ flUnOp "acos" (creg x)
474doOp v LFATan [x] = v ++ flUnOp "atan" (creg x)
475doOp v LFSqrt [x] = v ++ flUnOp "sqrt" (creg x)
476doOp v LFFloor [x] = v ++ flUnOp "floor" (creg x)
477doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x)
478doOp v LFNegate [x] = v ++ "MKFLOAT(vm, -GETFLOAT(" ++ (creg x) ++ "))"
480doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"
481doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"
482doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")"
483doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")"
484doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")"
486doOp v LAllocate [x] = v ++ "idris_allocate(vm, " ++ creg x ++ ")"
487doOp v LAppendBuffer [a, b, c, d, e, f] = v ++ "idris_appendBuffer(vm, " ++ creg a ++ "," ++ creg b ++ "," ++ creg c ++ "," ++ creg d ++ "," ++ creg e ++ "," ++ creg f ++ ")"
488doOp v (LAppend ity en) [a, b, c, d] = v ++ "idris_append" ++ intTyName ity ++ show en ++ "(vm, " ++ creg a ++ "," ++ creg b ++ "," ++ creg c ++ "," ++ creg d ++ ")"
489doOp v (LPeek ity en) [x, y] = v ++ "idris_peek" ++ intTyName ity ++ show en ++ "(vm, " ++ creg x ++ "," ++ creg y ++ ")"
491doOp v LStdIn [] = v ++ "MKPTR(vm, stdin)"
492doOp v LStdOut [] = v ++ "MKPTR(vm, stdout)"
493doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)"
495doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 0 "EVAL") ++ ", " ++ creg x ++ "))"
496doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
497doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"
498doOp v LNullPtr [] = v ++ "MKPTR(vm, NULL)"
499doOp v LRegisterPtr [p, i] = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++
500 "), GETINT(" ++ creg i ++ "))"
501doOp v (LChInt ITNative) args = v ++ creg (last args)
502doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args
503doOp v (LIntCh ITNative) args = v ++ creg (last args)
504doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args
506doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"
507doOp v LNoOp args = v ++ creg (last args)
508doOp _ op _ = "FAIL /* " ++ show op ++ " */"
510flUnOp :: String -> String -> String
511flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"