3Description : The default code generator for Idris, generating C code.
6Maintainer : The Idris Community.
8{-# LANGUAGE FlexibleContexts #-}
10module IRTS.CodegenC (codegenC) where
14import IRTS.CodegenCommon
15import IRTS.Defunctionalise
24import Data.List (intercalate, nubBy)
27import System.FilePath ((<.>), (</>))
31codegenC :: CodeGenerator
32codegenC ci = do codegenC' (simpleDecls ci)
37 (map mkLib (compileLibs ci) ++
38 map incdir (importDirs ci))
43 when (interfaces ci) $
44 codegenH (exportDecls ci)
46 where mkLib l = "-l" ++ l
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)
57 -> Bool -- ^ interfaces too (so make a .o instead)
60codegenC' defs out exec incs objs libs flags exports iface dbg
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)
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)
72 Raw -> writeSource out cout
74 (tmpn, tmph) <- tempfile ".c"
75 hSetEncoding tmph utf8
80 libFlags <- getLibFlags
81 incFlags <- getIncFlags
82 envFlags <- getEnvFlags
83 let stripFlag = if isDarwin then "-dead_strip" else "-Wl,-gc-sections"
84 let stackFlags = if isWindows then ["-Wl,--stack,16777216"] else []
85 let linkFlags = stripFlag : stackFlags
86 let args = gccDbg dbg ++
88 -- # Any flags defined here which alter the RTS API must also be added to config.mk
90 , "-fdata-sections", "-ffunction-sections"
91 , "-D_POSIX_C_SOURCE=200809L", "-DHAS_PTHREAD", "-DIDRIS_ENABLE_STATS"
92 , "-I."] ++ objs ++ envFlags ++
93 (if (exec == Executable) then linkFlags else ["-c"]) ++
95 (if not iface then libFlags else []) ++
97 (if not iface then libs else []) ++
100-- putStrLn (show args)
101 exit <- rawSystem comp args
102 when (exit /= ExitSuccess) $
103 putStrLn ("FAILURE: " ++ show comp ++ " " ++ show args)
105 getExp (Export _ _ exp) = exp
109 (\h -> "#include \"" ++ h ++ "\"\n")
110 (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h"])
112debug TRACE = "#define IDRIS_TRACE\n\n"
115-- We're using signed integers now. Make sure we get consistent semantics
116-- out of them from gcc. See e.g. http://thiemonagel.de/2010/01/signed-integer-overflow/
117gccFlags i = if i then ["-fwrapv"]
118 else ["-fwrapv", "-fno-strict-overflow"]
123cname :: Name -> String
124cname n = "_idris_" ++ concatMap cchar (showCG n)
125 where cchar x | isAscii x && isAlpha x || isDigit x = [x]
126 | otherwise = "_" ++ show (fromEnum x) ++ "_"
128indent :: Int -> String
129indent n = replicate (n*4) ' '
132creg (L i) = "LOC(" ++ show i ++ ")"
133creg (T i) = "TOP(" ++ show i ++ ")"
136toDecl :: Name -> String
137toDecl f = "void* " ++ cname f ++ "(VM*, VAL*);\n"
139toC :: Name -> [BC] -> String
141 = -- "/* " ++ show code ++ "*/\n\n" ++
142 "void* " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++
143 indent 1 ++ "INITFRAME;\nloop:\n" ++
144 concatMap (bcc f 1) code ++ "}\n\n"
146showCStr :: String -> String
147showCStr s = '"' : foldr ((++) . showChar) "\"" s
149 showChar :: Char -> String
150 showChar '"' = "\\\""
151 showChar '\\' = "\\\\"
153 -- Note: we need the double quotes around the codes because otherwise
154 -- "\n3" would get encoded as "\x0a3", which is incorrect.
155 -- Instead, we opt for "\x0a""3" and let the C compiler deal with it.
156 | ord c < 0x20 = showUTF8 (ord c)
157 | ord c < 0x7f = [c] -- 0x7f = \DEL
158 | otherwise = showHexes (utf8bytes (ord c))
160 showUTF8 c = "\"\"\\x" ++ pad (showHex c "") ++ "\"\""
161 showHexes = foldr ((++) . showUTF8) ""
163 utf8bytes :: Int -> [Int]
166 | x <= 0x7ff = let (y : ys) = split [] 2 x in (y .|. 0xc0) : map (.|. 0x80) ys
167 | x <= 0xffff = let (y : ys) = split [] 3 x in (y .|. 0xe0) : map (.|. 0x80) ys
168 | x <= 0x10ffff = let (y : ys) = split [] 4 x in (y .|. 0xf0) : map (.|. 0x80) ys
169 | otherwise = error $ "Invalid Unicode code point U+" ++ showHex x ""
171 split acc 1 x = x : acc
172 split acc i x = split (x .&. 0x3f : acc) (i - 1) (shiftR x 6)
174 pad :: String -> String
175 pad s = case length s of
178 _ -> error $ "Can't happen: String of invalid length " ++ show s
180bcc :: Name -> Int -> BC -> String
181bcc f i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
182bcc f i (ASSIGNCONST l c)
183 = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"
185 mkConst (I i) = "MKINT(" ++ show i ++ ")"
186 mkConst (BI i) = let maxInt = 2^30
187 in if i >= -maxInt && i < maxInt
188 then "MKINT(" ++ show i ++ ")"
189 else "MKBIGC(vm,\"" ++ show i ++ "\")"
190 mkConst (Fl f) = "MKFLOAT(vm, " ++ (map toUpper $ show f) ++ ")"
191 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"
192 mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"
193 mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ "U)"
194 mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"
195 mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"
196 mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"
197 -- if it's a type constant, we won't use it, but equally it shouldn't
198 -- report an error. These might creep into generated for various reasons
199 -- (especially if erasure is disabled).
200 mkConst c | isTypeConst c = "MKINT(42424242)"
201 mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"
203bcc f i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
204bcc f i (MKCON l loc tag []) | tag < 256
205 = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"
206bcc f i (MKCON l loc tag args)
207 = indent i ++ alloc loc tag ++
208 indent i ++ setArgs 0 args ++ "\n" ++
209 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"
210 where setArgs i [] = ""
211 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++
212 "); " ++ setArgs (i + 1) xs
214 = "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ ", " ++
215 show (length args) ++ ", 0);\n"
217 = "updateCon(" ++ creg Tmp ++ ", " ++ creg old ++ ", " ++ show tag ++ ", " ++
218 show (length args) ++ ");\n"
220bcc f i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++
221 ", " ++ show a ++ ");\n"
222bcc f i (PROJECTINTO r t idx)
223 = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"
224bcc f i (CASE True r [(_, alt)] Nothing)
225 = indent i ++ showCode i alt
227 showCode :: Int -> [BC] -> String
228 showCode i bc = "{\n" ++ concatMap (bcc f (i + 1)) bc ++
230bcc f i (CASE True r code def)
231 | length code < 6 && length code > 1 = showCase i def code
233 showCode :: Int -> [BC] -> String
234 showCode i bc = "{\n" ++ concatMap (bcc f (i + 1)) bc ++
237 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String
238 showCase i Nothing [(t, c)] = indent i ++ showCode i c
239 showCase i (Just def) [] = indent i ++ showCode i def
240 showCase i def ((t, c) : cs)
241 = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c
242 ++ indent i ++ "else\n" ++ showCase i def cs
244bcc f i (CASE safe r code def)
245 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++
246 concatMap (showCase i) code ++
253 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
254 ++ concatMap (bcc f (i+1)) bc ++ indent (i + 1) ++ "break;\n"
255 showDef i Nothing = indent i ++ "default:\n" ++
256 indent (i + 1) ++ "return NULL;\n"
257 showDef i (Just c) = indent i ++ "default:\n"
258 ++ concatMap (bcc f (i+1)) c ++ indent (i + 1) ++ "break;\n"
259bcc f i (CONSTCASE r code def)
261-- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++
262-- concatMap (showCase i) code ++
265 = concatMap (iCase (creg r)) code ++
266 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
268 = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++
269 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
271 = concatMap (biCase (creg r)) code ++
272 indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
273 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code
275 intConsts ((I _, _ ) : _) = True
276 intConsts ((Ch _, _ ) : _) = True
277 intConsts ((B8 _, _ ) : _) = True
278 intConsts ((B16 _, _ ) : _) = True
279 intConsts ((B32 _, _ ) : _) = True
280 intConsts ((B64 _, _ ) : _) = True
283 bigintConsts ((BI _, _ ) : _) = True
284 bigintConsts _ = False
286 strConsts ((Str _, _ ) : _) = True
290 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++
291 concatMap (bcc f (i+1)) bc ++ indent i ++ "} else\n"
292 biCase bv (BI b, bc) =
293 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"
294 ++ concatMap (bcc f (i+1)) bc ++ indent i ++ "} else\n"
296 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"
297 ++ concatMap (bcc f (i+1)) bc ++ indent i ++ "} else\n"
299 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n"
300 ++ concatMap (bcc f (i+1)) bc ++ indent i ++ "} else\n"
302 indent i ++ "if (GETBITS8(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
303 ++ concatMap (bcc f (i+1)) bc ++ indent i ++ "} else\n"
304 iCase v (B16 w, bc) =
305 indent i ++ "if (GETBITS16(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
306 ++ concatMap (bcc f (i+1)) bc ++ indent i ++ "} else\n"
307 iCase v (B32 w, bc) =
308 indent i ++ "if (GETBITS32(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
309 ++ concatMap (bcc f (i+1)) bc ++ indent i ++ "} else\n"
310 iCase v (B64 w, bc) =
311 indent i ++ "if (GETBITS64(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
312 ++ concatMap (bcc f (i+1)) bc ++ indent i ++ "} else\n"
313 showDefS i Nothing = ""
314 showDefS i (Just c) = concatMap (bcc f (i+1)) c
316bcc f i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"
318 | f == n = indent i ++ "goto loop;\n"
319 | otherwise = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"
320bcc f i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"
321bcc f i REBASE = indent i ++ "REBASE;\n"
322bcc f i (RESERVE 0) = ""
323bcc f i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"
324bcc f i (ADDTOP 0) = ""
325bcc f i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"
326bcc f i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
327bcc f i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
328bcc f i STOREOLD = indent i ++ "STOREOLD;\n"
329bcc f i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"
330bcc f i (FOREIGNCALL l rty (FStr ('#':name)) [])
332 c_irts (toFType rty) (creg l ++ " = ") name ++ ";\n"
333bcc f i (FOREIGNCALL l rty (FStr fn@('&':name)) [])
335 c_irts (toFType rty) (creg l ++ " = ") fn ++ ";\n"
336bcc f i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%wrapper"
338 c_irts (toFType rty) (creg l ++ " = ")
339 ("_idris_get_wrapper(" ++ creg (snd x) ++ ")") ++ ";\n"
340bcc f i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%dynamic"
341 = indent i ++ c_irts (toFType rty) (creg l ++ " = ")
342 ("(*(" ++ cFnSig "" rty xs ++ ") GETPTR(" ++ creg (snd x) ++ "))" ++
343 "(" ++ showSep "," (map fcall xs) ++ ")") ++ ";\n"
344bcc f i (FOREIGNCALL l rty (FStr fn) args)
346 c_irts (toFType rty) (creg l ++ " = ")
347 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
348bcc f i (FOREIGNCALL l rty _ args) = error "Foreign Function calls cannot be partially applied, without being inlined."
349bcc f i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed
350bcc f i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"
351-- bcc f i c = error (show c) -- indent i ++ "// not done yet\n"
353fcall (t, arg) = irts_c (toFType t) (creg arg)
354-- Deconstruct the Foreign type in the defunctionalised expression and build
355-- a foreign type description for c_irts and irts_c
357 | i == sUN "C_IntChar" = ATInt ITChar
358 | i == sUN "C_IntNative" = ATInt ITNative
359 | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)
360 | i == sUN "C_IntBits16" = ATInt (ITFixed IT16)
361 | i == sUN "C_IntBits32" = ATInt (ITFixed IT32)
362 | i == sUN "C_IntBits64" = ATInt (ITFixed IT64)
363toAType t = error (show t ++ " not defined in toAType")
366 | c == sUN "C_Str" = FString
367 | c == sUN "C_Float" = FArith ATFloat
368 | c == sUN "C_Ptr" = FPtr
369 | c == sUN "C_MPtr" = FManagedPtr
370 | c == sUN "C_CData" = FCData
371 | c == sUN "C_Unit" = FUnit
372toFType (FApp c [_,ity])
373 | c == sUN "C_IntT" = FArith (toAType ity)
374 | c == sUN "C_FnT" = toFunType ity
376 | c == sUN "C_Any" = FAny
379toFunType (FApp c [_,ity])
380 | c == sUN "C_FnBase" = FFunction
381 | c == sUN "C_FnIO" = FFunctionIO
382toFunType (FApp c [_,_,_,ity])
383 | c == sUN "C_Fn" = toFunType ity
386c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
387c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x
388c_irts (FArith (ATInt (ITFixed ity))) l x
389 = l ++ "idris_b" ++ show (nativeTyWidth ity) ++ "const(vm, " ++ x ++ ")"
390c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"
392c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"
393c_irts FManagedPtr l x = l ++ x
394c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"
395c_irts FCData l x = l ++ "MKCDATA(vm, " ++ x ++ ")"
396c_irts FAny l x = l ++ x
397c_irts FFunction l x = error "Return of function from foreign call is not supported"
398c_irts FFunctionIO l x = error "Return of function from foreign call is not supported"
400irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"
401irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x
402irts_c (FArith (ATInt (ITFixed ity))) x
403 = "GETBITS" ++ show (nativeTyWidth ity) ++ "(" ++ x ++ ")"
404irts_c FString x = "GETSTR(" ++ x ++ ")"
406irts_c FPtr x = "GETPTR(" ++ x ++ ")"
407irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"
408irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"
409irts_c FCData x = "GETCDATA(" ++ x ++ ")"
411irts_c FFunctionIO x = wrapped x
412irts_c FFunction x = wrapped x
414cFnSig name rty [] = ctype rty ++ " (*" ++ name ++ ")(void) "
415cFnSig name rty args = ctype rty ++ " (*" ++ name ++ ")("
416 ++ showSep "," (map (ctype . fst) args) ++ ") "
418wrapped x = "_idris_get_wrapper(" ++ x ++ ")"
420bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"
422bitCoerce v op input output arg
423 = v ++ "idris_b" ++ show (nativeTyWidth input) ++ op ++ show (nativeTyWidth output) ++ "(vm, " ++ creg arg ++ ")"
425signedTy :: NativeTy -> String
426signedTy t = "int" ++ show (nativeTyWidth t) ++ "_t"
428-- Need to ensure we have enough spare *before* GMP operations because they
429-- use the idris allocator but outside our control, and if it GCs in the middle
430-- then things get moved which leads to trouble...
431-- I'm just guessing how much it'll need. This is a TMP HACK. Sorry.
433 = "idris_requireAlloc(vm, 65536); " ++ op ++ "; idris_doneAlloc(vm)"
435doOp v (LPlus (ATInt ITNative)) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"
436doOp v (LMinus (ATInt ITNative)) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
437doOp v (LTimes (ATInt ITNative)) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"
438doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
439doOp v (LSDiv (ATInt ITNative)) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
440doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
441doOp v (LSRem (ATInt ITNative)) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
442doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"
443doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"
444doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"
445doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"
446doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
447doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
448doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"
449doOp v (LEq (ATInt ITNative)) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
450doOp v (LSLt (ATInt ITNative)) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
451doOp v (LSLe (ATInt ITNative)) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
452doOp v (LSGt (ATInt ITNative)) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
453doOp v (LSGe (ATInt ITNative)) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
454doOp v (LLt ITNative) [l, r] = v ++ "UINTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
455doOp v (LLe ITNative) [l, r] = v ++ "UINTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
456doOp v (LGt ITNative) [l, r] = v ++ "UINTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
457doOp v (LGe ITNative) [l, r] = v ++ "UINTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
459doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r]
460doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r]
461doOp v (LTimes (ATInt ITChar)) [l, r] = doOp v (LTimes (ATInt ITNative)) [l, r]
462doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r]
463doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r]
464doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r]
465doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r]
466doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r]
467doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r]
468doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r]
469doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r]
470doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r]
471doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r]
472doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x]
473doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r]
474doOp v (LSLt (ATInt ITChar)) [l, r] = doOp v (LSLt (ATInt ITNative)) [l, r]
475doOp v (LSLe (ATInt ITChar)) [l, r] = doOp v (LSLe (ATInt ITNative)) [l, r]
476doOp v (LSGt (ATInt ITChar)) [l, r] = doOp v (LSGt (ATInt ITNative)) [l, r]
477doOp v (LSGe (ATInt ITChar)) [l, r] = doOp v (LSGe (ATInt ITNative)) [l, r]
478doOp v (LLt ITChar) [l, r] = doOp v (LLt ITNative) [l, r]
479doOp v (LLe ITChar) [l, r] = doOp v (LLe ITNative) [l, r]
480doOp v (LGt ITChar) [l, r] = doOp v (LGt ITNative) [l, r]
481doOp v (LGe ITChar) [l, r] = doOp v (LGe ITNative) [l, r]
483doOp v (LPlus ATFloat) [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"
484doOp v (LMinus ATFloat) [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
485doOp v (LTimes ATFloat) [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"
486doOp v (LSDiv ATFloat) [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
487doOp v (LEq ATFloat) [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
488doOp v (LSLt ATFloat) [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
489doOp v (LSLe ATFloat) [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
490doOp v (LSGt ATFloat) [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
491doOp v (LSGe ATFloat) [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
493doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"
494doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"
495doOp v (LPlus (ATInt ITBig)) [l, r] = wrapGMP $ v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
496doOp v (LMinus (ATInt ITBig)) [l, r] = wrapGMP $ v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
497doOp v (LTimes (ATInt ITBig)) [l, r] = wrapGMP $ v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
498doOp v (LSDiv (ATInt ITBig)) [l, r] = wrapGMP $ v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
499doOp v (LSRem (ATInt ITBig)) [l, r] = wrapGMP $ v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
500doOp v (LAnd ITBig) [l, r] = wrapGMP $ v ++ "idris_bigAnd(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
501doOp v (LOr ITBig) [l, r] = wrapGMP $ v ++ "idris_bigOr(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
502doOp v (LSHL ITBig) [l, r] = wrapGMP $ v ++ "idris_bigShiftLeft(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
503doOp v (LLSHR ITBig) [l, r] = wrapGMP $ v ++ "idris_bigLShiftRight(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
504doOp v (LASHR ITBig) [l, r] = wrapGMP $ v ++ "idris_bigAShiftRight(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
505doOp v (LEq (ATInt ITBig)) [l, r] = wrapGMP $ v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
506doOp v (LSLt (ATInt ITBig)) [l, r] = wrapGMP $ v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
507doOp v (LSLe (ATInt ITBig)) [l, r] = wrapGMP $ v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
508doOp v (LSGt (ATInt ITBig)) [l, r] = wrapGMP $ v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
509doOp v (LSGe (ATInt ITBig)) [l, r] = wrapGMP $ v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
511doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"
512doOp v (LFloatInt ITNative) [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"
513doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"
514doOp v (LTrunc ITBig ITNative) [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"
515doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"
516doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"
517doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"
518doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"
519doOp v (LIntStr (ITFixed _)) [x] = v ++ "idris_castBitsStr(vm, " ++ creg x ++ ")"
520doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"
521doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"
523doOp v (LSLt (ATInt (ITFixed ty))) [x, y] = bitOp v "SLt" ty [x, y]
524doOp v (LSLe (ATInt (ITFixed ty))) [x, y] = bitOp v "SLte" ty [x, y]
525doOp v (LEq (ATInt (ITFixed ty))) [x, y] = bitOp v "Eq" ty [x, y]
526doOp v (LSGe (ATInt (ITFixed ty))) [x, y] = bitOp v "SGte" ty [x, y]
527doOp v (LSGt (ATInt (ITFixed ty))) [x, y] = bitOp v "SGt" ty [x, y]
528doOp v (LLt (ITFixed ty)) [x, y] = bitOp v "Lt" ty [x, y]
529doOp v (LLe (ITFixed ty)) [x, y] = bitOp v "Lte" ty [x, y]
530doOp v (LGe (ITFixed ty)) [x, y] = bitOp v "Gte" ty [x, y]
531doOp v (LGt (ITFixed ty)) [x, y] = bitOp v "Gt" ty [x, y]
533doOp v (LSHL (ITFixed ty)) [x, y] = bitOp v "Shl" ty [x, y]
534doOp v (LLSHR (ITFixed ty)) [x, y] = bitOp v "LShr" ty [x, y]
535doOp v (LASHR (ITFixed ty)) [x, y] = bitOp v "AShr" ty [x, y]
536doOp v (LAnd (ITFixed ty)) [x, y] = bitOp v "And" ty [x, y]
537doOp v (LOr (ITFixed ty)) [x, y] = bitOp v "Or" ty [x, y]
538doOp v (LXOr (ITFixed ty)) [x, y] = bitOp v "Xor" ty [x, y]
539doOp v (LCompl (ITFixed ty)) [x] = bitOp v "Compl" ty [x]
541doOp v (LPlus (ATInt (ITFixed ty))) [x, y] = bitOp v "Plus" ty [x, y]
542doOp v (LMinus (ATInt (ITFixed ty))) [x, y] = bitOp v "Minus" ty [x, y]
543doOp v (LTimes (ATInt (ITFixed ty))) [x, y] = bitOp v "Times" ty [x, y]
544doOp v (LUDiv (ITFixed ty)) [x, y] = bitOp v "UDiv" ty [x, y]
545doOp v (LSDiv (ATInt (ITFixed ty))) [x, y] = bitOp v "SDiv" ty [x, y]
546doOp v (LURem (ITFixed ty)) [x, y] = bitOp v "URem" ty [x, y]
547doOp v (LSRem (ATInt (ITFixed ty))) [x, y] = bitOp v "SRem" ty [x, y]
549doOp v (LSExt (ITFixed from) ITBig) [x]
550 = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ") GETBITS" ++ show (nativeTyWidth from) ++ "(" ++ creg x ++ "))"
551doOp v (LSExt ITNative (ITFixed to)) [x]
552 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
553doOp v (LSExt ITChar (ITFixed to)) [x]
554 = doOp v (LSExt ITNative (ITFixed to)) [x]
555doOp v (LSExt (ITFixed from) ITNative) [x]
556 = v ++ "MKINT((i_int)((" ++ signedTy from ++ ") GETBITS" ++ show (nativeTyWidth from) ++ "(" ++ creg x ++ ")))"
557doOp v (LSExt (ITFixed from) ITChar) [x]
558 = doOp v (LSExt (ITFixed from) ITNative) [x]
559doOp v (LSExt (ITFixed from) (ITFixed to)) [x]
560 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "S" from to x
561doOp v (LZExt ITNative (ITFixed to)) [x]
562 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
563doOp v (LZExt ITChar (ITFixed to)) [x]
564 = doOp v (LZExt ITNative (ITFixed to)) [x]
565doOp v (LZExt (ITFixed from) ITNative) [x]
566 = v ++ "MKINT((i_int)GETBITS" ++ show (nativeTyWidth from) ++ "(" ++ creg x ++ "))"
567doOp v (LZExt (ITFixed from) ITChar) [x]
568 = doOp v (LZExt (ITFixed from) ITNative) [x]
569doOp v (LZExt (ITFixed from) ITBig) [x]
570 = v ++ "MKBIGUI(vm, GETBITS" ++ show (nativeTyWidth from) ++ "(" ++ creg x ++ "))"
571doOp v (LZExt ITNative ITBig) [x]
572 = v ++ "MKBIGUI(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
573doOp v (LZExt (ITFixed from) (ITFixed to)) [x]
574 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "Z" from to x
575doOp v (LTrunc ITNative (ITFixed to)) [x]
576 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
577doOp v (LTrunc ITChar (ITFixed to)) [x]
578 = doOp v (LTrunc ITNative (ITFixed to)) [x]
579doOp v (LTrunc (ITFixed from) ITNative) [x]
580 = v ++ "MKINT((i_int)GETBITS" ++ show (nativeTyWidth from) ++ "(" ++ creg x ++ "))"
581doOp v (LTrunc (ITFixed from) ITChar) [x]
582 = doOp v (LTrunc (ITFixed from) ITNative) [x]
583doOp v (LTrunc ITBig (ITFixed IT64)) [x]
584 = v ++ "idris_b64const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : idris_truncBigB64(GETMPZ(" ++ creg x ++ ")))"
585doOp v (LTrunc ITBig (ITFixed to)) [x]
586 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"
587doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]
588 | nativeTyWidth from > nativeTyWidth to = bitCoerce v "T" from to x
590doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)
591doOp v LFLog [x] = v ++ flUnOp "log" (creg x)
592doOp v LFSin [x] = v ++ flUnOp "sin" (creg x)
593doOp v LFCos [x] = v ++ flUnOp "cos" (creg x)
594doOp v LFTan [x] = v ++ flUnOp "tan" (creg x)
595doOp v LFASin [x] = v ++ flUnOp "asin" (creg x)
596doOp v LFACos [x] = v ++ flUnOp "acos" (creg x)
597doOp v LFATan [x] = v ++ flUnOp "atan" (creg x)
598doOp v LFSqrt [x] = v ++ flUnOp "sqrt" (creg x)
599doOp v LFFloor [x] = v ++ flUnOp "floor" (creg x)
600doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x)
601doOp v LFNegate [x] = v ++ "MKFLOAT(vm, -GETFLOAT(" ++ (creg x) ++ "))"
602doOp v LFATan2 [y, x] = v ++ "MKFLOAT(vm, atan2(GETFLOAT(" ++ creg y ++ "), GETFLOAT(" ++ creg x ++ ")))"
604-- String functions which don't need to know we're UTF8
605doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
606doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
607doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
609doOp v LReadStr [_] = v ++ "idris_readStr(vm, stdin)"
610doOp v LWriteStr [_,s]
611 = v ++ "MKINT((i_int)(idris_writeStr(stdout"
616-- String functions which need to know we're UTF8
617doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"
618doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"
619doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")"
620doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")"
621doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")"
622doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"
623doOp v LStrSubstr [x,y,z] = v ++ "idris_substr(vm, " ++ creg x ++ "," ++ creg y ++ "," ++ creg z ++ ")"
625doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 0 "EVAL") ++ ", " ++ creg x ++ "))"
626doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
627doOp v (LChInt ITNative) args = v ++ creg (last args)
628doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args
629doOp v (LIntCh ITNative) args = v ++ creg (last args)
630doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args
632doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"
633doOp v LCrash [x] = "idris_crash(GETSTR(" ++ creg x ++ "))"
634doOp v LNoOp args = v ++ creg (last args)
636-- Pointer primitives (declared as %extern in Builtins.idr)
637doOp v (LExternal rf) [_,x]
638 | rf == sUN "prim__readFile"
639 = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"
640doOp v (LExternal rf) [_,len,x]
641 | rf == sUN "prim__readChars"
642 = v ++ "idris_readChars(vm, GETINT(" ++ creg len ++
643 "), GETPTR(" ++ creg x ++ "))"
644doOp v (LExternal wf) [_,x,s]
645 | wf == sUN "prim__writeFile"
646 = v ++ "MKINT((i_int)(idris_writeStr(GETPTR(" ++ creg x
649doOp v (LExternal si) [] | si == sUN "prim__stdin" = v ++ "MKPTR(vm, stdin)"
650doOp v (LExternal so) [] | so == sUN "prim__stdout" = v ++ "MKPTR(vm, stdout)"
651doOp v (LExternal se) [] | se == sUN "prim__stderr" = v ++ "MKPTR(vm, stderr)"
653doOp v (LExternal vm) [_] | vm == sUN "prim__vm" = v ++ "MKPTR(vm, vm)"
654doOp v (LExternal nul) [] | nul == sUN "prim__null" = v ++ "MKPTR(vm, NULL)"
655doOp v (LExternal nul) [] | nul == sUN "prim__managedNull" = v ++ "MKPTR(vm, NULL)"
656doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqPtr"
657 = v ++ "MKINT((i_int)(GETPTR(" ++ creg x ++ ") == GETPTR(" ++ creg y ++ ")))"
658doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqManagedPtr"
659 = v ++ "MKINT((i_int)(GETMPTR(" ++ creg x ++ ") == GETMPTR(" ++ creg y ++ ")))"
660doOp v (LExternal rp) [p, i] | rp == sUN "prim__registerPtr"
661 = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++ "), GETINT(" ++ creg i ++ "))"
662doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek8"
663 = v ++ "idris_peekB8(vm," ++ creg p ++ "," ++ creg o ++")"
664doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke8"
665 = v ++ "idris_pokeB8(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
666doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek16"
667 = v ++ "idris_peekB16(vm," ++ creg p ++ "," ++ creg o ++")"
668doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke16"
669 = v ++ "idris_pokeB16(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
670doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek32"
671 = v ++ "idris_peekB32(vm," ++ creg p ++ "," ++ creg o ++")"
672doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke32"
673 = v ++ "idris_pokeB32(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
674doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek64"
675 = v ++ "idris_peekB64(vm," ++ creg p ++ "," ++ creg o ++")"
676doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke64"
677 = v ++ "idris_pokeB64(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
678doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekPtr"
679 = v ++ "idris_peekPtr(vm," ++ creg p ++ "," ++ creg o ++")"
680doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokePtr"
681 = v ++ "idris_pokePtr(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
682doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokeDouble"
683 = v ++ "idris_pokeDouble(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
684doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekDouble"
685 = v ++ "idris_peekDouble(vm," ++ creg p ++ "," ++ creg o ++")"
686doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokeSingle"
687 = v ++ "idris_pokeSingle(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
688doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekSingle"
689 = v ++ "idris_peekSingle(vm," ++ creg p ++ "," ++ creg o ++")"
690doOp v (LExternal pk) [] | pk == sUN "prim__sizeofPtr"
691 = v ++ "MKINT(sizeof(void*))"
692doOp v (LExternal mpt) [p] | mpt == sUN "prim__asPtr"
693 = v ++ "MKPTR(vm, GETMPTR("++ creg p ++"))"
694doOp v (LExternal offs) [p, n] | offs == sUN "prim__ptrOffset"
695 = v ++ "MKPTR(vm, (void *)((char *)GETPTR(" ++ creg p ++ ") + GETINT(" ++ creg n ++ ")))"
696doOp _ op args = error $ "doOp not implemented (" ++ show (op, args) ++ ")"
699flUnOp :: String -> String -> String
700flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"
702-------------------- Interface file generation
704-- First, the wrappers in the C file
706ifaceC :: Export -> String
707ifaceC (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"
708ifaceC (ExportFun n cn ret args)
709 = ctype ret ++ " " ++ cdesc cn ++
710 "(VM* vm" ++ showArgs (zip argNames args) ++ ") {\n"
711 ++ mkBody n (zip argNames args) ret ++ "}\n\n"
712 where showArgs [] = ""
713 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++
716 argNames = zipWith (++) (repeat "arg") (map show [0..])
719 = indent 1 ++ "INITFRAME;\n" ++
720 indent 1 ++ "RESERVE(" ++ show (max (length as) 3) ++ ");\n" ++
721 push 0 as ++ call n ++ retval t
724 FIO t -> as_in ++ [("NULL", FUnknown)] -- add world token
727 push i ((n, t) : ts) = indent 1 ++ c_irts (toFType t)
728 ("TOP(" ++ show i ++ ") = ") n
729 ++ ";\n" ++ push (i + 1) ts
731 call _ = indent 1 ++ "STOREOLD;\n" ++
732 indent 1 ++ "BASETOP(0);\n" ++
733 indent 1 ++ "ADDTOP(" ++ show (length as) ++ ");\n" ++
734 indent 1 ++ "CALL(" ++ cname n ++ ");\n"
736 retval (FIO t) = retval t
737 retval t = indent 1 ++ "return " ++ irts_c (toFType t) "RVAL" ++ ";\n"
740 | c == sUN "C_Str" = "char*"
741 | c == sUN "C_Float" = "float"
742 | c == sUN "C_Ptr" = "void*"
743 | c == sUN "C_MPtr" = "void*"
744 | c == sUN "C_Unit" = "void"
745ctype (FApp c [_,ity])
746 | c == sUN "C_IntT" = carith ity
748 | c == sUN "C_Any" = "VAL"
750ctype FUnknown = "void*"
751ctype (FIO t) = ctype t
752ctype t = error "Can't happen: Not a valid interface type " ++ show t
755 | i == sUN "C_IntChar" = "char"
756 | i == sUN "C_IntNative" = "int"
757 | i == sUN "C_IntBits8" = "uint8_t"
758 | i == sUN "C_IntBits16" = "uint16_t"
759 | i == sUN "C_IntBits32" = "uint32_t"
760 | i == sUN "C_IntBits64" = "uint64_t"
761carith t = error $ "Can't happen: Not an exportable arithmetic type " ++ show t
764cdesc s = error "Can't happen: Not a valid C name"
766-- Then, the header files
768codegenH :: [ExportIFace] -> IO ()
769codegenH es = mapM_ writeIFace es
771writeIFace :: ExportIFace -> IO ()
772writeIFace (Export ffic hdr exps)
773 | ffic == sNS (sUN "FFI_C") ["FFI_C"]
774 = do let hfile = "#ifndef " ++ hdr_guard hdr ++ "\n" ++
775 "#define " ++ hdr_guard hdr ++ "\n\n" ++
776 "#include <idris_rts.h>\n\n" ++
777 concatMap hdr_export exps ++ "\n" ++
780 | otherwise = return ()
782hdr_guard x = "__" ++ map hchar x
783 where hchar x | isAlphaNum x = toUpper x
786hdr_export :: Export -> String
787hdr_export (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"
788hdr_export (ExportFun n cn ret args)
789 = ctype ret ++ " " ++ cdesc cn ++
790 "(VM* vm" ++ showArgs (zip argNames args) ++ ");\n"
791 where showArgs [] = ""
792 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++
795 argNames = zipWith (++) (repeat "arg") (map show [0..])
797------------------ Callback wrapper generation ----------------
798-- Generate callback wrappers and a function to select the
799-- correct wrapper function to pass.
800-- TODO: This is limited to functions that are specified in
801-- the foreign call. Otherwise we would have to generate wrappers for all
802-- functions with correct arity or do flow analysis
803-- to find all possible inputs to the foreign call.
804genWrappers :: [(Name, [BC])] -> String
806 tags = nubBy (\x y -> snd x == snd y) $ concatMap (getCallback . snd) bcs
810 t -> concatMap genWrapper t ++ genDispatcher t
812genDispatcher :: [(FDesc, Int)] -> String
813genDispatcher tags = "void* _idris_get_wrapper(VAL con)\n" ++
815 indent 1 ++ "switch(TAG(con)) {\n" ++
816 concatMap makeSwitch tags ++
818 indent 1 ++ "fprintf(stderr, \"No wrapper for callback\");\n" ++
819 indent 1 ++ "exit(-1);\n" ++
822 makeSwitch (_, tag) =
823 indent 1 ++ "case " ++ show tag ++ ":\n" ++
824 indent 2 ++ "return (void*) &" ++ wrapperName tag ++ ";\n"
826genWrapper :: (FDesc, Int) -> String
827genWrapper (desc, tag) | (toFType desc) == FFunctionIO =
828 error "Cannot create C callbacks for IO functions, wrap them with unsafePerformIO.\n"
829genWrapper (desc, tag) = ret ++ " " ++ wrapperName tag ++ "(" ++
830 renderArgs argList ++")\n" ++
832 (if ret /= "void" then indent 1 ++ ret ++ " ret;\n" else "") ++
833 indent 1 ++ "VM* vm = get_vm();\n" ++
834 indent 1 ++ "if (vm == NULL) {\n" ++
835 indent 2 ++ "vm = idris_vm();\n" ++
837 indent 1 ++ "INITFRAME;\n" ++
838 indent 1 ++ "RESERVE(" ++ show (len + 1) ++ ");\n" ++
839 indent 1 ++ "allocCon(REG1, vm, " ++ show tag ++ ",0 , 0);\n" ++
840 indent 1 ++ "TOP(0) = REG1;\n" ++
843 then indent 1 ++ "ret = " ++ irts_c (toFType ft) "RVAL" ++ ";\n"
844 ++ indent 1 ++ "return ret;\n}\n\n"
848 argList = zip (args desc) [0..]
851 applyArgs (x:y:xs) = push 1 [x] ++
852 indent 1 ++ "STOREOLD;\n" ++
853 indent 1 ++ "BASETOP(0);\n" ++
854 indent 1 ++ "ADDTOP(2);\n" ++
855 indent 1 ++ "CALL(_idris__123_APPLY_95_0_125_);\n" ++
856 indent 1 ++ "TOP(0)=REG1;\n" ++
858 applyArgs x = push 1 x ++
859 indent 1 ++ "STOREOLD;\n" ++
860 indent 1 ++ "BASETOP(0);\n" ++
861 indent 1 ++ "ADDTOP(" ++ show (length x + 1) ++ ");\n" ++
862 indent 1 ++ "CALL(_idris__123_APPLY_95_0_125_);\n"
863 renderArgs [] = "void"
864 renderArgs [((s, _), n)] = s ++ " a" ++ (show n)
865 renderArgs (((s, _), n):xs) = s ++ " a" ++ (show n) ++ ", " ++
868 | c == sUN "C_FnBase" = (ctype ty, ty)
869 | c == sUN "C_FnIO" = (ctype ty, ty)
870 | c == sUN "C_FnT" = rty ty
871 rty (FApp c [_,_,ty,fn])
872 | c == sUN "C_Fn" = rty fn
875 | c == sUN "C_FnBase" = []
876 | c == sUN "C_FnIO" = []
877 | c == sUN "C_FnT" = args ty
878 args (FApp c [_,_,ty,fn])
879 | toFType ty == FUnit = []
880 | c == sUN "C_Fn" = (ctype ty, ty) : args fn
883 push i (((c, t), n) : ts) = indent 1 ++ c_irts (toFType t)
884 ("TOP(" ++ show i ++ ") = ") ("a" ++ show n)
885 ++ ";\n" ++ push (i + 1) ts
887wrapperName :: Int -> String
888wrapperName tag = "_idris_wrapper_" ++ show tag
890getCallback :: [BC] -> [(FDesc, Int)]
891getCallback bc = getCallback' (reverse bc)
893 getCallback' (x:xs) = case hasCallback x of
894 [] -> getCallback' xs
895 cbs -> case findCons cbs xs of
896 [] -> error "Idris function couldn't be wrapped."
899 findCons (c:cs) xs = findCon c xs ++ findCons cs xs
901 findCon c ((MKCON l loc tag args):xs) | snd c == l =
904 else error "Can't wrap a closure as callback."
905 findCon c (_:xs) = findCon c xs
908hasCallback :: BC -> [(FDesc, Reg)]
909hasCallback (FOREIGNCALL l rty (FStr fn) args) = filter isFn args
911 isFn (desc,_) = case toFType desc of
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list