miloignis/kraken
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Moved over first rbtree test from koka_bench and integrated Kraken via compiler wrapper script that calls the partial_evaluator / compiler and then emits a wrapper script that runs the resulting wasm via wasmtime.

Browse Source
This commit is contained in:
Nathan Braswell
2022-05-16 02:33:10 -04:00
parent 025ca41c59
commit b1b060292e
13 changed files with 584 additions and 310 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
koka_bench/.gitignore vendored Normal file
View File

@@ -0,0 +1,5 @@
build/
*.hi
*.o
*.cmi
*.cmx

13
koka_bench/CMakeLists.txt Normal file
View File

@@ -0,0 +1,13 @@
cmake_minimum_required(VERSION 3.16)
project(KokaBench)
get_property(isMultiConfig GLOBAL PROPERTY GENERATOR_IS_MULTI_CONFIG)
if (NOT isMultiConfig AND NOT DEFINED CMAKE_BUILD_TYPE)
set(CMAKE_BUILD_TYPE Release)
endif ()
enable_testing()
add_subdirectory(kraken)
add_subdirectory(koka)
add_subdirectory(cpp)

210
koka_bench/LICENSE Normal file
View File

@@ -0,0 +1,210 @@
Copyright 2012-2021, Microsoft Research, Daan Leijen - modified 2022 by Nathan Braswell.
Koka is free software; You can redistribute it and/or
modify it under the terms of this license.
Apache License, Version 2.0
Apache License
Version 2.0, January 2004
http://www.apache.org/licenses/
TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
1. Definitions.
"License" shall mean the terms and conditions for use, reproduction, and
distribution as defined by Sections 1 through 9 of this document.
"Licensor" shall mean the copyright owner or entity authorized by the
copyright owner that is granting the License.
"Legal Entity" shall mean the union of the acting entity and all other
entities that control, are controlled by, or are under common control
with that entity. For the purposes of this definition, "control" means
(i) the power, direct or indirect, to cause the direction or management
of such entity, whether by contract or otherwise, or (ii) ownership of
fifty percent (50%) or more of the outstanding shares, or (iii)
beneficial ownership of such entity.
"You" (or "Your") shall mean an individual or Legal Entity exercising
permissions granted by this License.
"Source" form shall mean the preferred form for making modifications,
including but not limited to software source code, documentation source,
and configuration files.
"Object" form shall mean any form resulting from mechanical
transformation or translation of a Source form, including but not limited
to compiled object code, generated documentation, and conversions to
other media types.
"Work" shall mean the work of authorship, whether in Source or Object
form, made available under the License, as indicated by a copyright
notice that is included in or attached to the work (an example is
provided in the Appendix below).
"Derivative Works" shall mean any work, whether in Source or Object form,
that is based on (or derived from) the Work and for which the editorial
revisions, annotations, elaborations, or other modifications represent,
as a whole, an original work of authorship. For the purposes of this
License, Derivative Works shall not include works that remain separable
from, or merely link (or bind by name) to the interfaces of, the Work and
Derivative Works thereof.
"Contribution" shall mean any work of authorship, including the original
version of the Work and any modifications or additions to that Work or
Derivative Works thereof, that is intentionally submitted to Licensor for
inclusion in the Work by the copyright owner or by an individual or Legal
Entity authorized to submit on behalf of the copyright owner. For the
purposes of this definition, "submitted" means any form of electronic,
verbal, or written communication sent to the Licensor or its
representatives, including but not limited to communication on electronic
mailing lists, source code control systems, and issue tracking systems
that are managed by, or on behalf of, the Licensor for the purpose of
discussing and improving the Work, but excluding communication that is
conspicuously marked or otherwise designated in writing by the copyright
owner as "Not a Contribution."
"Contributor" shall mean Licensor and any individual or Legal Entity on
behalf of whom a Contribution has been received by Licensor and
subsequently incorporated within the Work.
2. Grant of Copyright License.
Subject to the terms and conditions of this License, each Contributor
hereby grants to You a perpetual, worldwide, non-exclusive, no-charge,
royalty-free, irrevocable copyright license to reproduce, prepare
Derivative Works of, publicly display, publicly perform, sublicense, and
distribute the Work and such Derivative Works in Source or Object form.
3. Grant of Patent License.
Subject to the terms and conditions of this License, each Contributor
hereby grants to You a perpetual, worldwide, non-exclusive, no-charge,
royalty-free, irrevocable (except as stated in this section) patent
license to make, have made, use, offer to sell, sell, import, and
otherwise transfer the Work, where such license applies only to those
patent claims licensable by such Contributor that are necessarily
infringed by their Contribution(s) alone or by combination of their
Contribution(s) with the Work to which such Contribution(s) was
submitted. If You institute patent litigation against any entity
(including a cross-claim or counterclaim in a lawsuit) alleging that the
Work or a Contribution incorporated within the Work constitutes direct or
contributory patent infringement, then any patent licenses granted to You
under this License for that Work shall terminate as of the date such
litigation is filed.
4. Redistribution.
You may reproduce and distribute copies of the Work or Derivative Works
thereof in any medium, with or without modifications, and in Source or
Object form, provided that You meet the following conditions:
You must give any other recipients of the Work or Derivative Works a copy
of this License; and
You must cause any modified files to carry prominent notices stating that
You changed the files; and
You must retain, in the Source form of any Derivative Works that You
distribute, all copyright, patent, trademark, and attribution notices
from the Source form of the Work, excluding those notices that do not
pertain to any part of the Derivative Works; and
If the Work includes a "NOTICE" text file as part of its distribution,
then any Derivative Works that You distribute must include a readable
copy of the attribution notices contained within such NOTICE file,
excluding those notices that do not pertain to any part of the Derivative
Works, in at least one of the following places: within a NOTICE text file
distributed as part of the Derivative Works; within the Source form or
documentation, if provided along with the Derivative Works; or, within a
display generated by the Derivative Works, if and wherever such
third-party notices normally appear. The contents of the NOTICE file are
for informational purposes only and do not modify the License. You may
add Your own attribution notices within Derivative Works that You
distribute, alongside or as an addendum to the NOTICE text from the Work,
provided that such additional attribution notices cannot be construed as
modifying the License.
You may add Your own copyright statement to Your modifications and may
provide additional or different license terms and conditions for use,
reproduction, or distribution of Your modifications, or for any such
Derivative Works as a whole, provided Your use, reproduction, and
distribution of the Work otherwise complies with the conditions stated in
this License.
5. Submission of Contributions.
Unless You explicitly state otherwise, any Contribution intentionally
submitted for inclusion in the Work by You to the Licensor shall be under
the terms and conditions of this License, without any additional terms or
conditions. Notwithstanding the above, nothing herein shall supersede or
modify the terms of any separate license agreement you may have executed
with Licensor regarding such Contributions.
6. Trademarks.
This License does not grant permission to use the trade names,
trademarks, service marks, or product names of the Licensor, except as
required for reasonable and customary use in describing the origin of the
Work and reproducing the content of the NOTICE file.
7. Disclaimer of Warranty.
Unless required by applicable law or agreed to in writing, Licensor
provides the Work (and each Contributor provides its Contributions) on an
"AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either
express or implied, including, without limitation, any warranties or
conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
PARTICULAR PURPOSE. You are solely responsible for determining the
appropriateness of using or redistributing the Work and assume any risks
associated with Your exercise of permissions under this License.
8. Limitation of Liability.
In no event and under no legal theory, whether in tort (including
negligence), contract, or otherwise, unless required by applicable law
(such as deliberate and grossly negligent acts) or agreed to in writing,
shall any Contributor be liable to You for damages, including any direct,
indirect, special, incidental, or consequential damages of any character
arising as a result of this License or out of the use or inability to use
the Work (including but not limited to damages for loss of goodwill, work
stoppage, computer failure or malfunction, or any and all other
commercial damages or losses), even if such Contributor has been advised
of the possibility of such damages.
9. Accepting Warranty or Additional Liability.
While redistributing the Work or Derivative Works thereof, You may choose
to offer, and charge a fee for, acceptance of support, warranty,
indemnity, or other liability obligations and/or rights consistent with
this License. However, in accepting such obligations, You may act only on
Your own behalf and on Your sole responsibility, not on behalf of any
other Contributor, and only if You agree to indemnify, defend, and hold
each Contributor harmless for any liability incurred by, or claims
asserted against, such Contributor by reason of your accepting any such
warranty or additional liability.
END OF TERMS AND CONDITIONS
APPENDIX: How to apply the Apache License to your work
To apply the Apache License to your work, attach the following
boilerplate notice, with the fields enclosed by brackets "[]" replaced
with your own identifying information. (Don't include the brackets!) The
text should be enclosed in the appropriate comment syntax for the file
format. We also recommend that a file or class name and description of
purpose be included on the same "printed page" as the copyright notice
for easier identification within third-party archives.
Copyright [yyyy] [name of copyright owner]
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied.
See the License for the specific language governing permissions and
limitations under the License.

131
koka_bench/README.md Normal file
View File

@@ -0,0 +1,131 @@
# NOTE
These are the benchmarks extracted from the Koka repository https://github.com/koka-lang/koka
at b1670308f88dd1fc6c22cad28385fcb185d5b27d from the test/bench directory
and modified by me to run inside a reproducable environment defined by a Nix Flake,
and to use Bash to coordinate and Hyperfine to time instead of the Koka based runner.
./test.sh will build and run the benchmarks.
I'm slowly porting them over to the Kraken project, and adding Kraken versions of each one.
## Some explanation from a PLDI Readme originally included:
Available languages are:
- `kk` : Koka v2.1.1 compiling using gcc 9.3.0.
- `kkx` : Koka v2.1.1 compiling using gcc 9.3.0 but without reuse optimization (Section 2.4).
- `ml` : OCaml v4.08.1 using the optimizing compiler (`ocamlopt`)
- `hs` : Haskell GHC 8.6.5.
- `sw` : Swift 5.3.3.
- `jv` : Java 15.0.2, Java(TM) SE Runtime Environment (build 15.0.2+7-27),
Java HotSpot(TM) 64-Bit Server VM (build 15.0.2+7-27, mixed mode, sharing).
- `cpp` : GCC 9.3.0,
Available tests are described in detail in Section 4 and are:
- `rbtree` : inserts 42 million items into a red-black tree.
- `rbtree-ck` : a variant of rbtree that keeps a list of every 5th subtree and thus shares many subtrees.
- `deriv` : the symbolic derivative of a large expression.
- `nqueens` : calculates all solutions for the n-queens problem of size 13 into a list, and returns the length of that list.
- `cfold` : constant-folding over a large symbolic expression.
# Original README follows:
# Build and run benchmarks
This contains the standard benchmark suite (discussed in detail in [Perceus] paper).
It is still basic but more benchmarks
with effect handlers are coming. The suite can run on (Ubuntu Linux), WSL2, and macOS,
and the benchmarks need:
- `gcc`. Should be there, otherwise use `sudo apt install gcc`,
- `ghc`. Use `sudo apt install ghc`,
- `ocamlopt`. Use `sudo apt install ocaml`.
We used the new multi-core OCaml, see <https://github.com/ocaml-multicore/multicore-opam>
for installation instructions (including `domainslib` for the binarytrees benchmark)
```
> opam update
> opam switch create 4.12.0+domains+effects --repositories=multicore=git+https://github.com/ocaml-multicore/multicore-opam.git,default
> opam install dune domainslib
```
- `swiftc`. The Swift compiler can be downloaded [here](https://swift.org/download/).
The benchmarks expect `swiftc` to be installed at `/opt/swift/bin`,
so unpack and copy everything under `swift-.../usr` to `/opt/swift/bin`:
```
> tar -xzf swift-5.5-RELEASE-ubuntu20.04.tar.gz
> cd swift-5.5-RELEASE-ubuntu20.04/usr
> sudo mkdir /opt/swift
> sudo cp -r * /opt/swift
```
- `javac`/`java`. We used these [instructions](https://www.linuxcapable.com/how-to-install-java-17-lts-jdk-17-on-ubuntu-20-04/)
to install the Java SE 17 Hotspot compiler:
```
> sudo apt update
> sudo add-apt-repository ppa:linuxuprising/java
> sudo apt-get -y install oracle-java17-installer oracle-java17-set-default
> java --version
java 17 2021-09-14 LTS
Java(TM) SE Runtime Environment (build 17+35-LTS-2724)
Java HotSpot(TM) 64-Bit Server VM (build 17+35-LTS-2724, mixed mode, sharing)
```
The benchmarks can now be build using:
```
> cd test/bench
> mkdir build
> cd build
> cmake .. -DCMAKE_BUILD_TYPE=Release
> cmake --build .
```
For some benchmarks, like `cfold`, we may need a large stack, so it may be good to raise the limit:
```
> ulimit -s unlimited
```
We can then run all benchmarks as:
```
> ctest .
```
Or only run benchmarks for one language with `-L <lang>`:
```
> ctest -L koka
```
Or run specific benchmarks using `-R <regex>`,
like the symbolic derivative benchmark:
```
> ctest -R deriv
Test project /home/daan/dev/koka/test/bench/build
Start 4: hs-deriv
1/4 Test #4: hs-deriv ......................... Passed 2.29 sec
Start 10: kk-deriv
2/4 Test #10: kk-deriv ......................... Passed 1.25 sec
Start 19: ml-deriv
3/4 Test #19: ml-deriv ......................... Passed 1.73 sec
Start 25: sw-deriv
4/4 Test #25: sw-deriv ......................... Passed 2.88 sec
100% tests passed, 0 tests failed out of 4
...
```
We can also run the tests using the `test/bench/bench.kk` script instead of
using `ctest` which also measures peak working set and calculates
normalized scores. For example, from the `build` directory, we can run all benchmarks as:
```
> koka -e ../bench
```
Use the `--lang` or `--test` options to specify a comma separated list of
languages or benchmarks:
```
> koka -e ../bench -- --lang=koka,ocaml --test=rbtree,rbtree-ck
```
The `-i<N>` switch runs `N` iterations on each benchmark and calculates
the average and the error interval.

16
koka_bench/cpp/CMakeLists.txt Normal file
View File

@@ -0,0 +1,16 @@
set(CMAKE_CXX_STANDARD 17)
set(CMAKE_CXX_STANDARD_REQUIRED YES)
set(CMAKE_CXX_EXTENSIONS NO)
foreach (source IN ITEMS rbtree.cpp)
get_filename_component(name "${source}" NAME_WE)
set(name "cpp-${name}")
add_executable(${name} ${source})
if(source MATCHES "binarytrees.cpp")
target_link_libraries(${name} pthread)
endif()
add_test(NAME ${name} COMMAND ${name})
set_tests_properties(${name} PROPERTIES LABELS cpp)
endforeach ()

43
koka_bench/cpp/rbtree.cpp Normal file
View File

@@ -0,0 +1,43 @@
// Using standard STL to test the red-black tree in C++
// In glibc++ this uses <https://github.com/gcc-mirror/gcc/tree/master/libstdc++-v3/src/c++98/tree.cc>
// With the LLVM libc++ this uses <https://github.com/llvm/llvm-project/blob/main/libcxx/include/__tree>
// In glibc this uses eventually: <https://sourceware.org/git/?p=glibc.git;a=blob;f=misc/tsearch.c>
// (Highly optimized in-place red-black tree using the low pointer bit to encode color information.)
#include <iostream>
#include <map>
#include <algorithm>
using std::for_each;
typedef int nat;
struct nat_lt_fn {
bool operator()(nat const & n1, nat const & n2) const { return n1 < n2; }
};
typedef std::map<nat, bool, nat_lt_fn> map;
map mk_map(unsigned n) {
map m;
while (n > 0) {
--n;
m.insert(std::make_pair(nat(n), n%10 == 0));
}
return m;
}
nat fold(map const & m) {
nat r(0);
for_each(m.begin(), m.end(), [&](std::pair<nat, bool> const & p) { if (p.second) r = r + nat(1); });
return r;
}
int main(int argc, char ** argv) {
unsigned n = 4200000;
if (argc == 2) {
n = atoi(argv[1]);
}
map m = mk_map(n);
std::cout << fold(m) << "\n";
return 0;
}

22
koka_bench/koka/CMakeLists.txt Normal file
View File

@@ -0,0 +1,22 @@
set(sources rbtree.kk)
set(koka koka)
foreach (source IN LISTS sources)
get_filename_component(basename "${source}" NAME_WE)
set(name "kk-${basename}")
set(out_dir "${CMAKE_CURRENT_BINARY_DIR}/out/bench")
set(out_path "${out_dir}/${name}")
add_custom_command(
OUTPUT ${out_path}
COMMAND ${koka} --target=c --stack=128M --outputdir=${out_dir} --buildname=${name} -v -O2 -i$<SHELL_PATH:${CMAKE_CURRENT_SOURCE_DIR}> "${source}"
DEPENDS ${source}
VERBATIM)
add_custom_target(update-${name} ALL DEPENDS "${out_path}")
add_executable(${name}-exe IMPORTED)
set_target_properties(${name}-exe PROPERTIES IMPORTED_LOCATION "${out_path}")
endforeach ()

87
koka_bench/koka/rbtree.kk Normal file
View File

@@ -0,0 +1,87 @@
// Adapted from https://github.com/leanprover/lean4/blob/IFL19/tests/bench/rbmap.lean
import std/num/int32
import std/os/env
type color
Red
Black
type tree
Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree)
Leaf()
fun is-red(t : tree) : bool
match t
Node(Red) -> True
_ -> False
fun balance-left(l :tree, k : int32, v : bool, r : tree) : tree
match l
Node(_, Node(Red, lx, kx, vx, rx), ky, vy, ry)
-> Node(Red, Node(Black, lx, kx, vx, rx), ky, vy, Node(Black, ry, k, v, r))
Node(_, ly, ky, vy, Node(Red, lx, kx, vx, rx))
-> Node(Red, Node(Black, ly, ky, vy, lx), kx, vx, Node(Black, rx, k, v, r))
Node(_, lx, kx, vx, rx)
-> Node(Black, Node(Red, lx, kx, vx, rx), k, v, r)
Leaf -> Leaf
fun balance-right(l : tree, k : int32, v : bool, r : tree) : tree
match r
Node(_, Node(Red, lx, kx, vx, rx), ky, vy, ry)
-> Node(Red, Node(Black, l, k, v, lx), kx, vx, Node(Black, rx, ky, vy, ry))
Node(_, lx, kx, vx, Node(Red, ly, ky, vy, ry))
-> Node(Red, Node(Black, l, k, v, lx), kx, vx, Node(Black, ly, ky, vy, ry))
Node(_, lx, kx, vx, rx)
-> Node(Black, l, k, v, Node(Red, lx, kx, vx, rx))
Leaf -> Leaf
fun ins(t : tree, k : int32, v : bool) : tree
match t
Node(Red, l, kx, vx, r)
-> if k < kx then Node(Red, ins(l, k, v), kx, vx, r)
elif k > kx then Node(Red, l, kx, vx, ins(r, k, v))
else Node(Red, l, k, v, r)
Node(Black, l, kx, vx, r)
-> if k < kx then (if is-red(l) then balance-left(ins(l,k,v), kx, vx, r)
else Node(Black, ins(l, k, v), kx, vx, r))
elif k > kx then (if is-red(r) then balance-right(l, kx, vx, ins(r,k,v))
else Node(Black, l, kx, vx, ins(r, k, v)))
else Node(Black, l, k, v, r)
Leaf -> Node(Red, Leaf, k, v, Leaf)
fun set-black(t : tree) : tree
match t
Node(_, l, k, v, r) -> Node(Black, l, k, v, r)
_ -> t
fun insert(t : tree, k : int32, v : bool) : tree
ins(t, k, v).set-black
fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a
match t
Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f)
Leaf -> b
fun make-tree-aux(n : int32, t : tree) : div tree
if n <= zero then t else
val n1 = n.dec
make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero))
pub fun make-tree(n : int32) : div tree
make-tree-aux(n, Leaf)
pub fun main()
val n = get-args().head("").parse-int.default(4200000).int32
val t = make-tree(n)
val v = t.fold(zero) fn(k,v,r:int32){ if (v) then r.inc else r }
v.show.println

