git.iko.soy/Idris-dev
on master help sign in
Install support headers; allow arbitrary types in foreign calls
46b7a4eEdwin Brady
lib/io.idr+8−7
compare with master
unifiedsplit
@@ -18,15 +18,16 @@ io_return x = prim__IO x
18run__IO : IO () -> IO ()
18run__IO : IO () -> IO ()
19run__IO v = io_bind v (\v' => io_return v')
19run__IO v = io_bind v (\v' => io_return v')
20
20
21−data FTy = FInt | FFloat | FChar | FString | FPtr | FUnit
21+data FTy = FInt | FFloat | FChar | FString | FPtr | FAny Set | FUnit
22
22
23interpFTy : FTy -> Set
23interpFTy : FTy -> Set
24−interpFTy FInt = Int
24+interpFTy FInt = Int
25−interpFTy FFloat = Float
25+interpFTy FFloat = Float
26−interpFTy FChar = Char
26+interpFTy FChar = Char
27−interpFTy FString = String
27+interpFTy FString = String
28−interpFTy FPtr = Ptr
28+interpFTy FPtr = Ptr
29−interpFTy FUnit = ()
29+interpFTy (FAny t) = t
30+interpFTy FUnit = ()
30
31
31ForeignTy : (xs:List FTy) -> (t:FTy) -> Set
32ForeignTy : (xs:List FTy) -> (t:FTy) -> Set
32ForeignTy xs t = mkForeign' (reverse xs) (IO (interpFTy t)) where
33ForeignTy xs t = mkForeign' (reverse xs) (IO (interpFTy t)) where
src/Idris/Compiler.hs+15−6
@@ -32,9 +32,11 @@ compile f tm
32 objs <- getObjectFiles
32 objs <- getObjectFiles
33 libs <- getLibs
33 libs <- getLibs
34 hdrs <- getHdrs
34 hdrs <- getHdrs
35− let incs = map Include hdrs
36− so <- getSO
37 ddir <- liftIO $ getDataDir
35 ddir <- liftIO $ getDataDir
36+ -- if any includes exist in the data directory, use that
37+ hdrs' <- liftIO $ mapM (inDir ddir) hdrs
38+ let incs = map Include hdrs'
39+ so <- getSO
38 let ilib = ddir ++ "/libidris.a"
40 let ilib = ddir ++ "/libidris.a"
39 case so of
41 case so of
40 Nothing ->
42 Nothing ->
@@ -47,6 +49,10 @@ compile f tm
47 case idris_metavars i \\ primDefs of
49 case idris_metavars i \\ primDefs of
48 [] -> return ()
50 [] -> return ()
49 ms -> fail $ "There are undefined metavariables: " ++ show ms
51 ms -> fail $ "There are undefined metavariables: " ++ show ms
52+ inDir d h = do let f = d ++ "/" ++ h
53+ ex <- doesFileExist f
54+ if ex then return f else return h
55+
50
56
51allNames :: [Name] -> Name -> Idris [Name]
57allNames :: [Name] -> Name -> Idris [Name]
52allNames ns n | n `elem` ns = return []
58allNames ns n | n `elem` ns = return []
@@ -151,9 +157,9 @@ instance ToEpic (TT Name) where
151
157
152doForeign :: [TT Name] -> Idris E.Term
158doForeign :: [TT Name] -> Idris E.Term
153doForeign (_ : fgn : args)
159doForeign (_ : fgn : args)
154− | (_, (Constant (Str fgnName) : fgnArgTys : P _ (UN ret) _ : [])) <- unApply fgn
160+ | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn
155 = let tys = getFTypes fgnArgTys
161 = let tys = getFTypes fgnArgTys
156− rty = mkEty ret in
162+ rty = mkEty' ret in
157 do args' <- mapM epic args
163 do args' <- mapM epic args
158 -- wrap it in a prim__IO
164 -- wrap it in a prim__IO
159 -- return $ con_ 0 @@ impossible @@
165 -- return $ con_ 0 @@ impossible @@
@@ -163,9 +169,12 @@ doForeign (_ : fgn : args)
163getFTypes :: TT Name -> [E.Type]
169getFTypes :: TT Name -> [E.Type]
164getFTypes tm = case unApply tm of
170getFTypes tm = case unApply tm of
165 (nil, []) -> []
171 (nil, []) -> []
166− (cons, [(P _ (UN ty) _), xs]) ->
172+ (cons, [ty, xs]) ->
167 let rest = getFTypes xs in
173 let rest = getFTypes xs in
168− mkEty ty : rest
174+ mkEty' ty : rest
175+
176+mkEty' (P _ (UN ty) _) = mkEty ty
177+mkEty' _ = tyAny
169
178
170mkEty "FInt" = tyInt
179mkEty "FInt" = tyInt
171mkEty "FFloat" = tyFloat
180mkEty "FFloat" = tyFloat
support/Makefile+4−1
@@ -1,4 +1,6 @@
1−OBJS = testidr.o
1+OBJS = network.o testidr.o
2+HDRS = network.h testidr.h
3+
2CFLAGS = `epic -includedirs`
4CFLAGS = `epic -includedirs`
3
5
4LIBTARGET = libidris.a
6LIBTARGET = libidris.a
@@ -8,5 +10,6 @@ check: $(OBJS)
8
10
9install: check
11install: check
10 install $(LIBTARGET) $(TARGET)
12 install $(LIBTARGET) $(TARGET)
13+ install $(HDRS) $(TARGET)
11
14
12.PHONY:
15.PHONY:
support/network.cnew file+260
@@ -0,0 +1,260 @@
1+#include <stdio.h>
2+#include <sys/types.h>
3+#include <sys/socket.h>
4+#include <netinet/in.h>
5+#include <arpa/inet.h>
6+#include <unistd.h>
7+#include <string.h>
8+#include <fcntl.h>
9+#include <errno.h>
10+#include <closure.h>
11+
12+#include "network.h"
13+
14+int isReadable(int sd, int timeOut) { // milliseconds
15+ fd_set socketReadSet;
16+ FD_ZERO(&socketReadSet);
17+ FD_SET(sd,&socketReadSet);
18+ struct timeval tv;
19+ if (timeOut) {
20+ tv.tv_sec = timeOut / 1000;
21+ tv.tv_usec = (timeOut % 1000) * 1000;
22+ } else {
23+ tv.tv_sec = 0;
24+ tv.tv_usec = 0;
25+ } // if
26+ if (select(sd+1,&socketReadSet,0,0,&tv) == -1) {
27+ printf("READ ERROR!\n");
28+ return 0;
29+ } // if
30+ return FD_ISSET(sd,&socketReadSet) != 0;
31+} /* isReadable */
32+
33+void* net_UDP_clientSocket(char* server, int port) {
34+ srand(12345); //time(NULL));
35+
36+ Connection* con = (Connection*)EMALLOC(sizeof(Connection));
37+ int s;
38+ struct sockaddr_in si_me, si_other;
39+
40+ if ((s=socket(AF_INET, SOCK_DGRAM, 0))==-1) {
41+ printf("FAIL 1\n");
42+ return NULL;
43+ }
44+
45+ memset((char *) &si_other, 0, sizeof(si_other));
46+ si_other.sin_family = AF_INET;
47+ si_other.sin_port = htons(port);
48+
49+ if (inet_aton(server, &si_other.sin_addr)==0) {
50+ printf("FAIL 2\n");
51+ return NULL;
52+ }
53+
54+ // Bind, so we can receive replies.
55+ si_me.sin_family = AF_INET;
56+ si_me.sin_port = htons(0);
57+ si_me.sin_addr.s_addr = htonl(INADDR_ANY);
58+
59+ if (bind(s, (struct sockaddr*)&si_me, sizeof(si_me))<0) {
60+ return NULL;
61+ }
62+
63+ con->sock = s;
64+ con->addr = si_other;
65+
66+// printf("Opened client socket %d\n", s);
67+ return con;
68+}
69+
70+void* net_UDP_serverSocket(int port) {
71+ srand(time(NULL));
72+
73+ Connection* con = (Connection*)EMALLOC(sizeof(Connection));
74+ int s;
75+ struct sockaddr_in si_me;
76+
77+ if ((s=socket(AF_INET, SOCK_DGRAM, 0))==-1) {
78+ return NULL;
79+ }
80+
81+ memset((char *) &si_me, 0, sizeof(si_me));
82+ si_me.sin_family = AF_INET;
83+ si_me.sin_port = htons(port);
84+ si_me.sin_addr.s_addr = htonl(INADDR_ANY);
85+ if (bind(s, (struct sockaddr*)&si_me, sizeof(si_me))==-1) {
86+ return NULL;
87+ }
88+
89+ con->sock = s;
90+ con->addr = si_me;
91+
92+// printf("Opened server socket %d\n", s);
93+ return con;
94+}
95+
96+int net_sendUDP(void* conn, char* server, int port, char* stuff) {
97+// printf("Socket is %d\n", conn);
98+ if (0) { //rand()%50000 == 0) {
99+ printf("DROP\n");
100+ return 0;
101+ }
102+
103+
104+ Connection* c = (Connection*)conn;
105+ int s = c->sock;
106+ struct sockaddr_in other = c->addr;
107+ memset((char *) &other, 0, sizeof(other));
108+ other.sin_family = AF_INET;
109+ other.sin_port = htons(port);
110+ if (inet_aton(server, &other.sin_addr)==0) {
111+ printf("FAIL 3\n");
112+ return -1;
113+ }
114+
115+ if (sendto(s, stuff, strlen(stuff), 0, (struct sockaddr*)&other,
116+ sizeof(other))==-1) {
117+ printf("Send FAIL\n");
118+ return -1;
119+ }
120+// printf("Send WIN, to %s %d %d\n", inet_ntoa(other.sin_addr),
121+// ntohs(other.sin_port), port);
122+ return 0;
123+}
124+
125+void* net_recvUDP(void* conn) {
126+ struct sockaddr_in other;
127+ Connection* c = (Connection*)conn;
128+ int s = c->sock;
129+ socklen_t slen = sizeof(other);
130+ struct sockaddr_in me = c->addr;
131+
132+ // TMP HACK: 512 should be enough for the purposes of this experiment...
133+ // Do it properly some time.
134+ char* buf = (char*)EMALLOC(512*sizeof(char));
135+
136+// printf("Waiting to receive\n");
137+
138+ int error;
139+// while (!isReadable(s,100)) printf(".");
140+
141+ if (!isReadable(s, 1000)) {
142+ printf("Nothing\n");
143+ return NULL;
144+ }
145+
146+ if (recvfrom(s, buf, 512, 0, (struct sockaddr *)&other, &slen)==-1) {
147+ printf("Nothing\n");
148+ return NULL;
149+ }
150+
151+/* printf("Received %s from %s:UDP%u\n",
152+ buf,inet_ntoa(other.sin_addr),
153+ ntohs(other.sin_port));
154+*/
155+ // return a structure with the received value, and where it came from.
156+ Recv* r = (Recv*)EMALLOC(sizeof(Recv));
157+ r->buf = buf;
158+ r->server = inet_ntoa(other.sin_addr);
159+ r->port = ntohs(other.sin_port);
160+
161+ return (void*)r;
162+}
163+
164+char* get_recvBuf(void* recv) {
165+ return ((Recv*)recv)->buf;
166+}
167+
168+char* get_recvServer(void* recv) {
169+ return ((Recv*)recv)->server;
170+}
171+
172+int get_recvPort(void* recv) {
173+ return ((Recv*)recv)->port;
174+}
175+
176+int nullPtr(void *ptr) {
177+ return ptr==NULL;
178+}
179+
180+// Just to see if the idris FFI is working, and happily talking to .o files...
181+int netTest(char* strTest, int num) {
182+ int i;
183+ for(i=0;i<num;++i) {
184+ printf("%s\n",strTest);
185+ }
186+
187+ return i;
188+}
189+
190+void net_sendRaw(void* conn, char* server, int port, VAL pkt)
191+{
192+ int seq = GETINT(PROJECT(pkt, 0));
193+ VAL ty = PROJECT(pkt, 1);
194+ int pty;
195+
196+ switch(TAG(ty)) {
197+ case 0:
198+ pty = 0;
199+ break;
200+ case 1:
201+ pty = 1;
202+ break;
203+ case 2:
204+ pty = TAG(PROJECT(ty,0)) + 2;
205+ }
206+
207+ char* buf = (char*)EMALLOC(512*sizeof(char));
208+ sprintf(buf, "%d %d", seq, pty);
209+
210+ net_sendUDP(conn, server, port, buf);
211+}
212+
213+VAL net_recvRaw(void* conn)
214+{
215+ int seq, pty;
216+
217+ void* dat = net_recvUDP(conn);
218+ if (dat==NULL) {
219+ return CONSTRUCTOR(1,0,NULL); // Nothing
220+ }
221+ else {
222+ char* recvBuf = get_recvBuf(dat);
223+
224+ sscanf(recvBuf, "%d %d", &seq, &pty);
225+ VAL ptyc = NULL;
226+ if (pty<2) {
227+ ptyc = CONSTRUCTOR(pty,0,NULL);
228+ } else {
229+ ptyc = CONSTRUCTOR1(2, CONSTRUCTOR(pty-2,0,NULL));
230+ }
231+ VAL pkt = CONSTRUCTOR2(0, MKINT(seq), ptyc);
232+ printf("Received %d %d\n", seq, pty);
233+
234+ VAL recvpkt = CONSTRUCTOR3(0, pkt, MKSTR(get_recvServer(dat)),
235+ MKINT(get_recvPort(dat)));
236+
237+ return CONSTRUCTOR1(0, recvpkt); // Just pkt
238+ }
239+
240+}
241+
242+void dumpPkt(VAL pkt)
243+{
244+ int seq = GETINT(PROJECT(pkt, 0));
245+ VAL ty = PROJECT(pkt, 1);
246+ int pty;
247+
248+ switch(TAG(ty)) {
249+ case 0:
250+ pty = 0;
251+ break;
252+ case 1:
253+ pty = 1;
254+ break;
255+ case 2:
256+ pty = TAG(PROJECT(ty,0)) + 2;
257+ }
258+
259+ printf("%d %d\n", seq, pty);
260+}
support/network.hnew file+36
@@ -0,0 +1,36 @@
1+#include <stdio.h>
2+#include <sys/types.h>
3+#include <sys/socket.h>
4+#include <netinet/in.h>
5+#include <arpa/inet.h>
6+#include <unistd.h>
7+#include <string.h>
8+#include <closure.h>
9+
10+typedef struct {
11+ int sock;
12+ struct sockaddr_in addr;
13+} Connection;
14+
15+typedef struct {
16+ unsigned port;
17+ char* buf;
18+ char* server;
19+} Recv;
20+
21+int netTest(char* strTest, int num);
22+void* net_UDP_serverSocket(int port);
23+void* net_UDP_clientSocket(char* server, int port);
24+
25+int nullPtr(void *ptr);
26+
27+int net_sendUDP(void* conn, char* server, int port, char* stuff);
28+void* net_recvUDP(void* conn);
29+
30+char* get_recvBuf(void* recv);
31+char* get_recvServer(void* recv);
32+int get_recvPort(void* recv);
33+
34+void net_sendRaw(void* conn, char* server, int port, VAL pkt);
35+VAL net_recvRaw(void* conn);
36+void dumpPkt(VAL pkt);