added fibers code

imaginary/fibers-dev/ChangeLog.md

@@ -0,0 +1,5 @@
+# Revision history for eta-fibers
+
+## 0.1.0.0  -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

imaginary/fibers-dev/LICENSE

@@ -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.

imaginary/fibers-dev/Main.hs

@@ -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 ()

imaginary/fibers-dev/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

imaginary/fibers-dev/desktop.ini

@@ -0,0 +1,5 @@
+[.ShellClassInfo]
+InfoTip=Esta carpeta se ha compartido online.
+IconFile=C:\Program Files (x86)\Google\Drive\googledrivesync.exe
+IconIndex=16
+

imaginary/fibers-dev/fibers-dev.cabal

@@ -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

imaginary/fibers-dev/prim/PrimOps.java

@@ -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;
+        }
+    }
+}

imaginary/fibers-dev/prim/desktop.ini

@@ -0,0 +1,5 @@
+[.ShellClassInfo]
+InfoTip=Esta carpeta se ha compartido online.
+IconFile=C:\Program Files (x86)\Google\Drive\googledrivesync.exe
+IconIndex=16
+

imaginary/fibers-dev/src/Control/Concurrent/Fiber.hs

@@ -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)