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