b290280 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Implement support for C callbacks

b290280Niklas Larsson11 years ago

idris.cabal+5

compare with master

unifiedsplit

@@ -468,6 +468,11 @@ Extra-source-files:

468 test/ffi006/*.c

469 test/ffi006/run

470 test/ffi006/expected

471+ test/ffi007/*.idr

472+ test/ffi007/*.c

473+ test/ffi007/*.h

474+ test/ffi007/run

475+ test/ffi007/expected

471

476

472 test/folding001/*.idr

477 test/folding001/*.idr

473 test/folding001/run

478 test/folding001/run

libs/prelude/IO.idr+27−12

@@ -145,12 +145,15 @@ namespace FFI_C

145 -- code generated can assume it's compiled just as 't'

146 MkRaw : (x : t) -> Raw t

147

148− -- Tell erasure analysis not to erase the argument

149− %used MkRaw x

150−

151− ||| Supported C integer types

152 public export

148 public export

149+ data CFnPtr : Type -> Type where

150+ MkCFnPtr : (x : t) -> CFnPtr t

151+

152+

153+ mutual

154+ ||| Supported C integer types

155+ public export

153− data C_IntTypes : Type -> Type where

156+ data C_IntTypes : Type -> Type where

154 C_IntChar : C_IntTypes Char

157 C_IntChar : C_IntTypes Char

155 C_IntNative : C_IntTypes Int

158 C_IntNative : C_IntTypes Int

156 C_IntBits8 : C_IntTypes Bits8

159 C_IntBits8 : C_IntTypes Bits8

@@ -158,31 +161,43 @@ namespace FFI_C

158 C_IntBits32 : C_IntTypes Bits32

161 C_IntBits32 : C_IntTypes Bits32

159 C_IntBits64 : C_IntTypes Bits64

162 C_IntBits64 : C_IntTypes Bits64

160

163

164+ public export

165+ data C_FnTypes : Type -> Type where

166+ C_Fn : C_Types s -> C_FnTypes t -> C_FnTypes (s -> t)

167+ C_FnIO : C_Types t -> C_FnTypes (IO' FFI_C t)

168+ C_FnBase : C_Types t -> C_FnTypes t

169+

161− ||| Supported C foreign types

170+ ||| Supported C foreign types

162− public export

171+ public export

163− data C_Types : Type -> Type where

172+ data C_Types : Type -> Type where

164 C_Str : C_Types String

173 C_Str : C_Types String

165 C_Float : C_Types Double

174 C_Float : C_Types Double

166 C_Ptr : C_Types Ptr

175 C_Ptr : C_Types Ptr

167 C_MPtr : C_Types ManagedPtr

176 C_MPtr : C_Types ManagedPtr

168 C_Unit : C_Types ()

177 C_Unit : C_Types ()

169 C_Any : C_Types (Raw a)

178 C_Any : C_Types (Raw a)

179+ C_FnT : C_FnTypes t -> C_Types (CFnPtr t)

170 C_IntT : C_IntTypes i -> C_Types i

180 C_IntT : C_IntTypes i -> C_Types i

171

181

172− ||| A descriptor for the C FFI. See the constructors of `C_Types`

182+ ||| A descriptor for the C FFI. See the constructors of `C_Types`

173− ||| and `C_IntTypes` for the concrete types that are available.

183+ ||| and `C_IntTypes` for the concrete types that are available.

174 %error_reverse

184 %error_reverse

175 public export

185 public export

176− FFI_C : FFI

186+ FFI_C : FFI

177− FFI_C = MkFFI C_Types String String

187+ FFI_C = MkFFI C_Types String String

178

188

179||| Interactive programs, describing I/O actions and returning a value.

189||| Interactive programs, describing I/O actions and returning a value.

180||| @res The result type of the program

190||| @res The result type of the program

181%error_reverse

191%error_reverse

182public export

192public export

193+

183IO : (res : Type) -> Type

194IO : (res : Type) -> Type

184IO = IO' FFI_C

195IO = IO' FFI_C

185

196

197+ -- Tell erasure analysis not to erase the argument

198+%used MkRaw x

199+%used MkCFnPtr x

200+

186-- Cannot be relaxed as is used by type providers and they expect IO a

201-- Cannot be relaxed as is used by type providers and they expect IO a

187-- in the first argument.

202-- in the first argument.

188run__provider : IO a -> PrimIO a

203run__provider : IO a -> PrimIO a

rts/idris_rts.c+8

@@ -78,6 +78,14 @@ VM* idris_vm() {

78 return vm;

79}

81+VM* get_vm(void) {

82+#ifdef HAS_PTHREAD

83+ return pthread_getspecific(vm_key);

84+#else

85+ return global_vm;

86+#endif

87+}

88+

81void close_vm(VM* vm) {

89void close_vm(VM* vm) {

82 terminate(vm);

90 terminate(vm);

83}

91}

rts/idris_rts.h+3

@@ -115,6 +115,9 @@ typedef struct VM_t VM;

115// Create a new VM

116VM* init_vm(int stack_size, size_t heap_size,

117 int max_threads);

118+

119+// Get the VM for the current thread

120+VM* get_vm(void);

118// Initialise thread-local data for this VM

121// Initialise thread-local data for this VM

119void init_threaddata(VM *vm);

122void init_threaddata(VM *vm);

120// Clean up a VM once it's no longer needed

123// Clean up a VM once it's no longer needed

src/IRTS/CodegenC.hs+131−2

@@ -13,7 +13,7 @@ import Util.System

13import Numeric

14import Data.Char

15import Data.Bits

16−import Data.List (intercalate)

16+import Data.List (intercalate, nubBy)

17import System.Process

18import System.Exit

19import System.IO

@@ -55,12 +55,13 @@ codegenC' :: [(Name, SDecl)] ->

55codegenC' defs out exec incs objs libs flags exports iface dbg

56 = do -- print defs

57 let bc = map toBC defs

58+ let wrappers = genWrappers bc

58 let h = concatMap toDecl (map fst bc)

59 let h = concatMap toDecl (map fst bc)

59 let cc = concatMap (uncurry toC) bc

60 let cc = concatMap (uncurry toC) bc

60 let hi = concatMap ifaceC (concatMap getExp exports)

61 let hi = concatMap ifaceC (concatMap getExp exports)

61 d <- getDataDir

62 d <- getDataDir

62 mprog <- readFile (d </> "rts" </> "idris_main" <.> "c")

63 mprog <- readFile (d </> "rts" </> "idris_main" <.> "c")

63− let cout = headers incs ++ debug dbg ++ h ++ cc ++

64+ let cout = headers incs ++ debug dbg ++ h ++ wrappers ++ cc ++

64 (if (exec == Executable) then mprog else hi)

65 (if (exec == Executable) then mprog else hi)

65 case exec of

66 case exec of

66 MavenProject -> putStrLn ("FAILURE: output type not supported")

67 MavenProject -> putStrLn ("FAILURE: output type not supported")

@@ -317,6 +318,10 @@ bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"

317bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"

318bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"

318bcc i STOREOLD = indent i ++ "STOREOLD;\n"

319bcc i STOREOLD = indent i ++ "STOREOLD;\n"

319bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"

320bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"

321+bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "_idris_get_wrapper"

322+ = indent i ++

323+ c_irts (toFType rty) (creg l ++ " = ")

324+ (fn ++ "(" ++ creg (snd x) ++ ")") ++ ";\n"

320bcc i (FOREIGNCALL l rty (FStr fn) args)

325bcc i (FOREIGNCALL l rty (FStr fn) args)

321 = indent i ++

326 = indent i ++

322 c_irts (toFType rty) (creg l ++ " = ")

327 c_irts (toFType rty) (creg l ++ " = ")

@@ -345,10 +350,18 @@ toFType (FCon c)

345 | c == sUN "C_Unit" = FUnit

350 | c == sUN "C_Unit" = FUnit

346toFType (FApp c [_,ity])

351toFType (FApp c [_,ity])

347 | c == sUN "C_IntT" = FArith (toAType ity)

352 | c == sUN "C_IntT" = FArith (toAType ity)

353+ | c == sUN "C_FnT" = toFunType ity

348toFType (FApp c [_])

354toFType (FApp c [_])

349 | c == sUN "C_Any" = FAny

355 | c == sUN "C_Any" = FAny

350toFType t = FAny

356toFType t = FAny

351

357

358+toFunType (FApp c [_,ity])

359+ | c == sUN "C_FnBase" = FFunction

360+ | c == sUN "C_FnIO" = FFunctionIO

361+toFunType (FApp c [_,_,_,ity])

362+ | c == sUN "C_Fn" = toFunType ity

363+toFunType _ = FAny

364+

352c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

365c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

353c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x

366c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x

354c_irts (FArith (ATInt (ITFixed ity))) l x

367c_irts (FArith (ATInt (ITFixed ity))) l x

@@ -359,6 +372,8 @@ c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"

359c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"

372c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"

360c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

373c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

361c_irts FAny l x = l ++ x

374c_irts FAny l x = l ++ x

375+c_irts FFunction l x = error "Return of function from foreign call is not supported"

376+c_irts FFunctionIO l x = error "Return of function from foreign call is not supported"

362

377

363irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"

378irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"

364irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x

379irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x

@@ -370,6 +385,10 @@ irts_c FPtr x = "GETPTR(" ++ x ++ ")"

370irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"

385irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"

371irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"

386irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"

372irts_c FAny x = x

387irts_c FAny x = x

388+irts_c FFunctionIO x = wrapped x

389+irts_c FFunction x = wrapped x

390+

391+wrapped x = "_idris_get_wrapper(" ++ x ++ ")"

373

392

374bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"

393bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"

375

394

@@ -713,3 +732,113 @@ hdr_export (ExportFun n cn ret args)

713 showArgs ts

732 showArgs ts

714

733

715 argNames = zipWith (++) (repeat "arg") (map show [0..])

734 argNames = zipWith (++) (repeat "arg") (map show [0..])

735+

736+------------------ Callback wrapper generation ----------------

737+-- Generate callback wrappers and a function to select the

738+-- correct wrapper function to pass.

739+-- TODO: This is limited to functions that are specified in

740+-- the foreign call. Otherwise we would have to generate wrappers for all

741+-- functions with correct arity or do flow analysis

742+-- to find all possible inputs to the foreign call.

743+genWrappers :: [(Name, [BC])] -> String

744+genWrappers bcs = let

745+ tags = nubBy (\x y -> snd x == snd y) $ concatMap (getCallback . snd) bcs

746+ in

747+ case tags of

748+ [] -> ""

749+ t -> concatMap genWrapper t ++ genDispatcher t

750+

751+genDispatcher :: [(FDesc, Int)] -> String

752+genDispatcher tags = "void* _idris_get_wrapper(VAL con)\n" ++

753+ "{\n" ++

754+ indent 1 ++ "switch(TAG(con)) {\n" ++

755+ concatMap makeSwitch tags ++

756+ indent 1 ++ "}\n" ++

757+ indent 1 ++ "fprintf(stderr, \"No wrapper for callback\");\n" ++

758+ indent 1 ++ "exit(-1);\n" ++

759+ "}\n\n"

760+ where

761+ makeSwitch (_, tag) =

762+ indent 1 ++ "case " ++ show tag ++ ":\n" ++

763+ indent 2 ++ "return (void*) &" ++ wrapperName tag ++ ";\n"

764+

765+genWrapper :: (FDesc, Int) -> String

766+genWrapper (desc, tag) | (toFType desc) == FFunctionIO =

767+ error $ "Cannot create C callbacks for IO functions, wrap them with unsafePerformIO.\n"

768+genWrapper (desc, tag) = ret ++ " " ++ wrapperName tag ++ "(" ++

769+ renderArgs argList ++")\n" ++

770+ "{\n" ++

771+ (if ret /= "void" then indent 1 ++ ret ++ " ret;\n" else "") ++

772+ indent 1 ++ "VM* vm = get_vm();\n" ++

773+ indent 1 ++ "if (vm == NULL) {\n" ++

774+ indent 2 ++ "fprintf(stderr, \"No vm available in callback.\");\n" ++

775+ indent 2 ++ "exit(-1);\n" ++

776+ indent 1 ++ "}\n" ++

777+ indent 1 ++ "INITFRAME;\n" ++

778+ indent 1 ++ "RESERVE(" ++ show (len + 1) ++ ");\n" ++

779+ indent 1 ++ "allocCon(REG1, vm, " ++ show tag ++ ",0 , 0);\n" ++

780+ indent 1 ++ "TOP(0) = REG1;\n" ++

781+

782+ push 1 argList ++

783+ indent 1 ++ "STOREOLD;\n" ++

784+ indent 1 ++ "BASETOP(0);\n" ++

785+ indent 1 ++ "ADDTOP(" ++ show (len + 1) ++ ");\n" ++

786+ indent 1 ++ "CALL(_idris__123_APPLY0_125_);\n" ++

787+ if ret /= "void"

788+ then indent 1 ++ "ret = " ++ irts_c (toFType ft) "RVAL" ++ ";\n"

789+ ++ indent 1 ++ "return ret;\n}"

790+ else "}\n"

791+ where

792+ (ret, ft) = rty desc

793+ argList = zip (args desc) [0..]

794+ len = length argList

795+ renderArgs [] = "void"

796+ renderArgs [((s, _), n)] = s ++ " a" ++ (show n)

797+ renderArgs (((s, _), n):xs) = s ++ " a" ++ (show n) ++ ", " ++

798+ renderArgs xs

799+ rty (FApp c [_,ty])

800+ | c == sUN "C_FnBase" = (ctype ty, ty)

801+ | c == sUN "C_FnIO" = (ctype ty, ty)

802+ | c == sUN "C_FnT" = rty ty

803+ rty (FApp c [_,_,ty,fn])

804+ | c == sUN "C_Fn" = rty fn

805+ rty x = ("", x)

806+ args (FApp c [_,ty])

807+ | c == sUN "C_FnBase" = []

808+ | c == sUN "C_FnIO" = []

809+ | c == sUN "C_FnT" = args ty

810+ args (FApp c [_,_,ty,fn])

811+ | toFType ty == FUnit = []

812+ | c == sUN "C_Fn" = (ctype ty, ty) : args fn

813+ args _ = []

814+ push i [] = ""

815+ push i (((c, t), n) : ts) = indent 1 ++ c_irts (toFType t)

816+ ("TOP(" ++ show i ++ ") = ") ("a" ++ show n)

817+ ++ ";\n" ++ push (i + 1) ts

818+

819+wrapperName :: Int -> String

820+wrapperName tag = "_idris_wrapper_" ++ show tag

821+

822+getCallback :: [BC] -> [(FDesc, Int)]

823+getCallback bc = getCallback' (reverse bc)

824+ where

825+ getCallback' (x:xs) = case hasCallback x of

826+ [] -> getCallback' xs

827+ cbs -> case findCons cbs xs of

828+ [] -> error "Idris function couldn't be wrapped."

829+ x -> x

830+ getCallback' [] = []

831+ findCons (c:cs) xs = findCon c xs ++ findCons cs xs

832+ findCons [] _ = []

833+ findCon c ((MKCON l loc tag args):xs) | snd c == l = [(fst c, tag)]

834+ findCon c (_:xs) = findCon c xs

835+ findCon c [] = []

836+

837+hasCallback :: BC -> [(FDesc, Reg)]

838+hasCallback (FOREIGNCALL l rty (FStr fn) args) = filter isFn args

839+ where

840+ isFn (desc,_) = case toFType desc of

841+ FFunction -> True

842+ FFunctionIO -> True

843+ _ -> False

844+hasCallback _ = []

test/Makefile+1−1

@@ -12,7 +12,7 @@ info: runtest

12 @./runtest $(patsubst %.test,%,$@) -q

14test_js: runtest

15− @./runtest without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 basic007 basic011 ffi006 primitives005 opts --codegen node

15+ @./runtest without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 basic007 basic011 ffi006 ffi007 primitives005 opts --codegen node

17update: runtest

18 @./runtest all -u

test/ffi007/expectednew file+5

@@ -0,0 +1,5 @@

1+8

2+5

3+Before calling callback

4+In an Idris callback

5+After calling callback

test/ffi007/ffi007.cnew file+21

@@ -0,0 +1,21 @@

1+#include <stdio.h>

3+typedef int (*callback)(int);

4+typedef int (*cb2)(char *);

6+void test_ffi(callback cb)

7+{

8+ printf("%d\n", cb(3));

9+}

10+

11+void test_ffi2(cb2 cb)

12+{

13+ printf("%d\n", cb("hello"));

14+}

15+

16+void test_ffi3(void (*cb)(void))

17+{

18+ printf("Before calling callback\n");

19+ cb();

20+ printf("After calling callback\n");

21+}

test/ffi007/ffi007.hnew file+4

@@ -0,0 +1,4 @@

1+void test_ffi(int (*cb)(int));

3+void test_ffi2(int (*cb)(char*));

4+void test_ffi3(void (*cb)(void));

test/ffi007/ffi007.idrnew file+35

@@ -0,0 +1,35 @@

1+module Main

3+%include c "ffi007.h"

5+getInt : Int -> Int

6+getInt _ = 8

8+test : IO ()

9+test = foreign FFI_C "test_ffi" (CFnPtr (Int -> Int) -> IO ()) (MkCFnPtr getInt)

10+

11+strLen : String -> Int

12+strLen s = cast $ length s

13+

14+test2 : IO ()

15+test2 = foreign FFI_C "test_ffi2" (CFnPtr (String -> Int) -> IO ()) (MkCFnPtr strLen)

16+

17+-- Do IO

18+printIt : () -> ()

19+printIt _ = unsafePerformIO $ do

20+ putStrLn "In an Idris callback"

21+

22+test3 : IO ()

23+test3 = foreign FFI_C "test_ffi3" (CFnPtr (() -> ()) -> IO ()) (MkCFnPtr printIt)

24+

25+test4 : IO Ptr

26+test4 = foreign FFI_C "_idris_get_wrapper" (CFnPtr (() -> ()) -> IO Ptr) (MkCFnPtr printIt)

27+

28+

29+main : IO ()

30+main = do

31+ test

32+ test2

33+ test3

34+ ptr <- test4

35+ return ()

test/ffi007/runnew file+4

@@ -0,0 +1,4 @@

1+#!/usr/bin/env bash

2+${IDRIS:-idris} $@ ffi007.idr -o ffi007 --cg-opt "ffi007.c"

3+./ffi007

4+rm -f ffi007 *.ibc