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