Skip to content

added fibers code #2

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 4 commits into
base: master
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 5 additions & 0 deletions imaginary/fibers-dev/ChangeLog.md
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
# Revision history for eta-fibers

## 0.1.0.0 -- YYYY-mm-dd

* First version. Released on an unsuspecting world.
30 changes: 30 additions & 0 deletions imaginary/fibers-dev/LICENSE
Original file line number Diff line number Diff line change
@@ -0,0 +1,30 @@
Copyright (c) 2017, Rahul Muttineni

All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.

* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.

* Neither the name of Rahul Muttineni nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
50 changes: 50 additions & 0 deletions imaginary/fibers-dev/Main.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,50 @@
import Control.Monad
import Control.Concurrent.MVar hiding (takeMVar, putMVar)
import qualified Control.Concurrent.MVar as MVar
import Control.Concurrent.Fiber
import Control.Concurrent.Fiber.MVar
import System.Environment
import GHC.Conc.Sync hiding (yield)
import GHC.Conc.IO
import Java

import Control.Monad.IO.Class

ring = 503

new l i = do
r <- newEmptyMVar
ret <- newEmptyMVar
forkFiber (thread ret i l r)
return (r, ret)

thread :: MVar Int -> Int -> MVar Int -> MVar Int -> Fiber ()
thread ret i l r = go
where go = do
m <- takeMVar l
putMVar r $! m - 1
if (m < 1)
then putMVar ret m
else go

threadring :: Int -> Int -> IO JIntArray
threadring ring msgs = do
setNumCapabilities 1
a <- newMVar msgs
ret <- newEmptyMVar
(z, xs) <- foldM (\(prev, xs) i -> do
(r, ret) <- new prev i
return (r, ret:xs))
(a, []) [2..ring]
forkFiber (thread ret 1 z a)
ints <- mapM MVar.takeMVar (reverse (ret : xs))
return $ toJava ints

foreign export java "@static eta.threadring.ThreadRing.start"
threadring :: Int -> Int -> IO JIntArray

main :: IO ()
main = do
msgs <- fmap (read . head) getArgs
threadring ring msgs
return ()
2 changes: 2 additions & 0 deletions imaginary/fibers-dev/Setup.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain
5 changes: 5 additions & 0 deletions imaginary/fibers-dev/desktop.ini
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
[.ShellClassInfo]
InfoTip=Esta carpeta se ha compartido online.
IconFile=C:\Program Files (x86)\Google\Drive\googledrivesync.exe
IconIndex=16

41 changes: 41 additions & 0 deletions imaginary/fibers-dev/fibers-dev.cabal
Original file line number Diff line number Diff line change
@@ -0,0 +1,41 @@
name: fibers-dev
version: 0.1.0.0
-- synopsis:
-- description:
license: BSD3
license-file: LICENSE
author: Rahul Muttineni
maintainer: [email protected]
-- copyright:
-- category:
build-type: Simple
extra-source-files: ChangeLog.md
cabal-version: >=1.10

library
exposed-modules: Control.Concurrent.Fiber
Control.Concurrent.Fiber.MVar
Control.Concurrent.Fiber.Internal
-- other-extensions:
build-depends: base >=4.8 && <4.9
, transformers
hs-source-dirs: src
java-sources: prim/PrimOps.java
default-language: Haskell2010
default-extensions: InstanceSigs
ScopedTypeVariables
GHCForeignImportPrim
MagicHash
UnboxedTuples
UnliftedFFITypes
ghc-options: -ddump-stg -ddump-to-file

executable Main
main-is: Main.hs
build-depends:
base >=4.8 && <4.9
, transformers
, fibers-dev
default-language: Haskell2010
hs-source-dirs: .
ghc-options: -threaded -rtsopts
157 changes: 157 additions & 0 deletions imaginary/fibers-dev/prim/PrimOps.java
Original file line number Diff line number Diff line change
@@ -0,0 +1,157 @@
package eta.fibers;

import java.util.Queue;
import java.util.Map;
import java.util.Stack;
import java.util.IdentityHashMap;
import java.util.concurrent.ConcurrentHashMap;
import java.util.concurrent.ConcurrentLinkedQueue;
import java.util.concurrent.atomic.AtomicBoolean;

import eta.runtime.stg.Capability;
import eta.runtime.stg.Closure;
import eta.runtime.stg.Closures;
import eta.runtime.stg.StgContext;
import eta.runtime.stg.TSO;
import eta.runtime.concurrent.Concurrent;
import eta.runtime.concurrent.Fiber;
import eta.runtime.concurrent.MVar;
//import eta.runtime.exception;

import static ghc_prim.ghc.Types.*;
import static eta.runtime.stg.TSO.WhatNext.*;
import static eta.runtime.stg.Closures.*;

