From 4b1bbe98786a14faf506fd338d45126f9a94445c Mon Sep 17 00:00:00 2001 From: Irakli Safareli Date: Sat, 25 May 2019 13:15:06 -0700 Subject: [PATCH] Make Effect stacksafe --- .eslintrc.json | 2 +- .travis.yml | 7 +- bench/.gitignore | 5 ++ bench/bower.json | 11 +++ bench/package.json | 19 +++++ bench/src/Bench/Main.js | 21 +++++ bench/src/Bench/Main.purs | 109 ++++++++++++++++++++++++ package.json | 8 +- src/Effect.js | 174 ++++++++++++++++++++++++++++++++++++-- src/Effect.purs | 8 +- test/Test/Main.js | 56 ++++++++++++ test/Test/Main.purs | 93 ++++++++++++++++++++ 12 files changed, 499 insertions(+), 14 deletions(-) create mode 100644 bench/.gitignore create mode 100644 bench/bower.json create mode 100644 bench/package.json create mode 100644 bench/src/Bench/Main.js create mode 100644 bench/src/Bench/Main.purs create mode 100644 test/Test/Main.js create mode 100644 test/Test/Main.purs diff --git a/.eslintrc.json b/.eslintrc.json index 39963d3..5a2b1f5 100644 --- a/.eslintrc.json +++ b/.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"], diff --git a/.travis.yml b/.travis.yml index 27b95cd..d025f2c 100644 --- a/.travis.yml +++ b/.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 && diff --git a/bench/.gitignore b/bench/.gitignore new file mode 100644 index 0000000..f1237d3 --- /dev/null +++ b/bench/.gitignore @@ -0,0 +1,5 @@ +/.* +!/.gitignore +!/.travis.yml +/bower_components/ +/output/ diff --git a/bench/bower.json b/bench/bower.json new file mode 100644 index 0000000..704059f --- /dev/null +++ b/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" + } +} diff --git a/bench/package.json b/bench/package.json new file mode 100644 index 0000000..c06a8d5 --- /dev/null +++ b/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" + } +} diff --git a/bench/src/Bench/Main.js b/bench/src/Bench/Main.js new file mode 100644 index 0000000..7541f8f --- /dev/null +++ b/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); + }; +}; \ No newline at end of file diff --git a/bench/src/Bench/Main.purs b/bench/src/Bench/Main.purs new file mode 100644 index 0000000..86a699d --- /dev/null +++ b/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 "
benchmark" + 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 "
" + +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 + diff --git a/package.json b/package.json index 02e36ea..afc15ba 100644 --- a/package.json +++ b/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", diff --git a/src/Effect.js b/src/Effect.js index 940a106..015f1a1 100644 --- a/src/Effect.js +++ b/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()); diff --git a/src/Effect.purs b/src/Effect.purs index 412e91e..3921f6b 100644 --- a/src/Effect.purs +++ b/src/Effect.purs @@ -16,10 +16,14 @@ import Control.Apply (lift2) foreign import data Effect :: Type -> Type instance functorEffect :: Functor Effect where - map = liftA1 + map = mapE + +foreign import mapE :: forall a b. (a -> b) -> Effect a -> Effect b instance applyEffect :: Apply Effect where - apply = ap + apply = applyE + +foreign import applyE :: forall a b. Effect (a -> b) -> Effect a -> Effect b instance applicativeEffect :: Applicative Effect where pure = pureE diff --git a/test/Test/Main.js b/test/Test/Main.js new file mode 100644 index 0000000..2f6b9dc --- /dev/null +++ b/test/Test/Main.js @@ -0,0 +1,56 @@ +"use strict"; + +exports.mkArr = function(){ + return []; +}; + +exports.unArr = function(xs){ + return xs.slice(0); +}; + +exports.pushToArr = function(xs) { + return function(x) { + return function() { + xs.push(x); + return x; + }; + }; +}; + +exports.assert = function(isOk) { + return function(msg) { + return function() { + if (isOk == false) { + throw new Error("assertion failed: " + msg); + }; + }; + }; +}; + +exports.naturals = function(n) { + var res = []; + for (var index = 0; index < n; index++) { + res[index] = index; + } + return res; +}; + +exports.log = function(x) { + return function(){ + console.log(x) + } +}; + + +exports.time = function(x) { + return function(){ + console.time(x) + } +}; + + +exports.timeEnd = function(x) { + return function(){ + console.timeEnd(x) + } +}; diff --git a/test/Test/Main.purs b/test/Test/Main.purs new file mode 100644 index 0000000..d1449ee --- /dev/null +++ b/test/Test/Main.purs @@ -0,0 +1,93 @@ +module Test.Main where + +import Prelude + +import Effect (Effect) +import Control.Apply (lift2) + +testLift2 :: Effect Unit +testLift2 = do + arr <- mkArr + res <- (pushToArr arr 1) `lift2 (+)` (pushToArr arr 2) + res' <- (pure 1) `lift2 (+)` (pure 2) + assert ([1, 2] == unArr arr) "lift2 1/3" + assert (3 == res') "lift2 2/3" + assert (3 == res) "lift2 3/3" + + +testApply :: Int -> Effect Unit +testApply n' = do + arr <- mkArr + applyLoop (void <<< pushToArr arr) n' + assert (naturals n' == unArr arr) $ "apply " <> show n' + where + applyLoop eff max = go (pure unit) 0 + where + go acc n | n == max = acc + go acc n = go (acc <* eff n) (n + 1) + + + +testBindRight :: Int -> Effect Unit +testBindRight n' = do + arr <- mkArr + bindRightLoop (void <<< pushToArr arr) n' + assert (naturals n' == unArr arr) $ "bind right " <> show n' + where + 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 :: Int -> Effect Unit +testBindLeft n' = do + arr <- mkArr + bindLeftLoop (void <<< pushToArr arr) n' + assert (naturals n' == unArr arr) $ "bind left " <> show n' + where + 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 :: Int -> Effect Unit +testMap n = do + arr <- mkArr + res <- mapLoop n (pushToArr arr 0) + assert (res == n) $ "map " <> show n + assert ([0] == unArr arr) $ "map" + where + mapLoop max i = + if max == 0 + then i + else mapLoop (max - 1) (map (_ + 1) i) + + +main :: Effect Unit +main = do + test "testLift2" $ testLift2 + test "testBindRight" $ testBindRight 1000000 + test "testBindLeft" $ testMap 1000000 + test "testMap" $ testMap 5000000 + test "testApply" $ testApply 1000000 + where + test msg eff = do + time msg + eff + timeEnd msg + + +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 assert :: Boolean -> String -> Effect Unit +foreign import log :: forall a. a -> Effect Unit +foreign import unArr :: forall a. Arr a -> Array a +foreign import naturals :: Int -> Array Int + +foreign import time :: String -> Effect Unit +foreign import timeEnd :: String -> Effect Unit