git.iko.soy/Idris-dev
on 5ffef89 help sign in
Idris-dev/src/IRTS/CodegenC.hs
502 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 tag args)
157 = indent i ++ "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ "," ++
158 show (length args) ++ ", 0);\n" ++
159 indent i ++ setArgs 0 args ++ "\n" ++
160 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"
162-- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++
163-- show (length args) ++ concatMap showArg args ++ ");\n"
164 where showArg r = ", " ++ creg r
165 setArgs i [] = ""
166 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++
167 "); " ++ setArgs (i + 1) xs
169bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++
170 ", " ++ show a ++ ");\n"
171bcc i (PROJECTINTO r t idx)
172 = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"
173bcc i (CASE True r code def)
174 | length code < 4 = showCase i def code
175 where
176 showCode :: Int -> [BC] -> String
177 showCode i bc = "{\n" ++ concatMap (bcc (i + 1)) bc ++
178 indent i ++ "}\n"
180 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String
181 showCase i Nothing [(t, c)] = showCode i c
182 showCase i (Just def) [] = showCode i def
183 showCase i def ((t, c) : cs)
184 = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c
185 ++ indent i ++ "else " ++ showCase i def cs
187bcc i (CASE safe r code def)
188 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++
189 concatMap (showCase i) code ++
190 showDef i def ++
191 indent i ++ "}\n"
192 where
193 ctag True = "CTAG"
194 ctag False = "TAG"
196 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
197 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"
198 showDef i Nothing = ""
199 showDef i (Just c) = indent i ++ "default:\n"
200 ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"
201bcc i (CONSTCASE r code def)
202 | intConsts code
203-- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++
204-- concatMap (showCase i) code ++
205-- showDef i def ++
206-- indent i ++ "}\n"
207 = concatMap (iCase (creg r)) code ++
208 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
209 | strConsts code
210 = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++
211 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
212 | bigintConsts code
213 = concatMap (biCase (creg r)) code ++
214 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
215 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code
216 where
217 intConsts ((I _, _ ) : _) = True
218 intConsts ((Ch _, _ ) : _) = True
219 intConsts _ = False
221 bigintConsts ((BI _, _ ) : _) = True
222 bigintConsts _ = False
224 strConsts ((Str _, _ ) : _) = True
225 strConsts _ = False
227 strCase sv (s, bc) =
228 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++
229 concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
230 biCase bv (BI b, bc) =
231 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"
232 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
233 iCase v (I b, bc) =
234 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"
235 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
236 iCase v (Ch b, bc) =
237 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n"
238 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
240 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
241 ++ concatMap (bcc (i+1)) bc ++
242 indent (i + 1) ++ "break;\n"
243 showDef i Nothing = ""
244 showDef i (Just c) = indent i ++ "default:\n"
245 ++ concatMap (bcc (i+1)) c ++
246 indent (i + 1) ++ "break;\n"
247 showDefS i Nothing = ""
248 showDefS i (Just c) = concatMap (bcc (i+1)) c
250bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"
251bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"
252bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"
253bcc i REBASE = indent i ++ "REBASE;\n"
254bcc i (RESERVE 0) = ""
255bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"
256bcc i (ADDTOP 0) = ""
257bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"
258bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
259bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
260bcc i STOREOLD = indent i ++ "STOREOLD;\n"
261bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"
262bcc i (FOREIGNCALL l LANG_C rty fn args)
263 = indent i ++
264 c_irts rty (creg l ++ " = ")
265 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
266 where fcall (t, arg) = irts_c t (creg arg)
267bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed
268bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0); exit(-1);"
269-- bcc i _ = indent i ++ "// not done yet\n"
273c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
274c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x
275c_irts (FArith (ATInt (ITFixed ity))) l x
276 = l ++ "idris_b" ++ show (nativeTyWidth ity) ++ "const(vm, " ++ x ++ ")"
277c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"
278c_irts FUnit l x = x
279c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"
280c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"
281c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"
282c_irts FAny l x = l ++ x
284irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"
285irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x
286irts_c (FArith (ATInt (ITFixed ity))) x
287 = "(" ++ x ++ "->info.bits" ++ show (nativeTyWidth ity) ++ ")"
288irts_c FString x = "GETSTR(" ++ x ++ ")"
289irts_c FUnit x = x
290irts_c FPtr x = "GETPTR(" ++ x ++ ")"
291irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"
292irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"
293irts_c FAny x = x
295bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"
297bitCoerce v op input output arg
298 = v ++ "idris_b" ++ show (nativeTyWidth input) ++ op ++ show (nativeTyWidth output) ++ "(vm, " ++ creg arg ++ ")"
300signedTy :: NativeTy -> String
301signedTy t = "int" ++ show (nativeTyWidth t) ++ "_t"
303doOp v (LPlus (ATInt ITNative)) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"
304doOp v (LMinus (ATInt ITNative)) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
305doOp v (LTimes (ATInt ITNative)) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"
306doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
307doOp v (LSDiv (ATInt ITNative)) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
308doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
309doOp v (LSRem (ATInt ITNative)) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
310doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"
311doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"
312doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"
313doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"
314doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
315doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
316doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"
317doOp v (LEq (ATInt ITNative)) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
318doOp v (LSLt (ATInt ITNative)) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
319doOp v (LSLe (ATInt ITNative)) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
320doOp v (LSGt (ATInt ITNative)) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
321doOp v (LSGe (ATInt ITNative)) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
322doOp v (LLt ITNative) [l, r] = v ++ "UINTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
323doOp v (LLe ITNative) [l, r] = v ++ "UINTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
324doOp v (LGt ITNative) [l, r] = v ++ "UINTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
325doOp v (LGe ITNative) [l, r] = v ++ "UINTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
327doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r]
328doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r]
329doOp v (LTimes (ATInt ITChar)) [l, r] = doOp v (LTimes (ATInt ITNative)) [l, r]
330doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r]
331doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r]
332doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r]
333doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r]
334doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r]
335doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r]
336doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r]
337doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r]
338doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r]
339doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r]
340doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x]
341doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r]
342doOp v (LSLt (ATInt ITChar)) [l, r] = doOp v (LSLt (ATInt ITNative)) [l, r]
343doOp v (LSLe (ATInt ITChar)) [l, r] = doOp v (LSLe (ATInt ITNative)) [l, r]
344doOp v (LSGt (ATInt ITChar)) [l, r] = doOp v (LSGt (ATInt ITNative)) [l, r]
345doOp v (LSGe (ATInt ITChar)) [l, r] = doOp v (LSGe (ATInt ITNative)) [l, r]
346doOp v (LLt ITChar) [l, r] = doOp v (LLt ITNative) [l, r]
347doOp v (LLe ITChar) [l, r] = doOp v (LLe ITNative) [l, r]
348doOp v (LGt ITChar) [l, r] = doOp v (LGt ITNative) [l, r]
349doOp v (LGe ITChar) [l, r] = doOp v (LGe ITNative) [l, r]
351doOp v (LPlus ATFloat) [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"
352doOp v (LMinus ATFloat) [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
353doOp v (LTimes ATFloat) [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"
354doOp v (LSDiv ATFloat) [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
355doOp v (LEq ATFloat) [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
356doOp v (LSLt ATFloat) [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
357doOp v (LSLe ATFloat) [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
358doOp v (LSGt ATFloat) [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
359doOp v (LSGe ATFloat) [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
361doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"
362doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"
363doOp v (LPlus (ATInt ITBig)) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
364doOp v (LMinus (ATInt ITBig)) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
365doOp v (LTimes (ATInt ITBig)) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
366doOp v (LSDiv (ATInt ITBig)) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
367doOp v (LSRem (ATInt ITBig)) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
368doOp v (LEq (ATInt ITBig)) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
369doOp v (LSLt (ATInt ITBig)) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
370doOp v (LSLe (ATInt ITBig)) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
371doOp v (LSGt (ATInt ITBig)) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
372doOp v (LSGe (ATInt ITBig)) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
374doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
375doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
376doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
377doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"
379doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"
380doOp v (LFloatInt ITNative) [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"
381doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"
382doOp v (LTrunc ITBig ITNative) [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"
383doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"
384doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"
385doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"
386doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"
387doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"
388doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"
390doOp v LReadStr [x] = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"
391doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"
392doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)"
394doOp v (LSLt (ATInt (ITFixed ty))) [x, y] = bitOp v "SLt" ty [x, y]
395doOp v (LSLe (ATInt (ITFixed ty))) [x, y] = bitOp v "SLte" ty [x, y]
396doOp v (LEq (ATInt (ITFixed ty))) [x, y] = bitOp v "Eq" ty [x, y]
397doOp v (LSGe (ATInt (ITFixed ty))) [x, y] = bitOp v "SGte" ty [x, y]
398doOp v (LSGt (ATInt (ITFixed ty))) [x, y] = bitOp v "SGt" ty [x, y]
399doOp v (LLt (ITFixed ty)) [x, y] = bitOp v "Lt" ty [x, y]
400doOp v (LLe (ITFixed ty)) [x, y] = bitOp v "Lte" ty [x, y]
401doOp v (LGe (ITFixed ty)) [x, y] = bitOp v "Gte" ty [x, y]
402doOp v (LGt (ITFixed ty)) [x, y] = bitOp v "Gt" ty [x, y]
404doOp v (LSHL (ITFixed ty)) [x, y] = bitOp v "Shl" ty [x, y]
405doOp v (LLSHR (ITFixed ty)) [x, y] = bitOp v "LShr" ty [x, y]
406doOp v (LASHR (ITFixed ty)) [x, y] = bitOp v "AShr" ty [x, y]
407doOp v (LAnd (ITFixed ty)) [x, y] = bitOp v "And" ty [x, y]
408doOp v (LOr (ITFixed ty)) [x, y] = bitOp v "Or" ty [x, y]
409doOp v (LXOr (ITFixed ty)) [x, y] = bitOp v "Xor" ty [x, y]
410doOp v (LCompl (ITFixed ty)) [x] = bitOp v "Compl" ty [x]
412doOp v (LPlus (ATInt (ITFixed ty))) [x, y] = bitOp v "Plus" ty [x, y]
413doOp v (LMinus (ATInt (ITFixed ty))) [x, y] = bitOp v "Minus" ty [x, y]
414doOp v (LTimes (ATInt (ITFixed ty))) [x, y] = bitOp v "Times" ty [x, y]
415doOp v (LUDiv (ITFixed ty)) [x, y] = bitOp v "UDiv" ty [x, y]
416doOp v (LSDiv (ATInt (ITFixed ty))) [x, y] = bitOp v "SDiv" ty [x, y]
417doOp v (LURem (ITFixed ty)) [x, y] = bitOp v "URem" ty [x, y]
418doOp v (LSRem (ATInt (ITFixed ty))) [x, y] = bitOp v "SRem" ty [x, y]
420doOp v (LSExt (ITFixed from) ITBig) [x]
421 = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
422doOp v (LSExt ITNative (ITFixed to)) [x]
423 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
424doOp v (LSExt ITChar (ITFixed to)) [x]
425 = doOp v (LSExt ITNative (ITFixed to)) [x]
426doOp v (LSExt (ITFixed from) ITNative) [x]
427 = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ "))"
428doOp v (LSExt (ITFixed from) ITChar) [x]
429 = doOp v (LSExt (ITFixed from) ITNative) [x]
430doOp v (LSExt (ITFixed from) (ITFixed to)) [x]
431 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "S" from to x
432doOp v (LZExt ITNative (ITFixed to)) [x]
433 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ ")"
434doOp v (LZExt ITChar (ITFixed to)) [x]
435 = doOp v (LZExt ITNative (ITFixed to)) [x]
436doOp v (LZExt (ITFixed from) ITNative) [x]
437 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
438doOp v (LZExt (ITFixed from) ITChar) [x]
439 = doOp v (LZExt (ITFixed from) ITNative) [x]
440doOp v (LZExt (ITFixed from) ITBig) [x]
441 = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
442doOp v (LZExt ITNative ITBig) [x]
443 = v ++ "MKBIGUI(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
444doOp v (LZExt (ITFixed from) (ITFixed to)) [x]
445 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "Z" from to x
446doOp v (LTrunc ITNative (ITFixed to)) [x]
447 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
448doOp v (LTrunc ITChar (ITFixed to)) [x]
449 = doOp v (LTrunc ITNative (ITFixed to)) [x]
450doOp v (LTrunc (ITFixed from) ITNative) [x]
451 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
452doOp v (LTrunc (ITFixed from) ITChar) [x]
453 = doOp v (LTrunc (ITFixed from) ITNative) [x]
454doOp v (LTrunc ITBig (ITFixed to)) [x]
455 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"
456doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]
457 | nativeTyWidth from > nativeTyWidth to = bitCoerce v "T" from to x
459doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)
460doOp v LFLog [x] = v ++ flUnOp "log" (creg x)
461doOp v LFSin [x] = v ++ flUnOp "sin" (creg x)
462doOp v LFCos [x] = v ++ flUnOp "cos" (creg x)
463doOp v LFTan [x] = v ++ flUnOp "tan" (creg x)
464doOp v LFASin [x] = v ++ flUnOp "asin" (creg x)
465doOp v LFACos [x] = v ++ flUnOp "acos" (creg x)
466doOp v LFATan [x] = v ++ flUnOp "atan" (creg x)
467doOp v LFSqrt [x] = v ++ flUnOp "sqrt" (creg x)
468doOp v LFFloor [x] = v ++ flUnOp "floor" (creg x)
469doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x)
471doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"
472doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"
473doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")"
474doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")"
475doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")"
477doOp v LAllocate [x] = v ++ "idris_allocate(vm, " ++ creg x ++ ")"
478doOp v LAppendBuffer [a, b, c, d, e, f] = v ++ "idris_appendBuffer(vm, " ++ creg a ++ "," ++ creg b ++ "," ++ creg c ++ "," ++ creg d ++ "," ++ creg e ++ "," ++ creg f ++ ")"
479doOp v (LAppend ity en) [a, b, c, d] = v ++ "idris_append" ++ intTyName ity ++ show en ++ "(vm, " ++ creg a ++ "," ++ creg b ++ "," ++ creg c ++ "," ++ creg d ++ ")"
480doOp v (LPeek ity en) [x, y] = v ++ "idris_peek" ++ intTyName ity ++ show en ++ "(vm, " ++ creg x ++ "," ++ creg y ++ ")"
482doOp v LStdIn [] = v ++ "MKPTR(vm, stdin)"
483doOp v LStdOut [] = v ++ "MKPTR(vm, stdout)"
484doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)"
486doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 0 "EVAL") ++ ", " ++ creg x ++ "))"
487doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
488doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"
489doOp v LNullPtr [] = v ++ "MKPTR(vm, NULL)"
490doOp v LRegisterPtr [p, i] = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++
491 "), GETINT(" ++ creg i ++ "))"
492doOp v (LChInt ITNative) args = v ++ creg (last args)
493doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args
494doOp v (LIntCh ITNative) args = v ++ creg (last args)
495doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args
497doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"
498doOp v LNoOp args = v ++ creg (last args)
499doOp _ op _ = "FAIL /* " ++ show op ++ " */"
501flUnOp :: String -> String -> String
502flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"