[ { "path": ".github/ISSUE_TEMPLATE/bug_report.yml", "content": "name: Bug report\ndescription: Create a report to help us improve.\nbody:\n - type: markdown\n attributes: \n value: |\n ### Bug Report\n 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.\n\n ### For Windows Users\n 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).\n \n - type: textarea\n attributes:\n label: Reproducing the behavior\n description: A clear and concise description of what the bug is.\n value: |\n Example:\n Running command...\n With code....\n Error...\n Expected behavior....\n validations:\n required: true\n \n - type: textarea\n attributes:\n label: System Settings\n description: Your System's settings\n value: |\n Example:\n - OS: [e.g. Linux (Ubuntu 22.04)]\n - CPU: [e.g. Intel i9-14900KF]\n - GPU: [e.g. RTX 4090]\n - Cuda Version [e.g. release 12.4, V12.4.131]\n validations:\n required: true\n - type: textarea\n attributes:\n label: Additional context\n description: Add any other context about the problem here (Optional). \n \n" }, { "path": ".github/ISSUE_TEMPLATE/config.yml", "content": "blank_issues_enabled: false\ncontact_links: \n - name: Bend Related Issues\n url: https://github.com/HigherOrderCO/Bend/issues/new/choose\n about: For Bend related Issues, please Report them on the Bend repository. \n" }, { "path": ".github/ISSUE_TEMPLATE/feature_request.md", "content": "---\nname: Feature request\nabout: Suggest a feature that you think should be added.\ntitle: ''\nlabels: ''\n\n---\n\n**Is your feature request related to a problem? Please describe.**\nA clear and concise description of what the problem is. Ex. I'm frustrated when [...]\n\n**Describe the solution you'd like**\nA clear and concise description of what you want to happen.\n\n**Describe alternatives you've considered**\nA clear and concise description of any alternative solutions or features you've considered.\n\n**Additional context**\nAdd any other context or screenshots about the feature request here.\n" }, { "path": ".github/workflows/CI.yml", "content": "name: HVM3 CI\non:\n push:\n branches: [ main ]\n pull_request:\n branches: [ main ]\njobs:\n hvml-pipeline:\n name: HVM3 CI (${{ matrix.os }})\n runs-on: ${{ matrix.os }}\n strategy:\n fail-fast: false\n matrix:\n os: [ubuntu-latest, macos-latest]\n \n steps:\n - name: Checkout repository\n uses: actions/checkout@v3\n \n - name: Cache GHC and Cabal\n uses: actions/cache@v3\n id: cache-ghc\n with:\n path: |\n ~/.ghcup\n key: ${{ runner.os }}-ghcup-${{ hashFiles('.github/workflows/ci.yml') }}\n restore-keys: |\n ${{ runner.os }}-ghcup-\n \n - name: Set up GHC and Cabal\n uses: haskell-actions/setup@v2\n id: setup-haskell\n with:\n ghc-version: '9.12.2'\n cabal-version: '3.14.1.1'\n setup-haskell-bin: ${{ steps.cache-ghc.outputs.cache-hit != 'true' }}\n setup-haskell-cabal: ${{ steps.cache-ghc.outputs.cache-hit != 'true' }}\n setup-haskell-ghc: ${{ steps.cache-ghc.outputs.cache-hit != 'true' }}\n \n - name: Update Cabal package list\n run: cabal update\n \n - name: Install system dependencies\n run: |\n if [ \"${{ matrix.os }}\" == \"ubuntu-latest\" ]; then\n sudo apt-get update\n sudo apt-get install -y libffi-dev\n elif [ \"${{ matrix.os }}\" == \"macos-latest\" ]; then\n brew install libffi\n fi\n shell: bash\n \n - name: Cache Cabal packages\n uses: actions/cache@v3\n with:\n path: |\n ${{ steps.setup-haskell.outputs.cabal-store }}\n ~/.cabal/packages\n ~/.cabal/config\n key: ${{ runner.os }}-cabal-${{ hashFiles('**/*.cabal', 'cabal.project*') }}-${{ github.sha }}\n restore-keys: |\n ${{ runner.os }}-cabal-${{ hashFiles('**/*.cabal', 'cabal.project*') }}-\n ${{ runner.os }}-cabal-\n\n - name: Build dependencies\n run: cabal build --only-dependencies\n \n - name: Build the project\n run: cabal build\n \n - name: Lazy - Run interpreted normalization\n run: cabal run hvm -- run ./examples/feat_hoas.hvm -s\n \n - name: Lazy - Run compiled normalization\n run: cabal run hvm -- run ./examples/feat_hoas.hvm -c -s\n \n - name: Lazy - Run interpreted collapse\n run: cabal run hvm -- run ./examples/enum_lam_smart.hvm -C -s\n \n - name: Lazy - Run compiled collapse\n run: cabal run hvm -- run ./examples/enum_lam_smart.hvm -C -c -s\n" }, { "path": ".gitignore", "content": "dist-newstyle/\ndist-install/\n*.o\n*.hi\nmain\nMain1\ncabal-dev/\n.cabal-sandbox/\ncabal.sandbox.config\n.stack-work/\n*.prof\n*.aux\n*.hp\n*.eventlog\n.HTF/\n.ghc.environment.*\n.log.txt\n.msg.txt\n.sys.txt\n.out.hvm\ntmp/\nTIMES/\n.main*\n.build/\ndist/\n" }, { "path": "CLAUDE.md", "content": "# HVM3\n\nThis project is an efficient implementation of the Interaction Calculus.\n\nBefore doing any work, read the `HVM.md` file to learn more about it.\n" }, { "path": "HVM.cabal", "content": "cabal-version: 3.0\nname: HVM\nversion: 0.1.0.0\nhomepage: https://higherorderco.com/\nlicense: MIT\nlicense-file: LICENSE\nauthor: Victor Taelin\nmaintainer: victor.taelin@gmail.com\ncategory: Language\nbuild-type: Simple\nextra-source-files:\n src/HVM/Runtime.h\n src/HVM/runtime/*.c\n src/HVM/runtime/reduce/*.c\n src/HVM/runtime/prim/*.c\n\n\nlibrary\n default-language: GHC2024\n build-depends: base ^>=4.21.0.0,\n mtl ^>=2.3.1,\n containers ^>=0.7,\n parsec ^>=3.1.17.0,\n hs-highlight ^>= 1.0.5,\n ansi-terminal == 1.1.1,\n file-embed,\n process,\n libffi,\n unix,\n deepseq\n exposed-modules: HVM.Type\n , HVM.Collapse\n , HVM.Compile\n , HVM.Extract\n , HVM.Foreign\n , HVM.Inject\n , HVM.Parse\n , HVM.Adjust\n , HVM.Reduce\n , HVM.API\n other-modules:\n hs-source-dirs: src\n include-dirs: src/HVM\n includes: Runtime.h\n install-includes: Runtime.h\n -- Build the runtime as a single translation unit for performance\n c-sources: src/HVM/Runtime.c\n extra-libraries: c\n ghc-options: -Wno-all\n\nexecutable hvm\n default-language: GHC2024\n build-depends: base ^>=4.21.0.0,\n containers ^>=0.7,\n network\n main-is: Main.hs\n build-depends: HVM\n hs-source-dirs: app\n ghc-options: -Wno-all -threaded\n" }, { "path": "HVM.md", "content": "# HVM\n\nThe HVM is a extension, and efficient runtime, for the Interaction Calculus.\n\n## Project Organization\n\n- `README.md`: introduction and general information\n\n- `IC.md`: full spec of the Interaction Calculus (read it!)\n\n- `HVM.md`: full spec of the HVM runtime (read it!)\n\n- `Inters.md`: the complete interaction table\n\n- `examples/`: many example `.hvm` files\n\n- `src/`: Haskell and C implementation\n - `Type.hs`: defines the Term and Book types, used in all files (read it!)\n - `Show.hs`: converts a Term to a String\n - `Parse.hs`: converts a String to a Term\n - `Reduce.hs`: evaluates a Term to weak head normal form (WHNF)\n - `Inject.hs`: converts a Haskell-side Term to a C-side Term\n - `Extract.hs`: normalize and extracts a C-side Term into a Haskell-side IC Term\n - `Collapse.hs`: normalizes and collapses a C-side Term into a list of Haskell-side λC (i.e., dup/sup-free) Terms\n - `Foreign.hs`: imports C-side functions on Haskell-side\n - `Runtime.c`: the complete C runtime, including memory types, interactions, and a faster WHNF evaluator\n - `Compile.hs`: converts a top-level Book into a list of optimized, native C-code\n\n- `dist/`, `dist-newstyle`: Haskell artifacts\n\n## Memory Layout\n\nOn HVM, each Term is represented as a word, with the following fields:\n\n- `sub`: true if this is a substitution\n- `tag`: the tag identifying the term type\n- `lab`: a label, used to trigger commutations\n- `val`: the value (a node address, or an unboxed number)\n\nThe length of each field depends on the version:\n\n- **32-bit**: 1-bit sub | 5-bit tag | 2-bit lab | 24-bit val\n- **64-bit**: 1-bit sub | 5-bit tag | 18-bit lab | 40-bit val\n\nThe meaning of the val field depends on the term's tag, as follows:\n\nTag | ID | Value points to / stores ...\n--- | ---- | --------------------------------------\nDP0 | 0x00 | Dup Node ({val: Term}) or substitution\nDP1 | 0x01 | Dup Node ({val: Term}) or substitution\nVAR | 0x02 | Lam Node ({bod: Term}) or substitution\nFWD | 0x03 | TODO: document\nREF | 0x04 | Ref Node ({arg0: Term, ... argN: Term})\nLET | 0x05 | Let Node\nAPP | 0x06 | App Node ({fun: Term, arg: Term})\nMAT | 0x08 | Mat Node\nIFL | 0x09 | IfL Node\nSWI | 0x0A | Swi Node\nOPX | 0x0B | OpX Node\nOPY | 0x0C | OpY Node\nERA | 0x0D | Unused\nLAM | 0x0E | Lam Node ({bod: Term})\nSUP | 0x0F | Sup Node\nCTR | 0x10 | Ctr Node ({x0: Term, ... xN: Term})\nW32 | 0x11 | Unboxed U32 Number\nCHR | 0x12 | Unboxed U32 Number\n\nA Node is a consecutive block of its child terms. For example, the SUP term\npoints to the memory location where its two child terms are stored.\n\nVariable terms (`VAR`, `DP0`, and `DP1`) point to an entry on the subst map. As\nan optimization, HVM doesn't have a separate subst map. Instead, variables point\nto the location of the corresponding binder node (like a Lam or Dup). When an\ninteraction occurs, that location is reused as a subst map entry, and we set the\n'sub' bit of the stored term to '1'. When a variable points to a term with the\nbit flag set, we it is a substitution, so we retrieve it and clear the flag.\n\nNote that there is no explicit DUP term. That's because Dup nodes are special:\nthey aren't part of the AST, and they don't store a body; they \"float\" on the\nheap. In other words, `λx. !&0{x0,x1}=x; &0{x0,x1}` and `!&0{x0,x1}=x; λx.\n&0{x0,x1}` are both valid, and stored identically in memory. As such, the only\nway to access a Dup node is via its bound variables, `DP0` and `DP1`.\n\nNote that, when a Dup Node interacts, it usually generates two substitutions.\nSo, how can we store them in its location, given that a Dup Node has only one\nword? The answer is: we don't. Dup Nodes only interact when we access them\nvia either a `DP0` or a `DP1`. As such, we immediatelly return one of the\nsubstitutions to the variable that triggered the interaction, and store the\nother substitution on the Dup Node's location.\n\nFor example, the DUP-SUP interaction could be implemented as:\n\n```\ndef dup_sup(dup, sup):\n dup_lab = dup.tag & 0x3\n sup_lab = sup.tag & 0x3\n if dup_lab == sup_lab:\n tm0 = heap[sup.loc + 0]\n tm1 = heap[sup.loc + 1]\n heap[dup.loc] = as_sub(tm1 if (dup.tag & 0x4) == 0 else tm0)\n return (tm0 if (dup.tag & 0x4) == 0 else tm1)\n else:\n co0_loc = alloc(1)\n co1_loc = alloc(1)\n su0_loc = alloc(2)\n su1_loc = alloc(2)\n su0_val = Term(SP0 + sup_lab, su0_loc)\n su1_val = Term(SP0 + sup_lab, su1_loc)\n heap[co0_loc] = heap[sup.loc + 0]\n heap[co1_loc] = heap[sup.loc + 1]\n heap[su0_loc + 0] = Term(CX0 + dup_lab, co0_loc)\n heap[su0_loc + 1] = Term(CX0 + dup_lab, co1_loc)\n heap[su1_loc + 0] = Term(CY0 + dup_lab, co0_loc)\n heap[su1_loc + 1] = Term(CY0 + dup_lab, co1_loc)\n heap[dup.loc] = as_sub(su1_val if (dup.tag & 0x4) == 0 else su0_val)\n return (su0_val if (dup.tag & 0x4) == 0 else su1_val)\n```\n\nNote that HVM extends the Interaction Calculus with many new types and\ninteractions. The complete Interaction Table is at INTERS.md.\n\n## C FFI and Compiler\n\nIn this project, Terms have two representations:\n\n- A Haskell-side representation (the Term type on `Type.hs`)\n\n- A C-side representation (the pointer format specified on `HVM.md`)\n\nFunctions are implemented on Haskell, C, or both:\n\n- Interactions are exclusively implemented on C, except for CALL.\n\n- The WHNF function is implemented on both Haskell and C.\n\n- All other functions are implemented on Haskell only.\n\nThere are two evaluation modes:\n\n- Interpreted Mode:\n - uses Haskell-side parser, WHNF, collapser, and stringifier\n - uses Haskell-side CALL interaction\n - uses C-side for other interactions\n\n- Compiled Mode:\n - uses Haskell-side parser, collapser and strinigifier\n - uses C-side CALL interaction\n - uses C-side WHNF and interactions\n\nTo run HVM3 on Compiled Mode, we generate a new copy of `Runtime.c` with the\ncompiled functions inlined, and then compile with GCC and reload as a dylib.\nThis allows the C-side WHNF to dispatch CALL interactions to native C\nprocedures, which run much faster than `inject`.\n\n## The CALL interaction\n\nThe CALL interaction performs a global function call. For example, given:\n\n```\n@mul2(x) = ~ x { 0:0 p:(+ 2 @mul2(p)) }\n```\n\nWhen we evaluate the expression:\n\n```\n@foo(4)\n```\n\nIt will expand to:\n\n```\n~ 4 { 0:0 p:(+ 2 @mul2(p)) }\n```\n\nOn Interpreted Mode, this is done by `inject`, which allocates the body of the\nfunction, substituting variables by the respective arguments.\n\nOn Compiled Mode, this is done by calling a native C function, via two paths:\n\n`Slow Path`: a C function that just allocates the body, like `inject`. Example:\n\n```c\nTerm mul2_t(Term ref) {\n Term arg0 = got(term_loc(ref) + 0);\n Loc mat1 = alloc_node(3);\n set_new(mat1 + 0, arg0);\n set_new(mat1 + 1, term_new(W32, 0, 0));\n Loc lam2 = alloc_node(1);\n Loc opx3 = alloc_node(2);\n Loc ref4 = alloc_node(1);\n set_new(ref4 + 0, term_new(VAR, 0, lam2 + 0));\n set_new(opx3 + 0, term_new(W32, 0, 2));\n set_new(opx3 + 1, term_new(REF, 0, ref4));\n set_new(lam2 + 0, term_new(OPX, 0, opx3));\n set_new(mat1 + 2, term_new(LAM, 0, lam2));\n return term_new(SWI, 2, mat1);\n}\n```\n\n`Fast Path`: a C function that attempts to perform *inline interactions*,\navoiding allocating extra memory. For example, in the `mul2` case, it will check\nif the argument is a number. If so, it will perform a native C switch, instead\nof allocating a `SWI` node. It also performs inline arithmetic and even loops,\nwhen the function is tail-call recursive. Example:\n\n```c\nTerm mul2_f(Term ref) {\n u64 itrs = 0;\n Term arg0 = got(term_loc(ref) + 0);\n while (1) {\n Term val1 = (arg0);\n if (term_tag(val1) == W32) {\n u32 num2 = term_loc(val1);\n switch (num2) {\n case 0: {\n itrs += 1;\n *HVM.itrs += itrs;\n return term_new(W32, 0, 0);\n break;\n }\n default: {\n Term pre3 = term_new(W32, 0, num2 - 1);\n itrs += 2;\n Loc ref8 = alloc_node(1);\n set_new(ref8 + 0, pre3);\n Term nu06 = (term_new(W32, 0, 2));\n Term nu17 = (term_new(REF, 0, ref8));\n Term ret5;\n if (term_tag(nu06) == W32 && term_tag(nu17) == W32) {\n itrs += 2;\n ret5 = term_new(W32, 0, term_loc(nu06) + term_loc(nu17));\n } else {\n Loc opx4 = alloc_node(2);\n set_new(opx4 + 0, nu06);\n set_new(opx4 + 1, nu17);\n ret5 = term_new(OPX, 0, opx4);\n }\n *HVM.itrs += itrs;\n return ret5;\n break;\n }\n }\n }\n set_old(term_loc(ref) + 0, arg0);\n return mul2_t(ref);\n }\n}\n```\n\n# Parser\n\nOn HVM, all bound variables have global range. For example, consider the term:\n\n```\nλt.((t x) λx.λy.y)\n```\n\nHere, the `x` variable appears before its binder, `λx`. Since runtime variables\nmust point to their bound λ's, linking them correctly requires caution. A way to\ndo it is to store two structures at parse-time: a list from names to locations,\nand a map from names to variable terms.\n\nWhenever we parse a name, we add the current location to the 'uses' array, and\nwhenever we parse a binder (lams, lets, etc.), we add a variable term pointing\nto it to the 'vars' map. Then, once the parsing is done, we run iterate through\nthe 'uses' array, and write, to each location, the corresponding term. Below\nare some example parsers using this strategy:\n\n```python\ndef parse_var(loc):\n nam = parse_name()\n uses.push((nam,loc))\n\ndef parse_lam(loc):\n lam = alloc(1)\n consume(\"λ\")\n nam = parse_name()\n consume(\".\")\n vars[nam] = Term(VAR, 0, lam)\n parse_term(lam)\n heap[loc] = Term(LAM, 0, lam)\n\ndef parse_app(loc):\n app = alloc(2)\n consume(\"(\")\n parse_term(app + 0)\n consume(\" \")\n parse_term(app + 1)\n consume(\")\")\n heap[loc] = Term(APP, 0, app)\n\n...\n```\n\n# Stringifier\n\nConverting HVM terms to strings faces two challenges:\n\nFirst, HVM terms and nodes don't store variable names. As such, we must\ngenerate fresh, unique variable names during stringification, and maintain a\nmapping from each binder's memory location to its assigned name.\n\nSecond, on HVM, Dup nodes aren't part of the main program's AST. Instead, they\n\"float\" on the heap, and are only reachable via DP0 and DP1 variables. Because\nof that, by stringifying a term naively, Col nodes will be missing.\n\nTo solve these, we proceed as follows:\n\n1. Before stringifying, we pass through the full term, and assign a id to each\nvariable binder we find (on lam, let, dup, etc.)\n\n2. We also register every Dup node we found, avoiding duplicates (remember the\nsame dup node is pointed to by up to 2 variables, DP0 and DP1)\n\nThen, to stringify the term, we first stringify each DUP node, and then we\nstringify the actual term. As such, the result will always be in the form:\n\n! &{x0 x1} = t0\n! &{x2 x3} = t1\n! &{x4 x5} = t2\n...\nterm\n\nWith no Dup nodes inside the ASTs of t0, t1, t2 ... and term.\n" }, { "path": "IC.md", "content": "# The Interaction Calculus\n\nThe [Interaction Calculus](https://github.com/VictorTaelin/Interaction-Calculus)\nis a minimal term rewriting system inspired by the Lambda Calculus (λC), but\nwith some key differences:\n1. Vars are affine: they can only occur up to one time.\n2. Vars are global: they can occur anywhere in the program.\n3. There is a new core primitive: the superposition.\n\nAn Interaction Calculus term is defined by the following grammar:\n\n```haskell\nTerm ::=\n | VAR: Name\n | ERA: \"*\"\n | LAM: \"λ\" Name \".\" Term\n | APP: \"(\" Term \" \" Term \")\"\n | SUP: \"&\" Label \"{\" Term \",\" Term \"}\"\n | DUP: \"!\" \"&\" Label \"{\" Name \",\" Name \"}\" \"=\" Term \";\" Term\n```\n\nWhere:\n- VAR represents a variable.\n- ERA represents an erasure.\n- LAM represents a lambda.\n- APP represents a application.\n- SUP represents a superposition.\n- DUP represents a duplication.\n\nLambdas are curried, and work like their λC counterpart, except with a relaxed\nscope, and with affine usage. Applications eliminate lambdas, like in λC,\nthrough the beta-reduce (APP-LAM) interaction.\n\nSuperpositions work like pairs. Duplications eliminate superpositions through\nthe DUP-SUP interaction, which works exactly like a pair projection.\n\nWhat makes SUPs and DUPs unique is how they interact with LAMs and APPs. When a\nSUP is applied to an argument, it reduces through the APP-SUP interaction, and\nwhen a LAM is projected, it reduces through the DUP-LAM interaction. This gives\na computational behavior for every possible interaction: there are no runtime\nerrors on the core Interaction Calculus.\n\nThe 'Label' is a numeric value that affects some interactions, like DUP-SUP,\ncausing terms to commute, instead of annihilate. Read Lafont's Interaction\nCombinators paper to learn more.\n\nThe core interaction rules are listed below:\n\n```haskell\n(* a)\n----- APP-ERA\n*\n\n(λx.f a)\n-------- APP-LAM\nx <- a\nf\n\n(&L{a,b} c)\n----------------- APP-SUP\n! &L{c0,c1} = c;\n&L{(a c0),(b c1)}\n\n! &L{r,s} = *;\nK\n-------------- DUP-ERA\nr <- *\ns <- *\nK\n\n! &L{r,s} = λx.f;\nK\n----------------- DUP-LAM\nr <- λx0.f0\ns <- λx1.f1\nx <- &L{x0,x1}\n! &L{f0,f1} = f;\nK\n\n! &L{x,y} = &L{a,b};\nK\n-------------------- DUP-SUP (if equal labels)\nx <- a\ny <- b\nK\n\n! &L{x,y} = &R{a,b};\nK\n-------------------- DUP-SUP (if different labels)\nx <- &R{a0,b0} \ny <- &R{a1,b1}\n! &L{a0,a1} = a;\n! &L{b0,b1} = b;\nK\n```\n\nWhere `x <- t` stands for a global substitution of `x` by `t`.\n\nSince variables are affine, substitutions can be implemented efficiently by just\ninserting an entry in a global substitution map (`sub[var] = value`). There is\nno need to traverse the target term, or to handle name capture, as long as fresh\nvariable names are globally unique. Thread-safe substitutions can be performed\nwith a single atomic-swap.\n\nBelow is a pseudocode implementation of these interaction rules:\n\n```python\ndef app_lam(app, lam):\n sub[lam.nam] = app.arg\n return lam.bod\n\ndef app_sup(app, sup):\n x0 = fresh()\n x1 = fresh()\n a0 = App(sup.lft, Var(x0))\n a1 = App(sup.rgt, Var(x1))\n return Dup(sup.lab, x0, x1, app.arg, Sup(a0, a1))\n\ndef dup_lam(dup, lam):\n x0 = fresh()\n x1 = fresh()\n f0 = fresh()\n f1 = fresh()\n sub[dup.lft] = Lam(x0, Var(f0))\n sub[dup.rgt] = Lam(x1, Var(f1))\n sub[lam.nam] = Sup(dup.lab, Var(x0), Var(x1))\n return Dup(dup.lab, f0, f1, lam.bod, dup.bod)\n\ndef dup_sup(dup, sup):\n if dup.lab == sup.lab:\n sub[dup.lft] = sup.lft\n sub[dup.rgt] = sup.rgt\n return dup.bod\n```\n\nTerms can be reduced to weak head normal form, which means reducing until the\noutermost constructor is a value (LAM, SUP, etc.), or until no more reductions\nare possible. Example:\n\n```python\ndef whnf(term):\n while True:\n match term:\n case Var(nam):\n if nam in sub:\n term = sub[nam]\n else:\n return term\n case App(fun, arg):\n fun = whnf(fun)\n match fun.tag:\n case LAM: term = app_lam(term, fun)\n case SUP: term = app_sup(term, fun)\n case _ : return App(fun, arg)\n case Dup(lft, rgt, val, bod):\n val = whnf(val)\n match val.tag:\n case LAM: term = dup_lam(term, val)\n case SUP: term = dup_sup(term, val)\n case _ : return Dup(lft, rgt, val, bod)\n case _:\n return term\n```\n\nTerms can be reduced to full normal form by recursively taking the whnf:\n\n```python\ndef normal(term):\n term = whnf(term)\n match term:\n case Lam(nam, bod):\n bod_nf = normal(bod)\n return Lam(nam, bod_nf)\n case App(fun, arg):\n fun_nf = normal(fun)\n arg_nf = normal(arg)\n return App(fun_nf, arg_nf)\n ...\n case _:\n return term\n```\n\nBelow are some normalization examples.\n\nExample 0: (simple λ-term)\n\n```haskell\n(λx.λt.(t x) λy.y)\n------------------ APP-LAM\nλt.(t λy.y)\n```\n\nExample 1: (larger λ-term)\n\n```haskell\n(λb.λt.λf.((b f) t) λT.λF.T)\n---------------------------- APP-LAM\nλt.λf.((λT.λF.T f) t)\n----------------------- APP-LAM\nλt.λf.(λF.t f)\n-------------- APP-LAM\nλt.λf.t\n```\n\nExample 2: (global scopes)\n\n```haskell\n{x,(λx.λy.y λk.k)}\n------------------ APP-LAM\n{λk.k,λy.y}\n```\n\nExample 3: (superposition)\n\n```haskell\n!{a,b} = {λx.x,λy.y}; (a b)\n--------------------------- DUP-SUP\n(λx.x λy.y)\n----------- APP-LAM\nλy.y\n```\n\nExample 4: (overlap)\n\n```haskell\n({λx.x,λy.y} λz.z)\n------------------ APP-SUP \n! {x0,x1} = λz.z; {(λx.x x0),(λy.y x1)} \n--------------------------------------- DUP-LAM \n! {f0,f1} = {r,s}; {(λx.x λr.f0),(λy.y λs.f1)} \n---------------------------------------------- DUP-SUP \n{(λx.x λr.r),(λy.y λs.s)} \n------------------------- APP-LAM \n{λr.r,(λy.y λs.s)} \n------------------ APP-LAM \n{λr.r,λs.s} \n```\n\nExample 5: (default test term)\n\nThe following term can be used to test all interactions:\n\n```haskell\n((λf.λx.!{f0,f1}=f;(f0 (f1 x)) λB.λT.λF.((B F) T)) λa.λb.a)\n----------------------------------------------------------- 16 interactions\nλa.λb.a\n```\n\n# Collapsing\n\nAn Interaction Calculus term can be collapsed to a superposed tree of pure\nLambda Calculus terms without SUPs and DUPs, by extending the evaluator with the\nfollowing collapse interactions:\n\n```haskell\nλx.*\n------ ERA-LAM\nx <- *\n*\n\n(f *)\n----- ERA-APP\n*\n\nλx.&L{f0,f1}\n----------------- SUP-LAM\nx <- &L{x0,x1}\n&L{λx0.f0,λx1.f1}\n\n(f &L{x0,x1})\n------------------- SUP-APP\n!&L{f0,f1} = f;\n&L{(f0 x0),(f1 x1)}\n\n&R{&L{x0,x1},y}\n----------------------- SUP-SUP-X (if R>L)\n!&R{y0,y1} = y;\n&L{&R{x0,x1},&R{y0,y1}}\n\n&R{x,&L{y0,y1}}\n----------------------- SUP-SUP-Y (if R>L)\n!&R{x0,x1} = x;\n&L{&R{x0,x1},&R{y0,y1}}\n\n!&L{x0,x1} = x; K\n----------------- DUP-VAR\nx0 <- x\nx1 <- x\nK\n\n!&L{a0,a1} = (f x); K\n--------------------- DUP-APP\na0 <- (f0 x0)\na1 <- (f1 x1)\n!&L{f0,f1} = f;\n!&L{x0,x1} = x;\nK\n```\n" }, { "path": "INTERS.md", "content": "# HVM - Interaction Table\n\nTODO: this document is a WIP. It is not complete yet.\n\n## Core Interactions\n\nLambdas and Superpositions:\n\n```haskell\n(* a)\n----- APP-ERA\n*\n\n(λx.f a)\n-------- APP-LAM\nx <- a\nf\n\n(&L{a,b} c)\n----------------- APP-SUP\n! &L{c0,c1} = c;\n&L{(a c0),(b c1)}\n\n! &L{r,s} = *;\nK\n-------------- DUP-ERA\nr <- *\ns <- *\nK\n\n! &L{r,s} = λx.f;\nK\n----------------- DUP-LAM\nr <- λx0.f0\ns <- λx1.f1\nx <- &L{x0,x1}\n! &L{f0,f1} = f;\nK\n\n! &L{x,y} = &L{a,b};\nK\n-------------------- DUP-SUP (if equal labels)\nx <- a\ny <- b\nK\n\n! &L{x,y} = &R{a,b};\nK\n-------------------- DUP-SUP (if different labels)\nx <- &R{a0,b0} \ny <- &R{a1,b1}\n! &L{a0,a1} = a;\n! &L{b0,b1} = b;\nK\n```\n\nNumbers:\n\n```haskell\n+N\n--- SUC-NUM\nN+1\n\n+*\n-- SUC-ERA\n*\n\n+&L{x,y}\n--------- SUC-SUP\n&L{+x,+y}\n\n?N{0:z;+:s;}\n------------ SWI-NUM (if N==0)\nz\n\n?N{0:z;+:s;}\n------------ SWI-NUM (if N>0)\n(s N-1)\n\n?*{0:z;+:s;}\n------------ SWI-ERA\n*\n\n?&L{x,y}{0:z;+:s;}\n--------------------------------- SWI-SUP\n!&L{z0,z1} = z;\n!&L{s0,s1} = s;\n&L{?x{0:z0;+:s0;},?y{0:z1;+:s1;}}\n\n! &L{x,y} = N;\nK\n-------------- DUP-NUM\nx <- N\ny <- N\nK\n```\n\n## Collapsing Interactions\n\nThese interactions are NOT part of the WHNF. They're called by the collapser.\n\n```haskell\nλx.*\n------ ERA-LAM\nx <- *\n*\n\n(f *)\n----- ERA-APP\n*\n\nλx.&L{f0,f1}\n----------------- SUP-LAM\nx <- &L{x0,x1}\n&L{λx0.f0,λx1.f1}\n\n(f &L{x0,x1})\n------------------- SUP-APP\n!&L{f0,f1} = f;\n&L{(f0 x0),(f1 x1)}\n\n~N{0:&L{z0,z1};+:s;}\n--------------------------------- SUP-SWI-Z\n!&L{N0,N1} = N;\n!&L{S0,S1} = S;\n&L{~N0{0:z0;+:S0},~N1{0:z1;+:S1}}\n\n~N{0:z;+:&0{s0,s1};}\n--------------------------------- SUP-SWI-S\n!&L{N0,N1} = N;\n!&L{Z0,Z1} = Z;\n&L{~N0{0:z0;+:S0},~N1{0:z1;+:S1}}\n\n&R{&L{x0,x1},y}\n----------------------- SUP-SUP-X (if R>L)\n!&R{y0,y1} = y;\n&L{&R{x0,x1},&R{y0,y1}}\n\n&R{x,&L{y0,y1}}\n----------------------- SUP-SUP-Y (if R>L)\n!&R{x0,x1} = x;\n&L{&R{x0,x1},&R{y0,y1}}\n\n!&L{x0,x1} = x; K\n----------------- DUP-VAR\nx0 <- x\nx1 <- x\nK\n\n!&L{a0,a1} = (f x); K\n--------------------- DUP-APP\na0 <- (f0 x0)\na1 <- (f1 x1)\n!&L{f0,f1} = f;\n!&L{x0,x1} = x;\nK\n```\n" }, { "path": "LICENSE", "content": "Copyright (c) 2024 Victor Taelin\n\nPermission is hereby granted, free of charge, to any person obtaining\na copy of this software and associated documentation files (the\n\"Software\"), to deal in the Software without restriction, including\nwithout limitation the rights to use, copy, modify, merge, publish,\ndistribute, sublicense, and/or sell copies of the Software, and to\npermit persons to whom the Software is furnished to do so, subject to\nthe following conditions:\n\nThe above copyright notice and this permission notice shall be included\nin all copies or substantial portions of the Software.\n\nTHE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,\nEXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF\nMERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.\nIN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY\nCLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,\nTORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE\nSOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.\n" }, { "path": "MODES.md", "content": "# Evaluation Modes\n\n## Lazy Mode\n\nPointers represent positive-to-negative ports in polarized nets. This causes the\nmemory format to coincide perfectly with how IC terms are written textually. It\nis a direct improvement of [HVM1](https://github.com/HigherOrderCO/hvm1). It is\nimplemented in this repository.\n\n### Strengths:\n\n- Efficient lazy evaluation\n- Lévy Optimality (minimal β-reduction)\n- Very fast single-core evaluation\n- Compiles to efficient C (often, faster than GHC)\n\n### Drawbacks:\n\n- WHNF may return a pending variable\n- Requires global garbage collection\n- Parallelism is still an open problem\n\n## Strict Mode\n\nPointers represent aux-to-main ports, resulting in a tree-like memory format. It\nis implemented in a [separate repository](https://github.com/HigherOrderCO/hvm3-strict),\nand will be merged later.\n\n### Strengths:\n\n- Efficient parallel evaluation\n- Does not require global garbage collection\n\n### Drawbacks:\n\n- Lazy evaluation is impossible\n\n- Not Lévy Optimal (can waste β-reductions)\n" }, { "path": "README.md", "content": "# HVM3 - Work In Progress\n\nThe **HVM** is an efficient implementation of the [Interaction Calculus](https://github.com/VictorTaelin/Interaction-Calculus) (IC).\n\nThe Interaction Calculus is a new foundation for computing, similar to the\nLambda Calculus, but theoretically optimal. The HVM is an efficient\nimplementation of this new paradigm, and can be seen as a fast engine for\nsymbolic computations.\n\nIn some ways, it is very similar to Haskell, but it has some key differences:\n- Lambdas must be linear or affine, making it resource-aware\n- Lambdas have no scope boundaries, enabling global substitutions\n- First-class duplications allow a term to be copied into two locations\n- First-class superpositions allow 2 terms to be stored in 1 location\n\nThese primitives allow HVM to natively represent concepts that are not present\nin the traditional λ-Calculus, including continuations, linear HOAS interpreters\nand mutable references. Moreover, superpositions and duplications allow it to\nperform optimal beta-reduction, allowing some expressions to be evaluated with\nan exponential speedup. Finally, being fully affine makes its garbage collector\nvery efficient, and greatly simplifies parallelism.\n\nThe HVM3 is the successor to HVM1 and HVM2, combining their strengths. It aims\nto be the main compile target of [Bend](https://github.com/HigherOrderCO/Bend).\nIt is a WIP under active development.\n\n## Specifications\n\n- [IC.md](./IC.md): Interaction Calculus, the theoretical foundation behind HVM\n\n- [HVM.md](./HVM.md): the HVM language, which extends IC with pragmatic primitives\n\n## Install\n\n1. Install Cabal.\n\n3. Clone this repository.\n\n3. Run `cabal install`.\n\n## Usage\n\n```bash\nhvm run file.hvml # runs interpreted (slow)\nhvm run file.hvml -c # runs compiled (fast)\n```\n\nNote: the `-c` flag will also generate a standalone `.main.c` file, which if you\nwant, you can compile and run it independently. See examples in the [book/](book/) directory.\n" }, { "path": "app/Main.hs", "content": "module Main where\n\nimport Network.Socket as Network\nimport System.IO (hSetEncoding, utf8, hPutStrLn, stderr)\nimport Control.Exception (try, fromException, SomeException, finally, AsyncException(UserInterrupt))\nimport Control.Monad (when, forM_, unless)\nimport Data.List (partition, isPrefixOf, find)\nimport HVM.API\nimport HVM.Collapse\nimport HVM.Extract\nimport HVM.Foreign\nimport HVM.Parse\nimport HVM.Reduce\nimport HVM.Type\nimport System.Environment (getArgs)\nimport System.Exit (exitWith, ExitCode(ExitSuccess, ExitFailure))\nimport System.IO\nimport Text.Printf\nimport Text.Read (readMaybe)\nimport qualified Data.Map.Strict as MS\n\n-- Main\n-- ----\n\nmain :: IO ()\nmain = do\n args <- getArgs\n result <- case args of\n (\"run\" : file : rest) -> do\n let (flags, sArgs) = partition (\"-\" `isPrefixOf`) rest\n let compiled = \"-c\" `elem` flags\n let collapseFlag = Data.List.find (isPrefixOf \"-C\") flags >>= parseCollapseFlag\n let stats = \"-s\" `elem` flags\n let debug = \"-d\" `elem` flags\n let hideQuotes = \"-Q\" `elem` flags\n let mode = case collapseFlag of { Just n -> Collapse n ; Nothing -> Normalize }\n cliRun file debug compiled mode stats hideQuotes sArgs\n (\"serve\" : file : rest) -> do\n let (flags, _) = partition (\"-\" `isPrefixOf`) rest\n let compiled = \"-c\" `elem` flags\n let collapseFlag = Data.List.find (isPrefixOf \"-C\") flags >>= parseCollapseFlag\n let stats = \"-s\" `elem` flags\n let debug = \"-d\" `elem` flags\n let hideQuotes = \"-Q\" `elem` flags\n let mode = case collapseFlag of { Just n -> Collapse n ; Nothing -> Normalize }\n cliServe file debug compiled mode stats hideQuotes\n [\"help\"] -> printHelp\n _ -> printHelp\n case result of\n Left err -> do\n putStrLn err\n exitWith (ExitFailure 1)\n Right _ -> do\n exitWith ExitSuccess\n\nparseCollapseFlag :: String -> Maybe (Maybe Int)\nparseCollapseFlag ('-':'C':rest) = \n case rest of\n \"\" -> Just Nothing\n n -> Just (readMaybe n)\nparseCollapseFlag _ = Nothing\n\nprintHelp :: IO (Either String ())\nprintHelp = do\n putStrLn \"HVM usage:\"\n putStrLn \" hvm3 help # Shows this help message\"\n putStrLn \" hvm3 run [flags] [args...] # Evals main\"\n putStrLn \" hvm3 serve [flags] # Starts socket server on port 8080\"\n putStrLn \" -c # Runs with compiled mode (fast)\"\n putStrLn \" -C # Collapse the result to a list of λ-Terms\"\n putStrLn \" -CN # Same as above, but show only first N results\"\n putStrLn \" -s # Show statistics\"\n putStrLn \" -d # Print execution steps (debug mode)\"\n putStrLn \" -Q # Hide quotes in output\"\n return $ Right ()\n\n-- CLI Commands\n-- ------------\n\ncliRun :: FilePath -> Bool -> Bool -> RunMode -> Bool -> Bool -> [String] -> IO (Either String ())\ncliRun filePath debug compiled mode showStats hideQuotes strArgs = do\n code <- readFile' filePath\n book <- doParseBook filePath code\n hvmInit\n initBook filePath book compiled\n checkHasMain book\n args <- doParseArguments book strArgs\n checkMainArgs book args\n (_, stats) <- withRunStats $ do\n injectRoot book (Ref \"main\" maxBound args)\n rxAt <- if compiled\n then return (reduceCAt debug)\n else return (reduceAt debug)\n case mode of\n Collapse limit -> do\n core <- doCollapseFlatAt rxAt book 0\n let vals = maybe id Prelude.take limit core\n forM_ vals $ \\val -> do -- Collapse and print the result line by line lazily\n let out = if hideQuotes then removeQuotes (show val) else show val\n printf \"%s\\n\" out\n Normalize -> do\n core <- doExtractCoreAt rxAt book 0\n let val = doLiftDups core\n let out = if hideQuotes then removeQuotes (show val) else show val\n printf \"%s\\n\" out\n hvmFree\n when showStats $ do\n print stats\n return $ Right ()\n\ncliServe :: FilePath -> Bool -> Bool -> RunMode -> Bool -> Bool -> IO (Either String ())\ncliServe filePath debug compiled mode showStats hideQuotes = do\n code <- readFile' filePath\n book <- doParseBook filePath code\n hvmInit\n initBook filePath book compiled\n checkHasMain book\n putStrLn \"HVM serve mode. Listening on port 8080.\"\n sock <- socket AF_INET Stream 0\n setSocketOption sock ReuseAddr 1\n Network.bind sock (SockAddrInet 8080 0)\n listen sock 5\n putStrLn \"Server started. Listening on port 8080.\"\n serverLoop sock book `finally` do\n close sock\n hvmFree\n putStrLn \"\\nServer terminated.\"\n return $ Right ()\n where\n serverLoop sock book = do\n result <- try $ do\n (conn, _) <- accept sock\n h <- socketToHandle conn ReadWriteMode\n hSetBuffering h LineBuffering\n hSetEncoding h utf8\n input <- hGetLine h\n unless (input == \"exit\" || input == \"quit\") $ do\n oldSize <- getLen\n args <- doParseArguments book [input]\n checkMainArgs book args\n let root = Ref \"main\" maxBound args\n (vals, stats) <- runBook book root mode compiled debug\n let out = unlines $ map (\\t -> if hideQuotes then removeQuotes (show t) else show t) vals\n hPutStrLn h out\n when showStats $ do\n hPutStrLn h (show stats)\n setItr 0\n setLen oldSize\n hClose h\n case result of\n Left e -> case fromException e of\n Just UserInterrupt -> return () -- Exit loop on Ctrl+C\n _ -> do\n hPutStrLn stderr $ \"Connection error: \" ++ show (e :: SomeException)\n serverLoop sock book\n Right _ -> serverLoop sock book\n\nremoveQuotes :: String -> String\nremoveQuotes s = case s of\n '\"':rest -> init rest -- Remove first and last quote if present\n _ -> s -- Otherwise return as-is\n\ncheckHasMain :: Book -> IO ()\ncheckHasMain book = do\n when (not $ MS.member \"main\" (namToFid book)) $ do\n putStrLn \"Error: 'main' not found.\"\n exitWith (ExitFailure 1)\n\ncheckMainArgs :: Book -> [Core] -> IO ()\ncheckMainArgs book args = do\n let ((_, mainArgs), _) = mget (fidToFun book) (mget (namToFid book) \"main\")\n when (length args /= length mainArgs) $ do\n putStrLn $ \"Error: 'main' expects \" ++ show (length mainArgs) ++ \" arguments, found \" ++ show (length args)\n exitWith (ExitFailure 1)\n" }, { "path": "bug.hvm", "content": "@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", "content": "packages: .\n\npackage *\n optimization: 2\n\nsource-repository-package\n type: git\n location: https://github.com/HigherOrderCO-archive/hs-highlight\n" }, { "path": "examples/_test_.js", "content": "/**\n * HVM Test Script\n *\n * This script tests the HVM implementation by running a series of .hvm files\n * in both interpreted and compiled modes, as specified in the test table.\n * For each test case:\n * - If a 'main' line is provided, it replaces the '@main' line in the original file\n * and saves it as '_test_.hvm'. Otherwise, it copies the original file to '_test_.hvm'.\n * - Runs the test 4 times:\n * - First run: Extracts the result (first line of output) and checks it against\n * the expected 'norm'. Logs an error if they don't match.\n * - Next 3 runs: Measures the execution time (from the 'TIME:' line in output).\n * - Averages the times from the last 3 runs.\n * - Compares the average time with the previous run's time stored in '_perf_.json'.\n * If the new time is >5% slower and the total run time is >= 0.05 seconds, logs a warning.\n * - Updates '_perf_.json' with the new average times after all tests.\n *\n * Key Notes:\n * - Only runs modes ('intr' or 'comp') specified in the test table for each file.\n * - Some tests lack a 'main' line, meaning no replacement is needed—just copy the file.\n * - Uses Node.js 'fs' for file operations and 'child_process.execSync' to run commands.\n * - Assumes the script runs in a directory containing the .hvm files.\n * - Commands use a hardcoded project directory (/Users/v/vic/dev/HVM) for interpreted mode.\n */\n\nconst fs = require('fs');\nconst { execSync } = require('child_process');\n\n// ### Test Specifications\n// Array of test objects, each defining a file and its test cases for 'intr' (interpreted)\n// and/or 'comp' (compiled) modes. Each mode object has an expected 'norm' and an optional 'main'.\nconst tests = [\n {\n file: 'bench_cnots.hvm',\n intr: { main: '@main = (@P20 @not @true)', norm: 'λa λb a' },\n comp: { main: '@main = (@P24 @not @true)', norm: 'λa λb a' }\n },\n {\n file: 'bench_count.hvm',\n intr: { main: '@main = @count(2_000_000 0)', norm: '4000000' },\n comp: { main: '@main = @count(2_000_000_000 0)', norm: '4000000000' }\n },\n {\n file: 'bench_sum_range.hvm',\n intr: { main: '@main = @sum(@range(1_000_000 #Nil) 0)', norm: '1783293664' },\n comp: { main: '@main = @sum(@range(300_000_000 #Nil) 0)', norm: '3992170112' }\n },\n {\n file: 'enum_coc_smart.hvm',\n intr: { norm: '\"λλ(0 λλ((1 3) 2))\"' },\n comp: { norm: '\"λλ(0 λλ((1 3) 2))\"' }\n },\n {\n file: 'enum_lam_naive_blc.hvm',\n comp: { norm: '\"λλ(1 λλ((2 0) 1))\"' }\n },\n {\n file: 'enum_lam_smart.hvm',\n intr: { norm: '\"λ(0 λλλ((0 1) 2))\"' },\n comp: { norm: '\"λ(0 λλλ((0 1) 2))\"' }\n },\n {\n file: 'enum_nat.hvm',\n intr: { main: '@main = @if(@eq(@mul(@X @nat(20)) @nat(12000)) @u32(@X) *)', norm: '600' },\n comp: { main: '@main = @if(@eq(@mul(@X @nat(20)) @nat(20000)) @u32(@X) *)', norm: '1000' }\n },\n {\n file: 'enum_primes.hvm',\n 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)' },\n 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)' }\n },\n {\n file: 'feat_affine_ctx.hvm',\n intr: { norm: '1' },\n comp: { norm: '1' }\n },\n {\n file: 'feat_cmul.hvm',\n intr: { norm: 'λa λb (a (a (a (a b))))' },\n comp: { norm: 'λa λb (a (a (a (a b))))' }\n },\n {\n file: 'feat_hoas.hvm',\n intr: { norm: '\"λx λy (x (x (x (x y))))\"' },\n comp: { norm: '\"λx λy (x (x (x (x y))))\"' }\n },\n {\n file: 'feat_mut_ref.hvm',\n intr: { norm: '2' },\n comp: { norm: '2' }\n },\n {\n file: 'fuse_inc.hvm',\n intr: { norm: '1234567' },\n comp: { norm: '1234567' }\n },\n {\n file: 'fuse_mul.hvm',\n intr: { main: '@main = @mul(12345 12345)', norm: '152399025' },\n comp: { main: '@main = @mul(23232 32323)', norm: '750927936' }\n },\n {\n file: 'fuse_rot.hvm',\n intr: { main: '@main = (@read(@S) @sqr(12345 (@add(@S) @KA) @KB))', norm: '209865' },\n comp: { main: '@main = (@read(@S) @sqr(54321 (@add(@S) @KA) @KB))', norm: '923457' }\n },\n {\n file: 'enum_1D_match.hvm',\n intr: { main: '@main = @solve(16)', norm: '64' },\n comp: { main: '@main = @solve(18)', norm: '64' }\n },\n];\n\n// ### Load Previous Performance Data\n// Load '_perf_.json' if it exists, otherwise initialize an empty object.\nlet perfData = {};\ntry {\n perfData = JSON.parse(fs.readFileSync('_perf_.json', 'utf8'));\n} catch (e) {\n console.log('[INFO] _perf_.json not found, initializing as empty.');\n}\n\n// ### Counters for Errors and Warnings\n// Track the number of errors (result mismatches) and warnings (perf regressions).\nlet errorCount = 0;\nlet warningCount = 0;\n\n// ### Main Test Loop\nfor (const test of tests) {\n const file = test.file;\n // Check each mode: 'intr' (interpreted) and 'comp' (compiled).\n for (const mode of ['intr', 'comp']) {\n if (test[mode]) { // Only run if the mode is specified in the test.\n console.log(`Running ${file} in ${mode} mode...`);\n const { main, norm } = test[mode];\n\n // Prepare the test file by adjusting '@main' or copying as needed.\n prepareTestFile(file, main);\n\n let times = [];\n for (let i = 0; i < 4; i++) {\n const output = runTest(mode);\n const { result, time } = parseOutput(output);\n\n console.log(\"- time:\", time.toFixed(7), \"| norm: \" + result);\n\n if (i === 0) {\n // First run: Check the result against the expected norm.\n if (result !== norm) {\n console.log(`[ERROR] For ${file} in ${mode} mode, expected \"${norm}\", but got \"${result}\"`);\n errorCount++;\n }\n } else {\n // Next 3 runs: Collect execution times.\n times.push(time);\n }\n }\n\n // Calculate average time from the last 3 runs.\n const averageTime = times.reduce((a, b) => a + b, 0) / times.length;\n const key = `${file}_${mode}`; // Unique key for this test and mode.\n const previousTime = perfData[key];\n\n // Check for performance regression (>5% slower) if previous data exists and time >= 0.05s.\n if (previousTime && averageTime > previousTime * 1.05 && averageTime >= 0.05) {\n console.log(`[WARNING] Performance regression for ${file} in ${mode} mode: ` +\n `previous ${previousTime.toFixed(6)}s, now ${averageTime.toFixed(6)}s`);\n warningCount++;\n }\n\n // Update performance data with the new average time.\n perfData[key] = averageTime;\n }\n }\n}\n\n// ### Save Updated Performance Data\n// Write the new performance data to '_perf_.json' with readable formatting.\nfs.writeFileSync('_perf_.json', JSON.stringify(perfData, null, 2), 'utf8');\n\n// ### Summary\n// Log the total number of errors and warnings.\nconsole.log(`All tests completed with ${errorCount} errors and ${warningCount} warnings.`);\n\n// ### Helper Functions\n\n/**\n * Prepares the test file by replacing the '@main' line or copying the original file.\n * @param {string} originalFile - The original .hvm file path.\n * @param {string|undefined} mainLine - The new '@main' line to use, if provided.\n */\nfunction prepareTestFile(originalFile, mainLine) {\n if (mainLine) {\n // Read the original file and split into lines.\n const lines = fs.readFileSync(originalFile, 'utf8').split('\\n');\n // Find the line starting with '@main'.\n const index = lines.findIndex(line => line.startsWith('@main'));\n if (index !== -1) {\n lines[index] = mainLine; // Replace the '@main' line.\n } else {\n // If no '@main' line exists, append the new one and warn.\n console.log(`[WARNING] No @main line found in ${originalFile}, adding at the end.`);\n lines.push(mainLine);\n }\n // Save the modified content to '_test_.hvm'.\n fs.writeFileSync('_test_.hvm', lines.join('\\n'), 'utf8');\n } else {\n // If no mainLine is provided, copy the original file as is.\n fs.copyFileSync(originalFile, '_test_.hvm');\n }\n}\n\n/**\n * Runs the HVM test in the specified mode and returns the output.\n * @param {string} mode - 'intr' for interpreted, 'comp' for compiled.\n * @returns {string} - The command output.\n */\nfunction runTest(mode) {\n let command;\n if (mode === 'intr') {\n command = 'cabal run -v0 hvm --project-dir=/Users/v/vic/dev/HVM -- run _test_.hvm -C -s';\n } else if (mode === 'comp') {\n command = 'hvm run _test_.hvm -c -C -s';\n } else {\n throw new Error(`Unknown mode: ${mode}`);\n }\n // Execute the command and capture the output as a UTF-8 string.\n return execSync(command, { encoding: 'utf8' });\n}\n\n/**\n * Parses the command output to extract the result and time.\n * @param {string} output - The output from running the HVM command.\n * @returns {{result: string, time: number}} - The result (first line) and time in seconds.\n */\nfunction parseOutput(output) {\n const lines = output.split('\\n');\n const result = lines[0].trim(); // First line is the result.\n const timeLine = lines.find(line => line.startsWith('TIME:'));\n if (!timeLine) {\n throw new Error('TIME line not found in output');\n }\n const timeStr = timeLine.split(' ')[1]; // Extract time value after 'TIME:'.\n const time = parseFloat(timeStr);\n if (isNaN(time)) {\n throw new Error(`Failed to parse time: ${timeStr}`);\n }\n return { result, time };\n}\n" }, { "path": "examples/bench_cnots.hvm", "content": "@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} = f\n ! &0{f01x f01y} = λk01 (f00x (f00y k01))\n ! &0{f02x f02y} = λk02 (f01x (f01y k02))\n ! &0{f03x f03y} = λk03 (f02x (f02y k03))\n λk04 (f03x (f03y k04))\n\n@P08 = λf\n ! &0{f00x f00y} = f\n ! &0{f01x f01y} = λk01 (f00x (f00y k01))\n ! &0{f02x f02y} = λk02 (f01x (f01y k02))\n ! &0{f03x f03y} = λk03 (f02x (f02y k03))\n ! &0{f04x f04y} = λk04 (f03x (f03y k04))\n ! &0{f05x f05y} = λk05 (f04x (f04y k05))\n ! &0{f06x f06y} = λk06 (f05x (f05y k06))\n ! &0{f07x f07y} = λk07 (f06x (f06y k07))\n λk08 (f07x (f07y k08))\n\n@P16 = λf\n ! &0{f00x f00y} = f\n ! &0{f01x f01y} = λk01 (f00x (f00y k01))\n ! &0{f02x f02y} = λk02 (f01x (f01y k02))\n ! &0{f03x f03y} = λk03 (f02x (f02y k03))\n ! &0{f04x f04y} = λk04 (f03x (f03y k04))\n ! &0{f05x f05y} = λk05 (f04x (f04y k05))\n ! &0{f06x f06y} = λk06 (f05x (f05y k06))\n ! &0{f07x f07y} = λk07 (f06x (f06y k07))\n ! &0{f08x f08y} = λk08 (f07x (f07y k08))\n ! &0{f09x f09y} = λk09 (f08x (f08y k09))\n ! &0{f10x f10y} = λk10 (f09x (f09y k10))\n ! &0{f11x f11y} = λk11 (f10x (f10y k11))\n ! &0{f12x f12y} = λk12 (f11x (f11y k12))\n ! &0{f13x f13y} = λk13 (f12x (f12y k13))\n ! &0{f14x f14y} = λk14 (f13x (f13y k14))\n ! &0{f15x f15y} = λk15 (f14x (f14y k15))\n λk16 (f15x (f15y k16))\n\n@P20 = λf\n ! &0{f00x f00y} = f\n ! &0{f01x f01y} = λk01 (f00x (f00y k01))\n ! &0{f02x f02y} = λk02 (f01x (f01y k02))\n ! &0{f03x f03y} = λk03 (f02x (f02y k03))\n ! &0{f04x f04y} = λk04 (f03x (f03y k04))\n ! &0{f05x f05y} = λk05 (f04x (f04y k05))\n ! &0{f06x f06y} = λk06 (f05x (f05y k06))\n ! &0{f07x f07y} = λk07 (f06x (f06y k07))\n ! &0{f08x f08y} = λk08 (f07x (f07y k08))\n ! &0{f09x f09y} = λk09 (f08x (f08y k09))\n ! &0{f10x f10y} = λk10 (f09x (f09y k10))\n ! &0{f11x f11y} = λk11 (f10x (f10y k11))\n ! &0{f12x f12y} = λk12 (f11x (f11y k12))\n ! &0{f13x f13y} = λk13 (f12x (f12y k13))\n ! &0{f14x f14y} = λk14 (f13x (f13y k14))\n ! &0{f15x f15y} = λk15 (f14x (f14y k15))\n ! &0{f16x f16y} = λk16 (f15x (f15y k16))\n ! &0{f17x f17y} = λk17 (f16x (f16y k17))\n ! &0{f18x f18y} = λk18 (f17x (f17y k18))\n ! &0{f19x f19y} = λk19 (f18x (f18y k19))\n λk20 (f19x (f19y k20))\n\n@P24 = λf\n ! &0{f00x f00y} = f\n ! &0{f01x f01y} = λk01 (f00x (f00y k01))\n ! &0{f02x f02y} = λk02 (f01x (f01y k02))\n ! &0{f03x f03y} = λk03 (f02x (f02y k03))\n ! &0{f04x f04y} = λk04 (f03x (f03y k04))\n ! &0{f05x f05y} = λk05 (f04x (f04y k05))\n ! &0{f06x f06y} = λk06 (f05x (f05y k06))\n ! &0{f07x f07y} = λk07 (f06x (f06y k07))\n ! &0{f08x f08y} = λk08 (f07x (f07y k08))\n ! &0{f09x f09y} = λk09 (f08x (f08y k09))\n ! &0{f10x f10y} = λk10 (f09x (f09y k10))\n ! &0{f11x f11y} = λk11 (f10x (f10y k11))\n ! &0{f12x f12y} = λk12 (f11x (f11y k12))\n ! &0{f13x f13y} = λk13 (f12x (f12y k13))\n ! &0{f14x f14y} = λk14 (f13x (f13y k14))\n ! &0{f15x f15y} = λk15 (f14x (f14y k15))\n ! &0{f16x f16y} = λk16 (f15x (f15y k16))\n ! &0{f17x f17y} = λk17 (f16x (f16y k17))\n ! &0{f18x f18y} = λk18 (f17x (f17y k18))\n ! &0{f19x f19y} = λk19 (f18x (f18y k19))\n ! &0{f20x f20y} = λk20 (f19x (f19y k20))\n ! &0{f21x f21y} = λk21 (f20x (f20y k21))\n ! &0{f22x f22y} = λk22 (f21x (f21y k22))\n ! &0{f23x f23y} = λk23 (f22x (f22y k23))\n λk24 (f23x (f23y k24))\n" }, { "path": "examples/bench_count.hs", "content": "import Data.Word\n\ncount :: Word32 -> Word32 -> Word32\ncount 0 k = k\ncount p k = count (p - 1) (k + 1)\n\nmain :: IO ()\nmain = print $ count 2_000_000_000 0\n" }, { "path": "examples/bench_count.hvm", "content": "@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 interactions\n//TIME: 1.1376750 seconds\n//SIZE: 3 nodes\n//PERF: 10547.828 MIPS\n" }, { "path": "examples/bench_sum_range.hs", "content": "import Data.Word\n\ndata List = Nil | Cons !Word32 List\n\nrange :: Word32 -> List -> List\nrange 0 xs = xs\nrange n xs = range (n - 1) (Cons (n - 1) xs)\n\nsum' :: List -> Word32 -> Word32\nsum' Nil r = r\nsum' (Cons head tail) r = sum' tail (head + r)\n\nmain :: IO ()\nmain = do\n let !a = range 50_000_000 Nil\n print $ sum' a 0\n" }, { "path": "examples/bench_sum_range.hvm", "content": "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@range(n xs) = ~n !xs {\n 0: xs\n 1+p: !&0{p0 p1}=p @range(p0 #Cons{p1 xs})\n}\n\n@main = @sum(@range(50_000_000 #Nil) 0)\n\n//WORK: 600000007 interactions\n//TIME: 0.1968570 seconds\n//SIZE: 100000005 nodes\n//PERF: 3047.898 MIPS\n" }, { "path": "examples/bench_sum_range.py", "content": "class Nil:\n def __init__(self):\n self.tag = \"Nil\"\n\nclass Cons:\n def __init__(self, head, tail):\n self.tag = \"Cons\"\n self.head = head\n self.tail = tail\n\ndef range_custom(n, xs):\n result = xs\n for i in range(n, 0, -1):\n result = Cons(i - 1, result)\n return result\n\ndef sum_custom(lst):\n total = 0\n while lst.tag != \"Nil\":\n total = (total + lst.head) & 0xFFFFFFFF\n lst = lst.tail\n return total\n\ndef main():\n print(sum_custom(range_custom(50000000, Nil())))\n\nif __name__ == \"__main__\":\n main()\n" }, { "path": "examples/enum_1D_match.hvm", "content": "// This is similar to `enum_invert_add`, except the goal is harder:\n// > Can we find a displacement (rotations) that will make two arrays equal?\n// This file includes interesting insights, such as:\n// - How to represent a space that can be rotated with binary trees\n// - How to compress such space by compacting identical values\n// - How to fuse the tree rotation (rotr/rotl) operations\n// - How to recursively perform a bit-reversal permutation of a tree\n// - How to implement equality efficiently assuming normalized trees\n// Read: https://discord.com/channels/912426566838013994/915345481675186197/1351306002699390976\n\ndata Bool { #T #F }\ndata Pair { #P{x y} }\ndata Bin { #O{p} #I{p} #E }\ndata Nat { #S{p} #Z }\ndata Map { #BR{x y} #M0 #M1 }\n\n// Prelude\n// -------\n\n// If/Exit\n@when(!c t) = ~ c {\n 0: *\n 1+p: t\n}\n\n// And\n!@and(!a b) = ~ a {\n 0: 0\n 1+p: b\n}\n\n// Repeated Application\n@rep(n f x) = ~ n !f !x {\n 0: x\n 1+p: !&0{f0 f1}=f (f0 @rep(p f1 x))\n}\n\n// Squared Application\n@sqr(n f x) = ~ n !f !x {\n 0: x\n 1+p: !&0{p0 p1}=(+ p 1)\n !&0{fA f0}=f\n !&0{f1 f2}=fA\n @sqr((/ p0 2) λk(f0 (f1 k)) @rep((% p1 2) f2 x))\n}\n\n// Church Nat (with fusion)\n@nat(n) = λs λz @sqr(n s z)\n\n// Fixed Point\n@fix(f) = !&{f f0}=f !&{f f1}=f (f0 @fix(f1))\n\n// λ-Encoded Booleans\n// ------------------\n\n// Booleans\n@tru = λt λf t\n@fal = λt λf f\n@idf = λb λt λf (b t f)\n@not = λb λt λf (b f t)\n\n// Below, '@foo' represents two possible functions:\n// - @foo(N x) = match N !x { #Z:x #S{n}:@foo(n (id x)) }\n// - @foo(N x) = match N !x { #Z:x #S{n}:@foo(n (not x)) }\n// The question is: if we apply @foo to a large N, how long will it take to\n// compute? In particular, will it fuse `not` and `id` correctly, even though\n// they're behind a superposition?\n@foo = λN\n ! step = λfoo_N λx\n // Universe 1-L: apply 'id' to 'x'\n // Universe 1-R: apply 'not' to 'x'\n ! &1{F0 F1} = foo_N\n ! &1{x0 x1} = x\n &1{\n (F0 (@idf x0))\n (F1 (@not x1))\n }\n ! base = λx x\n (N step base)\n\n//@main = (@foo @nat(100001) @tru)\n\n// λ-Encoded Nats\n// --------------\n\n// Constructors\n@S(n) = λs λz (s n)\n@Z = λs λz z\n\n// Nat\n@nat_all = &1{@Z @S(@nat_all)}\n\n// Nat → Nat\n@nat_view(n) =\n ! case_s = λp #S{@nat_view(p)}\n ! case_z = #Z\n (n case_s case_z)\n\n// U32 → Nat\n@nat(n) = ~ n {\n 0: @Z\n 1+n: @S(@nat(n))\n}\n\n// λ-Encoded Bitstrings\n// --------------------\n\n// Constructors\n@E = λo λi λe e\n@O(xs) = λo λi λe (o xs)\n@I(xs) = λo λi λe (i xs)\n\n// Bin\n@bin_zero(n) = ~ n {\n 0: @E\n 1+n: @O(@bin_zero(n))\n}\n\n// U32 → U32 → Bin\n@bin(l n) =\n @sqr(n λx@bin_inc(x) @bin_zero(l))\n\n// Bin → U32\n@bin_to_u32(x) =\n ! case_o = λp (+ (* @bin_to_u32(p) 2) 0)\n ! case_i = λp (+ (* @bin_to_u32(p) 2) 1)\n ! case_e = 0\n (x case_o case_i case_e)\n\n// Bin → Bin\n@bin_id(x) = λo λi λe\n (x o i e)\n\n// Bin → Bin\n@bin_inc(x) = λo λi λe \n ! case_o = λp (i p)\n ! case_i = λp (o @bin_inc(p))\n ! case_e = e\n (x case_o case_i case_e)\n\n// Bin → Bin → Bin\n@bin_add(a b) =\n !case_o = λaP λb λo λi λe\n !case_o = λbP λaP (o @bin_add(aP bP))\n !case_i = λbP λaP (i @bin_add(aP bP))\n !case_e = λaP e\n (b case_o case_i case_e aP)\n !case_i = λaP λb λo λi λe\n !case_o = λbP λaP (i @bin_add(aP bP))\n !case_i = λbP λaP (o @bin_inc(@bin_add(aP bP)))\n !case_e = λaP e\n (b case_o case_i case_e aP)\n !case_e = λb b\n (a case_o case_i case_e b)\n\n// Bin → Bin → Bin\n@bin_add_2(a b) =\n @bin_sqr(a λx(@bin_inc(x)) b)\n\n// Bin → Bin -> Bool\n@bin_eql(a b) =\n !case_o = λaP λb\n !case_o = λbP λaP @bin_eql(aP bP)\n !case_i = λbP λaP 0\n !case_e = λaP 0\n (b case_o case_i case_e aP)\n !case_i = λaP λb\n !case_o = λbP λaP 0\n !case_i = λbP λaP @bin_eql(aP bP)\n !case_e = λaP 0\n (b case_o case_i case_e aP)\n !case_e = λb\n !case_o = λbP 0\n !case_i = λbP 0\n !case_e = 1\n (b case_o case_i case_e)\n (a case_o case_i case_e b)\n\n// Bin → Bin\n@bin_view(x) =\n ! case_o = λp #O{@bin_view(p)}\n ! case_i = λp #I{@bin_view(p)}\n ! case_e = #E\n (x case_o case_i case_e)\n\n// U32 → Bin\n@bin_all(n) = ~ n {\n 0: λo λi λe e\n 1+n:\n ! &1{n0 n1} = n\n &1{\n λo λi λe (o @bin_all(n0))\n λo λi λe (i @bin_all(n1))\n }\n}\n\n// Bin → U32\n@bin_len(xs) =\n ! case_o = λxs (+ 1 @bin_len(xs))\n ! case_i = λxs (+ 1 @bin_len(xs))\n ! case_e = 0\n (xs case_o case_i case_e)\n\n// Squared Application (with a bitstring)\n@bin_sqr(xs f x) =\n ! case_o = λxs λf λx !&{f0 f1}=f @bin_sqr(xs λk(f0 (f1 k)) x)\n ! case_i = λxs λf λx !&{F f01}=f !&{f0 f1}=f01 @bin_sqr(xs λk(f0 (f1 k)) (F x))\n ! case_e = λf λx x\n (xs case_o case_i case_e f x)\n\n////Test:\n//@L = 64\n//@A = @bin(@L 10000000)\n//@X = @bin_all(@L)\n//@B = @bin(@L 99999999)\n//@main =\n //! solved = @bin_eql(@bin_add_2(@A @X) @B) // A + X = B\n //@when(solved @bin_to_u32(@X)) // Prints X\n\n// λ-Encoded Bit Maps\n// ------------------\n\n// Constructors\n@M0 = λbr λm0 λm1 m0\n@M1 = λbr λm0 λm1 m1\n@Br(a b) = λbr λm0 λm1 (br a b)\n@BR(a b) =\n ! case_br_a = λax λay λb @Br(@Br(ax ay) b)\n ! case_m0_a = λb\n ! case_br_b = λbx λby @Br(@M0 @Br(bx by))\n ! case_m0_b = @M0\n ! case_m1_b = @Br(@M0 @M1)\n (b case_br_b case_m0_b case_m1_b)\n ! case_m1_a = λb\n ! case_br_b = λbx λby @Br(@M1 @Br(bx by))\n ! case_m0_b = @Br(@M1 @M0)\n ! case_m1_b = @M1\n (b case_br_b case_m0_b case_m1_b)\n (a case_br_a case_m0_a case_m1_a b)\n\n// map_view : U32 → Map → Map\n@map_view(map) =\n ! case_br = λx λy #BR{@map_view(x) @map_view(y)}\n ! case_m0 = #M0\n ! case_m1 = #M1\n (map case_br case_m0 case_m1)\n\n// map_set : Bin → Map → Map\n@map_set(bs map) =\n ! case_o = λbsP λmap \n ! case_br = λx λy λbsP @BR((@map_set(bsP x)) y)\n ! case_m0 = λbsP @BR((@map_set(bsP @M0)) @M0)\n ! case_m1 = λbsP @BR((@map_set(bsP @M1)) @M1)\n (map case_br case_m0 case_m1 bsP)\n ! case_i = λbsP λmap \n ! case_br = λx λy λbsP @BR(x (@map_set(bsP y)))\n ! case_m0 = λbsP @BR(@M0 (@map_set(bsP @M0)))\n ! case_m1 = λbsP @BR(@M1 (@map_set(bsP @M1)))\n (map case_br case_m0 case_m1 bsP)\n ! case_e = λmap @M1\n (bs case_o case_i case_e map)\n\n// map_get : Bin → Map → U32\n@map_get(bs map) =\n ! case_o = λbsP λmap \n ! case_br = λx λy @map_get(bsP x)\n ! case_m0 = 0\n ! case_m1 = 1\n (map case_br case_m0 case_m1)\n ! case_i = λbsP λmap \n ! case_br = λx λy @map_get(bsP y)\n ! case_m0 = 0\n ! case_m1 = 1\n (map case_br case_m0 case_m1)\n ! case_e = λmap \n ! case_br = λx λy 0\n ! case_m0 = 0\n ! case_m1 = 1\n (map case_br case_m0 case_m1)\n (bs case_o case_i case_e map)\n\n// map_eql : Map → Map → Bool\n@map_eql(a b) =\n ! case_br_a = λax λay λb \n ! case_br_b = λbx λby @and(@map_eql(ax bx) @map_eql(ay by))\n ! case_m0_b = 0\n ! case_m1_b = 0\n (b case_br_b case_m0_b case_m1_b)\n ! case_m0_a = λb\n ! case_br_b = λbx λby 0\n ! case_m0_b = 1\n ! case_m1_b = 0\n (b case_br_b case_m0_b case_m1_b)\n ! case_m1_a = λb \n ! case_br_b = λbx λby 0\n ! case_m0_b = 0\n ! case_m1_b = 1\n (b case_br_b case_m0_b case_m1_b)\n (a case_br_a case_m0_a case_m1_a b)\n\n// map_zero : Map\n@map_zero = @M0\n\n// map_alloc : U32 → Map\n@map_alloc(d) = ~ d {\n 0: @M0\n 1+d: !&{d0 d1}=d @BR(@map_alloc(d0) @map_alloc(d1))\n}\n\n// map_swp : Map → Map\n@map_swp(map) =\n ! case_br = λa λb\n ! case_br_a = λax λay λb\n ! case_br_b = λbx λby λax λay @BR(@BR(ax bx) @BR(ay by))\n ! case_m0_b = λax λay 0 // TODO\n ! case_m1_b = λax λay 0 // TODO\n (@map_swp(b) case_br_b case_m0_b case_m1_b ax ay)\n ! case_m0_a = λb\n ! case_br_b = λbx λby 0 // TODO\n ! case_m0_b = @BR(@M0 @M0)\n ! case_m1_b = @BR(@M0 @M1)\n (@map_swp(b) case_br_b case_m0_b case_m1_b)\n ! case_m1_a = λb\n ! case_br_b = λbx λby 0 // TODO\n ! case_m0_b = @BR(@M1 @M0)\n ! case_m1_b = @BR(@M1 @M1)\n (@map_swp(b) case_br_b case_m0_b case_m1_b)\n (@map_swp(a) case_br_a case_m0_a case_m1_a b)\n ! case_m0 = @M0\n ! case_m1 = @M1\n (map case_br case_m0 case_m1)\n\n// map_inv : Map → Map\n@map_inv(map) = λbr λm0 λm1\n ! case_br = λx λy (br @map_inv(x) @map_inv(y))\n ! case_m0 = m0\n ! case_m1 = m1\n (@map_swp(map) case_br case_m0 case_m1)\n\n// map_rotr : Map → Map\n@map_rotr(map) = λbr λm0 λm1\n ! case_br = λx λy (br @map_rotr(y) x)\n ! case_m0 = m0\n ! case_m1 = m1\n (map case_br case_m0 case_m1)\n\n// map_rotl : Map → Map\n@map_rotl(map) = λbr λm0 λm1\n ! case_br = λx λy (br y @map_rotl(x))\n ! case_m0 = m0\n ! case_m1 = m1\n (map case_br case_m0 case_m1)\n\n// map_spinr : Bin → Map → Map\n@map_spinr(xs map) =\n @bin_sqr(xs λx(@map_rotr(x)) map)\n\n@solve(!&L) =\n ! A = @map_set(@bin(L 0x00) @map_set(@bin(L 0x80) @map_zero))\n ! B = @map_set(@bin(L 0x40) @map_set(@bin(L 0xC0) @map_zero))\n ! E = @map_eql(@map_spinr(@bin_all(L) A) B)\n @when(E @bin_to_u32(@bin_all(L)))\n\n@main = @solve(20)\n" }, { "path": "examples/enum_bin.hvm", "content": "// 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 {\n 0: f\n _: t\n}\n\n// Not\n@not(a) = ~a {\n 0: 1\n _: 0\n}\n\n// And\n@and(a b) = ~a {\n 0: 0\n _: b\n}\n\n// Or\n@or(a b) = ~a {\n 0: b\n _: 1\n}\n\n// Converts a Bin to an U32\n@u32(b) = ~b{\n #O{p}: (+ (* 2 @u32(p)) 0)\n #I{p}: (+ (* 2 @u32(p)) 1)\n #E: 0\n}\n\n// Converts an U32 to a Bin of given size\n@bin(s n) = ~s{\n 0: #E\n 1+p: !&0{n0 n1}=n ~(% n0 2) !p !n1 {\n 0: #O{@bin(p (/ n1 2))}\n _: #I{@bin(p (/ n1 2))}\n }\n}\n\n// Bin Equality\n@eq(a b) = ~a !b {\n #E: ~b {\n #O{bp}: 0\n #I{bp}: 0\n #E: 1\n }\n #O{ap}: ~b{\n #O{bp}: @eq(ap bp)\n #I{bp}: 0\n #E: 0\n }\n #I{ap}: ~b{\n #O{bp}: 0\n #I{bp}: @eq(ap bp)\n #E: 0\n }\n}\n\n// Increments a Bin\n@inc(a) = ~a{\n #O{p}: #I{p}\n #I{p}: #O{@inc(p)}\n #E: #E\n}\n\n// Decrements a Bin\n@dec(a) = ~a{\n #O{p}: #O{@dec(p)}\n #I{p}: #I{p}\n #E: #E\n}\n\n// Adds two Bins\n@add(a b) = ~a !b {\n #O{ap}: ~b !ap {\n #O{bp}: #O{@add(ap bp)}\n #I{bp}: #I{@add(ap bp)}\n #E: #O{ap}\n }\n #I{ap}: ~b !ap {\n #O{bp}: #I{@add(ap bp)}\n #I{bp}: #O{@inc(@add(ap bp))}\n #E: #I{ap}\n }\n #E: #E\n}\n\n// Muls two Bins\n@mul(a b) = ~b !a {\n #E: #E\n #O{bp}: #O{@mul(a bp)}\n #I{bp}: !&0{a0 a1}=a @add(a0 #O{@mul(a1 bp)})\n}\n\n// Concatenates two Bins\n@cat(a b) = ~a !b {\n #O{ap}: #O{@cat(ap b)}\n #I{ap}: #I{@cat(ap b)}\n #E: b\n}\n\n// Lt two Bins (a < b)\n@lt(a b) = @lt_go(0 a b)\n\n@lt_go(&k a b) = ~a !b {\n #E: ~b {\n #E: &k\n #O{bp}: 1\n #I{bp}: 1\n }\n #O: λap ~b !ap {\n #E: 0\n #O{bp}: @lt_go(&k ap bp)\n #I{bp}: @lt_go(1 ap bp)\n }\n #I: λap ~b !ap {\n #E: 0\n #O{bp}: @lt_go(0 ap bp)\n #I{bp}: @lt_go(&k ap bp)\n }\n}\n\n// Take the first N bits of a Bin\n@take(n b) = ~n {\n 0: #E\n 1+p: ~b !p {\n #O{bp}: #O{@take(p bp)}\n #I{bp}: #I{@take(p bp)}\n #E: #E\n }\n}\n\n// Enums all Bins of given size (label 1)\n@all1(s) = ~s{\n 0: #E\n 1+p: !&1{p0 p1}=p &1{\n #O{@all1(p0)}\n #I{@all1(p1)}\n }\n}\n\n// Enums all Bins of given size (label 2)\n@all2(s) = ~s{\n 0: #E\n 1+p: !&2{p0 p1}=p &2{\n #O{@all2(p0)}\n #I{@all2(p1)}\n }\n}\n\n//// 4:\n//@K = 1\n//@H = 2\n//@S = 4\n//@X = @cat(@all1(@H) @bin(@H 0))\n//@Y = @cat(@all2(@H) @bin(@H 0))\n//@A = @cat(@bin(@K 3) @bin(@H 0))\n//@B = @cat(@bin(@H 3) @bin(@H 0))\n//@P = @bin(@S 9)\n\n//// 6:\n//@K = 2\n//@H = 3\n//@S = 6\n//@X = @cat(@all1(@H) @bin(@H 0))\n//@Y = @cat(@all2(@H) @bin(@H 0))\n//@A = @cat(@bin(@K 5) @bin(@H 0))\n//@B = @cat(@bin(@H 5) @bin(@H 0))\n//@P = @bin(@S 25)\n\n//// 8:\n//@K = 3\n//@H = 4\n//@S = 8\n//@X = @cat(@all1(@H) @bin(@H 0))\n//@Y = @cat(@all2(@H) @bin(@H 0))\n//@A = @cat(@bin(@K 13) @bin(@H 0))\n//@B = @cat(@bin(@H 13) @bin(@H 0))\n//@P = @bin(@S 169)\n\n//// 10:\n//@K = 4\n//@H = 5\n//@S = 10\n//@X = @cat(@all1(@H) @bin(@H 0))\n//@Y = @cat(@all2(@H) @bin(@H 0))\n//@A = @cat(@bin(@K 31) @bin(@H 0))\n//@B = @cat(@bin(@H 19) @bin(@H 0))\n//@P = @bin(@S 589)\n\n//// 12:\n//@K = 5\n//@H = 6\n//@S = 12\n//@X = @cat(@all1(@H) @bin(@H 0))\n//@Y = @cat(@all2(@H) @bin(@H 0))\n//@A = @cat(@bin(@K 53) @bin(@H 0))\n//@B = @cat(@bin(@H 37) @bin(@H 0))\n//@P = @bin(@S 1961)\n\n//// 14:\n//@K = 6\n//@H = 7\n//@S = 14\n//@X = @cat(@all1(@H) @bin(@H 0))\n//@Y = @cat(@all2(@H) @bin(@H 0))\n//@A = @cat(@bin(@K 109) @bin(@H 0))\n//@B = @cat(@bin(@H 97) @bin(@H 0))\n//@P = @bin(@S 10573)\n\n//// 16:\n//@K = 7\n//@H = 8\n//@S = 16\n//@X = @cat(@all1(@H) @bin(@H 0))\n//@Y = @cat(@all2(@H) @bin(@H 0))\n//@A = @cat(@bin(@K 173) @bin(@H 0))\n//@B = @cat(@bin(@H 233) @bin(@H 0))\n//@P = @bin(@S 40309)\n\n//// 18:\n//@K = 8\n//@H = 9\n//@S = 18\n//@X = @cat(@all1(@H) @bin(@H 0))\n//@Y = @cat(@all2(@H) @bin(@H 0))\n//@A = @cat(@bin(@K 449) @bin(@H 0))\n//@B = @cat(@bin(@H 389) @bin(@H 0))\n//@P = @bin(@S 174661)\n\n//// 20:\n//@K = 9\n//@H = 10\n//@S = 20\n//@X = @cat(@all1(@H) @bin(@H 0))\n//@Y = @cat(@all2(@H) @bin(@H 0))\n//@A = @cat(@bin(@K 769) @bin(@H 0))\n//@B = @cat(@bin(@H 569) @bin(@H 0))\n//@P = @bin(@S 437561)\n\n//// 22:\n//@K = 10\n//@H = 11\n//@S = 22\n//@X = @cat(@all1(@H) @bin(@H 0))\n//@Y = @cat(@all2(@H) @bin(@H 0))\n//@A = @cat(@bin(@K 1423) @bin(@H 0))\n//@B = @cat(@bin(@H 1229) @bin(@H 0))\n//@P = @bin(@S 1748867)\n\n//// 24:\n//@K = 11\n//@H = 12\n//@S = 24\n//@X = @cat(@all1(@H) @bin(@H 0))\n//@Y = @cat(@all2(@H) @bin(@H 0))\n//@A = @cat(@bin(@K 2437) @bin(@H 0))\n//@B = @cat(@bin(@H 2333) @bin(@H 0))\n//@P = @bin(@S 5685521)\n\n//// 26:\n//@K = 12\n//@H = 13\n//@S = 26\n//@X = @cat(@all1(@H) @bin(@H 0))\n//@Y = @cat(@all2(@H) @bin(@H 0))\n//@A = @cat(@bin(@K 4987) @bin(@H 0))\n//@B = @cat(@bin(@H 6203) @bin(@H 0))\n//@P = @bin(@S 30934361)\n\n//// 28:\n//@K = 13\n//@H = 14\n//@S = 28\n//@X = @cat(@all1(@H) @bin(@H 0))\n//@Y = @cat(@all2(@H) @bin(@H 0))\n//@A = @cat(@bin(@K 13513) @bin(@H 0))\n//@B = @cat(@bin(@H 13721) @bin(@H 0))\n//@P = @bin(@S 185411873)\n\n//// 30:\n//@K = 14\n//@H = 15\n//@S = 30\n//@X = @cat(@all1(@H) @bin(@H 0))\n//@Y = @cat(@all2(@H) @bin(@H 0))\n//@A = @cat(@bin(@K 24923) @bin(@H 0))\n//@B = @cat(@bin(@H 19489) @bin(@H 0))\n//@P = @bin(@S 485724347)\n\n//// 32:\n//@K = 15\n//@H = 16\n//@S = 32\n//@X = @cat(@all1(@H) @bin(@H 0))\n//@Y = @cat(@all2(@H) @bin(@H 0))\n//@A = @cat(@bin(@K 47791) @bin(@H 0))\n//@B = @cat(@bin(@H 54881) @bin(@H 0))\n//@P = @bin(@S 2622817871)\n\n@main = \n ! cond = @eq(@mul(@X @Y) @P)\n ! not1 = @not(@eq(@X @bin(@S 1)))\n @if(@and(cond not1) λt(t @u32(@X) @u32(@Y)) *)\n" }, { "path": "examples/enum_coc_smart.hvm", "content": "// Superposes dependently typed λ-terms. With it, solving:\n// (?X λt(t A B)) == λt(t B A)\n// Where\n// ?X : ∀A. (∀P. A -> A -> P) -> (∀P. A -> A -> P)\n// Is down to 3k interactions. Of course, that's not too surprising given there\n// are only two functions of that type, but the real win is that now we only\n// need to make a choice when selecting an element from context. Intros and\n// elims follow directly from types, no need for choices / superpositions.\n\ndata List {\n #Nil\n #Cons{head tail}\n}\n\ndata Bits {\n #O{pred}\n #I{pred}\n #E\n}\n\ndata Term {\n #Var{idx}\n #Pol{bod}\n #All{inp bod}\n #Lam{bod}\n #App{fun arg}\n #U32\n #Num{val}\n}\n\ndata Pair {\n #Pair{fst snd}\n}\n\ndata Maybe {\n #None\n #Some{value}\n}\n\n// Prelude\n// -------\n\n@if(c t f) = ~ c {\n 0: f\n _: t\n}\n\n@when(c t) = ~ c {\n 0: *\n _: t\n}\n\n@tail(xs) = ~ xs {\n #Nil: *\n #Cons{h t}: t\n}\n\n@and(a b) = ~ a !b {\n 0: 0\n _: b\n}\n\n@unwrap(mb) = ~mb {\n #None: *\n #Some{x}: x\n}\n\n@seq(str) = ~ str {\n #Nil: #Nil\n #Cons{h t}:\n !! h = h\n !! t = @seq(t)\n #Cons{h t}\n}\n\n@tm0(x) = !&0{a b}=x a\n@tm1(x) = !&0{a b}=x b\n\n// Stringification\n// ---------------\n\n@show_nat(nat) = ~nat { \n 0: λk #Cons{'Z' k}\n 1+p: λk #Cons{'S' (@show_nat(p) k)}\n}\n\n@show_dec(&n r) =\n ! chr = (+ (% n 10) '0')\n ~ (< n 10) !chr !r {\n 0: @show_dec((/ n 10) #Cons{chr r})\n _: #Cons{chr r}\n }\n\n@do_show_dec(n) = @show_dec(n #Nil)\n\n@show_bits(bits) = ~bits {\n #O{pred}: λk #Cons{'#' #Cons{'O' #Cons{'{' (@show_bits(pred) #Cons{'}' k})}}}\n #I{pred}: λk #Cons{'#' #Cons{'I' #Cons{'{' (@show_bits(pred) #Cons{'}' k})}}}\n #E: λk #Cons{'#' #Cons{'E' k}}\n}\n\n@do_show_bits(bits) = (@show_bits(bits) #Nil)\n\n@show_term(term dep) = ~term !&dep {\n #Var{idx}: λk\n @show_dec(idx k)\n #Pol{bod}: λk\n #Cons{'∀' (@show_term((bod #Var{dep}) (+ dep 1)) k)}\n #All{inp bod}: λk\n #Cons{'Π'\n #Cons{'('\n (@show_term(inp dep)\n #Cons{')'\n (@show_term((bod #Var{dep}) (+ dep 1))\n k)})}}\n #Lam{bod}: λk\n #Cons{'λ' (@show_term((bod #Var{dep}) (+ dep 1)) k)}\n #App{fun arg}: λk\n #Cons{'(' (@show_term(fun dep)\n #Cons{' ' (@show_term(arg dep)\n #Cons{')' k})})}\n #U32: λk\n #Cons{'U' k}\n #Num{val}: λk\n #Cons{'#' @show_dec(val k)}\n}\n\n@do_show_term(term) = (@show_term(term 0) #Nil)\n\n// Equality\n// --------\n\n@eq(a b d) = ~ @wnf(a) !b !d {\n #Var{aI}: ~ @wnf(b) !d {\n #Var{bI}: (== aI bI)\n else: 0\n }\n #Pol{aB}: ~ @wnf(b) !&d {\n #Pol{bB}:\n @eq((aB #Var{d}) (bB #Var{d}) (+ d 1))\n else: 0\n }\n #All{aI aB}: ~ @wnf(b) !&d {\n #All{bI bB}:\n @and(@eq(aI bI d) @eq((aB #Var{d}) (bB #Var{d}) (+ d 1)))\n else: 0\n }\n #Lam{aB}: ~ @wnf(b) !&d {\n #Lam{bB}:\n @eq((aB #Var{d}) (bB #Var{d}) (+ d 1))\n else: 0\n }\n #App{aF aX}: ~ @wnf(b) !&d {\n #App{bF bX}:\n @and(@eq(aF bF d) @eq(aX bX d))\n else: 0\n }\n #U32: ~ @wnf(b) !d {\n #U32: 1\n else: 0\n }\n #Num{aV}: ~ @wnf(b) !d {\n #Num{bV}: (== aV bV)\n else: 0\n }\n}\n\n// Evaluation\n// ----------\n\n@wnf(term) = ~ term { \n #Var{idx}: #Var{idx}\n #Pol{bod}: #Pol{bod}\n #All{inp bod}: #All{inp bod}\n #Lam{bod}: #Lam{bod}\n #App{fun arg}: @wnf_app(@wnf(fun) arg)\n #U32: #U32\n #Num{val}: #Num{val}\n}\n\n@wnf_app(f x) = ~ f !x {\n #Var{idx}: #App{#Var{idx} x}\n #Pol{bod}: #App{#Pol{bod} x}\n #All{inp bod}: #App{#All{inp bod} x}\n #Lam{bod}: @wnf((bod @wnf(x)))\n #App{fun arg}: #App{#App{fun arg} x}\n #U32: #U32\n #Num{val}: #App{#Num{val} x}\n}\n\n// Enumeration\n// -----------\n\n@all(&L typ &dep ctx) =\n @intr(L typ dep ctx)\n\n@intr(!&L typ !&dep ctx) =\n ~ typ !ctx {\n #All{t_inp t_bod}: \n !&0{ctx bod} = @all(L (t_bod #Var{dep}) (+ dep 1) #Cons{#Some{&0{$x t_inp}} ctx})\n &0{@tail(ctx) #Lam{λ$x(bod)}}\n #Pol{t_bod}:\n @intr(L (t_bod #Var{dep}) (+ dep 1) ctx)\n #U32:\n @pick(L #U32 dep ctx λk(k))\n #Var{idx}:\n @pick(L #Var{idx} dep ctx λk(k))\n #App{fun arg}:\n @pick(L #App{fun arg} dep ctx λk(k))\n #Lam{bod}: *\n #Num{val}: *\n }\n\n@pick(!&L typ !&dep ctx rem) = \n ~ctx {\n #Nil: *\n #Cons{ann ctx}:\n !&L{typL typR} = typ\n !&L{remL remR} = rem\n !&L{annL annR} = ann\n !&L{ctxL ctxR} = ctx\n &L{\n @elim(L typL dep (remL ctxL) annL)\n @pick(L typR dep ctxR λk(remR #Cons{annR k}))\n }\n }\n\n@elim(!&L typ !&dep ctx ann) = ~ann {\n #None: *\n #Some{ann}:\n ! &0{v t} = ann\n ~ t !typ !ctx !v {\n #Pol{t_bod}:\n ! &{typ0 typ1} = typ\n @elim(L typ0 dep ctx #Some{&0{v (t_bod typ1)}})\n #All{t_inp t_bod}:\n ! &0{ctx arg} = @all((+(* L 2)1) t_inp dep ctx)\n ! &{arg0 arg1} = arg\n @elim((+(* L 2)0) typ dep ctx #Some{&0{#App{v arg0} (t_bod arg1)}})\n #U32: \n @when(@eq(typ #U32 dep) &0{ctx v})\n #Var{idx}:\n @when(@eq(typ #Var{idx} dep) &0{ctx v})\n #App{fun arg}:\n @when(@eq(typ #App{fun arg} dep) &0{ctx v})\n #Lam{bod}: *\n #Num{val}: *\n }\n}\n\n// T0 = Π(x:U32) Π(y:U32) Π(z:U32) U32\n@T0 =\n #All{#U32 λx\n #All{#U32 λy\n #All{#U32 λz\n #U32}}}\n\n// CBool = ∀P Π(x:P) Π(y:P) P\n@CBool =\n #Pol{λ&p\n #All{p λx\n #All{p λy\n p}}}\n\n// Tup(A B) = ∀P Π(p: Π(x:A) Π(y:B) P) P\n@Tup(A B) =\n #Pol{λ&p\n #All{\n #All{A λx\n #All{B λy\n p}} λ_\n p}}\n\n// TupF = ∀A Π(x: (Tup A A)) (Tup A A)\n@TupF =\n #Pol{λ&A\n #Pol{λ&B\n #All{@Tup(A A) λx\n @Tup(A A)}}}\n\n// Tests\n// -----\n\n//A= λt(t 1 2)\n@A = #Lam{λt #App{#App{t #Num{1}} #Num{2}}}\n\n//B= λt(t 2 1)\n@B = #Lam{λt #App{#App{t #Num{2}} #Num{1}}}\n\n//R= λx(x λaλbλt(t b a))\n@R = #Lam{λx #App{x #Lam{λa #Lam{λb #Lam{λt #App{#App{t b} a}}}}}}\n\n// X : ∀A. (Tup A A) -> (Tup A A) = \n@T = @TupF\n@X = @tm1(@all(1 @T 0 #Nil))\n\n// Solves for `?X` in `(?X λt(t A B)) == λt(t B A)`.\n// It finds `?X = λλ(0 λλ((1 3) 2))` in 3k interactions.\n@main = @when(@eq(#App{@X @A} @B 0) @do_show_term(@X))\n\n//@main = @X\n" }, { "path": "examples/enum_invert_add.hvm", "content": "// This file shows how we can use superpositionn to apply multiple functions to\n// the same input, in a way that \"shares computations\" across different calls.\n// In this example, we apply `add(0)`, `add(1)`, ..., `add(2^64-1)` - i.e., 2^64\n// different functions, to the same input, 10,000,000. Then, we check\n// `addN(10,000,000) = 99,999,999`, and eliminate all universes that don't\n// satisfy this equation. Since `inc` fuses, and since `addN` is a superposition\n// of every function, there is a *massive* amount of sharing between different\n// universes (i.e., the universe where we check `add1(10,000,00) = 99,999,999`,\n// the universe where we check `add2(10,000,00) = 99,999,999`, and so on). Thus,\n// after trying all possible universes, we eventually find out that the only\n// universe that is *not* destroyed is `add89999999(10,000,00) = 99,999,999`.\n// We then use this information to output `89,999,999`, which is the solution to\n// the `10,000,000 + X = 99,999,999` equation. And the magic is: this happens in\n// just 196411 interactions (0.001 seconds). In any other language, this would\n// take *at least* enough time to call `add` 2^64 times, which is probably\n// weeks. In other words, we effectivelly implemented 'sub' efficiently, by\n// using superpositions to enumerate the domain of 'add(N,x)', inverting it. Of\n// course, 'add' is a very simple function. Can this technique be used to invert\n// more complex functions efficiently? See 'enum_1D_match.hvml' for an attempt.\n\ndata Bool { #T #F }\ndata Pair { #P{x y} }\ndata Bin { #O{p} #I{p} #E }\ndata Nat { #S{p} #Z }\ndata Map { #BR{x y} #M0 #M1 }\n\n// Prelude\n// -------\n\n// If/Exit\n@when(!c t) = ~ c {\n 0: *\n _: t\n}\n\n// And\n!@and(!a b) = ~ a {\n 0: 0\n _: b\n}\n\n// Repeated Application\n@rep(n f x) = ~ n !f !x {\n 0: x\n 1+p: !&0{f0 f1}=f (f0 @rep(p f1 x))\n}\n\n// Squared Application\n@sqr(n f x) = ~ n !f !x {\n 0: x\n 1+p:\n !&0{p0 p1}=(+ p 1)\n !&0{fA f0}=f\n !&0{f1 f2}=fA\n @sqr((/ p0 2) λk(f0 (f1 k)) @rep((% p1 2) f2 x))\n}\n\n// Church Nat (with fusion)\n@nat(n) = λs λz @sqr(n s z)\n\n// Fixed Point\n@fix(f) = !&{f f0}=f !&{f f1}=f (f0 @fix(f1))\n\n// λ-Encoded Nats\n// --------------\n\n// Constructors\n@S(n) = λs λz (s n)\n@Z = λs λz z\n\n// Nat\n@nat_all = &1{@Z @S(@nat_all)}\n\n// Nat → Nat\n@nat_view(n) =\n ! case_s = λp #S{@nat_view(p)}\n ! case_z = #Z\n (n case_s case_z)\n\n// U32 → Nat\n@nat(n) = ~ n {\n 0: @Z\n 1+n: @S(@nat(n))\n}\n\n// λ-Encoded Bitstrings\n// --------------------\n\n// Constructors\n@E = λo λi λe e\n@O(xs) = λo λi λe (o xs)\n@I(xs) = λo λi λe (i xs)\n\n// Bin\n@bin_zero(n) = ~ n {\n 0: @E\n 1+n: @O(@bin_zero(n))\n}\n\n// U32 → U32 → Bin\n@bin(l n) =\n @sqr(n λx@bin_inc(x) @bin_zero(l))\n\n// Bin → U32\n@bin_to_u32(x) =\n ! case_o = λp (+ (* @bin_to_u32(p) 2) 0)\n ! case_i = λp (+ (* @bin_to_u32(p) 2) 1)\n ! case_e = 0\n (x case_o case_i case_e)\n\n// Bin → Bin\n@bin_id(x) = λo λi λe\n (x o i e)\n\n// Bin → Bin\n@bin_inc(x) = λo λi λe \n ! case_o = λp (i p)\n ! case_i = λp (o @bin_inc(p))\n ! case_e = e\n (x case_o case_i case_e)\n\n// Bin → Bin → Bin\n@bin_add(a b) =\n !case_o = λaP λb λo λi λe\n !case_o = λbP λaP (o @bin_add(aP bP))\n !case_i = λbP λaP (i @bin_add(aP bP))\n !case_e = λaP e\n (b case_o case_i case_e aP)\n !case_i = λaP λb λo λi λe\n !case_o = λbP λaP (i @bin_add(aP bP))\n !case_i = λbP λaP (o @bin_inc(@bin_add(aP bP)))\n !case_e = λaP e\n (b case_o case_i case_e aP)\n !case_e = λb b\n (a case_o case_i case_e b)\n\n// Bin → Bin → Bin\n@bin_add_2(a b) =\n @bin_sqr(a λx(@bin_inc(x)) b)\n\n// Bin → Bin -> Bool\n@bin_eql(a b) =\n !case_o = λaP λb\n !case_o = λbP λaP @bin_eql(aP bP)\n !case_i = λbP λaP 0\n !case_e = λaP 0\n (b case_o case_i case_e aP)\n !case_i = λaP λb\n !case_o = λbP λaP 0\n !case_i = λbP λaP @bin_eql(aP bP)\n !case_e = λaP 0\n (b case_o case_i case_e aP)\n !case_e = λb\n !case_o = λbP 0\n !case_i = λbP 0\n !case_e = 1\n (b case_o case_i case_e)\n (a case_o case_i case_e b)\n\n// Bin → Bin\n@bin_view(x) =\n ! case_o = λp #O{@bin_view(p)}\n ! case_i = λp #I{@bin_view(p)}\n ! case_e = #E\n (x case_o case_i case_e)\n\n// U32 → Bin\n@bin_all(n) = ~ n {\n 0: λo λi λe e\n 1+n:\n ! &1{n0 n1} = n\n &1{\n λo λi λe (o @bin_all(n0))\n λo λi λe (i @bin_all(n1))\n }\n}\n\n// Bin → U32\n@bin_len(xs) =\n ! case_o = λxs (+ 1 @bin_len(xs))\n ! case_i = λxs (+ 1 @bin_len(xs))\n ! case_e = 0\n (xs case_o case_i case_e)\n\n// Squared Application (with a bitstring)\n@bin_sqr(xs f x) =\n ! case_o = λxs λf λx !&{f0 f1}=f @bin_sqr(xs λk(f0 (f1 k)) x)\n ! case_i = λxs λf λx !&{F f01}=f !&{f0 f1}=f01 @bin_sqr(xs λk(f0 (f1 k)) (F x))\n ! case_e = λf λx x\n (xs case_o case_i case_e f x)\n\n//Test:\n@L = 64\n@A = @bin(@L 10000000)\n@X = @bin_all(@L)\n@B = @bin(@L 99999999)\n@main =\n ! solved = @bin_eql(@bin_add_2(@A @X) @B) // A + X = B\n @when(solved @bin_to_u32(@X)) // Prints X\n" }, { "path": "examples/enum_lam_naive_blc.hs", "content": "-- This is the Haskell version of the naive λ-Calculus enumerator, that just\n-- generates all BLC strings and attempts one by one in a loop.\n\n{-# LANGUAGE PatternSynonyms #-}\n\nimport Control.Monad (forM_, when)\nimport Data.Bits (testBit)\nimport System.Exit (exitSuccess)\n\ndata Bits = O Bits | I Bits | E deriving Show\ndata Term = Lam Term | App Term Term | Var Int deriving Show\ndata HTerm = HLam (HTerm -> HTerm) | HApp HTerm HTerm | HVar Int | HSub HTerm\ndata Pair a b = Pair a b deriving Show\ndata Result a r = Result a r deriving Show\n\n-- Prelude\n-- -------\n\nbits :: Int -> Int -> Bits\nbits 0 _ = E\nbits n i\n | testBit i (n-1) = I (bits (n-1) i)\n | otherwise = O (bits (n-1) i)\n\n-- Parser\n-- ------\n\nparseTerm :: Bits -> Maybe (Result Bits Term)\nparseTerm (O src) = do\n Result src nat <- parseInt src\n return $ Result src (Var nat)\nparseTerm (I src) = case src of\n O src -> do\n Result src bod <- parseTerm src\n return $ Result src (Lam bod)\n I src -> do\n Result src fun <- parseTerm src\n Result src arg <- parseTerm src\n return $ Result src (App fun arg)\n E -> Nothing\nparseTerm E = Nothing\n\nparseInt :: Bits -> Maybe (Result Bits Int)\nparseInt (O src) = Just $ Result src 0\nparseInt (I src) = do\n Result src nat <- parseInt src\n return $ Result src (1 + nat)\nparseInt E = Just $ Result E 0\n\ndoParseTerm :: Bits -> Maybe Term\ndoParseTerm src = do\n Result _ term <- parseTerm src\n return term\n\ndoParseHTerm :: Bits -> Maybe HTerm\ndoParseHTerm src = do\n Result _ term <- parseTerm src\n doBindTerm term\n\n-- Binding\n-- -------\n-- NOTE: since Haskell doesn't have global variables ($x), we'll bind in two passes\n-- The first pass just binds all variables\n-- The second pass excludes non-affine terms\n\nuses :: Term -> Int -> Int\nuses (Lam bod) idx = uses bod (idx + 1)\nuses (App fun arg) idx = uses fun idx + uses arg idx\nuses (Var n) idx = if n == idx then 1 else 0\n\naffine :: Term -> Bool\naffine term = go term 0 where\n go (Lam bod) dep = uses bod 0 <= 1 && go bod (dep + 1)\n go (App fun arg) dep = go fun dep && go arg dep\n go (Var n) dep = n < dep\n\ndoBindTerm :: Term -> Maybe HTerm\ndoBindTerm term | affine term = Just (bindTerm term [])\ndoBindTerm term | otherwise = Nothing\n\nbindTerm :: Term -> [HTerm] -> HTerm\nbindTerm (Lam bod) ctx = HLam $ \\x -> bindTerm bod (x : ctx)\nbindTerm (App fun arg) ctx = HApp (bindTerm fun ctx) (bindTerm arg ctx)\nbindTerm (Var idx) ctx = get idx ctx\n\nget :: Int -> [HTerm] -> HTerm\nget 0 (x:_) = x\nget n (_:t) = get (n-1) t\nget _ [] = error \"*\"\n\n-- Stringification\n-- ---------------\n\nshowBits :: Bits -> String -> String\nshowBits (O pred) k = '#':'O':'{': showBits pred ('}':k)\nshowBits (I pred) k = '#':'I':'{': showBits pred ('}':k)\nshowBits E k = '#':'E':k\n\ndoShowBits :: Bits -> String\ndoShowBits bits = showBits bits []\n\nshowTerm :: HTerm -> Int -> String -> String\nshowTerm (HVar idx) dep k = show (dep - idx - 1) ++ k\nshowTerm (HLam bod) dep k = 'λ' : showTerm (bod (HVar dep)) (dep+1) k\nshowTerm (HApp fun arg) dep k = '(' : showTerm fun dep (' ' : showTerm arg dep (')':k))\nshowTerm (HSub _) _ _ = error \"*\"\n\ndoShowTerm :: HTerm -> String\ndoShowTerm term = showTerm term 0 []\n\n-- Equality\n-- --------\n\neq :: HTerm -> HTerm -> Int -> Bool\neq (HLam aBod) (HLam bBod) dep = eq (aBod (HVar dep)) (bBod (HVar dep)) (dep+1)\neq (HApp aFun aArg) (HApp bFun bArg) dep = eq aFun bFun dep && eq aArg bArg dep\neq (HVar aIdx) (HVar bIdx) _ = aIdx == bIdx\neq _ _ _ = False\n\n-- Evaluation\n-- ----------\n\nwnf :: HTerm -> HTerm\nwnf (HLam bod) = HLam bod\nwnf (HApp fun arg) = app (wnf fun) arg\nwnf (HVar idx) = HVar idx\nwnf (HSub val) = HSub val\n\napp :: HTerm -> HTerm -> HTerm\napp (HLam bod) x = wnf (bod (wnf x))\napp (HApp fun arg) x = HApp (HApp fun arg) x\napp (HVar idx) x = HApp (HVar idx) x\napp (HSub val) x = HApp (HSub val) x\n\n-- Normalization\n-- -------------\n\nnf :: HTerm -> HTerm\nnf term = case wnf term of\n HLam bod -> HLam $ \\x -> nf (bod (HSub x))\n HApp fun arg -> HApp (nf fun) (nf arg)\n HVar idx -> HVar idx\n HSub val -> val\n\n-- Main\n-- ----\n\na :: HTerm\na = HLam $ \\t -> HApp (HApp t (HVar 1)) (HVar 2)\n\nb :: HTerm\nb = HLam $ \\t -> HApp (HApp t (HVar 2)) (HVar 1)\n\nr :: HTerm\nr = HLam $ \\x -> HApp x (HLam $ \\a -> HLam $ \\b -> HLam $ \\t -> HApp (HApp t b) a)\n\n-- Solve `?x` in `λaλb(?x λt(t a b)) == λaλbλt(t b a)`\nmain :: IO ()\nmain = forM_ [0..2^25-1] $ \\i -> do\n let bs = bits 25 i\n case doParseHTerm bs of\n Nothing -> do\n return ()\n Just x -> do\n let solved = eq (nf (HApp x a)) b 0\n -- putStrLn $ show bs\n -- putStrLn $ doShowTerm x\n -- putStrLn $ doShowTerm (nf x)\n -- putStrLn $ show solved\n -- putStrLn $ \"----------\"\n when solved $ do\n putStrLn (doShowTerm x)\n exitSuccess\n" }, { "path": "examples/enum_lam_naive_blc.hvm", "content": "// This is the HVM version of the naive λ-Calculus enumerator. It superposes all\n// binary λ-calculus strings, parses, and applies to the equation we want to\n// solve. Despite the use of superpositions, this performs about the same as the\n// Haskell version, since HVM is forced to enumerate all terms anyway, and not a\n// lot of sharing is possible. This takes about 32 million interactions. A\n// better approach is provided in the lambda_enumerator_optimal.hvml file, which\n// brings this number down to just 72k interactions.\n// UPDATE: actually - by just avoiding the issue depicted on:\n// https://gist.github.com/VictorTaelin/fb798a5bd182f8c57dd302380f69777a\n// We can bring this naive BLC enumerator down to 1.7m interactions. Not quite\n// as fast as 72k, but this makes it ~37x faster than the Haskell version.\n// UPDATE: somehow this needs only ~111k interactions after using a lazy @and...\n\ndata List {\n #Nil\n #Cons{head tail}\n}\n\ndata Bits {\n #O{pred}\n #I{pred}\n #E\n}\n\ndata Term {\n #Lam{bod}\n #App{fun arg}\n #Var{idx}\n}\n\ndata pair {\n #Pair{fst snd}\n}\n\ndata Maybe {\n #None\n #Some{value}\n}\n\n// Prelude\n// -------\n\n@if(c t f) = ~ c {\n 0: f\n _: t\n}\n\n@when(c t) = ~ c {\n 0: *\n _: t\n}\n\n@tail(xs) = ~ xs {\n #Nil: *\n #Cons{h t}: t\n}\n\n@and(a b) = ~ a !b {\n 0: 0\n _: b\n}\n\n// Parsing\n// -------\n\n@do_parse_term(src) =\n ! &0{src term} = @parse_term(src)\n @do_bind_term(term)\n\n@parse_term(src) = ~src {\n #O{src}:\n ! &0{src nat} = @parse_nat(src)\n &0{src #Var{nat}}\n #I{src}: ~src {\n #O{src}:\n ! &0{src bod} = @parse_term(src)\n &0{src #Lam{bod}}\n #I{src}:\n ! &0{src fun} = @parse_term(src)\n ! &0{src arg} = @parse_term(src)\n &0{src #App{fun arg}}\n #E: * \n }\n #E: *\n}\n\n@parse_nat(src) = ~src {\n #O{src}: &0{src 0}\n #I{src}:\n ! &0{src nat} = @parse_nat(src)\n &0{src (+ 1 nat)}\n #E: &0{#E 0}\n}\n\n// Binding\n// -------\n\n@do_bind_term(term) =\n ! &0{ctx term} = @bind_term(term #Nil)\n term\n\n@bind_term(term ctx) = ~term !ctx {\n #Lam{bod}:\n ! &0{ctx bod} = @bind_term(bod #Cons{#Some{$x} ctx})\n &0{@tail(ctx) #Lam{λ$x bod}}\n #App{fun arg}:\n ! &0{ctx fun} = @bind_term(fun ctx)\n ! &0{ctx arg} = @bind_term(arg ctx)\n &0{ctx #App{fun arg}}\n #Var{idx}: @get(idx ctx)\n}\n\n@get(idx ctx) = ~ idx !ctx {\n 0: ~ ctx {\n #Nil: *\n #Cons{h t}: ~ h {\n #None: *\n #Some{x}: &0{#Cons{#None t} x}\n }\n }\n 1+p: ~ ctx {\n #Nil: *\n #Cons{h t}:\n ! &0{t x} = @get(p t)\n &0{#Cons{h t} x}\n }\n}\n\n// Stringification\n// ---------------\n\n@show_nat(nat) = ~nat { \n 0: λk #Cons{'Z' k}\n 1+p: λk #Cons{'S' (@show_nat(p) k)}\n}\n\n@show_dec(n r) =\n ! &{n n0} = n\n ! &{n n1} = n\n ! chr = (+ (% n 10) '0')\n ~ (< n0 10) !chr !r {\n 0: @show_dec((/ n1 10) #Cons{chr r})\n _: #Cons{chr r}\n }\n\n@do_show_dec(n) = @show_dec(n #Nil)\n\n@show_bits(bits) = ~bits {\n #O{pred}: λk #Cons{'#' #Cons{'O' #Cons{'{' (@show_bits(pred) #Cons{'}' k})}}}\n #I{pred}: λk #Cons{'#' #Cons{'I' #Cons{'{' (@show_bits(pred) #Cons{'}' k})}}}\n #E: λk #Cons{'#' #Cons{'E' k}}\n}\n\n@do_show_bits(bits) = (@show_bits(bits) #Nil)\n\n@show_term(term dep) = ~term !dep {\n #Var{idx}: λk\n @show_dec((- (- dep idx) 1) k)\n #Lam{bod}: λk\n !&0{d0 d1}=dep\n #Cons{'λ' (@show_term((bod #Var{d0}) (+ d1 1)) k)}\n #App{fun arg}: λk\n !&0{d0 d1}=dep\n #Cons{'(' (@show_term(fun d0)\n #Cons{' ' (@show_term(arg d1)\n #Cons{')' k})})}\n}\n\n@do_show_term(term) = (@show_term(term 0) #Nil)\n\n// Equality\n// --------\n\n@eq(a b dep) = ~ @wnf(a) !b !dep {\n #Lam{a_bod}: ~ @wnf(b) !dep {\n #Lam{b_bod}:\n !&1{dep d0}=dep\n !&1{dep d1}=dep\n !&1{dep d2}=dep\n @eq((a_bod #Var{d0}) (b_bod #Var{d1}) (+ 1 d2))\n #App{b_fun b_arg}: 0\n #Var{b_idx}: 0\n }\n #App{a_fun a_arg}: ~ b !dep {\n #Lam{b_bod}: 0\n #App{b_fun b_arg}:\n !&1{dep d0}=dep\n !&1{dep d1}=dep\n @and(@eq(a_fun b_fun d0) @eq(a_arg b_arg d1))\n #Var{b_idx}: 0\n }\n #Var{a_idx}: ~ b !dep {\n #Lam{b_bod}: 0\n #App{b_fun b_arg}: 0\n #Var{b_idx}: (== a_idx b_idx)\n }\n}\n\n// Evaluation\n// ----------\n\n@wnf(term) = ~ term { \n #Lam{bod}: #Lam{bod}\n #App{fun arg}: @app(@wnf(fun) arg)\n #Var{idx}: #Var{idx}\n}\n\n@app(f x) = ~ f !x {\n #Lam{bod}: @wnf((bod @wnf(x)))\n #App{fun arg}: #App{#App{fun arg} x}\n #Var{idx}: #App{#Var{idx} x}\n}\n\n// Enumeration\n// -----------\n\n// Enums all Bins of given size (label 1)\n@all1(s) = ~s{\n 0: #E\n 1+p: !&2{p0 p1}=p &2{\n #O{@all1(p0)}\n #I{@all1(p1)}\n }\n}\n\n// Tests\n// -----\n\n//A= λt (t ^1 ^2)\n//A= λ((Z SZ) SSZ)\n@A = #Lam{λt #App{#App{t #Var{1}} #Var{2}}}\n\n//B= λt (t ^2 ^1)\n//B= λ((Z SSZ) SZ)\n@B = #Lam{λt #App{#App{t #Var{2}} #Var{1}}}\n\n//R= λx (x λa λb λt (t b a))\n//R= λ(Z λλλ((SSSZ SSZ) SZ))\n@R = #Lam{λx #App{x #Lam{λa #Lam{λb #Lam{λt #App{#App{t b} a}}}}}}\n\n@X = @all1(25)\n\n// Solve `?x` in `λaλb(?x λt(t a b)) == λaλbλt(t b a)`\n@main =\n ! &5{x0 x1} = @do_parse_term(@X)\n ! solved = @eq(#App{x0 @A} @B 0) // (?x A) == B\n @when(solved @do_show_term(x1))\n" }, { "path": "examples/enum_lam_smart.hvm", "content": "// An Optimal λ-Calculus Enumerator for Program Search\n// ---------------------------------------------------\n// This file shows a template on how to enumerate superposed terms in a\n// higher-order language (here, the affine λ-Calculus) for proof search.\n// Instead of generating the source syntax (like superposing all binary strings\n// and parsing it as a binary λ-calculus), we create a superposition of all\n// λ-terms *directly*, in a way that head constructors are emitted as soon as\n// possible. This allows HVM to prune branches and backtrack efficiently as it\n// computes the application of all λ-terms to some expression. The result is a\n// reduction in the interactions needed to solve the equation:\n// > (?X λt(t 1 2)) == λt(t 2 1)\n// From ~32 million to just 76k, a 420x speedup*, which increases the harder the\n// problem is. This generator works by synthesizing a λ-term in layers. On each\n// layer, we either generate a lambda and extend a context, or select one of the\n// variables in the context to return. When we select a variable, we will apply\n// it to either 0, 1 or 2 other variables in the context (we don't generate\n// terms with >2 arity apps here). This is not ideal; in a typed version, we\n// would be able to tell the arity of the context variable, and generate the\n// right amount of applications, without making a guess.\n// * NOTE: we're actually able to bring the naive approach down to 1.7 million\n// interactions. So, the numbers are:\n// - Enum binary λC with loops (Haskell): 0.992s \n// - Enum binary λC with sups (HVM): 0.026s (38x speedup)\n// - Enum λC directly with sups (HVM): 0.0011s (862x speedup)\n// The main contribution of this file is on the shape of the superposer. There\n// are a few things that one must get right to achieve the desired effect.\n// First, how do we split a linear context? It depends: when generating an\n// application like `(f ?A ?B)`, we need to pass the context to `?A`, get the\n// leftover, and pass it to `?B`, in such a way that `?A` and `?B` won't use the\n// same variable twice. This happens within the same \"universe\". Yet, when\n// making a choice, like \"do we return a lambda or a variable here\", we need to\n// clone the linear context with the same label forked the universe itself,\n// allowing a variable to be used more than once, as long as its occurrences are\n// in different universes. Handling this correctly is very subtle, which is why\n// this file can be useful for study.\n// Second, how do we handle labels? As discussed recently on Discord:\n// https://discord.com/channels/912426566838013994/915345481675186197/1311434500911403109\n// We only need one label to fully enumerate all natural numbers. Yet, that\n// doesn't work for binary trees. My conclusion is that we need to \"fork\" the\n// label whenever we enumerate a constructor that branches; i.e., that has more\n// than one field. Nats and Bits are safe because their constructors only have\n// one field, but a binary Tree needs forking. To fork a label, we just mul by 2\n// and add 0 or 1, and the seed has to be 1, so that forked branches never use\n// the same label. We apply this here to the arity-2 app case.\n// Third, how do we emit constructors as soon as possible, while still passing a\n// context down? It is easy to accidentally mess this up by making the enum\n// monadic. This will cause it to sequentialize its execution, meaning no ctor\n// is emitted until the entire enumerator returns. That's a big problem, since\n// we need head ctors to be available as soon as possible. That's how HVM is\n// able to invalidate universes and backtrack. While this is a silly issue, it\n// can spoil the whole thing, so I've elaborated it here:\n// https://gist.github.com/VictorTaelin/fb798a5bd182f8c57dd302380f69777a\n// The enumerator in this file is the simplest \"template\" enumerator that has\n// everything a higher order language needs and is structured in a way that can\n// be studied and extended with more sophisticate approaches, like types.\n// EDIT: the dependently typed version has been pushed. It reduces the rewrite\n// count to 3k, and greatly improves the enumerator shape.\n\ndata List {\n #Nil\n #Cons{head tail}\n}\n\ndata Bits {\n #O{pred}\n #I{pred}\n #E\n}\n\ndata Term {\n #Lam{bod}\n #App{fun arg}\n #Var{idx}\n #Sub{val}\n}\n\ndata pair {\n #Pair{fst snd}\n}\n\ndata Result {\n #Result{src val}\n}\n\ndata Maybe {\n #None\n #Some{value}\n}\n\n// Prelude\n// -------\n\n@if(c t f) = ~ c {\n 0: f\n _: t\n}\n\n@when(c t) = ~ c {\n 0: *\n _: t\n}\n\n@tail(xs) = ~ xs {\n #Nil: *\n #Cons{h t}: t\n}\n\n@and(a b) = ~ a !b {\n 0: 0\n _: b\n}\n\n@unwrap(mb) = ~ mb {\n #None: *\n #Some{x}: x\n}\n\n@tm0(x) = !&0{a b}=x a\n@tm1(x) = !&0{a b}=x b\n\n// Stringification\n// ---------------\n\n@show_nat(nat) = ~nat { \n 0: λk #Cons{'Z' k}\n 1+p: λk #Cons{'S' (@show_nat(p) k)}\n}\n\n@show_dec(&n r) =\n ! chr = (+ (% n 10) '0')\n ~ (< n 10) !chr !r {\n 0: @show_dec((/ n 10) #Cons{chr r})\n _: #Cons{chr r}\n }\n\n@do_show_dec(n) = @show_dec(n #Nil)\n\n@show_bits(bits) = ~bits {\n #O{pred}: λk #Cons{'#' #Cons{'O' #Cons{'{' (@show_bits(pred) #Cons{'}' k})}}}\n #I{pred}: λk #Cons{'#' #Cons{'I' #Cons{'{' (@show_bits(pred) #Cons{'}' k})}}}\n #E: λk #Cons{'#' #Cons{'E' k}}\n}\n\n@do_show_bits(bits) = (@show_bits(bits) #Nil)\n\n@show_term(term dep) = ~term !&dep {\n #Var{idx}: λk\n @show_dec((- (- dep idx) 1) k)\n #Lam{bod}: λk\n #Cons{'λ' (@show_term((bod #Var{dep}) (+ dep 1)) k)}\n #App{fun arg}: λk\n #Cons{'(' (@show_term(fun dep)\n #Cons{' ' (@show_term(arg dep)\n #Cons{')' k})})}\n #Sub{val}: *\n}\n\n@do_show_term(term) = (@show_term(term 0) #Nil)\n\n// Equality\n// --------\n\n@eq(a b dep) = ~ a !b !dep {\n #Lam{a_bod}: ~ b !&dep {\n #Lam{b_bod}:\n @eq((a_bod #Var{dep}) (b_bod #Var{dep}) (+ 1 dep))\n else: 0\n }\n #App{a_fun a_arg}: ~ b !&dep {\n #App{b_fun b_arg}:\n @and(@eq(a_fun b_fun dep) @eq(a_arg b_arg dep))\n else: 0\n }\n #Var{a_idx}: ~ b !&dep {\n #Var{b_idx}: (== a_idx b_idx)\n else: 0\n }\n #Sub{a_val}: *\n}\n\n// Evaluation\n// ----------\n\n@wnf(term) = ~ term { \n #Lam{bod}: #Lam{bod}\n #App{fun arg}: @wnf_app(@wnf(fun) arg)\n #Var{idx}: #Var{idx}\n #Sub{val}: #Sub{val}\n}\n\n@wnf_app(f x) = ~ f !x {\n #Lam{bod}: @wnf((bod @wnf(x)))\n #App{fun arg}: #App{#App{fun arg} x}\n #Var{idx}: #App{#Var{idx} x}\n #Sub{val}: #App{#Sub{val} x}\n}\n\n// Normalization\n// -------------\n\n@nf(term) = ~ @wnf(term) {\n #Lam{bod}: #Lam{λx @nf((bod #Sub{x}))}\n #App{fun arg}: #App{@nf(fun) @nf(arg)}\n #Var{idx}: #Var{idx}\n #Sub{val}: val\n}\n\n// Enumeration\n// -----------\n\n// Enumerates affine λ-terms.\n// - lim: max context length (i.e., nested lambdas)\n// - lab: superposition label. should be 1 initially.\n// - ctx: the current scope. should be [] initially.\n// If the binder limit has been reached, destroy this universe.\n// Otherwise, make a choice.\n// - A. We generate a fresh lambda.\n// - B. We select a variable from context.\n// Note that, every time we make a choice, we \"fork\" the current context by\n// using DUP nodes with the same label that we used in the choice SUP node.\n@all(!&L !&lim ctx) = ~lim {\n 0: *\n 1+&lim:\n !&L{ctxL ctxR} = ctx\n &L{\n @lam(L lim ctxL)\n @ret(L (+ lim 1) ctxR λk(k))\n }\n}\n\n// Generate a fresh lambda and extend the context with its variable.\n@lam(!&L !&lim ctx) =\n !&0{ctx bod} = @all(L lim #Cons{#Some{$x} ctx})\n &0{@tail(ctx) #Lam{λ$x(bod)}}\n\n// Return a variable from the context.\n// If the context is empty, destroy this universe.\n// Otherwise, make a choice.\n// - A. We emit the head of the context, and apply it to things.\n// - B. We keep the head of the context, and go to the next element.\n@ret(!&L !&lim ctx rem) = ~ctx {\n #Nil: *\n #Cons{val ctx}:\n !&L{remL remR} = rem\n !&L{valL valR} = val\n !&L{ctxL ctxR} = ctx\n &L{\n @app(L lim (remL #Cons{#None ctxL}) valL)\n @ret(L lim ctxR λk(remR #Cons{valR k}))\n }\n}\n\n// To apply a value to things, we will make a triple choice.\n// - A. Just return it directly.\n// - B. Apply it to 1 argument.\n// - C. Apply it to 2 arguments.\n// When we apply it to 2 arguments, as in `(App ?A ?B)`, we need to fork the\n// label, so that DUPs/SUPs in `?A` and `?B` never use the same label.\n@app(!&L !&lim ctx val) = ~ val {\n #None: *\n #Some{val}: \n !&L{val val0} = val\n !&L{val val1} = val\n !&L{val val2} = val\n !&L{ctx ctx0} = ctx\n !&L{ctx ctx1} = ctx\n !&L{ctx ctx2} = ctx\n ! arity_0 =\n &0{ctx0 val0}\n ! arity_1 = \n !&0{ctx1 argX} = @all(L lim ctx1)\n &0{ctx1 #App{val1 argX}}\n ! arity_2 =\n !&0{ctx2 argX} = @all((+(* L 2) 0) lim ctx2)\n !&0{ctx2 argY} = @all((+(* L 2) 1) lim ctx2)\n &0{ctx2 #App{#App{val2 argX} argY}}\n &L{arity_0 &L{arity_1 arity_2}}\n}\n\n// Tests\n// -----\n\n//A= λt (t ^1 ^2)\n//A= λ((Z SZ) SSZ)\n@A = #Lam{λt #App{#App{t #Var{1}} #Var{2}}}\n\n//B= λt (t ^2 ^1)\n//B= λ((Z SSZ) SZ)\n@B = #Lam{λt #App{#App{t #Var{2}} #Var{1}}}\n\n//R= λx (x λa λb λt (t b a))\n//R= λ(Z λλλ((SSSZ SSZ) SZ))\n@R = #Lam{λx #App{x #Lam{λa #Lam{λb #Lam{λt #App{#App{t b} a}}}}}}\n\n//X= (all terms)\n@X = @tm1(@all(1 5 #Nil))\n\n// Solves for `?X` in `(?X λt(t A B)) == λt(t B A)`.\n// It finds `?X = λλ(1 λλ((2 0) 1))` in 76k interactions.\n@main =\n ! solved = @eq(@nf(#App{@X @A}) @B 0)\n @when(solved @do_show_term(@X))\n" }, { "path": "examples/enum_nat.hvm", "content": "// This shows how to use a 'pseudo-metavar' to invert the binary add function,\n// and solve the equation: 'X * 20 = 5000'. Run it with collapse mode:\n// $ hvml run pseudo_metavar_nat.hvml -C -s\n\n// Unary Peano Nats\ndata Nat { #Z #S{pred} }\n\n// If-Then-Else\n@if(b t f) = ~b {\n 0: f\n _: t\n}\n\n// Converts an U32 to a Nat\n@nat(n) = ~n{\n 0: #Z\n 1+p: #S{@nat(p)}\n}\n\n// Converts a Nat to an U32\n@u32(n) = ~n{\n #Z: 0\n #S{np}: (+ 1 @u32(np))\n}\n\n// Adds two Nats\n@add(a b) = ~a !b {\n #Z: b\n #S{ap}: #S{@add(ap b)}\n}\n\n// Muls two Nats\n@mul(a b) = ~a !b {\n #Z: #Z\n #S{ap}: !&1{b0 b1}=b @add(b0 @mul(ap b1))\n}\n\n// Compares two Nats for equality\n@eq(a b) = ~a !b {\n #Z: ~b{\n #Z: 1\n #S{bp}: 0\n }\n #S{ap}: ~b{\n #Z: 0\n #S{bp}: @eq(ap bp)\n }\n}\n\n// A superposition of all Nats (pseudo-metavar)\n@X = &0{#Z #S{@X}}\n\n// Solves 'X * 20 = 20000'\n@main = @if(@eq(@mul(@X @nat(20)) @nat(12000)) @u32(@X) *)\n\n// This is quadratic. In the post below, I discuss solutions to make it linear:\n// https://gist.github.com/VictorTaelin/93c327e5b4e752b744d7798687977f8a\n// These solutions are implemented on the branches:\n// - oportunistic_swaps\n// - unordered_superpositions\n// Sadly they don't work as I expected in all cases. More clarity is needed.\n" }, { "path": "examples/enum_path_finder.hvm", "content": "// Simple path finding with superpositions\n\n// Lists\ndata List { #Nil #Cons{head tail} }\n\n// Directions (Left/Right/Up/Down)\ndata Dir { #L #R #U #D }\n\n// Collapses an universe when c=0\n@when(!c t) =\n ~ c {\n 0: *\n _: t\n }\n\n// Decrements/increments a number\n@dec(x) = ~ x { 0:*; 1+x:x }\n@inc(x) = (+ x 1)\n\n// Swaps an element in an array\n@swap(xs i v) = ~ i !xs !v {\n 0: ~ xs {\n #Nil: *\n #Cons{x xs}:\n &0{#Cons{v xs} x}\n }\n 1+i: ~ xs {\n #Nil: *\n #Cons{x xs}:\n ! &0{xs v} = @swap(xs i v)\n &0{#Cons{x xs} v}\n }\n}\n\n// Swaps an element in a 2D grid\n@swap2D(xs pos v) =\n ! &0{i j } = pos\n ! & {i0 i1} = i\n ! & {j0 j1} = j\n ! &0{xs ys} = @swap(xs j0 *)\n ! &0{ys k } = @swap(ys i0 *)\n ! &0{ys _ } = @swap(ys i1 v)\n ! &0{xs _ } = @swap(xs j1 ys)\n &0{xs k}\n\n// Moves a position to a direction\n@move(pos dir) =\n ! &0{x y} = pos\n ~ dir !x !y {\n #L: &0{@dec(x) y}\n #R: &0{@inc(x) y}\n #U: &0{x @dec(y)}\n #D: &0{x @inc(y)}\n }\n\n@diff(&a &b) =\n ~ (< a b) {\n 0: (- a b)\n _: (- b a)\n }\n\n@gdist(pos goal) =\n ! &0{px py} = pos\n ! &0{gx gy} = goal\n ! dx = @diff(px gx)\n ! dy = @diff(py gy)\n (+ dx dy)\n\n@closer(prev curr &goal) =\n ! d_prev = @gdist(prev goal) // distance from prev → goal\n ! d_curr = @gdist(curr goal) // distance from cur → goal\n (< d_curr d_prev)\n\n!@walk(map &pos !path &goal) =\n ~ path {\n #Nil:\n pos\n #Cons{dir path}:\n ! &new_pos = @move(pos dir)\n ! &0{map got} = @swap2D(map new_pos 0) // <- 0 means we don't replace the prev tile by a wall, making it much harder\n ~ got {\n 0: ↑@walk(map new_pos path goal) // <- generates a weird path? and ↓ hangs...\n //~ @closer(pos new_pos goal) !map !path {\n //0: ↓↓@walk(map new_pos path goal)\n //_: ↓@walk(map new_pos path goal)\n //}\n _: *\n }\n }\n\n@map = [\n [0 1 0 1 0 0 0 0 0]\n [0 1 0 1 0 1 1 1 0]\n [0 0 0 1 0 0 0 1 0]\n [0 1 1 1 0 1 1 0 0]\n [0 0 0 0 0 1 0 1 0]\n [0 1 1 1 0 1 0 1 0]\n [0 1 0 0 0 1 0 1 0]\n [0 1 0 1 1 1 0 1 0]\n [0 0 0 0 0 0 0 1 0]\n]\n\n// Superposition of all possible paths\n@dirs(&L) = ~ L {\n 0: #Nil\n 1+&L: &1{#Nil &1{#Cons{#L @dirs(L)} &1{#Cons{#R @dirs(L)} &1{#Cons{#U @dirs(L)} #Cons{#D @dirs(L)}}}}}\n}\n\n// Finds a path from (0,0) to (8,8)\n@main =\n ! &lim = 32\n ! &ini = &0{0 0}\n ! &end = &0{4 0}\n ! &0{i j} = @walk(@map ini @dirs(lim) end)\n ! &0{I J} = end\n @when((& (== i I) (== j J)) @dirs(lim))\n //@when((& (== i I) (== j J)) 1)\n" }, { "path": "examples/enum_primes.hs", "content": "-- //./pseudo_metavar_factors.hvml//\n\nimport Control.Monad (forM_, when)\nimport Data.Time.Clock (getCurrentTime, diffUTCTime)\nimport System.Exit (exitSuccess)\nimport Text.Printf (printf)\n\ndata Bin = O Bin | I Bin | E deriving (Show, Eq)\n\nu32 :: Bin -> Int\nu32 (O p) = 2 * u32 p + 0\nu32 (I p) = 2 * u32 p + 1\nu32 E = 0\n\nbin :: Int -> Int -> Bin\nbin 0 _ = E\nbin s n = case n `mod` 2 of\n 0 -> O (bin (s-1) (n `div` 2))\n _ -> I (bin (s-1) (n `div` 2))\n\neq :: Bin -> Bin -> Bool\neq E E = True\neq (O a) (O b) = eq a b\neq (I a) (I b) = eq a b\neq _ _ = False\n\ninc :: Bin -> Bin\ninc (O p) = I p\ninc (I p) = O (inc p)\ninc E = E\n\nadd :: Bin -> Bin -> Bin\nadd (O a) (O b) = O (add a b)\nadd (O a) (I b) = I (add a b)\nadd (I a) (O b) = I (add a b)\nadd (I a) (I b) = O (inc (add a b))\nadd E b = E\nadd a E = E\n\nmul :: Bin -> Bin -> Bin\nmul _ E = E\nmul a (O b) = O (mul a b)\nmul a (I b) = add a (O (mul a b))\n\ncat :: Bin -> Bin -> Bin\ncat (O a) b = O (cat a b)\ncat (I a) b = I (cat a b)\ncat E b = b\n\nk = 14\nh = 15\ns = 30\np = 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))))))))))))))))))))))))))))))\n\n--INJECT--\n\nmain :: IO ()\nmain = do\n start <- getCurrentTime\n forM_ [0..2^h-1] $ \\a -> do\n forM_ [0..2^h-1] $ \\b -> do\n let binA = cat (bin h a) (bin h 0)\n let binB = cat (bin h b) (bin h 0)\n when (eq (mul binA binB) p) $ do\n end <- getCurrentTime\n let duration = diffUTCTime end start\n putStrLn $ \"FACT: \" ++ show a ++ \" \" ++ show b\n putStrLn $ \"TIME: \" ++ printf \"%.7f seconds\" (realToFrac duration :: Double)\n exitSuccess\n" }, { "path": "examples/enum_primes.hvm", "content": "// 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 an U32\n@u32(b) = ~b{\n #O{p}: (+ (* 2 @u32(p)) 0)\n #I{p}: (+ (* 2 @u32(p)) 1)\n #E: 0\n}\n\n// Converts an U32 to a Bin of given size\n@bin(s n) = ~s{\n 0: #E\n 1+p: !&0{n0 n1}=n ~(% n0 2) !p !n1 {\n 0: #O{@bin(p (/ n1 2))}\n _: #I{@bin(p (/ n1 2))}\n }\n}\n\n// Bin Equality\n@eq(a b) = ~a !b {\n #E: ~b {\n #O{bp}: 0\n #I{bp}: 0\n #E: 1\n }\n #O{ap}: ~b{\n #O{bp}: @eq(ap bp)\n #I{bp}: 0\n #E: 0\n }\n #I{ap}: ~b{\n #O{bp}: 0\n #I{bp}: @eq(ap bp)\n #E: 0\n }\n}\n\n// Increments a Bin\n@inc(a) = ~a{\n #O{p}: #I{p}\n #I{p}: #O{@inc(p)}\n #E: #E\n}\n\n// Decrements a Bin\n@dec(a) = ~a{\n #O{p}: #O{@dec(p)}\n #I{p}: #I{p}\n #E: #E\n}\n\n// Adds two Bins\n@add(a b) = ~a !b {\n #O{ap}: ~b !ap {\n #O{bp}: #O{@add(ap bp)}\n #I{bp}: #I{@add(ap bp)}\n #E: #E\n }\n #I{ap}: ~b !ap {\n #O{bp}: #I{@add(ap bp)}\n #I{bp}: #O{@inc(@add(ap bp))}\n #E: #E\n }\n #E: #E\n}\n\n// Muls two Bins\n@mul(a b) = ~b !a {\n #O{bp}: #O{@mul(a bp)}\n #I{bp}: !&0{a0 a1}=a @add(a0 #O{@mul(a1 bp)})\n #E: #E\n}\n\n// Concatenates two Bins\n@cat(a b) = ~a !b {\n #O{ap}: #O{@cat(ap b)}\n #I{ap}: #I{@cat(ap b)}\n #E: b\n}\n\n// Enums all Bins of given size (label 1)\n@all1(s) = ~s{\n 0: #E\n 1+p: !&1{p0 p1}=p &1{ #O{@all1(p0)} #I{@all1(p1)} }\n}\n\n// Enums all Bins of given size (label 2)\n@all2(s) = ~s{\n 0: #E\n 1+p: !&2{p0 p1}=p &2{ #O{@all2(p0)} #I{@all2(p1)} }\n}\n\n// 8:\n@K_A = 3\n@H_A = 4\n@S_A = 8\n@X_A = @cat(@all1(@H_A) @bin(@H_A 0))\n@Y_A = @cat(@all2(@H_A) @bin(@H_A 0))\n@P_A = #I{#O{#O{#I{#O{#I{#O{#I{#E}}}}}}}}\n\n// 20:\n@K_B = 9\n@H_B = 10\n@S_B = 20\n@X_B = @cat(@all1(@H_B) @bin(@H_B 0))\n@Y_B = @cat(@all2(@H_B) @bin(@H_B 0))\n@P_B = #I{#I{#I{#I{#O{#I{#I{#O{#I{#I{#O{#O{#I{#O{#I{#O{#O{#O{#I{#I{#E}}}}}}}}}}}}}}}}}}}}\n\n// 30:\n@K_C = 14\n@H_C = 15\n@S_C = 30\n@X_C = @cat(@all1(@H_C) @bin(@H_C 0))\n@Y_C = @cat(@all2(@H_C) @bin(@H_C 0))\n@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}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}\n\n////INJECT//\n\n@main = @if(@eq(@mul(@X_B @Y_B) @P_B) λt(t @u32(@X_B) @u32(@Y_B)) *)\n" }, { "path": "examples/feat_affine_ctx.hvm", "content": "// Optimal recursive context passing with HVM's \"pure mutable references\"\n// Article: https://gist.github.com/VictorTaelin/fb798a5bd182f8c57dd302380f69777a\n\ndata Pair { #Pair{fst snd} }\ndata List { #Nil #Cons{head tail} }\ndata Tree { #Leaf #Node{lft rgt} }\n\n// Utils\n// -----\n\n@is_node(tree) = ~tree {\n #Leaf: 0\n #Node{lft rgt}: 1\n}\n\n@range(n r) = ~n !r {\n 0: r\n 1+p: !&0{p0 p1}=p @range(p0 #Cons{p1 r})\n}\n\n@fst(p) = ~p {\n #Pair{fst snd}: fst\n}\n\n@snd(p) = ~p {\n #Pair{fst snd}: snd\n}\n\n@tm0(sup) = !&0{tm0 tm1}=sup tm0\n@tm1(sup) = !&0{tm0 tm1}=sup tm1\n\n// Mutable references\n@mut(ref fn) = !! $new = (fn (ref $new)) *\n@spt(ref fn) = (fn λ$y(ref $z) λ$z($y))\n\n// Slow Version\n// ------------\n\n// The slow version passes a context monadically, with a pair state.\n@list_to_tree_slow(n ctx) = ~n !ctx {\n // Base Case:\n // - take the ctx's head\n // - return the context's tail and '#Leaf{head}'\n 0: ~ctx {\n #Nil: *\n #Cons{head tail}: #Pair{tail #Leaf{head}}\n }\n // Step Case:\n // - recurse to the lft, get the new ctx and 'lft' tree\n // - recurse to the rgt, get the new ctx and 'rgt' tree\n // - return the final context and a '#Node{lft rgt}'\n 1+p:\n !&0{p0 p1}=p\n ~ @list_to_tree_slow(p0 ctx) {\n #Pair{ctx lft}: ~ @list_to_tree_slow(p1 ctx) {\n #Pair{ctx rgt}: #Pair{ctx #Node{lft rgt}}\n }\n }\n}\n\n// Fast Version: parallel destructing\n// ----------------------------------\n\n// This version uses a superposition instead of a pair. It is faster because it\n// allows us to destruct in parallel (which isn't available for native ADTs),\n// preventing the sequential chaining issue.\n@list_to_tree_fast_par(n ctx) = ~n !ctx {\n 0: ~ctx {\n #Nil: *\n #Cons{head tail}: &0{tail #Leaf{head}}\n }\n 1+p:\n ! &0{p0 p1} = p\n ! &0{ctx lft} = @list_to_tree_fast_par(p0 ctx)\n ! &0{ctx rgt} = @list_to_tree_fast_par(p1 ctx)\n &0{ctx #Node{lft rgt}}\n}\n\n// Fast Version: mutable references\n// --------------------------------\n\n// This version passes the context as a mutable reference.\n// It avoids pair entirely.\n@list_to_tree_fast_mut(n ctx) = ~n !ctx {\n // Base case:\n // - mutably replace the context by its tail, and extract its head\n // - return just '#Leaf{head}' (no pairs!)\n 0: \n !! @mut(ctx λctx ~ctx { #Nil:* #Cons{$head tail}:tail })\n #Leaf{$head}\n // Step Case:\n // - split the mutable reference into two\n // - recurse to the lft and rgt, passing the split mut refs\n // - return just '#Node{lft rgt}' directly (no pairs!)\n 1+p:\n !&0{pL pR}=p\n !! @spt(ctx λ$ctxL λ$ctxR *)\n #Node{\n @list_to_tree_fast_mut(pL $ctxL)\n @list_to_tree_fast_mut(pR $ctxR)\n }\n}\n\n// Main\n// ----\n\n// Tree Depth\n@depth = 16\n\n// Tests slow version\n//@main = @is_node(@snd(@list_to_tree_slow(@depth (@range((<< 1 @depth) 0)))))\n\n// Tests fast version with parallel destruct\n@main = @is_node(@tm1(@list_to_tree_fast_par(@depth (@range((<< 1 @depth) 0)))))\n\n// Tests fast version with mutable refs\n//@main = @is_node(@list_to_tree_fast_mut(@depth λ$ctx(@range((<< 1 @depth) 0))))\n" }, { "path": "examples/feat_cmul.hvm", "content": "@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", "content": "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 ys) = ~xs !ys {\n #Nil: ys\n #Cons{h t}: #Cons{h @cat(t ys)}\n}\n\n@join(xs) = ~xs {\n #Nil: #Nil\n #Cons{h t}: @cat(h @join(t))\n}\n\n@show(term) = ~term {\n #Var{nam}: nam\n #Lam{nam bod}: !&0{n0 n1}=nam @join([\"λ\" n0 \" \" @show((bod #Var{n1}))])\n #App{fun arg}: @join([\"(\" @show(fun) \" \" @show(arg) \")\"])\n #Sub{val}: @show(val)\n}\n\n@wnf(term) = ~term {\n #Var{nam}: #Var{nam}\n #Lam{nam bod}: #Lam{nam bod}\n #App{fun arg}: @app(@wnf(fun) arg)\n #Sub{val}: @wnf(val)\n}\n\n@nf(term) = ~ @wnf(term) {\n #Var{nam}: #Var{nam}\n #Lam{nam bod}: #Lam{nam λx @nf((bod #Sub{x}))}\n #App{fun arg}: #App{@nf(fun) @nf(arg)}\n #Sub{val}: val\n}\n\n@app(f x) = ~f !x {\n #Var{nam}: #App{#Var{nam} x}\n #Lam{nam bod}: @wnf((bod @wnf(x)))\n #App{fun arg}: #App{#App{fun arg} x}\n #Sub{val}: #Var{\"TODO\"}\n}\n\n@ID = #Lam{\"x\" λx(x)}\n@c2 = #Lam{\"f\" λf #Lam{\"x\" λx !&1{f0 f1}=f #App{f0 #App{f1 x}}}}\n@k2 = #Lam{\"g\" λf #Lam{\"y\" λx !&2{f0 f1}=f #App{f0 #App{f1 x}}}}\n@fn = #App{@c2 @k2}\n\n@main = @show(@nf(@fn))\n" }, { "path": "examples/feat_mut_ref.hvm", "content": "// Article: https://gist.github.com/VictorTaelin/fb798a5bd182f8c57dd302380f69777a\n\n@mut(ref fn) = !! $new = (fn (ref $new)) *\n@spt(ref fn) = (fn λ$y(ref $z) λ$z($y))\n\n@main =\n ! $X = λ$x(0) // u32* X = &0;\n !! @spt($X λ$X0 λ$X1 *) // u32* X0 = X; u32* X1 = X;\n !! @mut($X0 λx(+ x 1)) // *X += 1;\n !! @mut($X1 λx(+ x 1)) // *X += 1;\n $x // *X\n\n// The '!! x = val' notation represents a seq operator.\n// It reduces 'val' to whnf and assigns the result to 'x'.\n// The '!! val' notation is a shortcut for '!! _ = val'.\n// The '$var' notation is for globally scoped variables.\n" }, { "path": "examples/fuse_inc.hvm", "content": "// A minimal example of Optimal Evaluation (:\n\n// Bits (Native)\ndata Bits {\n #O{pred}\n #I{pred}\n #E{}\n}\n\n// Repeated Application\n@rep(n f x) = ~ n !f !x {\n 0: x\n 1+p: !&0{f0 f1}=f (f0 @rep(p f1 x))\n}\n\n// Squared Application\n@sqr(n f x) = ~ n !f !x {\n 0: x\n 1+p:\n !&0{p0 p1}=(+ p 1)\n !&0{fA f0}=f\n !&0{f1 f2}=fA\n @sqr((/ p0 2) λk(f0 (f1 k)) @rep((% p1 2) f2 x))\n}\n\n// Bits (Scott)\n@o(x) = λo λi λe (o x)\n@i(x) = λo λi λe (i x)\n@e = λo λi λe e\n\n// Bits increment\n@inc(x) = λo λi λe (x i λop(o @inc(op)) e)\n\n// Creates an all-zero Bits\n@zero(s) = ~s{\n 0: @e\n 1+p: @o(@zero(p))\n}\n\n// Converts a Bits to an U32\n@bits_to_u32(xs) = (xs\n λp0 (+ (* 2 @bits_to_u32(p0)) 0)\n λp1 (+ (* 2 @bits_to_u32(p1)) 1)\n 0)\n\n// Applies 'inc' N times to zero\n@main = @bits_to_u32(@sqr(1234567 λx@inc(x) @zero(32)))\n" }, { "path": "examples/fuse_inc.hvm1", "content": "// 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 n f x) = (Sqr (/ n 2) λk(f (f k)) (Rep (% n 2) f x))\n\n// Bits (Scott-Encoded)\n(O x) = λo λi λe (o x)\n(I x) = λo λi λe (i x)\nE = λo λi λe e\n\n// Bits increment\n(Inc x) = λo λi λe (x i λop(o (Inc op)) e)\n\n// Converts a Bits to a U60\n(BitsToU60 x) = (x\n λp0 (+ (* 2 (BitsToU60 p0)) 0)\n λp1 (+ (* 2 (BitsToU60 p1)) 1)\n 0)\n\n(Zero 0) = E\n(Zero s) = (O (Zero (- s 1)))\n\n// Applies 'Inc' N times to zero\nMain = (BitsToU60 (Sqr 1234567 λx(Inc x) (Zero 60)))\n" }, { "path": "examples/fuse_mul.hvm", "content": "// Multiplication by squared addition with optimal evaluation\n\n// Repeated Application\n@rep(n f x) = ~ n !f !x {\n 0: x\n 1+p: !&0{f0 f1}=f (f0 @rep(p f1 x))\n}\n\n// Squared Application\n@sqr(n f x) = ~ n !f !x {\n 0: x\n 1+p:\n !&0{p0 p1}=(+ p 1)\n !&0{fA f0}=f\n !&0{f1 f2}=fA\n @sqr((/ p0 2) λk(f0 (f1 k)) @rep((% p1 2) f2 x))\n}\n\n// Bits (Scott)\n@o(x) = λo λi λe (o x)\n@i(x) = λo λi λe (i x)\n@e = λo λi λe e\n\n// Creates an all-zero Bits\n@zero(s) = ~s{\n 0: @e\n 1+p: @o(@zero(p))\n}\n\n// U32 -> Bits\n@bits(n) = ~ n {\n 0: @e\n 1+p: !&0{n0 n1}=(+ p 1) ~ (% n0 2) !n1 {\n 0: @o(@bits((/ n1 2)))\n 1: @i(@bits((/ n1 2)))\n 2+p: *\n }\n}\n\n// Bits -> U32\n@u32(xs) = (xs\n λp0 (+ (* 2 @u32(p0)) 0)\n λp1 (+ (* 2 @u32(p1)) 1)\n 0)\n\n// Bits increment\n@inc(x) = λo λi λe (x i λop(o @inc(op)) e)\n\n// Addition with carry\n@add = λa (a\n λap λb (b λbp λap @o((@add ap bp)) λbp λap @i( (@add ap bp)) @e ap)\n λap λb (b λbp λap @i((@add ap bp)) λbp λap @o(@inc((@add ap bp))) @e ap)\n λb b)\n\n// Multiplication by squared addition\n@mul(a b) = @u32(@sqr(a (@add @bits(b)) @zero(64)))\n\n@main = @mul(23232 32323)\n\n//WORK: 233357193 interactions\n//TIME: 3.202 seconds\n//SIZE: 1402714952 nodes\n//PERF: 72.890 MIPS\n" }, { "path": "examples/fuse_rot.hvm", "content": "// Relevant discussion:\n// https://discord.com/channels/912426566838013994/915345481675186197/1312147864373301329\n\ndata List { #Nil #Cons{head tail} }\n\n// Repeated Application\n@rep(n f x) = ~ n !f !x {\n 0: x\n 1+p: !&0{f0 f1}=f (f0 @rep(p f1 x))\n}\n\n// Squared Application\n@sqr(n f x) = ~ n !f !x {\n 0: x\n 1+p:!&0{p0 p1}=(+ p 1)\n !&0{fA f0}=f\n !&0{f1 f2}=fA\n @sqr((/ p0 2) λk(f0 (f1 k)) @rep((% p1 2) f2 x))\n}\n\n@O(a b) = λo λi (o a b)\n@I(a b) = λo λi (i a b)\n@L(x) = x\n\n@view(!&s) = ~s {\n 0: λx x\n 1+&p: λx (x\n λa λb [0 (@view(p) a) (@view(p) b)]\n λa λb [1 (@view(p) a) (@view(p) b)])\n}\n\n@read(!&s) = ~s {\n 0: λx 0\n 1+&p: λx (x\n λa λb (+ 0 (* (@read(p) a) 2))\n λa λb (+ 1 (* (@read(p) a) 2)))\n}\n\n@zero(s) = ~s {\n 0: 0\n 1+&p: @O(@zero(p) @zero(p))\n}\n\n@inc(s) = ~s {\n 0: λx x\n 1+&p: λx λo λi (x\n λa λb (i b (@inc(p) a))\n λa λb (o b (@inc(p) a)))\n}\n\n@dec(s) = ~s {\n 0: λx x\n 1+&p: λx λo λi (x\n λa λb (i (@dec(p) b) a)\n λa λb (o (@dec(p) b) a))\n}\n\n@neg(!&s) = ~s {\n 0: λx x\n 1+&p: λx λo λi (x\n λa λb (o (@neg(p) a) (@neg(p) b))\n λa λb (i (@neg(p) b) (@neg(p) a)))\n}\n\n// What this does?\n@foo(!&s) = ~s {\n 0: λx λy x\n 1+&p: λx (x\n λxa λxb !&1{xa0 xa1}=xa !&1{xb0 xb1}=xb λy λo λi (y\n λya λyb (o (@foo(p) xa0 ya) (@foo(p) xb0 yb))\n λya λyb (i (@foo(p) xb1 yb) (@foo(p) xa1 ya)))\n λxa λxb !&1{xa0 xa1}=xa !&1{xb0 xb1}=xb λy λo λi (y\n λya λyb (i (@foo(p) xb0 yb) (@foo(p) xa0 ya))\n λya λyb (o (@foo(p) xa1 ya) (@foo(p) xb1 yb))))\n}\n\n// Removing the recursive calls to @dec/@inc makes this\n// fuse; but since we can't, it doesn't, making it slow\n@add(!&s) = ~s {\n 0: λx λy y\n 1+&p: λx (x\n λxa λxb !&1{xa0 xa1}=xa !&1{xb0 xb1}=xb λy λo λi (y\n λya λyb (o (@add(p) xa0 ya) (@add(p) xb0 yb))\n λya λyb (i (@add(p) xb1 ya) (@add(p) xa1 yb)))\n λxa λxb !&1{xa0 xa1}=xa !&1{xb0 xb1}=xb λy λo λi (y\n λya λyb (i (@add(p) xa0 yb) (@add(p) xb0 ya))\n λya λyb (o (@dec(p) (@add(p) xb1 yb)) (@inc(p) (@add(p) xa1 ya)))))\n}\n\n@S = 32\n@K(n) = @rep(n @inc(@S) @zero(@S))\n@KA = @K(17)\n@KB = @K(0)\n\n// meh\n@main = (@read(@S) @sqr(54321 (@add(@S) @KA) @KB))\n" }, { "path": "examples/main.hvm", "content": "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 bod}\n #Lam{bod}\n #App{fun arg}\n #U32\n #Num{val}\n}\n\n@main = ~ (#Pol{123}) {\n #Var{idx}: *\n #Pol{bod}: 123\n #All{inp bod}: *\n #Lam{bod}: *\n #App{fun arg}: *\n #U32: *\n #Num{val}: *\n}\n\n////@main = ~ (#A) {\n ////#A: 1\n ////#B: 2\n////}\n\n////@main = ~ 3 {\n ////0: 10\n ////1: 20\n ////p: p\n////}\n\n//@main = \n //~ [1 2] {\n //#Cons{a b}: a\n //#Nil: 0\n //}\n\n//!@foo(k a) =\n //! &0{x y} = a\n //! &1{_ _} = 1\n //! &2{_ _} = 2\n //(+ x y)\n//@main = @foo(1 &0{1 2})\n\n//data Foo {\n //#A{k}\n //#B{k}\n//}\n\n//@bar(x) = ~ x {\n //#A{k}: (+ 1 k)\n //#B{k}: (+ 2 k)\n//}\n\n//@main = @bar(*)\n\n//@foo(n) = ~n { 0: 0 p: (+ 1 @foo(p)) }\n\n////@main = @foo(&0{1000 1000})\n//@main = &0{@foo(1000) @foo(1000)}\n\n// ~ &0{#A{...} #B{...}} {\n// #A: ...\n// #B: ...\n// }\n\n//@foo(&0{1 2} x y)\n//-----------------\n//&0{x0 x1}=x\n//&0{y0 y1}=y\n//&0{@foo(1 x0 y0) @foo(2 x1 y1)}\n\n//(&L{x y} arg)\n//-------------\n//&0{arg0 arg1}=arg\n//&{(x arg0) (y arg1)}\n\n//data Foo { #A{a b} #B{a b} #C{a b} #D{a b} }\n\n//@main = ~ 7 {\n //0: 3\n //p: p\n//}\n\n//@main = ~ #A{1 2} {\n //#A{a b}: [\"A\" a b]\n //#B{a b}: [\"B\" a b]\n //#C{a b}: [\"C\" a b]\n//}\n\n//@main = λx ~ #D{1 2} {\n //#A{a b}: [\"A\" a b]\n //#C{a b}: [\"C\" a b]\n //term: term\n//}\n\n//@main = ~ #A{1 2} {\n //#A{a b}: [\"A\" a b]\n //x: 123\n//}\n\n//data List { #Nil #Cons{head tail} }\n\n//@Foo = #Cons{1 @Foo}\n//@main = 50\n\n//@main = λx\n //!! @LOG(&{1 (+ x 1)})\n //123\n\n//@main = λt(t &0{&0{1 2} &0{3 4}} &0{&0{1 2} &0{3 4}})\n\n//λa ((a 1) 1)\n//λa ((a 2) 2)\n//λa ((a 3) 3)\n//λa ((a 4) 4)\n\n//@foo(&a x) = ~ x {\n //0: &a\n //p: &a\n//}\n\n//@main = @foo(7 1)\n\n//@main = λa\n //@DUP((+ 5 7) a λx λy [x y])\n //@DUP(11 @SUP(10 50 60) λa λb [a b])\n\n//data Tree { #Leaf #Node{lft rgt} }\n\n//@all(s) = ~s {\n //0: #Leaf\n //p: &0{ #Leaf #Node{@all(p) @all(p)} }\n//}\n\n//@main = @all(4)\n\n//data Tree { #Leaf #Node{lft rgt} }\n\n//@all(s l) = ~s {\n //0:\n //#Leaf\n //p:\n //!&0{p p0}=p\n //!&0{p p1}=p\n //!&0{l l0}=l\n //!&0{l l1}=l\n //!&0{l l2}=l\n //! lL = (+ (* l1 2) 0)\n //! lR = (+ (* l2 2) 1)\n //@SUP(l0 #Leaf #Node{ @all(p0 lL) @all(p1 lR) })\n//}\n\n//@main = @all(4 1)\n\n//@dyn(n lab) = ~n {\n //0: 0\n //p: !&0{l0 l1}=lab @SUP(l0 0 @dyn(p (+ l1 1)))\n//}\n\n//@main = @dyn(8 0)\n\n//// Simple Function, `A -> B`\n//@Fun(A B) = %f λx {(f {x::A}) :: B}\n\n//// Dependent Function, `∀(x: A) -> (B x)`\n//@All(A B) = %f λx !&0{x0 x1}=x {(f {x0::A}) :: (B x)}\n\n//// main\n//// : ∀A (A -> A) -> (A -> A)\n//// = λf λx (f x)\n//@main = λA\n //! &0{A A0} = A\n //! &0{A A1} = A\n //! &0{A A2} = A\n //! &0{A A3} = A\n //! typ = @Fun(@Fun(A0 A1) @Fun(A2 A3))\n //! val = λf λx (f x)\n //{ val :: typ }\n\n//@main = λA λB\n //! &0{A A0} = A\n //! &0{A A1} = A\n //! &0{A A2} = A\n //! &0{A A3} = A\n //{ λf λx !&0{f0 f1}=f (f0 (f1 x))\n //:: @Fun(@Fun(A0 A1) @Fun(A2 A3)) }\n\n//@main = λA λB {λx x :: @Fun(A B)}\n\n//@main = λA λB\n //!&0{A0 A1}=A\n //{λa λb (a b) :: %f λa λb {(f {a::A0} {b::B})::A1}}\n\n//@count(n k) = ~n !k {\n //0: k\n //p: @count(p (+ k 2))\n//}\n\n//@main = @count(2_000_000_000 0)\n\n//data L { #N #C{h t} }\n\n//@foo = λx λa λb λc ~x !a !b !c {\n //#N: λt(t a b c)\n //#C{H T}: λt(t a b c H T)\n//}\n\n//@bar = λx ~x {\n //0: 10\n //1+p: p\n//}\n\n////@main = (+ (+ 2 3) 4)\n////@main = (@bar 10)\n////@main = (@foo #C{1 #C{2 #C{3 #N}}} 10 20 30)\n////@main = λx ~x { #N: 0 #C{h t}: λK(K h t) }\n\n////@main = λt(t (+ 1 (+ 2 (+ 3 4))) (+ 1 (+ 2 (+ 3 4))))\n//@main = (+ 1 2)\n\n//@true = λt λf t\n//@false = λt λf f\n//@not = λb ((b @false) @true)\n//@dups = ! &1{ x y } = &0{ #12{} #24{} } &0{ y x }\n//@main = (+ 10 ~7{ 0 1 2 λx x })\n//@main = (* 100 123)\n//@main = λt(t #5{(λx x 7)} λk k)\n//@main = (λa λb(λt λf t &0{a b} &0{b a}) 1 2)\n//@succ = λn λs λz (s n)\n//@zero = λs λz z\n//@mul2 = λn (n λp(@succ (@succ (@mul2 p))) @zero)\n//@main = (@mul2 (@succ (@succ (@succ @zero))))\n//@foo(x y) = #0{y x}\n//@main = @foo(@foo(5 8) @foo(1 2))\n\n//data List { #Nil #Cons{head tail} }\n\n//@sum(xs r) = ~xs{\n //#Nil: r\n //#Cons: λhead λtail @sum(tail (+ head r))\n//}\n\n//@range(n xs) = ~n{\n //0: xs\n //p: !&0{p0 p1}=p @range(p0 #Cons{p1 xs})\n//}\n\n//@main =\n //!list = #Cons{0 #Cons{1 #Cons{&0{10 20} #Cons{3 #Cons{4 #Cons{5 #Cons{6 #Cons{7 #Cons{8 #Cons{9 #Nil}}}}}}}}}}\n //@sum(list 0)\n\n//@main = !&0{a b}=(+ 1 2) λt(t a b)\n" }, { "path": "src/HVM/API.hs", "content": "module HVM.API where\n\nimport Control.DeepSeq (deepseq)\nimport Control.Monad (when, forM_)\nimport Data.Word (Word64)\nimport Data.List (isPrefixOf)\nimport Foreign.LibFFI\nimport GHC.Clock\nimport HVM.Adjust\nimport HVM.Collapse\nimport HVM.Compile\nimport HVM.Extract\nimport HVM.Foreign\nimport HVM.Inject\nimport HVM.Parse\nimport HVM.Reduce\nimport HVM.Type\nimport System.Exit (exitWith, ExitCode(ExitFailure))\nimport System.IO (readFile')\nimport System.IO.Error (tryIOError)\nimport System.Posix.DynamicLinker\nimport System.Process (callCommand)\nimport Text.Printf\n\nimport qualified Data.Map.Strict as MS\n\ndata RunMode\n = Normalize\n | Collapse (Maybe Int)\n deriving Eq\n\ndata RunStats = RunStats {\n rsItrs :: Word64,\n rsTime :: Double,\n rsSize :: Word64,\n rsPerf :: Double\n}\n\n-- Main external API for running HVM\nrunHVM :: FilePath -> Core -> RunMode -> IO ([Core], RunStats)\nrunHVM filePath root mode = do\n code <- readFile' filePath\n book <- doParseBook filePath code\n hvmInit\n initBook filePath book True\n (vals, stats) <- runBook book root mode True False\n hvmFree\n return (vals, stats)\n\n-- Initializes the runtime with the definitions from a book\ninitBook :: FilePath -> Book -> Bool -> IO ()\ninitBook filePath book compiled = do\n forM_ (MS.toList (cidToAri book)) $ \\(cid, ari) -> hvmSetCari cid (fromIntegral ari)\n forM_ (MS.toList (cidToLen book)) $ \\(cid, len) -> hvmSetClen cid (fromIntegral len)\n forM_ (MS.toList (cidToADT book)) $ \\(cid, adt) -> hvmSetCadt cid (fromIntegral adt)\n forM_ (MS.toList (fidToFun book)) $ \\(fid, ((_, args), _)) -> hvmSetFari fid (fromIntegral $ length args)\n when compiled $ do\n oPath <- compileBookToBin filePath book\n dylib <- dlopen oPath [RTLD_NOW]\n forM_ (MS.keys (fidToFun book)) $ \\fid -> do\n funPtr <- dlsym dylib (mget (fidToNam book) fid ++ \"_f\")\n hvmDefine fid funPtr\n hvmGotState <- hvmGetState\n hvmSetState <- dlsym dylib \"hvm_set_state\"\n callFFI hvmSetState retVoid [argPtr hvmGotState]\n\nrunBook :: Book -> Core -> RunMode -> Bool -> Bool -> IO ([Core], RunStats)\nrunBook book root mode compiled debug =\n withRunStats $ do\n injectRoot book root\n rxAt <- if compiled\n then return (reduceCAt debug)\n else return (reduceAt debug)\n vals <- case mode of\n Collapse limit -> do\n core <- doCollapseFlatAt rxAt book 0\n let vals = maybe id Prelude.take limit core\n vals `deepseq` return vals\n Normalize -> do\n core <- doExtractCoreAt rxAt book 0\n let vals = [core]\n vals `deepseq` return vals\n return vals\n\ncompileBookToBin :: FilePath -> Book -> IO FilePath\ncompileBookToBin filePath book = do\n -- Use the embedded runtime sources so compiled mode doesn't depend on CWD\n let mainC = compileBook book runtime_c\n callCommand \"mkdir -p .build\"\n let fName = last $ words $ map (\\c -> if c == '/' then ' ' else c) filePath\n let cPath = \".build/\" ++ fName ++ \".c\"\n let oPath = \".build/\" ++ fName ++ \".so\"\n oldCFile <- tryIOError (readFile' cPath)\n when (oldCFile /= Right mainC) $ do\n writeFile cPath mainC\n callCommand $ \"gcc -O2 -fPIC -flto -shared \" ++ cPath ++ \" -o \" ++ oPath\n return oPath\n\ninjectRoot :: Book -> Core -> IO ()\ninjectRoot book root = do\n let (book', root') = adjust \"\" book root []\n doInjectCoreAt book' root' 0 []\n return ()\n\nwithRunStats :: IO a -> IO (a, RunStats)\nwithRunStats action = do\n init <- getMonotonicTimeNSec\n res <- action\n end <- getMonotonicTimeNSec\n itrs <- getItr\n size <- getLen\n let time = fromIntegral (end - init) / (10^9) :: Double\n let mips = (fromIntegral itrs / 1000000.0) / time\n let stats = RunStats { rsItrs = itrs, rsSize = size , rsTime = time, rsPerf = mips }\n return (res, stats)\n\ninstance Show RunStats where\n show stats = printf \"WORK: %llu interactions\\n\" (rsItrs stats) ++\n printf \"TIME: %.7f seconds\\n\" (rsTime stats) ++\n printf \"SIZE: %llu nodes\\n\" (rsSize stats) ++\n printf \"PERF: %.3f MIPS\\n\" (rsPerf stats)\n" }, { "path": "src/HVM/Adjust.hs", "content": "module HVM.Adjust where\n\nimport Control.Monad\nimport Control.Monad.State\nimport Data.List (sortOn)\nimport Data.Word\nimport HVM.Type\nimport qualified Data.Map as MS\nimport Debug.Trace (trace)\n\n-- External API\n----------------\n\nadjustBook :: Book -> Book\nadjustBook book = foldr adjustFunc book (MS.toList (fidToFun book))\n\nadjustFunc :: (Word16, Func) -> Book -> Book\nadjustFunc (fid, ((cp, ars), cr)) book =\n let nam = mget (fidToNam book) fid in\n let (b', cr') = adjust nam book cr (map snd ars) in\n let ars' = map (\\(s, n) -> (s, stripName n)) ars in\n b' { fidToFun = MS.insert fid ((cp, ars'), cr') (fidToFun b') }\n\nadjust :: Name -> Book -> Core -> [String] -> (Book, Core)\nadjust orig book term binds =\n let termA = setRefIds (namToFid book) term\n termB = setCtrIds (ctrToCid book) (cidToADT book) termA\n termC = sortCases (ctrToCid book) termB\n (fr, termD) = insertDups (freshLab book) binds termC\n termE = lexify termD\n termF = validate orig book termE\n in (book { freshLab = fr }, termF)\n\n\n-- Adjusters\n-------------\n\n-- Adds the function id to Ref constructors\nsetRefIds :: MS.Map String Word16 -> Core -> Core\nsetRefIds fids term = go term\n where\n go :: Core -> Core\n go (Var nam) = Var nam\n go (Let m x v b) = Let m x (go v) (go b)\n go (Lam x bod) = Lam x (go bod)\n go (App f x) = App (go f) (go x)\n go (Sup l x y) = Sup l (go x) (go y)\n go (Dup l x y v b) = Dup l x y (go v) (go b)\n go (Ctr nam fds) = Ctr nam (map go fds)\n 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)\n go (Op2 op x y) = Op2 op (go x) (go y)\n go (U32 n) = U32 n\n go (Chr c) = Chr c\n go Era = Era\n go (Inc x) = Inc (go x)\n go (Dec x) = Dec (go x)\n go (Ref nam fid arg) =\n case MS.lookup nam fids of\n Just fid -> Ref nam fid (map go arg)\n Nothing -> error $ \"Unknown function: \" ++ show nam\n\n\n-- Adds the constructor id to Mat and IFL terms\nsetCtrIds :: MS.Map String Word16 -> MS.Map Word16 Word16 -> Core -> Core\nsetCtrIds cids adts term = go term\n where\n go :: Core -> Core\n go (Var nam) = Var nam\n go (Let m x v b) = Let m x (go v) (go b)\n go (Lam x bod) = Lam x (go bod)\n go (App f x) = App (go f) (go x)\n go (Sup l x y) = Sup l (go x) (go y)\n go (Dup l x y v b) = Dup l x y (go v) (go b)\n go (Ctr nam fds) = Ctr nam (map go fds)\n go (Mat k x mov css) = Mat k' (go x) mov' css' where\n getCtr (ctr, _, _) = ctr\n mov' = map (\\(k,v) -> (k, go v)) mov\n css' = map (\\(ctr,fds,cs) -> (ctr, fds, go cs)) css\n k' = case k of\n SWI -> SWI\n MAT _ -> MAT (mget adts (mget cids (getCtr (head css))))\n IFL _ -> IFL (mget cids (getCtr (head css)))\n _ -> k\n go (Op2 op x y) = Op2 op (go x) (go y)\n go (U32 n) = U32 n\n go (Chr c) = Chr c\n go Era = Era\n go (Inc x) = Inc (go x)\n go (Dec x) = Dec (go x)\n go (Ref nam fid arg) = Ref nam fid (map go arg)\n\n\n-- Sorts match cases by constructor ID or numeric value\nsortCases :: MS.Map String Word16 -> Core -> Core\nsortCases cids term = go term\n where\n go :: Core -> Core\n go (Var nam) = Var nam\n go (Let m x v b) = Let m x (go v) (go b)\n go (Lam x bod) = Lam x (go bod)\n go (App f x) = App (go f) (go x)\n go (Sup l x y) = Sup l (go x) (go y)\n go (Dup l x y v b) = Dup l x y (go v) (go b)\n go (Ctr nam fds) = Ctr nam (map go fds)\n go (Mat k x mov css) = Mat k (go x) mov' css' where\n mov' = map (\\(k,v) -> (k, go v)) mov\n css' = map (\\(ctr,fds,bod) -> (ctr, fds, go bod)) sort\n sort = sortOn sortKey css\n sortKey (name, _, _) =\n case name of\n ('#':_) -> case MS.lookup name cids of\n Nothing -> maxBound\n Just id -> id\n _ -> case reads name of\n [(num :: Word16, \"\")] -> num\n _ -> maxBound\n go (Op2 op x y) = Op2 op (go x) (go y)\n go (U32 n) = U32 n\n go (Chr c) = Chr c\n go Era = Era\n go (Inc x) = Inc (go x)\n go (Dec x) = Dec (go x)\n go (Ref nam fid arg) = Ref nam fid (map go arg)\n\n\n-- Inserts Dup nodes for vars that have been used more than once.\n-- Renames vars according to the new Dup bindings.\n-- Gives fresh labels to the new Dup nodes.\ninsertDups :: Lab -> [String] -> Core -> (Lab, Core)\ninsertDups fresh binds term =\n let (term', (fresh', _)) = runState (withBinds binds term) (fresh, MS.empty)\n in (fresh', term')\n where\n go :: Core -> State (Lab, MS.Map String [String]) Core\n go (Var nam) = do\n nam <- useVar nam\n return $ (Var nam)\n go (Let m x v b) = do\n v <- go v\n b <- withBinds [x] b\n return $ Let m (stripName x) v b\n go (Lam x bod) = do\n bod <- withBinds [x] bod\n return $ Lam (stripName x) bod\n go (App fun arg) = do\n fun <- go fun\n arg <- go arg\n return $ App fun arg\n go (Sup lab tm0 tm1) = do\n tm0 <- go tm0\n tm1 <- go tm1\n return $ Sup lab tm0 tm1\n go (Dup lab x y v b) = do\n v <- go v\n b <- withBinds [x, y] b\n return $ Dup lab (stripName x) (stripName y) v b\n go (Ctr nam fds) = do\n fds <- mapM go fds\n return $ Ctr nam fds\n go (Mat k x mov css) = do\n x <- go x\n mov <- forM mov (\\(k,v) -> do\n v <- go v\n return (k, v))\n css <- forM css (\\(ctr,fds,bod) -> do\n bod <- withBinds ((map fst mov) ++ fds) bod\n return (ctr, map stripName fds, bod))\n let mov' = map (\\(k,v) -> (stripName k, v)) mov\n return $ Mat k x mov' css\n go (Op2 op x y) = do\n x <- go x\n y <- go y\n return $ Op2 op x y\n go (U32 n) = do\n return $ U32 n\n go (Chr c) = do\n return $ Chr c\n go Era = do\n return Era\n go (Inc x) = do\n x <- go x\n return $ Inc x\n go (Dec x) = do\n x <- go x\n return $ Dec x\n go (Ref nam fid arg) = do\n arg <- mapM go arg\n return $ Ref nam fid arg\n\n -- Recurses on the body of a term that binds variables.\n -- Adds Dups if the new vars are used more than once.\n withBinds :: [String] -> Core -> State (Lab, MS.Map String [String]) Core\n withBinds vars term = do\n (lab, prev) <- get\n -- Add the new binds\n let bfor = foldr addVar prev vars\n put (lab, bfor)\n term <- go term\n term <- foldM applyDups term vars\n -- Remove the new binds\n (lab, aftr) <- get\n let next = foldr (restoreVar prev) (foldr remVar aftr vars) vars\n put (lab, next)\n return term\n where\n addVar var uses = MS.insert (stripName var) [] uses\n remVar var uses = MS.delete (stripName var) uses\n restoreVar old var new = \n case MS.lookup (stripName var) old of\n Just val -> MS.insert (stripName var) val new\n Nothing -> new\n\n applyDups :: Core -> String -> State (Lab, MS.Map String [String]) Core\n applyDups body var = do\n (_, uses) <- get\n let vUse = mget uses (stripName var)\n when ((head var /= '&') && (length vUse > 1)) $\n error $ \"Linear variable \" ++ show var ++ \" used \" ++ show (length vUse) ++ \" times\"\n case (reverse vUse) of\n [] -> do\n return body\n [_] -> do\n return body\n (name:dups) -> do\n foldM (\\acc currName -> do\n label <- genFresh\n return $ Dup label name currName (Var name) acc) body dups\n\n genFresh :: State (Lab, MS.Map String [String]) Lab\n genFresh = do\n (lab, _) <- get\n when (lab > 0x7FFF) $ do\n error \"Label overflow: generated label would be too large\"\n modify (\\(lab, uses) -> (lab + 1, uses))\n return $ 0x8000 + lab\n\n useVar :: String -> State (Lab, MS.Map String [String]) String\n useVar nam@('$':_) = do\n return nam\n useVar nam = do\n (_, uses) <- get\n case mget uses nam of\n [] -> do\n modify (\\(lab, uses) -> (lab, MS.insert nam [nam] uses))\n return nam\n vUse -> do\n let dupNam = nam ++ \"$dup\" ++ show (length vUse)\n modify (\\(lab, uses) -> (lab, MS.insert nam (dupNam : vUse) uses))\n return dupNam\n\n-- Strip the & prefix from a non-linear variable name\n-- e.g., \"&x\" -> \"x\", \"x\" -> \"x\"\nstripName :: String -> String\nstripName ('&':nam) = nam\nstripName nam = nam\n\n\n-- Gives unique names to lexically scoped vars, unless they start with '$'.\n-- Example: `λx λt (t λx(x) x)` will read as `λx0 λt1 (t1 λx2(x2) x0)`.\nlexify :: Core -> Core\nlexify term = evalState (go term MS.empty) 0 where\n fresh :: String -> State Int String\n fresh nam@('$':_) = return $ nam\n fresh nam = do i <- get; put (i+1); return $ nam++\"$\"++show i\n\n extend :: String -> String -> MS.Map String String -> State Int (MS.Map String String)\n extend old@('$':_) new ctx = return $ ctx\n extend old new ctx = return $ MS.insert old new ctx\n\n go :: Core -> MS.Map String String -> State Int Core\n go term ctx = case term of\n Var nam -> \n return $ Var (MS.findWithDefault nam nam ctx)\n Ref nam fid arg -> do\n arg <- mapM (\\x -> go x ctx) arg\n return $ Ref nam fid arg\n Let mod nam val bod -> do\n val <- go val ctx\n nam' <- fresh nam\n ctx <- extend nam nam' ctx\n bod <- go bod ctx\n return $ Let mod nam' val bod\n Lam nam bod -> do\n nam' <- fresh nam\n ctx <- extend nam nam' ctx\n bod <- go bod ctx\n return $ Lam nam' bod\n App fun arg -> do\n fun <- go fun ctx\n arg <- go arg ctx\n return $ App fun arg\n Sup lab tm0 tm1 -> do\n tm0 <- go tm0 ctx\n tm1 <- go tm1 ctx\n return $ Sup lab tm0 tm1\n Dup lab dp0 dp1 val bod -> do\n val <- go val ctx\n dp0' <- fresh dp0\n dp1' <- fresh dp1\n ctx <- extend dp0 dp0' ctx\n ctx <- extend dp1 dp1' ctx\n bod <- go bod ctx\n return $ Dup lab dp0' dp1' val bod\n Ctr nam fds -> do\n fds <- mapM (\\x -> go x ctx) fds\n return $ Ctr nam fds\n Mat kin val mov css -> do\n val' <- go val ctx\n mov' <- forM mov $ \\ (k,v) -> do\n k' <- fresh k\n v <- go v ctx\n return $ (k', v)\n css' <- forM css $ \\ (ctr,fds,bod) -> do\n fds' <- mapM fresh fds\n ctx <- foldM (\\ ctx (fd,fd') -> extend fd fd' ctx) ctx (zip fds fds')\n ctx <- foldM (\\ ctx ((k,_),(k',_)) -> extend k k' ctx) ctx (zip mov mov')\n bod <- go bod ctx\n return (ctr, fds', bod)\n return $ Mat kin val' mov' css'\n Op2 op nm0 nm1 -> do\n nm0 <- go nm0 ctx\n nm1 <- go nm1 ctx\n return $ Op2 op nm0 nm1\n U32 n -> \n return $ U32 n\n Chr c ->\n return $ Chr c\n Era -> \n return Era\n Inc x -> do\n x <- go x ctx\n return $ Inc x\n Dec x -> do\n x <- go x ctx\n return $ Dec x\n\nvalidate :: Name -> Book -> Core -> Core\nvalidate orig book term = go term where\n go :: Core -> Core\n go (Var nam) = Var nam\n go (Let m x v b) = Let m x (go v) (go b)\n go (Lam x bod) = Lam x (go bod)\n go (App f x) = App (go f) (go x)\n go (Sup l x y) = Sup l (go x) (go y)\n go (Dup l x y v b) = Dup l x y (go v) (go b)\n go (Ctr nam fds) =\n case MS.lookup nam (ctrToCid book) of\n Nothing ->\n error $ header ++ \"Unknown constructor: \" ++ show nam\n Just cid ->\n if length fds /= fromIntegral (mget (cidToAri book) cid) then\n error $ header ++ \"Arity mismatch on Ctr: \" ++ show (Ctr nam fds) ++ \". \" ++ \"Expected \" ++ show (mget (cidToAri book) cid) ++ \" arguments, got \" ++ show (length fds)\n else\n Ctr nam (map go fds)\n go (Mat k x mov css) =\n if not uniqueCss then error $ header ++ \"Duplicate match case: \" ++ show (Mat k x mov css) ++ \".\"\n else Mat k (go x) mov' css'\n where\n mov' = map (\\(k,v) -> (k, go v)) mov\n css' = map (\\(ctr,fds,bod) -> (ctr, fds, go bod)) css\n ctrs = map (\\(ctr, _, _) -> ctr) css\n uniqueCss = null (filter (\\ctr -> length (filter (== ctr) ctrs) > 1) ctrs)\n go (Op2 op x y) = Op2 op (go x) (go y)\n go (U32 n) = U32 n\n go (Chr c) = Chr c\n go Era = Era\n go (Inc x) = Inc (go x)\n go (Dec x) = Dec (go x)\n go (Ref nam fid arg) =\n if not ariOk then\n error $ header ++ \"Arity mismatch on Ref: \" ++ show (Ref nam fid arg) ++ \". \" ++ \"Expected \" ++ show (funArity book fid) ++ \" arguments, got \" ++ show (length arg)\n else\n Ref nam fid (map go arg)\n where\n ariOk = length arg == fromIntegral (funArity book fid)\n\n header = if null orig then \"\" else \"In function @\" ++ orig ++ \": \"\n" }, { "path": "src/HVM/Collapse.hs", "content": "{-./Type.hs-}\n{-# LANGUAGE BangPatterns #-}\n\nmodule HVM.Collapse where\n\nimport Control.Monad (ap, forM, forM_)\nimport Control.Monad.IO.Class\nimport Data.Char (chr, ord)\nimport Data.IORef\nimport Data.Bits ((.&.), xor, (.|.), complement, shiftR)\nimport Data.Word\nimport Debug.Trace\nimport GHC.Conc\nimport HVM.Foreign\nimport HVM.Type\nimport System.Exit (exitFailure)\nimport System.IO.Unsafe (unsafeInterleaveIO)\nimport qualified Data.IntMap.Strict as IM\nimport qualified Data.Map.Strict as MS\n\n-- The Collapse Monad \n-- ------------------\n-- See: https://gist.github.com/VictorTaelin/60d3bc72fb4edefecd42095e44138b41\n\n-- A bit-string\ndata Bin\n = O Bin\n | I Bin\n | E\n deriving Show\n\n-- A Collapse is a tree of superposed values\ndata Collapse a\n = CSup !Lab (Collapse a) (Collapse a)\n | CInc (Collapse a)\n | CDec (Collapse a)\n | CVal !a\n | CEra\n deriving Show\n\nbind :: Collapse a -> (a -> Collapse b) -> Collapse b\nbind k f = fork k IM.empty where\n -- fork :: Collapse a -> IntMap (Bin -> Bin) -> Collapse b\n fork CEra paths = CEra\n fork (CVal v) paths = pass (f v) (IM.map (\\x -> x E) paths)\n fork (CInc x) paths = CInc (fork x paths)\n fork (CDec x) paths = CDec (fork x paths)\n fork (CSup k x y) paths =\n let lft = fork x $ IM.alter (\\x -> Just (maybe (putO id) putO x)) (fromIntegral k) paths in\n let rgt = fork y $ IM.alter (\\x -> Just (maybe (putI id) putI x)) (fromIntegral k) paths in\n CSup k lft rgt \n -- pass :: Collapse b -> IntMap Bin -> Collapse b\n pass CEra paths = CEra\n pass (CVal v) paths = CVal v\n pass (CInc x) paths = CInc (pass x paths)\n pass (CDec x) paths = CDec (pass x paths)\n pass (CSup k x y) paths = case IM.lookup (fromIntegral k) paths of\n Just (O p) -> pass x (IM.insert (fromIntegral k) p paths)\n Just (I p) -> pass y (IM.insert (fromIntegral k) p paths)\n Just E -> CSup k (pass x paths) (pass y paths)\n Nothing -> CSup k (pass x paths) (pass y paths)\n -- putO :: (Bin -> Bin) -> (Bin -> Bin)\n putO bs = \\x -> bs (O x)\n -- putI :: (Bin -> Bin) -> (Bin -> Bin) \n putI bs = \\x -> bs (I x)\n\ninstance Functor Collapse where\n fmap f (CVal v) = CVal (f v)\n fmap f (CSup k x y) = CSup k (fmap f x) (fmap f y)\n fmap f (CInc x) = CInc (fmap f x)\n fmap f (CDec x) = CDec (fmap f x)\n fmap _ CEra = CEra\n\ninstance Applicative Collapse where\n pure = CVal\n (<*>) = ap\n\ninstance Monad Collapse where\n return = pure\n (>>=) = bind\n\n-- Dup Collapser\n-- -------------\n\ncollapseDupsAt :: IM.IntMap [Int] -> ReduceAt -> Book -> Loc -> HVM Core\n\ncollapseDupsAt state@(paths) reduceAt book host = unsafeInterleaveIO $ do\n term <- reduceAt book host\n case termTag term of\n t | t == _ERA_ -> do\n return Era\n\n t | t == _LET_ -> do\n let loc = termLoc term\n let mode = modeT (termLab term)\n name <- return $ \"$\" ++ show (loc + 0)\n val0 <- collapseDupsAt state reduceAt book (loc + 1)\n bod0 <- collapseDupsAt state reduceAt book (loc + 2)\n return $ Let mode name val0 bod0\n\n t | t == _LAM_ -> do\n let loc = termLoc term\n name <- return $ \"$\" ++ show (loc + 0)\n bod0 <- collapseDupsAt state reduceAt book (loc + 0)\n return $ Lam name bod0\n\n t | t == _APP_ -> do\n let loc = termLoc term\n fun0 <- collapseDupsAt state reduceAt book (loc + 0)\n arg0 <- collapseDupsAt state reduceAt book (loc + 1)\n return $ App fun0 arg0\n\n t | t == _SUP_ -> do\n let loc = termLoc term\n let lab = termLab term\n case IM.lookup (fromIntegral lab) paths of\n Just (p:ps) -> do\n let newPaths = IM.insert (fromIntegral lab) ps paths\n collapseDupsAt (newPaths) reduceAt book (loc + fromIntegral p)\n _ -> do\n tm00 <- collapseDupsAt state reduceAt book (loc + 0)\n tm11 <- collapseDupsAt state reduceAt book (loc + 1)\n return $ Sup lab tm00 tm11\n\n t | t == _VAR_ -> do\n let loc = termLoc term\n sub <- got loc\n if termGetBit sub /= 0\n then do\n set (loc + 0) (termRemBit sub)\n collapseDupsAt state reduceAt book (loc + 0)\n else do\n name <- return $ \"$\" ++ show loc\n return $ Var name\n\n t | t == _DP0_ -> do\n let loc = termLoc term\n let lab = termLab term\n sb0 <- got (loc+0)\n if termGetBit sb0 /= 0\n then do\n set (loc + 0) (termRemBit sb0)\n collapseDupsAt state reduceAt book (loc + 0)\n else do\n let newPaths = IM.alter (Just . maybe [0] (0:)) (fromIntegral lab) paths\n collapseDupsAt (newPaths) reduceAt book (loc + 0)\n\n t | t == _DP1_ -> do\n let loc = termLoc term\n let lab = termLab term\n sb1 <- got (loc+0)\n if termGetBit sb1 /= 0\n then do\n set (loc + 0) (termRemBit sb1)\n collapseDupsAt state reduceAt book (loc + 0)\n else do\n let newPaths = IM.alter (Just . maybe [1] (1:)) (fromIntegral lab) paths\n collapseDupsAt (newPaths) reduceAt book (loc + 0)\n\n t | t == _CTR_ -> do\n let loc = termLoc term\n let lab = termLab term\n let cid = fromIntegral lab\n let nam = MS.findWithDefault \"?\" cid (cidToCtr book)\n let ari = mget (cidToAri book) cid\n let aux = if ari == 0 then [] else [0 .. ari-1]\n fds0 <- forM aux (\\i -> collapseDupsAt state reduceAt book (loc + fromIntegral i))\n return $ Ctr nam fds0\n\n t | t == _MAT_ -> do\n let loc = termLoc term\n let lab = termLab term\n let cid = fromIntegral lab\n let len = fromIntegral $ mget (cidToLen book) cid\n val0 <- collapseDupsAt state reduceAt book (loc + 0)\n css0 <- forM [0..len-1] $ \\i -> do\n let ctr = mget (cidToCtr book) (cid + i)\n let ari = fromIntegral $ mget (cidToAri book) (cid + i)\n let fds = if ari == 0 then [] else [\"$\" ++ show (loc + 1 + j) | j <- [0..ari-1]]\n bod0 <- collapseDupsAt state reduceAt book (loc + 1 + fromIntegral i)\n return (ctr, fds, bod0)\n return $ Mat (MAT cid) val0 [] css0\n\n t | t == _IFL_ -> do\n let loc = termLoc term\n let lab = termLab term\n let cid = fromIntegral lab\n val0 <- collapseDupsAt state reduceAt book (loc + 0)\n cs00 <- collapseDupsAt state reduceAt book (loc + 1)\n cs10 <- collapseDupsAt state reduceAt book (loc + 2)\n return $ Mat (IFL cid) val0 [] [(mget (cidToCtr book) cid, [], cs00), (\"_\", [], cs10)]\n\n t | t == _SWI_ -> do\n let loc = termLoc term\n let lab = termLab term\n let len = fromIntegral lab\n val0 <- collapseDupsAt state reduceAt book (loc + 0)\n css0 <- forM [0..len-1] $ \\i -> do\n bod0 <- collapseDupsAt state reduceAt book (loc + 1 + i)\n return (show i, [], bod0)\n return $ Mat SWI val0 [] css0\n\n t | t == _W32_ -> do\n let val = termLoc term\n return $ U32 (fromIntegral val)\n\n t | t == _CHR_ -> do\n let val = termLoc term\n return $ Chr (chr (fromIntegral val))\n\n t | t == _OPX_ -> do\n let loc = termLoc term\n let opr = toEnum (fromIntegral (termLab term))\n nm00 <- collapseDupsAt state reduceAt book (loc + 0)\n nm10 <- collapseDupsAt state reduceAt book (loc + 1)\n return $ Op2 opr nm00 nm10\n\n t | t == _OPY_ -> do\n let loc = termLoc term\n let opr = toEnum (fromIntegral (termLab term))\n nm00 <- collapseDupsAt state reduceAt book (loc + 0)\n nm10 <- collapseDupsAt state reduceAt book (loc + 1)\n return $ Op2 opr nm00 nm10\n\n t | t == _REF_ -> do\n let loc = termLoc term\n let lab = termLab term\n let fid = fromIntegral lab\n let ari = fromIntegral (funArity book fid)\n arg0 <- forM [0..ari-1] (\\i -> collapseDupsAt state reduceAt book (loc + i))\n let name = MS.findWithDefault \"?\" fid (fidToNam book)\n return $ Ref name fid arg0\n\n t | t == _INC_ -> do\n let loc = termLoc term\n val0 <- collapseDupsAt state reduceAt book (loc + 0)\n return $ Inc val0\n\n t | t == _DEC_ -> do\n let loc = termLoc term\n val0 <- collapseDupsAt state reduceAt book (loc + 0)\n return $ Dec val0\n\n tag -> do\n return $ Var \"?\"\n -- exitFailure\n\n-- Sup Collapser\n-- -------------\n\ncollapseSups :: Book -> Core -> Collapse Core\n\ncollapseSups book core = case core of\n\n Var name -> do\n return $ Var name\n\n Ref name fid args -> do\n args <- mapM (collapseSups book) args\n return $ Ref name fid args\n\n Lam name body -> do\n body <- collapseSups book body\n return $ Lam name body\n\n App fun arg -> do\n fun <- collapseSups book fun\n arg <- collapseSups book arg\n return $ App fun arg\n\n Dup lab x y val body -> do\n val <- collapseSups book val\n body <- collapseSups book body\n return $ Dup lab x y val body\n\n Ctr nam fields -> do\n fields <- mapM (collapseSups book) fields\n return $ Ctr nam fields\n\n Mat kin val mov css -> do\n val <- collapseSups book val\n mov <- mapM (\\(key, expr) -> do\n expr <- collapseSups book expr\n return (key, expr)) mov\n css <- mapM (\\(ctr, fds, bod) -> do\n bod <- collapseSups book bod\n return (ctr, fds, bod)) css\n return $ Mat kin val mov css\n\n U32 val -> do\n return $ U32 val\n\n Chr val -> do\n return $ Chr val\n\n Op2 op x y -> do\n x <- collapseSups book x\n y <- collapseSups book y\n return $ Op2 op x y\n\n Let mode name val body -> do\n val <- collapseSups book val\n body <- collapseSups book body\n return $ Let mode name val body\n\n Era -> do\n CEra\n\n Sup lab tm0 tm1 -> do\n let tm0' = collapseSups book tm0\n let tm1' = collapseSups book tm1\n CSup lab tm0' tm1'\n\n Inc val -> do\n let val' = collapseSups book val\n CInc val'\n\n Dec val -> do\n let val' = collapseSups book val\n CDec val'\n\n-- Tree Collapser\n-- --------------\n\ndoCollapseAt :: ReduceAt -> Book -> Loc -> HVM (Collapse Core)\ndoCollapseAt reduceAt book host = do\n -- namesRef <- newIORef MS.empty\n let state = (IM.empty)\n core <- collapseDupsAt state reduceAt book host\n return $ collapseSups book core\n\n-- Simple Queue\n-- ------------\n-- Allows pushing to an end, and popping from another.\n-- Simple purely functional implementation.\n-- Includes sqPop and sqPut.\n\ndata SQ a = SQ [a] [a]\n\nsqNew :: SQ a\nsqNew = SQ [] []\n\nsqPop :: SQ a -> Maybe (a, SQ a)\nsqPop (SQ [] []) = Nothing\nsqPop (SQ [] ys) = sqPop (SQ (reverse ys) [])\nsqPop (SQ (x:xs) ys) = Just (x, SQ xs ys)\n\nsqPut :: a -> SQ a -> SQ a\nsqPut x (SQ xs ys) = SQ xs (x:ys)\n\n-- Priority Queue\n-- --------------\n-- A stable min-heap implemented with a radix tree.\n-- Orders by an Int priority and a unique Word64 key.\n-- Based on IntPSQ from the the psqueues library (https://hackage.haskell.org/package/psqueues-0.2.8.1)\n\ndata PQ p v\n = Bin !Word64 !p v !Word64 !(PQ p v) !(PQ p v)\n | Tip !Word64 !p v\n | Nil\n\npqPush :: Ord p => Word64 -> p -> v -> PQ p v -> PQ p v\npqPush k1 p1 x1 t = case t of\n Nil -> Tip k1 p1 x1\n (Tip k2 p2 x2)\n | (p1, k1) < (p2, k2) -> link k1 p1 x1 k2 (Tip k2 p2 x2) Nil\n | otherwise -> link k2 p2 x2 k1 (Tip k1 p1 x1) Nil\n (Bin k2 p2 x2 m l r)\n | nomatch k1 k2 m, (p1, k1) < (p2, k2) -> link k1 p1 x1 k2 (Bin k2 p2 x2 m l r) Nil\n | nomatch k1 k2 m -> link k2 p2 x2 k1 (Tip k1 p1 x1) (pqMerge m l r)\n | (p1, k1) < (p2, k2), zero k2 m -> Bin k1 p1 x1 m (pqPush k2 p2 x2 l) r\n | (p1, k1) < (p2, k2) -> Bin k1 p1 x1 m l (pqPush k2 p2 x2 r)\n | zero k1 m -> Bin k2 p2 x2 m (pqPush k1 p1 x1 l) r\n | otherwise -> Bin k2 p2 x2 m l (pqPush k1 p1 x1 r)\n where\n nomatch :: Word64 -> Word64 -> Word64 -> Bool\n nomatch k1 k2 m =\n let maskW = complement (m-1) `xor` m\n in (k1 .&. maskW) /= (k2 .&. maskW)\n\n zero :: Word64 -> Word64 -> Bool\n zero i m = i .&. m == 0\n\n link :: Word64 -> p -> v -> Word64 -> (PQ p v) -> (PQ p v) -> (PQ p v)\n link k p x k' fst snd =\n let m = highestBitMask (k `xor` k')\n in if zero m k'\n then Bin k p x m fst snd\n else Bin k p x m snd fst\n\n highestBitMask :: Word64 -> Word64\n highestBitMask x1 =\n let x2 = x1 .|. x1 `shiftR` 1\n x3 = x2 .|. x2 `shiftR` 2\n x4 = x3 .|. x3 `shiftR` 4\n x5 = x4 .|. x4 `shiftR` 8\n x6 = x5 .|. x5 `shiftR` 16\n x7 = x6 .|. x6 `shiftR` 32\n in x7 `xor` (x7 `shiftR` 1)\n\npqPop :: Ord p => PQ p v -> Maybe (Word64, p, v, PQ p v)\npqPop t = case t of\n Nil -> Nothing\n Tip k p x -> Just (k, p, x, Nil)\n Bin k p x m l r -> Just (k, p, x, pqMerge m l r)\n\npqMerge :: Ord p => Word64 -> PQ p v -> PQ p v -> PQ p v\npqMerge m l r = case (l, r) of\n (Nil, r) -> r\n (l, Nil) -> l\n (Tip lk lp lx, Tip rk rp rx)\n | (lp, lk) < (rp, rk) -> Bin lk lp lx m Nil r\n | otherwise -> Bin rk rp rx m l Nil\n (Tip lk lp lx, Bin rk rp rx rm rl rr)\n | (lp, lk) < (rp, rk) -> Bin lk lp lx m Nil r\n | otherwise -> Bin rk rp rx m l (pqMerge rm rl rr)\n (Bin lk lp lx lm ll lr, Tip rk rp rx)\n | (lp, lk) < (rp, rk) -> Bin lk lp lx m (pqMerge lm ll lr) r\n | otherwise -> Bin rk rp rx m l Nil\n (Bin lk lp lx lm ll lr, Bin rk rp rx rm rl rr)\n | (lp, lk) < (rp, rk) -> Bin lk lp lx m (pqMerge lm ll lr) r\n | otherwise -> Bin rk rp rx m l (pqMerge rm rl rr)\n\n\n-- Flattener\n-- ---------\n\nflattenDFS :: Collapse a -> [a]\nflattenDFS (CSup k a b) = flatten a ++ flatten b\nflattenDFS (CVal x) = [x]\nflattenDFS (CInc x) = flattenDFS x\nflattenDFS (CDec x) = flattenDFS x\nflattenDFS CEra = []\n\nflattenBFS :: Collapse a -> [a]\nflattenBFS term = go term (sqNew :: SQ (Collapse a)) where\n go (CSup k a b) sq = go CEra (sqPut b $ sqPut a $ sq)\n go (CVal x) sq = x : go CEra sq\n go (CInc x) sq = go x sq\n go (CDec x) sq = go x sq\n go CEra sq = case sqPop sq of\n Just (v,sq) -> go v sq\n Nothing -> []\n\n-- Priority-Queue Flattener\n-- ------------------------\n-- * priority starts at 0\n-- * since PQ is a min-queue, we invert the scoers:\n-- * passing through (CInc t) subs 1 ; (CDec t) adds 1\n-- * when no Inc/Dec are present every node has priority == depth\n-- hence the order matches plain BFS exactly (stable heap).\n\nflattenPRI :: Collapse a -> [a]\nflattenPRI term = go 1 (Tip 0 0 term) where\n go i pq = case pqPop pq of\n Nothing -> []\n Just (_, pri, node, pq') -> case node of\n CEra -> go i pq'\n CVal v -> v : go i pq'\n CInc t -> go (i + 1) (pqPush i (pri - 1) t pq')\n CDec t -> go (i + 1) (pqPush i (pri + 1) t pq')\n CSup _ a b ->\n let pq1 = (pqPush (i + 0) (pri + 1) a pq')\n pq2 = (pqPush (i + 1) (pri + 1) b pq1)\n in go (i + 2) pq2\n\n-- Default Flattener\n-- -----------------\n\nflatten :: Collapse a -> [a]\nflatten = flattenPRI\n\n-- Flat Collapser\n-- --------------\n\ndoCollapseFlatAt :: ReduceAt -> Book -> Loc -> HVM [Core]\ndoCollapseFlatAt reduceAt book host = do\n coll <- doCollapseAt reduceAt book host\n return $ flatten coll\n" }, { "path": "src/HVM/Compile.hs", "content": "{-./../IC.md-}\n{-./Type.hs-}\n{-./Inject.hs-}\n\n{-# LANGUAGE TemplateHaskell #-}\n\nmodule HVM.Compile where\n\nimport Control.Monad (forM_, forM, foldM, when)\nimport Control.Monad.State\nimport Data.Bits (shiftL, (.|.))\nimport Data.List\nimport Data.Word\nimport Data.FileEmbed\nimport Debug.Trace\nimport HVM.Foreign hiding (fresh)\nimport HVM.Type\nimport qualified Data.Map.Strict as MS\n\n-- The Runtime.c file content embedded in the binary\n-- Embed the entire runtime as a single translation unit for compiled mode.\n-- We inline Runtime.h and concatenate all .c modules with the include line removed.\nruntime_h :: String\nruntime_h = $(embedStringFile \"./src/HVM/Runtime.h\")\nrt_state_c :: String; rt_state_c = $(embedStringFile \"./src/HVM/runtime/state.c\")\nrt_heap_c :: String; rt_heap_c = $(embedStringFile \"./src/HVM/runtime/heap.c\")\nrt_term_c :: String; rt_term_c = $(embedStringFile \"./src/HVM/runtime/term.c\")\nrt_stack_c :: String; rt_stack_c = $(embedStringFile \"./src/HVM/runtime/stack.c\")\nrt_print_c :: String; rt_print_c = $(embedStringFile \"./src/HVM/runtime/print.c\")\nrt_memory_c :: String; rt_memory_c = $(embedStringFile \"./src/HVM/runtime/memory.c\")\nrt_reduce_c :: String; rt_reduce_c = $(embedStringFile \"./src/HVM/runtime/reduce.c\")\nrt_pr_SUP_c :: String; rt_pr_SUP_c = $(embedStringFile \"./src/HVM/runtime/prim/SUP.c\")\nrt_pr_DUP_c :: String; rt_pr_DUP_c = $(embedStringFile \"./src/HVM/runtime/prim/DUP.c\")\nrt_pr_LOG_c :: String; rt_pr_LOG_c = $(embedStringFile \"./src/HVM/runtime/prim/LOG.c\")\nrt_red_app_ctr :: String; rt_red_app_ctr = $(embedStringFile \"./src/HVM/runtime/reduce/app_ctr.c\")\nrt_red_app_era :: String; rt_red_app_era = $(embedStringFile \"./src/HVM/runtime/reduce/app_era.c\")\nrt_red_app_lam :: String; rt_red_app_lam = $(embedStringFile \"./src/HVM/runtime/reduce/app_lam.c\")\nrt_red_app_sup :: String; rt_red_app_sup = $(embedStringFile \"./src/HVM/runtime/reduce/app_sup.c\")\nrt_red_app_una :: String; rt_red_app_una = $(embedStringFile \"./src/HVM/runtime/reduce/app_una.c\")\nrt_red_app_w32 :: String; rt_red_app_w32 = $(embedStringFile \"./src/HVM/runtime/reduce/app_w32.c\")\nrt_red_dup_ctr :: String; rt_red_dup_ctr = $(embedStringFile \"./src/HVM/runtime/reduce/dup_ctr.c\")\nrt_red_dup_era :: String; rt_red_dup_era = $(embedStringFile \"./src/HVM/runtime/reduce/dup_era.c\")\nrt_red_dup_lam :: String; rt_red_dup_lam = $(embedStringFile \"./src/HVM/runtime/reduce/dup_lam.c\")\nrt_red_dup_ref :: String; rt_red_dup_ref = $(embedStringFile \"./src/HVM/runtime/reduce/dup_ref.c\")\nrt_red_dup_sup :: String; rt_red_dup_sup = $(embedStringFile \"./src/HVM/runtime/reduce/dup_sup.c\")\nrt_red_dup_una :: String; rt_red_dup_una = $(embedStringFile \"./src/HVM/runtime/reduce/dup_una.c\")\nrt_red_dup_w32 :: String; rt_red_dup_w32 = $(embedStringFile \"./src/HVM/runtime/reduce/dup_w32.c\")\nrt_red_let :: String; rt_red_let = $(embedStringFile \"./src/HVM/runtime/reduce/let.c\")\nrt_red_ref :: String; rt_red_ref = $(embedStringFile \"./src/HVM/runtime/reduce/ref.c\")\nrt_red_ref_sup :: String; rt_red_ref_sup = $(embedStringFile \"./src/HVM/runtime/reduce/ref_sup.c\")\nrt_red_mat_ctr :: String; rt_red_mat_ctr = $(embedStringFile \"./src/HVM/runtime/reduce/mat_ctr.c\")\nrt_red_mat_era :: String; rt_red_mat_era = $(embedStringFile \"./src/HVM/runtime/reduce/mat_era.c\")\nrt_red_mat_lam :: String; rt_red_mat_lam = $(embedStringFile \"./src/HVM/runtime/reduce/mat_lam.c\")\nrt_red_mat_sup :: String; rt_red_mat_sup = $(embedStringFile \"./src/HVM/runtime/reduce/mat_sup.c\")\nrt_red_mat_una :: String; rt_red_mat_una = $(embedStringFile \"./src/HVM/runtime/reduce/mat_una.c\")\nrt_red_mat_w32 :: String; rt_red_mat_w32 = $(embedStringFile \"./src/HVM/runtime/reduce/mat_w32.c\")\nrt_red_opx_ctr :: String; rt_red_opx_ctr = $(embedStringFile \"./src/HVM/runtime/reduce/opx_ctr.c\")\nrt_red_opx_era :: String; rt_red_opx_era = $(embedStringFile \"./src/HVM/runtime/reduce/opx_era.c\")\nrt_red_opx_lam :: String; rt_red_opx_lam = $(embedStringFile \"./src/HVM/runtime/reduce/opx_lam.c\")\nrt_red_opx_sup :: String; rt_red_opx_sup = $(embedStringFile \"./src/HVM/runtime/reduce/opx_sup.c\")\nrt_red_opx_una :: String; rt_red_opx_una = $(embedStringFile \"./src/HVM/runtime/reduce/opx_una.c\")\nrt_red_opx_w32 :: String; rt_red_opx_w32 = $(embedStringFile \"./src/HVM/runtime/reduce/opx_w32.c\")\nrt_red_opy_ctr :: String; rt_red_opy_ctr = $(embedStringFile \"./src/HVM/runtime/reduce/opy_ctr.c\")\nrt_red_opy_era :: String; rt_red_opy_era = $(embedStringFile \"./src/HVM/runtime/reduce/opy_era.c\")\nrt_red_opy_lam :: String; rt_red_opy_lam = $(embedStringFile \"./src/HVM/runtime/reduce/opy_lam.c\")\nrt_red_opy_sup :: String; rt_red_opy_sup = $(embedStringFile \"./src/HVM/runtime/reduce/opy_sup.c\")\nrt_red_opy_una :: String; rt_red_opy_una = $(embedStringFile \"./src/HVM/runtime/reduce/opy_una.c\")\nrt_red_opy_w32 :: String; rt_red_opy_w32 = $(embedStringFile \"./src/HVM/runtime/reduce/opy_w32.c\")\n\nstripIncl :: String -> String\nstripIncl = unlines . filter (not . isPrefixOf \"#include \\\"Runtime.h\\\"\") . lines\n\n-- Remove header-only pragmas that are noisy in a main TU\nstripHdr :: String -> String\nstripHdr = unlines . filter (not . isPrefixOf \"#pragma once\") . lines\n\nruntime_c :: String\nruntime_c = unlines\n [ stripHdr runtime_h\n , stripIncl rt_state_c\n , stripIncl rt_heap_c\n , stripIncl rt_term_c\n , stripIncl rt_stack_c\n , stripIncl rt_print_c\n , stripIncl rt_memory_c\n , stripIncl rt_reduce_c\n , stripIncl rt_pr_SUP_c\n , stripIncl rt_pr_DUP_c\n , stripIncl rt_pr_LOG_c\n , stripIncl rt_red_app_ctr\n , stripIncl rt_red_app_era\n , stripIncl rt_red_app_lam\n , stripIncl rt_red_app_sup\n , stripIncl rt_red_app_una\n , stripIncl rt_red_app_w32\n , stripIncl rt_red_dup_ctr\n , stripIncl rt_red_dup_era\n , stripIncl rt_red_dup_lam\n , stripIncl rt_red_dup_ref\n , stripIncl rt_red_dup_sup\n , stripIncl rt_red_dup_una\n , stripIncl rt_red_dup_w32\n , stripIncl rt_red_let\n , stripIncl rt_red_ref\n , stripIncl rt_red_ref_sup\n , stripIncl rt_red_mat_ctr\n , stripIncl rt_red_mat_era\n , stripIncl rt_red_mat_lam\n , stripIncl rt_red_mat_sup\n , stripIncl rt_red_mat_una\n , stripIncl rt_red_mat_w32\n , stripIncl rt_red_opx_ctr\n , stripIncl rt_red_opx_era\n , stripIncl rt_red_opx_lam\n , stripIncl rt_red_opx_sup\n , stripIncl rt_red_opx_una\n , stripIncl rt_red_opx_w32\n , stripIncl rt_red_opy_ctr\n , stripIncl rt_red_opy_era\n , stripIncl rt_red_opy_lam\n , stripIncl rt_red_opy_sup\n , stripIncl rt_red_opy_una\n , stripIncl rt_red_opy_w32\n ]\n\n\n-- Generates the complete C code for a Book\ncompileBook :: Book -> String -> String\ncompileBook book runtime_c =\n let decls = compileHeaders book\n funcs = map (\\ (fid, _) -> compile book fid) (MS.toList (fidToFun book))\n in unlines $ [runtime_c] ++ [decls] ++ funcs ++ [genMain book]\n\n-- Compilation\n-- -----------\n\ndata CompileState = CompileState\n { next :: Word64\n , tabs :: Int\n , bins :: MS.Map String String -- var_name => binder_host\n , vars :: [(String, String)] -- [(var_name, var_host)]\n , code :: [String]\n , reus :: MS.Map Int [String] -- arity => [reuse_loc]\n , tco :: Bool -- tail-call optimization\n }\n\ntype Compile = State CompileState\n\ncompile :: Book -> Word16 -> String\ncompile book fid =\n let full = compileWith compileFull book fid in\n let fast = compileWith compileFast book fid in\n if \"\" `isInfixOf` fast then full else fast\n\n-- Compiles a function using either Fast-Mode or Full-Mode\ncompileWith :: (Book -> Word16 -> Core -> Bool -> [(Bool,String)] -> Compile ()) -> Book -> Word16 -> String\ncompileWith cmp book fid = \n let copy = fst (fst (mget (fidToFun book) fid)) in\n let args = snd (fst (mget (fidToFun book) fid)) in\n let core = snd (mget (fidToFun book) fid) in\n let tco = isTailRecursive core fid in\n let state = CompileState 0 0 MS.empty [] [] MS.empty tco in\n let result = runState (cmp book fid core copy args) state in\n unlines $ reverse $ code (snd result)\n\nemit :: String -> Compile ()\nemit line = modify $ \\st -> st { code = (replicate (tabs st * 2) ' ' ++ line) : code st }\n\ntabInc :: Compile ()\ntabInc = modify $ \\st -> st { tabs = tabs st + 1 }\n\ntabDec :: Compile ()\ntabDec = modify $ \\st -> st { tabs = tabs st - 1 }\n\nbind :: String -> String -> Compile ()\nbind var host = modify $ \\st -> st { bins = MS.insert var host (bins st) }\n\nfresh :: String -> Compile String\nfresh name = do\n uid <- gets next\n modify $ \\s -> s { next = uid + 1 }\n return $ name ++ show uid\n\nreuse :: Int -> String -> Compile ()\nreuse arity loc = modify $ \\st -> st { reus = MS.insertWith (++) arity [loc] (reus st) }\n\n-- Full Compiler\n-- -------------\n\ncompileFull :: Book -> Word16 -> Core -> Bool -> [(Bool,String)] -> Compile ()\ncompileFull book fid core copy args = do\n emit $ \"Term \" ++ mget (fidToNam book) fid ++ \"_f(Term ref) {\"\n tabInc\n forM_ (zip [0..] args) $ \\(i, arg) -> do\n argVar <- fresh \"arg\"\n if fst arg\n then emit $ \"Term \" ++ argVar ++ \" = reduce_at(term_loc(ref) + \" ++ show i ++ \");\"\n else emit $ \"Term \" ++ argVar ++ \" = got(term_loc(ref) + \" ++ show i ++ \");\"\n let argName = snd arg\n bind argName argVar\n result <- compileFullCore book fid core \"root\"\n st <- get\n forM_ (vars st) $ \\ (var,host) -> do\n let varTerm = MS.findWithDefault \"\" var (bins st)\n emit $ \"set(\" ++ host ++ \", \" ++ varTerm ++ \");\"\n emit $ \"return \" ++ result ++ \";\"\n tabDec\n emit \"}\"\n\ncompileFullVar :: String -> String -> Compile String\ncompileFullVar var host = do\n bins <- gets bins\n case MS.lookup var bins of\n Just entry -> do\n return entry\n Nothing -> do\n modify $ \\s -> s { vars = (var, host) : vars s }\n return \"0\"\n\ncompileFullCore :: Book -> Word16 -> Core -> String -> Compile String\n\ncompileFullCore book fid Era _ = do\n return $ \"term_new(ERA, 0, 0)\"\n\ncompileFullCore book fid (Var name) host = do\n compileFullVar name host\n\ncompileFullCore book fid (Let mode var val bod) host = do\n letNam <- fresh \"let\"\n emit $ \"Loc \" ++ letNam ++ \" = alloc_node(2);\"\n valT <- compileFullCore book fid val (letNam ++ \" + 0\")\n emit $ \"set(\" ++ letNam ++ \" + 0, \" ++ valT ++ \");\"\n bind var $ \"term_new(VAR, 0, \" ++ letNam ++ \" + 0)\"\n bodT <- compileFullCore book fid bod (letNam ++ \" + 1\")\n emit $ \"set(\" ++ letNam ++ \" + 1, \" ++ bodT ++ \");\"\n return $ \"term_new(LET, \" ++ show (fromEnum mode) ++ \", \" ++ letNam ++ \")\"\n\ncompileFullCore book fid (Lam var bod) host = do\n lamNam <- fresh \"lam\"\n emit $ \"Loc \" ++ lamNam ++ \" = alloc_node(1);\"\n bind var $ \"term_new(VAR, 0, \" ++ lamNam ++ \" + 0)\"\n bodT <- compileFullCore book fid bod (lamNam ++ \" + 0\")\n emit $ \"set(\" ++ lamNam ++ \" + 0, \" ++ bodT ++ \");\"\n return $ \"term_new(LAM, 0, \" ++ lamNam ++ \")\"\n\ncompileFullCore book fid (App fun arg) host = do\n appNam <- fresh \"app\"\n emit $ \"Loc \" ++ appNam ++ \" = alloc_node(2);\"\n funT <- compileFullCore book fid fun (appNam ++ \" + 0\")\n argT <- compileFullCore book fid arg (appNam ++ \" + 1\")\n emit $ \"set(\" ++ appNam ++ \" + 0, \" ++ funT ++ \");\"\n emit $ \"set(\" ++ appNam ++ \" + 1, \" ++ argT ++ \");\"\n return $ \"term_new(APP, 0, \" ++ appNam ++ \")\"\n\ncompileFullCore book fid (Sup lab tm0 tm1) host = do\n supNam <- fresh \"sup\"\n emit $ \"Loc \" ++ supNam ++ \" = alloc_node(2);\"\n tm0T <- compileFullCore book fid tm0 (supNam ++ \" + 0\")\n tm1T <- compileFullCore book fid tm1 (supNam ++ \" + 1\")\n emit $ \"set(\" ++ supNam ++ \" + 0, \" ++ tm0T ++ \");\"\n emit $ \"set(\" ++ supNam ++ \" + 1, \" ++ tm1T ++ \");\"\n return $ \"term_new(SUP, \" ++ show lab ++ \", \" ++ supNam ++ \")\"\n\ncompileFullCore book fid (Dup lab dp0 dp1 val bod) host = do\n dupNam <- fresh \"dup\"\n emit $ \"Loc \" ++ dupNam ++ \" = alloc_node(1);\"\n bind dp0 $ \"term_new(DP0, \" ++ show lab ++ \", \" ++ dupNam ++ \" + 0)\"\n bind dp1 $ \"term_new(DP1, \" ++ show lab ++ \", \" ++ dupNam ++ \" + 0)\"\n valT <- compileFullCore book fid val (dupNam ++ \" + 0\")\n emit $ \"set(\" ++ dupNam ++ \" + 0, \" ++ valT ++ \");\"\n bodT <- compileFullCore book fid bod host\n return bodT\n\ncompileFullCore book fid (Ctr nam fds) host = do\n ctrNam <- fresh \"ctr\"\n let arity = length fds\n let cid = mget (ctrToCid book) nam\n emit $ \"Loc \" ++ ctrNam ++ \" = alloc_node(\" ++ show arity ++ \");\"\n fdsT <- mapM (\\ (i,fd) -> compileFullCore book fid fd (ctrNam ++ \" + \" ++ show i)) (zip [0..] fds)\n sequence_ [emit $ \"set(\" ++ ctrNam ++ \" + \" ++ show i ++ \", \" ++ fdT ++ \");\" | (i,fdT) <- zip [0..] fdsT]\n return $ \"term_new(CTR, \" ++ show cid ++ \", \" ++ ctrNam ++ \")\"\n\ncompileFullCore book fid tm@(Mat kin val mov css) host = do\n matNam <- fresh \"mat\"\n emit $ \"Loc \" ++ matNam ++ \" = alloc_node(\" ++ show (1 + length css) ++ \");\"\n valT <- compileFullCore book fid val (matNam ++ \" + 0\")\n emit $ \"set(\" ++ matNam ++ \" + 0, \" ++ valT ++ \");\"\n forM_ (zip [0..] css) $ \\ (i,(ctr,fds,bod)) -> do\n let bod' = foldr (\\x b -> Lam x b) (foldr (\\x b -> Lam x b) bod (map fst mov)) fds\n bodT <- compileFullCore book fid bod' (matNam ++ \" + \" ++ show (i+1))\n emit $ \"set(\" ++ matNam ++ \" + \" ++ show (i+1) ++ \", \" ++ bodT ++ \");\"\n let tag = case kin of { SWI -> \"SWI\" ; (IFL _) -> \"IFL\" ; (MAT _) -> \"MAT\" }\n let lab = case kin of { SWI -> fromIntegral (length css) ; (IFL cid) -> cid ; (MAT cid) -> cid }\n let mat = \"term_new(\" ++ tag ++ \", \" ++ show lab ++ \", \" ++ matNam ++ \")\"\n foldM (\\term (key, val) -> do\n appNam <- fresh \"app\"\n emit $ \"Loc \" ++ appNam ++ \" = alloc_node(2);\"\n valT <- compileFullCore book fid val (appNam ++ \" + 1\")\n emit $ \"set(\" ++ appNam ++ \" + 0, \" ++ term ++ \");\"\n emit $ \"set(\" ++ appNam ++ \" + 1, \" ++ valT ++ \");\"\n return $ \"term_new(APP, 0, \" ++ appNam ++ \")\") mat mov\n\ncompileFullCore book fid (U32 val) _ =\n return $ \"term_new(W32, 0, \" ++ show (fromIntegral val) ++ \")\"\n\ncompileFullCore book fid (Chr val) _ =\n return $ \"term_new(CHR, 0, \" ++ show (fromEnum val) ++ \")\"\n\ncompileFullCore book fid (Op2 opr nu0 nu1) host = do\n opxNam <- fresh \"opx\"\n emit $ \"Loc \" ++ opxNam ++ \" = alloc_node(2);\"\n nu0T <- compileFullCore book fid nu0 (opxNam ++ \" + 0\")\n nu1T <- compileFullCore book fid nu1 (opxNam ++ \" + 1\")\n emit $ \"set(\" ++ opxNam ++ \" + 0, \" ++ nu0T ++ \");\"\n emit $ \"set(\" ++ opxNam ++ \" + 1, \" ++ nu1T ++ \");\"\n return $ \"term_new(OPX, \" ++ show (fromEnum opr) ++ \", \" ++ opxNam ++ \")\"\n\ncompileFullCore book fid t@(Ref rNam rFid rArg) host = do\n checkRefAri book fid t\n refNam <- fresh \"ref\"\n let arity = length rArg\n emit $ \"Loc \" ++ refNam ++ \" = alloc_node(\" ++ show arity ++ \");\"\n argsT <- mapM (\\ (i,arg) -> compileFullCore book fid arg (refNam ++ \" + \" ++ show i)) (zip [0..] rArg)\n sequence_ [emit $ \"set(\" ++ refNam ++ \" + \" ++ show i ++ \", \" ++ argT ++ \");\" | (i,argT) <- zip [0..] argsT]\n return $ \"term_new(REF, \" ++ show rFid ++ \", \" ++ refNam ++ \")\"\n\ncompileFullCore book fid (Inc val) host = do\n incNam <- fresh \"inc\"\n emit $ \"Loc \" ++ incNam ++ \" = alloc_node(1);\"\n valT <- compileFullCore book fid val (incNam ++ \" + 0\")\n emit $ \"set(\" ++ incNam ++ \" + 0, \" ++ valT ++ \");\"\n return $ \"term_new(INC, 0, \" ++ incNam ++ \")\"\n\ncompileFullCore book fid (Dec val) host = do\n decNam <- fresh \"dec\"\n emit $ \"Loc \" ++ decNam ++ \" = alloc_node(1);\"\n valT <- compileFullCore book fid val (decNam ++ \" + 0\")\n emit $ \"set(\" ++ decNam ++ \" + 0, \" ++ valT ++ \");\"\n return $ \"term_new(DEC, 0, \" ++ decNam ++ \")\"\n\n-- Fast Compiler\n-- -------------\n\n-- Compiles a function using Fast-Mode\ncompileFast :: Book -> Word16 -> Core -> Bool -> [(Bool,String)] -> Compile ()\ncompileFast book fid core copy args = do\n emit $ \"Term \" ++ mget (fidToNam book) fid ++ \"_f(Term ref) {\"\n tabInc\n emit \"u64 itrs = 0;\"\n args <- forM (zip [0..] args) $ \\ (i, (strict, arg)) -> do\n argNam <- fresh \"arg\"\n if strict then do\n emit $ \"Term \" ++ argNam ++ \" = reduce_at(term_loc(ref) + \" ++ show i ++ \");\"\n else do\n emit $ \"Term \" ++ argNam ++ \" = got(term_loc(ref) + \" ++ show i ++ \");\"\n if copy && strict then do\n case MS.lookup fid (fidToLab book) of\n Just labs -> do\n emit $ \"if (term_tag(\" ++ argNam ++ \") == ERA) {\"\n emit $ \" itrs += 1;\"\n emit $ \" *HVM.itrs += itrs;\"\n emit $ \" return term_new(ERA, 0, 0);\"\n emit $ \"}\"\n emit $ \"if (term_tag(\" ++ argNam ++ \") == SUP) {\"\n tabInc\n emit $ \"u64 lab = term_lab(\" ++ argNam ++ \");\"\n emit $ \"if (1\"\n forM_ (MS.keys labs) $ \\lab -> do\n emit $ \" && lab != \" ++ show lab\n emit $ \") {\"\n tabInc\n emit $ \"return reduce_ref_sup(ref, \" ++ show i ++ \");\"\n tabDec\n emit $ \"}\"\n tabDec\n emit $ \"}\"\n Nothing -> return ()\n else\n return ()\n bind arg argNam\n return argNam\n reuse (length (snd (fst (mget (fidToFun book) fid)))) \"term_loc(ref)\"\n compileFastArgs book fid core args\n tabDec\n emit \"}\"\n\n-- Compiles a fast function's argument list\ncompileFastArgs :: Book -> Word16 -> Core -> [String] -> Compile ()\ncompileFastArgs book fid body ctx = do\n tco <- gets tco\n if tco then do\n emit $ \"_Bool fst_iter = true;\"\n emit $ \"while (1) {\"\n tabInc\n compileFastBody book fid body ctx False 0\n tabDec\n emit $ \"}\"\n else do\n compileFastBody book fid body ctx False 0\n\n-- Compiles a fast function body (pattern-matching)\ncompileFastBody :: Book -> Word16 -> Core -> [String] -> Bool -> Int -> Compile ()\ncompileFastBody book fid term@(Mat kin val mov css) ctx stop@False itr = do\n valT <- compileFastCore book fid val\n valNam <- fresh \"val\"\n emit $ \"Term \" ++ valNam ++ \" = reduce(\" ++ valT ++ \");\"\n let valVar = \"scrut%\"++valNam\n bind valVar valNam\n let isNumeric = length css > 0 && (let (ctr,fds,bod) = css !! 0 in ctr == \"0\")\n\n -- Numeric Pattern-Matching\n if isNumeric then do\n numNam <- fresh \"num\"\n emit $ \"if (term_tag(\"++valNam++\") == W32) {\"\n tabInc\n emit $ \"u32 \" ++ numNam ++ \" = term_loc(\" ++ valNam ++ \");\"\n emit $ \"switch (\" ++ numNam ++ \") {\"\n tabInc\n forM_ (zip [0..] css) $ \\ (i, (ctr,fds,bod)) -> do\n if i < length css - 1 then do\n emit $ \"case \" ++ show i ++ \": {\"\n tabInc\n forM_ mov $ \\ (key,val) -> do\n valT <- compileFastCore book fid val\n bind key valT\n compileFastBody book fid bod ctx stop (itr + 1 + length mov)\n tabDec\n emit $ \"}\"\n else do\n emit $ \"default: {\"\n tabInc\n preNam <- fresh \"pre\"\n emit $ \"Term \" ++ preNam ++ \" = \" ++ \"term_new(W32, 0, \"++numNam++\" - \"++show (length css - 1)++\");\"\n forM_ fds $ \\ fd -> do\n bind fd preNam\n forM_ mov $ \\ (key,val) -> do\n valT <- compileFastCore book fid val\n bind key valT\n compileFastBody book fid bod ctx stop (itr + 1 + length fds + length mov)\n tabDec\n emit $ \"}\"\n tabDec\n emit $ \"}\"\n tabDec\n emit $ \"} else if (term_tag(\" ++ valNam ++ \") == ERA) {\"\n tabInc\n compileFastBody book fid Era ctx stop (itr + 1)\n tabDec\n emit $ \"} else {\"\n tabInc\n val <- compileFastCore book fid (Mat kin (Var valVar) mov css)\n emit $ \"itrs += \" ++ show itr ++ \";\"\n compileFastSave book fid term ctx itr\n emit $ \"return \" ++ val ++ \";\"\n tabDec\n emit $ \"}\"\n\n -- Constructor Pattern-Matching (with IfLet)\n else if (case kin of { (IFL _) -> True ; _ -> False }) then do\n let (Var defNam) = val\n let iflCss = undoIfLetChain defNam term\n let (_, dflt) = last iflCss\n let othCss = init iflCss\n emit $ \"if (term_tag(\" ++ valNam ++ \") == CTR) {\"\n tabInc\n emit $ \"switch (term_lab(\" ++ valNam ++ \")) {\"\n tabInc\n reuse' <- gets reus\n itrA <- foldM (\\itr (mov, (ctr, fds, bod)) -> do\n emit $ \"case \" ++ show (mget (ctrToCid book) ctr) ++ \": {\"\n tabInc\n reuse (length fds) (\"term_loc(\" ++ valNam ++ \")\")\n forM_ (zip [0..] fds) $ \\(k, fd) -> do\n fdNam <- fresh \"fd\"\n emit $ \"Term \" ++ fdNam ++ \" = got(term_loc(\" ++ valNam ++ \") + \" ++ show k ++ \");\"\n bind fd fdNam\n forM_ mov $ \\(key, val) -> do\n valT <- compileFastCore book fid val\n bind key valT\n compileFastBody book fid bod ctx stop (itr + 1 + length fds + length mov)\n tabDec\n emit $ \"}\"\n modify $ \\st -> st { reus = reuse' }\n return (itr + 1 + 1 + length mov)) itr othCss\n emit $ \"default: {\"\n tabInc\n let (_, [dflNam], dflBod) = dflt\n fdNam <- fresh \"fd\"\n emit $ \"Term \" ++ fdNam ++ \" = \" ++ valNam ++ \";\"\n bind dflNam fdNam\n forM_ mov $ \\(key, val) -> do\n valT <- compileFastCore book fid val\n bind key valT\n compileFastBody book fid dflBod ctx stop itrA\n tabDec\n emit $ \"}\"\n tabDec\n emit $ \"}\"\n tabDec\n emit $ \"} else if (term_tag(\" ++ valNam ++ \") == ERA) {\"\n tabInc\n compileFastBody book fid Era ctx stop (itr + 1)\n tabDec\n emit $ \"} else {\"\n tabInc\n val <- compileFastCore book fid (Mat kin (Var valVar) mov css)\n emit $ \"itrs += \" ++ show itr ++ \";\"\n compileFastSave book fid term ctx itr\n emit $ \"return \" ++ val ++ \";\"\n tabDec\n emit $ \"}\"\n\n -- Constructor Pattern-Matching (without IfLet)\n else do\n emit $ \"if (term_tag(\" ++ valNam ++ \") == CTR) {\"\n tabInc\n emit $ \"switch (term_lab(\" ++ valNam ++ \") - \" ++ show (case kin of { (IFL c) -> c ; (MAT c) -> c ; _ -> 0 }) ++ \") {\"\n tabInc\n reuse' <- gets reus\n forM_ (zip [0..] css) $ \\ (i, (ctr,fds,bod)) -> do\n emit $ \"case \" ++ show i ++ \": {\"\n tabInc\n reuse (length fds) (\"term_loc(\" ++ valNam ++ \")\")\n forM_ (zip [0..] fds) $ \\ (k,fd) -> do\n fdNam <- fresh \"fd\"\n emit $ \"Term \" ++ fdNam ++ \" = got(term_loc(\" ++ valNam ++ \") + \" ++ show k ++ \");\"\n bind fd fdNam\n forM_ mov $ \\ (key,val) -> do\n valT <- compileFastCore book fid val\n bind key valT\n compileFastBody book fid bod ctx stop (itr + 1 + length fds + length mov)\n tabDec\n emit $ \"}\"\n modify $ \\st -> st { reus = reuse' }\n emit $ \"default: { exit(1); }\"\n tabDec\n emit $ \"}\"\n tabDec\n emit $ \"} else if (term_tag(\" ++ valNam ++ \") == ERA) {\"\n tabInc\n compileFastBody book fid Era ctx stop (itr + 1)\n tabDec\n emit $ \"} else {\"\n tabInc\n val <- compileFastCore book fid (Mat kin (Var valVar) mov css)\n emit $ \"itrs += \" ++ show itr ++ \";\"\n compileFastSave book fid term ctx itr\n emit $ \"return \" ++ val ++ \";\"\n tabDec\n emit $ \"}\"\n where\n undoIfLetChain :: String -> Core -> [([(String,Core)], (String, [String], Core))]\n undoIfLetChain expNam term@(Mat _ (Var gotNam) mov [(ctr, fds, bod), (\"_\", [nxtNam], rest)]) =\n if gotNam == expNam\n then (mov, (ctr, fds, bod)) : undoIfLetChain nxtNam rest\n else [([], (\"_\", [expNam], term))]\n undoIfLetChain expNam term = [([], (\"_\", [expNam], term))]\n\ncompileFastBody book fid term@(Dup lab dp0 dp1 val bod) ctx stop itr = do\n valT <- compileFastCore book fid val\n valNam <- fresh \"val\"\n dp0Nam <- fresh \"dpA\"\n dp1Nam <- fresh \"dpB\"\n emit $ \"Term \" ++ valNam ++ \" = (\" ++ valT ++ \");\"\n emit $ \"Term \" ++ dp0Nam ++ \";\"\n emit $ \"Term \" ++ dp1Nam ++ \";\"\n emit $ \"if (term_is_atom(\" ++ valNam ++ \")) {\"\n tabInc\n emit $ \"itrs += 1;\"\n emit $ dp0Nam ++ \" = \" ++ valNam ++ \";\"\n emit $ dp1Nam ++ \" = \" ++ valNam ++ \";\"\n tabDec\n emit $ \"} else if (term_tag(\" ++ valNam ++ \") == SUP && term_lab(\" ++ valNam ++ \") == \" ++ show lab ++ \") {\"\n tabInc\n emit $ \"itrs += 1;\"\n emit $ dp0Nam ++ \" = got(term_loc(\" ++ valNam ++ \") + 0);\"\n emit $ dp1Nam ++ \" = got(term_loc(\" ++ valNam ++ \") + 1);\"\n tabDec\n emit $ \"} else {\"\n tabInc\n dupNam <- fresh \"dup\"\n compileFastAlloc dupNam 1\n emit $ \"set(\" ++ dupNam ++ \" + 0, \" ++ valNam ++ \");\"\n emit $ dp0Nam ++ \" = term_new(DP0, \" ++ show lab ++ \", \" ++ dupNam ++ \" + 0);\"\n emit $ dp1Nam ++ \" = term_new(DP1, \" ++ show lab ++ \", \" ++ dupNam ++ \" + 0);\"\n tabDec\n emit $ \"}\"\n bind dp0 dp0Nam\n bind dp1 dp1Nam\n compileFastBody book fid bod ctx stop itr\n\ncompileFastBody book fid term@(Let mode var val bod) ctx stop itr = do\n valT <- compileFastCore book fid val\n case mode of\n LAZY -> do\n bind var valT\n STRI -> do\n case val of\n t@(Ref _ rFid _) -> do\n checkRefAri book fid t\n valNam <- fresh \"val\"\n emit $ \"Term \" ++ valNam ++ \" = reduce(\" ++ mget (fidToNam book) rFid ++ \"_f(\" ++ valT ++ \"));\"\n bind var valNam\n _ -> do\n valNam <- fresh \"val\" \n emit $ \"Term \" ++ valNam ++ \" = reduce(\" ++ valT ++ \");\"\n bind var valNam\n compileFastBody book fid bod ctx stop itr\n\ncompileFastBody book fid term@(Ref fNam fFid fArg) ctx stop itr\n -- Tail-call optimization\n | fFid == fid = do\n checkRefAri book fid term\n forM_ (zip fArg ctx) $ \\ (arg, ctxVar) -> do\n argT <- compileFastCore book fid arg\n emit $ \"\" ++ ctxVar ++ \" = \" ++ argT ++ \";\"\n emit $ \"itrs += \" ++ show (itr + 1) ++ \";\"\n emit $ \"fst_iter = false;\"\n emit $ \"continue;\"\n\n -- Inline Dynamic DUP\n -- The label must be a number at this point (not SUP, ERA, etc).\n | fNam == \"DUP\" && (case fArg of [_, _, Lam _ (Lam _ _)] -> True ; _ -> False) = do\n let [lab, val, Lam dp0 (Lam dp1 bod)] = fArg\n labNam <- fresh \"lab\"\n labTm <- compileFastCore book fid lab\n emit $ \"Term \" ++ labNam ++ \" = reduce(\" ++ labTm ++ \");\"\n emit $ \"if (term_tag(\" ++ labNam ++ \") != W32) {\"\n emit $ \" printf(\\\"ERROR:non-numeric-sup-label\\\\n\\\");\"\n emit $ \"}\"\n emit $ \"itrs += 3;\"\n -- Regular dup compilation (need to reimplement here since we don't know the label during compilation)\n valT <- compileFastCore book fid val\n valNam <- fresh \"val\"\n dp0Nam <- fresh \"dpA\"\n dp1Nam <- fresh \"dpB\"\n emit $ \"Term \" ++ valNam ++ \" = (\" ++ valT ++ \");\"\n emit $ \"Term \" ++ dp0Nam ++ \";\"\n emit $ \"Term \" ++ dp1Nam ++ \";\"\n emit $ \"if (term_is_atom(\" ++ valNam ++ \")) {\"\n tabInc\n emit $ \"itrs += 1;\"\n emit $ dp0Nam ++ \" = \" ++ valNam ++ \";\"\n emit $ dp1Nam ++ \" = \" ++ valNam ++ \";\"\n tabDec\n emit $ \"} else if (term_tag(\" ++ valNam ++ \") == SUP && term_lab(\" ++ valNam ++ \") == term_loc(\" ++ labNam ++ \")) {\"\n tabInc\n emit $ \"itrs += 1;\"\n emit $ dp0Nam ++ \" = got(term_loc(\" ++ valNam ++ \") + 0);\"\n emit $ dp1Nam ++ \" = got(term_loc(\" ++ valNam ++ \") + 1);\"\n tabDec\n emit $ \"} else {\"\n tabInc\n dupNam <- fresh \"dup\"\n compileFastAlloc dupNam 1\n emit $ \"set(\" ++ dupNam ++ \" + 0, \" ++ valNam ++ \");\"\n -- Set to the dynamic label.\n emit $ dp0Nam ++ \" = term_new(DP0, term_loc(\" ++ labNam ++ \"), \" ++ dupNam ++ \" + 0);\"\n emit $ dp1Nam ++ \" = term_new(DP1, term_loc(\" ++ labNam ++ \"), \" ++ dupNam ++ \" + 0);\"\n tabDec\n emit $ \"}\"\n bind dp0 dp0Nam\n bind dp1 dp1Nam\n compileFastBody book fid bod ctx stop itr\n\ncompileFastBody book fid term ctx stop itr = do\n body <- compileFastCore book fid term\n emit $ \"itrs += \" ++ show itr ++ \";\"\n compileFastSave book fid term ctx itr\n emit $ \"return \" ++ body ++ \";\"\n\n-- Completes a fast mode call\ncompileFastSave :: Book -> Word16 -> Core -> [String] -> Int -> Compile ()\ncompileFastSave book fid term ctx itr = do\n emit $ \"*HVM.itrs += itrs;\"\n\n-- Helper function to allocate nodes with reuse\ncompileFastAlloc :: String -> Int -> Compile ()\ncompileFastAlloc name 0 = do\n emit $ \"Loc \" ++ name ++ \" = 0;\"\ncompileFastAlloc name arity = do\n reuse <- gets reus\n -- Find the smallest reuse location that's big enough\n -- Very large reuses are usually functions with a lot of state that doesn't need to be moved\n -- Don't fragment those to avoid moving those values (a separate optimization)\n let bigEnough = [(k,locs) | (k,locs) <- MS.toList reuse, k >= arity, k <= arity + 5, not (null locs)]\n case bigEnough of\n [] -> do\n emit $ \"Loc \" ++ name ++ \" = alloc_node(\" ++ show arity ++ \");\"\n ((k,loc:locs):_) -> do\n emit $ \"Loc \" ++ name ++ \";\"\n -- Too hard to determine statically if reusing is ok in tail-call-optimization\n tco <- gets tco\n if tco then do\n emit $ \"if (fst_iter) {\"\n emit $ \" \" ++ name ++ \" = \" ++ loc ++ \";\"\n emit $ \"} else {\"\n emit $ \" \" ++ name ++ \" = alloc_node(\" ++ show arity ++ \");\"\n emit $ \"}\"\n else do\n emit $ name ++ \" = \" ++ loc ++ \";\"\n -- Remove the used location\n let reuse' = MS.insert k locs reuse\n -- If we used a location bigger than needed, add the remainder back\n let reuse'' = if k > arity \n then MS.insertWith (++) (k - arity) [loc ++ \" + \" ++ show arity] reuse'\n else reuse'\n modify $ \\st -> st { reus = reuse'' }\n\n-- Compiles a core term in fast mode\ncompileFastCore :: Book -> Word16 -> Core -> Compile String\n\ncompileFastCore book fid Era = \n return $ \"term_new(ERA, 0, 0)\"\n\ncompileFastCore book fid (Let mode var val bod) = do\n valT <- compileFastCore book fid val\n case mode of\n LAZY -> do\n emit $ \"itrs += 1;\"\n bind var valT\n compileFastCore book fid bod\n STRI -> do\n letNam <- fresh \"let\"\n compileFastAlloc letNam 2\n emit $ \"set(\" ++ letNam ++ \" + 0, \" ++ valT ++ \");\"\n bind var $ \"term_new(VAR, 0, \" ++ letNam ++ \" + 0)\"\n bodT <- compileFastCore book fid bod\n emit $ \"set(\" ++ letNam ++ \" + 1, \" ++ bodT ++ \");\"\n return $ \"term_new(LET, \" ++ show (fromEnum STRI) ++ \", \" ++ letNam ++ \")\"\n\ncompileFastCore book fid (Var name) = do\n compileFastVar name\n\ncompileFastCore book fid (Lam var bod) = do\n lamNam <- fresh \"lam\"\n compileFastAlloc lamNam 1\n bind var $ \"term_new(VAR, 0, \" ++ lamNam ++ \" + 0)\"\n bodT <- compileFastCore book fid bod\n emit $ \"set(\" ++ lamNam ++ \" + 0, \" ++ bodT ++ \");\"\n return $ \"term_new(LAM, 0, \" ++ lamNam ++ \")\"\n\ncompileFastCore book fid (App fun arg) = do\n appNam <- fresh \"app\"\n compileFastAlloc appNam 2\n funT <- compileFastCore book fid fun\n argT <- compileFastCore book fid arg\n emit $ \"set(\" ++ appNam ++ \" + 0, \" ++ funT ++ \");\"\n emit $ \"set(\" ++ appNam ++ \" + 1, \" ++ argT ++ \");\"\n return $ \"term_new(APP, 0, \" ++ appNam ++ \")\"\n\ncompileFastCore book fid (Sup lab tm0 tm1) = do\n supNam <- fresh \"sup\"\n compileFastAlloc supNam 2\n tm0T <- compileFastCore book fid tm0\n tm1T <- compileFastCore book fid tm1\n emit $ \"set(\" ++ supNam ++ \" + 0, \" ++ tm0T ++ \");\"\n emit $ \"set(\" ++ supNam ++ \" + 1, \" ++ tm1T ++ \");\"\n return $ \"term_new(SUP, \" ++ show lab ++ \", \" ++ supNam ++ \")\"\n\ncompileFastCore book fid (Dup lab dp0 dp1 val bod) = do\n dupNam <- fresh \"dup\"\n dp0Nam <- fresh \"dpA\"\n dp1Nam <- fresh \"dpB\"\n valNam <- fresh \"val\"\n valT <- compileFastCore book fid val\n emit $ \"Term \" ++ valNam ++ \" = (\" ++ valT ++ \");\"\n emit $ \"Term \" ++ dp0Nam ++ \";\"\n emit $ \"Term \" ++ dp1Nam ++ \";\"\n emit $ \"if (term_is_atom(\" ++ valNam ++ \")) {\"\n tabInc\n emit $ \"itrs += 1;\"\n emit $ dp0Nam ++ \" = \" ++ valNam ++ \";\"\n emit $ dp1Nam ++ \" = \" ++ valNam ++ \";\"\n tabDec\n emit $ \"} else if (term_tag(\" ++ valNam ++ \") == SUP && term_lab(\" ++ valNam ++ \") == \" ++ show lab ++ \") {\"\n tabInc\n emit $ \"itrs += 1;\"\n emit $ dp0Nam ++ \" = got(term_loc(\" ++ valNam ++ \") + 0);\"\n emit $ dp1Nam ++ \" = got(term_loc(\" ++ valNam ++ \") + 1);\"\n tabDec\n emit $ \"} else {\"\n tabInc\n compileFastAlloc dupNam 1\n emit $ \"set(\" ++ dupNam ++ \" + 0, \" ++ valNam ++ \");\"\n emit $ dp0Nam ++ \" = term_new(DP0, \" ++ show lab ++ \", \" ++ dupNam ++ \" + 0);\"\n emit $ dp1Nam ++ \" = term_new(DP1, \" ++ show lab ++ \", \" ++ dupNam ++ \" + 0);\"\n tabDec\n emit $ \"}\"\n bind dp0 dp0Nam\n bind dp1 dp1Nam\n compileFastCore book fid bod\n\ncompileFastCore book fid (Ctr nam fds) = do\n ctrNam <- fresh \"ctr\"\n let ari = length fds\n let cid = mget (ctrToCid book) nam\n compileFastAlloc ctrNam ari\n fdsT <- mapM (\\ (i,fd) -> compileFastCore book fid fd) (zip [0..] fds)\n sequence_ [emit $ \"set(\" ++ ctrNam ++ \" + \" ++ show i ++ \", \" ++ fdT ++ \");\" | (i,fdT) <- zip [0..] fdsT]\n return $ \"term_new(CTR, \" ++ show cid ++ \", \" ++ ctrNam ++ \")\"\n\ncompileFastCore book fid tm@(Mat kin val mov css) = do\n matNam <- fresh \"mat\"\n compileFastAlloc matNam (1 + length css)\n valT <- compileFastCore book fid val\n emit $ \"set(\" ++ matNam ++ \" + 0, \" ++ valT ++ \");\"\n forM_ (zip [0..] css) $ \\(i,(ctr,fds,bod)) -> do\n let bod' = foldr (\\x b -> Lam x b) (foldr (\\x b -> Lam x b) bod (map fst mov)) fds\n bodT <- compileFastCore book fid bod'\n emit $ \"set(\" ++ matNam ++ \" + \" ++ show (i+1) ++ \", \" ++ bodT ++ \");\"\n let tag = case kin of { SWI -> \"SWI\" ; (IFL _) -> \"IFL\" ; (MAT _) -> \"MAT\" }\n let lab = case kin of { SWI -> fromIntegral (length css) ; (IFL cid) -> cid ; (MAT cid) -> cid }\n retNam <- fresh \"ret\"\n emit $ \"Term \" ++ retNam ++ \" = term_new(\" ++ tag ++ \", \" ++ show lab ++ \", \" ++ matNam ++ \");\"\n foldM (\\acc (_, val) -> do\n appNam <- fresh \"app\"\n compileFastAlloc appNam 2\n emit $ \"set(\" ++ appNam ++ \" + 0, \" ++ acc ++ \");\"\n valT <- compileFastCore book fid val\n emit $ \"set(\" ++ appNam ++ \" + 1, \" ++ valT ++ \");\"\n return $ \"term_new(APP, 0, \" ++ appNam ++ \")\") retNam mov\n\ncompileFastCore book fid (U32 val) =\n return $ \"term_new(W32, 0, \" ++ show (fromIntegral val) ++ \")\"\n\ncompileFastCore book fid (Chr val) =\n return $ \"term_new(CHR, 0, \" ++ show (fromEnum val) ++ \")\"\n\ncompileFastCore book fid (Op2 opr nu0 nu1) = do\n opxNam <- fresh \"opx\"\n retNam <- fresh \"ret\"\n nu0Nam <- fresh \"nu0\"\n nu1Nam <- fresh \"nu1\"\n nu0T <- compileFastCore book fid nu0\n nu1T <- compileFastCore book fid nu1\n emit $ \"Term \" ++ nu0Nam ++ \" = (\" ++ nu0T ++ \");\"\n emit $ \"Term \" ++ nu1Nam ++ \" = (\" ++ nu1T ++ \");\"\n emit $ \"Term \" ++ retNam ++ \";\"\n emit $ \"if (term_tag(\" ++ nu0Nam ++ \") == W32 && term_tag(\" ++ nu1Nam ++ \") == W32) {\"\n emit $ \" itrs += 2;\"\n let oprStr = case opr of\n OP_ADD -> \"+\"\n OP_SUB -> \"-\"\n OP_MUL -> \"*\"\n OP_DIV -> \"/\"\n OP_MOD -> \"%\"\n OP_EQ -> \"==\"\n OP_NE -> \"!=\"\n OP_LT -> \"<\"\n OP_GT -> \">\"\n OP_LTE -> \"<=\"\n OP_GTE -> \">=\"\n OP_AND -> \"&\"\n OP_OR -> \"|\"\n OP_XOR -> \"^\"\n OP_LSH -> \"<<\"\n OP_RSH -> \">>\"\n emit $ \" \" ++ retNam ++ \" = term_new(W32, 0, term_loc(\" ++ nu0Nam ++ \") \" ++ oprStr ++ \" term_loc(\" ++ nu1Nam ++ \"));\"\n emit $ \"} else {\"\n tabInc\n compileFastAlloc opxNam 2\n emit $ \"set(\" ++ opxNam ++ \" + 0, \" ++ nu0Nam ++ \");\"\n emit $ \"set(\" ++ opxNam ++ \" + 1, \" ++ nu1Nam ++ \");\"\n emit $ retNam ++ \" = term_new(OPX, \" ++ show (fromEnum opr) ++ \", \" ++ opxNam ++ \");\"\n tabDec\n emit $ \"}\"\n return $ retNam\n\ncompileFastCore book fid t@(Ref rNam rFid rArg) = do\n checkRefAri book fid t\n refNam <- fresh \"ref\"\n let arity = length rArg\n compileFastAlloc refNam arity\n argsT <- mapM (\\ (i,arg) -> compileFastCore book fid arg) (zip [0..] rArg)\n sequence_ [emit $ \"set(\" ++ refNam ++ \" + \" ++ show i ++ \", \" ++ argT ++ \");\" | (i,argT) <- zip [0..] argsT]\n return $ \"term_new(REF, \" ++ show rFid ++ \", \" ++ refNam ++ \")\"\n\ncompileFastCore book fid (Inc val) = do\n incNam <- fresh \"inc\"\n compileFastAlloc incNam 1\n valT <- compileFastCore book fid val\n emit $ \"set(\" ++ incNam ++ \" + 0, \" ++ valT ++ \");\"\n return $ \"term_new(INC, 0, \" ++ incNam ++ \")\"\n\ncompileFastCore book fid (Dec val) = do\n decNam <- fresh \"dec\"\n compileFastAlloc decNam 1\n valT <- compileFastCore book fid val\n emit $ \"set(\" ++ decNam ++ \" + 0, \" ++ valT ++ \");\"\n return $ \"term_new(DEC, 0, \" ++ decNam ++ \")\"\n\n-- Compiles a variable in fast mode\ncompileFastVar :: String -> Compile String\ncompileFastVar var = do\n bins <- gets bins\n case MS.lookup var bins of\n Just entry -> do\n return entry\n Nothing -> do\n return $ \"\"\n\ncheckRefAri :: Book -> Word16 -> Core -> Compile ()\ncheckRefAri book orig core = do\n case core of\n Ref nam lab arg -> do\n let fid = fromIntegral lab\n let ari = funArity book fid\n let len = length arg\n when (ari /= fromIntegral len) $ do\n let nam = mget (fidToNam book) orig\n error $ \"On function @\" ++ nam ++ \": Arity mismatch on term: \" ++ show core ++ \". Expected \" ++ show ari ++ \", got \" ++ show len ++ \".\"\n _ -> return ()\n\n-- Generates the forward declarations of the compiled C functions\ncompileHeaders :: Book -> String\ncompileHeaders book =\n let funcs = MS.toList (fidToNam book)\n decls = map (\\(_, name) -> \"Term \" ++ name ++ \"_f(Term);\") funcs\n in unlines decls\n\n-- Generates the main function for the compiled C code\ngenMain :: Book -> String\ngenMain book = case MS.lookup \"main\" (namToFid book) of\n Just mainFid ->\n unlines\n [ \"int main() {\"\n , \" hvm_init();\"\n , registerFuncs\n , \" clock_t start = clock();\"\n , \" Term root = term_new(REF, \"++show mainFid++\", 0);\"\n , \" normal(root);\"\n , \" double time = (double)(clock() - start) / CLOCKS_PER_SEC * 1000;\"\n , \" printf(\\\"WORK: %\\\"PRIu64\\\" interactions\\\\n\\\", get_itr());\"\n , \" printf(\\\"TIME: %.3fs seconds\\\\n\\\", time / 1000.0);\"\n , \" printf(\\\"SIZE: %llu nodes\\\\n\\\", get_len());\"\n , \" printf(\\\"PERF: %.3f MIPS\\\\n\\\", (get_itr() / 1000000.0) / (time / 1000.0));\"\n , \" hvm_free();\"\n , \" return 0;\"\n , \"}\"\n ]\n Nothing -> \"\"\n where \n registerFuncs = unlines [\" hvm_define(\" ++ show fid ++ \", \" ++ name ++ \"_f);\" | (fid, name) <- MS.toList (fidToNam book)]\n\nisTailRecursive :: Core -> Word16 -> Bool\nisTailRecursive core fid = case core of\n Ref _ fFid _ | fFid == fid -> True\n Ref \"DUP\" _ [_, _, Lam _ (Lam _ f)] -> isTailRecursive f fid\n Dup _ _ _ _ f -> isTailRecursive f fid\n Let _ _ _ f -> isTailRecursive f fid\n Mat _ _ _ c -> any (\\(_,_,f) -> isTailRecursive f fid) c\n _ -> False\n" }, { "path": "src/HVM/Extract.hs", "content": "{-./Type.hs-}\n{-./Inject.hs-}\n\nmodule HVM.Extract where\n\nimport Control.Monad (foldM, forM_, forM)\nimport Control.Monad.State\nimport Data.Bits (shiftR)\nimport Data.Char (chr, ord)\nimport Data.IORef\nimport Data.Word\nimport Debug.Trace\nimport HVM.Foreign\nimport System.IO.Unsafe (unsafeInterleaveIO)\nimport HVM.Type\nimport qualified Data.IntSet as IS\nimport qualified Data.Map.Strict as MS\n\nextractCoreAt :: IORef IS.IntSet -> ReduceAt -> Book -> Loc -> HVM Core\n\nextractCoreAt dupsRef reduceAt book host = unsafeInterleaveIO $ do\n term <- reduceAt book host\n -- trace (\"extract \" ++ show host ++ \" \" ++ termToString term) $\n let tag = termTag term\n case tag of\n t | t == _ERA_ -> do\n return Era\n\n t | t == _LET_ -> do\n let loc = termLoc term\n let mode = modeT (termLab term)\n name <- return $ \"$\" ++ show (loc + 0)\n val <- extractCoreAt dupsRef reduceAt book (loc + 0)\n bod <- extractCoreAt dupsRef reduceAt book (loc + 1)\n return $ Let mode name val bod\n\n t | t == _LAM_ -> do\n let loc = termLoc term\n name <- return $ \"$\" ++ show (loc + 0)\n bod <- extractCoreAt dupsRef reduceAt book (loc + 0)\n return $ Lam name bod\n\n t | t == _APP_ -> do\n let loc = termLoc term\n fun <- extractCoreAt dupsRef reduceAt book (loc + 0)\n arg <- extractCoreAt dupsRef reduceAt book (loc + 1)\n return $ App fun arg\n\n t | t == _SUP_ -> do\n let loc = termLoc term\n let lab = termLab term\n tm0 <- extractCoreAt dupsRef reduceAt book (loc + 0)\n tm1 <- extractCoreAt dupsRef reduceAt book (loc + 1)\n return $ Sup lab tm0 tm1\n\n t | t == _VAR_ -> do\n let loc = termLoc term\n sub <- got (loc + 0)\n if termGetBit sub == 0\n then do\n name <- return $ \"$\" ++ show (loc + 0)\n return $ Var name\n else do\n set (loc + 0) (termRemBit sub)\n extractCoreAt dupsRef reduceAt book (loc + 0)\n\n t | t == _DP0_ -> do\n let loc = termLoc term\n let lab = termLab term\n dups <- readIORef dupsRef\n if IS.member (fromIntegral loc) dups\n then do\n name <- return $ \"$\" ++ show (loc + 0) ++ \"_0\"\n return $ Var name\n else do\n dp0 <- return $ \"$\" ++ show (loc + 0) ++ \"_0\"\n dp1 <- return $ \"$\" ++ show (loc + 0) ++ \"_1\"\n val <- extractCoreAt dupsRef reduceAt book (loc + 0)\n modifyIORef' dupsRef (IS.insert (fromIntegral loc))\n return $ Dup lab dp0 dp1 val (Var dp0)\n\n t | t == _DP1_ -> do\n let loc = termLoc term\n let lab = termLab term\n dups <- readIORef dupsRef\n if IS.member (fromIntegral loc) dups\n then do\n name <- return $ \"$\" ++ show (loc + 0) ++ \"_1\"\n return $ Var name\n else do\n dp0 <- return $ \"$\" ++ show (loc + 0) ++ \"_0\"\n dp1 <- return $ \"$\" ++ show (loc + 0) ++ \"_1\"\n val <- extractCoreAt dupsRef reduceAt book (loc + 0)\n modifyIORef' dupsRef (IS.insert (fromIntegral loc))\n return $ Dup lab dp0 dp1 val (Var dp1)\n\n t | t == _CTR_ -> do\n let loc = termLoc term\n let lab = termLab term\n let cid = fromIntegral lab\n let nam = mget (cidToCtr book) cid\n let ari = mget (cidToAri book) cid\n let ars = if ari == 0 then [] else [0..fromIntegral ari-1]\n fds <- mapM (\\i -> extractCoreAt dupsRef reduceAt book (loc + i)) ars\n return $ Ctr nam fds\n\n t | t == _MAT_ -> do\n let loc = termLoc term\n let lab = termLab term\n let cid = fromIntegral lab\n let len = mget (cidToLen book) cid\n val <- extractCoreAt dupsRef reduceAt book (loc + 0)\n css <- foldM (\\css i -> do\n let ctr = mget (cidToCtr book) (cid + i)\n let ari = mget (cidToAri book) (cid + i)\n let fds = if ari == 0 then [] else [\"$\" ++ show (loc + 1 + j) | j <- [0..fromIntegral ari-1]]\n bod <- extractCoreAt dupsRef reduceAt book (loc + 1 + fromIntegral i)\n return $ (ctr,fds,bod):css) [] [0..len-1]\n return $ Mat (MAT cid) val [] (reverse css)\n\n t | t == _IFL_ -> do\n let loc = termLoc term\n let lab = termLab term\n let cid = fromIntegral lab\n val <- extractCoreAt dupsRef reduceAt book (loc + 0)\n cs0 <- extractCoreAt dupsRef reduceAt book (loc + 1)\n cs1 <- extractCoreAt dupsRef reduceAt book (loc + 2)\n return $ Mat (IFL cid) val [] [(mget (cidToCtr book) cid, [], cs0), (\"_\", [], cs1)]\n\n t | t == _SWI_ -> do\n let loc = termLoc term\n let lab = termLab term\n let len = fromIntegral lab\n val <- extractCoreAt dupsRef reduceAt book (loc + 0)\n css <- foldM (\\css i -> do\n bod <- extractCoreAt dupsRef reduceAt book (loc + 1 + i)\n return $ (show i, [], bod):css) [] [0..len-1]\n return $ Mat SWI val [] (reverse css)\n\n t | t == _W32_ -> do\n let val = termLoc term\n return $ U32 (fromIntegral val)\n\n t | t == _CHR_ -> do\n let val = termLoc term\n return $ Chr (chr (fromIntegral val))\n\n t | t == _OPX_ -> do\n let loc = termLoc term\n let opr = toEnum (fromIntegral (termLab term))\n nmx <- extractCoreAt dupsRef reduceAt book (loc + 0)\n nmy <- extractCoreAt dupsRef reduceAt book (loc + 1)\n return $ Op2 opr nmx nmy\n\n t | t == _OPY_ -> do\n let loc = termLoc term\n let opr = toEnum (fromIntegral (termLab term))\n nmy <- extractCoreAt dupsRef reduceAt book (loc + 0)\n nmx <- extractCoreAt dupsRef reduceAt book (loc + 1)\n return $ Op2 opr nmx nmy\n\n t | t == _REF_ -> do\n let loc = termLoc term\n let lab = termLab term\n let fid = fromIntegral lab\n let ari = fromIntegral $ funArity book fid\n let aux = if ari == 0 then [] else [0..ari-1]\n arg <- mapM (\\i -> extractCoreAt dupsRef reduceAt book (loc + i)) aux\n let name = MS.findWithDefault \"?\" fid (fidToNam book)\n return $ Ref name fid arg\n\n t | t == _FWD_ -> do\n return Era\n\n t | t == _INC_ -> do\n let loc = termLoc term\n val <- extractCoreAt dupsRef reduceAt book (loc + 0)\n return $ Inc val\n\n t | t == _DEC_ -> do\n let loc = termLoc term\n val <- extractCoreAt dupsRef reduceAt book (loc + 0)\n return $ Dec val\n\n _ -> do\n return Era\n\ndoExtractCoreAt :: ReduceAt -> Book -> Loc -> HVM Core\ndoExtractCoreAt reduceAt book loc = do\n dupsRef <- newIORef IS.empty\n core <- extractCoreAt dupsRef reduceAt book loc\n return core\n -- return $ doLiftDups core\n\n-- Lifting Dups\n-- ------------\n\nliftDups :: Core -> (Core, Core -> Core)\n\nliftDups (Var nam) =\n (Var nam, id)\n\nliftDups (Ref nam fid arg) =\n let (argT, argD) = liftDupsList arg\n in (Ref nam fid argT, argD)\n\nliftDups Era =\n (Era, id)\n\nliftDups (Lam str bod) =\n let (bodT, bodD) = liftDups bod\n in (Lam str bodT, bodD)\n\nliftDups (App fun arg) =\n let (funT, funD) = liftDups fun\n (argT, argD) = liftDups arg\n in (App funT argT, funD . argD)\n\nliftDups (Sup lab tm0 tm1) =\n let (tm0T, tm0D) = liftDups tm0\n (tm1T, tm1D) = liftDups tm1\n in (Sup lab tm0T tm1T, tm0D . tm1D)\n\nliftDups (Dup lab dp0 dp1 val bod) =\n let (valT, valD) = liftDups val\n (bodT, bodD) = liftDups bod\n in (bodT, \\x -> valD (bodD (Dup lab dp0 dp1 valT x)))\n\nliftDups (Ctr nam fds) =\n let (fdsT, fdsD) = liftDupsList fds\n in (Ctr nam fdsT, fdsD)\n\nliftDups (Mat kin val mov css) =\n let (valT, valD) = liftDups val\n (movT, movD) = liftDupsMov mov\n (cssT, cssD) = liftDupsCss css\n in (Mat kin valT movT cssT, valD . movD . cssD)\n\nliftDups (U32 val) =\n (U32 val, id)\n\nliftDups (Chr val) =\n (Chr val, id)\n\nliftDups (Op2 opr nm0 nm1) =\n let (nm0T, nm0D) = liftDups nm0\n (nm1T, nm1D) = liftDups nm1\n in (Op2 opr nm0T nm1T, nm0D . nm1D)\n\nliftDups (Let mod nam val bod) =\n let (valT, valD) = liftDups val\n (bodT, bodD) = liftDups bod\n in (Let mod nam valT bodT, valD . bodD)\n\nliftDups (Inc val) =\n let (valT, valD) = liftDups val\n in (Inc valT, valD)\n\nliftDups (Dec val) =\n let (valT, valD) = liftDups val\n in (Dec valT, valD)\n\nliftDupsList :: [Core] -> ([Core], Core -> Core)\n\nliftDupsList [] = \n ([], id)\n\nliftDupsList (x:xs) =\n let (xT, xD) = liftDups x\n (xsT, xsD) = liftDupsList xs\n in (xT:xsT, xD . xsD)\n\nliftDupsMov :: [(String, Core)] -> ([(String, Core)], Core -> Core)\n\nliftDupsMov [] = \n ([], id)\n\nliftDupsMov ((k,v):xs) =\n let (vT, vD) = liftDups v\n (xsT, xsD) = liftDupsMov xs\n in ((k,vT):xsT, vD . xsD)\n\nliftDupsCss :: [(String, [String], Core)] -> ([(String, [String], Core)], Core -> Core)\n\nliftDupsCss [] = \n ([], id)\n\nliftDupsCss ((c,fs,b):xs) =\n let (bT, bD) = liftDups b\n (xsT, xsD) = liftDupsCss xs\n in ((c,fs,bT):xsT, bD . xsD)\n\ndoLiftDups :: Core -> Core\ndoLiftDups term =\n let (termExpr, termDups) = liftDups term in\n let termBody = termDups (Var \"\") in\n -- hack to print expr before dups\n Let LAZY \"\" termExpr termBody\n" }, { "path": "src/HVM/Foreign.hs", "content": "{-./Runtime.c-}\n\nmodule HVM.Foreign where\n\nimport Data.Word\nimport Foreign.Ptr\nimport HVM.Type\n\nforeign import ccall \"set_len\" \n setLen :: Word64 -> IO ()\n\nforeign import ccall \"set_itr\"\n setItr :: Word64 -> IO ()\n\nforeign import ccall unsafe \"Runtime.c hvm_init\"\n hvmInit :: IO ()\n\nforeign import ccall unsafe \"Runtime.c hvm_free\"\n hvmFree :: IO ()\n\nforeign import ccall unsafe \"Runtime.c alloc_node\"\n allocNode :: Loc -> IO Loc\n\nforeign import ccall unsafe \"Runtime.c set\"\n set :: Loc -> Term -> IO ()\n\nforeign import ccall unsafe \"Runtime.c got\"\n got :: Loc -> IO Term\n\nforeign import ccall unsafe \"Runtime.c take\"\n take :: Loc -> IO Term\n\nforeign import ccall unsafe \"Runtime.c swap\"\n swap :: Loc -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c term_new\"\n termNew :: Tag -> Lab -> Loc -> Term\n\nforeign import ccall unsafe \"Runtime.c term_tag\"\n termTag :: Term -> Tag\n\nforeign import ccall unsafe \"Runtime.c term_get_bit\"\n termGetBit :: Term -> Word8\n\nforeign import ccall unsafe \"Runtime.c term_lab\"\n termLab :: Term -> Lab\n\nforeign import ccall unsafe \"Runtime.c term_loc\"\n termLoc :: Term -> Loc\n\nforeign import ccall unsafe \"Runtime.c term_set_bit\"\n termSetBit :: Term -> Term\n\nforeign import ccall unsafe \"Runtime.c term_rem_bit\"\n termRemBit :: Term -> Term\n\nforeign import ccall unsafe \"Runtime.c get_len\"\n getLen :: IO Word64\n\nforeign import ccall unsafe \"Runtime.c get_itr\"\n getItr :: IO Word64\n\nforeign import ccall unsafe \"Runtime.c inc_itr\"\n incItr :: IO ()\n\nforeign import ccall unsafe \"Runtime.c fresh\"\n fresh :: IO Word64\n\nforeign import ccall unsafe \"Runtime.c reduce\"\n reduceC :: Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_at\"\n reduceAtC :: Loc -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_let\"\n reduceLet :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_app_era\"\n reduceAppEra :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_app_lam\"\n reduceAppLam :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_app_sup\"\n reduceAppSup :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_app_ctr\"\n reduceAppCtr :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_app_w32\"\n reduceAppW32 :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_app_inc\"\n reduceAppInc :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_app_dec\"\n reduceAppDec :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_dup_era\"\n reduceDupEra :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_dup_lam\"\n reduceDupLam :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_dup_sup\"\n reduceDupSup :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_dup_ctr\"\n reduceDupCtr :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_dup_w32\"\n reduceDupW32 :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_dup_ref\"\n reduceDupRef :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_dup_inc\"\n reduceDupInc :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_dup_dec\"\n reduceDupDec :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_mat_era\"\n reduceMatEra :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_mat_lam\"\n reduceMatLam :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_mat_sup\"\n reduceMatSup :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_mat_ctr\"\n reduceMatCtr :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_mat_w32\"\n reduceMatW32 :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_mat_inc\"\n reduceMatInc :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_mat_dec\"\n reduceMatDec :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_opx_era\"\n reduceOpxEra :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_opx_lam\"\n reduceOpxLam :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_opx_sup\"\n reduceOpxSup :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_opx_ctr\"\n reduceOpxCtr :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_opx_w32\"\n reduceOpxW32 :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_opx_inc\"\n reduceOpxInc :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_opx_dec\"\n reduceOpxDec :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_opy_era\"\n reduceOpyEra :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_opy_lam\"\n reduceOpyLam :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_opy_sup\"\n reduceOpySup :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_opy_ctr\"\n reduceOpyCtr :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_opy_w32\"\n reduceOpyW32 :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_opy_inc\"\n reduceOpyInc :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_opy_dec\"\n reduceOpyDec :: Term -> Term -> IO Term\n\nforeign import ccall unsafe \"Runtime.c reduce_ref_sup\"\n reduceRefSup :: Term -> Word16 -> IO Term\n\nforeign import ccall unsafe \"Runtime.c hvm_define\"\n hvmDefine :: Word16 -> FunPtr (IO Term) -> IO ()\n\nforeign import ccall unsafe \"Runtime.c hvm_get_state\"\n hvmGetState :: IO (Ptr ())\n\nforeign import ccall unsafe \"Runtime.c hvm_set_state\"\n hvmSetState :: Ptr () -> IO ()\n\nforeign import ccall unsafe \"Runtime.c hvm_set_cari\"\n hvmSetCari :: Word16 -> Word16 -> IO ()\n\nforeign import ccall unsafe \"Runtime.c hvm_set_clen\"\n hvmSetClen :: Word16 -> Word16 -> IO ()\n\nforeign import ccall unsafe \"Runtime.c hvm_set_cadt\"\n hvmSetCadt :: Word16 -> Word16 -> IO ()\n\nforeign import ccall unsafe \"Runtime.c hvm_set_fari\"\n hvmSetFari :: Word16 -> Word16 -> IO ()\n\nshowTerm :: Term -> String\nshowTerm term =\n let tag = showTag (termTag term)\n lab = showLab (termLab term)\n loc = showLoc (termLoc term)\n in \"term_new(\" ++ tag ++ \",0x\" ++ lab ++ \",0x\" ++ loc ++ \")\"\n" }, { "path": "src/HVM/Inject.hs", "content": "{-./Type.hs-}\n\nmodule HVM.Inject where\n\nimport Control.Monad (foldM, when, forM_)\nimport Control.Monad.State\nimport Data.Bits (shiftL, (.|.))\nimport Data.Char (ord)\nimport Data.List (foldr, take)\nimport Data.Word\nimport Debug.Trace\nimport HVM.Foreign\nimport HVM.Type\nimport qualified Data.Map.Strict as MS\n\ntype InjectM a = StateT InjectState HVM a\n\ndata InjectState = InjectState\n { args :: MS.Map String Term -- maps var names to binder locations\n , vars :: [(String, Loc)] -- list of (var name, usage location) pairs\n }\n\nemptyState :: InjectState\nemptyState = InjectState MS.empty []\n\ninjectCore :: Book -> Core -> Loc -> InjectM ()\n\ninjectCore _ Era loc = do\n lift $ set loc (termNew _ERA_ 0 0)\n\ninjectCore _ (Var nam) loc = do\n argsMap <- gets args\n case MS.lookup nam argsMap of\n Just term -> do\n lift $ set loc term\n modify $ \\s -> s { args = MS.delete nam (args s) }\n Nothing -> do\n modify $ \\s -> s { vars = (nam, loc) : vars s }\n\ninjectCore book (Let mod nam val bod) loc = do\n let_node <- lift $ allocNode 2\n modify $ \\s -> s { args = MS.insert nam (termNew _VAR_ 0 (let_node + 0)) (args s) }\n injectCore book val (let_node + 0)\n injectCore book bod (let_node + 1)\n lift $ set loc (termNew _LET_ (fromIntegral $ fromEnum mod) let_node)\n\ninjectCore book (Lam vr0 bod) loc = do\n lam <- lift $ allocNode 1\n modify $ \\s -> s { args = MS.insert vr0 (termNew _VAR_ 0 (lam + 0)) (args s) }\n injectCore book bod (lam + 0)\n lift $ set loc (termNew _LAM_ 0 lam)\n\ninjectCore book (App fun arg) loc = do\n app <- lift $ allocNode 2\n injectCore book fun (app + 0)\n injectCore book arg (app + 1)\n lift $ set loc (termNew _APP_ 0 app)\n\ninjectCore book (Sup lab tm0 tm1) loc = do\n sup <- lift $ allocNode 2\n injectCore book tm0 (sup + 0)\n injectCore book tm1 (sup + 1)\n lift $ set loc (termNew _SUP_ lab sup)\n\ninjectCore book (Dup lab dp0 dp1 val bod) loc = do\n dup <- lift $ allocNode 1\n modify $ \\s -> s \n { args = MS.insert dp0 (termNew _DP0_ lab dup) \n $ MS.insert dp1 (termNew _DP1_ lab dup) (args s) \n }\n injectCore book val (dup + 0)\n injectCore book bod loc\n\ninjectCore book (Ref nam fid arg) loc = do\n let ari = funArity book fid\n let lab = fromIntegral fid\n ref <- lift $ allocNode (fromIntegral ari)\n sequence_ [injectCore book x (ref + i) | (i,x) <- zip [0..] arg]\n lift $ set loc (termNew _REF_ lab ref)\n\ninjectCore book (Ctr nam fds) loc = do\n let cid = mget (ctrToCid book) nam\n let ari = mget (cidToAri book) cid\n let lab = fromIntegral cid\n ctr <- lift $ allocNode (fromIntegral ari)\n sequence_ [injectCore book fd (ctr + ix) | (ix,fd) <- zip [0..] fds]\n lift $ set loc (termNew _CTR_ lab ctr)\n\ninjectCore book tm@(Mat kin val mov css) loc = do\n mat <- lift $ allocNode (1 + fromIntegral (length css))\n injectCore book val (mat + 0)\n forM_ (zip [0..] css) $ \\ (idx, (ctr, fds, bod)) -> do\n injectCore book (foldr (\\x b -> Lam x b) (foldr (\\x b -> Lam x b) bod (map fst mov)) fds) (mat + 1 + fromIntegral idx)\n let tag = case kin of { SWI -> _SWI_ ; (MAT _) -> _MAT_ ; (IFL _) -> _IFL_ }\n let lab = case kin of { SWI -> fromIntegral $ length css ; (MAT cid) -> fromIntegral cid ; (IFL cid) -> fromIntegral cid }\n trm <- return $ termNew tag lab mat\n ret <- foldM (\\mat (_, val) -> do\n app <- lift $ allocNode 2\n lift $ set (app + 0) mat\n injectCore book val (app + 1)\n return $ termNew _APP_ 0 app)\n trm\n mov\n lift $ set loc ret\n\ninjectCore book (U32 val) loc = do\n lift $ set loc (termNew _W32_ 0 (fromIntegral val))\n\ninjectCore book (Chr val) loc = do\n lift $ set loc (termNew _CHR_ 0 (fromIntegral $ ord val))\n\ninjectCore book (Op2 opr nm0 nm1) loc = do\n opx <- lift $ allocNode 2\n injectCore book nm0 (opx + 0)\n injectCore book nm1 (opx + 1)\n lift $ set loc (termNew _OPX_ (fromIntegral $ fromEnum opr) opx)\n\ninjectCore book (Inc val) loc = do\n inc <- lift $ allocNode 1\n injectCore book val (inc + 0)\n lift $ set loc (termNew _INC_ 0 inc)\n\ninjectCore book (Dec val) loc = do\n dec <- lift $ allocNode 1\n injectCore book val (dec + 0)\n lift $ set loc (termNew _DEC_ 0 dec)\n\ndoInjectCoreAt :: Book -> Core -> Loc -> [(String,Term)] -> HVM Term\ndoInjectCoreAt book core host argList = do\n (_, state) <- runStateT (injectCore book core host) (emptyState { args = MS.fromList argList })\n foldM (\\m (name, loc) -> do\n case MS.lookup name (args state) of\n Just term -> do\n set loc term\n return $ MS.delete name m\n Nothing -> do\n error $ \"Unbound variable: \\n\\x1b[2m\" ++ name ++ \"\\n\\x1b[0mIn term:\\n\\x1b[2m\" ++ Data.List.take 1024 (showCore core) ++ \"...\\x1b[0m\")\n (args state)\n (vars state)\n got host\n" }, { "path": "src/HVM/Parse.hs", "content": "{-./Type.hs-}\n\nmodule HVM.Parse where\n\nimport Control.Monad (foldM, forM, forM_, when)\nimport Control.Monad.State\nimport Data.IORef\nimport Data.List\nimport Data.Word\nimport Debug.Trace\nimport Highlight (highlightError)\nimport System.Console.ANSI\nimport Text.Parsec hiding (State)\nimport Text.Parsec.Error\nimport HVM.Adjust (adjustBook, adjust)\nimport HVM.Type\nimport qualified Data.Map.Strict as MS\n\n-- Core Parsers\n-- ------------\n\ndata ParserState = ParserState\n { pCidToAri :: MS.Map Word16 Word16\n , pCidToLen :: MS.Map Word16 Word16\n , pCtrToCid :: MS.Map String Word16\n , pCidToCtr :: MS.Map Word16 String\n , pCidToADT :: MS.Map Word16 Word16\n , imported :: MS.Map String ()\n , varUsages :: MS.Map String Int\n , globalVars :: MS.Map String ()\n , pFreshLab :: Lab\n }\n\ntype ParserM = ParsecT String ParserState IO\n\n-- Core Term\nparseCore :: ParserM Core\nparseCore = do\n skip\n head <- lookAhead anyChar\n case head of\n '*' -> parseEra\n 'λ' -> parseLam\n '(' -> parseExp\n '@' -> parseRef\n '&' -> parseSup\n '!' -> parseLet\n '#' -> parseCtr\n '~' -> parseMat\n '↑' -> parseInc\n '↓' -> parseDec\n '[' -> parseLst\n '\\'' -> parseChr\n '\"' -> parseStr '\"'\n '`' -> parseStr '`'\n _ -> parseLit\n\n-- Era: `*`\nparseEra :: ParserM Core\nparseEra = do\n consume \"*\"\n return Era\n\n-- Lam: `λx.F` or `λ&x.F` for non-linear variables\nparseLam :: ParserM Core\nparseLam = do\n consume \"λ\"\n var <- parseName1\n swallow \".\"\n bod <- bindVars [var] parseCore\n return $ Lam var bod\n\n-- FshSup: `& {a,b}` -- uses a fresh label\n-- StaSup: `&0{a,b}` -- uses a static label\n-- DynSup: `&L{a,b}` -- uses a dynamic label\n-- DynLab: `&L` -- a dynamic label variable\nparseSup :: ParserM Core\nparseSup = do\n consume \"&\"\n name <- parseName\n next <- optionMaybe $ try $ lookAhead anyChar\n case next of\n Just '{' -> do\n consume \"{\"\n tm0 <- parseCore\n swallow \",\"\n tm1 <- parseCore\n consume \"}\"\n if null name then do\n num <- genFreshLabel\n return $ Sup num tm0 tm1\n else case reads name of\n [(num :: Lab, \"\")] -> do\n return $ Sup num tm0 tm1\n otherwise -> do\n useVar name\n return $ Ref \"SUP\" (fromIntegral _SUP_F_) [Var name, tm0, tm1]\n _ -> do\n useVar (\"&\" ++ name)\n return $ Var (\"&\" ++ name)\n\n-- Exp: `( A B)`\nparseExp :: ParserM Core\nparseExp = do\n next <- lookAhead (anyChar >> anyChar)\n case next of\n '+' -> parseOper OP_ADD\n '-' -> parseOper OP_SUB\n '*' -> parseOper OP_MUL\n '/' -> parseOper OP_DIV\n '%' -> parseOper OP_MOD\n '=' -> parseOper OP_EQ\n '!' -> parseOper OP_NE\n '&' -> parseOper OP_AND\n '|' -> parseOper OP_OR\n '^' -> parseOper OP_XOR\n '<' -> do\n next <- lookAhead (anyChar >> anyChar >> anyChar)\n case next of\n '<' -> parseOper OP_LSH\n '=' -> parseOper OP_LTE\n _ -> parseOper OP_LT\n '>' -> do\n next <- lookAhead (anyChar >> anyChar >> anyChar)\n case next of\n '>' -> parseOper OP_RSH\n '=' -> parseOper OP_GTE\n _ -> parseOper OP_GT\n _ -> do\n consume \"(\"\n fun <- parseCore\n args <- many $ do\n closeWith \")\"\n parseCore\n skip\n char ')'\n return $ foldl (\\f a -> App f a) fun args\n\n-- Oper: `(+ a b)`\nparseOper :: Oper -> ParserM Core\nparseOper op = do\n consume \"(\"\n consume (show op)\n nm0 <- parseCore\n nm1 <- parseCore\n consume \")\"\n return $ Op2 op nm0 nm1\n\n-- Ref: `@Fun(x0 x1 ...)`\nparseRef :: ParserM Core\nparseRef = do\n consume \"@\"\n name <- parseName1\n args <- option [] $ do\n try $ string \"(\"\n args <- many $ do\n closeWith \")\"\n swallow \",\"\n parseCore\n consume \")\"\n return args\n return $ Ref name 0 args\n\n-- Ctr: `#Ctr{x0 x1 ...}`\nparseCtr :: ParserM Core\nparseCtr = do\n consume \"#\"\n nam <- parseName1\n fds <- option [] $ do\n try $ consume \"{\"\n fds <- many $ do\n closeWith \"}\"\n parseCore\n consume \"}\"\n return fds\n return $ Ctr ('#':nam) fds\n\n-- Mat: `~ x !m0=v0 !m1=v1 ... { #Ctr{x0 x1 ...}:... ... }`\nparseMat :: ParserM Core\nparseMat = do\n consume \"~\"\n val <- parseCore\n mov <- many parseMove\n consume \"{\"\n cs0 <- parseCase False (map fst mov)\n css <- many $ parseCase (let (n,_,_)=cs0 in n==\"0\") (map fst mov)\n consume \"}\"\n buildMatchExpr val mov (cs0:css)\n\n-- Mov: `!m0 = v0` (used inside Mat)\nparseMove :: ParserM (String, Core)\nparseMove = do\n try $ skip >> consume \"!\"\n name <- parseName1\n expr <- optionMaybe $ try $ consume \"=\" >> parseCore\n case expr of\n Just e -> return (name, e)\n Nothing -> do\n -- !x is shorthand for !x=x\n -- !&x is shorthand for !&x=x\n useVar (stripName name)\n return (name, Var (stripName name))\n\n-- Case: CtrCase | NumCase | DefCase\nparseCase :: Bool -> [String] -> ParserM (String, [String], Core)\nparseCase isNumMat mov = do\n closeWith \"}\" >> skip\n c <- lookAhead anyChar\n if c == '#'\n then parseCtrCase mov -- Constructor case\n else if c >= '0' && c <= '9'\n then parseNumCase mov -- Numeric case\n else (parseDefCase isNumMat mov) -- Default case\n\n-- CtrCase: `#Ctr{x0 x1 ...}: f`\nparseCtrCase :: [String] -> ParserM (String, [String], Core)\nparseCtrCase mov = do\n consume \"#\"\n name <- parseName1\n skip\n vars <- option [] $ do\n consume \"{\"\n vars <- many $ do\n closeWith \"}\"\n parseName1\n consume \"}\"\n return vars\n consume \":\"\n body <- bindVars (mov ++ vars) parseCore\n swallow \";\"\n return ('#':name, vars, body)\n\n-- NumCase: LitCase | PreCase\nparseNumCase :: [String] -> ParserM (String, [String], Core)\nparseNumCase mov = try (parseLitCase mov) <|> try (parsePreCase mov)\n\n-- LitCase: `123: f`\nparseLitCase :: [String] -> ParserM (String, [String], Core)\nparseLitCase mov = do\n digits <- many1 digit\n consume \":\"\n body <- bindVars mov parseCore\n swallow \";\"\n return (digits, [], body)\n\n-- PreCase: `123+p: f`\nparsePreCase :: [String] -> ParserM (String, [String], Core)\nparsePreCase mov = do\n pred <- many1 digit\n consume \"+\"\n name <- parseName1\n consume \":\"\n body <- bindVars (mov ++ [name]) parseCore\n swallow \";\"\n return (\"_\", [name], body)\n\n-- DefCase: `x: f`\nparseDefCase :: Bool -> [String] -> ParserM (String, [String], Core)\nparseDefCase isNumMat mov = do\n name <- parseName1\n consume \":\"\n body <- bindVars (mov ++ [name]) parseCore\n swallow \";\"\n if isNumMat && name /= \"_\" then do\n fail $ concat\n [ \"To avoid ambiguity, the switch syntax changed.\\n\"\n , \"- Old Syntax: ~ n { 0:zero_case x:pred_case }\\n\"\n , \"- New Syntax: ~ n { 0:zero_case 1+x:pred_case }\\n\"\n , \"- Please, update your code.\"\n ]\n else do\n return (\"_\", [name], body)\n\n-- Inc: `↑x`\nparseInc :: ParserM Core\nparseInc = do\n consume \"↑\"\n term <- parseCore\n return $ Inc term\n\n-- Dec: `↓x`\nparseDec :: ParserM Core\nparseDec = do\n consume \"↓\"\n term <- parseCore\n return $ Dec term\n\n-- Let: Dup | StriLet | LazyLet\nparseLet :: ParserM Core\nparseLet = do\n consume \"!\"\n skip\n next <- lookAhead anyChar\n case next of\n '&' -> try parseDup <|> try parseLazyLet\n '!' -> parseStriLet\n _ -> parseLazyLet\n\n-- Fresh Dup : `! & {a b}=v f`\n-- Static Dup : `! &0{a b}=v f`\n-- Dynamic Dup : `! &L{a b}=v f`\nparseDup :: ParserM Core\nparseDup = do\n consume \"&\"\n nam <- parseName\n consume \"{\"\n dp0 <- parseName1\n dp1 <- parseName1\n consume \"}\"\n consume \"=\"\n val <- parseCore\n swallow \";\"\n bod <- bindVars [dp0, dp1] parseCore\n if null nam then do\n num <- genFreshLabel\n return $ Dup num dp0 dp1 val bod\n else case reads nam of\n [(num :: Lab, \"\")] -> do\n return $ Dup num dp0 dp1 val bod\n otherwise -> do\n useVar nam\n return $ Ref \"DUP\" (fromIntegral _DUP_F_) [Var nam, val, Lam dp0 (Lam dp1 bod)]\n\n-- StriLet: `! !x=v f`\nparseStriLet :: ParserM Core\nparseStriLet = do\n consume \"!\"\n nam <- option \"_\" $ try $ do\n nam <- parseName1\n consume \"=\"\n return nam\n val <- parseCore\n swallow \";\"\n bod <- bindVars [nam] parseCore\n return $ Let STRI nam val bod\n\n-- LazyLet: `! x=v f`\nparseLazyLet :: ParserM Core\nparseLazyLet = do\n nam <- parseName1\n consume \"=\"\n val <- parseCore\n swallow \";\"\n bod <- bindVars [nam] parseCore\n return $ Let LAZY nam val bod\n\n-- Lit: Var | U32\nparseLit :: ParserM Core\nparseLit = do\n name <- parseName1\n case name of\n \"log\" -> parseLogExpr\n _ -> case reads (filter (/= '_') name) of\n [(num, \"\")] -> do\n return $ U32 (fromIntegral (num :: Integer))\n _ -> do\n useVar name\n return $ Var name\n\n-- Log: `log x f` -> `!! @LOG(x) f`\nparseLogExpr :: ParserM Core\nparseLogExpr = do\n skip\n expr <- parseCore\n skip\n cont <- parseCore\n let logCall = Ref \"LOG\" (fromIntegral _LOG_F_) [expr]\n return $ Let STRI \"_\" logCall cont\n\n-- Chr: 'x'\nparseChr :: ParserM Core\nparseChr = do\n skip\n char '\\''\n c <- escaped\n char '\\''\n return $ Chr c\n\n-- -- Str: \"abc\"\nparseStr :: Char -> ParserM Core\nparseStr delim = do\n skip\n char delim\n str <- many escaped\n char delim\n return $ foldr (\\c acc -> Ctr \"#Cons\" [Chr c, acc]) (Ctr \"#Nil\" []) str\n\n-- Lst: `[x0 x1 ...]`\nparseLst :: ParserM Core\nparseLst = do\n skip\n char '['\n elems <- many $ do\n closeWith \"]\"\n swallow \",\"\n parseCore\n skip\n char ']'\n return $ foldr (\\x acc -> Ctr \"#Cons\" [x, acc]) (Ctr \"#Nil\" []) elems\n\n-- Def: `@foo(x0 x1...) = f`\nparseDef :: ParserM (String, ((Bool, [(Bool, String)]), Core))\nparseDef = do\n -- Reset global binds\n modifyState $ \\st -> st { globalVars = MS.empty, varUsages = MS.empty }\n copy <- option False $ do\n string \"!\"\n skip\n return True\n string \"@\"\n name <- parseName1\n args <- option [] $ do\n try $ string \"(\"\n args <- many $ do\n closeWith \")\"\n swallow \",\"\n strict <- option False $ do\n try $ do\n consume \"!\"\n return True\n arg <- parseName1\n return (strict, arg)\n consume \")\"\n return args\n skip\n consume \"=\"\n core <- bindVars (map snd args) parseCore\n return (name, ((copy,args), core))\n\n-- ADT: `data Foo { #Ctr{x0 x1 ...} ... }`\nparseADT :: ParserM ()\nparseADT = do\n string \"data\"\n name <- parseName1\n skip\n consume \"{\"\n constructors <- many parseADTCtr\n consume \"}\"\n registerADT name constructors\n\n-- ADT-Ctr: `#Ctr{x0 x1 ...}`\nparseADTCtr :: ParserM (String, [String])\nparseADTCtr = do\n skip\n consume \"#\"\n name <- parseName1\n st <- getState\n when (MS.member ('#':name) (pCtrToCid st)) $ do\n fail $ \"Constructor '\" ++ name ++ \"' redefined\"\n fields <- option [] $ do\n try $ consume \"{\"\n fds <- many $ do\n closeWith \"}\"\n parseName1\n skip\n consume \"}\"\n return fds\n skip\n return ('#':name, fields)\n\n-- Book: [ADT]\nparseBook :: ParserM [(String, ((Bool, [(Bool,String)]), Core))]\nparseBook = do\n skip\n defs <- many $ do\n def <- choice [parseTopImp, parseTopADT, parseTopDef]\n skip\n return def\n try $ skip >> eof\n return $ concat defs\n\n-- TopADT: ADT\nparseTopADT :: ParserM [(String, ((Bool, [(Bool,String)]), Core))]\nparseTopADT = do\n parseADT\n return []\n\n-- TopDef: Def\nparseTopDef :: ParserM [(String, ((Bool, [(Bool,String)]), Core))]\nparseTopDef = do\n def <- parseDef\n return [def]\n\n-- TopImp: 'import Foo/bar.hvm'\nparseTopImp :: ParserM [(String, ((Bool, [(Bool,String)]), Core))]\nparseTopImp = do\n string \"import\"\n space\n path <- many1 (noneOf \"\\n\\r\")\n st <- getState\n if MS.member path (imported st)\n then return [] -- skip if already imported\n else importFile path\n where\n importFile :: String -> ParserM [(String, ((Bool, [(Bool,String)]), Core))]\n importFile path = do\n modifyState (\\s -> s { imported = MS.insert path () (imported s) })\n contents <- liftIO $ readFile path\n st <- getState\n result <- liftIO $ runParserT parseBookWithState st path contents\n case result of\n Left err -> do\n liftIO $ showParseError path contents err\n fail $ \"Error importing file \" ++ show path ++ \": parse failed\"\n Right (importedDefs, importedState) -> do\n putState importedState\n skip\n return importedDefs\n parseBookWithState :: ParserM ([(String, ((Bool, [(Bool,String)]), Core))], ParserState)\n parseBookWithState = do\n defs <- parseBook\n state <- getState\n return (defs, state)\n\n-- Utils\n-- -----\n\nparseName :: ParserM String\nparseName = skip >> many (alphaNum <|> char '_' <|> char '$' <|> char '&')\n\nparseName1 :: ParserM String\nparseName1 = skip >> many1 (alphaNum <|> char '_' <|> char '$' <|> char '&')\n\nconsume :: String -> ParserM String\nconsume str = skip >> string str\n\nswallow :: String -> ParserM ()\nswallow str = do\n skip\n _ <- optionMaybe $ try (string str)\n return ()\n\ncloseWith :: String -> ParserM ()\ncloseWith str = try $ do\n skip\n notFollowedBy (string str)\n\nskip :: ParserM ()\nskip = skipMany (parseSpace <|> parseComment) where\n parseSpace = (try $ do\n space\n return ()) \"space\"\n parseComment = (try $ do\n string \"//\"\n skipMany (noneOf \"\\n\")\n (char '\\n' >> return ()) <|> eof\n return ()) \"Comment\"\n\nescaped :: ParserM Char\nescaped\n = parseEscapeSequence\n <|> parseUnicodeEscape\n <|> parseRegularChar\n where\n parseEscapeSequence = try $ do\n char '\\\\'\n c <- oneOf \"\\\\\\\"nrtbf0/\\'\"\n return $ case c of\n '\\\\' -> '\\\\'\n '/' -> '/'\n '\"' -> '\"'\n '\\'' -> '\\''\n 'n' -> '\\n'\n 'r' -> '\\r'\n 't' -> '\\t'\n 'b' -> '\\b'\n 'f' -> '\\f'\n '0' -> '\\0'\n parseUnicodeEscape = try $ do\n string \"\\\\u\"\n code <- count 4 hexDigit\n return $ toEnum (read (\"0x\" ++ code) :: Int)\n parseRegularChar = noneOf \"\\\"\\\\\"\n\n-- External API\n-- ------------\n\n-- Parse Book and Core\ndoParseBook :: String -> String -> IO Book\ndoParseBook filePath code = do\n result <- runParserT p (ParserState MS.empty MS.empty MS.empty MS.empty MS.empty MS.empty MS.empty MS.empty 0) \"\" code\n case result of\n Right (defs, st) -> do\n return $ createBook defs (pCtrToCid st) (pCidToCtr st) (pCidToAri st) (pCidToLen st) (pCidToADT st) (pFreshLab st)\n Left err -> do\n showParseError filePath code err\n return $ Book MS.empty MS.empty MS.empty MS.empty MS.empty MS.empty MS.empty MS.empty MS.empty 0\n where\n p = do\n defs <- parseBook\n st <- getState\n return (defs, st)\n\ndoParseCore :: String -> IO Core\ndoParseCore code = do\n result <- runParserT parseCore (ParserState MS.empty MS.empty MS.empty MS.empty MS.empty MS.empty MS.empty MS.empty 0) \"\" code\n case result of\n Right core -> return core\n Left err -> do\n showParseError \"\" code err\n return $ Ref \"⊥\" 0 []\n\ndoParseArguments :: Book -> [String] -> IO [Core]\ndoParseArguments book [] = return []\ndoParseArguments book (arg:args) = do\n (book', core) <- parseArg book arg\n rest <- doParseArguments book' args\n return (core : rest)\n where\n parseArg :: Book -> String -> IO (Book, Core)\n parseArg book arg = do\n let st = ParserState\n { pCidToAri = cidToAri book\n , pCidToLen = cidToLen book\n , pCtrToCid = ctrToCid book\n , pCidToCtr = cidToCtr book\n , pCidToADT = cidToADT book\n , imported = MS.empty\n , varUsages = MS.empty\n , globalVars = MS.empty\n , pFreshLab = freshLab book\n }\n result <- runParserT p st \"\" arg\n case result of\n Right (book, core) -> do\n return (book, core)\n Left err -> do\n showParseError \"\" arg err\n return (book, Ref \"⊥\" 0 [])\n p = do\n core <- parseCore\n st <- getState\n let (book', core') = adjust \"\" (book { freshLab = pFreshLab st }) core []\n return (book', core')\n\n-- Errors\n-- ------\n\nextractExpectedTokens :: ParseError -> String\nextractExpectedTokens err =\n let msgs = errorMessages err\n failMsg = [msg | Message msg <- msgs]\n expectedMsgs = [msg | Expect msg <- msgs, msg /= \"space\", msg /= \"Comment\"]\n in if not (null failMsg)\n then head failMsg\n else if null expectedMsgs\n then \"syntax error\"\n else intercalate \" | \" expectedMsgs\n\nshowParseError :: String -> String -> ParseError -> IO ()\nshowParseError filename input err = do\n let pos = errorPos err\n let lin = sourceLine pos\n let col = sourceColumn pos\n let errorMsg = extractExpectedTokens err\n putStr $ setSGRCode [SetConsoleIntensity BoldIntensity] ++ \"\\nPARSE_ERROR\" ++ setSGRCode [Reset]\n putStr \" (\"\n putStr $ setSGRCode [SetUnderlining SingleUnderline] ++ filename ++ \":\" ++ show lin ++ \":\" ++ show col ++ setSGRCode [Reset]\n putStrLn \")\"\n if any isMessage (errorMessages err)\n then putStrLn $ \"- \" ++ errorMsg\n else do\n putStrLn $ \"- expected: \" ++ errorMsg\n putStrLn $ \"- detected:\"\n putStrLn $ highlightError (lin, col) (lin, col + 1) input\n where\n isMessage (Message _) = True\n isMessage _ = False\n\nparseLog :: String -> ParserM ()\nparseLog msg = do\n pos <- getPosition\n remaining <- getInput\n let preview = \"[[[\" ++ Data.List.take 20 remaining ++ (if length remaining > 20 then \"...\" else \"\") ++ \"]]]\"\n trace (\"[\" ++ show pos ++ \"] \" ++ msg ++ \"\\nRemaining code: \" ++ preview) $ return ()\n\n-- Book\n-- ----\n\n-- Register the parsed ADT in the parser state\nregisterADT :: String -> [(String, [String])] -> ParserM ()\nregisterADT name constructors = do\n st <- getState\n let baseCid = fromIntegral $ MS.size (pCtrToCid st)\n let ctrToCid = zip (map fst constructors) [baseCid..]\n let cidToCtr = map (\\ (ctr,cid) -> (cid, ctr)) ctrToCid\n let cidToAri = map (\\ (ctr,cid) -> (cid, fromIntegral . length . snd $ head $ filter ((== ctr) . fst) constructors)) ctrToCid\n let cidToLen = (baseCid, fromIntegral $ length constructors)\n let cidToADT = map (\\ (_,cid) -> (cid, baseCid)) ctrToCid\n modifyState (\\s -> s {\n pCtrToCid = MS.union (MS.fromList ctrToCid) (pCtrToCid s),\n pCidToCtr = MS.union (MS.fromList cidToCtr) (pCidToCtr s),\n pCidToAri = MS.union (MS.fromList cidToAri) (pCidToAri s),\n pCidToLen = MS.insert (fst cidToLen) (snd cidToLen) (pCidToLen s),\n pCidToADT = MS.union (MS.fromList cidToADT) (pCidToADT s) })\n\n-- Book creation and setup functions\ncreateBook :: [(String, ((Bool,[(Bool,String)]), Core))] -> MS.Map String Word16 -> MS.Map Word16 String -> MS.Map Word16 Word16 -> MS.Map Word16 Word16 -> MS.Map Word16 Word16 -> Lab -> Book\ncreateBook defs ctrToCid cidToCtr cidToAri cidToLen cidToADT freshLab =\n let withPrims = \\n2i -> MS.union n2i (MS.fromList primitives)\n nameList = zip (map fst defs) [0..] :: [(String, Word16)]\n namToFid' = withPrims (MS.fromList nameList)\n fidToNam' = MS.fromList (map (\\(k,v) -> (v,k)) (MS.toList namToFid'))\n fidToFun' = MS.fromList (map (\\(nam, func) -> (mget namToFid' nam, func)) defs)\n fidToLab' = MS.fromList (map (\\(nam, ((_, _), cr)) -> (mget namToFid' nam, collectLabels cr)) defs) in\n let book = Book\n { fidToFun = fidToFun'\n , fidToNam = fidToNam'\n , fidToLab = fidToLab'\n , namToFid = namToFid'\n , cidToAri = cidToAri\n , cidToCtr = cidToCtr\n , ctrToCid = ctrToCid\n , cidToLen = cidToLen\n , cidToADT = cidToADT\n , freshLab = freshLab\n } in\n adjustBook book\n\n-- Binding\n-- -------\n\n-- Strip the & prefix from a non-linear variable name\n-- e.g., \"&x\" -> \"x\", \"x\" -> \"x\"\nstripName :: String -> String\nstripName var = if not (null var) && head var == '&' then tail var else var\n\nbindVars :: [String] -> ParserM Core -> ParserM Core\nbindVars vars parse = do\n st <- getState\n let prev = varUsages st\n -- Split into scopeless vars (starting with $) and regular vars\n let (svars, rvars) = partition (\\v -> head v == '$') vars\n forM_ svars bindScopeless\n -- Add bindings for regular vars\n let tmp = MS.fromList [(stripName var, 0) | var <- rvars]\n modifyState (\\st -> st {varUsages = MS.union tmp prev})\n body <- parse\n forM_ rvars checkLinear\n -- Restore the original state for regular vars\n modifyState (\\st -> st {varUsages = MS.union (MS.difference (varUsages st) tmp) prev})\n return body\n where\n bindScopeless var = do\n st <- getState\n case MS.lookup var (globalVars st) of\n Just _ -> fail $ \"Global variable \" ++ show var ++ \" already bound\"\n Nothing -> putState st {globalVars = MS.insert var () (globalVars st)}\n\n checkLinear var = do\n st <- getState\n let uses = mget (varUsages st) (stripName var)\n if (head var /= '&') && uses > 1 then\n fail $ \"Linear variable \" ++ show var ++ \" used \" ++ show uses ++ \" times\"\n else return ()\n\nuseVar :: String -> ParserM ()\nuseVar name = do\n st <- getState\n case (head name, MS.lookup name (varUsages st)) of\n ('$', Nothing) -> do -- $-vars can be used before definition\n putState st {varUsages = MS.insert name 1 (varUsages st)}\n (_, Nothing) -> do\n fail $ \"Unbound variable \" ++ show name\n (_, Just uses) -> do\n putState st {varUsages = MS.insert name (uses + 1) (varUsages st)}\n\n-- Utils\n-- -------------------\n\ngenFreshLabel :: ParserM Lab\ngenFreshLabel = do\n st <- getState\n let lbl = pFreshLab st\n putState st { pFreshLab = lbl + 1 }\n when (lbl > 0x7FFF) $ do\n error \"Label overflow: generated label would be too large\"\n return $ lbl + 0x8000\n\n-- Collects all labels used\ncollectLabels :: Core -> MS.Map Lab ()\ncollectLabels term = case term of\n Var _ -> MS.empty\n U32 _ -> MS.empty\n Chr _ -> MS.empty\n Era -> MS.empty\n Ref _ _ args -> MS.unions $ map collectLabels args\n Let _ _ val bod -> MS.union (collectLabels val) (collectLabels bod)\n Lam _ bod -> collectLabels bod\n App fun arg -> MS.union (collectLabels fun) (collectLabels arg)\n Sup lab tm0 tm1 -> MS.insert lab () $ MS.union (collectLabels tm0) (collectLabels tm1)\n Dup lab _ _ val bod -> MS.insert lab () $ MS.union (collectLabels val) (collectLabels bod)\n Ctr _ fds -> MS.unions $ map collectLabels fds\n Mat kin val mov css -> MS.unions $ collectLabels val : map (collectLabels . snd) mov ++ map (\\(_,_,bod) -> collectLabels bod) css\n Op2 _ x y -> MS.union (collectLabels x) (collectLabels y)\n Inc x -> collectLabels x\n Dec x -> collectLabels x\n\n-- Build match expression based on case types\nbuildMatchExpr :: Core -> [(String, Core)] -> [(String, [String], Core)] -> ParserM Core\nbuildMatchExpr val mov cases\n | null cases = \n fail \"Match needs at least one case\"\n | isSwitch (head cases) = \n return $ Mat SWI val mov cases -- Switch case\n | onlyDefault cases =\n fail \"Match with only a default case is not allowed\" -- Invalid case\n | hasDefault (last cases) = do -- Has default: use If-Let chain\n var <- return $ getVar (last cases)\n ifl <- intoIfLetChain (Var (stripName var)) mov (init cases) var (last cases)\n return $ Let LAZY var val ifl\n | otherwise = do -- All ADT cases covered\n st <- getState\n let ctrs = map getName cases\n let cids = map (mget (pCtrToCid st)) ctrs\n let adt = mget (pCidToADT st) (head cids)\n let len = mget (pCidToLen st) adt\n let miss = filter (\\c -> not (c `elem` cids)) [adt..adt+len-1]\n case miss of\n [] -> return $ Mat (MAT adt) val mov cases\n _ -> fail $ \"Missing match cases: \" ++ show (map (mget (pCidToCtr st)) miss)\n where\n isSwitch (name, _, _) = name == \"0\"\n hasDefault (name, _, _) = name == \"_\"\n onlyDefault cases = length cases == 1 && hasDefault (head cases)\n getName (name, _, _) = name\n getVar (_, [v], _) = v\n\nintoIfLetChain :: Core -> [(String, Core)] -> [(String, [String], Core)] -> String -> (String, [String], Core) -> ParserM Core\nintoIfLetChain _ _ [] defName (_,_,defBody) = return defBody\nintoIfLetChain val mov ((ctr,fds,bod):css) defName defCase = do\n st <- getState\n kin <- return $ IFL (mget (pCtrToCid st) ctr)\n rec <- intoIfLetChain val mov css defName defCase\n css <- return $ [(ctr, fds, bod), (\"_\", [defName], rec)]\n return $ Mat kin val mov css\n" }, { "path": "src/HVM/Reduce.hs", "content": "{-./Type.hs-}\n{-./Foreign.hs-}\n\n-- NOTE: THIS FILE IS MISSING HTE INC/DEC INTERACTIONS. LET'S FIX IT\n\nmodule HVM.Reduce where\n\nimport Control.Monad (when, forM, forM_)\nimport Data.Word\nimport HVM.Collapse\nimport HVM.Extract\nimport HVM.Foreign\nimport HVM.Inject\nimport HVM.Type\nimport System.Exit\nimport qualified Data.Map.Strict as MS\n\nreduceAt :: Bool -> ReduceAt\n\nreduceAt debug book host = do \n term <- got host\n let tag = termTag term\n let lab = termLab term\n let loc = termLoc term\n\n when debug $ do\n root <- doExtractCoreAt gotT book 0\n core <- doExtractCoreAt gotT book host\n putStrLn $ \"reduce: \" ++ showTerm term\n -- putStrLn $ \"---------------- CORE: \"\n -- putStrLn $ showCore core\n putStrLn $ \"---------------- ROOT: \"\n putStrLn $ showCore (doLiftDups root)\n\n case tag of\n t | t == _LET_ -> do\n case modeT lab of\n LAZY -> do\n val <- got (loc + 0)\n cont host (reduceLet term val)\n STRI -> do\n val <- reduceAt debug book (loc + 0)\n cont host (reduceLet term val)\n\n t | t == _APP_ -> do\n fun <- reduceAt debug book (loc + 0)\n case termTag fun of\n t | t == _ERA_ -> cont host (reduceAppEra term fun)\n t | t == _LAM_ -> cont host (reduceAppLam term fun)\n t | t == _SUP_ -> cont host (reduceAppSup term fun)\n t | t == _CTR_ -> cont host (reduceAppCtr term fun)\n t | t == _W32_ -> cont host (reduceAppW32 term fun)\n t | t == _CHR_ -> cont host (reduceAppW32 term fun)\n t | t == _INC_ -> cont host (reduceAppInc term fun)\n t | t == _DEC_ -> cont host (reduceAppDec term fun)\n _ -> set (loc + 0) fun >> return term\n\n t | t == _MAT_ -> do\n val <- reduceAt debug book (loc + 0)\n case termTag val of\n t | t == _ERA_ -> cont host (reduceMatEra term val)\n t | t == _LAM_ -> cont host (reduceMatLam term val)\n t | t == _SUP_ -> cont host (reduceMatSup term val)\n t | t == _CTR_ -> cont host (reduceMatCtr term val)\n t | t == _W32_ -> cont host (reduceMatW32 term val)\n t | t == _CHR_ -> cont host (reduceMatW32 term val)\n t | t == _INC_ -> cont host (reduceMatInc term val)\n t | t == _DEC_ -> cont host (reduceMatDec term val)\n _ -> set (loc + 0) val >> return term\n\n t | t == _IFL_ -> do\n val <- reduceAt debug book (loc + 0)\n case termTag val of\n t | t == _ERA_ -> cont host (reduceMatEra term val)\n t | t == _LAM_ -> cont host (reduceMatLam term val)\n t | t == _SUP_ -> cont host (reduceMatSup term val)\n t | t == _CTR_ -> cont host (reduceMatCtr term val)\n t | t == _W32_ -> cont host (reduceMatW32 term val)\n t | t == _CHR_ -> cont host (reduceMatW32 term val)\n t | t == _INC_ -> cont host (reduceMatInc term val)\n t | t == _DEC_ -> cont host (reduceMatDec term val)\n _ -> set (loc + 0) val >> return term\n\n t | t == _SWI_ -> do\n val <- reduceAt debug book (loc + 0)\n case termTag val of\n t | t == _ERA_ -> cont host (reduceMatEra term val)\n t | t == _LAM_ -> cont host (reduceMatLam term val)\n t | t == _SUP_ -> cont host (reduceMatSup term val)\n t | t == _CTR_ -> cont host (reduceMatCtr term val)\n t | t == _W32_ -> cont host (reduceMatW32 term val)\n t | t == _CHR_ -> cont host (reduceMatW32 term val)\n t | t == _INC_ -> cont host (reduceMatInc term val)\n t | t == _DEC_ -> cont host (reduceMatDec term val)\n _ -> set (loc + 0) val >> return term\n\n t | t == _OPX_ -> do\n val <- reduceAt debug book (loc + 0)\n case termTag val of\n t | t == _ERA_ -> cont host (reduceOpxEra term val)\n t | t == _LAM_ -> cont host (reduceOpxLam term val)\n t | t == _SUP_ -> cont host (reduceOpxSup term val)\n t | t == _CTR_ -> cont host (reduceOpxCtr term val)\n t | t == _W32_ -> cont host (reduceOpxW32 term val)\n t | t == _CHR_ -> cont host (reduceOpxW32 term val)\n t | t == _INC_ -> cont host (reduceOpxInc term val)\n t | t == _DEC_ -> cont host (reduceOpxDec term val)\n _ -> set (loc + 0) val >> return term\n\n t | t == _OPY_ -> do\n val <- reduceAt debug book (loc + 0)\n case termTag val of\n t | t == _ERA_ -> cont host (reduceOpyEra term val)\n t | t == _LAM_ -> cont host (reduceOpyLam term val)\n t | t == _SUP_ -> cont host (reduceOpySup term val)\n t | t == _CTR_ -> cont host (reduceOpyCtr term val)\n t | t == _W32_ -> cont host (reduceOpyW32 term val)\n t | t == _CHR_ -> cont host (reduceOpyW32 term val)\n t | t == _INC_ -> cont host (reduceOpyInc term val)\n t | t == _DEC_ -> cont host (reduceOpyDec term val)\n _ -> set (loc + 0) val >> return term\n\n t | t == _DP0_ -> do\n sb0 <- got (loc + 0)\n if termGetBit sb0 == 0\n then do\n val <- reduceAt debug book (loc + 0)\n case termTag val of\n t | t == _ERA_ -> cont host (reduceDupEra term val)\n t | t == _LAM_ -> cont host (reduceDupLam term val)\n t | t == _SUP_ -> cont host (reduceDupSup term val)\n t | t == _CTR_ -> cont host (reduceDupCtr term val)\n t | t == _W32_ -> cont host (reduceDupW32 term val)\n t | t == _CHR_ -> cont host (reduceDupW32 term val)\n t | t == _INC_ -> cont host (reduceDupInc term val)\n t | t == _DEC_ -> cont host (reduceDupDec term val)\n _ -> set (loc + 0) val >> return term\n else do\n set host (termRemBit sb0)\n reduceAt debug book host\n\n t | t == _DP1_ -> do\n sb1 <- got (loc + 0)\n if termGetBit sb1 == 0\n then do\n val <- reduceAt debug book (loc + 0)\n case termTag val of\n t | t == _ERA_ -> cont host (reduceDupEra term val)\n t | t == _LAM_ -> cont host (reduceDupLam term val)\n t | t == _SUP_ -> cont host (reduceDupSup term val)\n t | t == _CTR_ -> cont host (reduceDupCtr term val)\n t | t == _W32_ -> cont host (reduceDupW32 term val)\n t | t == _CHR_ -> cont host (reduceDupW32 term val)\n t | t == _INC_ -> cont host (reduceDupInc term val)\n t | t == _DEC_ -> cont host (reduceDupDec term val)\n _ -> set (loc + 0) val >> return term\n else do\n set host (termRemBit sb1)\n reduceAt debug book host\n\n t | t == _VAR_ -> do\n sub <- got (loc + 0)\n if termGetBit sub == 0\n then return term\n else do\n set host (termRemBit sub)\n reduceAt debug book host\n\n t | t == _REF_ -> do\n reduceRefAt book host\n reduceAt debug book host\n\n _ -> do\n return term\n\n where\n cont host action = do\n ret <- action\n set host ret\n reduceAt debug book host\n\ngotT :: Book -> Loc -> HVM Term\ngotT book host = got host\n\nreduceRefAt :: Book -> Loc -> HVM Term\nreduceRefAt book host = do\n term <- got host\n let lab = termLab term\n let loc = termLoc term\n let fid = fromIntegral lab\n let ari = funArity book fid\n case lab of\n x | x == _DUP_F_ -> reduceRefAt_DupF book host loc ari\n x | x == _SUP_F_ -> reduceRefAt_SupF book host loc ari\n x | x == _LOG_F_ -> reduceRefAt_LogF book host loc ari\n otherwise -> case MS.lookup fid (fidToFun book) of\n Just ((copy, args), core) -> do\n incItr\n when (length args /= fromIntegral ari) $ do\n putStrLn $ \"RUNTIME_ERROR: arity mismatch on call to '@\" ++ mget (fidToNam book) fid ++ \"'.\"\n exitFailure\n argTerms <- if ari == 0\n then return []\n else forM (zip [0..] args) $ \\(i, (strict, _)) -> do\n term <- got (loc + i)\n if strict\n then reduceAt False book (loc + i)\n else return term\n doInjectCoreAt book core host $ zip (map snd args) argTerms\n Nothing -> do\n putStrLn $ \"RUNTIME_ERROR: Function ID \" ++ show fid ++ \" not found in fidToFun book.\"\n exitFailure\n\n-- Primitive: Dynamic Dup `@DUP(lab val λdp0λdp1(bod))`\nreduceRefAt_DupF :: Book -> Loc -> Loc -> Word16 -> HVM Term \nreduceRefAt_DupF book host loc ari = do\n incItr\n when (ari /= 3) $ do\n putStrLn $ \"RUNTIME_ERROR: arity mismatch on call to '@DUP'.\"\n exitFailure\n lab <- reduceAt False book (loc + 0)\n val <- got (loc + 1)\n bod <- got (loc + 2)\n dup <- allocNode 1\n case termTag lab of\n t | t == _W32_ -> do\n when (termLoc lab > 0xFFFF) $ do\n error \"RUNTIME_ERROR: dynamic DUP label too large\"\n -- Create the DUP node with value\n set (dup + 0) val\n -- Create first APP node for (APP bod DP0)\n app1 <- allocNode 2\n set (app1 + 0) bod\n set (app1 + 1) (termNew _DP0_ (fromIntegral (termLoc lab)) dup)\n -- Create second APP node for (APP (APP bod DP0) DP1)\n app2 <- allocNode 2\n set (app2 + 0) (termNew _APP_ 0 app1)\n set (app2 + 1) (termNew _DP1_ (fromIntegral (termLoc lab)) dup)\n let ret = termNew _APP_ 0 app2\n set host ret\n return ret\n _ -> do\n core <- doExtractCoreAt gotT book (loc + 0)\n putStrLn $ \"RUNTIME_ERROR: dynamic DUP without numeric label: \" ++ showTerm lab\n putStrLn $ showCore (doLiftDups core)\n exitFailure\n\n-- Primitive: Dynamic Sup `@SUP(lab tm0 tm1)`\nreduceRefAt_SupF :: Book -> Loc -> Loc -> Word16 -> HVM Term\nreduceRefAt_SupF book host loc ari = do\n incItr\n when (ari /= 3) $ do\n putStrLn $ \"RUNTIME_ERROR: arity mismatch on call to '@SUP'.\"\n exitFailure\n lab <- reduceAt False book (loc + 0)\n tm0 <- got (loc + 1)\n tm1 <- got (loc + 2)\n sup <- allocNode 2\n case termTag lab of\n t | t == _W32_ -> do\n when (termLoc lab > 0xFFFF) $ do\n error \"RUNTIME_ERROR: dynamic SUP label too large\"\n let ret = termNew _SUP_ (fromIntegral (termLoc lab)) sup\n set (sup + 0) tm0\n set (sup + 1) tm1\n set host ret\n return ret\n _ -> error \"RUNTIME_ERROR: dynamic SUP without numeric label.\"\n\n-- Primitive: Logger `@LOG(msg)`\n-- Will extract the term and log it. \n-- Returns 0.\nreduceRefAt_LogF :: Book -> Loc -> Loc -> Word16 -> HVM Term\nreduceRefAt_LogF book host loc ari = do\n incItr\n when (ari /= 1) $ do\n putStrLn $ \"RUNTIME_ERROR: arity mismatch on call to '@LOG'.\"\n exitFailure\n msg <- doExtractCoreAt (reduceAt False) book (loc + 0)\n putStrLn $ showCore msg\n -- msgs <- doCollapseFlatAt gotT book (loc + 0)\n -- forM_ msgs $ \\msg -> do\n -- putStrLn $ showCore msg\n let ret = termNew _W32_ 0 0\n set host ret\n return ret\n\n-- Primitive: Fresh `@FRESH`\n-- Returns a fresh dup label.\nreduceRefAt_FreshF :: Book -> Loc -> Loc -> Word16 -> HVM Term\nreduceRefAt_FreshF book host loc ari = do\n incItr\n when (ari /= 0) $ do\n putStrLn $ \"RUNTIME_ERROR: arity mismatch on call to '@Fresh'.\"\n exitFailure\n num <- fromIntegral <$> fresh\n let ret = termNew _W32_ 0 num\n set host ret\n return ret\n\nreduceCAt :: Bool -> ReduceAt\nreduceCAt = \\ _ _ host -> reduceAtC host\n" }, { "path": "src/HVM/Runtime.c", "content": "#include \"Runtime.h\"\n\n// Single translation unit aggregator for the C runtime.\n// Keeping hot paths in one TU restores inlining and performance.\n\n// Core state and memory\n#include \"runtime/state.c\"\n#include \"runtime/memory.c\"\n\n// Heap, terms, stack, and debug printing\n#include \"runtime/heap.c\"\n#include \"runtime/term.c\"\n#include \"runtime/stack.c\"\n#include \"runtime/print.c\"\n\n// Reductions dispatcher and helpers\n#include \"runtime/reduce.c\"\n\n// Interaction rules, grouped by tag\n#include \"runtime/reduce/let.c\"\n\n// APP\n#include \"runtime/reduce/app_era.c\"\n#include \"runtime/reduce/app_lam.c\"\n#include \"runtime/reduce/app_sup.c\"\n#include \"runtime/reduce/app_ctr.c\"\n#include \"runtime/reduce/app_w32.c\"\n#include \"runtime/reduce/app_una.c\"\n\n// DUP\n#include \"runtime/reduce/dup_era.c\"\n#include \"runtime/reduce/dup_lam.c\"\n#include \"runtime/reduce/dup_sup.c\"\n#include \"runtime/reduce/dup_ctr.c\"\n#include \"runtime/reduce/dup_w32.c\"\n#include \"runtime/reduce/dup_ref.c\"\n#include \"runtime/reduce/dup_una.c\"\n\n// MAT / IFL / SWI\n#include \"runtime/reduce/mat_era.c\"\n#include \"runtime/reduce/mat_lam.c\"\n#include \"runtime/reduce/mat_sup.c\"\n#include \"runtime/reduce/mat_ctr.c\"\n#include \"runtime/reduce/mat_w32.c\"\n#include \"runtime/reduce/mat_una.c\"\n\n// OPX/OPY\n#include \"runtime/reduce/opx_era.c\"\n#include \"runtime/reduce/opx_lam.c\"\n#include \"runtime/reduce/opx_sup.c\"\n#include \"runtime/reduce/opx_ctr.c\"\n#include \"runtime/reduce/opx_w32.c\"\n#include \"runtime/reduce/opx_una.c\"\n#include \"runtime/reduce/opy_era.c\"\n#include \"runtime/reduce/opy_lam.c\"\n#include \"runtime/reduce/opy_sup.c\"\n#include \"runtime/reduce/opy_ctr.c\"\n#include \"runtime/reduce/opy_w32.c\"\n#include \"runtime/reduce/opy_una.c\"\n\n// Primitives\n#include \"runtime/prim/SUP.c\"\n#include \"runtime/prim/DUP.c\"\n#include \"runtime/prim/LOG.c\"\n" }, { "path": "src/HVM/Runtime.h", "content": "// Shared runtime declarations for HVM C runtime\n#pragma once\n\n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n\n// mmap portability helpers (e.g., macOS)\n#ifndef MAP_ANONYMOUS\n# ifdef MAP_ANON\n# define MAP_ANONYMOUS MAP_ANON\n# else\n# define MAP_ANONYMOUS 0\n# endif\n#endif\n#ifndef MAP_NORESERVE\n# define MAP_NORESERVE 0\n#endif\n\n// Limits\n#define MAX_HEAP_SIZE (1ULL << 40)\n#define MAX_STACK_SIZE (1ULL << 28)\n\n// Basic types\ntypedef uint8_t Tag;\ntypedef uint16_t Lab; // 16-bit label (fits 65536 ctors/ops)\ntypedef uint64_t Loc; // up to 40-bit heap index in term payload\ntypedef uint64_t Term;\ntypedef uint16_t u16;\ntypedef uint32_t u32;\ntypedef uint64_t u64;\n\n// Constants (tags)\n#define DP0 0x00\n#define DP1 0x01\n#define VAR 0x02\n#define SUB 0x03\n#define REF 0x04\n#define LET 0x05\n#define APP 0x06\n#define MAT 0x08\n#define IFL 0x09\n#define SWI 0x0A\n#define OPX 0x0B\n#define OPY 0x0C\n#define ERA 0x0D\n#define LAM 0x0E\n#define SUP 0x0F\n#define CTR 0x10\n#define W32 0x11\n#define CHR 0x12\n#define INC 0x13\n#define DEC 0x14\n\n// Operators\n#define OP_ADD 0x00\n#define OP_SUB 0x01\n#define OP_MUL 0x02\n#define OP_DIV 0x03\n#define OP_MOD 0x04\n#define OP_EQ 0x05\n#define OP_NE 0x06\n#define OP_LT 0x07\n#define OP_GT 0x08\n#define OP_LTE 0x09\n#define OP_GTE 0x0A\n#define OP_AND 0x0B\n#define OP_OR 0x0C\n#define OP_XOR 0x0D\n#define OP_LSH 0x0E\n#define OP_RSH 0x0F\n\n// Builtin function ids\n#define DUP_F 0xFFFF\n#define SUP_F 0xFFFE\n#define LOG_F 0xFFFD\n\n// Let flavours\n#define LAZY 0x0\n#define STRI 0x1\n\n#define VOID 0x00000000000000ULL\n\n// Runtime State\ntypedef struct {\n Term* sbuf; // reduction stack buffer\n u64* spos; // reduction stack position\n Term* heap; // global node buffer\n u64* size; // global node buffer position\n u64* itrs; // interaction count\n u64* frsh; // fresh dup label count\n Term (*book[65536])(Term); // functions\n u16 cari[65536]; // arity of each constructor\n u16 clen[65536]; // case length of each constructor\n u16 cadt[65536]; // ADT id of each constructor\n u16 fari[65536]; // arity of each function\n} State;\n\n// Global runtime state\nextern State HVM;\n\n// Heap controls\nvoid set_len(u64 size);\nvoid set_itr(u64 itrs);\nu64 get_len();\nu64 get_itr();\nu64 fresh();\n\n// Term helpers\nTerm term_new(Tag tag, Lab lab, Loc loc);\nTag term_tag(Term x);\nLab term_lab(Term x);\nLoc term_loc(Term x);\nu64 term_get_bit(Term x);\nTerm term_set_bit(Term term);\nTerm term_rem_bit(Term term);\nTerm term_set_loc(Term x, Loc loc);\n_Bool term_is_atom(Term term);\n\n// Heap read/write\nTerm swap(Loc loc, Term term);\nTerm got(Loc loc);\nvoid set(Loc loc, Term term);\nvoid sub(Loc loc, Term term);\nTerm take(Loc loc);\n\n// Allocation and accounting\nLoc alloc_node(Loc arity);\nvoid inc_itr();\n\n// Stack\nvoid spush(Term term, Term* sbuf, u64* spos);\nTerm spop(Term* sbuf, u64* spos);\n\n// Debug printing\nvoid print_tag(Tag tag);\nvoid print_term(Term term);\nvoid print_heap();\n\n// Reductions (public API)\nTerm reduce(Term term);\nTerm reduce_at(Loc host);\nTerm normal(Term term);\n\n// Interaction functions\nTerm reduce_ref_sup(Term ref, u16 idx);\nTerm reduce_ref(Term ref);\nTerm reduce_let(Term let, Term val);\n\n// APP\nTerm reduce_app_era(Term app, Term era);\nTerm reduce_app_lam(Term app, Term lam);\nTerm reduce_app_sup(Term app, Term sup);\nTerm reduce_app_ctr(Term app, Term ctr);\nTerm reduce_app_w32(Term app, Term w32);\nTerm reduce_app_una(Term app, Term una, Tag tag);\nTerm reduce_app_inc(Term app, Term inc);\nTerm reduce_app_dec(Term app, Term dec);\n\n// DUP\nTerm reduce_dup_era(Term dup, Term era);\nTerm reduce_dup_lam(Term dup, Term lam);\nTerm reduce_dup_sup(Term dup, Term sup);\nTerm reduce_dup_ctr(Term dup, Term ctr);\nTerm reduce_dup_w32(Term dup, Term w32);\nTerm reduce_dup_ref(Term dup, Term ref);\nTerm reduce_dup_una(Term dup, Term una, Tag tag);\nTerm reduce_dup_inc(Term dup, Term inc);\nTerm reduce_dup_dec(Term dup, Term dec);\n\n// MAT\nTerm reduce_mat_era(Term mat, Term era);\nTerm reduce_mat_lam(Term mat, Term lam);\nTerm reduce_mat_sup(Term mat, Term sup);\nTerm reduce_mat_ctr(Term mat, Term ctr);\nTerm reduce_mat_w32(Term mat, Term w32);\nTerm reduce_mat_una(Term mat, Term una, Tag tag);\nTerm reduce_mat_inc(Term mat, Term inc);\nTerm reduce_mat_dec(Term mat, Term dec);\n\n// OPX\nTerm reduce_opx_era(Term opx, Term era);\nTerm reduce_opx_lam(Term opx, Term lam);\nTerm reduce_opx_sup(Term opx, Term sup);\nTerm reduce_opx_ctr(Term opx, Term ctr);\nTerm reduce_opx_w32(Term opx, Term nmx);\nTerm reduce_opx_una(Term opx, Term una, Tag tag);\nTerm reduce_opx_inc(Term opx, Term inc);\nTerm reduce_opx_dec(Term opx, Term dec);\n\n// OPY\nTerm reduce_opy_era(Term opy, Term era);\nTerm reduce_opy_lam(Term opy, Term lam);\nTerm reduce_opy_sup(Term opy, Term sup);\nTerm reduce_opy_ctr(Term opy, Term ctr);\nTerm reduce_opy_w32(Term opy, Term w32);\nTerm reduce_opy_una(Term opy, Term una, Tag tag);\nTerm reduce_opy_inc(Term opy, Term inc);\nTerm reduce_opy_dec(Term opy, Term dec);\n\n// Primitives\nTerm SUP_f(Term ref);\nTerm DUP_f(Term ref);\nTerm LOG_f(Term ref);\n\n// Runtime memory API\nvoid hvm_init();\nvoid hvm_free();\nState* hvm_get_state();\nvoid hvm_set_state(State* hvm);\nvoid hvm_define(u16 fid, Term (*func)());\nvoid hvm_set_cari(u16 cid, u16 arity);\nvoid hvm_set_fari(u16 fid, u16 arity);\nvoid hvm_set_clen(u16 cid, u16 cases);\nvoid hvm_set_cadt(u16 cid, u16 adt);\n" }, { "path": "src/HVM/Type.hs", "content": "module HVM.Type where\n\nimport Data.Word\nimport Foreign.Ptr\n\nimport Control.Applicative ((<|>))\nimport Control.DeepSeq\nimport Control.Monad (forM)\nimport Data.Char (chr, ord)\nimport Data.Char (intToDigit)\nimport Data.IORef\nimport Data.List\nimport Data.Word\nimport GHC.Stack (HasCallStack)\nimport Numeric (showIntAtBase)\nimport System.IO.Unsafe (unsafePerformIO)\nimport qualified Data.Map.Strict as MS\n\n-- Core Types\n-- ----------\n\ntype Tag = Word8\ntype Lab = Word16\ntype Loc = Word64\ntype Term = Word64\n\ntype Name = String\ntype Move = (Name, Core) -- !x = term\ntype Case = (Name, [Name], Core) -- #Ctr{x0 x1...}: fn\n\ndata LetT = LAZY | STRI deriving (Eq, Enum)\ndata MatT = SWI | MAT Word16 | IFL Word16 deriving (Show, Eq)\n\ndata Core\n = Var Name -- x\n | Ref Name Word16 [Core] -- @fn\n | Era -- *\n | Lam Name Core -- λx(F)\n | App Core Core -- (f x)\n | Sup Lab Core Core -- &L{a b}\n | Dup Lab Name Name Core Core -- ! &L{a b} = v body\n | Ctr Name [Core] -- #Ctr{a b ...}\n | U32 Word32 -- 123\n | Chr Char -- 'a'\n | Op2 Oper Core Core -- (+ a b)\n | Let LetT Name Core Core -- ! x = v body\n | Mat MatT Core [Move] [Case] -- ~ v !moves { cases }\n | Inc Core -- ↑ x\n | Dec Core -- ↓ x\n deriving (Eq)\n\ndata Oper\n = OP_ADD | OP_SUB | OP_MUL | OP_DIV\n | OP_MOD | OP_EQ | OP_NE | OP_LT\n | OP_GT | OP_LTE | OP_GTE | OP_AND\n | OP_OR | OP_XOR | OP_LSH | OP_RSH\n deriving (Eq, Enum)\n\n-- A top-level function, including:\n-- - copy: true when ref-copy mode is enabled\n-- - args: a list of (isArgStrict, argName) pairs\n-- - core: the function's body\n-- Note: ref-copy improves C speed, but increases interaction count\ntype Func = ((Bool, [(Bool,String)]), Core)\n\n-- Set of labels in a function's body\ntype HasLab = (MS.Map Lab ())\n\ndata Book = Book\n { fidToFun :: MS.Map Word16 Func -- func id to Func object\n , fidToLab :: MS.Map Word16 HasLab -- func id to dup labels used\n , fidToNam :: MS.Map Word16 Name -- func id to name\n , namToFid :: MS.Map Name Word16 -- func name to id\n , cidToAri :: MS.Map Word16 Word16 -- ctor id to field count (arity)\n , cidToLen :: MS.Map Word16 Word16 -- ctor id to cases length (ADT ctors)\n , cidToCtr :: MS.Map Word16 Name -- ctor id to name\n , ctrToCid :: MS.Map Name Word16 -- ctor name to id\n , cidToADT :: MS.Map Word16 Word16 -- ctor id to ADT id (first ADT cid)\n , freshLab :: Lab -- auto dup label counter\n } deriving (Show, Eq)\n\n-- Runtime Types\n-- -------------\n\ntype HVM = IO\ntype ReduceAt = Book -> Loc -> HVM Term\n\n-- Constants\n-- ---------\n\n-- Tags\n_DP0_ = 0x00 :: Tag\n_DP1_ = 0x01 :: Tag\n_VAR_ = 0x02 :: Tag\n_FWD_ = 0x03 :: Tag\n_REF_ = 0x04 :: Tag\n_LET_ = 0x05 :: Tag\n_APP_ = 0x06 :: Tag\n_MAT_ = 0x08 :: Tag\n_IFL_ = 0x09 :: Tag\n_SWI_ = 0x0A :: Tag\n_OPX_ = 0x0B :: Tag\n_OPY_ = 0x0C :: Tag\n_ERA_ = 0x0D :: Tag\n_LAM_ = 0x0E :: Tag\n_SUP_ = 0x0F :: Tag\n_CTR_ = 0x10 :: Tag\n_W32_ = 0x11 :: Tag\n_CHR_ = 0x12 :: Tag\n_INC_ = 0x13 :: Tag\n_DEC_ = 0x14 :: Tag\n\n-- Let Types\nmodeT :: Lab -> LetT\nmodeT 0x00 = LAZY\nmodeT 0x01 = STRI\nmodeT mode = error $ \"unknown mode: \" ++ show mode\n\n-- Primitive Functions\n_DUP_F_ = 0xFFFF :: Lab\n_SUP_F_ = 0xFFFE :: Lab\n_LOG_F_ = 0xFFFD :: Lab\n\nprimitives :: [(String, Word16)]\nprimitives =\n [ (\"SUP\", fromIntegral _SUP_F_)\n , (\"DUP\", fromIntegral _DUP_F_)\n , (\"LOG\", fromIntegral _LOG_F_)\n ]\n\n-- Utils\n-- -----\n\n-- Getter function for maps\nmget :: (Ord k, Show k, HasCallStack) => MS.Map k a -> k -> a\nmget map key =\n case MS.lookup key map of\n Just val -> val\n Nothing -> error $ \"key not found: \" ++ show key\n\nfunArity :: Book -> Word16 -> Word16\nfunArity book fid\n | fid == fromIntegral _SUP_F_ = 3\n | fid == fromIntegral _DUP_F_ = 3\n | fid == fromIntegral _LOG_F_ = 1\n | otherwise = case MS.lookup fid (fidToFun book) of\n Just ((_, args), _) -> fromIntegral (length args)\n Nothing -> error $ \"Function ID not found: \" ++ show fid\n\ninstance NFData Core where\n rnf (Var k) = rnf k\n rnf (Ref k i xs) = rnf k `seq` rnf i `seq` rnf xs\n rnf Era = ()\n rnf (Lam x f) = rnf x `seq` rnf f\n rnf (App f x) = rnf f `seq` rnf x\n rnf (Sup l a b) = rnf l `seq` rnf a `seq` rnf b\n rnf (Dup l x y v f) = rnf l `seq` rnf x `seq` rnf y `seq` rnf v `seq` rnf f\n rnf (Ctr k xs) = rnf k `seq` rnf xs\n rnf (U32 v) = rnf v\n rnf (Chr v) = rnf v\n rnf (Op2 o a b) = o `seq` rnf a `seq` rnf b\n rnf (Let m k v f) = m `seq` rnf k `seq` rnf v `seq` rnf f\n rnf (Mat k v m ks) = k `seq` rnf v `seq` rnf m `seq` rnf ks\n rnf (Inc x) = rnf x\n rnf (Dec x) = rnf x\n\n\n-- Stringification\n-- ---------------\n\npadLeft :: String -> Int -> Char -> String\npadLeft str n c = replicate (n - length str) c ++ str\n\nshowHex :: Word64 -> String\nshowHex x = showIntAtBase 16 intToDigit (fromIntegral x) \"\"\n\nshowName :: Int -> String\nshowName n = go (n + 1) \"\" where\n go n ac | n == 0 = ac\n | otherwise = go q (chr (ord 'a' + r) : ac)\n where (q,r) = quotRem (n - 1) 26\n\nshowTag :: Tag -> String\nshowTag tag\n | tag == _DP0_ = \"DP0\"\n | tag == _DP1_ = \"DP1\"\n | tag == _VAR_ = \"VAR\"\n | tag == _FWD_ = \"FWD\"\n | tag == _REF_ = \"REF\"\n | tag == _LET_ = \"LET\"\n | tag == _APP_ = \"APP\"\n | tag == _MAT_ = \"MAT\"\n | tag == _IFL_ = \"IFL\"\n | tag == _SWI_ = \"SWI\"\n | tag == _OPX_ = \"OPX\"\n | tag == _OPY_ = \"OPY\"\n | tag == _ERA_ = \"ERA\"\n | tag == _LAM_ = \"LAM\"\n | tag == _SUP_ = \"SUP\"\n | tag == _CTR_ = \"CTR\"\n | tag == _W32_ = \"W32\"\n | tag == _CHR_ = \"CHR\"\n | tag == _INC_ = \"INC\"\n | tag == _DEC_ = \"DEC\"\n | otherwise = error $ \"unknown tag: \" ++ show tag\n\nshowLab :: Lab -> String\nshowLab lab = padLeft (showHex (fromIntegral lab)) 6 '0'\n\nshowLoc :: Loc -> String\nshowLoc loc = padLeft (showHex (fromIntegral loc)) 8 '0'\n\ninstance Show Oper where\n show OP_ADD = \"+\"\n show OP_SUB = \"-\"\n show OP_MUL = \"*\"\n show OP_DIV = \"/\"\n show OP_MOD = \"%\"\n show OP_EQ = \"==\"\n show OP_NE = \"!=\"\n show OP_LT = \"<\"\n show OP_GT = \">\"\n show OP_LTE = \"<=\"\n show OP_GTE = \">=\"\n show OP_AND = \"&\"\n show OP_OR = \"|\"\n show OP_XOR = \"^\"\n show OP_LSH = \"<<\"\n show OP_RSH = \">>\"\n\ninstance Show LetT where\n show LAZY = \"\"\n show STRI = \"!\"\n\nshowCore :: Core -> String\nshowCore core = maybe (format core) id (sugar core) where\n\n sugar :: Core -> Maybe String\n sugar core = nil core <|> str core <|> lst core where\n nil :: Core -> Maybe String\n nil (Ctr \"#Nil\" []) = Just \"[]\"\n nil _ = Nothing\n str :: Core -> Maybe String\n str (Ctr \"#Nil\" []) = Just \"\\\"\\\"\"\n str (Ctr \"#Cons\" [Chr h, t]) = do\n rest <- str t\n return $ \"\\\"\" ++ h : tail rest\n str _ = Nothing\n lst :: Core -> Maybe String\n lst (Ctr \"#Nil\" []) = Just \"[]\"\n lst (Ctr \"#Cons\" [x, xs]) = do\n rest <- lst xs\n return $ \"[\" ++ showCore x ++ if rest == \"[]\" then \"]\" else \" \" ++ tail rest\n lst _ = Nothing\n\n format :: Core -> String\n format (Var k) =\n k\n format Era =\n \"*\"\n format (Lam x f) =\n let f' = showCore f in\n concat [\"λ\", x, \" \", f']\n format (App f x) =\n let f' = showCore f in\n let x' = showCore x in\n concat [\"(\", f', \" \", x', \")\"]\n format (Sup l a b) =\n let a' = showCore a in\n let b' = showCore b in\n concat [\"&\", show l, \"{\", a', \" \", b', \"}\"]\n format (Dup l x y v f) =\n let v' = showCore v in\n let f' = showCore f in\n concat [\"! &\", show l, \"{\", x, \" \", y, \"} = \", v', \"\\n\", f']\n format (Ref k i xs) =\n let xs' = intercalate \" \" (map showCore xs) in\n concat [\"@\", k, \"(\", xs', \")\"]\n format (Ctr k xs) =\n let xs' = unwords (map showCore xs) in\n concat [k, \"{\", xs', \"}\"]\n format (Mat k v m ks) =\n let v' = showCore v in\n let m' = concatMap (\\(k,v) -> concat [\" !\", k, \"=\", showCore v]) m in\n let ks' = unwords [concat [c, \":\", showCore b] | (c, vs, b) <- ks] in\n concat [\"(~\", v', m', \" {\", ks', \"})\"]\n format (U32 v) =\n show v\n format (Chr v) =\n concat [\"'\", [v], \"'\"]\n format (Op2 o a b) =\n let a' = showCore a in\n let b' = showCore b in\n concat [\"(\", show o, \" \", a', \" \", b', \")\"]\n format (Let m k v f)\n | k == \"\" =\n let v' = showCore v in\n let f' = showCore f in\n concat [v', \"\\n\", f']\n | otherwise =\n let v' = showCore v in\n let f' = showCore f in\n concat [\"! \", show m, k, \" = \", v', \"\\n\", f']\n format (Inc x) =\n let x' = showCore x in\n concat [\"↑\", x']\n format (Dec x) =\n let x' = showCore x in\n concat [\"↓\", x']\n\nrename :: Core -> Core\nrename core = unsafePerformIO $ do\n names <- newIORef MS.empty\n renamer names core\n\nrenamer :: IORef (MS.Map String String) -> Core -> IO Core\nrenamer names core = case core of\n Var k -> do\n k' <- genName names k\n return $ Var k'\n Lam x f -> do\n x' <- genName names x\n f' <- renamer names f\n return $ Lam x' f'\n Let m k v f -> do\n k' <- genName names k\n v' <- renamer names v\n f' <- renamer names f\n return $ Let m k' v' f'\n App f x -> do\n f' <- renamer names f\n x' <- renamer names x\n return $ App f' x'\n Sup l a b -> do\n a' <- renamer names a\n b' <- renamer names b\n return $ Sup l a' b'\n Dup l x y v f -> do\n x' <- genName names x\n y' <- genName names y\n v' <- renamer names v\n f' <- renamer names f\n return $ Dup l x' y' v' f'\n Ctr k xs -> do\n xs' <- mapM (renamer names) xs\n return $ Ctr k xs'\n Mat k v m ks -> do\n v' <- renamer names v\n m' <- forM m $ \\(k,v) -> do v' <- renamer names v; return (k,v')\n ks' <- forM ks $ \\(c,vs,t) -> do\n vs' <- mapM (genName names) vs\n t' <- renamer names t\n return (c,vs',t')\n return $ Mat k v' m' ks'\n Op2 o a b -> do\n a' <- renamer names a\n b' <- renamer names b\n return $ Op2 o a' b'\n Ref k i xs -> do\n xs' <- mapM (renamer names) xs\n return $ Ref k i xs'\n Inc x -> do\n x' <- renamer names x\n return $ Inc x'\n Dec x -> do\n x' <- renamer names x\n return $ Dec x'\n other -> \n return other\n\ngenName :: IORef (MS.Map String String) -> String -> IO String\ngenName names name =\n atomicModifyIORef' names $ \\map ->\n case MS.lookup (strip name) map of\n Just val -> (map, val)\n Nothing ->\n let new = showName (MS.size map)\n map' = MS.insert (strip name) new map\n in (map', new)\n where strip name = if \"&\" `isPrefixOf` name then tail name else name\n\ninstance Show Core where\n show = showCore . rename\n" }, { "path": "src/HVM/runtime/heap.c", "content": "#include \"Runtime.h\"\n\n// Heap counters\nvoid set_len(u64 size) { *HVM.size = size; }\nvoid set_itr(u64 itrs) { *HVM.itrs = itrs; }\nu64 get_len() { return *HVM.size; }\nu64 get_itr() { return *HVM.itrs; }\nu64 fresh() { return (*HVM.frsh)++; }\n\n// Atomics\nTerm swap(Loc loc, Term term) {\n Term val = HVM.heap[loc];\n HVM.heap[loc] = term;\n if (val == 0) {\n printf(\"SWAP 0 at %08llx\\n\", (u64)loc);\n exit(0);\n }\n return val;\n}\n\nTerm got(Loc loc) {\n Term val = HVM.heap[loc];\n if (val == 0) {\n printf(\"GOT 0 at %08llx\\n\", (u64)loc);\n exit(0);\n }\n return val;\n}\n\nvoid set(Loc loc, Term term) { HVM.heap[loc] = term; }\nvoid sub(Loc loc, Term term) { set(loc, term_set_bit(term)); }\nTerm take(Loc loc) { return swap(loc, VOID); }\n\n// Allocation and accounting\nLoc alloc_node(Loc arity) {\n if (*HVM.size + arity > MAX_HEAP_SIZE) {\n printf(\"Heap memory limit exceeded\\n\");\n exit(1);\n }\n u64 old = *HVM.size;\n *HVM.size += arity;\n return old;\n}\n\nvoid inc_itr() { (*HVM.itrs)++; }\n\n" }, { "path": "src/HVM/runtime/memory.c", "content": "#include \"Runtime.h\"\n\nstatic void *alloc_huge(size_t size) {\n void *ptr = mmap(NULL, size, PROT_READ | PROT_WRITE,\n MAP_PRIVATE | MAP_ANONYMOUS | MAP_NORESERVE,\n -1, 0);\n if (ptr == MAP_FAILED) {\n perror(\"mmap failed\");\n return NULL;\n }\n return ptr;\n}\n\nvoid hvm_init() {\n HVM.sbuf = alloc_huge(MAX_STACK_SIZE * sizeof(Term));\n HVM.heap = alloc_huge(MAX_HEAP_SIZE * sizeof(Term));\n HVM.spos = alloc_huge(sizeof(u64));\n HVM.size = alloc_huge(sizeof(u64));\n HVM.itrs = alloc_huge(sizeof(u64));\n HVM.frsh = alloc_huge(sizeof(u64));\n\n #define CHECK_ALLOC(ptr, name) if (!(ptr)) { printf(name \" alloc failed\\n\"); allocs_failed++; }\n int allocs_failed = 0;\n CHECK_ALLOC(HVM.sbuf, \"sbuf\");\n CHECK_ALLOC(HVM.heap, \"heap\");\n CHECK_ALLOC(HVM.spos, \"spos\");\n CHECK_ALLOC(HVM.size, \"size\");\n CHECK_ALLOC(HVM.itrs, \"itrs\");\n CHECK_ALLOC(HVM.frsh, \"frsh\");\n if (allocs_failed > 0) {\n printf(\"hvm_init alloc's failed: %d allocations failed\\n\", allocs_failed);\n exit(1);\n }\n #undef CHECK_ALLOC\n\n *HVM.spos = 0;\n *HVM.size = 1;\n *HVM.itrs = 0;\n *HVM.frsh = 0x20;\n HVM.book[SUP_F] = SUP_f;\n HVM.book[DUP_F] = DUP_f;\n HVM.book[LOG_F] = LOG_f;\n for (int i = 0; i < 65536; i++) {\n HVM.cari[i] = 0;\n HVM.clen[i] = 0;\n HVM.cadt[i] = 0;\n HVM.fari[i] = 0;\n }\n}\n\nstatic void hvm_munmap(void *ptr, size_t size, const char *name) {\n if (ptr != MAP_FAILED) {\n if (munmap(ptr, size) == -1) {\n perror(\"munmap failed\");\n }\n } else {\n printf(\"%s is already null or invalid.\\n\", name);\n }\n}\n\nvoid hvm_free() {\n hvm_munmap(HVM.sbuf, MAX_STACK_SIZE * sizeof(Term), \"sbuf\");\n hvm_munmap(HVM.heap, MAX_HEAP_SIZE * sizeof(Term), \"heap\");\n hvm_munmap(HVM.spos, sizeof(u64), \"spos\");\n hvm_munmap(HVM.size, sizeof(u64), \"size\");\n hvm_munmap(HVM.itrs, sizeof(u64), \"itrs\");\n hvm_munmap(HVM.frsh, sizeof(u64), \"frsh\");\n}\n\n" }, { "path": "src/HVM/runtime/prim/DUP.c", "content": "#include \"Runtime.h\"\n\n// Primitive: Dynamic Dup `@DUP(lab val λdp0λdp1(bod))`\n// Creates a DUP node with given label.\nTerm DUP_f(Term ref) {\n Loc ref_loc = term_loc(ref);\n Term lab = reduce(got(ref_loc + 0));\n Term lab_val = term_loc(lab);\n if (term_tag(lab) != W32) {\n printf(\"ERROR:non-numeric-dup-label\\n\");\n }\n if (lab_val > 0xFFFF) {\n printf(\"ERROR:dup-label-too-large\\n\");\n }\n Term val = got(ref_loc + 1);\n Term bod = got(ref_loc + 2);\n Loc dup = alloc_node(1);\n set(dup + 0, val);\n if (term_tag(bod) == LAM) {\n Loc lam0 = term_loc(bod);\n Term bod0 = got(lam0 + 0);\n if (term_tag(bod0) == LAM) {\n Loc lam1 = term_loc(bod0);\n Term bod1 = got(lam1 + 0);\n sub(lam0 + 0, term_new(DP0, lab_val, dup));\n sub(lam1 + 0, term_new(DP1, lab_val, dup));\n *HVM.itrs += 3;\n return bod1;\n }\n }\n Loc app0 = alloc_node(2);\n set(app0 + 0, bod);\n set(app0 + 1, term_new(DP0, lab_val, dup));\n Loc app1 = alloc_node(2);\n set(app1 + 0, term_new(APP, 0, app0));\n set(app1 + 1, term_new(DP1, lab_val, dup));\n *HVM.itrs += 1;\n return term_new(APP, 0, app1);\n}\n\n" }, { "path": "src/HVM/runtime/prim/LOG.c", "content": "#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", "content": "#include \"Runtime.h\"\n\n// Primitive: Dynamic Sup `@SUP(lab tm0 tm1)`\n// Allocates a new SUP node with given label.\nTerm SUP_f(Term ref) {\n Loc ref_loc = term_loc(ref);\n Term lab = reduce(got(ref_loc + 0));\n Term lab_val = term_loc(lab);\n if (term_tag(lab) != W32) {\n printf(\"ERROR:non-numeric-sup-label\\n\");\n }\n if (lab_val > 0xFFFF) {\n printf(\"ERROR:sup-label-too-large\\n\");\n }\n Term tm0 = got(ref_loc + 1);\n Term tm1 = got(ref_loc + 2);\n Loc sup = alloc_node(2);\n Term ret = term_new(SUP, lab_val, sup);\n set(sup + 0, tm0);\n set(sup + 1, tm1);\n *HVM.itrs += 1;\n return ret;\n}\n\n" }, { "path": "src/HVM/runtime/print.c", "content": "#include \"Runtime.h\"\n\nvoid print_tag(Tag tag) {\n switch (tag) {\n case VAR: printf(\"VAR\"); break;\n case DP0: printf(\"DP0\"); break;\n case DP1: printf(\"DP1\"); break;\n case APP: printf(\"APP\"); break;\n case LAM: printf(\"LAM\"); break;\n case ERA: printf(\"ERA\"); break;\n case SUP: printf(\"SUP\"); break;\n case REF: printf(\"REF\"); break;\n case LET: printf(\"LET\"); break;\n case CTR: printf(\"CTR\"); break;\n case MAT: printf(\"MAT\"); break;\n case IFL: printf(\"IFL\"); break;\n case SWI: printf(\"SWI\"); break;\n case W32: printf(\"W32\"); break;\n case CHR: printf(\"CHR\"); break;\n case OPX: printf(\"OPX\"); break;\n case OPY: printf(\"OPY\"); break;\n case INC: printf(\"INC\"); break;\n case DEC: printf(\"DEC\"); break;\n default : printf(\"???\"); break;\n }\n}\n\nvoid print_term(Term term) {\n printf(\"term_new(\");\n print_tag(term_tag(term));\n printf(\",0x%04llx,0x%010llx)\", (u64)term_lab(term), (u64)term_loc(term));\n}\n\nvoid print_heap() {\n for (Loc i = 0; i < *HVM.size; i++) {\n Term term = got(i);\n if (term != 0) {\n printf(\"set(0x%08llx, \", (u64)i);\n print_term(term);\n printf(\");\\n\");\n }\n }\n}\n" }, { "path": "src/HVM/runtime/reduce/app_ctr.c", "content": "#include \"Runtime.h\"\n\n// &L(#{x y z ...} a)\n// ------------------ APP-CTR\n// ⊥\nTerm reduce_app_ctr(Term app, Term ctr) {\n printf(\"invalid:app-ctr(%lu)\", (unsigned long)term_lab(ctr));\n exit(0);\n}\n" }, { "path": "src/HVM/runtime/reduce/app_era.c", "content": "#include \"Runtime.h\"\n\n// (* a)\n// ------- APP-ERA\n// *\nTerm reduce_app_era(Term app, Term era) {\n inc_itr();\n return era;\n}\n" }, { "path": "src/HVM/runtime/reduce/app_lam.c", "content": "#include \"Runtime.h\"\n\n// (λx(body) arg)\n// ---------------- APP-LAM\n// x <- arg\n// body\nTerm reduce_app_lam(Term app, Term lam) {\n inc_itr();\n Loc app_loc = term_loc(app);\n Loc lam_loc = term_loc(lam);\n Term bod = got(lam_loc + 0);\n Term arg = got(app_loc + 1);\n sub(lam_loc + 0, arg);\n return bod;\n}\n" }, { "path": "src/HVM/runtime/reduce/app_sup.c", "content": "#include \"Runtime.h\"\n\n// (&L{a b} c)\n// --------------------- APP-SUP\n// ! &L{x0 x1} = c\n// &L{(a x0) (b x1)}\nTerm reduce_app_sup(Term app, Term sup) {\n inc_itr();\n Loc app_loc = term_loc(app);\n Loc sup_loc = term_loc(sup);\n Lab sup_lab = term_lab(sup);\n\n Term arg = got(app_loc + 1);\n Term tm1 = got(sup_loc + 1);\n\n Loc loc = alloc_node(3);\n Loc ap0 = sup_loc;\n Loc ap1 = loc + 0;\n Loc su0 = app_loc;\n Loc dup = loc + 2;\n\n set(ap0 + 1, term_new(DP0, sup_lab, dup));\n\n set(ap1 + 0, tm1);\n set(ap1 + 1, term_new(DP1, sup_lab, dup));\n\n // Reuse app_loc for the result superposition\n set(su0 + 0, term_new(APP, 0, ap0));\n set(su0 + 1, term_new(APP, 0, ap1));\n\n set(dup + 0, arg);\n\n return term_new(SUP, sup_lab, su0);\n}\n" }, { "path": "src/HVM/runtime/reduce/app_una.c", "content": "#include \"Runtime.h\"\n\n// (↑f x) / (↓f x)\n// ---------------- APP-INC/DEC\n// ↑(f x) / ↓(f x)\nTerm reduce_app_una(Term app, Term una, Tag tag) {\n inc_itr();\n Loc app_loc = term_loc(app);\n Loc una_loc = term_loc(una);\n Term fun = got(una_loc + 0);\n Term arg = got(app_loc + 1);\n\n // build the inner application in-place, re-using app_loc\n set(app_loc + 0, fun);\n set(app_loc + 1, arg);\n\n // point INC/DEC to the freshly built APP\n set(una_loc + 0, term_new(APP, 0, app_loc));\n return una;\n}\n\nTerm reduce_app_inc(Term app, Term inc) {\n return reduce_app_una(app, inc, INC);\n}\n\nTerm reduce_app_dec(Term app, Term dec) {\n return reduce_app_una(app, dec, DEC);\n}\n" }, { "path": "src/HVM/runtime/reduce/app_w32.c", "content": "#include \"Runtime.h\"\n\n// &L(123 a)\n// --------- APP-W32\n// ⊥\nTerm reduce_app_w32(Term app, Term w32) {\n printf(\"invalid:app-w32(%llu)\", (unsigned long long)term_loc(w32));\n exit(0);\n}\n" }, { "path": "src/HVM/runtime/reduce/dup_ctr.c", "content": "#include \"Runtime.h\"\n\n// ! &L{x y} = #{a b c ...}\n// ------------------------ DUP-CTR\n// ! &L{a0 a1} = a\n// ! &L{b0 b1} = b\n// ! &L{c0 c1} = c\n// ...\n// x <- #{a0 b0 c0 ...} \n// y <- #{a1 b1 c1 ...}\nTerm reduce_dup_ctr(Term dup, Term ctr) {\n inc_itr();\n Loc dup_loc = term_loc(dup);\n Lab dup_lab = term_lab(dup);\n Loc ctr_loc = term_loc(ctr);\n Lab ctr_lab = term_lab(ctr);\n u64 ctr_ari = HVM.cari[ctr_lab];\n\n Loc loc = alloc_node(ctr_ari * 2);\n Loc ctr0 = ctr_loc;\n Loc ctr1 = loc + 0;\n for (u64 i = 0; i < ctr_ari; i++) {\n Loc du0 = loc + ctr_ari + i;\n set(du0 + 0, got(ctr_loc + i));\n set(ctr0 + i, term_new(DP0, dup_lab, du0));\n set(ctr1 + i, term_new(DP1, dup_lab, du0));\n }\n if (term_tag(dup) == DP0) {\n sub(dup_loc + 0, term_new(CTR, ctr_lab, ctr1));\n return term_new(CTR, ctr_lab, ctr0);\n } else {\n sub(dup_loc + 0, term_new(CTR, ctr_lab, ctr0));\n return term_new(CTR, ctr_lab, ctr1);\n }\n}\n" }, { "path": "src/HVM/runtime/reduce/dup_era.c", "content": "#include \"Runtime.h\"\n\n// ! &L{x y} = *\n// ------------- DUP-ERA\n// x <- *\n// y <- *\nTerm reduce_dup_era(Term dup, Term era) {\n inc_itr();\n Loc dup_loc = term_loc(dup);\n sub(dup_loc + 0, era);\n return era;\n}\n" }, { "path": "src/HVM/runtime/reduce/dup_lam.c", "content": "#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(f1)\n// x <- &L{x0 x1}\nTerm reduce_dup_lam(Term dup, Term lam) {\n inc_itr();\n Loc dup_loc = term_loc(dup);\n Loc lam_loc = term_loc(lam);\n Lab dup_lab = term_lab(dup);\n\n Term bod = got(lam_loc + 0);\n \n Loc loc = alloc_node(5);\n Loc lm0 = loc + 0;\n Loc lm1 = loc + 1;\n Loc su0 = loc + 2;\n Loc du0 = loc + 4;\n\n sub(lam_loc + 0, term_new(SUP, dup_lab, su0));\n\n set(lm0 + 0, term_new(DP0, dup_lab, du0));\n set(lm1 + 0, term_new(DP1, dup_lab, du0));\n set(su0 + 0, term_new(VAR, 0, lm0));\n set(su0 + 1, term_new(VAR, 0, lm1));\n set(du0 + 0, bod);\n\n if (term_tag(dup) == DP0) {\n sub(dup_loc + 0, term_new(LAM, 0, lm1));\n return term_new(LAM, 0, lm0);\n } else {\n sub(dup_loc + 0, term_new(LAM, 0, lm0));\n return term_new(LAM, 0, lm1);\n }\n}\n" }, { "path": "src/HVM/runtime/reduce/dup_ref.c", "content": "#include \"Runtime.h\"\n\n// ! &L{x y} = @foo(a b c ...)\n// --------------------------- DUP-REF-COPY (when &L not in @foo)\n// ! &L{a0 a1} = a\n// ! &L{b0 b1} = b\n// ! &L{c0 c1} = c\n// ...\n// x <- @foo(a0 b0 c0 ...)\n// y <- @foo(a1 b1 c1 ...)\nTerm reduce_dup_ref(Term dup, Term ref) {\n inc_itr();\n Loc dup_loc = term_loc(dup);\n Lab dup_lab = term_lab(dup);\n Loc ref_loc = term_loc(ref);\n Lab ref_lab = term_lab(ref);\n u64 ref_ari = HVM.fari[ref_lab];\n\n Loc loc = alloc_node(ref_ari * 2);\n Loc ref0 = ref_loc;\n Loc ref1 = loc + 0;\n for (u64 i = 0; i < ref_ari; i++) {\n Loc du0 = loc + ref_ari + i;\n set(du0 + 0, got(ref_loc + i));\n set(ref0 + i, term_new(DP0, dup_lab, du0));\n set(ref1 + i, term_new(DP1, dup_lab, du0));\n }\n if (term_tag(dup) == DP0) {\n sub(dup_loc + 0, term_new(REF, ref_lab, ref1));\n return term_new(REF, ref_lab, ref0);\n } else {\n sub(dup_loc + 0, term_new(REF, ref_lab, ref0));\n return term_new(REF, ref_lab, ref1);\n }\n}\n" }, { "path": "src/HVM/runtime/reduce/dup_sup.c", "content": "#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// else:\n// x <- &R{a0 b0} \n// y <- &R{a1 b1}\n// ! &L{a0 a1} = a\n// ! &L{b0 b1} = b\nTerm reduce_dup_sup(Term dup, Term sup) {\n inc_itr();\n Loc dup_loc = term_loc(dup);\n Lab dup_lab = term_lab(dup);\n Lab sup_lab = term_lab(sup);\n Loc sup_loc = term_loc(sup);\n if (dup_lab == sup_lab) {\n Term tm0 = got(sup_loc + 0);\n Term tm1 = got(sup_loc + 1);\n if (term_tag(dup) == DP0) {\n sub(dup_loc + 0, tm1);\n return tm0;\n } else {\n sub(dup_loc + 0, tm0);\n return tm1;\n }\n } else {\n Loc loc = alloc_node(4);\n Loc du0 = sup_loc + 0;\n Loc du1 = sup_loc + 1;\n Loc su0 = loc + 0;\n Loc su1 = loc + 2;\n set(su0 + 0, term_new(DP0, dup_lab, du0));\n set(su0 + 1, term_new(DP0, dup_lab, du1));\n set(su1 + 0, term_new(DP1, dup_lab, du0));\n set(su1 + 1, term_new(DP1, dup_lab, du1));\n if (term_tag(dup) == DP0) {\n sub(dup_loc + 0, term_new(SUP, sup_lab, su1));\n return term_new(SUP, sup_lab, su0);\n } else {\n sub(dup_loc + 0, term_new(SUP, sup_lab, su0));\n return term_new(SUP, sup_lab, su1);\n }\n }\n}\n" }, { "path": "src/HVM/runtime/reduce/dup_una.c", "content": "#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 / ↓B\nTerm reduce_dup_una(Term dup, Term una, Tag tag) {\n inc_itr();\n Loc dup_loc = term_loc(dup);\n Lab lab = term_lab(dup);\n Loc una_loc = term_loc(una);\n Term inner = got(una_loc + 0);\n\n // duplicate inner value\n Loc du_loc = una_loc;\n Loc w0_loc = alloc_node(1);\n Loc w1_loc = alloc_node(1);\n\n // wrap duplicates in INC / DEC\n set(w0_loc + 0, term_new(DP0, lab, du_loc));\n set(w1_loc + 0, term_new(DP1, lab, du_loc));\n\n if (term_tag(dup) == DP0) {\n sub(dup_loc + 0, term_new(tag, 0, w1_loc));\n return term_new(tag, 0, w0_loc);\n } else {\n sub(dup_loc + 0, term_new(tag, 0, w0_loc));\n return term_new(tag, 0, w1_loc);\n }\n}\n\nTerm reduce_dup_inc(Term dup, Term inc) {\n return reduce_dup_una(dup, inc, INC);\n}\n\nTerm reduce_dup_dec(Term dup, Term dec) {\n return reduce_dup_una(dup, dec, DEC);\n}\n" }, { "path": "src/HVM/runtime/reduce/dup_w32.c", "content": "#include \"Runtime.h\"\n\n// ! &L{x y} = 123\n// --------------- DUP-W32\n// x <- 123\n// y <- 123\nTerm reduce_dup_w32(Term dup, Term w32) {\n inc_itr();\n Loc dup_loc = term_loc(dup);\n sub(dup_loc + 0, w32);\n return w32;\n}\n" }, { "path": "src/HVM/runtime/reduce/let.c", "content": "#include \"Runtime.h\"\n\n// ! x = val\n// bod\n// --------- LET\n// x <- val\n// bod\nTerm reduce_let(Term let, Term val) {\n inc_itr();\n Loc let_loc = term_loc(let);\n Term bod = got(let_loc + 1);\n sub(let_loc + 0, val);\n return bod;\n}\n" }, { "path": "src/HVM/runtime/reduce/mat_ctr.c", "content": "#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_loc = term_loc(mat);\n Lab mat_lab = term_lab(mat);\n // If-Let\n if (mat_tag == IFL) {\n Loc ctr_loc = term_loc(ctr);\n Lab ctr_lab = term_lab(ctr);\n u64 mat_ctr = mat_lab;\n u64 ctr_num = ctr_lab;\n u64 ctr_ari = HVM.cari[ctr_num];\n if (mat_ctr == ctr_num) {\n Term app = got(mat_loc + 1);\n Loc loc = alloc_node(ctr_ari * 2);\n for (u64 i = 0; i < ctr_ari; i++) {\n Loc new_app = loc + i * 2;\n set(new_app + 0, app);\n set(new_app + 1, got(ctr_loc + i));\n app = term_new(APP, 0, new_app);\n }\n return app;\n } else {\n Term app = got(mat_loc + 2);\n Loc new_app = mat_loc;\n set(new_app + 0, app);\n set(new_app + 1, ctr);\n app = term_new(APP, 0, new_app);\n return app;\n }\n // Match\n } else {\n Loc ctr_loc = term_loc(ctr);\n Lab ctr_lab = term_lab(ctr);\n u64 ctr_num = ctr_lab;\n u64 ctr_ari = HVM.cari[ctr_num];\n u64 mat_ctr = mat_lab;\n u64 cadt = HVM.cadt[mat_ctr];\n u64 clen = HVM.clen[mat_ctr];\n if (ctr_num < cadt || ctr_num >= cadt + clen) {\n printf(\"invalid:mat-ctr(%llu, %llu)\\n\", (unsigned long long)ctr_num, (unsigned long long)cadt);\n exit(1);\n }\n u64 cse_idx = ctr_num - mat_ctr;\n Term app = got(mat_loc + 1 + cse_idx);\n Loc loc = alloc_node(ctr_ari * 2);\n for (u64 i = 0; i < ctr_ari; i++) {\n Loc new_app = loc + i * 2;\n set(new_app + 0, app);\n set(new_app + 1, got(ctr_loc + i));\n app = term_new(APP, 0, new_app);\n }\n return app;\n }\n}\n" }, { "path": "src/HVM/runtime/reduce/mat_era.c", "content": "#include \"Runtime.h\"\n\n// ~ * {K0 K1 K2 ...} \n// ------------------ MAT-ERA\n// *\nTerm reduce_mat_era(Term mat, Term era) {\n inc_itr();\n return era;\n}\n" }, { "path": "src/HVM/runtime/reduce/mat_lam.c", "content": "#include \"Runtime.h\"\n\n// ~ λx(x) {K0 K1 K2 ...}\n// ------------------------ MAT-LAM\n// ⊥\nTerm reduce_mat_lam(Term mat, Term lam) {\n printf(\"invalid:mat-lam\");\n exit(0);\n}\n" }, { "path": "src/HVM/runtime/reduce/mat_sup.c", "content": "#include \"Runtime.h\"\n\n// ~ &L{x y} {K0 K1 K2 ...}\n// ------------------------ MAT-SUP\n// ! &L{k0a k0b} = K0\n// ! &L{k1a k1b} = K1\n// ! &L{k2a k2b} = K2\n// ...\n// &L{ ~ x {K0a K1a K2a ...}\n// ~ y {K0b K1b K2b ...} }\nTerm reduce_mat_sup(Term mat, Term sup) {\n inc_itr();\n Tag mat_tag = term_tag(mat);\n Lab mat_lab = term_lab(mat);\n Loc mat_loc = term_loc(mat);\n Loc sup_loc = term_loc(sup);\n Lab sup_lab = term_lab(sup);\n\n Term tm0 = got(sup_loc + 0);\n Term tm1 = got(sup_loc + 1);\n u64 mat_len = mat_tag == SWI ? mat_lab : mat_tag == IFL ? 2 : HVM.clen[mat_lab];\n\n Loc loc = alloc_node(1 + mat_len + mat_len);\n Loc mat0 = mat_loc;\n Loc mat1 = loc + 0;\n Loc sup0 = sup_loc;\n\n set(mat0 + 0, tm0);\n set(mat1 + 0, tm1);\n for (u64 i = 0; i < mat_len; i++) {\n Loc du0 = loc + 1 + mat_len + i;\n set(du0 + 0, got(mat_loc + 1 + i));\n set(mat0 + 1 + i, term_new(DP0, sup_lab, du0));\n set(mat1 + 1 + i, term_new(DP1, sup_lab, du0));\n }\n set(sup0 + 0, term_new(mat_tag, mat_lab, mat0));\n set(sup0 + 1, term_new(mat_tag, mat_lab, mat1));\n return term_new(SUP, sup_lab, sup0);\n}\n" }, { "path": "src/HVM/runtime/reduce/mat_una.c", "content": "#include \"Runtime.h\"\n\n// ~(↑x) {…} / ~(↓x) {…}\n// → ↑(~x {…}) / ↓(~x {…})\nTerm reduce_mat_una(Term mat, Term una, Tag tag) {\n inc_itr();\n Loc mat_loc = term_loc(mat);\n Loc una_loc = term_loc(una);\n Term inner = got(una_loc + 0);\n\n set(mat_loc + 0, inner); // plug x inside the matcher\n set(una_loc + 0, mat); // re-attach wrapped matcher\n return una;\n}\n\nTerm reduce_mat_inc(Term mat, Term inc) {\n return reduce_mat_una(mat, inc, INC);\n}\n\nTerm reduce_mat_dec(Term mat, Term dec) {\n return reduce_mat_una(mat, dec, DEC);\n}\n" }, { "path": "src/HVM/runtime/reduce/mat_w32.c", "content": "#include \"Runtime.h\"\n\n// ~ num {K0 K1 K2 ... KN}\n// ----------------------- MAT-W32\n// if n < N: Kn\n// else : KN(num-N)\nTerm reduce_mat_w32(Term mat, Term w32) {\n inc_itr();\n Loc mat_loc = term_loc(mat);\n Lab mat_lab = term_lab(mat);\n u64 mat_len = mat_lab;\n u64 w32_val = term_loc(w32);\n if (w32_val < mat_len - 1) {\n return got(mat_loc + 1 + w32_val);\n } else {\n Term fn = got(mat_loc + mat_len);\n Loc app = mat_loc;\n set(app + 0, fn);\n set(app + 1, term_new(W32, 0, w32_val - (mat_len - 1)));\n return term_new(APP, 0, app);\n }\n}\n" }, { "path": "src/HVM/runtime/reduce/opx_ctr.c", "content": "#include \"Runtime.h\"\n\n// op(x0 x1)\nTerm reduce_opx_w32(Term opx, Term nmx) {\n inc_itr();\n Lab opx_lab = term_lab(opx);\n Loc opx_loc = term_loc(opx);\n Term nmy = got(opx_loc + 1);\n set(opx_loc + 0, nmy);\n set(opx_loc + 1, nmx);\n return term_new(OPY, opx_lab, opx_loc);\n}\n" }, { "path": "src/HVM/runtime/reduce/opy_ctr.c", "content": "#include \"Runtime.h\"\n\n// >op(#{x y z ...} b)\n// ---------------------- OPY-CTR\n// ⊥\nTerm reduce_opy_ctr(Term opy, Term ctr) {\n printf(\"invalid:opy-ctr\");\n exit(0);\n}\n" }, { "path": "src/HVM/runtime/reduce/opy_era.c", "content": "#include \"Runtime.h\"\n\n// >op(a *)\n// -------- OPY-ERA\n// *\nTerm reduce_opy_era(Term opy, Term era) {\n inc_itr();\n return era;\n}\n" }, { "path": "src/HVM/runtime/reduce/opy_lam.c", "content": "#include \"Runtime.h\"\n\n// >op(a λx(B))\n// ------------ OPY-LAM\n// ⊥\nTerm reduce_opy_lam(Term opy, Term era) {\n printf(\"invalid:opy-lam\");\n exit(0);\n}\n" }, { "path": "src/HVM/runtime/reduce/opy_sup.c", "content": "#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(Term opy, Term sup) {\n inc_itr();\n Loc opy_loc = term_loc(opy);\n Loc sup_loc = term_loc(sup);\n Lab sup_lab = term_lab(sup);\n Term nmx = got(opy_loc + 1);\n Term tm0 = got(sup_loc + 0);\n Term tm1 = got(sup_loc + 1);\n Loc op0 = sup_loc;\n Loc op1 = opy_loc;\n Loc su0 = alloc_node(2);\n set(op0 + 1, nmx);\n set(op1 + 0, tm1);\n set(su0 + 0, term_new(OPY, term_lab(opy), op0));\n set(su0 + 1, term_new(OPY, term_lab(opy), op1));\n return term_new(SUP, sup_lab, su0);\n}\n" }, { "path": "src/HVM/runtime/reduce/opy_una.c", "content": "#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) {\n inc_itr();\n Loc opy_loc = term_loc(opy);\n Loc una_loc = term_loc(una);\n Term rhs = got(una_loc + 0);\n Term lhs = got(opy_loc + 1); // first operand stored at +1\n\n set(opy_loc + 0, rhs);\n set(opy_loc + 1, lhs);\n set(una_loc + 0, term_new(OPY, term_lab(opy), opy_loc));\n return una;\n}\n\nTerm reduce_opy_inc(Term opy, Term inc) {\n return reduce_opy_una(opy, inc, INC);\n}\n\nTerm reduce_opy_dec(Term opy, Term dec) {\n return reduce_opy_una(opy, dec, DEC);\n}\n" }, { "path": "src/HVM/runtime/reduce/opy_w32.c", "content": "#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 Loc opy_loc = term_loc(opy);\n Tag t = term_tag(w32);\n u32 x = term_loc(got(opy_loc + 1));\n u32 y = term_loc(w32);\n u32 result;\n switch (term_lab(opy)) {\n case OP_ADD: result = x + y; break;\n case OP_SUB: result = x - y; break;\n case OP_MUL: result = x * y; break;\n case OP_DIV: result = x / y; break;\n case OP_MOD: result = x % y; break;\n case OP_EQ: result = x == y; break;\n case OP_NE: result = x != y; break;\n case OP_LT: result = x < y; break;\n case OP_GT: result = x > y; break;\n case OP_LTE: result = x <= y; break;\n case OP_GTE: result = x >= y; break;\n case OP_AND: result = x & y; break;\n case OP_OR: result = x | y; break;\n case OP_XOR: result = x ^ y; break;\n case OP_LSH: result = x << y; break;\n case OP_RSH: result = x >> y; break;\n default: {\n printf(\"invalid:opy-w32\");\n exit(0);\n }\n }\n return term_new(t, 0, result);\n}\n" }, { "path": "src/HVM/runtime/reduce/ref.c", "content": "#include \"Runtime.h\"\n\n// @foo(a b c ...)\n// -------------------- REF\n// book[foo](a b c ...)\nTerm reduce_ref(Term ref) {\n inc_itr();\n return HVM.book[term_lab(ref)](ref);\n}\n" }, { "path": "src/HVM/runtime/reduce/ref_sup.c", "content": "#include \"Runtime.h\"\n\n// @foo(&L{ax ay} b c ...)\n// ----------------------- REF-SUP-COPY (when @L not in @foo)\n// ! &L{bx by} = b\n// ! &L{cx cy} = b\n// ...\n// &L{@foo(ax bx cx ...) @foo(ay by cy ...)}\nTerm reduce_ref_sup(Term ref, u16 idx) {\n inc_itr();\n Loc ref_loc = term_loc(ref);\n Lab ref_lab = term_lab(ref);\n u16 fun_id = ref_lab;\n u16 arity = HVM.fari[fun_id];\n if (idx >= arity) {\n printf(\"ERROR: Invalid index in reduce_ref_sup\\n\");\n exit(1);\n }\n Term sup = got(ref_loc + idx);\n if (term_tag(sup) != SUP) {\n printf(\"ERROR: Expected SUP at index %u\\n\", idx);\n exit(1);\n }\n Lab sup_lab = term_lab(sup);\n Loc sup_loc = term_loc(sup);\n Term sup0 = got(sup_loc + 0);\n Term sup1 = got(sup_loc + 1);\n // Allocate space for new REF node arguments for the second branch\n Loc ref1_loc = alloc_node(arity);\n for (u64 i = 0; i < arity; ++i) {\n if (i != idx) {\n // Duplicate argument\n Term arg = got(ref_loc + i);\n Loc dup_loc = alloc_node(1);\n set(dup_loc + 0, arg);\n set(ref_loc + i, term_new(DP0, sup_lab, dup_loc));\n set(ref1_loc + i, term_new(DP1, sup_lab, dup_loc));\n } else {\n // Set the SUP components directly\n set(ref_loc + i, sup0);\n set(ref1_loc + i, sup1);\n }\n }\n // Create new REF nodes\n Term ref0 = term_new(REF, ref_lab, ref_loc);\n Term ref1 = term_new(REF, ref_lab, ref1_loc);\n // Reuse sup_loc to create the new SUP node\n set(sup_loc + 0, ref0);\n set(sup_loc + 1, ref1);\n return term_new(SUP, sup_lab, sup_loc);\n}\n" }, { "path": "src/HVM/runtime/reduce.c", "content": "#include \"Runtime.h\"\n\n// Core reducer and helpers (dispatcher, WHNF, normal form)\n\nTerm reduce(Term term) {\n if (term_tag(term) >= ERA) return term;\n Term next = term;\n u64 stop = *HVM.spos;\n u64 spos = stop;\n Term* sbuf = HVM.sbuf;\n\n while (1) {\n Tag tag = term_tag(next);\n Lab lab = term_lab(next);\n Loc loc = term_loc(next);\n\n // On variables: substitute\n // On eliminators: move to field\n switch (tag) {\n case LET: {\n switch (lab) {\n case LAZY: next = reduce_let(next, got(loc + 0)); continue;\n case STRI: spush(next, sbuf, &spos); next = got(loc + 0); continue;\n default: printf(\"invalid:let\"); exit(0);\n }\n }\n case APP:\n case MAT:\n case IFL:\n case SWI:\n case OPX:\n case OPY: { spush(next, sbuf, &spos); next = got(loc + 0); continue; }\n case DP0:\n case DP1: {\n Term sub = got(loc + 0);\n if (term_get_bit(sub) == 0) { spush(next, sbuf, &spos); next = sub; continue; }\n next = term_rem_bit(sub); continue;\n }\n case VAR: {\n Term sub = got(loc);\n if (term_get_bit(sub) == 0) break;\n next = term_rem_bit(sub); continue;\n }\n case REF: { *HVM.spos = spos; next = reduce_ref(next); spos = *HVM.spos; continue; }\n default: break;\n }\n\n // Empty stack: term is in WHNF\n if (spos == stop) { *HVM.spos = spos; return next; }\n\n // Interaction Dispatcher\n Term prev = spop(sbuf, &spos);\n switch (term_tag(prev)) {\n case LET: next = reduce_let(prev, next); continue;\n case APP: switch (tag) {\n case ERA: next = reduce_app_era(prev, next); continue;\n case LAM: next = reduce_app_lam(prev, next); continue;\n case SUP: next = reduce_app_sup(prev, next); continue;\n case CTR: next = reduce_app_ctr(prev, next); continue;\n case W32: case CHR: next = reduce_app_w32(prev, next); continue;\n case INC: next = reduce_app_inc(prev, next); continue;\n case DEC: next = reduce_app_dec(prev, next); continue;\n default: break;\n }\n case DP0:\n case DP1: switch (tag) {\n case ERA: next = reduce_dup_era(prev, next); continue;\n case LAM: next = reduce_dup_lam(prev, next); continue;\n case SUP: next = reduce_dup_sup(prev, next); continue;\n case CTR: next = reduce_dup_ctr(prev, next); continue;\n case W32: case CHR: next = reduce_dup_w32(prev, next); continue;\n case INC: next = reduce_dup_inc(prev, next); continue;\n case DEC: next = reduce_dup_dec(prev, next); continue;\n default: break;\n }\n case MAT:\n case IFL:\n case SWI: switch (tag) {\n case ERA: next = reduce_mat_era(prev, next); continue;\n case LAM: next = reduce_mat_lam(prev, next); continue;\n case SUP: next = reduce_mat_sup(prev, next); continue;\n case CTR: next = reduce_mat_ctr(prev, next); continue;\n case W32: case CHR: next = reduce_mat_w32(prev, next); continue;\n case INC: next = reduce_mat_inc(prev, next); continue;\n case DEC: next = reduce_mat_dec(prev, next); continue;\n default: break;\n }\n case OPX: switch (tag) {\n case ERA: next = reduce_opx_era(prev, next); continue;\n case LAM: next = reduce_opx_lam(prev, next); continue;\n case SUP: next = reduce_opx_sup(prev, next); continue;\n case CTR: next = reduce_opx_ctr(prev, next); continue;\n case W32: case CHR: next = reduce_opx_w32(prev, next); continue;\n case INC: next = reduce_opx_inc(prev, next); continue;\n case DEC: next = reduce_opx_dec(prev, next); continue;\n default: break;\n }\n case OPY: switch (tag) {\n case ERA: next = reduce_opy_era(prev, next); continue;\n case LAM: next = reduce_opy_lam(prev, next); continue;\n case SUP: next = reduce_opy_sup(prev, next); continue;\n case CTR: next = reduce_opy_ctr(prev, next); continue;\n case W32: case CHR: next = reduce_opy_w32(prev, next); continue;\n case INC: next = reduce_opy_inc(prev, next); continue;\n case DEC: next = reduce_opy_dec(prev, next); continue;\n default: break;\n }\n default: break;\n }\n\n // No interaction: push term back to stack, update parent chain\n spush(prev, sbuf, &spos);\n while (spos > stop) {\n Term host = spop(sbuf, &spos);\n set(term_loc(host) + 0, next);\n next = host;\n }\n *HVM.spos = spos;\n return next;\n }\n}\n\nTerm reduce_at(Loc host) {\n Term tm0 = got(host);\n if (term_tag(tm0) >= ERA) return tm0;\n Term tm1 = reduce(tm0);\n set(host, tm1);\n return tm1;\n}\n\nTerm normal(Term term) {\n Term wnf = reduce(term);\n Tag tag = term_tag(wnf);\n Lab lab = term_lab(wnf);\n Loc loc = term_loc(wnf);\n switch (tag) {\n case LAM: { Term bod = got(loc + 0); bod = normal(bod); set(term_loc(wnf) + 1, bod); return wnf; }\n case APP: { Term fun = got(loc + 0); Term arg = got(loc + 1); fun = normal(fun); arg = normal(arg); set(term_loc(wnf) + 0, fun); set(term_loc(wnf) + 1, arg); return wnf; }\n case SUP: { Term tm0 = got(loc + 0); Term tm1 = got(loc + 1); tm0 = normal(tm0); tm1 = normal(tm1); set(term_loc(wnf) + 0, tm0); set(term_loc(wnf) + 1, tm1); return wnf; }\n case DP0:\n case DP1: { Term val = got(loc + 0); val = normal(val); set(term_loc(wnf) + 0, val); return wnf; }\n case CTR: { u64 cid = lab; u64 ari = HVM.cari[cid]; for (u64 i = 0; i < ari; i++) { Term arg = got(loc + i); arg = normal(arg); set(term_loc(wnf) + i, arg); } return wnf; }\n case MAT:\n case IFL:\n case SWI: { u64 len = tag == SWI ? lab : tag == IFL ? 2 : HVM.clen[lab]; for (u64 i = 0; i <= len; i++) { Term arg = got(loc + i); arg = normal(arg); set(term_loc(wnf) + i, arg); } return wnf; }\n default: return wnf;\n }\n}\n" }, { "path": "src/HVM/runtime/stack.c", "content": "#include \"Runtime.h\"\n\nvoid spush(Term term, Term* sbuf, u64* spos) {\n if (*spos >= MAX_STACK_SIZE) {\n printf(\"Stack memory limit exceeded\\n\");\n exit(1);\n }\n sbuf[(*spos)++] = term;\n}\n\nTerm spop(Term* sbuf, u64* spos) {\n return sbuf[--(*spos)];\n}\n\n" }, { "path": "src/HVM/runtime/state.c", "content": "#include \"Runtime.h\"\n\nState HVM = {\n .sbuf = NULL,\n .spos = NULL,\n .heap = NULL,\n .size = NULL,\n .itrs = NULL,\n .frsh = NULL,\n .book = {NULL},\n .cari = {0},\n .clen = {0},\n .cadt = {0},\n .fari = {0},\n};\n\nState* hvm_get_state() {\n return &HVM;\n}\n\nvoid hvm_set_state(State* hvm) {\n HVM.sbuf = hvm->sbuf;\n HVM.spos = hvm->spos;\n HVM.heap = hvm->heap;\n HVM.size = hvm->size;\n HVM.itrs = hvm->itrs;\n HVM.frsh = hvm->frsh;\n for (int i = 0; i < 65536; i++) {\n HVM.book[i] = hvm->book[i];\n HVM.fari[i] = hvm->fari[i];\n HVM.cari[i] = hvm->cari[i];\n HVM.clen[i] = hvm->clen[i];\n HVM.cadt[i] = hvm->cadt[i];\n }\n}\n\nvoid hvm_define(u16 fid, Term (*func)()) {\n HVM.book[fid] = func;\n}\n\nvoid hvm_set_cari(u16 cid, u16 arity) {\n HVM.cari[cid] = arity;\n}\n\nvoid hvm_set_fari(u16 fid, u16 arity) {\n HVM.fari[fid] = arity;\n}\n\nvoid hvm_set_clen(u16 cid, u16 cases) {\n HVM.clen[cid] = cases;\n}\n\nvoid hvm_set_cadt(u16 cid, u16 adt) {\n HVM.cadt[cid] = adt;\n}\n\n" }, { "path": "src/HVM/runtime/term.c", "content": "// Term encoding and helpers\n// -------------------------\n// Layout (least-significant bit on the right):\n// [ 63 ............... 24 ][ 23 .... 8 ][ 7 ][ 6 .... 0 ]\n// location (40b) lab(16b) S tag(7b)\n// - tag: 7-bit node tag (see Runtime.h constants)\n// - S : substitution/\"sub\" bit (1 when value is substituted)\n// - lab: constructor/operator label (16 bits)\n// - loc: heap location / payload (40 bits)\n\n#include \"Runtime.h\"\n\n// Bit masks and shifts for clarity (no behavior change)\n#define TAG_MASK (0x7FULL)\n#define SUB_MASK (1ULL << 7)\n#define LAB_MASK (0xFFFFULL)\n#define LOC_MASK (0xFFFFFFFFFFULL)\n#define LAB_SHIFT (8)\n#define LOC_SHIFT (24)\n\nTerm term_new(Tag tag, Lab lab, Loc loc) {\n return ((Term)tag)\n | ((Term)lab << LAB_SHIFT)\n | ((Term)loc << LOC_SHIFT);\n}\n\nTag term_tag(Term x) {\n return (Tag)(x & TAG_MASK);\n}\n\nLab term_lab(Term x) {\n return (Lab)((x >> LAB_SHIFT) & LAB_MASK);\n}\n\nLoc term_loc(Term x) {\n return (Loc)((x >> LOC_SHIFT) & LOC_MASK);\n}\n\nu64 term_get_bit(Term x) {\n return (x >> 7) & 1ULL;\n}\n\nTerm term_set_bit(Term x) {\n return x | SUB_MASK;\n}\n\nTerm term_rem_bit(Term x) {\n return x & ~SUB_MASK;\n}\n\nTerm term_set_loc(Term x, Loc loc) {\n return (x & 0x0000000000FFFFFFULL) | ((Term)loc << LOC_SHIFT);\n}\n\n_Bool term_is_atom(Term t) {\n Tag tg = term_tag(t);\n return (tg == ERA) || (tg == W32) || (tg == CHR);\n}\n" } ]