stack safe

.eslintrc.json

@@ -19,7 +19,7 @@
     "no-param-reassign": 2,
     "no-return-assign": 2,
     "no-unused-expressions": 2,
-    "no-use-before-define": 2,
+    "no-use-before-define": [2, "nofunc"],
     "radix": [2, "always"],
     "indent": [2, 2, { "SwitchCase": 1 }],
     "quotes": [2, "double"],

.travis.yml

@@ -9,11 +9,12 @@ install:
   - wget -O $HOME/purescript.tar.gz https://github.com/purescript/purescript/releases/download/$TAG/linux64.tar.gz
   - tar -xvf $HOME/purescript.tar.gz -C $HOME/
   - chmod a+x $HOME/purescript
-  - npm install -g bower
   - npm install
-  - bower install
+  - npm run install
 script:
-  - npm run -s build
+  - npm run build
+  - npm run test
+  - npm run bench:start
 after_success:
 - >-
   test $TRAVIS_TAG &&

bench/.gitignore

@@ -0,0 +1,5 @@
+/.*
+!/.gitignore
+!/.travis.yml
+/bower_components/
+/output/

bench/bower.json

@@ -0,0 +1,11 @@
+{
+  "name": "purescript-eff-aff-bench",
+  "dependencies": {
+    "purescript-minibench": "^2.0.0",
+    "purescript-effect": "safareli/purescript-effect#fast",
+    "purescript-aff": "^5.0.0"
+  },
+  "resolutions": {
+    "purescript-effect": "fast"
+  }
+}

bench/package.json

@@ -0,0 +1,19 @@
+{
+  "private": true,
+  "scripts": {
+    "clean": "rimraf output && rimraf .pulp-cache",
+    "start": "npm run build && npm run run",
+    "run": "node --expose-gc -e 'require(\"./output/Bench.Main/index.js\").main()'",
+    "build": "eslint src && pulp build -- --censor-lib --strict"
+  },
+  "devDependencies": {
+    "eslint": "^4.19.1",
+    "pulp": "^12.2.0",
+    "purescript-psa": "^0.6.0",
+    "rimraf": "^2.6.2"
+  },
+  "dependencies": {
+    "bower": "^1.8.8",
+    "purescript": "^0.12.5"
+  }
+}

bench/src/Bench/Main.js

@@ -0,0 +1,21 @@
+"use strict";
+
+exports.mkArr = function(){
+  return { count: 0 };
+};
+
+exports.pushToArr = function(xs) {
+  return function() {
+    return function() {
+      xs.count += 1;
+      return xs;
+    };
+  };
+};
+
+exports.log = function(x) {
+  return function(){
+    // eslint-disable-next-line
+    console.log(x);
+  };
+};

bench/src/Bench/Main.purs

