Skip to content

Commit 4b1bbe9

Browse files
safarelisafareli
committed
Make Effect stacksafe
1 parent 6caa8e1 commit 4b1bbe9

File tree

12 files changed

+499
-14
lines changed

12 files changed

+499
-14
lines changed

‎.eslintrc.json

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,7 @@
1919
"no-param-reassign": 2,
2020
"no-return-assign": 2,
2121
"no-unused-expressions": 2,
22-
"no-use-before-define": 2,
22+
"no-use-before-define": [2, "nofunc"],
2323
"radix": [2, "always"],
2424
"indent": [2, 2, { "SwitchCase": 1 }],
2525
"quotes": [2, "double"],

‎.travis.yml

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -9,11 +9,12 @@ install:
99
- wget -O $HOME/purescript.tar.gz https://github.com/purescript/purescript/releases/download/$TAG/linux64.tar.gz
1010
- tar -xvf $HOME/purescript.tar.gz -C $HOME/
1111
- chmod a+x $HOME/purescript
12-
- npm install -g bower
1312
- npm install
14-
- bower install
13+
- npm run install
1514
script:
16-
- npm run -s build
15+
- npm run build
16+
- npm run test
17+
- npm run bench:start
1718
after_success:
1819
- >-
1920
test $TRAVIS_TAG &&

‎bench/.gitignore

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
/.*
2+
!/.gitignore
3+
!/.travis.yml
4+
/bower_components/
5+
/output/

‎bench/bower.json

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
{
2+
"name": "purescript-eff-aff-bench",
3+
"dependencies": {
4+
"purescript-minibench": "^2.0.0",
5+
"purescript-effect": "safareli/purescript-effect#fast",
6+
"purescript-aff": "^5.0.0"
7+
},
8+
"resolutions": {
9+
"purescript-effect": "fast"
10+
}
11+
}

‎bench/package.json

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
{
2+
"private": true,
3+
"scripts": {
4+
"clean": "rimraf output && rimraf .pulp-cache",
5+
"start": "npm run build && npm run run",
6+
"run": "node --expose-gc -e 'require(\"./output/Bench.Main/index.js\").main()'",
7+
"build": "eslint src && pulp build -- --censor-lib --strict"
8+
},
9+
"devDependencies": {
10+
"eslint": "^4.19.1",
11+
"pulp": "^12.2.0",
12+
"purescript-psa": "^0.6.0",
13+
"rimraf": "^2.6.2"
14+
},
15+
"dependencies": {
16+
"bower": "^1.8.8",
17+
"purescript": "^0.12.5"
18+
}
19+
}

‎bench/src/Bench/Main.js

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,21 @@
1+
"use strict";
2+
3+
exports.mkArr = function(){
4+
return { count: 0 };
5+
};
6+
7+
exports.pushToArr = function(xs) {
8+
return function() {
9+
return function() {
10+
xs.count += 1;
11+
return xs;
12+
};
13+
};
14+
};
15+
16+
exports.log = function(x) {
17+
return function(){
18+
// eslint-disable-next-line
19+
console.log(x);
20+
};
21+
};

‎bench/src/Bench/Main.purs

