git.iko.soy/Idris-dev
on a5e76fc help sign in
Idris-dev/src/IRTS/CodegenC.hs
670 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.List (intercalate)
16import qualified Data.Vector.Unboxed as V
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 -> writeFile 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 let args = [gccDbg dbg] ++
77 gccFlags iface ++
78 -- # Any flags defined here which alter the RTS API must also be added to config.mk
79 ["-DHAS_PTHREAD", "-DIDRIS_ENABLE_STATS", "-msse2",
80 "-I."] ++ objs ++ ["-x", "c"] ++
81 (if (exec == Executable) then [] else ["-c"]) ++
82 [tmpn] ++
83 (if not iface then concatMap words libFlags else []) ++
84 concatMap words incFlags ++
85 (if not iface then concatMap words libs else []) ++
86 concatMap words flags ++
87 ["-o", out]
88-- putStrLn (show args)
89 exit <- rawSystem comp args
90 when (exit /= ExitSuccess) $
91 putStrLn ("FAILURE: " ++ show comp ++ " " ++ show args)
92 where
93 getExp (Export _ _ exp) = exp
95headers xs =
96 concatMap
97 (\h -> "#include <" ++ h ++ ">\n")
98 (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h"])
100debug TRACE = "#define IDRIS_TRACE\n\n"
101debug _ = ""
103-- We're using signed integers now. Make sure we get consistent semantics
104-- out of them from gcc. See e.g. http://thiemonagel.de/2010/01/signed-integer-overflow/
105gccFlags i = if i then ["-fwrapv"]
106 else ["-fwrapv", "-fno-strict-overflow"]
108gccDbg DEBUG = "-g"
109gccDbg TRACE = "-O2"
110gccDbg _ = "-O2"
112cname :: Name -> String
113cname n = "_idris_" ++ concatMap cchar (showCG n)
114 where cchar x | isAlpha x || isDigit x = [x]
115 | otherwise = "_" ++ show (fromEnum x) ++ "_"
117indent :: Int -> String
118indent n = replicate (n*4) ' '
120creg RVal = "RVAL"
121creg (L i) = "LOC(" ++ show i ++ ")"
122creg (T i) = "TOP(" ++ show i ++ ")"
123creg Tmp = "REG1"
125toDecl :: Name -> String
126toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"
128toC :: Name -> [BC] -> String
129toC f code
130 = -- "/* " ++ show code ++ "*/\n\n" ++
131 "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++
132 indent 1 ++ "INITFRAME;\n" ++
133 concatMap (bcc 1) code ++ "}\n\n"
135showCStr :: String -> String
136showCStr s = '"' : foldr ((++) . showChar) "\"" s
137 where
138 showChar :: Char -> String
139 showChar '"' = "\\\""
140 showChar '\\' = "\\\\"
141 showChar c
142 -- Note: we need the double quotes around the codes because otherwise
143 -- "\n3" would get encoded as "\x0a3", which is incorrect.
144 -- Instead, we opt for "\x0a""3" and let the C compiler deal with it.
145 | ord c < 0x10 = "\"\"\\x0" ++ showHex (ord c) "\"\""
146 | ord c < 0x20 = "\"\"\\x" ++ showHex (ord c) "\"\""
147 | ord c < 0x7f = [c] -- 0x7f = \DEL
148 | ord c < 0x100 = "\"\"\\x" ++ showHex (ord c) "\"\""
149 | otherwise = error $ "non-8-bit character in string literal: " ++ show c
151bcc :: Int -> BC -> String
152bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
153bcc i (ASSIGNCONST l c)
154 = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"
155 where
156 mkConst (I i) = "MKINT(" ++ show i ++ ")"
157 mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")"
158 | otherwise = "MKBIGC(vm,\"" ++ show i ++ "\")"
159 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"
160 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"
161 mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"
162 mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ "U)"
163 mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"
164 mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"
165 mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"
166 mkConst (B8V x) = let x' = V.toList x in "MKB8x16const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "U") x') ++ ")"
167 mkConst (B16V x) = let x' = V.toList x in "MKB16x8const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "U") x') ++ ")"
168 mkConst (B32V x) = let x' = V.toList x in "MKB32x4const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "UL") x') ++ ")"
169 mkConst (B64V x) = let x' = V.toList x in "MKB64x2const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "ULL") x') ++ ")"
170 -- if it's a type constant, we won't use it, but equally it shouldn't
171 -- report an error. These might creep into generated for various reasons
172 -- (especially if erasure is disabled).
173 mkConst c | isTypeConst c = "MKINT(42424242)"
174 mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"
176bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
177bcc i (MKCON l loc tag []) | tag < 256
178 = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"
179bcc i (MKCON l loc tag args)
180 = indent i ++ alloc loc tag ++
181 indent i ++ setArgs 0 args ++ "\n" ++
182 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"
184-- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++
185-- show (length args) ++ concatMap showArg args ++ ");\n"
186 where showArg r = ", " ++ creg r
187 setArgs i [] = ""
188 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++
189 "); " ++ setArgs (i + 1) xs
190 alloc Nothing tag
191 = "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ ", " ++
192 show (length args) ++ ", 0);\n"
193 alloc (Just old) tag
194 = "updateCon(" ++ creg Tmp ++ ", " ++ creg old ++ ", " ++ show tag ++ ", " ++
195 show (length args) ++ ");\n"
197bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++
198 ", " ++ show a ++ ");\n"
199bcc i (PROJECTINTO r t idx)
200 = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"
201bcc i (CASE True r code def)
202 | length code < 4 = showCase i def code
203 where
204 showCode :: Int -> [BC] -> String
205 showCode i bc = "{\n" ++ concatMap (bcc (i + 1)) bc ++
206 indent i ++ "}\n"
208 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String
209 showCase i Nothing [(t, c)] = showCode i c
210 showCase i (Just def) [] = showCode i def
211 showCase i def ((t, c) : cs)
212 = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c
213 ++ indent i ++ "else " ++ showCase i def cs
215bcc i (CASE safe r code def)
216 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++
217 concatMap (showCase i) code ++
218 showDef i def ++
219 indent i ++ "}\n"
220 where
221 ctag True = "CTAG"
222 ctag False = "TAG"
224 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
225 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"
226 showDef i Nothing = ""
227 showDef i (Just c) = indent i ++ "default:\n"
228 ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"
229bcc i (CONSTCASE r code def)
230 | intConsts code
231-- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++
232-- concatMap (showCase i) code ++
233-- showDef i def ++
234-- indent i ++ "}\n"
235 = concatMap (iCase (creg r)) code ++
236 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
237 | strConsts code
238 = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++
239 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
240 | bigintConsts code
241 = concatMap (biCase (creg r)) code ++
242 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
243 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code
244 where
245 intConsts ((I _, _ ) : _) = True
246 intConsts ((Ch _, _ ) : _) = True
247 intConsts _ = False
249 bigintConsts ((BI _, _ ) : _) = True
250 bigintConsts _ = False
252 strConsts ((Str _, _ ) : _) = True
253 strConsts _ = False
255 strCase sv (s, bc) =
256 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++
257 concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
258 biCase bv (BI b, bc) =
259 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"
260 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
261 iCase v (I b, bc) =
262 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"
263 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
264 iCase v (Ch b, bc) =
265 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n"
266 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
268 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
269 ++ concatMap (bcc (i+1)) bc ++
270 indent (i + 1) ++ "break;\n"
271 showDef i Nothing = ""
272 showDef i (Just c) = indent i ++ "default:\n"
273 ++ concatMap (bcc (i+1)) c ++
274 indent (i + 1) ++ "break;\n"
275 showDefS i Nothing = ""
276 showDefS i (Just c) = concatMap (bcc (i+1)) c
278bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"
279bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"
280bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"
281bcc i REBASE = indent i ++ "REBASE;\n"
282bcc i (RESERVE 0) = ""
283bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"
284bcc i (ADDTOP 0) = ""
285bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"
286bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
287bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
288bcc i STOREOLD = indent i ++ "STOREOLD;\n"
289bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"
290bcc i (FOREIGNCALL l rty (FStr fn) args)
291 = indent i ++
292 c_irts (toFType rty) (creg l ++ " = ")
293 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
294 where fcall (t, arg) = irts_c (toFType t) (creg arg)
295bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed
296bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1); exit(-1);"
297-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"
299-- Deconstruct the Foreign type in the defunctionalised expression and build
300-- a foreign type description for c_irts and irts_c
301toAType (FCon i)
302 | i == sUN "C_IntChar" = ATInt ITChar
303 | i == sUN "C_IntNative" = ATInt ITNative
304 | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)
305 | i == sUN "C_IntBits16" = ATInt (ITFixed IT16)
306 | i == sUN "C_IntBits32" = ATInt (ITFixed IT32)
307 | i == sUN "C_IntBits64" = ATInt (ITFixed IT64)
308 | i == sUN "C_IntB8x16" = ATInt (ITVec IT8 16)
309 | i == sUN "C_IntB16x8" = ATInt (ITVec IT16 8)
310 | i == sUN "C_IntB32x4" = ATInt (ITVec IT32 4)
311 | i == sUN "C_IntB64x2" = ATInt (ITVec IT64 2)
312toAType t = error (show t ++ " not defined in toAType")
314toFType (FCon c)
315 | c == sUN "C_Str" = FString
316 | c == sUN "C_Float" = FArith ATFloat
317 | c == sUN "C_Ptr" = FPtr
318 | c == sUN "C_MPtr" = FManagedPtr
319 | c == sUN "C_Unit" = FUnit
320toFType (FApp c [_,ity])
321 | c == sUN "C_IntT" = FArith (toAType ity)
322toFType (FApp c [_])
323 | c == sUN "C_Any" = FAny
324toFType t = FAny
326c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
327c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x
328c_irts (FArith (ATInt (ITFixed ity))) l x
329 = l ++ "idris_b" ++ show (nativeTyWidth ity) ++ "const(vm, " ++ x ++ ")"
330c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"
331c_irts FUnit l x = x
332c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"
333c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"
334c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"
335c_irts FAny l x = l ++ x
337irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"
338irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x
339irts_c (FArith (ATInt (ITFixed ity))) x
340 = "(" ++ x ++ "->info.bits" ++ show (nativeTyWidth ity) ++ ")"
341irts_c FString x = "GETSTR(" ++ x ++ ")"
342irts_c FUnit x = x
343irts_c FPtr x = "GETPTR(" ++ x ++ ")"
344irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"
345irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"
346irts_c FAny x = x
348bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"
350bitCoerce v op input output arg
351 = v ++ "idris_b" ++ show (nativeTyWidth input) ++ op ++ show (nativeTyWidth output) ++ "(vm, " ++ creg arg ++ ")"
353signedTy :: NativeTy -> String
354signedTy t = "int" ++ show (nativeTyWidth t) ++ "_t"
356doOp v (LPlus (ATInt ITNative)) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"
357doOp v (LMinus (ATInt ITNative)) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
358doOp v (LTimes (ATInt ITNative)) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"
359doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
360doOp v (LSDiv (ATInt ITNative)) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
361doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
362doOp v (LSRem (ATInt ITNative)) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
363doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"
364doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"
365doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"
366doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"
367doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
368doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
369doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"
370doOp v (LEq (ATInt ITNative)) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
371doOp v (LSLt (ATInt ITNative)) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
372doOp v (LSLe (ATInt ITNative)) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
373doOp v (LSGt (ATInt ITNative)) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
374doOp v (LSGe (ATInt ITNative)) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
375doOp v (LLt ITNative) [l, r] = v ++ "UINTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
376doOp v (LLe ITNative) [l, r] = v ++ "UINTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
377doOp v (LGt ITNative) [l, r] = v ++ "UINTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
378doOp v (LGe ITNative) [l, r] = v ++ "UINTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
380doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r]
381doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r]
382doOp v (LTimes (ATInt ITChar)) [l, r] = doOp v (LTimes (ATInt ITNative)) [l, r]
383doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r]
384doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r]
385doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r]
386doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r]
387doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r]
388doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r]
389doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r]
390doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r]
391doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r]
392doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r]
393doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x]
394doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r]
395doOp v (LSLt (ATInt ITChar)) [l, r] = doOp v (LSLt (ATInt ITNative)) [l, r]
396doOp v (LSLe (ATInt ITChar)) [l, r] = doOp v (LSLe (ATInt ITNative)) [l, r]
397doOp v (LSGt (ATInt ITChar)) [l, r] = doOp v (LSGt (ATInt ITNative)) [l, r]
398doOp v (LSGe (ATInt ITChar)) [l, r] = doOp v (LSGe (ATInt ITNative)) [l, r]
399doOp v (LLt ITChar) [l, r] = doOp v (LLt ITNative) [l, r]
400doOp v (LLe ITChar) [l, r] = doOp v (LLe ITNative) [l, r]
401doOp v (LGt ITChar) [l, r] = doOp v (LGt ITNative) [l, r]
402doOp v (LGe ITChar) [l, r] = doOp v (LGe ITNative) [l, r]
404doOp v (LPlus ATFloat) [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"
405doOp v (LMinus ATFloat) [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
406doOp v (LTimes ATFloat) [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"
407doOp v (LSDiv ATFloat) [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
408doOp v (LEq ATFloat) [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
409doOp v (LSLt ATFloat) [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
410doOp v (LSLe ATFloat) [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
411doOp v (LSGt ATFloat) [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
412doOp v (LSGe ATFloat) [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
414doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"
415doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"
416doOp v (LPlus (ATInt ITBig)) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
417doOp v (LMinus (ATInt ITBig)) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
418doOp v (LTimes (ATInt ITBig)) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
419doOp v (LSDiv (ATInt ITBig)) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
420doOp v (LSRem (ATInt ITBig)) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
421doOp v (LEq (ATInt ITBig)) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
422doOp v (LSLt (ATInt ITBig)) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
423doOp v (LSLe (ATInt ITBig)) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
424doOp v (LSGt (ATInt ITBig)) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
425doOp v (LSGe (ATInt ITBig)) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
427doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
428doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
429doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
430doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"
432doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"
433doOp v (LFloatInt ITNative) [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"
434doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"
435doOp v (LTrunc ITBig ITNative) [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"
436doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"
437doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"
438doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"
439doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"
440doOp v (LIntStr (ITFixed _)) [x] = v ++ "idris_castBitsStr(vm, " ++ creg x ++ ")"
441doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"
442doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"
444doOp v LReadStr [_] = v ++ "idris_readStr(vm, stdin)"
445doOp v LWriteStr [_,s] = v ++ "MKINT((i_int)(idris_writeStr(stdout"
446 ++ ",GETSTR("
447 ++ creg s ++ "))))"
449doOp v LReadFile [_,x] = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"
450doOp v LWriteFile [_,x,s] = v ++ "MKINT((i_int)(idris_writeStr(GETPTR(" ++ creg x
451 ++ "),GETSTR("
452 ++ creg s ++ "))))"
454doOp v (LSLt (ATInt (ITFixed ty))) [x, y] = bitOp v "SLt" ty [x, y]
455doOp v (LSLe (ATInt (ITFixed ty))) [x, y] = bitOp v "SLte" ty [x, y]
456doOp v (LEq (ATInt (ITFixed ty))) [x, y] = bitOp v "Eq" ty [x, y]
457doOp v (LSGe (ATInt (ITFixed ty))) [x, y] = bitOp v "SGte" ty [x, y]
458doOp v (LSGt (ATInt (ITFixed ty))) [x, y] = bitOp v "SGt" ty [x, y]
459doOp v (LLt (ITFixed ty)) [x, y] = bitOp v "Lt" ty [x, y]
460doOp v (LLe (ITFixed ty)) [x, y] = bitOp v "Lte" ty [x, y]
461doOp v (LGe (ITFixed ty)) [x, y] = bitOp v "Gte" ty [x, y]
462doOp v (LGt (ITFixed ty)) [x, y] = bitOp v "Gt" ty [x, y]
464doOp v (LSHL (ITFixed ty)) [x, y] = bitOp v "Shl" ty [x, y]
465doOp v (LLSHR (ITFixed ty)) [x, y] = bitOp v "LShr" ty [x, y]
466doOp v (LASHR (ITFixed ty)) [x, y] = bitOp v "AShr" ty [x, y]
467doOp v (LAnd (ITFixed ty)) [x, y] = bitOp v "And" ty [x, y]
468doOp v (LOr (ITFixed ty)) [x, y] = bitOp v "Or" ty [x, y]
469doOp v (LXOr (ITFixed ty)) [x, y] = bitOp v "Xor" ty [x, y]
470doOp v (LCompl (ITFixed ty)) [x] = bitOp v "Compl" ty [x]
472doOp v (LPlus (ATInt (ITFixed ty))) [x, y] = bitOp v "Plus" ty [x, y]
473doOp v (LMinus (ATInt (ITFixed ty))) [x, y] = bitOp v "Minus" ty [x, y]
474doOp v (LTimes (ATInt (ITFixed ty))) [x, y] = bitOp v "Times" ty [x, y]
475doOp v (LUDiv (ITFixed ty)) [x, y] = bitOp v "UDiv" ty [x, y]
476doOp v (LSDiv (ATInt (ITFixed ty))) [x, y] = bitOp v "SDiv" ty [x, y]
477doOp v (LURem (ITFixed ty)) [x, y] = bitOp v "URem" ty [x, y]
478doOp v (LSRem (ATInt (ITFixed ty))) [x, y] = bitOp v "SRem" ty [x, y]
480doOp v (LSExt (ITFixed from) ITBig) [x]
481 = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
482doOp v (LSExt ITNative (ITFixed to)) [x]
483 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
484doOp v (LSExt ITChar (ITFixed to)) [x]
485 = doOp v (LSExt ITNative (ITFixed to)) [x]
486doOp v (LSExt (ITFixed from) ITNative) [x]
487 = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ "))"
488doOp v (LSExt (ITFixed from) ITChar) [x]
489 = doOp v (LSExt (ITFixed from) ITNative) [x]
490doOp v (LSExt (ITFixed from) (ITFixed to)) [x]
491 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "S" from to x
492doOp v (LZExt ITNative (ITFixed to)) [x]
493 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
494doOp v (LZExt ITChar (ITFixed to)) [x]
495 = doOp v (LZExt ITNative (ITFixed to)) [x]
496doOp v (LZExt (ITFixed from) ITNative) [x]
497 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
498doOp v (LZExt (ITFixed from) ITChar) [x]
499 = doOp v (LZExt (ITFixed from) ITNative) [x]
500doOp v (LZExt (ITFixed from) ITBig) [x]
501 = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
502doOp v (LZExt ITNative ITBig) [x]
503 = v ++ "MKBIGUI(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
504doOp v (LZExt (ITFixed from) (ITFixed to)) [x]
505 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "Z" from to x
506doOp v (LTrunc ITNative (ITFixed to)) [x]
507 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
508doOp v (LTrunc ITChar (ITFixed to)) [x]
509 = doOp v (LTrunc ITNative (ITFixed to)) [x]
510doOp v (LTrunc (ITFixed from) ITNative) [x]
511 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
512doOp v (LTrunc (ITFixed from) ITChar) [x]
513 = doOp v (LTrunc (ITFixed from) ITNative) [x]
514doOp v (LTrunc ITBig (ITFixed to)) [x]
515 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"
516doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]
517 | nativeTyWidth from > nativeTyWidth to = bitCoerce v "T" from to x
519doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)
520doOp v LFLog [x] = v ++ flUnOp "log" (creg x)
521doOp v LFSin [x] = v ++ flUnOp "sin" (creg x)
522doOp v LFCos [x] = v ++ flUnOp "cos" (creg x)
523doOp v LFTan [x] = v ++ flUnOp "tan" (creg x)
524doOp v LFASin [x] = v ++ flUnOp "asin" (creg x)
525doOp v LFACos [x] = v ++ flUnOp "acos" (creg x)
526doOp v LFATan [x] = v ++ flUnOp "atan" (creg x)
527doOp v LFSqrt [x] = v ++ flUnOp "sqrt" (creg x)
528doOp v LFFloor [x] = v ++ flUnOp "floor" (creg x)
529doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x)
530doOp v LFNegate [x] = v ++ "MKFLOAT(vm, -GETFLOAT(" ++ (creg x) ++ "))"
532doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"
533doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"
534doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")"
535doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")"
536doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")"
538doOp v LAllocate [x] = v ++ "idris_buffer_allocate(vm, " ++ creg x ++ ")"
539doOp v LAppendBuffer [a, b, c, d, e, f] = v ++ "idris_appendBuffer(vm, " ++ creg a ++ "," ++ creg b ++ "," ++ creg c ++ "," ++ creg d ++ "," ++ creg e ++ "," ++ creg f ++ ")"
540doOp v (LAppend ity en) [a, b, c, d] = v ++ "idris_append" ++ intTyName ity ++ show en ++ "(vm, " ++ creg a ++ "," ++ creg b ++ "," ++ creg c ++ "," ++ creg d ++ ")"
541doOp v (LPeek ity en) [x, y] = v ++ "idris_peek" ++ intTyName ity ++ show en ++ "(vm, " ++ creg x ++ "," ++ creg y ++ ")"
543doOp v LStdIn [] = v ++ "MKPTR(vm, stdin)"
544doOp v LStdOut [] = v ++ "MKPTR(vm, stdout)"
545doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)"
547doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 0 "EVAL") ++ ", " ++ creg x ++ "))"
548doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
549doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"
550doOp v LNullPtr [] = v ++ "MKPTR(vm, NULL)"
551doOp v LRegisterPtr [p, i] = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++
552 "), GETINT(" ++ creg i ++ "))"
553doOp v (LChInt ITNative) args = v ++ creg (last args)
554doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args
555doOp v (LIntCh ITNative) args = v ++ creg (last args)
556doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args
558doOp v c@(LMkVec IT8 _) args = v ++ "MKB8x16(vm, " ++ (intercalate ", " (map creg args)) ++ ")"
559doOp v c@(LMkVec IT16 _) args = v ++ "MKB16x8(vm, " ++ (intercalate ", " (map creg args)) ++ ")"
560doOp v c@(LMkVec IT32 _) args = v ++ "MKB32x4(vm, " ++ (intercalate ", " (map creg args)) ++ ")"
561doOp v c@(LMkVec IT64 _) args = v ++ "MKB64x2(vm, " ++ (intercalate ", " (map creg args)) ++ ")"
563doOp v c@(LIdxVec IT8 _) [p, i] = v ++ "idris_IDXB8x16(vm, " ++ creg p ++ ", " ++ creg i ++ ")"
564doOp v c@(LIdxVec IT16 _) [p, i] = v ++ "idris_IDXB16x8(vm, " ++ creg p ++ ", " ++ creg i ++ ")"
565doOp v c@(LIdxVec IT32 _) [p, i] = v ++ "idris_IDXB32x4(vm, " ++ creg p ++ ", " ++ creg i ++ ")"
566doOp v c@(LIdxVec IT64 _) [p, i] = v ++ "idris_IDXB64x2(vm, " ++ creg p ++ ", " ++ creg i ++ ")"
568doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"
569doOp v LNoOp args = v ++ creg (last args)
570doOp _ op args = error "doOp of (" ++ show op ++ ") not implemented, arguments (" ++ show args ++ ")"
572flUnOp :: String -> String -> String
573flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"
575-------------------- Interface file generation
577-- First, the wrappers in the C file
579ifaceC :: Export -> String
580ifaceC (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"
581ifaceC (ExportFun n cn ret args)
582 = ctype ret ++ " " ++ cdesc cn ++
583 "(VM* vm" ++ showArgs (zip argNames args) ++ ") {\n"
584 ++ mkBody n (zip argNames args) ret ++ "}\n\n"
585 where showArgs [] = ""
586 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++
587 showArgs ts
589 argNames = zipWith (++) (repeat "arg") (map show [0..])
591mkBody n as t = indent 1 ++ "INITFRAME;\n" ++
592 indent 1 ++ "RESERVE(" ++ show (max (length as) 3) ++ ");\n" ++
593 push 0 as ++ call n ++ retval t
594 where push i [] = ""
595 push i ((n, t) : ts) = indent 1 ++ c_irts (toFType t)
596 ("TOP(" ++ show i ++ ") = ") n
597 ++ ";\n" ++ push (i + 1) ts
599 call _ = indent 1 ++ "STOREOLD;\n" ++
600 indent 1 ++ "BASETOP(0);\n" ++
601 indent 1 ++ "ADDTOP(" ++ show (length as) ++ ");\n" ++
602 indent 1 ++ "CALL(" ++ cname n ++ ");\n"
604 retval (FIO t)
605 = indent 1 ++ "TOP(0) = NULL;\n" ++
606 indent 1 ++ "TOP(1) = NULL;\n" ++
607 indent 1 ++ "TOP(2) = RVAL;\n" ++
608 indent 1 ++ "STOREOLD;\n" ++
609 indent 1 ++ "BASETOP(0);\n" ++
610 indent 1 ++ "ADDTOP(3);\n" ++
611 indent 1 ++ "CALL(" ++ cname (sUN "call__IO") ++ ");\n" ++
612 retval t
613 retval t = indent 1 ++ "return " ++ irts_c (toFType t) "RVAL" ++ ";\n"
615ctype (FCon c)
616 | c == sUN "C_Str" = "char*"
617 | c == sUN "C_Float" = "float"
618 | c == sUN "C_Ptr" = "void*"
619 | c == sUN "C_MPtr" = "void*"
620 | c == sUN "C_Unit" = "void"
621ctype (FApp c [_,ity])
622 | c == sUN "C_IntT" = carith ity
623ctype (FApp c [_])
624 | c == sUN "C_Any" = "VAL"
625ctype (FStr s) = s
626ctype FUnknown = "void*"
627ctype (FIO t) = ctype t
628ctype t = error "Can't happen: Not a valid interface type " ++ show t
630carith (FCon i)
631 | i == sUN "C_IntChar" = "char"
632 | i == sUN "C_IntNative" = "int"
633carith t = error "Can't happen: Not an exportable arithmetic type"
635cdesc (FStr s) = s
636cdesc s = error "Can't happen: Not a valid C name"
638-- Then, the header files
640codegenH :: [ExportIFace] -> IO ()
641codegenH es = mapM_ writeIFace es
643writeIFace :: ExportIFace -> IO ()
644writeIFace (Export ffic hdr exps)
645 | ffic == sUN "FFI_C"
646 = do let hfile = "#ifndef " ++ hdr_guard hdr ++ "\n" ++
647 "#define " ++ hdr_guard hdr ++ "\n\n" ++
648 "#include <idris_rts.h>\n\n" ++
649 concatMap hdr_export exps ++ "\n" ++
650 "#endif\n\n"
651 writeFile hdr hfile
652 | otherwise = return ()
654hdr_guard x = "__" ++ map hchar x
655 where hchar x | isAlphaNum x = toUpper x
656 hchar _ = '_'
658hdr_export :: Export -> String
659hdr_export (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"
660hdr_export (ExportFun n cn ret args)
661 = ctype ret ++ " " ++ cdesc cn ++
662 "(VM* vm" ++ showArgs (zip argNames args) ++ ");\n"
663 where showArgs [] = ""
664 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++
665 showArgs ts
667 argNames = zipWith (++) (repeat "arg") (map show [0..])