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