10
koka_bench/kraken_wrapper.sh Executable file
View File

@@ -0,0 +1,10 @@
#!/usr/bin/env bash
OUR_DIR="$(dirname $(readlink -f $0))"
SOURCE="$1"
OUT_DIR="$2"
OUT_NAME="$3"
scheme --script "$OUR_DIR/../partial_eval.scm" $SOURCE
mkdir -p "$OUT_DIR"
mv ./csc_out.wasm "$OUT_DIR/$OUT_NAME.wasm"
printf '#!/usr/bin/env bash\nwasmtime "$(dirname $(readlink -f $0))/'"$OUT_NAME"'.wasm" $@' > "$OUT_DIR/$OUT_NAME"
chmod 755 "$OUT_DIR/$OUT_NAME"

5
koka_bench/rbtree_table.md Normal file
View File

@@ -0,0 +1,5 @@
| Command | Mean [s] | Min [s] | Max [s] | Relative |
|:---|---:|---:|---:|---:|
| `build/kraken/out/bench/kraken-rbtree 42000` | 4.116 ± 0.030 | 4.078 | 4.160 | 862.26 ± 110.34 |
| `build/cpp/cpp-rbtree 42000` | 0.006 ± 0.001 | 0.005 | 0.008 | 1.22 ± 0.20 |
| `build/koka/out/bench/kk-rbtree 42000` | 0.005 ± 0.001 | 0.004 | 0.008 | 1.00 |

