Skip to content
Browse files

Add mkLazyForeign primitive

  • Loading branch information...
1 parent 2316dc9 commit 66334835dd87e385692218bc2d053a57a106c6b9 Edwin Brady committed Apr 27, 2012
Showing with 44 additions and 32 deletions.
  1. +2 −1 lib/io.idr
  2. +3 −0 lib/system.idr
  3. +9 −5 src/Idris/Compiler.hs
  4. +2 −2 support/Makefile
  5. +27 −22 support/threads.c
  6. +1 −2 support/threads.h
View
3 lib/io.idr
@@ -41,6 +41,7 @@ data Foreign : Set -> Set where
Foreign (ForeignTy xs t)
mkForeign : Foreign x -> x
--- mkForeign compiled as primitive
+mkLazyForeign : Foreign x -> x
+-- mkForeign and mkLazyForeign compiled as primitives
View
3 lib/system.idr
@@ -25,3 +25,6 @@ getEnv x = mkForeign (FFun "getenv" [FString] FString) x
exit : Int -> IO ()
exit code = mkForeign (FFun "exit" [FInt] FUnit) code
+usleep : Int -> IO ()
+usleep i = mkForeign (FFun "usleep" [FInt] FUnit) i
+
View
14 src/Idris/Compiler.hs
@@ -21,7 +21,7 @@ import Paths_idris
import Epic.Epic hiding (Term, Type, Name, fn, compile)
import qualified Epic.Epic as E
-primDefs = [UN "mkForeign", UN "FalseElim"]
+primDefs = [UN "mkLazyForeign", UN "mkForeign", UN "FalseElim"]
compile :: FilePath -> Term -> Idris ()
compile f tm
@@ -102,7 +102,9 @@ instance ToEpic (TT Name) where
epic tm = epic' [] tm where
epic' env tm@(App f a)
| (P _ (UN "mkForeign") _, args) <- unApply tm
- = doForeign args
+ = doForeign False args
+ | (P _ (UN "mkLazyForeign") _, args) <- unApply tm
+ = doForeign True args
| (P _ (UN "lazy") _, [_,arg]) <- unApply tm
= do arg' <- epic' env arg
return $ lazy_ arg'
@@ -155,15 +157,17 @@ instance ToEpic (TT Name) where
buildApp env (e @@ x') xs
-doForeign :: [TT Name] -> Idris E.Term
-doForeign (_ : fgn : args)
+doForeign :: Bool -> [TT Name] -> Idris E.Term
+doForeign lazy (_ : fgn : args)
| (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn
= let tys = getFTypes fgnArgTys
rty = mkEty' ret in
do args' <- mapM epic args
-- wrap it in a prim__IO
-- return $ con_ 0 @@ impossible @@
- return $ lazy_ $ foreign_ rty fgnName (zip args' tys)
+ if lazy
+ then return $ lazy_ $ foreignL_ rty fgnName (zip args' tys)
+ else return $ lazy_ $ foreign_ rty fgnName (zip args' tys)
| otherwise = fail "Badly formed foreign function call"
getFTypes :: TT Name -> [E.Type]
View
4 support/Makefile
@@ -1,5 +1,5 @@
-OBJS = network.o testidr.o
-HDRS = network.h testidr.h
+OBJS = network.o threads.o testidr.o
+HDRS = network.h threads.h testidr.h
CFLAGS = `epic -includedirs`
View
49 support/threads.c
@@ -5,72 +5,77 @@
typedef struct {
pthread_mutex_t m_id;
-} Mutex;
+} IdrisMutex;
typedef struct {
pthread_t t_id;
-} Thread;
+} IdrisThread;
-Mutex** ms = NULL;
-int mutexes = 0;
+IdrisMutex** idris_ms = NULL;
+int idris_mutexes = 0;
-int idris_newLock(int sem)
+int idris_newLock()
{
pthread_mutex_t m;
pthread_mutex_init(&m, NULL);
- Mutex* newm = EMALLOC(sizeof(Mutex));
+ IdrisMutex* newm = EMALLOC(sizeof(IdrisMutex));
newm->m_id = m;
// Increase space for the mutexes
- if (ms==NULL) {
- ms = (Mutex**)EMALLOC(sizeof(Mutex*));
- mutexes=1;
+ if (idris_ms==NULL) {
+ idris_ms = (IdrisMutex**)EMALLOC(sizeof(IdrisMutex*));
+ idris_mutexes=1;
} else {
- ms = (Mutex**)(EREALLOC(ms, sizeof(Mutex*)*(mutexes+1)));
- mutexes++;
+ idris_ms = (IdrisMutex**)(EREALLOC(idris_ms, sizeof(IdrisMutex*)*(idris_mutexes+1)));
+ idris_mutexes++;
}
- ms[mutexes-1] = newm;
- return mutexes-1;
+ idris_ms[idris_mutexes-1] = newm;
+ return idris_mutexes-1;
}
void idris_doLock(int lock)
{
- pthread_mutex_lock(&(ms[lock]->m_id));
+ pthread_mutex_lock(&(idris_ms[lock]->m_id));
}
void idris_doUnlock(int lock)
{
- pthread_mutex_unlock(&(ms[lock]->m_id));
+ pthread_mutex_unlock(&(idris_ms[lock]->m_id));
}
-struct threadinfo {
+struct idris_threadinfo {
void* proc;
void* result;
};
void* idris_runThread(void* th_in) {
- struct threadinfo* th = (struct threadinfo*)th_in;
- void* v = DO_EVAL(th->proc, 1);
+ printf("IN THREAD\n");
+ struct idris_threadinfo* th = (struct idris_threadinfo*)th_in;
+ printf("using %d\n", th_in);
+ void* v = DO_EVAL(th_in, 1);
th->result = v;
return v;
}
void idris_doFork(void* proc)
{
- pthread_t* t = EMALLOC(sizeof(pthread_t));
- struct threadinfo th;
+ printf("FORKING!\n");
+ pthread_t* t = malloc(sizeof(pthread_t));
+ struct idris_threadinfo th;
+ printf("in %d\n", proc);
th.proc = proc;
th.result = NULL;
- pthread_create(t, NULL, idris_runThread, &th);
+ pthread_create(t, NULL, idris_runThread, proc);
+ printf("FORKED!\n");
}
void* idris_doWithin(int limit, void* proc, void* doOnFail)
{
pthread_t* t = EMALLOC(sizeof(pthread_t));
// printf("CREATING THREAD %d\n", t);
- struct threadinfo th;
+ struct idris_threadinfo th;
th.proc = proc;
th.result = NULL;
View
3 support/threads.h
@@ -1,8 +1,7 @@
#ifndef _THREADS_H
#define _THREADS_H
-
-int idris_newLock(int sem);
+int idris_newLock();
void idris_doLock(int lock);
void idris_doUnlock(int lock);
void idris_doFork(void* proc);

0 comments on commit 6633483

Please sign in to comment.
Something went wrong with that request. Please try again.