Lines changed: 109 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,109 @@
1+
module Bench.Main where
2+
3+
import Prelude
4+
5+
import Effect (Effect)
6+
import Effect.Aff (Aff, launchAff_)
7+
import Effect.Class (class MonadEffect, liftEffect)
8+
import Effect.Unsafe (unsafePerformEffect)
9+
import Data.Traversable (for_, intercalate)
10+
import Performance.Minibench (BenchResult, benchWith', withUnits)
11+
12+
13+
testApply :: forall m. MonadEffect m => Int -> m Unit
14+
testApply n' = do
15+
arr <- liftEffect mkArr
16+
applyLoop (void <<< liftEffect <<< pushToArr arr) n'
17+
where
18+
applyLoop :: Monad m => (Int -> m Unit) -> Int -> m Unit
19+
applyLoop eff max = go (pure unit) 0
20+
where
21+
go acc n | n == max = acc
22+
go acc n = go (acc <* eff n) (n + 1)
23+
24+
25+
testBindRight :: forall m. MonadEffect m => Int -> m Unit
26+
testBindRight n' = do
27+
arr <- liftEffect mkArr
28+
bindRightLoop (void <<< liftEffect <<< pushToArr arr) n'
29+
where
30+
bindRightLoop :: Monad m => (Int -> m Unit) -> Int -> m Unit
31+
bindRightLoop eff max = go (pure unit) 0
32+
where
33+
go acc n | n == max = acc
34+
go acc n = go (eff (max - n - 1) >>= const acc) (n + 1)
35+
36+
37+
testBindLeft :: forall m. MonadEffect m => Int -> m Unit
38+
testBindLeft n' = do
39+
arr <- liftEffect mkArr
40+
bindLeftLoop (void <<< liftEffect <<< pushToArr arr) n'
41+
where
42+
bindLeftLoop :: Monad m => (Int -> m Unit) -> Int -> m Unit
43+
bindLeftLoop eff max = go (pure unit) 0
44+
where
45+
go acc n | n == max = acc
46+
go acc n = go (acc >>= const (eff n)) (n + 1)
47+
48+
49+
testMap :: forall m. MonadEffect m => Int -> m Unit
50+
testMap n = do
51+
arr <- liftEffect mkArr
52+
res <- mapLoop n (liftEffect $ pushToArr arr 0)
53+
pure unit
54+
where
55+
mapLoop :: Monad m => Int -> m Int -> m Int
56+
mapLoop max i =
57+
if max == 0
58+
then i
59+
else mapLoop (max - 1) (map (_ + 1) i)
60+
61+
62+
main :: Effect Unit
63+
main = do
64+
log "<details><summary>benchmark</summary>"
65+
log "| bench | type | n | mean | stddev | min | max |"
66+
log "| ----- | ---- | - | ---- | ------ | --- | --- |"
67+
bench 10 ">>=R" testBindRight testBindRight [100, 1000, 5000]
68+
bench 10 ">>=L" testBindLeft testBindLeft [100, 1000, 5000]
69+
bench 10 "map" testMap testMap [100, 1000, 5000]
70+
bench 10 "apply" testApply testApply [100, 1000, 5000]
71+
log "| - | - | - | - | - | - | - |"
72+
bench 2 ">>=R" testBindRight testBindRight [10000, 50000, 100000, 1000000]
73+
bench 2 ">>=L" testBindLeft testBindLeft [10000, 50000, 100000, 1000000]
74+
bench 2 "map" testMap testMap [10000, 50000, 100000, 1000000, 350000, 700000]
75+
bench 2 "apply" testApply testApply [10000, 50000, 100000, 1000000]
76+
log "</details>"
77+
78+
bench
79+
:: Int
80+
-> String
81+
-> (Int -> Effect Unit)
82+
-> (Int -> Aff Unit)
83+
-> Array Int
84+
-> Effect Unit
85+
bench n name buildEffect buildAff vals = for_ vals \val -> do
86+
logBench [name <> " build", "Eff", show val] $ benchWith' n \_ -> buildEffect val
87+
logBench' identity [name <> " build", "Aff", show val] $ benchWith' n \_ -> buildAff val
88+
let eff = liftEffect $ buildEffect val
89+
logBench [name <> " run", "Eff", show val] $ benchWith' n \_ -> unsafePerformEffect eff
90+
let aff = launchAff_ $ buildAff val
91+
logBench' identity [name <> " run", "Aff", show val] $ benchWith' n \_ -> unsafePerformEffect aff
92+
93+
logBench' :: (String -> String) -> Array String -> Effect BenchResult -> Effect Unit
94+
logBench' f msg benchEffect = do
95+
res <- benchEffect
96+
let
97+
logStr = intercalate " | "
98+
$ append msg
99+
$ map (f <<< withUnits) [res.mean, res.stdDev, res.min, res.max]
100+
log $ "| " <> logStr <> " |"
101+
102+
logBench :: Array String -> Effect BenchResult -> Effect Unit
103+
logBench = logBench' \s -> "**" <> s <> "**"
104+
105+
foreign import data Arr :: Type -> Type
106+
foreign import mkArr :: forall a. Effect (Arr a)
107+
foreign import pushToArr :: forall a. Arr a -> a -> Effect a
108+
foreign import log :: forall a. a -> Effect Unit
109+

‎package.json

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,9 +2,15 @@
22
"private": true,
33
"scripts": {
44
"clean": "rimraf output && rimraf .pulp-cache",
5-
"build": "eslint src && pulp build -- --censor-lib --strict"
5+
"test": "pulp test",
6+
"build": "eslint src && pulp build -- --censor-lib --strict",
7+
"install": "bower install && cd bench && bower install",
8+
"bench:start": "npm run bench:build && npm run bench:run",
9+
"bench:run": "node --expose-gc -e 'require(\"./bench/output/Bench.Main/index.js\").main()'",
10+
"bench:build": "cd bench && eslint src && pulp build -- --censor-lib --strict"
611
},
712
"devDependencies": {
13+
"bower": "^1.8.8",
814
"eslint": "^4.19.1",
915
"pulp": "^12.2.0",
1016
"purescript-psa": "^0.6.0",

‎src/Effect.js

Lines changed: 167 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,19 +1,179 @@
11
"use strict";
22

3-
exports.pureE = function (a) {
4-
return function () {
5-
return a;
3+
4+
/*
5+
A computation of type `Effect a` in runtime is represented by a function which when
6+
invoked performs some effect and results some value of type `a`.
7+
8+
With trivial implementation of `Effect` we have an issue with stack usage, as on each `bind`
9+
you create new function which increases size of stack needed to execute whole computation.
10+
For example if you write `forever` recursively like this, stack will overflow:
11+
12+
``` purs
13+
forever :: forall a b. Effect a -> Effect b
14+
forever f = f *> forever f
15+
```
16+
17+
Solution to the stack issue is to change runtime representation of Effect from function
18+
to some "free like structure" (Defunctionalization), for example if we were to write new
19+
Effect structure which is stack safe we could do something like this:
20+
21+
``` purs
22+
data EffectSafe a
23+
= Effect (Effect a)
24+
| Pure a
25+
| exists b. Map (b -> a) (EffectSafe b)
26+
| exists b. Apply (EffectSafe b) (EffectSafe (b -> a))
27+
| exists b. Bind (b -> EffectSafe a) (EffectSafe b)
28+
```
29+
implementing Functor Applicative and Monad instances would be trivial, and instead of
30+
them constructing new function they create new node of EffectSafe tree structure
31+
which then needs to be interpreted.
32+
33+
34+
We could implement `EffectSafe` in PS but then to get safety benefits everyone should
35+
start using it and doing FFI on such type will not be as easy as with `Effect` implemented
36+
with just a function. If we just change runtime representation of the `Effect` that it would
37+
brake all FFI related code, which we don't want to do.
38+
39+
So we need some way to achieve stack safety such that runtime representation is still a function.
40+
41+
hmmm...
42+
43+
In JS, function is an object, so we can set arbitrary properties on it. i.e. we can use function
44+
as object, like look up some properties without invoking it. It means we can use function as
45+
representation of `Effect`, as it was before, but set some properties on it, to be able get
46+
benefits of the free-ish representation.
47+
48+
So we would assume an `Effect a` to be normal effectful function as before,
49+
but it could also have `tag` property which could be 'PURE', 'MAP', 'APPLY' or 'BIND',
50+
depending on the tag, we would expect certain properties to contain certain type of values:
51+
52+
``` js
53+
Effect a
54+
= { Unit -> a }
55+
| { Unit -> a, tag: "PURE", _0 :: a }
56+
| { Unit -> a, tag: "MAP", _0 :: b -> a, _1 :: Effect b }
57+
| { Unit -> a, tag: "APPLY", _0 :: Effect b, _1 :: Effect (b -> a) }
58+
| { Unit -> a, tag: "BIND", _0 :: b -> Effect a, _1 :: Effect b }
59+
```
60+
61+
Now hardest thing is to interpret this in stack safe way. but at first let's see
62+
how `pureE` `mapE` `applyE` `bindE` `runPure` are defined:
63+
*/
64+
65+
var PURE = "PURE";
66+
var MAP = "MAP";
67+
var APPLY = "APPLY";
68+
var BIND = "BIND";
69+
var APPLY_FUNC = "APPLY_FUNC";
70+
71+
exports.pureE = function (x) {
72+
return mkEff(PURE, x);
73+
};
74+
75+
exports.mapE = function (f) {
76+
return function (effect) {
77+
return mkEff(MAP, f, effect);
678
};
779
};
880

9-
exports.bindE = function (a) {
81+
exports.applyE = function (effF) {
82+
return function (effect) {
83+
return mkEff(APPLY, effect, effF);
84+
};
85+
};
86+
87+
exports.bindE = function (effect) {
1088
return function (f) {
11-
return function () {
12-
return f(a())();
13-
};
89+
return mkEff(BIND, f, effect);
1490
};
1591
};
1692

93+
/*
94+
95+
As you can see this function takes the `tag` and up to 2 values depending on the `tag`.
96+
in here we create new named function which invokes runEff with itself
97+
(we give it name so it's easy to identify such functions during debugging)
98+
then we set `tag`, `_0` and `_1` properties on the function we just constructed
99+
and return it so the result is basically an object which can also be invoked
100+
and it then executes `runEff` with itself which tries to evaluate it without
101+
increasing stack usage.
102+
103+
*/
104+
function mkEff(tag, _0, _1) {
105+
var effect = function $effect() { return runEff($effect); };
106+
effect.tag = tag;
107+
effect._0 = _0;
108+
effect._1 = _1;
109+
return effect;
110+
}
111+
112+
/*
113+
114+
So when this function is called it will take effect which must have the `tag` property on it.
115+
116+
we would set up some variables which are needed for safe evaluation:
117+
118+
* operations - this will be a type aligned sequence of `Operations` which looks like this:
119+
``` purs
120+
Operation a b
121+
= { tag: "MAP", _0 :: a -> b }
122+
| { tag: "APPLY", _0 :: Effect a }
123+
| { tag: "APPLY_FUNC", _0 :: a -> b }
124+
| { tag: "BIND", _0 :: a -> Effect b }
125+
```
126+
* effect - initially it's `inputEff` (argument of the `runEff`), it's basically tip of the tree,
127+
it will be then updated with other nodes while we are interpreting the structure.
128+
* res - it will store results of invocations of effects which return results
129+
* op - it will store current `Operation` which is popped from `operations`
130+
131+
if you look closely at Operation and Effect you would see that they have similar shape.
132+
this nodes from `Effect` have same representation as `Operation`:
133+
134+
```
135+
| { Unit -> a, tag: "MAP", _0 :: b -> a, _1 :: Effect b }
136+
| { Unit -> a, tag: "APPLY", _0 :: Effect b, _1 :: Effect (b -> a) }
137+
| { Unit -> a, tag: "BIND", _0 :: b -> Effect a, _1 :: Effect b }
138+
```
139+
*/
140+
141+
function runEff(inputEff) {
142+
var operations = [];
143+
var effect = inputEff;
144+
var res;
145+
var op;
146+
effLoop: for (;;) {
147+
if (effect.tag !== undefined) {
148+
if (effect.tag === MAP || effect.tag === BIND || effect.tag === APPLY) {
149+
operations.push(effect);
150+
effect = effect._1 ;
151+
continue;
152+
}
153+
// here `tag === PURE`
154+
res = effect._0;
155+
} else {
156+
res = effect();
157+
}
158+
159+
while ((op = operations.pop())) {
160+
if (op.tag === MAP) {
161+
res = op._0(res);
162+
} else if (op.tag === APPLY_FUNC) {
163+
res = op._0(res);
164+
} else if (op.tag === APPLY) {
165+
effect = op._0;
166+
operations.push({ tag: APPLY_FUNC, _0: res });
167+
continue effLoop;
168+
} else { // op.tag === BIND
169+
effect = op._0(res);
170+
continue effLoop;
171+
}
172+
}
173+
return res;
174+
}
175+
}
176+
17177
exports.untilE = function (f) {
18178
return function () {
19179
while (!f());

0 commit comments

Comments
 (0)