├── .ctags ├── .gitattributes ├── .gitignore ├── .hlint.yaml ├── .stylish-haskell.yaml ├── ABI.md ├── ABI ├── abi.pdf └── arm.txt ├── CHANGELOG.md ├── LICENSE ├── Makefile ├── README.md ├── TODO.md ├── bash ├── bench ├── bench-kc ├── cross └── profile-install ├── bench └── Bench.hs ├── benchmarks ├── Splitmix.hs ├── splitmix.rs └── splitmix64.c ├── cabal.project ├── docs ├── index.html ├── manual.html ├── manual.md └── manual.pdf ├── examples ├── factorial.kmp ├── hamming.kmp ├── os.kmp ├── splitmix.kmp └── vierergruppe.kmp ├── golden ├── CDecl.hs ├── Golden.hs └── Harness.hs ├── kempe.cabal ├── lib ├── bool.kmp ├── either.kmp ├── gaussian.kmp ├── libc.kmp ├── maybe.kmp ├── numbertheory.kmp ├── order.kmp ├── rational.kmp ├── these.kmp └── tuple.kmp ├── prelude ├── arith.kmp └── fn.kmp ├── run └── Main.hs ├── src ├── Data │ ├── Copointed.hs │ ├── Foldable │ │ └── Ext.hs │ └── Tuple │ │ └── Ext.hs ├── Kempe │ ├── AST.hs │ ├── AST │ │ └── Size.hs │ ├── Asm │ │ ├── Arm │ │ │ ├── ControlFlow.hs │ │ │ ├── Linear.hs │ │ │ ├── Opt.hs │ │ │ ├── Trans.hs │ │ │ └── Type.hs │ │ ├── Liveness.hs │ │ ├── Pretty.hs │ │ ├── Type.hs │ │ └── X86 │ │ │ ├── BasicBlock.hs │ │ │ ├── ControlFlow.hs │ │ │ ├── Linear.hs │ │ │ ├── Trans.hs │ │ │ └── Type.hs │ ├── CGen.hs │ ├── Check │ │ ├── Lint.hs │ │ ├── Pattern.hs │ │ ├── Restrict.hs │ │ └── TopLevel.hs │ ├── Debug.hs │ ├── Error.hs │ ├── Error │ │ └── Warning.hs │ ├── File.hs │ ├── IR.hs │ ├── IR │ │ ├── Monad.hs │ │ ├── Opt.hs │ │ └── Type.hs │ ├── Inline.hs │ ├── Lexer.x │ ├── Module.hs │ ├── Monomorphize.hs │ ├── Name.hs │ ├── Parser.y │ ├── Pipeline.hs │ ├── Proc │ │ ├── As.hs │ │ └── Nasm.hs │ ├── Shuttle.hs │ ├── TyAssign.hs │ └── Unique.hs ├── Language │ └── C │ │ └── AST.hs └── Prettyprinter │ ├── Debug.hs │ └── Ext.hs ├── test ├── Abi.hs ├── Backend.hs ├── Parser.hs ├── Spec.hs ├── Type.hs ├── data │ ├── abi.kmp │ ├── badCodegen.kmp │ ├── ccall.kmp │ ├── diamond │ │ ├── a.kmp │ │ ├── b.kmp │ │ ├── c.kmp │ │ └── d.kmp │ ├── export.kmp │ ├── lex.kmp │ ├── maybeC.kmp │ ├── mod.kmp │ ├── multiConstruct.kmp │ ├── mutual.kmp │ ├── regAlloc.kmp │ ├── transitive.kmp │ └── ty.kmp ├── err │ ├── badWildcard.kmp │ ├── kind.kmp │ ├── merge.kmp │ ├── patternMatch.kmp │ ├── questionable.kmp │ ├── stupid.kmp │ ├── swapBinOp.kmp │ └── typecheck.kmp ├── examples │ ├── bool.kmp │ ├── const.kmp │ ├── hamming.kmp │ └── splitmix.kmp ├── golden │ ├── a.ir │ ├── abi.ir │ ├── bool.out │ ├── const.out │ ├── factorial.out │ ├── gaussian.ir │ ├── hamming.out │ ├── id.out │ ├── mod.out │ ├── numbertheory.out │ └── splitmix.out ├── harness │ ├── bool.c │ ├── const.c │ ├── factorial.c │ ├── hamming.c │ ├── id.c │ ├── mod.c │ ├── numbertheory.c │ └── splitmix.c └── include │ ├── num.h │ └── splitmix.h ├── tex ├── types.pdf └── types.tex └── vim ├── ftdetect └── kempe.vim ├── ftplugin └── kempe.vim ├── syntax └── kempe.vim └── syntax_checkers └── kempe └── kc.vim /.ctags: -------------------------------------------------------------------------------- 1 | --langdef=KEMPE 2 | --langmap=KEMPE:.kmp 3 | --regex-KEMPE=/([[:lower:]][[:alnum:]]+ *:)/\1/f,function/ 4 | --regex-KEMPE=/type *([[:upper:]][[:alnum:]]+) */\1/t,type/ 5 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | *.cpphs linguist-language=Haskell 2 | *.y linguist-language=Happy 3 | *.x linguist-language=Alex 4 | ABI/abi.pdf linguist-vendored 5 | docs/index.html linguist-generated 6 | docs/index.pdf linguist-generated 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.fls 2 | *.toc 3 | *.log 4 | *.synctex.gz 5 | *.fdb_latexmk 6 | tags 7 | dist 8 | dist-* 9 | doc 10 | *.o 11 | *.hi 12 | *.chi 13 | *.chs.h 14 | *.dyn_o 15 | *.dyn_hi 16 | .cabal-sandbox/ 17 | cabal.sandbox.config 18 | *.prof 19 | *.aux 20 | *.hp 21 | *.tix 22 | *.eventlog 23 | .stack-work/ 24 | .HTF/ 25 | .ghc.environment.* 26 | .hspec-failures 27 | *_stubs.h 28 | factorial.S 29 | factorial 30 | splitmix.S 31 | numbertheory 32 | numbertheory.S 33 | *_dats.c 34 | kc-perf/bench 35 | bin 36 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | - ignore: {name: Use section} 3 | - ignore: {name: Redundant lambda} 4 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | steps: 3 | - simple_align: 4 | cases: true 5 | top_level_patterns: true 6 | records: true 7 | - imports: 8 | align: global 9 | list_align: after_alias 10 | pad_module_names: true 11 | long_list_align: inline 12 | empty_list_align: inherit 13 | list_padding: 4 14 | separate_lists: true 15 | space_surround: false 16 | - language_pragmas: 17 | style: vertical 18 | align: true 19 | remove_redundant: false 20 | 21 | - trailing_whitespace: {} 22 | columns: 180 23 | newline: native 24 | language_extensions: [] 25 | -------------------------------------------------------------------------------- /ABI.md: -------------------------------------------------------------------------------- 1 | 2 | * Stack grows up; pointer is incremented when new data is pushed. 3 | * Kempe data pointer is maintained through calls. 4 | 5 | # x86 6 | 7 | * `rbx` has Kempe data pointer. 8 | 9 | # Aarch64 10 | 11 | * `x19` has Kempe data pointer. 12 | 13 | -------------------------------------------------------------------------------- /ABI/abi.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vmchale/kempe/15aa714ace9ad436e7b2c8366ae7c61a893afc99/ABI/abi.pdf -------------------------------------------------------------------------------- /ABI/arm.txt: -------------------------------------------------------------------------------- 1 | - https://github.com/ARM-software/abi-aa#abi-for-the-arm-64-bit-architecture 2 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # kempe 2 | 3 | ## 0.2.0.14 4 | 5 | * Catch-up with `base` 6 | 7 | ## 0.2.0.13 8 | 9 | * Update for latest `alex` templates 10 | 11 | ## 0.2.0.12 12 | 13 | * Typechecker is 𝜖 faster 14 | 15 | ## 0.2.0.11 16 | 17 | * Fix bug in typechecker 18 | 19 | ## 0.2.0.10 20 | 21 | * Fix bug in typechecking against inferred signatures. 22 | * Fix bug in prelude 23 | 24 | ## 0.2.0.9 25 | 26 | * Add `armabi` method of exporting Kempe functions, so that `kc` generates 27 | suitable code for M1 darwin. 28 | * Add `cdecl` subcommand to generate C headers for exported functions 29 | 30 | ## 0.2.0.8 31 | 32 | * More efficient IR generation; don't copy bytes from a source to the same 33 | destination 34 | * Fix bugs in `case` IR generation 35 | 36 | ## 0.2.0.7 37 | 38 | * Fix bug in unification 39 | * Fix bug so that `and` and `or` instructions print correctly for x86 assembler 40 | * Add lints for `dip(+) +` to `+ +`, (associative dip) `dup and` to `id`, etc. 41 | * Add lints for `swap swap` and `1 drop` etc. 42 | * Add `join` for `Maybe` and `Either` 43 | * Last branch of case statement always falls through (more efficient code) 44 | 45 | ## 0.2.0.6 46 | 47 | * Add `absInt` and `chocie` functions to prelude. 48 | * Add lints for `swap >`, `swap *` &c. 49 | * Fix bug in typing `>=`, `>`, `!=` 50 | 51 | ## 0.2.0.5 52 | 53 | * Fix bug in arm control-flow analysis 54 | * Fix bugs in IR optimization pass 55 | * Improve IR optimization 56 | * Add `fromMaybe` and `fromRight` functions 57 | 58 | ## 0.2.0.4 59 | 60 | * Kind-check external function declarations 61 | * Fix bug in inliner where functions within `dip(...)`s were not inlined 62 | * Fix unification bug where solved constraints were not back-substituted correctly. 63 | 64 | ## 0.2.0.3 65 | 66 | * GHC 8.0.2 and 8.2.2 67 | 68 | ## 0.2.0.2 69 | 70 | * Improve performance + generated code 71 | * Fix bug in monomorphization of patterns 72 | 73 | ## 0.2.0.1 74 | 75 | * Performance improvements when assembling x86 76 | * Fix pattern match exhaustiveness checker 77 | * More lenient command-line parser 78 | 79 | ## 0.2.0.0 80 | 81 | * Add aarch64 backend 82 | * Change type of shifts, they no longer take an `Int8` as the second argument. 83 | 84 | ## 0.1.1.3 85 | 86 | * Tweak some RTS flags for faster performance 87 | * `lib/gaussian.kmp` has `mult` function 88 | * A couple inefficiencies under the hood 89 | 90 | ## 0.1.1.2 91 | 92 | * Case statements with a single branch are plain and efficient. 93 | * Add `safeDiv` and `safeMod` to `prelude/arith.kmp` 94 | 95 | ## 0.1.1.1 96 | 97 | * Performance improvements under the hood (use `IntSet`s for liveness 98 | analysis) 99 | 100 | ## 0.1.1.0 101 | 102 | * Fix internal pretty-printer (exposed as hidden `fmt` subcommand) 103 | * Optimize IR cases 104 | * Fix padding 105 | * Fix bug in lexer (for C foreign calls) 106 | * Support down to GHC 8.0.2 107 | * Unification no longer takes pathologically long time 108 | * Add test files so source distribution passes 109 | * Some sort of imports now supported. 110 | 111 | ## 0.1.0.2 112 | 113 | * Add optimizations (simplify code so that liveness analysis is quicker) 114 | * Fix major bug in kind-checker 115 | * Fix bug in type assignment 116 | 117 | ## 0.1.0.1 118 | 119 | * Better debug pretty-printer 120 | * Pattern match exhaustiveness checker so that pattern matches don't do 121 | something heinous at runtime 122 | 123 | ## 0.1.0.0 124 | 125 | Initial release 126 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Vanessa McHale (c) 2020-2022 2 | 3 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 4 | 5 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 6 | 7 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | 9 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 10 | 11 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 12 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: install clean docs 2 | 3 | MAKEFLAGS += --warn-undefined-variables --no-builtin-rules 4 | .DELETE_ON_ERROR: 5 | 6 | HS_SRC := $(shell find src -type f) kempe.cabal 7 | 8 | BINS := bin/x86_64-linux-kc.lz \ 9 | bin/x86_64-linux-kc.gz \ 10 | bin/x86_64-linux-kc.zst \ 11 | bin/aarch64-linux-kc.lz \ 12 | bin/aarch64-linux-kc.gz \ 13 | bin/aarch64-linux-kc.zst 14 | 15 | install: 16 | cabal install exe:kc --overwrite-policy=always -w ghc-9.2.4 17 | strip $$(readlink -f $$(which kc)) 18 | 19 | moddeps.svg: $(HS_SRC) 20 | graphmod -i src | dot -Tsvg -o $@ 21 | 22 | packdeps.svg: kempe.cabal 23 | cabal build --disable-benchmarks --disable-tests 24 | cabal-plan dot | dot -Tsvg -o $@ 25 | 26 | bins: $(BINS) 27 | 28 | docs: docs/manual.pdf docs/manual.html 29 | 30 | docs/manual.pdf: docs/manual.md 31 | pandoc $^ -o $@ --toc 32 | 33 | docs/manual.html: docs/manual.md 34 | pandoc -s $^ -o $@ --toc 35 | 36 | numbertheory.S: lib/numbertheory.kmp 37 | kc $^ --dump-asm > $@ 38 | 39 | numbertheory.o: numbertheory.S 40 | nasm -g -f elf64 $^ -o $@ 41 | 42 | numbertheory: numbertheory.o test/harness/numbertheory.c 43 | gcc -g $^ -o $@ 44 | 45 | factorial.o: examples/factorial.kmp 46 | kc -g $^ $@ 47 | 48 | factorial: factorial.o test/harness/factorial.c 49 | gcc -g $^ -o $@ 50 | 51 | rts.o: rts.S 52 | nasm $^ -f elf64 -o $@ 53 | 54 | clean: 55 | rm -rf dist-newstyle *.rlib *.d *.rmeta *.o stack.yaml.lock factorial.S factorial splitmix.S numbertheory.S numbertheory *.so bin moddeps.svg packdeps.svg benchmarks/*_stub.h benchmarks/*.hi benchmarks/*.o 56 | 57 | %.zst: % 58 | sak compress $< $@ --best 59 | 60 | %.lz: % 61 | sak compress $< $@ --best 62 | 63 | %.gz: % 64 | sak compress $^ $@ --best 65 | 66 | bin/aarch64-linux-kc: $(HS_SRC) 67 | @mkdir -p $(dir $@) 68 | cabal build exe:kc --with-ghc=aarch64-linux-gnu-ghc --with-ghc-pkg=aarch64-linux-gnu-ghc-pkg --constraint='kempe +cross' --enable-executable-static 69 | export BIN=$$(fd 'aarch64-linux.*kc$$' dist-newstyle -t x -p -I); \ 70 | cp $$BIN $@ ; \ 71 | aarch64-linux-gnu-strip $@ 72 | 73 | bin/x86_64-linux-kc: $(HS_SRC) 74 | @mkdir -p $(dir $@) 75 | cabal build exe:kc 76 | export BIN=$$(fd 'x86_64-linux.*kc$$' dist-newstyle -t x -p -I); \ 77 | cp $$BIN $@ ; \ 78 | strip $@ 79 | 80 | tags: $(HS_SRC) 81 | echo ':ctags' | cabal repl 82 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Kempe 2 | 3 | Kempe is a stack-based language and toy compiler for x86_64 and aarch64. It requires the 4 | [nasm](https://nasm.us/) assembler when targeting x86_64. 5 | 6 | Inspiration is primarily from [Mirth](https://github.com/mirth-lang/mirth). 7 | 8 | See manual 9 | [here](http://hackage.haskell.org/package/kempe/src/docs/manual.pdf). There is 10 | also a tour of the compiler available 11 | [here](http://vmchale.com/static/original/compiler.pdf). 12 | 13 | ## Installation 14 | 15 | Installation is via [cabal-install](https://www.haskell.org/cabal/): 16 | 17 | ``` 18 | cabal install kempe 19 | ``` 20 | 21 | For shell completions put the following in your `~/.bashrc` or 22 | `~/.bash_profile`: 23 | 24 | ``` 25 | eval "$(kc --bash-completion-script kc)" 26 | ``` 27 | 28 | ## Defects 29 | 30 | * Errors don't have position information 31 | * Monomorphization fails on recursive polymorphic functions 32 | 33 | Hopefully this isn't too sinful; I can't think of any examples of recursive 34 | polymorphic functions 35 | * Can't export or call C functions with more than 6 arguments; can't call or 36 | export large arguments (i.e. structs) passed by value. 37 | 38 | This is less of an impediment than it sounds like. 39 | * Cyclic imports are not detected 40 | * Imports are kind of defective 41 | 42 | ### Comparison 43 | 44 | You may wish to use [Mirth](https://github.com/mirth-lang/mirth/) or 45 | [Factor](https://factorcode.org/) instead. Mirth is statically typed (similar to 46 | Kempe) but less mature. 47 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | - [ ] Fix Dickinson modules? lol 2 | - [ ] Take notes on phases, revisit Appel book 3 | # ABI support 4 | - [ ] Kempe ABI proper 5 | - [ ] Fortran? 6 | # Documentation 7 | - [ ] http://texdoc.net/texmf-dist/doc/latex/bytefield/bytefield.pdf 8 | # Examples 9 | - [ ] https://github.com/Keith-Cancel/k-hash/blob/main/khash.h 10 | - [ ] delink? 11 | - [x] Primality test (and link to C...) 12 | - [ ] Totient function 13 | - [ ] Needs sensible float support! 14 | - [x] splitmix random number generator? (or rather any pseudorandom number 15 | generator...) 16 | - [ ] http://prng.di.unimi.it/xoroshiro128plus.c 17 | - [ ] Exponentiation (O (log n)) 18 | - [ ] regular expressions? machine 19 | # Backends 20 | - [x] Linear scan register allocator 21 | - [ ] Graph (?) register allocator 22 | # Code 23 | - [ ] `typed-process`? 24 | # Performance 25 | - [ ] DList for arm backend? laying down asm... 26 | - [ ] look at http://hackage.haskell.org/package/linearscan-hoopl 27 | - [ ] Liveness analysis on a per-decl basis? (basic blocks) 28 | - [ ] `lea`, `xchg`? `test`? 29 | - [ ] `11111` could be True, everything else is false (then could use `xor` for 30 | int eq?) -> alternately `8` could be `True`, all else false `xor + popcnt`? 31 | - [ ] https://hackage.haskell.org/package/hashtables 32 | ## Data Structures 33 | - [ ] Difference lists when laying down atoms/IR 34 | - [ ] Do sets actually help? 35 | - [ ] https://hackage.haskell.org/package/hoopl (may be faster) 36 | - [ ] https://hackage.haskell.org/package/fmlist 37 | # Bugs 38 | - [ ] Specific error for mismatched pattern wildcards 39 | - [x] The current setup ignores extern imports -> no it doesn't 40 | - [x] Exported functions w/ C ABI should be there (so it can link) 41 | - [ ] Throw error when return value in C ABI is too big 42 | - [x] Constructors aren't monomorphized 43 | - [ ] Tries to monomorphize constructors that aren't exported 44 | - [ ] http://mlton.org/Monomorphise 45 | - [x] Constructors that call constructors don't dispatch/monomorphize 46 | properly? 47 | - [x] Correctly restore registers (C ABI) 48 | - [x] Warn on >256 constructors 49 | - [ ] Error on >256 constructors? 50 | - [x] Constructors not inlined; need type specializations when one calls 51 | a constructor on a constructor! 52 | - [x] Save callee-save registers on C call 53 | - [x] caller-save registers (`popa`?) 54 | - [ ] Something block-like that only saves registers that are actually used 55 | # Pipeline 56 | - [x] Inliner (all non-recursive?) 57 | # Features 58 | - [ ] Only save registers that get clobbered 59 | - [x] Aarch64 backend 60 | - [ ] https://developer.arm.com/documentation/102374/0101/Loads-and-stores---load-pair-and-store-pair 61 | - [ ] https://community.arm.com/developer/ip-products/processors/b/processors-ip-blog/posts/arm-a-profile-architecture-developments-2021 62 | - [ ] Arithmetic and patterns for `i8` 63 | - [ ] Patterns for words? 64 | - [ ] or-patterns (easy enough?) 65 | - [ ] `divMod` builtin? 66 | - [ ] Floats 67 | - [ ] `fmt` subcommand 68 | - [ ] `abstype` for pointer abstract types? 69 | - [ ] maybe just builtin lol 70 | - [ ] convert ints &c. between types 71 | - [ ] REPL for type inspection? 72 | - [ ] ─ 73 | - [x] Pattern match exhaustiveness checker 74 | - [ ] Tuples (?) 75 | - [ ] Error messages should have line numbers 76 | - [x] Tail-call optimization (easier than I thought?) 77 | - [x] Mutually recursive function optimization (what ATS does?) 78 | - [ ] tail recursion modulo cons ? 79 | - [ ] `.intel_syntax noprefix` for arm 80 | - [ ] RCL/RCR/ROL/ROR 81 | - [ ] real backend? https://github.com/AjayMT/nanoc 82 | - [ ] neat: http://joy-lang.org/papers-on-joy/atomic-programs-of-joy 83 | - [x] fall through on last case arm 84 | - [ ] Strip out loads to registers that aren't subsequently used (but not in 85 | a way that messes up the C ABI) 86 | - [ ] https://en.wikibooks.org/wiki/LaTeX/Source_Code_Listings <- in papers 87 | ## Builtins 88 | - [ ] `rem` builtin or the like? (basically functions in library) 89 | - [ ] `sal`, `sar`? 90 | - [x] `popcnt` basically 91 | - [ ] combinators: http://tunes.org/~iepos/joy.html#swap 92 | # Test Cases 93 | - [ ] Unit tests for type merge? 94 | - [ ] Unit tests for catTypes? 95 | - [ ] Test foreign calls (e.g. `random`) 96 | -------------------------------------------------------------------------------- /bash/bench: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # 'icc -fsyntax-only benchmarks/splitmix64.c' \ 4 | # 'icc -O0 -c benchmarks/splitmix64.c' \ 5 | bench 'gcc-10 -fsyntax-only benchmarks/splitmix64.c' \ 6 | 'clang-11 -fsyntax-only benchmarks/splitmix64.c' \ 7 | 'kc typecheck examples/splitmix.kmp' \ 8 | 'ghc -fno-code benchmarks/Splitmix.hs' \ 9 | 'gcc-10 -O0 -c benchmarks/splitmix64.c' \ 10 | 'clang-11 -O0 -c benchmarks/splitmix64.c' \ 11 | 'ghc -O0 benchmarks/Splitmix.hs' \ 12 | 'rustc --crate-type=lib --emit=dep-info,metadata benchmarks/splitmix.rs' \ 13 | 'rustc --crate-type=lib benchmarks/splitmix.rs' \ 14 | 'rustc --crate-type=cdylib benchmarks/splitmix.rs' \ 15 | 'kc examples/splitmix.kmp splitmix.o' \ 16 | 'kc examples/splitmix.kmp splitmix.o --arch aarch64' \ 17 | 'aarch64-linux-gnu-gcc -O0 -c benchmarks/splitmix64.c' \ 18 | 'clang-11 -c benchmarks/splitmix64.c --target=aarch64-linux-gnu' \ 19 | 'rustc --crate-type=cdylib benchmarks/splitmix.rs --target=aarch64-unknown-linux-gnu -C "linker=aarch64-linux-gnu-ld"' \ 20 | 'aarch64-linux-gnu-ghc -O0 benchmarks/Splitmix.hs' 21 | -------------------------------------------------------------------------------- /bash/bench-kc: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | bench 'kc typecheck examples/splitmix.kmp' \ 4 | 'kc examples/splitmix.kmp splitmix.o --arch x64' \ 5 | 'kc examples/splitmix.kmp splitmix.o --arch aarch64' \ 6 | -------------------------------------------------------------------------------- /bash/cross: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | 5 | cabal build --with-ghc=aarch64-linux-gnu-ghc --with-ghc-pkg=aarch64-linux-gnu-ghc-pkg --constraint='kempe +cross' --enable-executable-static 6 | cabal build --with-ghc=powerpc64le-linux-gnu-ghc --with-ghc-pkg=powerpc64le-linux-gnu-ghc-pkg --constraint='kempe +cross' --enable-executable-static 7 | cabal build --with-ghc=sparc64-linux-gnu-ghc --with-ghc-pkg=sparc64-linux-gnu-ghc-pkg --constraint='kempe +cross' --enable-executable-static 8 | cabal build --with-ghc=arm-linux-gnueabihf-ghc --with-ghc-pkg=arm-linux-gnueabihf-ghc-pkg --constraint='kempe +cross' --enable-executable-static 9 | -------------------------------------------------------------------------------- /bash/profile-install: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e pipefail 4 | 5 | cabal build exe:kc --enable-profiling -w ghc-9.0.1 6 | bin="$(fd -t x '^kc$' -I | tail -n1)" 7 | cp "$bin" "$HOME"/.local/bin/kc-prof 8 | -------------------------------------------------------------------------------- /bench/Bench.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Control.Exception (throw) 4 | import Criterion.Main 5 | import qualified Data.ByteString.Lazy as BSL 6 | import qualified Data.Text as T 7 | import qualified Data.Text.Lazy.IO as TLIO 8 | import Kempe.Asm.Liveness 9 | import qualified Kempe.Asm.X86.ControlFlow as X86 10 | import qualified Kempe.Asm.X86.Linear as X86 11 | import Kempe.Asm.X86.Trans 12 | import Kempe.Check.Pattern 13 | import Kempe.File 14 | import Kempe.IR 15 | import Kempe.IR.Opt 16 | import Kempe.Inline 17 | import Kempe.Lexer 18 | import Kempe.Module 19 | import Kempe.Monomorphize 20 | import Kempe.Parser 21 | import Kempe.Pipeline 22 | import Kempe.Shuttle 23 | import Kempe.TyAssign 24 | import Prettyprinter (Doc, defaultLayoutOptions, layoutCompact, layoutPretty) 25 | import Prettyprinter.Render.Text (renderLazy, renderStrict) 26 | import System.IO (hFlush) 27 | import System.IO.Temp (withSystemTempFile) 28 | 29 | main :: IO () 30 | main = 31 | defaultMain [ env (BSL.readFile "test/data/lex.kmp") $ \contents -> 32 | bgroup "parser" 33 | [ bench "lex" $ nf lexKempe contents 34 | , bench "parse" $ nf parse contents 35 | ] 36 | , env forTyEnv $ \ ~(p, s, prel) -> 37 | bgroup "type assignment" 38 | [ bench "check (test/data/ty.kmp)" $ nf runCheck p 39 | , bench "check (prelude/fn.kmp)" $ nf runCheck prel 40 | , bench "assign (test/data/ty.kmp)" $ nf runAssign p 41 | , bench "assign (prelude/fn.kmp)" $ nf runAssign prel 42 | , bench "shuttle (test/data/ty.kmp)" $ nf (uncurry monomorphize) p 43 | , bench "shuttle (examples/splitmix.kmp)" $ nf (uncurry monomorphize) s 44 | , bench "closedModule" $ nf (runSpecialize =<<) (runAssign p) 45 | ] 46 | , env eitherMod $ \ e -> 47 | bgroup "Pattern match exhaustiveness checker" 48 | [ bench "lib/either.kmp" $ nf checkModuleExhaustive e 49 | , bench "examples/vierergruppe.kmp" $ nf checkModuleExhaustive e 50 | ] 51 | , env parsedInteresting $ \ ~(f, n) -> 52 | bgroup "Inliner" 53 | [ bench "examples/factorial.kmp" $ nf inline (snd f) 54 | , bench "lib/numbertheory.kmp" $ nf inline (snd n) 55 | ] 56 | , env irEnv $ \ ~(s, f, n) -> 57 | bgroup "IR" 58 | [ bench "IR pipeline (examples/splitmix.kmp)" $ nf (fst . runIR) s -- IR benchmarks are a bit silly; I will use them to decide if I should use difference lists 59 | , bench "IR pipeline (examples/factorial.kmp)" $ nf (fst . runIR) f 60 | , bench "IR pipeline (lib/numbertheory.kmp)" $ nf (fst . runIR) n 61 | ] 62 | , env envIR $ \ ~(s, f) -> 63 | bgroup "opt" 64 | [ bench "IR optimization (examples/splitmix.kmp)" $ nf optimize s 65 | , bench "IR optimization (examples/factorial.kmp)" $ nf optimize f 66 | ] 67 | , env irEnv $ \ ~(s, f, _) -> 68 | bgroup "Instruction selection" 69 | [ bench "X86 (examples/factorial.kmp)" $ nf genX86 f 70 | , bench "X86 (examples/splitmix.kmp)" $ nf genX86 s 71 | ] 72 | , env x86Env $ \ ~(s, f) -> 73 | bgroup "Control flow graph" 74 | [ bench "X86 (examples/factorial.kmp)" $ nf X86.mkControlFlow f 75 | , bench "X86 (examples/splitmix.kmp)" $ nf X86.mkControlFlow s 76 | ] 77 | , env cfEnv $ \ ~(s, f, n, r) -> 78 | bgroup "Liveness analysis" 79 | [ bench "X86 (examples/factorial.kmp)" $ nf reconstruct f 80 | , bench "X86 (examples/splitmix.kmp)" $ nf reconstruct s 81 | , bench "X86 (lib/numbertheory.kmp)" $ nf reconstruct n 82 | , bench "X86 (lib/rational.kmp)" $ nf reconstruct r 83 | ] 84 | , env absX86 $ \ ~(s, f, n) -> 85 | bgroup "Register allocation" 86 | [ bench "X86/linear (examples/factorial.kmp)" $ nf X86.allocRegs f 87 | , bench "X86/linear (examples/splitmix.kmp)" $ nf X86.allocRegs s 88 | , bench "X86/linear (lib/numbertheory.kmp)" $ nf X86.allocRegs n 89 | ] 90 | , bgroup "Pipeline" 91 | [ bench "Validate (examples/factorial.kmp)" $ nfIO (tcFile "examples/factorial.kmp") 92 | , bench "Validate (examples/splitmix.kmp)" $ nfIO (tcFile "examples/splitmix.kmp") 93 | , bench "Validate (lib/numbertheory.kmp)" $ nfIO (tcFile "lib/numbertheory.kmp") 94 | , bench "Generate assembly (examples/factorial.kmp)" $ nfIO (writeAsm "examples/factorial.kmp") 95 | , bench "Generate assembly (examples/splitmix.kmp)" $ nfIO (writeAsm "examples/splitmix.kmp") 96 | , bench "Generate assembly (lib/numbertheory.kmp)" $ nfIO (writeAsm "lib/numbertheory.kmp") 97 | , bench "Generate assembly (lib/gaussian.kmp)" $ nfIO (writeAsm "lib/gaussian.kmp") 98 | , bench "Write assembly to file (lib/gaussian.kmp)" $ nfIO (writeAsmToFile "lib/gaussian.kmp") 99 | , bench "Generate arm assembly (examples/factorial.kmp)" $ nfIO (writeArmAsm "examples/factorial.kmp") 100 | , bench "Generate arm assembly (lib/gaussian.kmp)" $ nfIO (writeArmAsm "lib/gaussian.kmp") 101 | , bench "Object file (examples/factorial.kmp)" $ nfIO (compile "examples/factorial.kmp" "/tmp/factorial.o" False) 102 | , bench "Object file (lib/numbertheory.kmp)" $ nfIO (compile "lib/numbertheory.kmp" "/tmp/numbertheory.o" False) 103 | , bench "Object file (examples/splitmix.kmp)" $ nfIO (compile "examples/splitmix.kmp" "/tmp/splitmix.o" False) 104 | , bench "Object file (lib/rational.kmp)" $ nfIO (compile "lib/rational.kmp" "/tmp/rational.o" False) 105 | ] 106 | ] 107 | where parsedM = parseProcess "test/data/ty.kmp" 108 | splitmix = parseProcess "examples/splitmix.kmp" 109 | fac = parseProcess "examples/factorial.kmp" 110 | num = parseProcess "lib/numbertheory.kmp" 111 | rat = parseProcess "lib/rational.kmp" 112 | eitherMod = snd <$> parseProcess "lib/either.kmp" 113 | parsedInteresting = (,) <$> fac <*> num 114 | prelude = parseProcess "prelude/fn.kmp" 115 | forTyEnv = (,,) <$> parsedM <*> splitmix <*> prelude 116 | runCheck (maxU, m) = runTypeM maxU (checkModule m) 117 | runAssign (maxU, m) = runTypeM maxU (assignModule m) 118 | runSpecialize (m, i) = runMonoM i (closedModule m) 119 | splitmixMono = either throw id . uncurry monomorphize <$> splitmix 120 | facMono = either throw id . uncurry monomorphize <$> fac 121 | numMono = either throw id . uncurry monomorphize <$> num 122 | irEnv = (,,) <$> splitmixMono <*> facMono <*> numMono 123 | -- TODO: bench optimization 124 | runIR = runTempM . yrrucnu writeModule 125 | genIR = fst . runTempM . yrrucnu writeModule 126 | genX86 m = let (ir, u) = runIR m in irToX86 undefined u (optimize ir) 127 | facIR = genIR <$> facMono 128 | splitmixIR = genIR <$> splitmixMono 129 | envIR = (,) <$> splitmixIR <*> facIR 130 | facX86 = genX86 <$> facMono 131 | splitmixX86 = genX86 <$> splitmixMono 132 | x86Env = (,) <$> splitmixX86 <*> facX86 133 | numX86 = uncurry x86Parsed <$> num 134 | ratX86 = uncurry x86Parsed <$> rat 135 | facX86Cf = X86.mkControlFlow <$> facX86 136 | splitmixX86Cf = X86.mkControlFlow <$> splitmixX86 137 | numX86Cf = X86.mkControlFlow <$> numX86 138 | ratX86Cf = X86.mkControlFlow <$> ratX86 139 | cfEnv = (,,,) <$> splitmixX86Cf <*> facX86Cf <*> numX86Cf <*> ratX86Cf 140 | facAbsX86 = reconstruct <$> facX86Cf 141 | splitmixAbsX86 = reconstruct <$> splitmixX86Cf 142 | numAbsX86 = reconstruct <$> numX86Cf 143 | absX86 = (,,) <$> splitmixAbsX86 <*> facAbsX86 <*> numAbsX86 144 | -- not even gonna justify this 145 | yrrucnu f (y, x) = f x y 146 | 147 | writeAsmToFile :: FilePath 148 | -> IO () 149 | writeAsmToFile inp = withSystemTempFile "unassembled.kmp" $ \_ h -> do 150 | res <- parseProcess inp 151 | TLIO.hPutStr h $ renderLazy $ layoutCompact $ uncurry dumpX86 res 152 | hFlush h 153 | 154 | writeAsm :: FilePath 155 | -> IO T.Text 156 | writeAsm fp = do 157 | res <- parseProcess fp 158 | pure $ renderText $ uncurry dumpX86 res 159 | 160 | renderText :: Doc ann -> T.Text 161 | renderText = renderStrict . layoutPretty defaultLayoutOptions 162 | 163 | writeArmAsm :: FilePath 164 | -> IO T.Text 165 | writeArmAsm fp = do 166 | res <- parseProcess fp 167 | pure $ renderText $ uncurry dumpArm res 168 | -------------------------------------------------------------------------------- /benchmarks/Splitmix.hs: -------------------------------------------------------------------------------- 1 | module Splitmix ( next ) where 2 | 3 | import Data.Bits (shiftR, xor) 4 | import Data.Functor (($>)) 5 | import Data.Word (Word64) 6 | import Foreign.Ptr (Ptr) 7 | import Foreign.Storable (poke) 8 | 9 | next :: Word64 -> (Word64, Word64) 10 | next seed = (seed', rand) 11 | where seed' = seed + 0x9e3779b97f4a7c15 12 | z0 = seed' 13 | z1 = (z0 `xor` (z0 `shiftR` 30)) * 0xbf58476d1ce4e5b9 14 | z2 = (z1 `xor` (z1 `shiftR` 27)) * 0x94d049bb133111eb 15 | rand = z2 `xor` (z2 `shiftR` 31) 16 | 17 | c_next :: Word64 -> Ptr Word64 -> IO Word64 18 | c_next seed pSeed' = 19 | let (seed', rand) = next seed 20 | in poke pSeed' seed' $> rand 21 | 22 | foreign export ccall c_next :: Word64 -> Ptr Word64 -> IO Word64 23 | -------------------------------------------------------------------------------- /benchmarks/splitmix.rs: -------------------------------------------------------------------------------- 1 | #[no_mangle] 2 | pub extern "C" fn next(x: u64) -> (u64, u64) { 3 | let next_seed = x + 0x9e3779b97f4a7c15; 4 | let mut z = next_seed; 5 | z = (z ^ (z >> 30)) * 0xbf58476d1ce4e5b9; 6 | z = (z ^ (z >> 27)) * 0x94d049bb133111eb; 7 | return (z ^ (z >> 31), next_seed); 8 | } 9 | -------------------------------------------------------------------------------- /benchmarks/splitmix64.c: -------------------------------------------------------------------------------- 1 | typedef unsigned long int __uint64_t; 2 | typedef __uint64_t uint64_t; 3 | 4 | // modified to have ""multiple return"" since C doesn't really have that 5 | uint64_t next(uint64_t x, uint64_t* y) { 6 | uint64_t z = (x += 0x9e3779b97f4a7c15); 7 | z = (z ^ (z >> 30)) * 0xbf58476d1ce4e5b9; 8 | z = (z ^ (z >> 27)) * 0x94d049bb133111eb; 9 | *y = x; 10 | return z ^ (z >> 31); 11 | } 12 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./ 2 | 3 | haddock-internal: True 4 | 5 | program-options 6 | alex-options: -g 7 | happy-options: -gcsa 8 | 9 | package kempe 10 | ghc-options: -j +RTS -A32m 11 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | manual.html -------------------------------------------------------------------------------- /docs/manual.md: -------------------------------------------------------------------------------- 1 | % Kempe Compiler & Language Manual 2 | % Vanessa McHale 3 | 4 | # Introduction 5 | 6 | Kempe is a stack-based language, and `kc` is a toy compiler for x86_64 and 7 | aarch64. 8 | 9 | # Installing kc 10 | 11 | First, install [cabal](https://www.haskell.org/cabal/download.html) and 12 | [GHC](https://www.haskell.org/ghc/download.html). Then: 13 | 14 | ``` 15 | cabal install kempe 16 | ``` 17 | 18 | This provides `kc`, the Kempe compiler. 19 | 20 | `kc` requires [NASM](https://www.nasm.us/) when targeting x86_64. 21 | 22 | ## Editor Integration 23 | 24 | A [vim plugin](https://github.com/vmchale/kempe/tree/master/vim) is 25 | available. 26 | 27 | To install with [vim-plug](https://github.com/junegunn/vim-plug): 28 | 29 | ```vimscript 30 | Plug 'vmchale/kempe' , { 'rtp' : 'vim' } 31 | ``` 32 | 33 | # Kempe Language 34 | 35 | ## Types 36 | 37 | Kempe has a stack-based type system. So if you see a type signature: 38 | 39 | ``` 40 | next : Word -- Word Word 41 | ``` 42 | 43 | that means that the stack must have a `Word` on it for `next` to be invoked, and 44 | that it will have two `Word`s on the stack after it is invoked. 45 | 46 | ### Polymorphism 47 | 48 | Kempe allows polymorphic functions. So we can define: 49 | 50 | ``` 51 | id : a -- a 52 | =: [ ] 53 | ``` 54 | 55 | 56 | ## Literals 57 | 58 | Integer literals have type `-- Int`. 59 | 60 | Positive literals followed by a `u` have type `-- Word`, e.g. `1u`. 61 | 62 | Negative integer literals are indicated by an underscore, `_`, i.e. `_1` has 63 | type `-- Int`. 64 | 65 | ## Builtins 66 | 67 | The Kempe compiler has a few builtin functions that you can use for arithmetic 68 | and for shuffling data around. Many of them are familiar to stack-based 69 | programmers: 70 | 71 | * `dup : a -- a a` 72 | * `swap : a b -- b a` 73 | * `drop : a --` 74 | 75 | For arithmetic: 76 | 77 | * `+ : Int Int -- Int` 78 | * `* : Int Int -- Int` 79 | * `- : Int Int -- Int` 80 | * `/ : Int Int -- Int` 81 | * `% : Int Int -- Int` 82 | * `>> : Int Int -- Int` 83 | * `<< : Int Int -- Int` 84 | * `xori : Int Int -- Int` 85 | * `+~ : Word Word -- Word` 86 | * `*~ : Word Word -- Word` 87 | * `/~ : Word Word -- Word` 88 | * `%~ : Word Word -- Word` 89 | * `>>~ : Word Word -- Word` 90 | * `<<~ : Word Word -- Word` 91 | * `xoru : Word Word -- Word` 92 | * `popcount : Word -- Int` 93 | * `= : Int Int -- Bool` 94 | * `> : Int Int -- Bool` 95 | * `< : Int Int -- Bool` 96 | * `!= : Int Int -- Bool` 97 | * `<= : Int Int -- Bool` 98 | * `>= : Int Int -- Bool` 99 | * `& : Bool Bool -- Bool` 100 | * `|| : Bool Bool -- Bool` 101 | * `xor : Bool Bool -- Bool` 102 | * `~ : Int -- Int` 103 | 104 | `%` is like Haskell's `rem` and `/` is like Haskell's `quot`. `>>`, `<<`, `>>~`, 105 | and `<<~` are like Haskell's `rotate`; i.e. they are logical shifts (not 106 | arithmetic shifts). 107 | 108 | There is one higher-order construct, `dip`, which we illustrate by example: 109 | 110 | ``` 111 | nip : a b -- b 112 | =: [ dip(drop) ] 113 | ``` 114 | 115 | ### If Blocks 116 | 117 | If-blocks are atoms which contain two blocks of atoms on each arm. If the next 118 | item on the stack is `True`, the first will be executed, otherwise the second. 119 | 120 | ``` 121 | loop : Int Int -- Int 122 | =: [ swap dup 0 = 123 | if( drop 124 | , dup 1 - dip(*) swap loop ) 125 | ] 126 | 127 | fac_tailrec : Int -- Int 128 | =: [ 1 loop ] 129 | ``` 130 | 131 | ## Sum Types 132 | 133 | Kempe supports sum types, for instance: 134 | 135 | ``` 136 | type Maybe a { Just a | Nothing } 137 | ``` 138 | 139 | Note that empty sum types such as 140 | 141 | ``` 142 | type Void {} 143 | ``` 144 | 145 | are not really supported. 146 | 147 | ### Pattern Matching 148 | 149 | Sum types are taken apart with pattern matching, viz. 150 | 151 | ``` 152 | isJust : (Maybe a) -- Bool 153 | =: [ 154 | { case 155 | | Just -> drop True 156 | | Nothing -> False 157 | } 158 | ] 159 | ``` 160 | 161 | Note that pattern matches in Kempe must be exhaustive. 162 | 163 | ## Imports 164 | 165 | Kempe has rudimentary imports. As an example: 166 | 167 | ``` 168 | import "prelude/fn.kmp" 169 | 170 | type Pair a b { Pair a b } 171 | 172 | ... 173 | 174 | snd : ((Pair a) b) -- b 175 | =: [ unPair nip ] 176 | ``` 177 | 178 | where `prelude/fn.kmp` contains 179 | 180 | ``` 181 | ... 182 | 183 | nip : a b -- b 184 | =: [ dip(drop) ] 185 | 186 | ... 187 | ``` 188 | 189 | The import system is sort of defective. 190 | 191 | ## FFI 192 | 193 | Kempe can call into C functions. Suppose we have 194 | 195 | ```c 196 | int rand(void); 197 | ``` 198 | 199 | Then we can declare this as: 200 | 201 | ``` 202 | rand : -- Int 203 | =: $cfun"rand" 204 | ``` 205 | 206 | And `rand` will be available as a Kempe function. 207 | 208 | ## Recursion 209 | 210 | `kc` optimizes tail recursion. 211 | 212 | ## Non-Features 213 | 214 | Kempe is missing a good many features, such as: 215 | 216 | * Floats 217 | * Dynamically sized data types 218 | * Strings 219 | * Recursive data types 220 | * Pointers 221 | * Operator overloading 222 | 223 | # Programming in Kempe 224 | 225 | ## Invoking the Compiler 226 | 227 | `kc` cannot be used to produce executables. Rather, the Kempe compiler will 228 | produce `.o` files which contain functions. 229 | 230 | Kempe functions can be exported with a C ABI: 231 | 232 | ``` 233 | fac : Int -- Int 234 | =: [ dup 0 = 235 | if( drop 1 236 | , dup 1 - fac * ) 237 | ] 238 | 239 | %foreign cabi fac 240 | ``` 241 | 242 | This would be called with a C wrapper like so: 243 | 244 | ```c 245 | #include 246 | 247 | extern int fac(int); 248 | 249 | int main(int argc, char *argv[]) { 250 | printf("%d", fac(3)); 251 | } 252 | ``` 253 | 254 | The C ABI should work on Unix; it does not target Windows. 255 | 256 | There is also an alternate ABI, `armabi`, which takes a stack (to be used as the 257 | Kempe data stack) as the first argument. One would use it like so: 258 | 259 | ``` 260 | %foreign armabi fac 261 | ``` 262 | 263 | ```c 264 | #include 265 | #include 266 | 267 | extern int fact(void*, int); 268 | 269 | int main(int argc, char *argv[]) { 270 | void* kptr = malloc(32 * 1024); 271 | printf("%d", fac(kptr, 3)); 272 | } 273 | ``` 274 | 275 | Unlike the frontend and type checker, the backend is dodgy. 276 | 277 | ### Generating C Headers 278 | 279 | `kc` has the `cdecl` subcommand, which generates headers from exported Kempe 280 | functions. 281 | 282 | For the above example, one would get 283 | 284 | ```c 285 | extern int fac(int); 286 | ``` 287 | 288 | for `cabi` and 289 | 290 | ```c 291 | extern int fac(void*, int); 292 | ``` 293 | 294 | for `armabi`. 295 | 296 | ### Cross-Compilation 297 | 298 | `kc` is a cross-compiler; the target architecture can be set by passing one of 299 | `x64` or `aarch64` to `--arch`. By default `kc` targets the architecture of the 300 | host machine. 301 | 302 | You will need the appropriate assembler installed. 303 | 304 | ## Internals 305 | 306 | Kempe maintains its own stack and stores the pointer in `rbp` (x86) or `x19` 307 | (aarch64). 308 | 309 | Kempe procedures 310 | do not require any registers to be preserved across function calls. 311 | 312 | ### C Calls 313 | 314 | When exporting to C with the `cabi`, `kc` generates code that initializes the Kempe data pointer 315 | (`rbx`). Thus, one should avoid calling into Kempe code with `cabi` too often! 316 | 317 | Note that the Kempe data pointer is static, so calling different Kempe functions 318 | in different threads will fail unpredictably. 319 | 320 | ### Kempe ABI 321 | 322 | Sum types have a guaranteed representation so that they can be used from other 323 | languages. 324 | 325 | Consider: 326 | 327 | ``` 328 | type Param a b c 329 | { C a b b 330 | | D a b c 331 | } 332 | ``` 333 | 334 | Kempe types always have the same size; a value constructed with `C` will occupy 335 | the same number of bytes on the stack as a value constructed with `D`. 336 | 337 | So, for instance 338 | 339 | ``` 340 | mkD : Int8 Int Int8 -- (((Param Int8) Int) Int8) 341 | =: [ D ] 342 | ``` 343 | 344 | will pad the value with 7 bytes, as a `(((Param Int8) Int) Int8)` constructed 345 | with `C` would be 7 bytes bigger. 346 | 347 | # Examples 348 | 349 | ## Splitmix Pseudorandom Number Generator 350 | 351 | The generator in question comes from a [recent 352 | paper](https://dl.acm.org/doi/10.1145/2714064.2660195). 353 | 354 | Implementation turns out to be quite nice thanks to Kempe's multiple return 355 | values: 356 | 357 | ``` 358 | ; given a seed, return a random value and the new seed 359 | next : Word -- Word Word 360 | =: [ 0x9e3779b97f4a7c15u +~ dup 361 | dup 30u >>~ xoru 0xbf58476d1ce4e5b9u *~ 362 | dup 27u >>~ xoru 0x94d049bb133111ebu *~ 363 | dup 31u >>~ xoru 364 | ] 365 | 366 | %foreign kabi next 367 | ``` 368 | 369 | Compare this [C implementation](http://prng.di.unimi.it/splitmix64.c): 370 | 371 | ```c 372 | #include 373 | 374 | // modified to have ""multiple return"" with destination-passing style 375 | uint64_t next(uint64_t x, uint64_t* y) { 376 | uint64_t z = (x += 0x9e3779b97f4a7c15); 377 | z = (z ^ (z >> 30)) * 0xbf58476d1ce4e5b9; 378 | z = (z ^ (z >> 27)) * 0x94d049bb133111eb; 379 | *y = x; 380 | return z ^ (z >> 31); 381 | } 382 | ``` 383 | 384 | ## GCD 385 | 386 | ``` 387 | gcd : Int Int -- Int 388 | =: [ dup 0 = 389 | if( drop 390 | , dup dip(%) swap gcd ) 391 | ] 392 | ``` 393 | 394 | ## Mutual Recursion 395 | 396 | `kc` supports mutual recursion: 397 | 398 | ``` 399 | odd : Int -- Bool 400 | =: [ dup 0 = 401 | if( drop False 402 | , - 1 even ) 403 | ] 404 | 405 | even : Int -- Bool 406 | =: [ dup 0 = 407 | if( drop True 408 | , - 1 odd ) 409 | ] 410 | ``` 411 | -------------------------------------------------------------------------------- /docs/manual.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vmchale/kempe/15aa714ace9ad436e7b2c8366ae7c61a893afc99/docs/manual.pdf -------------------------------------------------------------------------------- /examples/factorial.kmp: -------------------------------------------------------------------------------- 1 | loop : Int Int -- Int 2 | =: [ swap dup 0 = 3 | if( drop 4 | , dup 1 - dip(*) swap loop ) 5 | ] 6 | 7 | ; tail recursive factorial 8 | ; 9 | ; see C example: https://wiki.c2.com/?TailRecursion 10 | fac_tailrec : Int -- Int 11 | =: [ 1 loop ] 12 | 13 | ; naïve factorial 14 | fac : Int -- Int 15 | =: [ dup 0 = 16 | if( drop 1 17 | , dup 1 - fac * ) 18 | ] 19 | 20 | %foreign armabi fac 21 | %foreign armabi fac_tailrec 22 | -------------------------------------------------------------------------------- /examples/hamming.kmp: -------------------------------------------------------------------------------- 1 | hamming : Word Word -- Int 2 | =: [ xoru popcount ] 3 | -------------------------------------------------------------------------------- /examples/os.kmp: -------------------------------------------------------------------------------- 1 | type OS { Macos | Linux | Windows | Freebsd } 2 | 3 | isUnix : OS -- Bool 4 | =: [ 5 | { case 6 | | Windows -> False 7 | | _ -> True 8 | } 9 | ] 10 | 11 | %foreign cabi isUnix 12 | -------------------------------------------------------------------------------- /examples/splitmix.kmp: -------------------------------------------------------------------------------- 1 | ; from here: http://prng.di.unimi.it/splitmix64.c 2 | 3 | ; given a seed, return a random value and the new seed 4 | next : Word -- Word Word 5 | =: [ 0x9e3779b97f4a7c15u +~ dup 6 | dup 30u >>~ xoru 0xbf58476d1ce4e5b9u *~ 7 | dup 27u >>~ xoru 0x94d049bb133111ebu *~ 8 | dup 31u >>~ xoru 9 | ] 10 | 11 | %foreign kabi next 12 | -------------------------------------------------------------------------------- /examples/vierergruppe.kmp: -------------------------------------------------------------------------------- 1 | type Element { E | A | B | C } 2 | 3 | ; see: https://mathworld.wolfram.com/Vierergruppe.html 4 | mult : Element Element -- Element 5 | =: [ 6 | { case 7 | | E -> 8 | | A -> { case | E -> A | A -> E | B -> C | C -> B } 9 | | B -> { case | E -> B | A -> C | B -> E | C -> A } 10 | | C -> { case | E -> C | A -> B | B -> A | C -> E } 11 | } 12 | ] 13 | 14 | %foreign kabi mult 15 | -------------------------------------------------------------------------------- /golden/CDecl.hs: -------------------------------------------------------------------------------- 1 | module CDecl ( goldenCDecl 2 | ) where 3 | 4 | import qualified Data.ByteString.Lazy as BSL 5 | import Data.Text.Lazy.Encoding (encodeUtf8) 6 | import Kempe.File 7 | import Language.C.AST 8 | import Prettyprinter (Doc, layoutSmart) 9 | import Prettyprinter.Render.Text (renderLazy) 10 | import Test.Tasty (TestTree) 11 | import Test.Tasty.Golden (goldenVsString) 12 | 13 | renderBSL :: Doc ann -> BSL.ByteString 14 | renderBSL = encodeUtf8 . renderLazy . layoutSmart cSettings where 15 | 16 | compileOutput :: FilePath 17 | -> IO BSL.ByteString 18 | compileOutput = fmap (renderBSL . prettyHeaders) . cDeclFile 19 | 20 | goldenCDecl :: FilePath -- ^ Kempe file 21 | -> FilePath -- ^ Golden header file 22 | -> TestTree 23 | goldenCDecl kFp golden = 24 | goldenVsString kFp golden (compileOutput kFp) 25 | -------------------------------------------------------------------------------- /golden/Golden.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import CDecl 4 | import Data.Tuple.Extra (uncurry3) 5 | import Harness 6 | import System.Info (arch) 7 | import Test.Tasty 8 | 9 | main :: IO () 10 | main = defaultMain $ 11 | testGroup "Golden output tests" $ 12 | fmap (uncurry3 goldenOutput) allGoldens ++ crossTests 13 | ++ fmap (uncurry goldenCDecl) headerGoldens 14 | 15 | -- These are redundant on arm 16 | crossTests :: [TestTree] 17 | crossTests = case arch of 18 | "x86_64" -> fmap (uncurry3 crossGolden) allGoldens 19 | "aarch64" -> [] 20 | _ -> error "Test suite must be run on x86_64 or aarch64" 21 | 22 | headerGoldens :: [(FilePath, FilePath)] 23 | headerGoldens = [ ("test/examples/splitmix.kmp", "test/include/splitmix.h") 24 | , ("lib/numbertheory.kmp", "test/include/num.h") 25 | ] 26 | 27 | allGoldens :: [(FilePath, FilePath, FilePath)] 28 | allGoldens = 29 | [ ("examples/factorial.kmp", "test/harness/factorial.c", "test/golden/factorial.out") 30 | , ("test/examples/splitmix.kmp", "test/harness/splitmix.c", "test/golden/splitmix.out") 31 | , ("lib/numbertheory.kmp", "test/harness/numbertheory.c", "test/golden/numbertheory.out") 32 | , ("test/examples/hamming.kmp", "test/harness/hamming.c", "test/golden/hamming.out") 33 | , ("test/examples/bool.kmp", "test/harness/bool.c", "test/golden/bool.out") 34 | , ("test/examples/const.kmp", "test/harness/const.c", "test/golden/const.out") 35 | , ("test/data/badCodegen.kmp", "test/harness/id.c", "test/golden/id.out") 36 | , ("test/data/mod.kmp", "test/harness/mod.c", "test/golden/mod.out") 37 | ] 38 | -------------------------------------------------------------------------------- /golden/Harness.hs: -------------------------------------------------------------------------------- 1 | module Harness ( goldenOutput 2 | , crossGolden 3 | ) where 4 | 5 | import qualified Data.ByteString.Lazy as BSL 6 | import qualified Data.ByteString.Lazy.Char8 as ASCII 7 | import Data.Functor (void) 8 | import Kempe.File 9 | import System.FilePath (()) 10 | import System.IO.Temp 11 | import System.Info (arch) 12 | import System.Process (CreateProcess (env, std_err), StdStream (Inherit), proc, readCreateProcess) 13 | import Test.Tasty 14 | import Test.Tasty.Golden (goldenVsString) 15 | 16 | data CC = CC 17 | | ArmCC 18 | 19 | instance Show CC where 20 | show CC = "cc" 21 | show ArmCC = "aarch64-linux-gnu-gcc" 22 | 23 | runGcc :: CC 24 | -> [FilePath] 25 | -> FilePath 26 | -> IO () 27 | runGcc cc fps o = 28 | void $ readCreateProcess ((proc (show cc) (fps ++ ["-o", o])) { std_err = Inherit }) "" 29 | 30 | compileOutput :: FilePath 31 | -> FilePath 32 | -> IO BSL.ByteString 33 | compileOutput fp harness = 34 | withSystemTempDirectory "kmp" $ \dir -> do 35 | let oFile = dir "kempe.o" 36 | exe = dir "kempe" 37 | compiler = case arch of 38 | "x86_64" -> compile 39 | "aarch64" -> armCompile 40 | _ -> error "Internal error in test suite! Must run on either x86_64 or aarch64" 41 | compiler fp oFile False 42 | runGcc CC [oFile, harness] exe 43 | readExe exe 44 | where readExe fp' = ASCII.pack <$> readCreateProcess ((proc fp' []) { std_err = Inherit }) "" 45 | 46 | crossCompileOutput :: FilePath 47 | -> FilePath 48 | -> IO BSL.ByteString 49 | crossCompileOutput fp harness = 50 | withSystemTempDirectory "kmp" $ \dir -> do 51 | let oFile = dir "kempe.o" 52 | exe = dir "kempe" 53 | armCompile fp oFile False 54 | runGcc ArmCC [oFile, harness] exe 55 | readExe exe 56 | where readExe fp' = ASCII.pack <$> readCreateProcess ((proc "qemu-aarch64-static" [fp']) { std_err = Inherit, env = qemuEnv }) "" 57 | qemuEnv = Just [("QEMU_LD_PREFIX", "/usr/aarch64-linux-gnu/")] 58 | 59 | goldenOutput :: FilePath -- ^ Kempe file 60 | -> FilePath -- ^ C test harness 61 | -> FilePath -- ^ Golden file path 62 | -> TestTree 63 | goldenOutput kFp cFp golden = 64 | goldenVsString kFp golden (compileOutput kFp cFp) 65 | 66 | crossGolden :: FilePath -- ^ Kempe file 67 | -> FilePath -- ^ C test harness 68 | -> FilePath -- ^ Golden file path 69 | -> TestTree 70 | crossGolden kFp cFp golden = 71 | goldenVsString kFp golden (crossCompileOutput kFp cFp) 72 | -------------------------------------------------------------------------------- /kempe.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: kempe 3 | version: 0.2.0.14 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | copyright: Copyright: (c) 2020-2022 Vanessa McHale 7 | maintainer: vamchale@gmail.com 8 | author: Vanessa McHale 9 | synopsis: Kempe compiler 10 | description: Kempe is a stack-based language 11 | category: Language, Compilers 12 | build-type: Simple 13 | data-files: 14 | test/data/*.kmp 15 | test/data/diamond/*.kmp 16 | test/err/*.kmp 17 | test/examples/*.kmp 18 | test/golden/*.out 19 | test/golden/*.ir 20 | test/include/*.h 21 | test/harness/*.c 22 | examples/*.kmp 23 | prelude/*.kmp 24 | lib/*.kmp 25 | docs/manual.pdf 26 | .ctags 27 | 28 | extra-doc-files: 29 | README.md 30 | CHANGELOG.md 31 | 32 | source-repository head 33 | type: git 34 | location: https://github.com/vmchale/kempe 35 | 36 | flag cross 37 | description: Enable to ease cross-compiling 38 | default: False 39 | manual: True 40 | 41 | library kempe-modules 42 | exposed-modules: 43 | Kempe.File 44 | Kempe.Lexer 45 | Kempe.Parser 46 | Kempe.AST 47 | Kempe.TyAssign 48 | Kempe.Monomorphize 49 | Kempe.Pipeline 50 | Kempe.Shuttle 51 | Kempe.Inline 52 | Kempe.Module 53 | Kempe.Check.Pattern 54 | Kempe.IR 55 | Kempe.IR.Opt 56 | Kempe.Asm.Liveness 57 | Kempe.Asm.X86.Trans 58 | Kempe.Asm.X86.ControlFlow 59 | Kempe.Asm.X86.Linear 60 | Kempe.Asm.Arm.Trans 61 | Kempe.Asm.Arm.ControlFlow 62 | Kempe.Asm.Arm.Linear 63 | Language.C.AST 64 | 65 | hs-source-dirs: src 66 | other-modules: 67 | Kempe.Check.Restrict 68 | Kempe.Check.TopLevel 69 | Kempe.Check.Lint 70 | Kempe.Unique 71 | Kempe.Name 72 | Kempe.Error 73 | Kempe.Error.Warning 74 | Kempe.AST.Size 75 | Kempe.Asm.Arm.Type 76 | Kempe.Asm.Arm.Opt 77 | Kempe.Asm.X86.Type 78 | Kempe.Asm.Type 79 | Kempe.Asm.Pretty 80 | Kempe.IR.Type 81 | Kempe.IR.Monad 82 | Kempe.CGen 83 | Kempe.Proc.Nasm 84 | Kempe.Proc.As 85 | Kempe.Debug 86 | Prettyprinter.Ext 87 | Prettyprinter.Debug 88 | Data.Foldable.Ext 89 | Data.Copointed 90 | Data.Tuple.Ext 91 | 92 | default-language: Haskell2010 93 | other-extensions: 94 | DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable 95 | FlexibleContexts GeneralizedNewtypeDeriving OverloadedStrings 96 | StandaloneDeriving TupleSections DeriveAnyClass 97 | 98 | ghc-options: -Wall -Wmissing-export-lists -Wcpp-undef 99 | -Wincomplete-uni-patterns -Wincomplete-record-updates 100 | -Wredundant-constraints -Widentities -Wunused-packages 101 | -Wno-x-partial -Wno-missing-signatures 102 | 103 | build-depends: 104 | base >=4.19 && <5, 105 | array, 106 | bytestring, 107 | containers >=0.6.0.0, 108 | deepseq, 109 | text, 110 | mtl, 111 | microlens, 112 | transformers, 113 | prettyprinter >=1.7.0, 114 | composition-prelude >=2.0.2.0, 115 | microlens-mtl >=0.1.8.0, 116 | process >=1.2.3.0, 117 | temporary 118 | 119 | if !flag(cross) 120 | build-tool-depends: alex:alex >=3.3.0.0, happy:happy >=1.17.1 121 | 122 | executable kc 123 | main-is: Main.hs 124 | hs-source-dirs: run 125 | other-modules: Paths_kempe 126 | autogen-modules: Paths_kempe 127 | default-language: Haskell2010 128 | ghc-options: -Wall -rtsopts -with-rtsopts=-A4m 129 | -Wmissing-export-lists -Wcpp-undef 130 | -Wincomplete-uni-patterns -Wincomplete-record-updates 131 | -Wredundant-constraints -Widentities -Wunused-packages 132 | 133 | build-depends: 134 | base, 135 | optparse-applicative, 136 | kempe-modules, 137 | prettyprinter >=1.7.0, 138 | bytestring, 139 | text 140 | 141 | test-suite kempe-test 142 | type: exitcode-stdio-1.0 143 | main-is: Spec.hs 144 | hs-source-dirs: test 145 | other-modules: 146 | Parser 147 | Type 148 | Backend 149 | Abi 150 | 151 | default-language: Haskell2010 152 | ghc-options: -threaded -rtsopts "-with-rtsopts=-N -K1K" -Wall 153 | -Wmissing-export-lists -Wcpp-undef 154 | -Wincomplete-uni-patterns -Wincomplete-record-updates 155 | -Wredundant-constraints -Widentities -Wunused-packages 156 | build-depends: 157 | base, 158 | kempe-modules, 159 | tasty, 160 | tasty-hunit, 161 | bytestring, 162 | prettyprinter >=1.7.0, 163 | deepseq, 164 | tasty-golden, 165 | text, 166 | composition-prelude 167 | 168 | test-suite kempe-golden 169 | type: exitcode-stdio-1.0 170 | main-is: Golden.hs 171 | hs-source-dirs: golden 172 | other-modules: 173 | Harness 174 | CDecl 175 | 176 | default-language: Haskell2010 177 | ghc-options: -threaded -rtsopts "-with-rtsopts=-N -K1K" -Wall 178 | -Wmissing-export-lists -Wcpp-undef 179 | -Wincomplete-uni-patterns -Wincomplete-record-updates 180 | -Wredundant-constraints -Widentities -Wunused-packages 181 | build-depends: 182 | base, 183 | kempe-modules, 184 | tasty, 185 | bytestring, 186 | process, 187 | temporary, 188 | filepath, 189 | tasty-golden, 190 | extra, 191 | prettyprinter, 192 | text 193 | 194 | benchmark kempe-bench 195 | type: exitcode-stdio-1.0 196 | main-is: Bench.hs 197 | hs-source-dirs: bench 198 | default-language: Haskell2010 199 | ghc-options: -Wall -rtsopts -with-rtsopts=-A4m -Wcpp-undef 200 | -Wincomplete-uni-patterns -Wincomplete-record-updates 201 | -Wredundant-constraints -Widentities -Wunused-packages 202 | -Wmissing-export-lists 203 | build-depends: 204 | base, 205 | kempe-modules, 206 | bytestring, 207 | criterion, 208 | prettyprinter, 209 | text, 210 | temporary 211 | -------------------------------------------------------------------------------- /lib/bool.kmp: -------------------------------------------------------------------------------- 1 | not : Bool -- Bool 2 | =: [ 3 | { case 4 | | True -> False 5 | | False -> True 6 | } 7 | ] 8 | 9 | eq : Bool Bool -- Bool 10 | =: [ xor not ] 11 | 12 | nand : Bool Bool -- Bool 13 | =: [ & not ] 14 | 15 | nor : Bool Bool -- Bool 16 | =: [ || not ] 17 | -------------------------------------------------------------------------------- /lib/either.kmp: -------------------------------------------------------------------------------- 1 | ; I'm not sure how useful this module is but I have it as a test for the 2 | ; typechecker and I guess to show how pattern matching works. 3 | 4 | type Either a b { Left a | Right b } 5 | 6 | fromRight : b ((Either a) b) -- b 7 | =: [ 8 | { case 9 | | Left -> drop 10 | | Right -> dip(drop) 11 | } 12 | ] 13 | 14 | join : ((Either a) ((Either a) b)) -- ((Either a) b) 15 | =: [ 16 | { case 17 | | Left -> Left 18 | | Right -> 19 | } 20 | ] 21 | 22 | isLeft : ((Either a) b) -- Bool 23 | =: [ 24 | { case 25 | | Left -> drop True 26 | | Right -> drop False 27 | } 28 | ] 29 | 30 | isRight : ((Either a) b) -- Bool 31 | =: [ 32 | { case 33 | | Right -> drop True 34 | | Left -> drop False 35 | } 36 | ] 37 | -------------------------------------------------------------------------------- /lib/gaussian.kmp: -------------------------------------------------------------------------------- 1 | ; Gaussian integers 2 | import"prelude/fn.kmp" 3 | 4 | type Gaussian { Gaussian Int Int } 5 | 6 | unGaussian : Gaussian -- Int Int 7 | =: [ {case | Gaussian ->} ] 8 | 9 | grp : a b c -- b a c 10 | =: [ dip(swap) ] 11 | 12 | ; perhaps unimpressive but I use this to test sizing 13 | add : Gaussian Gaussian -- Gaussian 14 | =: [ dip(unGaussian) unGaussian grp + dip(+) Gaussian ] 15 | 16 | multRe : Gaussian Gaussian -- Int 17 | =: [ dip(unGaussian) unGaussian dip(swap) * dip(*) - ] 18 | 19 | multIm : Gaussian Gaussian -- Int 20 | =: [ dip(unGaussian) unGaussian dip(*) swap dip(*) + ] 21 | 22 | mult : Gaussian Gaussian -- Gaussian 23 | =: [ dup2 multIm dip(multRe) Gaussian ] 24 | 25 | conjugate : Gaussian -- Gaussian 26 | =: [ unGaussian ~ Gaussian ] 27 | 28 | %foreign kabi add 29 | %foreign kabi conjugate 30 | %foreign kabi mult 31 | -------------------------------------------------------------------------------- /lib/libc.kmp: -------------------------------------------------------------------------------- 1 | ; bindings to libc (x86_64 guess) 2 | 3 | rand : -- Int 4 | =: $cfun"rand" 5 | 6 | exit : Int -- 7 | =: $cfun"exit" 8 | -------------------------------------------------------------------------------- /lib/maybe.kmp: -------------------------------------------------------------------------------- 1 | type Maybe a { Just a | Nothing } 2 | 3 | fromMaybe : a (Maybe a) -- a 4 | =: [ 5 | { case 6 | | Just -> dip(drop) 7 | | Nothing -> 8 | } 9 | ] 10 | 11 | join : (Maybe (Maybe a)) -- (Maybe a) 12 | =: [ 13 | { case 14 | | Just -> 15 | | Nothing -> Nothing 16 | } 17 | ] 18 | 19 | isJust : (Maybe a) -- Bool 20 | =: [ 21 | { case 22 | | Just -> drop True 23 | | Nothing -> False 24 | } 25 | ] 26 | 27 | isNothing : (Maybe a) -- Bool 28 | =: [ 29 | { case 30 | | Nothing -> True 31 | | Just -> drop False 32 | } 33 | ] 34 | -------------------------------------------------------------------------------- /lib/numbertheory.kmp: -------------------------------------------------------------------------------- 1 | import "prelude/fn.kmp" 2 | 3 | ; tail recursive! 4 | gcd : Int Int -- Int 5 | =: [ dup 0 = 6 | if( drop 7 | , dup dip(%) swap gcd ) 8 | ] 9 | 10 | lcm : Int Int -- Int 11 | =: [ dup2 dip(dip(*)) gcd / ] 12 | 13 | square : Int -- Int 14 | =: [ dup * ] 15 | 16 | divides : Int Int -- Bool 17 | =: [ % 0 = ] 18 | 19 | ; also tail recursive! 20 | ; 21 | ; kinda sus in that squaring will be integer overflow tho 22 | is_prime_step : Int Int -- Bool 23 | =: [ dup2 divides 24 | if( drop drop False 25 | , dup2 square < 26 | if( 1 + is_prime_step 27 | , drop drop True 28 | ) 29 | ) 30 | ] 31 | 32 | is_prime : Int -- Bool 33 | =: [ 2 is_prime_step ] 34 | 35 | k_gcd : Int Int -- Int 36 | =: [ gcd ] 37 | 38 | %foreign armabi k_gcd 39 | %foreign armabi is_prime 40 | -------------------------------------------------------------------------------- /lib/order.kmp: -------------------------------------------------------------------------------- 1 | import "prelude/fn.kmp" 2 | 3 | type Order { LT | EQ | GT } 4 | 5 | ; from Mirth 6 | cmpInt : Int Int -- Order 7 | =: [ dup2 = 8 | if( drop2 EQ 9 | , < if ( LT, GT ) 10 | ) 11 | ] 12 | -------------------------------------------------------------------------------- /lib/rational.kmp: -------------------------------------------------------------------------------- 1 | import"prelude/fn.kmp" 2 | import"lib/numbertheory.kmp" 3 | 4 | ; Slightly suspect rational based on 'Int' type 5 | type Rational a { Rational a a } 6 | 7 | unRational : (Rational a) -- a a 8 | =: [ { case | Rational -> } ] 9 | 10 | multRat : (Rational Int) (Rational Int) -- (Rational Int) 11 | =: [ dip(unRational) unRational dip(swap *) * Rational reduce ] 12 | 13 | reduce : (Rational Int) -- (Rational Int) 14 | =: [ unRational dup2 gcd dup dip(swap dip(/)) / Rational ] 15 | 16 | addRat : (Rational Int) (Rational Int) -- (Rational Int) 17 | =: [ dip(unRational) unRational dip(swap) 18 | dup2 * dip(swap dip(swap) * dip(*) +) 19 | Rational reduce 20 | ] 21 | 22 | %foreign kabi multRat 23 | %foreign kabi addRat 24 | %foreign kabi reduce 25 | -------------------------------------------------------------------------------- /lib/these.kmp: -------------------------------------------------------------------------------- 1 | type These a b { This a | That b | These a b } 2 | -------------------------------------------------------------------------------- /lib/tuple.kmp: -------------------------------------------------------------------------------- 1 | import "prelude/fn.kmp" 2 | 3 | type Pair a b { Pair a b } 4 | 5 | unPair : ((Pair a) b) -- a b 6 | =: [ { case | Pair -> } ] 7 | 8 | fst : ((Pair a) b) -- a 9 | =: [ unPair drop ] 10 | 11 | snd : ((Pair a) b) -- b 12 | =: [ unPair nip ] 13 | -------------------------------------------------------------------------------- /prelude/arith.kmp: -------------------------------------------------------------------------------- 1 | import "prelude/fn.kmp" 2 | import "lib/maybe.kmp" 3 | 4 | ; like haskell; % is rem and mod is... mod 5 | ; 6 | ; from here: https://hackage.haskell.org/package/ghc-prim-0.7.0/docs/src/GHC-Classes.html#modInt%23 7 | modInt : Int Int -- Int 8 | =: [ dup2 dup2 9 | 0 < dip(0 >) & 10 | dip(0 > dip(0 <) &) 11 | || 12 | dip(dup dip(%)) 13 | ; FIXME: hits the second branch when 2, -3 14 | if( dip(dip(dup) 0 !=) swap if(+, nip) 15 | , drop 16 | ) 17 | ] 18 | 19 | divInt : Int Int -- Int 20 | =: [ dup2 21 | 0 < dip(0 >) & 22 | if( dip(1 -) / 1 - 23 | , dup2 24 | 0 < dip(0 >) & 25 | if( dip(1 +) / 1 - 26 | ; FIXME: hits second branch when 2, -3 27 | , / 28 | ) 29 | ) 30 | ] 31 | 32 | succInt : Int -- Int 33 | =: [ 1 + ] 34 | 35 | predInt : Int -- Int 36 | =: [ 1 - ] 37 | 38 | isZeroInt : Int -- Bool 39 | =: [ 0 = ] 40 | 41 | absInt : Int -- Int 42 | =: [ dup 0 < 43 | if (~ ,) 44 | ] 45 | 46 | ; More from Mirth 47 | maxInt : Int Int -- Int 48 | =: [ dup2 < if(nip, drop) ] 49 | 50 | minInt : Int Int -- Int 51 | =: [ dup2 < if(drop, nip) ] 52 | 53 | ; checks for division by zero 54 | safeQuot : Int Int -- (Maybe Int) 55 | =: [ dup isZeroInt 56 | if( drop2 Nothing 57 | , / Just 58 | ) 59 | ] 60 | 61 | safeRem : Int Int -- (Maybe Int) 62 | =: [ dup isZeroInt 63 | if( drop2 Nothing 64 | , % Just 65 | ) 66 | ] 67 | -------------------------------------------------------------------------------- /prelude/fn.kmp: -------------------------------------------------------------------------------- 1 | ; from mirth 2 | 3 | id : a -- a 4 | =: [ ] 5 | 6 | trip : a -- a a a 7 | =: [ dup dup ] 8 | 9 | rotr : a b c -- c a b 10 | =: [ swap dip(swap) ] 11 | 12 | rotl : a b c -- c b a 13 | =: [ rotr swap ] 14 | 15 | ; from https://docs.factorcode.org/content/word-pick%2Ckernel.html 16 | pick : a b c -- a b c a 17 | =: [ dip(dip(dup)) dip(swap) swap ] 18 | 19 | over : a b -- a b a 20 | =: [ dip(dup) swap ] 21 | 22 | tuck : a b -- b a b 23 | =: [ dup dip(swap) ] 24 | 25 | nip : a b -- b 26 | =: [ dip(drop) ] 27 | 28 | dup2 : a b -- a b a b 29 | =: [ over over ] 30 | 31 | dup3 : a b c -- a b c a b c 32 | =: [ dip(dup2) dup dip(rotr) ] 33 | 34 | drop2 : a b -- 35 | =: [ drop drop ] 36 | 37 | drop3 : a b c -- 38 | =: [ drop drop drop ] 39 | 40 | ; from Joy 41 | choice : a a Bool -- a 42 | =: [ if( drop 43 | , nip 44 | ) 45 | ] 46 | -------------------------------------------------------------------------------- /run/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Control.Exception (Exception, throwIO) 4 | import Control.Monad ((<=<)) 5 | import qualified Data.ByteString.Lazy as BSL 6 | import qualified Data.Text.Lazy.IO as TLIO 7 | import qualified Data.Version as V 8 | import Kempe.AST 9 | import Kempe.File 10 | import Kempe.Lexer 11 | import Kempe.Parser 12 | import Language.C.AST 13 | import Options.Applicative 14 | import qualified Paths_kempe as P 15 | import Prettyprinter (LayoutOptions (LayoutOptions), PageWidth (AvailablePerLine), hardline, layoutSmart) 16 | import Prettyprinter.Render.Text (putDoc, renderIO, renderLazy) 17 | import System.Exit (ExitCode (ExitFailure), exitWith) 18 | import System.IO (stdout) 19 | import System.Info (arch) 20 | 21 | data Arch = Aarch64 22 | | X64 23 | 24 | data Command = TypeCheck !FilePath 25 | | Compile !FilePath !(Maybe FilePath) !Arch !Bool !Bool !Bool 26 | | Format !FilePath 27 | | Lint !FilePath 28 | | CDecl !FilePath !(Maybe FilePath) 29 | 30 | cdecl :: FilePath -> IO () 31 | cdecl = putDoc . (<> hardline) . prettyHeaders <=< cDeclFile 32 | 33 | writeCDecl :: FilePath -> FilePath -> IO () 34 | writeCDecl fp o = do 35 | ds <- cDeclFile fp 36 | TLIO.writeFile o (renderLazy $ layoutSmart cSettings $ prettyHeaders ds) 37 | 38 | fmt :: FilePath -> IO () 39 | fmt = renderIO stdout <=< fmap (render . (<> hardline) . prettyModule) . parsedFp 40 | where render = layoutSmart settings 41 | settings = LayoutOptions $ AvailablePerLine 80 0.5 42 | 43 | parsedFp :: FilePath -> IO (Module AlexPosn AlexPosn AlexPosn) 44 | parsedFp fp = do 45 | contents <- BSL.readFile fp 46 | yeetIO $ parse contents 47 | 48 | yeetIO :: Exception e => Either e a -> IO a 49 | yeetIO = either throwIO pure 50 | 51 | run :: Command -> IO () 52 | run (TypeCheck fp) = either throwIO pure =<< tcFile fp 53 | run (Lint fp) = maybe (pure ()) throwIO =<< warnFile fp 54 | run (Compile _ Nothing _ _ False False) = putStrLn "No output file specified!" 55 | run (Compile fp (Just o) X64 dbg False False) = compile fp o dbg 56 | run (Compile fp (Just o) Aarch64 dbg False False) = armCompile fp o dbg 57 | run (Compile fp Nothing _ False True False) = irFile fp 58 | run (Compile fp Nothing X64 False False True) = x86File fp 59 | run (Compile fp Nothing Aarch64 False False True) = armFile fp 60 | run (Format fp) = fmt fp 61 | run (CDecl fp Nothing) = cdecl fp 62 | run (CDecl fp (Just o)) = writeCDecl fp o 63 | run _ = putStrLn "Invalid combination of CLI options. Try kc --help" *> exitWith (ExitFailure 1) 64 | 65 | kmpFile :: Parser FilePath 66 | kmpFile = argument str 67 | (metavar "FILE" 68 | <> help "Source file" 69 | <> kmpCompletions) 70 | 71 | fmtP :: Parser Command 72 | fmtP = Format <$> kmpFile 73 | 74 | lintP :: Parser Command 75 | lintP = Lint <$> kmpFile 76 | 77 | cdeclP :: Parser Command 78 | cdeclP = CDecl <$> kmpFile <*> outFile 79 | 80 | debugSwitch :: Parser Bool 81 | debugSwitch = switch 82 | (long "debug" 83 | <> short 'g' 84 | <> help "Include debug symbols") 85 | 86 | archFlag :: Parser Arch 87 | archFlag = fmap parseArch $ optional $ strOption 88 | (long "arch" 89 | <> metavar "ARCH" 90 | <> help "Target architecture (x64 or aarch64)" 91 | <> completer (listCompleter ["x64", "aarch64"])) 92 | where parseArch :: Maybe String -> Arch 93 | parseArch str' = case (str', arch) of 94 | (Nothing, "aarch64") -> Aarch64 95 | (Nothing, "x86_64") -> X64 96 | (Just "aarch64", _) -> Aarch64 97 | (Just "arm64", _) -> Aarch64 98 | (Just "x64", _) -> X64 99 | (Just "x86_64", _) -> X64 100 | (Just "x86-64", _) -> X64 101 | (Just "amd64", _) -> X64 102 | _ -> error "Failed to parse architecture! Try one of x64, aarch64" 103 | 104 | irSwitch :: Parser Bool 105 | irSwitch = switch 106 | (long "dump-ir" 107 | <> help "Write intermediate representation to stdout") 108 | 109 | asmSwitch :: Parser Bool 110 | asmSwitch = switch 111 | (long "dump-asm" 112 | <> help "Write assembly (intel syntax) to stdout") 113 | 114 | outFile :: Parser (Maybe FilePath) 115 | outFile = optional $ argument str 116 | (metavar "OUTPUT" 117 | <> help "File output") 118 | 119 | kmpCompletions :: HasCompleter f => Mod f a 120 | kmpCompletions = completer . bashCompleter $ "file -X '!*.kmp' -o plusdirs" 121 | 122 | commandP :: Parser Command 123 | commandP = hsubparser 124 | (command "typecheck" (info tcP (progDesc "Type-check module contents")) 125 | <> command "lint" (info lintP (progDesc "Lint a file")) 126 | <> command "cdecl" (info cdeclP (progDesc "Generate C headers for exported Kempe code"))) 127 | <|> hsubparser (command "fmt" (info fmtP (progDesc "Pretty-print a Kempe file")) <> internal) 128 | <|> compileP 129 | where 130 | tcP = TypeCheck <$> kmpFile 131 | compileP = Compile <$> kmpFile <*> outFile <*> archFlag <*> debugSwitch <*> irSwitch <*> asmSwitch 132 | 133 | wrapper :: ParserInfo Command 134 | wrapper = info (helper <*> versionMod <*> commandP) 135 | (fullDesc 136 | <> progDesc "Kempe language compiler for X86_64 and Aarch64" 137 | <> header "Kempe - a stack-based language") 138 | 139 | versionMod :: Parser (a -> a) 140 | versionMod = infoOption (V.showVersion P.version) (short 'V' <> long "version" <> help "Show version") 141 | 142 | main :: IO () 143 | main = run =<< execParser wrapper 144 | -------------------------------------------------------------------------------- /src/Data/Copointed.hs: -------------------------------------------------------------------------------- 1 | module Data.Copointed ( Copointed (..) 2 | ) where 3 | 4 | class Copointed p where 5 | copoint :: p a -> a 6 | -------------------------------------------------------------------------------- /src/Data/Foldable/Ext.hs: -------------------------------------------------------------------------------- 1 | module Data.Foldable.Ext ( foldMapA 2 | , foldMapAlternative 3 | ) where 4 | 5 | import Control.Applicative (Alternative) 6 | import Data.Foldable (asum, fold) 7 | 8 | foldMapAlternative :: (Traversable t, Alternative f) => (a -> f b) -> t a -> f b 9 | foldMapAlternative f xs = asum (f <$> xs) 10 | 11 | foldMapA :: (Applicative f, Traversable t, Monoid m) => (a -> f m) -> t a -> f m 12 | foldMapA = (fmap fold .) . traverse 13 | -------------------------------------------------------------------------------- /src/Data/Tuple/Ext.hs: -------------------------------------------------------------------------------- 1 | module Data.Tuple.Ext ( fst3 2 | , snd3 3 | , thd3 4 | , third3 5 | ) where 6 | 7 | fst3 :: (a, b, c) -> a 8 | fst3 (x, _, _) = x 9 | 10 | snd3 :: (a, b, c) -> b 11 | snd3 (_, x, _) = x 12 | 13 | thd3 :: (a, b, c) -> c 14 | thd3 (_, _, x) = x 15 | 16 | third3 f (x, y, z) = (x, y, f z) 17 | -------------------------------------------------------------------------------- /src/Kempe/AST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | 8 | -- | Frontend AST 9 | module Kempe.AST ( ConsAnn (..) 10 | , Atom (..) 11 | , BuiltinFn (..) 12 | , KempeDecl (..) 13 | , Pattern (..) 14 | , Declarations 15 | , Module (..) 16 | , ABI (..) 17 | , BuiltinTy (..) 18 | , KempeTy (..) 19 | , StackType (..) 20 | , MonoStackType 21 | , prettyMonoStackType 22 | , freeVars 23 | , prettyTyped 24 | , prettyTypedModule 25 | , prettyFancyModule 26 | , prettyModule 27 | , flipStackType 28 | , prettyTypedDecl 29 | -- * I resent this... 30 | , voidStackType 31 | ) where 32 | 33 | import Control.DeepSeq (NFData) 34 | import Data.Bifunctor (Bifunctor (..)) 35 | import qualified Data.ByteString.Lazy as BSL 36 | import Data.Foldable (toList) 37 | import Data.Functor (void) 38 | import qualified Data.Functor as Fun 39 | import Data.Int (Int64, Int8) 40 | import Data.List.NonEmpty (NonEmpty) 41 | import qualified Data.List.NonEmpty as NE 42 | import qualified Data.Set as S 43 | import Data.Text.Lazy.Encoding (decodeUtf8) 44 | import Data.Word (Word8) 45 | import GHC.Generics (Generic) 46 | import Kempe.AST.Size 47 | import Kempe.Name 48 | import Numeric.Natural 49 | import Prettyprinter (Doc, Pretty (pretty), align, braces, brackets, colon, concatWith, dquotes, fillSep, hsep, parens, pipe, sep, vsep, (<+>)) 50 | import Prettyprinter.Ext 51 | 52 | 53 | -- | Annotation carried on constructors to keep size information through the IR 54 | -- generation phase. 55 | data ConsAnn a = ConsAnn { tySz :: Int64, tag :: Word8, consTy :: a } 56 | deriving (Functor, Foldable, Traversable, Generic, NFData) 57 | 58 | instance Pretty a => Pretty (ConsAnn a) where 59 | pretty (ConsAnn tSz b ty) = braces ("tySz" <+> colon <+> pretty tSz <+> "tag" <+> colon <+> pretty b <+> "type" <+> colon <+> pretty ty) 60 | 61 | voidStackType :: StackType a -> StackType () 62 | voidStackType (StackType ins outs) = StackType (void <$> ins) (void <$> outs) 63 | 64 | data Pattern c b = PatternInt b Integer 65 | | PatternCons { patternKind :: c, patternName :: TyName c } -- a constructed pattern 66 | | PatternWildcard b 67 | | PatternBool b Bool 68 | deriving (Eq, Ord, Generic, NFData, Functor, Foldable, Traversable) 69 | 70 | instance Bifunctor Pattern where 71 | second = fmap 72 | first f (PatternCons l tn) = PatternCons (f l) (fmap f tn) 73 | first _ (PatternInt l i) = PatternInt l i 74 | first _ (PatternWildcard l) = PatternWildcard l 75 | first _ (PatternBool l b) = PatternBool l b 76 | 77 | instance Pretty (Pattern c a) where 78 | pretty (PatternInt _ i) = pretty i 79 | pretty (PatternBool _ b) = pretty b 80 | pretty PatternWildcard{} = "_" 81 | pretty (PatternCons _ tn) = pretty tn 82 | 83 | prettyTypedPattern :: (Pretty a) => Pattern a b -> Doc ann 84 | prettyTypedPattern (PatternCons ty tn) = parens (pretty tn <+> ":" <+> pretty ty) 85 | prettyTypedPattern p = pretty p 86 | 87 | instance Pretty (Atom c a) where 88 | pretty (AtName _ n) = pretty n 89 | pretty (Dip _ as) = "dip(" <> fillSep (fmap pretty as) <> ")" 90 | pretty (AtBuiltin _ b) = pretty b 91 | pretty (AtCons _ tn) = pretty tn 92 | pretty (If _ as as') = "if(" <> align (fillSep (fmap pretty as)) <> ", " <> align (fillSep (fmap pretty as')) <> ")" 93 | pretty (IntLit _ i) = pretty i 94 | pretty (BoolLit _ b) = pretty b 95 | pretty (WordLit _ w) = pretty w <> "u" 96 | pretty (Int8Lit _ i) = pretty i <> "i8" 97 | pretty (Case _ ls) = "case" <+> braces (align (vsep (toList $ fmap (uncurry prettyLeaf) ls))) 98 | 99 | prettyLeaf :: Pattern c a -> [Atom c a] -> Doc ann 100 | prettyLeaf p as = pipe <+> pretty p <+> "->" <+> align (fillSep (fmap pretty as)) 101 | 102 | prettyTypedLeaf :: (Pretty a, Pretty b) => Pattern a b -> [Atom a b] -> Doc ann 103 | prettyTypedLeaf p as = pipe <+> prettyTypedPattern p <+> "->" <+> align (fillSep (fmap prettyTyped as)) 104 | 105 | prettyTyped :: (Pretty a, Pretty b) => Atom a b -> Doc ann 106 | prettyTyped (AtName ty n) = parens (pretty n <+> ":" <+> pretty ty) 107 | prettyTyped (Dip _ as) = "dip(" <> fillSep (prettyTyped <$> as) <> ")" 108 | prettyTyped (AtBuiltin ty b) = parens (pretty b <+> ":" <+> pretty ty) 109 | prettyTyped (AtCons ty tn) = parens (pretty tn <+> ":" <+> pretty ty) 110 | prettyTyped (If _ as as') = "if(" <> fillSep (prettyTyped <$> as) <> ", " <> fillSep (prettyTyped <$> as') <> ")" 111 | prettyTyped (IntLit _ i) = pretty i 112 | prettyTyped (BoolLit _ b) = pretty b 113 | prettyTyped (Int8Lit _ i) = pretty i <> "i8" 114 | prettyTyped (WordLit _ n) = pretty n <> "u" 115 | prettyTyped (Case _ ls) = braces ("case" <+> vsep (toList $ fmap (uncurry prettyTypedLeaf) ls)) 116 | 117 | data Atom c b = AtName b (Name b) 118 | | Case b (NonEmpty (Pattern c b, [Atom c b])) 119 | | If b [Atom c b] [Atom c b] 120 | | Dip b [Atom c b] 121 | | IntLit b Integer 122 | | WordLit b Natural 123 | | Int8Lit b Int8 124 | | BoolLit b Bool 125 | | AtBuiltin b BuiltinFn 126 | | AtCons c (TyName c) 127 | deriving (Eq, Ord, Generic, NFData, Functor, Foldable, Traversable) 128 | 129 | instance Bifunctor Atom where 130 | second = fmap 131 | first f (AtCons l n) = AtCons (f l) (fmap f n) 132 | first _ (AtName l n) = AtName l n 133 | first _ (IntLit l i) = IntLit l i 134 | first _ (WordLit l w) = WordLit l w 135 | first _ (Int8Lit l i) = Int8Lit l i 136 | first _ (BoolLit l b) = BoolLit l b 137 | first _ (AtBuiltin l b) = AtBuiltin l b 138 | first f (Dip l as) = Dip l (fmap (first f) as) 139 | first f (If l as as') = If l (fmap (first f) as) (fmap (first f) as') 140 | first f (Case l ls) = 141 | let (ps, aLs) = Fun.unzip ls 142 | in Case l $ NE.zip (fmap (first f) ps) (fmap (fmap (first f)) aLs) 143 | 144 | data BuiltinFn = Drop 145 | | Swap 146 | | Dup 147 | | IntPlus 148 | | IntMinus 149 | | IntTimes 150 | | IntDiv 151 | | IntMod 152 | | IntEq 153 | | IntLeq 154 | | IntLt 155 | | IntGeq 156 | | IntGt 157 | | IntNeq 158 | | IntShiftR 159 | | IntShiftL 160 | | IntXor 161 | | WordPlus 162 | | WordTimes 163 | | WordMinus 164 | | WordDiv 165 | | WordMod 166 | | WordShiftR 167 | | WordShiftL 168 | | WordXor 169 | | And 170 | | Or 171 | | Xor 172 | | IntNeg 173 | | Popcount 174 | deriving (Eq, Ord, Generic, NFData) 175 | 176 | instance Pretty BuiltinFn where 177 | pretty Drop = "drop" 178 | pretty Swap = "swap" 179 | pretty Dup = "dup" 180 | pretty IntPlus = "+" 181 | pretty IntMinus = "-" 182 | pretty IntTimes = "*" 183 | pretty IntDiv = "/" 184 | pretty IntMod = "%" 185 | pretty IntEq = "=" 186 | pretty IntLeq = "<=" 187 | pretty IntLt = "<" 188 | pretty IntShiftR = ">>" 189 | pretty IntShiftL = "<<" 190 | pretty WordPlus = "+~" 191 | pretty WordTimes = "*~" 192 | pretty WordShiftL = "<<~" 193 | pretty WordShiftR = ">>~" 194 | pretty IntXor = "xori" 195 | pretty WordXor = "xoru" 196 | pretty IntGeq = ">=" 197 | pretty IntGt = ">" 198 | pretty IntNeq = "!=" 199 | pretty WordMinus = "-~" 200 | pretty WordDiv = "/~" 201 | pretty WordMod = "%~" 202 | pretty And = "&" 203 | pretty Or = "||" 204 | pretty Xor = "xor" 205 | pretty IntNeg = "~" 206 | pretty Popcount = "popcount" 207 | 208 | prettyKempeDecl :: (Atom c b -> Doc ann) -> KempeDecl a c b -> Doc ann 209 | prettyKempeDecl atomizer (FunDecl _ n is os as) = pretty n <+> align (":" <+> sep (fmap pretty is) <+> "--" <+> sep (fmap pretty os) <#> "=:" <+> brackets (align (fillSep (atomizer <$> as)))) 210 | prettyKempeDecl _ (Export _ abi n) = "%foreign" <+> pretty abi <+> pretty n 211 | prettyKempeDecl _ (ExtFnDecl _ n is os b) = pretty n <+> align (":" <+> sep (fmap pretty is) <+> "--" <+> sep (fmap pretty os) <#> "=:" <+> "$cfun" <> dquotes (pretty (decodeUtf8 b))) 212 | prettyKempeDecl _ (TyDecl _ tn ns ls) = "type" <+> pretty tn <+> hsep (fmap pretty ns) <+> braces (concatWith (\x y -> x <+> pipe <+> y) $ fmap (uncurry prettyTyLeaf) ls) 213 | 214 | instance Pretty (KempeDecl a b c) where 215 | pretty = prettyKempeDecl pretty 216 | 217 | prettyTyLeaf :: TyName a -> [KempeTy b] -> Doc ann 218 | prettyTyLeaf cn vars = pretty cn <+> hsep (fmap pretty vars) 219 | 220 | -- TODO: separate annotations for TyName in TyDecl 221 | data KempeDecl a c b = TyDecl a (TyName a) [Name a] [(TyName b, [KempeTy a])] 222 | | FunDecl b (Name b) [KempeTy a] [KempeTy a] [Atom c b] 223 | | ExtFnDecl b (Name b) [KempeTy a] [KempeTy a] BSL.ByteString -- ShortByteString? 224 | | Export b ABI (Name b) 225 | deriving (Eq, Ord, Generic, NFData, Functor, Foldable, Traversable) 226 | 227 | instance Bifunctor (KempeDecl a) where 228 | first _ (TyDecl x tn ns ls) = TyDecl x tn ns ls 229 | first f (FunDecl l n tys tys' as) = FunDecl l n tys tys' (fmap (first f) as) 230 | first _ (ExtFnDecl l n tys tys' b) = ExtFnDecl l n tys tys' b 231 | first _ (Export l abi n) = Export l abi n 232 | second = fmap 233 | 234 | prettyDeclarationsGeneral :: (Atom c b -> Doc ann) -> Declarations a c b -> Doc ann 235 | prettyDeclarationsGeneral atomizer = sepDecls . fmap (prettyKempeDecl atomizer) 236 | 237 | prettyImport :: BSL.ByteString -> Doc ann 238 | prettyImport b = "import" <+> dquotes (pretty (decodeUtf8 b)) 239 | 240 | prettyModuleGeneral :: (Atom c b -> Doc ann) -> Module a c b -> Doc ann 241 | prettyModuleGeneral atomizer (Module [] ds) = prettyDeclarationsGeneral atomizer ds 242 | prettyModuleGeneral atomizer (Module is ds) = prettyLines (fmap prettyImport is) <##> prettyDeclarationsGeneral atomizer ds 243 | 244 | prettyDecls :: Declarations a c b -> Doc ann 245 | prettyDecls = prettyDeclarationsGeneral pretty 246 | 247 | prettyFancyModule :: (Pretty a, Pretty b) => Declarations c (ConsAnn a) b -> Doc ann 248 | prettyFancyModule = prettyTypedModule . fmap (first consTy) 249 | 250 | prettyTypedDecl :: (Pretty a, Pretty b) => KempeDecl c a b -> Doc ann 251 | prettyTypedDecl = prettyKempeDecl prettyTyped 252 | 253 | prettyTypedModule :: (Pretty a, Pretty b) => Declarations c a b -> Doc ann 254 | prettyTypedModule = prettyDeclarationsGeneral prettyTyped 255 | 256 | prettyModule :: Module a c b -> Doc ann 257 | prettyModule = prettyModuleGeneral pretty 258 | 259 | type Declarations a c b = [KempeDecl a c b] 260 | 261 | data Module a c b = Module { importFps :: [BSL.ByteString] 262 | , body :: [KempeDecl a c b] 263 | } deriving (Generic, NFData) 264 | 265 | extrVars :: KempeTy a -> [Name a] 266 | extrVars TyBuiltin{} = [] 267 | extrVars TyNamed{} = [] 268 | extrVars (TyVar _ n) = [n] 269 | extrVars (TyApp _ ty ty') = extrVars ty ++ extrVars ty' 270 | 271 | freeVars :: [KempeTy a] -> S.Set (Name a) 272 | freeVars tys = S.fromList (concatMap extrVars tys) 273 | 274 | -- | Used in "Kempe.Monomorphize" for patterns 275 | flipStackType :: StackType () -> StackType () 276 | flipStackType (StackType is os) = StackType os is 277 | -------------------------------------------------------------------------------- /src/Kempe/AST/Size.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | -- | Frontend AST 7 | -- | This module is split out so that the bakend/IR need not depend on 8 | -- everything in 'AST'. 9 | module Kempe.AST.Size ( KempeTy (..) 10 | , StackType (..) 11 | , MonoStackType 12 | , BuiltinTy (..) 13 | , ABI (..) 14 | , prettyMonoStackType 15 | -- * Sizing bits 16 | , SizeEnv 17 | , Size 18 | , size 19 | , size' 20 | , sizeStack 21 | ) where 22 | 23 | import Control.DeepSeq (NFData) 24 | import Data.Int (Int64) 25 | import qualified Data.IntMap as IM 26 | import Data.Monoid (Sum (..)) 27 | import GHC.Generics (Generic) 28 | import Kempe.Name 29 | import Kempe.Unique 30 | import Prettyprinter (Doc, Pretty (pretty), parens, sep, (<+>)) 31 | 32 | data KempeTy a = TyBuiltin a BuiltinTy 33 | | TyNamed a (TyName a) 34 | | TyVar a (Name a) 35 | | TyApp a (KempeTy a) (KempeTy a) -- type applied to another, e.g. Just Int 36 | deriving (Generic, NFData, Functor, Eq, Ord) -- questionable eq instance but eh 37 | 38 | data StackType b = StackType { inTypes :: [KempeTy b] 39 | , outTypes :: [KempeTy b] 40 | } deriving (Generic, NFData, Eq, Ord) 41 | 42 | type MonoStackType = ([KempeTy ()], [KempeTy ()]) 43 | 44 | prettyMonoStackType :: ([KempeTy a], [KempeTy a]) -> Doc ann 45 | prettyMonoStackType (is, os) = sep (fmap pretty is) <+> "--" <+> sep (fmap pretty os) 46 | 47 | data BuiltinTy = TyInt 48 | | TyBool 49 | | TyInt8 50 | | TyWord 51 | deriving (Generic, NFData, Eq, Ord) 52 | 53 | instance Pretty BuiltinTy where 54 | pretty TyInt = "Int" 55 | pretty TyBool = "Bool" 56 | pretty TyInt8 = "Int8" 57 | pretty TyWord = "Word" 58 | 59 | instance Pretty (KempeTy a) where 60 | pretty (TyBuiltin _ b) = pretty b 61 | pretty (TyNamed _ tn) = pretty tn 62 | pretty (TyVar _ n) = pretty n 63 | pretty (TyApp _ ty ty') = parens (pretty ty <+> pretty ty') 64 | 65 | instance Pretty (StackType a) where 66 | pretty (StackType ins outs) = sep (fmap pretty ins) <+> "--" <+> sep (fmap pretty outs) 67 | 68 | data ABI = Cabi 69 | | Kabi 70 | | Hooked 71 | | ArmAbi 72 | deriving (Eq, Ord, Generic, NFData) 73 | 74 | instance Pretty ABI where 75 | pretty Cabi = "cabi" 76 | pretty Kabi = "kabi" 77 | pretty Hooked = "hooked" 78 | pretty ArmAbi = "armabi" 79 | 80 | -- machinery for assigning a constructor to a function of its concrete types 81 | -- (and then curry forward...) 82 | 83 | type Size = [Int64] -> Int64 84 | type SizeEnv = IM.IntMap Size 85 | 86 | -- the kempe sizing system is kind of fucked (it works tho) 87 | 88 | -- | Don't call this on ill-kinded types; it won't throw any error. 89 | size :: SizeEnv -> KempeTy a -> Size 90 | size _ (TyBuiltin _ TyInt) = const 8 91 | size _ (TyBuiltin _ TyBool) = const 1 92 | size _ (TyBuiltin _ TyInt8) = const 1 93 | size _ (TyBuiltin _ TyWord) = const 8 94 | size _ TyVar{} = error "Internal error: type variables should not be present at this stage." 95 | size env (TyNamed _ (Name _ (Unique k) _)) = IM.findWithDefault (error "Size not in map!") k env 96 | size env (TyApp _ ty ty') = \tys -> size env ty (size env ty' [] : tys) 97 | 98 | size' :: SizeEnv -> KempeTy a -> Int64 99 | size' env = ($ []) . size env 100 | 101 | sizeStack :: SizeEnv -> [KempeTy a] -> Int64 102 | sizeStack env = getSum . foldMap (Sum . size' env) 103 | -------------------------------------------------------------------------------- /src/Kempe/Asm/Arm/ControlFlow.hs: -------------------------------------------------------------------------------- 1 | module Kempe.Asm.Arm.ControlFlow ( mkControlFlow 2 | , ControlAnn (..) 3 | ) where 4 | 5 | import Control.Monad.State.Strict (State, evalState, gets, modify) 6 | import Data.Bifunctor (first, second) 7 | import Data.Functor (($>)) 8 | import qualified Data.IntSet as IS 9 | import qualified Data.Map as M 10 | import Kempe.Asm.Arm.Type 11 | import Kempe.Asm.Type 12 | 13 | -- map of labels by node 14 | type FreshM = State (Int, M.Map Label Int) 15 | 16 | runFreshM :: FreshM a -> a 17 | runFreshM = flip evalState (0, mempty) 18 | 19 | mkControlFlow :: [Arm AbsReg ()] -> [Arm AbsReg ControlAnn] 20 | mkControlFlow instrs = runFreshM (broadcasts instrs *> addControlFlow instrs) 21 | 22 | getFresh :: FreshM Int 23 | getFresh = gets fst <* modify (first (+1)) 24 | 25 | lookupLabel :: Label -> FreshM Int 26 | lookupLabel l = gets (M.findWithDefault (error "Internal error in control-flow graph: node label not in map.") l . snd) 27 | 28 | broadcast :: Int -> Label -> FreshM () 29 | broadcast i l = modify (second (M.insert l i)) 30 | 31 | singleton :: AbsReg -> IS.IntSet 32 | singleton = maybe IS.empty IS.singleton . toInt 33 | 34 | -- | Can't be called on abstract registers i.e. 'DataPointer' 35 | -- This is kinda sus but it allows us to use an 'IntSet' for liveness analysis. 36 | toInt :: AbsReg -> Maybe Int 37 | toInt (AllocReg i) = Just i 38 | toInt _ = Nothing 39 | 40 | fromList :: [AbsReg] -> IS.IntSet 41 | fromList = foldMap singleton 42 | 43 | addrRegs :: Addr AbsReg -> IS.IntSet 44 | addrRegs (Reg r) = singleton r 45 | addrRegs (AddRRPlus r r') = fromList [r, r'] 46 | addrRegs (AddRCPlus r _) = singleton r 47 | 48 | -- | Annotate instructions with a unique node name and a list of all possible 49 | -- destinations. 50 | addControlFlow :: [Arm AbsReg ()] -> FreshM [Arm AbsReg ControlAnn] 51 | addControlFlow [] = pure [] 52 | addControlFlow ((Label _ l):asms) = do 53 | { i <- lookupLabel l 54 | ; (f, asms') <- next asms 55 | ; pure (Label (ControlAnn i (f []) IS.empty IS.empty) l : asms') 56 | } 57 | addControlFlow ((BranchCond _ l c):asms) = do 58 | { i <- getFresh 59 | ; (f, asms') <- next asms 60 | ; l_i <- lookupLabel l 61 | ; pure (BranchCond (ControlAnn i (f [l_i]) IS.empty IS.empty) l c : asms') 62 | } 63 | addControlFlow ((BranchZero _ r l):asms) = do 64 | { i <- getFresh 65 | ; (f, asms') <- next asms 66 | ; l_i <- lookupLabel l 67 | ; pure (BranchZero (ControlAnn i (f [l_i]) (singleton r) IS.empty) r l : asms') 68 | } 69 | addControlFlow ((BranchNonzero _ r l):asms) = do 70 | { i <- getFresh 71 | ; (f, asms') <- next asms 72 | ; l_i <- lookupLabel l 73 | ; pure (BranchNonzero (ControlAnn i (f [l_i]) (singleton r) IS.empty) r l : asms') 74 | } 75 | addControlFlow ((BranchLink _ l):asms) = do 76 | { i <- getFresh 77 | ; nextAsms <- addControlFlow asms 78 | ; l_i <- lookupLabel l 79 | ; pure (BranchLink (ControlAnn i [l_i] IS.empty IS.empty) l : nextAsms) 80 | } 81 | addControlFlow ((Branch _ l):asms) = do 82 | { i <- getFresh 83 | ; nextAsms <- addControlFlow asms 84 | ; l_i <- lookupLabel l 85 | ; pure (Branch (ControlAnn i [l_i] IS.empty IS.empty) l : nextAsms) 86 | } 87 | addControlFlow (Ret{}:asms) = do 88 | { i <- getFresh 89 | ; nextAsms <- addControlFlow asms 90 | ; pure (Ret (ControlAnn i [] IS.empty IS.empty) : nextAsms) 91 | } 92 | addControlFlow (asm:asms) = do 93 | { i <- getFresh 94 | ; (f, asms') <- next asms 95 | ; pure ((asm $> ControlAnn i (f []) (uses asm) (defs asm)) : asms') 96 | } 97 | 98 | uses :: Arm AbsReg ann -> IS.IntSet 99 | uses (MovRR _ _ r) = singleton r 100 | uses (AddRR _ _ r r') = fromList [r, r'] 101 | uses (SubRR _ _ r r') = fromList [r, r'] 102 | uses (SubRC _ _ r _) = singleton r 103 | uses (LShiftLRR _ _ r r') = fromList [r, r'] 104 | uses (LShiftRRR _ _ r r') = fromList [r, r'] 105 | uses (BranchZero _ r _) = singleton r 106 | uses (MovRK _ r _ _) = singleton r -- since MovRK only affects 16 bits, it depends on the previous r to be live! 107 | uses (BranchNonzero _ r _) = singleton r 108 | uses (AddRC _ _ r _) = singleton r 109 | uses (MulRR _ _ r r') = fromList [r, r'] 110 | uses (AndRR _ _ r r') = fromList [r, r'] 111 | uses (OrRR _ _ r r') = fromList [r, r'] 112 | uses (SignedDivRR _ _ r r') = fromList [r, r'] 113 | uses (UnsignedDivRR _ _ r r') = fromList [r, r'] 114 | uses (CmpRR _ r r') = fromList [r, r'] 115 | uses (CmpRC _ r _) = singleton r 116 | uses (Load _ _ a) = addrRegs a 117 | uses (LoadByte _ _ a) = addrRegs a 118 | uses (Neg _ _ r) = singleton r 119 | uses (MulSubRRR _ _ r r' r'') = fromList [r, r', r''] 120 | uses (XorRR _ _ r r') = fromList [r, r'] 121 | uses (Store _ r a) = singleton r <> addrRegs a 122 | uses (StoreByte _ r a) = singleton r <> addrRegs a 123 | uses _ = mempty 124 | 125 | defs :: Arm AbsReg ann -> IS.IntSet 126 | defs (MovRR _ r _) = singleton r 127 | defs (MovRC _ r _) = singleton r 128 | defs (MovRWord _ r _) = singleton r 129 | defs (MovRK _ r _ _) = singleton r 130 | defs (AddRR _ r _ _) = singleton r 131 | defs (SubRR _ r _ _) = singleton r 132 | defs (AddRC _ r _ _) = singleton r 133 | defs (SubRC _ r _ _) = singleton r 134 | defs (LoadByte _ r _) = singleton r 135 | defs (LShiftRRR _ r _ _) = singleton r 136 | defs (MulSubRRR _ r _ _ _) = singleton r 137 | defs (LShiftLRR _ r _ _) = singleton r 138 | defs (AndRR _ r _ _) = singleton r 139 | defs (OrRR _ r _ _) = singleton r 140 | defs (MulRR _ r _ _) = singleton r 141 | defs (Load _ r _) = singleton r 142 | defs (SignedDivRR _ r _ _) = singleton r 143 | defs (UnsignedDivRR _ r _ _) = singleton r 144 | defs (LoadLabel _ r _) = singleton r 145 | defs (CSet _ r _) = singleton r 146 | defs (Neg _ r _) = singleton r 147 | defs (XorRR _ r _ _) = singleton r 148 | defs _ = mempty 149 | 150 | next :: [Arm AbsReg ()] -> FreshM ([Int] -> [Int], [Arm AbsReg ControlAnn]) 151 | next asms = do 152 | nextAsms <- addControlFlow asms 153 | case nextAsms of 154 | [] -> pure (id, []) 155 | (asm:_) -> pure ((node (ann asm) :), nextAsms) 156 | 157 | -- | Construct map assigning labels to their node name. 158 | broadcasts :: [Arm reg ()] -> FreshM [Arm reg ()] 159 | broadcasts [] = pure [] 160 | broadcasts (asm@(Label _ l):asms) = do 161 | { i <- getFresh 162 | ; broadcast i l 163 | ; (asm :) <$> broadcasts asms 164 | } 165 | broadcasts (asm:asms) = (asm :) <$> broadcasts asms 166 | -------------------------------------------------------------------------------- /src/Kempe/Asm/Arm/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Linear scan register allocator 5 | module Kempe.Asm.Arm.Linear ( allocRegs 6 | ) where 7 | 8 | import Control.Monad.State.Strict (State, evalState, gets) 9 | import Data.Foldable (traverse_) 10 | import qualified Data.IntMap as IM 11 | import qualified Data.IntSet as IS 12 | import Data.Maybe (fromMaybe) 13 | import qualified Data.Set as S 14 | import Kempe.Asm.Arm.Type 15 | import Kempe.Asm.Type 16 | import Lens.Micro (Lens') 17 | import Lens.Micro.Mtl (modifying, (.=)) 18 | 19 | data AllocSt = AllocSt { allocs :: IM.IntMap ArmReg -- ^ Already allocated registers 20 | , free :: S.Set ArmReg -- TODO: IntSet here? 21 | } 22 | 23 | allocsLens :: Lens' AllocSt (IM.IntMap ArmReg) 24 | allocsLens f s = fmap (\x -> s { allocs = x }) (f (allocs s)) 25 | 26 | freeLens :: Lens' AllocSt (S.Set ArmReg) 27 | freeLens f s = fmap (\x -> s { free = x }) (f (free s)) 28 | 29 | -- | Mark all registers as free (at the beginning). 30 | allFree :: AllocSt 31 | allFree = AllocSt mempty allReg 32 | 33 | allReg :: S.Set ArmReg 34 | allReg = S.fromList [X0 .. X29] S.\\ S.singleton X19 -- don't allocate to x19 (data pointer) 35 | 36 | type AllocM = State AllocSt 37 | 38 | runAllocM :: AllocM a -> a 39 | runAllocM = flip evalState allFree 40 | 41 | allocRegs :: [Arm AbsReg Liveness] -> [Arm ArmReg ()] 42 | allocRegs = runAllocM . traverse allocReg 43 | 44 | new :: Liveness -> IS.IntSet 45 | new (Liveness i o) = o IS.\\ i 46 | 47 | done :: Liveness -> IS.IntSet 48 | done (Liveness i o) = i IS.\\ o 49 | 50 | freeDone :: Liveness -> AllocM () 51 | freeDone l = traverse_ freeReg (IS.toList absRs) 52 | where absRs = done l 53 | 54 | freeReg :: Int -> AllocM () 55 | freeReg i = do 56 | xR <- findReg i 57 | modifying allocsLens (IM.delete i) 58 | modifying freeLens (S.insert xR) 59 | 60 | assignReg :: Int -> ArmReg -> AllocM () 61 | assignReg i xr = 62 | modifying allocsLens (IM.insert i xr) 63 | 64 | newReg :: AllocM ArmReg 65 | newReg = do 66 | rSt <- gets free 67 | let (res', newSt) = fromMaybe err $ S.minView rSt 68 | -- register is no longer free 69 | freeLens .= newSt 70 | pure res' 71 | 72 | where err = error "(internal error) No register available." 73 | 74 | findReg :: Int -> AllocM ArmReg 75 | findReg i = gets 76 | (IM.findWithDefault (error $ "Internal error in register allocator: unfound register" ++ show i) i . allocs) 77 | 78 | useRegInt :: Liveness -> Int -> AllocM ArmReg 79 | useRegInt l i = 80 | if i `IS.member` new l 81 | then do { res' <- newReg ; assignReg i res' ; pure res' } 82 | else findReg i 83 | 84 | useAddr :: Liveness -> Addr AbsReg -> AllocM (Addr ArmReg) 85 | useAddr l (Reg r) = Reg <$> useReg l r 86 | useAddr l (AddRCPlus r c) = AddRCPlus <$> useReg l r <*> pure c 87 | useAddr l (AddRRPlus r0 r1) = AddRRPlus <$> useReg l r0 <*> useReg l r1 88 | 89 | useReg :: Liveness -> AbsReg -> AllocM ArmReg 90 | useReg l (AllocReg i) = useRegInt l i 91 | useReg _ DataPointer = pure X19 92 | useReg _ LinkReg = pure X30 93 | useReg _ CArg0 = pure X0 94 | useReg _ CArg1 = pure X1 -- shouldn't clobber anything because it's just used in function wrapper to push onto the kempe stack 95 | useReg _ CArg2 = pure X2 96 | useReg _ CArg3 = pure X3 97 | useReg _ CArg4 = pure X4 98 | useReg _ CArg5 = pure X5 99 | useReg _ CArg6 = pure X6 100 | useReg _ CArg7 = pure X7 101 | useReg _ StackPtr = pure SP 102 | 103 | allocReg :: Arm AbsReg Liveness -> AllocM (Arm ArmReg ()) 104 | allocReg Ret{} = pure $ Ret () 105 | allocReg (Branch _ l) = pure $ Branch () l 106 | allocReg (BranchLink _ l) = pure $ BranchLink () l 107 | allocReg (BranchCond _ l c) = pure $ BranchCond () l c 108 | allocReg (Label _ l) = pure $ Label () l 109 | allocReg (BSLabel _ l) = pure $ BSLabel () l 110 | allocReg (GnuMacro _ m) = pure $ GnuMacro () m 111 | allocReg (BranchZero l r lbl) = (BranchZero () <$> useReg l r <*> pure lbl) <* freeDone l 112 | allocReg (AddRR l r0 r1 r2) = (AddRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l 113 | allocReg (SubRR l r0 r1 r2) = (SubRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l 114 | allocReg (MulRR l r0 r1 r2) = (MulRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l 115 | allocReg (SignedDivRR l r0 r1 r2) = (SignedDivRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l 116 | allocReg (UnsignedDivRR l r0 r1 r2) = (UnsignedDivRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l 117 | allocReg (LShiftLRR l r0 r1 r2) = (LShiftLRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l 118 | allocReg (LShiftRRR l r0 r1 r2) = (LShiftRRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l 119 | allocReg (AndRR l r0 r1 r2) = (AndRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l 120 | allocReg (AddRC l r0 r1 c) = (AddRC () <$> useReg l r0 <*> useReg l r1 <*> pure c) <* freeDone l 121 | allocReg (SubRC l r0 r1 c) = (SubRC () <$> useReg l r0 <*> useReg l r1 <*> pure c) <* freeDone l 122 | allocReg (MovRC l r0 c) = (MovRC () <$> useReg l r0 <*> pure c) <* freeDone l 123 | allocReg (MovRWord l r0 w) = (MovRWord () <$> useReg l r0 <*> pure w) <* freeDone l 124 | allocReg (Load l r a) = (Load () <$> useReg l r <*> useAddr l a) <* freeDone l 125 | allocReg (LoadLabel l r lbl) = (LoadLabel () <$> useReg l r <*> pure lbl) <* freeDone l 126 | allocReg (MovRR l r0 r1) = (MovRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l 127 | allocReg (CSet l r c) = (CSet () <$> useReg l r <*> pure c) <* freeDone l 128 | allocReg (Store l r a) = (Store () <$> useReg l r <*> useAddr l a) <* freeDone l 129 | allocReg (StoreByte l r a) = (StoreByte () <$> useReg l r <*> useAddr l a) <* freeDone l 130 | allocReg (CmpRR l r0 r1) = (CmpRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l 131 | allocReg (Neg l r0 r1) = (Neg () <$> useReg l r0 <*> useReg l r1) <* freeDone l 132 | allocReg (MulSubRRR l r0 r1 r2 r3) = (MulSubRRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2 <*> useReg l r3) <* freeDone l 133 | allocReg (LoadByte l r a) = (LoadByte () <$> useReg l r <*> useAddr l a) <* freeDone l 134 | allocReg (XorRR l r0 r1 r2) = (XorRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l 135 | allocReg (OrRR l r0 r1 r2) = (OrRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l 136 | allocReg (BranchNonzero l r lbl) = (BranchNonzero () <$> useReg l r <*> pure lbl) <* freeDone l 137 | allocReg (CmpRC l r c) = (CmpRC () <$> useReg l r <*> pure c) <* freeDone l 138 | allocReg (MovRK l r0 c s) = (MovRK () <$> useReg l r0 <*> pure c <*> pure s) <* freeDone l 139 | -------------------------------------------------------------------------------- /src/Kempe/Asm/Arm/Opt.hs: -------------------------------------------------------------------------------- 1 | module Kempe.Asm.Arm.Opt ( optimizeArm 2 | ) where 3 | 4 | import Kempe.Asm.Arm.Type 5 | 6 | optimizeArm :: Eq reg => [Arm reg a] -> [Arm reg a] 7 | optimizeArm ((Store l r a):(Load _ r' a'):as) | r == r' && a == a' = optimizeArm (Store l r a : as) 8 | optimizeArm ((StoreByte l r a):(LoadByte _ r' a'):as) | r == r' && a == a' = optimizeArm (StoreByte l r a : as) 9 | optimizeArm (a:as) = a : optimizeArm as 10 | optimizeArm [] = [] 11 | -------------------------------------------------------------------------------- /src/Kempe/Asm/Liveness.hs: -------------------------------------------------------------------------------- 1 | -- FIXME: this module is slow 2 | 3 | -- | Based on the Appel book. 4 | module Kempe.Asm.Liveness ( reconstruct 5 | ) where 6 | 7 | import Data.Copointed 8 | -- this seems to be faster 9 | import qualified Data.IntMap.Lazy as IM 10 | import qualified Data.IntSet as IS 11 | import Kempe.Asm.Type 12 | 13 | emptyLiveness :: Liveness 14 | emptyLiveness = Liveness IS.empty IS.empty 15 | 16 | initLiveness :: Copointed p => [p ControlAnn] -> LivenessMap 17 | initLiveness = IM.fromList . fmap (\asm -> let x = copoint asm in (node x, (x, emptyLiveness))) 18 | 19 | type LivenessMap = IM.IntMap (ControlAnn, Liveness) 20 | 21 | -- | All program points accessible from some node. 22 | succNode :: ControlAnn -- ^ 'ControlAnn' associated w/ node @n@ 23 | -> LivenessMap 24 | -> [Liveness] -- ^ 'Liveness' associated with 'succNode' @n@ 25 | succNode x ns = 26 | let conns = conn x 27 | in fmap (snd . flip lookupNode ns) conns 28 | 29 | lookupNode :: Int -> LivenessMap -> (ControlAnn, Liveness) 30 | lookupNode = IM.findWithDefault (error "Internal error: failed to look up instruction") 31 | 32 | done :: LivenessMap -> LivenessMap -> Bool 33 | done n0 n1 = {-# SCC "done" #-} and $ zipWith (\(_, l) (_, l') -> l == l') (IM.elems n0) (IM.elems n1) -- should be safe b/c n0, n1 must have same length 34 | 35 | -- order in which to inspect nodes during liveness analysis 36 | inspectOrder :: Copointed p => [p ControlAnn] -> [Int] 37 | inspectOrder = fmap (node . copoint) -- don't need to reverse because thread goes in opposite order 38 | 39 | reconstruct :: (Copointed p, Functor p) => [p ControlAnn] -> [p Liveness] 40 | reconstruct asms = {-# SCC "reconstructL" #-} fmap (fmap lookupL) asms 41 | where l = {-# SCC "mkLiveness" #-} mkLiveness asms 42 | lookupL x = snd $ lookupNode (node x) l 43 | 44 | mkLiveness :: Copointed p => [p ControlAnn] -> LivenessMap 45 | mkLiveness asms = liveness is (initLiveness asms) 46 | where is = inspectOrder asms 47 | 48 | liveness :: [Int] -> LivenessMap -> LivenessMap 49 | liveness is nSt = 50 | if done nSt nSt' 51 | then nSt 52 | else liveness is nSt' 53 | where nSt' = {-# SCC "iterNodes" #-} iterNodes is nSt 54 | 55 | iterNodes :: [Int] -> LivenessMap -> LivenessMap 56 | iterNodes is = thread (fmap stepNode is) 57 | where thread = foldr (.) id 58 | 59 | stepNode :: Int -> LivenessMap -> LivenessMap 60 | stepNode n ns = {-# SCC "stepNode" #-} IM.insert n (c, Liveness ins' out') ns 61 | where (c, l) = lookupNode n ns 62 | ins' = usesNode c <> (out l IS.\\ defsNode c) 63 | out' = IS.unions (fmap ins (succNode c ns)) 64 | -------------------------------------------------------------------------------- /src/Kempe/Asm/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Kempe.Asm.Pretty ( i4 4 | , prettyLabel 5 | ) where 6 | 7 | import Prettyprinter (Doc, indent, pretty) 8 | 9 | i4 :: Doc ann -> Doc ann 10 | i4 = indent 4 11 | 12 | prettyLabel :: Word -> Doc ann 13 | prettyLabel l = "kmp_" <> pretty l 14 | -------------------------------------------------------------------------------- /src/Kempe/Asm/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Kempe.Asm.Type ( ControlAnn (..) 6 | , Liveness (..) 7 | ) where 8 | 9 | import Control.DeepSeq (NFData) 10 | import qualified Data.IntSet as IS 11 | import GHC.Generics (Generic) 12 | import Prettyprinter (Pretty (pretty), braces, punctuate, (<+>)) 13 | 14 | data Liveness = Liveness { ins :: !IS.IntSet, out :: !IS.IntSet } -- strictness annotations make it perform better 15 | deriving (Eq, Generic, NFData) 16 | 17 | instance Pretty Liveness where 18 | pretty (Liveness is os) = braces (pp is <+> ";" <+> pp os) 19 | where pp = mconcat . punctuate "," . fmap pretty . IS.toList 20 | 21 | -- | Control-flow annotations 22 | data ControlAnn = ControlAnn { node :: !Int 23 | , conn :: [Int] 24 | , usesNode :: IS.IntSet 25 | , defsNode :: IS.IntSet 26 | } deriving (Generic, NFData) 27 | -------------------------------------------------------------------------------- /src/Kempe/Asm/X86/BasicBlock.hs: -------------------------------------------------------------------------------- 1 | -- | Simple-minded basic blocks. In particular, this does not detect labels that 2 | -- are only targeted by only one jump. 3 | module Kempe.Asm.X86.BasicBlock ( BasicBlock (..) 4 | , splitInstr 5 | ) where 6 | 7 | import Data.List.Split (split, whenElt) 8 | import Kempe.Asm.X86.Type 9 | 10 | data BasicBlock reg a = BasicBlock { blockAnn :: a 11 | , instr :: [X86 reg ()] -- TODO: always () empty ann? 12 | } 13 | 14 | -- | Split x86 instructions into basic blocks 15 | splitInstr :: [X86 reg ()] -> [BasicBlock reg ()] 16 | splitInstr = fmap (BasicBlock ()) . split (whenElt isCf) where 17 | isCf Jump{} = True 18 | isCf Label{} = True 19 | isCf Call{} = True 20 | isCf CallBS{} = True 21 | isCf BSLabel{} = True 22 | isCf Ret{} = True 23 | isCf Jle{} = True 24 | isCf Jg{} = True 25 | isCf Jge{} = True 26 | isCf Jne{} = True 27 | isCf Jl{} = True 28 | isCf Je{} = True 29 | isCf _ = False 30 | -------------------------------------------------------------------------------- /src/Kempe/Asm/X86/ControlFlow.hs: -------------------------------------------------------------------------------- 1 | module Kempe.Asm.X86.ControlFlow ( mkControlFlow 2 | , ControlAnn (..) 3 | ) where 4 | 5 | -- seems to pretty clearly be faster 6 | import Control.Monad.State.Strict (State, evalState, gets, modify) 7 | import Data.Bifunctor (first, second) 8 | import Data.Functor (($>)) 9 | import qualified Data.IntSet as IS 10 | import qualified Data.Map as M 11 | import Kempe.Asm.Type 12 | import Kempe.Asm.X86.Type 13 | 14 | -- map of labels by node 15 | type FreshM = State (Int, M.Map Label Int) -- TODO: map int to asm 16 | 17 | runFreshM :: FreshM a -> a 18 | runFreshM = flip evalState (0, mempty) 19 | 20 | mkControlFlow :: [X86 AbsReg ()] -> [X86 AbsReg ControlAnn] 21 | mkControlFlow instrs = runFreshM (broadcasts instrs *> addControlFlow instrs) 22 | 23 | getFresh :: FreshM Int 24 | getFresh = gets fst <* modify (first (+1)) 25 | 26 | lookupLabel :: Label -> FreshM Int 27 | lookupLabel l = gets (M.findWithDefault (error "Internal error in control-flow graph: node label not in map.") l . snd) 28 | 29 | broadcast :: Int -> Label -> FreshM () 30 | broadcast i l = modify (second (M.insert l i)) 31 | 32 | singleton :: AbsReg -> IS.IntSet 33 | singleton = maybe IS.empty IS.singleton . toInt 34 | 35 | -- | Make sure 8-bit and 64-bit registers have no overlap. 36 | -- 37 | -- Also can't be called on abstract registers i.e. 'DataPointer' or 'CArg1'. 38 | -- This is kinda sus but it allows us to use an 'IntSet' for liveness analysis. 39 | toInt :: AbsReg -> Maybe Int 40 | toInt (AllocReg64 i) = Just i 41 | toInt (AllocReg8 i) = Just i 42 | toInt _ = Nothing 43 | 44 | fromList :: [AbsReg] -> IS.IntSet 45 | fromList = foldMap singleton 46 | 47 | addrRegs :: Addr AbsReg -> IS.IntSet 48 | addrRegs (Reg r) = singleton r 49 | addrRegs (AddrRRPlus r r') = fromList [r, r'] 50 | addrRegs (AddrRCPlus r _) = singleton r 51 | addrRegs (AddrRCMinus r _) = singleton r 52 | addrRegs (AddrRRScale r r' _) = fromList [r, r'] 53 | 54 | -- | Annotate instructions with a unique node name and a list of all possible 55 | -- destinations. 56 | addControlFlow :: [X86 AbsReg ()] -> FreshM [X86 AbsReg ControlAnn] 57 | addControlFlow [] = pure [] 58 | addControlFlow ((Label _ l):asms) = do 59 | { i <- lookupLabel l 60 | ; (f, asms') <- next asms 61 | ; pure (Label (ControlAnn i (f []) IS.empty IS.empty) l : asms') 62 | } 63 | addControlFlow ((Je _ l):asms) = do 64 | { i <- getFresh 65 | ; (f, asms') <- next asms 66 | ; l_i <- lookupLabel l -- TODO: is this what's wanted? 67 | ; pure (Je (ControlAnn i (f [l_i]) IS.empty IS.empty) l : asms') 68 | } 69 | addControlFlow ((Jl _ l):asms) = do 70 | { i <- getFresh 71 | ; (f, asms') <- next asms 72 | ; l_i <- lookupLabel l 73 | ; pure (Jl (ControlAnn i (f [l_i]) IS.empty IS.empty) l : asms') 74 | } 75 | addControlFlow ((Jle _ l):asms) = do 76 | { i <- getFresh 77 | ; (f, asms') <- next asms 78 | ; l_i <- lookupLabel l 79 | ; pure (Jle (ControlAnn i (f [l_i]) IS.empty IS.empty) l : asms') 80 | } 81 | addControlFlow ((Jne _ l):asms) = do 82 | { i <- getFresh 83 | ; (f, asms') <- next asms 84 | ; l_i <- lookupLabel l 85 | ; pure (Jne (ControlAnn i (f [l_i]) IS.empty IS.empty) l : asms') 86 | } 87 | addControlFlow ((Jge _ l):asms) = do 88 | { i <- getFresh 89 | ; (f, asms') <- next asms 90 | ; l_i <- lookupLabel l 91 | ; pure (Jge (ControlAnn i (f [l_i]) IS.empty IS.empty) l : asms') 92 | } 93 | addControlFlow ((Jg _ l):asms) = do 94 | { i <- getFresh 95 | ; (f, asms') <- next asms 96 | ; l_i <- lookupLabel l 97 | ; pure (Jg (ControlAnn i (f [l_i]) IS.empty IS.empty) l : asms') 98 | } 99 | addControlFlow ((Jump _ l):asms) = do 100 | { i <- getFresh 101 | ; nextAsms <- addControlFlow asms 102 | ; l_i <- lookupLabel l 103 | ; pure (Jump (ControlAnn i [l_i] IS.empty IS.empty) l : nextAsms) 104 | } 105 | addControlFlow ((Call _ l):asms) = do 106 | { i <- getFresh 107 | ; nextAsms <- addControlFlow asms 108 | ; l_i <- lookupLabel l 109 | ; pure (Call (ControlAnn i [l_i] IS.empty IS.empty) l : nextAsms) 110 | } 111 | addControlFlow (Ret{}:asms) = do 112 | { i <- getFresh 113 | ; nextAsms <- addControlFlow asms 114 | ; pure (Ret (ControlAnn i [] IS.empty IS.empty) : nextAsms) 115 | } 116 | addControlFlow (asm:asms) = do 117 | { i <- getFresh 118 | ; (f, asms') <- next asms 119 | ; pure ((asm $> ControlAnn i (f []) (uses asm) (defs asm)) : asms') 120 | } 121 | 122 | uses :: X86 AbsReg ann -> IS.IntSet 123 | uses (PushReg _ r) = singleton r 124 | uses (PushMem _ a) = addrRegs a 125 | uses (PopMem _ a) = addrRegs a 126 | uses (MovRA _ _ a) = addrRegs a 127 | uses (MovAR _ a r) = singleton r <> addrRegs a 128 | uses (MovRR _ _ r) = singleton r 129 | uses (MovRRLower _ _ r) = singleton r 130 | uses (AddRR _ r r') = fromList [r, r'] 131 | uses (SubRR _ r r') = fromList [r, r'] 132 | uses (ImulRR _ r r') = fromList [r, r'] 133 | uses (AddRC _ r _) = singleton r 134 | uses (SubRC _ r _) = singleton r 135 | uses (AddAC _ a _) = addrRegs a 136 | uses (MovABool _ a _) = addrRegs a 137 | uses (MovAC _ a _) = addrRegs a 138 | uses (MovACi8 _ a _) = addrRegs a 139 | uses (XorRR _ r r') = fromList [r, r'] 140 | uses (CmpAddrReg _ a r) = singleton r <> addrRegs a 141 | uses (CmpRegReg _ r r') = fromList [r, r'] 142 | uses (CmpRegBool _ r _) = singleton r 143 | uses (CmpAddrBool _ a _) = addrRegs a 144 | uses (LShiftLRR _ r r') = fromList [r, r'] 145 | uses (LShiftRRR _ r r') = fromList [r, r'] 146 | uses (AShiftRRR _ r r') = fromList [r, r'] 147 | uses (MovRCi8 _ r _) = singleton r 148 | uses (MovACTag _ a _) = addrRegs a 149 | uses (IdivR _ r) = singleton r 150 | uses (DivR _ r) = singleton r 151 | uses Cqo{} = IS.empty -- TODO? 152 | uses (AndRR _ r r') = fromList [r, r'] 153 | uses (OrRR _ r r') = fromList [r, r'] 154 | uses (PopcountRR _ _ r') = singleton r' 155 | uses (NegR _ r) = singleton r 156 | uses _ = IS.empty 157 | 158 | defs :: X86 AbsReg ann -> IS.IntSet 159 | defs (MovRA _ r _) = singleton r 160 | defs (MovRR _ r _) = singleton r 161 | defs (MovRRLower _ r _) = singleton r 162 | defs (MovRC _ r _) = singleton r 163 | defs (MovRCBool _ r _) = singleton r 164 | defs (MovRCi8 _ r _) = singleton r 165 | defs (MovRWord _ r _) = singleton r 166 | defs (AddRR _ r _) = singleton r 167 | defs (SubRR _ r _) = singleton r 168 | defs (ImulRR _ r _) = singleton r 169 | defs (AddRC _ r _) = singleton r 170 | defs (SubRC _ r _) = singleton r 171 | defs (XorRR _ r _) = singleton r 172 | defs (MovRL _ r _) = singleton r 173 | defs (LShiftRRR _ r _) = singleton r 174 | defs (PopReg _ r) = singleton r 175 | defs (LShiftLRR _ r _) = singleton r 176 | defs (AShiftRRR _ r _) = singleton r 177 | defs (AndRR _ r _) = singleton r 178 | defs (OrRR _ r _) = singleton r 179 | defs (PopcountRR _ r _) = singleton r 180 | defs (NegR _ r) = singleton r 181 | defs (MovRCTag _ r _) = singleton r 182 | -- defs for IdivR &c.? 183 | defs _ = IS.empty 184 | 185 | next :: [X86 AbsReg ()] -> FreshM ([Int] -> [Int], [X86 AbsReg ControlAnn]) 186 | next asms = do 187 | nextAsms <- addControlFlow asms 188 | case nextAsms of 189 | [] -> pure (id, []) 190 | (asm:_) -> pure ((node (ann asm) :), nextAsms) 191 | 192 | -- | Construct map assigning labels to their node name. 193 | broadcasts :: [X86 reg ()] -> FreshM [X86 reg ()] 194 | broadcasts [] = pure [] 195 | broadcasts (asm@(Label _ l):asms) = do 196 | { i <- getFresh 197 | ; broadcast i l 198 | ; (asm :) <$> broadcasts asms 199 | } 200 | broadcasts (asm:asms) = (asm :) <$> broadcasts asms 201 | -------------------------------------------------------------------------------- /src/Kempe/CGen.hs: -------------------------------------------------------------------------------- 1 | module Kempe.CGen ( cGen 2 | ) where 3 | 4 | import Data.Maybe (mapMaybe) 5 | import Kempe.AST 6 | import Kempe.Name 7 | import Language.C.AST 8 | 9 | cGen :: Declarations a c (StackType ()) -> [CFunc] 10 | cGen = mapMaybe cDecl 11 | 12 | cDecl :: KempeDecl a c (StackType ()) -> Maybe CFunc 13 | cDecl ExtFnDecl{} = Nothing 14 | cDecl TyDecl{} = Nothing 15 | cDecl FunDecl{} = Nothing 16 | cDecl (Export _ Cabi (Name n _ (StackType [] []))) = Just (CFunc n [CVoid] CVoid) 17 | cDecl (Export _ Cabi (Name n _ (StackType [] [o]))) = Just (CFunc n [CVoid] (kempeTyToCType o)) 18 | cDecl (Export _ Cabi (Name n _ (StackType ins []))) = Just (CFunc n (kempeTyToCType <$> ins) CVoid) 19 | cDecl (Export _ Cabi (Name n _ (StackType ins [o]))) = Just (CFunc n (kempeTyToCType <$> ins) (kempeTyToCType o)) 20 | cDecl (Export _ Cabi _) = error "Multiple return not suppported :(" 21 | cDecl (Export _ ArmAbi (Name n _ (StackType [] []))) = Just (CFunc n [CVoidPtr] CVoid) 22 | cDecl (Export _ ArmAbi (Name n _ (StackType [] [o]))) = Just (CFunc n [CVoidPtr] (kempeTyToCType o)) 23 | cDecl (Export _ ArmAbi (Name n _ (StackType ins []))) = Just (CFunc n (CVoidPtr : fmap kempeTyToCType ins) CVoid) 24 | cDecl (Export _ ArmAbi (Name n _ (StackType ins [o]))) = Just (CFunc n (CVoidPtr : fmap kempeTyToCType ins) (kempeTyToCType o)) 25 | cDecl (Export _ ArmAbi _) = error "Multiple return not suppported :(" 26 | cDecl (Export _ Hooked (Name n _ _)) = Just (CFunc n [CVoidPtr] CVoid) 27 | cDecl (Export _ Kabi _) = error "You probably don't want to do this." 28 | 29 | kempeTyToCType :: KempeTy a -> CType 30 | kempeTyToCType (TyBuiltin _ TyInt) = CInt 31 | kempeTyToCType (TyBuiltin _ TyBool) = CBool 32 | kempeTyToCType (TyBuiltin _ TyWord) = CUInt64 33 | kempeTyToCType (TyBuiltin _ TyInt8) = CInt8 34 | kempeTyToCType TyVar{} = error "Don't do that" 35 | kempeTyToCType TyApp{} = error "User-defined types cannot be exported :(" 36 | kempeTyToCType TyNamed{} = error "User-defined types cannot be exported :(" 37 | -------------------------------------------------------------------------------- /src/Kempe/Check/Lint.hs: -------------------------------------------------------------------------------- 1 | module Kempe.Check.Lint ( lint 2 | ) where 3 | 4 | import Data.Foldable.Ext 5 | import Kempe.AST 6 | import Kempe.Error.Warning 7 | 8 | lint :: Declarations a b b -> Maybe (Warning b) 9 | lint = foldMapAlternative lintDecl 10 | 11 | -- TODO: lint for something like dip(0) -> replace with 0 swap 12 | 13 | lintDecl :: KempeDecl a b b -> Maybe (Warning b) 14 | lintDecl Export{} = Nothing 15 | lintDecl TyDecl{} = Nothing 16 | lintDecl ExtFnDecl{} = Nothing 17 | lintDecl (FunDecl _ _ _ _ as) = lintAtoms as 18 | 19 | -- TODO: swap drop drop -> drop drop 20 | -- TODO: dup - -> 0 21 | 22 | -- a bunch of this is from http://joy-lang.org/papers-on-joy/the-algebra-of-joy/ 23 | lintAtoms :: [Atom b b] -> Maybe (Warning b) 24 | lintAtoms [] = Nothing 25 | lintAtoms (a@(Dip l _):a'@Dip{}:_) = Just (DoubleDip l a a') 26 | lintAtoms (a@(IntLit l _):(AtBuiltin _ Drop):_) = Just (PushDrop l a) 27 | lintAtoms (a@(WordLit l _):(AtBuiltin _ Drop):_) = Just (PushDrop l a) 28 | lintAtoms (a@(BoolLit l _):(AtBuiltin _ Drop):_) = Just (PushDrop l a) 29 | lintAtoms (a@(Int8Lit l _):(AtBuiltin _ Drop):_) = Just (PushDrop l a) 30 | lintAtoms ((Dip l [AtBuiltin _ IntPlus]):a@(AtBuiltin _ IntPlus):_) = Just (DipAssoc l a) 31 | lintAtoms ((Dip l [AtBuiltin _ IntTimes]):a@(AtBuiltin _ IntTimes):_) = Just (DipAssoc l a) 32 | lintAtoms ((Dip l [AtBuiltin _ WordPlus]):a@(AtBuiltin _ WordPlus):_) = Just (DipAssoc l a) 33 | lintAtoms ((Dip l [AtBuiltin _ WordTimes]):a@(AtBuiltin _ WordTimes):_) = Just (DipAssoc l a) 34 | lintAtoms ((Dip l [AtBuiltin _ And]):a@(AtBuiltin _ And):_) = Just (DipAssoc l a) 35 | lintAtoms ((Dip l [AtBuiltin _ Or]):a@(AtBuiltin _ Or):_) = Just (DipAssoc l a) 36 | -- lintAtoms ((Dip l [AtBuiltin _ IntEq]):a@(AtBuiltin _ IntEq):_) = Just (DipAssoc l a) 37 | lintAtoms ((AtBuiltin l Swap):(AtBuiltin _ Swap):_) = Just (DoubleSwap l) 38 | lintAtoms ((AtBuiltin l Dup):a@(AtBuiltin _ And):_) = Just (Identity l a) 39 | lintAtoms ((AtBuiltin l Dup):a@(AtBuiltin _ Or):_) = Just (Identity l a) 40 | lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ IntEq):_) = Just (SwapBinary l a' a') 41 | lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ IntNeq):_) = Just (SwapBinary l a' a') 42 | lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ And):_) = Just (SwapBinary l a' a') 43 | lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ Or):_) = Just (SwapBinary l a' a') 44 | lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ Xor):_) = Just (SwapBinary l a' a') 45 | lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ WordXor):_) = Just (SwapBinary l a' a') 46 | lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ IntTimes):_) = Just (SwapBinary l a' a') 47 | lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ IntPlus):_) = Just (SwapBinary l a' a') 48 | lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ WordPlus):_) = Just (SwapBinary l a' a') 49 | lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ WordTimes):_) = Just (SwapBinary l a' a') 50 | lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ IntXor):_) = Just (SwapBinary l a' a') 51 | lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin l' IntGt):_) = Just (SwapBinary l a' (AtBuiltin l' IntLt)) 52 | lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin l' IntGeq):_) = Just (SwapBinary l a' (AtBuiltin l' IntLeq)) 53 | lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin l' IntLt):_) = Just (SwapBinary l a' (AtBuiltin l' IntGt)) 54 | lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin l' IntLeq):_) = Just (SwapBinary l a' (AtBuiltin l' IntGeq)) 55 | lintAtoms (_:as) = lintAtoms as 56 | -------------------------------------------------------------------------------- /src/Kempe/Check/Pattern.hs: -------------------------------------------------------------------------------- 1 | -- | Check pattern match exhaustiveness, since we don't really handle that in 2 | -- source code. 3 | -- 4 | -- This is pretty easy because of how patterns work in Kempe. 5 | -- 6 | -- Some of this code is from Dickinson, but we don't need the Maranget approach 7 | -- because the pattern matching is simpler in Kempe. 8 | module Kempe.Check.Pattern ( checkModuleExhaustive 9 | ) where 10 | 11 | import Control.Monad (forM_) 12 | import Control.Monad.State.Strict (State, execState) 13 | import Data.Coerce (coerce) 14 | import Data.Foldable (toList, traverse_) 15 | import Data.Foldable.Ext 16 | import qualified Data.Functor as Fun 17 | import qualified Data.IntMap.Strict as IM 18 | import qualified Data.IntSet as IS 19 | import Data.List.NonEmpty (NonEmpty (..)) 20 | import Kempe.AST 21 | import Kempe.Error 22 | import Kempe.Name 23 | import Kempe.Unique 24 | import Lens.Micro (Lens') 25 | import Lens.Micro.Mtl (modifying) 26 | 27 | checkAtom :: PatternEnv -> Atom c b -> Maybe (Error b) 28 | checkAtom env (Case l ls) = 29 | let (ps, as) = Fun.unzip ls in 30 | if isExhaustive env ps 31 | then foldMapAlternative (foldMapAlternative (checkAtom env)) as 32 | else Just (InexhaustiveMatch l) 33 | checkAtom _ _ = Nothing 34 | 35 | checkDecl :: PatternEnv -> KempeDecl a c b -> Maybe (Error b) 36 | checkDecl env (FunDecl _ _ _ _ as) = foldMapAlternative (checkAtom env) as 37 | checkDecl _ _ = Nothing 38 | 39 | checkModule :: PatternEnv -> Declarations a c b -> Maybe (Error b) 40 | checkModule env = foldMapAlternative (checkDecl env) 41 | 42 | checkModuleExhaustive :: Declarations a c b -> Maybe (Error b) 43 | checkModuleExhaustive m = 44 | let env = runPatternM $ patternEnvDecls m 45 | in checkModule env m 46 | 47 | data PatternEnv = PatternEnv { allCons :: IM.IntMap IS.IntSet -- ^ all constructors indexed by type 48 | , types :: IM.IntMap Int -- ^ all types indexed by constructor 49 | } 50 | 51 | allConsLens :: Lens' PatternEnv (IM.IntMap IS.IntSet) 52 | allConsLens f s = fmap (\x -> s { allCons = x }) (f (allCons s)) 53 | 54 | typesLens :: Lens' PatternEnv (IM.IntMap Int) 55 | typesLens f s = fmap (\x -> s { types = x }) (f (types s)) 56 | 57 | type PatternM = State PatternEnv 58 | 59 | patternEnvDecls :: Declarations a c b -> PatternM () 60 | patternEnvDecls = traverse_ declAdd 61 | 62 | declAdd :: KempeDecl a c b -> PatternM () 63 | declAdd FunDecl{} = pure () 64 | declAdd ExtFnDecl{} = pure () 65 | declAdd Export{} = pure () 66 | declAdd (TyDecl _ (Name _ (Unique i) _) _ ls) = do 67 | forM_ ls $ \(Name _ (Unique j) _, _) -> 68 | modifying typesLens (IM.insert j i) 69 | let cons = IS.fromList $ toList (unUnique . unique . fst <$> ls) 70 | modifying allConsLens (IM.insert i cons) 71 | 72 | runPatternM :: PatternM a -> PatternEnv 73 | runPatternM = flip execState (PatternEnv mempty mempty) 74 | 75 | internalError :: a 76 | internalError = error "Internal error: lookup in a PatternEnv failed" 77 | 78 | -- given a constructor name, get the IntSet of all constructors of that type 79 | assocUniques :: PatternEnv -> Name a -> IS.IntSet 80 | assocUniques env (Name _ (Unique i) _) = 81 | let ty = IM.findWithDefault internalError i (types env) 82 | in IM.findWithDefault internalError ty (allCons env) 83 | 84 | hasWildcard :: Foldable t => t (Pattern c b) -> Bool 85 | hasWildcard = any isWildcard where 86 | isWildcard PatternWildcard{} = True 87 | isWildcard _ = False 88 | 89 | -- | Only works on well-typed stuff 90 | isExhaustive :: PatternEnv -> NonEmpty (Pattern c b) -> Bool 91 | isExhaustive _ (PatternWildcard{}:|_) = True 92 | isExhaustive _ (PatternInt{}:|ps) = hasWildcard ps 93 | isExhaustive _ (PatternBool _ True:|PatternBool _ False:_) = True 94 | isExhaustive _ (PatternBool _ False:|PatternBool _ True:_) = True 95 | -- doesn't technically work since you could have True True False but like... 96 | -- don't do that 97 | isExhaustive _ (PatternBool{}:|ps) = hasWildcard ps 98 | isExhaustive env ps@(PatternCons{}:|_) = hasWildcard ps || isCompleteSet env (fmap patternName ps) 99 | 100 | isCompleteSet :: PatternEnv -> NonEmpty (TyName a) -> Bool 101 | isCompleteSet env ns@(n:|_) = 102 | let allU = assocUniques env n 103 | ty = coerce (unique <$> toList ns) 104 | in IS.null (allU IS.\\ IS.fromList ty) 105 | -------------------------------------------------------------------------------- /src/Kempe/Check/Restrict.hs: -------------------------------------------------------------------------------- 1 | -- | Check that sum types have <256 constructors 2 | module Kempe.Check.Restrict ( restrictConstructors 3 | ) where 4 | 5 | import Data.Foldable.Ext 6 | import Kempe.AST 7 | import Kempe.Error (Error (FatSumType)) 8 | 9 | restrictConstructors :: Declarations a c b -> Maybe (Error a) 10 | restrictConstructors = foldMapAlternative restrictDecl 11 | 12 | restrictDecl :: KempeDecl a c b -> Maybe (Error a) 13 | restrictDecl (TyDecl l n _ ls) | length ls > 256 = Just (FatSumType l n) 14 | | otherwise = Nothing 15 | restrictDecl _ = Nothing 16 | -------------------------------------------------------------------------------- /src/Kempe/Check/TopLevel.hs: -------------------------------------------------------------------------------- 1 | module Kempe.Check.TopLevel ( topLevelCheck 2 | , Warning 3 | ) where 4 | 5 | import Control.Applicative ((<|>)) 6 | import Data.Foldable (toList) 7 | import Data.Foldable.Ext 8 | import Data.List (group, sort) 9 | import Data.Maybe (mapMaybe) 10 | import Kempe.AST 11 | import Kempe.Error.Warning 12 | import Kempe.Name 13 | 14 | topLevelCheck :: Declarations a c a -> Maybe (Warning a) 15 | topLevelCheck ds = 16 | checkNames (collectNames ds) 17 | <|> checkNames (collectCons ds) 18 | 19 | -- | Just checks function names and type names. Doesn't check constructors. 20 | collectNames :: Declarations a c a -> [Name a] 21 | collectNames = mapMaybe collectDeclNames where 22 | collectDeclNames (FunDecl _ n _ _ _) = Just n 23 | collectDeclNames (ExtFnDecl _ n _ _ _) = Just n 24 | collectDeclNames Export{} = Nothing 25 | collectDeclNames (TyDecl _ tn _ _) = Just tn 26 | 27 | collectCons :: Declarations a c b-> [Name b] 28 | collectCons = concatMap collectDeclNames where 29 | collectDeclNames (TyDecl _ _ _ ls) = toList (fst <$> ls) 30 | collectDeclNames _ = [] 31 | 32 | checkNames :: [Name a] -> Maybe (Warning a) 33 | checkNames ns = foldMapAlternative announce (group $ sort ns) -- maybe could be better idk 34 | where announce (_:y:_) = Just $ NameClash (loc y) y 35 | announce _ = Nothing 36 | -------------------------------------------------------------------------------- /src/Kempe/Debug.hs: -------------------------------------------------------------------------------- 1 | module Kempe.Debug ( armDebug 2 | ) where 3 | 4 | import qualified Kempe.Asm.Arm.ControlFlow as Arm 5 | import qualified Kempe.Asm.Arm.Type as Arm 6 | import Kempe.Asm.Liveness 7 | import Kempe.Module 8 | import Kempe.Pipeline 9 | import Prettyprinter (Doc) 10 | 11 | -- | Helper function displays calculated live ranges for debugging 12 | armDebug :: FilePath -> IO (Doc ann) 13 | armDebug fp = 14 | Arm.prettyDebugAsm 15 | . reconstruct 16 | . Arm.mkControlFlow 17 | . uncurry armParsed <$> parseProcess fp 18 | -------------------------------------------------------------------------------- /src/Kempe/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Kempe.Error ( Error (..) 6 | , mErr 7 | ) where 8 | 9 | import Control.DeepSeq (NFData) 10 | import Control.Exception (Exception) 11 | import Data.Typeable (Typeable) 12 | import GHC.Generics (Generic) 13 | import Kempe.AST.Size 14 | import Kempe.Name 15 | import Prettyprinter (Pretty (pretty), comma, squotes, (<+>)) 16 | 17 | -- reject mutually recursive types? idk :p 18 | data Error a = PoorScope a (Name a) 19 | | MismatchedLengths a (StackType a) (StackType a) 20 | | UnificationFailed a (KempeTy a) (KempeTy a) -- TODO: include atom expression? 21 | | TyVarExt a (Name a) 22 | | MonoFailed a 23 | | LessGeneral a (StackType a) (StackType a) 24 | | InvalidCExport a (Name a) 25 | | InvalidCImport a (Name a) 26 | | IllKinded a (KempeTy a) 27 | | BadType a 28 | | FatSumType a (TyName a) 29 | | InexhaustiveMatch a 30 | deriving (Generic, NFData) 31 | 32 | mErr :: Maybe (Error ()) -> Either (Error ()) () 33 | mErr Nothing = Right () 34 | mErr (Just err) = Left err 35 | 36 | instance Show (Error a) where 37 | show = show . pretty 38 | 39 | instance Pretty (Error a) where 40 | pretty (PoorScope _ n) = "name" <+> squotes (pretty n) <+> "not in scope" 41 | pretty (MismatchedLengths _ st0 st1) = "mismatched type lengths" <+> pretty st0 <> comma <+> pretty st1 42 | pretty (UnificationFailed _ ty ty') = "could not unify type" <+> squotes (pretty ty) <+> "with" <+> squotes (pretty ty') 43 | pretty (TyVarExt _ n) = "Error in function" <+> pretty n <> ": type variables may not occur in external or exported functions." 44 | pretty (MonoFailed _) = "Monomorphization step failed" 45 | pretty (LessGeneral _ sty sty') = "Type" <+> pretty sty' <+> "is not as general as type" <+> pretty sty <+> "or does not match." 46 | pretty (InvalidCExport _ n) = "C export" <+> pretty n <+> "has more than one return value" 47 | pretty (InvalidCImport _ n) = pretty n <+> "imported functions can have at most one return value" 48 | pretty (IllKinded _ ty) = "Ill-kinded type:" <+> squotes (pretty ty) <> ". Note that type variables have kind ⭑ in Kempe." 49 | pretty (BadType _) = "All types appearing in a signature must have kind ⭑" 50 | pretty (FatSumType _ tn) = "Sum type" <+> pretty tn <+> "has too many constructors! Sum types are limited to 256 constructors in Kempe." 51 | pretty InexhaustiveMatch{} = "Inexhaustive pattern match." 52 | 53 | instance (Typeable a) => Exception (Error a) 54 | -------------------------------------------------------------------------------- /src/Kempe/Error/Warning.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Kempe.Error.Warning ( Warning (..) 4 | ) where 5 | 6 | import Control.Exception (Exception) 7 | import Data.Typeable (Typeable) 8 | import Kempe.AST 9 | import Kempe.Name 10 | import Prettyprinter (Pretty (pretty), squotes, (<+>)) 11 | 12 | data Warning a = NameClash a (Name a) 13 | | DoubleDip a (Atom a a) (Atom a a) 14 | | SwapBinary a (Atom a a) (Atom a a) 15 | | DoubleSwap a 16 | | DipAssoc a (Atom a a) 17 | | Identity a (Atom a a) 18 | | PushDrop a (Atom a a) 19 | 20 | instance Pretty a => Pretty (Warning a) where 21 | pretty (NameClash l x) = pretty l <> " '" <> pretty x <> "' is defined more than once." 22 | pretty (DoubleDip l a a') = pretty l <+> pretty a <+> pretty a' <+> "could be written as a single dip()" 23 | pretty (SwapBinary l a a') = pretty l <+> squotes ("swap" <+> pretty a) <+> "is" <+> pretty a' 24 | pretty (DoubleSwap l) = pretty l <+> "double swap" 25 | pretty (DipAssoc l a) = pretty l <+> "dip(" <> pretty a <> ")" <+> pretty a <+> "is equivalent to" <+> pretty a <+> pretty a <+> "by associativity" 26 | pretty (Identity l a) = pretty l <+> squotes ("dup" <+> pretty a) <+> "is identity" 27 | pretty (PushDrop l a) = pretty l <+> squotes (pretty a <+> "drop") <+> "is identity" 28 | 29 | instance (Pretty a) => Show (Warning a) where 30 | show = show . pretty 31 | 32 | instance (Pretty a, Typeable a) => Exception (Warning a) 33 | -------------------------------------------------------------------------------- /src/Kempe/File.hs: -------------------------------------------------------------------------------- 1 | module Kempe.File ( tcFile 2 | , warnFile 3 | , dumpMono 4 | , dumpTyped 5 | , dumpCDecl 6 | , cDeclFile 7 | , irFile 8 | , x86File 9 | , armFile 10 | , dumpX86 11 | , dumpArm 12 | , compile 13 | , armCompile 14 | , dumpIR 15 | ) where 16 | 17 | -- common b/w test suite and exec, repl utils 18 | import Control.Applicative ((<|>)) 19 | import Control.Composition ((.*)) 20 | import Control.Exception (Exception, throwIO) 21 | import Control.Monad ((<=<)) 22 | import Data.Bifunctor (bimap) 23 | import Data.Functor (void) 24 | import Data.Tuple.Ext (fst3) 25 | import Data.Typeable (Typeable) 26 | import qualified Kempe.Asm.Arm.Type as Arm 27 | import qualified Kempe.Asm.X86.Type as X86 28 | import Kempe.AST 29 | import Kempe.CGen 30 | import Kempe.Check.Lint 31 | import Kempe.Check.Pattern 32 | import Kempe.Check.TopLevel 33 | import Kempe.Error 34 | import Kempe.IR 35 | import Kempe.Lexer 36 | import Kempe.Module 37 | import Kempe.Pipeline 38 | import Kempe.Proc.As as As 39 | import qualified Kempe.Proc.Nasm as Nasm 40 | import Kempe.Shuttle 41 | import Kempe.TyAssign 42 | import Language.C.AST 43 | import Prettyprinter (Doc, hardline) 44 | import Prettyprinter.Render.Text (putDoc) 45 | 46 | tcFile :: FilePath -> IO (Either (Error ()) ()) 47 | tcFile fp = do 48 | (maxU, m) <- parseProcess fp 49 | pure $ do 50 | void $ runTypeM maxU (checkModule m) 51 | mErr $ checkModuleExhaustive (void <$> m) 52 | 53 | warnFile :: FilePath -> IO (Maybe (Warning AlexPosn)) 54 | warnFile fp = do 55 | (_, m) <- parseProcess fp 56 | pure (topLevelCheck m <|> lint m) 57 | 58 | yeetIO :: Exception e => Either e a -> IO a 59 | yeetIO = either throwIO pure 60 | 61 | cDeclFile :: FilePath -> IO [CFunc] 62 | cDeclFile fp = do 63 | (i, m) <- parseProcess fp 64 | (mTyped, _) <- yeetIO $ runTypeM i (assignModule m) 65 | pure $ cGen mTyped 66 | 67 | dumpCDecl :: FilePath -> IO () 68 | dumpCDecl = putDoc . prettyHeaders <=< cDeclFile 69 | 70 | dumpTyped :: FilePath -> IO () 71 | dumpTyped fp = do 72 | (i, m) <- parseProcess fp 73 | (mTyped, _) <- yeetIO $ runTypeM i (assignModule m) 74 | putDoc $ prettyTypedModule mTyped 75 | 76 | dumpMono :: FilePath -> IO () 77 | dumpMono fp = do 78 | (i, m) <- parseProcess fp 79 | (mMono, _) <- yeetIO $ monomorphize i m 80 | putDoc $ prettyTypedModule (fmap (bimap fromMonoConsAnn fromMono) mMono) 81 | where fromMono (is, os) = StackType is os 82 | fromMonoConsAnn (ConsAnn _ _ ty) = fromMono ty 83 | 84 | dumpIR :: Typeable a => Int -> Declarations a c b -> Doc ann 85 | dumpIR = prettyIR . fst3 .* irGen 86 | 87 | dumpX86 :: Typeable a => Int -> Declarations a c b -> Doc ann 88 | dumpX86 = X86.prettyAsm .* x86Alloc 89 | 90 | dumpArm :: Typeable a => Int -> Declarations a c b -> Doc ann 91 | dumpArm = Arm.prettyAsm .* armAlloc 92 | 93 | irFile :: FilePath -> IO () 94 | irFile fp = do 95 | res <- parseProcess fp 96 | putDoc $ uncurry dumpIR res <> hardline 97 | 98 | x86File :: FilePath -> IO () 99 | x86File fp = do 100 | res <- parseProcess fp 101 | putDoc $ uncurry dumpX86 res <> hardline 102 | 103 | armFile :: FilePath -> IO () 104 | armFile fp = do 105 | res <- parseProcess fp 106 | putDoc $ uncurry dumpArm res -- don't need hardline b/c arm pp adds it already 107 | 108 | compile :: FilePath 109 | -> FilePath 110 | -> Bool -- ^ Debug symbols? 111 | -> IO () 112 | compile fp o dbg = do 113 | res <- parseProcess fp 114 | Nasm.writeO (uncurry dumpX86 res) o dbg 115 | 116 | armCompile :: FilePath 117 | -> FilePath 118 | -> Bool -- ^ Debug symbols? 119 | -> IO () 120 | armCompile fp o dbg = do 121 | res <- parseProcess fp 122 | As.writeO (uncurry dumpArm res) o dbg 123 | -------------------------------------------------------------------------------- /src/Kempe/IR/Monad.hs: -------------------------------------------------------------------------------- 1 | -- | Put this in its own module to 2 | module Kempe.IR.Monad ( WriteM 3 | , nextLabels 4 | , nextInt 5 | , getInt 6 | , getLabel 7 | , runWriteM 8 | , allocTemp8 9 | , allocTemp64 10 | ) where 11 | 12 | import Control.Monad.State.Strict (State, evalState, gets, modify) 13 | import Kempe.IR.Type 14 | 15 | type WriteM = State WriteSt 16 | 17 | nextLabels :: WriteSt -> WriteSt 18 | nextLabels (WriteSt ls ts) = WriteSt (tail ls) ts 19 | 20 | nextInt :: WriteSt -> WriteSt 21 | nextInt (WriteSt ls ts) = WriteSt ls (tail ts) 22 | 23 | getInt :: WriteM Int 24 | getInt = gets (head . temps) <* modify nextInt 25 | 26 | getLabel :: WriteM Label 27 | getLabel = gets (head . wlabels) <* modify nextLabels 28 | 29 | allocTemp64 :: WriteM Temp 30 | allocTemp64 = Temp64 <$> getInt 31 | 32 | allocTemp8 :: WriteM Temp 33 | allocTemp8 = Temp8 <$> getInt 34 | 35 | runWriteM :: WriteSt -> WriteM a -> a 36 | runWriteM = flip evalState 37 | -------------------------------------------------------------------------------- /src/Kempe/IR/Opt.hs: -------------------------------------------------------------------------------- 1 | module Kempe.IR.Opt ( optimize 2 | ) where 3 | 4 | import Kempe.IR.Type 5 | 6 | optimize :: [Stmt] -> [Stmt] 7 | optimize = sameTarget . successiveBumps . successiveBumps . removeNop . liftOptE 8 | 9 | -- | Often IR generation will leave us with something like 10 | -- 11 | -- > (movtemp datapointer (+ (reg datapointer) (int 8))) 12 | -- > (movtemp datapointer (- (reg datapointer) (int 8))) 13 | -- 14 | -- i.e. push a value and immediately pop it for use. 15 | -- 16 | -- This is silly and we remove it in this pass. 17 | -- 18 | -- Also take the opportunity to simplify stuff like 19 | -- 20 | -- > (movmem (- (reg datapointer) (int 8)) (mem [8] (- (reg datapointer) (int 0)))) 21 | -- > (movmem (- (reg datapointer) (int 0)) (mem [8] (- (reg datapointer) (int 8)))) 22 | successiveBumps :: [Stmt] -> [Stmt] 23 | successiveBumps [] = [] 24 | successiveBumps 25 | ((MovTemp DataPointer (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt i))) 26 | :(MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt i'))) 27 | :ss) | i == i' = successiveBumps ss 28 | successiveBumps 29 | ((MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt i))) 30 | :(MovTemp DataPointer (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt i'))) 31 | :ss) | i == i' = successiveBumps ss 32 | successiveBumps 33 | ((MovTemp DataPointer (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt i))) 34 | :(MovTemp DataPointer (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt i'))) 35 | :ss) = 36 | MovTemp DataPointer (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt $ i+i')) : successiveBumps ss 37 | successiveBumps 38 | ((MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt i))) 39 | :(MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt i'))) 40 | :ss) = 41 | MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt $ i+i')) : successiveBumps ss 42 | successiveBumps 43 | ((MovTemp DataPointer (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt i))) 44 | :(MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt i'))) 45 | :ss) = 46 | MovTemp DataPointer (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt $ i-i')) : successiveBumps ss 47 | successiveBumps 48 | ((MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt i))) 49 | :(MovTemp DataPointer (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt i'))) 50 | :ss) = -- TODO: is this particular one right? 51 | MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt $ i-i')) : successiveBumps ss 52 | successiveBumps 53 | (st@(MovMem e0 k (Mem 8 e1)) 54 | :(MovMem e0' k' (Mem 8 e1')) 55 | :ss) | k == k' && e0 == e1' && e1 == e0' = st : successiveBumps ss 56 | successiveBumps (s:ss) = s : successiveBumps ss 57 | 58 | -- | Stuff like 59 | -- 60 | -- > (movmem (- (reg datapointer) (int 8)) (mem [8] (- (reg datapointer) (int 0)))) 61 | -- > (movmem (- (reg datapointer) (int 8)) (mem [8] (- (reg datapointer) (int 16)))) 62 | -- 63 | -- Basically if two successive 'Stmt's write to the same location, only bother 64 | -- with the second one. 65 | sameTarget :: [Stmt] -> [Stmt] 66 | sameTarget [] = [] 67 | sameTarget 68 | ((MovMem e0 k _) 69 | :st@(MovMem e0' k' _) 70 | :ss) | k == k' && e0 == e0' = st : sameTarget ss 71 | sameTarget (s:ss) = s : sameTarget ss 72 | 73 | liftOptE :: [Stmt] -> [Stmt] 74 | liftOptE [] = [] 75 | liftOptE ((MovMem e0 sz e1) : ss) = MovMem (optE e0) sz (optE e1) : liftOptE ss 76 | liftOptE ((MovTemp t e) : ss) = MovTemp t (optE e) : liftOptE ss 77 | liftOptE ((MJump e l) : ss) = MJump (optE e) l : liftOptE ss 78 | liftOptE ((CJump e l0 l1) : ss) = CJump (optE e) l0 l1 : liftOptE ss 79 | liftOptE (s:ss) = s : liftOptE ss 80 | 81 | optE :: Exp -> Exp 82 | optE (ExprIntBinOp IntPlusIR e (ConstInt 0)) = optE e 83 | optE (ExprIntBinOp IntMinusIR e (ConstInt 0)) = optE e 84 | optE (BoolBinOp op e e') = BoolBinOp op (optE e) (optE e') 85 | optE (Mem sz e) = Mem sz (optE e) 86 | optE (PopcountIR e) = PopcountIR (optE e) 87 | optE (IntNegIR e) = IntNegIR (optE e) 88 | optE (EqByte e e') = EqByte (optE e) (optE e') 89 | optE e = e 90 | 91 | removeNop :: [Stmt] -> [Stmt] 92 | removeNop = filter (not . isNop) 93 | where 94 | isNop (MovTemp e (Reg e')) | e == e' = True 95 | isNop (MovMem e _ (Mem _ e')) | e == e' = True -- the Eq on Exp is kinda weird, but if the syntax trees are the same then they're certainly equivalent semantically 96 | isNop _ = False 97 | -------------------------------------------------------------------------------- /src/Kempe/IR/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | -- | IR loosely based on Appel book. 6 | module Kempe.IR.Type ( Stmt (..) 7 | , Exp (..) 8 | , RelBinOp (..) 9 | , IntBinOp (..) 10 | , BoolBinOp (..) 11 | , Label 12 | , Temp (..) 13 | , WriteSt (..) 14 | ) where 15 | 16 | import Control.DeepSeq (NFData) 17 | import qualified Data.ByteString as BS 18 | import qualified Data.ByteString.Lazy as BSL 19 | import Data.Int (Int64, Int8) 20 | import Data.Text.Encoding (decodeUtf8) 21 | import Data.Word (Word8) 22 | import GHC.Generics (Generic) 23 | import Kempe.AST.Size 24 | import Prettyprinter (Doc, Pretty (pretty), braces, brackets, colon, hardline, parens, (<+>)) 25 | import Prettyprinter.Ext 26 | 27 | data WriteSt = WriteSt { wlabels :: [Label] 28 | , temps :: [Int] 29 | } 30 | 31 | type Label = Word 32 | 33 | prettyLabel :: Label -> Doc ann 34 | prettyLabel l = "kmp" <> pretty l 35 | 36 | data Temp = Temp64 !Int 37 | | Temp8 !Int 38 | | DataPointer -- RBP on x86 and x19 on aarch64? 39 | deriving (Eq, Generic, NFData) 40 | 41 | instance Pretty Temp where 42 | pretty (Temp64 i) = "t_" <> pretty i 43 | pretty (Temp8 i) = "t8_" <> pretty i 44 | pretty DataPointer = "datapointer" 45 | 46 | instance Pretty Stmt where 47 | pretty (Labeled l) = hardline <> prettyLabel l <> colon 48 | pretty (Jump l) = parens ("j" <+> prettyLabel l) 49 | pretty (CCall ty bs) = parens ("C" <+> pretty (decodeUtf8 (BSL.toStrict bs)) <+> braces (prettyMonoStackType ty)) 50 | pretty (KCall l) = parens ("call" <+> prettyLabel l) 51 | pretty Ret = parens "ret" 52 | pretty (MovTemp t e) = parens ("movtemp" <+> pretty t <+> pretty e) 53 | pretty (MovMem e _ e') = parens ("movmem" <+> pretty e <+> pretty e') -- TODO: maybe print size? 54 | pretty (CJump e l l') = parens ("cjump" <+> pretty e <+> prettyLabel l <+> prettyLabel l') 55 | pretty (WrapKCall _ ty fn l) = hardline <> "export" <+> pretty (decodeUtf8 fn) <+> braces (prettyMonoStackType ty) <+> prettyLabel l 56 | pretty (MJump e l) = parens ("mjump" <+> pretty e <+> prettyLabel l) 57 | 58 | instance Pretty Exp where 59 | pretty (ConstInt i) = parens ("int" <+> pretty i) 60 | pretty (ConstInt8 i) = parens ("int8" <+> pretty i) 61 | pretty (ConstWord n) = parens ("word" <+> pretty n) 62 | pretty (ConstBool False) = parens "bool false" 63 | pretty (ConstBool True) = parens "bool true" 64 | pretty (Reg t) = parens ("reg" <+> pretty t) 65 | pretty (Mem sz e) = parens ("mem" <+> brackets (pretty sz) <+> pretty e) 66 | pretty (ExprIntBinOp op e e') = parens (pretty op <+> pretty e <+> pretty e') 67 | pretty (ExprIntRel op e e') = parens (pretty op <+> pretty e <+> pretty e') 68 | pretty (ConstTag b) = parens ("tag" <+> prettyHex b) 69 | pretty (BoolBinOp op e e') = parens (pretty op <+> pretty e <+> pretty e') 70 | pretty (IntNegIR e) = parens ("~" <+> pretty e) 71 | pretty (PopcountIR e) = parens ("popcount" <+> pretty e) 72 | pretty (EqByte e e') = parens ("=b" <+> pretty e <+> pretty e') 73 | 74 | data Stmt = Labeled Label 75 | | Jump Label 76 | | CJump Exp Label Label -- ^ If the 'Exp' evaluates to @1@, go to the first label, otherwise go to the second (if-then-else). Used to implement ifs. 77 | | MJump Exp Label 78 | | CCall MonoStackType BSL.ByteString 79 | | KCall Label -- ^ a 'KCall' is a jump to a Kempe procedure 80 | | WrapKCall ABI MonoStackType BS.ByteString Label 81 | | MovTemp Temp Exp -- ^ Put @e@ in temp 82 | | MovMem Exp Int64 Exp -- ^ Store @e2@ at address given by @e1@, with sizing information 83 | | Ret 84 | deriving (Generic, NFData) 85 | 86 | data Exp = ConstInt Int64 87 | | ConstInt8 Int8 88 | | ConstTag Word8 -- ^ Used to distinguish constructors of a sum type 89 | | ConstWord Word 90 | | ConstBool Bool 91 | | Reg Temp -- TODO: size? 92 | | Mem Int64 Exp -- ^ Fetch from address 93 | | ExprIntBinOp IntBinOp Exp Exp 94 | | ExprIntRel RelBinOp Exp Exp 95 | | BoolBinOp BoolBinOp Exp Exp 96 | | IntNegIR Exp 97 | | PopcountIR Exp 98 | | EqByte Exp Exp 99 | deriving (Eq, Generic, NFData) 100 | -- TODO: one for data, one for C ABI 101 | 102 | data BoolBinOp = BoolAnd 103 | | BoolOr 104 | | BoolXor 105 | deriving (Eq, Generic, NFData) 106 | 107 | instance Pretty BoolBinOp where 108 | pretty BoolAnd = "&" 109 | pretty BoolOr = "||" 110 | pretty BoolXor = "xor" 111 | 112 | data RelBinOp = IntEqIR 113 | | IntNeqIR 114 | | IntLtIR 115 | | IntGtIR 116 | | IntLeqIR 117 | | IntGeqIR 118 | deriving (Eq, Generic, NFData) 119 | 120 | instance Pretty RelBinOp where 121 | pretty IntEqIR = "=" 122 | pretty IntNeqIR = "!=" 123 | pretty IntLtIR = "<" 124 | pretty IntGtIR = ">" 125 | pretty IntLeqIR = "<=" 126 | pretty IntGeqIR = ">=" 127 | 128 | data IntBinOp = IntPlusIR 129 | | IntTimesIR 130 | | IntDivIR 131 | | IntMinusIR 132 | | IntModIR -- rem? 133 | | IntXorIR 134 | | WordShiftRIR -- ^ compiles to @shr@ on x86 135 | | WordShiftLIR 136 | -- int/word mod are different, see: https://stackoverflow.com/questions/8231882/how-to-implement-the-mod-operator-in-assembly 137 | | WordModIR 138 | | WordDivIR 139 | deriving (Eq, Generic, NFData) 140 | 141 | instance Pretty IntBinOp where 142 | pretty IntPlusIR = "+" 143 | pretty IntTimesIR = "*" 144 | pretty IntDivIR = "/" 145 | pretty IntMinusIR = "-" 146 | pretty IntModIR = "%" 147 | pretty IntXorIR = "xor" 148 | pretty WordShiftRIR = ">>" 149 | pretty WordShiftLIR = "<<" 150 | pretty WordModIR = "%~" 151 | pretty WordDivIR = "/~" 152 | -------------------------------------------------------------------------------- /src/Kempe/Inline.hs: -------------------------------------------------------------------------------- 1 | -- | A simple inliner. Inlines all non-recursive functions. 2 | -- 3 | -- This should all work. 4 | module Kempe.Inline ( inline 5 | ) where 6 | 7 | import qualified Data.Functor as Fun 8 | import Data.Graph (Graph, Vertex, graphFromEdges, path) 9 | import qualified Data.IntMap as IM 10 | import qualified Data.List.NonEmpty as NE 11 | import Data.Maybe (fromMaybe, mapMaybe) 12 | import Data.Tuple.Ext (third3) 13 | import Kempe.AST 14 | import Kempe.Name 15 | import Kempe.Unique 16 | 17 | -- | A 'FnModuleMap' is a map which retrives the 'Atoms's defining 18 | -- a given 'Name' 19 | type FnModuleMap c b = IM.IntMap (Maybe [Atom c b]) 20 | 21 | inline :: Declarations a c b -> Declarations a c b 22 | inline m = fmap inlineDecl m 23 | where inlineDecl (FunDecl l n ty ty' as) = FunDecl l n ty ty' (inlineAtoms n as) 24 | inlineDecl d = d 25 | inlineAtoms n = concatMap (inlineAtom n) 26 | inlineAtom declName a@(AtName _ n) = 27 | if path graph (nLookup n) (nLookup declName) || don'tInline n 28 | then [a] -- no inline 29 | else foldMap (inlineAtom declName) $ findDecl a n 30 | inlineAtom declName (If l as as') = 31 | [If l (inlineAtoms declName as) (inlineAtoms declName as')] 32 | inlineAtom declName (Dip l as) = 33 | [Dip l (inlineAtoms declName as)] 34 | inlineAtom declName (Case l ls) = 35 | let (ps, ass) = Fun.unzip ls 36 | in [Case l (NE.zip ps $ fmap (inlineAtoms declName) ass)] 37 | inlineAtom _ a = [a] 38 | fnMap = mkFnModuleMap m 39 | (graph, _, nLookup) = kempeGraph m 40 | findDecl at (Name _ (Unique k) _) = 41 | case findPreDecl k fnMap of 42 | Just as -> as 43 | Nothing -> pure at -- tried to inline an extern function 44 | findPreDecl = IM.findWithDefault (error "Internal error: FnModuleMap does not contain name/declaration!") 45 | recMap = graphRecursiveMap m (graph, nLookup) 46 | don'tInline (Name _ (Unique i) _) = IM.findWithDefault (error "Internal error! recursive map missing key!") i recMap 47 | 48 | -- | Given a module, make a map telling which top-level names are recursive or 49 | -- cannot be inlined 50 | graphRecursiveMap :: Declarations a c b -> (Graph, Name b -> Vertex) -> IM.IntMap Bool 51 | graphRecursiveMap m (graph, nLookup) = IM.fromList $ mapMaybe fnRecursive m 52 | where fnRecursive (FunDecl _ n@(Name _ (Unique i) _) _ _ as) | n `elem` namesInAtoms as = Just (i, True) -- if it calls iteself 53 | | anyReachable n as = Just (i, True) 54 | | otherwise = Just (i, False) 55 | fnRecursive (ExtFnDecl _ (Name _ (Unique i) _) _ _ _) = Just (i, True) -- not recursive but don't try to inline this 56 | fnRecursive _ = Nothing 57 | anyReachable n as = 58 | any (\nA -> path graph (nLookup nA) (nLookup n)) (namesInAtoms as) -- TODO: lift let-binding (nLookup?) 59 | 60 | 61 | kempeGraph :: Declarations a c b -> (Graph, Vertex -> (KempeDecl a c b, Name b, [Name b]), Name b -> Vertex) 62 | kempeGraph = third3 (findVtx .) . graphFromEdges . kempePreGraph 63 | where findVtx = fromMaybe (error "Internal error: bad name lookup!") 64 | 65 | kempePreGraph :: Declarations a c b -> [(KempeDecl a c b, Name b, [Name b])] 66 | kempePreGraph = mapMaybe kempeDeclToGraph 67 | where kempeDeclToGraph :: KempeDecl a c b -> Maybe (KempeDecl a c b, Name b, [Name b]) 68 | kempeDeclToGraph d@(FunDecl _ n _ _ as) = Just (d, n, foldMap namesInAtom as) 69 | kempeDeclToGraph d@(ExtFnDecl _ n _ _ _) = Just (d, n, []) 70 | kempeDeclToGraph _ = Nothing 71 | 72 | mkFnModuleMap :: Declarations a c b -> FnModuleMap c b 73 | mkFnModuleMap = IM.fromList . mapMaybe toInt where 74 | toInt (FunDecl _ (Name _ (Unique i) _) _ _ as) = Just (i, Just as) 75 | toInt (ExtFnDecl _ (Name _ (Unique i) _) _ _ _) = Just (i, Nothing) 76 | toInt _ = Nothing 77 | 78 | namesInAtoms :: [Atom c a] -> [Name a] 79 | namesInAtoms = foldMap namesInAtom 80 | 81 | namesInAtom :: Atom c a -> [Name a] 82 | namesInAtom AtBuiltin{} = [] 83 | namesInAtom (If _ as as') = foldMap namesInAtom as <> foldMap namesInAtom as' 84 | namesInAtom (Dip _ as) = foldMap namesInAtom as 85 | namesInAtom (AtName _ n) = [n] 86 | namesInAtom AtCons{} = [] 87 | namesInAtom IntLit{} = [] 88 | namesInAtom BoolLit{} = [] 89 | namesInAtom Int8Lit{} = [] 90 | namesInAtom WordLit{} = [] 91 | namesInAtom (Case _ as) = foldMap namesInAtom (foldMap snd as) 92 | -------------------------------------------------------------------------------- /src/Kempe/Module.hs: -------------------------------------------------------------------------------- 1 | -- | Pretty easy since doesn't need renaming. 2 | -- 3 | -- Just thread lexer state through, remove duplicates. 4 | module Kempe.Module ( parseProcess 5 | ) where 6 | 7 | import Control.Exception (Exception, throwIO) 8 | import qualified Data.ByteString.Lazy as BSL 9 | import qualified Data.ByteString.Lazy.Char8 as ASCII 10 | import qualified Data.Set as S 11 | import Data.Tuple.Ext (fst3, third3) 12 | import Kempe.AST 13 | import Kempe.Lexer 14 | import Kempe.Parser 15 | 16 | 17 | parseProcess :: FilePath -> IO (Int, Declarations AlexPosn AlexPosn AlexPosn) 18 | parseProcess fp = do 19 | (st, [], ds) <- loopFps True [fp] alexInitUserState 20 | pure (fst3 st, {-# SCC "dedup" #-} dedup ds) 21 | 22 | yeetIO :: Exception e => Either e a -> IO a 23 | yeetIO = either throwIO pure 24 | 25 | loopFps :: Bool -> [FilePath] -> AlexUserState -> IO (AlexUserState, [FilePath], Declarations AlexPosn AlexPosn AlexPosn) 26 | loopFps _ [] st = pure (st, [], []) 27 | loopFps isInit (fp:fps) st = do 28 | (st', Module is ds) <- parseStep fp st 29 | let discardDs = if isInit then id else filter (not . isExport) 30 | third3 (++ discardDs ds) <$> loopFps False (fmap ASCII.unpack (reverse is) ++ fps) st' 31 | where isExport Export{} = True 32 | isExport _ = False 33 | 34 | parseStep :: FilePath -> AlexUserState -> IO (AlexUserState, Module AlexPosn AlexPosn AlexPosn) 35 | parseStep fp st = do 36 | contents <- BSL.readFile fp 37 | yeetIO $ parseWithCtx contents st 38 | 39 | dedup :: Ord a => [a] -> [a] 40 | dedup = loop S.empty 41 | where loop _ [] = [] 42 | loop acc (x:xs) = 43 | if S.member x acc 44 | then loop acc xs 45 | else x : loop (S.insert x acc) xs 46 | -------------------------------------------------------------------------------- /src/Kempe/Name.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Kempe.Name ( Name (..) 7 | , TyName 8 | ) where 9 | 10 | import Control.DeepSeq (NFData (..)) 11 | import qualified Data.Text as T 12 | import Kempe.Unique 13 | import Prettyprinter (Pretty (pretty)) 14 | 15 | data Name a = Name { name :: T.Text 16 | , unique :: !Unique 17 | , loc :: a 18 | } deriving (Functor, Foldable, Traversable) 19 | 20 | instance Eq (Name a) where 21 | (==) (Name _ u _) (Name _ u' _) = u == u' 22 | 23 | instance Pretty (Name a) where 24 | pretty (Name t u _) = pretty t <> "_" <> pretty u 25 | 26 | instance Ord (Name a) where 27 | compare (Name _ u _) (Name _ u' _) = compare u u' 28 | 29 | instance NFData a => NFData (Name a) where 30 | rnf (Name _ u x) = rnf x `seq` u `seq` () 31 | 32 | type TyName = Name 33 | -------------------------------------------------------------------------------- /src/Kempe/Parser.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | module Kempe.Parser ( parse 6 | , parseWithMax 7 | , parseWithCtx 8 | , parseWithInitCtx 9 | , ParseError (..) 10 | ) where 11 | 12 | import Control.Composition ((.*)) 13 | import Control.DeepSeq (NFData) 14 | import Control.Exception (Exception) 15 | import Control.Monad.Except (ExceptT, runExceptT, throwError) 16 | import Control.Monad.Trans.Class (lift) 17 | import Data.Bifunctor (first) 18 | import qualified Data.ByteString.Lazy as BSL 19 | import Data.List.NonEmpty (NonEmpty (..)) 20 | import qualified Data.List.NonEmpty as NE 21 | import qualified Data.Text as T 22 | import Data.Tuple.Ext (fst3) 23 | import Data.Typeable (Typeable) 24 | import GHC.Generics (Generic) 25 | import Kempe.AST 26 | import Kempe.Lexer 27 | import qualified Kempe.Name as Name 28 | import Kempe.Name hiding (loc) 29 | import Prettyprinter (Pretty (pretty), (<+>)) 30 | 31 | } 32 | 33 | %name parseModule Module 34 | %tokentype { Token AlexPosn } 35 | %error { parseError } 36 | %monad { Parse } { (>>=) } { pure } 37 | %lexer { lift alexMonadScan >>= } { EOF _ } 38 | 39 | %token 40 | 41 | arrow { TokSym $$ Arrow } 42 | defEq { TokSym $$ DefEq } 43 | colon { TokSym $$ Colon } 44 | lbrace { TokSym $$ LBrace } 45 | rbrace { TokSym $$ RBrace } 46 | lsqbracket { TokSym $$ LSqBracket } 47 | rsqbracket { TokSym $$ RSqBracket } 48 | lparen { TokSym $$ LParen } 49 | rparen { TokSym $$ RParen } 50 | vbar { TokSym $$ VBar } 51 | caseArr { TokSym $$ CaseArr } 52 | comma { TokSym $$ Comma } 53 | underscore { TokSym $$ Underscore } 54 | 55 | plus { TokSym $$ Plus } 56 | plusU { TokSym $$ PlusU } 57 | minus { TokSym $$ Minus } 58 | times { TokSym $$ Times } 59 | timesU { TokSym $$ TimesU } 60 | div { TokSym $$ Div } 61 | percent { TokSym $$ Percent } 62 | eq { TokSym $$ Eq } 63 | neq { TokSym $$ Neq } 64 | leq { TokSym $$ Leq } 65 | lt { TokSym $$ Lt } 66 | geq { TokSym $$ Geq } 67 | gt { TokSym $$ Gt } 68 | shiftrU { TokSym $$ ShiftRU } 69 | shiftlU { TokSym $$ ShiftLU } 70 | shiftr { TokSym $$ ShiftR } 71 | shiftl { TokSym $$ ShiftL } 72 | neg { TokSym $$ NegTok } 73 | and { TokSym $$ AndTok } 74 | or { TokSym $$ OrTok } 75 | 76 | name { TokName _ $$ } 77 | tyName { TokTyName _ $$ } 78 | foreignName { TokForeign _ $$ } 79 | moduleFile { TokModuleStr _ $$ } 80 | 81 | intLit { $$@(TokInt _ _) } 82 | wordLit { $$@(TokWord _ _) } 83 | int8Lit { $$@(TokInt8 _ _) } 84 | 85 | type { TokKeyword $$ KwType } 86 | case { TokKeyword $$ KwCase } 87 | cfun { TokKeyword $$ KwCfun } 88 | if { TokKeyword $$ KwIf } 89 | foreign { TokKeyword $$ KwForeign } 90 | cabi { TokKeyword $$ KwCabi } 91 | kabi { TokKeyword $$ KwKabi } 92 | hooked { TokKeyword $$ KwHooked } 93 | armabi { TokKeyword $$ KwArmAbi } 94 | import { TokKeyword $$ KwImport } 95 | 96 | dip { TokBuiltin $$ BuiltinDip } 97 | boolLit { $$@(TokBuiltin _ (BuiltinBoolLit _)) } 98 | bool { TokBuiltin $$ BuiltinBool } 99 | int { TokBuiltin $$ BuiltinInt } 100 | int8 { TokBuiltin $$ BuiltinInt8 } 101 | word { TokBuiltin $$ BuiltinWord } 102 | dup { TokBuiltin $$ BuiltinDup } 103 | swap { TokBuiltin $$ BuiltinSwap } 104 | drop { TokBuiltin $$ BuiltinDrop } 105 | intXor { TokBuiltin $$ BuiltinIntXor } 106 | wordXor { TokBuiltin $$ BuiltinWordXor } 107 | boolXor { TokBuiltin $$ BuiltinBoolXor } 108 | popcount { TokBuiltin $$ BuiltinPopcount } 109 | 110 | %% 111 | 112 | many(p) 113 | : many(p) p { $2 : $1 } 114 | | { [] } 115 | 116 | some(p) 117 | : many(p) p { $2 :| $1 } 118 | 119 | sepBy(p,q) 120 | : sepBy(p,q) q p { $3 : $1 } 121 | | p q p { $3 : [$1] } 122 | 123 | braces(p) 124 | : lbrace p rbrace { $2 } 125 | 126 | brackets(p) 127 | : lsqbracket p rsqbracket { $2 } 128 | 129 | parens(p) 130 | : lparen p rparen { $2 } 131 | 132 | Module :: { Module AlexPosn AlexPosn AlexPosn } 133 | : many(Import) Declarations { Module (reverse $1) $2 } 134 | 135 | Declarations :: { Declarations AlexPosn AlexPosn AlexPosn } 136 | : many(Decl) { (reverse $1) } 137 | 138 | Import :: { BSL.ByteString } 139 | : import moduleFile { $2 } 140 | 141 | ABI :: { ABI } 142 | : cabi { Cabi } 143 | | kabi { Kabi } 144 | | hooked { Hooked } 145 | | armabi { ArmAbi } 146 | 147 | Decl :: { KempeDecl AlexPosn AlexPosn AlexPosn } 148 | : TyDecl { $1 } 149 | | FunDecl { $1 } 150 | | foreign ABI name { Export $1 $2 $3 } 151 | 152 | TyDecl :: { KempeDecl AlexPosn AlexPosn AlexPosn } 153 | : type tyName many(name) braces(sepBy(TyLeaf, vbar)) { TyDecl $1 $2 (reverse $3) (reverse $4) } 154 | | type tyName many(name) braces(TyLeaf) { TyDecl $1 $2 (reverse $3) [$4] } 155 | | type tyName many(name) lbrace rbrace { TyDecl $1 $2 (reverse $3) [] } -- necessary since sepBy always has some "flesh" 156 | 157 | Type :: { KempeTy AlexPosn } 158 | : name { TyVar (Name.loc $1) $1 } 159 | | tyName { TyNamed (Name.loc $1) $1 } 160 | | bool { TyBuiltin $1 TyBool } 161 | | int { TyBuiltin $1 TyInt } 162 | | int8 { TyBuiltin $1 TyInt8 } 163 | | word { TyBuiltin $1 TyWord } 164 | | lparen Type Type rparen { TyApp $1 $2 $3 } 165 | 166 | FunDecl :: { KempeDecl AlexPosn AlexPosn AlexPosn } 167 | : FunSig FunBody { uncurry4 FunDecl $1 $2 } 168 | | FunSig defEq cfun foreignName { uncurry4 ExtFnDecl $1 $4 } 169 | 170 | 171 | FunSig :: { (AlexPosn, Name AlexPosn, [KempeTy AlexPosn], [KempeTy AlexPosn]) } 172 | : name colon many(Type) arrow many(Type) { ($2, $1, reverse $3, reverse $5) } 173 | 174 | FunBody :: { [Atom AlexPosn AlexPosn] } 175 | : defEq brackets(many(Atom)) { reverse $2 } 176 | 177 | Atom :: { Atom AlexPosn AlexPosn } 178 | : name { AtName (Name.loc $1) $1 } 179 | | tyName { AtCons (Name.loc $1) $1 } 180 | | lbrace case some(CaseLeaf) rbrace { Case $2 (NE.reverse $3) } 181 | | intLit { IntLit (loc $1) (int $1) } 182 | | wordLit { WordLit (loc $1) (word $1) } 183 | | int8Lit { Int8Lit (loc $1) (int8 $1) } 184 | | dip parens(many(Atom)) { Dip $1 (reverse $2) } 185 | | if lparen many(Atom) comma many(Atom) rparen { If $1 (reverse $3) (reverse $5) } 186 | | boolLit { BoolLit (loc $1) (bool $ builtin $1) } 187 | | dup { AtBuiltin $1 Dup } 188 | | drop { AtBuiltin $1 Drop } 189 | | swap { AtBuiltin $1 Swap } 190 | | plus { AtBuiltin $1 IntPlus } 191 | | plusU { AtBuiltin $1 WordPlus } 192 | | minus { AtBuiltin $1 IntMinus } 193 | | times { AtBuiltin $1 IntTimes } 194 | | timesU { AtBuiltin $1 WordTimes } 195 | | div { AtBuiltin $1 IntDiv } 196 | | percent { AtBuiltin $1 IntMod } 197 | | eq { AtBuiltin $1 IntEq } 198 | | neq { AtBuiltin $1 IntNeq } 199 | | leq { AtBuiltin $1 IntLeq } 200 | | lt { AtBuiltin $1 IntLt } 201 | | geq { AtBuiltin $1 IntGeq } 202 | | gt { AtBuiltin $1 IntGt } 203 | | and { AtBuiltin $1 And } 204 | | or { AtBuiltin $1 Or } 205 | | neg { AtBuiltin $1 IntNeg } 206 | | shiftl { AtBuiltin $1 IntShiftL } 207 | | shiftr { AtBuiltin $1 IntShiftR } 208 | | shiftlU { AtBuiltin $1 WordShiftL } 209 | | shiftrU { AtBuiltin $1 WordShiftR } 210 | | intXor { AtBuiltin $1 IntXor } 211 | | wordXor { AtBuiltin $1 WordXor } 212 | | boolXor { AtBuiltin $1 Xor } 213 | | popcount { AtBuiltin $1 Popcount } 214 | 215 | CaseLeaf :: { (Pattern AlexPosn AlexPosn, [Atom AlexPosn AlexPosn]) } 216 | : vbar Pattern caseArr many(Atom) { ($2, reverse $4) } 217 | 218 | Pattern :: { Pattern AlexPosn AlexPosn } 219 | : tyName { PatternCons (Name.loc $1) $1 } 220 | | underscore { PatternWildcard $1 } 221 | | intLit { PatternInt (loc $1) (int $1) } 222 | | boolLit { PatternBool (loc $1) (bool $ builtin $1) } 223 | 224 | TyLeaf :: { (Name AlexPosn, [KempeTy AlexPosn]) } 225 | : tyName many(Type) { ($1, reverse $2) } 226 | 227 | { 228 | 229 | parseError :: Token AlexPosn -> Parse a 230 | parseError = throwError . Unexpected 231 | 232 | data ParseError a = Unexpected (Token a) 233 | | LexErr String 234 | | NoImpl (Name a) 235 | deriving (Generic, NFData) 236 | 237 | instance Pretty a => Pretty (ParseError a) where 238 | pretty (Unexpected tok) = pretty (loc tok) <+> "Unexpected" <+> pretty tok 239 | pretty (LexErr str) = pretty (T.pack str) 240 | pretty (NoImpl n) = pretty (Name.loc n) <+> "Signature for" <+> pretty n <+> "is not accompanied by an implementation" 241 | 242 | instance Pretty a => Show (ParseError a) where 243 | show = show . pretty 244 | 245 | instance (Pretty a, Typeable a) => Exception (ParseError a) 246 | 247 | type Parse = ExceptT (ParseError AlexPosn) Alex 248 | 249 | parse :: BSL.ByteString -> Either (ParseError AlexPosn) (Module AlexPosn AlexPosn AlexPosn) 250 | parse = fmap snd . parseWithMax 251 | 252 | parseWithMax :: BSL.ByteString -> Either (ParseError AlexPosn) (Int, Module AlexPosn AlexPosn AlexPosn) 253 | parseWithMax = fmap (first fst3) . parseWithInitCtx 254 | 255 | parseWithInitCtx :: BSL.ByteString -> Either (ParseError AlexPosn) (AlexUserState, Module AlexPosn AlexPosn AlexPosn) 256 | parseWithInitCtx bsl = parseWithCtx bsl alexInitUserState 257 | 258 | parseWithCtx :: BSL.ByteString -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, Module AlexPosn AlexPosn AlexPosn) 259 | parseWithCtx = parseWithInitSt parseModule 260 | 261 | runParse :: Parse a -> BSL.ByteString -> Either (ParseError AlexPosn) (AlexUserState, a) 262 | runParse parser str = liftErr $ runAlexSt str (runExceptT parser) 263 | 264 | parseWithInitSt :: Parse a -> BSL.ByteString -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, a) 265 | parseWithInitSt parser str st = liftErr $ withAlexSt str st (runExceptT parser) 266 | where liftErr (Left err) = Left (LexErr err) 267 | liftErr (Right (_, Left err)) = Left err 268 | liftErr (Right (i, Right x)) = Right (i, x) 269 | 270 | liftErr :: Either String (b, Either (ParseError a) c) -> Either (ParseError a) (b, c) 271 | liftErr (Left err) = Left (LexErr err) 272 | liftErr (Right (_, Left err)) = Left err 273 | liftErr (Right (i, Right x)) = Right (i, x) 274 | 275 | uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e 276 | uncurry4 f ~(x, y, z, w) = f x y z w 277 | 278 | } 279 | -------------------------------------------------------------------------------- /src/Kempe/Pipeline.hs: -------------------------------------------------------------------------------- 1 | module Kempe.Pipeline ( irGen 2 | , x86Parsed 3 | , x86Alloc 4 | , armParsed 5 | , armAlloc 6 | ) where 7 | 8 | import Control.Composition ((.*)) 9 | import Control.Exception (throw) 10 | import Data.Bifunctor (first) 11 | import Data.Typeable (Typeable) 12 | import qualified Kempe.Asm.Arm.ControlFlow as Arm 13 | import qualified Kempe.Asm.Arm.Linear as Arm 14 | import Kempe.Asm.Arm.Opt 15 | import Kempe.Asm.Arm.Trans 16 | import qualified Kempe.Asm.Arm.Type as Arm 17 | import Kempe.Asm.Liveness 18 | import qualified Kempe.Asm.X86.ControlFlow as X86 19 | import qualified Kempe.Asm.X86.Linear as X86 20 | import Kempe.Asm.X86.Trans 21 | import qualified Kempe.Asm.X86.Type as X86 22 | import Kempe.AST 23 | import Kempe.AST.Size 24 | import Kempe.Check.Restrict 25 | import Kempe.IR 26 | import Kempe.IR.Opt 27 | import Kempe.IR.Type 28 | import Kempe.Shuttle 29 | 30 | irGen :: Typeable a 31 | => Int -- ^ Thread uniques through 32 | -> Declarations a c b -> ([Stmt], WriteSt, SizeEnv) 33 | irGen i m = adjEnv $ first optimize $ runTempM (writeModule env tAnnMod) 34 | where (tAnnMod, env) = either throw id $ monomorphize i mOk 35 | mOk = maybe m throw (restrictConstructors m) 36 | adjEnv (x, y) = (x, y, env) 37 | 38 | armParsed :: Typeable a => Int -> Declarations a c b -> [Arm.Arm Arm.AbsReg ()] 39 | armParsed i m = let (ir, u, env) = irGen i m in irToAarch64 env u ir 40 | 41 | armAlloc :: Typeable a => Int -> Declarations a c b -> [Arm.Arm Arm.ArmReg ()] 42 | armAlloc = optimizeArm . Arm.allocRegs . reconstruct . Arm.mkControlFlow .* armParsed 43 | 44 | x86Parsed :: Typeable a => Int -> Declarations a c b -> [X86.X86 X86.AbsReg ()] 45 | x86Parsed i m = let (ir, u, env) = irGen i m in irToX86 env u ir 46 | 47 | x86Alloc :: Typeable a => Int -> Declarations a c b -> [X86.X86 X86.X86Reg ()] 48 | x86Alloc = X86.allocRegs . reconstruct . X86.mkControlFlow .* x86Parsed 49 | -------------------------------------------------------------------------------- /src/Kempe/Proc/As.hs: -------------------------------------------------------------------------------- 1 | module Kempe.Proc.As ( writeO 2 | ) where 3 | 4 | import Data.Functor (void) 5 | import Prettyprinter (Doc, layoutCompact) 6 | import Prettyprinter.Render.String (renderString) 7 | import System.Info (arch) 8 | import System.Process (CreateProcess (..), StdStream (Inherit), proc, readCreateProcess) 9 | 10 | -- | @as@ on Aarch64 systems, or @aarch64-linux-gnu-as@ when 11 | -- cross-assembling/cross-compiling. 12 | assembler :: String 13 | assembler = 14 | case arch of 15 | "x86_64" -> "aarch64-linux-gnu-as" 16 | _ -> "as" 17 | 18 | -- | Assemble using @as@, output in some file. 19 | writeO :: Doc ann 20 | -> FilePath 21 | -> Bool -- ^ Debug symbols? 22 | -> IO () 23 | writeO p fpO dbg = do 24 | let inp = renderString (layoutCompact p) 25 | debugFlag = if dbg then ("-g":) else id 26 | void $ readCreateProcess ((proc assembler (debugFlag ["-o", fpO, "--"])) { std_err = Inherit }) inp 27 | -------------------------------------------------------------------------------- /src/Kempe/Proc/Nasm.hs: -------------------------------------------------------------------------------- 1 | module Kempe.Proc.Nasm ( writeO 2 | ) where 3 | 4 | import Data.Functor (void) 5 | import qualified Data.Text.Lazy.IO as TLIO 6 | import Prettyprinter (Doc, layoutCompact) 7 | import Prettyprinter.Render.Text (renderLazy) 8 | import System.IO (hFlush) 9 | import System.IO.Temp (withSystemTempFile) 10 | import System.Process (CreateProcess (..), StdStream (Inherit), proc, readCreateProcess) 11 | 12 | -- | Assemble using @nasm@, output in some file. 13 | writeO :: Doc ann 14 | -> FilePath 15 | -> Bool -- ^ Debug symbols? 16 | -> IO () 17 | writeO p fpO dbg = withSystemTempFile "kmp.S" $ \fp h -> do 18 | let txt = renderLazy $ layoutCompact p 19 | {-# SCC "Prettyprinter" #-} TLIO.hPutStr h txt 20 | {-# SCC "Prettyprinter" #-} hFlush h 21 | let debugFlag = if dbg then ("-g":) else id 22 | -- -O1 is signed byte optimization but no multi-passes 23 | {-# SCC "nasm" #-} void $ readCreateProcess ((proc "nasm" (debugFlag [fp, "-f", "elf64", "-O1", "-o", fpO])) { std_err = Inherit }) "" 24 | -------------------------------------------------------------------------------- /src/Kempe/Shuttle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | 3 | module Kempe.Shuttle ( monomorphize 4 | ) where 5 | 6 | import Data.Functor (void) 7 | import Kempe.AST 8 | import Kempe.AST.Size 9 | import Kempe.Check.Pattern 10 | import Kempe.Error 11 | import Kempe.Inline 12 | import Kempe.Monomorphize 13 | import Kempe.TyAssign 14 | 15 | inlineAssignFlatten :: Int 16 | -> Declarations a c b 17 | -> Either (Error ()) (Declarations () (ConsAnn MonoStackType) (StackType ()), (Int, SizeEnv)) 18 | inlineAssignFlatten ctx m = do 19 | -- check before inlining otherwise users would get weird errors 20 | -- TODO: make this more efficient now that liveness anal. is not dominating 21 | -- all performance 22 | void $ do 23 | void $ runTypeM ctx (checkModule m) 24 | mErr $ checkModuleExhaustive (void <$> m) 25 | (mTy, i) <- runTypeM ctx (assignModule $ inline m) 26 | runMonoM i (flattenModule mTy) 27 | 28 | monomorphize :: Int 29 | -> Declarations a c b 30 | -> Either (Error ()) (Declarations () (ConsAnn MonoStackType) MonoStackType, SizeEnv) 31 | monomorphize ctx m = do 32 | (flat, (_, env)) <- inlineAssignFlatten ctx m 33 | let flatFn' = filter (not . isTyDecl) flat 34 | (, env) <$> traverse (traverse tryMono) flatFn' 35 | 36 | isTyDecl :: KempeDecl a c b -> Bool 37 | isTyDecl TyDecl{} = True 38 | isTyDecl _ = False 39 | -------------------------------------------------------------------------------- /src/Kempe/Unique.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Kempe.Unique ( Unique (..) 4 | ) where 5 | 6 | import Prettyprinter (Pretty) 7 | 8 | newtype Unique = Unique { unUnique :: Int } 9 | deriving (Eq, Ord, Pretty) 10 | -------------------------------------------------------------------------------- /src/Language/C/AST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Language.C.AST ( CType (..) 4 | , CFunc (..) 5 | , prettyHeaders 6 | , cSettings 7 | ) where 8 | 9 | import qualified Data.Set as S 10 | import qualified Data.Text as T 11 | import Prettyprinter (Doc, LayoutOptions (..), PageWidth (..), Pretty (..), tupled, (<+>)) 12 | import Prettyprinter.Ext 13 | 14 | cSettings :: LayoutOptions 15 | cSettings = LayoutOptions $ AvailablePerLine 180 0.8 16 | 17 | data CHeader = StdBool -- ^ @stdbool.h@ 18 | | StdInt -- ^ @stdint.h@ 19 | deriving (Eq, Ord) 20 | 21 | prettyInclude :: CHeader -> Doc ann 22 | prettyInclude StdBool = "#include " 23 | prettyInclude StdInt = "#include " 24 | 25 | data CType = CInt 26 | | CBool 27 | | CUInt64 28 | | CInt8 29 | | CVoid 30 | | CVoidPtr 31 | -- ADTs etc. 32 | 33 | data CFunc = CFunc !T.Text [CType] CType 34 | 35 | prettyHeaders :: [CFunc] -> Doc ann 36 | prettyHeaders es = 37 | let hs = foldMap mentionedFunc es 38 | in prettyLines (fmap prettyInclude (S.toList hs)) 39 | <#> prettyLines (fmap pretty es) 40 | 41 | mentioned :: CType -> S.Set CHeader 42 | mentioned CInt = mempty 43 | mentioned CBool = S.singleton StdBool 44 | mentioned CUInt64 = S.singleton StdInt 45 | mentioned CVoid = mempty 46 | mentioned CVoidPtr = mempty 47 | mentioned CInt8 = S.singleton StdInt 48 | 49 | mentionedFunc :: CFunc -> S.Set CHeader 50 | mentionedFunc (CFunc _ args ret) = foldMap mentioned (ret : args) 51 | 52 | instance Pretty CType where 53 | pretty CInt = "int" 54 | pretty CBool = "bool" 55 | pretty CUInt64 = "uint64_t" 56 | pretty CVoid = "void" 57 | pretty CVoidPtr = "void*" 58 | pretty CInt8 = "int8_t" 59 | 60 | instance Pretty CFunc where 61 | pretty (CFunc fname args retType) = "extern" <+> pretty retType <+> pretty fname <+> tupled (pretty <$> args) <> ";" 62 | -------------------------------------------------------------------------------- /src/Prettyprinter/Debug.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Prettyprinter.Debug ( prettyBind 4 | , prettyBound 5 | , (<#*>) 6 | ) where 7 | 8 | import Prettyprinter (Doc, Pretty (pretty), hardline, indent, (<+>)) 9 | 10 | 11 | (<#*>) :: Doc a -> Doc a -> Doc a 12 | (<#*>) x y = x <> hardline <> indent 2 y 13 | 14 | prettyBind :: (Pretty c, Pretty b) => (c, b) -> Doc a 15 | prettyBind (i, j) = pretty i <+> "→" <+> pretty j 16 | 17 | prettyBound :: (Pretty a, Pretty c) => (a, c) -> Doc b 18 | prettyBound (i, e) = pretty i <+> "←" <#*> pretty e 19 | -------------------------------------------------------------------------------- /src/Prettyprinter/Ext.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Prettyprinter.Ext ( (<#>) 4 | , (<##>) 5 | , (<~>) 6 | , prettyHex 7 | , prettyLines 8 | , sepDecls 9 | ) where 10 | 11 | import Numeric (showHex) 12 | import Prettyprinter 13 | 14 | infixr 6 <#> 15 | infixr 6 <##> 16 | infixr 6 <~> 17 | 18 | --- ₀₁₂₃₄₅₆₇₈₉ 19 | 20 | (<#>) :: Doc a -> Doc a -> Doc a 21 | (<#>) x y = x <> hardline <> y 22 | 23 | (<##>) :: Doc a -> Doc a -> Doc a 24 | (<##>) x y = x <> hardline <> hardline <> y 25 | 26 | (<~>) :: Doc a -> Doc a -> Doc a 27 | (<~>) x y = x <> ", " <> y 28 | 29 | prettyHex :: Integral a => a -> Doc ann 30 | prettyHex x = "0x" <> pretty (showHex x mempty) 31 | 32 | prettyLines :: [Doc ann] -> Doc ann 33 | prettyLines = concatWith (<#>) 34 | 35 | sepDecls :: [Doc ann] -> Doc ann 36 | sepDecls = concatWith (<##>) 37 | -------------------------------------------------------------------------------- /test/Abi.hs: -------------------------------------------------------------------------------- 1 | -- | This is to ensure consistency in the ABI. 2 | module Abi ( backendGolden 3 | ) where 4 | 5 | import Control.Composition ((.*)) 6 | import qualified Data.Text.Lazy as TL 7 | import Data.Text.Lazy.Encoding (encodeUtf8) 8 | import Data.Typeable (Typeable) 9 | import Kempe.AST 10 | import Kempe.File 11 | import Kempe.Module 12 | import Prettyprinter (defaultLayoutOptions, layoutPretty) 13 | import Prettyprinter.Render.Text (renderLazy) 14 | import Test.Tasty 15 | import Test.Tasty.Golden (goldenVsString) 16 | 17 | backendGolden :: TestTree 18 | backendGolden = 19 | testGroup "IR goldens" 20 | [ goldenIR "test/data/abi.kmp" "test/golden/abi.ir" 21 | , goldenIR "lib/gaussian.kmp" "test/golden/gaussian.ir" 22 | -- not for ABI, to test it imports the right thing (transitively) 23 | , goldenIR "test/data/diamond/a.kmp" "test/golden/a.ir" 24 | ] 25 | 26 | dumpIRLazyText :: Typeable a => Int -> Declarations a c b -> TL.Text 27 | dumpIRLazyText = renderLazy . layoutPretty defaultLayoutOptions .* dumpIR 28 | 29 | goldenIR :: FilePath 30 | -> FilePath 31 | -> TestTree 32 | goldenIR fp out = 33 | goldenVsString fp out $ 34 | do 35 | res <- parseProcess fp 36 | pure $ encodeUtf8 $ uncurry dumpIRLazyText res 37 | -------------------------------------------------------------------------------- /test/Backend.hs: -------------------------------------------------------------------------------- 1 | module Backend ( backendTests 2 | ) where 3 | 4 | import Control.DeepSeq (deepseq) 5 | import qualified Kempe.Asm.Arm.ControlFlow as Arm 6 | import Kempe.Asm.Liveness 7 | import qualified Kempe.Asm.X86.ControlFlow as X86 8 | import Kempe.Inline 9 | import Kempe.Module 10 | import Kempe.Monomorphize 11 | import Kempe.Pipeline 12 | import Kempe.Shuttle 13 | import Prettyprinter (pretty) 14 | import Test.Tasty 15 | import Test.Tasty.HUnit 16 | import Type 17 | 18 | backendTests :: TestTree 19 | backendTests = 20 | testGroup "Backend-ish" 21 | [ monoTest "test/data/ty.kmp" 22 | , inlineTest "lib/numbertheory.kmp" 23 | , inlineTest "examples/factorial.kmp" 24 | , pipelineWorks "test/data/ty.kmp" 25 | , pipelineWorks "examples/splitmix.kmp" 26 | , pipelineWorks "examples/factorial.kmp" 27 | , pipelineWorks "test/data/mutual.kmp" 28 | , pipelineWorks "test/data/multiConstruct.kmp" 29 | , pipelineWorks "test/data/mod.kmp" 30 | , irNoYeet "test/data/export.kmp" 31 | , irNoYeet "examples/splitmix.kmp" 32 | , irNoYeet "examples/factorial.kmp" 33 | , irNoYeet "test/data/maybeC.kmp" 34 | , irNoYeet "examples/os.kmp" 35 | , x86NoYeet "examples/factorial.kmp" 36 | , x86NoYeet "examples/splitmix.kmp" 37 | , armNoYeet "examples/factorial.kmp" 38 | , controlFlowGraph "examples/factorial.kmp" 39 | , controlFlowGraph "examples/splitmix.kmp" 40 | , controlFlowGraphArm "lib/gaussian.kmp" 41 | , liveness "examples/factorial.kmp" 42 | , liveness "examples/splitmix.kmp" 43 | , livenessArm "lib/gaussian.kmp" 44 | , codegen "examples/factorial.kmp" 45 | , codegen "examples/splitmix.kmp" 46 | , codegen "lib/numbertheory.kmp" 47 | , codegen "test/examples/bool.kmp" 48 | , codegen "lib/gaussian.kmp" 49 | , codegen "test/data/ccall.kmp" 50 | , codegen "test/data/mutual.kmp" 51 | , codegen "lib/rational.kmp" 52 | , codegen "test/data/regAlloc.kmp" 53 | , armCodegen "examples/factorial.kmp" 54 | , armCodegen "lib/numbertheory.kmp" 55 | , armCodegen "lib/gaussian.kmp" 56 | , armCodegen "lib/rational.kmp" 57 | , armCodegen "examples/splitmix.kmp" 58 | , armCodegen "test/data/regAlloc.kmp" 59 | ] 60 | 61 | codegen :: FilePath -> TestTree 62 | codegen fp = testCase ("Generates code without throwing an exception (" ++ fp ++ ")") $ do 63 | parsed <- parseProcess fp 64 | let code = uncurry x86Alloc parsed 65 | assertBool "Doesn't fail" (code `deepseq` True) 66 | 67 | armCodegen :: FilePath -> TestTree 68 | armCodegen fp = testCase ("Generates arm assembly without throwing exception (" ++ fp ++ ")") $ do 69 | parsed <- parseProcess fp 70 | let code = uncurry armAlloc parsed 71 | assertBool "Doesn't fail" (code `deepseq` True) 72 | 73 | livenessArm :: FilePath -> TestTree 74 | livenessArm fp = testCase ("Aarch64 liveness analysis terminates (" ++ fp ++ ")") $ do 75 | parsed <- parseProcess fp 76 | let arm = uncurry armParsed parsed 77 | cf = Arm.mkControlFlow arm 78 | assertBool "Doesn't bottom" (reconstruct cf `deepseq` True) 79 | 80 | liveness :: FilePath -> TestTree 81 | liveness fp = testCase ("Liveness analysis terminates (" ++ fp ++ ")") $ do 82 | parsed <- parseProcess fp 83 | let x86 = uncurry x86Parsed parsed 84 | cf = X86.mkControlFlow x86 85 | assertBool "Doesn't bottom" (reconstruct cf `deepseq` True) 86 | 87 | controlFlowGraph :: FilePath -> TestTree 88 | controlFlowGraph fp = testCase ("Doesn't crash while creating control flow graph for " ++ fp) $ do 89 | parsed <- parseProcess fp 90 | let x86 = uncurry x86Parsed parsed 91 | assertBool "Worked without exception" (X86.mkControlFlow x86 `deepseq` True) 92 | 93 | controlFlowGraphArm :: FilePath -> TestTree 94 | controlFlowGraphArm fp = testCase ("Doesn't crash while creating control flow graph for aarch64 assembly " ++ fp) $ do 95 | parsed <- parseProcess fp 96 | let arm = uncurry armParsed parsed 97 | assertBool "Worked without exception" (Arm.mkControlFlow arm `deepseq` True) 98 | 99 | armNoYeet :: FilePath -> TestTree 100 | armNoYeet fp = testCase ("Selects instructions for " ++ fp) $ do 101 | parsed <- parseProcess fp 102 | let arm = uncurry armParsed parsed 103 | assertBool "Worked without exception" (arm `deepseq` True) 104 | 105 | x86NoYeet :: FilePath -> TestTree 106 | x86NoYeet fp = testCase ("Selects instructions for " ++ fp) $ do 107 | parsed <- parseProcess fp 108 | let x86 = uncurry x86Parsed parsed 109 | assertBool "Worked without exception" (x86 `deepseq` True) 110 | 111 | irNoYeet :: FilePath -> TestTree 112 | irNoYeet fp = testCase ("Generates IR without throwing an exception (" ++ fp ++ ")") $ do 113 | (i, m) <- parseProcess fp 114 | let (res, _, _) = irGen i m 115 | assertBool "Worked without failure" (res `deepseq` True) 116 | 117 | inlineTest :: FilePath -> TestTree 118 | inlineTest fp = testCase ("Inlines " ++ fp ++ " without error") $ inlineFile fp 119 | 120 | inlineFile :: FilePath -> Assertion 121 | inlineFile fp = do 122 | (_, m) <- parseProcess fp 123 | let res = inline m 124 | assertBool "Doesn't bottom when inlining" (res `deepseq` True) 125 | 126 | monoTest :: FilePath -> TestTree 127 | monoTest fp = testCase ("Monomorphizes " ++ fp ++ " without error") $ monoFile fp 128 | 129 | monoFile :: FilePath -> Assertion 130 | monoFile fp = do 131 | (tyM, i) <- assignTypes fp 132 | let res = runMonoM i (flattenModule tyM) 133 | assertBool "Doesn't throw any exceptions" (res `deepseq` True) 134 | 135 | pipelineWorks :: FilePath -> TestTree 136 | pipelineWorks fp = testCase ("Functions in " ++ fp ++ " can be specialized") $ do 137 | (maxU, m) <- parseProcess fp 138 | let res = monomorphize maxU m 139 | case res of 140 | Left err -> assertFailure (show $ pretty err) 141 | Right{} -> assertBool "Doesn't fail type-checking" True 142 | -------------------------------------------------------------------------------- /test/Parser.hs: -------------------------------------------------------------------------------- 1 | module Parser ( parserTests 2 | ) where 3 | 4 | import qualified Data.ByteString.Lazy as BSL 5 | import Kempe.Parser 6 | import Prettyprinter (pretty) 7 | import Test.Tasty 8 | import Test.Tasty.HUnit 9 | 10 | parseNoError :: FilePath -> TestTree 11 | parseNoError fp = testCase ("Parsing doesn't fail (" ++ fp ++ ")") $ do 12 | contents <- BSL.readFile fp 13 | case parse contents of 14 | Left err -> assertFailure (show $ pretty err) 15 | Right{} -> assertBool "Doesn't fail parsing" True 16 | 17 | 18 | parserTests :: TestTree 19 | parserTests = 20 | testGroup "Parser golden tests" 21 | [ parseNoError "test/data/lex.kmp" 22 | , parseNoError "examples/splitmix.kmp" 23 | ] 24 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main (main) where 4 | 5 | import Abi 6 | import Backend 7 | import Parser 8 | import Test.Tasty 9 | import Type 10 | 11 | main :: IO () 12 | main = defaultMain $ 13 | testGroup "Kempe compiler tests" 14 | [ parserTests 15 | , typeTests 16 | , backendTests 17 | , backendGolden 18 | ] 19 | -------------------------------------------------------------------------------- /test/Type.hs: -------------------------------------------------------------------------------- 1 | module Type ( typeTests 2 | , assignTypes 3 | , yeetIO 4 | ) where 5 | 6 | import Control.DeepSeq (deepseq) 7 | import Control.Exception (Exception, throwIO) 8 | import Kempe.AST 9 | import Kempe.File 10 | import Kempe.Module 11 | import Kempe.TyAssign 12 | import Prettyprinter (pretty) 13 | import Test.Tasty 14 | import Test.Tasty.HUnit 15 | 16 | typeTests :: TestTree 17 | typeTests = 18 | testGroup "Type assignment" 19 | [ tyInfer "test/data/ty.kmp" 20 | , tyInfer "prelude/fn.kmp" 21 | , tyInfer "lib/maybe.kmp" 22 | , tyInfer "lib/either.kmp" 23 | , tyInfer "test/data/mutual.kmp" 24 | , tyInfer "examples/factorial.kmp" 25 | , tyInfer "lib/bool.kmp" 26 | , tyInfer "examples/hamming.kmp" 27 | , tyInfer "lib/gaussian.kmp" 28 | , tyInfer "test/data/transitive.kmp" 29 | , tyInfer "lib/tuple.kmp" 30 | , badType "test/err/merge.kmp" "Type a_4 -- Int a_4 is not as general as type a_3 -- a_3 a_3 or does not match." 31 | , badType "test/err/kind.kmp" "Ill-kinded type: '(Maybe_1 Maybe_1)'. Note that type variables have kind \11089 in Kempe." 32 | , badType "test/err/patternMatch.kmp" "Inexhaustive pattern match." 33 | , badType "test/err/typecheck.kmp" "Type a_8 a_9 a_10 -- a_8 a_8 a_9 a_10 is not as general as type a_5\nb_6\nc_7 -- a_5 b_6 c_7 a_5 or does not match." 34 | , testAssignment "test/data/ty.kmp" 35 | , testAssignment "lib/either.kmp" 36 | , testAssignment "prelude/fn.kmp" 37 | , testAssignment "test/data/mutual.kmp" 38 | ] 39 | 40 | yeetIO :: Exception e => Either e a -> IO a 41 | yeetIO = either throwIO pure 42 | 43 | assignTypes :: FilePath -> IO (Declarations () (StackType ()) (StackType ()), Int) 44 | assignTypes fp = do 45 | (maxU, m) <- parseProcess fp 46 | yeetIO $ runTypeM maxU (assignModule m) 47 | 48 | testAssignment :: FilePath -> TestTree 49 | testAssignment fp = testCase ("Annotates " ++ fp ++ " with types") $ do 50 | (m, i) <- assignTypes fp 51 | assertBool "Does not throw an exception" (m `deepseq` i `seq` True) 52 | 53 | tyInfer :: FilePath -> TestTree 54 | tyInfer fp = testCase ("Checks types (" ++ fp ++ ")") $ do 55 | res <- tcFile fp 56 | case res of 57 | Left err -> assertFailure (show $ pretty err) 58 | Right{} -> assertBool "Doesn't fail type-checking" True 59 | 60 | badType :: FilePath -> String -> TestTree 61 | badType fp msg = testCase ("Detects error (" ++ fp ++ ")") $ do 62 | res <- tcFile fp 63 | case res of 64 | Left err -> show (pretty err) @?= msg 65 | Right{} -> assertFailure "No error detected!" 66 | -------------------------------------------------------------------------------- /test/data/abi.kmp: -------------------------------------------------------------------------------- 1 | type Param a b c 2 | { C a b b 3 | | D a b c 4 | } 5 | 6 | ; this should have 7 bytes of padding before the D, so as to match a C constructor 7 | mkConcrete : -- (((Param Int8) Int) Int8) 8 | =: [ 0i8 0 0i8 D ] 9 | 10 | %foreign kabi mkConcrete 11 | -------------------------------------------------------------------------------- /test/data/badCodegen.kmp: -------------------------------------------------------------------------------- 1 | import "lib/maybe.kmp" 2 | 3 | id0 : Int -- Int 4 | =: [ Just dip(0) fromMaybe ] 5 | 6 | id1 : Int -- Int 7 | =: [ Just {case | Nothing -> 0 | Just ->} ] 8 | ; works with new fallthrough 9 | 10 | id2 : Int -- Int 11 | =: [ Just 0 swap {case | Just -> dip(drop) | Nothing ->} ] 12 | 13 | id3 : Int -- Int 14 | =: [ Just 0 swap drop swap ] 15 | 16 | %foreign cabi id0 17 | %foreign cabi id1 18 | %foreign cabi id2 19 | %foreign cabi id3 20 | -------------------------------------------------------------------------------- /test/data/ccall.kmp: -------------------------------------------------------------------------------- 1 | rand : -- Int 2 | =: $cfun"rand" 3 | 4 | randTwice : -- Int Int 5 | =: [ rand rand ] 6 | 7 | %foreign kabi randTwice 8 | -------------------------------------------------------------------------------- /test/data/diamond/a.kmp: -------------------------------------------------------------------------------- 1 | import "test/data/diamond/c.kmp" 2 | import "test/data/diamond/b.kmp" 3 | 4 | forExport : -- Int 5 | =: [ res 2 * ] 6 | 7 | %foreign cabi forExport 8 | -------------------------------------------------------------------------------- /test/data/diamond/b.kmp: -------------------------------------------------------------------------------- 1 | rand : -- Int 2 | =: $cfun"rand" 3 | -------------------------------------------------------------------------------- /test/data/diamond/c.kmp: -------------------------------------------------------------------------------- 1 | import "test/data/diamond/d.kmp" 2 | 3 | res : -- Int 4 | =: [ rand 1 + ] 5 | -------------------------------------------------------------------------------- /test/data/diamond/d.kmp: -------------------------------------------------------------------------------- 1 | rand : -- Int 2 | =: [ 17 ] 3 | -------------------------------------------------------------------------------- /test/data/export.kmp: -------------------------------------------------------------------------------- 1 | even : Int -- Bool 2 | =: [ 2 % 0 = ] 3 | 4 | rand : -- Int 5 | =: $cfun"rand" 6 | 7 | randBool : -- Bool 8 | =: [ rand even ] 9 | 10 | %foreign cabi even 11 | %foreign cabi randBool 12 | -------------------------------------------------------------------------------- /test/data/lex.kmp: -------------------------------------------------------------------------------- 1 | ; this is a comment 2 | 3 | type Void {} 4 | 5 | type Maybe a { Just a | Nothing } 6 | 7 | type OS { Macos | Linux | Windows | Freebsd } 8 | 9 | ; just has type a -- Maybe a 10 | ; nothing has type -- Maybe a 11 | 12 | isUnix : OS -- Bool 13 | =: [ 14 | { case 15 | | Windows -> False 16 | | _ -> True 17 | } 18 | ] 19 | 20 | osNum : OS -- Int 21 | =: [ 22 | { case 23 | | Macos -> 1 24 | | Linux -> 2 25 | | Windows -> 3 26 | | Freebsd -> 4 27 | } 28 | ] 29 | 30 | not : Bool -- Bool 31 | =: [ 32 | { case 33 | | True -> False 34 | | False -> True 35 | } 36 | ] 37 | 38 | rand : -- Int 39 | =: $cfun"rand" 40 | 41 | ; all types are sized (monomorphized) 42 | drop2 : a b -- 43 | =: [ drop drop ] 44 | 45 | drop3 : a b c -- 46 | =: [ drop drop drop ] 47 | 48 | trip : a -- a a a 49 | =: [ dup dup ] 50 | 51 | push3 : -- OS OS OS 52 | =: [ Linux dup dup ] 53 | 54 | aInt : a -- Int a 55 | =: [ dip(3) ] 56 | 57 | randTwice : -- Int Int 58 | =: [ rand rand ] 59 | 60 | odd : Int -- Bool 61 | =: [ 2 % 0 = ] 62 | 63 | %foreign kabi randTwice 64 | -------------------------------------------------------------------------------- /test/data/maybeC.kmp: -------------------------------------------------------------------------------- 1 | type Maybe a { Just a | Nothing } 2 | 3 | noInt : -- (Maybe Int) 4 | =: [ Nothing ] 5 | 6 | ; FIXME: maybe this doesn't work because (Maybe Int) is too big? 7 | %foreign cabi noInt 8 | -------------------------------------------------------------------------------- /test/data/mod.kmp: -------------------------------------------------------------------------------- 1 | import"prelude/arith.kmp" 2 | 3 | mod_kmp : Int Int -- Int 4 | =: [ modInt ] 5 | 6 | div_kmp : Int Int -- Int 7 | =: [ divInt ] 8 | 9 | %foreign cabi mod_kmp 10 | %foreign cabi div_kmp 11 | -------------------------------------------------------------------------------- /test/data/multiConstruct.kmp: -------------------------------------------------------------------------------- 1 | import "lib/maybe.kmp" 2 | import "lib/either.kmp" 3 | 4 | mkJustRight : Int -- ((Either Int) (Maybe Int)) 5 | =: [ Just Right ] 6 | 7 | %foreign kabi mkJustRight 8 | -------------------------------------------------------------------------------- /test/data/mutual.kmp: -------------------------------------------------------------------------------- 1 | odd : Int -- Bool 2 | =: [ dup 0 = 3 | if( drop False 4 | , - 1 even ) 5 | ] 6 | 7 | even : Int -- Bool 8 | =: [ dup 0 = 9 | if( drop True 10 | , - 1 odd ) 11 | ] 12 | 13 | %foreign cabi even 14 | -------------------------------------------------------------------------------- /test/data/regAlloc.kmp: -------------------------------------------------------------------------------- 1 | import "prelude/fn.kmp" 2 | import "lib/maybe.kmp" 3 | 4 | constTrue : Bool Bool -- Bool 5 | =: [ & drop True ] 6 | 7 | %foreign kabi constTrue 8 | -------------------------------------------------------------------------------- /test/data/transitive.kmp: -------------------------------------------------------------------------------- 1 | import "lib/tuple.kmp" 2 | 3 | enTuple : Int Int -- ((Pair Int) Int) 4 | =: [ Pair ] 5 | 6 | %foreign kabi enTuple 7 | -------------------------------------------------------------------------------- /test/data/ty.kmp: -------------------------------------------------------------------------------- 1 | type Void {} 2 | 3 | type Maybe a { Just a | Nothing } 4 | 5 | type OS { Macos | Linux | Windows | Freebsd } 6 | 7 | ; just has type a -- Maybe a 8 | ; nothing has type -- Maybe a 9 | 10 | rand : -- Int 11 | =: $cfun"rand" 12 | 13 | ; all types are sized (monomorphized) 14 | drop2 : a b -- 15 | =: [ drop drop ] 16 | 17 | drop3 : a b c -- 18 | =: [ drop drop drop ] 19 | 20 | trip : a -- a a a 21 | =: [ dup dup ] 22 | 23 | trint : -- Int Int Int 24 | =: [ 0 trip ] 25 | 26 | even : Int -- Bool 27 | =: [ 2 % 0 = ] 28 | 29 | randBool : -- Bool 30 | =: [ rand even ] 31 | 32 | maybeEven : -- (Maybe Int) 33 | =: [ rand dup even 34 | if( drop Nothing 35 | , Just 36 | ) 37 | ] 38 | 39 | push3 : -- OS OS OS 40 | =: [ Linux trip ] 41 | 42 | doNothing : Int Int -- Int Int 43 | =: [ ] 44 | 45 | %foreign cabi randBool 46 | %foreign cabi maybeEven 47 | -------------------------------------------------------------------------------- /test/err/badWildcard.kmp: -------------------------------------------------------------------------------- 1 | type Maybe a { Just a | Nothing } 2 | 3 | return0 : (Maybe a) -- Int 4 | =: [ 5 | { case 6 | | _ -> 2 7 | } 8 | ] 9 | 10 | %foreign kabi return0 11 | -------------------------------------------------------------------------------- /test/err/kind.kmp: -------------------------------------------------------------------------------- 1 | type Maybe a { Just a | Nothing } 2 | 3 | poorlyKinded : (Maybe Maybe) -- 4 | =: [ drop ] 5 | -------------------------------------------------------------------------------- /test/err/merge.kmp: -------------------------------------------------------------------------------- 1 | dup0 : a -- a a 2 | =: [ dip(3) ] 3 | -------------------------------------------------------------------------------- /test/err/patternMatch.kmp: -------------------------------------------------------------------------------- 1 | not : Bool -- Bool 2 | =: [ 3 | { case 4 | | True -> False 5 | } 6 | ] 7 | -------------------------------------------------------------------------------- /test/err/questionable.kmp: -------------------------------------------------------------------------------- 1 | type Option a { Some a | None } 2 | 3 | type Optional a { Some a | None } 4 | -------------------------------------------------------------------------------- /test/err/stupid.kmp: -------------------------------------------------------------------------------- 1 | rand : -- Int 2 | =: [ 3 ] 3 | 4 | rand : -- Int 5 | =: $cfun"rand" 6 | -------------------------------------------------------------------------------- /test/err/swapBinOp.kmp: -------------------------------------------------------------------------------- 1 | lte : Int Int -- Bool 2 | =: [ swap > ] 3 | -------------------------------------------------------------------------------- /test/err/typecheck.kmp: -------------------------------------------------------------------------------- 1 | ; FIXME: should not typecheck (just generates constraint b = c, which should not be allowed 2 | pick : a b c -- a b c a 3 | =: [ dip(dip(dup)) ] 4 | -------------------------------------------------------------------------------- /test/examples/bool.kmp: -------------------------------------------------------------------------------- 1 | not : Bool -- Bool 2 | =: [ 3 | { case 4 | | True -> False 5 | | False -> True 6 | } 7 | ] 8 | 9 | eq : Bool Bool -- Bool 10 | =: [ xor not ] 11 | 12 | nand : Bool Bool -- Bool 13 | =: [ & not ] 14 | 15 | nor : Bool Bool -- Bool 16 | =: [ || not ] 17 | 18 | %foreign armabi not 19 | %foreign armabi eq 20 | -------------------------------------------------------------------------------- /test/examples/const.kmp: -------------------------------------------------------------------------------- 1 | id_int : Int -- Int 2 | =: [ ] 3 | 4 | %foreign armabi id_int 5 | -------------------------------------------------------------------------------- /test/examples/hamming.kmp: -------------------------------------------------------------------------------- 1 | hamming : Word Word -- Int 2 | =: [ xoru popcount ] 3 | 4 | %foreign cabi hamming 5 | -------------------------------------------------------------------------------- /test/examples/splitmix.kmp: -------------------------------------------------------------------------------- 1 | next : Word -- Word Word 2 | =: [ 0x9e3779b97f4a7c15u +~ dup 3 | dup 30u >>~ xoru 0xbf58476d1ce4e5b9u *~ 4 | dup 27u >>~ xoru 0x94d049bb133111ebu *~ 5 | dup 31u >>~ xoru 6 | ] 7 | 8 | from_seed : Word -- Word 9 | =: [ next dip(drop) ] 10 | 11 | %foreign armabi from_seed 12 | -------------------------------------------------------------------------------- /test/golden/a.ir: -------------------------------------------------------------------------------- 1 | 2 | kmp1: 3 | (movmem (reg datapointer) (int 17)) 4 | (movtemp datapointer (+ (reg datapointer) (int 8))) 5 | (movmem (reg datapointer) (int 1)) 6 | (movtemp t_1 (mem [8] (reg datapointer))) 7 | (movtemp datapointer (- (reg datapointer) (int 8))) 8 | (movtemp t_2 (mem [8] (reg datapointer))) 9 | (movmem (reg datapointer) (+ (reg t_2) (reg t_1))) 10 | (movtemp datapointer (+ (reg datapointer) (int 8))) 11 | (movmem (reg datapointer) (int 2)) 12 | (movtemp t_3 (mem [8] (reg datapointer))) 13 | (movtemp datapointer (- (reg datapointer) (int 8))) 14 | (movtemp t_4 (mem [8] (reg datapointer))) 15 | (movmem (reg datapointer) (* (reg t_4) (reg t_3))) 16 | (movtemp datapointer (+ (reg datapointer) (int 8))) 17 | (ret) 18 | 19 | export forExport { -- Int} kmp1 -------------------------------------------------------------------------------- /test/golden/abi.ir: -------------------------------------------------------------------------------- 1 | 2 | kmp1: 3 | (movmem (reg datapointer) (int8 0)) 4 | (movtemp datapointer (+ (reg datapointer) (int 1))) 5 | (movmem (reg datapointer) (int 0)) 6 | (movtemp datapointer (+ (reg datapointer) (int 8))) 7 | (movmem (reg datapointer) (int8 0)) 8 | (movtemp datapointer (+ (reg datapointer) (int 8))) 9 | (movmem (reg datapointer) (tag 0x1)) 10 | (movtemp datapointer (+ (reg datapointer) (int 1))) 11 | (ret) 12 | 13 | export mkConcrete { -- (((Param_1 Int8) Int) Int8)} kmp1 -------------------------------------------------------------------------------- /test/golden/bool.out: -------------------------------------------------------------------------------- 1 | 0 2 | 1 3 | 0 -------------------------------------------------------------------------------- /test/golden/const.out: -------------------------------------------------------------------------------- 1 | 3 -------------------------------------------------------------------------------- /test/golden/factorial.out: -------------------------------------------------------------------------------- 1 | 6 2 | 6 -------------------------------------------------------------------------------- /test/golden/gaussian.ir: -------------------------------------------------------------------------------- 1 | 2 | kmp1: 3 | (movtemp datapointer (- (reg datapointer) (int 18))) 4 | (movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 17)))) 5 | (movmem (+ (reg datapointer) (int 8)) (mem [8] (+ (reg datapointer) (int 25)))) 6 | (movmem (+ (reg datapointer) (int 16)) (mem [1] (+ (reg datapointer) (int 33)))) 7 | (movtemp datapointer (+ (reg datapointer) (int 16))) 8 | (movmem (reg datapointer) (mem [8] (- (reg datapointer) (int 24)))) 9 | (movmem (- (reg datapointer) (int 24)) (mem [8] (- (reg datapointer) (int 16)))) 10 | (movmem (- (reg datapointer) (int 16)) (mem [8] (reg datapointer))) 11 | (movtemp datapointer (- (reg datapointer) (int 8))) 12 | (movtemp t_1 (mem [8] (reg datapointer))) 13 | (movtemp datapointer (- (reg datapointer) (int 8))) 14 | (movtemp t_2 (mem [8] (reg datapointer))) 15 | (movmem (reg datapointer) (+ (reg t_2) (reg t_1))) 16 | (movtemp datapointer (- (reg datapointer) (int 8))) 17 | (movtemp t_3 (mem [8] (reg datapointer))) 18 | (movtemp datapointer (- (reg datapointer) (int 8))) 19 | (movtemp t_4 (mem [8] (reg datapointer))) 20 | (movmem (reg datapointer) (+ (reg t_4) (reg t_3))) 21 | (movtemp datapointer (+ (reg datapointer) (int 8))) 22 | (movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 8)))) 23 | (movtemp datapointer (+ (reg datapointer) (int 8))) 24 | (movmem (reg datapointer) (tag 0x0)) 25 | (movtemp datapointer (+ (reg datapointer) (int 1))) 26 | (ret) 27 | 28 | kmp2: 29 | (movmem (reg datapointer) (mem [8] (- (reg datapointer) (int 17)))) 30 | (movmem (+ (reg datapointer) (int 8)) (mem [8] (- (reg datapointer) (int 9)))) 31 | (movmem (+ (reg datapointer) (int 16)) (mem [1] (- (reg datapointer) (int 1)))) 32 | (movmem (- (reg datapointer) (int 17)) (mem [8] (- (reg datapointer) (int 34)))) 33 | (movmem (- (reg datapointer) (int 9)) (mem [8] (- (reg datapointer) (int 26)))) 34 | (movmem (- (reg datapointer) (int 1)) (mem [1] (- (reg datapointer) (int 18)))) 35 | (movtemp datapointer (+ (reg datapointer) (int 17))) 36 | (movmem (reg datapointer) (mem [8] (- (reg datapointer) (int 34)))) 37 | (movmem (+ (reg datapointer) (int 8)) (mem [8] (- (reg datapointer) (int 26)))) 38 | (movmem (+ (reg datapointer) (int 16)) (mem [1] (- (reg datapointer) (int 18)))) 39 | (movmem (- (reg datapointer) (int 34)) (mem [8] (- (reg datapointer) (int 17)))) 40 | (movmem (- (reg datapointer) (int 26)) (mem [8] (- (reg datapointer) (int 9)))) 41 | (movmem (- (reg datapointer) (int 18)) (mem [1] (- (reg datapointer) (int 1)))) 42 | (movmem (- (reg datapointer) (int 17)) (mem [8] (reg datapointer))) 43 | (movmem (- (reg datapointer) (int 9)) (mem [8] (+ (reg datapointer) (int 8)))) 44 | (movmem (- (reg datapointer) (int 1)) (mem [1] (+ (reg datapointer) (int 16)))) 45 | (movmem (reg datapointer) (mem [8] (- (reg datapointer) (int 17)))) 46 | (movmem (+ (reg datapointer) (int 8)) (mem [8] (- (reg datapointer) (int 9)))) 47 | (movmem (+ (reg datapointer) (int 16)) (mem [1] (- (reg datapointer) (int 1)))) 48 | (movmem (- (reg datapointer) (int 17)) (mem [8] (- (reg datapointer) (int 34)))) 49 | (movmem (- (reg datapointer) (int 9)) (mem [8] (- (reg datapointer) (int 26)))) 50 | (movmem (- (reg datapointer) (int 1)) (mem [1] (- (reg datapointer) (int 18)))) 51 | (movtemp datapointer (+ (reg datapointer) (int 17))) 52 | (movmem (reg datapointer) (mem [8] (- (reg datapointer) (int 34)))) 53 | (movmem (+ (reg datapointer) (int 8)) (mem [8] (- (reg datapointer) (int 26)))) 54 | (movmem (+ (reg datapointer) (int 16)) (mem [1] (- (reg datapointer) (int 18)))) 55 | (movmem (- (reg datapointer) (int 34)) (mem [8] (- (reg datapointer) (int 17)))) 56 | (movmem (- (reg datapointer) (int 26)) (mem [8] (- (reg datapointer) (int 9)))) 57 | (movmem (- (reg datapointer) (int 18)) (mem [1] (- (reg datapointer) (int 1)))) 58 | (movmem (- (reg datapointer) (int 17)) (mem [8] (reg datapointer))) 59 | (movmem (- (reg datapointer) (int 9)) (mem [8] (+ (reg datapointer) (int 8)))) 60 | (movmem (- (reg datapointer) (int 1)) (mem [1] (+ (reg datapointer) (int 16)))) 61 | (movtemp datapointer (- (reg datapointer) (int 18))) 62 | (movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 17)))) 63 | (movmem (+ (reg datapointer) (int 8)) (mem [8] (+ (reg datapointer) (int 25)))) 64 | (movmem (+ (reg datapointer) (int 16)) (mem [1] (+ (reg datapointer) (int 33)))) 65 | (movtemp t_5 (mem [8] (reg datapointer))) 66 | (movtemp datapointer (- (reg datapointer) (int 8))) 67 | (movtemp t_6 (mem [8] (reg datapointer))) 68 | (movmem (reg datapointer) (* (reg t_6) (reg t_5))) 69 | (movtemp datapointer (+ (reg datapointer) (int 8))) 70 | (movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 8)))) 71 | (movtemp datapointer (+ (reg datapointer) (int 8))) 72 | (movmem (reg datapointer) (mem [8] (- (reg datapointer) (int 16)))) 73 | (movmem (- (reg datapointer) (int 16)) (mem [8] (- (reg datapointer) (int 8)))) 74 | (movmem (- (reg datapointer) (int 8)) (mem [8] (reg datapointer))) 75 | (movtemp datapointer (- (reg datapointer) (int 16))) 76 | (movtemp t_7 (mem [8] (reg datapointer))) 77 | (movtemp datapointer (- (reg datapointer) (int 8))) 78 | (movtemp t_8 (mem [8] (reg datapointer))) 79 | (movmem (reg datapointer) (* (reg t_8) (reg t_7))) 80 | (movtemp datapointer (+ (reg datapointer) (int 8))) 81 | (movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 8)))) 82 | (movtemp t_9 (mem [8] (reg datapointer))) 83 | (movtemp datapointer (- (reg datapointer) (int 8))) 84 | (movtemp t_10 (mem [8] (reg datapointer))) 85 | (movmem (reg datapointer) (+ (reg t_10) (reg t_9))) 86 | (movtemp datapointer (+ (reg datapointer) (int -18))) 87 | (movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 25)))) 88 | (movmem (+ (reg datapointer) (int 8)) (mem [8] (+ (reg datapointer) (int 33)))) 89 | (movmem (+ (reg datapointer) (int 16)) (mem [8] (+ (reg datapointer) (int 41)))) 90 | (movmem (+ (reg datapointer) (int 24)) (mem [1] (+ (reg datapointer) (int 49)))) 91 | (movtemp datapointer (+ (reg datapointer) (int 16))) 92 | (movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 8)))) 93 | (movtemp datapointer (+ (reg datapointer) (int 8))) 94 | (movmem (reg datapointer) (mem [8] (- (reg datapointer) (int 32)))) 95 | (movmem (- (reg datapointer) (int 32)) (mem [8] (- (reg datapointer) (int 24)))) 96 | (movmem (- (reg datapointer) (int 24)) (mem [8] (reg datapointer))) 97 | (movtemp datapointer (- (reg datapointer) (int 16))) 98 | (movtemp t_11 (mem [8] (reg datapointer))) 99 | (movtemp datapointer (- (reg datapointer) (int 8))) 100 | (movtemp t_12 (mem [8] (reg datapointer))) 101 | (movmem (reg datapointer) (* (reg t_12) (reg t_11))) 102 | (movtemp datapointer (+ (reg datapointer) (int 8))) 103 | (movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 8)))) 104 | (movtemp datapointer (+ (reg datapointer) (int -16))) 105 | (movtemp t_13 (mem [8] (reg datapointer))) 106 | (movtemp datapointer (- (reg datapointer) (int 8))) 107 | (movtemp t_14 (mem [8] (reg datapointer))) 108 | (movmem (reg datapointer) (* (reg t_14) (reg t_13))) 109 | (movtemp datapointer (+ (reg datapointer) (int 8))) 110 | (movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 16)))) 111 | (movmem (+ (reg datapointer) (int 8)) (mem [8] (+ (reg datapointer) (int 24)))) 112 | (movtemp t_15 (mem [8] (reg datapointer))) 113 | (movtemp datapointer (- (reg datapointer) (int 8))) 114 | (movtemp t_16 (mem [8] (reg datapointer))) 115 | (movmem (reg datapointer) (- (reg t_16) (reg t_15))) 116 | (movtemp datapointer (+ (reg datapointer) (int 8))) 117 | (movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 8)))) 118 | (movtemp datapointer (+ (reg datapointer) (int 8))) 119 | (movmem (reg datapointer) (tag 0x0)) 120 | (movtemp datapointer (+ (reg datapointer) (int 1))) 121 | (ret) 122 | 123 | kmp3: 124 | (movtemp datapointer (- (reg datapointer) (int 9))) 125 | (movtemp t_17 (mem [8] (reg datapointer))) 126 | (movmem (reg datapointer) (~ (reg t_17))) 127 | (movtemp datapointer (+ (reg datapointer) (int 8))) 128 | (movmem (reg datapointer) (tag 0x0)) 129 | (movtemp datapointer (+ (reg datapointer) (int 1))) 130 | (ret) 131 | 132 | export add {Gaussian_1 Gaussian_1 -- Gaussian_1} kmp1 133 | 134 | export conjugate {Gaussian_1 -- Gaussian_1} kmp3 135 | 136 | export mult {Gaussian_1 Gaussian_1 -- Gaussian_1} kmp2 -------------------------------------------------------------------------------- /test/golden/hamming.out: -------------------------------------------------------------------------------- 1 | 2 -------------------------------------------------------------------------------- /test/golden/id.out: -------------------------------------------------------------------------------- 1 | 4 2 | 4 3 | 4 4 | -------------------------------------------------------------------------------- /test/golden/mod.out: -------------------------------------------------------------------------------- 1 | -1 2 | -------------------------------------------------------------------------------- /test/golden/numbertheory.out: -------------------------------------------------------------------------------- 1 | 1 2 | 0 3 | 7 -------------------------------------------------------------------------------- /test/golden/splitmix.out: -------------------------------------------------------------------------------- 1 | 3631356771 -------------------------------------------------------------------------------- /test/harness/bool.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | extern bool not(void*, bool); 6 | extern bool eq(void*, bool, bool); 7 | 8 | int main(int argc, char *argv[]) { 9 | void* kptr = malloc(32 * 1024); 10 | printf("%d\n", not(kptr, true)); 11 | printf("%d\n", not(kptr, false)); 12 | printf("%d", eq(kptr, true, false)); 13 | } 14 | -------------------------------------------------------------------------------- /test/harness/const.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | extern int id_int(void*, int); 5 | 6 | int main(int argc, char *argv[]) { 7 | void* kptr = malloc(32 * 1024); 8 | printf("%d", id_int(kptr, 3)); 9 | } 10 | -------------------------------------------------------------------------------- /test/harness/factorial.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | extern int fac_tailrec(void*, int); 5 | extern int fac(void*, int); 6 | 7 | int main(int argc, char *argv[]) { 8 | void* kptr = malloc(32 * 1024); 9 | printf("%d\n", fac_tailrec(kptr, 3)); 10 | printf("%d", fac(kptr, 3)); 11 | } 12 | -------------------------------------------------------------------------------- /test/harness/hamming.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | extern int hamming(uint64_t, uint64_t); 5 | 6 | int main(int argc, char *argv[]) { 7 | printf("%d", hamming(5, 3)); 8 | } 9 | -------------------------------------------------------------------------------- /test/harness/id.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | extern int id0(int); 4 | extern int id1(int); 5 | extern int id2(int); 6 | extern int id3(int); 7 | 8 | int main(int argc, char *argv[]) { 9 | printf("%d\n", id0(4)); 10 | printf("%d\n", id1(4)); 11 | printf("%d\n", id2(4)); 12 | printf("%d", id3(4)); 13 | } 14 | -------------------------------------------------------------------------------- /test/harness/mod.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | extern int mod_kmp(int, int); 4 | extern int div_kmp(int, int); 5 | 6 | int main(int argc, char *argv[]) { 7 | printf("%d\n", mod_kmp(2, -3)); 8 | printf("%d\n", div_kmp(2, -3)); 9 | printf("%d\n", div_kmp(-2, 3)); 10 | } 11 | -------------------------------------------------------------------------------- /test/harness/numbertheory.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | extern int k_gcd(void*, int, int); 6 | extern bool is_prime(void*, int); 7 | 8 | int main(int argc, char *argv[]) { 9 | void* kptr = malloc(32 * 1024); 10 | printf("%d\n", is_prime(kptr, 37)); 11 | printf("%d\n", is_prime(kptr, 36)); 12 | printf("%d", k_gcd(kptr, 21, 35)); 13 | } 14 | -------------------------------------------------------------------------------- /test/harness/splitmix.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | extern uint64_t from_seed(void*, uint64_t); 6 | 7 | int main(int argc, char *argv[]) { 8 | void* kptr = malloc(32 * 1024); 9 | printf("%u", (unsigned int) from_seed(kptr, 3012512025)); 10 | } 11 | -------------------------------------------------------------------------------- /test/include/num.h: -------------------------------------------------------------------------------- 1 | #include 2 | extern int k_gcd (void*, int, int); 3 | extern bool is_prime (void*, int); -------------------------------------------------------------------------------- /test/include/splitmix.h: -------------------------------------------------------------------------------- 1 | #include 2 | extern uint64_t from_seed (void*, uint64_t); -------------------------------------------------------------------------------- /tex/types.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vmchale/kempe/15aa714ace9ad436e7b2c8366ae7c61a893afc99/tex/types.pdf -------------------------------------------------------------------------------- /tex/types.tex: -------------------------------------------------------------------------------- 1 | \documentclass{report} 2 | 3 | \usepackage{mathpartir} 4 | \usepackage{syntax} 5 | 6 | \begin{document} 7 | 8 | \title{Kempe Type System} 9 | \author {Vanessa McHale} 10 | \maketitle 11 | 12 | \tableofcontents 13 | 14 | \section{Introduction} 15 | 16 | This presents the Kempe type system. 17 | 18 | \section{Syntax} 19 | 20 | \setlength{\grammarparsep}{20pt plus 1pt minus 1pt} 21 | \setlength{\grammarindent}{12em} 22 | 23 | \begin{grammar} 24 | ::= 25 | \alt 26 | 27 | ::= 28 | \alt 29 | \alt 30 | \end{grammar} 31 | 32 | \section{Judgments} 33 | 34 | \begin{mathpar} 35 | \inferrule 36 | {\Gamma \vdash x : \alpha_1\cdots\alpha_n -- \beta_1\cdots\beta_m\gamma_1\cdots\gamma_k \\ \Gamma \vdash y : \gamma_1\cdots\gamma_k -- \delta_1\cdots\delta_l} 37 | {\Gamma \vdash xy : \alpha_1\cdots\alpha_n -- \beta_1\cdots\beta_n\delta_1\cdots\delta_l} 38 | \quad(\textsc {Concat}) 39 | 40 | \inferrule 41 | {\Gamma \vdash x : \alpha_1\cdots\alpha_n -- \beta_1\cdots\beta_m} 42 | {\Gamma \vdash x : a\alpha_1\cdots\alpha_n -- a\beta_1\cdots\beta_m} 43 | \quad(\textsc{Generalize}) 44 | 45 | \inferrule 46 | {\Gamma \vdash x : \alpha_1\cdots\alpha_n -- \beta_1\cdots\beta_m} 47 | {\Gamma \vdash [x] : -- [\alpha_1\cdots\alpha_n -- \beta_1\cdots\beta_m]} 48 | \quad(\textsc{Quote}) 49 | 50 | \inferrule 51 | {\Gamma \vdash f : -- [\alpha_1\cdots\alpha_n -- \beta_1\cdots\beta_m]} 52 | {\Gamma \vdash f \textrm{apply} : \alpha_1\cdots\alpha_n -- \beta_1\cdots\beta_m} 53 | \quad(\textsc{Apply}) 54 | 55 | \inferrule 56 | {\Gamma \vdash x : [\alpha_1\cdots\alpha_n -- \beta_1\cdots\beta_m]} 57 | {\Gamma \vdash x : [a\alpha_1\cdots\alpha_n -- a\beta_1\cdots\beta_m]} 58 | \quad(\textsc{Generalize-Quote}) 59 | 60 | \end{mathpar} 61 | 62 | \end{document} 63 | -------------------------------------------------------------------------------- /vim/ftdetect/kempe.vim: -------------------------------------------------------------------------------- 1 | augroup kempe 2 | autocmd BufNewFile,BufRead *.kmp set filetype=kempe 3 | augroup END 4 | -------------------------------------------------------------------------------- /vim/ftplugin/kempe.vim: -------------------------------------------------------------------------------- 1 | setlocal commentstring=;\ %s 2 | 3 | set smarttab 4 | 5 | setl shiftwidth=4 6 | 7 | " use kc as a checker 8 | let g:syntastic_kempe_checkers = [ 'kc' ] 9 | -------------------------------------------------------------------------------- /vim/syntax/kempe.vim: -------------------------------------------------------------------------------- 1 | scriptencoding utf-8 2 | 3 | if exists('b:current_syntax') 4 | finish 5 | endif 6 | 7 | syntax match kempeSymbol "--" 8 | syntax match kempeSymbol "->" 9 | 10 | syntax match kempeIdentifier "\v[a-z][a-zA-Z0-9]*" 11 | syntax match kempeType "\v[A-Z][a-zA-Z0-9]*" 12 | 13 | syntax match kempeExternal "\".*\"" 14 | 15 | syntax match kempeNum "\v[0-9]+" 16 | syntax match kempeNum "\v0x[0-9a-z]+" 17 | syntax match kempeNum "\v0x[0-9a-z]+u" 18 | syntax match kempeNum "\v[0-9]+i8" 19 | 20 | syntax match kempeKeyword "type" 21 | syntax match kempeKeyword "case" 22 | syntax match kempeKeyword "import" 23 | 24 | syntax match kempeType "Int" 25 | syntax match kempeType "Word" 26 | syntax match kempeType "Int8" 27 | syntax match kempeType "Ptr" 28 | 29 | syntax match kempeComment "\v;.*$" contains=@Spell 30 | 31 | syntax match kempeIdentifier "$cfun" 32 | syntax match kempeSymbol "cabi" 33 | syntax match kempeSymbol "kabi" 34 | syntax match kempeSymbol "hooked" 35 | syntax match kempeSymbol "armabi" 36 | syntax match kempePragma "%foreign" 37 | 38 | highlight link kempeComment Comment 39 | highlight link kempeKeyword Keyword 40 | highlight link kempeOperator Keyword 41 | highlight link kempeNum Number 42 | highlight link kempeIdentifier Identifier 43 | highlight link kempeType Type 44 | highlight link kempeSymbol Special 45 | highlight link kempeExternal String 46 | highlight link kempePragma Type 47 | 48 | let b:current_syntax = 'kempe' 49 | -------------------------------------------------------------------------------- /vim/syntax_checkers/kempe/kc.vim: -------------------------------------------------------------------------------- 1 | if exists('g:loaded_syntastic_kempe_kc_checker') 2 | finish 3 | endif 4 | let g:loaded_syntastic_kempe_kc_checker = 1 5 | 6 | let g:syntastic_kempe_kc_exec = 'kc' 7 | 8 | function! SyntaxCheckers_kempe_kc_GetLocList() dict 9 | let makeprg = self.makeprgBuild({ 10 | \ 'exe': self.getExec(), 11 | \ 'args': 'typecheck', 12 | \ 'fname': shellescape(expand('%') )}) 13 | 14 | let errorformat = 15 | \ 'kc: %m' 16 | 17 | let loclist = SyntasticMake({ 18 | \ 'makeprg': makeprg, 19 | \ 'errorformat': errorformat }) 20 | 21 | return loclist 22 | 23 | endfunction 24 | 25 | call g:SyntasticRegistry.CreateAndRegisterChecker({ 26 | \ 'filetype': 'kempe', 27 | \ 'name': 'kc' }) 28 | --------------------------------------------------------------------------------