Showing preview only (309K chars total). Download the full file or copy to clipboard to get everything.
Repository: HigherOrderCO/HVM3
Branch: main
Commit: fba2e9c82faf
Files: 99
Total size: 284.8 KB
Directory structure:
gitextract_w2c5eac0/
├── .github/
│ ├── ISSUE_TEMPLATE/
│ │ ├── bug_report.yml
│ │ ├── config.yml
│ │ └── feature_request.md
│ └── workflows/
│ └── CI.yml
├── .gitignore
├── CLAUDE.md
├── HVM.cabal
├── HVM.md
├── IC.md
├── INTERS.md
├── LICENSE
├── MODES.md
├── README.md
├── app/
│ └── Main.hs
├── bug.hvm
├── cabal.project
├── examples/
│ ├── _test_.js
│ ├── bench_cnots.hvm
│ ├── bench_count.hs
│ ├── bench_count.hvm
│ ├── bench_sum_range.hs
│ ├── bench_sum_range.hvm
│ ├── bench_sum_range.py
│ ├── enum_1D_match.hvm
│ ├── enum_bin.hvm
│ ├── enum_coc_smart.hvm
│ ├── enum_invert_add.hvm
│ ├── enum_lam_naive_blc.hs
│ ├── enum_lam_naive_blc.hvm
│ ├── enum_lam_smart.hvm
│ ├── enum_nat.hvm
│ ├── enum_path_finder.hvm
│ ├── enum_primes.hs
│ ├── enum_primes.hvm
│ ├── feat_affine_ctx.hvm
│ ├── feat_cmul.hvm
│ ├── feat_hoas.hvm
│ ├── feat_mut_ref.hvm
│ ├── fuse_inc.hvm
│ ├── fuse_inc.hvm1
│ ├── fuse_mul.hvm
│ ├── fuse_rot.hvm
│ └── main.hvm
└── src/
└── HVM/
├── API.hs
├── Adjust.hs
├── Collapse.hs
├── Compile.hs
├── Extract.hs
├── Foreign.hs
├── Inject.hs
├── Parse.hs
├── Reduce.hs
├── Runtime.c
├── Runtime.h
├── Type.hs
└── runtime/
├── heap.c
├── memory.c
├── prim/
│ ├── DUP.c
│ ├── LOG.c
│ └── SUP.c
├── print.c
├── reduce/
│ ├── app_ctr.c
│ ├── app_era.c
│ ├── app_lam.c
│ ├── app_sup.c
│ ├── app_una.c
│ ├── app_w32.c
│ ├── dup_ctr.c
│ ├── dup_era.c
│ ├── dup_lam.c
│ ├── dup_ref.c
│ ├── dup_sup.c
│ ├── dup_una.c
│ ├── dup_w32.c
│ ├── let.c
│ ├── mat_ctr.c
│ ├── mat_era.c
│ ├── mat_lam.c
│ ├── mat_sup.c
│ ├── mat_una.c
│ ├── mat_w32.c
│ ├── opx_ctr.c
│ ├── opx_era.c
│ ├── opx_lam.c
│ ├── opx_sup.c
│ ├── opx_una.c
│ ├── opx_w32.c
│ ├── opy_ctr.c
│ ├── opy_era.c
│ ├── opy_lam.c
│ ├── opy_sup.c
│ ├── opy_una.c
│ ├── opy_w32.c
│ ├── ref.c
│ └── ref_sup.c
├── reduce.c
├── stack.c
├── state.c
└── term.c
================================================
FILE CONTENTS
================================================
================================================
FILE: .github/ISSUE_TEMPLATE/bug_report.yml
================================================
name: Bug report
description: Create a report to help us improve.
body:
- type: markdown
attributes:
value: |
### Bug Report
Note, your issue might have been already reported, please check [issues](https://github.com/HigherOrderCO/HVM3/issues). If you find a similar issue, respond with a reaction or any additional information that you feel may be helpful.
### For Windows Users
There is currently no native way to install HVM, as a temporary workaround, please use [WSL2](https://learn.microsoft.com/en-us/windows/wsl/install).
- type: textarea
attributes:
label: Reproducing the behavior
description: A clear and concise description of what the bug is.
value: |
Example:
Running command...
With code....
Error...
Expected behavior....
validations:
required: true
- type: textarea
attributes:
label: System Settings
description: Your System's settings
value: |
Example:
- OS: [e.g. Linux (Ubuntu 22.04)]
- CPU: [e.g. Intel i9-14900KF]
- GPU: [e.g. RTX 4090]
- Cuda Version [e.g. release 12.4, V12.4.131]
validations:
required: true
- type: textarea
attributes:
label: Additional context
description: Add any other context about the problem here (Optional).
================================================
FILE: .github/ISSUE_TEMPLATE/config.yml
================================================
blank_issues_enabled: false
contact_links:
- name: Bend Related Issues
url: https://github.com/HigherOrderCO/Bend/issues/new/choose
about: For Bend related Issues, please Report them on the Bend repository.
================================================
FILE: .github/ISSUE_TEMPLATE/feature_request.md
================================================
---
name: Feature request
about: Suggest a feature that you think should be added.
title: ''
labels: ''
---
**Is your feature request related to a problem? Please describe.**
A clear and concise description of what the problem is. Ex. I'm frustrated when [...]
**Describe the solution you'd like**
A clear and concise description of what you want to happen.
**Describe alternatives you've considered**
A clear and concise description of any alternative solutions or features you've considered.
**Additional context**
Add any other context or screenshots about the feature request here.
================================================
FILE: .github/workflows/CI.yml
================================================
name: HVM3 CI
on:
push:
branches: [ main ]
pull_request:
branches: [ main ]
jobs:
hvml-pipeline:
name: HVM3 CI (${{ matrix.os }})
runs-on: ${{ matrix.os }}
strategy:
fail-fast: false
matrix:
os: [ubuntu-latest, macos-latest]
steps:
- name: Checkout repository
uses: actions/checkout@v3
- name: Cache GHC and Cabal
uses: actions/cache@v3
id: cache-ghc
with:
path: |
~/.ghcup
key: ${{ runner.os }}-ghcup-${{ hashFiles('.github/workflows/ci.yml') }}
restore-keys: |
${{ runner.os }}-ghcup-
- name: Set up GHC and Cabal
uses: haskell-actions/setup@v2
id: setup-haskell
with:
ghc-version: '9.12.2'
cabal-version: '3.14.1.1'
setup-haskell-bin: ${{ steps.cache-ghc.outputs.cache-hit != 'true' }}
setup-haskell-cabal: ${{ steps.cache-ghc.outputs.cache-hit != 'true' }}
setup-haskell-ghc: ${{ steps.cache-ghc.outputs.cache-hit != 'true' }}
- name: Update Cabal package list
run: cabal update
- name: Install system dependencies
run: |
if [ "${{ matrix.os }}" == "ubuntu-latest" ]; then
sudo apt-get update
sudo apt-get install -y libffi-dev
elif [ "${{ matrix.os }}" == "macos-latest" ]; then
brew install libffi
fi
shell: bash
- name: Cache Cabal packages
uses: actions/cache@v3
with:
path: |
${{ steps.setup-haskell.outputs.cabal-store }}
~/.cabal/packages
~/.cabal/config
key: ${{ runner.os }}-cabal-${{ hashFiles('**/*.cabal', 'cabal.project*') }}-${{ github.sha }}
restore-keys: |
${{ runner.os }}-cabal-${{ hashFiles('**/*.cabal', 'cabal.project*') }}-
${{ runner.os }}-cabal-
- name: Build dependencies
run: cabal build --only-dependencies
- name: Build the project
run: cabal build
- name: Lazy - Run interpreted normalization
run: cabal run hvm -- run ./examples/feat_hoas.hvm -s
- name: Lazy - Run compiled normalization
run: cabal run hvm -- run ./examples/feat_hoas.hvm -c -s
- name: Lazy - Run interpreted collapse
run: cabal run hvm -- run ./examples/enum_lam_smart.hvm -C -s
- name: Lazy - Run compiled collapse
run: cabal run hvm -- run ./examples/enum_lam_smart.hvm -C -c -s
================================================
FILE: .gitignore
================================================
dist-newstyle/
dist-install/
*.o
*.hi
main
Main1
cabal-dev/
.cabal-sandbox/
cabal.sandbox.config
.stack-work/
*.prof
*.aux
*.hp
*.eventlog
.HTF/
.ghc.environment.*
.log.txt
.msg.txt
.sys.txt
.out.hvm
tmp/
TIMES/
.main*
.build/
dist/
================================================
FILE: CLAUDE.md
================================================
# HVM3
This project is an efficient implementation of the Interaction Calculus.
Before doing any work, read the `HVM.md` file to learn more about it.
================================================
FILE: HVM.cabal
================================================
cabal-version: 3.0
name: HVM
version: 0.1.0.0
homepage: https://higherorderco.com/
license: MIT
license-file: LICENSE
author: Victor Taelin
maintainer: victor.taelin@gmail.com
category: Language
build-type: Simple
extra-source-files:
src/HVM/Runtime.h
src/HVM/runtime/*.c
src/HVM/runtime/reduce/*.c
src/HVM/runtime/prim/*.c
library
default-language: GHC2024
build-depends: base ^>=4.21.0.0,
mtl ^>=2.3.1,
containers ^>=0.7,
parsec ^>=3.1.17.0,
hs-highlight ^>= 1.0.5,
ansi-terminal == 1.1.1,
file-embed,
process,
libffi,
unix,
deepseq
exposed-modules: HVM.Type
, HVM.Collapse
, HVM.Compile
, HVM.Extract
, HVM.Foreign
, HVM.Inject
, HVM.Parse
, HVM.Adjust
, HVM.Reduce
, HVM.API
other-modules:
hs-source-dirs: src
include-dirs: src/HVM
includes: Runtime.h
install-includes: Runtime.h
-- Build the runtime as a single translation unit for performance
c-sources: src/HVM/Runtime.c
extra-libraries: c
ghc-options: -Wno-all
executable hvm
default-language: GHC2024
build-depends: base ^>=4.21.0.0,
containers ^>=0.7,
network
main-is: Main.hs
build-depends: HVM
hs-source-dirs: app
ghc-options: -Wno-all -threaded
================================================
FILE: HVM.md
================================================
# HVM
The HVM is a extension, and efficient runtime, for the Interaction Calculus.
## Project Organization
- `README.md`: introduction and general information
- `IC.md`: full spec of the Interaction Calculus (read it!)
- `HVM.md`: full spec of the HVM runtime (read it!)
- `Inters.md`: the complete interaction table
- `examples/`: many example `.hvm` files
- `src/`: Haskell and C implementation
- `Type.hs`: defines the Term and Book types, used in all files (read it!)
- `Show.hs`: converts a Term to a String
- `Parse.hs`: converts a String to a Term
- `Reduce.hs`: evaluates a Term to weak head normal form (WHNF)
- `Inject.hs`: converts a Haskell-side Term to a C-side Term
- `Extract.hs`: normalize and extracts a C-side Term into a Haskell-side IC Term
- `Collapse.hs`: normalizes and collapses a C-side Term into a list of Haskell-side λC (i.e., dup/sup-free) Terms
- `Foreign.hs`: imports C-side functions on Haskell-side
- `Runtime.c`: the complete C runtime, including memory types, interactions, and a faster WHNF evaluator
- `Compile.hs`: converts a top-level Book into a list of optimized, native C-code
- `dist/`, `dist-newstyle`: Haskell artifacts
## Memory Layout
On HVM, each Term is represented as a word, with the following fields:
- `sub`: true if this is a substitution
- `tag`: the tag identifying the term type
- `lab`: a label, used to trigger commutations
- `val`: the value (a node address, or an unboxed number)
The length of each field depends on the version:
- **32-bit**: 1-bit sub | 5-bit tag | 2-bit lab | 24-bit val
- **64-bit**: 1-bit sub | 5-bit tag | 18-bit lab | 40-bit val
The meaning of the val field depends on the term's tag, as follows:
Tag | ID | Value points to / stores ...
--- | ---- | --------------------------------------
DP0 | 0x00 | Dup Node ({val: Term}) or substitution
DP1 | 0x01 | Dup Node ({val: Term}) or substitution
VAR | 0x02 | Lam Node ({bod: Term}) or substitution
FWD | 0x03 | TODO: document
REF | 0x04 | Ref Node ({arg0: Term, ... argN: Term})
LET | 0x05 | Let Node
APP | 0x06 | App Node ({fun: Term, arg: Term})
MAT | 0x08 | Mat Node
IFL | 0x09 | IfL Node
SWI | 0x0A | Swi Node
OPX | 0x0B | OpX Node
OPY | 0x0C | OpY Node
ERA | 0x0D | Unused
LAM | 0x0E | Lam Node ({bod: Term})
SUP | 0x0F | Sup Node
CTR | 0x10 | Ctr Node ({x0: Term, ... xN: Term})
W32 | 0x11 | Unboxed U32 Number
CHR | 0x12 | Unboxed U32 Number
A Node is a consecutive block of its child terms. For example, the SUP term
points to the memory location where its two child terms are stored.
Variable terms (`VAR`, `DP0`, and `DP1`) point to an entry on the subst map. As
an optimization, HVM doesn't have a separate subst map. Instead, variables point
to the location of the corresponding binder node (like a Lam or Dup). When an
interaction occurs, that location is reused as a subst map entry, and we set the
'sub' bit of the stored term to '1'. When a variable points to a term with the
bit flag set, we it is a substitution, so we retrieve it and clear the flag.
Note that there is no explicit DUP term. That's because Dup nodes are special:
they aren't part of the AST, and they don't store a body; they "float" on the
heap. In other words, `λx. !&0{x0,x1}=x; &0{x0,x1}` and `!&0{x0,x1}=x; λx.
&0{x0,x1}` are both valid, and stored identically in memory. As such, the only
way to access a Dup node is via its bound variables, `DP0` and `DP1`.
Note that, when a Dup Node interacts, it usually generates two substitutions.
So, how can we store them in its location, given that a Dup Node has only one
word? The answer is: we don't. Dup Nodes only interact when we access them
via either a `DP0` or a `DP1`. As such, we immediatelly return one of the
substitutions to the variable that triggered the interaction, and store the
other substitution on the Dup Node's location.
For example, the DUP-SUP interaction could be implemented as:
```
def dup_sup(dup, sup):
dup_lab = dup.tag & 0x3
sup_lab = sup.tag & 0x3
if dup_lab == sup_lab:
tm0 = heap[sup.loc + 0]
tm1 = heap[sup.loc + 1]
heap[dup.loc] = as_sub(tm1 if (dup.tag & 0x4) == 0 else tm0)
return (tm0 if (dup.tag & 0x4) == 0 else tm1)
else:
co0_loc = alloc(1)
co1_loc = alloc(1)
su0_loc = alloc(2)
su1_loc = alloc(2)
su0_val = Term(SP0 + sup_lab, su0_loc)
su1_val = Term(SP0 + sup_lab, su1_loc)
heap[co0_loc] = heap[sup.loc + 0]
heap[co1_loc] = heap[sup.loc + 1]
heap[su0_loc + 0] = Term(CX0 + dup_lab, co0_loc)
heap[su0_loc + 1] = Term(CX0 + dup_lab, co1_loc)
heap[su1_loc + 0] = Term(CY0 + dup_lab, co0_loc)
heap[su1_loc + 1] = Term(CY0 + dup_lab, co1_loc)
heap[dup.loc] = as_sub(su1_val if (dup.tag & 0x4) == 0 else su0_val)
return (su0_val if (dup.tag & 0x4) == 0 else su1_val)
```
Note that HVM extends the Interaction Calculus with many new types and
interactions. The complete Interaction Table is at INTERS.md.
## C FFI and Compiler
In this project, Terms have two representations:
- A Haskell-side representation (the Term type on `Type.hs`)
- A C-side representation (the pointer format specified on `HVM.md`)
Functions are implemented on Haskell, C, or both:
- Interactions are exclusively implemented on C, except for CALL.
- The WHNF function is implemented on both Haskell and C.
- All other functions are implemented on Haskell only.
There are two evaluation modes:
- Interpreted Mode:
- uses Haskell-side parser, WHNF, collapser, and stringifier
- uses Haskell-side CALL interaction
- uses C-side for other interactions
- Compiled Mode:
- uses Haskell-side parser, collapser and strinigifier
- uses C-side CALL interaction
- uses C-side WHNF and interactions
To run HVM3 on Compiled Mode, we generate a new copy of `Runtime.c` with the
compiled functions inlined, and then compile with GCC and reload as a dylib.
This allows the C-side WHNF to dispatch CALL interactions to native C
procedures, which run much faster than `inject`.
## The CALL interaction
The CALL interaction performs a global function call. For example, given:
```
@mul2(x) = ~ x { 0:0 p:(+ 2 @mul2(p)) }
```
When we evaluate the expression:
```
@foo(4)
```
It will expand to:
```
~ 4 { 0:0 p:(+ 2 @mul2(p)) }
```
On Interpreted Mode, this is done by `inject`, which allocates the body of the
function, substituting variables by the respective arguments.
On Compiled Mode, this is done by calling a native C function, via two paths:
`Slow Path`: a C function that just allocates the body, like `inject`. Example:
```c
Term mul2_t(Term ref) {
Term arg0 = got(term_loc(ref) + 0);
Loc mat1 = alloc_node(3);
set_new(mat1 + 0, arg0);
set_new(mat1 + 1, term_new(W32, 0, 0));
Loc lam2 = alloc_node(1);
Loc opx3 = alloc_node(2);
Loc ref4 = alloc_node(1);
set_new(ref4 + 0, term_new(VAR, 0, lam2 + 0));
set_new(opx3 + 0, term_new(W32, 0, 2));
set_new(opx3 + 1, term_new(REF, 0, ref4));
set_new(lam2 + 0, term_new(OPX, 0, opx3));
set_new(mat1 + 2, term_new(LAM, 0, lam2));
return term_new(SWI, 2, mat1);
}
```
`Fast Path`: a C function that attempts to perform *inline interactions*,
avoiding allocating extra memory. For example, in the `mul2` case, it will check
if the argument is a number. If so, it will perform a native C switch, instead
of allocating a `SWI` node. It also performs inline arithmetic and even loops,
when the function is tail-call recursive. Example:
```c
Term mul2_f(Term ref) {
u64 itrs = 0;
Term arg0 = got(term_loc(ref) + 0);
while (1) {
Term val1 = (arg0);
if (term_tag(val1) == W32) {
u32 num2 = term_loc(val1);
switch (num2) {
case 0: {
itrs += 1;
*HVM.itrs += itrs;
return term_new(W32, 0, 0);
break;
}
default: {
Term pre3 = term_new(W32, 0, num2 - 1);
itrs += 2;
Loc ref8 = alloc_node(1);
set_new(ref8 + 0, pre3);
Term nu06 = (term_new(W32, 0, 2));
Term nu17 = (term_new(REF, 0, ref8));
Term ret5;
if (term_tag(nu06) == W32 && term_tag(nu17) == W32) {
itrs += 2;
ret5 = term_new(W32, 0, term_loc(nu06) + term_loc(nu17));
} else {
Loc opx4 = alloc_node(2);
set_new(opx4 + 0, nu06);
set_new(opx4 + 1, nu17);
ret5 = term_new(OPX, 0, opx4);
}
*HVM.itrs += itrs;
return ret5;
break;
}
}
}
set_old(term_loc(ref) + 0, arg0);
return mul2_t(ref);
}
}
```
# Parser
On HVM, all bound variables have global range. For example, consider the term:
```
λt.((t x) λx.λy.y)
```
Here, the `x` variable appears before its binder, `λx`. Since runtime variables
must point to their bound λ's, linking them correctly requires caution. A way to
do it is to store two structures at parse-time: a list from names to locations,
and a map from names to variable terms.
Whenever we parse a name, we add the current location to the 'uses' array, and
whenever we parse a binder (lams, lets, etc.), we add a variable term pointing
to it to the 'vars' map. Then, once the parsing is done, we run iterate through
the 'uses' array, and write, to each location, the corresponding term. Below
are some example parsers using this strategy:
```python
def parse_var(loc):
nam = parse_name()
uses.push((nam,loc))
def parse_lam(loc):
lam = alloc(1)
consume("λ")
nam = parse_name()
consume(".")
vars[nam] = Term(VAR, 0, lam)
parse_term(lam)
heap[loc] = Term(LAM, 0, lam)
def parse_app(loc):
app = alloc(2)
consume("(")
parse_term(app + 0)
consume(" ")
parse_term(app + 1)
consume(")")
heap[loc] = Term(APP, 0, app)
...
```
# Stringifier
Converting HVM terms to strings faces two challenges:
First, HVM terms and nodes don't store variable names. As such, we must
generate fresh, unique variable names during stringification, and maintain a
mapping from each binder's memory location to its assigned name.
Second, on HVM, Dup nodes aren't part of the main program's AST. Instead, they
"float" on the heap, and are only reachable via DP0 and DP1 variables. Because
of that, by stringifying a term naively, Col nodes will be missing.
To solve these, we proceed as follows:
1. Before stringifying, we pass through the full term, and assign a id to each
variable binder we find (on lam, let, dup, etc.)
2. We also register every Dup node we found, avoiding duplicates (remember the
same dup node is pointed to by up to 2 variables, DP0 and DP1)
Then, to stringify the term, we first stringify each DUP node, and then we
stringify the actual term. As such, the result will always be in the form:
! &{x0 x1} = t0
! &{x2 x3} = t1
! &{x4 x5} = t2
...
term
With no Dup nodes inside the ASTs of t0, t1, t2 ... and term.
================================================
FILE: IC.md
================================================
# The Interaction Calculus
The [Interaction Calculus](https://github.com/VictorTaelin/Interaction-Calculus)
is a minimal term rewriting system inspired by the Lambda Calculus (λC), but
with some key differences:
1. Vars are affine: they can only occur up to one time.
2. Vars are global: they can occur anywhere in the program.
3. There is a new core primitive: the superposition.
An Interaction Calculus term is defined by the following grammar:
```haskell
Term ::=
| VAR: Name
| ERA: "*"
| LAM: "λ" Name "." Term
| APP: "(" Term " " Term ")"
| SUP: "&" Label "{" Term "," Term "}"
| DUP: "!" "&" Label "{" Name "," Name "}" "=" Term ";" Term
```
Where:
- VAR represents a variable.
- ERA represents an erasure.
- LAM represents a lambda.
- APP represents a application.
- SUP represents a superposition.
- DUP represents a duplication.
Lambdas are curried, and work like their λC counterpart, except with a relaxed
scope, and with affine usage. Applications eliminate lambdas, like in λC,
through the beta-reduce (APP-LAM) interaction.
Superpositions work like pairs. Duplications eliminate superpositions through
the DUP-SUP interaction, which works exactly like a pair projection.
What makes SUPs and DUPs unique is how they interact with LAMs and APPs. When a
SUP is applied to an argument, it reduces through the APP-SUP interaction, and
when a LAM is projected, it reduces through the DUP-LAM interaction. This gives
a computational behavior for every possible interaction: there are no runtime
errors on the core Interaction Calculus.
The 'Label' is a numeric value that affects some interactions, like DUP-SUP,
causing terms to commute, instead of annihilate. Read Lafont's Interaction
Combinators paper to learn more.
The core interaction rules are listed below:
```haskell
(* a)
----- APP-ERA
*
(λx.f a)
-------- APP-LAM
x <- a
f
(&L{a,b} c)
----------------- APP-SUP
! &L{c0,c1} = c;
&L{(a c0),(b c1)}
! &L{r,s} = *;
K
-------------- DUP-ERA
r <- *
s <- *
K
! &L{r,s} = λx.f;
K
----------------- DUP-LAM
r <- λx0.f0
s <- λx1.f1
x <- &L{x0,x1}
! &L{f0,f1} = f;
K
! &L{x,y} = &L{a,b};
K
-------------------- DUP-SUP (if equal labels)
x <- a
y <- b
K
! &L{x,y} = &R{a,b};
K
-------------------- DUP-SUP (if different labels)
x <- &R{a0,b0}
y <- &R{a1,b1}
! &L{a0,a1} = a;
! &L{b0,b1} = b;
K
```
Where `x <- t` stands for a global substitution of `x` by `t`.
Since variables are affine, substitutions can be implemented efficiently by just
inserting an entry in a global substitution map (`sub[var] = value`). There is
no need to traverse the target term, or to handle name capture, as long as fresh
variable names are globally unique. Thread-safe substitutions can be performed
with a single atomic-swap.
Below is a pseudocode implementation of these interaction rules:
```python
def app_lam(app, lam):
sub[lam.nam] = app.arg
return lam.bod
def app_sup(app, sup):
x0 = fresh()
x1 = fresh()
a0 = App(sup.lft, Var(x0))
a1 = App(sup.rgt, Var(x1))
return Dup(sup.lab, x0, x1, app.arg, Sup(a0, a1))
def dup_lam(dup, lam):
x0 = fresh()
x1 = fresh()
f0 = fresh()
f1 = fresh()
sub[dup.lft] = Lam(x0, Var(f0))
sub[dup.rgt] = Lam(x1, Var(f1))
sub[lam.nam] = Sup(dup.lab, Var(x0), Var(x1))
return Dup(dup.lab, f0, f1, lam.bod, dup.bod)
def dup_sup(dup, sup):
if dup.lab == sup.lab:
sub[dup.lft] = sup.lft
sub[dup.rgt] = sup.rgt
return dup.bod
```
Terms can be reduced to weak head normal form, which means reducing until the
outermost constructor is a value (LAM, SUP, etc.), or until no more reductions
are possible. Example:
```python
def whnf(term):
while True:
match term:
case Var(nam):
if nam in sub:
term = sub[nam]
else:
return term
case App(fun, arg):
fun = whnf(fun)
match fun.tag:
case LAM: term = app_lam(term, fun)
case SUP: term = app_sup(term, fun)
case _ : return App(fun, arg)
case Dup(lft, rgt, val, bod):
val = whnf(val)
match val.tag:
case LAM: term = dup_lam(term, val)
case SUP: term = dup_sup(term, val)
case _ : return Dup(lft, rgt, val, bod)
case _:
return term
```
Terms can be reduced to full normal form by recursively taking the whnf:
```python
def normal(term):
term = whnf(term)
match term:
case Lam(nam, bod):
bod_nf = normal(bod)
return Lam(nam, bod_nf)
case App(fun, arg):
fun_nf = normal(fun)
arg_nf = normal(arg)
return App(fun_nf, arg_nf)
...
case _:
return term
```
Below are some normalization examples.
Example 0: (simple λ-term)
```haskell
(λx.λt.(t x) λy.y)
------------------ APP-LAM
λt.(t λy.y)
```
Example 1: (larger λ-term)
```haskell
(λb.λt.λf.((b f) t) λT.λF.T)
---------------------------- APP-LAM
λt.λf.((λT.λF.T f) t)
----------------------- APP-LAM
λt.λf.(λF.t f)
-------------- APP-LAM
λt.λf.t
```
Example 2: (global scopes)
```haskell
{x,(λx.λy.y λk.k)}
------------------ APP-LAM
{λk.k,λy.y}
```
Example 3: (superposition)
```haskell
!{a,b} = {λx.x,λy.y}; (a b)
--------------------------- DUP-SUP
(λx.x λy.y)
----------- APP-LAM
λy.y
```
Example 4: (overlap)
```haskell
({λx.x,λy.y} λz.z)
------------------ APP-SUP
! {x0,x1} = λz.z; {(λx.x x0),(λy.y x1)}
--------------------------------------- DUP-LAM
! {f0,f1} = {r,s}; {(λx.x λr.f0),(λy.y λs.f1)}
---------------------------------------------- DUP-SUP
{(λx.x λr.r),(λy.y λs.s)}
------------------------- APP-LAM
{λr.r,(λy.y λs.s)}
------------------ APP-LAM
{λr.r,λs.s}
```
Example 5: (default test term)
The following term can be used to test all interactions:
```haskell
((λf.λx.!{f0,f1}=f;(f0 (f1 x)) λB.λT.λF.((B F) T)) λa.λb.a)
----------------------------------------------------------- 16 interactions
λa.λb.a
```
# Collapsing
An Interaction Calculus term can be collapsed to a superposed tree of pure
Lambda Calculus terms without SUPs and DUPs, by extending the evaluator with the
following collapse interactions:
```haskell
λx.*
------ ERA-LAM
x <- *
*
(f *)
----- ERA-APP
*
λx.&L{f0,f1}
----------------- SUP-LAM
x <- &L{x0,x1}
&L{λx0.f0,λx1.f1}
(f &L{x0,x1})
------------------- SUP-APP
!&L{f0,f1} = f;
&L{(f0 x0),(f1 x1)}
&R{&L{x0,x1},y}
----------------------- SUP-SUP-X (if R>L)
!&R{y0,y1} = y;
&L{&R{x0,x1},&R{y0,y1}}
&R{x,&L{y0,y1}}
----------------------- SUP-SUP-Y (if R>L)
!&R{x0,x1} = x;
&L{&R{x0,x1},&R{y0,y1}}
!&L{x0,x1} = x; K
----------------- DUP-VAR
x0 <- x
x1 <- x
K
!&L{a0,a1} = (f x); K
--------------------- DUP-APP
a0 <- (f0 x0)
a1 <- (f1 x1)
!&L{f0,f1} = f;
!&L{x0,x1} = x;
K
```
================================================
FILE: INTERS.md
================================================
# HVM - Interaction Table
TODO: this document is a WIP. It is not complete yet.
## Core Interactions
Lambdas and Superpositions:
```haskell
(* a)
----- APP-ERA
*
(λx.f a)
-------- APP-LAM
x <- a
f
(&L{a,b} c)
----------------- APP-SUP
! &L{c0,c1} = c;
&L{(a c0),(b c1)}
! &L{r,s} = *;
K
-------------- DUP-ERA
r <- *
s <- *
K
! &L{r,s} = λx.f;
K
----------------- DUP-LAM
r <- λx0.f0
s <- λx1.f1
x <- &L{x0,x1}
! &L{f0,f1} = f;
K
! &L{x,y} = &L{a,b};
K
-------------------- DUP-SUP (if equal labels)
x <- a
y <- b
K
! &L{x,y} = &R{a,b};
K
-------------------- DUP-SUP (if different labels)
x <- &R{a0,b0}
y <- &R{a1,b1}
! &L{a0,a1} = a;
! &L{b0,b1} = b;
K
```
Numbers:
```haskell
+N
--- SUC-NUM
N+1
+*
-- SUC-ERA
*
+&L{x,y}
--------- SUC-SUP
&L{+x,+y}
?N{0:z;+:s;}
------------ SWI-NUM (if N==0)
z
?N{0:z;+:s;}
------------ SWI-NUM (if N>0)
(s N-1)
?*{0:z;+:s;}
------------ SWI-ERA
*
?&L{x,y}{0:z;+:s;}
--------------------------------- SWI-SUP
!&L{z0,z1} = z;
!&L{s0,s1} = s;
&L{?x{0:z0;+:s0;},?y{0:z1;+:s1;}}
! &L{x,y} = N;
K
-------------- DUP-NUM
x <- N
y <- N
K
```
## Collapsing Interactions
These interactions are NOT part of the WHNF. They're called by the collapser.
```haskell
λx.*
------ ERA-LAM
x <- *
*
(f *)
----- ERA-APP
*
λx.&L{f0,f1}
----------------- SUP-LAM
x <- &L{x0,x1}
&L{λx0.f0,λx1.f1}
(f &L{x0,x1})
------------------- SUP-APP
!&L{f0,f1} = f;
&L{(f0 x0),(f1 x1)}
~N{0:&L{z0,z1};+:s;}
--------------------------------- SUP-SWI-Z
!&L{N0,N1} = N;
!&L{S0,S1} = S;
&L{~N0{0:z0;+:S0},~N1{0:z1;+:S1}}
~N{0:z;+:&0{s0,s1};}
--------------------------------- SUP-SWI-S
!&L{N0,N1} = N;
!&L{Z0,Z1} = Z;
&L{~N0{0:z0;+:S0},~N1{0:z1;+:S1}}
&R{&L{x0,x1},y}
----------------------- SUP-SUP-X (if R>L)
!&R{y0,y1} = y;
&L{&R{x0,x1},&R{y0,y1}}
&R{x,&L{y0,y1}}
----------------------- SUP-SUP-Y (if R>L)
!&R{x0,x1} = x;
&L{&R{x0,x1},&R{y0,y1}}
!&L{x0,x1} = x; K
----------------- DUP-VAR
x0 <- x
x1 <- x
K
!&L{a0,a1} = (f x); K
--------------------- DUP-APP
a0 <- (f0 x0)
a1 <- (f1 x1)
!&L{f0,f1} = f;
!&L{x0,x1} = x;
K
```
================================================
FILE: LICENSE
================================================
Copyright (c) 2024 Victor Taelin
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
================================================
FILE: MODES.md
================================================
# Evaluation Modes
## Lazy Mode
Pointers represent positive-to-negative ports in polarized nets. This causes the
memory format to coincide perfectly with how IC terms are written textually. It
is a direct improvement of [HVM1](https://github.com/HigherOrderCO/hvm1). It is
implemented in this repository.
### Strengths:
- Efficient lazy evaluation
- Lévy Optimality (minimal β-reduction)
- Very fast single-core evaluation
- Compiles to efficient C (often, faster than GHC)
### Drawbacks:
- WHNF may return a pending variable
- Requires global garbage collection
- Parallelism is still an open problem
## Strict Mode
Pointers represent aux-to-main ports, resulting in a tree-like memory format. It
is implemented in a [separate repository](https://github.com/HigherOrderCO/hvm3-strict),
and will be merged later.
### Strengths:
- Efficient parallel evaluation
- Does not require global garbage collection
### Drawbacks:
- Lazy evaluation is impossible
- Not Lévy Optimal (can waste β-reductions)
================================================
FILE: README.md
================================================
# HVM3 - Work In Progress
The **HVM** is an efficient implementation of the [Interaction Calculus](https://github.com/VictorTaelin/Interaction-Calculus) (IC).
The Interaction Calculus is a new foundation for computing, similar to the
Lambda Calculus, but theoretically optimal. The HVM is an efficient
implementation of this new paradigm, and can be seen as a fast engine for
symbolic computations.
In some ways, it is very similar to Haskell, but it has some key differences:
- Lambdas must be linear or affine, making it resource-aware
- Lambdas have no scope boundaries, enabling global substitutions
- First-class duplications allow a term to be copied into two locations
- First-class superpositions allow 2 terms to be stored in 1 location
These primitives allow HVM to natively represent concepts that are not present
in the traditional λ-Calculus, including continuations, linear HOAS interpreters
and mutable references. Moreover, superpositions and duplications allow it to
perform optimal beta-reduction, allowing some expressions to be evaluated with
an exponential speedup. Finally, being fully affine makes its garbage collector
very efficient, and greatly simplifies parallelism.
The HVM3 is the successor to HVM1 and HVM2, combining their strengths. It aims
to be the main compile target of [Bend](https://github.com/HigherOrderCO/Bend).
It is a WIP under active development.
## Specifications
- [IC.md](./IC.md): Interaction Calculus, the theoretical foundation behind HVM
- [HVM.md](./HVM.md): the HVM language, which extends IC with pragmatic primitives
## Install
1. Install Cabal.
3. Clone this repository.
3. Run `cabal install`.
## Usage
```bash
hvm run file.hvml # runs interpreted (slow)
hvm run file.hvml -c # runs compiled (fast)
```
Note: the `-c` flag will also generate a standalone `.main.c` file, which if you
want, you can compile and run it independently. See examples in the [book/](book/) directory.
================================================
FILE: app/Main.hs
================================================
module Main where
import Network.Socket as Network
import System.IO (hSetEncoding, utf8, hPutStrLn, stderr)
import Control.Exception (try, fromException, SomeException, finally, AsyncException(UserInterrupt))
import Control.Monad (when, forM_, unless)
import Data.List (partition, isPrefixOf, find)
import HVM.API
import HVM.Collapse
import HVM.Extract
import HVM.Foreign
import HVM.Parse
import HVM.Reduce
import HVM.Type
import System.Environment (getArgs)
import System.Exit (exitWith, ExitCode(ExitSuccess, ExitFailure))
import System.IO
import Text.Printf
import Text.Read (readMaybe)
import qualified Data.Map.Strict as MS
-- Main
-- ----
main :: IO ()
main = do
args <- getArgs
result <- case args of
("run" : file : rest) -> do
let (flags, sArgs) = partition ("-" `isPrefixOf`) rest
let compiled = "-c" `elem` flags
let collapseFlag = Data.List.find (isPrefixOf "-C") flags >>= parseCollapseFlag
let stats = "-s" `elem` flags
let debug = "-d" `elem` flags
let hideQuotes = "-Q" `elem` flags
let mode = case collapseFlag of { Just n -> Collapse n ; Nothing -> Normalize }
cliRun file debug compiled mode stats hideQuotes sArgs
("serve" : file : rest) -> do
let (flags, _) = partition ("-" `isPrefixOf`) rest
let compiled = "-c" `elem` flags
let collapseFlag = Data.List.find (isPrefixOf "-C") flags >>= parseCollapseFlag
let stats = "-s" `elem` flags
let debug = "-d" `elem` flags
let hideQuotes = "-Q" `elem` flags
let mode = case collapseFlag of { Just n -> Collapse n ; Nothing -> Normalize }
cliServe file debug compiled mode stats hideQuotes
["help"] -> printHelp
_ -> printHelp
case result of
Left err -> do
putStrLn err
exitWith (ExitFailure 1)
Right _ -> do
exitWith ExitSuccess
parseCollapseFlag :: String -> Maybe (Maybe Int)
parseCollapseFlag ('-':'C':rest) =
case rest of
"" -> Just Nothing
n -> Just (readMaybe n)
parseCollapseFlag _ = Nothing
printHelp :: IO (Either String ())
printHelp = do
putStrLn "HVM usage:"
putStrLn " hvm3 help # Shows this help message"
putStrLn " hvm3 run <file> [flags] [args...] # Evals main"
putStrLn " hvm3 serve <file> [flags] # Starts socket server on port 8080"
putStrLn " -c # Runs with compiled mode (fast)"
putStrLn " -C # Collapse the result to a list of λ-Terms"
putStrLn " -CN # Same as above, but show only first N results"
putStrLn " -s # Show statistics"
putStrLn " -d # Print execution steps (debug mode)"
putStrLn " -Q # Hide quotes in output"
return $ Right ()
-- CLI Commands
-- ------------
cliRun :: FilePath -> Bool -> Bool -> RunMode -> Bool -> Bool -> [String] -> IO (Either String ())
cliRun filePath debug compiled mode showStats hideQuotes strArgs = do
code <- readFile' filePath
book <- doParseBook filePath code
hvmInit
initBook filePath book compiled
checkHasMain book
args <- doParseArguments book strArgs
checkMainArgs book args
(_, stats) <- withRunStats $ do
injectRoot book (Ref "main" maxBound args)
rxAt <- if compiled
then return (reduceCAt debug)
else return (reduceAt debug)
case mode of
Collapse limit -> do
core <- doCollapseFlatAt rxAt book 0
let vals = maybe id Prelude.take limit core
forM_ vals $ \val -> do -- Collapse and print the result line by line lazily
let out = if hideQuotes then removeQuotes (show val) else show val
printf "%s\n" out
Normalize -> do
core <- doExtractCoreAt rxAt book 0
let val = doLiftDups core
let out = if hideQuotes then removeQuotes (show val) else show val
printf "%s\n" out
hvmFree
when showStats $ do
print stats
return $ Right ()
cliServe :: FilePath -> Bool -> Bool -> RunMode -> Bool -> Bool -> IO (Either String ())
cliServe filePath debug compiled mode showStats hideQuotes = do
code <- readFile' filePath
book <- doParseBook filePath code
hvmInit
initBook filePath book compiled
checkHasMain book
putStrLn "HVM serve mode. Listening on port 8080."
sock <- socket AF_INET Stream 0
setSocketOption sock ReuseAddr 1
Network.bind sock (SockAddrInet 8080 0)
listen sock 5
putStrLn "Server started. Listening on port 8080."
serverLoop sock book `finally` do
close sock
hvmFree
putStrLn "\nServer terminated."
return $ Right ()
where
serverLoop sock book = do
result <- try $ do
(conn, _) <- accept sock
h <- socketToHandle conn ReadWriteMode
hSetBuffering h LineBuffering
hSetEncoding h utf8
input <- hGetLine h
unless (input == "exit" || input == "quit") $ do
oldSize <- getLen
args <- doParseArguments book [input]
checkMainArgs book args
let root = Ref "main" maxBound args
(vals, stats) <- runBook book root mode compiled debug
let out = unlines $ map (\t -> if hideQuotes then removeQuotes (show t) else show t) vals
hPutStrLn h out
when showStats $ do
hPutStrLn h (show stats)
setItr 0
setLen oldSize
hClose h
case result of
Left e -> case fromException e of
Just UserInterrupt -> return () -- Exit loop on Ctrl+C
_ -> do
hPutStrLn stderr $ "Connection error: " ++ show (e :: SomeException)
serverLoop sock book
Right _ -> serverLoop sock book
removeQuotes :: String -> String
removeQuotes s = case s of
'"':rest -> init rest -- Remove first and last quote if present
_ -> s -- Otherwise return as-is
checkHasMain :: Book -> IO ()
checkHasMain book = do
when (not $ MS.member "main" (namToFid book)) $ do
putStrLn "Error: 'main' not found."
exitWith (ExitFailure 1)
checkMainArgs :: Book -> [Core] -> IO ()
checkMainArgs book args = do
let ((_, mainArgs), _) = mget (fidToFun book) (mget (namToFid book) "main")
when (length args /= length mainArgs) $ do
putStrLn $ "Error: 'main' expects " ++ show (length mainArgs) ++ " arguments, found " ++ show (length args)
exitWith (ExitFailure 1)
================================================
FILE: bug.hvm
================================================
@main =
!c2_0 = λf !&0{f0 f1}=f λx(f0 (f1 x))
!c2_1 = λf !&1{f0 f1}=f λx(f0 (f1 x))
(c2_0 c2_1)
================================================
FILE: cabal.project
================================================
packages: .
package *
optimization: 2
source-repository-package
type: git
location: https://github.com/HigherOrderCO-archive/hs-highlight
================================================
FILE: examples/_test_.js
================================================
/**
* HVM Test Script
*
* This script tests the HVM implementation by running a series of .hvm files
* in both interpreted and compiled modes, as specified in the test table.
* For each test case:
* - If a 'main' line is provided, it replaces the '@main' line in the original file
* and saves it as '_test_.hvm'. Otherwise, it copies the original file to '_test_.hvm'.
* - Runs the test 4 times:
* - First run: Extracts the result (first line of output) and checks it against
* the expected 'norm'. Logs an error if they don't match.
* - Next 3 runs: Measures the execution time (from the 'TIME:' line in output).
* - Averages the times from the last 3 runs.
* - Compares the average time with the previous run's time stored in '_perf_.json'.
* If the new time is >5% slower and the total run time is >= 0.05 seconds, logs a warning.
* - Updates '_perf_.json' with the new average times after all tests.
*
* Key Notes:
* - Only runs modes ('intr' or 'comp') specified in the test table for each file.
* - Some tests lack a 'main' line, meaning no replacement is needed—just copy the file.
* - Uses Node.js 'fs' for file operations and 'child_process.execSync' to run commands.
* - Assumes the script runs in a directory containing the .hvm files.
* - Commands use a hardcoded project directory (/Users/v/vic/dev/HVM) for interpreted mode.
*/
const fs = require('fs');
const { execSync } = require('child_process');
// ### Test Specifications
// Array of test objects, each defining a file and its test cases for 'intr' (interpreted)
// and/or 'comp' (compiled) modes. Each mode object has an expected 'norm' and an optional 'main'.
const tests = [
{
file: 'bench_cnots.hvm',
intr: { main: '@main = (@P20 @not @true)', norm: 'λa λb a' },
comp: { main: '@main = (@P24 @not @true)', norm: 'λa λb a' }
},
{
file: 'bench_count.hvm',
intr: { main: '@main = @count(2_000_000 0)', norm: '4000000' },
comp: { main: '@main = @count(2_000_000_000 0)', norm: '4000000000' }
},
{
file: 'bench_sum_range.hvm',
intr: { main: '@main = @sum(@range(1_000_000 #Nil) 0)', norm: '1783293664' },
comp: { main: '@main = @sum(@range(300_000_000 #Nil) 0)', norm: '3992170112' }
},
{
file: 'enum_coc_smart.hvm',
intr: { norm: '"λλ(0 λλ((1 3) 2))"' },
comp: { norm: '"λλ(0 λλ((1 3) 2))"' }
},
{
file: 'enum_lam_naive_blc.hvm',
comp: { norm: '"λλ(1 λλ((2 0) 1))"' }
},
{
file: 'enum_lam_smart.hvm',
intr: { norm: '"λ(0 λλλ((0 1) 2))"' },
comp: { norm: '"λ(0 λλλ((0 1) 2))"' }
},
{
file: 'enum_nat.hvm',
intr: { main: '@main = @if(@eq(@mul(@X @nat(20)) @nat(12000)) @u32(@X) *)', norm: '600' },
comp: { main: '@main = @if(@eq(@mul(@X @nat(20)) @nat(20000)) @u32(@X) *)', norm: '1000' }
},
{
file: 'enum_primes.hvm',
intr: { main: '@main = @if(@eq(@mul(@X_B @Y_B) @P_B) λt(t @u32(@X_B) @u32(@Y_B)) *)', norm: 'λa ((a 853) 947)' },
comp: { main: '@main = @if(@eq(@mul(@X_C @Y_C) @P_C) λt(t @u32(@X_C) @u32(@Y_C)) *)', norm: 'λa ((a 25997) 27299)' }
},
{
file: 'feat_affine_ctx.hvm',
intr: { norm: '1' },
comp: { norm: '1' }
},
{
file: 'feat_cmul.hvm',
intr: { norm: 'λa λb (a (a (a (a b))))' },
comp: { norm: 'λa λb (a (a (a (a b))))' }
},
{
file: 'feat_hoas.hvm',
intr: { norm: '"λx λy (x (x (x (x y))))"' },
comp: { norm: '"λx λy (x (x (x (x y))))"' }
},
{
file: 'feat_mut_ref.hvm',
intr: { norm: '2' },
comp: { norm: '2' }
},
{
file: 'fuse_inc.hvm',
intr: { norm: '1234567' },
comp: { norm: '1234567' }
},
{
file: 'fuse_mul.hvm',
intr: { main: '@main = @mul(12345 12345)', norm: '152399025' },
comp: { main: '@main = @mul(23232 32323)', norm: '750927936' }
},
{
file: 'fuse_rot.hvm',
intr: { main: '@main = (@read(@S) @sqr(12345 (@add(@S) @KA) @KB))', norm: '209865' },
comp: { main: '@main = (@read(@S) @sqr(54321 (@add(@S) @KA) @KB))', norm: '923457' }
},
{
file: 'enum_1D_match.hvm',
intr: { main: '@main = @solve(16)', norm: '64' },
comp: { main: '@main = @solve(18)', norm: '64' }
},
];
// ### Load Previous Performance Data
// Load '_perf_.json' if it exists, otherwise initialize an empty object.
let perfData = {};
try {
perfData = JSON.parse(fs.readFileSync('_perf_.json', 'utf8'));
} catch (e) {
console.log('[INFO] _perf_.json not found, initializing as empty.');
}
// ### Counters for Errors and Warnings
// Track the number of errors (result mismatches) and warnings (perf regressions).
let errorCount = 0;
let warningCount = 0;
// ### Main Test Loop
for (const test of tests) {
const file = test.file;
// Check each mode: 'intr' (interpreted) and 'comp' (compiled).
for (const mode of ['intr', 'comp']) {
if (test[mode]) { // Only run if the mode is specified in the test.
console.log(`Running ${file} in ${mode} mode...`);
const { main, norm } = test[mode];
// Prepare the test file by adjusting '@main' or copying as needed.
prepareTestFile(file, main);
let times = [];
for (let i = 0; i < 4; i++) {
const output = runTest(mode);
const { result, time } = parseOutput(output);
console.log("- time:", time.toFixed(7), "| norm: " + result);
if (i === 0) {
// First run: Check the result against the expected norm.
if (result !== norm) {
console.log(`[ERROR] For ${file} in ${mode} mode, expected "${norm}", but got "${result}"`);
errorCount++;
}
} else {
// Next 3 runs: Collect execution times.
times.push(time);
}
}
// Calculate average time from the last 3 runs.
const averageTime = times.reduce((a, b) => a + b, 0) / times.length;
const key = `${file}_${mode}`; // Unique key for this test and mode.
const previousTime = perfData[key];
// Check for performance regression (>5% slower) if previous data exists and time >= 0.05s.
if (previousTime && averageTime > previousTime * 1.05 && averageTime >= 0.05) {
console.log(`[WARNING] Performance regression for ${file} in ${mode} mode: ` +
`previous ${previousTime.toFixed(6)}s, now ${averageTime.toFixed(6)}s`);
warningCount++;
}
// Update performance data with the new average time.
perfData[key] = averageTime;
}
}
}
// ### Save Updated Performance Data
// Write the new performance data to '_perf_.json' with readable formatting.
fs.writeFileSync('_perf_.json', JSON.stringify(perfData, null, 2), 'utf8');
// ### Summary
// Log the total number of errors and warnings.
console.log(`All tests completed with ${errorCount} errors and ${warningCount} warnings.`);
// ### Helper Functions
/**
* Prepares the test file by replacing the '@main' line or copying the original file.
* @param {string} originalFile - The original .hvm file path.
* @param {string|undefined} mainLine - The new '@main' line to use, if provided.
*/
function prepareTestFile(originalFile, mainLine) {
if (mainLine) {
// Read the original file and split into lines.
const lines = fs.readFileSync(originalFile, 'utf8').split('\n');
// Find the line starting with '@main'.
const index = lines.findIndex(line => line.startsWith('@main'));
if (index !== -1) {
lines[index] = mainLine; // Replace the '@main' line.
} else {
// If no '@main' line exists, append the new one and warn.
console.log(`[WARNING] No @main line found in ${originalFile}, adding at the end.`);
lines.push(mainLine);
}
// Save the modified content to '_test_.hvm'.
fs.writeFileSync('_test_.hvm', lines.join('\n'), 'utf8');
} else {
// If no mainLine is provided, copy the original file as is.
fs.copyFileSync(originalFile, '_test_.hvm');
}
}
/**
* Runs the HVM test in the specified mode and returns the output.
* @param {string} mode - 'intr' for interpreted, 'comp' for compiled.
* @returns {string} - The command output.
*/
function runTest(mode) {
let command;
if (mode === 'intr') {
command = 'cabal run -v0 hvm --project-dir=/Users/v/vic/dev/HVM -- run _test_.hvm -C -s';
} else if (mode === 'comp') {
command = 'hvm run _test_.hvm -c -C -s';
} else {
throw new Error(`Unknown mode: ${mode}`);
}
// Execute the command and capture the output as a UTF-8 string.
return execSync(command, { encoding: 'utf8' });
}
/**
* Parses the command output to extract the result and time.
* @param {string} output - The output from running the HVM command.
* @returns {{result: string, time: number}} - The result (first line) and time in seconds.
*/
function parseOutput(output) {
const lines = output.split('\n');
const result = lines[0].trim(); // First line is the result.
const timeLine = lines.find(line => line.startsWith('TIME:'));
if (!timeLine) {
throw new Error('TIME line not found in output');
}
const timeStr = timeLine.split(' ')[1]; // Extract time value after 'TIME:'.
const time = parseFloat(timeStr);
if (isNaN(time)) {
throw new Error(`Failed to parse time: ${timeStr}`);
}
return { result, time };
}
================================================
FILE: examples/bench_cnots.hvm
================================================
@main = (@P24 @not @true)
@true = λt λf t
@false = λt λf f
@not = λX (X @false @true)
@P04 = λf
! &0{f00x f00y} = f
! &0{f01x f01y} = λk01 (f00x (f00y k01))
! &0{f02x f02y} = λk02 (f01x (f01y k02))
! &0{f03x f03y} = λk03 (f02x (f02y k03))
λk04 (f03x (f03y k04))
@P08 = λf
! &0{f00x f00y} = f
! &0{f01x f01y} = λk01 (f00x (f00y k01))
! &0{f02x f02y} = λk02 (f01x (f01y k02))
! &0{f03x f03y} = λk03 (f02x (f02y k03))
! &0{f04x f04y} = λk04 (f03x (f03y k04))
! &0{f05x f05y} = λk05 (f04x (f04y k05))
! &0{f06x f06y} = λk06 (f05x (f05y k06))
! &0{f07x f07y} = λk07 (f06x (f06y k07))
λk08 (f07x (f07y k08))
@P16 = λf
! &0{f00x f00y} = f
! &0{f01x f01y} = λk01 (f00x (f00y k01))
! &0{f02x f02y} = λk02 (f01x (f01y k02))
! &0{f03x f03y} = λk03 (f02x (f02y k03))
! &0{f04x f04y} = λk04 (f03x (f03y k04))
! &0{f05x f05y} = λk05 (f04x (f04y k05))
! &0{f06x f06y} = λk06 (f05x (f05y k06))
! &0{f07x f07y} = λk07 (f06x (f06y k07))
! &0{f08x f08y} = λk08 (f07x (f07y k08))
! &0{f09x f09y} = λk09 (f08x (f08y k09))
! &0{f10x f10y} = λk10 (f09x (f09y k10))
! &0{f11x f11y} = λk11 (f10x (f10y k11))
! &0{f12x f12y} = λk12 (f11x (f11y k12))
! &0{f13x f13y} = λk13 (f12x (f12y k13))
! &0{f14x f14y} = λk14 (f13x (f13y k14))
! &0{f15x f15y} = λk15 (f14x (f14y k15))
λk16 (f15x (f15y k16))
@P20 = λf
! &0{f00x f00y} = f
! &0{f01x f01y} = λk01 (f00x (f00y k01))
! &0{f02x f02y} = λk02 (f01x (f01y k02))
! &0{f03x f03y} = λk03 (f02x (f02y k03))
! &0{f04x f04y} = λk04 (f03x (f03y k04))
! &0{f05x f05y} = λk05 (f04x (f04y k05))
! &0{f06x f06y} = λk06 (f05x (f05y k06))
! &0{f07x f07y} = λk07 (f06x (f06y k07))
! &0{f08x f08y} = λk08 (f07x (f07y k08))
! &0{f09x f09y} = λk09 (f08x (f08y k09))
! &0{f10x f10y} = λk10 (f09x (f09y k10))
! &0{f11x f11y} = λk11 (f10x (f10y k11))
! &0{f12x f12y} = λk12 (f11x (f11y k12))
! &0{f13x f13y} = λk13 (f12x (f12y k13))
! &0{f14x f14y} = λk14 (f13x (f13y k14))
! &0{f15x f15y} = λk15 (f14x (f14y k15))
! &0{f16x f16y} = λk16 (f15x (f15y k16))
! &0{f17x f17y} = λk17 (f16x (f16y k17))
! &0{f18x f18y} = λk18 (f17x (f17y k18))
! &0{f19x f19y} = λk19 (f18x (f18y k19))
λk20 (f19x (f19y k20))
@P24 = λf
! &0{f00x f00y} = f
! &0{f01x f01y} = λk01 (f00x (f00y k01))
! &0{f02x f02y} = λk02 (f01x (f01y k02))
! &0{f03x f03y} = λk03 (f02x (f02y k03))
! &0{f04x f04y} = λk04 (f03x (f03y k04))
! &0{f05x f05y} = λk05 (f04x (f04y k05))
! &0{f06x f06y} = λk06 (f05x (f05y k06))
! &0{f07x f07y} = λk07 (f06x (f06y k07))
! &0{f08x f08y} = λk08 (f07x (f07y k08))
! &0{f09x f09y} = λk09 (f08x (f08y k09))
! &0{f10x f10y} = λk10 (f09x (f09y k10))
! &0{f11x f11y} = λk11 (f10x (f10y k11))
! &0{f12x f12y} = λk12 (f11x (f11y k12))
! &0{f13x f13y} = λk13 (f12x (f12y k13))
! &0{f14x f14y} = λk14 (f13x (f13y k14))
! &0{f15x f15y} = λk15 (f14x (f14y k15))
! &0{f16x f16y} = λk16 (f15x (f15y k16))
! &0{f17x f17y} = λk17 (f16x (f16y k17))
! &0{f18x f18y} = λk18 (f17x (f17y k18))
! &0{f19x f19y} = λk19 (f18x (f18y k19))
! &0{f20x f20y} = λk20 (f19x (f19y k20))
! &0{f21x f21y} = λk21 (f20x (f20y k21))
! &0{f22x f22y} = λk22 (f21x (f21y k22))
! &0{f23x f23y} = λk23 (f22x (f22y k23))
λk24 (f23x (f23y k24))
================================================
FILE: examples/bench_count.hs
================================================
import Data.Word
count :: Word32 -> Word32 -> Word32
count 0 k = k
count p k = count (p - 1) (k + 1)
main :: IO ()
main = print $ count 2_000_000_000 0
================================================
FILE: examples/bench_count.hvm
================================================
@count(!n k) = ~n !k {
0: k
1+p: @count(p,(+ k 2))
}
@main = @count(2_000_000_000 0)
//WORK: 12000000004 interactions
//TIME: 1.1376750 seconds
//SIZE: 3 nodes
//PERF: 10547.828 MIPS
================================================
FILE: examples/bench_sum_range.hs
================================================
import Data.Word
data List = Nil | Cons !Word32 List
range :: Word32 -> List -> List
range 0 xs = xs
range n xs = range (n - 1) (Cons (n - 1) xs)
sum' :: List -> Word32 -> Word32
sum' Nil r = r
sum' (Cons head tail) r = sum' tail (head + r)
main :: IO ()
main = do
let !a = range 50_000_000 Nil
print $ sum' a 0
================================================
FILE: examples/bench_sum_range.hvm
================================================
data List { #Nil #Cons{ head tail } }
@sum(!xs r) = ~xs !r {
#Nil: r
#Cons{head tail}: @sum(tail (+ head r))
}
@range(n xs) = ~n !xs {
0: xs
1+p: !&0{p0 p1}=p @range(p0 #Cons{p1 xs})
}
@main = @sum(@range(50_000_000 #Nil) 0)
//WORK: 600000007 interactions
//TIME: 0.1968570 seconds
//SIZE: 100000005 nodes
//PERF: 3047.898 MIPS
================================================
FILE: examples/bench_sum_range.py
================================================
class Nil:
def __init__(self):
self.tag = "Nil"
class Cons:
def __init__(self, head, tail):
self.tag = "Cons"
self.head = head
self.tail = tail
def range_custom(n, xs):
result = xs
for i in range(n, 0, -1):
result = Cons(i - 1, result)
return result
def sum_custom(lst):
total = 0
while lst.tag != "Nil":
total = (total + lst.head) & 0xFFFFFFFF
lst = lst.tail
return total
def main():
print(sum_custom(range_custom(50000000, Nil())))
if __name__ == "__main__":
main()
================================================
FILE: examples/enum_1D_match.hvm
================================================
// This is similar to `enum_invert_add`, except the goal is harder:
// > Can we find a displacement (rotations) that will make two arrays equal?
// This file includes interesting insights, such as:
// - How to represent a space that can be rotated with binary trees
// - How to compress such space by compacting identical values
// - How to fuse the tree rotation (rotr/rotl) operations
// - How to recursively perform a bit-reversal permutation of a tree
// - How to implement equality efficiently assuming normalized trees
// Read: https://discord.com/channels/912426566838013994/915345481675186197/1351306002699390976
data Bool { #T #F }
data Pair { #P{x y} }
data Bin { #O{p} #I{p} #E }
data Nat { #S{p} #Z }
data Map { #BR{x y} #M0 #M1 }
// Prelude
// -------
// If/Exit
@when(!c t) = ~ c {
0: *
1+p: t
}
// And
!@and(!a b) = ~ a {
0: 0
1+p: b
}
// Repeated Application
@rep(n f x) = ~ n !f !x {
0: x
1+p: !&0{f0 f1}=f (f0 @rep(p f1 x))
}
// Squared Application
@sqr(n f x) = ~ n !f !x {
0: x
1+p: !&0{p0 p1}=(+ p 1)
!&0{fA f0}=f
!&0{f1 f2}=fA
@sqr((/ p0 2) λk(f0 (f1 k)) @rep((% p1 2) f2 x))
}
// Church Nat (with fusion)
@nat(n) = λs λz @sqr(n s z)
// Fixed Point
@fix(f) = !&{f f0}=f !&{f f1}=f (f0 @fix(f1))
// λ-Encoded Booleans
// ------------------
// Booleans
@tru = λt λf t
@fal = λt λf f
@idf = λb λt λf (b t f)
@not = λb λt λf (b f t)
// Below, '@foo' represents two possible functions:
// - @foo(N x) = match N !x { #Z:x #S{n}:@foo(n (id x)) }
// - @foo(N x) = match N !x { #Z:x #S{n}:@foo(n (not x)) }
// The question is: if we apply @foo to a large N, how long will it take to
// compute? In particular, will it fuse `not` and `id` correctly, even though
// they're behind a superposition?
@foo = λN
! step = λfoo_N λx
// Universe 1-L: apply 'id' to 'x'
// Universe 1-R: apply 'not' to 'x'
! &1{F0 F1} = foo_N
! &1{x0 x1} = x
&1{
(F0 (@idf x0))
(F1 (@not x1))
}
! base = λx x
(N step base)
//@main = (@foo @nat(100001) @tru)
// λ-Encoded Nats
// --------------
// Constructors
@S(n) = λs λz (s n)
@Z = λs λz z
// Nat
@nat_all = &1{@Z @S(@nat_all)}
// Nat → Nat
@nat_view(n) =
! case_s = λp #S{@nat_view(p)}
! case_z = #Z
(n case_s case_z)
// U32 → Nat
@nat(n) = ~ n {
0: @Z
1+n: @S(@nat(n))
}
// λ-Encoded Bitstrings
// --------------------
// Constructors
@E = λo λi λe e
@O(xs) = λo λi λe (o xs)
@I(xs) = λo λi λe (i xs)
// Bin
@bin_zero(n) = ~ n {
0: @E
1+n: @O(@bin_zero(n))
}
// U32 → U32 → Bin
@bin(l n) =
@sqr(n λx@bin_inc(x) @bin_zero(l))
// Bin → U32
@bin_to_u32(x) =
! case_o = λp (+ (* @bin_to_u32(p) 2) 0)
! case_i = λp (+ (* @bin_to_u32(p) 2) 1)
! case_e = 0
(x case_o case_i case_e)
// Bin → Bin
@bin_id(x) = λo λi λe
(x o i e)
// Bin → Bin
@bin_inc(x) = λo λi λe
! case_o = λp (i p)
! case_i = λp (o @bin_inc(p))
! case_e = e
(x case_o case_i case_e)
// Bin → Bin → Bin
@bin_add(a b) =
!case_o = λaP λb λo λi λe
!case_o = λbP λaP (o @bin_add(aP bP))
!case_i = λbP λaP (i @bin_add(aP bP))
!case_e = λaP e
(b case_o case_i case_e aP)
!case_i = λaP λb λo λi λe
!case_o = λbP λaP (i @bin_add(aP bP))
!case_i = λbP λaP (o @bin_inc(@bin_add(aP bP)))
!case_e = λaP e
(b case_o case_i case_e aP)
!case_e = λb b
(a case_o case_i case_e b)
// Bin → Bin → Bin
@bin_add_2(a b) =
@bin_sqr(a λx(@bin_inc(x)) b)
// Bin → Bin -> Bool
@bin_eql(a b) =
!case_o = λaP λb
!case_o = λbP λaP @bin_eql(aP bP)
!case_i = λbP λaP 0
!case_e = λaP 0
(b case_o case_i case_e aP)
!case_i = λaP λb
!case_o = λbP λaP 0
!case_i = λbP λaP @bin_eql(aP bP)
!case_e = λaP 0
(b case_o case_i case_e aP)
!case_e = λb
!case_o = λbP 0
!case_i = λbP 0
!case_e = 1
(b case_o case_i case_e)
(a case_o case_i case_e b)
// Bin → Bin
@bin_view(x) =
! case_o = λp #O{@bin_view(p)}
! case_i = λp #I{@bin_view(p)}
! case_e = #E
(x case_o case_i case_e)
// U32 → Bin
@bin_all(n) = ~ n {
0: λo λi λe e
1+n:
! &1{n0 n1} = n
&1{
λo λi λe (o @bin_all(n0))
λo λi λe (i @bin_all(n1))
}
}
// Bin → U32
@bin_len(xs) =
! case_o = λxs (+ 1 @bin_len(xs))
! case_i = λxs (+ 1 @bin_len(xs))
! case_e = 0
(xs case_o case_i case_e)
// Squared Application (with a bitstring)
@bin_sqr(xs f x) =
! case_o = λxs λf λx !&{f0 f1}=f @bin_sqr(xs λk(f0 (f1 k)) x)
! case_i = λxs λf λx !&{F f01}=f !&{f0 f1}=f01 @bin_sqr(xs λk(f0 (f1 k)) (F x))
! case_e = λf λx x
(xs case_o case_i case_e f x)
////Test:
//@L = 64
//@A = @bin(@L 10000000)
//@X = @bin_all(@L)
//@B = @bin(@L 99999999)
//@main =
//! solved = @bin_eql(@bin_add_2(@A @X) @B) // A + X = B
//@when(solved @bin_to_u32(@X)) // Prints X
// λ-Encoded Bit Maps
// ------------------
// Constructors
@M0 = λbr λm0 λm1 m0
@M1 = λbr λm0 λm1 m1
@Br(a b) = λbr λm0 λm1 (br a b)
@BR(a b) =
! case_br_a = λax λay λb @Br(@Br(ax ay) b)
! case_m0_a = λb
! case_br_b = λbx λby @Br(@M0 @Br(bx by))
! case_m0_b = @M0
! case_m1_b = @Br(@M0 @M1)
(b case_br_b case_m0_b case_m1_b)
! case_m1_a = λb
! case_br_b = λbx λby @Br(@M1 @Br(bx by))
! case_m0_b = @Br(@M1 @M0)
! case_m1_b = @M1
(b case_br_b case_m0_b case_m1_b)
(a case_br_a case_m0_a case_m1_a b)
// map_view : U32 → Map → Map
@map_view(map) =
! case_br = λx λy #BR{@map_view(x) @map_view(y)}
! case_m0 = #M0
! case_m1 = #M1
(map case_br case_m0 case_m1)
// map_set : Bin → Map → Map
@map_set(bs map) =
! case_o = λbsP λmap
! case_br = λx λy λbsP @BR((@map_set(bsP x)) y)
! case_m0 = λbsP @BR((@map_set(bsP @M0)) @M0)
! case_m1 = λbsP @BR((@map_set(bsP @M1)) @M1)
(map case_br case_m0 case_m1 bsP)
! case_i = λbsP λmap
! case_br = λx λy λbsP @BR(x (@map_set(bsP y)))
! case_m0 = λbsP @BR(@M0 (@map_set(bsP @M0)))
! case_m1 = λbsP @BR(@M1 (@map_set(bsP @M1)))
(map case_br case_m0 case_m1 bsP)
! case_e = λmap @M1
(bs case_o case_i case_e map)
// map_get : Bin → Map → U32
@map_get(bs map) =
! case_o = λbsP λmap
! case_br = λx λy @map_get(bsP x)
! case_m0 = 0
! case_m1 = 1
(map case_br case_m0 case_m1)
! case_i = λbsP λmap
! case_br = λx λy @map_get(bsP y)
! case_m0 = 0
! case_m1 = 1
(map case_br case_m0 case_m1)
! case_e = λmap
! case_br = λx λy 0
! case_m0 = 0
! case_m1 = 1
(map case_br case_m0 case_m1)
(bs case_o case_i case_e map)
// map_eql : Map → Map → Bool
@map_eql(a b) =
! case_br_a = λax λay λb
! case_br_b = λbx λby @and(@map_eql(ax bx) @map_eql(ay by))
! case_m0_b = 0
! case_m1_b = 0
(b case_br_b case_m0_b case_m1_b)
! case_m0_a = λb
! case_br_b = λbx λby 0
! case_m0_b = 1
! case_m1_b = 0
(b case_br_b case_m0_b case_m1_b)
! case_m1_a = λb
! case_br_b = λbx λby 0
! case_m0_b = 0
! case_m1_b = 1
(b case_br_b case_m0_b case_m1_b)
(a case_br_a case_m0_a case_m1_a b)
// map_zero : Map
@map_zero = @M0
// map_alloc : U32 → Map
@map_alloc(d) = ~ d {
0: @M0
1+d: !&{d0 d1}=d @BR(@map_alloc(d0) @map_alloc(d1))
}
// map_swp : Map → Map
@map_swp(map) =
! case_br = λa λb
! case_br_a = λax λay λb
! case_br_b = λbx λby λax λay @BR(@BR(ax bx) @BR(ay by))
! case_m0_b = λax λay 0 // TODO
! case_m1_b = λax λay 0 // TODO
(@map_swp(b) case_br_b case_m0_b case_m1_b ax ay)
! case_m0_a = λb
! case_br_b = λbx λby 0 // TODO
! case_m0_b = @BR(@M0 @M0)
! case_m1_b = @BR(@M0 @M1)
(@map_swp(b) case_br_b case_m0_b case_m1_b)
! case_m1_a = λb
! case_br_b = λbx λby 0 // TODO
! case_m0_b = @BR(@M1 @M0)
! case_m1_b = @BR(@M1 @M1)
(@map_swp(b) case_br_b case_m0_b case_m1_b)
(@map_swp(a) case_br_a case_m0_a case_m1_a b)
! case_m0 = @M0
! case_m1 = @M1
(map case_br case_m0 case_m1)
// map_inv : Map → Map
@map_inv(map) = λbr λm0 λm1
! case_br = λx λy (br @map_inv(x) @map_inv(y))
! case_m0 = m0
! case_m1 = m1
(@map_swp(map) case_br case_m0 case_m1)
// map_rotr : Map → Map
@map_rotr(map) = λbr λm0 λm1
! case_br = λx λy (br @map_rotr(y) x)
! case_m0 = m0
! case_m1 = m1
(map case_br case_m0 case_m1)
// map_rotl : Map → Map
@map_rotl(map) = λbr λm0 λm1
! case_br = λx λy (br y @map_rotl(x))
! case_m0 = m0
! case_m1 = m1
(map case_br case_m0 case_m1)
// map_spinr : Bin → Map → Map
@map_spinr(xs map) =
@bin_sqr(xs λx(@map_rotr(x)) map)
@solve(!&L) =
! A = @map_set(@bin(L 0x00) @map_set(@bin(L 0x80) @map_zero))
! B = @map_set(@bin(L 0x40) @map_set(@bin(L 0xC0) @map_zero))
! E = @map_eql(@map_spinr(@bin_all(L) A) B)
@when(E @bin_to_u32(@bin_all(L)))
@main = @solve(20)
================================================
FILE: examples/enum_bin.hvm
================================================
// Bitstrings
data Bin { #O{pred} #I{pred} #E }
// Pairs
data Pair { #Pair{fst snd} }
// If-Then-Else
@if(b t f) = ~b {
0: f
_: t
}
// Not
@not(a) = ~a {
0: 1
_: 0
}
// And
@and(a b) = ~a {
0: 0
_: b
}
// Or
@or(a b) = ~a {
0: b
_: 1
}
// Converts a Bin to an U32
@u32(b) = ~b{
#O{p}: (+ (* 2 @u32(p)) 0)
#I{p}: (+ (* 2 @u32(p)) 1)
#E: 0
}
// Converts an U32 to a Bin of given size
@bin(s n) = ~s{
0: #E
1+p: !&0{n0 n1}=n ~(% n0 2) !p !n1 {
0: #O{@bin(p (/ n1 2))}
_: #I{@bin(p (/ n1 2))}
}
}
// Bin Equality
@eq(a b) = ~a !b {
#E: ~b {
#O{bp}: 0
#I{bp}: 0
#E: 1
}
#O{ap}: ~b{
#O{bp}: @eq(ap bp)
#I{bp}: 0
#E: 0
}
#I{ap}: ~b{
#O{bp}: 0
#I{bp}: @eq(ap bp)
#E: 0
}
}
// Increments a Bin
@inc(a) = ~a{
#O{p}: #I{p}
#I{p}: #O{@inc(p)}
#E: #E
}
// Decrements a Bin
@dec(a) = ~a{
#O{p}: #O{@dec(p)}
#I{p}: #I{p}
#E: #E
}
// Adds two Bins
@add(a b) = ~a !b {
#O{ap}: ~b !ap {
#O{bp}: #O{@add(ap bp)}
#I{bp}: #I{@add(ap bp)}
#E: #O{ap}
}
#I{ap}: ~b !ap {
#O{bp}: #I{@add(ap bp)}
#I{bp}: #O{@inc(@add(ap bp))}
#E: #I{ap}
}
#E: #E
}
// Muls two Bins
@mul(a b) = ~b !a {
#E: #E
#O{bp}: #O{@mul(a bp)}
#I{bp}: !&0{a0 a1}=a @add(a0 #O{@mul(a1 bp)})
}
// Concatenates two Bins
@cat(a b) = ~a !b {
#O{ap}: #O{@cat(ap b)}
#I{ap}: #I{@cat(ap b)}
#E: b
}
// Lt two Bins (a < b)
@lt(a b) = @lt_go(0 a b)
@lt_go(&k a b) = ~a !b {
#E: ~b {
#E: &k
#O{bp}: 1
#I{bp}: 1
}
#O: λap ~b !ap {
#E: 0
#O{bp}: @lt_go(&k ap bp)
#I{bp}: @lt_go(1 ap bp)
}
#I: λap ~b !ap {
#E: 0
#O{bp}: @lt_go(0 ap bp)
#I{bp}: @lt_go(&k ap bp)
}
}
// Take the first N bits of a Bin
@take(n b) = ~n {
0: #E
1+p: ~b !p {
#O{bp}: #O{@take(p bp)}
#I{bp}: #I{@take(p bp)}
#E: #E
}
}
// Enums all Bins of given size (label 1)
@all1(s) = ~s{
0: #E
1+p: !&1{p0 p1}=p &1{
#O{@all1(p0)}
#I{@all1(p1)}
}
}
// Enums all Bins of given size (label 2)
@all2(s) = ~s{
0: #E
1+p: !&2{p0 p1}=p &2{
#O{@all2(p0)}
#I{@all2(p1)}
}
}
//// 4:
//@K = 1
//@H = 2
//@S = 4
//@X = @cat(@all1(@H) @bin(@H 0))
//@Y = @cat(@all2(@H) @bin(@H 0))
//@A = @cat(@bin(@K 3) @bin(@H 0))
//@B = @cat(@bin(@H 3) @bin(@H 0))
//@P = @bin(@S 9)
//// 6:
//@K = 2
//@H = 3
//@S = 6
//@X = @cat(@all1(@H) @bin(@H 0))
//@Y = @cat(@all2(@H) @bin(@H 0))
//@A = @cat(@bin(@K 5) @bin(@H 0))
//@B = @cat(@bin(@H 5) @bin(@H 0))
//@P = @bin(@S 25)
//// 8:
//@K = 3
//@H = 4
//@S = 8
//@X = @cat(@all1(@H) @bin(@H 0))
//@Y = @cat(@all2(@H) @bin(@H 0))
//@A = @cat(@bin(@K 13) @bin(@H 0))
//@B = @cat(@bin(@H 13) @bin(@H 0))
//@P = @bin(@S 169)
//// 10:
//@K = 4
//@H = 5
//@S = 10
//@X = @cat(@all1(@H) @bin(@H 0))
//@Y = @cat(@all2(@H) @bin(@H 0))
//@A = @cat(@bin(@K 31) @bin(@H 0))
//@B = @cat(@bin(@H 19) @bin(@H 0))
//@P = @bin(@S 589)
//// 12:
//@K = 5
//@H = 6
//@S = 12
//@X = @cat(@all1(@H) @bin(@H 0))
//@Y = @cat(@all2(@H) @bin(@H 0))
//@A = @cat(@bin(@K 53) @bin(@H 0))
//@B = @cat(@bin(@H 37) @bin(@H 0))
//@P = @bin(@S 1961)
//// 14:
//@K = 6
//@H = 7
//@S = 14
//@X = @cat(@all1(@H) @bin(@H 0))
//@Y = @cat(@all2(@H) @bin(@H 0))
//@A = @cat(@bin(@K 109) @bin(@H 0))
//@B = @cat(@bin(@H 97) @bin(@H 0))
//@P = @bin(@S 10573)
//// 16:
//@K = 7
//@H = 8
//@S = 16
//@X = @cat(@all1(@H) @bin(@H 0))
//@Y = @cat(@all2(@H) @bin(@H 0))
//@A = @cat(@bin(@K 173) @bin(@H 0))
//@B = @cat(@bin(@H 233) @bin(@H 0))
//@P = @bin(@S 40309)
//// 18:
//@K = 8
//@H = 9
//@S = 18
//@X = @cat(@all1(@H) @bin(@H 0))
//@Y = @cat(@all2(@H) @bin(@H 0))
//@A = @cat(@bin(@K 449) @bin(@H 0))
//@B = @cat(@bin(@H 389) @bin(@H 0))
//@P = @bin(@S 174661)
//// 20:
//@K = 9
//@H = 10
//@S = 20
//@X = @cat(@all1(@H) @bin(@H 0))
//@Y = @cat(@all2(@H) @bin(@H 0))
//@A = @cat(@bin(@K 769) @bin(@H 0))
//@B = @cat(@bin(@H 569) @bin(@H 0))
//@P = @bin(@S 437561)
//// 22:
//@K = 10
//@H = 11
//@S = 22
//@X = @cat(@all1(@H) @bin(@H 0))
//@Y = @cat(@all2(@H) @bin(@H 0))
//@A = @cat(@bin(@K 1423) @bin(@H 0))
//@B = @cat(@bin(@H 1229) @bin(@H 0))
//@P = @bin(@S 1748867)
//// 24:
//@K = 11
//@H = 12
//@S = 24
//@X = @cat(@all1(@H) @bin(@H 0))
//@Y = @cat(@all2(@H) @bin(@H 0))
//@A = @cat(@bin(@K 2437) @bin(@H 0))
//@B = @cat(@bin(@H 2333) @bin(@H 0))
//@P = @bin(@S 5685521)
//// 26:
//@K = 12
//@H = 13
//@S = 26
//@X = @cat(@all1(@H) @bin(@H 0))
//@Y = @cat(@all2(@H) @bin(@H 0))
//@A = @cat(@bin(@K 4987) @bin(@H 0))
//@B = @cat(@bin(@H 6203) @bin(@H 0))
//@P = @bin(@S 30934361)
//// 28:
//@K = 13
//@H = 14
//@S = 28
//@X = @cat(@all1(@H) @bin(@H 0))
//@Y = @cat(@all2(@H) @bin(@H 0))
//@A = @cat(@bin(@K 13513) @bin(@H 0))
//@B = @cat(@bin(@H 13721) @bin(@H 0))
//@P = @bin(@S 185411873)
//// 30:
//@K = 14
//@H = 15
//@S = 30
//@X = @cat(@all1(@H) @bin(@H 0))
//@Y = @cat(@all2(@H) @bin(@H 0))
//@A = @cat(@bin(@K 24923) @bin(@H 0))
//@B = @cat(@bin(@H 19489) @bin(@H 0))
//@P = @bin(@S 485724347)
//// 32:
//@K = 15
//@H = 16
//@S = 32
//@X = @cat(@all1(@H) @bin(@H 0))
//@Y = @cat(@all2(@H) @bin(@H 0))
//@A = @cat(@bin(@K 47791) @bin(@H 0))
//@B = @cat(@bin(@H 54881) @bin(@H 0))
//@P = @bin(@S 2622817871)
@main =
! cond = @eq(@mul(@X @Y) @P)
! not1 = @not(@eq(@X @bin(@S 1)))
@if(@and(cond not1) λt(t @u32(@X) @u32(@Y)) *)
================================================
FILE: examples/enum_coc_smart.hvm
================================================
// Superposes dependently typed λ-terms. With it, solving:
// (?X λt(t A B)) == λt(t B A)
// Where
// ?X : ∀A. (∀P. A -> A -> P) -> (∀P. A -> A -> P)
// Is down to 3k interactions. Of course, that's not too surprising given there
// are only two functions of that type, but the real win is that now we only
// need to make a choice when selecting an element from context. Intros and
// elims follow directly from types, no need for choices / superpositions.
data List {
#Nil
#Cons{head tail}
}
data Bits {
#O{pred}
#I{pred}
#E
}
data Term {
#Var{idx}
#Pol{bod}
#All{inp bod}
#Lam{bod}
#App{fun arg}
#U32
#Num{val}
}
data Pair {
#Pair{fst snd}
}
data Maybe {
#None
#Some{value}
}
// Prelude
// -------
@if(c t f) = ~ c {
0: f
_: t
}
@when(c t) = ~ c {
0: *
_: t
}
@tail(xs) = ~ xs {
#Nil: *
#Cons{h t}: t
}
@and(a b) = ~ a !b {
0: 0
_: b
}
@unwrap(mb) = ~mb {
#None: *
#Some{x}: x
}
@seq(str) = ~ str {
#Nil: #Nil
#Cons{h t}:
!! h = h
!! t = @seq(t)
#Cons{h t}
}
@tm0(x) = !&0{a b}=x a
@tm1(x) = !&0{a b}=x b
// Stringification
// ---------------
@show_nat(nat) = ~nat {
0: λk #Cons{'Z' k}
1+p: λk #Cons{'S' (@show_nat(p) k)}
}
@show_dec(&n r) =
! chr = (+ (% n 10) '0')
~ (< n 10) !chr !r {
0: @show_dec((/ n 10) #Cons{chr r})
_: #Cons{chr r}
}
@do_show_dec(n) = @show_dec(n #Nil)
@show_bits(bits) = ~bits {
#O{pred}: λk #Cons{'#' #Cons{'O' #Cons{'{' (@show_bits(pred) #Cons{'}' k})}}}
#I{pred}: λk #Cons{'#' #Cons{'I' #Cons{'{' (@show_bits(pred) #Cons{'}' k})}}}
#E: λk #Cons{'#' #Cons{'E' k}}
}
@do_show_bits(bits) = (@show_bits(bits) #Nil)
@show_term(term dep) = ~term !&dep {
#Var{idx}: λk
@show_dec(idx k)
#Pol{bod}: λk
#Cons{'∀' (@show_term((bod #Var{dep}) (+ dep 1)) k)}
#All{inp bod}: λk
#Cons{'Π'
#Cons{'('
(@show_term(inp dep)
#Cons{')'
(@show_term((bod #Var{dep}) (+ dep 1))
k)})}}
#Lam{bod}: λk
#Cons{'λ' (@show_term((bod #Var{dep}) (+ dep 1)) k)}
#App{fun arg}: λk
#Cons{'(' (@show_term(fun dep)
#Cons{' ' (@show_term(arg dep)
#Cons{')' k})})}
#U32: λk
#Cons{'U' k}
#Num{val}: λk
#Cons{'#' @show_dec(val k)}
}
@do_show_term(term) = (@show_term(term 0) #Nil)
// Equality
// --------
@eq(a b d) = ~ @wnf(a) !b !d {
#Var{aI}: ~ @wnf(b) !d {
#Var{bI}: (== aI bI)
else: 0
}
#Pol{aB}: ~ @wnf(b) !&d {
#Pol{bB}:
@eq((aB #Var{d}) (bB #Var{d}) (+ d 1))
else: 0
}
#All{aI aB}: ~ @wnf(b) !&d {
#All{bI bB}:
@and(@eq(aI bI d) @eq((aB #Var{d}) (bB #Var{d}) (+ d 1)))
else: 0
}
#Lam{aB}: ~ @wnf(b) !&d {
#Lam{bB}:
@eq((aB #Var{d}) (bB #Var{d}) (+ d 1))
else: 0
}
#App{aF aX}: ~ @wnf(b) !&d {
#App{bF bX}:
@and(@eq(aF bF d) @eq(aX bX d))
else: 0
}
#U32: ~ @wnf(b) !d {
#U32: 1
else: 0
}
#Num{aV}: ~ @wnf(b) !d {
#Num{bV}: (== aV bV)
else: 0
}
}
// Evaluation
// ----------
@wnf(term) = ~ term {
#Var{idx}: #Var{idx}
#Pol{bod}: #Pol{bod}
#All{inp bod}: #All{inp bod}
#Lam{bod}: #Lam{bod}
#App{fun arg}: @wnf_app(@wnf(fun) arg)
#U32: #U32
#Num{val}: #Num{val}
}
@wnf_app(f x) = ~ f !x {
#Var{idx}: #App{#Var{idx} x}
#Pol{bod}: #App{#Pol{bod} x}
#All{inp bod}: #App{#All{inp bod} x}
#Lam{bod}: @wnf((bod @wnf(x)))
#App{fun arg}: #App{#App{fun arg} x}
#U32: #U32
#Num{val}: #App{#Num{val} x}
}
// Enumeration
// -----------
@all(&L typ &dep ctx) =
@intr(L typ dep ctx)
@intr(!&L typ !&dep ctx) =
~ typ !ctx {
#All{t_inp t_bod}:
!&0{ctx bod} = @all(L (t_bod #Var{dep}) (+ dep 1) #Cons{#Some{&0{$x t_inp}} ctx})
&0{@tail(ctx) #Lam{λ$x(bod)}}
#Pol{t_bod}:
@intr(L (t_bod #Var{dep}) (+ dep 1) ctx)
#U32:
@pick(L #U32 dep ctx λk(k))
#Var{idx}:
@pick(L #Var{idx} dep ctx λk(k))
#App{fun arg}:
@pick(L #App{fun arg} dep ctx λk(k))
#Lam{bod}: *
#Num{val}: *
}
@pick(!&L typ !&dep ctx rem) =
~ctx {
#Nil: *
#Cons{ann ctx}:
!&L{typL typR} = typ
!&L{remL remR} = rem
!&L{annL annR} = ann
!&L{ctxL ctxR} = ctx
&L{
@elim(L typL dep (remL ctxL) annL)
@pick(L typR dep ctxR λk(remR #Cons{annR k}))
}
}
@elim(!&L typ !&dep ctx ann) = ~ann {
#None: *
#Some{ann}:
! &0{v t} = ann
~ t !typ !ctx !v {
#Pol{t_bod}:
! &{typ0 typ1} = typ
@elim(L typ0 dep ctx #Some{&0{v (t_bod typ1)}})
#All{t_inp t_bod}:
! &0{ctx arg} = @all((+(* L 2)1) t_inp dep ctx)
! &{arg0 arg1} = arg
@elim((+(* L 2)0) typ dep ctx #Some{&0{#App{v arg0} (t_bod arg1)}})
#U32:
@when(@eq(typ #U32 dep) &0{ctx v})
#Var{idx}:
@when(@eq(typ #Var{idx} dep) &0{ctx v})
#App{fun arg}:
@when(@eq(typ #App{fun arg} dep) &0{ctx v})
#Lam{bod}: *
#Num{val}: *
}
}
// T0 = Π(x:U32) Π(y:U32) Π(z:U32) U32
@T0 =
#All{#U32 λx
#All{#U32 λy
#All{#U32 λz
#U32}}}
// CBool = ∀P Π(x:P) Π(y:P) P
@CBool =
#Pol{λ&p
#All{p λx
#All{p λy
p}}}
// Tup(A B) = ∀P Π(p: Π(x:A) Π(y:B) P) P
@Tup(A B) =
#Pol{λ&p
#All{
#All{A λx
#All{B λy
p}} λ_
p}}
// TupF = ∀A Π(x: (Tup A A)) (Tup A A)
@TupF =
#Pol{λ&A
#Pol{λ&B
#All{@Tup(A A) λx
@Tup(A A)}}}
// Tests
// -----
//A= λt(t 1 2)
@A = #Lam{λt #App{#App{t #Num{1}} #Num{2}}}
//B= λt(t 2 1)
@B = #Lam{λt #App{#App{t #Num{2}} #Num{1}}}
//R= λx(x λaλbλt(t b a))
@R = #Lam{λx #App{x #Lam{λa #Lam{λb #Lam{λt #App{#App{t b} a}}}}}}
// X : ∀A. (Tup A A) -> (Tup A A) = <all terms>
@T = @TupF
@X = @tm1(@all(1 @T 0 #Nil))
// Solves for `?X` in `(?X λt(t A B)) == λt(t B A)`.
// It finds `?X = λλ(0 λλ((1 3) 2))` in 3k interactions.
@main = @when(@eq(#App{@X @A} @B 0) @do_show_term(@X))
//@main = @X
================================================
FILE: examples/enum_invert_add.hvm
================================================
// This file shows how we can use superpositionn to apply multiple functions to
// the same input, in a way that "shares computations" across different calls.
// In this example, we apply `add(0)`, `add(1)`, ..., `add(2^64-1)` - i.e., 2^64
// different functions, to the same input, 10,000,000. Then, we check
// `addN(10,000,000) = 99,999,999`, and eliminate all universes that don't
// satisfy this equation. Since `inc` fuses, and since `addN` is a superposition
// of every function, there is a *massive* amount of sharing between different
// universes (i.e., the universe where we check `add1(10,000,00) = 99,999,999`,
// the universe where we check `add2(10,000,00) = 99,999,999`, and so on). Thus,
// after trying all possible universes, we eventually find out that the only
// universe that is *not* destroyed is `add89999999(10,000,00) = 99,999,999`.
// We then use this information to output `89,999,999`, which is the solution to
// the `10,000,000 + X = 99,999,999` equation. And the magic is: this happens in
// just 196411 interactions (0.001 seconds). In any other language, this would
// take *at least* enough time to call `add` 2^64 times, which is probably
// weeks. In other words, we effectivelly implemented 'sub' efficiently, by
// using superpositions to enumerate the domain of 'add(N,x)', inverting it. Of
// course, 'add' is a very simple function. Can this technique be used to invert
// more complex functions efficiently? See 'enum_1D_match.hvml' for an attempt.
data Bool { #T #F }
data Pair { #P{x y} }
data Bin { #O{p} #I{p} #E }
data Nat { #S{p} #Z }
data Map { #BR{x y} #M0 #M1 }
// Prelude
// -------
// If/Exit
@when(!c t) = ~ c {
0: *
_: t
}
// And
!@and(!a b) = ~ a {
0: 0
_: b
}
// Repeated Application
@rep(n f x) = ~ n !f !x {
0: x
1+p: !&0{f0 f1}=f (f0 @rep(p f1 x))
}
// Squared Application
@sqr(n f x) = ~ n !f !x {
0: x
1+p:
!&0{p0 p1}=(+ p 1)
!&0{fA f0}=f
!&0{f1 f2}=fA
@sqr((/ p0 2) λk(f0 (f1 k)) @rep((% p1 2) f2 x))
}
// Church Nat (with fusion)
@nat(n) = λs λz @sqr(n s z)
// Fixed Point
@fix(f) = !&{f f0}=f !&{f f1}=f (f0 @fix(f1))
// λ-Encoded Nats
// --------------
// Constructors
@S(n) = λs λz (s n)
@Z = λs λz z
// Nat
@nat_all = &1{@Z @S(@nat_all)}
// Nat → Nat
@nat_view(n) =
! case_s = λp #S{@nat_view(p)}
! case_z = #Z
(n case_s case_z)
// U32 → Nat
@nat(n) = ~ n {
0: @Z
1+n: @S(@nat(n))
}
// λ-Encoded Bitstrings
// --------------------
// Constructors
@E = λo λi λe e
@O(xs) = λo λi λe (o xs)
@I(xs) = λo λi λe (i xs)
// Bin
@bin_zero(n) = ~ n {
0: @E
1+n: @O(@bin_zero(n))
}
// U32 → U32 → Bin
@bin(l n) =
@sqr(n λx@bin_inc(x) @bin_zero(l))
// Bin → U32
@bin_to_u32(x) =
! case_o = λp (+ (* @bin_to_u32(p) 2) 0)
! case_i = λp (+ (* @bin_to_u32(p) 2) 1)
! case_e = 0
(x case_o case_i case_e)
// Bin → Bin
@bin_id(x) = λo λi λe
(x o i e)
// Bin → Bin
@bin_inc(x) = λo λi λe
! case_o = λp (i p)
! case_i = λp (o @bin_inc(p))
! case_e = e
(x case_o case_i case_e)
// Bin → Bin → Bin
@bin_add(a b) =
!case_o = λaP λb λo λi λe
!case_o = λbP λaP (o @bin_add(aP bP))
!case_i = λbP λaP (i @bin_add(aP bP))
!case_e = λaP e
(b case_o case_i case_e aP)
!case_i = λaP λb λo λi λe
!case_o = λbP λaP (i @bin_add(aP bP))
!case_i = λbP λaP (o @bin_inc(@bin_add(aP bP)))
!case_e = λaP e
(b case_o case_i case_e aP)
!case_e = λb b
(a case_o case_i case_e b)
// Bin → Bin → Bin
@bin_add_2(a b) =
@bin_sqr(a λx(@bin_inc(x)) b)
// Bin → Bin -> Bool
@bin_eql(a b) =
!case_o = λaP λb
!case_o = λbP λaP @bin_eql(aP bP)
!case_i = λbP λaP 0
!case_e = λaP 0
(b case_o case_i case_e aP)
!case_i = λaP λb
!case_o = λbP λaP 0
!case_i = λbP λaP @bin_eql(aP bP)
!case_e = λaP 0
(b case_o case_i case_e aP)
!case_e = λb
!case_o = λbP 0
!case_i = λbP 0
!case_e = 1
(b case_o case_i case_e)
(a case_o case_i case_e b)
// Bin → Bin
@bin_view(x) =
! case_o = λp #O{@bin_view(p)}
! case_i = λp #I{@bin_view(p)}
! case_e = #E
(x case_o case_i case_e)
// U32 → Bin
@bin_all(n) = ~ n {
0: λo λi λe e
1+n:
! &1{n0 n1} = n
&1{
λo λi λe (o @bin_all(n0))
λo λi λe (i @bin_all(n1))
}
}
// Bin → U32
@bin_len(xs) =
! case_o = λxs (+ 1 @bin_len(xs))
! case_i = λxs (+ 1 @bin_len(xs))
! case_e = 0
(xs case_o case_i case_e)
// Squared Application (with a bitstring)
@bin_sqr(xs f x) =
! case_o = λxs λf λx !&{f0 f1}=f @bin_sqr(xs λk(f0 (f1 k)) x)
! case_i = λxs λf λx !&{F f01}=f !&{f0 f1}=f01 @bin_sqr(xs λk(f0 (f1 k)) (F x))
! case_e = λf λx x
(xs case_o case_i case_e f x)
//Test:
@L = 64
@A = @bin(@L 10000000)
@X = @bin_all(@L)
@B = @bin(@L 99999999)
@main =
! solved = @bin_eql(@bin_add_2(@A @X) @B) // A + X = B
@when(solved @bin_to_u32(@X)) // Prints X
================================================
FILE: examples/enum_lam_naive_blc.hs
================================================
-- This is the Haskell version of the naive λ-Calculus enumerator, that just
-- generates all BLC strings and attempts one by one in a loop.
{-# LANGUAGE PatternSynonyms #-}
import Control.Monad (forM_, when)
import Data.Bits (testBit)
import System.Exit (exitSuccess)
data Bits = O Bits | I Bits | E deriving Show
data Term = Lam Term | App Term Term | Var Int deriving Show
data HTerm = HLam (HTerm -> HTerm) | HApp HTerm HTerm | HVar Int | HSub HTerm
data Pair a b = Pair a b deriving Show
data Result a r = Result a r deriving Show
-- Prelude
-- -------
bits :: Int -> Int -> Bits
bits 0 _ = E
bits n i
| testBit i (n-1) = I (bits (n-1) i)
| otherwise = O (bits (n-1) i)
-- Parser
-- ------
parseTerm :: Bits -> Maybe (Result Bits Term)
parseTerm (O src) = do
Result src nat <- parseInt src
return $ Result src (Var nat)
parseTerm (I src) = case src of
O src -> do
Result src bod <- parseTerm src
return $ Result src (Lam bod)
I src -> do
Result src fun <- parseTerm src
Result src arg <- parseTerm src
return $ Result src (App fun arg)
E -> Nothing
parseTerm E = Nothing
parseInt :: Bits -> Maybe (Result Bits Int)
parseInt (O src) = Just $ Result src 0
parseInt (I src) = do
Result src nat <- parseInt src
return $ Result src (1 + nat)
parseInt E = Just $ Result E 0
doParseTerm :: Bits -> Maybe Term
doParseTerm src = do
Result _ term <- parseTerm src
return term
doParseHTerm :: Bits -> Maybe HTerm
doParseHTerm src = do
Result _ term <- parseTerm src
doBindTerm term
-- Binding
-- -------
-- NOTE: since Haskell doesn't have global variables ($x), we'll bind in two passes
-- The first pass just binds all variables
-- The second pass excludes non-affine terms
uses :: Term -> Int -> Int
uses (Lam bod) idx = uses bod (idx + 1)
uses (App fun arg) idx = uses fun idx + uses arg idx
uses (Var n) idx = if n == idx then 1 else 0
affine :: Term -> Bool
affine term = go term 0 where
go (Lam bod) dep = uses bod 0 <= 1 && go bod (dep + 1)
go (App fun arg) dep = go fun dep && go arg dep
go (Var n) dep = n < dep
doBindTerm :: Term -> Maybe HTerm
doBindTerm term | affine term = Just (bindTerm term [])
doBindTerm term | otherwise = Nothing
bindTerm :: Term -> [HTerm] -> HTerm
bindTerm (Lam bod) ctx = HLam $ \x -> bindTerm bod (x : ctx)
bindTerm (App fun arg) ctx = HApp (bindTerm fun ctx) (bindTerm arg ctx)
bindTerm (Var idx) ctx = get idx ctx
get :: Int -> [HTerm] -> HTerm
get 0 (x:_) = x
get n (_:t) = get (n-1) t
get _ [] = error "*"
-- Stringification
-- ---------------
showBits :: Bits -> String -> String
showBits (O pred) k = '#':'O':'{': showBits pred ('}':k)
showBits (I pred) k = '#':'I':'{': showBits pred ('}':k)
showBits E k = '#':'E':k
doShowBits :: Bits -> String
doShowBits bits = showBits bits []
showTerm :: HTerm -> Int -> String -> String
showTerm (HVar idx) dep k = show (dep - idx - 1) ++ k
showTerm (HLam bod) dep k = 'λ' : showTerm (bod (HVar dep)) (dep+1) k
showTerm (HApp fun arg) dep k = '(' : showTerm fun dep (' ' : showTerm arg dep (')':k))
showTerm (HSub _) _ _ = error "*"
doShowTerm :: HTerm -> String
doShowTerm term = showTerm term 0 []
-- Equality
-- --------
eq :: HTerm -> HTerm -> Int -> Bool
eq (HLam aBod) (HLam bBod) dep = eq (aBod (HVar dep)) (bBod (HVar dep)) (dep+1)
eq (HApp aFun aArg) (HApp bFun bArg) dep = eq aFun bFun dep && eq aArg bArg dep
eq (HVar aIdx) (HVar bIdx) _ = aIdx == bIdx
eq _ _ _ = False
-- Evaluation
-- ----------
wnf :: HTerm -> HTerm
wnf (HLam bod) = HLam bod
wnf (HApp fun arg) = app (wnf fun) arg
wnf (HVar idx) = HVar idx
wnf (HSub val) = HSub val
app :: HTerm -> HTerm -> HTerm
app (HLam bod) x = wnf (bod (wnf x))
app (HApp fun arg) x = HApp (HApp fun arg) x
app (HVar idx) x = HApp (HVar idx) x
app (HSub val) x = HApp (HSub val) x
-- Normalization
-- -------------
nf :: HTerm -> HTerm
nf term = case wnf term of
HLam bod -> HLam $ \x -> nf (bod (HSub x))
HApp fun arg -> HApp (nf fun) (nf arg)
HVar idx -> HVar idx
HSub val -> val
-- Main
-- ----
a :: HTerm
a = HLam $ \t -> HApp (HApp t (HVar 1)) (HVar 2)
b :: HTerm
b = HLam $ \t -> HApp (HApp t (HVar 2)) (HVar 1)
r :: HTerm
r = HLam $ \x -> HApp x (HLam $ \a -> HLam $ \b -> HLam $ \t -> HApp (HApp t b) a)
-- Solve `?x` in `λaλb(?x λt(t a b)) == λaλbλt(t b a)`
main :: IO ()
main = forM_ [0..2^25-1] $ \i -> do
let bs = bits 25 i
case doParseHTerm bs of
Nothing -> do
return ()
Just x -> do
let solved = eq (nf (HApp x a)) b 0
-- putStrLn $ show bs
-- putStrLn $ doShowTerm x
-- putStrLn $ doShowTerm (nf x)
-- putStrLn $ show solved
-- putStrLn $ "----------"
when solved $ do
putStrLn (doShowTerm x)
exitSuccess
================================================
FILE: examples/enum_lam_naive_blc.hvm
================================================
// This is the HVM version of the naive λ-Calculus enumerator. It superposes all
// binary λ-calculus strings, parses, and applies to the equation we want to
// solve. Despite the use of superpositions, this performs about the same as the
// Haskell version, since HVM is forced to enumerate all terms anyway, and not a
// lot of sharing is possible. This takes about 32 million interactions. A
// better approach is provided in the lambda_enumerator_optimal.hvml file, which
// brings this number down to just 72k interactions.
// UPDATE: actually - by just avoiding the issue depicted on:
// https://gist.github.com/VictorTaelin/fb798a5bd182f8c57dd302380f69777a
// We can bring this naive BLC enumerator down to 1.7m interactions. Not quite
// as fast as 72k, but this makes it ~37x faster than the Haskell version.
// UPDATE: somehow this needs only ~111k interactions after using a lazy @and...
data List {
#Nil
#Cons{head tail}
}
data Bits {
#O{pred}
#I{pred}
#E
}
data Term {
#Lam{bod}
#App{fun arg}
#Var{idx}
}
data pair {
#Pair{fst snd}
}
data Maybe {
#None
#Some{value}
}
// Prelude
// -------
@if(c t f) = ~ c {
0: f
_: t
}
@when(c t) = ~ c {
0: *
_: t
}
@tail(xs) = ~ xs {
#Nil: *
#Cons{h t}: t
}
@and(a b) = ~ a !b {
0: 0
_: b
}
// Parsing
// -------
@do_parse_term(src) =
! &0{src term} = @parse_term(src)
@do_bind_term(term)
@parse_term(src) = ~src {
#O{src}:
! &0{src nat} = @parse_nat(src)
&0{src #Var{nat}}
#I{src}: ~src {
#O{src}:
! &0{src bod} = @parse_term(src)
&0{src #Lam{bod}}
#I{src}:
! &0{src fun} = @parse_term(src)
! &0{src arg} = @parse_term(src)
&0{src #App{fun arg}}
#E: *
}
#E: *
}
@parse_nat(src) = ~src {
#O{src}: &0{src 0}
#I{src}:
! &0{src nat} = @parse_nat(src)
&0{src (+ 1 nat)}
#E: &0{#E 0}
}
// Binding
// -------
@do_bind_term(term) =
! &0{ctx term} = @bind_term(term #Nil)
term
@bind_term(term ctx) = ~term !ctx {
#Lam{bod}:
! &0{ctx bod} = @bind_term(bod #Cons{#Some{$x} ctx})
&0{@tail(ctx) #Lam{λ$x bod}}
#App{fun arg}:
! &0{ctx fun} = @bind_term(fun ctx)
! &0{ctx arg} = @bind_term(arg ctx)
&0{ctx #App{fun arg}}
#Var{idx}: @get(idx ctx)
}
@get(idx ctx) = ~ idx !ctx {
0: ~ ctx {
#Nil: *
#Cons{h t}: ~ h {
#None: *
#Some{x}: &0{#Cons{#None t} x}
}
}
1+p: ~ ctx {
#Nil: *
#Cons{h t}:
! &0{t x} = @get(p t)
&0{#Cons{h t} x}
}
}
// Stringification
// ---------------
@show_nat(nat) = ~nat {
0: λk #Cons{'Z' k}
1+p: λk #Cons{'S' (@show_nat(p) k)}
}
@show_dec(n r) =
! &{n n0} = n
! &{n n1} = n
! chr = (+ (% n 10) '0')
~ (< n0 10) !chr !r {
0: @show_dec((/ n1 10) #Cons{chr r})
_: #Cons{chr r}
}
@do_show_dec(n) = @show_dec(n #Nil)
@show_bits(bits) = ~bits {
#O{pred}: λk #Cons{'#' #Cons{'O' #Cons{'{' (@show_bits(pred) #Cons{'}' k})}}}
#I{pred}: λk #Cons{'#' #Cons{'I' #Cons{'{' (@show_bits(pred) #Cons{'}' k})}}}
#E: λk #Cons{'#' #Cons{'E' k}}
}
@do_show_bits(bits) = (@show_bits(bits) #Nil)
@show_term(term dep) = ~term !dep {
#Var{idx}: λk
@show_dec((- (- dep idx) 1) k)
#Lam{bod}: λk
!&0{d0 d1}=dep
#Cons{'λ' (@show_term((bod #Var{d0}) (+ d1 1)) k)}
#App{fun arg}: λk
!&0{d0 d1}=dep
#Cons{'(' (@show_term(fun d0)
#Cons{' ' (@show_term(arg d1)
#Cons{')' k})})}
}
@do_show_term(term) = (@show_term(term 0) #Nil)
// Equality
// --------
@eq(a b dep) = ~ @wnf(a) !b !dep {
#Lam{a_bod}: ~ @wnf(b) !dep {
#Lam{b_bod}:
!&1{dep d0}=dep
!&1{dep d1}=dep
!&1{dep d2}=dep
@eq((a_bod #Var{d0}) (b_bod #Var{d1}) (+ 1 d2))
#App{b_fun b_arg}: 0
#Var{b_idx}: 0
}
#App{a_fun a_arg}: ~ b !dep {
#Lam{b_bod}: 0
#App{b_fun b_arg}:
!&1{dep d0}=dep
!&1{dep d1}=dep
@and(@eq(a_fun b_fun d0) @eq(a_arg b_arg d1))
#Var{b_idx}: 0
}
#Var{a_idx}: ~ b !dep {
#Lam{b_bod}: 0
#App{b_fun b_arg}: 0
#Var{b_idx}: (== a_idx b_idx)
}
}
// Evaluation
// ----------
@wnf(term) = ~ term {
#Lam{bod}: #Lam{bod}
#App{fun arg}: @app(@wnf(fun) arg)
#Var{idx}: #Var{idx}
}
@app(f x) = ~ f !x {
#Lam{bod}: @wnf((bod @wnf(x)))
#App{fun arg}: #App{#App{fun arg} x}
#Var{idx}: #App{#Var{idx} x}
}
// Enumeration
// -----------
// Enums all Bins of given size (label 1)
@all1(s) = ~s{
0: #E
1+p: !&2{p0 p1}=p &2{
#O{@all1(p0)}
#I{@all1(p1)}
}
}
// Tests
// -----
//A= λt (t ^1 ^2)
//A= λ((Z SZ) SSZ)
@A = #Lam{λt #App{#App{t #Var{1}} #Var{2}}}
//B= λt (t ^2 ^1)
//B= λ((Z SSZ) SZ)
@B = #Lam{λt #App{#App{t #Var{2}} #Var{1}}}
//R= λx (x λa λb λt (t b a))
//R= λ(Z λλλ((SSSZ SSZ) SZ))
@R = #Lam{λx #App{x #Lam{λa #Lam{λb #Lam{λt #App{#App{t b} a}}}}}}
@X = @all1(25)
// Solve `?x` in `λaλb(?x λt(t a b)) == λaλbλt(t b a)`
@main =
! &5{x0 x1} = @do_parse_term(@X)
! solved = @eq(#App{x0 @A} @B 0) // (?x A) == B
@when(solved @do_show_term(x1))
================================================
FILE: examples/enum_lam_smart.hvm
================================================
// An Optimal λ-Calculus Enumerator for Program Search
// ---------------------------------------------------
// This file shows a template on how to enumerate superposed terms in a
// higher-order language (here, the affine λ-Calculus) for proof search.
// Instead of generating the source syntax (like superposing all binary strings
// and parsing it as a binary λ-calculus), we create a superposition of all
// λ-terms *directly*, in a way that head constructors are emitted as soon as
// possible. This allows HVM to prune branches and backtrack efficiently as it
// computes the application of all λ-terms to some expression. The result is a
// reduction in the interactions needed to solve the equation:
// > (?X λt(t 1 2)) == λt(t 2 1)
// From ~32 million to just 76k, a 420x speedup*, which increases the harder the
// problem is. This generator works by synthesizing a λ-term in layers. On each
// layer, we either generate a lambda and extend a context, or select one of the
// variables in the context to return. When we select a variable, we will apply
// it to either 0, 1 or 2 other variables in the context (we don't generate
// terms with >2 arity apps here). This is not ideal; in a typed version, we
// would be able to tell the arity of the context variable, and generate the
// right amount of applications, without making a guess.
// * NOTE: we're actually able to bring the naive approach down to 1.7 million
// interactions. So, the numbers are:
// - Enum binary λC with loops (Haskell): 0.992s
// - Enum binary λC with sups (HVM): 0.026s (38x speedup)
// - Enum λC directly with sups (HVM): 0.0011s (862x speedup)
// The main contribution of this file is on the shape of the superposer. There
// are a few things that one must get right to achieve the desired effect.
// First, how do we split a linear context? It depends: when generating an
// application like `(f ?A ?B)`, we need to pass the context to `?A`, get the
// leftover, and pass it to `?B`, in such a way that `?A` and `?B` won't use the
// same variable twice. This happens within the same "universe". Yet, when
// making a choice, like "do we return a lambda or a variable here", we need to
// clone the linear context with the same label forked the universe itself,
// allowing a variable to be used more than once, as long as its occurrences are
// in different universes. Handling this correctly is very subtle, which is why
// this file can be useful for study.
// Second, how do we handle labels? As discussed recently on Discord:
// https://discord.com/channels/912426566838013994/915345481675186197/1311434500911403109
// We only need one label to fully enumerate all natural numbers. Yet, that
// doesn't work for binary trees. My conclusion is that we need to "fork" the
// label whenever we enumerate a constructor that branches; i.e., that has more
// than one field. Nats and Bits are safe because their constructors only have
// one field, but a binary Tree needs forking. To fork a label, we just mul by 2
// and add 0 or 1, and the seed has to be 1, so that forked branches never use
// the same label. We apply this here to the arity-2 app case.
// Third, how do we emit constructors as soon as possible, while still passing a
// context down? It is easy to accidentally mess this up by making the enum
// monadic. This will cause it to sequentialize its execution, meaning no ctor
// is emitted until the entire enumerator returns. That's a big problem, since
// we need head ctors to be available as soon as possible. That's how HVM is
// able to invalidate universes and backtrack. While this is a silly issue, it
// can spoil the whole thing, so I've elaborated it here:
// https://gist.github.com/VictorTaelin/fb798a5bd182f8c57dd302380f69777a
// The enumerator in this file is the simplest "template" enumerator that has
// everything a higher order language needs and is structured in a way that can
// be studied and extended with more sophisticate approaches, like types.
// EDIT: the dependently typed version has been pushed. It reduces the rewrite
// count to 3k, and greatly improves the enumerator shape.
data List {
#Nil
#Cons{head tail}
}
data Bits {
#O{pred}
#I{pred}
#E
}
data Term {
#Lam{bod}
#App{fun arg}
#Var{idx}
#Sub{val}
}
data pair {
#Pair{fst snd}
}
data Result {
#Result{src val}
}
data Maybe {
#None
#Some{value}
}
// Prelude
// -------
@if(c t f) = ~ c {
0: f
_: t
}
@when(c t) = ~ c {
0: *
_: t
}
@tail(xs) = ~ xs {
#Nil: *
#Cons{h t}: t
}
@and(a b) = ~ a !b {
0: 0
_: b
}
@unwrap(mb) = ~ mb {
#None: *
#Some{x}: x
}
@tm0(x) = !&0{a b}=x a
@tm1(x) = !&0{a b}=x b
// Stringification
// ---------------
@show_nat(nat) = ~nat {
0: λk #Cons{'Z' k}
1+p: λk #Cons{'S' (@show_nat(p) k)}
}
@show_dec(&n r) =
! chr = (+ (% n 10) '0')
~ (< n 10) !chr !r {
0: @show_dec((/ n 10) #Cons{chr r})
_: #Cons{chr r}
}
@do_show_dec(n) = @show_dec(n #Nil)
@show_bits(bits) = ~bits {
#O{pred}: λk #Cons{'#' #Cons{'O' #Cons{'{' (@show_bits(pred) #Cons{'}' k})}}}
#I{pred}: λk #Cons{'#' #Cons{'I' #Cons{'{' (@show_bits(pred) #Cons{'}' k})}}}
#E: λk #Cons{'#' #Cons{'E' k}}
}
@do_show_bits(bits) = (@show_bits(bits) #Nil)
@show_term(term dep) = ~term !&dep {
#Var{idx}: λk
@show_dec((- (- dep idx) 1) k)
#Lam{bod}: λk
#Cons{'λ' (@show_term((bod #Var{dep}) (+ dep 1)) k)}
#App{fun arg}: λk
#Cons{'(' (@show_term(fun dep)
#Cons{' ' (@show_term(arg dep)
#Cons{')' k})})}
#Sub{val}: *
}
@do_show_term(term) = (@show_term(term 0) #Nil)
// Equality
// --------
@eq(a b dep) = ~ a !b !dep {
#Lam{a_bod}: ~ b !&dep {
#Lam{b_bod}:
@eq((a_bod #Var{dep}) (b_bod #Var{dep}) (+ 1 dep))
else: 0
}
#App{a_fun a_arg}: ~ b !&dep {
#App{b_fun b_arg}:
@and(@eq(a_fun b_fun dep) @eq(a_arg b_arg dep))
else: 0
}
#Var{a_idx}: ~ b !&dep {
#Var{b_idx}: (== a_idx b_idx)
else: 0
}
#Sub{a_val}: *
}
// Evaluation
// ----------
@wnf(term) = ~ term {
#Lam{bod}: #Lam{bod}
#App{fun arg}: @wnf_app(@wnf(fun) arg)
#Var{idx}: #Var{idx}
#Sub{val}: #Sub{val}
}
@wnf_app(f x) = ~ f !x {
#Lam{bod}: @wnf((bod @wnf(x)))
#App{fun arg}: #App{#App{fun arg} x}
#Var{idx}: #App{#Var{idx} x}
#Sub{val}: #App{#Sub{val} x}
}
// Normalization
// -------------
@nf(term) = ~ @wnf(term) {
#Lam{bod}: #Lam{λx @nf((bod #Sub{x}))}
#App{fun arg}: #App{@nf(fun) @nf(arg)}
#Var{idx}: #Var{idx}
#Sub{val}: val
}
// Enumeration
// -----------
// Enumerates affine λ-terms.
// - lim: max context length (i.e., nested lambdas)
// - lab: superposition label. should be 1 initially.
// - ctx: the current scope. should be [] initially.
// If the binder limit has been reached, destroy this universe.
// Otherwise, make a choice.
// - A. We generate a fresh lambda.
// - B. We select a variable from context.
// Note that, every time we make a choice, we "fork" the current context by
// using DUP nodes with the same label that we used in the choice SUP node.
@all(!&L !&lim ctx) = ~lim {
0: *
1+&lim:
!&L{ctxL ctxR} = ctx
&L{
@lam(L lim ctxL)
@ret(L (+ lim 1) ctxR λk(k))
}
}
// Generate a fresh lambda and extend the context with its variable.
@lam(!&L !&lim ctx) =
!&0{ctx bod} = @all(L lim #Cons{#Some{$x} ctx})
&0{@tail(ctx) #Lam{λ$x(bod)}}
// Return a variable from the context.
// If the context is empty, destroy this universe.
// Otherwise, make a choice.
// - A. We emit the head of the context, and apply it to things.
// - B. We keep the head of the context, and go to the next element.
@ret(!&L !&lim ctx rem) = ~ctx {
#Nil: *
#Cons{val ctx}:
!&L{remL remR} = rem
!&L{valL valR} = val
!&L{ctxL ctxR} = ctx
&L{
@app(L lim (remL #Cons{#None ctxL}) valL)
@ret(L lim ctxR λk(remR #Cons{valR k}))
}
}
// To apply a value to things, we will make a triple choice.
// - A. Just return it directly.
// - B. Apply it to 1 argument.
// - C. Apply it to 2 arguments.
// When we apply it to 2 arguments, as in `(App ?A ?B)`, we need to fork the
// label, so that DUPs/SUPs in `?A` and `?B` never use the same label.
@app(!&L !&lim ctx val) = ~ val {
#None: *
#Some{val}:
!&L{val val0} = val
!&L{val val1} = val
!&L{val val2} = val
!&L{ctx ctx0} = ctx
!&L{ctx ctx1} = ctx
!&L{ctx ctx2} = ctx
! arity_0 =
&0{ctx0 val0}
! arity_1 =
!&0{ctx1 argX} = @all(L lim ctx1)
&0{ctx1 #App{val1 argX}}
! arity_2 =
!&0{ctx2 argX} = @all((+(* L 2) 0) lim ctx2)
!&0{ctx2 argY} = @all((+(* L 2) 1) lim ctx2)
&0{ctx2 #App{#App{val2 argX} argY}}
&L{arity_0 &L{arity_1 arity_2}}
}
// Tests
// -----
//A= λt (t ^1 ^2)
//A= λ((Z SZ) SSZ)
@A = #Lam{λt #App{#App{t #Var{1}} #Var{2}}}
//B= λt (t ^2 ^1)
//B= λ((Z SSZ) SZ)
@B = #Lam{λt #App{#App{t #Var{2}} #Var{1}}}
//R= λx (x λa λb λt (t b a))
//R= λ(Z λλλ((SSSZ SSZ) SZ))
@R = #Lam{λx #App{x #Lam{λa #Lam{λb #Lam{λt #App{#App{t b} a}}}}}}
//X= (all terms)
@X = @tm1(@all(1 5 #Nil))
// Solves for `?X` in `(?X λt(t A B)) == λt(t B A)`.
// It finds `?X = λλ(1 λλ((2 0) 1))` in 76k interactions.
@main =
! solved = @eq(@nf(#App{@X @A}) @B 0)
@when(solved @do_show_term(@X))
================================================
FILE: examples/enum_nat.hvm
================================================
// This shows how to use a 'pseudo-metavar' to invert the binary add function,
// and solve the equation: 'X * 20 = 5000'. Run it with collapse mode:
// $ hvml run pseudo_metavar_nat.hvml -C -s
// Unary Peano Nats
data Nat { #Z #S{pred} }
// If-Then-Else
@if(b t f) = ~b {
0: f
_: t
}
// Converts an U32 to a Nat
@nat(n) = ~n{
0: #Z
1+p: #S{@nat(p)}
}
// Converts a Nat to an U32
@u32(n) = ~n{
#Z: 0
#S{np}: (+ 1 @u32(np))
}
// Adds two Nats
@add(a b) = ~a !b {
#Z: b
#S{ap}: #S{@add(ap b)}
}
// Muls two Nats
@mul(a b) = ~a !b {
#Z: #Z
#S{ap}: !&1{b0 b1}=b @add(b0 @mul(ap b1))
}
// Compares two Nats for equality
@eq(a b) = ~a !b {
#Z: ~b{
#Z: 1
#S{bp}: 0
}
#S{ap}: ~b{
#Z: 0
#S{bp}: @eq(ap bp)
}
}
// A superposition of all Nats (pseudo-metavar)
@X = &0{#Z #S{@X}}
// Solves 'X * 20 = 20000'
@main = @if(@eq(@mul(@X @nat(20)) @nat(12000)) @u32(@X) *)
// This is quadratic. In the post below, I discuss solutions to make it linear:
// https://gist.github.com/VictorTaelin/93c327e5b4e752b744d7798687977f8a
// These solutions are implemented on the branches:
// - oportunistic_swaps
// - unordered_superpositions
// Sadly they don't work as I expected in all cases. More clarity is needed.
================================================
FILE: examples/enum_path_finder.hvm
================================================
// Simple path finding with superpositions
// Lists
data List { #Nil #Cons{head tail} }
// Directions (Left/Right/Up/Down)
data Dir { #L #R #U #D }
// Collapses an universe when c=0
@when(!c t) =
~ c {
0: *
_: t
}
// Decrements/increments a number
@dec(x) = ~ x { 0:*; 1+x:x }
@inc(x) = (+ x 1)
// Swaps an element in an array
@swap(xs i v) = ~ i !xs !v {
0: ~ xs {
#Nil: *
#Cons{x xs}:
&0{#Cons{v xs} x}
}
1+i: ~ xs {
#Nil: *
#Cons{x xs}:
! &0{xs v} = @swap(xs i v)
&0{#Cons{x xs} v}
}
}
// Swaps an element in a 2D grid
@swap2D(xs pos v) =
! &0{i j } = pos
! & {i0 i1} = i
! & {j0 j1} = j
! &0{xs ys} = @swap(xs j0 *)
! &0{ys k } = @swap(ys i0 *)
! &0{ys _ } = @swap(ys i1 v)
! &0{xs _ } = @swap(xs j1 ys)
&0{xs k}
// Moves a position to a direction
@move(pos dir) =
! &0{x y} = pos
~ dir !x !y {
#L: &0{@dec(x) y}
#R: &0{@inc(x) y}
#U: &0{x @dec(y)}
#D: &0{x @inc(y)}
}
@diff(&a &b) =
~ (< a b) {
0: (- a b)
_: (- b a)
}
@gdist(pos goal) =
! &0{px py} = pos
! &0{gx gy} = goal
! dx = @diff(px gx)
! dy = @diff(py gy)
(+ dx dy)
@closer(prev curr &goal) =
! d_prev = @gdist(prev goal) // distance from prev → goal
! d_curr = @gdist(curr goal) // distance from cur → goal
(< d_curr d_prev)
!@walk(map &pos !path &goal) =
~ path {
#Nil:
pos
#Cons{dir path}:
! &new_pos = @move(pos dir)
! &0{map got} = @swap2D(map new_pos 0) // <- 0 means we don't replace the prev tile by a wall, making it much harder
~ got {
0: ↑@walk(map new_pos path goal) // <- generates a weird path? and ↓ hangs...
//~ @closer(pos new_pos goal) !map !path {
//0: ↓↓@walk(map new_pos path goal)
//_: ↓@walk(map new_pos path goal)
//}
_: *
}
}
@map = [
[0 1 0 1 0 0 0 0 0]
[0 1 0 1 0 1 1 1 0]
[0 0 0 1 0 0 0 1 0]
[0 1 1 1 0 1 1 0 0]
[0 0 0 0 0 1 0 1 0]
[0 1 1 1 0 1 0 1 0]
[0 1 0 0 0 1 0 1 0]
[0 1 0 1 1 1 0 1 0]
[0 0 0 0 0 0 0 1 0]
]
// Superposition of all possible paths
@dirs(&L) = ~ L {
0: #Nil
1+&L: &1{#Nil &1{#Cons{#L @dirs(L)} &1{#Cons{#R @dirs(L)} &1{#Cons{#U @dirs(L)} #Cons{#D @dirs(L)}}}}}
}
// Finds a path from (0,0) to (8,8)
@main =
! &lim = 32
! &ini = &0{0 0}
! &end = &0{4 0}
! &0{i j} = @walk(@map ini @dirs(lim) end)
! &0{I J} = end
@when((& (== i I) (== j J)) @dirs(lim))
//@when((& (== i I) (== j J)) 1)
================================================
FILE: examples/enum_primes.hs
================================================
-- //./pseudo_metavar_factors.hvml//
import Control.Monad (forM_, when)
import Data.Time.Clock (getCurrentTime, diffUTCTime)
import System.Exit (exitSuccess)
import Text.Printf (printf)
data Bin = O Bin | I Bin | E deriving (Show, Eq)
u32 :: Bin -> Int
u32 (O p) = 2 * u32 p + 0
u32 (I p) = 2 * u32 p + 1
u32 E = 0
bin :: Int -> Int -> Bin
bin 0 _ = E
bin s n = case n `mod` 2 of
0 -> O (bin (s-1) (n `div` 2))
_ -> I (bin (s-1) (n `div` 2))
eq :: Bin -> Bin -> Bool
eq E E = True
eq (O a) (O b) = eq a b
eq (I a) (I b) = eq a b
eq _ _ = False
inc :: Bin -> Bin
inc (O p) = I p
inc (I p) = O (inc p)
inc E = E
add :: Bin -> Bin -> Bin
add (O a) (O b) = O (add a b)
add (O a) (I b) = I (add a b)
add (I a) (O b) = I (add a b)
add (I a) (I b) = O (inc (add a b))
add E b = E
add a E = E
mul :: Bin -> Bin -> Bin
mul _ E = E
mul a (O b) = O (mul a b)
mul a (I b) = add a (O (mul a b))
cat :: Bin -> Bin -> Bin
cat (O a) b = O (cat a b)
cat (I a) b = I (cat a b)
cat E b = b
k = 14
h = 15
s = 30
p = I(I(I(O(O(O(I(I(O(I(O(I(O(O(O(O(I(O(I(I(O(O(I(O(O(I(O(I(O(I(E))))))))))))))))))))))))))))))
--INJECT--
main :: IO ()
main = do
start <- getCurrentTime
forM_ [0..2^h-1] $ \a -> do
forM_ [0..2^h-1] $ \b -> do
let binA = cat (bin h a) (bin h 0)
let binB = cat (bin h b) (bin h 0)
when (eq (mul binA binB) p) $ do
end <- getCurrentTime
let duration = diffUTCTime end start
putStrLn $ "FACT: " ++ show a ++ " " ++ show b
putStrLn $ "TIME: " ++ printf "%.7f seconds" (realToFrac duration :: Double)
exitSuccess
================================================
FILE: examples/enum_primes.hvm
================================================
// Bitstrings
data Bin { #O{pred} #I{pred} #E }
// If-Then-Else
@if(b t f) = ~b {
0: f
_: t
}
// Converts a Bin to an U32
@u32(b) = ~b{
#O{p}: (+ (* 2 @u32(p)) 0)
#I{p}: (+ (* 2 @u32(p)) 1)
#E: 0
}
// Converts an U32 to a Bin of given size
@bin(s n) = ~s{
0: #E
1+p: !&0{n0 n1}=n ~(% n0 2) !p !n1 {
0: #O{@bin(p (/ n1 2))}
_: #I{@bin(p (/ n1 2))}
}
}
// Bin Equality
@eq(a b) = ~a !b {
#E: ~b {
#O{bp}: 0
#I{bp}: 0
#E: 1
}
#O{ap}: ~b{
#O{bp}: @eq(ap bp)
#I{bp}: 0
#E: 0
}
#I{ap}: ~b{
#O{bp}: 0
#I{bp}: @eq(ap bp)
#E: 0
}
}
// Increments a Bin
@inc(a) = ~a{
#O{p}: #I{p}
#I{p}: #O{@inc(p)}
#E: #E
}
// Decrements a Bin
@dec(a) = ~a{
#O{p}: #O{@dec(p)}
#I{p}: #I{p}
#E: #E
}
// Adds two Bins
@add(a b) = ~a !b {
#O{ap}: ~b !ap {
#O{bp}: #O{@add(ap bp)}
#I{bp}: #I{@add(ap bp)}
#E: #E
}
#I{ap}: ~b !ap {
#O{bp}: #I{@add(ap bp)}
#I{bp}: #O{@inc(@add(ap bp))}
#E: #E
}
#E: #E
}
// Muls two Bins
@mul(a b) = ~b !a {
#O{bp}: #O{@mul(a bp)}
#I{bp}: !&0{a0 a1}=a @add(a0 #O{@mul(a1 bp)})
#E: #E
}
// Concatenates two Bins
@cat(a b) = ~a !b {
#O{ap}: #O{@cat(ap b)}
#I{ap}: #I{@cat(ap b)}
#E: b
}
// Enums all Bins of given size (label 1)
@all1(s) = ~s{
0: #E
1+p: !&1{p0 p1}=p &1{ #O{@all1(p0)} #I{@all1(p1)} }
}
// Enums all Bins of given size (label 2)
@all2(s) = ~s{
0: #E
1+p: !&2{p0 p1}=p &2{ #O{@all2(p0)} #I{@all2(p1)} }
}
// 8:
@K_A = 3
@H_A = 4
@S_A = 8
@X_A = @cat(@all1(@H_A) @bin(@H_A 0))
@Y_A = @cat(@all2(@H_A) @bin(@H_A 0))
@P_A = #I{#O{#O{#I{#O{#I{#O{#I{#E}}}}}}}}
// 20:
@K_B = 9
@H_B = 10
@S_B = 20
@X_B = @cat(@all1(@H_B) @bin(@H_B 0))
@Y_B = @cat(@all2(@H_B) @bin(@H_B 0))
@P_B = #I{#I{#I{#I{#O{#I{#I{#O{#I{#I{#O{#O{#I{#O{#I{#O{#O{#O{#I{#I{#E}}}}}}}}}}}}}}}}}}}}
// 30:
@K_C = 14
@H_C = 15
@S_C = 30
@X_C = @cat(@all1(@H_C) @bin(@H_C 0))
@Y_C = @cat(@all2(@H_C) @bin(@H_C 0))
@P_C = #I{#I{#I{#O{#O{#O{#I{#I{#O{#I{#O{#I{#O{#O{#O{#O{#I{#O{#I{#I{#O{#O{#I{#O{#O{#I{#O{#I{#O{#I{#E}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}
////INJECT//
@main = @if(@eq(@mul(@X_B @Y_B) @P_B) λt(t @u32(@X_B) @u32(@Y_B)) *)
================================================
FILE: examples/feat_affine_ctx.hvm
================================================
// Optimal recursive context passing with HVM's "pure mutable references"
// Article: https://gist.github.com/VictorTaelin/fb798a5bd182f8c57dd302380f69777a
data Pair { #Pair{fst snd} }
data List { #Nil #Cons{head tail} }
data Tree { #Leaf #Node{lft rgt} }
// Utils
// -----
@is_node(tree) = ~tree {
#Leaf: 0
#Node{lft rgt}: 1
}
@range(n r) = ~n !r {
0: r
1+p: !&0{p0 p1}=p @range(p0 #Cons{p1 r})
}
@fst(p) = ~p {
#Pair{fst snd}: fst
}
@snd(p) = ~p {
#Pair{fst snd}: snd
}
@tm0(sup) = !&0{tm0 tm1}=sup tm0
@tm1(sup) = !&0{tm0 tm1}=sup tm1
// Mutable references
@mut(ref fn) = !! $new = (fn (ref $new)) *
@spt(ref fn) = (fn λ$y(ref $z) λ$z($y))
// Slow Version
// ------------
// The slow version passes a context monadically, with a pair state.
@list_to_tree_slow(n ctx) = ~n !ctx {
// Base Case:
// - take the ctx's head
// - return the context's tail and '#Leaf{head}'
0: ~ctx {
#Nil: *
#Cons{head tail}: #Pair{tail #Leaf{head}}
}
// Step Case:
// - recurse to the lft, get the new ctx and 'lft' tree
// - recurse to the rgt, get the new ctx and 'rgt' tree
// - return the final context and a '#Node{lft rgt}'
1+p:
!&0{p0 p1}=p
~ @list_to_tree_slow(p0 ctx) {
#Pair{ctx lft}: ~ @list_to_tree_slow(p1 ctx) {
#Pair{ctx rgt}: #Pair{ctx #Node{lft rgt}}
}
}
}
// Fast Version: parallel destructing
// ----------------------------------
// This version uses a superposition instead of a pair. It is faster because it
// allows us to destruct in parallel (which isn't available for native ADTs),
// preventing the sequential chaining issue.
@list_to_tree_fast_par(n ctx) = ~n !ctx {
0: ~ctx {
#Nil: *
#Cons{head tail}: &0{tail #Leaf{head}}
}
1+p:
! &0{p0 p1} = p
! &0{ctx lft} = @list_to_tree_fast_par(p0 ctx)
! &0{ctx rgt} = @list_to_tree_fast_par(p1 ctx)
&0{ctx #Node{lft rgt}}
}
// Fast Version: mutable references
// --------------------------------
// This version passes the context as a mutable reference.
// It avoids pair entirely.
@list_to_tree_fast_mut(n ctx) = ~n !ctx {
// Base case:
// - mutably replace the context by its tail, and extract its head
// - return just '#Leaf{head}' (no pairs!)
0:
!! @mut(ctx λctx ~ctx { #Nil:* #Cons{$head tail}:tail })
#Leaf{$head}
// Step Case:
// - split the mutable reference into two
// - recurse to the lft and rgt, passing the split mut refs
// - return just '#Node{lft rgt}' directly (no pairs!)
1+p:
!&0{pL pR}=p
!! @spt(ctx λ$ctxL λ$ctxR *)
#Node{
@list_to_tree_fast_mut(pL $ctxL)
@list_to_tree_fast_mut(pR $ctxR)
}
}
// Main
// ----
// Tree Depth
@depth = 16
// Tests slow version
//@main = @is_node(@snd(@list_to_tree_slow(@depth (@range((<< 1 @depth) 0)))))
// Tests fast version with parallel destruct
@main = @is_node(@tm1(@list_to_tree_fast_par(@depth (@range((<< 1 @depth) 0)))))
// Tests fast version with mutable refs
//@main = @is_node(@list_to_tree_fast_mut(@depth λ$ctx(@range((<< 1 @depth) 0))))
================================================
FILE: examples/feat_cmul.hvm
================================================
@main =
!c2_0 = λf !&0{f0 f1}=f λx(f0 (f1 x))
!c2_1 = λf !&1{f0 f1}=f λx(f0 (f1 x))
(c2_0 c2_1)
================================================
FILE: examples/feat_hoas.hvm
================================================
data List {
#Nil
#Cons{head tail}
}
data Term {
#Var{nam}
#Lam{nam bod}
#App{fun arg}
#Sub{val}
}
@cat(xs ys) = ~xs !ys {
#Nil: ys
#Cons{h t}: #Cons{h @cat(t ys)}
}
@join(xs) = ~xs {
#Nil: #Nil
#Cons{h t}: @cat(h @join(t))
}
@show(term) = ~term {
#Var{nam}: nam
#Lam{nam bod}: !&0{n0 n1}=nam @join(["λ" n0 " " @show((bod #Var{n1}))])
#App{fun arg}: @join(["(" @show(fun) " " @show(arg) ")"])
#Sub{val}: @show(val)
}
@wnf(term) = ~term {
#Var{nam}: #Var{nam}
#Lam{nam bod}: #Lam{nam bod}
#App{fun arg}: @app(@wnf(fun) arg)
#Sub{val}: @wnf(val)
}
@nf(term) = ~ @wnf(term) {
#Var{nam}: #Var{nam}
#Lam{nam bod}: #Lam{nam λx @nf((bod #Sub{x}))}
#App{fun arg}: #App{@nf(fun) @nf(arg)}
#Sub{val}: val
}
@app(f x) = ~f !x {
#Var{nam}: #App{#Var{nam} x}
#Lam{nam bod}: @wnf((bod @wnf(x)))
#App{fun arg}: #App{#App{fun arg} x}
#Sub{val}: #Var{"TODO"}
}
@ID = #Lam{"x" λx(x)}
@c2 = #Lam{"f" λf #Lam{"x" λx !&1{f0 f1}=f #App{f0 #App{f1 x}}}}
@k2 = #Lam{"g" λf #Lam{"y" λx !&2{f0 f1}=f #App{f0 #App{f1 x}}}}
@fn = #App{@c2 @k2}
@main = @show(@nf(@fn))
================================================
FILE: examples/feat_mut_ref.hvm
================================================
// Article: https://gist.github.com/VictorTaelin/fb798a5bd182f8c57dd302380f69777a
@mut(ref fn) = !! $new = (fn (ref $new)) *
@spt(ref fn) = (fn λ$y(ref $z) λ$z($y))
@main =
! $X = λ$x(0) // u32* X = &0;
!! @spt($X λ$X0 λ$X1 *) // u32* X0 = X; u32* X1 = X;
!! @mut($X0 λx(+ x 1)) // *X += 1;
!! @mut($X1 λx(+ x 1)) // *X += 1;
$x // *X
// The '!! x = val' notation represents a seq operator.
// It reduces 'val' to whnf and assigns the result to 'x'.
// The '!! val' notation is a shortcut for '!! _ = val'.
// The '$var' notation is for globally scoped variables.
================================================
FILE: examples/fuse_inc.hvm
================================================
// A minimal example of Optimal Evaluation (:
// Bits (Native)
data Bits {
#O{pred}
#I{pred}
#E{}
}
// Repeated Application
@rep(n f x) = ~ n !f !x {
0: x
1+p: !&0{f0 f1}=f (f0 @rep(p f1 x))
}
// Squared Application
@sqr(n f x) = ~ n !f !x {
0: x
1+p:
!&0{p0 p1}=(+ p 1)
!&0{fA f0}=f
!&0{f1 f2}=fA
@sqr((/ p0 2) λk(f0 (f1 k)) @rep((% p1 2) f2 x))
}
// Bits (Scott)
@o(x) = λo λi λe (o x)
@i(x) = λo λi λe (i x)
@e = λo λi λe e
// Bits increment
@inc(x) = λo λi λe (x i λop(o @inc(op)) e)
// Creates an all-zero Bits
@zero(s) = ~s{
0: @e
1+p: @o(@zero(p))
}
// Converts a Bits to an U32
@bits_to_u32(xs) = (xs
λp0 (+ (* 2 @bits_to_u32(p0)) 0)
λp1 (+ (* 2 @bits_to_u32(p1)) 1)
0)
// Applies 'inc' N times to zero
@main = @bits_to_u32(@sqr(1234567 λx@inc(x) @zero(32)))
================================================
FILE: examples/fuse_inc.hvm1
================================================
// Repeated Application
(Rep 0 f x) = x
(Rep n f x) = (f (Rep (- n 1) f x))
// Squared Application
(Sqr 0 f x) = x
(Sqr n f x) = (Sqr (/ n 2) λk(f (f k)) (Rep (% n 2) f x))
// Bits (Scott-Encoded)
(O x) = λo λi λe (o x)
(I x) = λo λi λe (i x)
E = λo λi λe e
// Bits increment
(Inc x) = λo λi λe (x i λop(o (Inc op)) e)
// Converts a Bits to a U60
(BitsToU60 x) = (x
λp0 (+ (* 2 (BitsToU60 p0)) 0)
λp1 (+ (* 2 (BitsToU60 p1)) 1)
0)
(Zero 0) = E
(Zero s) = (O (Zero (- s 1)))
// Applies 'Inc' N times to zero
Main = (BitsToU60 (Sqr 1234567 λx(Inc x) (Zero 60)))
================================================
FILE: examples/fuse_mul.hvm
================================================
// Multiplication by squared addition with optimal evaluation
// Repeated Application
@rep(n f x) = ~ n !f !x {
0: x
1+p: !&0{f0 f1}=f (f0 @rep(p f1 x))
}
// Squared Application
@sqr(n f x) = ~ n !f !x {
0: x
1+p:
!&0{p0 p1}=(+ p 1)
!&0{fA f0}=f
!&0{f1 f2}=fA
@sqr((/ p0 2) λk(f0 (f1 k)) @rep((% p1 2) f2 x))
}
// Bits (Scott)
@o(x) = λo λi λe (o x)
@i(x) = λo λi λe (i x)
@e = λo λi λe e
// Creates an all-zero Bits
@zero(s) = ~s{
0: @e
1+p: @o(@zero(p))
}
// U32 -> Bits
@bits(n) = ~ n {
0: @e
1+p: !&0{n0 n1}=(+ p 1) ~ (% n0 2) !n1 {
0: @o(@bits((/ n1 2)))
1: @i(@bits((/ n1 2)))
2+p: *
}
}
// Bits -> U32
@u32(xs) = (xs
λp0 (+ (* 2 @u32(p0)) 0)
λp1 (+ (* 2 @u32(p1)) 1)
0)
// Bits increment
@inc(x) = λo λi λe (x i λop(o @inc(op)) e)
// Addition with carry
@add = λa (a
λap λb (b λbp λap @o((@add ap bp)) λbp λap @i( (@add ap bp)) @e ap)
λap λb (b λbp λap @i((@add ap bp)) λbp λap @o(@inc((@add ap bp))) @e ap)
λb b)
// Multiplication by squared addition
@mul(a b) = @u32(@sqr(a (@add @bits(b)) @zero(64)))
@main = @mul(23232 32323)
//WORK: 233357193 interactions
//TIME: 3.202 seconds
//SIZE: 1402714952 nodes
//PERF: 72.890 MIPS
================================================
FILE: examples/fuse_rot.hvm
================================================
// Relevant discussion:
// https://discord.com/channels/912426566838013994/915345481675186197/1312147864373301329
data List { #Nil #Cons{head tail} }
// Repeated Application
@rep(n f x) = ~ n !f !x {
0: x
1+p: !&0{f0 f1}=f (f0 @rep(p f1 x))
}
// Squared Application
@sqr(n f x) = ~ n !f !x {
0: x
1+p:!&0{p0 p1}=(+ p 1)
!&0{fA f0}=f
!&0{f1 f2}=fA
@sqr((/ p0 2) λk(f0 (f1 k)) @rep((% p1 2) f2 x))
}
@O(a b) = λo λi (o a b)
@I(a b) = λo λi (i a b)
@L(x) = x
@view(!&s) = ~s {
0: λx x
1+&p: λx (x
λa λb [0 (@view(p) a) (@view(p) b)]
λa λb [1 (@view(p) a) (@view(p) b)])
}
@read(!&s) = ~s {
0: λx 0
1+&p: λx (x
λa λb (+ 0 (* (@read(p) a) 2))
λa λb (+ 1 (* (@read(p) a) 2)))
}
@zero(s) = ~s {
0: 0
1+&p: @O(@zero(p) @zero(p))
}
@inc(s) = ~s {
0: λx x
1+&p: λx λo λi (x
λa λb (i b (@inc(p) a))
λa λb (o b (@inc(p) a)))
}
@dec(s) = ~s {
0: λx x
1+&p: λx λo λi (x
λa λb (i (@dec(p) b) a)
λa λb (o (@dec(p) b) a))
}
@neg(!&s) = ~s {
0: λx x
1+&p: λx λo λi (x
λa λb (o (@neg(p) a) (@neg(p) b))
λa λb (i (@neg(p) b) (@neg(p) a)))
}
// What this does?
@foo(!&s) = ~s {
0: λx λy x
1+&p: λx (x
λxa λxb !&1{xa0 xa1}=xa !&1{xb0 xb1}=xb λy λo λi (y
λya λyb (o (@foo(p) xa0 ya) (@foo(p) xb0 yb))
λya λyb (i (@foo(p) xb1 yb) (@foo(p) xa1 ya)))
λxa λxb !&1{xa0 xa1}=xa !&1{xb0 xb1}=xb λy λo λi (y
λya λyb (i (@foo(p) xb0 yb) (@foo(p) xa0 ya))
λya λyb (o (@foo(p) xa1 ya) (@foo(p) xb1 yb))))
}
// Removing the recursive calls to @dec/@inc makes this
// fuse; but since we can't, it doesn't, making it slow
@add(!&s) = ~s {
0: λx λy y
1+&p: λx (x
λxa λxb !&1{xa0 xa1}=xa !&1{xb0 xb1}=xb λy λo λi (y
λya λyb (o (@add(p) xa0 ya) (@add(p) xb0 yb))
λya λyb (i (@add(p) xb1 ya) (@add(p) xa1 yb)))
λxa λxb !&1{xa0 xa1}=xa !&1{xb0 xb1}=xb λy λo λi (y
λya λyb (i (@add(p) xa0 yb) (@add(p) xb0 ya))
λya λyb (o (@dec(p) (@add(p) xb1 yb)) (@inc(p) (@add(p) xa1 ya)))))
}
@S = 32
@K(n) = @rep(n @inc(@S) @zero(@S))
@KA = @K(17)
@KB = @K(0)
// meh
@main = (@read(@S) @sqr(54321 (@add(@S) @KA) @KB))
================================================
FILE: examples/main.hvm
================================================
data List{ #Nil #Cons{head tail} }
data Foo{ #A #B }
data Bar{ #C #D }
data Term {
#Var{idx}
#Pol{bod}
#All{inp bod}
#Lam{bod}
#App{fun arg}
#U32
#Num{val}
}
@main = ~ (#Pol{123}) {
#Var{idx}: *
#Pol{bod}: 123
#All{inp bod}: *
#Lam{bod}: *
#App{fun arg}: *
#U32: *
#Num{val}: *
}
////@main = ~ (#A) {
////#A: 1
////#B: 2
////}
////@main = ~ 3 {
////0: 10
////1: 20
////p: p
////}
//@main =
//~ [1 2] {
//#Cons{a b}: a
//#Nil: 0
//}
//!@foo(k a) =
//! &0{x y} = a
//! &1{_ _} = 1
//! &2{_ _} = 2
//(+ x y)
//@main = @foo(1 &0{1 2})
//data Foo {
//#A{k}
//#B{k}
//}
//@bar(x) = ~ x {
//#A{k}: (+ 1 k)
//#B{k}: (+ 2 k)
//}
//@main = @bar(*)
//@foo(n) = ~n { 0: 0 p: (+ 1 @foo(p)) }
////@main = @foo(&0{1000 1000})
//@main = &0{@foo(1000) @foo(1000)}
// ~ &0{#A{...} #B{...}} {
// #A: ...
// #B: ...
// }
//@foo(&0{1 2} x y)
//-----------------
//&0{x0 x1}=x
//&0{y0 y1}=y
//&0{@foo(1 x0 y0) @foo(2 x1 y1)}
//(&L{x y} arg)
//-------------
//&0{arg0 arg1}=arg
//&{(x arg0) (y arg1)}
//data Foo { #A{a b} #B{a b} #C{a b} #D{a b} }
//@main = ~ 7 {
//0: 3
//p: p
//}
//@main = ~ #A{1 2} {
//#A{a b}: ["A" a b]
//#B{a b}: ["B" a b]
//#C{a b}: ["C" a b]
//}
//@main = λx ~ #D{1 2} {
//#A{a b}: ["A" a b]
//#C{a b}: ["C" a b]
//term: term
//}
//@main = ~ #A{1 2} {
//#A{a b}: ["A" a b]
//x: 123
//}
//data List { #Nil #Cons{head tail} }
//@Foo = #Cons{1 @Foo}
//@main = 50
//@main = λx
//!! @LOG(&{1 (+ x 1)})
//123
//@main = λt(t &0{&0{1 2} &0{3 4}} &0{&0{1 2} &0{3 4}})
//λa ((a 1) 1)
//λa ((a 2) 2)
//λa ((a 3) 3)
//λa ((a 4) 4)
//@foo(&a x) = ~ x {
//0: &a
//p: &a
//}
//@main = @foo(7 1)
//@main = λa
//@DUP((+ 5 7) a λx λy [x y])
//@DUP(11 @SUP(10 50 60) λa λb [a b])
//data Tree { #Leaf #Node{lft rgt} }
//@all(s) = ~s {
//0: #Leaf
//p: &0{ #Leaf #Node{@all(p) @all(p)} }
//}
//@main = @all(4)
//data Tree { #Leaf #Node{lft rgt} }
//@all(s l) = ~s {
//0:
//#Leaf
//p:
//!&0{p p0}=p
//!&0{p p1}=p
//!&0{l l0}=l
//!&0{l l1}=l
//!&0{l l2}=l
//! lL = (+ (* l1 2) 0)
//! lR = (+ (* l2 2) 1)
//@SUP(l0 #Leaf #Node{ @all(p0 lL) @all(p1 lR) })
//}
//@main = @all(4 1)
//@dyn(n lab) = ~n {
//0: 0
//p: !&0{l0 l1}=lab @SUP(l0 0 @dyn(p (+ l1 1)))
//}
//@main = @dyn(8 0)
//// Simple Function, `A -> B`
//@Fun(A B) = %f λx {(f {x::A}) :: B}
//// Dependent Function, `∀(x: A) -> (B x)`
//@All(A B) = %f λx !&0{x0 x1}=x {(f {x0::A}) :: (B x)}
//// main
//// : ∀A (A -> A) -> (A -> A)
//// = λf λx (f x)
//@main = λA
//! &0{A A0} = A
//! &0{A A1} = A
//! &0{A A2} = A
//! &0{A A3} = A
//! typ = @Fun(@Fun(A0 A1) @Fun(A2 A3))
//! val = λf λx (f x)
//{ val :: typ }
//@main = λA λB
//! &0{A A0} = A
//! &0{A A1} = A
//! &0{A A2} = A
//! &0{A A3} = A
//{ λf λx !&0{f0 f1}=f (f0 (f1 x))
//:: @Fun(@Fun(A0 A1) @Fun(A2 A3)) }
//@main = λA λB {λx x :: @Fun(A B)}
//@main = λA λB
//!&0{A0 A1}=A
//{λa λb (a b) :: %f λa λb {(f {a::A0} {b::B})::A1}}
//@count(n k) = ~n !k {
//0: k
//p: @count(p (+ k 2))
//}
//@main = @count(2_000_000_000 0)
//data L { #N #C{h t} }
//@foo = λx λa λb λc ~x !a !b !c {
//#N: λt(t a b c)
//#C{H T}: λt(t a b c H T)
//}
//@bar = λx ~x {
//0: 10
//1+p: p
//}
////@main = (+ (+ 2 3) 4)
////@main = (@bar 10)
////@main = (@foo #C{1 #C{2 #C{3 #N}}} 10 20 30)
////@main = λx ~x { #N: 0 #C{h t}: λK(K h t) }
////@main = λt(t (+ 1 (+ 2 (+ 3 4))) (+ 1 (+ 2 (+ 3 4))))
//@main = (+ 1 2)
//@true = λt λf t
//@false = λt λf f
//@not = λb ((b @false) @true)
//@dups = ! &1{ x y } = &0{ #12{} #24{} } &0{ y x }
//@main = (+ 10 ~7{ 0 1 2 λx x })
//@main = (* 100 123)
//@main = λt(t #5{(λx x 7)} λk k)
//@main = (λa λb(λt λf t &0{a b} &0{b a}) 1 2)
//@succ = λn λs λz (s n)
//@zero = λs λz z
//@mul2 = λn (n λp(@succ (@succ (@mul2 p))) @zero)
//@main = (@mul2 (@succ (@succ (@succ @zero))))
//@foo(x y) = #0{y x}
//@main = @foo(@foo(5 8) @foo(1 2))
//data List { #Nil #Cons{head tail} }
//@sum(xs r) = ~xs{
//#Nil: r
//#Cons: λhead λtail @sum(tail (+ head r))
//}
//@range(n xs) = ~n{
//0: xs
//p: !&0{p0 p1}=p @range(p0 #Cons{p1 xs})
//}
//@main =
//!list = #Cons{0 #Cons{1 #Cons{&0{10 20} #Cons{3 #Cons{4 #Cons{5 #Cons{6 #Cons{7 #Cons{8 #Cons{9 #Nil}}}}}}}}}}
//@sum(list 0)
//@main = !&0{a b}=(+ 1 2) λt(t a b)
================================================
FILE: src/HVM/API.hs
================================================
module HVM.API where
import Control.DeepSeq (deepseq)
import Control.Monad (when, forM_)
import Data.Word (Word64)
import Data.List (isPrefixOf)
import Foreign.LibFFI
import GHC.Clock
import HVM.Adjust
import HVM.Collapse
import HVM.Compile
import HVM.Extract
import HVM.Foreign
import HVM.Inject
import HVM.Parse
import HVM.Reduce
import HVM.Type
import System.Exit (exitWith, ExitCode(ExitFailure))
import System.IO (readFile')
import System.IO.Error (tryIOError)
import System.Posix.DynamicLinker
import System.Process (callCommand)
import Text.Printf
import qualified Data.Map.Strict as MS
data RunMode
= Normalize
| Collapse (Maybe Int)
deriving Eq
data RunStats = RunStats {
rsItrs :: Word64,
rsTime :: Double,
rsSize :: Word64,
rsPerf :: Double
}
-- Main external API for running HVM
runHVM :: FilePath -> Core -> RunMode -> IO ([Core], RunStats)
runHVM filePath root mode = do
code <- readFile' filePath
book <- doParseBook filePath code
hvmInit
initBook filePath book True
(vals, stats) <- runBook book root mode True False
hvmFree
return (vals, stats)
-- Initializes the runtime with the definitions from a book
initBook :: FilePath -> Book -> Bool -> IO ()
initBook filePath book compiled = do
forM_ (MS.toList (cidToAri book)) $ \(cid, ari) -> hvmSetCari cid (fromIntegral ari)
forM_ (MS.toList (cidToLen book)) $ \(cid, len) -> hvmSetClen cid (fromIntegral len)
forM_ (MS.toList (cidToADT book)) $ \(cid, adt) -> hvmSetCadt cid (fromIntegral adt)
forM_ (MS.toList (fidToFun book)) $ \(fid, ((_, args), _)) -> hvmSetFari fid (fromIntegral $ length args)
when compiled $ do
oPath <- compileBookToBin filePath book
dylib <- dlopen oPath [RTLD_NOW]
forM_ (MS.keys (fidToFun book)) $ \fid -> do
funPtr <- dlsym dylib (mget (fidToNam book) fid ++ "_f")
hvmDefine fid funPtr
hvmGotState <- hvmGetState
hvmSetState <- dlsym dylib "hvm_set_state"
callFFI hvmSetState retVoid [argPtr hvmGotState]
runBook :: Book -> Core -> RunMode -> Bool -> Bool -> IO ([Core], RunStats)
runBook book root mode compiled debug =
withRunStats $ do
injectRoot book root
rxAt <- if compiled
then return (reduceCAt debug)
else return (reduceAt debug)
vals <- case mode of
Collapse limit -> do
core <- doCollapseFlatAt rxAt book 0
let vals = maybe id Prelude.take limit core
vals `deepseq` return vals
Normalize -> do
core <- doExtractCoreAt rxAt book 0
let vals = [core]
vals `deepseq` return vals
return vals
compileBookToBin :: FilePath -> Book -> IO FilePath
compileBookToBin filePath book = do
-- Use the embedded runtime sources so compiled mode doesn't depend on CWD
let mainC = compileBook book runtime_c
callCommand "mkdir -p .build"
let fName = last $ words $ map (\c -> if c == '/' then ' ' else c) filePath
let cPath = ".build/" ++ fName ++ ".c"
let oPath = ".build/" ++ fName ++ ".so"
oldCFile <- tryIOError (readFile' cPath)
when (oldCFile /= Right mainC) $ do
writeFile cPath mainC
callCommand $ "gcc -O2 -fPIC -flto -shared " ++ cPath ++ " -o " ++ oPath
return oPath
injectRoot :: Book -> Core -> IO ()
injectRoot book root = do
let (book', root') = adjust "" book root []
doInjectCoreAt book' root' 0 []
return ()
withRunStats :: IO a -> IO (a, RunStats)
withRunStats action = do
init <- getMonotonicTimeNSec
res <- action
end <- getMonotonicTimeNSec
itrs <- getItr
size <- getLen
let time = fromIntegral (end - init) / (10^9) :: Double
let mips = (fromIntegral itrs / 1000000.0) / time
let stats = RunStats { rsItrs = itrs, rsSize = size , rsTime = time, rsPerf = mips }
return (res, stats)
instance Show RunStats where
show stats = printf "WORK: %llu interactions\n" (rsItrs stats) ++
printf "TIME: %.7f seconds\n" (rsTime stats) ++
printf "SIZE: %llu nodes\n" (rsSize stats) ++
printf "PERF: %.3f MIPS\n" (rsPerf stats)
================================================
FILE: src/HVM/Adjust.hs
================================================
module HVM.Adjust where
import Control.Monad
import Control.Monad.State
import Data.List (sortOn)
import Data.Word
import HVM.Type
import qualified Data.Map as MS
import Debug.Trace (trace)
-- External API
----------------
adjustBook :: Book -> Book
adjustBook book = foldr adjustFunc book (MS.toList (fidToFun book))
adjustFunc :: (Word16, Func) -> Book -> Book
adjustFunc (fid, ((cp, ars), cr)) book =
let nam = mget (fidToNam book) fid in
let (b', cr') = adjust nam book cr (map snd ars) in
let ars' = map (\(s, n) -> (s, stripName n)) ars in
b' { fidToFun = MS.insert fid ((cp, ars'), cr') (fidToFun b') }
adjust :: Name -> Book -> Core -> [String] -> (Book, Core)
adjust orig book term binds =
let termA = setRefIds (namToFid book) term
termB = setCtrIds (ctrToCid book) (cidToADT book) termA
termC = sortCases (ctrToCid book) termB
(fr, termD) = insertDups (freshLab book) binds termC
termE = lexify termD
termF = validate orig book termE
in (book { freshLab = fr }, termF)
-- Adjusters
-------------
-- Adds the function id to Ref constructors
setRefIds :: MS.Map String Word16 -> Core -> Core
setRefIds fids term = go term
where
go :: Core -> Core
go (Var nam) = Var nam
go (Let m x v b) = Let m x (go v) (go b)
go (Lam x bod) = Lam x (go bod)
go (App f x) = App (go f) (go x)
go (Sup l x y) = Sup l (go x) (go y)
go (Dup l x y v b) = Dup l x y (go v) (go b)
go (Ctr nam fds) = Ctr nam (map go fds)
go (Mat k x mov css) = Mat k (go x) (map (\ (k,v) -> (k, go v)) mov) (map (\ (ctr,fds,cs) -> (ctr, fds, go cs)) css)
go (Op2 op x y) = Op2 op (go x) (go y)
go (U32 n) = U32 n
go (Chr c) = Chr c
go Era = Era
go (Inc x) = Inc (go x)
go (Dec x) = Dec (go x)
go (Ref nam fid arg) =
case MS.lookup nam fids of
Just fid -> Ref nam fid (map go arg)
Nothing -> error $ "Unknown function: " ++ show nam
-- Adds the constructor id to Mat and IFL terms
setCtrIds :: MS.Map String Word16 -> MS.Map Word16 Word16 -> Core -> Core
setCtrIds cids adts term = go term
where
go :: Core -> Core
go (Var nam) = Var nam
go (Let m x v b) = Let m x (go v) (go b)
go (Lam x bod) = Lam x (go bod)
go (App f x) = App (go f) (go x)
go (Sup l x y) = Sup l (go x) (go y)
go (Dup l x y v b) = Dup l x y (go v) (go b)
go (Ctr nam fds) = Ctr nam (map go fds)
go (Mat k x mov css) = Mat k' (go x) mov' css' where
getCtr (ctr, _, _) = ctr
mov' = map (\(k,v) -> (k, go v)) mov
css' = map (\(ctr,fds,cs) -> (ctr, fds, go cs)) css
k' = case k of
SWI -> SWI
MAT _ -> MAT (mget adts (mget cids (getCtr (head css))))
IFL _ -> IFL (mget cids (getCtr (head css)))
_ -> k
go (Op2 op x y) = Op2 op (go x) (go y)
go (U32 n) = U32 n
go (Chr c) = Chr c
go Era = Era
go (Inc x) = Inc (go x)
go (Dec x) = Dec (go x)
go (Ref nam fid arg) = Ref nam fid (map go arg)
-- Sorts match cases by constructor ID or numeric value
sortCases :: MS.Map String Word16 -> Core -> Core
sortCases cids term = go term
where
go :: Core -> Core
go (Var nam) = Var nam
go (Let m x v b) = Let m x (go v) (go b)
go (Lam x bod) = Lam x (go bod)
go (App f x) = App (go f) (go x)
go (Sup l x y) = Sup l (go x) (go y)
go (Dup l x y v b) = Dup l x y (go v) (go b)
go (Ctr nam fds) = Ctr nam (map go fds)
go (Mat k x mov css) = Mat k (go x) mov' css' where
mov' = map (\(k,v) -> (k, go v)) mov
css' = map (\(ctr,fds,bod) -> (ctr, fds, go bod)) sort
sort = sortOn sortKey css
sortKey (name, _, _) =
case name of
('#':_) -> case MS.lookup name cids of
Nothing -> maxBound
Just id -> id
_ -> case reads name of
[(num :: Word16, "")] -> num
_ -> maxBound
go (Op2 op x y) = Op2 op (go x) (go y)
go (U32 n) = U32 n
go (Chr c) = Chr c
go Era = Era
go (Inc x) = Inc (go x)
go (Dec x) = Dec (go x)
go (Ref nam fid arg) = Ref nam fid (map go arg)
-- Inserts Dup nodes for vars that have been used more than once.
-- Renames vars according to the new Dup bindings.
-- Gives fresh labels to the new Dup nodes.
insertDups :: Lab -> [String] -> Core -> (Lab, Core)
insertDups fresh binds term =
let (term', (fresh', _)) = runState (withBinds binds term) (fresh, MS.empty)
in (fresh', term')
where
go :: Core -> State (Lab, MS.Map String [String]) Core
go (Var nam) = do
nam <- useVar nam
return $ (Var nam)
go (Let m x v b) = do
v <- go v
b <- withBinds [x] b
return $ Let m (stripName x) v b
go (Lam x bod) = do
bod <- withBinds [x] bod
return $ Lam (stripName x) bod
go (App fun arg) = do
fun <- go fun
arg <- go arg
return $ App fun arg
go (Sup lab tm0 tm1) = do
tm0 <- go tm0
tm1 <- go tm1
return $ Sup lab tm0 tm1
go (Dup lab x y v b) = do
v <- go v
b <- withBinds [x, y] b
return $ Dup lab (stripName x) (stripName y) v b
go (Ctr nam fds) = do
fds <- mapM go fds
return $ Ctr nam fds
go (Mat k x mov css) = do
x <- go x
mov <- forM mov (\(k,v) -> do
v <- go v
return (k, v))
css <- forM css (\(ctr,fds,bod) -> do
bod <- withBinds ((map fst mov) ++ fds) bod
return (ctr, map stripName fds, bod))
let mov' = map (\(k,v) -> (stripName k, v)) mov
return $ Mat k x mov' css
go (Op2 op x y) = do
x <- go x
y <- go y
return $ Op2 op x y
go (U32 n) = do
return $ U32 n
go (Chr c) = do
return $ Chr c
go Era = do
return Era
go (Inc x) = do
x <- go x
return $ Inc x
go (Dec x) = do
x <- go x
return $ Dec x
go (Ref nam fid arg) = do
arg <- mapM go arg
return $ Ref nam fid arg
-- Recurses on the body of a term that binds variables.
-- Adds Dups if the new vars are used more than once.
withBinds :: [String] -> Core -> State (Lab, MS.Map String [String]) Core
withBinds vars term = do
(lab, prev) <- get
-- Add the new binds
let bfor = foldr addVar prev vars
put (lab, bfor)
term <- go term
term <- foldM applyDups term vars
-- Remove the new binds
(lab, aftr) <- get
let next = foldr (restoreVar prev) (foldr remVar aftr vars) vars
put (lab, next)
return term
where
addVar var uses = MS.insert (stripName var) [] uses
remVar var uses = MS.delete (stripName var) uses
restoreVar old var new =
case MS.lookup (stripName var) old of
Just val -> MS.insert (stripName var) val new
Nothing -> new
applyDups :: Core -> String -> State (Lab, MS.Map String [String]) Core
applyDups body var = do
(_, uses) <- get
let vUse = mget uses (stripName var)
when ((head var /= '&') && (length vUse > 1)) $
error $ "Linear variable " ++ show var ++ " used " ++ show (length vUse) ++ " times"
case (reverse vUse) of
[] -> do
return body
[_] -> do
return body
(name:dups) -> do
foldM (\acc currName -> do
label <- genFresh
return $ Dup label name currName (Var name) acc) body dups
genFresh :: State (Lab, MS.Map String [String]) Lab
genFresh = do
(lab, _) <- get
when (lab > 0x7FFF) $ do
error "Label overflow: generated label would be too large"
modify (\(lab, uses) -> (lab + 1, uses))
return $ 0x8000 + lab
useVar :: String -> State (Lab, MS.Map String [String]) String
useVar nam@('$':_) = do
return nam
useVar nam = do
(_, uses) <- get
case mget uses nam of
[] -> do
modify (\(lab, uses) -> (lab, MS.insert nam [nam] uses))
return nam
vUse -> do
let dupNam = nam ++ "$dup" ++ show (length vUse)
modify (\(lab, uses) -> (lab, MS.insert nam (dupNam : vUse) uses))
return dupNam
-- Strip the & prefix from a non-linear variable name
-- e.g., "&x" -> "x", "x" -> "x"
stripName :: String -> String
stripName ('&':nam) = nam
stripName nam = nam
-- Gives unique names to lexically scoped vars, unless they start with '$'.
-- Example: `λx λt (t λx(x) x)` will read as `λx0 λt1 (t1 λx2(x2) x0)`.
lexify :: Core -> Core
lexify term = evalState (go term MS.empty) 0 where
fresh :: String -> State Int String
fresh nam@('$':_) = return $ nam
fresh nam = do i <- get; put (i+1); return $ nam++"$"++show i
extend :: String -> String -> MS.Map String String -> State Int (MS.Map String String)
extend old@('$':_) new ctx = return $ ctx
extend old new ctx = return $ MS.insert old new ctx
go :: Core -> MS.Map String String -> State Int Core
go term ctx = case term of
Var nam ->
return $ Var (MS.findWithDefault nam nam ctx)
Ref nam fid arg -> do
arg <- mapM (\x -> go x ctx) arg
return $ Ref nam fid arg
Let mod nam val bod -> do
val <- go val ctx
nam' <- fresh nam
ctx <- extend nam nam' ctx
bod <- go bod ctx
return $ Let mod nam' val bod
Lam nam bod -> do
nam' <- fresh nam
ctx <- extend nam nam' ctx
bod <- go bod ctx
return $ Lam nam' bod
App fun arg -> do
fun <- go fun ctx
arg <- go arg ctx
return $ App fun arg
Sup lab tm0 tm1 -> do
tm0 <- go tm0 ctx
tm1 <- go tm1 ctx
return $ Sup lab tm0 tm1
Dup lab dp0 dp1 val bod -> do
val <- go val ctx
dp0' <- fresh dp0
dp1' <- fresh dp1
ctx <- extend dp0 dp0' ctx
ctx <- extend dp1 dp1' ctx
bod <- go bod ctx
return $ Dup lab dp0' dp1' val bod
Ctr nam fds -> do
fds <- mapM (\x -> go x ctx) fds
return $ Ctr nam fds
Mat kin val mov css -> do
val' <- go val ctx
mov' <- forM mov $ \ (k,v) -> do
k' <- fresh k
v <- go v ctx
return $ (k', v)
css' <- forM css $ \ (ctr,fds,bod) -> do
fds' <- mapM fresh fds
ctx <- foldM (\ ctx (fd,fd') -> extend fd fd' ctx) ctx (zip fds fds')
ctx <- foldM (\ ctx ((k,_),(k',_)) -> extend k k' ctx) ctx (zip mov mov')
bod <- go bod ctx
return (ctr, fds', bod)
return $ Mat kin val' mov' css'
Op2 op nm0 nm1 -> do
nm0 <- go nm0 ctx
nm1 <- go nm1 ctx
return $ Op2 op nm0 nm1
U32 n ->
return $ U32 n
Chr c ->
return $ Chr c
Era ->
return Era
Inc x -> do
x <- go x ctx
return $ Inc x
Dec x -> do
x <- go x ctx
return $ Dec x
validate :: Name -> Book -> Core -> Core
validate orig book term = go term where
go :: Core -> Core
go (Var nam) = Var nam
go (Let m x v b) = Let m x (go v) (go b)
go (Lam x bod) = Lam x (go bod)
go (App f x) = App (go f) (go x)
go (Sup l x y) = Sup l (go x) (go y)
go (Dup l x y v b) = Dup l x y (go v) (go b)
go (Ctr nam fds) =
case MS.lookup nam (ctrToCid book) of
Nothing ->
error $ header ++ "Unknown constructor: " ++ show nam
Just cid ->
if length fds /= fromIntegral (mget (cidToAri book) cid) then
error $ header ++ "Arity mismatch on Ctr: " ++ show (Ctr nam fds) ++ ". " ++ "Expected " ++ show (mget (cidToAri book) cid) ++ " arguments, got " ++ show (length fds)
else
Ctr nam (map go fds)
go (Mat k x mov css) =
if not uniqueCss then error $ header ++ "Duplicate match case: " ++ show (Mat k x mov css) ++ "."
else Mat k (go x) mov' css'
where
mov' = map (\(k,v) -> (k, go v)) mov
css' = map (\(ctr,fds,bod) -> (ctr, fds, go bod)) css
ctrs = map (\(ctr, _, _) -> ctr) css
uniqueCss = null (filter (\ctr -> length (filter (== ctr) ctrs) > 1) ctrs)
go (Op2 op x y) = Op2 op (go x) (go y)
go (U32 n) = U32 n
go (Chr c) = Chr c
go Era = Era
go (Inc x) = Inc (go x)
go (Dec x) = Dec (go x)
go (Ref nam fid arg) =
if not ariOk then
error $ header ++ "Arity mismatch on Ref: " ++ show (Ref nam fid arg) ++ ". " ++ "Expected " ++ show (funArity book fid) ++ " arguments, got " ++ show (length arg)
else
Ref nam fid (map go arg)
where
ariOk = length arg == fromIntegral (funArity book fid)
header = if null orig then "" else "In function @" ++ orig ++ ": "
================================================
FILE: src/HVM/Collapse.hs
================================================
{-./Type.hs-}
{-# LANGUAGE BangPatterns #-}
module HVM.Collapse where
import Control.Monad (ap, forM, forM_)
import Control.Monad.IO.Class
import Data.Char (chr, ord)
import Data.IORef
import Data.Bits ((.&.), xor, (.|.), complement, shiftR)
import Data.Word
import Debug.Trace
import GHC.Conc
import HVM.Foreign
import HVM.Type
import System.Exit (exitFailure)
import System.IO.Unsafe (unsafeInterleaveIO)
import qualified Data.IntMap.Strict as IM
import qualified Data.Map.Strict as MS
-- The Collapse Monad
-- ------------------
-- See: https://gist.github.com/VictorTaelin/60d3bc72fb4edefecd42095e44138b41
-- A bit-string
data Bin
= O Bin
| I Bin
| E
deriving Show
-- A Collapse is a tree of superposed values
data Collapse a
= CSup !Lab (Collapse a) (Collapse a)
| CInc (Collapse a)
| CDec (Collapse a)
| CVal !a
| CEra
deriving Show
bind :: Collapse a -> (a -> Collapse b) -> Collapse b
bind k f = fork k IM.empty where
-- fork :: Collapse a -> IntMap (Bin -> Bin) -> Collapse b
fork CEra paths = CEra
fork (CVal v) paths = pass (f v) (IM.map (\x -> x E) paths)
fork (CInc x) paths = CInc (fork x paths)
fork (CDec x) paths = CDec (fork x paths)
fork (CSup k x y) paths =
let lft = fork x $ IM.alter (\x -> Just (maybe (putO id) putO x)) (fromIntegral k) paths in
let rgt = fork y $ IM.alter (\x -> Just (maybe (putI id) putI x)) (fromIntegral k) paths in
CSup k lft rgt
-- pass :: Collapse b -> IntMap Bin -> Collapse b
pass CEra paths = CEra
pass (CVal v) paths = CVal v
pass (CInc x) paths = CInc (pass x paths)
pass (CDec x) paths = CDec (pass x paths)
pass (CSup k x y) paths = case IM.lookup (fromIntegral k) paths of
Just (O p) -> pass x (IM.insert (fromIntegral k) p paths)
Just (I p) -> pass y (IM.insert (fromIntegral k) p paths)
Just E -> CSup k (pass x paths) (pass y paths)
Nothing -> CSup k (pass x paths) (pass y paths)
-- putO :: (Bin -> Bin) -> (Bin -> Bin)
putO bs = \x -> bs (O x)
-- putI :: (Bin -> Bin) -> (Bin -> Bin)
putI bs = \x -> bs (I x)
instance Functor Collapse where
fmap f (CVal v) = CVal (f v)
fmap f (CSup k x y) = CSup k (fmap f x) (fmap f y)
fmap f (CInc x) = CInc (fmap f x)
fmap f (CDec x) = CDec (fmap f x)
fmap _ CEra = CEra
instance Applicative Collapse where
pure = CVal
(<*>) = ap
instance Monad Collapse where
return = pure
(>>=) = bind
-- Dup Collapser
-- -------------
collapseDupsAt :: IM.IntMap [Int] -> ReduceAt -> Book -> Loc -> HVM Core
collapseDupsAt state@(paths) reduceAt book host = unsafeInterleaveIO $ do
term <- reduceAt book host
case termTag term of
t | t == _ERA_ -> do
return Era
t | t == _LET_ -> do
let loc = termLoc term
let mode = modeT (termLab term)
name <- return $ "$" ++ show (loc + 0)
val0 <- collapseDupsAt state reduceAt book (loc + 1)
bod0 <- collapseDupsAt state reduceAt book (loc + 2)
return $ Let mode name val0 bod0
t | t == _LAM_ -> do
let loc = termLoc term
name <- return $ "$" ++ show (loc + 0)
bod0 <- collapseDupsAt state reduceAt book (loc + 0)
return $ Lam name bod0
t | t == _APP_ -> do
let loc = termLoc term
fun0 <- collapseDupsAt state reduceAt book (loc + 0)
arg0 <- collapseDupsAt state reduceAt book (loc + 1)
return $ App fun0 arg0
t | t == _SUP_ -> do
let loc = termLoc term
let lab = termLab term
case IM.lookup (fromIntegral lab) paths of
Just (p:ps) -> do
let newPaths = IM.insert (fromIntegral lab) ps paths
collapseDupsAt (newPaths) reduceAt book (loc + fromIntegral p)
_ -> do
tm00 <- collapseDupsAt state reduceAt book (loc + 0)
tm11 <- collapseDupsAt state reduceAt book (loc + 1)
return $ Sup lab tm00 tm11
t | t == _VAR_ -> do
let loc = termLoc term
sub <- got loc
if termGetBit sub /= 0
then do
set (loc + 0) (termRemBit sub)
collapseDupsAt state reduceAt book (loc + 0)
else do
name <- return $ "$" ++ show loc
return $ Var name
t | t == _DP0_ -> do
let loc = termLoc term
let lab = termLab term
sb0 <- got (loc+0)
if termGetBit sb0 /= 0
then do
set (loc + 0) (termRemBit sb0)
collapseDupsAt state reduceAt book (loc + 0)
else do
let newPaths = IM.alter (Just . maybe [0] (0:)) (fromIntegral lab) paths
collapseDupsAt (newPaths) reduceAt book (loc + 0)
t | t == _DP1_ -> do
let loc = termLoc term
let lab = termLab term
sb1 <- got (loc+0)
if termGetBit sb1 /= 0
then do
set (loc + 0) (termRemBit sb1)
collapseDupsAt state reduceAt book (loc + 0)
else do
let newPaths = IM.alter (Just . maybe [1] (1:)) (fromIntegral lab) paths
collapseDupsAt (newPaths) reduceAt book (loc + 0)
t | t == _CTR_ -> do
let loc = termLoc term
let lab = termLab term
let cid = fromIntegral lab
let nam = MS.findWithDefault "?" cid (cidToCtr book)
let ari = mget (cidToAri book) cid
let aux = if ari == 0 then [] else [0 .. ari-1]
fds0 <- forM aux (\i -> collapseDupsAt state reduceAt book (loc + fromIntegral i))
return $ Ctr nam fds0
t | t == _MAT_ -> do
let loc = termLoc term
let lab = termLab term
let cid = fromIntegral lab
let len = fromIntegral $ mget (cidToLen book) cid
val0 <- collapseDupsAt state reduceAt book (loc + 0)
css0 <- forM [0..len-1] $ \i -> do
let ctr = mget (cidToCtr book) (cid + i)
let ari = fromIntegral $ mget (cidToAri book) (cid + i)
let fds = if ari == 0 then [] else ["$" ++ show (loc + 1 + j) | j <- [0..ari-1]]
bod0 <- collapseDupsAt state reduceAt book (loc + 1 + fromIntegral i)
return (ctr, fds, bod0)
return $ Mat (MAT cid) val0 [] css0
t | t == _IFL_ -> do
let loc = termLoc term
let lab = termLab term
let cid = fromIntegral lab
val0 <- collapseDupsAt state reduceAt book (loc + 0)
cs00 <- collapseDupsAt state reduceAt book (loc + 1)
cs10 <- collapseDupsAt state reduceAt book (loc + 2)
return $ Mat (IFL cid) val0 [] [(mget (cidToCtr book) cid, [], cs00), ("_", [], cs10)]
t | t == _SWI_ -> do
let loc = termLoc term
let lab = termLab term
let len = fromIntegral lab
val0 <- collapseDupsAt state reduceAt book (loc + 0)
css0 <- forM [0..len-1] $ \i -> do
bod0 <- collapseDupsAt state reduceAt book (loc + 1 + i)
return (show i, [], bod0)
return $ Mat SWI val0 [] css0
t | t == _W32_ -> do
let val = termLoc term
return $ U32 (fromIntegral val)
t | t == _CHR_ -> do
let val = termLoc term
return $ Chr (chr (fromIntegral val))
t | t == _OPX_ -> do
let loc = termLoc term
let opr = toEnum (fromIntegral (termLab term))
nm00 <- collapseDupsAt state reduceAt book (loc + 0)
nm10 <- collapseDupsAt state reduceAt book (loc + 1)
return $ Op2 opr nm00 nm10
t | t == _OPY_ -> do
let loc = termLoc term
let opr = toEnum (fromIntegral (termLab term))
nm00 <- collapseDupsAt state reduceAt book (loc + 0)
nm10 <- collapseDupsAt state reduceAt book (loc + 1)
return $ Op2 opr nm00 nm10
t | t == _REF_ -> do
let loc = termLoc term
let lab = termLab term
let fid = fromIntegral lab
let ari = fromIntegral (funArity book fid)
arg0 <- forM [0..ari-1] (\i -> collapseDupsAt state reduceAt book (loc + i))
let name = MS.findWithDefault "?" fid (fidToNam book)
return $ Ref name fid arg0
t | t == _INC_ -> do
let loc = termLoc term
val0 <- collapseDupsAt state reduceAt book (loc + 0)
return $ Inc val0
t | t == _DEC_ -> do
let loc = termLoc term
val0 <- collapseDupsAt state reduceAt book (loc + 0)
return $ Dec val0
tag -> do
return $ Var "?"
-- exitFailure
-- Sup Collapser
-- -------------
collapseSups :: Book -> Core -> Collapse Core
collapseSups book core = case core of
Var name -> do
return $ Var name
Ref name fid args -> do
args <- mapM (collapseSups book) args
return $ Ref name fid args
Lam name body -> do
body <- collapseSups book body
return $ Lam name body
App fun arg -> do
fun <- collapseSups book fun
arg <- collapseSups book arg
return $ App fun arg
Dup lab x y val body -> do
val <- collapseSups book val
body <- collapseSups book body
return $ Dup lab x y val body
Ctr nam fields -> do
fields <- mapM (collapseSups book) fields
return $ Ctr nam fields
Mat kin val mov css -> do
val <- collapseSups book val
mov <- mapM (\(key, expr) -> do
expr <- collapseSups book expr
return (key, expr)) mov
css <- mapM (\(ctr, fds, bod) -> do
bod <- collapseSups book bod
return (ctr, fds, bod)) css
return $ Mat kin val mov css
U32 val -> do
return $ U32 val
Chr val -> do
return $ Chr val
Op2 op x y -> do
x <- collapseSups book x
y <- collapseSups book y
return $ Op2 op x y
Let mode name val body -> do
val <- collapseSups book val
body <- collapseSups book body
return $ Let mode name val body
Era -> do
CEra
Sup lab tm0 tm1 -> do
let tm0' = collapseSups book tm0
let tm1' = collapseSups book tm1
CSup lab tm0' tm1'
Inc val -> do
let val' = collapseSups book val
CInc val'
Dec val -> do
let val' = collapseSups book val
CDec val'
-- Tree Collapser
-- --------------
doCollapseAt :: ReduceAt -> Book -> Loc -> HVM (Collapse Core)
doCollapseAt reduceAt book host = do
-- namesRef <- newIORef MS.empty
let state = (IM.empty)
core <- collapseDupsAt state reduceAt book host
return $ collapseSups book core
-- Simple Queue
-- ------------
-- Allows pushing to an end, and popping from another.
-- Simple purely functional implementation.
-- Includes sqPop and sqPut.
data SQ a = SQ [a] [a]
sqNew :: SQ a
sqNew = SQ [] []
sqPop :: SQ a -> Maybe (a, SQ a)
sqPop (SQ [] []) = Nothing
sqPop (SQ [] ys) = sqPop (SQ (reverse ys) [])
sqPop (SQ (x:xs) ys) = Just (x, SQ xs ys)
sqPut :: a -> SQ a -> SQ a
sqPut x (SQ xs ys) = SQ xs (x:ys)
-- Priority Queue
-- --------------
-- A stable min-heap implemented with a radix tree.
-- Orders by an Int priority and a unique Word64 key.
-- Based on IntPSQ from the the psqueues library (https://hackage.haskell.org/package/psqueues-0.2.8.1)
data PQ p v
= Bin !Word64 !p v !Word64 !(PQ p v) !(PQ p v)
| Tip !Word64 !p v
| Nil
pqPush :: Ord p => Word64 -> p -> v -> PQ p v -> PQ p v
pqPush k1 p1 x1 t = case t of
Nil -> Tip k1 p1 x1
(Tip k2 p2 x2)
| (p1, k1) < (p2, k2) -> link k1 p1 x1 k2 (Tip k2 p2 x2) Nil
| otherwise -> link k2 p2 x2 k1 (Tip k1 p1 x1) Nil
(Bin k2 p2 x2 m l r)
| nomatch k1 k2 m, (p1, k1) < (p2, k2) -> link k1 p1 x1 k2 (Bin k2 p2 x2 m l r) Nil
| nomatch k1 k2 m -> link k2 p2 x2 k1 (Tip k1 p1 x1) (pqMerge m l r)
| (p1, k1) < (p2, k2), zero k2 m -> Bin k1 p1 x1 m (pqPush k2 p2 x2 l) r
| (p1, k1) < (p2, k2) -> Bin k1 p1 x1 m l (pqPush k2 p2 x2 r)
| zero k1 m -> Bin k2 p2 x2 m (pqPush k1 p1 x1 l) r
| otherwise -> Bin k2 p2 x2 m l (pqPush k1 p1 x1 r)
where
nomatch :: Word64 -> Word64 -> Word64 -> Bool
nomatch k1 k2 m =
let maskW = complement (m-1) `xor` m
in (k1 .&. maskW) /= (k2 .&. maskW)
zero :: Word64 -> Word64 -> Bool
zero i m = i .&. m == 0
link :: Word64 -> p -> v -> Word64 -> (PQ p v) -> (PQ p v) -> (PQ p v)
link k p x k' fst snd =
let m = highestBitMask (k `xor` k')
in if zero m k'
then Bin k p x m fst snd
else Bin k p x m snd fst
highestBitMask :: Word64 -> Word64
highestBitMask x1 =
let x2 = x1 .|. x1 `shiftR` 1
x3 = x2 .|. x2 `shiftR` 2
x4 = x3 .|. x3 `shiftR` 4
x5 = x4 .|. x4 `shiftR` 8
x6 = x5 .|. x5 `shiftR` 16
x7 = x6 .|. x6 `shiftR` 32
in x7 `xor` (x7 `shiftR` 1)
pqPop :: Ord p => PQ p v -> Maybe (Word64, p, v, PQ p v)
pqPop t = case t of
Nil -> Nothing
Tip k p x -> Just (k, p, x, Nil)
Bin k p x m l r -> Just (k, p, x, pqMerge m l r)
pqMerge :: Ord p => Word64 -> PQ p v -> PQ p v -> PQ p v
pqMerge m l r = case (l, r) of
(Nil, r) -> r
(l, Nil) -> l
(Tip lk lp lx, Tip rk rp rx)
| (lp, lk) < (rp, rk) -> Bin lk lp lx m Nil r
| otherwise -> Bin rk rp rx m l Nil
(Tip lk lp lx, Bin rk rp rx rm rl rr)
| (lp, lk) < (rp, rk) -> Bin lk lp lx m Nil r
| otherwise -> Bin rk rp rx m l (pqMerge rm rl rr)
(Bin lk lp lx lm ll lr, Tip rk rp rx)
| (lp, lk) < (rp, rk) -> Bin lk lp lx m (pqMerge lm ll lr) r
| otherwise -> Bin rk rp rx m l Nil
(Bin lk lp lx lm ll lr, Bin rk rp rx rm rl rr)
| (lp, lk) < (rp, rk) -> Bin lk lp lx m (pqMerge lm ll lr) r
| otherwise -> Bin rk rp rx m l (pqMerge rm rl rr)
-- Flattener
-- ---------
flattenDFS :: Collapse a -> [a]
flattenDFS (CSup k a b) = flatten a ++ flatten b
flattenDFS (CVal x) = [x]
flattenDFS (CInc x) = flattenDFS x
flattenDFS (CDec x) = flattenDFS x
flattenDFS CEra = []
flattenBFS :: Collapse a -> [a]
flattenBFS term = go term (sqNew :: SQ (Collapse a)) where
go (CSup k a b) sq = go CEra (sqPut b $ sqPut a $ sq)
go (CVal x) sq = x : go CEra sq
go (CInc x) sq = go x sq
go (CDec x) sq = go x sq
go CEra sq = case sqPop sq of
Just (v,sq) -> go v sq
Nothing -> []
-- Priority-Queue Flattener
-- ------------------------
-- * priority starts at 0
-- * since PQ is a min-queue, we invert the scoers:
-- * passing through (CInc t) subs 1 ; (CDec t) adds 1
-- * when no Inc/Dec are present every node has priority == depth
-- hence the order matches plain BFS exactly (stable heap).
flattenPRI :: Collapse a -> [a]
flattenPRI term = go 1 (Tip 0 0 term) where
go i pq = case pqPop pq of
Nothing -> []
Just (_, pri, node, pq') -> case node of
CEra -> go i pq'
CVal v -> v : go i pq'
CInc t -> go (i + 1) (pqPush i (pri - 1) t pq')
CDec t -> go (i + 1) (pqPush i (pri + 1) t pq')
CSup _ a b ->
let pq1 = (pqPush (i + 0) (pri + 1) a pq')
pq2 = (pqPush (i + 1) (pri + 1) b pq1)
in go (i + 2) pq2
-- Default Flattener
-- -----------------
flatten :: Collapse a -> [a]
flatten = flattenPRI
-- Flat Collapser
-- --------------
doCollapseFlatAt :: ReduceAt -> Book -> Loc -> HVM [Core]
doCollapseFlatAt reduceAt book host = do
coll <- doCollapseAt reduceAt book host
return $ flatten coll
================================================
FILE: src/HVM/Compile.hs
================================================
{-./../IC.md-}
{-./Type.hs-}
{-./Inject.hs-}
{-# LANGUAGE TemplateHaskell #-}
module HVM.Compile where
import Control.Monad (forM_, forM, foldM, when)
import Control.Monad.State
import Data.Bits (shiftL, (.|.))
import Data.List
import Data.Word
import Data.FileEmbed
import Debug.Trace
import HVM.Foreign hiding (fresh)
import HVM.Type
import qualified Data.Map.Strict as MS
-- The Runtime.c file content embedded in the binary
-- Embed the entire runtime as a single translation unit for compiled mode.
-- We inline Runtime.h and concatenate all .c modules with the include line removed.
runtime_h :: String
runtime_h = $(embedStringFile "./src/HVM/Runtime.h")
rt_state_c :: String; rt_state_c = $(embedStringFile "./src/HVM/runtime/state.c")
rt_heap_c :: String; rt_heap_c = $(embedStringFile "./src/HVM/runtime/heap.c")
rt_term_c :: String; rt_term_c = $(embedStringFile "./src/HVM/runtime/term.c")
rt_stack_c :: String; rt_stack_c = $(embedStringFile "./src/HVM/runtime/stack.c")
rt_print_c :: String; rt_print_c = $(embedStringFile "./src/HVM/runtime/print.c")
rt_memory_c :: String; rt_memory_c = $(embedStringFile "./src/HVM/runtime/memory.c")
rt_reduce_c :: String; rt_reduce_c = $(embedStringFile "./src/HVM/runtime/reduce.c")
rt_pr_SUP_c :: String; rt_pr_SUP_c = $(embedStringFile "./src/HVM/runtime/prim/SUP.c")
rt_pr_DUP_c :: String; rt_pr_DUP_c = $(embedStringFile "./src/HVM/runtime/prim/DUP.c")
rt_pr_LOG_c :: String; rt_pr_LOG_c = $(embedStringFile "./src/HVM/runtime/prim/LOG.c")
rt_red_app_ctr :: String; rt_red_app_ctr = $(embedStringFile "./src/HVM/runtime/reduce/app_ctr.c")
rt_red_app_era :: String; rt_red_app_era = $(embedStringFile "./src/HVM/runtime/reduce/app_era.c")
rt_red_app_lam :: String; rt_red_app_lam = $(embedStringFile "./src/HVM/runtime/reduce/app_lam.c")
rt_red_app_sup :: String; rt_red_app_sup = $(embedStringFile "./src/HVM/runtime/reduce/app_sup.c")
rt_red_app_una :: String; rt_red_app_una = $(embedStringFile "./src/HVM/runtime/reduce/app_una.c")
rt_red_app_w32 :: String; rt_red_app_w32 = $(embedStringFile "./src/HVM/runtime/reduce/app_w32.c")
rt_red_dup_ctr :: String; rt_red_dup_ctr = $(embedStringFile "./src/HVM/runtime/reduce/dup_ctr.c")
rt_red_dup_era :: String; rt_red_dup_era = $(embedStringFile "./src/HVM/runtime/reduce/dup_era.c")
rt_red_dup_lam :: String; rt_red_dup_lam = $(embedStringFile "./src/HVM/runtime/reduce/dup_lam.c")
rt_red_dup_ref :: String; rt_red_dup_ref = $(embedStringFile "./src/HVM/runtime/reduce/dup_ref.c")
rt_red_dup_sup :: String; rt_red_dup_sup = $(embedStringFile "./src/HVM/runtime/reduce/dup_sup.c")
rt_red_dup_una :: String; rt_red_dup_una = $(embedStringFile "./src/HVM/runtime/reduce/dup_una.c")
rt_red_dup_w32 :: String; rt_red_dup_w32 = $(embedStringFile "./src/HVM/runtime/reduce/dup_w32.c")
rt_red_let :: String; rt_red_let = $(embedStringFile "./src/HVM/runtime/reduce/let.c")
rt_red_ref :: String; rt_red_ref = $(embedStringFile "./src/HVM/runtime/reduce/ref.c")
rt_red_ref_sup :: String; rt_red_ref_sup = $(embedStringFile "./src/HVM/runtime/reduce/ref_sup.c")
rt_red_mat_ctr :: String; rt_red_mat_ctr = $(embedStringFile "./src/HVM/runtime/reduce/mat_ctr.c")
rt_red_mat_era :: String; rt_red_mat_era = $(embedStringFile "./src/HVM/runtime/reduce/mat_era.c")
rt_red_mat_lam :: String; rt_red_mat_lam = $(embedStringFile "./src/HVM/runtime/reduce/mat_lam.c")
rt_red_mat_sup :: String; rt_red_mat_sup = $(embedStringFile "./src/HVM/runtime/reduce/mat_sup.c")
rt_red_mat_una :: String; rt_red_mat_una = $(embedStringFile "./src/HVM/runtime/reduce/mat_una.c")
rt_red_mat_w32 :: String; rt_red_mat_w32 = $(embedStringFile "./src/HVM/runtime/reduce/mat_w32.c")
rt_red_opx_ctr :: String; rt_red_opx_ctr = $(embedStringFile "./src/HVM/runtime/reduce/opx_ctr.c")
rt_red_opx_era :: String; rt_red_opx_era = $(embedStringFile "./src/HVM/runtime/reduce/opx_era.c")
rt_red_opx_lam :: String; rt_red_opx_lam = $(embedStringFile "./src/HVM/runtime/reduce/opx_lam.c")
rt_red_opx_sup :: String; rt_red_opx_sup = $(embedStringFile "./src/HVM/runtime/reduce/opx_sup.c")
rt_red_opx_una :: String; rt_red_opx_una = $(embedStringFile "./src/HVM/runtime/reduce/opx_una.c")
rt_red_opx_w32 :: String; rt_red_opx_w32 = $(embedStringFile "./src/HVM/runtime/reduce/opx_w32.c")
rt_red_opy_ctr :: String; rt_red_opy_ctr = $(embedStringFile "./src/HVM/runtime/reduce/opy_ctr.c")
rt_red_opy_era :: String; rt_red_opy_era = $(embedStringFile "./src/HVM/runtime/reduce/opy_era.c")
rt_red_opy_lam :: String; rt_red_opy_lam = $(embedStringFile "./src/HVM/runtime/reduce/opy_lam.c")
rt_red_opy_sup :: String; rt_red_opy_sup = $(embedStringFile "./src/HVM/runtime/reduce/opy_sup.c")
rt_red_opy_una :: String; rt_red_opy_una = $(embedStringFile "./src/HVM/runtime/reduce/opy_una.c")
rt_red_opy_w32 :: String; rt_red_opy_w32 = $(embedStringFile "./src/HVM/runtime/reduce/opy_w32.c")
stripIncl :: String -> String
stripIncl = unlines . filter (not . isPrefixOf "#include \"Runtime.h\"") . lines
-- Remove header-only pragmas that are noisy in a main TU
stripHdr :: String -> String
stripHdr = unlines . filter (not . isPrefixOf "#pragma once") . lines
runtime_c :: String
runtime_c = unlines
[ stripHdr runtime_h
, stripIncl rt_state_c
, stripIncl rt_heap_c
, stripIncl rt_term_c
, stripIncl rt_stack_c
, stripIncl rt_print_c
, stripIncl rt_memory_c
, stripIncl rt_reduce_c
, stripIncl rt_pr_SUP_c
, stripIncl rt_pr_DUP_c
, stripIncl rt_pr_LOG_c
, stripIncl rt_red_app_ctr
, stripIncl rt_red_app_era
, stripIncl rt_red_app_lam
, stripIncl rt_red_app_sup
, stripIncl rt_red_app_una
, stripIncl rt_red_app_w32
, stripIncl rt_red_dup_ctr
, stripIncl rt_red_dup_era
, stripIncl rt_red_dup_lam
, stripIncl rt_red_dup_ref
, stripIncl rt_red_dup_sup
, stripIncl rt_red_dup_una
, stripIncl rt_red_dup_w32
, stripIncl rt_red_let
, stripIncl rt_red_ref
, stripIncl rt_red_ref_sup
, stripIncl rt_red_mat_ctr
, stripIncl rt_red_mat_era
, stripIncl rt_red_mat_lam
, stripIncl rt_red_mat_sup
, stripIncl rt_red_mat_una
, stripIncl rt_red_mat_w32
, stripIncl rt_red_opx_ctr
, stripIncl rt_red_opx_era
, stripIncl rt_red_opx_lam
, stripIncl rt_red_opx_sup
, stripIncl rt_red_opx_una
, stripIncl rt_red_opx_w32
, stripIncl rt_red_opy_ctr
, stripIncl rt_red_opy_era
, stripIncl rt_red_opy_lam
, stripIncl rt_red_opy_sup
, stripIncl rt_red_opy_una
, stripIncl rt_red_opy_w32
]
-- Generates the complete C code for a Book
compileBook :: Book -> String -> String
compileBook book runtime_c =
let decls = compileHeaders book
funcs = map (\ (fid, _) -> compile book fid) (MS.toList (fidToFun book))
in unlines $ [runtime_c] ++ [decls] ++ funcs ++ [genMain book]
-- Compilation
-- -----------
data CompileState = CompileState
{ next :: Word64
, tabs :: Int
, bins :: MS.Map String String -- var_name => binder_host
, vars :: [(String, String)] -- [(var_name, var_host)]
, code :: [String]
, reus :: MS.Map Int [String] -- arity => [reuse_loc]
, tco :: Bool -- tail-call optimization
}
type Compile = State CompileState
compile :: Book -> Word16 -> String
compile book fid =
let full = compileWith compileFull book fid in
let fast = compileWith compileFast book fid in
if "<ERR>" `isInfixOf` fast then full else fast
-- Compiles a function using either Fast-Mode or Full-Mode
compileWith :: (Book -> Word16 -> Core -> Bool -> [(Bool,String)] -> Compile ()) -> Book -> Word16 -> String
compileWith cmp book fid =
let copy = fst (fst (mget (fidToFun book) fid)) in
let args = snd (fst (mget (fidToFun book) fid)) in
let core = snd (mget (fidToFun book) fid) in
let tco = isTailRecursive core fid in
let state = CompileState 0 0 MS.empty [] [] MS.empty tco in
let result = runState (cmp book fid core copy args) state in
unlines $ reverse $ code (snd result)
emit :: String -> Compile ()
emit line = modify $ \st -> st { code = (replicate (tabs st * 2) ' ' ++ line) : code st }
tabInc :: Compile ()
tabInc = modify $ \st -> st { tabs = tabs st + 1 }
tabDec :: Compile ()
tabDec = modify $ \st -> st { tabs = tabs st - 1 }
bind :: String -> String -> Compile ()
bind var host = modify $ \st -> st { bins = MS.insert var host (bins st) }
fresh :: String -> Compile String
fresh name = do
uid <- gets next
modify $ \s -> s { next = uid + 1 }
return $ name ++ show uid
reuse :: Int -> String -> Compile ()
reuse arity loc = modify $ \st -> st { reus = MS.insertWith (++) arity [loc] (reus st) }
-- Full Compiler
-- -------------
compileFull :: Book -> Word16 -> Core -> Bool -> [(Bool,String)] -> Compile ()
compileFull book fid core copy args = do
emit $ "Term " ++ mget (fidToNam book) fid ++ "_f(Term ref) {"
tabInc
forM_ (zip [0..] args) $ \(i, arg) -> do
argVar <- fresh "arg"
if fst arg
then emit $ "Term " ++ argVar ++ " = reduce_at(term_loc(ref) + " ++ show i ++ ");"
else emit $ "Term " ++ argVar ++ " = got(term_loc(ref) + " ++ show i ++ ");"
let argName = snd arg
bind argName argVar
result <- compileFullCore book fid core "root"
st <- get
forM_ (vars st) $ \ (var,host) -> do
let varTerm = MS.findWithDefault "" var (bins st)
emit $ "set(" ++ host ++ ", " ++ varTerm ++ ");"
emit $ "return " ++ result ++ ";"
tabDec
emit "}"
compileFullVar :: String -> String -> Compile String
compileFullVar var host = do
bins <- gets bins
case MS.lookup var bins of
Just entry -> do
return entry
Nothing -> do
modify $ \s -> s { vars = (var, host) : vars s }
return "0"
compileFullCore :: Book -> Word16 -> Core -> String -> Compile String
compileFullCore book fid Era _ = do
return $ "term_new(ERA, 0, 0)"
compileFullCore book fid (Var name) host = do
compileFullVar name host
compileFullCore book fid (Let mode var val bod) host = do
letNam <- fresh "let"
emit $ "Loc " ++ letNam ++ " = alloc_node(2);"
valT <- compileFullCore book fid val (letNam ++ " + 0")
emit $ "set(" ++ letNam ++ " + 0, " ++ valT ++ ");"
bind var $ "term_new(VAR, 0, " ++ letNam ++ " + 0)"
bodT <- compileFullCore book fid bod (letNam ++ " + 1")
emit $ "set(" ++ letNam ++ " + 1, " ++ bodT ++ ");"
return $ "term_new(LET, " ++ show (fromEnum mode) ++ ", " ++ letNam ++ ")"
compileFullCore book fid (Lam var bod) host = do
lamNam <- fresh "lam"
emit $ "Loc " ++ lamNam ++ " = alloc_node(1);"
bind var $ "term_new(VAR, 0, " ++ lamNam ++ " + 0)"
bodT <- compileFullCore book fid bod (lamNam ++ " + 0")
emit $ "set(" ++ lamNam ++ " + 0, " ++ bodT ++ ");"
return $ "term_new(LAM, 0, " ++ lamNam ++ ")"
compileFullCore book fid (App fun arg) host = do
appNam <- fresh "app"
emit $ "Loc " ++ appNam ++ " = alloc_node(2);"
funT <- compileFullCore book fid fun (appNam ++ " + 0")
argT <- compileFullCore book fid arg (appNam ++ " + 1")
emit $ "set(" ++ appNam ++ " + 0, " ++ funT ++ ");"
emit $ "set(" ++ appNam ++ " + 1, " ++ argT ++ ");"
return $ "term_new(APP, 0, " ++ appNam ++ ")"
compileFullCore book fid (Sup lab tm0 tm1) host = do
supNam <- fresh "sup"
emit $ "Loc " ++ supNam ++ " = alloc_node(2);"
tm0T <- compileFullCore book fid tm0 (supNam ++ " + 0")
tm1T <- compileFullCore book fid tm1 (supNam ++ " + 1")
emit $ "set(" ++ supNam ++ " + 0, " ++ tm0T ++ ");"
emit $ "set(" ++ supNam ++ " + 1, " ++ tm1T ++ ");"
return $ "term_new(SUP, " ++ show lab ++ ", " ++ supNam ++ ")"
compileFullCore book fid (Dup lab dp0 dp1 val bod) host = do
dupNam <- fresh "dup"
emit $ "Loc " ++ dupNam ++ " = alloc_node(1);"
bind dp0 $ "term_new(DP0, " ++ show lab ++ ", " ++ dupNam ++ " + 0)"
bind dp1 $ "term_new(DP1, " ++ show lab ++ ", " ++ dupNam ++ " + 0)"
valT <- compileFullCore book fid val (dupNam ++ " + 0")
emit $ "set(" ++ dupNam ++ " + 0, " ++ valT ++ ");"
bodT <- compileFullCore book fid bod host
return bodT
compileFullCore book fid (Ctr nam fds) host = do
ctrNam <- fresh "ctr"
let arity = length fds
let cid = mget (ctrToCid book) nam
emit $ "Loc " ++ ctrNam ++ " = alloc_node(" ++ show arity ++ ");"
fdsT <- mapM (\ (i,fd) -> compileFullCore book fid fd (ctrNam ++ " + " ++ show i)) (zip [0..] fds)
sequence_ [emit $ "set(" ++ ctrNam ++ " + " ++ show i ++ ", " ++ fdT ++ ");" | (i,fdT) <- zip [0..] fdsT]
return $ "term_new(CTR, " ++ show cid ++ ", " ++ ctrNam ++ ")"
compileFullCore book fid tm@(Mat kin val mov css) host = do
matNam <- fresh "mat"
emit $ "Loc " ++ matNam ++ " = alloc_node(" ++ show (1 + length css) ++ ");"
valT <- compileFullCore book fid val (matNam ++ " + 0")
emit $ "set(" ++ matNam ++ " + 0, " ++ valT ++ ");"
forM_ (zip [0..] css) $ \ (i,(ctr,fds,bod)) -> do
let bod' = foldr (\x b -> Lam x b) (foldr (\x b -> Lam x b) bod (map fst mov)) fds
bodT <- compileFullCore book fid bod' (matNam ++ " + " ++ show (i+1))
emit $ "set(" ++ matNam ++ " + " ++ show (i+1) ++ ", " ++ bodT ++ ");"
let tag = case kin of { SWI -> "SWI" ; (IFL _) -> "IFL" ; (MAT _) -> "MAT" }
let lab = case kin of { SWI -> fromIntegral (length css) ; (IFL cid) -> cid ; (MAT cid) -> cid }
let mat = "term_new(" ++ tag ++ ", " ++ show lab ++ ", " ++ matNam ++ ")"
foldM (\term (key, val) -> do
appNam <- fresh "app"
emit $ "Loc " ++ appNam ++ " = alloc_node(2);"
valT <- compileFullCore book fid val (appNam ++ " + 1")
emit $ "set(" ++ appNam ++ " + 0, " ++ term ++ ");"
emit $ "set(" ++ appNam ++ " + 1, " ++ valT ++ ");"
return $ "term_new(APP, 0, " ++ appNam ++ ")") mat mov
compileFullCore book fid (U32 val) _ =
return $ "term_new(W32, 0, " ++ show (fromIntegral val) ++ ")"
compileFullCore book fid (Chr val) _ =
return $ "term_new(CHR, 0, " ++ show (fromEnum val) ++ ")"
compileFullCore book fid (Op2 opr nu0 nu1) host = do
opxNam <- fresh "opx"
emit $ "Loc " ++ opxNam ++ " = alloc_node(2);"
nu0T <- compileFullCore book fid nu0 (opxNam ++ " + 0")
nu1T <- compileFullCore book fid nu1 (opxNam ++ " + 1")
emit $ "set(" ++ opxNam ++ " + 0, " ++ nu0T ++ ");"
emit $ "set(" ++ opxNam ++ " + 1, " ++ nu1T ++ ");"
return $ "term_new(OPX, " ++ show (fromEnum opr) ++ ", " ++ opxNam ++ ")"
compileFullCore book fid t@(Ref rNam rFid rArg) host = do
checkRefAri book fid t
refNam <- fresh "ref"
let arity = length rArg
emit $ "Loc " ++ refNam ++ " = alloc_node(" ++ show arity ++ ");"
argsT <- mapM (\ (i,arg) -> compileFullCore book fid arg (refNam ++ " + " ++ show i)) (zip [0..] rArg)
sequence_ [emit $ "set(" ++ refNam ++ " + " ++ show i ++ ", " ++ argT ++ ");" | (i,argT) <- zip [0..] argsT]
return $ "term_new(REF, " ++ show rFid ++ ", " ++ refNam ++ ")"
compileFullCore book fid (Inc val) host = do
incNam <- fresh "inc"
emit $ "Loc " ++ incNam ++ " = alloc_node(1);"
valT <- compileFullCore book fid val (incNam ++ " + 0")
emit $ "set(" ++ incNam ++ " + 0, " ++ valT ++ ");"
return $ "term_new(INC, 0, " ++ incNam ++ ")"
compileFullCore book fid (Dec val) host = do
decNam <- fresh "dec"
emit $ "Loc " ++ decNam ++ " = alloc_node(1);"
valT <- compileFullCore book fid val (decNam ++ " + 0")
emit $ "set(" ++ decNam ++ " + 0, " ++ valT ++ ");"
return $ "term_new(DEC, 0, " ++ decNam ++ ")"
-- Fast Compiler
-- -------------
-- Compiles a function using Fast-Mode
compileFast :: Book -> Word16 -> Core -> Bool -> [(Bool,String)] -> Compile ()
compileFast book fid core copy args = do
emit $ "Term " ++ mget (fidToNam book) fid ++ "_f(Term ref) {"
tabInc
emit "u64 itrs = 0;"
args <- forM (zip [0..] args) $ \ (i, (strict, arg)) -> do
argNam <- fresh "arg"
if strict then do
emit $ "Term " ++ argNam ++ " = reduce_at(term_loc(ref) + " ++ show i ++ ");"
else do
emit $ "Term " ++ argNam ++ " = got(term_loc(ref) + " ++ show i ++ ");"
if copy && strict then do
case MS.lookup fid (fidToLab book) of
Just labs -> do
emit $ "if (term_tag(" ++ argNam ++ ") == ERA) {"
emit $ " itrs += 1;"
emit $ " *HVM.itrs += itrs;"
emit $ " return term_new(ERA, 0, 0);"
emit $ "}"
emit $ "if (term_tag(" ++ argNam ++ ") == SUP) {"
tabInc
emit $ "u64 lab = term_lab(" ++ argNam ++ ");"
emit $ "if (1"
forM_ (MS.keys labs) $ \lab -> do
emit $ " && lab != " ++ show lab
emit $ ") {"
tabInc
emit $ "return reduce_ref_sup(ref, " ++ show i ++ ");"
tabDec
emit $ "}"
tabDec
emit $ "}"
Nothing -> return ()
else
return ()
bind arg argNam
return argNam
reuse (length (snd (fst (mget (fidToFun book) fid)))) "term_loc(ref)"
compileFastArgs book fid core args
tabDec
emit "}"
-- Compiles a fast function's argument list
compileFastArgs :: Book -> Word16 -> Core -> [String] -> Compile ()
compileFastArgs book fid body ctx = do
tco <- gets tco
if tco then do
emit $ "_Bool fst_iter = true;"
emit $ "while (1) {"
tabInc
compileFastBody book fid body ctx False 0
tabDec
emit $ "}"
else do
compileFastBody book fid body ctx False 0
-- Compiles a fast function body (pattern-matching)
compileFastBody :: Book -> Word16 -> Core -> [String] -> Bool -> Int -> Compile ()
compileFastBody book fid term@(Mat kin val mov css) ctx stop@False itr = do
valT <- compileFastCore book fid val
valNam <- fresh "val"
emit $ "Term " ++ valNam ++ " = reduce(" ++ valT ++ ");"
let valVar = "scrut%"++valNam
bind valVar valNam
let isNumeric = length css > 0 && (let (ctr,fds,bod) = css !! 0 in ctr == "0")
-- Numeric Pattern-Matching
if isNumeric then do
numNam <- fresh "num"
emit $ "if (term_tag("++valNam++") == W32) {"
tabInc
emit $ "u32 " ++ numNam ++ " = term_loc(" ++ valNam ++ ");"
emit $ "switch (" ++ numNam ++ ") {"
tabInc
forM_ (zip [0..] css) $ \ (i, (ctr,fds,bod)) -> do
if i < length css - 1 then do
emit $ "case " ++ show i ++ ": {"
tabInc
forM_ mov $ \ (key,val) -> do
valT <- compileFastCore book fid val
bind key valT
compileFastBody book fid bod ctx stop (itr + 1 + length mov)
tabDec
emit $ "}"
else do
emit $ "default: {"
tabInc
preNam <- fresh "pre"
emit $ "Term " ++ preNam ++ " = " ++ "term_new(W32, 0, "++numNam++" - "++show (length css - 1)++");"
forM_ fds $ \ fd -> do
bind fd preNam
forM_ mov $ \ (key,val) -> do
valT <- compileFastCore book fid val
bind key valT
compileFastBody book fid bod ctx stop (itr + 1 + length fds + length mov)
tabDec
emit $ "}"
tabDec
emit $ "}"
tabDec
emit $ "} else if (term_tag(" ++ valNam ++ ") == ERA) {"
tabInc
compileFastBody book fid Era ctx stop (itr + 1)
tabDec
emit $ "} else {"
tabInc
val <- compileFastCore book fid (Mat kin (Var valVar) mov css)
emit $ "itrs += " ++ show itr ++ ";"
compileFastSave book fid term ctx itr
emit $ "return " ++ val ++ ";"
tabDec
emit $ "}"
-- Constructor Pattern-Matching (with IfLet)
else if (case kin of { (IFL _) -> True ; _ -> False }) then do
let (Var defNam) = val
let iflCss = undoIfLetChain defNam term
let (_, dflt) = last iflCss
let othCss = init iflCss
emit $ "if (term_tag(" ++ valNam ++ ") == CTR) {"
tabInc
emit $ "switch (term_lab(" ++ valNam ++ ")) {"
tabInc
reuse' <- gets reus
itrA <- foldM (\itr (mov, (ctr, fds, bod)) -> do
emit $ "case " ++ show (mget (ctrToCid book) ctr) ++ ": {"
tabInc
reuse (length fds) ("term_loc(" ++ valNam ++ ")")
forM_ (zip [0..] fds) $ \(k, fd) -> do
fdNam <- fresh "fd"
emit $ "Term " ++ fdNam ++ " = got(term_loc(" ++ valNam ++ ") + " ++ show k ++ ");"
bind fd fdNam
forM_ mov $ \(key, val) -> do
valT <- compileFastCore book fid val
bind key valT
compileFastBody book fid bod ctx stop (itr + 1 + length fds + length mov)
tabDec
emit $ "}"
modify $ \st -> st { reus = reuse' }
return (itr + 1 + 1 + length mov)) itr othCss
emit $ "default: {"
tabInc
let (_, [dflNam], dflBod) = dflt
fdNam <- fresh "fd"
emit $ "Term " ++ fdNam ++ " = " ++ valNam ++ ";"
bind dflNam fdNam
forM_ mov $ \(key, val) -> do
valT <- compileFastCore book fid val
bind key valT
compileFastBody book fid dflBod ctx stop itrA
tabDec
emit $ "}"
tabDec
emit $ "}"
tabDec
emit $ "} else if (term_tag(" ++ valNam ++ ") == ERA) {"
tabInc
compileFastBody book fid Era ctx stop (itr + 1)
tabDec
emit $ "} else {"
tabInc
val <- compileFastCore book fid (Mat kin (Var valVar) mov css)
emit $ "itrs += " ++ show itr ++ ";"
compileFastSave book fid term ctx itr
emit $ "return " ++ val ++ ";"
tabDec
emit $ "}"
-- Constructor Pattern-Matching (without IfLet)
else do
emit $ "if (term_tag(" ++ valNam ++ ") == CTR) {"
tabInc
emit $ "switch (term_lab(" ++ valNam ++ ") - " ++ show (case kin of { (IFL c) -> c ; (MAT c) -> c ; _ -> 0 }) ++ ") {"
tabInc
reuse' <- gets reus
forM_ (zip [0..] css) $ \ (i, (ctr,fds,bod)) -> do
emit $ "case " ++ show i ++ ": {"
tabInc
reuse (length fds) ("term_loc(" ++ valNam ++ ")")
forM_ (zip [0..] fds) $ \ (k,fd) -> do
fdNam <- fresh "fd"
emit $ "Term " ++ fdNam ++ " = got(term_loc(" ++ valNam ++ ") + " ++ show k ++ ");"
bind fd fdNam
forM_ mov $ \ (key,val) -> do
valT <- compileFastCore book fid val
bind key valT
compileFastBody book fid bod ctx stop (itr + 1 + length fds + length mov)
tabDec
emit $ "}"
modify $ \st -> st { reus = reuse' }
emit $ "default: { exit(1); }"
tabDec
emit $ "}"
tabDec
emit $ "} else if (term_tag(" ++ valNam ++ ") == ERA) {"
tabInc
compileFastBody book fid Era ctx stop (itr + 1)
tabDec
emit $ "} else {"
tabInc
val <- compileFastCore book fid (Mat kin (Var valVar) mov css)
emit $ "itrs += " ++ show itr ++ ";"
compileFastSave book fid term ctx itr
emit $ "return " ++ val ++ ";"
tabDec
emit $ "}"
where
undoIfLetChain :: String -> Core -> [([(String,Core)], (String, [String], Core))]
undoIfLetChain expNam term@(Mat _ (Var gotNam) mov [(ctr, fds, bod), ("_", [nxtNam], rest)]) =
if gotNam == expNam
then (mov, (ctr, fds, bod)) : undoIfLetChain nxtNam rest
else [([], ("_", [expNam], term))]
undoIfLetChain expNam term = [([], ("_", [expNam], term))]
compileFastBody book fid term@(Dup lab dp0 dp1 val bod) ctx stop itr = do
valT <- compileFastCore book fid val
valNam <- fresh "val"
dp0Nam <- fresh "dpA"
dp1Nam <- fresh "dpB"
emit $ "Term " ++ valNam ++ " = (" ++ valT ++ ");"
emit $ "Term " ++ dp0Nam ++ ";"
emit $ "Term " ++ dp1Nam ++ ";"
emit $ "if (term_is_atom(" ++ valNam ++ ")) {"
tabInc
emit $ "itrs += 1;"
emit $ dp0Nam ++ " = " ++ valNam ++ ";"
emit $ dp1Nam ++ " = " ++ valNam ++ ";"
tabDec
emit $ "} else if (term_tag(" ++ valNam ++ ") == SUP && term_lab(" ++ valNam ++ ") == " ++ show lab ++ ") {"
tabInc
emit $ "itrs += 1;"
emit $ dp0Nam ++ " = got(term_loc(" ++ valNam ++ ") + 0);"
emit $ dp1Nam ++ " = got(term_loc(" ++ valNam ++ ") + 1);"
tabDec
emit $ "} else {"
tabInc
dupNam <- fresh "dup"
compileFastAlloc dupNam 1
emit $ "set(" ++ dupNam ++ " + 0, " ++ valNam ++ ");"
emit $ dp0Nam ++ " = term_new(DP0, " ++ show lab ++ ", " ++ dupNam ++ " + 0);"
emit $ dp1Nam ++ " = term_new(DP1, " ++ show lab ++ ", " ++ dupNam ++ " + 0);"
tabDec
emit $ "}"
bind dp0 dp0Nam
bind dp1 dp1Nam
compileFastBody book fid bod ctx stop itr
compileFastBody book fid term@(Let mode var val bod) ctx stop itr = do
valT <- compileFastCore book fid val
case mode of
LAZY -> do
bind var valT
STRI -> do
case val of
t@(Ref _ rFid _) -> do
checkRefAri book fid t
valNam <- fresh "val"
emit $ "Term " ++ valNam ++ " = reduce(" ++ mget (fidToNam book) rFid ++ "_f(" ++ valT ++ "));"
bind var valNam
_ -> do
valNam <- fresh "val"
emit $ "Term " ++ valNam ++ " = reduce(" ++ valT ++ ");"
bind var valNam
compileFastBody book fid bod ctx stop itr
compileFastBody book fid term@(Ref fNam fFid fArg) ctx stop itr
-- Tail-call optimization
| fFid == fid = do
checkRefAri book fid term
forM_ (zip fArg ctx) $ \ (arg, ctxVar) -> do
argT <- compileFastCore book fid arg
emit $ "" ++ ctxVar ++ " = " ++ argT ++ ";"
emit $ "itrs += " ++ show (itr + 1) ++ ";"
emit $ "fst_iter = false;"
emit $ "continue;"
-- Inline Dynamic DUP
-- The label must be a number at this point (not SUP, ERA, etc).
| fNam == "DUP" && (case fArg of [_, _, Lam _ (Lam _ _)] -> True ; _ -> False) = do
let [lab, val, Lam dp0 (Lam dp1 bod)] = fArg
labNam <- fresh "lab"
labTm <- compileFastCore book fid lab
emit $ "Term " ++ labNam ++ " = reduce(" ++ labTm ++ ");"
emit $ "if (term_tag(" ++ labNam ++ ") != W32) {"
emit $ " printf(\"ERROR:non-numeric-sup-label\\n\");"
emit $ "}"
emit $ "itrs += 3;"
-- Regular dup compilation (need to reimplement here since we don't know the label during compilation)
valT <- compileFastCore book fid val
valNam <- fresh "val"
dp0Nam <- fresh "dpA"
dp1Nam <- fresh "dpB"
emit $ "Term " ++ valNam ++ " = (" ++ valT ++ ");"
emit $ "Term " ++ dp0Nam ++ ";"
emit $ "Term " ++ dp1Nam ++ ";"
emit $ "if (term_is_atom(" ++ valNam ++ ")) {"
tabInc
emit $ "itrs += 1;"
emit $ dp0Nam ++ " = " ++ valNam ++ ";"
emit $ dp1Nam ++ " = " ++ valNam ++ ";"
tabDec
emit $ "} else if (term_tag(" ++ valNam ++ ") == SUP && term_lab(" ++ valNam ++ ") == term_loc(" ++ labNam ++ ")) {"
tabInc
emit $ "itrs += 1;"
emit $ dp0Nam ++ " = got(term_loc(" ++ valNam ++ ") + 0);"
emit $ dp1Nam ++ " = got(term_loc(" ++ valNam ++ ") + 1);"
tabDec
emit $ "} else {"
tabInc
dupNam <- fresh "dup"
compileFastAlloc dupNam 1
emit $ "set(" ++ dupNam ++ " + 0, " ++ valNam ++ ");"
-- Set to the dynamic label.
emit $ dp0Nam ++ " = term_new(DP0, term_loc(" ++ labNam ++ "), " ++ dupNam ++ " + 0);"
emit $ dp1Nam ++ " = term_new(DP1, term_loc(" ++ labNam ++ "), " ++ dupNam ++ " + 0);"
tabDec
emit $ "}"
bind dp0 dp0Nam
bind dp1 dp1Nam
compileFastBody book fid bod ctx stop itr
compileFastBody book fid term ctx stop itr = do
body <- compileFastCore book fid term
emit $ "itrs += " ++ show itr ++ ";"
compileFastSave book fid term ctx itr
emit $ "return " ++ body ++ ";"
-- Completes a fast mode call
compileFastSave :: Book -> Word16 -> Core -> [String] -> Int -> Compile ()
compileFastSave book fid term ctx itr = do
emit $ "*HVM.itrs += itrs;"
-- Helper function to allocate nodes with reuse
compileFastAlloc :: String -> Int -> Compile ()
compileFastAlloc name 0 = do
emit $ "Loc " ++ name ++ " = 0;"
compileFastAlloc name arity = do
reuse <- gets reus
-- Find the smallest reuse location that's big enough
-- Very large reuses are usually functions with a lot of state that doesn't need to be moved
-- Don't fragment those to avoid moving those values (a separate optimization)
let bigEnough = [(k,locs) | (k,locs) <- MS.toList reuse, k >= arity, k <= arity + 5, not (null locs)]
case bigEnough of
[] -> do
emit $ "Loc " ++ name ++ " = alloc_node(" ++ show arity ++ ");"
((k,loc:locs):_) -> do
emit $ "Loc " ++ name ++ ";"
-- Too hard to determine statically if reusing is ok in tail-call-optimization
tco <- gets tco
if tco then do
emit $ "if (fst_iter) {"
emit $ " " ++ name ++ " = " ++ loc ++ ";"
emit $ "} else {"
emit $ " " ++ name ++ " = alloc_node(" ++ show arity ++ ");"
emit $ "}"
else do
emit $ name ++ " = " ++ loc ++ ";"
-- Remove the used location
let reuse' = MS.insert k locs reuse
-- If we used a location bigger than needed, add the remainder back
let reuse'' = if k > arity
then MS.insertWith (++) (k - arity) [loc ++ " + " ++ show arity] reuse'
else reuse'
modify $ \st -> st { reus = reuse'' }
-- Compiles a core term in fast mode
compileFastCore :: Book -> Word16 -> Core -> Compile String
compileFastCore book fid Era =
return $ "term_new(ERA, 0, 0)"
compileFastCore book fid (Let mode var val bod) = do
valT <- compileFastCore book fid val
case mode of
LAZY -> do
emit $ "itrs += 1;"
bind var valT
compileFastCore book fid bod
STRI -> do
letNam <- fresh "let"
compileFastAlloc letNam 2
emit $ "set(" ++ letNam ++ " + 0, " ++ valT ++ ");"
bind var $ "term_new(VAR, 0, " ++ letNam ++ " + 0)"
bodT <- compileFastCore book fid bod
emit $ "set(" ++ letNam ++ " + 1, " ++ bodT ++ ");"
return $ "term_new(LET, " ++ show (fromEnum STRI) ++ ", " ++ letNam ++ ")"
compileFastCore book fid (Var name) = do
compileFastVar name
compileFastCore book fid (Lam var bod) = do
lamNam <- fresh "lam"
compileFastAlloc lamNam 1
bind var $ "term_new(VAR, 0, " ++ lamNam ++ " + 0)"
bodT <- compileFastCore book fid bod
emit $ "set(" ++ lamNam ++ " + 0, " ++ bodT ++ ");"
return $ "term_new(LAM, 0, " ++ lamNam ++ ")"
compileFastCore book fid (App fun arg) = do
appNam <- fresh "app"
compileFastAlloc appNam 2
funT <- compileFastCore book fid fun
argT <- compileFastCore book fid arg
emit $ "set(" ++ appNam ++ " + 0, " ++ funT ++ ");"
emit $ "set(" ++ appNam ++ " + 1, " ++ argT ++ ");"
return $ "term_new(APP, 0, " ++ appNam ++ ")"
compileFastCore book fid (Sup lab tm0 tm1) = do
supNam <- fresh "sup"
compileFastAlloc supNam 2
tm0T <- compileFastCore book fid tm0
tm1T <- compileFastCore book fid tm1
emit $ "set(" ++ supNam ++ " + 0, " ++ tm0T ++ ");"
emit $ "set(" ++ supNam ++ " + 1, " ++ tm1T ++ ");"
return $ "term_new(SUP, " ++ show lab ++ ", " ++ supNam ++ ")"
compileFastCore book fid (Dup lab dp0 dp1 val bod) = do
dupNam <- fresh "dup"
dp0Nam <- fresh "dpA"
dp1Nam <- fresh "dpB"
valNam <- fresh "val"
valT <- compileFastCore book fid val
emit $ "Term " ++ valNam ++ " = (" ++ valT ++ ");"
emit $ "Term " ++ dp0Nam ++ ";"
emit $ "Term " ++ dp1Nam ++ ";"
emit $ "if (term_is_atom(" ++ valNam ++ ")) {"
tabInc
emit $ "itrs += 1;"
emit $ dp0Nam ++ " = " ++ valNam ++ ";"
emit $ dp1Nam ++ " = " ++ valNam ++ ";"
tabDec
emit $ "} else if (term_tag(" ++ valNam ++ ") == SUP && term_lab(" ++ valNam ++ ") == " ++ show lab ++ ") {"
tabInc
emit $ "itrs += 1;"
emit $ dp0Nam ++ " = got(term_loc(" ++ valNam ++ ") + 0);"
emit $ dp1Nam ++ " = got(term_loc(" ++ valNam ++ ") + 1);"
tabDec
emit $ "} else {"
tabInc
compileFastAlloc dupNam 1
emit $ "set(" ++ dupNam ++ " + 0, " ++ valNam ++ ");"
emit $ dp0Nam ++ " = term_new(DP0, " ++ show lab ++ ", " ++ dupNam ++ " + 0);"
emit $ dp1Nam ++ " = term_new(DP1, " ++ show lab ++ ", " ++ dupNam ++ " + 0);"
tabDec
emit $ "}"
bind dp0 dp0Nam
bind dp1 dp1Nam
compileFastCore book fid bod
compileFastCore book fid (Ctr nam fds) = do
ctrNam <- fresh "ctr"
let ari = length fds
let cid = mget (ctrToCid book) nam
compileFastAlloc ctrNam ari
fdsT <- mapM (\ (i,fd) -> compileFastCore book fid fd) (zip [0..] fds)
sequence_ [emit $ "set(" ++ ctrNam ++ " + " ++ show i ++ ", " ++ fdT ++ ");" | (i,fdT) <- zip [0..] fdsT]
return $ "term_new(CTR, " ++ show cid ++ ", " ++ ctrNam ++ ")"
compileFastCore book fid tm@(Mat kin val mov css) = do
matNam <- fresh "mat"
compileFastAlloc matNam (1 + length css)
valT <- compileFastCore book fid val
emit $ "set(" ++ matNam ++ " + 0, " ++ valT ++ ");"
forM_ (zip [0..] css) $ \(i,(ctr,fds,bod)) -> do
let bod' = foldr (\x b -> Lam x b) (foldr (\x b -> Lam x b) bod (map fst mov)) fds
bodT <- compileFastCore book fid bod'
emit $ "set(" ++ matNam ++ " + " ++ show (i+1) ++ ", " ++ bodT ++ ");"
let tag = case kin of { SWI -> "SWI" ; (IFL _) -> "IFL" ; (MAT _) -> "MAT" }
let lab = case kin of { SWI -> fromIntegral (length css) ; (IFL cid) -> cid ; (MAT cid) -> cid }
retNam <- fresh "ret"
emit $ "Term " ++ retNam ++ " = term_new(" ++ tag ++ ", " ++ show lab ++ ", " ++ matNam ++ ");"
foldM (\acc (_, val) -> do
appNam <- fresh "app"
compileFastAlloc appNam 2
emit $ "set(" ++ appNam ++ " + 0, " ++ acc ++ ");"
valT <- compileFastCore book fid val
emit $ "set(" ++ appNam ++ " + 1, " ++ valT ++ ");"
return $ "term_new(APP, 0, " ++ appNam ++ ")") retNam mov
compileFastCore book fid (U32 val) =
return $ "term_new(W32, 0, " ++ show (fromIntegral val) ++ ")"
compileFastCore book fid (Chr val) =
return $ "term_new(CHR, 0, " ++ show (fromEnum val) ++ ")"
compileFastCore book fid (Op2 opr nu0 nu1) = do
opxNam <- fresh "opx"
retNam <- fresh "ret"
nu0Nam <- fresh "nu0"
nu1Nam <- fresh "nu1"
nu0T <- compileFastCore book fid nu0
nu1T <- compileFastCore book fid nu1
emit $ "Term " ++ nu0Nam ++ " = (" ++ nu0T ++ ");"
emit $ "Term " ++ nu1Nam ++ " = (" ++ nu1T ++ ");"
emit $ "Term " ++ retNam ++ ";"
emit $ "if (term_tag(" ++ nu0Nam ++ ") == W32 && term_tag(" ++ nu1Nam ++ ") == W32) {"
emit $ " itrs += 2;"
let oprStr = case opr of
OP_ADD -> "+"
OP_SUB -> "-"
OP_MUL -> "*"
OP_DIV -> "/"
OP_MOD -> "%"
OP_EQ -> "=="
OP_NE -> "!="
OP_LT -> "<"
OP_GT -> ">"
OP_LTE -> "<="
OP_GTE -> ">="
OP_AND -> "&"
OP_OR -> "|"
OP_XOR -> "^"
OP_LSH -> "<<"
OP_RSH -> ">>"
emit $ " " ++ retNam ++ " = term_new(W32, 0, term_loc(" ++ nu0Nam ++ ") " ++ oprStr ++ " term_loc(" ++ nu1Nam ++ "));"
emit $ "} else {"
tabInc
compileFastAlloc opxNam 2
emit $ "set(" ++ opxNam ++ " + 0, " ++ nu0Nam ++ ");"
emit $ "set(" ++ opxNam ++ " + 1, " ++ nu1Nam ++ ");"
emit $ retNam ++ " = term_new(OPX, " ++ show (fromEnum opr) ++ ", " ++ opxNam ++ ");"
tabDec
emit $ "}"
return $ retNam
compileFastCore book fid t@(Ref rNam rFid rArg) = do
checkRefAri book fid t
refNam <- fresh "ref"
let arity = length rArg
compileFastAlloc refNam arity
argsT <- mapM (\ (i,arg) -> compileFastCore book fid arg) (zip [0..] rArg)
sequence_ [emit $ "set(" ++ refNam ++ " + " ++ show i ++ ", " ++ argT ++ ");" | (i,argT) <- zip [0..] argsT]
return $ "term_new(REF, " ++ show rFid ++ ", " ++ refNam ++ ")"
compileFastCore book fid (Inc val) = do
incNam <- fresh "inc"
compileFastAlloc incNam 1
valT <- compileFastCore book fid val
emit $ "set(" ++ incNam ++ " + 0, " ++ valT ++ ");"
return $ "term_new(INC, 0, " ++ incNam ++ ")"
compileFastCore book fid (Dec val) = do
decNam <- fresh "dec"
compileFastAlloc decNam 1
valT <- compileFastCore book fid val
emit $ "set(" ++ decNam ++ " + 0, " ++ valT ++ ");"
return $ "term_new(DEC, 0, " ++ decNam ++ ")"
-- Compiles a variable in fast mode
compileFastVar :: String -> Compile String
compileFastVar var = do
bins <- gets bins
case MS.lookup var bins of
Just entry -> do
return entry
Nothing -> do
return $ "<ERR>"
checkRefAri :: Book -> Word16 -> Core -> Compile ()
checkRefAri book orig core = do
case core of
Ref nam lab arg -> do
let fid = fromIntegral lab
let ari = funArity book fid
let len = length arg
when (ari /= fromIntegral len) $ do
let nam = mget (fidToNam book) orig
error $ "On function @" ++ nam ++ ": Arity mismatch on term: " ++ show core ++ ". Expected " ++ show ari ++ ", got " ++ show len ++ "."
_ -> return ()
-- Generates the forward declarations of the compiled C functions
compileHeaders :: Book -> String
compileHeaders book =
let funcs = MS.toList (fidToNam book)
decls = map (\(_, name) -> "Term " ++ name ++ "_f(Term);") funcs
in unlines decls
-- Generates the main function for the compiled C code
genMain :: Book -> String
genMain book = case MS.lookup "main" (namToFid book) of
Just mainFid ->
unlines
[ "int main() {"
, " hvm_init();"
, registerFuncs
, " clock_t start = clock();"
, " Term root = term_new(REF, "++show mainFid++", 0);"
, " normal(root);"
, " double time = (double)(clock() - start) / CLOCKS_PER_SEC * 1000;"
, " printf(\"WORK: %\"PRIu64\" interactions\\n\", get_itr());"
, " printf(\"TIME: %.3fs seconds\\n\", time / 1000.0);"
, " printf(\"SIZE: %llu nodes\\n\", get_len());"
, " printf(\"PERF: %.3f MIPS\\n\", (get_itr() / 1000000.0) / (time / 1000.0));"
, " hvm_free();"
, " return 0;"
, "}"
]
Nothing -> ""
where
registerFuncs = unlines [" hvm_define(" ++ show fid ++ ", " ++ name ++ "_f);" | (fid, name) <- MS.toList (fidToNam book)]
isTailRecursive :: Core -> Word16 -> Bool
isTailRecursive core fid = case core of
Ref _ fFid _ | fFid == fid -> True
Ref "DUP" _ [_, _, Lam _ (Lam _ f)] -> isTailRecursive f fid
Dup _ _ _ _ f -> isTailRecursive f fid
Let _ _ _ f -> isTailRecursive f fid
Mat _ _ _ c -> any (\(_,_,f) -> isTailRecursive f fid) c
_ -> False
================================================
FILE: src/HVM/Extract.hs
================================================
{-./Type.hs-}
{-./Inject.hs-}
module HVM.Extract where
import Control.Monad (foldM, forM_, forM)
import Control.Monad.State
import Data.Bits (shiftR)
import Data.Char (chr, ord)
import Data.IORef
import Data.Word
import Debug.Trace
import HVM.Foreign
import System.IO.Unsafe (unsafeInterleaveIO)
import HVM.Type
import qualified Data.IntSet as IS
import qualified Data.Map.Strict as MS
extractCoreAt :: IORef IS.IntSet -> ReduceAt -> Book -> Loc -> HVM Core
extractCoreAt dupsRef reduceAt book host = unsafeInterleaveIO $ do
term <- reduceAt book host
-- trace ("extract " ++ show host ++ " " ++ termToString term) $
let tag = termTag term
case tag of
t | t == _ERA_ -> do
return Era
t | t == _LET_ -> do
let loc = termLoc term
let mode = modeT (termLab term)
name <- return $ "$" ++ show (loc + 0)
val <- extractCoreAt dupsRef reduceAt book (loc + 0)
bod <- extractCoreAt dupsRef reduceAt book (loc + 1)
return $ Let mode name val bod
t | t == _LAM_ -> do
let loc = termLoc term
name <- return $ "$" ++ show (loc + 0)
bod <- extractCoreAt dupsRef reduceAt book (loc + 0)
return $ Lam name bod
t | t == _APP_ -> do
let loc = termLoc term
fun <- extractCoreAt dupsRef reduceAt book (loc + 0)
arg <- extractCoreAt dupsRef reduceAt book (loc + 1)
return $ App fun arg
t | t == _SUP_ -> do
let loc = termLoc term
let lab = termLab term
tm0 <- extractCoreAt dupsRef reduceAt book (loc + 0)
tm1 <- extractCoreAt dupsRef reduceAt book (loc + 1)
return $ Sup lab tm0 tm1
t | t == _VAR_ -> do
let loc = termLoc term
sub <- got (loc + 0)
if termGetBit sub == 0
then do
name <- return $ "$" ++ show (loc + 0)
return $ Var name
else do
set (loc + 0) (termRemBit sub)
extractCoreAt dupsRef reduceAt book (loc + 0)
t | t == _DP0_ -> do
let loc = termLoc term
let lab = termLab term
dups <- readIORef dupsRef
if IS.member (fromIntegral loc) dups
then do
name <- return $ "$" ++ show (loc + 0) ++ "_0"
return $ Var name
else do
dp0 <- return $ "$" ++ show (loc + 0) ++ "_0"
dp1 <- return $ "$" ++ show (loc + 0) ++ "_1"
val <- extractCoreAt dupsRef reduceAt book (loc + 0)
modifyIORef' dupsRef (IS.insert (fromIntegral loc))
return $ Dup lab dp0 dp1 val (Var dp0)
t | t == _DP1_ -> do
let loc = termLoc term
let lab = termLab term
dups <- readIORef dupsRef
if IS.member (fromIntegral loc) dups
then do
name <- return $ "$" ++ show (loc + 0) ++ "_1"
return $ Var name
else do
dp0 <- return $ "$" ++ show (loc + 0) ++ "_0"
dp1 <- return $ "$" ++ show (loc + 0) ++ "_1"
val <- extractCoreAt dupsRef reduceAt book (loc + 0)
modifyIORef' dupsRef (IS.insert (fromIntegral loc))
return $ Dup lab dp0 dp1 val (Var dp1)
t | t == _CTR_ -> do
let loc = termLoc term
let lab = termLab term
let cid = fromIntegral lab
let nam = mget (cidToCtr book) cid
let ari = mget (cidToAri book) cid
let ars = if ari == 0 then [] else [0..fromIntegral ari-1]
fds <- mapM (\i -> extractCoreAt dupsRef reduceAt book (loc + i)) ars
return $ Ctr nam fds
t | t == _MAT_ -> do
let loc = termLoc term
let lab = termLab term
let cid = fromIntegral lab
let len = mget (cidToLen book) cid
val <- extractCoreAt dupsRef reduceAt book (loc + 0)
css <- foldM (\css i -> do
let ctr = mget (cidToCtr book) (cid + i)
let ari = mget (cidToAri book) (cid + i)
let fds = if ari == 0 then [] else ["$" ++ show (loc + 1 + j) | j <- [0..fromIntegral ari-1]]
bod <- extractCoreAt dupsRef reduceAt book (loc + 1 + fromIntegral i)
return $ (ctr,fds,bod):css) [] [0..len-1]
return $ Mat (MAT cid) val [] (reverse css)
t | t == _IFL_ -> do
let loc = termLoc term
let lab = termLab term
let cid = fromIntegral lab
val <- extractCoreAt dupsRef reduceAt book (loc + 0)
cs0 <- extractCoreAt dupsRef reduceAt book (loc + 1)
cs1 <- extractCoreAt dupsRef reduceAt book (loc + 2)
return $ Mat (IFL cid) val [] [(mget (cidToCtr book) cid, [], cs0), ("_", [], cs1)]
t | t == _SWI_ -> do
let loc = termLoc term
let lab = termLab term
let len = fromIntegral lab
val <- extractCoreAt dupsRef reduceAt book (loc + 0)
css <- foldM (\css i -> do
bod <- extractCoreAt dupsRef reduceAt book (loc + 1 + i)
return $ (show i, [], bod):css) [] [0..len-1]
return $ Mat SWI val [] (reverse css)
t | t == _W32_ -> do
let val = termLoc term
return $ U32 (fromIntegral val)
t | t == _CHR_ -> do
let val = termLoc term
return $ Chr (chr (fromIntegral val))
t | t == _OPX_ -> do
let loc = termLoc term
let opr = toEnum (fromIntegral (termLab term))
nmx <- extractCoreAt dupsRef reduceAt book (loc + 0)
nmy <- extractCoreAt dupsRef reduceAt book (loc + 1)
return $ Op2 opr nmx nmy
t | t == _OPY_ -> do
let loc = termLoc term
let opr = toEnum (fromIntegral (termLab term))
nmy <- extractCoreAt dupsRef reduceAt book (loc + 0)
nmx <- extractCoreAt dupsRef reduceAt book (loc + 1)
return $ Op2 opr nmx nmy
t | t == _REF_ -> do
let loc = termLoc term
let lab = termLab term
let fid = fromIntegral lab
let ari = fromIntegral $ funArity book fid
let aux = if ari == 0 then [] else [0..ari-1]
arg <- mapM (\i -> extractCoreAt dupsRef reduceAt book (loc + i)) aux
let name = MS.findWithDefault "?" fid (fidToNam book)
return $ Ref name fid arg
t | t == _FWD_ -> do
return Era
t | t == _INC_ -> do
let loc = termLoc term
val <- extractCoreAt dupsRef reduceAt book (loc + 0)
return $ Inc val
t | t == _DEC_ -> do
let loc = termLoc term
val <- extractCoreAt dupsRef reduceAt book (loc + 0)
return $ Dec val
_ -> do
return Era
doExtractCoreAt :: ReduceAt -> Book -> Loc -> HVM Core
doExtractCoreAt reduceAt book loc = do
dupsRef <- newIORef IS.empty
core <- extractCoreAt dupsRef reduceAt book loc
return core
-- return $ doLiftDups core
-- Lifting Dups
-- ------------
liftDups :: Core -> (Core, Core -> Core)
liftDups (Var nam) =
(Var nam, id)
liftDups (Ref nam fid arg) =
let (argT, argD) = liftDupsList arg
in (Ref nam fid argT, argD)
liftDups Era =
(Era, id)
liftDups (Lam str bod) =
let (bodT, bodD) = liftDups bod
in (Lam str bodT, bodD)
liftDups (App fun arg) =
let (funT, funD) = liftDups fun
(argT, argD) = liftDups arg
in (App funT argT, funD . argD)
liftDups (Sup lab tm0 tm1) =
let (tm0T, tm0D) = liftDups tm0
(tm1T, tm1D) = liftDups tm1
in (Sup lab tm0T tm1T, tm0D . tm1D)
liftDups (Dup lab dp0 dp1 val bod) =
let (valT, valD) = liftDups val
(bodT, bodD) = liftDups bod
in (bodT, \x -> valD (bodD (Dup lab dp0 dp1 valT x)))
liftDups (Ctr nam fds) =
let (fdsT, fdsD) = liftDupsList fds
in (Ctr nam fdsT, fdsD)
liftDups (Mat kin val mov css) =
let (valT, valD) = liftDups val
(movT, movD) = liftDupsMov mov
(cssT, cssD) = liftDupsCss css
in (Mat kin valT movT cssT, valD . movD . cssD)
liftDups (U32 val) =
(U32 val, id)
liftDups (Chr val) =
(Chr val, id)
liftDups (Op2 opr nm0 nm1) =
let (nm0T, nm0D) = liftDups nm0
(nm1T, nm1D) = liftDups nm1
in (Op2 opr nm0T nm1T, nm0D . nm1D)
liftDups (Let mod nam val bod) =
let (valT, valD) = liftDups val
(bodT, bodD) = liftDups bod
in (Let mod nam valT bodT, valD . bodD)
liftDups (Inc val) =
let (valT, valD) = liftDups val
in (Inc valT, valD)
liftDups (Dec val)
gitextract_w2c5eac0/
├── .github/
│ ├── ISSUE_TEMPLATE/
│ │ ├── bug_report.yml
│ │ ├── config.yml
│ │ └── feature_request.md
│ └── workflows/
│ └── CI.yml
├── .gitignore
├── CLAUDE.md
├── HVM.cabal
├── HVM.md
├── IC.md
├── INTERS.md
├── LICENSE
├── MODES.md
├── README.md
├── app/
│ └── Main.hs
├── bug.hvm
├── cabal.project
├── examples/
│ ├── _test_.js
│ ├── bench_cnots.hvm
│ ├── bench_count.hs
│ ├── bench_count.hvm
│ ├── bench_sum_range.hs
│ ├── bench_sum_range.hvm
│ ├── bench_sum_range.py
│ ├── enum_1D_match.hvm
│ ├── enum_bin.hvm
│ ├── enum_coc_smart.hvm
│ ├── enum_invert_add.hvm
│ ├── enum_lam_naive_blc.hs
│ ├── enum_lam_naive_blc.hvm
│ ├── enum_lam_smart.hvm
│ ├── enum_nat.hvm
│ ├── enum_path_finder.hvm
│ ├── enum_primes.hs
│ ├── enum_primes.hvm
│ ├── feat_affine_ctx.hvm
│ ├── feat_cmul.hvm
│ ├── feat_hoas.hvm
│ ├── feat_mut_ref.hvm
│ ├── fuse_inc.hvm
│ ├── fuse_inc.hvm1
│ ├── fuse_mul.hvm
│ ├── fuse_rot.hvm
│ └── main.hvm
└── src/
└── HVM/
├── API.hs
├── Adjust.hs
├── Collapse.hs
├── Compile.hs
├── Extract.hs
├── Foreign.hs
├── Inject.hs
├── Parse.hs
├── Reduce.hs
├── Runtime.c
├── Runtime.h
├── Type.hs
└── runtime/
├── heap.c
├── memory.c
├── prim/
│ ├── DUP.c
│ ├── LOG.c
│ └── SUP.c
├── print.c
├── reduce/
│ ├── app_ctr.c
│ ├── app_era.c
│ ├── app_lam.c
│ ├── app_sup.c
│ ├── app_una.c
│ ├── app_w32.c
│ ├── dup_ctr.c
│ ├── dup_era.c
│ ├── dup_lam.c
│ ├── dup_ref.c
│ ├── dup_sup.c
│ ├── dup_una.c
│ ├── dup_w32.c
│ ├── let.c
│ ├── mat_ctr.c
│ ├── mat_era.c
│ ├── mat_lam.c
│ ├── mat_sup.c
│ ├── mat_una.c
│ ├── mat_w32.c
│ ├── opx_ctr.c
│ ├── opx_era.c
│ ├── opx_lam.c
│ ├── opx_sup.c
│ ├── opx_una.c
│ ├── opx_w32.c
│ ├── opy_ctr.c
│ ├── opy_era.c
│ ├── opy_lam.c
│ ├── opy_sup.c
│ ├── opy_una.c
│ ├── opy_w32.c
│ ├── ref.c
│ └── ref_sup.c
├── reduce.c
├── stack.c
├── state.c
└── term.c
SYMBOL INDEX (104 symbols across 47 files)
FILE: examples/_test_.js
function prepareTestFile (line 192) | function prepareTestFile(originalFile, mainLine) {
function runTest (line 218) | function runTest(mode) {
function parseOutput (line 236) | function parseOutput(output) {
FILE: examples/bench_sum_range.py
class Nil (line 1) | class Nil:
method __init__ (line 2) | def __init__(self):
class Cons (line 5) | class Cons:
method __init__ (line 6) | def __init__(self, head, tail):
function range_custom (line 11) | def range_custom(n, xs):
function sum_custom (line 17) | def sum_custom(lst):
function main (line 24) | def main():
FILE: src/HVM/Runtime.h
type Tag (line 30) | typedef uint8_t Tag;
type Lab (line 31) | typedef uint16_t Lab;
type Loc (line 32) | typedef uint64_t Loc;
type Term (line 33) | typedef uint64_t Term;
type u16 (line 34) | typedef uint16_t u16;
type u32 (line 35) | typedef uint32_t u32;
type u64 (line 36) | typedef uint64_t u64;
type State (line 90) | typedef struct {
FILE: src/HVM/runtime/heap.c
function set_len (line 4) | void set_len(u64 size) { *HVM.size = size; }
function set_itr (line 5) | void set_itr(u64 itrs) { *HVM.itrs = itrs; }
function u64 (line 6) | u64 get_len() { return *HVM.size; }
function u64 (line 7) | u64 get_itr() { return *HVM.itrs; }
function u64 (line 8) | u64 fresh() { return (*HVM.frsh)++; }
function Term (line 11) | Term swap(Loc loc, Term term) {
function Term (line 21) | Term got(Loc loc) {
function set (line 30) | void set(Loc loc, Term term) { HVM.heap[loc] = term; }
function sub (line 31) | void sub(Loc loc, Term term) { set(loc, term_set_bit(term)); }
function Term (line 32) | Term take(Loc loc) { return swap(loc, VOID); }
function Loc (line 35) | Loc alloc_node(Loc arity) {
function inc_itr (line 45) | void inc_itr() { (*HVM.itrs)++; }
FILE: src/HVM/runtime/memory.c
function hvm_init (line 14) | void hvm_init() {
function hvm_munmap (line 51) | static void hvm_munmap(void *ptr, size_t size, const char *name) {
function hvm_free (line 61) | void hvm_free() {
FILE: src/HVM/runtime/prim/DUP.c
function Term (line 5) | Term DUP_f(Term ref) {
FILE: src/HVM/runtime/prim/LOG.c
function Term (line 3) | Term LOG_f(Term ref) {
FILE: src/HVM/runtime/prim/SUP.c
function Term (line 5) | Term SUP_f(Term ref) {
FILE: src/HVM/runtime/print.c
function print_tag (line 3) | void print_tag(Tag tag) {
function print_term (line 28) | void print_term(Term term) {
function print_heap (line 34) | void print_heap() {
FILE: src/HVM/runtime/reduce.c
function Term (line 5) | Term reduce(Term term) {
function Term (line 123) | Term reduce_at(Loc host) {
function Term (line 131) | Term normal(Term term) {
FILE: src/HVM/runtime/reduce/app_ctr.c
function Term (line 6) | Term reduce_app_ctr(Term app, Term ctr) {
FILE: src/HVM/runtime/reduce/app_era.c
function Term (line 6) | Term reduce_app_era(Term app, Term era) {
FILE: src/HVM/runtime/reduce/app_lam.c
function Term (line 7) | Term reduce_app_lam(Term app, Term lam) {
FILE: src/HVM/runtime/reduce/app_sup.c
function Term (line 7) | Term reduce_app_sup(Term app, Term sup) {
FILE: src/HVM/runtime/reduce/app_una.c
function Term (line 6) | Term reduce_app_una(Term app, Term una, Tag tag) {
function Term (line 22) | Term reduce_app_inc(Term app, Term inc) {
function Term (line 26) | Term reduce_app_dec(Term app, Term dec) {
FILE: src/HVM/runtime/reduce/app_w32.c
function Term (line 6) | Term reduce_app_w32(Term app, Term w32) {
FILE: src/HVM/runtime/reduce/dup_ctr.c
function Term (line 11) | Term reduce_dup_ctr(Term dup, Term ctr) {
FILE: src/HVM/runtime/reduce/dup_era.c
function Term (line 7) | Term reduce_dup_era(Term dup, Term era) {
FILE: src/HVM/runtime/reduce/dup_lam.c
function Term (line 9) | Term reduce_dup_lam(Term dup, Term lam) {
FILE: src/HVM/runtime/reduce/dup_ref.c
function Term (line 11) | Term reduce_dup_ref(Term dup, Term ref) {
FILE: src/HVM/runtime/reduce/dup_sup.c
function Term (line 13) | Term reduce_dup_sup(Term dup, Term sup) {
FILE: src/HVM/runtime/reduce/dup_una.c
function Term (line 8) | Term reduce_dup_una(Term dup, Term una, Tag tag) {
function Term (line 33) | Term reduce_dup_inc(Term dup, Term inc) {
function Term (line 37) | Term reduce_dup_dec(Term dup, Term dec) {
FILE: src/HVM/runtime/reduce/dup_w32.c
function Term (line 7) | Term reduce_dup_w32(Term dup, Term w32) {
FILE: src/HVM/runtime/reduce/let.c
function Term (line 8) | Term reduce_let(Term let, Term val) {
FILE: src/HVM/runtime/reduce/mat_ctr.c
function Term (line 3) | Term reduce_mat_ctr(Term mat, Term ctr) {
FILE: src/HVM/runtime/reduce/mat_era.c
function Term (line 6) | Term reduce_mat_era(Term mat, Term era) {
FILE: src/HVM/runtime/reduce/mat_lam.c
function Term (line 6) | Term reduce_mat_lam(Term mat, Term lam) {
FILE: src/HVM/runtime/reduce/mat_sup.c
function Term (line 11) | Term reduce_mat_sup(Term mat, Term sup) {
FILE: src/HVM/runtime/reduce/mat_una.c
function Term (line 5) | Term reduce_mat_una(Term mat, Term una, Tag tag) {
function Term (line 16) | Term reduce_mat_inc(Term mat, Term inc) {
function Term (line 20) | Term reduce_mat_dec(Term mat, Term dec) {
FILE: src/HVM/runtime/reduce/mat_w32.c
function Term (line 7) | Term reduce_mat_w32(Term mat, Term w32) {
FILE: src/HVM/runtime/reduce/opx_ctr.c
function Term (line 6) | Term reduce_opx_ctr(Term opx, Term ctr) {
FILE: src/HVM/runtime/reduce/opx_era.c
function Term (line 6) | Term reduce_opx_era(Term opx, Term era) {
FILE: src/HVM/runtime/reduce/opx_lam.c
function Term (line 6) | Term reduce_opx_lam(Term opx, Term lam) {
FILE: src/HVM/runtime/reduce/opx_sup.c
function Term (line 7) | Term reduce_opx_sup(Term opx, Term sup) {
FILE: src/HVM/runtime/reduce/opx_una.c
function Term (line 4) | Term reduce_opx_una(Term opx, Term una, Tag tag) {
function Term (line 17) | Term reduce_opx_inc(Term opx, Term inc) {
function Term (line 21) | Term reduce_opx_dec(Term opx, Term dec) {
FILE: src/HVM/runtime/reduce/opx_w32.c
function Term (line 6) | Term reduce_opx_w32(Term opx, Term nmx) {
FILE: src/HVM/runtime/reduce/opy_ctr.c
function Term (line 6) | Term reduce_opy_ctr(Term opy, Term ctr) {
FILE: src/HVM/runtime/reduce/opy_era.c
function Term (line 6) | Term reduce_opy_era(Term opy, Term era) {
FILE: src/HVM/runtime/reduce/opy_lam.c
function Term (line 6) | Term reduce_opy_lam(Term opy, Term era) {
FILE: src/HVM/runtime/reduce/opy_sup.c
function Term (line 6) | Term reduce_opy_sup(Term opy, Term sup) {
FILE: src/HVM/runtime/reduce/opy_una.c
function Term (line 4) | Term reduce_opy_una(Term opy, Term una, Tag tag) {
function Term (line 17) | Term reduce_opy_inc(Term opy, Term inc) {
function Term (line 21) | Term reduce_opy_dec(Term opy, Term dec) {
FILE: src/HVM/runtime/reduce/opy_w32.c
function Term (line 6) | Term reduce_opy_w32(Term opy, Term w32) {
FILE: src/HVM/runtime/reduce/ref.c
function Term (line 6) | Term reduce_ref(Term ref) {
FILE: src/HVM/runtime/reduce/ref_sup.c
function Term (line 9) | Term reduce_ref_sup(Term ref, u16 idx) {
FILE: src/HVM/runtime/stack.c
function spush (line 3) | void spush(Term term, Term* sbuf, u64* spos) {
function Term (line 11) | Term spop(Term* sbuf, u64* spos) {
FILE: src/HVM/runtime/state.c
function State (line 17) | State* hvm_get_state() {
function hvm_set_state (line 21) | void hvm_set_state(State* hvm) {
function hvm_define (line 37) | void hvm_define(u16 fid, Term (*func)()) {
function hvm_set_cari (line 41) | void hvm_set_cari(u16 cid, u16 arity) {
function hvm_set_fari (line 45) | void hvm_set_fari(u16 fid, u16 arity) {
function hvm_set_clen (line 49) | void hvm_set_clen(u16 cid, u16 cases) {
function hvm_set_cadt (line 53) | void hvm_set_cadt(u16 cid, u16 adt) {
FILE: src/HVM/runtime/term.c
function Term (line 21) | Term term_new(Tag tag, Lab lab, Loc loc) {
function Tag (line 27) | Tag term_tag(Term x) {
function Lab (line 31) | Lab term_lab(Term x) {
function Loc (line 35) | Loc term_loc(Term x) {
function u64 (line 39) | u64 term_get_bit(Term x) {
function Term (line 43) | Term term_set_bit(Term x) {
function Term (line 47) | Term term_rem_bit(Term x) {
function Term (line 51) | Term term_set_loc(Term x, Loc loc) {
function _Bool (line 55) | _Bool term_is_atom(Term t) {
Condensed preview — 99 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (311K chars).
[
{
"path": ".github/ISSUE_TEMPLATE/bug_report.yml",
"chars": 1326,
"preview": "name: Bug report\ndescription: Create a report to help us improve.\nbody:\n - type: markdown\n attributes: \n value: |\n"
},
{
"path": ".github/ISSUE_TEMPLATE/config.yml",
"chars": 226,
"preview": "blank_issues_enabled: false\ncontact_links: \n - name: Bend Related Issues\n url: https://github.com/HigherOrderCO/"
},
{
"path": ".github/ISSUE_TEMPLATE/feature_request.md",
"chars": 591,
"preview": "---\nname: Feature request\nabout: Suggest a feature that you think should be added.\ntitle: ''\nlabels: ''\n\n---\n\n**Is your "
},
{
"path": ".github/workflows/CI.yml",
"chars": 2609,
"preview": "name: HVM3 CI\non:\n push:\n branches: [ main ]\n pull_request:\n branches: [ main ]\njobs:\n hvml-pipeline:\n name:"
},
{
"path": ".gitignore",
"chars": 233,
"preview": "dist-newstyle/\ndist-install/\n*.o\n*.hi\nmain\nMain1\ncabal-dev/\n.cabal-sandbox/\ncabal.sandbox.config\n.stack-work/\n*.prof\n*.a"
},
{
"path": "CLAUDE.md",
"chars": 152,
"preview": "# HVM3\n\nThis project is an efficient implementation of the Interaction Calculus.\n\nBefore doing any work, read the `HVM.m"
},
{
"path": "HVM.cabal",
"chars": 1782,
"preview": "cabal-version: 3.0\nname: HVM\nversion: 0.1.0.0\nhomepage: https://higherorderco.co"
},
{
"path": "HVM.md",
"chars": 10824,
"preview": "# HVM\n\nThe HVM is a extension, and efficient runtime, for the Interaction Calculus.\n\n## Project Organization\n\n- `README."
},
{
"path": "IC.md",
"chars": 6673,
"preview": "# The Interaction Calculus\n\nThe [Interaction Calculus](https://github.com/VictorTaelin/Interaction-Calculus)\nis a minima"
},
{
"path": "INTERS.md",
"chars": 2061,
"preview": "# HVM - Interaction Table\n\nTODO: this document is a WIP. It is not complete yet.\n\n## Core Interactions\n\nLambdas and Supe"
},
{
"path": "LICENSE",
"chars": 1057,
"preview": "Copyright (c) 2024 Victor Taelin\n\nPermission is hereby granted, free of charge, to any person obtaining\na copy of this s"
},
{
"path": "MODES.md",
"chars": 1009,
"preview": "# Evaluation Modes\n\n## Lazy Mode\n\nPointers represent positive-to-negative ports in polarized nets. This causes the\nmemor"
},
{
"path": "README.md",
"chars": 1954,
"preview": "# HVM3 - Work In Progress\n\nThe **HVM** is an efficient implementation of the [Interaction Calculus](https://github.com/V"
},
{
"path": "app/Main.hs",
"chars": 6295,
"preview": "module Main where\n\nimport Network.Socket as Network\nimport System.IO (hSetEncoding, utf8, hPutStrLn, stderr)\nimport Cont"
},
{
"path": "bug.hvm",
"chars": 102,
"preview": "@main =\n !c2_0 = λf !&0{f0 f1}=f λx(f0 (f1 x))\n !c2_1 = λf !&1{f0 f1}=f λx(f0 (f1 x))\n (c2_0 c2_1)\n"
},
{
"path": "cabal.project",
"chars": 146,
"preview": "packages: .\n\npackage *\n optimization: 2\n\nsource-repository-package\n type: git\n location: https://github.com/HigherOrd"
},
{
"path": "examples/_test_.js",
"chars": 9209,
"preview": "/**\n * HVM Test Script\n *\n * This script tests the HVM implementation by running a series of .hvm files\n * in both inter"
},
{
"path": "examples/bench_cnots.hvm",
"chars": 3261,
"preview": "@main = (@P24 @not @true)\n@true = λt λf t\n@false = λt λf f\n@not = λX (X @false @true)\n\n@P04 = λf\n ! &0{f00x f00y} ="
},
{
"path": "examples/bench_count.hs",
"chars": 154,
"preview": "import Data.Word\n\ncount :: Word32 -> Word32 -> Word32\ncount 0 k = k\ncount p k = count (p - 1) (k + 1)\n\nmain :: IO ()\nmai"
},
{
"path": "examples/bench_count.hvm",
"chars": 189,
"preview": "@count(!n k) = ~n !k {\n 0: k\n 1+p: @count(p,(+ k 2))\n}\n\n@main = @count(2_000_000_000 0)\n\n//WORK: 12000000004 interacti"
},
{
"path": "examples/bench_sum_range.hs",
"chars": 333,
"preview": "import Data.Word\n\ndata List = Nil | Cons !Word32 List\n\nrange :: Word32 -> List -> List\nrange 0 xs = xs\nrange n xs = rang"
},
{
"path": "examples/bench_sum_range.hvm",
"chars": 340,
"preview": "data List { #Nil #Cons{ head tail } }\n\n@sum(!xs r) = ~xs !r {\n #Nil: r\n #Cons{head tail}: @sum(tail (+ head r))\n}\n\n@ra"
},
{
"path": "examples/bench_sum_range.py",
"chars": 569,
"preview": "class Nil:\n def __init__(self):\n self.tag = \"Nil\"\n\nclass Cons:\n def __init__(self, head, tail):\n sel"
},
{
"path": "examples/enum_1D_match.hvm",
"chars": 8689,
"preview": "// This is similar to `enum_invert_add`, except the goal is harder:\n// > Can we find a displacement (rotations) that wil"
},
{
"path": "examples/enum_bin.hvm",
"chars": 5292,
"preview": "// Bitstrings\ndata Bin { #O{pred} #I{pred} #E }\n\n// Pairs\ndata Pair { #Pair{fst snd} }\n\n// If-Then-Else\n@if(b t f) = ~b "
},
{
"path": "examples/enum_coc_smart.hvm",
"chars": 5796,
"preview": "// Superposes dependently typed λ-terms. With it, solving:\n// (?X λt(t A B)) == λt(t B A)\n// Where\n// ?X : ∀A. (∀P. "
},
{
"path": "examples/enum_invert_add.hvm",
"chars": 4835,
"preview": "// This file shows how we can use superpositionn to apply multiple functions to\n// the same input, in a way that \"shares"
},
{
"path": "examples/enum_lam_naive_blc.hs",
"chars": 4876,
"preview": "-- This is the Haskell version of the naive λ-Calculus enumerator, that just\n-- generates all BLC strings and attempts o"
},
{
"path": "examples/enum_lam_naive_blc.hvm",
"chars": 4961,
"preview": "// This is the HVM version of the naive λ-Calculus enumerator. It superposes all\n// binary λ-calculus strings, parses, a"
},
{
"path": "examples/enum_lam_smart.hvm",
"chars": 9217,
"preview": "// An Optimal λ-Calculus Enumerator for Program Search\n// ---------------------------------------------------\n// This fi"
},
{
"path": "examples/enum_nat.hvm",
"chars": 1244,
"preview": "// This shows how to use a 'pseudo-metavar' to invert the binary add function,\n// and solve the equation: 'X * 20 = 5000"
},
{
"path": "examples/enum_path_finder.hvm",
"chars": 2475,
"preview": "// Simple path finding with superpositions\n\n// Lists\ndata List { #Nil #Cons{head tail} }\n\n// Directions (Left/Right/Up/D"
},
{
"path": "examples/enum_primes.hs",
"chars": 1631,
"preview": "-- //./pseudo_metavar_factors.hvml//\n\nimport Control.Monad (forM_, when)\nimport Data.Time.Clock (getCurrentTime, diffUTC"
},
{
"path": "examples/enum_primes.hvm",
"chars": 2153,
"preview": "// Bitstrings\ndata Bin { #O{pred} #I{pred} #E }\n\n// If-Then-Else\n@if(b t f) = ~b {\n 0: f\n _: t\n}\n\n// Converts a Bin to"
},
{
"path": "examples/feat_affine_ctx.hvm",
"chars": 3037,
"preview": "// Optimal recursive context passing with HVM's \"pure mutable references\"\n// Article: https://gist.github.com/VictorTael"
},
{
"path": "examples/feat_cmul.hvm",
"chars": 102,
"preview": "@main =\n !c2_0 = λf !&0{f0 f1}=f λx(f0 (f1 x))\n !c2_1 = λf !&1{f0 f1}=f λx(f0 (f1 x))\n (c2_0 c2_1)\n"
},
{
"path": "examples/feat_hoas.hvm",
"chars": 1100,
"preview": "data List {\n #Nil\n #Cons{head tail}\n}\n\ndata Term {\n #Var{nam}\n #Lam{nam bod}\n #App{fun arg}\n #Sub{val}\n}\n\n@cat(xs "
},
{
"path": "examples/feat_mut_ref.hvm",
"chars": 577,
"preview": "// Article: https://gist.github.com/VictorTaelin/fb798a5bd182f8c57dd302380f69777a\n\n@mut(ref fn) = !! $new = (fn (ref $ne"
},
{
"path": "examples/fuse_inc.hvm",
"chars": 818,
"preview": "// A minimal example of Optimal Evaluation (:\n\n// Bits (Native)\ndata Bits {\n #O{pred}\n #I{pred}\n #E{}\n}\n\n// Repeated "
},
{
"path": "examples/fuse_inc.hvm1",
"chars": 576,
"preview": "// Repeated Application\n(Rep 0 f x) = x\n(Rep n f x) = (f (Rep (- n 1) f x))\n\n// Squared Application\n(Sqr 0 f x) = x\n(Sqr"
},
{
"path": "examples/fuse_mul.hvm",
"chars": 1212,
"preview": "// Multiplication by squared addition with optimal evaluation\n\n// Repeated Application\n@rep(n f x) = ~ n !f !x {\n 0: x\n"
},
{
"path": "examples/fuse_rot.hvm",
"chars": 2143,
"preview": "// Relevant discussion:\n// https://discord.com/channels/912426566838013994/915345481675186197/1312147864373301329\n\ndata "
},
{
"path": "examples/main.hvm",
"chars": 4359,
"preview": "data List{ #Nil #Cons{head tail} }\ndata Foo{ #A #B }\ndata Bar{ #C #D }\n\ndata Term {\n #Var{idx}\n #Pol{bod}\n #All{inp b"
},
{
"path": "src/HVM/API.hs",
"chars": 4002,
"preview": "module HVM.API where\n\nimport Control.DeepSeq (deepseq)\nimport Control.Monad (when, forM_)\nimport Data.Word (Word64)\nimpo"
},
{
"path": "src/HVM/Adjust.hs",
"chars": 13028,
"preview": "module HVM.Adjust where\n\nimport Control.Monad\nimport Control.Monad.State\nimport Data.List (sortOn)\nimport Data.Word\nimpo"
},
{
"path": "src/HVM/Collapse.hs",
"chars": 15125,
"preview": "{-./Type.hs-}\n{-# LANGUAGE BangPatterns #-}\n\nmodule HVM.Collapse where\n\nimport Control.Monad (ap, forM, forM_)\nimport Co"
},
{
"path": "src/HVM/Compile.hs",
"chars": 37615,
"preview": "{-./../IC.md-}\n{-./Type.hs-}\n{-./Inject.hs-}\n\n{-# LANGUAGE TemplateHaskell #-}\n\nmodule HVM.Compile where\n\nimport Control"
},
{
"path": "src/HVM/Extract.hs",
"chars": 8837,
"preview": "{-./Type.hs-}\n{-./Inject.hs-}\n\nmodule HVM.Extract where\n\nimport Control.Monad (foldM, forM_, forM)\nimport Control.Monad."
},
{
"path": "src/HVM/Foreign.hs",
"chars": 6318,
"preview": "{-./Runtime.c-}\n\nmodule HVM.Foreign where\n\nimport Data.Word\nimport Foreign.Ptr\nimport HVM.Type\n\nforeign import ccall \"se"
},
{
"path": "src/HVM/Inject.hs",
"chars": 4678,
"preview": "{-./Type.hs-}\n\nmodule HVM.Inject where\n\nimport Control.Monad (foldM, when, forM_)\nimport Control.Monad.State\nimport Data"
},
{
"path": "src/HVM/Parse.hs",
"chars": 24041,
"preview": "{-./Type.hs-}\n\nmodule HVM.Parse where\n\nimport Control.Monad (foldM, forM, forM_, when)\nimport Control.Monad.State\nimport"
},
{
"path": "src/HVM/Reduce.hs",
"chars": 11017,
"preview": "{-./Type.hs-}\n{-./Foreign.hs-}\n\n-- NOTE: THIS FILE IS MISSING HTE INC/DEC INTERACTIONS. LET'S FIX IT\n\nmodule HVM.Reduce "
},
{
"path": "src/HVM/Runtime.c",
"chars": 1780,
"preview": "#include \"Runtime.h\"\n\n// Single translation unit aggregator for the C runtime.\n// Keeping hot paths in one TU restores i"
},
{
"path": "src/HVM/Runtime.h",
"chars": 5420,
"preview": "// Shared runtime declarations for HVM C runtime\n#pragma once\n\n#include <inttypes.h>\n#include <stdint.h>\n#include <stdio"
},
{
"path": "src/HVM/Type.hs",
"chars": 10583,
"preview": "module HVM.Type where\n\nimport Data.Word\nimport Foreign.Ptr\n\nimport Control.Applicative ((<|>))\nimport Control.DeepSeq\nim"
},
{
"path": "src/HVM/runtime/heap.c",
"chars": 1003,
"preview": "#include \"Runtime.h\"\n\n// Heap counters\nvoid set_len(u64 size) { *HVM.size = size; }\nvoid set_itr(u64 itrs) { *HVM.itrs ="
},
{
"path": "src/HVM/runtime/memory.c",
"chars": 1948,
"preview": "#include \"Runtime.h\"\n\nstatic void *alloc_huge(size_t size) {\n void *ptr = mmap(NULL, size, PROT_READ | PROT_WRITE,\n "
},
{
"path": "src/HVM/runtime/prim/DUP.c",
"chars": 1114,
"preview": "#include \"Runtime.h\"\n\n// Primitive: Dynamic Dup `@DUP(lab val λdp0λdp1(bod))`\n// Creates a DUP node with given label.\nTe"
},
{
"path": "src/HVM/runtime/prim/LOG.c",
"chars": 84,
"preview": "#include \"Runtime.h\"\n\nTerm LOG_f(Term ref) {\n printf(\"TODO: LOG_f\");\n exit(0);\n}\n\n"
},
{
"path": "src/HVM/runtime/prim/SUP.c",
"chars": 600,
"preview": "#include \"Runtime.h\"\n\n// Primitive: Dynamic Sup `@SUP(lab tm0 tm1)`\n// Allocates a new SUP node with given label.\nTerm S"
},
{
"path": "src/HVM/runtime/print.c",
"chars": 1155,
"preview": "#include \"Runtime.h\"\n\nvoid print_tag(Tag tag) {\n switch (tag) {\n case VAR: printf(\"VAR\"); break;\n case DP0: print"
},
{
"path": "src/HVM/runtime/reduce/app_ctr.c",
"chars": 198,
"preview": "#include \"Runtime.h\"\n\n// &L(#{x y z ...} a)\n// ------------------ APP-CTR\n// ⊥\nTerm reduce_app_ctr(Term app, Term ctr) {"
},
{
"path": "src/HVM/runtime/reduce/app_era.c",
"chars": 126,
"preview": "#include \"Runtime.h\"\n\n// (* a)\n// ------- APP-ERA\n// *\nTerm reduce_app_era(Term app, Term era) {\n inc_itr();\n return e"
},
{
"path": "src/HVM/runtime/reduce/app_lam.c",
"chars": 314,
"preview": "#include \"Runtime.h\"\n\n// (λx(body) arg)\n// ---------------- APP-LAM\n// x <- arg\n// body\nTerm reduce_app_lam(Term app, Te"
},
{
"path": "src/HVM/runtime/reduce/app_sup.c",
"chars": 742,
"preview": "#include \"Runtime.h\"\n\n// (&L{a b} c)\n// --------------------- APP-SUP\n// ! &L{x0 x1} = c\n// &L{(a x0) (b x1)}\nTerm reduc"
},
{
"path": "src/HVM/runtime/reduce/app_una.c",
"chars": 675,
"preview": "#include \"Runtime.h\"\n\n// (↑f x) / (↓f x)\n// ---------------- APP-INC/DEC\n// ↑(f x) / ↓(f x)\nTerm reduce_app_una(Term app"
},
{
"path": "src/HVM/runtime/reduce/app_w32.c",
"chars": 186,
"preview": "#include \"Runtime.h\"\n\n// &L(123 a)\n// --------- APP-W32\n// ⊥\nTerm reduce_app_w32(Term app, Term w32) {\n printf(\"invalid"
},
{
"path": "src/HVM/runtime/reduce/dup_ctr.c",
"chars": 945,
"preview": "#include \"Runtime.h\"\n\n// ! &L{x y} = #{a b c ...}\n// ------------------------ DUP-CTR\n// ! &L{a0 a1} = a\n// ! &L{b0 b1} "
},
{
"path": "src/HVM/runtime/reduce/dup_era.c",
"chars": 211,
"preview": "#include \"Runtime.h\"\n\n// ! &L{x y} = *\n// ------------- DUP-ERA\n// x <- *\n// y <- *\nTerm reduce_dup_era(Term dup, Term e"
},
{
"path": "src/HVM/runtime/reduce/dup_lam.c",
"chars": 906,
"preview": "#include \"Runtime.h\"\n\n// ! &L{r s} = λx(f)\n// ------------------- DUP-LAM\n// ! &L{f0 f1} = f\n// r <- λx0(f0)\n// s <- λx1"
},
{
"path": "src/HVM/runtime/reduce/dup_ref.c",
"chars": 983,
"preview": "#include \"Runtime.h\"\n\n// ! &L{x y} = @foo(a b c ...)\n// --------------------------- DUP-REF-COPY (when &L not in @foo)\n/"
},
{
"path": "src/HVM/runtime/reduce/dup_sup.c",
"chars": 1199,
"preview": "#include \"Runtime.h\"\n\n// ! &L{x y} = &R{a b}\n// ------------------- DUP-SUP\n// if L == R:\n// x <- a\n// y <- b\n// els"
},
{
"path": "src/HVM/runtime/reduce/dup_una.c",
"chars": 943,
"preview": "#include \"Runtime.h\"\n\n// ! &L{a b} = ↑x / ↓x\n// ------------- DUP-INC/DEC\n// ! &L{A B} = x\n// a <- ↑A / ↓A\n// b <- ↑B / "
},
{
"path": "src/HVM/runtime/reduce/dup_w32.c",
"chars": 219,
"preview": "#include \"Runtime.h\"\n\n// ! &L{x y} = 123\n// --------------- DUP-W32\n// x <- 123\n// y <- 123\nTerm reduce_dup_w32(Term dup"
},
{
"path": "src/HVM/runtime/reduce/let.c",
"chars": 235,
"preview": "#include \"Runtime.h\"\n\n// ! x = val\n// bod\n// --------- LET\n// x <- val\n// bod\nTerm reduce_let(Term let, Term val) {\n in"
},
{
"path": "src/HVM/runtime/reduce/mat_ctr.c",
"chars": 1638,
"preview": "#include \"Runtime.h\"\n\nTerm reduce_mat_ctr(Term mat, Term ctr) {\n inc_itr();\n Tag mat_tag = term_tag(mat);\n Loc mat_lo"
},
{
"path": "src/HVM/runtime/reduce/mat_era.c",
"chars": 151,
"preview": "#include \"Runtime.h\"\n\n// ~ * {K0 K1 K2 ...} \n// ------------------ MAT-ERA\n// *\nTerm reduce_mat_era(Term mat, Term era) "
},
{
"path": "src/HVM/runtime/reduce/mat_lam.c",
"chars": 173,
"preview": "#include \"Runtime.h\"\n\n// ~ λx(x) {K0 K1 K2 ...}\n// ------------------------ MAT-LAM\n// ⊥\nTerm reduce_mat_lam(Term mat, T"
},
{
"path": "src/HVM/runtime/reduce/mat_sup.c",
"chars": 1119,
"preview": "#include \"Runtime.h\"\n\n// ~ &L{x y} {K0 K1 K2 ...}\n// ------------------------ MAT-SUP\n// ! &L{k0a k0b} = K0\n// ! &L{k1a "
},
{
"path": "src/HVM/runtime/reduce/mat_una.c",
"chars": 547,
"preview": "#include \"Runtime.h\"\n\n// ~(↑x) {…} / ~(↓x) {…}\n// → ↑(~x {…}) / ↓(~x {…})\nTerm reduce_mat_una(Term mat, Term una, Tag "
},
{
"path": "src/HVM/runtime/reduce/mat_w32.c",
"chars": 561,
"preview": "#include \"Runtime.h\"\n\n// ~ num {K0 K1 K2 ... KN}\n// ----------------------- MAT-W32\n// if n < N: Kn\n// else : KN(num-"
},
{
"path": "src/HVM/runtime/reduce/opx_ctr.c",
"chars": 169,
"preview": "#include \"Runtime.h\"\n\n// <op(#{x0 x1 x2...} y)\n// --------------------- OPX-CTR\n// ⊥\nTerm reduce_opx_ctr(Term opx, Term "
},
{
"path": "src/HVM/runtime/reduce/opx_era.c",
"chars": 130,
"preview": "#include \"Runtime.h\"\n\n// <op(* b)\n// -------- OPX-ERA\n// *\nTerm reduce_opx_era(Term opx, Term era) {\n inc_itr();\n retu"
},
{
"path": "src/HVM/runtime/reduce/opx_lam.c",
"chars": 154,
"preview": "#include \"Runtime.h\"\n\n// <op(λx(B) y)\n// --------------- OPX-LAM\n// ⊥\nTerm reduce_opx_lam(Term opx, Term lam) {\n printf"
},
{
"path": "src/HVM/runtime/reduce/opx_sup.c",
"chars": 803,
"preview": "#include \"Runtime.h\"\n\n// <op(&L{x0 x1} y)\n// ------------------------- OPX-SUP\n// ! &L{y0 y1} = y\n// &L{<op(x0 y0) <op(x"
},
{
"path": "src/HVM/runtime/reduce/opx_una.c",
"chars": 589,
"preview": "#include \"Runtime.h\"\n\n// <op(↑x y) / <op(↓x y) → ↑<op(x y) / ↓<op(x y)\nTerm reduce_opx_una(Term opx, Term una, Tag tag"
},
{
"path": "src/HVM/runtime/reduce/opx_w32.c",
"chars": 314,
"preview": "#include \"Runtime.h\"\n\n// <op(x0 x1)\n// ---------- OPX-W32\n// >op(x0 x1)\nTerm reduce_opx_w32(Term opx, Term nmx) {\n inc_"
},
{
"path": "src/HVM/runtime/reduce/opy_ctr.c",
"chars": 168,
"preview": "#include \"Runtime.h\"\n\n// >op(#{x y z ...} b)\n// ---------------------- OPY-CTR\n// ⊥\nTerm reduce_opy_ctr(Term opy, Term c"
},
{
"path": "src/HVM/runtime/reduce/opy_era.c",
"chars": 130,
"preview": "#include \"Runtime.h\"\n\n// >op(a *)\n// -------- OPY-ERA\n// *\nTerm reduce_opy_era(Term opy, Term era) {\n inc_itr();\n retu"
},
{
"path": "src/HVM/runtime/reduce/opy_lam.c",
"chars": 151,
"preview": "#include \"Runtime.h\"\n\n// >op(a λx(B))\n// ------------ OPY-LAM\n// ⊥\nTerm reduce_opy_lam(Term opy, Term era) {\n printf(\"i"
},
{
"path": "src/HVM/runtime/reduce/opy_sup.c",
"chars": 613,
"preview": "#include \"Runtime.h\"\n\n// >op(a &L{x y})\n// --------------------- OPY-SUP\n// &L{>op(a x) >op(a y)}\nTerm reduce_opy_sup(Te"
},
{
"path": "src/HVM/runtime/reduce/opy_una.c",
"chars": 601,
"preview": "#include \"Runtime.h\"\n\n// >op(a ↑y) / >op(a ↓y) → ↑>op(a y) / ↓>op(a y)\nTerm reduce_opy_una(Term opy, Term una, Tag tag"
},
{
"path": "src/HVM/runtime/reduce/opy_w32.c",
"chars": 1034,
"preview": "#include \"Runtime.h\"\n\n// >op(x y)\n// --------- OPY-W32\n// x op y\nTerm reduce_opy_w32(Term opy, Term w32) {\n inc_itr();\n"
},
{
"path": "src/HVM/runtime/reduce/ref.c",
"chars": 175,
"preview": "#include \"Runtime.h\"\n\n// @foo(a b c ...)\n// -------------------- REF\n// book[foo](a b c ...)\nTerm reduce_ref(Term ref) {"
},
{
"path": "src/HVM/runtime/reduce/ref_sup.c",
"chars": 1520,
"preview": "#include \"Runtime.h\"\n\n// @foo(&L{ax ay} b c ...)\n// ----------------------- REF-SUP-COPY (when @L not in @foo)\n// ! &L{b"
},
{
"path": "src/HVM/runtime/reduce.c",
"chars": 5793,
"preview": "#include \"Runtime.h\"\n\n// Core reducer and helpers (dispatcher, WHNF, normal form)\n\nTerm reduce(Term term) {\n if (term_t"
},
{
"path": "src/HVM/runtime/stack.c",
"chars": 257,
"preview": "#include \"Runtime.h\"\n\nvoid spush(Term term, Term* sbuf, u64* spos) {\n if (*spos >= MAX_STACK_SIZE) {\n printf(\"Stack "
},
{
"path": "src/HVM/runtime/state.c",
"chars": 975,
"preview": "#include \"Runtime.h\"\n\nState HVM = {\n .sbuf = NULL,\n .spos = NULL,\n .heap = NULL,\n .size = NULL,\n .itrs = NULL,\n .f"
},
{
"path": "src/HVM/runtime/term.c",
"chars": 1408,
"preview": "// Term encoding and helpers\n// -------------------------\n// Layout (least-significant bit on the right):\n// [ 63 ...."
}
]
About this extraction
This page contains the full source code of the HigherOrderCO/HVM3 GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 99 files (284.8 KB), approximately 103.7k tokens, and a symbol index with 104 extracted functions, classes, methods, constants, and types. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.