git.iko.soy/Idris-dev
on 50878fa help sign in
Idris-dev/src/IRTS/CodegenC.hs
696 lines 33 kB history raw
1module IRTS.CodegenC (codegenC) where
3import Idris.AbsSyntax
4import IRTS.Bytecode
5import IRTS.Lang
6import IRTS.Simplified
7import IRTS.Defunctionalise
8import IRTS.System
9import IRTS.CodegenCommon
10import Idris.Core.TT
11import Util.System
13import Numeric
14import Data.Char
15import Data.Bits
16import Data.List (intercalate)
17import System.Process
18import System.Exit
19import System.IO
20import System.Directory
21import System.FilePath ((</>), (<.>))
22import Control.Monad
24import Debug.Trace
26codegenC :: CodeGenerator
27codegenC ci = do codegenC' (simpleDecls ci)
28 (outputFile ci)
29 (outputType ci)
30 (includes ci)
31 (compileObjs ci)
32 (map mkLib (compileLibs ci) ++
33 map incdir (importDirs ci))
34 (compilerFlags ci)
35 (exportDecls ci)
36 (interfaces ci)
37 (debugLevel ci)
38 when (interfaces ci) $
39 codegenH (exportDecls ci)
41 where mkLib l = "-l" ++ l
42 incdir i = "-I" ++ i
44codegenC' :: [(Name, SDecl)] ->
45 String -> -- output file name
46 OutputType -> -- generate executable if True, only .o if False
47 [FilePath] -> -- include files
48 [String] -> -- extra object files
49 [String] -> -- extra compiler flags (libraries)
50 [String] -> -- extra compiler flags (anything)
51 [ExportIFace] ->
52 Bool -> -- interfaces too (so make a .o instead)
53 DbgLevel ->
54 IO ()
55codegenC' defs out exec incs objs libs flags exports iface dbg
56 = do -- print defs
57 let bc = map toBC defs
58 let h = concatMap toDecl (map fst bc)
59 let cc = concatMap (uncurry toC) bc
60 let hi = concatMap ifaceC (concatMap getExp exports)
61 d <- getDataDir
62 mprog <- readFile (d </> "rts" </> "idris_main" <.> "c")
63 let cout = headers incs ++ debug dbg ++ h ++ cc ++
64 (if (exec == Executable) then mprog else hi)
65 case exec of
66 MavenProject -> putStrLn ("FAILURE: output type not supported")
67 Raw -> writeSource out cout
68 _ -> do
69 (tmpn, tmph) <- tempfile
70 hPutStr tmph cout
71 hFlush tmph
72 hClose tmph
73 comp <- getCC
74 libFlags <- getLibFlags
75 incFlags <- getIncFlags
76 envFlags <- getEnvFlags
77 let args = [gccDbg dbg] ++
78 gccFlags iface ++
79 -- # Any flags defined here which alter the RTS API must also be added to config.mk
80 ["-DHAS_PTHREAD", "-DIDRIS_ENABLE_STATS",
81 "-I."] ++ objs ++ ["-x", "c"] ++ envFlags ++
82 (if (exec == Executable) then [] else ["-c"]) ++
83 [tmpn] ++
84 (if not iface then concatMap words libFlags else []) ++
85 concatMap words incFlags ++
86 (if not iface then concatMap words libs else []) ++
87 concatMap words flags ++
88 ["-o", out]
89-- putStrLn (show args)
90 exit <- rawSystem comp args
91 when (exit /= ExitSuccess) $
92 putStrLn ("FAILURE: " ++ show comp ++ " " ++ show args)
93 where
94 getExp (Export _ _ exp) = exp
96headers xs =
97 concatMap
98 (\h -> "#include <" ++ h ++ ">\n")
99 (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h"])
101debug TRACE = "#define IDRIS_TRACE\n\n"
102debug _ = ""
104-- We're using signed integers now. Make sure we get consistent semantics
105-- out of them from gcc. See e.g. http://thiemonagel.de/2010/01/signed-integer-overflow/
106gccFlags i = if i then ["-fwrapv"]
107 else ["-fwrapv", "-fno-strict-overflow"]
109gccDbg DEBUG = "-g"
110gccDbg TRACE = "-O2"
111gccDbg _ = "-O2"
113cname :: Name -> String
114cname n = "_idris_" ++ concatMap cchar (showCG n)
115 where cchar x | isAlpha x || isDigit x = [x]
116 | otherwise = "_" ++ show (fromEnum x) ++ "_"
118indent :: Int -> String
119indent n = replicate (n*4) ' '
121creg RVal = "RVAL"
122creg (L i) = "LOC(" ++ show i ++ ")"
123creg (T i) = "TOP(" ++ show i ++ ")"
124creg Tmp = "REG1"
126toDecl :: Name -> String
127toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"
129toC :: Name -> [BC] -> String
130toC f code
131 = -- "/* " ++ show code ++ "*/\n\n" ++
132 "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++
133 indent 1 ++ "INITFRAME;\n" ++
134 concatMap (bcc 1) code ++ "}\n\n"
136showCStr :: String -> String
137showCStr s = '"' : foldr ((++) . showChar) "\"" s
138 where
139 showChar :: Char -> String
140 showChar '"' = "\\\""
141 showChar '\\' = "\\\\"
142 showChar c
143 -- Note: we need the double quotes around the codes because otherwise
144 -- "\n3" would get encoded as "\x0a3", which is incorrect.
145 -- Instead, we opt for "\x0a""3" and let the C compiler deal with it.
146 | ord c < 0x10 = "\"\"\\x0" ++ showHex (ord c) "\"\""
147 | ord c < 0x20 = "\"\"\\x" ++ showHex (ord c) "\"\""
148 | ord c < 0x7f = [c] -- 0x7f = \DEL
149 | otherwise = showHexes (utf8bytes (ord c))
151 utf8bytes :: Int -> [Int]
152 utf8bytes x = let (h : bytes) = split [] x in
153 headHex h (length bytes) : map toHex bytes
154 where
155 split acc 0 = acc
156 split acc x = let xbits = x .&. 0x3f
157 xrest = shiftR x 6 in
158 split (xbits : acc) xrest
160 headHex h 1 = h + 0xc0
161 headHex h 2 = h + 0xe0
162 headHex h 3 = h + 0xf0
163 headHex h n = error "Can't happen: Invalid UTF8 character"
165 toHex i = i + 0x80
167 showHexes = foldr ((++) . showUTF8) ""
168 showUTF8 c = "\"\"\\x" ++ showHex c "\"\""
170bcc :: Int -> BC -> String
171bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
172bcc i (ASSIGNCONST l c)
173 = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"
174 where
175 mkConst (I i) = "MKINT(" ++ show i ++ ")"
176 mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")"
177 | otherwise = "MKBIGC(vm,\"" ++ show i ++ "\")"
178 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"
179 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"
180 mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"
181 mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ "U)"
182 mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"
183 mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"
184 mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"
185 -- if it's a type constant, we won't use it, but equally it shouldn't
186 -- report an error. These might creep into generated for various reasons
187 -- (especially if erasure is disabled).
188 mkConst c | isTypeConst c = "MKINT(42424242)"
189 mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"
191bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
192bcc i (MKCON l loc tag []) | tag < 256
193 = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"
194bcc i (MKCON l loc tag args)
195 = indent i ++ alloc loc tag ++
196 indent i ++ setArgs 0 args ++ "\n" ++
197 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"
199-- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++
200-- show (length args) ++ concatMap showArg args ++ ");\n"
201 where showArg r = ", " ++ creg r
202 setArgs i [] = ""
203 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++
204 "); " ++ setArgs (i + 1) xs
205 alloc Nothing tag
206 = "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ ", " ++
207 show (length args) ++ ", 0);\n"
208 alloc (Just old) tag
209 = "updateCon(" ++ creg Tmp ++ ", " ++ creg old ++ ", " ++ show tag ++ ", " ++
210 show (length args) ++ ");\n"
212bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++
213 ", " ++ show a ++ ");\n"
214bcc i (PROJECTINTO r t idx)
215 = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"
216bcc i (CASE True r code def)
217 | length code < 4 = showCase i def code
218 where
219 showCode :: Int -> [BC] -> String
220 showCode i bc = "{\n" ++ concatMap (bcc (i + 1)) bc ++
221 indent i ++ "}\n"
223 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String
224 showCase i Nothing [(t, c)] = indent i ++ showCode i c
225 showCase i (Just def) [] = indent i ++ showCode i def
226 showCase i def ((t, c) : cs)
227 = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c
228 ++ indent i ++ "else\n" ++ showCase i def cs
230bcc i (CASE safe r code def)
231 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++
232 concatMap (showCase i) code ++
233 showDef i def ++
234 indent i ++ "}\n"
235 where
236 ctag True = "CTAG"
237 ctag False = "TAG"
239 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
240 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"
241 showDef i Nothing = ""
242 showDef i (Just c) = indent i ++ "default:\n"
243 ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"
244bcc i (CONSTCASE r code def)
245 | intConsts code
246-- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++
247-- concatMap (showCase i) code ++
248-- showDef i def ++
249-- indent i ++ "}\n"
250 = concatMap (iCase (creg r)) code ++
251 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
252 | strConsts code
253 = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++
254 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
255 | bigintConsts code
256 = concatMap (biCase (creg r)) code ++
257 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
258 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code
259 where
260 intConsts ((I _, _ ) : _) = True
261 intConsts ((Ch _, _ ) : _) = True
262 intConsts ((B8 _, _ ) : _) = True
263 intConsts ((B16 _, _ ) : _) = True
264 intConsts ((B32 _, _ ) : _) = True
265 intConsts ((B64 _, _ ) : _) = True
266 intConsts _ = False
268 bigintConsts ((BI _, _ ) : _) = True
269 bigintConsts _ = False
271 strConsts ((Str _, _ ) : _) = True
272 strConsts _ = False
274 strCase sv (s, bc) =
275 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++
276 concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
277 biCase bv (BI b, bc) =
278 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"
279 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
280 iCase v (I b, bc) =
281 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"
282 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
283 iCase v (Ch b, bc) =
284 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n"
285 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
286 iCase v (B8 w, bc) =
287 indent i ++ "if (GETBITS8(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
288 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
289 iCase v (B16 w, bc) =
290 indent i ++ "if (GETBITS16(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
291 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
292 iCase v (B32 w, bc) =
293 indent i ++ "if (GETBITS32(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
294 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
295 iCase v (B64 w, bc) =
296 indent i ++ "if (GETBITS64(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
297 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
298 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
299 ++ concatMap (bcc (i+1)) bc ++
300 indent (i + 1) ++ "break;\n"
301 showDef i Nothing = ""
302 showDef i (Just c) = indent i ++ "default:\n"
303 ++ concatMap (bcc (i+1)) c ++
304 indent (i + 1) ++ "break;\n"
305 showDefS i Nothing = ""
306 showDefS i (Just c) = concatMap (bcc (i+1)) c
308bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"
309bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"
310bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"
311bcc i REBASE = indent i ++ "REBASE;\n"
312bcc i (RESERVE 0) = ""
313bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"
314bcc i (ADDTOP 0) = ""
315bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"
316bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
317bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
318bcc i STOREOLD = indent i ++ "STOREOLD;\n"
319bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"
320bcc i (FOREIGNCALL l rty (FStr fn) args)
321 = indent i ++
322 c_irts (toFType rty) (creg l ++ " = ")
323 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
324 where fcall (t, arg) = irts_c (toFType t) (creg arg)
325bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed
326bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"
327-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"
329-- Deconstruct the Foreign type in the defunctionalised expression and build
330-- a foreign type description for c_irts and irts_c
331toAType (FCon i)
332 | i == sUN "C_IntChar" = ATInt ITChar
333 | i == sUN "C_IntNative" = ATInt ITNative
334 | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)
335 | i == sUN "C_IntBits16" = ATInt (ITFixed IT16)
336 | i == sUN "C_IntBits32" = ATInt (ITFixed IT32)
337 | i == sUN "C_IntBits64" = ATInt (ITFixed IT64)
338toAType t = error (show t ++ " not defined in toAType")
340toFType (FCon c)
341 | c == sUN "C_Str" = FString
342 | c == sUN "C_Float" = FArith ATFloat
343 | c == sUN "C_Ptr" = FPtr
344 | c == sUN "C_MPtr" = FManagedPtr
345 | c == sUN "C_Unit" = FUnit
346toFType (FApp c [_,ity])
347 | c == sUN "C_IntT" = FArith (toAType ity)
348toFType (FApp c [_])
349 | c == sUN "C_Any" = FAny
350toFType t = FAny
352c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
353c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x
354c_irts (FArith (ATInt (ITFixed ity))) l x
355 = l ++ "idris_b" ++ show (nativeTyWidth ity) ++ "const(vm, " ++ x ++ ")"
356c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"
357c_irts FUnit l x = x
358c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"
359c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"
360c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"
361c_irts FAny l x = l ++ x
363irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"
364irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x
365irts_c (FArith (ATInt (ITFixed ity))) x
366 = "(" ++ x ++ "->info.bits" ++ show (nativeTyWidth ity) ++ ")"
367irts_c FString x = "GETSTR(" ++ x ++ ")"
368irts_c FUnit x = x
369irts_c FPtr x = "GETPTR(" ++ x ++ ")"
370irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"
371irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"
372irts_c FAny x = x
374bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"
376bitCoerce v op input output arg
377 = v ++ "idris_b" ++ show (nativeTyWidth input) ++ op ++ show (nativeTyWidth output) ++ "(vm, " ++ creg arg ++ ")"
379signedTy :: NativeTy -> String
380signedTy t = "int" ++ show (nativeTyWidth t) ++ "_t"
382doOp v (LPlus (ATInt ITNative)) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"
383doOp v (LMinus (ATInt ITNative)) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
384doOp v (LTimes (ATInt ITNative)) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"
385doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
386doOp v (LSDiv (ATInt ITNative)) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
387doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
388doOp v (LSRem (ATInt ITNative)) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
389doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"
390doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"
391doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"
392doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"
393doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
394doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
395doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"
396doOp v (LEq (ATInt ITNative)) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
397doOp v (LSLt (ATInt ITNative)) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
398doOp v (LSLe (ATInt ITNative)) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
399doOp v (LSGt (ATInt ITNative)) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
400doOp v (LSGe (ATInt ITNative)) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
401doOp v (LLt ITNative) [l, r] = v ++ "UINTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
402doOp v (LLe ITNative) [l, r] = v ++ "UINTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
403doOp v (LGt ITNative) [l, r] = v ++ "UINTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
404doOp v (LGe ITNative) [l, r] = v ++ "UINTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
406doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r]
407doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r]
408doOp v (LTimes (ATInt ITChar)) [l, r] = doOp v (LTimes (ATInt ITNative)) [l, r]
409doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r]
410doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r]
411doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r]
412doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r]
413doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r]
414doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r]
415doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r]
416doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r]
417doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r]
418doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r]
419doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x]
420doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r]
421doOp v (LSLt (ATInt ITChar)) [l, r] = doOp v (LSLt (ATInt ITNative)) [l, r]
422doOp v (LSLe (ATInt ITChar)) [l, r] = doOp v (LSLe (ATInt ITNative)) [l, r]
423doOp v (LSGt (ATInt ITChar)) [l, r] = doOp v (LSGt (ATInt ITNative)) [l, r]
424doOp v (LSGe (ATInt ITChar)) [l, r] = doOp v (LSGe (ATInt ITNative)) [l, r]
425doOp v (LLt ITChar) [l, r] = doOp v (LLt ITNative) [l, r]
426doOp v (LLe ITChar) [l, r] = doOp v (LLe ITNative) [l, r]
427doOp v (LGt ITChar) [l, r] = doOp v (LGt ITNative) [l, r]
428doOp v (LGe ITChar) [l, r] = doOp v (LGe ITNative) [l, r]
430doOp v (LPlus ATFloat) [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"
431doOp v (LMinus ATFloat) [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
432doOp v (LTimes ATFloat) [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"
433doOp v (LSDiv ATFloat) [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
434doOp v (LEq ATFloat) [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
435doOp v (LSLt ATFloat) [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
436doOp v (LSLe ATFloat) [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
437doOp v (LSGt ATFloat) [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
438doOp v (LSGe ATFloat) [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
440doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"
441doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"
442doOp v (LPlus (ATInt ITBig)) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
443doOp v (LMinus (ATInt ITBig)) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
444doOp v (LTimes (ATInt ITBig)) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
445doOp v (LSDiv (ATInt ITBig)) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
446doOp v (LSRem (ATInt ITBig)) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
447doOp v (LEq (ATInt ITBig)) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
448doOp v (LSLt (ATInt ITBig)) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
449doOp v (LSLe (ATInt ITBig)) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
450doOp v (LSGt (ATInt ITBig)) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
451doOp v (LSGe (ATInt ITBig)) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
453doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"
454doOp v (LFloatInt ITNative) [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"
455doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"
456doOp v (LTrunc ITBig ITNative) [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"
457doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"
458doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"
459doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"
460doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"
461doOp v (LIntStr (ITFixed _)) [x] = v ++ "idris_castBitsStr(vm, " ++ creg x ++ ")"
462doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"
463doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"
465doOp v (LSLt (ATInt (ITFixed ty))) [x, y] = bitOp v "SLt" ty [x, y]
466doOp v (LSLe (ATInt (ITFixed ty))) [x, y] = bitOp v "SLte" ty [x, y]
467doOp v (LEq (ATInt (ITFixed ty))) [x, y] = bitOp v "Eq" ty [x, y]
468doOp v (LSGe (ATInt (ITFixed ty))) [x, y] = bitOp v "SGte" ty [x, y]
469doOp v (LSGt (ATInt (ITFixed ty))) [x, y] = bitOp v "SGt" ty [x, y]
470doOp v (LLt (ITFixed ty)) [x, y] = bitOp v "Lt" ty [x, y]
471doOp v (LLe (ITFixed ty)) [x, y] = bitOp v "Lte" ty [x, y]
472doOp v (LGe (ITFixed ty)) [x, y] = bitOp v "Gte" ty [x, y]
473doOp v (LGt (ITFixed ty)) [x, y] = bitOp v "Gt" ty [x, y]
475doOp v (LSHL (ITFixed ty)) [x, y] = bitOp v "Shl" ty [x, y]
476doOp v (LLSHR (ITFixed ty)) [x, y] = bitOp v "LShr" ty [x, y]
477doOp v (LASHR (ITFixed ty)) [x, y] = bitOp v "AShr" ty [x, y]
478doOp v (LAnd (ITFixed ty)) [x, y] = bitOp v "And" ty [x, y]
479doOp v (LOr (ITFixed ty)) [x, y] = bitOp v "Or" ty [x, y]
480doOp v (LXOr (ITFixed ty)) [x, y] = bitOp v "Xor" ty [x, y]
481doOp v (LCompl (ITFixed ty)) [x] = bitOp v "Compl" ty [x]
483doOp v (LPlus (ATInt (ITFixed ty))) [x, y] = bitOp v "Plus" ty [x, y]
484doOp v (LMinus (ATInt (ITFixed ty))) [x, y] = bitOp v "Minus" ty [x, y]
485doOp v (LTimes (ATInt (ITFixed ty))) [x, y] = bitOp v "Times" ty [x, y]
486doOp v (LUDiv (ITFixed ty)) [x, y] = bitOp v "UDiv" ty [x, y]
487doOp v (LSDiv (ATInt (ITFixed ty))) [x, y] = bitOp v "SDiv" ty [x, y]
488doOp v (LURem (ITFixed ty)) [x, y] = bitOp v "URem" ty [x, y]
489doOp v (LSRem (ATInt (ITFixed ty))) [x, y] = bitOp v "SRem" ty [x, y]
491doOp v (LSExt (ITFixed from) ITBig) [x]
492 = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
493doOp v (LSExt ITNative (ITFixed to)) [x]
494 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
495doOp v (LSExt ITChar (ITFixed to)) [x]
496 = doOp v (LSExt ITNative (ITFixed to)) [x]
497doOp v (LSExt (ITFixed from) ITNative) [x]
498 = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ "))"
499doOp v (LSExt (ITFixed from) ITChar) [x]
500 = doOp v (LSExt (ITFixed from) ITNative) [x]
501doOp v (LSExt (ITFixed from) (ITFixed to)) [x]
502 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "S" from to x
503doOp v (LZExt ITNative (ITFixed to)) [x]
504 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
505doOp v (LZExt ITChar (ITFixed to)) [x]
506 = doOp v (LZExt ITNative (ITFixed to)) [x]
507doOp v (LZExt (ITFixed from) ITNative) [x]
508 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
509doOp v (LZExt (ITFixed from) ITChar) [x]
510 = doOp v (LZExt (ITFixed from) ITNative) [x]
511doOp v (LZExt (ITFixed from) ITBig) [x]
512 = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
513doOp v (LZExt ITNative ITBig) [x]
514 = v ++ "MKBIGUI(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
515doOp v (LZExt (ITFixed from) (ITFixed to)) [x]
516 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "Z" from to x
517doOp v (LTrunc ITNative (ITFixed to)) [x]
518 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
519doOp v (LTrunc ITChar (ITFixed to)) [x]
520 = doOp v (LTrunc ITNative (ITFixed to)) [x]
521doOp v (LTrunc (ITFixed from) ITNative) [x]
522 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
523doOp v (LTrunc (ITFixed from) ITChar) [x]
524 = doOp v (LTrunc (ITFixed from) ITNative) [x]
525doOp v (LTrunc ITBig (ITFixed to)) [x]
526 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"
527doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]
528 | nativeTyWidth from > nativeTyWidth to = bitCoerce v "T" from to x
530doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)
531doOp v LFLog [x] = v ++ flUnOp "log" (creg x)
532doOp v LFSin [x] = v ++ flUnOp "sin" (creg x)
533doOp v LFCos [x] = v ++ flUnOp "cos" (creg x)
534doOp v LFTan [x] = v ++ flUnOp "tan" (creg x)
535doOp v LFASin [x] = v ++ flUnOp "asin" (creg x)
536doOp v LFACos [x] = v ++ flUnOp "acos" (creg x)
537doOp v LFATan [x] = v ++ flUnOp "atan" (creg x)
538doOp v LFSqrt [x] = v ++ flUnOp "sqrt" (creg x)
539doOp v LFFloor [x] = v ++ flUnOp "floor" (creg x)
540doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x)
541doOp v LFNegate [x] = v ++ "MKFLOAT(vm, -GETFLOAT(" ++ (creg x) ++ "))"
543-- String functions which don't need to know we're UTF8
544doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
545doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
546doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
548doOp v LReadStr [_] = v ++ "idris_readStr(vm, stdin)"
549doOp v LWriteStr [_,s]
550 = v ++ "MKINT((i_int)(idris_writeStr(stdout"
551 ++ ",GETSTR("
552 ++ creg s ++ "))))"
555-- String functions which need to know we're UTF8
556doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"
557doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"
558doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")"
559doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")"
560doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")"
561doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"
562doOp v LStrSubstr [x,y,z] = v ++ "idris_substr(vm, " ++ creg x ++ "," ++ creg y ++ "," ++ creg z ++ ")"
564doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 0 "EVAL") ++ ", " ++ creg x ++ "))"
565doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
566doOp v (LChInt ITNative) args = v ++ creg (last args)
567doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args
568doOp v (LIntCh ITNative) args = v ++ creg (last args)
569doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args
571doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"
572doOp v LNoOp args = v ++ creg (last args)
574-- Pointer primitives (declared as %extern in Builtins.idr)
575doOp v (LExternal rf) [_,x]
576 | rf == sUN "prim__readFile"
577 = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"
578doOp v (LExternal wf) [_,x,s]
579 | wf == sUN "prim__writeFile"
580 = v ++ "MKINT((i_int)(idris_writeStr(GETPTR(" ++ creg x
581 ++ "),GETSTR("
582 ++ creg s ++ "))))"
583doOp v (LExternal vm) [] | vm == sUN "prim__vm" = v ++ "MKPTR(vm, vm)"
584doOp v (LExternal si) [] | si == sUN "prim__stdin" = v ++ "MKPTR(vm, stdin)"
585doOp v (LExternal so) [] | so == sUN "prim__stdout" = v ++ "MKPTR(vm, stdout)"
586doOp v (LExternal se) [] | se == sUN "prim__stderr" = v ++ "MKPTR(vm, stderr)"
588doOp v (LExternal nul) [] | nul == sUN "prim__null" = v ++ "MKPTR(vm, NULL)"
589doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqPtr"
590 = v ++ "MKINT((i_int)(GETPTR(" ++ creg x ++ ") == GETPTR(" ++ creg y ++ ")))"
591doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqManagedPtr"
592 = v ++ "MKINT((i_int)(GETMPTR(" ++ creg x ++ ") == GETMPTR(" ++ creg y ++ ")))"
593doOp v (LExternal rp) [p, i] | rp == sUN "prim__registerPtr"
594 = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++ "), GETINT(" ++ creg i ++ "))"
596doOp _ op args = error $ "doOp not implemented (" ++ show (op, args) ++ ")"
598flUnOp :: String -> String -> String
599flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"
601-------------------- Interface file generation
603-- First, the wrappers in the C file
605ifaceC :: Export -> String
606ifaceC (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"
607ifaceC (ExportFun n cn ret args)
608 = ctype ret ++ " " ++ cdesc cn ++
609 "(VM* vm" ++ showArgs (zip argNames args) ++ ") {\n"
610 ++ mkBody n (zip argNames args) ret ++ "}\n\n"
611 where showArgs [] = ""
612 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++
613 showArgs ts
615 argNames = zipWith (++) (repeat "arg") (map show [0..])
617mkBody n as t = indent 1 ++ "INITFRAME;\n" ++
618 indent 1 ++ "RESERVE(" ++ show (max (length as) 3) ++ ");\n" ++
619 push 0 as ++ call n ++ retval t
620 where push i [] = ""
621 push i ((n, t) : ts) = indent 1 ++ c_irts (toFType t)
622 ("TOP(" ++ show i ++ ") = ") n
623 ++ ";\n" ++ push (i + 1) ts
625 call _ = indent 1 ++ "STOREOLD;\n" ++
626 indent 1 ++ "BASETOP(0);\n" ++
627 indent 1 ++ "ADDTOP(" ++ show (length as) ++ ");\n" ++
628 indent 1 ++ "CALL(" ++ cname n ++ ");\n"
630 retval (FIO t)
631 = indent 1 ++ "TOP(0) = NULL;\n" ++
632 indent 1 ++ "TOP(1) = NULL;\n" ++
633 indent 1 ++ "TOP(2) = RVAL;\n" ++
634 indent 1 ++ "STOREOLD;\n" ++
635 indent 1 ++ "BASETOP(0);\n" ++
636 indent 1 ++ "ADDTOP(3);\n" ++
637 indent 1 ++ "CALL(" ++ cname (sUN "call__IO") ++ ");\n" ++
638 retval t
639 retval t = indent 1 ++ "return " ++ irts_c (toFType t) "RVAL" ++ ";\n"
641ctype (FCon c)
642 | c == sUN "C_Str" = "char*"
643 | c == sUN "C_Float" = "float"
644 | c == sUN "C_Ptr" = "void*"
645 | c == sUN "C_MPtr" = "void*"
646 | c == sUN "C_Unit" = "void"
647ctype (FApp c [_,ity])
648 | c == sUN "C_IntT" = carith ity
649ctype (FApp c [_])
650 | c == sUN "C_Any" = "VAL"
651ctype (FStr s) = s
652ctype FUnknown = "void*"
653ctype (FIO t) = ctype t
654ctype t = error "Can't happen: Not a valid interface type " ++ show t
656carith (FCon i)
657 | i == sUN "C_IntChar" = "char"
658 | i == sUN "C_IntNative" = "int"
659carith t = error "Can't happen: Not an exportable arithmetic type"
661cdesc (FStr s) = s
662cdesc s = error "Can't happen: Not a valid C name"
664-- Then, the header files
666codegenH :: [ExportIFace] -> IO ()
667codegenH es = mapM_ writeIFace es
669writeIFace :: ExportIFace -> IO ()
670writeIFace (Export ffic hdr exps)
671 | ffic == sNS (sUN "FFI_C") ["FFI_C"]
672 = do let hfile = "#ifndef " ++ hdr_guard hdr ++ "\n" ++
673 "#define " ++ hdr_guard hdr ++ "\n\n" ++
674 "#include <idris_rts.h>\n\n" ++
675 concatMap hdr_export exps ++ "\n" ++
676 "#endif\n\n"
677 writeFile hdr hfile
678 | otherwise = return ()
680hdr_guard x = "__" ++ map hchar x
681 where hchar x | isAlphaNum x = toUpper x
682 hchar _ = '_'
684hdr_export :: Export -> String
685hdr_export (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"
686hdr_export (ExportFun n cn ret args)
687 = ctype ret ++ " " ++ cdesc cn ++
688 "(VM* vm" ++ showArgs (zip argNames args) ++ ");\n"
689 where showArgs [] = ""
690 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++
691 showArgs ts
693 argNames = zipWith (++) (repeat "arg") (map show [0..])