6633483 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

Add mkLazyForeign primitive

commit66334835dd87e385692218bc2d053a57a106c6b9 authorEdwin Brady <eb@cs.st-andrews.ac.uk> dateFri 27 Apr 2012, 11:14 (15 years ago) parent2316dc9

6 files changed+44−32

compare with master

unifiedsplit

lib/io.idr+2−1 lib/system.idr+3 src/Idris/Compiler.hs+9−5 support/Makefile+2−2 support/threads.c+27−22 support/threads.h+1−2

lib/io.idr+2−1

@@ -41,6 +41,7 @@ data Foreign : Set -> Set where

4141 Foreign (ForeignTy xs t)

4242

4343mkForeign : Foreign x -> x

44−-- mkForeign compiled as primitive

44+mkLazyForeign : Foreign x -> x

45+-- mkForeign and mkLazyForeign compiled as primitives

4546

4647

lib/system.idr+3

@@ -25,3 +25,6 @@ getEnv x = mkForeign (FFun "getenv" [FString] FString) x

2525exit : Int -> IO ()

2626exit code = mkForeign (FFun "exit" [FInt] FUnit) code

2727

28+usleep : Int -> IO ()

29+usleep i = mkForeign (FFun "usleep" [FInt] FUnit) i

30+

src/Idris/Compiler.hs+9−5

@@ -21,7 +21,7 @@ import Paths_idris

2121import Epic.Epic hiding (Term, Type, Name, fn, compile)

2222import qualified Epic.Epic as E

2323

24−primDefs = [UN "mkForeign", UN "FalseElim"]

24+primDefs = [UN "mkLazyForeign", UN "mkForeign", UN "FalseElim"]

2525

2626compile :: FilePath -> Term -> Idris ()

2727compile f tm

@@ -102,7 +102,9 @@ instance ToEpic (TT Name) where

102102 epic tm = epic' [] tm where

103103 epic' env tm@(App f a)

104104 | (P _ (UN "mkForeign") _, args) <- unApply tm

105− = doForeign args

105+ = doForeign False args

106+ | (P _ (UN "mkLazyForeign") _, args) <- unApply tm

107+ = doForeign True args

106108 | (P _ (UN "lazy") _, [_,arg]) <- unApply tm

107109 = do arg' <- epic' env arg

108110 return $ lazy_ arg'

@@ -155,15 +157,17 @@ instance ToEpic (TT Name) where

155157 buildApp env (e @@ x') xs

156158

157159

158−doForeign :: [TT Name] -> Idris E.Term

159−doForeign (_ : fgn : args)

160+doForeign :: Bool -> [TT Name] -> Idris E.Term

161+doForeign lazy (_ : fgn : args)

160162 | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn

161163 = let tys = getFTypes fgnArgTys

162164 rty = mkEty' ret in

163165 do args' <- mapM epic args

164166 -- wrap it in a prim__IO

165167 -- return $ con_ 0 @@ impossible @@

166− return $ lazy_ $ foreign_ rty fgnName (zip args' tys)

168+ if lazy

169+ then return $ lazy_ $ foreignL_ rty fgnName (zip args' tys)

170+ else return $ lazy_ $ foreign_ rty fgnName (zip args' tys)

167171 | otherwise = fail "Badly formed foreign function call"

168172

169173getFTypes :: TT Name -> [E.Type]

support/Makefile+2−2

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

1−OBJS = network.o testidr.o

2−HDRS = network.h testidr.h

1+OBJS = network.o threads.o testidr.o

2+HDRS = network.h threads.h testidr.h

44CFLAGS = `epic -includedirs`

support/threads.c+27−22

@@ -5,72 +5,77 @@

66typedef struct {

77 pthread_mutex_t m_id;

8−} Mutex;

8+} IdrisMutex;

1010typedef struct {

1111 pthread_t t_id;

12−} Thread;

12+} IdrisThread;

1313

14−Mutex** ms = NULL;

15−int mutexes = 0;

14+IdrisMutex** idris_ms = NULL;

15+int idris_mutexes = 0;

1616

17−int idris_newLock(int sem)

17+int idris_newLock()

1818{

1919 pthread_mutex_t m;

2020

2121 pthread_mutex_init(&m, NULL);

22− Mutex* newm = EMALLOC(sizeof(Mutex));

22+ IdrisMutex* newm = EMALLOC(sizeof(IdrisMutex));

2323 newm->m_id = m;

2424

2525 // Increase space for the mutexes

26− if (ms==NULL) {

27− ms = (Mutex**)EMALLOC(sizeof(Mutex*));

28− mutexes=1;

26+ if (idris_ms==NULL) {

27+ idris_ms = (IdrisMutex**)EMALLOC(sizeof(IdrisMutex*));

28+ idris_mutexes=1;

2929 } else {

30− ms = (Mutex**)(EREALLOC(ms, sizeof(Mutex*)*(mutexes+1)));

31− mutexes++;

30+ idris_ms = (IdrisMutex**)(EREALLOC(idris_ms, sizeof(IdrisMutex*)*(idris_mutexes+1)));

31+ idris_mutexes++;

3232 }

3333

34− ms[mutexes-1] = newm;

35− return mutexes-1;

34+ idris_ms[idris_mutexes-1] = newm;

35+ return idris_mutexes-1;

3636}

3737

3838void idris_doLock(int lock)

3939{

40− pthread_mutex_lock(&(ms[lock]->m_id));

40+ pthread_mutex_lock(&(idris_ms[lock]->m_id));

4141}

4242

4343void idris_doUnlock(int lock)

4444{

45− pthread_mutex_unlock(&(ms[lock]->m_id));

45+ pthread_mutex_unlock(&(idris_ms[lock]->m_id));

4646}

4747

48−struct threadinfo {

48+struct idris_threadinfo {

4949 void* proc;

5050 void* result;

5151};

5252

5353void* idris_runThread(void* th_in) {

54− struct threadinfo* th = (struct threadinfo*)th_in;

55− void* v = DO_EVAL(th->proc, 1);

54+ printf("IN THREAD\n");

55+ struct idris_threadinfo* th = (struct idris_threadinfo*)th_in;

56+ printf("using %d\n", th_in);

57+ void* v = DO_EVAL(th_in, 1);

5658 th->result = v;

5759 return v;

5860}

5961

6062void idris_doFork(void* proc)

6163{

62− pthread_t* t = EMALLOC(sizeof(pthread_t));

63− struct threadinfo th;

64+ printf("FORKING!\n");

65+ pthread_t* t = malloc(sizeof(pthread_t));

66+ struct idris_threadinfo th;

67+ printf("in %d\n", proc);

6468 th.proc = proc;

6569 th.result = NULL;

66− pthread_create(t, NULL, idris_runThread, &th);

70+ pthread_create(t, NULL, idris_runThread, proc);

71+ printf("FORKED!\n");

6772}

6873

6974void* idris_doWithin(int limit, void* proc, void* doOnFail)

7075{

7176 pthread_t* t = EMALLOC(sizeof(pthread_t));

7277// printf("CREATING THREAD %d\n", t);

73− struct threadinfo th;

78+ struct idris_threadinfo th;

7479 th.proc = proc;

7580 th.result = NULL;

7681

support/threads.h+1−2

@@ -1,8 +1,7 @@

11#ifndef _THREADS_H

22#define _THREADS_H

4−

5−int idris_newLock(int sem);

4+int idris_newLock();

65void idris_doLock(int lock);

76void idris_doUnlock(int lock);

87void idris_doFork(void* proc);