13
koka_bench/test.sh Executable file
View File

@@ -0,0 +1,13 @@
#!/usr/bin/env bash
set -e
if [[ ! -d "build" ]]
then
mkdir build
pushd build
nix develop -i -c bash -c 'cmake .. -DCMAKE_BUILD_TYPE=Release && cmake --build .'
popd
rm -rf ./build/CMakeFiles || true
fi
nix develop -i -c bash -c 'ulimit -s unlimited && find build -type f -executable -name \*rbtree -printf "\"%p 42000\"\n" | xargs hyperfine --ignore-failure --warmup 2 --export-markdown rbtree_table.md'

310
rb_tree_test/matching.kp
View File

@@ -1,310 +0,0 @@
((wrap (vau root_env (quote)
((wrap (vau (let1)
(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se)))
(let1 current-env (vau de () de)
(let1 cons (lambda (h t) (concat (array h) t))
(let1 Y (lambda (f3)
((lambda (x1) (x1 x1))
(lambda (x2) (f3 (wrap (vau app_env (& y) (lapply (x2 x2) y app_env)))))))
(let1 vY (lambda (f)
((lambda (x3) (x3 x3))
(lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1))))))
(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2)
true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2)))))
(let (
lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args)))))
rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se))
if (vau de (con than & else) (eval (array cond con than
true (cond (> (len else) 0) (idx else 0)
true false)) de))
map (lambda (f5 l5)
(let (helper (rec-lambda recurse (f4 l4 n4 i4)
(cond (= i4 (len l4)) n4
(<= i4 (- (len l4) 4)) (recurse f4 l4 (concat n4 (array
(f4 (idx l4 (+ i4 0)))
(f4 (idx l4 (+ i4 1)))
(f4 (idx l4 (+ i4 2)))
(f4 (idx l4 (+ i4 3)))
)) (+ i4 4))
true (recurse f4 l4 (concat n4 (array (f4 (idx l4 i4)))) (+ i4 1)))))
(helper f5 l5 (array) 0)))
map_i (lambda (f l)
(let (helper (rec-lambda recurse (f l n i)
(cond (= i (len l)) n
(<= i (- (len l) 4)) (recurse f l (concat n (array
(f (+ i 0) (idx l (+ i 0)))
(f (+ i 1) (idx l (+ i 1)))
(f (+ i 2) (idx l (+ i 2)))
(f (+ i 3) (idx l (+ i 3)))
)) (+ i 4))
true (recurse f l (concat n (array (f i (idx l i)))) (+ i 1)))))
(helper f l (array) 0)))
filter_i (lambda (f l)
(let (helper (rec-lambda recurse (f l n i)
(if (= i (len l))
n
(if (f i (idx l i)) (recurse f l (concat n (array (idx l i))) (+ i 1))
(recurse f l n (+ i 1))))))
(helper f l (array) 0)))
filter (lambda (f l) (filter_i (lambda (i x) (f x)) l))
; Huge thanks to Oleg Kiselyov for his fantastic website
; http://okmij.org/ftp/Computation/fixed-point-combinators.html
Y* (lambda (& l)
((lambda (u) (u u))
(lambda (p)
(map (lambda (li) (lambda (& x) (lapply (lapply li (p p)) x))) l))))
vY* (lambda (& l)
((lambda (u) (u u))
(lambda (p)
(map (lambda (li) (vau ide (& x) (vapply (lapply li (p p)) x ide))) l))))
let-rec (vau de (name_func body)
(let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func)
funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func)
overwrite_name (idx name_func (- (len name_func) 2)))
(eval (array let (concat (array overwrite_name (concat (array Y*) (map (lambda (f) (array lambda names f)) funcs)))
(lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names)))
body) de)))
let-vrec (vau de (name_func body)
(let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func)
funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func)
overwrite_name (idx name_func (- (len name_func) 2)))
(eval (array let (concat (array overwrite_name (concat (array vY*) (map (lambda (f) (array lambda names f)) funcs)))
(lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names)))
body) de)))
flat_map (lambda (f l)
(let (helper (rec-lambda recurse (f l n i)
(if (= i (len l))
n
(recurse f l (concat n (f (idx l i))) (+ i 1)))))
(helper f l (array) 0)))
flat_map_i (lambda (f l)
(let (helper (rec-lambda recurse (f l n i)
(if (= i (len l))
n
(recurse f l (concat n (f i (idx l i))) (+ i 1)))))
(helper f l (array) 0)))
; with all this, we make a destrucutring-capable let
let (let (
destructure_helper (rec-lambda recurse (vs i r)
(cond (= (len vs) i) r
(array? (idx vs i)) (let (bad_sym (str-to-symbol (str (idx vs i)))
new_vs (flat_map_i (lambda (i x) (array x (array idx bad_sym i))) (idx vs i))
)
(recurse (concat new_vs (slice vs (+ i 2) -1)) 0 (concat r (array bad_sym (idx vs (+ i 1))))))
true (recurse vs (+ i 2) (concat r (slice vs i (+ i 2))))
))) (vau de (vs b) (vapply let (array (destructure_helper vs 0 (array)) b) de)))
; and a destructuring-capable lambda!
only_symbols (rec-lambda recurse (a i) (cond (= i (len a)) true
(symbol? (idx a i)) (recurse a (+ i 1))
true false))
; Note that if macro_helper is inlined, the mapping lambdas will close over
; se, and then not be able to be taken in as values to the maps, and the vau
; will fail to partially evaluate away.
lambda (let (macro_helper (lambda (p b) (let (
sym_params (map (lambda (param) (if (symbol? param) param
(str-to-symbol (str param)))) p)
body (array let (flat_map_i (lambda (i x) (array (idx p i) x)) sym_params) b)
) (array vau sym_params body))))
(vau se (p b) (if (only_symbols p 0) (vapply lambda (array p b) se)
(wrap (eval (macro_helper p b) se)))))
; and rec-lambda - yes it's the same definition again
rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se))
nil (array)
not (lambda (x) (if x false true))
or (let (macro_helper (rec-lambda recurse (bs i) (cond (= i (len bs)) false
(= (+ 1 i) (len bs)) (idx bs i)
true (array let (array 'tmp (idx bs i)) (array if 'tmp 'tmp (recurse bs (+ i 1)))))))
(vau se (& bs) (eval (macro_helper bs 0) se)))
and (let (macro_helper (rec-lambda recurse (bs i) (cond (= i (len bs)) true
(= (+ 1 i) (len bs)) (idx bs i)
true (array let (array 'tmp (idx bs i)) (array if 'tmp (recurse bs (+ i 1)) 'tmp)))))
(vau se (& bs) (eval (macro_helper bs 0) se)))
foldl (let (helper (rec-lambda recurse (f z vs i) (if (= i (len (idx vs 0))) z
(recurse f (lapply f (cons z (map (lambda (x) (idx x i)) vs))) vs (+ i 1)))))
(lambda (f z & vs) (helper f z vs 0)))
foldr (let (helper (rec-lambda recurse (f z vs i) (if (= i (len (idx vs 0))) z
(lapply f (cons (recurse f z vs (+ i 1)) (map (lambda (x) (idx x i)) vs))))))
(lambda (f z & vs) (helper f z vs 0)))
reverse (lambda (x) (foldl (lambda (acc i) (cons i acc)) (array) x))
zip (lambda (& xs) (lapply foldr (concat (array (lambda (a & ys) (cons ys a)) (array)) xs)))
match (let (
evaluate_case (rec-lambda evaluate_case (access c) (cond
(symbol? c) (array true (lambda (b) (array let (array c access) b)))
(and (array? c) (= 2 (len c)) (= 'unquote (idx c 0))) (array (array = access (idx c 1)) (lambda (b) b))
(and (array? c) (= 2 (len c)) (= 'quote (idx c 0))) (array (array = access c) (lambda (b) b))
(array? c) (let (
tests (array and (array array? access) (array = (len c) (array len access)))
(tests body_func) ((rec-lambda recurse (tests body_func i) (if (= i (len c))
(array tests body_func)
(let ( (inner_test inner_body_func) (evaluate_case (array idx access i) (idx c i)) )
(recurse (concat tests (array inner_test))
(lambda (b) (body_func (inner_body_func b)))
(+ i 1)))))
tests (lambda (b) b) 0)
) (array tests body_func))
true (array (array = access c) (lambda (b) b))
))
helper (rec-lambda helper (x_sym cases i) (cond (< i (- (len cases) 1)) (let ( (test body_func) (evaluate_case x_sym (idx cases i)) )
(concat (array test (body_func (idx cases (+ i 1)))) (helper x_sym cases (+ i 2))))
true (array true (array error "none matched"))))
) (vau de (x & cases) (eval (array let (array '___MATCH_SYM x) (concat (array cond) (helper '___MATCH_SYM cases 0))) de)))
; This is based on https://www.cs.cornell.edu/courses/cs3110/2020sp/a4/deletion.pdf
; and the figure references refer to it
; Insert is taken from the same paper, but is origional to Okasaki, I belive
; The tree has been modified slightly to take in a comparison function
; and override if insert replaces or not to allow use as a set or as a map
; I think this is actually pretty cool - instead of having a bunch of seperate ['B]
; be our leaf node, we use ['B] with all nils. This allows us to not use -B, as
; both leaf and non-leaf 'BB has the same structure with children! Also, we make
; sure to use empty itself so we don't make a ton of empties...
empty (array 'B nil nil nil)
E empty
EE (array 'BB nil nil nil)
size (rec-lambda recurse (t) (match t
,E 0
(c a x b) (+ 1 (recurse a) (recurse b))))
generic-foldl (rec-lambda recurse (f z t) (match t
,E z
(c a x b) (recurse f (f (recurse f z a) x) b)))
generic-contains? (rec-lambda recurse (t cmp v found not-found) (match t
,E (not-found)
(c a x b) (match (cmp v x) '< (recurse a cmp v found not-found)
'= (found x)
'> (recurse b cmp v found not-found))))
blacken (lambda (t) (match t
('R a x b) (array 'B a x b)
t t))
balance (lambda (t) (match t
; figures 1 and 2
('B ('R ('R a x b) y c) z d) (array 'R (array 'B a x b) y (array 'B c z d))
('B ('R a x ('R b y c)) z d) (array 'R (array 'B a x b) y (array 'B c z d))
('B a x ('R ('R b y c) z d)) (array 'R (array 'B a x b) y (array 'B c z d))
('B a x ('R b y ('R c z d))) (array 'R (array 'B a x b) y (array 'B c z d))
; figure 8, double black cases
('BB ('R a x ('R b y c)) z d) (array 'B (array 'B a x b) y (array 'B c z d))
('BB a x ('R ('R b y c) z d)) (array 'B (array 'B a x b) y (array 'B c z d))
; already balenced
t t))
generic-insert (lambda (t cmp v replace) (let (
ins (rec-lambda ins (t) (match t
,E (array 'R t v t)
(c a x b) (match (cmp v x) '< (balance (array c (ins a) x b))
'= (if replace (array c a v b)
t)
'> (balance (array c a x (ins b))))))
) (blacken (ins t))))
rotate (lambda (t) (match t
; case 1, fig 6
('R ('BB a x b) y ('B c z d)) (balance (array 'B (array 'R (array 'B a x b) y c) z d))
('R ('B a x b) y ('BB c z d)) (balance (array 'B a x (array 'R b y (array 'B c z d))))
; case 2, figure 7
('B ('BB a x b) y ('B c z d)) (balance (array 'BB (array 'R (array 'B a x b) y c) z d))
('B ('B a x b) y ('BB c z d)) (balance (array 'BB a x (array 'R b y (array 'B c z d))))
; case 3, figure 9
('B ('BB a w b) x ('R ('B c y d) z e)) (array 'B (balance (array 'B (array 'R (array 'B a w b) x c) y d)) z e)
('B ('R a w ('B b x c)) y ('BB d z e)) (array 'B a w (balance (array 'B b x (array 'R c y (array 'B d z e)))))
; fall through
t t))
redden (lambda (t) (match t
('B a x b) (if (and (= 'B (idx a 0)) (= 'B (idx b 0))) (array 'R a x b)
t)
t t))
min_delete (rec-lambda recurse (t) (match t
,E (error "min_delete empty tree")
('R ,E x ,E) (array x E)
('B ,E x ,E) (array x EE)
('B ,E x ('R a y b)) (array x (array 'B a y b))
(c a x b) (let ((v ap) (recurse a)) (array v (rotate (array c ap x b))))))
generic-delete (lambda (t cmp v) (let (
del (rec-lambda del (t v) (match t
; figure 3
,E t
; figure 4
('R ,E x ,E) (match (cmp v x) '= E
_ t)
('B ('R a x b) y ,E) (match (cmp v y) '< (rotate (array 'B (del (array 'R a x b) v) y E))
'= (array 'B a x b)
'> t)
; figure 5
('B ,E x ,E) (match (cmp v x) '= EE
_ t)
(c a x b) (match (cmp v x) '< (rotate (array c (del a v) x b))
'= (let ((array vp bp) (min_delete b))
(rotate (array c a vp bp)))
'> (rotate (array c a x (del b v))))))
) (del (redden t) v)))
set-cmp (lambda (a b) (cond (< a b) '<
(= a b) '=
true '>))
set-empty empty
set-foldl generic-foldl
set-insert (lambda (t x) (generic-insert t set-cmp x false))
set-contains? (lambda (t x) (generic-contains? t set-cmp x (lambda (f) true) (lambda () false)))
set-remove (lambda (t x) (generic-delete t set-cmp x))
map-cmp (lambda (a b) (let (ak (idx a 0)
bk (idx b 0))
(cond (< ak bk) '<
(= ak bk) '=
true '>)))
map-empty empty
map-insert (lambda (t k v) (generic-insert t map-cmp (array k v) true))
map-contains-key? (lambda (t k) (generic-contains? t map-cmp (array k nil) (lambda (f) true) (lambda () false)))
map-get (lambda (t k) (generic-contains? t map-cmp (array k nil) (lambda (f) (idx f 1)) (lambda () (error (str "didn't find key " k " in map " t)))))
map-get-or-default (lambda (t k d) (generic-contains? t map-cmp (array k nil) (lambda (f) (idx f 1)) (lambda () d)))
map-get-with-default (lambda (t k d) (generic-contains? t map-cmp (array k nil) (lambda (f) (idx f 1)) (lambda () (d))))
map-remove (lambda (t k) (generic-delete t map-cmp (array k nil)))
; This could be 2x as efficent by being implmented on generic instead of map,
; as we wouldn't have to traverse once to find and once to insert
multimap-empty map-empty
multimap-insert (lambda (t k v) (map-insert t k (set-insert (map-get-or-default t k set-empty) v)))
multimap-get (lambda (t k) (map-get-or-default t k set-empty))
make-test-tree (rec-lambda make-test-tree (n t) (cond (<= n 0) t
true (make-test-tree (- n 1) (map-insert t n (= 0 (% n 10))))))
reduce-test-tree (lambda (tree) (generic-foldl (lambda (a x) (if (idx x 1) (+ a 1) a)) 0 tree))
monad (array 'write 1 (str "running tree test") (vau (written code)
(array 'exit (log (reduce-test-tree (make-test-tree (log 420000) map-empty))))
;(array 'read 0 60 (vau (data code)
; (array 'exit (log (reduce-test-tree (make-test-tree (read-string data) map-empty))))
;))
))
) monad)
; end of all lets
))))))
; impl of let1
)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))
; impl of quote
)) (vau (x5) x5))

29
working_files/rb_profile.txt Normal file
View File

@@ -0,0 +1,29 @@
Samples: 27K of event 'cycles:u', Event count (approx.): 16890753964
Overhead Command Shared Object Symbol
33.05% wasmtime jitted-1267703-13.so [.] wasm::wasm-function[16]
12.64% wasmtime jitted-1267703-12.so [.] wasm::wasm-function[15]
10.48% wasmtime jitted-1267703-2.so [.] wasm::wasm-function[5]
10.11% wasmtime jitted-1267703-0.so [.] wasm::wasm-function[3]
9.95% wasmtime jitted-1267703-528.so [.] wasm::wasm-function[531]
4.12% wasmtime jitted-1267703-526.so [.] wasm::wasm-function[529]
4.02% wasmtime jitted-1267703-85.so [.] wasm::wasm-function[88]
3.01% wasmtime jitted-1267703-39.so [.] wasm::wasm-function[42]
2.42% wasmtime jitted-1267703-1.so [.] wasm::wasm-function[4]
1.19% wasmtime jitted-1267703-87.so [.] wasm::wasm-function[90]
1.18% wasmtime jitted-1267703-37.so [.] wasm::wasm-function[40]
0.97% wasmtime jitted-1267703-3.so [.] wasm::wasm-function[6]
0.88% wasmtime jitted-1267703-23.so [.] wasm::wasm-function[26]
0.83% wasmtime jitted-1267703-134.so [.] wasm::wasm-function[137]
0.79% wasmtime jitted-1267703-582.so [.] wasm::wasm-function[585]
0.63% wasmtime jitted-1267703-132.so [.] wasm::wasm-function[135]
0.49% wasmtime jitted-1267703-99.so [.] wasm::wasm-function[102]
0.30% wasmtime jitted-1267703-524.so [.] wasm::wasm-function[527]
0.29% wasmtime jitted-1267703-14.so [.] wasm::wasm-function[17]
0.28% wasmtime jitted-1267703-133.so [.] wasm::wasm-function[136]
0.24% wasmtime jitted-1267703-525.so [.] wasm::wasm-function[528]
0.23% wasmtime jitted-1267703-41.so [.] wasm::wasm-function[44]
0.17% wasmtime jitted-1267703-581.so [.] wasm::wasm-function[584]
0.14% wasmtime jitted-1267703-488.so [.] wasm::wasm-function[491]
0.14% wasmtime jitted-1267703-523.so [.] wasm::wasm-function[526]
0.12% wasmtime jitted-1267703-131.so [.] wasm::wasm-function[134]