@@ -0,0 +1,109 @@
+module Bench.Main where
+
+import Prelude
+
+import Effect (Effect)
+import Effect.Aff (Aff, launchAff_)
+import Effect.Class (class MonadEffect, liftEffect)
+import Effect.Unsafe (unsafePerformEffect)
+import Data.Traversable (for_, intercalate)
+import Performance.Minibench (BenchResult, benchWith', withUnits)
+
+
+testApply :: forall m. MonadEffect m => Int -> m Unit
+testApply n' = do
+  arr <- liftEffect mkArr
+  applyLoop (void <<< liftEffect <<< pushToArr arr) n'
+  where
+  applyLoop :: Monad m => (Int -> m Unit) -> Int -> m Unit
+  applyLoop eff max = go (pure unit) 0
+    where 
+    go acc n | n == max = acc
+    go acc n = go (acc <* eff n) (n + 1)
+
+
+testBindRight :: forall m. MonadEffect m => Int -> m Unit
+testBindRight n' = do
+  arr <- liftEffect mkArr
+  bindRightLoop (void <<< liftEffect <<< pushToArr arr) n'
+  where
+  bindRightLoop :: Monad m => (Int -> m Unit)  -> Int -> m Unit
+  bindRightLoop eff max = go (pure unit) 0
+    where 
+    go acc n | n == max = acc
+    go acc n = go (eff (max - n - 1) >>= const acc) (n + 1)
+
+
+testBindLeft :: forall m. MonadEffect m => Int -> m Unit
+testBindLeft n' = do
+  arr <- liftEffect mkArr
+  bindLeftLoop (void <<< liftEffect <<< pushToArr arr) n'
+  where
+  bindLeftLoop :: Monad m => (Int -> m Unit)  -> Int -> m Unit
+  bindLeftLoop eff max = go (pure unit) 0
+    where 
+    go acc n | n == max = acc
+    go acc n = go (acc >>= const (eff n)) (n + 1)
+
+
+testMap :: forall m. MonadEffect m => Int -> m Unit
+testMap n = do
+  arr <- liftEffect mkArr
+  res <- mapLoop n (liftEffect $ pushToArr arr 0)
+  pure unit
+  where
+  mapLoop :: Monad m => Int -> m Int -> m Int
+  mapLoop max i = 
+    if max == 0 
+      then i 
+      else mapLoop (max - 1) (map (_ + 1) i)
+
+
+main :: Effect Unit
+main = do
+  log "<details><summary>benchmark</summary>"
+  log "| bench | type | n | mean | stddev | min | max |"
+  log "| ----- | ---- | - | ---- | ------ | --- | --- |"
+  bench 10 ">>=R" testBindRight testBindRight [100, 1000, 5000]
+  bench 10 ">>=L" testBindLeft testBindLeft [100, 1000, 5000]
+  bench 10 "map" testMap testMap [100, 1000, 5000]
+  bench 10 "apply" testApply testApply [100, 1000, 5000]
+  log "| - | - | - | - | - | - | - |"
+  bench 2 ">>=R" testBindRight testBindRight [10000, 50000, 100000, 1000000]
+  bench 2 ">>=L" testBindLeft testBindLeft [10000, 50000, 100000, 1000000]
+  bench 2 "map" testMap testMap [10000, 50000, 100000, 1000000, 350000, 700000]
+  bench 2 "apply" testApply testApply [10000, 50000, 100000, 1000000]
+  log "</details>"
+
+bench
+  :: Int
+  -> String
+  -> (Int -> Effect Unit)
+  -> (Int -> Aff Unit)
+  -> Array Int
+  -> Effect Unit
+bench n name buildEffect buildAff vals = for_ vals \val -> do 
+  logBench [name <> " build", "Eff", show val] $ benchWith' n \_ -> buildEffect val
+  logBench' identity [name <> " build", "Aff", show val] $ benchWith' n \_ -> buildAff val
+  let eff = liftEffect $ buildEffect val
+  logBench [name <> " run", "Eff", show val] $ benchWith' n \_ -> unsafePerformEffect eff
+  let aff = launchAff_ $ buildAff val
+  logBench' identity [name <> " run", "Aff", show val] $ benchWith' n \_ -> unsafePerformEffect aff
+
+logBench' :: (String -> String) -> Array String -> Effect BenchResult -> Effect Unit
+logBench' f msg benchEffect = do
+  res <- benchEffect
+  let 
+    logStr = intercalate " | " 
+      $ append msg 
+      $ map (f <<< withUnits) [res.mean, res.stdDev, res.min, res.max]
+  log $  "| "  <> logStr <>  " |"
+
+logBench :: Array String -> Effect BenchResult -> Effect Unit
+logBench = logBench' \s -> "**" <> s <> "**"
+
+foreign import data Arr :: Type -> Type
+foreign import mkArr :: forall a. Effect (Arr a)
+foreign import pushToArr :: forall a. Arr a -> a -> Effect a
+foreign import log :: forall a. a -> Effect Unit
+

package.json

@@ -2,9 +2,15 @@
   "private": true,
   "scripts": {
     "clean": "rimraf output && rimraf .pulp-cache",
-    "build": "eslint src && pulp build -- --censor-lib --strict"
+    "test": "pulp test",
+    "build": "eslint src && pulp build -- --censor-lib --strict",
+    "install": "bower install && cd bench && bower install",
+    "bench:start": "npm run bench:build && npm run bench:run",
+    "bench:run": "node --expose-gc -e 'require(\"./bench/output/Bench.Main/index.js\").main()'",
+    "bench:build": "cd bench && eslint src && pulp build -- --censor-lib --strict"
   },
   "devDependencies": {
+    "bower": "^1.8.8",
     "eslint": "^4.19.1",
     "pulp": "^12.2.0",
     "purescript-psa": "^0.6.0",

src/Effect.js

@@ -1,19 +1,179 @@
 "use strict";
 
-exports.pureE = function (a) {
-  return function () {
-    return a;
+
+/*
+A computation of type `Effect a` in runtime is represented by a function which when
+invoked performs some effect and results some value of type `a`.
+
+With trivial implementation of `Effect` we have an issue with stack usage, as on each `bind`
+you create new function which increases size of stack needed to execute whole computation.
+For example if you write `forever` recursively like this, stack will overflow:
+
+``` purs
+forever :: forall a b. Effect a -> Effect b
+forever f = f *> forever f
+```
+
+Solution to the stack issue is to change runtime representation of Effect from function 
+to some "free like structure" (Defunctionalization), for example if we were to write new
+Effect structure which is stack safe we could do something like this:
+
+``` purs
+data EffectSafe a
+  = Effect (Effect a)
+  | Pure a
+  | exists b. Map (b -> a) (EffectSafe b)
+  | exists b. Apply (EffectSafe b) (EffectSafe (b -> a))
+  | exists b. Bind (b -> EffectSafe a) (EffectSafe b)
+```
+implementing Functor Applicative and Monad instances would be trivial, and instead of
+them constructing new function they create new node of EffectSafe tree structure
+which then needs to be interpreted.
+
+
+We could implement `EffectSafe` in PS but then to get safety benefits everyone should
+start using it and doing FFI on such type will not be as easy as with `Effect` implemented
+with just a function. If we just change runtime representation of the `Effect` that it would
+brake all FFI related code, which we don't want to do.
+
+So we need some way to achieve stack safety such that runtime representation is still a function.
+
+hmmm...
+
+In JS, function is an object, so we can set arbitrary properties on it. i.e. we can use function
+as object, like look up some properties without invoking it. It means we can use function as
+representation of `Effect`, as it was before, but set some properties on it, to be able get
+benefits of the free-ish representation.
+
+So we would assume an `Effect a` to be normal effectful function as before,
+but it could also have `tag` property which could be 'PURE', 'MAP', 'APPLY' or 'BIND',
+depending on the tag, we would expect certain properties to contain certain type of values:
+
+``` js
+Effect a
+  = { Unit -> a }
+  | { Unit -> a, tag: "PURE",   _0 :: a }
+  | { Unit -> a, tag: "MAP",    _0 :: b -> a,        _1 :: Effect  b }
+  | { Unit -> a, tag: "APPLY",  _0 :: Effect b,      _1 :: Effect (b -> a) }
+  | { Unit -> a, tag: "BIND",   _0 :: b -> Effect a, _1 :: Effect  b }
+```
+
+Now hardest thing is to interpret this in stack safe way. but at first let's see
+how `pureE` `mapE` `applyE` `bindE` `runPure` are defined:
+*/
+
+var PURE = "PURE";
+var MAP = "MAP";
+var APPLY = "APPLY";
+var BIND = "BIND";
+var APPLY_FUNC = "APPLY_FUNC";
+
+exports.pureE = function (x) {
+  return mkEff(PURE, x);
+};
+
+exports.mapE = function (f) {
+  return function (effect) {
+    return mkEff(MAP, f, effect);
   };
 };
 
-exports.bindE = function (a) {
+exports.applyE = function (effF) {
+  return function (effect) {
+    return mkEff(APPLY, effect, effF);
+  };
+};
+
+exports.bindE = function (effect) {
   return function (f) {
-    return function () {
-      return f(a())();
-    };
+    return mkEff(BIND, f, effect);
   };
 };
 
+/*
+
+As you can see this function takes the `tag` and up to 2 values depending on the `tag`.
+in here we create new named function which invokes runEff with itself
+(we give it name so it's easy to identify such functions during debugging)
+then we set `tag`, `_0` and `_1` properties on the function we just constructed
+and return it so the result is basically an object which can also be invoked
+and it then executes `runEff` with itself which tries to evaluate it without
+increasing stack usage.
+
+*/
+function mkEff(tag, _0, _1) {
+  var effect = function $effect() { return runEff($effect); };
+  effect.tag = tag;
+  effect._0 = _0;
+  effect._1 = _1;
+  return effect;
+}
+
+/*
+
+So when this function is called it will take effect which must have the `tag` property on it.
+
+we would set up some variables which are needed for safe evaluation:
+
+* operations - this will be a type aligned sequence of `Operations` which looks like this:
+  ``` purs
+  Operation a b
+    = { tag: "MAP",        _0 :: a -> b }
+    | { tag: "APPLY",      _0 :: Effect a }
+    | { tag: "APPLY_FUNC", _0 :: a -> b }
+    | { tag: "BIND",       _0 :: a -> Effect b }
+  ```
+* effect - initially it's `inputEff` (argument of the `runEff`), it's basically tip of the tree,
+  it will be then updated with other nodes while we are interpreting the structure.
+* res - it will store results of invocations of effects which return results
+* op - it will store current `Operation` which is popped from `operations`
+
+if you look closely at Operation and Effect you would see that they have similar shape.
+this nodes from `Effect` have same representation as `Operation`:
+
+```
+| { Unit -> a, tag: "MAP",    _0 :: b -> a,        _1 :: Effect  b }
+| { Unit -> a, tag: "APPLY",  _0 :: Effect b,      _1 :: Effect (b -> a) }
+| { Unit -> a, tag: "BIND",   _0 :: b -> Effect a, _1 :: Effect  b }
+```
+*/
+
+function runEff(inputEff) {
+  var operations = [];
+  var effect = inputEff;
+  var res;
+  var op;
+  effLoop: for (;;) {
+    if (effect.tag !== undefined) {
+      if (effect.tag === MAP || effect.tag === BIND || effect.tag === APPLY) {
+        operations.push(effect);
+        effect = effect._1 ;
+        continue;
+      }
+      // here `tag === PURE`
+      res = effect._0;
+    } else {
+      res = effect();
+    }
+
+    while ((op = operations.pop())) {
+      if (op.tag === MAP) {
+        res = op._0(res);
+      } else if (op.tag === APPLY_FUNC) {
+        res = op._0(res);
+      } else if (op.tag === APPLY) {
+        effect = op._0;
+        operations.push({ tag: APPLY_FUNC, _0: res });
+        continue effLoop;
+      } else { // op.tag === BIND
+        effect = op._0(res);
+        continue effLoop;
+      }
+    }
+    return res;
+  }
+}
+
 exports.untilE = function (f) {
   return function () {
     while (!f());