git.iko.soy/Idris-dev
on bd8ea0a help sign in
Idris-dev/src/IRTS/CodegenC.hs
888 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) | i < (2^30) = "MKINT(" ++ show i ++ ")"
183 | otherwise = "MKBIGC(vm,\"" ++ show i ++ "\")"
184 mkConst (Fl f) = "MKFLOAT(vm, " ++ (map toUpper $ show f) ++ ")"
185 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"
186 mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"
187 mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ "U)"
188 mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"
189 mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"
190 mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"
191 -- if it's a type constant, we won't use it, but equally it shouldn't
192 -- report an error. These might creep into generated for various reasons
193 -- (especially if erasure is disabled).
194 mkConst c | isTypeConst c = "MKINT(42424242)"
195 mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"
197bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
198bcc i (MKCON l loc tag []) | tag < 256
199 = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"
200bcc i (MKCON l loc tag args)
201 = indent i ++ alloc loc tag ++
202 indent i ++ setArgs 0 args ++ "\n" ++
203 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"
204 where setArgs i [] = ""
205 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++
206 "); " ++ setArgs (i + 1) xs
207 alloc Nothing tag
208 = "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ ", " ++
209 show (length args) ++ ", 0);\n"
210 alloc (Just old) tag
211 = "updateCon(" ++ creg Tmp ++ ", " ++ creg old ++ ", " ++ show tag ++ ", " ++
212 show (length args) ++ ");\n"
214bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++
215 ", " ++ show a ++ ");\n"
216bcc i (PROJECTINTO r t idx)
217 = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"
218bcc i (CASE True r code def)
219 | length code < 4 = showCase i def code
220 where
221 showCode :: Int -> [BC] -> String
222 showCode i bc = "{\n" ++ concatMap (bcc (i + 1)) bc ++
223 indent i ++ "}\n"
225 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String
226 showCase i Nothing [(t, c)] = indent i ++ showCode i c
227 showCase i (Just def) [] = indent i ++ showCode i def
228 showCase i def ((t, c) : cs)
229 = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c
230 ++ indent i ++ "else\n" ++ showCase i def cs
232bcc i (CASE safe r code def)
233 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++
234 concatMap (showCase i) code ++
235 showDef i def ++
236 indent i ++ "}\n"
237 where
238 ctag True = "CTAG"
239 ctag False = "TAG"
241 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
242 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"
243 showDef i Nothing = ""
244 showDef i (Just c) = indent i ++ "default:\n"
245 ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"
246bcc i (CONSTCASE r code def)
247 | intConsts code
248-- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++
249-- concatMap (showCase i) code ++
250-- showDef i def ++
251-- indent i ++ "}\n"
252 = concatMap (iCase (creg r)) code ++
253 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
254 | strConsts code
255 = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++
256 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
257 | bigintConsts code
258 = concatMap (biCase (creg r)) code ++
259 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
260 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code
261 where
262 intConsts ((I _, _ ) : _) = True
263 intConsts ((Ch _, _ ) : _) = True
264 intConsts ((B8 _, _ ) : _) = True
265 intConsts ((B16 _, _ ) : _) = True
266 intConsts ((B32 _, _ ) : _) = True
267 intConsts ((B64 _, _ ) : _) = True
268 intConsts _ = False
270 bigintConsts ((BI _, _ ) : _) = True
271 bigintConsts _ = False
273 strConsts ((Str _, _ ) : _) = True
274 strConsts _ = False
276 strCase sv (s, bc) =
277 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++
278 concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
279 biCase bv (BI b, bc) =
280 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"
281 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
282 iCase v (I b, bc) =
283 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"
284 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
285 iCase v (Ch b, bc) =
286 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n"
287 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
288 iCase v (B8 w, bc) =
289 indent i ++ "if (GETBITS8(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
290 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
291 iCase v (B16 w, bc) =
292 indent i ++ "if (GETBITS16(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
293 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
294 iCase v (B32 w, bc) =
295 indent i ++ "if (GETBITS32(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
296 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
297 iCase v (B64 w, bc) =
298 indent i ++ "if (GETBITS64(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
299 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
300 showDefS i Nothing = ""
301 showDefS i (Just c) = concatMap (bcc (i+1)) c
303bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"
304bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"
305bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"
306bcc i REBASE = indent i ++ "REBASE;\n"
307bcc i (RESERVE 0) = ""
308bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"
309bcc i (ADDTOP 0) = ""
310bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"
311bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
312bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
313bcc i STOREOLD = indent i ++ "STOREOLD;\n"
314bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"
315bcc i (FOREIGNCALL l rty (FStr fn@('&':name)) [])
316 = indent i ++
317 c_irts (toFType rty) (creg l ++ " = ") fn ++ ";\n"
318bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%wrapper"
319 = indent i ++
320 c_irts (toFType rty) (creg l ++ " = ")
321 ("_idris_get_wrapper(" ++ creg (snd x) ++ ")") ++ ";\n"
322bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%dynamic"
323 = indent i ++ c_irts (toFType rty) (creg l ++ " = ")
324 ("(*(" ++ cFnSig "" rty xs ++ ") GETPTR(" ++ creg (snd x) ++ "))" ++
325 "(" ++ showSep "," (map fcall xs) ++ ")") ++ ";\n"
326bcc i (FOREIGNCALL l rty (FStr fn) args)
327 = indent i ++
328 c_irts (toFType rty) (creg l ++ " = ")
329 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
330bcc i (FOREIGNCALL l rty _ args) = error "Foreign Function calls cannot be partially applied, without being inlined."
331bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed
332bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"
333-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"
335fcall (t, arg) = irts_c (toFType t) (creg arg)
336-- Deconstruct the Foreign type in the defunctionalised expression and build
337-- a foreign type description for c_irts and irts_c
338toAType (FCon i)
339 | i == sUN "C_IntChar" = ATInt ITChar
340 | i == sUN "C_IntNative" = ATInt ITNative
341 | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)
342 | i == sUN "C_IntBits16" = ATInt (ITFixed IT16)
343 | i == sUN "C_IntBits32" = ATInt (ITFixed IT32)
344 | i == sUN "C_IntBits64" = ATInt (ITFixed IT64)
345toAType t = error (show t ++ " not defined in toAType")
347toFType (FCon c)
348 | c == sUN "C_Str" = FString
349 | c == sUN "C_Float" = FArith ATFloat
350 | c == sUN "C_Ptr" = FPtr
351 | c == sUN "C_MPtr" = FManagedPtr
352 | c == sUN "C_CData" = FCData
353 | c == sUN "C_Unit" = FUnit
354toFType (FApp c [_,ity])
355 | c == sUN "C_IntT" = FArith (toAType ity)
356 | c == sUN "C_FnT" = toFunType ity
357toFType (FApp c [_])
358 | c == sUN "C_Any" = FAny
359toFType t = FAny
361toFunType (FApp c [_,ity])
362 | c == sUN "C_FnBase" = FFunction
363 | c == sUN "C_FnIO" = FFunctionIO
364toFunType (FApp c [_,_,_,ity])
365 | c == sUN "C_Fn" = toFunType ity
366toFunType _ = FAny
368c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
369c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x
370c_irts (FArith (ATInt (ITFixed ity))) l x
371 = l ++ "idris_b" ++ show (nativeTyWidth ity) ++ "const(vm, " ++ x ++ ")"
372c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"
373c_irts FUnit l x = x
374c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"
375c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"
376c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"
377c_irts FCData l x = l ++ "MKCDATA(vm, " ++ x ++ ")"
378c_irts FAny l x = l ++ x
379c_irts FFunction l x = error "Return of function from foreign call is not supported"
380c_irts FFunctionIO l x = error "Return of function from foreign call is not supported"
382irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"
383irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x
384irts_c (FArith (ATInt (ITFixed ity))) x
385 = "(" ++ x ++ "->info.bits" ++ show (nativeTyWidth ity) ++ ")"
386irts_c FString x = "GETSTR(" ++ x ++ ")"
387irts_c FUnit x = x
388irts_c FPtr x = "GETPTR(" ++ x ++ ")"
389irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"
390irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"
391irts_c FCData x = "GETCDATA(" ++ x ++ ")"
392irts_c FAny x = x
393irts_c FFunctionIO x = wrapped x
394irts_c FFunction x = wrapped x
396cFnSig name rty [] = ctype rty ++ " (*" ++ name ++ ")(void) "
397cFnSig name rty args = ctype rty ++ " (*" ++ name ++ ")("
398 ++ showSep "," (map (ctype . fst) args) ++ ") "
400wrapped x = "_idris_get_wrapper(" ++ x ++ ")"
402bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"
404bitCoerce v op input output arg
405 = v ++ "idris_b" ++ show (nativeTyWidth input) ++ op ++ show (nativeTyWidth output) ++ "(vm, " ++ creg arg ++ ")"
407signedTy :: NativeTy -> String
408signedTy t = "int" ++ show (nativeTyWidth t) ++ "_t"
410doOp v (LPlus (ATInt ITNative)) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"
411doOp v (LMinus (ATInt ITNative)) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
412doOp v (LTimes (ATInt ITNative)) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"
413doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
414doOp v (LSDiv (ATInt ITNative)) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
415doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
416doOp v (LSRem (ATInt ITNative)) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
417doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"
418doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"
419doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"
420doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"
421doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
422doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
423doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"
424doOp v (LEq (ATInt ITNative)) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
425doOp v (LSLt (ATInt ITNative)) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
426doOp v (LSLe (ATInt ITNative)) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
427doOp v (LSGt (ATInt ITNative)) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
428doOp v (LSGe (ATInt ITNative)) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
429doOp v (LLt ITNative) [l, r] = v ++ "UINTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
430doOp v (LLe ITNative) [l, r] = v ++ "UINTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
431doOp v (LGt ITNative) [l, r] = v ++ "UINTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
432doOp v (LGe ITNative) [l, r] = v ++ "UINTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
434doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r]
435doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r]
436doOp v (LTimes (ATInt ITChar)) [l, r] = doOp v (LTimes (ATInt ITNative)) [l, r]
437doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r]
438doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r]
439doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r]
440doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r]
441doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r]
442doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r]
443doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r]
444doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r]
445doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r]
446doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r]
447doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x]
448doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r]
449doOp v (LSLt (ATInt ITChar)) [l, r] = doOp v (LSLt (ATInt ITNative)) [l, r]
450doOp v (LSLe (ATInt ITChar)) [l, r] = doOp v (LSLe (ATInt ITNative)) [l, r]
451doOp v (LSGt (ATInt ITChar)) [l, r] = doOp v (LSGt (ATInt ITNative)) [l, r]
452doOp v (LSGe (ATInt ITChar)) [l, r] = doOp v (LSGe (ATInt ITNative)) [l, r]
453doOp v (LLt ITChar) [l, r] = doOp v (LLt ITNative) [l, r]
454doOp v (LLe ITChar) [l, r] = doOp v (LLe ITNative) [l, r]
455doOp v (LGt ITChar) [l, r] = doOp v (LGt ITNative) [l, r]
456doOp v (LGe ITChar) [l, r] = doOp v (LGe ITNative) [l, r]
458doOp v (LPlus ATFloat) [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"
459doOp v (LMinus ATFloat) [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
460doOp v (LTimes ATFloat) [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"
461doOp v (LSDiv ATFloat) [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
462doOp v (LEq ATFloat) [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
463doOp v (LSLt ATFloat) [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
464doOp v (LSLe ATFloat) [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
465doOp v (LSGt ATFloat) [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
466doOp v (LSGe ATFloat) [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
468doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"
469doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"
470doOp v (LPlus (ATInt ITBig)) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
471doOp v (LMinus (ATInt ITBig)) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
472doOp v (LTimes (ATInt ITBig)) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
473doOp v (LSDiv (ATInt ITBig)) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
474doOp v (LSRem (ATInt ITBig)) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
475doOp v (LAnd ITBig) [l, r] = v ++ "idris_bigAnd(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
476doOp v (LOr ITBig) [l, r] = v ++ "idris_bigOr(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
477doOp v (LSHL ITBig) [l, r] = v ++ "idris_bigShiftLeft(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
478doOp v (LLSHR ITBig) [l, r] = v ++ "idris_bigLShiftRight(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
479doOp v (LASHR ITBig) [l, r] = v ++ "idris_bigAShiftRight(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
480doOp v (LEq (ATInt ITBig)) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
481doOp v (LSLt (ATInt ITBig)) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
482doOp v (LSLe (ATInt ITBig)) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
483doOp v (LSGt (ATInt ITBig)) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
484doOp v (LSGe (ATInt ITBig)) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
486doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"
487doOp v (LFloatInt ITNative) [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"
488doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"
489doOp v (LTrunc ITBig ITNative) [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"
490doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"
491doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"
492doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"
493doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"
494doOp v (LIntStr (ITFixed _)) [x] = v ++ "idris_castBitsStr(vm, " ++ creg x ++ ")"
495doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"
496doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"
498doOp v (LSLt (ATInt (ITFixed ty))) [x, y] = bitOp v "SLt" ty [x, y]
499doOp v (LSLe (ATInt (ITFixed ty))) [x, y] = bitOp v "SLte" ty [x, y]
500doOp v (LEq (ATInt (ITFixed ty))) [x, y] = bitOp v "Eq" ty [x, y]
501doOp v (LSGe (ATInt (ITFixed ty))) [x, y] = bitOp v "SGte" ty [x, y]
502doOp v (LSGt (ATInt (ITFixed ty))) [x, y] = bitOp v "SGt" ty [x, y]
503doOp v (LLt (ITFixed ty)) [x, y] = bitOp v "Lt" ty [x, y]
504doOp v (LLe (ITFixed ty)) [x, y] = bitOp v "Lte" ty [x, y]
505doOp v (LGe (ITFixed ty)) [x, y] = bitOp v "Gte" ty [x, y]
506doOp v (LGt (ITFixed ty)) [x, y] = bitOp v "Gt" ty [x, y]
508doOp v (LSHL (ITFixed ty)) [x, y] = bitOp v "Shl" ty [x, y]
509doOp v (LLSHR (ITFixed ty)) [x, y] = bitOp v "LShr" ty [x, y]
510doOp v (LASHR (ITFixed ty)) [x, y] = bitOp v "AShr" ty [x, y]
511doOp v (LAnd (ITFixed ty)) [x, y] = bitOp v "And" ty [x, y]
512doOp v (LOr (ITFixed ty)) [x, y] = bitOp v "Or" ty [x, y]
513doOp v (LXOr (ITFixed ty)) [x, y] = bitOp v "Xor" ty [x, y]
514doOp v (LCompl (ITFixed ty)) [x] = bitOp v "Compl" ty [x]
516doOp v (LPlus (ATInt (ITFixed ty))) [x, y] = bitOp v "Plus" ty [x, y]
517doOp v (LMinus (ATInt (ITFixed ty))) [x, y] = bitOp v "Minus" ty [x, y]
518doOp v (LTimes (ATInt (ITFixed ty))) [x, y] = bitOp v "Times" ty [x, y]
519doOp v (LUDiv (ITFixed ty)) [x, y] = bitOp v "UDiv" ty [x, y]
520doOp v (LSDiv (ATInt (ITFixed ty))) [x, y] = bitOp v "SDiv" ty [x, y]
521doOp v (LURem (ITFixed ty)) [x, y] = bitOp v "URem" ty [x, y]
522doOp v (LSRem (ATInt (ITFixed ty))) [x, y] = bitOp v "SRem" ty [x, y]
524doOp v (LSExt (ITFixed from) ITBig) [x]
525 = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
526doOp v (LSExt ITNative (ITFixed to)) [x]
527 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
528doOp v (LSExt ITChar (ITFixed to)) [x]
529 = doOp v (LSExt ITNative (ITFixed to)) [x]
530doOp v (LSExt (ITFixed from) ITNative) [x]
531 = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ "))"
532doOp v (LSExt (ITFixed from) ITChar) [x]
533 = doOp v (LSExt (ITFixed from) ITNative) [x]
534doOp v (LSExt (ITFixed from) (ITFixed to)) [x]
535 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "S" from to x
536doOp v (LZExt ITNative (ITFixed to)) [x]
537 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
538doOp v (LZExt ITChar (ITFixed to)) [x]
539 = doOp v (LZExt ITNative (ITFixed to)) [x]
540doOp v (LZExt (ITFixed from) ITNative) [x]
541 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
542doOp v (LZExt (ITFixed from) ITChar) [x]
543 = doOp v (LZExt (ITFixed from) ITNative) [x]
544doOp v (LZExt (ITFixed from) ITBig) [x]
545 = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
546doOp v (LZExt ITNative ITBig) [x]
547 = v ++ "MKBIGUI(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
548doOp v (LZExt (ITFixed from) (ITFixed to)) [x]
549 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "Z" from to x
550doOp v (LTrunc ITNative (ITFixed to)) [x]
551 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
552doOp v (LTrunc ITChar (ITFixed to)) [x]
553 = doOp v (LTrunc ITNative (ITFixed to)) [x]
554doOp v (LTrunc (ITFixed from) ITNative) [x]
555 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
556doOp v (LTrunc (ITFixed from) ITChar) [x]
557 = doOp v (LTrunc (ITFixed from) ITNative) [x]
558doOp v (LTrunc ITBig (ITFixed IT64)) [x]
559 = v ++ "idris_b64const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : idris_truncBigB64(GETMPZ(" ++ creg x ++ ")))"
560doOp v (LTrunc ITBig (ITFixed to)) [x]
561 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"
562doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]
563 | nativeTyWidth from > nativeTyWidth to = bitCoerce v "T" from to x
565doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)
566doOp v LFLog [x] = v ++ flUnOp "log" (creg x)
567doOp v LFSin [x] = v ++ flUnOp "sin" (creg x)
568doOp v LFCos [x] = v ++ flUnOp "cos" (creg x)
569doOp v LFTan [x] = v ++ flUnOp "tan" (creg x)
570doOp v LFASin [x] = v ++ flUnOp "asin" (creg x)
571doOp v LFACos [x] = v ++ flUnOp "acos" (creg x)
572doOp v LFATan [x] = v ++ flUnOp "atan" (creg x)
573doOp v LFSqrt [x] = v ++ flUnOp "sqrt" (creg x)
574doOp v LFFloor [x] = v ++ flUnOp "floor" (creg x)
575doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x)
576doOp v LFNegate [x] = v ++ "MKFLOAT(vm, -GETFLOAT(" ++ (creg x) ++ "))"
578-- String functions which don't need to know we're UTF8
579doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
580doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
581doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
583doOp v LReadStr [_] = v ++ "idris_readStr(vm, stdin)"
584doOp v LWriteStr [_,s]
585 = v ++ "MKINT((i_int)(idris_writeStr(stdout"
586 ++ ",GETSTR("
587 ++ creg s ++ "))))"
590-- String functions which need to know we're UTF8
591doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"
592doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"
593doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")"
594doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")"
595doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")"
596doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"
597doOp v LStrSubstr [x,y,z] = v ++ "idris_substr(vm, " ++ creg x ++ "," ++ creg y ++ "," ++ creg z ++ ")"
599doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 0 "EVAL") ++ ", " ++ creg x ++ "))"
600doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
601doOp v (LChInt ITNative) args = v ++ creg (last args)
602doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args
603doOp v (LIntCh ITNative) args = v ++ creg (last args)
604doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args
606doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"
607doOp v LCrash [x] = "idris_crash(GETSTR(" ++ creg x ++ "))"
608doOp v LNoOp args = v ++ creg (last args)
610-- Pointer primitives (declared as %extern in Builtins.idr)
611doOp v (LExternal rf) [_,x]
612 | rf == sUN "prim__readFile"
613 = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"
614doOp v (LExternal rf) [_,len,x]
615 | rf == sUN "prim__readChars"
616 = v ++ "idris_readChars(vm, GETINT(" ++ creg len ++
617 "), GETPTR(" ++ creg x ++ "))"
618doOp v (LExternal wf) [_,x,s]
619 | wf == sUN "prim__writeFile"
620 = v ++ "MKINT((i_int)(idris_writeStr(GETPTR(" ++ creg x
621 ++ "),GETSTR("
622 ++ creg s ++ "))))"
623doOp v (LExternal si) [] | si == sUN "prim__stdin" = v ++ "MKPTR(vm, stdin)"
624doOp v (LExternal so) [] | so == sUN "prim__stdout" = v ++ "MKPTR(vm, stdout)"
625doOp v (LExternal se) [] | se == sUN "prim__stderr" = v ++ "MKPTR(vm, stderr)"
627doOp v (LExternal vm) [_] | vm == sUN "prim__vm" = v ++ "MKPTR(vm, vm)"
628doOp v (LExternal nul) [] | nul == sUN "prim__null" = v ++ "MKPTR(vm, NULL)"
629doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqPtr"
630 = v ++ "MKINT((i_int)(GETPTR(" ++ creg x ++ ") == GETPTR(" ++ creg y ++ ")))"
631doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqManagedPtr"
632 = v ++ "MKINT((i_int)(GETMPTR(" ++ creg x ++ ") == GETMPTR(" ++ creg y ++ ")))"
633doOp v (LExternal rp) [p, i] | rp == sUN "prim__registerPtr"
634 = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++ "), GETINT(" ++ creg i ++ "))"
635doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek8"
636 = v ++ "idris_peekB8(vm," ++ creg p ++ "," ++ creg o ++")"
637doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke8"
638 = v ++ "idris_pokeB8(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
639doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek16"
640 = v ++ "idris_peekB16(vm," ++ creg p ++ "," ++ creg o ++")"
641doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke16"
642 = v ++ "idris_pokeB16(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
643doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek32"
644 = v ++ "idris_peekB32(vm," ++ creg p ++ "," ++ creg o ++")"
645doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke32"
646 = v ++ "idris_pokeB32(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
647doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek64"
648 = v ++ "idris_peekB64(vm," ++ creg p ++ "," ++ creg o ++")"
649doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke64"
650 = v ++ "idris_pokeB64(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
651doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekPtr"
652 = v ++ "idris_peekPtr(vm," ++ creg p ++ "," ++ creg o ++")"
653doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokePtr"
654 = v ++ "idris_pokePtr(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
655doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokeDouble"
656 = v ++ "idris_pokeDouble(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
657doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekDouble"
658 = v ++ "idris_peekDouble(vm," ++ creg p ++ "," ++ creg o ++")"
659doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokeSingle"
660 = v ++ "idris_pokeSingle(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
661doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekSingle"
662 = v ++ "idris_peekSingle(vm," ++ creg p ++ "," ++ creg o ++")"
663doOp v (LExternal pk) [] | pk == sUN "prim__sizeofPtr"
664 = v ++ "MKINT(sizeof(void*))"
665doOp v (LExternal mpt) [p] | mpt == sUN "prim__asPtr"
666 = v ++ "MKPTR(vm, GETMPTR("++ creg p ++"))"
667doOp v (LExternal offs) [p, n] | offs == sUN "prim__ptrOffset"
668 = v ++ "MKPTR(vm, (void *)((char *)GETPTR(" ++ creg p ++ ") + GETINT(" ++ creg n ++ ")))"
669doOp _ op args = error $ "doOp not implemented (" ++ show (op, args) ++ ")"
672flUnOp :: String -> String -> String
673flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"
675-------------------- Interface file generation
677-- First, the wrappers in the C file
679ifaceC :: Export -> String
680ifaceC (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"
681ifaceC (ExportFun n cn ret args)
682 = ctype ret ++ " " ++ cdesc cn ++
683 "(VM* vm" ++ showArgs (zip argNames args) ++ ") {\n"
684 ++ mkBody n (zip argNames args) ret ++ "}\n\n"
685 where showArgs [] = ""
686 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++
687 showArgs ts
689 argNames = zipWith (++) (repeat "arg") (map show [0..])
691mkBody n as t = indent 1 ++ "INITFRAME;\n" ++
692 indent 1 ++ "RESERVE(" ++ show (max (length as) 3) ++ ");\n" ++
693 push 0 as ++ call n ++ retval t
694 where push i [] = ""
695 push i ((n, t) : ts) = indent 1 ++ c_irts (toFType t)
696 ("TOP(" ++ show i ++ ") = ") n
697 ++ ";\n" ++ push (i + 1) ts
699 call _ = indent 1 ++ "STOREOLD;\n" ++
700 indent 1 ++ "BASETOP(0);\n" ++
701 indent 1 ++ "ADDTOP(" ++ show (length as) ++ ");\n" ++
702 indent 1 ++ "CALL(" ++ cname n ++ ");\n"
704 retval (FIO t)
705 = indent 1 ++ "TOP(0) = NULL;\n" ++
706 indent 1 ++ "TOP(1) = NULL;\n" ++
707 indent 1 ++ "TOP(2) = RVAL;\n" ++
708 indent 1 ++ "STOREOLD;\n" ++
709 indent 1 ++ "BASETOP(0);\n" ++
710 indent 1 ++ "ADDTOP(3);\n" ++
711 indent 1 ++ "CALL(" ++ cname (sUN "call__IO") ++ ");\n" ++
712 retval t
713 retval t = indent 1 ++ "return " ++ irts_c (toFType t) "RVAL" ++ ";\n"
715ctype (FCon c)
716 | c == sUN "C_Str" = "char*"
717 | c == sUN "C_Float" = "float"
718 | c == sUN "C_Ptr" = "void*"
719 | c == sUN "C_MPtr" = "void*"
720 | c == sUN "C_Unit" = "void"
721ctype (FApp c [_,ity])
722 | c == sUN "C_IntT" = carith ity
723ctype (FApp c [_])
724 | c == sUN "C_Any" = "VAL"
725ctype (FStr s) = s
726ctype FUnknown = "void*"
727ctype (FIO t) = ctype t
728ctype t = error "Can't happen: Not a valid interface type " ++ show t
730carith (FCon i)
731 | i == sUN "C_IntChar" = "char"
732 | i == sUN "C_IntNative" = "int"
733 | i == sUN "C_IntBits8" = "uint8_t"
734 | i == sUN "C_IntBits16" = "uint16_t"
735 | i == sUN "C_IntBits32" = "uint32_t"
736 | i == sUN "C_IntBits64" = "uint64_t"
737carith t = error $ "Can't happen: Not an exportable arithmetic type " ++ show t
739cdesc (FStr s) = s
740cdesc s = error "Can't happen: Not a valid C name"
742-- Then, the header files
744codegenH :: [ExportIFace] -> IO ()
745codegenH es = mapM_ writeIFace es
747writeIFace :: ExportIFace -> IO ()
748writeIFace (Export ffic hdr exps)
749 | ffic == sNS (sUN "FFI_C") ["FFI_C"]
750 = do let hfile = "#ifndef " ++ hdr_guard hdr ++ "\n" ++
751 "#define " ++ hdr_guard hdr ++ "\n\n" ++
752 "#include <idris_rts.h>\n\n" ++
753 concatMap hdr_export exps ++ "\n" ++
754 "#endif\n\n"
755 writeFile hdr hfile
756 | otherwise = return ()
758hdr_guard x = "__" ++ map hchar x
759 where hchar x | isAlphaNum x = toUpper x
760 hchar _ = '_'
762hdr_export :: Export -> String
763hdr_export (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"
764hdr_export (ExportFun n cn ret args)
765 = ctype ret ++ " " ++ cdesc cn ++
766 "(VM* vm" ++ showArgs (zip argNames args) ++ ");\n"
767 where showArgs [] = ""
768 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++
769 showArgs ts
771 argNames = zipWith (++) (repeat "arg") (map show [0..])
773------------------ Callback wrapper generation ----------------
774-- Generate callback wrappers and a function to select the
775-- correct wrapper function to pass.
776-- TODO: This is limited to functions that are specified in
777-- the foreign call. Otherwise we would have to generate wrappers for all
778-- functions with correct arity or do flow analysis
779-- to find all possible inputs to the foreign call.
780genWrappers :: [(Name, [BC])] -> String
781genWrappers bcs = let
782 tags = nubBy (\x y -> snd x == snd y) $ concatMap (getCallback . snd) bcs
783 in
784 case tags of
785 [] -> ""
786 t -> concatMap genWrapper t ++ genDispatcher t
788genDispatcher :: [(FDesc, Int)] -> String
789genDispatcher tags = "void* _idris_get_wrapper(VAL con)\n" ++
790 "{\n" ++
791 indent 1 ++ "switch(TAG(con)) {\n" ++
792 concatMap makeSwitch tags ++
793 indent 1 ++ "}\n" ++
794 indent 1 ++ "fprintf(stderr, \"No wrapper for callback\");\n" ++
795 indent 1 ++ "exit(-1);\n" ++
796 "}\n\n"
797 where
798 makeSwitch (_, tag) =
799 indent 1 ++ "case " ++ show tag ++ ":\n" ++
800 indent 2 ++ "return (void*) &" ++ wrapperName tag ++ ";\n"
802genWrapper :: (FDesc, Int) -> String
803genWrapper (desc, tag) | (toFType desc) == FFunctionIO =
804 error "Cannot create C callbacks for IO functions, wrap them with unsafePerformIO.\n"
805genWrapper (desc, tag) = ret ++ " " ++ wrapperName tag ++ "(" ++
806 renderArgs argList ++")\n" ++
807 "{\n" ++
808 (if ret /= "void" then indent 1 ++ ret ++ " ret;\n" else "") ++
809 indent 1 ++ "VM* vm = get_vm();\n" ++
810 indent 1 ++ "if (vm == NULL) {\n" ++
811 indent 2 ++ "vm = idris_vm();\n" ++
812 indent 1 ++ "}\n" ++
813 indent 1 ++ "INITFRAME;\n" ++
814 indent 1 ++ "RESERVE(" ++ show (len + 1) ++ ");\n" ++
815 indent 1 ++ "allocCon(REG1, vm, " ++ show tag ++ ",0 , 0);\n" ++
816 indent 1 ++ "TOP(0) = REG1;\n" ++
817 applyArgs argList ++
818 if ret /= "void"
819 then indent 1 ++ "ret = " ++ irts_c (toFType ft) "RVAL" ++ ";\n"
820 ++ indent 1 ++ "return ret;\n}\n\n"
821 else "}\n\n"
822 where
823 (ret, ft) = rty desc
824 argList = zip (args desc) [0..]
825 len = length argList
827 applyArgs (x:y:xs) = push 1 [x] ++
828 indent 1 ++ "STOREOLD;\n" ++
829 indent 1 ++ "BASETOP(0);\n" ++
830 indent 1 ++ "ADDTOP(2);\n" ++
831 indent 1 ++ "CALL(_idris__123_APPLY_95_0_125_);\n" ++
832 indent 1 ++ "TOP(0)=REG1;\n" ++
833 applyArgs (y:xs)
834 applyArgs x = push 1 x ++
835 indent 1 ++ "STOREOLD;\n" ++
836 indent 1 ++ "BASETOP(0);\n" ++
837 indent 1 ++ "ADDTOP(" ++ show (length x + 1) ++ ");\n" ++
838 indent 1 ++ "CALL(_idris__123_APPLY_95_0_125_);\n"
839 renderArgs [] = "void"
840 renderArgs [((s, _), n)] = s ++ " a" ++ (show n)
841 renderArgs (((s, _), n):xs) = s ++ " a" ++ (show n) ++ ", " ++
842 renderArgs xs
843 rty (FApp c [_,ty])
844 | c == sUN "C_FnBase" = (ctype ty, ty)
845 | c == sUN "C_FnIO" = (ctype ty, ty)
846 | c == sUN "C_FnT" = rty ty
847 rty (FApp c [_,_,ty,fn])
848 | c == sUN "C_Fn" = rty fn
849 rty x = ("", x)
850 args (FApp c [_,ty])
851 | c == sUN "C_FnBase" = []
852 | c == sUN "C_FnIO" = []
853 | c == sUN "C_FnT" = args ty
854 args (FApp c [_,_,ty,fn])
855 | toFType ty == FUnit = []
856 | c == sUN "C_Fn" = (ctype ty, ty) : args fn
857 args _ = []
858 push i [] = ""
859 push i (((c, t), n) : ts) = indent 1 ++ c_irts (toFType t)
860 ("TOP(" ++ show i ++ ") = ") ("a" ++ show n)
861 ++ ";\n" ++ push (i + 1) ts
863wrapperName :: Int -> String
864wrapperName tag = "_idris_wrapper_" ++ show tag
866getCallback :: [BC] -> [(FDesc, Int)]
867getCallback bc = getCallback' (reverse bc)
868 where
869 getCallback' (x:xs) = case hasCallback x of
870 [] -> getCallback' xs
871 cbs -> case findCons cbs xs of
872 [] -> error "Idris function couldn't be wrapped."
873 x -> x
874 getCallback' [] = []
875 findCons (c:cs) xs = findCon c xs ++ findCons cs xs
876 findCons [] _ = []
877 findCon c ((MKCON l loc tag args):xs) | snd c == l = [(fst c, tag)]
878 findCon c (_:xs) = findCon c xs
879 findCon c [] = []
881hasCallback :: BC -> [(FDesc, Reg)]
882hasCallback (FOREIGNCALL l rty (FStr fn) args) = filter isFn args
883 where
884 isFn (desc,_) = case toFType desc of
885 FFunction -> True
886 FFunctionIO -> True
887 _ -> False
888hasCallback _ = []