1module IRTS.CodegenC (codegenC) where
7import IRTS.Defunctionalise
9import IRTS.CodegenCommon
15import Data.List (intercalate)
16import qualified Data.Vector.Unboxed as V
20import System.Directory
21import System.FilePath ((</>), (<.>))
26codegenC :: CodeGenerator
27codegenC ci = codegenC' (simpleDecls ci)
32 (map mkLib (compileLibs ci) ++
33 map incdir (importDirs ci))
37 where mkLib l = "-l" ++ l
40codegenC' :: [(Name, SDecl)] ->
41 String -> -- output file name
42 OutputType -> -- generate executable if True, only .o if False
43 [FilePath] -> -- include files
44 [String] -> -- extra object files
45 [String] -> -- extra compiler flags (libraries)
46 [String] -> -- extra compiler flags (anything)
49codegenC' defs out exec incs objs libs flags dbg
51 let bc = map toBC defs
52 let h = concatMap toDecl (map fst bc)
53 let cc = concatMap (uncurry toC) bc
55 mprog <- readFile (d </> "rts" </> "idris_main" <.> "c")
56 let cout = headers incs ++ debug dbg ++ h ++ cc ++
57 (if (exec == Executable) then mprog else "")
59 MavenProject -> putStrLn ("FAILURE: output type not supported")
60 Raw -> writeFile out cout
62 (tmpn, tmph) <- tempfile
67 libFlags <- getLibFlags
68 incFlags <- getIncFlags
69 let args = [gccDbg dbg] ++
71 -- # Any flags defined here which alter the RTS API must also be added to config.mk
72 ["-DHAS_PTHREAD", "-DIDRIS_ENABLE_STATS", "-msse2",
73 "-I."] ++ objs ++ ["-x", "c"] ++
74 (if (exec == Executable) then [] else ["-c"]) ++
76 concatMap words libFlags ++
77 concatMap words incFlags ++
78 concatMap words libs ++
79 concatMap words flags ++
82 exit <- rawSystem comp args
83 when (exit /= ExitSuccess) $
84 putStrLn ("FAILURE: " ++ show comp ++ " " ++ show args)
88 (\h -> "#include <" ++ h ++ ">\n")
89 (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h"])
91debug TRACE = "#define IDRIS_TRACE\n\n"
94-- We're using signed integers now. Make sure we get consistent semantics
95-- out of them from gcc. See e.g. http://thiemonagel.de/2010/01/signed-integer-overflow/
96gccFlags = ["-fwrapv", "-fno-strict-overflow"]
102cname :: Name -> String
103cname n = "_idris_" ++ concatMap cchar (showCG n)
104 where cchar x | isAlpha x || isDigit x = [x]
105 | otherwise = "_" ++ show (fromEnum x) ++ "_"
107indent :: Int -> String
108indent n = replicate (n*4) ' '
111creg (L i) = "LOC(" ++ show i ++ ")"
112creg (T i) = "TOP(" ++ show i ++ ")"
115toDecl :: Name -> String
116toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"
118toC :: Name -> [BC] -> String
120 = -- "/* " ++ show code ++ "*/\n\n" ++
121 "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++
122 indent 1 ++ "INITFRAME;\n" ++
123 concatMap (bcc 1) code ++ "}\n\n"
125showCStr :: String -> String
126showCStr s = '"' : foldr ((++) . showChar) "\"" s
128 showChar :: Char -> String
129 showChar '"' = "\\\""
130 showChar '\\' = "\\\\"
132 -- Note: we need the double quotes around the codes because otherwise
133 -- "\n3" would get encoded as "\x0a3", which is incorrect.
134 -- Instead, we opt for "\x0a""3" and let the C compiler deal with it.
135 | ord c < 0x10 = "\"\"\\x0" ++ showHex (ord c) "\"\""
136 | ord c < 0x20 = "\"\"\\x" ++ showHex (ord c) "\"\""
137 | ord c < 0x7f = [c] -- 0x7f = \DEL
138 | ord c < 0x100 = "\"\"\\x" ++ showHex (ord c) "\"\""
139 | otherwise = error $ "non-8-bit character in string literal: " ++ show c
141bcc :: Int -> BC -> String
142bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
143bcc i (ASSIGNCONST l c)
144 = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"
146 mkConst (I i) = "MKINT(" ++ show i ++ ")"
147 mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")"
148 | otherwise = "MKBIGC(vm,\"" ++ show i ++ "\")"
149 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"
150 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"
151 mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"
152 mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ "U)"
153 mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"
154 mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"
155 mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"
156 mkConst (B8V x) = let x' = V.toList x in "MKB8x16const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "U") x') ++ ")"
157 mkConst (B16V x) = let x' = V.toList x in "MKB16x8const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "U") x') ++ ")"
158 mkConst (B32V x) = let x' = V.toList x in "MKB32x4const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "UL") x') ++ ")"
159 mkConst (B64V x) = let x' = V.toList x in "MKB64x2const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "ULL") x') ++ ")"
160 -- if it's a type constant, we won't use it, but equally it shouldn't
161 -- report an error. These might creep into generated for various reasons
162 -- (especially if erasure is disabled).
163 mkConst c | isTypeConst c = "MKINT(42424242)"
164 mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"
166bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
167bcc i (MKCON l loc tag []) | tag < 256
168 = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"
169bcc i (MKCON l loc tag args)
170 = indent i ++ alloc loc tag ++
171 indent i ++ setArgs 0 args ++ "\n" ++
172 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"
174-- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++
175-- show (length args) ++ concatMap showArg args ++ ");\n"
176 where showArg r = ", " ++ creg r
178 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++
179 "); " ++ setArgs (i + 1) xs
181 = "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ ", " ++
182 show (length args) ++ ", 0);\n"
184 = "updateCon(" ++ creg Tmp ++ ", " ++ creg old ++ ", " ++ show tag ++ ", " ++
185 show (length args) ++ ");\n"
187bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++
188 ", " ++ show a ++ ");\n"
189bcc i (PROJECTINTO r t idx)
190 = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"
191bcc i (CASE True r code def)
192 | length code < 4 = showCase i def code
194 showCode :: Int -> [BC] -> String
195 showCode i bc = "{\n" ++ concatMap (bcc (i + 1)) bc ++
198 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String
199 showCase i Nothing [(t, c)] = showCode i c
200 showCase i (Just def) [] = showCode i def
201 showCase i def ((t, c) : cs)
202 = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c
203 ++ indent i ++ "else " ++ showCase i def cs
205bcc i (CASE safe r code def)
206 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++
207 concatMap (showCase i) code ++
214 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
215 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"
216 showDef i Nothing = ""
217 showDef i (Just c) = indent i ++ "default:\n"
218 ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"
219bcc i (CONSTCASE r code def)
221-- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++
222-- concatMap (showCase i) code ++
225 = concatMap (iCase (creg r)) code ++
226 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
228 = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++
229 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
231 = concatMap (biCase (creg r)) code ++
232 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
233 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code
235 intConsts ((I _, _ ) : _) = True
236 intConsts ((Ch _, _ ) : _) = True
239 bigintConsts ((BI _, _ ) : _) = True
240 bigintConsts _ = False
242 strConsts ((Str _, _ ) : _) = True
246 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++
247 concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
248 biCase bv (BI b, bc) =
249 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"
250 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
252 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"
253 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
255 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n"
256 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
258 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
259 ++ concatMap (bcc (i+1)) bc ++
260 indent (i + 1) ++ "break;\n"
261 showDef i Nothing = ""
262 showDef i (Just c) = indent i ++ "default:\n"
263 ++ concatMap (bcc (i+1)) c ++
264 indent (i + 1) ++ "break;\n"
265 showDefS i Nothing = ""
266 showDefS i (Just c) = concatMap (bcc (i+1)) c
268bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"
269bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"
270bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"
271bcc i REBASE = indent i ++ "REBASE;\n"
272bcc i (RESERVE 0) = ""
273bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"
275bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"
276bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
277bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
278bcc i STOREOLD = indent i ++ "STOREOLD;\n"
279bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"
280bcc i (FOREIGNCALL l rty (FStr fn) args)
282 c_irts (toFType rty) (creg l ++ " = ")
283 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
284 where fcall (t, arg) = irts_c (toFType t) (creg arg)
285bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed
286bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1); exit(-1);"
287-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"
289-- Deconstruct the Foreign type in the defunctionalised expression and build
290-- a foreign type description for c_irts and irts_c
292 | i == sUN "C_IntChar" = ATInt ITChar
293 | i == sUN "C_IntNative" = ATInt ITNative
294 | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)
295 | i == sUN "C_IntBits16" = ATInt (ITFixed IT16)
296 | i == sUN "C_IntBits32" = ATInt (ITFixed IT32)
297 | i == sUN "C_IntBits64" = ATInt (ITFixed IT64)
298 | i == sUN "C_IntB8x16" = ATInt (ITVec IT8 16)
299 | i == sUN "C_IntB16x8" = ATInt (ITVec IT16 8)
300 | i == sUN "C_IntB32x4" = ATInt (ITVec IT32 4)
301 | i == sUN "C_IntB64x2" = ATInt (ITVec IT64 2)
302toAType t = error (show t ++ " not defined in toAType")
305 | c == sUN "C_Str" = FString
306 | c == sUN "C_Float" = FArith ATFloat
307 | c == sUN "C_Ptr" = FPtr
308 | c == sUN "C_MPtr" = FManagedPtr
309 | c == sUN "C_Unit" = FUnit
310toFType (FApp c [_,ity])
311 | c == sUN "C_IntT" = FArith (toAType ity)
313 | c == sUN "C_Any" = FAny
314toFType t = error (show t ++ " not defined in toFType")
316c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
317c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x
318c_irts (FArith (ATInt (ITFixed ity))) l x
319 = l ++ "idris_b" ++ show (nativeTyWidth ity) ++ "const(vm, " ++ x ++ ")"
320c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"
322c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"
323c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"
324c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"
325c_irts FAny l x = l ++ x
327irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"
328irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x
329irts_c (FArith (ATInt (ITFixed ity))) x
330 = "(" ++ x ++ "->info.bits" ++ show (nativeTyWidth ity) ++ ")"
331irts_c FString x = "GETSTR(" ++ x ++ ")"
333irts_c FPtr x = "GETPTR(" ++ x ++ ")"
334irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"
335irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"
338bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"
340bitCoerce v op input output arg
341 = v ++ "idris_b" ++ show (nativeTyWidth input) ++ op ++ show (nativeTyWidth output) ++ "(vm, " ++ creg arg ++ ")"
343signedTy :: NativeTy -> String
344signedTy t = "int" ++ show (nativeTyWidth t) ++ "_t"
346doOp v (LPlus (ATInt ITNative)) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"
347doOp v (LMinus (ATInt ITNative)) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
348doOp v (LTimes (ATInt ITNative)) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"
349doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
350doOp v (LSDiv (ATInt ITNative)) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
351doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
352doOp v (LSRem (ATInt ITNative)) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
353doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"
354doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"
355doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"
356doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"
357doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
358doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
359doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"
360doOp v (LEq (ATInt ITNative)) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
361doOp v (LSLt (ATInt ITNative)) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
362doOp v (LSLe (ATInt ITNative)) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
363doOp v (LSGt (ATInt ITNative)) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
364doOp v (LSGe (ATInt ITNative)) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
365doOp v (LLt ITNative) [l, r] = v ++ "UINTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
366doOp v (LLe ITNative) [l, r] = v ++ "UINTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
367doOp v (LGt ITNative) [l, r] = v ++ "UINTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
368doOp v (LGe ITNative) [l, r] = v ++ "UINTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
370doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r]
371doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r]
372doOp v (LTimes (ATInt ITChar)) [l, r] = doOp v (LTimes (ATInt ITNative)) [l, r]
373doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r]
374doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r]
375doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r]
376doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r]
377doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r]
378doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r]
379doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r]
380doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r]
381doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r]
382doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r]
383doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x]
384doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r]
385doOp v (LSLt (ATInt ITChar)) [l, r] = doOp v (LSLt (ATInt ITNative)) [l, r]
386doOp v (LSLe (ATInt ITChar)) [l, r] = doOp v (LSLe (ATInt ITNative)) [l, r]
387doOp v (LSGt (ATInt ITChar)) [l, r] = doOp v (LSGt (ATInt ITNative)) [l, r]
388doOp v (LSGe (ATInt ITChar)) [l, r] = doOp v (LSGe (ATInt ITNative)) [l, r]
389doOp v (LLt ITChar) [l, r] = doOp v (LLt ITNative) [l, r]
390doOp v (LLe ITChar) [l, r] = doOp v (LLe ITNative) [l, r]
391doOp v (LGt ITChar) [l, r] = doOp v (LGt ITNative) [l, r]
392doOp v (LGe ITChar) [l, r] = doOp v (LGe ITNative) [l, r]
394doOp v (LPlus ATFloat) [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"
395doOp v (LMinus ATFloat) [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
396doOp v (LTimes ATFloat) [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"
397doOp v (LSDiv ATFloat) [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
398doOp v (LEq ATFloat) [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
399doOp v (LSLt ATFloat) [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
400doOp v (LSLe ATFloat) [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
401doOp v (LSGt ATFloat) [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
402doOp v (LSGe ATFloat) [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
404doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"
405doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"
406doOp v (LPlus (ATInt ITBig)) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
407doOp v (LMinus (ATInt ITBig)) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
408doOp v (LTimes (ATInt ITBig)) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
409doOp v (LSDiv (ATInt ITBig)) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
410doOp v (LSRem (ATInt ITBig)) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
411doOp v (LEq (ATInt ITBig)) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
412doOp v (LSLt (ATInt ITBig)) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
413doOp v (LSLe (ATInt ITBig)) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
414doOp v (LSGt (ATInt ITBig)) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
415doOp v (LSGe (ATInt ITBig)) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
417doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
418doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
419doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
420doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"
422doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"
423doOp v (LFloatInt ITNative) [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"
424doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"
425doOp v (LTrunc ITBig ITNative) [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"
426doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"
427doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"
428doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"
429doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"
430doOp v (LIntStr (ITFixed _)) [x] = v ++ "idris_castBitsStr(vm, " ++ creg x ++ ")"
431doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"
432doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"
434doOp v LReadStr [_] = v ++ "idris_readStr(vm, stdin)"
435doOp v LWriteStr [_,s] = v ++ "MKINT((i_int)(idris_writeStr(stdout"
439doOp v LReadFile [_,x] = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"
440doOp v LWriteFile [_,x,s] = v ++ "MKINT((i_int)(idris_writeStr(GETPTR(" ++ creg x
444doOp v (LSLt (ATInt (ITFixed ty))) [x, y] = bitOp v "SLt" ty [x, y]
445doOp v (LSLe (ATInt (ITFixed ty))) [x, y] = bitOp v "SLte" ty [x, y]
446doOp v (LEq (ATInt (ITFixed ty))) [x, y] = bitOp v "Eq" ty [x, y]
447doOp v (LSGe (ATInt (ITFixed ty))) [x, y] = bitOp v "SGte" ty [x, y]
448doOp v (LSGt (ATInt (ITFixed ty))) [x, y] = bitOp v "SGt" ty [x, y]
449doOp v (LLt (ITFixed ty)) [x, y] = bitOp v "Lt" ty [x, y]
450doOp v (LLe (ITFixed ty)) [x, y] = bitOp v "Lte" ty [x, y]
451doOp v (LGe (ITFixed ty)) [x, y] = bitOp v "Gte" ty [x, y]
452doOp v (LGt (ITFixed ty)) [x, y] = bitOp v "Gt" ty [x, y]
454doOp v (LSHL (ITFixed ty)) [x, y] = bitOp v "Shl" ty [x, y]
455doOp v (LLSHR (ITFixed ty)) [x, y] = bitOp v "LShr" ty [x, y]
456doOp v (LASHR (ITFixed ty)) [x, y] = bitOp v "AShr" ty [x, y]
457doOp v (LAnd (ITFixed ty)) [x, y] = bitOp v "And" ty [x, y]
458doOp v (LOr (ITFixed ty)) [x, y] = bitOp v "Or" ty [x, y]
459doOp v (LXOr (ITFixed ty)) [x, y] = bitOp v "Xor" ty [x, y]
460doOp v (LCompl (ITFixed ty)) [x] = bitOp v "Compl" ty [x]
462doOp v (LPlus (ATInt (ITFixed ty))) [x, y] = bitOp v "Plus" ty [x, y]
463doOp v (LMinus (ATInt (ITFixed ty))) [x, y] = bitOp v "Minus" ty [x, y]
464doOp v (LTimes (ATInt (ITFixed ty))) [x, y] = bitOp v "Times" ty [x, y]
465doOp v (LUDiv (ITFixed ty)) [x, y] = bitOp v "UDiv" ty [x, y]
466doOp v (LSDiv (ATInt (ITFixed ty))) [x, y] = bitOp v "SDiv" ty [x, y]
467doOp v (LURem (ITFixed ty)) [x, y] = bitOp v "URem" ty [x, y]
468doOp v (LSRem (ATInt (ITFixed ty))) [x, y] = bitOp v "SRem" ty [x, y]
470doOp v (LSExt (ITFixed from) ITBig) [x]
471 = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
472doOp v (LSExt ITNative (ITFixed to)) [x]
473 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
474doOp v (LSExt ITChar (ITFixed to)) [x]
475 = doOp v (LSExt ITNative (ITFixed to)) [x]
476doOp v (LSExt (ITFixed from) ITNative) [x]
477 = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ "))"
478doOp v (LSExt (ITFixed from) ITChar) [x]
479 = doOp v (LSExt (ITFixed from) ITNative) [x]
480doOp v (LSExt (ITFixed from) (ITFixed to)) [x]
481 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "S" from to x
482doOp v (LZExt ITNative (ITFixed to)) [x]
483 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
484doOp v (LZExt ITChar (ITFixed to)) [x]
485 = doOp v (LZExt ITNative (ITFixed to)) [x]
486doOp v (LZExt (ITFixed from) ITNative) [x]
487 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
488doOp v (LZExt (ITFixed from) ITChar) [x]
489 = doOp v (LZExt (ITFixed from) ITNative) [x]
490doOp v (LZExt (ITFixed from) ITBig) [x]
491 = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
492doOp v (LZExt ITNative ITBig) [x]
493 = v ++ "MKBIGUI(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
494doOp v (LZExt (ITFixed from) (ITFixed to)) [x]
495 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "Z" from to x
496doOp v (LTrunc ITNative (ITFixed to)) [x]
497 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
498doOp v (LTrunc ITChar (ITFixed to)) [x]
499 = doOp v (LTrunc ITNative (ITFixed to)) [x]
500doOp v (LTrunc (ITFixed from) ITNative) [x]
501 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
502doOp v (LTrunc (ITFixed from) ITChar) [x]
503 = doOp v (LTrunc (ITFixed from) ITNative) [x]
504doOp v (LTrunc ITBig (ITFixed to)) [x]
505 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"
506doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]
507 | nativeTyWidth from > nativeTyWidth to = bitCoerce v "T" from to x
509doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)
510doOp v LFLog [x] = v ++ flUnOp "log" (creg x)
511doOp v LFSin [x] = v ++ flUnOp "sin" (creg x)
512doOp v LFCos [x] = v ++ flUnOp "cos" (creg x)
513doOp v LFTan [x] = v ++ flUnOp "tan" (creg x)
514doOp v LFASin [x] = v ++ flUnOp "asin" (creg x)
515doOp v LFACos [x] = v ++ flUnOp "acos" (creg x)
516doOp v LFATan [x] = v ++ flUnOp "atan" (creg x)
517doOp v LFSqrt [x] = v ++ flUnOp "sqrt" (creg x)
518doOp v LFFloor [x] = v ++ flUnOp "floor" (creg x)
519doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x)
520doOp v LFNegate [x] = v ++ "MKFLOAT(vm, -GETFLOAT(" ++ (creg x) ++ "))"
522doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"
523doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"
524doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")"
525doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")"
526doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")"
528doOp v LAllocate [x] = v ++ "idris_buffer_allocate(vm, " ++ creg x ++ ")"
529doOp v LAppendBuffer [a, b, c, d, e, f] = v ++ "idris_appendBuffer(vm, " ++ creg a ++ "," ++ creg b ++ "," ++ creg c ++ "," ++ creg d ++ "," ++ creg e ++ "," ++ creg f ++ ")"
530doOp v (LAppend ity en) [a, b, c, d] = v ++ "idris_append" ++ intTyName ity ++ show en ++ "(vm, " ++ creg a ++ "," ++ creg b ++ "," ++ creg c ++ "," ++ creg d ++ ")"
531doOp v (LPeek ity en) [x, y] = v ++ "idris_peek" ++ intTyName ity ++ show en ++ "(vm, " ++ creg x ++ "," ++ creg y ++ ")"
533doOp v LStdIn [] = v ++ "MKPTR(vm, stdin)"
534doOp v LStdOut [] = v ++ "MKPTR(vm, stdout)"
535doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)"
537doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 0 "EVAL") ++ ", " ++ creg x ++ "))"
538doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
539doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"
540doOp v LNullPtr [] = v ++ "MKPTR(vm, NULL)"
541doOp v LRegisterPtr [p, i] = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++
542 "), GETINT(" ++ creg i ++ "))"
543doOp v (LChInt ITNative) args = v ++ creg (last args)
544doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args
545doOp v (LIntCh ITNative) args = v ++ creg (last args)
546doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args
548doOp v c@(LMkVec IT8 _) args = v ++ "MKB8x16(vm, " ++ (intercalate ", " (map creg args)) ++ ")"
549doOp v c@(LMkVec IT16 _) args = v ++ "MKB16x8(vm, " ++ (intercalate ", " (map creg args)) ++ ")"
550doOp v c@(LMkVec IT32 _) args = v ++ "MKB32x4(vm, " ++ (intercalate ", " (map creg args)) ++ ")"
551doOp v c@(LMkVec IT64 _) args = v ++ "MKB64x2(vm, " ++ (intercalate ", " (map creg args)) ++ ")"
553doOp v c@(LIdxVec IT8 _) [p, i] = v ++ "idris_IDXB8x16(vm, " ++ creg p ++ ", " ++ creg i ++ ")"
554doOp v c@(LIdxVec IT16 _) [p, i] = v ++ "idris_IDXB16x8(vm, " ++ creg p ++ ", " ++ creg i ++ ")"
555doOp v c@(LIdxVec IT32 _) [p, i] = v ++ "idris_IDXB32x4(vm, " ++ creg p ++ ", " ++ creg i ++ ")"
556doOp v c@(LIdxVec IT64 _) [p, i] = v ++ "idris_IDXB64x2(vm, " ++ creg p ++ ", " ++ creg i ++ ")"
558doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"
559doOp v LNoOp args = v ++ creg (last args)
560doOp _ op args = error "doOp of (" ++ show op ++ ") not implemented, arguments (" ++ show args ++ ")"
562flUnOp :: String -> String -> String
563flUnOp 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