1module IRTS.CodegenC (codegenC) where
8import IRTS.CodegenCommon
15import Data.List (intercalate)
19import System.Directory
20import System.FilePath ((</>), (<.>))
23codegenC :: [(Name, SDecl)] ->
24 String -> -- output file name
25 OutputType -> -- generate executable if True, only .o if False
26 [FilePath] -> -- include files
27 String -> -- extra object files
28 String -> -- extra compiler flags (libraries)
29 String -> -- extra compiler flags (anything)
32codegenC defs out exec incs objs libs flags dbg
34 let bc = map toBC defs
35 let h = concatMap toDecl (map fst bc)
36 let cc = concatMap (uncurry toC) bc
38 mprog <- readFile (d </> "rts" </> "idris_main" <.> "c")
39 let cout = headers incs ++ debug dbg ++ h ++ cc ++
40 (if (exec == Executable) then mprog else "")
42 MavenProject -> putStrLn ("FAILURE: output type not supported")
43 Raw -> writeFile out cout
45 (tmpn, tmph) <- tempfile
51 libFlags <- getLibFlags
52 incFlags <- getIncFlags
53 let gcc = comp ++ " " ++
56 " -I. " ++ objs ++ " -x c " ++
57 (if (exec == Executable) then "" else " -c ") ++
66 when (exit /= ExitSuccess) $
67 putStrLn ("FAILURE: " ++ gcc)
71 (\h -> "#include <" ++ h ++ ">\n")
72 (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h", "assert.h"])
74debug TRACE = "#define IDRIS_TRACE\n\n"
77-- We're using signed integers now. Make sure we get consistent semantics
78-- out of them from gcc. See e.g. http://thiemonagel.de/2010/01/signed-integer-overflow/
79gccFlags = " -fwrapv -fno-strict-overflow"
85cname :: Name -> String
86cname n = "_idris_" ++ concatMap cchar (showCG n)
87 where cchar x | isAlpha x || isDigit x = [x]
88 | otherwise = "_" ++ show (fromEnum x) ++ "_"
90indent :: Int -> String
91indent n = replicate (n*4) ' '
94creg (L i) = "LOC(" ++ show i ++ ")"
95creg (T i) = "TOP(" ++ show i ++ ")"
98toDecl :: Name -> String
99toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"
101toC :: Name -> [BC] -> String
103 = -- "/* " ++ show code ++ "*/\n\n" ++
104 "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++
105 indent 1 ++ "INITFRAME;\n" ++
106 concatMap (bcc 1) code ++ "}\n\n"
108showCStr :: String -> String
109showCStr s = '"' : foldr ((++) . showChar) "\"" s
111 showChar :: Char -> String
112 showChar '"' = "\\\""
113 showChar '\\' = "\\\\"
115 -- Note: we need the double quotes around the codes because otherwise
116 -- "\n3" would get encoded as "\x0a3", which is incorrect.
117 -- Instead, we opt for "\x0a""3" and let the C compiler deal with it.
118 | ord c < 0x10 = "\"\"\\x0" ++ showHex (ord c) "\"\""
119 | ord c < 0x20 = "\"\"\\x" ++ showHex (ord c) "\"\""
120 | ord c < 0x7f = [c] -- 0x7f = \DEL
121 | ord c < 0x100 = "\"\"\\x" ++ showHex (ord c) "\"\""
122 | otherwise = error $ "non-8-bit character in string literal: " ++ show c
124bcc :: Int -> BC -> String
125bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
126bcc i (ASSIGNCONST l c)
127 = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"
129 mkConst (I i) = "MKINT(" ++ show i ++ ")"
130 mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")"
131 | otherwise = "MKBIGC(vm,\"" ++ show i ++ "\")"
132 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"
133 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"
134 mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"
135 mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ ")"
136 mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ ")"
137 mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ ")"
138 mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ ")"
139 mkConst _ = "MKINT(42424242)"
140bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
141bcc i (MKCON l tag args)
142 = indent i ++ "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ "," ++
143 show (length args) ++ ", 0);\n" ++
144 indent i ++ setArgs 0 args ++ "\n" ++
145 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"
147-- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++
148-- show (length args) ++ concatMap showArg args ++ ");\n"
149 where showArg r = ", " ++ creg r
151 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++
152 "); " ++ setArgs (i + 1) xs
154bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++
155 ", " ++ show a ++ ");\n"
156bcc i (PROJECTINTO r t idx)
157 = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"
158bcc i (CASE True r code def)
159 | length code < 4 = showCase i def code
161 showCode :: Int -> [BC] -> String
162 showCode i bc = "{\n" ++ indent i ++ concatMap (bcc (i + 1)) bc ++
165 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String
166 showCase i Nothing [(t, c)] = showCode i c
167 showCase i (Just def) [] = showCode i def
168 showCase i def ((t, c) : cs)
169 = "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c
170 ++ "else " ++ showCase i def cs
172bcc i (CASE safe r code def)
173 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++
174 concatMap (showCase i) code ++
181 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
182 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"
183 showDef i Nothing = ""
184 showDef i (Just c) = indent i ++ "default:\n"
185 ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"
186bcc i (CONSTCASE r code def)
188-- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++
189-- concatMap (showCase i) code ++
192 = concatMap (iCase (creg r)) code ++
193 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
195 = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++
196 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
198 = concatMap (biCase (creg r)) code ++
199 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
200 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code
202 intConsts ((I _, _ ) : _) = True
203 intConsts ((Ch _, _ ) : _) = True
206 bigintConsts ((BI _, _ ) : _) = True
207 bigintConsts _ = False
209 strConsts ((Str _, _ ) : _) = True
213 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++
214 concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
215 biCase bv (BI b, bc) =
216 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"
217 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
219 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"
220 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
222 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n"
223 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
225 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
226 ++ concatMap (bcc (i+1)) bc ++
227 indent (i + 1) ++ "break;\n"
228 showDef i Nothing = ""
229 showDef i (Just c) = indent i ++ "default:\n"
230 ++ concatMap (bcc (i+1)) c ++
231 indent (i + 1) ++ "break;\n"
232 showDefS i Nothing = ""
233 showDefS i (Just c) = concatMap (bcc (i+1)) c
235bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"
236bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"
237bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"
238bcc i REBASE = indent i ++ "REBASE;\n"
239bcc i (RESERVE 0) = ""
240bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"
242bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"
243bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
244bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
245bcc i STOREOLD = indent i ++ "STOREOLD;\n"
246bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"
247bcc i (FOREIGNCALL l LANG_C rty fn args)
249 c_irts rty (creg l ++ " = ")
250 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
251 where fcall (t, arg) = irts_c t (creg arg)
252bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed
253bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0); exit(-1);"
254-- bcc i _ = indent i ++ "// not done yet\n"
258c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
259c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x
260c_irts (FArith (ATInt (ITFixed ity))) l x
261 = l ++ "idris_b" ++ show (nativeTyWidth ity) ++ "const(vm, " ++ x ++ ")"
262c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"
264c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"
265c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"
266c_irts FAny l x = l ++ x
268irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"
269irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x
270irts_c (FArith (ATInt (ITFixed ity))) x
271 = "(" ++ x ++ "->info.bits" ++ show (nativeTyWidth ity) ++ ")"
272irts_c FString x = "GETSTR(" ++ x ++ ")"
274irts_c FPtr x = "GETPTR(" ++ x ++ ")"
275irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"
278bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"
280bitCoerce v op input output arg
281 = v ++ "idris_b" ++ show (nativeTyWidth input) ++ op ++ show (nativeTyWidth output) ++ "(vm, " ++ creg arg ++ ")"
283signedTy :: NativeTy -> String
284signedTy t = "int" ++ show (nativeTyWidth t) ++ "_t"
286doOp v (LPlus (ATInt ITNative)) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"
287doOp v (LMinus (ATInt ITNative)) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
288doOp v (LTimes (ATInt ITNative)) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"
289doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
290doOp v (LSDiv (ATInt ITNative)) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
291doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
292doOp v (LSRem (ATInt ITNative)) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
293doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"
294doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"
295doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"
296doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"
297doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
298doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
299doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"
300doOp v (LEq (ATInt ITNative)) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
301doOp v (LSLt (ATInt ITNative)) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
302doOp v (LSLe (ATInt ITNative)) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
303doOp v (LSGt (ATInt ITNative)) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
304doOp v (LSGe (ATInt ITNative)) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
305doOp v (LLt ITNative) [l, r] = v ++ "UINTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
306doOp v (LLe ITNative) [l, r] = v ++ "UINTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
307doOp v (LGt ITNative) [l, r] = v ++ "UINTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
308doOp v (LGe ITNative) [l, r] = v ++ "UINTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
310doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r]
311doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r]
312doOp v (LTimes (ATInt ITChar)) [l, r] = doOp v (LTimes (ATInt ITNative)) [l, r]
313doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r]
314doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r]
315doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r]
316doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r]
317doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r]
318doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r]
319doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r]
320doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r]
321doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r]
322doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r]
323doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x]
324doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r]
325doOp v (LSLt (ATInt ITChar)) [l, r] = doOp v (LSLt (ATInt ITNative)) [l, r]
326doOp v (LSLe (ATInt ITChar)) [l, r] = doOp v (LSLe (ATInt ITNative)) [l, r]
327doOp v (LSGt (ATInt ITChar)) [l, r] = doOp v (LSGt (ATInt ITNative)) [l, r]
328doOp v (LSGe (ATInt ITChar)) [l, r] = doOp v (LSGe (ATInt ITNative)) [l, r]
329doOp v (LLt ITChar) [l, r] = doOp v (LLt ITNative) [l, r]
330doOp v (LLe ITChar) [l, r] = doOp v (LLe ITNative) [l, r]
331doOp v (LGt ITChar) [l, r] = doOp v (LGt ITNative) [l, r]
332doOp v (LGe ITChar) [l, r] = doOp v (LGe ITNative) [l, r]
334doOp v (LPlus ATFloat) [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"
335doOp v (LMinus ATFloat) [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
336doOp v (LTimes ATFloat) [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"
337doOp v (LSDiv ATFloat) [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
338doOp v (LEq ATFloat) [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
339doOp v (LSLt ATFloat) [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
340doOp v (LSLe ATFloat) [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
341doOp v (LSGt ATFloat) [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
342doOp v (LSGe ATFloat) [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
344doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"
345doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"
346doOp v (LPlus (ATInt ITBig)) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
347doOp v (LMinus (ATInt ITBig)) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
348doOp v (LTimes (ATInt ITBig)) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
349doOp v (LSDiv (ATInt ITBig)) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
350doOp v (LSRem (ATInt ITBig)) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
351doOp v (LEq (ATInt ITBig)) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
352doOp v (LSLt (ATInt ITBig)) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
353doOp v (LSLe (ATInt ITBig)) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
354doOp v (LSGt (ATInt ITBig)) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
355doOp v (LSGe (ATInt ITBig)) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
357doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
358doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
359doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
360doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"
362doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"
363doOp v (LFloatInt ITNative) [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"
364doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"
365doOp v (LTrunc ITBig ITNative) [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"
366doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"
367doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"
368doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"
369doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"
370doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"
371doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"
373doOp v LReadStr [x] = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"
374doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"
375doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)"
377doOp v (LSLt (ATInt (ITFixed ty))) [x, y] = bitOp v "SLt" ty [x, y]
378doOp v (LSLe (ATInt (ITFixed ty))) [x, y] = bitOp v "SLte" ty [x, y]
379doOp v (LEq (ATInt (ITFixed ty))) [x, y] = bitOp v "Eq" ty [x, y]
380doOp v (LSGe (ATInt (ITFixed ty))) [x, y] = bitOp v "SGte" ty [x, y]
381doOp v (LSGt (ATInt (ITFixed ty))) [x, y] = bitOp v "SGt" ty [x, y]
382doOp v (LLt (ITFixed ty)) [x, y] = bitOp v "Lt" ty [x, y]
383doOp v (LLe (ITFixed ty)) [x, y] = bitOp v "Lte" ty [x, y]
384doOp v (LGe (ITFixed ty)) [x, y] = bitOp v "Gte" ty [x, y]
385doOp v (LGt (ITFixed ty)) [x, y] = bitOp v "Gt" ty [x, y]
387doOp v (LSHL (ITFixed ty)) [x, y] = bitOp v "Shl" ty [x, y]
388doOp v (LLSHR (ITFixed ty)) [x, y] = bitOp v "LShr" ty [x, y]
389doOp v (LASHR (ITFixed ty)) [x, y] = bitOp v "AShr" ty [x, y]
390doOp v (LAnd (ITFixed ty)) [x, y] = bitOp v "And" ty [x, y]
391doOp v (LOr (ITFixed ty)) [x, y] = bitOp v "Or" ty [x, y]
392doOp v (LXOr (ITFixed ty)) [x, y] = bitOp v "Xor" ty [x, y]
393doOp v (LCompl (ITFixed ty)) [x] = bitOp v "Compl" ty [x]
395doOp v (LPlus (ATInt (ITFixed ty))) [x, y] = bitOp v "Plus" ty [x, y]
396doOp v (LMinus (ATInt (ITFixed ty))) [x, y] = bitOp v "Minus" ty [x, y]
397doOp v (LTimes (ATInt (ITFixed ty))) [x, y] = bitOp v "Times" ty [x, y]
398doOp v (LUDiv (ITFixed ty)) [x, y] = bitOp v "UDiv" ty [x, y]
399doOp v (LSDiv (ATInt (ITFixed ty))) [x, y] = bitOp v "SDiv" ty [x, y]
400doOp v (LURem (ITFixed ty)) [x, y] = bitOp v "URem" ty [x, y]
401doOp v (LSRem (ATInt (ITFixed ty))) [x, y] = bitOp v "SRem" ty [x, y]
403doOp v (LSExt (ITFixed from) ITBig) [x]
404 = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
405doOp v (LSExt ITNative (ITFixed to)) [x]
406 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
407doOp v (LSExt ITChar (ITFixed to)) [x]
408 = doOp v (LSExt ITNative (ITFixed to)) [x]
409doOp v (LSExt (ITFixed from) ITNative) [x]
410 = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ "))"
411doOp v (LSExt (ITFixed from) ITChar) [x]
412 = doOp v (LSExt (ITFixed from) ITNative) [x]
413doOp v (LSExt (ITFixed from) (ITFixed to)) [x]
414 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "S" from to x
415doOp v (LZExt ITNative (ITFixed to)) [x]
416 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ ")"
417doOp v (LZExt ITChar (ITFixed to)) [x]
418 = doOp v (LZExt ITNative (ITFixed to)) [x]
419doOp v (LZExt (ITFixed from) ITNative) [x]
420 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
421doOp v (LZExt (ITFixed from) ITChar) [x]
422 = doOp v (LZExt (ITFixed from) ITNative) [x]
423doOp v (LZExt (ITFixed from) ITBig) [x]
424 = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
425doOp v (LZExt ITNative ITBig) [x]
426 = v ++ "MKBIGUI(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
427doOp v (LZExt (ITFixed from) (ITFixed to)) [x]
428 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "Z" from to x
429doOp v (LTrunc ITNative (ITFixed to)) [x]
430 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
431doOp v (LTrunc ITChar (ITFixed to)) [x]
432 = doOp v (LTrunc ITNative (ITFixed to)) [x]
433doOp v (LTrunc (ITFixed from) ITNative) [x]
434 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
435doOp v (LTrunc (ITFixed from) ITChar) [x]
436 = doOp v (LTrunc (ITFixed from) ITNative) [x]
437doOp v (LTrunc ITBig (ITFixed to)) [x]
438 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"
439doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]
440 | nativeTyWidth from > nativeTyWidth to = bitCoerce v "T" from to x
442doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)
443doOp v LFLog [x] = v ++ flUnOp "log" (creg x)
444doOp v LFSin [x] = v ++ flUnOp "sin" (creg x)
445doOp v LFCos [x] = v ++ flUnOp "cos" (creg x)
446doOp v LFTan [x] = v ++ flUnOp "tan" (creg x)
447doOp v LFASin [x] = v ++ flUnOp "asin" (creg x)
448doOp v LFACos [x] = v ++ flUnOp "acos" (creg x)
449doOp v LFATan [x] = v ++ flUnOp "atan" (creg x)
450doOp v LFSqrt [x] = v ++ flUnOp "sqrt" (creg x)
451doOp v LFFloor [x] = v ++ flUnOp "floor" (creg x)
452doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x)
454doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"
455doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"
456doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")"
457doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")"
458doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")"
460doOp v LStdIn [] = v ++ "MKPTR(vm, stdin)"
461doOp v LStdOut [] = v ++ "MKPTR(vm, stdout)"
462doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)"
464doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 0 "EVAL") ++ ", " ++ creg x ++ "))"
465doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
466doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"
467doOp v LNullPtr [] = v ++ "MKPTR(vm, NULL)"
468doOp v (LChInt ITNative) args = v ++ creg (last args)
469doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args
470doOp v (LIntCh ITNative) args = v ++ creg (last args)
471doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args
472doOp v LNoOp args = v ++ creg (last args)
473doOp _ op _ = "FAIL /* " ++ show op ++ " */"
475flUnOp :: String -> String -> String
476flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list