git.iko.soy/Idris-dev
on e680962 help sign in
Idris-dev/src/IRTS/CodegenC.hs
890 lines 43 kB history raw
1{-|
2Module : IRTS.CodegenC
3Description : The default code generator for Idris, generating C code.
4Copyright :
5License : BSD3
6Maintainer : The Idris Community.
7-}
8{-# LANGUAGE FlexibleContexts #-}
10module IRTS.CodegenC (codegenC) where
12import Idris.Core.TT
13import IRTS.Bytecode
14import IRTS.CodegenCommon
15import IRTS.Defunctionalise
16import IRTS.Simplified
17import IRTS.System
19import Util.System
21import Control.Monad
22import Data.Bits
23import Data.Char
24import Data.List (intercalate, nubBy)
25import Numeric
26import System.Exit
27import System.FilePath ((<.>), (</>))
28import System.IO
29import System.Process
31codegenC :: CodeGenerator
32codegenC ci = do codegenC' (simpleDecls ci)
33 (outputFile ci)
34 (outputType ci)
35 (includes ci)
36 (compileObjs ci)
37 (map mkLib (compileLibs ci) ++
38 map incdir (importDirs ci))
39 (compilerFlags ci)
40 (exportDecls ci)
41 (interfaces ci)
42 (debugLevel ci)
43 when (interfaces ci) $
44 codegenH (exportDecls ci)
46 where mkLib l = "-l" ++ l
47 incdir i = "-I" ++ i
49codegenC' :: [(Name, SDecl)]
50 -> String -- ^ output file name
51 -> OutputType -- ^ generate executable if True, only .o if False
52 -> [FilePath] -- ^ include files
53 -> [String] -- ^ extra object files
54 -> [String] -- ^ extra compiler flags (libraries)
55 -> [String] -- ^ extra compiler flags (anything)
56 -> [ExportIFace]
57 -> Bool -- ^ interfaces too (so make a .o instead)
58 -> DbgLevel
59 -> IO ()
60codegenC' defs out exec incs objs libs flags exports iface dbg
61 = do -- print defs
62 let bc = map toBC defs
63 let wrappers = genWrappers bc
64 let h = concatMap toDecl (map fst bc)
65 let cc = concatMap (uncurry toC) bc
66 let hi = concatMap ifaceC (concatMap getExp exports)
67 d <- getIdrisCRTSDir
68 mprog <- readFile (d </> "idris_main" <.> "c")
69 let cout = headers incs ++ debug dbg ++ h ++ wrappers ++ cc ++
70 (if (exec == Executable) then mprog else hi)
71 case exec of
72 Raw -> writeSource out cout
73 _ -> do
74 (tmpn, tmph) <- tempfile ".c"
75 hPutStr tmph cout
76 hFlush tmph
77 hClose tmph
78 comp <- getCC
79 libFlags <- getLibFlags
80 incFlags <- getIncFlags
81 envFlags <- getEnvFlags
82 let stackFlag = if isWindows then ["-Wl,--stack,16777216"] else []
83 let args = [gccDbg dbg] ++
84 gccFlags iface ++
85 -- # Any flags defined here which alter the RTS API must also be added to config.mk
86 ["-DHAS_PTHREAD", "-DIDRIS_ENABLE_STATS",
87 "-I."] ++ objs ++ envFlags ++
88 (if (exec == Executable) then [] else ["-c"]) ++
89 [tmpn] ++
90 (if not iface then libFlags else []) ++
91 incFlags ++
92 (if not iface then libs else []) ++
93 flags ++ stackFlag ++
94 ["-o", out]
95-- putStrLn (show args)
96 exit <- rawSystem comp args
97 when (exit /= ExitSuccess) $
98 putStrLn ("FAILURE: " ++ show comp ++ " " ++ show args)
99 where
100 getExp (Export _ _ exp) = exp
102headers xs =
103 concatMap
104 (\h -> "#include \"" ++ h ++ "\"\n")
105 (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h"])
107debug TRACE = "#define IDRIS_TRACE\n\n"
108debug _ = ""
110-- We're using signed integers now. Make sure we get consistent semantics
111-- out of them from gcc. See e.g. http://thiemonagel.de/2010/01/signed-integer-overflow/
112gccFlags i = if i then ["-fwrapv"]
113 else ["-fwrapv", "-fno-strict-overflow"]
115gccDbg DEBUG = "-g"
116gccDbg TRACE = "-O2"
117gccDbg _ = "-O2"
119cname :: Name -> String
120cname n = "_idris_" ++ concatMap cchar (showCG n)
121 where cchar x | isAlpha x || isDigit x = [x]
122 | otherwise = "_" ++ show (fromEnum x) ++ "_"
124indent :: Int -> String
125indent n = replicate (n*4) ' '
127creg RVal = "RVAL"
128creg (L i) = "LOC(" ++ show i ++ ")"
129creg (T i) = "TOP(" ++ show i ++ ")"
130creg Tmp = "REG1"
132toDecl :: Name -> String
133toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"
135toC :: Name -> [BC] -> String
136toC f code
137 = -- "/* " ++ show code ++ "*/\n\n" ++
138 "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++
139 indent 1 ++ "INITFRAME;\n" ++
140 concatMap (bcc 1) code ++ "}\n\n"
142showCStr :: String -> String
143showCStr s = '"' : foldr ((++) . showChar) "\"" s
144 where
145 showChar :: Char -> String
146 showChar '"' = "\\\""
147 showChar '\\' = "\\\\"
148 showChar c
149 -- Note: we need the double quotes around the codes because otherwise
150 -- "\n3" would get encoded as "\x0a3", which is incorrect.
151 -- Instead, we opt for "\x0a""3" and let the C compiler deal with it.
152 | ord c < 0x20 = showUTF8 (ord c)
153 | ord c < 0x7f = [c] -- 0x7f = \DEL
154 | otherwise = showHexes (utf8bytes (ord c))
156 showUTF8 c = "\"\"\\x" ++ pad (showHex c "") ++ "\"\""
157 showHexes = foldr ((++) . showUTF8) ""
159 utf8bytes :: Int -> [Int]
160 utf8bytes x
161 | x <= 0x7f = [x]
162 | x <= 0x7ff = let (y : ys) = split [] 2 x in (y .|. 0xc0) : map (.|. 0x80) ys
163 | x <= 0xffff = let (y : ys) = split [] 3 x in (y .|. 0xe0) : map (.|. 0x80) ys
164 | x <= 0x10ffff = let (y : ys) = split [] 4 x in (y .|. 0xf0) : map (.|. 0x80) ys
165 | otherwise = error $ "Invalid Unicode code point U+" ++ showHex x ""
166 where
167 split acc 1 x = x : acc
168 split acc i x = split (x .&. 0x3f : acc) (i - 1) (shiftR x 6)
170 pad :: String -> String
171 pad s = case length s of
172 1 -> "0" ++ s
173 2 -> s
174 _ -> error $ "Can't happen: String of invalid length " ++ show s
176bcc :: Int -> BC -> String
177bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
178bcc i (ASSIGNCONST l c)
179 = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"
180 where
181 mkConst (I i) = "MKINT(" ++ show i ++ ")"
182 mkConst (BI i) = let maxInt = 2^30
183 in if i >= -maxInt && i < maxInt
184 then "MKINT(" ++ show i ++ ")"
185 else "MKBIGC(vm,\"" ++ show i ++ "\")"
186 mkConst (Fl f) = "MKFLOAT(vm, " ++ (map toUpper $ show f) ++ ")"
187 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"
188 mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"
189 mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ "U)"
190 mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"
191 mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"
192 mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"
193 -- if it's a type constant, we won't use it, but equally it shouldn't
194 -- report an error. These might creep into generated for various reasons
195 -- (especially if erasure is disabled).
196 mkConst c | isTypeConst c = "MKINT(42424242)"
197 mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"
199bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
200bcc i (MKCON l loc tag []) | tag < 256
201 = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"
202bcc i (MKCON l loc tag args)
203 = indent i ++ alloc loc tag ++
204 indent i ++ setArgs 0 args ++ "\n" ++
205 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"
206 where setArgs i [] = ""
207 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++
208 "); " ++ setArgs (i + 1) xs
209 alloc Nothing tag
210 = "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ ", " ++
211 show (length args) ++ ", 0);\n"
212 alloc (Just old) tag
213 = "updateCon(" ++ creg Tmp ++ ", " ++ creg old ++ ", " ++ show tag ++ ", " ++
214 show (length args) ++ ");\n"
216bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++
217 ", " ++ show a ++ ");\n"
218bcc i (PROJECTINTO r t idx)
219 = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"
220bcc i (CASE True r code def)
221 | length code < 4 = showCase i def code
222 where
223 showCode :: Int -> [BC] -> String
224 showCode i bc = "{\n" ++ concatMap (bcc (i + 1)) bc ++
225 indent i ++ "}\n"
227 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String
228 showCase i Nothing [(t, c)] = indent i ++ showCode i c
229 showCase i (Just def) [] = indent i ++ showCode i def
230 showCase i def ((t, c) : cs)
231 = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c
232 ++ indent i ++ "else\n" ++ showCase i def cs
234bcc i (CASE safe r code def)
235 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++
236 concatMap (showCase i) code ++
237 showDef i def ++
238 indent i ++ "}\n"
239 where
240 ctag True = "CTAG"
241 ctag False = "TAG"
243 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
244 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"
245 showDef i Nothing = ""
246 showDef i (Just c) = indent i ++ "default:\n"
247 ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"
248bcc i (CONSTCASE r code def)
249 | intConsts code
250-- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++
251-- concatMap (showCase i) code ++
252-- showDef i def ++
253-- indent i ++ "}\n"
254 = concatMap (iCase (creg r)) code ++
255 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
256 | strConsts code
257 = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++
258 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
259 | bigintConsts code
260 = concatMap (biCase (creg r)) code ++
261 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
262 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code
263 where
264 intConsts ((I _, _ ) : _) = True
265 intConsts ((Ch _, _ ) : _) = True
266 intConsts ((B8 _, _ ) : _) = True
267 intConsts ((B16 _, _ ) : _) = True
268 intConsts ((B32 _, _ ) : _) = True
269 intConsts ((B64 _, _ ) : _) = True
270 intConsts _ = False
272 bigintConsts ((BI _, _ ) : _) = True
273 bigintConsts _ = False
275 strConsts ((Str _, _ ) : _) = True
276 strConsts _ = False
278 strCase sv (s, bc) =
279 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++
280 concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
281 biCase bv (BI b, bc) =
282 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"
283 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
284 iCase v (I b, bc) =
285 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"
286 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
287 iCase v (Ch b, bc) =
288 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n"
289 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
290 iCase v (B8 w, bc) =
291 indent i ++ "if (GETBITS8(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
292 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
293 iCase v (B16 w, bc) =
294 indent i ++ "if (GETBITS16(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
295 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
296 iCase v (B32 w, bc) =
297 indent i ++ "if (GETBITS32(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
298 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
299 iCase v (B64 w, bc) =
300 indent i ++ "if (GETBITS64(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
301 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
302 showDefS i Nothing = ""
303 showDefS i (Just c) = concatMap (bcc (i+1)) c
305bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"
306bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"
307bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"
308bcc i REBASE = indent i ++ "REBASE;\n"
309bcc i (RESERVE 0) = ""
310bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"
311bcc i (ADDTOP 0) = ""
312bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"
313bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
314bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
315bcc i STOREOLD = indent i ++ "STOREOLD;\n"
316bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"
317bcc i (FOREIGNCALL l rty (FStr fn@('&':name)) [])
318 = indent i ++
319 c_irts (toFType rty) (creg l ++ " = ") fn ++ ";\n"
320bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%wrapper"
321 = indent i ++
322 c_irts (toFType rty) (creg l ++ " = ")
323 ("_idris_get_wrapper(" ++ creg (snd x) ++ ")") ++ ";\n"
324bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%dynamic"
325 = indent i ++ c_irts (toFType rty) (creg l ++ " = ")
326 ("(*(" ++ cFnSig "" rty xs ++ ") GETPTR(" ++ creg (snd x) ++ "))" ++
327 "(" ++ showSep "," (map fcall xs) ++ ")") ++ ";\n"
328bcc i (FOREIGNCALL l rty (FStr fn) args)
329 = indent i ++
330 c_irts (toFType rty) (creg l ++ " = ")
331 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
332bcc i (FOREIGNCALL l rty _ args) = error "Foreign Function calls cannot be partially applied, without being inlined."
333bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed
334bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"
335-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"
337fcall (t, arg) = irts_c (toFType t) (creg arg)
338-- Deconstruct the Foreign type in the defunctionalised expression and build
339-- a foreign type description for c_irts and irts_c
340toAType (FCon i)
341 | i == sUN "C_IntChar" = ATInt ITChar
342 | i == sUN "C_IntNative" = ATInt ITNative
343 | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)
344 | i == sUN "C_IntBits16" = ATInt (ITFixed IT16)
345 | i == sUN "C_IntBits32" = ATInt (ITFixed IT32)
346 | i == sUN "C_IntBits64" = ATInt (ITFixed IT64)
347toAType t = error (show t ++ " not defined in toAType")
349toFType (FCon c)
350 | c == sUN "C_Str" = FString
351 | c == sUN "C_Float" = FArith ATFloat
352 | c == sUN "C_Ptr" = FPtr
353 | c == sUN "C_MPtr" = FManagedPtr
354 | c == sUN "C_CData" = FCData
355 | c == sUN "C_Unit" = FUnit
356toFType (FApp c [_,ity])
357 | c == sUN "C_IntT" = FArith (toAType ity)
358 | c == sUN "C_FnT" = toFunType ity
359toFType (FApp c [_])
360 | c == sUN "C_Any" = FAny
361toFType t = FAny
363toFunType (FApp c [_,ity])
364 | c == sUN "C_FnBase" = FFunction
365 | c == sUN "C_FnIO" = FFunctionIO
366toFunType (FApp c [_,_,_,ity])
367 | c == sUN "C_Fn" = toFunType ity
368toFunType _ = FAny
370c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
371c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x
372c_irts (FArith (ATInt (ITFixed ity))) l x
373 = l ++ "idris_b" ++ show (nativeTyWidth ity) ++ "const(vm, " ++ x ++ ")"
374c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"
375c_irts FUnit l x = x
376c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"
377c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"
378c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"
379c_irts FCData l x = l ++ "MKCDATA(vm, " ++ x ++ ")"
380c_irts FAny l x = l ++ x
381c_irts FFunction l x = error "Return of function from foreign call is not supported"
382c_irts FFunctionIO l x = error "Return of function from foreign call is not supported"
384irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"
385irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x
386irts_c (FArith (ATInt (ITFixed ity))) x
387 = "(" ++ x ++ "->info.bits" ++ show (nativeTyWidth ity) ++ ")"
388irts_c FString x = "GETSTR(" ++ x ++ ")"
389irts_c FUnit x = x
390irts_c FPtr x = "GETPTR(" ++ x ++ ")"
391irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"
392irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"
393irts_c FCData x = "GETCDATA(" ++ x ++ ")"
394irts_c FAny x = x
395irts_c FFunctionIO x = wrapped x
396irts_c FFunction x = wrapped x
398cFnSig name rty [] = ctype rty ++ " (*" ++ name ++ ")(void) "
399cFnSig name rty args = ctype rty ++ " (*" ++ name ++ ")("
400 ++ showSep "," (map (ctype . fst) args) ++ ") "
402wrapped x = "_idris_get_wrapper(" ++ x ++ ")"
404bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"
406bitCoerce v op input output arg
407 = v ++ "idris_b" ++ show (nativeTyWidth input) ++ op ++ show (nativeTyWidth output) ++ "(vm, " ++ creg arg ++ ")"
409signedTy :: NativeTy -> String
410signedTy t = "int" ++ show (nativeTyWidth t) ++ "_t"
412doOp v (LPlus (ATInt ITNative)) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"
413doOp v (LMinus (ATInt ITNative)) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
414doOp v (LTimes (ATInt ITNative)) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"
415doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
416doOp v (LSDiv (ATInt ITNative)) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
417doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
418doOp v (LSRem (ATInt ITNative)) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
419doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"
420doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"
421doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"
422doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"
423doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
424doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
425doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"
426doOp v (LEq (ATInt ITNative)) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
427doOp v (LSLt (ATInt ITNative)) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
428doOp v (LSLe (ATInt ITNative)) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
429doOp v (LSGt (ATInt ITNative)) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
430doOp v (LSGe (ATInt ITNative)) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
431doOp v (LLt ITNative) [l, r] = v ++ "UINTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
432doOp v (LLe ITNative) [l, r] = v ++ "UINTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
433doOp v (LGt ITNative) [l, r] = v ++ "UINTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
434doOp v (LGe ITNative) [l, r] = v ++ "UINTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
436doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r]
437doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r]
438doOp v (LTimes (ATInt ITChar)) [l, r] = doOp v (LTimes (ATInt ITNative)) [l, r]
439doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r]
440doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r]
441doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r]
442doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r]
443doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r]
444doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r]
445doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r]
446doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r]
447doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r]
448doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r]
449doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x]
450doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r]
451doOp v (LSLt (ATInt ITChar)) [l, r] = doOp v (LSLt (ATInt ITNative)) [l, r]
452doOp v (LSLe (ATInt ITChar)) [l, r] = doOp v (LSLe (ATInt ITNative)) [l, r]
453doOp v (LSGt (ATInt ITChar)) [l, r] = doOp v (LSGt (ATInt ITNative)) [l, r]
454doOp v (LSGe (ATInt ITChar)) [l, r] = doOp v (LSGe (ATInt ITNative)) [l, r]
455doOp v (LLt ITChar) [l, r] = doOp v (LLt ITNative) [l, r]
456doOp v (LLe ITChar) [l, r] = doOp v (LLe ITNative) [l, r]
457doOp v (LGt ITChar) [l, r] = doOp v (LGt ITNative) [l, r]
458doOp v (LGe ITChar) [l, r] = doOp v (LGe ITNative) [l, r]
460doOp v (LPlus ATFloat) [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"
461doOp v (LMinus ATFloat) [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
462doOp v (LTimes ATFloat) [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"
463doOp v (LSDiv ATFloat) [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
464doOp v (LEq ATFloat) [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
465doOp v (LSLt ATFloat) [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
466doOp v (LSLe ATFloat) [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
467doOp v (LSGt ATFloat) [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
468doOp v (LSGe ATFloat) [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
470doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"
471doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"
472doOp v (LPlus (ATInt ITBig)) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
473doOp v (LMinus (ATInt ITBig)) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
474doOp v (LTimes (ATInt ITBig)) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
475doOp v (LSDiv (ATInt ITBig)) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
476doOp v (LSRem (ATInt ITBig)) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
477doOp v (LAnd ITBig) [l, r] = v ++ "idris_bigAnd(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
478doOp v (LOr ITBig) [l, r] = v ++ "idris_bigOr(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
479doOp v (LSHL ITBig) [l, r] = v ++ "idris_bigShiftLeft(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
480doOp v (LLSHR ITBig) [l, r] = v ++ "idris_bigLShiftRight(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
481doOp v (LASHR ITBig) [l, r] = v ++ "idris_bigAShiftRight(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
482doOp v (LEq (ATInt ITBig)) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
483doOp v (LSLt (ATInt ITBig)) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
484doOp v (LSLe (ATInt ITBig)) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
485doOp v (LSGt (ATInt ITBig)) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
486doOp v (LSGe (ATInt ITBig)) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
488doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"
489doOp v (LFloatInt ITNative) [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"
490doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"
491doOp v (LTrunc ITBig ITNative) [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"
492doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"
493doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"
494doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"
495doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"
496doOp v (LIntStr (ITFixed _)) [x] = v ++ "idris_castBitsStr(vm, " ++ creg x ++ ")"
497doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"
498doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"
500doOp v (LSLt (ATInt (ITFixed ty))) [x, y] = bitOp v "SLt" ty [x, y]
501doOp v (LSLe (ATInt (ITFixed ty))) [x, y] = bitOp v "SLte" ty [x, y]
502doOp v (LEq (ATInt (ITFixed ty))) [x, y] = bitOp v "Eq" ty [x, y]
503doOp v (LSGe (ATInt (ITFixed ty))) [x, y] = bitOp v "SGte" ty [x, y]
504doOp v (LSGt (ATInt (ITFixed ty))) [x, y] = bitOp v "SGt" ty [x, y]
505doOp v (LLt (ITFixed ty)) [x, y] = bitOp v "Lt" ty [x, y]
506doOp v (LLe (ITFixed ty)) [x, y] = bitOp v "Lte" ty [x, y]
507doOp v (LGe (ITFixed ty)) [x, y] = bitOp v "Gte" ty [x, y]
508doOp v (LGt (ITFixed ty)) [x, y] = bitOp v "Gt" ty [x, y]
510doOp v (LSHL (ITFixed ty)) [x, y] = bitOp v "Shl" ty [x, y]
511doOp v (LLSHR (ITFixed ty)) [x, y] = bitOp v "LShr" ty [x, y]
512doOp v (LASHR (ITFixed ty)) [x, y] = bitOp v "AShr" ty [x, y]
513doOp v (LAnd (ITFixed ty)) [x, y] = bitOp v "And" ty [x, y]
514doOp v (LOr (ITFixed ty)) [x, y] = bitOp v "Or" ty [x, y]
515doOp v (LXOr (ITFixed ty)) [x, y] = bitOp v "Xor" ty [x, y]
516doOp v (LCompl (ITFixed ty)) [x] = bitOp v "Compl" ty [x]
518doOp v (LPlus (ATInt (ITFixed ty))) [x, y] = bitOp v "Plus" ty [x, y]
519doOp v (LMinus (ATInt (ITFixed ty))) [x, y] = bitOp v "Minus" ty [x, y]
520doOp v (LTimes (ATInt (ITFixed ty))) [x, y] = bitOp v "Times" ty [x, y]
521doOp v (LUDiv (ITFixed ty)) [x, y] = bitOp v "UDiv" ty [x, y]
522doOp v (LSDiv (ATInt (ITFixed ty))) [x, y] = bitOp v "SDiv" ty [x, y]
523doOp v (LURem (ITFixed ty)) [x, y] = bitOp v "URem" ty [x, y]
524doOp v (LSRem (ATInt (ITFixed ty))) [x, y] = bitOp v "SRem" ty [x, y]
526doOp v (LSExt (ITFixed from) ITBig) [x]
527 = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
528doOp v (LSExt ITNative (ITFixed to)) [x]
529 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
530doOp v (LSExt ITChar (ITFixed to)) [x]
531 = doOp v (LSExt ITNative (ITFixed to)) [x]
532doOp v (LSExt (ITFixed from) ITNative) [x]
533 = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ "))"
534doOp v (LSExt (ITFixed from) ITChar) [x]
535 = doOp v (LSExt (ITFixed from) ITNative) [x]
536doOp v (LSExt (ITFixed from) (ITFixed to)) [x]
537 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "S" from to x
538doOp v (LZExt ITNative (ITFixed to)) [x]
539 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
540doOp v (LZExt ITChar (ITFixed to)) [x]
541 = doOp v (LZExt ITNative (ITFixed to)) [x]
542doOp v (LZExt (ITFixed from) ITNative) [x]
543 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
544doOp v (LZExt (ITFixed from) ITChar) [x]
545 = doOp v (LZExt (ITFixed from) ITNative) [x]
546doOp v (LZExt (ITFixed from) ITBig) [x]
547 = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
548doOp v (LZExt ITNative ITBig) [x]
549 = v ++ "MKBIGUI(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
550doOp v (LZExt (ITFixed from) (ITFixed to)) [x]
551 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "Z" from to x
552doOp v (LTrunc ITNative (ITFixed to)) [x]
553 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
554doOp v (LTrunc ITChar (ITFixed to)) [x]
555 = doOp v (LTrunc ITNative (ITFixed to)) [x]
556doOp v (LTrunc (ITFixed from) ITNative) [x]
557 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
558doOp v (LTrunc (ITFixed from) ITChar) [x]
559 = doOp v (LTrunc (ITFixed from) ITNative) [x]
560doOp v (LTrunc ITBig (ITFixed IT64)) [x]
561 = v ++ "idris_b64const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : idris_truncBigB64(GETMPZ(" ++ creg x ++ ")))"
562doOp v (LTrunc ITBig (ITFixed to)) [x]
563 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"
564doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]
565 | nativeTyWidth from > nativeTyWidth to = bitCoerce v "T" from to x
567doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)
568doOp v LFLog [x] = v ++ flUnOp "log" (creg x)
569doOp v LFSin [x] = v ++ flUnOp "sin" (creg x)
570doOp v LFCos [x] = v ++ flUnOp "cos" (creg x)
571doOp v LFTan [x] = v ++ flUnOp "tan" (creg x)
572doOp v LFASin [x] = v ++ flUnOp "asin" (creg x)
573doOp v LFACos [x] = v ++ flUnOp "acos" (creg x)
574doOp v LFATan [x] = v ++ flUnOp "atan" (creg x)
575doOp v LFSqrt [x] = v ++ flUnOp "sqrt" (creg x)
576doOp v LFFloor [x] = v ++ flUnOp "floor" (creg x)
577doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x)
578doOp v LFNegate [x] = v ++ "MKFLOAT(vm, -GETFLOAT(" ++ (creg x) ++ "))"
580-- String functions which don't need to know we're UTF8
581doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
582doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
583doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
585doOp v LReadStr [_] = v ++ "idris_readStr(vm, stdin)"
586doOp v LWriteStr [_,s]
587 = v ++ "MKINT((i_int)(idris_writeStr(stdout"
588 ++ ",GETSTR("
589 ++ creg s ++ "))))"
592-- String functions which need to know we're UTF8
593doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"
594doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"
595doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")"
596doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")"
597doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")"
598doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"
599doOp v LStrSubstr [x,y,z] = v ++ "idris_substr(vm, " ++ creg x ++ "," ++ creg y ++ "," ++ creg z ++ ")"
601doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 0 "EVAL") ++ ", " ++ creg x ++ "))"
602doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
603doOp v (LChInt ITNative) args = v ++ creg (last args)
604doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args
605doOp v (LIntCh ITNative) args = v ++ creg (last args)
606doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args
608doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"
609doOp v LCrash [x] = "idris_crash(GETSTR(" ++ creg x ++ "))"
610doOp v LNoOp args = v ++ creg (last args)
612-- Pointer primitives (declared as %extern in Builtins.idr)
613doOp v (LExternal rf) [_,x]
614 | rf == sUN "prim__readFile"
615 = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"
616doOp v (LExternal rf) [_,len,x]
617 | rf == sUN "prim__readChars"
618 = v ++ "idris_readChars(vm, GETINT(" ++ creg len ++
619 "), GETPTR(" ++ creg x ++ "))"
620doOp v (LExternal wf) [_,x,s]
621 | wf == sUN "prim__writeFile"
622 = v ++ "MKINT((i_int)(idris_writeStr(GETPTR(" ++ creg x
623 ++ "),GETSTR("
624 ++ creg s ++ "))))"
625doOp v (LExternal si) [] | si == sUN "prim__stdin" = v ++ "MKPTR(vm, stdin)"
626doOp v (LExternal so) [] | so == sUN "prim__stdout" = v ++ "MKPTR(vm, stdout)"
627doOp v (LExternal se) [] | se == sUN "prim__stderr" = v ++ "MKPTR(vm, stderr)"
629doOp v (LExternal vm) [_] | vm == sUN "prim__vm" = v ++ "MKPTR(vm, vm)"
630doOp v (LExternal nul) [] | nul == sUN "prim__null" = v ++ "MKPTR(vm, NULL)"
631doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqPtr"
632 = v ++ "MKINT((i_int)(GETPTR(" ++ creg x ++ ") == GETPTR(" ++ creg y ++ ")))"
633doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqManagedPtr"
634 = v ++ "MKINT((i_int)(GETMPTR(" ++ creg x ++ ") == GETMPTR(" ++ creg y ++ ")))"
635doOp v (LExternal rp) [p, i] | rp == sUN "prim__registerPtr"
636 = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++ "), GETINT(" ++ creg i ++ "))"
637doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek8"
638 = v ++ "idris_peekB8(vm," ++ creg p ++ "," ++ creg o ++")"
639doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke8"
640 = v ++ "idris_pokeB8(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
641doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek16"
642 = v ++ "idris_peekB16(vm," ++ creg p ++ "," ++ creg o ++")"
643doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke16"
644 = v ++ "idris_pokeB16(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
645doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek32"
646 = v ++ "idris_peekB32(vm," ++ creg p ++ "," ++ creg o ++")"
647doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke32"
648 = v ++ "idris_pokeB32(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
649doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek64"
650 = v ++ "idris_peekB64(vm," ++ creg p ++ "," ++ creg o ++")"
651doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke64"
652 = v ++ "idris_pokeB64(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
653doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekPtr"
654 = v ++ "idris_peekPtr(vm," ++ creg p ++ "," ++ creg o ++")"
655doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokePtr"
656 = v ++ "idris_pokePtr(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
657doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokeDouble"
658 = v ++ "idris_pokeDouble(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
659doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekDouble"
660 = v ++ "idris_peekDouble(vm," ++ creg p ++ "," ++ creg o ++")"
661doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokeSingle"
662 = v ++ "idris_pokeSingle(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
663doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekSingle"
664 = v ++ "idris_peekSingle(vm," ++ creg p ++ "," ++ creg o ++")"
665doOp v (LExternal pk) [] | pk == sUN "prim__sizeofPtr"
666 = v ++ "MKINT(sizeof(void*))"
667doOp v (LExternal mpt) [p] | mpt == sUN "prim__asPtr"
668 = v ++ "MKPTR(vm, GETMPTR("++ creg p ++"))"
669doOp v (LExternal offs) [p, n] | offs == sUN "prim__ptrOffset"
670 = v ++ "MKPTR(vm, (void *)((char *)GETPTR(" ++ creg p ++ ") + GETINT(" ++ creg n ++ ")))"
671doOp _ op args = error $ "doOp not implemented (" ++ show (op, args) ++ ")"
674flUnOp :: String -> String -> String
675flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"
677-------------------- Interface file generation
679-- First, the wrappers in the C file
681ifaceC :: Export -> String
682ifaceC (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"
683ifaceC (ExportFun n cn ret args)
684 = ctype ret ++ " " ++ cdesc cn ++
685 "(VM* vm" ++ showArgs (zip argNames args) ++ ") {\n"
686 ++ mkBody n (zip argNames args) ret ++ "}\n\n"
687 where showArgs [] = ""
688 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++
689 showArgs ts
691 argNames = zipWith (++) (repeat "arg") (map show [0..])
693mkBody n as t = indent 1 ++ "INITFRAME;\n" ++
694 indent 1 ++ "RESERVE(" ++ show (max (length as) 3) ++ ");\n" ++
695 push 0 as ++ call n ++ retval t
696 where push i [] = ""
697 push i ((n, t) : ts) = indent 1 ++ c_irts (toFType t)
698 ("TOP(" ++ show i ++ ") = ") n
699 ++ ";\n" ++ push (i + 1) ts
701 call _ = indent 1 ++ "STOREOLD;\n" ++
702 indent 1 ++ "BASETOP(0);\n" ++
703 indent 1 ++ "ADDTOP(" ++ show (length as) ++ ");\n" ++
704 indent 1 ++ "CALL(" ++ cname n ++ ");\n"
706 retval (FIO t)
707 = indent 1 ++ "TOP(0) = NULL;\n" ++
708 indent 1 ++ "TOP(1) = NULL;\n" ++
709 indent 1 ++ "TOP(2) = RVAL;\n" ++
710 indent 1 ++ "STOREOLD;\n" ++
711 indent 1 ++ "BASETOP(0);\n" ++
712 indent 1 ++ "ADDTOP(3);\n" ++
713 indent 1 ++ "CALL(" ++ cname (sUN "call__IO") ++ ");\n" ++
714 retval t
715 retval t = indent 1 ++ "return " ++ irts_c (toFType t) "RVAL" ++ ";\n"
717ctype (FCon c)
718 | c == sUN "C_Str" = "char*"
719 | c == sUN "C_Float" = "float"
720 | c == sUN "C_Ptr" = "void*"
721 | c == sUN "C_MPtr" = "void*"
722 | c == sUN "C_Unit" = "void"
723ctype (FApp c [_,ity])
724 | c == sUN "C_IntT" = carith ity
725ctype (FApp c [_])
726 | c == sUN "C_Any" = "VAL"
727ctype (FStr s) = s
728ctype FUnknown = "void*"
729ctype (FIO t) = ctype t
730ctype t = error "Can't happen: Not a valid interface type " ++ show t
732carith (FCon i)
733 | i == sUN "C_IntChar" = "char"
734 | i == sUN "C_IntNative" = "int"
735 | i == sUN "C_IntBits8" = "uint8_t"
736 | i == sUN "C_IntBits16" = "uint16_t"
737 | i == sUN "C_IntBits32" = "uint32_t"
738 | i == sUN "C_IntBits64" = "uint64_t"
739carith t = error $ "Can't happen: Not an exportable arithmetic type " ++ show t
741cdesc (FStr s) = s
742cdesc s = error "Can't happen: Not a valid C name"
744-- Then, the header files
746codegenH :: [ExportIFace] -> IO ()
747codegenH es = mapM_ writeIFace es
749writeIFace :: ExportIFace -> IO ()
750writeIFace (Export ffic hdr exps)
751 | ffic == sNS (sUN "FFI_C") ["FFI_C"]
752 = do let hfile = "#ifndef " ++ hdr_guard hdr ++ "\n" ++
753 "#define " ++ hdr_guard hdr ++ "\n\n" ++
754 "#include <idris_rts.h>\n\n" ++
755 concatMap hdr_export exps ++ "\n" ++
756 "#endif\n\n"
757 writeFile hdr hfile
758 | otherwise = return ()
760hdr_guard x = "__" ++ map hchar x
761 where hchar x | isAlphaNum x = toUpper x
762 hchar _ = '_'
764hdr_export :: Export -> String
765hdr_export (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"
766hdr_export (ExportFun n cn ret args)
767 = ctype ret ++ " " ++ cdesc cn ++
768 "(VM* vm" ++ showArgs (zip argNames args) ++ ");\n"
769 where showArgs [] = ""
770 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++
771 showArgs ts
773 argNames = zipWith (++) (repeat "arg") (map show [0..])
775------------------ Callback wrapper generation ----------------
776-- Generate callback wrappers and a function to select the
777-- correct wrapper function to pass.
778-- TODO: This is limited to functions that are specified in
779-- the foreign call. Otherwise we would have to generate wrappers for all
780-- functions with correct arity or do flow analysis
781-- to find all possible inputs to the foreign call.
782genWrappers :: [(Name, [BC])] -> String
783genWrappers bcs = let
784 tags = nubBy (\x y -> snd x == snd y) $ concatMap (getCallback . snd) bcs
785 in
786 case tags of
787 [] -> ""
788 t -> concatMap genWrapper t ++ genDispatcher t
790genDispatcher :: [(FDesc, Int)] -> String
791genDispatcher tags = "void* _idris_get_wrapper(VAL con)\n" ++
792 "{\n" ++
793 indent 1 ++ "switch(TAG(con)) {\n" ++
794 concatMap makeSwitch tags ++
795 indent 1 ++ "}\n" ++
796 indent 1 ++ "fprintf(stderr, \"No wrapper for callback\");\n" ++
797 indent 1 ++ "exit(-1);\n" ++
798 "}\n\n"
799 where
800 makeSwitch (_, tag) =
801 indent 1 ++ "case " ++ show tag ++ ":\n" ++
802 indent 2 ++ "return (void*) &" ++ wrapperName tag ++ ";\n"
804genWrapper :: (FDesc, Int) -> String
805genWrapper (desc, tag) | (toFType desc) == FFunctionIO =
806 error "Cannot create C callbacks for IO functions, wrap them with unsafePerformIO.\n"
807genWrapper (desc, tag) = ret ++ " " ++ wrapperName tag ++ "(" ++
808 renderArgs argList ++")\n" ++
809 "{\n" ++
810 (if ret /= "void" then indent 1 ++ ret ++ " ret;\n" else "") ++
811 indent 1 ++ "VM* vm = get_vm();\n" ++
812 indent 1 ++ "if (vm == NULL) {\n" ++
813 indent 2 ++ "vm = idris_vm();\n" ++
814 indent 1 ++ "}\n" ++
815 indent 1 ++ "INITFRAME;\n" ++
816 indent 1 ++ "RESERVE(" ++ show (len + 1) ++ ");\n" ++
817 indent 1 ++ "allocCon(REG1, vm, " ++ show tag ++ ",0 , 0);\n" ++
818 indent 1 ++ "TOP(0) = REG1;\n" ++
819 applyArgs argList ++
820 if ret /= "void"
821 then indent 1 ++ "ret = " ++ irts_c (toFType ft) "RVAL" ++ ";\n"
822 ++ indent 1 ++ "return ret;\n}\n\n"
823 else "}\n\n"
824 where
825 (ret, ft) = rty desc
826 argList = zip (args desc) [0..]
827 len = length argList
829 applyArgs (x:y:xs) = push 1 [x] ++
830 indent 1 ++ "STOREOLD;\n" ++
831 indent 1 ++ "BASETOP(0);\n" ++
832 indent 1 ++ "ADDTOP(2);\n" ++
833 indent 1 ++ "CALL(_idris__123_APPLY_95_0_125_);\n" ++
834 indent 1 ++ "TOP(0)=REG1;\n" ++
835 applyArgs (y:xs)
836 applyArgs x = push 1 x ++
837 indent 1 ++ "STOREOLD;\n" ++
838 indent 1 ++ "BASETOP(0);\n" ++
839 indent 1 ++ "ADDTOP(" ++ show (length x + 1) ++ ");\n" ++
840 indent 1 ++ "CALL(_idris__123_APPLY_95_0_125_);\n"
841 renderArgs [] = "void"
842 renderArgs [((s, _), n)] = s ++ " a" ++ (show n)
843 renderArgs (((s, _), n):xs) = s ++ " a" ++ (show n) ++ ", " ++
844 renderArgs xs
845 rty (FApp c [_,ty])
846 | c == sUN "C_FnBase" = (ctype ty, ty)
847 | c == sUN "C_FnIO" = (ctype ty, ty)
848 | c == sUN "C_FnT" = rty ty
849 rty (FApp c [_,_,ty,fn])
850 | c == sUN "C_Fn" = rty fn
851 rty x = ("", x)
852 args (FApp c [_,ty])
853 | c == sUN "C_FnBase" = []
854 | c == sUN "C_FnIO" = []
855 | c == sUN "C_FnT" = args ty
856 args (FApp c [_,_,ty,fn])
857 | toFType ty == FUnit = []
858 | c == sUN "C_Fn" = (ctype ty, ty) : args fn
859 args _ = []
860 push i [] = ""
861 push i (((c, t), n) : ts) = indent 1 ++ c_irts (toFType t)
862 ("TOP(" ++ show i ++ ") = ") ("a" ++ show n)
863 ++ ";\n" ++ push (i + 1) ts
865wrapperName :: Int -> String
866wrapperName tag = "_idris_wrapper_" ++ show tag
868getCallback :: [BC] -> [(FDesc, Int)]
869getCallback bc = getCallback' (reverse bc)
870 where
871 getCallback' (x:xs) = case hasCallback x of
872 [] -> getCallback' xs
873 cbs -> case findCons cbs xs of
874 [] -> error "Idris function couldn't be wrapped."
875 x -> x
876 getCallback' [] = []
877 findCons (c:cs) xs = findCon c xs ++ findCons cs xs
878 findCons [] _ = []
879 findCon c ((MKCON l loc tag args):xs) | snd c == l = [(fst c, tag)]
880 findCon c (_:xs) = findCon c xs
881 findCon c [] = []
883hasCallback :: BC -> [(FDesc, Reg)]
884hasCallback (FOREIGNCALL l rty (FStr fn) args) = filter isFn args
885 where
886 isFn (desc,_) = case toFType desc of
887 FFunction -> True
888 FFunctionIO -> True
889 _ -> False
890hasCallback _ = []