/* TODO: Provide cleanup operations by extending the runtime with hooks. */


public class PrimOps {
public static class EmptyException extends eta.runtime.exception.StgException {}
public static final EmptyException EMPTYEXCEPTION= new EmptyException();

public static IdentityHashMap<TSO,Closure> tsoEvent = new IdentityHashMap<TSO,Closure>();
public static void throwEmpty(StgContext context){
throw EMPTYEXCEPTION;
}
public static Closure alternativeFiber(StgContext context, Closure fa, Closure fb) {
TSO tso = context.currentTSO;
int oldTop = tso.contStackTop;
try {
return fa.applyV(context);
} catch (EmptyException e) {
tso.contStackTop = oldTop;
tso.currentCont= fb;
return fb.applyV(context);
}
}



public static int topStackC(StgContext context){
return context.currentTSO.contStackTop;

}



public static Object getStackC(StgContext context){
Closure[] newContStack = new Closure[context.currentTSO.contStackTop];
System.arraycopy(context.currentTSO.contStack,0,newContStack,0, context.currentTSO.contStackTop);
return newContStack;
}


public static void setTopStackC(StgContext context,int top){
context.currentTSO.contStackTop= top;
}


public static TSO getTSOC(StgContext context) {
return context.currentTSO;
}

public static void setContStack(StgContext context, int top, Object newContStack,Closure current){
context.currentTSO.contStack= (Closure[]) newContStack;
context.currentTSO.contStackTop= top;
context.currentTSO.currentCont = current;

}

public static Closure getEventCC(StgContext context){
Closure v= tsoEvent.get(context.currentTSO);
if (v==null) context.I1 = 0; else context.I1 = 1;
return v;
}
public static void setEventC(StgContext context,Closure ev){
tsoEvent.put(context.currentTSO,ev);
}

public static void delEventCC(StgContext context){
tsoEvent.remove(context.currentTSO);
}



public static void setCurrentC(StgContext context, Closure action) {
context.currentTSO.currentCont = action;
}

public static void pushNextC(StgContext context, Closure action) {
context.currentTSO.pushCont(action);
}

public static Closure popNextC(StgContext context) {
return context.currentTSO.popCont();
}

public static Closure getCurrentC(StgContext context) {
return context.currentTSO.currentCont;
}

public static Closure popContStack(StgContext context) {
TSO tso = context.currentTSO;
if (tso.emptyContStack()) {
context.I1 = 0;
return null;
} else {
context.I1 = 1;
return tso.popCont();
}
}

public static Closure resumeFiber = null;

static {
try {
resumeFiber = loadClosure("fibers_dev.control.concurrent.fiber.Internal", "resumeFiber");
} catch (Exception e) {
System.err.println("FATAL ERROR: Failed to load resumeFiber closure.");
e.printStackTrace();
System.exit(1);
}
}
public static void yieldFiber(StgContext context, int block) {
TSO tso = context.currentTSO;
tso.whatNext = (block == 1)? ThreadBlock : ThreadYield;
Closure oldClosure = tso.closure;
if (oldClosure instanceof EvalLazyIO) {
((EvalLazyIO) oldClosure).p = resumeFiber;
} else {
oldClosure = Closures.evalLazyIO(resumeFiber);
}
throw Fiber.yieldException.get();
}

public static void addMVarListener(StgContext context, MVar m) {
m.registerListener(context.currentTSO);
}

public static void awakenMVarListeners(StgContext context, MVar m) {
for (TSO top = m.getListeners(); top != null;) {
Concurrent.pushToGlobalRunQueue(top);
TSO oldTop = top;
top = top.link;
oldTop.link = null;
}
}
}
5 changes: 5 additions & 0 deletions imaginary/fibers-dev/prim/desktop.ini
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
[.ShellClassInfo]
InfoTip=Esta carpeta se ha compartido online.
IconFile=C:\Program Files (x86)\Google\Drive\googledrivesync.exe
IconIndex=16

28 changes: 28 additions & 0 deletions imaginary/fibers-dev/src/Control/Concurrent/Fiber.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,28 @@
module Control.Concurrent.Fiber
(Fiber(..)
,runFiber
,forkFiber
,yield
,block
,liftIO

,MVar
,newMVar
,newEmptyMVar
,modifyMVar
,takeMVar
,putMVar

,setNumCapabilities
,getNumCapabilities

,threadDelay
)
where

import Control.Concurrent.Fiber.Internal
import Control.Concurrent.Fiber.MVar
import Control.Monad.IO.Class
import GHC.Conc.Sync hiding (yield)
import GHC.Conc.IO
import Control.Concurrent.MVar (newEmptyMVar, newMVar, modifyMVar)
Loading