├── .github ├── CODEOWNERS ├── Dockerfile └── workflows │ ├── binary.yml │ ├── docker.yml │ └── pure.yml ├── .gitignore ├── .holpath ├── COPYING ├── Holmakefile ├── README.md ├── compiler ├── Holmakefile ├── backend │ ├── Holmakefile │ ├── languages │ │ ├── Holmakefile │ │ ├── env_cexpScript.sml │ │ ├── properties │ │ │ ├── Holmakefile │ │ │ ├── env_cexp_lemmasScript.sml │ │ │ └── pure_cexp_lemmasScript.sml │ │ ├── pure_cexpScript.sml │ │ ├── relations │ │ │ ├── Holmakefile │ │ │ ├── pure_inline_rel_altScript.sml │ │ │ ├── pure_presScript.sml │ │ │ └── pure_pres_lemmasScript.sml │ │ ├── semantics │ │ │ ├── Holmakefile │ │ │ ├── envLangScript.sml │ │ │ ├── env_semanticsScript.sml │ │ │ ├── pureLangScript.sml │ │ │ ├── stateLangScript.sml │ │ │ ├── thunkLangPropsScript.sml │ │ │ ├── thunkLangScript.sml │ │ │ ├── thunkLang_primitivesScript.sml │ │ │ ├── thunk_exp_ofScript.sml │ │ │ └── thunk_semanticsScript.sml │ │ ├── state_cexpScript.sml │ │ └── thunk_cexpScript.sml │ ├── passes │ │ ├── Holmakefile │ │ ├── env_to_stateScript.sml │ │ ├── proofs │ │ │ ├── Holmakefile │ │ │ ├── env_to_stateProofScript.sml │ │ │ ├── env_to_state_1ProofScript.sml │ │ │ ├── env_to_state_2ProofScript.sml │ │ │ ├── expof_caseProofScript.sml │ │ │ ├── notes.txt │ │ │ ├── pure_dead_letProofScript.sml │ │ │ ├── pure_demands_analysisProofScript.sml │ │ │ ├── pure_freshenProofScript.sml │ │ │ ├── pure_inline_cexpProofScript.sml │ │ │ ├── pure_letrecProofScript.sml │ │ │ ├── pure_letrecScript.sml │ │ │ ├── pure_letrec_cexpProofScript.sml │ │ │ ├── pure_letrec_funProofScript.sml │ │ │ ├── pure_letrec_lamProofScript.sml │ │ │ ├── pure_letrec_lamScript.sml │ │ │ ├── pure_letrec_spec_cexpProofScript.sml │ │ │ ├── pure_namesProofScript.sml │ │ │ ├── pure_nestedcaseProofScript.sml │ │ │ ├── pure_to_cakeProofScript.sml │ │ │ ├── pure_to_thunkProofScript.sml │ │ │ ├── pure_to_thunk_1ProofScript.sml │ │ │ ├── pure_to_thunk_2ProofScript.sml │ │ │ ├── state_app_unitProofScript.sml │ │ │ ├── state_app_unit_1ProofScript.sml │ │ │ ├── state_app_unit_2ProofScript.sml │ │ │ ├── state_caseProofScript.sml │ │ │ ├── state_namesProofScript.sml │ │ │ ├── state_names_1ProofScript.sml │ │ │ ├── state_to_cakeProofScript.sml │ │ │ ├── state_unthunkProofScript.sml │ │ │ ├── thunk_Delay_LamScript.sml │ │ │ ├── thunk_Forcing_LambdasScript.sml │ │ │ ├── thunk_Let_Delay_VarScript.sml │ │ │ ├── thunk_Let_Lam_ForcedScript.sml │ │ │ ├── thunk_NRC_Forcing_LambdasScript.sml │ │ │ ├── thunk_NRC_relScript.sml │ │ │ ├── thunk_case_d2bProofScript.sml │ │ │ ├── thunk_case_inlProofScript.sml │ │ │ ├── thunk_case_liftProofScript.sml │ │ │ ├── thunk_case_projProofScript.sml │ │ │ ├── thunk_case_unboxProofScript.sml │ │ │ ├── thunk_combine_Forcing_LambdasScript.sml │ │ │ ├── thunk_force_delayScript.sml │ │ │ ├── thunk_let_forceProofScript.sml │ │ │ ├── thunk_let_force_1ProofScript.sml │ │ │ ├── thunk_remove_unuseful_bindingsScript.sml │ │ │ ├── thunk_split_Delay_LamProofScript.sml │ │ │ ├── thunk_split_Forcing_LamProofScript.sml │ │ │ ├── thunk_tickProofScript.sml │ │ │ ├── thunk_to_envProofScript.sml │ │ │ ├── thunk_to_env_1ProofScript.sml │ │ │ ├── thunk_unthunkProofScript.sml │ │ │ └── thunk_untickProofScript.sml │ │ ├── pure_comp_confScript.sml │ │ ├── pure_dead_letScript.sml │ │ ├── pure_demands_analysisScript.sml │ │ ├── pure_freshenScript.sml │ │ ├── pure_inline_cexpScript.sml │ │ ├── pure_letrec_cexpScript.sml │ │ ├── pure_letrec_spec_cexpScript.sml │ │ ├── pure_namesScript.sml │ │ ├── pure_nestedcaseScript.sml │ │ ├── pure_to_cakeScript.sml │ │ ├── pure_to_thunkScript.sml │ │ ├── state_app_unitScript.sml │ │ ├── state_namesScript.sml │ │ ├── state_to_cakeScript.sml │ │ ├── tests │ │ │ ├── Holmakefile │ │ │ └── pure_inline_testScript.sml │ │ ├── thunk_let_forceScript.sml │ │ ├── thunk_split_Delay_LamScript.sml │ │ ├── thunk_split_Forcing_LamScript.sml │ │ ├── thunk_to_envScript.sml │ │ └── var_setScript.sml │ └── pure_varsScript.sml ├── binary │ ├── Holmakefile │ ├── pure_backendProgScript.sml │ ├── pure_compilerCompileScript.sml │ ├── pure_compilerProgScript.sml │ ├── pure_frontendProgScript.sml │ ├── pure_inferProgScript.sml │ └── pure_parseProgScript.sml ├── parsing │ ├── .gitignore │ ├── Holmakefile │ ├── ast_to_cexpScript.sml │ ├── cases-algo.ML │ ├── cst_to_astScript.sml │ ├── gram.txt │ ├── ispegScript.sml │ ├── ispegexecScript.sml │ ├── paper.hs │ ├── pureASTScript.sml │ ├── pureNTScript.sml │ ├── purePEGScript.sml │ ├── pureParseScript.sml │ ├── pureParsingLib.sig │ ├── pureParsingLib.sml │ ├── pureTokenUtilsScript.sml │ ├── pure_lexer_implScript.sml │ ├── selftest.sml │ ├── sexp │ │ ├── Holmakefile │ │ ├── pure_printLib.sig │ │ ├── pure_printLib.sml │ │ ├── pure_printScript.sml │ │ └── pure_print_testScript.sml │ └── test1.hs ├── proofs │ ├── Holmakefile │ ├── pure_compilerProofScript.sml │ └── pure_end_to_endProofScript.sml └── pure_compilerScript.sml ├── examples ├── .gitignore ├── Makefile ├── README.md ├── benchmark │ ├── bench.config │ ├── benchmark.patch │ └── benchmark.py ├── factorials.hs ├── gameOfLife.hs ├── ghc.patch ├── invertTree.hs ├── lib │ └── basis_ffi.c ├── maxCollatzSequence.hs ├── permutations.hs ├── prelude │ ├── arrays.hs │ ├── bools.hs │ ├── combinators.hs │ ├── either.hs │ ├── integers.hs │ ├── io.hs │ ├── lists.hs │ ├── maybe.hs │ ├── strings.hs │ ├── trees.hs │ └── tuples.hs ├── primes.hs ├── queens.hs ├── quicksort.hs ├── suc_list.hs └── syntax.hs ├── language ├── Holmakefile ├── pure_configScript.sml ├── pure_evalScript.sml ├── pure_expScript.sml ├── pure_limitScript.sml ├── pure_semanticsScript.sml └── pure_valueScript.sml ├── meta-theory ├── Holmakefile ├── exp_eqSimps.sig ├── exp_eqSimps.sml ├── pure_alpha_equivScript.sml ├── pure_barendregtScript.sml ├── pure_beta_equivScript.sml ├── pure_congruenceScript.sml ├── pure_congruence_lemmasScript.sml ├── pure_ctxt_equivScript.sml ├── pure_demandScript.sml ├── pure_eval_lemmasScript.sml ├── pure_eval_surjScript.sml ├── pure_exp_lemmasScript.sml ├── pure_exp_relScript.sml ├── pure_inline_relScript.sml ├── pure_letrec_congScript.sml ├── pure_letrec_delargScript.sml ├── pure_letrec_seqScript.sml ├── pure_letrec_specScript.sml └── pure_obs_sem_equalScript.sml ├── misc ├── fix_files.sml ├── pure_miscScript.sml └── quotient_llistScript.sml ├── typeclass ├── Holmakefile ├── README.md ├── compiler │ └── parsing │ │ ├── .gitignore │ │ ├── Holmakefile │ │ ├── ast_to_texpScript.sml │ │ └── typeclassASTScript.sml └── typing │ ├── Holmakefile │ ├── acyclic_terminationScript.sml │ ├── pure_tcexpScript.sml │ ├── pure_tcexp_lemmasScript.sml │ ├── pure_tcexp_typingProofScript.sml │ ├── pure_tcexp_typingPropsScript.sml │ ├── pure_tcexp_typingScript.sml │ ├── test_typeclass_typing.hs │ ├── test_typeclass_typingScript.sml │ ├── test_typeclass_typing_translated.hs │ ├── typeclass_env_map_implScript.sml │ ├── typeclass_inference_commonScript.sml │ ├── typeclass_kindCheckScript.sml │ ├── typeclass_texpScript.sml │ ├── typeclass_typesPropsScript.sml │ ├── typeclass_typesScript.sml │ ├── typeclass_typingProofScript.sml │ ├── typeclass_typingPropsScript.sml │ ├── typeclass_typingScript.sml │ └── typeclass_unificationScript.sml └── typing ├── Holmakefile ├── pure_inferenceLib.sml ├── pure_inferenceProofScript.sml ├── pure_inferencePropsScript.sml ├── pure_inferenceScript.sml ├── pure_inference_commonScript.sml ├── pure_inference_modelScript.sml ├── pure_inference_testScript.sml ├── pure_tcexpScript.sml ├── pure_tcexp_lemmasScript.sml ├── pure_typingProofScript.sml ├── pure_typingPropsScript.sml ├── pure_typingScript.sml └── pure_unificationScript.sml /.github/CODEOWNERS: -------------------------------------------------------------------------------- 1 | .github/ @hrutvik 2 | -------------------------------------------------------------------------------- /.github/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ubuntu:20.04 2 | 3 | WORKDIR /home 4 | 5 | # Install pre-requisites 6 | RUN apt-get update && \ 7 | DEBIAN_FRONTEND=noninteractive \ 8 | apt-get install -y git build-essential gcc-10 libffi-dev wget mlton sudo \ 9 | locales-all emacs-nox vim tmux nano python3 python3-pip && \ 10 | pip install parse matplotlib pandas 11 | 12 | ENV LANG en_US.UTF-8 13 | 14 | # Install PolyML 15 | RUN git clone https://github.com/polyml/polyml.git && cd polyml && \ 16 | git checkout fixes-5.9 && \ 17 | ./configure --prefix=/usr && \ 18 | make && \ 19 | make install 20 | 21 | # Create user 22 | ARG USERNAME=pure 23 | RUN adduser --shell /bin/bash --disabled-password --gecos "" $USERNAME && \ 24 | echo "$USERNAME ALL=(ALL) NOPASSWD: ALL" > /etc/sudoers.d/$USERNAME && \ 25 | chmod 0440 /etc/sudoers.d/$USERNAME 26 | 27 | # Switch to user 28 | USER $USERNAME 29 | ARG WORKDIR=/home/$USERNAME 30 | WORKDIR $WORKDIR 31 | 32 | # Build HOL 33 | RUN git clone https://github.com/hol-theorem-prover/hol.git && cd hol && \ 34 | poly < tools/smart-configure.sml && \ 35 | ./bin/build 36 | 37 | # Set up HOL interaction 38 | RUN echo '(load "~/hol/tools/hol-mode")' >> .emacs && \ 39 | cp hol/tools/vim/hol-config.sml .hol-config.sml && \ 40 | echo "filetype on" >> .vimrc && mkdir -p .vim && \ 41 | cp hol/tools/vim/filetype.vim .vim/filetype.vim 42 | 43 | # Clone PureCake and CakeML 44 | RUN git clone https://github.com/cakeml/cakeml && \ 45 | git clone https://github.com/cakeml/pure 46 | 47 | # Update environment variables 48 | ENV HOLDIR $WORKDIR/hol/bin 49 | ENV PATH $HOLDIR:$PATH 50 | ENV CAKEMLDIR $WORKDIR/cakeml 51 | ENV PUREDIR $WORKDIR/pure 52 | 53 | # Build PureCake and necessary dependencies 54 | RUN cd pure && Holmake 55 | 56 | # Build PureLang sample programs 57 | RUN cd pure/examples && make check 58 | 59 | # Set up entrypoint 60 | RUN echo "export PS1='\u:\w \$ '" > /home/$USERNAME/.bashrc 61 | WORKDIR $WORKDIR/pure 62 | ENTRYPOINT ["bash"] 63 | 64 | -------------------------------------------------------------------------------- /.github/workflows/binary.yml: -------------------------------------------------------------------------------- 1 | name: Binary 2 | on: 3 | workflow_dispatch: 4 | 5 | jobs: 6 | 7 | build: 8 | runs-on: self-hosted 9 | container: ubuntu:20.04 10 | timeout-minutes: 480 11 | 12 | env: 13 | HOLDIR: ${{ github.workspace }}/HOL 14 | CAKEMLDIR: ${{ github.workspace }}/cakeml 15 | LD_LIBRARY_PATH: /usr/local/lib:$LD_LIBRARY_PATH 16 | 17 | steps: 18 | - name: Update PATH 19 | run: | 20 | echo "$HOLDIR/bin" >> $GITHUB_PATH 21 | - name: Get build-essentials 22 | run: | 23 | apt update 24 | apt install -y git build-essential gcc-10 libffi-dev wget mlton 25 | 26 | - name: Checkout Poly/ML 27 | uses: actions/checkout@v2 28 | with: 29 | repository: polyml/polyml 30 | ref: fixes-5.9 31 | path: polyml 32 | - name: Build Poly/ML 33 | run: | 34 | cd polyml 35 | ./configure 36 | make 37 | make install 38 | 39 | - name: Checkout HOL4 40 | uses: actions/checkout@v2 41 | with: 42 | repository: HOL-Theorem-Prover/HOL 43 | ref: master 44 | path: HOL 45 | - name: Checkout pure 46 | uses: actions/checkout@v2 47 | with: 48 | path: pure 49 | - name: Checkout CakeML 50 | uses: actions/checkout@v2 51 | with: 52 | repository: CakeML/CakeML 53 | path: cakeml 54 | 55 | - name: Build HOL4 56 | run: | 57 | cd $HOLDIR 58 | poly < tools/smart-configure.sml 59 | bin/build 60 | 61 | - name: Build compiler/binary 62 | run: | 63 | cd pure/compiler/binary 64 | Holmake 65 | 66 | - name: Save build artifact 67 | uses: actions/upload-artifact@v3 68 | with: 69 | name: pure.S 70 | path: pure/compiler/binary/pure.S 71 | 72 | -------------------------------------------------------------------------------- /.github/workflows/docker.yml: -------------------------------------------------------------------------------- 1 | name: Publish PureCake Docker image 2 | on: 3 | workflow_dispatch: 4 | 5 | env: 6 | REGISTRY: ghcr.io 7 | IMAGE_NAME: ${{ github.repository }} 8 | 9 | jobs: 10 | push-image: 11 | runs-on: self-hosted 12 | timeout-minutes: 480 13 | permissions: 14 | contents: read 15 | packages: write 16 | 17 | steps: 18 | - name: Log in to the Container registry 19 | uses: docker/login-action@v2 20 | with: 21 | registry: ${{ env.REGISTRY }} 22 | username: ${{ github.actor }} 23 | password: ${{ secrets.GITHUB_TOKEN }} 24 | 25 | - name: Extract metadata (tags, labels) for Docker 26 | id: meta 27 | uses: docker/metadata-action@v4 28 | with: 29 | images: ${{ env.REGISTRY }}/${{ env.IMAGE_NAME }} 30 | 31 | - name: Build and push Docker image 32 | uses: docker/build-push-action@v3 33 | with: 34 | file: .github/Dockerfile 35 | push: true 36 | no-cache: true 37 | tags: ${{ steps.meta.outputs.tags }} 38 | labels: ${{ steps.meta.outputs.labels }} 39 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # HOL stuff 2 | *Script 3 | *Theory.sig 4 | *Theory.sml 5 | *Theory.dat 6 | *.uo 7 | *.ui 8 | *.o 9 | .HOLMK 10 | .hollogs 11 | 12 | # Sample 13 | sample-code/cake 14 | sample-code/pure 15 | sample-code/pure.tar.gz 16 | sample-code/factorials 17 | sample-code/arrays 18 | sample-code/strings 19 | sample-code/lists 20 | sample-code/data 21 | sample-code/long_compile_time 22 | 23 | # TacticToe 24 | *Script_ttt.sml 25 | 26 | # Generated assembly 27 | *.S 28 | 29 | # Generated tarball 30 | cake-x64-64.tar.gz 31 | 32 | # Developer generated executables 33 | developers/readme_gen 34 | semantics/addancs 35 | tutorial/solutions/make_ex 36 | 37 | # regression test logs 38 | regression.log 39 | timing.log 40 | 41 | # HOLHEAP 42 | *heap 43 | 44 | # Translator stuff 45 | *_ml.txt 46 | *_hol.txt 47 | *_thm.txt 48 | *_ast.txt 49 | *.ml.txt 50 | *translate_timing.txt 51 | 52 | # Emacs backup files 53 | *~ 54 | 55 | # Vim swap files 56 | *.swp 57 | 58 | # Vscode 59 | .vscode/* 60 | 61 | # Reference manual 62 | documentation/*.pdf 63 | documentation/*.aux 64 | documentation/*.fdb_latexmk 65 | documentation/*.fls 66 | documentation/*.log 67 | documentation/*.out 68 | documentation/*.pyg 69 | documentation/*.toc 70 | documentation/_minted-reference 71 | documentation/lem-generated 72 | 73 | # Compiler Explorer 74 | *.exe 75 | *.cgi 76 | 77 | # Benchmarks 78 | compiler/benchmarks/ocaml/*.cmi 79 | compiler/benchmarks/ocaml/*.cmo 80 | compiler/benchmarks/ocaml/*.cmx 81 | compiler/benchmarks/ocaml/ocamlc_* 82 | compiler/benchmarks/ocaml/ocamlopt_* 83 | compiler/benchmarks/cakeml/basis_ffi.c 84 | compiler/benchmarks/cakeml/cakemlc 85 | compiler/benchmarks/cakeml/cake_O4_* 86 | compiler/benchmarks/sml/mlton_* 87 | compiler/benchmarks/sml/polyc_* 88 | compiler/benchmarks/sml/sml_* 89 | compiler/benchmarks/*.dat 90 | compiler/benchmarks/*.eps 91 | -------------------------------------------------------------------------------- /.holpath: -------------------------------------------------------------------------------- 1 | PUREDIR 2 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | PureCake Copyright Notice, License, and Disclaimer. 2 | 3 | Copyright 2020-2025 by Oskar Abrahamsson, Johannes Åman Pohjola, 4 | Hrutvik Kanabar, Magnus Myreen, Michael Norrish, Samuel Vivien, 5 | Riccardo Zanetti and other contributors listed at https://cakeml.org. 6 | 7 | All rights reserved. 8 | 9 | PureCake is free software. Redistribution and use in source and binary forms, 10 | with or without modification, are permitted provided that the following 11 | conditions are met: 12 | 13 | * Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | * Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in the 18 | documentation and/or other materials provided with the distribution. 19 | 20 | * The names of the copyright holders and contributors may not be 21 | used to endorse or promote products derived from this software without 22 | specific prior written permission. 23 | 24 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' 25 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 26 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE 28 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 29 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 30 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 31 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 32 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 33 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 34 | -------------------------------------------------------------------------------- /Holmakefile: -------------------------------------------------------------------------------- 1 | CLINE_OPTIONS = -r 2 | 3 | INCLUDES = misc\ 4 | language\ 5 | meta-theory\ 6 | compiler/backend/languages\ 7 | compiler/backend/languages/semantics\ 8 | compiler/backend/languages/properties\ 9 | compiler/backend/languages/relations\ 10 | typing\ 11 | typeclass/compiler/parsing\ 12 | typeclass/typing\ 13 | compiler/backend/passes\ 14 | compiler/backend/passes/proofs\ 15 | compiler/parsing\ 16 | compiler\ 17 | compiler/proofs\ 18 | compiler/binary 19 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # PureCake 2 | ## A verified compiler for a lazy functional language 3 | 4 | PureCake is a verified implementation of a small, Haskell-like language known as PureLang. 5 | It targets [CakeML](https://github.com/cakeml/cakeml), a verified implementation of a significant subset of Standard ML. 6 | PureCake is developed within the [HOL4 interactive theorem prover](http://hol-theorem-prover.org). 7 | 8 | 9 | ### Quick start 10 | 11 | ```bash 12 | docker run -it ghcr.io/cakeml/pure:master 13 | ``` 14 | This [Docker](https://www.docker.com/) image contains a pre-built version of the PureCake compiler. 15 | 16 | 17 | ### Quick start without Docker 18 | 19 | ```bash 20 | git clone https://github.com/cakeml/pure 21 | cd pure/examples && make download 22 | ``` 23 | This downloads the latest pre-built version of the PureCake compiler from GitHub. 24 | You can now compile PureLang programs without building the compiler yourself, as described in [`examples/README.md`](examples/README.md). 25 | 26 | 27 | ### Slow start 28 | 29 | Follow the build process described by our [`Dockerfile`](/.github/Dockerfile). 30 | In summary: install PolyML; build HOL4; clone the PureCake and CakeML repositories; run `Holmake` in the top-level of the PureCake repository. 31 | Building the entire PureCake project (including the bootstrapped compiler) will take several hours and require considerable compute resources. 32 | 33 | 34 | ### Repository structure 35 | 36 | [COPYING](COPYING): 37 | PureCake Copyright Notice, License, and Disclaimer. 38 | 39 | [compiler](compiler): 40 | A verified compiler from PureLang to CakeML, with the components below. 41 | - [backend](compiler/backend): 42 | the compiler backend, with the following subdirectories. 43 | - [languages](compiler/backend/languages): 44 | intermediate languages, their semantics, and derived properties. 45 | - [passes](compiler/backend/passes): 46 | compilation passes and their proofs of correctness. 47 | - [binary](compiler/binary): 48 | verified (in-logic) bootstrapping of a compiler binary. 49 | - [parsing](compiler/parsing): 50 | lexing and parsing expression grammar (PEG) parsing. 51 | - [proofs](compiler/proofs) 52 | overall proofs of correctness. 53 | - [pure_compilerScript.sml](compiler/pure_compilerScript.sml): 54 | the compiler's top-level definition. 55 | 56 | [examples](examples): 57 | Examples of PureLang code, how to invoke the PureCake compiler on them, and how to measure their performance. 58 | 59 | [language](language): 60 | Definitions concerning PureLang and its semantics, including built-in operations. 61 | 62 | [meta-theory](meta-theory): 63 | PureLang's meta-theory. 64 | In particular, PureLang's equational theory and associated proofs (*e.g.* soundness of alpha- and beta-equivalence, and coincidence with contextual equivalence), and a formalisation of strictness (*demands*). 65 | 66 | [misc](misc): 67 | Miscellaneous lemmas. 68 | 69 | [typing](typing): 70 | PureCake's type system: proof of type soundness and a verified type inferencer. 71 | -------------------------------------------------------------------------------- /compiler/Holmakefile: -------------------------------------------------------------------------------- 1 | INCLUDES = ../typing \ 2 | parsing \ 3 | parsing/sexp \ 4 | backend/languages \ 5 | backend/passes \ 6 | $(CAKEMLDIR)/compiler/parsing \ 7 | $(HOLDIR)/examples/bootstrap 8 | -------------------------------------------------------------------------------- /compiler/backend/Holmakefile: -------------------------------------------------------------------------------- 1 | INCLUDES = $(PUREDIR)/language $(CAKEMLDIR)/basis/pure 2 | -------------------------------------------------------------------------------- /compiler/backend/languages/Holmakefile: -------------------------------------------------------------------------------- 1 | INCLUDES = $(PUREDIR)/misc $(PUREDIR)/language \ 2 | $(CAKEMLDIR)/basis/pure 3 | -------------------------------------------------------------------------------- /compiler/backend/languages/env_cexpScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Compiler expressions for stateLang 3 | *) 4 | open HolKernel Parse boolLib bossLib BasicProvers dep_rewrite; 5 | open stringTheory optionTheory sumTheory pairTheory listTheory alistTheory 6 | pure_expTheory pure_semanticsTheory arithmeticTheory mlstringTheory 7 | pred_setTheory; 8 | 9 | val _ = new_theory "env_cexp"; 10 | 11 | val _ = set_grammar_ancestry ["pure_exp","mlstring"]; 12 | 13 | val _ = numLib.prefer_num(); 14 | 15 | Type vname = “:mlstring” 16 | 17 | Datatype: 18 | cop = Cons mlstring 19 | | AtomOp atom_op 20 | End 21 | 22 | Datatype: 23 | cexp = Var vname 24 | | Prim cop (cexp list) 25 | | App cexp cexp 26 | | Lam vname cexp 27 | | Letrec ((vname # cexp) list) cexp 28 | | Let (vname option) cexp cexp 29 | | If cexp cexp cexp 30 | | Delay cexp 31 | | Box cexp 32 | | Force cexp 33 | | Case vname ((vname # (vname list) # cexp) list) 34 | (((vname # num) list # cexp) option) 35 | (* monads *) 36 | | Ret cexp 37 | | Raise cexp 38 | | Bind cexp cexp 39 | | Handle cexp cexp 40 | | Act cexp 41 | | Length cexp 42 | | Alloc cexp cexp 43 | | Deref cexp cexp 44 | | Update cexp cexp cexp 45 | End 46 | 47 | Definition cns_arities_def: 48 | cns_arities (Var v :cexp) = {} ∧ 49 | cns_arities (Prim op es) = ( 50 | (case op of 51 | | Cons cn => {{explode cn, LENGTH es}} 52 | | _ => {}) ∪ 53 | BIGUNION (set (MAP cns_arities es))) ∧ 54 | cns_arities (App e1 e2) = cns_arities e1 ∪ cns_arities e2 ∧ 55 | cns_arities (Lam x e) = cns_arities e ∧ 56 | cns_arities (Letrec funs e) = 57 | BIGUNION (set (MAP (λ(v,e). cns_arities e) funs)) ∪ cns_arities e ∧ 58 | cns_arities (Let x e1 e2) = cns_arities e1 ∪ cns_arities e2 ∧ 59 | cns_arities (If e e1 e2) = cns_arities e ∪ cns_arities e1 ∪ cns_arities e2 ∧ 60 | cns_arities (Case v css d) = ( 61 | let css_cn_ars = set (MAP (λ(cn,vs,e). explode cn, LENGTH vs) css) in 62 | (case d of 63 | | NONE => {css_cn_ars} 64 | | SOME (a,e) => 65 | (set (MAP (λ(cn,ar). explode cn, ar) a) ∪ css_cn_ars) INSERT cns_arities e) ∪ 66 | BIGUNION (set (MAP (λ(cn,vs,e). cns_arities e) css))) ∧ 67 | cns_arities (Box e) = cns_arities e ∧ 68 | cns_arities (Delay e) = cns_arities e ∧ 69 | cns_arities (Force e) = cns_arities e ∧ 70 | cns_arities (Ret e) = cns_arities e ∧ 71 | cns_arities (Raise e) = cns_arities e ∧ 72 | cns_arities (Act e) = cns_arities e ∧ 73 | cns_arities (Length e) = cns_arities e ∧ 74 | cns_arities (Bind e1 e2) = cns_arities e1 ∪ cns_arities e2 ∧ 75 | cns_arities (Handle e1 e2) = cns_arities e1 ∪ cns_arities e2 ∧ 76 | cns_arities (Deref e1 e2) = cns_arities e1 ∪ cns_arities e2 ∧ 77 | cns_arities (Alloc e1 e2) = cns_arities e1 ∪ cns_arities e2 ∧ 78 | cns_arities (Update e1 e2 e3) = cns_arities e1 ∪ cns_arities e2 ∪ cns_arities e3 79 | Termination 80 | WF_REL_TAC `measure cexp_size` 81 | End 82 | 83 | Definition Lams_def: 84 | Lams [] x = x ∧ 85 | Lams (y::ys) x = Lam y (Lams ys x) 86 | End 87 | 88 | Definition Apps_def: 89 | Apps x [] = x ∧ 90 | Apps x (y::ys) = Apps (App x y) ys 91 | End 92 | 93 | Definition dest_Delay_def: 94 | dest_Delay (Delay x) = SOME x ∧ 95 | dest_Delay _ = NONE 96 | End 97 | 98 | Definition dest_Lam_def: 99 | dest_Lam (Lam v x) = SOME (v,x) ∧ 100 | dest_Lam _ = NONE 101 | End 102 | 103 | val _ = export_theory(); 104 | -------------------------------------------------------------------------------- /compiler/backend/languages/properties/Holmakefile: -------------------------------------------------------------------------------- 1 | INCLUDES = ../semantics $(PUREDIR)/language $(PUREDIR)/misc $(PUREDIR)/meta-theory 2 | -------------------------------------------------------------------------------- /compiler/backend/languages/properties/env_cexp_lemmasScript.sml: -------------------------------------------------------------------------------- 1 | open HolKernel Parse boolLib bossLib BasicProvers dep_rewrite; 2 | open arithmeticTheory listTheory stringTheory alistTheory 3 | optionTheory pairTheory pred_setTheory finite_mapTheory 4 | envLangTheory; 5 | open pure_miscTheory env_cexpTheory ; 6 | 7 | val _ = new_theory "env_cexp_lemmas"; 8 | 9 | val freevars_def = envLangTheory.freevars_def; 10 | val Lams_def = envLangTheory.Lams_def; 11 | val Apps_def = envLangTheory.Apps_def; 12 | 13 | Theorem freevars_Lams[simp]: 14 | ∀vs e. freevars (Lams vs e) = freevars e DIFF set vs 15 | Proof 16 | Induct >> rw[Lams_def, freevars_def] >> gvs[EXTENSION] >> rw[] >> metis_tac[] 17 | QED 18 | 19 | Theorem Lams_SNOC: 20 | (∀e. Lams [] e = e) ∧ 21 | (∀vs v. Lams (SNOC v vs) e = Lams vs (Lam v e)) 22 | Proof 23 | conj_tac >- rw[Lams_def] >> 24 | Induct >> rw[Lams_def] 25 | QED 26 | 27 | Theorem freevars_Apps[simp]: 28 | ∀es e. freevars (Apps e es) = freevars e ∪ BIGUNION (set (MAP freevars es)) 29 | Proof 30 | Induct >> rw[Apps_def, freevars_def] >> simp[UNION_ASSOC] 31 | QED 32 | 33 | Theorem Apps_SNOC: 34 | (∀x. Apps x [] = x) ∧ 35 | (∀ys x y. Apps x (SNOC y ys) = App (Apps x ys) y) 36 | Proof 37 | conj_tac >- rw[Apps_def] >> 38 | Induct >> rw[Apps_def] 39 | QED 40 | 41 | Theorem freevars_lets_for: 42 | ∀n c v l b. freevars (lets_for n c v l b) = 43 | case l of 44 | [] => freevars b 45 | | _ => v INSERT (freevars b DIFF set (MAP SND l)) 46 | Proof 47 | recInduct lets_for_ind >> rw[lets_for_def, freevars_def] >> 48 | rpt (CASE_TAC >> gvs[lets_for_def]) >> simp[EXTENSION] >> 49 | metis_tac[] 50 | QED 51 | 52 | Triviality MAPi_ID[simp]: 53 | ∀l. MAPi (λn v. v) l = l 54 | Proof 55 | Induct >> rw[combinTheory.o_DEF] 56 | QED 57 | 58 | Theorem freevars_Disj: 59 | freevars (Disj v cns) = if cns = [] then {} else {v} 60 | Proof 61 | Induct_on `cns` >> rw[Disj_def, freevars_def] >> 62 | PairCases_on `h` >> rw[Disj_def, freevars_def] 63 | QED 64 | 65 | Theorem freevars_rows_of: 66 | ∀v l eopt. freevars (rows_of v l eopt) = 67 | case l of 68 | | [] => ( 69 | case eopt of 70 | | NONE => {} 71 | | SOME ([],e) => freevars e 72 | | SOME (_, e) => v INSERT freevars e) 73 | | _ => v INSERT (case eopt of NONE => {} | SOME (_,e) => freevars e) ∪ 74 | BIGUNION (set (MAP (λ(cn,vs,b). freevars b DIFF set vs) l)) 75 | Proof 76 | recInduct rows_of_ind >> rw[rows_of_def, freevars_def] 77 | >- ( 78 | rpt CASE_TAC >> gvs[freevars_def, freevars_Disj] >> simp[GSYM INSERT_SING_UNION] 79 | ) >> 80 | Cases_on `rest` >> gvs[combinTheory.o_DEF, rows_of_def, freevars_def] >> 81 | simp[freevars_lets_for] >> 82 | rpt CASE_TAC >> gvs[EXTENSION, combinTheory.o_DEF, rows_of_def, freevars_def] >> 83 | Cases_on `vs` >> gvs[] >> metis_tac[] 84 | QED 85 | 86 | (* TODO There's nothing called freevars_cexp for envLang? *) 87 | 88 | (* 89 | Theorem freevars_exp_of: 90 | ∀ce. freevars (exp_of ce) = freevars_cexp ce 91 | Proof 92 | recInduct freevars_cexp_ind >> rw[exp_of_def] >> 93 | gvs[MAP_MAP_o, combinTheory.o_DEF, freevars_def] 94 | >- (ntac 2 AP_TERM_TAC >> rw[MAP_EQ_f]) 95 | >- (ntac 3 AP_TERM_TAC >> rw[MAP_EQ_f]) 96 | >- ( 97 | simp[LAMBDA_PROD, GSYM FST_THM] >> 98 | AP_THM_TAC >> ntac 4 AP_TERM_TAC >> rw[MAP_EQ_f] >> 99 | pairarg_tac >> gvs[] >> res_tac 100 | ) 101 | >- simp[DELETE_DEF] 102 | >- ( 103 | AP_TERM_TAC >> simp[freevars_rows_of] >> Cases_on `css` >> gvs[] >> 104 | PairCases_on `h` >> gvs[] >> rw[EXTENSION, PULL_EXISTS] >> 105 | simp[MEM_MAP, PULL_EXISTS, EXISTS_PROD] >> metis_tac[] 106 | ) 107 | QED 108 | *) 109 | 110 | val _ = export_theory(); 111 | -------------------------------------------------------------------------------- /compiler/backend/languages/relations/Holmakefile: -------------------------------------------------------------------------------- 1 | INCLUDES = ../semantics \ 2 | ../../passes \ 3 | ../../passes/proofs \ 4 | $(PUREDIR)/language \ 5 | $(PUREDIR)/misc \ 6 | $(PUREDIR)/meta-theory \ 7 | $(PUREDIR)/typing 8 | -------------------------------------------------------------------------------- /compiler/backend/languages/relations/pure_pres_lemmasScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Proves lemmas that follow from the definitions in pure_presTheory 3 | *) 4 | open HolKernel Parse boolLib bossLib term_tactic; 5 | open fixedPointTheory arithmeticTheory listTheory stringTheory alistTheory 6 | optionTheory pairTheory ltreeTheory llistTheory bagTheory dep_rewrite 7 | BasicProvers pred_setTheory relationTheory rich_listTheory finite_mapTheory 8 | combinTheory; 9 | open pure_expTheory pure_valueTheory pure_evalTheory pure_eval_lemmasTheory 10 | pure_exp_lemmasTheory pure_limitTheory pure_exp_relTheory 11 | pure_alpha_equivTheory pure_miscTheory pure_congruenceTheory 12 | pure_demandTheory pure_letrec_delargTheory 13 | pure_cexpTheory pure_cexp_lemmasTheory pureLangTheory pure_presTheory; 14 | 15 | val _ = new_theory "pure_pres_lemmas"; 16 | 17 | Theorem bidir_letrec_eta: 18 | MEM (f,Lam a vs x) l ∧ ALL_DISTINCT (MAP FST l) ∧ vs ≠ [] ∧ 19 | EVERY (λ(v,e). 20 | DISJOINT (IMAGE explode (set vs)) (freevars (exp_of e)) ∧ 21 | ~MEM v vs) l ∧ 22 | DISJOINT (set (MAP FST l)) (set vs) 23 | ⇒ 24 | (Letrec a l (Var a f)) 25 | <--> 26 | (Letrec a l (Lam a vs (App a (Var a f) (MAP (Var a) vs)))) 27 | Proof 28 | rw [] 29 | \\ irule_at Any bidir_trans 30 | \\ irule_at (Pos hd) bidir_Letrec_unroll 31 | \\ first_assum $ irule_at $ Pos hd \\ fs [] 32 | \\ irule_at Any bidir_trans 33 | \\ qexists_tac ‘Letrec a l (Lam a vs (App a (Lam a vs x) (MAP (Var a) vs)))’ 34 | \\ conj_tac 35 | >- 36 | (irule bidir_Letrec \\ fs [LIST_REL_same] 37 | \\ simp [Once bidir_sym] 38 | \\ irule bidir_App_Lam \\ fs []) 39 | \\ irule_at Any bidir_trans 40 | \\ irule_at (Pos hd) bidir_Letrec_Lam \\ fs [] 41 | \\ simp [Once bidir_sym] 42 | \\ irule_at Any bidir_trans 43 | \\ irule_at (Pos hd) bidir_Letrec_Lam \\ fs [] 44 | \\ irule_at Any bidir_Lam 45 | \\ irule_at Any bidir_trans 46 | \\ irule_at (Pos hd) bidir_Letrec_App_forget \\ fs [] 47 | \\ simp [Once bidir_sym] 48 | \\ irule_at Any bidir_trans 49 | \\ irule_at (Pos hd) bidir_Letrec_App_forget \\ fs [] 50 | \\ irule_at (Pos hd) bidir_App \\ fs [LIST_REL_same] 51 | \\ simp [Once bidir_sym] 52 | \\ irule_at (Pos hd) bidir_Letrec_unroll \\ fs [] 53 | \\ gvs [EVERY_MEM,FORALL_PROD,MEM_MAP,PULL_EXISTS] 54 | \\ res_tac \\ rw [] \\ gvs [exp_of_def] 55 | \\ gvs [IN_DISJOINT] \\ metis_tac [] 56 | QED 57 | 58 | Theorem bidir_letrec_eta_1: 59 | ¬MEM f vs ∧ vs ≠ [] 60 | ⇒ 61 | (Letrec a [(f,Lam a vs x)] (Var a f)) 62 | <--> 63 | (Letrec a [(f,Lam a vs x)] (Lam a vs (App a (Var a f) (MAP (Var a) vs)))) 64 | Proof 65 | rw [] \\ irule bidir_letrec_eta \\ fs [] 66 | \\ gvs [IN_DISJOINT,exp_of_def,MEM_MAP] 67 | \\ metis_tac [] 68 | QED 69 | 70 | Theorem bidir_letrec_expand_1: 71 | ¬MEM f vs ∧ vs ≠ [] 72 | ⇒ 73 | (Letrec a [(f,Lam a vs x)] x) 74 | <--> 75 | (Let a f (Lam a vs 76 | (Letrec a [(f,Lam a vs x)] 77 | (App a (Var a f) (MAP (Var a) vs)))) 78 | x) 79 | Proof 80 | rw [] 81 | \\ irule bidir_trans 82 | \\ irule_at Any bidir_Letrec_eq_Let_Letrec 83 | \\ irule_at Any bidir_Let \\ fs [] 84 | \\ simp [Once bidir_sym] 85 | \\ irule_at Any bidir_trans 86 | \\ simp [Once bidir_sym] 87 | \\ irule_at (Pos hd) bidir_Letrec_Lam \\ gvs [] 88 | \\ simp [Once bidir_sym] 89 | \\ irule_at Any bidir_letrec_eta_1 90 | \\ fs [exp_of_def,IN_DISJOINT,MEM_MAP] 91 | \\ metis_tac [] 92 | QED 93 | 94 | Theorem bidir_contract_1: 95 | ~MEM f ps ∧ ~MEM f ws ∧ vs ≠ [] ∧ ws ≠ [] ∧ set ws ⊆ set vs 96 | ⇒ 97 | (Lam a (vs ++ ps) 98 | (Letrec a [(f,Lam a (ws ++ ps) x)] 99 | (App a (Var a f) (MAP (Var a) (ws ++ ps))))) 100 | <--> 101 | (Lam a vs 102 | (Letrec a [(f,Lam a (ws ++ ps) x)] 103 | (App a (Var a f) (MAP (Var a) ws)))) 104 | Proof 105 | Cases_on ‘ps = []’ >- fs [] 106 | \\ rw [] 107 | \\ qabbrev_tac ‘z = Letrec a [(f,Lam a (ws ++ ps) x)] x’ 108 | \\ ‘Letrec a [(f,Lam a (ws ++ ps) x)] (Var a f) <--> Lam a (ws ++ ps) z’ by 109 | (irule bidir_trans 110 | \\ irule_at (Pos hd) bidir_Letrec_unroll \\ fs [] 111 | \\ unabbrev_all_tac 112 | \\ irule_at (Pos hd) bidir_Letrec_Lam \\ gvs [] 113 | \\ gvs [exp_of_def,IN_DISJOINT,MEM_MAP] 114 | \\ metis_tac []) 115 | \\ qsuff_tac ‘ 116 | Lam a (vs ++ ps) 117 | (App a (Lam a (ws ++ ps) z) (MAP (Var a) ws ++ MAP (Var a) ps)) <--> 118 | Lam a vs 119 | (App a (Lam a (ws ++ ps) z) (MAP (Var a) ws))’ 120 | >- 121 | (strip_tac 122 | \\ irule_at (Pos hd) bidir_trans 123 | \\ irule_at (Pos last) bidir_trans 124 | \\ pop_assum $ irule_at $ Pos hd 125 | \\ irule_at Any bidir_Lam 126 | \\ irule_at Any bidir_Lam 127 | \\ unabbrev_all_tac 128 | \\ irule_at (Pos hd) bidir_trans 129 | \\ irule_at Any bidir_Letrec_App_forget 130 | \\ gvs [EVERY_MAP,exp_of_def] \\ gvs [EVERY_MEM] 131 | \\ irule_at (Pos hd) bidir_App 132 | \\ gvs [LIST_REL_same] 133 | \\ simp [Once bidir_sym] 134 | \\ irule_at (Pos hd) bidir_trans 135 | \\ irule_at Any bidir_Letrec_App_forget 136 | \\ gvs [EVERY_MAP,exp_of_def] \\ gvs [EVERY_MEM] 137 | \\ irule_at (Pos hd) bidir_App 138 | \\ gvs [LIST_REL_same]) 139 | \\ irule_at Any bidir_trans 140 | \\ qexists_tac ‘Lam a (vs ++ ps) z’ 141 | \\ conj_tac >- 142 | (rewrite_tac [GSYM MAP_APPEND] 143 | \\ irule bidir_App_Lam \\ fs [] 144 | \\ gvs [SUBSET_DEF]) 145 | \\ qsuff_tac ‘ 146 | Lam a vs (Lam a ps z) <--> 147 | Lam a vs (App a (Lam a ws (Lam a ps z)) (MAP (Var a) ws))’ 148 | >- 149 | (strip_tac 150 | \\ irule bidir_trans 151 | \\ irule_at (Pos hd) bidir_Lam_append \\ fs [] 152 | \\ irule bidir_trans 153 | \\ pop_assum $ irule_at $ Pos hd 154 | \\ irule bidir_Lam 155 | \\ irule bidir_App 156 | \\ gvs [LIST_REL_same] 157 | \\ simp [Once bidir_sym] 158 | \\ irule_at (Pos hd) bidir_Lam_append \\ fs []) 159 | \\ simp [Once bidir_sym] 160 | \\ irule bidir_App_Lam \\ fs [] 161 | QED 162 | 163 | val _ = export_theory (); 164 | -------------------------------------------------------------------------------- /compiler/backend/languages/semantics/Holmakefile: -------------------------------------------------------------------------------- 1 | INCLUDES = ../ $(PUREDIR)/language $(PUREDIR)/misc \ 2 | $(CAKEMLDIR)/basis/pure 3 | -------------------------------------------------------------------------------- /compiler/backend/languages/semantics/thunk_exp_ofScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Definition of cexp -> exp function for thunkLang 3 | *) 4 | 5 | open HolKernel Parse boolLib bossLib term_tactic monadsyntax dep_rewrite; 6 | open stringTheory optionTheory sumTheory pairTheory listTheory alistTheory 7 | finite_mapTheory pred_setTheory rich_listTheory combinTheory 8 | thunkLangTheory thunk_cexpTheory; 9 | 10 | val _ = new_theory "thunk_exp_of"; 11 | 12 | val _ = set_grammar_ancestry ["thunkLang", "thunk_cexp"]; 13 | 14 | Definition lets_for_def: 15 | lets_for l cn v [] b = (b:thunkLang$exp) ∧ 16 | lets_for l cn v ((n,w)::ws) b = 17 | Seq (If (IsEq cn l T (Var v)) Unit Fail) $ 18 | Let (SOME w) (Proj cn n (Var v)) $ 19 | lets_for l cn v ws b 20 | End 21 | 22 | Overload True[local] = “Prim (Cons "True") []”; 23 | Overload False[local] = “Prim (Cons "False") []”; 24 | 25 | Definition Disj_def: 26 | Disj v [] = False ∧ 27 | Disj v ((cn,l)::xs) = If (IsEq cn l T (Var v)) True (Disj v xs) 28 | End 29 | 30 | Definition rows_of_def: 31 | rows_of v [] k = 32 | (case k of 33 | | NONE => Prim (AtomOp Add) [] 34 | | SOME (alts,e) => If (Disj v alts) e Fail) ∧ 35 | rows_of v ((cn,vs,b)::rest) k = 36 | If (IsEq cn (LENGTH vs) T (Var v)) 37 | (lets_for (LENGTH vs) cn v (MAPi (λi v. (i,v)) vs) b) (rows_of v rest k) 38 | End 39 | 40 | Definition op_of_def[simp]: 41 | op_of (Cons m) = Cons (explode m) ∧ 42 | op_of (AtomOp a) = AtomOp a 43 | End 44 | 45 | Definition exp_of_def[simp]: 46 | exp_of (Var n) = Var (explode n):thunkLang$exp ∧ 47 | exp_of (Prim p xs) = Prim (op_of p) (MAP exp_of xs) ∧ 48 | exp_of (Monad mop xs) = Monad mop (MAP exp_of xs) ∧ 49 | exp_of (Let w x y) = Let (OPTION_MAP explode w) (exp_of x) (exp_of y) ∧ 50 | exp_of (App f xs) = Apps (exp_of f) (MAP exp_of xs) ∧ 51 | exp_of (Lam vs x) = Lams (MAP explode vs) (exp_of x) ∧ 52 | exp_of (Letrec rs x) = Letrec (MAP (λ(n,x). (explode n,exp_of x)) rs) (exp_of x) ∧ 53 | exp_of (Case v rs d) = 54 | rows_of 55 | (explode v) 56 | (MAP (λ(c,vs,x). (explode c,MAP explode vs,exp_of x)) rs) 57 | (OPTION_MAP (λ(a,e). (MAP (explode ## I) a, exp_of e)) d) ∧ 58 | exp_of (Force x) = Force (exp_of x) ∧ 59 | exp_of (Delay x) = Delay (exp_of x) 60 | Termination 61 | WF_REL_TAC ‘measure cexp_size’ >> rw [cexp_size_eq] 62 | End 63 | 64 | Definition args_ok_def: 65 | args_ok (thunk_cexp$AtomOp aop) es = 66 | (num_atomop_args_ok aop (LENGTH es) ∧ 67 | (∀m. aop = Message m ⇒ m ≠ "") ∧ 68 | ∀s1 s2. aop ≠ Lit (Msg s1 s2) ∧ ∀l. aop ≠ Lit (Loc l)) ∧ 69 | args_ok _ _ = T 70 | End 71 | 72 | Definition cexp_ok_bind_def: 73 | (cexp_ok_bind (Delay _ : cexp) = T) ∧ 74 | (cexp_ok_bind (Lam _ _) = T) ∧ 75 | (cexp_ok_bind _ = F) 76 | End 77 | 78 | Definition cexp_wf_def: 79 | cexp_wf (Var v) = T ∧ 80 | cexp_wf (Prim op es) = (args_ok op es ∧ EVERY cexp_wf es) ∧ 81 | cexp_wf (Monad mop es) = (num_mop_args mop = LENGTH es ∧ EVERY cexp_wf es) ∧ 82 | cexp_wf (App e es) = (cexp_wf e ∧ EVERY cexp_wf es ∧ es ≠ []) ∧ 83 | cexp_wf (Force e) = cexp_wf e ∧ 84 | cexp_wf (Delay e) = cexp_wf e ∧ 85 | cexp_wf (Lam vs e) = (cexp_wf e ∧ vs ≠ []) ∧ 86 | cexp_wf (Let v e1 e2) = (cexp_wf e1 ∧ cexp_wf e2) ∧ 87 | cexp_wf (Letrec fns e) = (EVERY (λ(_,x). cexp_ok_bind x ∧ cexp_wf x) fns ∧ cexp_wf e 88 | ∧ fns ≠ [] ∧ ALL_DISTINCT (MAP FST fns)) ∧ 89 | cexp_wf (Case v css eopt) = ( 90 | EVERY (λ(_,vs,x). ALL_DISTINCT vs ∧ cexp_wf x) css ∧ 91 | css ≠ [] ∧ 92 | ¬ MEM v (FLAT $ MAP (FST o SND) css) ∧ 93 | ALL_DISTINCT (MAP FST css ++ case eopt of NONE => [] | SOME (a,_) => MAP FST a) ∧ 94 | OPTION_ALL (λ(a,e). a ≠ [] ∧ cexp_wf e ∧ EVERY (λ(cn,_). explode cn ∉ monad_cns) a) eopt ∧ 95 | (∀cn. MEM cn (MAP FST css) ⇒ explode cn ∉ monad_cns)) 96 | Termination 97 | WF_REL_TAC ‘measure cexp_size’ 98 | End 99 | 100 | Definition is_Delay_def: 101 | (is_Delay (Delay _ : cexp) = T) ∧ 102 | (is_Delay _ = F) 103 | End 104 | 105 | Theorem lets_for_APPEND: 106 | lets_for l m n (l1 ++ l2) e = lets_for l m n l1 (lets_for l m n l2 e) 107 | Proof 108 | Induct_on ‘l1’ \\ gvs [lets_for_def, FORALL_PROD] 109 | QED 110 | 111 | val _ = export_theory (); 112 | -------------------------------------------------------------------------------- /compiler/backend/languages/thunk_cexpScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | This file defines expressions for thunkLang as the compiler sees them. 3 | *) 4 | open HolKernel Parse boolLib bossLib; 5 | open arithmeticTheory listTheory mlstringTheory pure_configTheory 6 | pred_setTheory; 7 | 8 | val _ = new_theory "thunk_cexp"; 9 | 10 | Type name[local] = “:mlstring” 11 | 12 | Datatype: 13 | cop = Cons name (* datatype constructor *) 14 | | AtomOp atom_op (* primitive operations over Atoms *) 15 | End 16 | 17 | Datatype: 18 | cexp = Var name (* variable *) 19 | | Prim cop (cexp list) (* primitive operations *) 20 | | Monad mop (cexp list) (* monadic operations *) 21 | | App cexp (cexp list) (* function application *) 22 | | Lam (name list) cexp (* lambda *) 23 | | Let (name option) cexp cexp (* let *) 24 | | Letrec ((name # cexp) list) cexp (* mutually recursive exps *) 25 | | Case name ((name # (name list) # cexp) list) (* pattern match *) 26 | (((name # num) list # cexp) option) (* optional fallthrough *) 27 | | Delay cexp (* delay a computation as a thunk *) 28 | | Force cexp (* force a thunk *) 29 | End 30 | 31 | val cexp_size_def = fetch "-" "cexp_size_def"; 32 | 33 | Theorem cexp_size_lemma: 34 | (∀xs a. MEM a xs ⇒ cexp_size a < cexp8_size xs) ∧ 35 | (∀xs p e. MEM (p,e) xs ⇒ cexp_size e < cexp6_size xs) ∧ 36 | (∀xs a1 a2 a. MEM (a1,a2,a) xs ⇒ cexp_size a < cexp2_size xs) 37 | Proof 38 | rpt conj_tac 39 | \\ Induct \\ rw [] \\ fs [fetch "-" "cexp_size_def"] \\ res_tac \\ fs [] 40 | QED 41 | 42 | Definition cns_arities_def: 43 | cns_arities (Var v :cexp) = {} ∧ 44 | cns_arities (Prim op es) = ( 45 | (case op of 46 | | Cons cn => {{explode cn, LENGTH es}} 47 | | _ => {}) ∪ 48 | BIGUNION (set (MAP cns_arities es))) ∧ 49 | cns_arities (Monad mop es) = (BIGUNION (set (MAP cns_arities es))) ∧ 50 | cns_arities (App e1 es) = cns_arities e1 ∪ BIGUNION (set (MAP cns_arities es)) ∧ 51 | cns_arities (Lam vs e) = cns_arities e ∧ 52 | cns_arities (Letrec funs e) = 53 | BIGUNION (set (MAP (λ(v,e). cns_arities e) funs)) ∪ cns_arities e ∧ 54 | cns_arities (Let x e1 e2) = cns_arities e1 ∪ cns_arities e2 ∧ 55 | cns_arities (Case v css d) = ( 56 | let css_cn_ars = set (MAP (λ(cn,vs,e). explode cn, LENGTH vs) css) in 57 | (case d of 58 | | NONE => {css_cn_ars} 59 | | SOME (a,e) => 60 | (set (MAP (λ(cn,ar). explode cn, ar) a) ∪ css_cn_ars) INSERT cns_arities e) ∪ 61 | BIGUNION (set (MAP (λ(cn,vs,e). cns_arities e) css))) ∧ 62 | cns_arities (Delay e) = cns_arities e ∧ 63 | cns_arities (Force e) = cns_arities e 64 | Termination 65 | WF_REL_TAC `measure cexp_size` 66 | End 67 | 68 | Definition is_Lam_def: 69 | is_Lam (Lam s e) = T ∧ 70 | is_Lam _ = F 71 | End 72 | 73 | Definition dest_Var_def: 74 | dest_Var (Var v) = SOME v ∧ 75 | dest_Var _ = NONE 76 | End 77 | 78 | val _ = export_theory(); 79 | -------------------------------------------------------------------------------- /compiler/backend/passes/Holmakefile: -------------------------------------------------------------------------------- 1 | INCLUDES = $(PUREDIR)/misc ../ ../languages $(PUREDIR)/typing \ 2 | $(CAKEMLDIR)/basis/pure \ 3 | $(HOLDIR)/examples/algorithms 4 | -------------------------------------------------------------------------------- /compiler/backend/passes/env_to_stateScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Compiler from envLang to stateLang 3 | *) 4 | 5 | open HolKernel Parse boolLib bossLib BasicProvers dep_rewrite; 6 | open stringTheory optionTheory sumTheory pairTheory listTheory alistTheory 7 | finite_mapTheory pred_setTheory rich_listTheory arithmeticTheory 8 | open pure_miscTheory pure_configTheory pure_comp_confTheory 9 | env_cexpTheory state_cexpTheory 10 | state_app_unitTheory state_namesTheory; 11 | local open pure_semanticsTheory in end 12 | 13 | val _ = new_theory "env_to_state"; 14 | 15 | val _ = set_grammar_ancestry ["env_cexp", "state_cexp", "pure_comp_conf"]; 16 | 17 | Definition Letrec_imm_def: 18 | (Letrec_imm vs ((Var v):env_cexp$cexp) ⇔ MEM v vs) ∧ 19 | (Letrec_imm vs (Lam _ _) ⇔ T) ∧ 20 | (Letrec_imm vs _ ⇔ F) 21 | End 22 | 23 | Definition Letrec_split_def: 24 | Letrec_split vs [] = ([],[]) ∧ 25 | Letrec_split vs ((v:mlstring,x)::fns) = 26 | let (xs,ys) = Letrec_split vs fns in 27 | case dest_Delay x of 28 | | SOME y => ((v,Letrec_imm vs y,y)::xs,ys) 29 | | NONE => 30 | case dest_Lam x of 31 | | SOME (n,z) => (xs,(v,n,z)::ys) 32 | | NONE => (xs,ys) 33 | End 34 | 35 | Definition Bool_def[simp]: 36 | Bool T = (True :state_cexp$cexp) ∧ 37 | Bool F = (False :state_cexp$cexp) 38 | End 39 | 40 | Definition some_ref_bool_def: 41 | some_ref_bool (v:mlstring,b,y:state_cexp$cexp) = 42 | (SOME v, App Ref [Bool b; Bool b]) 43 | End 44 | 45 | Definition unsafe_update_def: 46 | unsafe_update (v,b,y) = 47 | (NONE:mlstring option, App UnsafeUpdate [Var v; IntLit 1; if b then y else Lam NONE y]) 48 | End 49 | 50 | Triviality Letrec_split_MEM_funs: 51 | ∀xs delays funs m n x. 52 | (delays,funs) = Letrec_split ns xs ∧ MEM (m,n,x) funs ⇒ 53 | cexp_size x ≤ list_size (pair_size mlstring_size cexp_size) xs 54 | Proof 55 | Induct \\ fs [Letrec_split_def] 56 | \\ PairCases \\ fs [Letrec_split_def] \\ rw [] 57 | \\ pairarg_tac \\ fs [] 58 | \\ gvs [AllCaseEqs()] 59 | \\ res_tac \\ fs [] 60 | \\ fs [list_size_def,basicSizeTheory.pair_size_def] 61 | \\ Cases_on ‘h1’ \\ gvs [dest_Lam_def,env_cexpTheory.cexp_size_def] 62 | QED 63 | 64 | Triviality Letrec_split_MEM_delays: 65 | ∀xs delays funs m n x. 66 | (delays,funs) = Letrec_split ns xs ∧ MEM (m,n,x) delays ⇒ 67 | cexp_size x ≤ list_size (pair_size mlstring_size cexp_size) xs 68 | Proof 69 | Induct \\ fs [Letrec_split_def] 70 | \\ PairCases \\ fs [Letrec_split_def] \\ rw [] 71 | \\ pairarg_tac \\ fs [] 72 | \\ gvs [AllCaseEqs()] 73 | \\ res_tac \\ fs [] 74 | \\ fs [list_size_def,basicSizeTheory.pair_size_def] 75 | \\ Cases_on ‘h1’ \\ gvs [dest_Delay_def,env_cexpTheory.cexp_size_def] 76 | QED 77 | 78 | Overload box[local] = “λx. App Ref [True]” 79 | Overload delay[local] = “λx. App Ref [False; Lam NONE x]” 80 | Overload suspend[local] = ``Lam NONE`` 81 | Overload trigger[local] = ``λe. app e Unit`` 82 | 83 | Definition to_state_def: 84 | to_state ((Var n):env_cexp$cexp) = (Var n):state_cexp$cexp ∧ 85 | to_state (App x y) = 86 | app (to_state x) (to_state y) ∧ 87 | to_state (Lam v x) = 88 | Lam (SOME v) (to_state x) ∧ 89 | to_state (Ret x) = 90 | suspend $ to_state x ∧ 91 | to_state (Raise x) = 92 | suspend $ Raise $ to_state x ∧ 93 | to_state (Bind x y) = 94 | suspend $ trigger $ app (to_state y) (trigger $ to_state x) ∧ 95 | to_state (Handle x y) = 96 | suspend $ trigger $ 97 | HandleApp (to_state y) 98 | (Let (SOME «v») (trigger $ to_state x) (suspend $ Var «v»)) ∧ 99 | to_state (Act x) = 100 | suspend $ trigger $ to_state x ∧ 101 | to_state (Length x) = 102 | suspend $ App Length [to_state x] ∧ 103 | to_state (Alloc x y) = 104 | suspend $ App Alloc [to_state x; to_state y] ∧ 105 | to_state (Update x y z) = 106 | suspend $ App Update [to_state x; to_state y; to_state z] ∧ 107 | to_state (Deref x y) = 108 | suspend $ App Sub [to_state x; to_state y] ∧ 109 | to_state (Box x) = 110 | App Ref [True; (to_state x)] ∧ 111 | to_state (Delay x) = 112 | App Ref [False; Lam NONE (to_state x)] ∧ 113 | to_state (Force x) = 114 | (Let (SOME «v») (to_state x) $ 115 | Let (SOME «v1») (App UnsafeSub [Var «v»; IntLit 0]) $ 116 | Let (SOME «v2») (App UnsafeSub [Var «v»; IntLit 1]) $ 117 | If (Var «v1») (Var «v2») $ 118 | Let (SOME «wh») (app (Var «v2») Unit) $ 119 | Let NONE (App UnsafeUpdate [Var «v»; IntLit 0; True]) $ 120 | Let NONE (App UnsafeUpdate [Var «v»; IntLit 1; Var «wh»]) $ 121 | Var «wh») ∧ 122 | to_state (Letrec xs y) = 123 | (let (delays,funs) = Letrec_split (MAP FST xs) xs in 124 | let delays = MAP (λ(m,n,x). (m,n,to_state x)) delays in 125 | let funs = MAP (λ(m,n,x). (m,n,to_state x)) funs in 126 | Lets (MAP some_ref_bool delays) $ 127 | Letrec funs $ 128 | Lets (MAP unsafe_update delays) (to_state y)) ∧ 129 | to_state (Let vo x y) = 130 | Let vo (to_state x) (to_state y) ∧ 131 | to_state (If x y z) = 132 | If (to_state x) (to_state y) (to_state z) ∧ 133 | to_state (Case v rs d) = 134 | Case v (MAP (λ(c,vs,y). (c,vs,to_state y)) rs) 135 | (case d of NONE => NONE | SOME (d,e) => SOME (d,to_state e)) ∧ 136 | to_state (Prim (Cons m) xs) = 137 | App (Cons m) (MAP to_state xs) ∧ 138 | to_state (Prim (AtomOp b) xs) = 139 | (let ys = MAP to_state xs in 140 | case dest_Message b of 141 | | SOME m => Let (SOME «v») (case ys of [] => Var «v» | (y::_) => y) 142 | (suspend $ App (FFI (implode m)) [Var «v»]) 143 | | _ => App (AtomOp b) ys) 144 | Termination 145 | WF_REL_TAC ‘measure cexp_size’ 146 | \\ fs [env_cexpTheory.cexp_size_eq] \\ rw [] 147 | \\ (drule_all Letrec_split_MEM_delays ORELSE drule_all Letrec_split_MEM_funs) 148 | \\ fs [] 149 | End 150 | 151 | Definition compile_def: 152 | compile x = app (to_state x) Unit 153 | End 154 | 155 | Definition compile_to_state_def: 156 | compile_to_state (c:compiler_opts) e = 157 | let x = compile e in 158 | let y = state_app_unit$optimise_app_unit c.do_app_unit x in 159 | let z = state_names$give_all_names y in 160 | z 161 | End 162 | 163 | val _ = export_theory (); 164 | -------------------------------------------------------------------------------- /compiler/backend/passes/proofs/Holmakefile: -------------------------------------------------------------------------------- 1 | INCLUDES = .. ../../languages/properties \ 2 | $(PUREDIR)/language $(PUREDIR)/meta-theory $(PUREDIR)/typing\ 3 | $(CAKEMLDIR)/basis/pure \ 4 | $(CAKEMLDIR)/semantics/proofs \ 5 | $(CAKEMLDIR)/semantics/alt_semantics \ 6 | $(CAKEMLDIR)/semantics/alt_semantics/proofs \ 7 | $(HOLDIR)/examples/algorithms 8 | -------------------------------------------------------------------------------- /compiler/backend/passes/proofs/env_to_stateProofScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Correctness for cexp compilation from envLang to stateLang 3 | *) 4 | 5 | open HolKernel Parse boolLib bossLib BasicProvers dep_rewrite; 6 | open stringTheory optionTheory sumTheory pairTheory listTheory alistTheory 7 | finite_mapTheory pred_setTheory rich_listTheory arithmeticTheory 8 | open pure_exp_lemmasTheory pure_miscTheory pure_configTheory 9 | envLangTheory thunkLang_primitivesTheory 10 | stateLangTheory env_semanticsTheory env_to_state_2ProofTheory 11 | state_caseProofTheory state_unthunkProofTheory state_app_unitProofTheory 12 | env_cexpTheory state_cexpTheory env_to_stateTheory 13 | state_app_unitProofTheory state_namesProofTheory; 14 | local open pure_semanticsTheory in end 15 | 16 | val _ = new_theory "env_to_stateProof"; 17 | 18 | val _ = set_grammar_ancestry 19 | ["env_to_state_2Proof", "state_namesProof", "state_app_unitProof", 20 | "env_to_state"]; 21 | 22 | Theorem itree_of_compile_to_state: 23 | cexp_wf x ⇒ 24 | itree_of (exp_of x) ---> itree_of (exp_of (compile_to_state c x)) 25 | Proof 26 | strip_tac 27 | \\ irule pure_semanticsTheory.compiles_to_trans 28 | \\ irule_at (Pos hd) env_to_state_2ProofTheory.itree_of_to_state 29 | \\ fs [compile_to_state_def] 30 | \\ irule pure_semanticsTheory.compiles_to_trans 31 | \\ irule_at (Pos last) itree_of_give_all_names 32 | \\ fs [itree_of_optimise_app_unit] 33 | \\ irule pure_semanticsTheory.eq_imp_compiles_to \\ fs [] 34 | QED 35 | 36 | Theorem IMP_state_cexp_wf: 37 | envLang$cexp_wf x ⇒ 38 | cexp_wf (compile_to_state c x) ∧ 39 | cns_arities (compile_to_state c x) ⊆ cns_arities x ∪ {{("",0)}; {("True", 0)}; {("False", 0)}} 40 | Proof 41 | strip_tac 42 | \\ simp [compile_to_state_def] 43 | \\ dxrule_then assume_tac to_state_cexp_wf 44 | \\ qspec_then ‘compile x’ assume_tac $ GEN_ALL cexp_wwf_optimise_app_unit 45 | \\ pop_assum $ qspec_then ‘c.do_app_unit’ strip_assume_tac 46 | \\ gs [] 47 | \\ dxrule_then assume_tac give_all_names_cexp_wf 48 | \\ fs [] 49 | \\ irule SUBSET_TRANS 50 | \\ first_x_assum $ irule_at Any 51 | \\ simp [] 52 | QED 53 | 54 | val _ = export_theory (); 55 | -------------------------------------------------------------------------------- /compiler/backend/passes/proofs/notes.txt: -------------------------------------------------------------------------------- 1 | 2 | thunks are ((unit -> 'a) + 'a) ref 3 | 4 | envLang stateLang 5 | 6 | Prim (Cons "Ret") [x] --> (fn u => App "force" (compile x ())) 7 | Prim (Cons "Bind") [x; y] --> (fn u => Let v (compile x ()) (compile y () v)) 8 | Prim (Cons "Handle") [x; y] --> (fn u => Handle (compile x ()) v (compile y () v)) 9 | Prim (Msg ffi) [x] --> (fn u => App (FFI ffi) [compile x]) 10 | Prim (Cons "Act" [msg]) --> (fn u => compile msg ()) 11 | 12 | Box x --> (Ref (Cons "INR" [(compile x)])) 13 | Delay x --> (Ref (Cons "INL" [fn u => (compile x) ()])) 14 | Force x --> force (compile x) 15 | 16 | fun force t = 17 | case !t of 18 | | INL f => let val v = f () in (t := INR v; v) end 19 | | INR v => v 20 | 21 | 22 | env$Letrec [(x, y + 1); ...] rest 23 | 24 | --> 25 | 26 | (* declare all references *) 27 | Let x (Ref (INL (fn u => Raise Bind))) 28 | (* use the bindings *) 29 | Letrec [...] 30 | (* update the references *) 31 | (x := INL (fn u => y + 1); compiler rest)) 32 | 33 | 34 | 35 | step (Exp (LitInt i)) s c = (Val (Lit i), s, c) 36 | step (Exp (Raise x)) s c = (Exp x, s, RaiseC c) 37 | 38 | step (Val v) s (RaiseC (LetC ... c)) = (Val v, s, RaiseC c) 39 | 40 | eval exp s c = Act ffi msg s' c' 41 | 42 | 43 | 44 | env$semantics (Bind (Bind (Ret ...) (Bind ... (Act ...)))) 45 | ~ 46 | state$eval (fn _ => ...) () 47 | 48 | eval : exp -> v 49 | 50 | itree_of : exp -> itree 51 | 52 | cakeml_semantics : exp -> io_oracle -> io_trace 53 | -------------------------------------------------------------------------------- /compiler/backend/passes/proofs/pure_letrecScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Simplification of Letrec 3 | *) 4 | open HolKernel Parse boolLib bossLib term_tactic; 5 | open pure_expTheory pure_miscTheory topological_sortTheory pure_letrec_cexpTheory; 6 | 7 | val _ = new_theory "pure_letrec"; 8 | 9 | (* 10 | The motivation for these Letrec simplifications is that the parser 11 | will produce a giant Letrec holding all the top-level functions. It 12 | makes sense to split this up and clean it up as much as possible early. 13 | *) 14 | 15 | (*******************) 16 | 17 | Definition letrec_recurse_def: 18 | letrec_recurse f (Letrec xs y) = 19 | f (MAP (λ(n,x). n, letrec_recurse f x) xs) (letrec_recurse f y) ∧ 20 | letrec_recurse f (Lam n x) = Lam n (letrec_recurse f x) ∧ 21 | letrec_recurse f (Prim p xs) = Prim p (MAP (letrec_recurse f) xs) ∧ 22 | letrec_recurse f (App x y) = App (letrec_recurse f x) (letrec_recurse f y) ∧ 23 | letrec_recurse f res = res 24 | Termination 25 | WF_REL_TAC ‘measure (exp_size o SND)’ >> rw [] >> 26 | Induct_on `xs` >> rw[] >> gvs[exp_size_def] 27 | End 28 | 29 | (*******************) 30 | 31 | (* 32 | 1. a pass that ensures, for every Letrec xs y, that ALL_DISTINCT (MAP FST xs) 33 | *) 34 | 35 | Definition distinct_def: 36 | distinct e = letrec_recurse (λfns e. Letrec (make_distinct fns) e) e 37 | End 38 | 39 | 40 | (* 41 | 2. split every Letrec according to top_sort_any, i.e. each Letrec becomes 42 | one or more nested Letrecs 43 | *) 44 | 45 | Definition make_Letrecs_def: 46 | make_Letrecs [] e = e ∧ 47 | make_Letrecs (fns::rest) e = Letrec fns (make_Letrecs rest e) 48 | End 49 | 50 | Definition split_one_def: 51 | split_one fns = 52 | let deps = MAP (λ(fn,body). (fn, freevars_l body)) fns in 53 | let sorted = top_sort_any deps in 54 | MAP (λl. MAP (λs. (s, THE (ALOOKUP fns s))) l) sorted 55 | End 56 | 57 | Definition split_all_def: 58 | split_all e = letrec_recurse (λfns e. make_Letrecs (split_one fns) e) e 59 | End 60 | 61 | 62 | (* 63 | 3. clean up pass: 64 | - remove any Letrec xs y that only bind variables that are not free in y 65 | - change any Letrec [(v,x)] y into Let v x y, when v not free in x 66 | *) 67 | 68 | Definition clean_one_def: 69 | clean_one fns e = 70 | if DISJOINT (set (MAP FST fns)) (freevars e) then e else 71 | case fns of 72 | [(v,x)] => if v ∈ freevars x then Letrec fns e else Let v x e 73 | | _ => Letrec fns e 74 | End 75 | 76 | Definition clean_all_def: 77 | clean_all e = letrec_recurse clean_one e 78 | End 79 | 80 | 81 | (* 82 | Putting it all together: 83 | *) 84 | 85 | Definition simplify_def: 86 | simplify e = 87 | let d = distinct e in 88 | let s = split_all d in 89 | s 90 | End 91 | 92 | (*******************) 93 | 94 | val _ = export_theory(); 95 | -------------------------------------------------------------------------------- /compiler/backend/passes/proofs/pure_letrec_lamScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Lambdifying of Letrec 3 | *) 4 | open HolKernel Parse boolLib bossLib; 5 | open pure_expTheory pure_beta_equivTheory pure_letrecTheory; 6 | 7 | val _ = new_theory "pure_letrec_lam"; 8 | 9 | (* 10 | This pass ensures that every variable bound by a Letrec is a Lambda. 11 | This will permit compatibility with CakeML letrecs. 12 | *) 13 | 14 | (* Arbitrary closed term - TODO replace with unit, if not already equal *) 15 | Definition cl_tm_def: 16 | cl_tm = Cons "" [] 17 | End 18 | 19 | Definition make_apps_def: 20 | make_apps [] = FEMPTY ∧ 21 | make_apps ((_,pure_exp$Lam _ _)::fs) = make_apps fs ∧ 22 | make_apps ((v,e)::fs) = make_apps fs |+ (v, App (Var v) cl_tm) 23 | End 24 | 25 | Definition lambdify_one_def: 26 | lambdify_one fns e = 27 | let apps = make_apps fns in 28 | let fresh = fresh_var "x" (MAP FST fns ++ FLAT (MAP (freevars_l o SND) fns)) in 29 | let fns' = MAP (λ(v,f). 30 | if v ∈ FDOM apps then (v, Lam fresh (subst apps f)) 31 | else (v,subst apps f)) fns in 32 | Letrec fns' (subst apps e) 33 | End 34 | 35 | Definition lambdify_all_def: 36 | lambdify_all e = letrec_recurse lambdify_one e 37 | End 38 | 39 | val _ = export_theory(); 40 | -------------------------------------------------------------------------------- /compiler/backend/passes/proofs/pure_namesProofScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Verification of functions in pure_namesTheory 3 | *) 4 | open HolKernel Parse boolLib bossLib BasicProvers dep_rewrite; 5 | open listTheory pairTheory alistTheory pred_setTheory finite_mapTheory 6 | sptreeTheory arithmeticTheory combinTheory; 7 | open pure_miscTheory pure_expTheory pure_cexpTheory pureLangTheory 8 | var_setTheory pure_exp_lemmasTheory pure_cexp_lemmasTheory 9 | pure_namesTheory; 10 | 11 | val _ = set_grammar_ancestry 12 | ["pure_names", "pure_exp", "pure_cexp", "var_set", "pureLang"]; 13 | 14 | val _ = new_theory "pure_namesProof"; 15 | 16 | Theorem extract_names_thm: 17 | (∀s (x:'a cexp) t. 18 | extract_names s x = t ∧ 19 | vars_ok s ⇒ 20 | vars_ok t ∧ set_of t = allvars_of x UNION set_of s) ∧ 21 | (∀s (xs: 'a cexp list) t. 22 | extract_names_list s xs = t ∧ 23 | vars_ok s ⇒ 24 | vars_ok t ∧ set_of t = BIGUNION (set (MAP allvars_of xs)) UNION set_of s) 25 | Proof 26 | ho_match_mp_tac extract_names_ind 27 | \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac 28 | >~ [‘Var’] >- 29 | (gvs [extract_names_def,exp_of_def] \\ fs [EXTENSION]) 30 | >~ [‘Lam’] >- 31 | (gvs [extract_names_def,exp_of_def] 32 | \\ fs [EXTENSION] \\ rw [] \\ eq_tac \\ rw [] \\ fs []) 33 | >~ [‘Let’] >- 34 | (gvs [extract_names_def,exp_of_def] 35 | \\ fs [EXTENSION] \\ rw [] \\ eq_tac \\ rw [] \\ fs []) 36 | >~ [‘App’] >- 37 | (gvs [extract_names_def,exp_of_def,SF ETA_ss] 38 | \\ fs [EXTENSION] \\ rw [] \\ eq_tac \\ rw [] \\ fs [] 39 | \\ metis_tac []) 40 | >~ [‘Prim’] >- 41 | (gvs [extract_names_def,exp_of_def,SF ETA_ss] 42 | \\ fs [EXTENSION] \\ rw [] \\ eq_tac \\ rw [] \\ fs [] 43 | \\ metis_tac []) 44 | >~ [‘Letrec’] >- 45 | (gvs [extract_names_def,exp_of_def,SF ETA_ss] 46 | \\ strip_tac \\ gvs [MAP_MAP_o,o_DEF] 47 | \\ fs [EXTENSION] \\ rw [] \\ eq_tac \\ rw [] \\ fs [] 48 | \\ metis_tac []) 49 | >~ [‘Case _ _ _ _ opt’] >- 50 | (gen_tac \\ gvs [extract_names_def,exp_of_def,SF ETA_ss,AllCaseEqs()] 51 | \\ strip_tac \\ gvs [] 52 | \\ gvs [MAP_MAP_o,o_DEF] 53 | \\ ‘BIGUNION (set (MAP (λx. set (MAP explode (FST (SND x)))) ys)) = 54 | set (MAP explode (FLAT (MAP (λx. FST (SND x)) ys)))’ by 55 | (fs [EXTENSION,MEM_MAP,MEM_FLAT,FORALL_PROD,EXISTS_PROD,PULL_EXISTS] 56 | \\ rw [] \\ eq_tac \\ strip_tac 57 | \\ qpat_x_assum ‘MEM _ _’ $ irule_at Any 58 | >- metis_tac [] 59 | \\ rw [] 60 | \\ qexists_tac ‘IMAGE explode $ set l’ \\ fs []) 61 | \\ asm_rewrite_tac [] 62 | \\ fs [EXTENSION,MEM_MAP,MEM_FLAT,PULL_EXISTS,EXISTS_PROD,FORALL_PROD] 63 | \\ rw [] \\ eq_tac \\ rw [] \\ fs [] 64 | \\ metis_tac []) 65 | >~ [‘NestedCase’] >- 66 | (gvs [extract_names_def,exp_of_def,SF ETA_ss] 67 | \\ strip_tac \\ gvs [MAP_MAP_o,o_DEF] 68 | \\ fs [EXTENSION] \\ rw [] \\ eq_tac \\ rw [] \\ fs [] 69 | \\ metis_tac []) 70 | >~ [‘extract_names_list s []’] >- 71 | gvs [extract_names_def,exp_of_def] 72 | >~ [‘extract_names_list s (x::xs)’] 73 | \\ gvs [extract_names_def,exp_of_def] 74 | \\ strip_tac \\ gvs [] 75 | \\ fs [EXTENSION] \\ metis_tac [] 76 | QED 77 | 78 | Theorem pure_names_ok: 79 | vars_ok (pure_names e) 80 | Proof 81 | fs [pure_names_def,SIMP_RULE std_ss [] extract_names_thm] 82 | QED 83 | 84 | Theorem pure_names_eq_allvars: 85 | set_of (pure_names e) = allvars_of e 86 | Proof 87 | fs [pure_names_def,SIMP_RULE std_ss [] extract_names_thm] 88 | QED 89 | 90 | val _ = export_theory(); 91 | -------------------------------------------------------------------------------- /compiler/backend/passes/proofs/pure_to_cakeProofScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Proof of composition from pureLang to CakeML 3 | *) 4 | 5 | open HolKernel Parse boolLib bossLib term_tactic monadsyntax dep_rewrite; 6 | open stringTheory optionTheory sumTheory pairTheory listTheory alistTheory 7 | finite_mapTheory pred_setTheory rich_listTheory arithmeticTheory combinTheory 8 | pure_to_thunkProofTheory thunk_to_envProofTheory pure_letrecProofTheory 9 | env_to_stateProofTheory state_to_cakeProofTheory pure_to_cakeTheory; 10 | 11 | val _ = new_theory "pure_to_cakeProof"; 12 | 13 | val _ = set_grammar_ancestry 14 | ["pure_to_cake", "pure_semantics", "pure_cexp", "pureLang", "pure_letrecProof"]; 15 | 16 | Theorem pure_to_env_correct: 17 | cexp_wf x ∧ closed (exp_of x) ∧ NestedCase_free x ∧ 18 | safe_itree (itree_of (exp_of x)) ∧ letrecs_distinct (exp_of x) 19 | ⇒ 20 | itree_of (exp_of x) = 21 | env_semantics$itree_of (envLang$exp_of (pure_to_env c x)) ∧ 22 | envLang$cexp_wf (pure_to_env c x) ∧ 23 | cns_arities (pure_to_env c x) ⊆ 24 | IMAGE (IMAGE (explode ## I)) (cns_arities x) 25 | Proof 26 | strip_tac 27 | \\ drule_all pure_to_thunkProofTheory.compile_to_thunk_itree_of 28 | \\ disch_then $ qspec_then ‘c’ assume_tac 29 | \\ fs [pure_to_env_def] 30 | \\ irule_at Any thunk_to_envProofTheory.to_env_semantics 31 | \\ drule_all IMP_thunk_cexp_wf \\ fs [] 32 | \\ disch_then $ qspec_then ‘c’ strip_assume_tac 33 | \\ drule_all IMP_env_cexp_wf \\ fs [] 34 | \\ rw [] \\ irule SUBSET_TRANS 35 | \\ first_assum $ irule_at Any \\ fs [] 36 | QED 37 | 38 | Theorem pure_to_state_correct: 39 | cexp_wf x ∧ closed (exp_of x) ∧ NestedCase_free x ∧ 40 | safe_itree (itree_of (exp_of x)) ∧ letrecs_distinct (exp_of x) 41 | ⇒ 42 | itree_of (exp_of x) = 43 | stateLang$itree_of (stateLang$exp_of (pure_to_state c x)) ∧ 44 | state_cexp$cexp_wf (pure_to_state c x) ∧ 45 | cns_arities (pure_to_state c x) ⊆ 46 | IMAGE (IMAGE (explode ## I)) (cns_arities x) ∪ {{("",0)}; {("True",0)}; {("False",0)}} 47 | Proof 48 | strip_tac 49 | \\ drule_all pure_to_env_correct 50 | \\ disch_then $ qspec_then ‘c’ strip_assume_tac 51 | \\ fs [pure_to_state_def] 52 | \\ drule env_to_stateProofTheory.itree_of_compile_to_state 53 | \\ disch_then $ qspec_then ‘c’ strip_assume_tac 54 | \\ drule_all pure_semanticsTheory.safe_itree_compiles_to_IMP_eq 55 | \\ strip_tac \\ fs [] 56 | \\ drule_all IMP_state_cexp_wf \\ fs [] 57 | \\ disch_then $ qspec_then ‘c’ strip_assume_tac 58 | \\ rw [] \\ irule SUBSET_TRANS 59 | \\ first_assum $ irule_at Any 60 | \\ fs [SUBSET_DEF] 61 | QED 62 | 63 | Theorem pure_to_cake_correct: 64 | cexp_wf x ∧ closed (exp_of x) ∧ NestedCase_free x ∧ 65 | safe_itree (itree_of (exp_of x)) ∧ letrecs_distinct (exp_of x) ∧ 66 | namespace_init_ok ((I ## K ns) initial_namespace) ∧ 67 | state_to_cakeProof$cns_ok ((I ## K ns) initial_namespace) 68 | (IMAGE (IMAGE (explode ## I)) (pure_cexp$cns_arities x)) 69 | ⇒ 70 | state_to_cakeProof$itree_rel 71 | (itree_of (exp_of x)) 72 | (itree_semantics$itree_semantics (pure_to_cake c ns x)) ∧ 73 | itree_semantics$safe_itree state_to_cakeProof$ffi_convention 74 | (itree_semantics$itree_semantics (pure_to_cake c ns x)) 75 | Proof 76 | strip_tac 77 | \\ drule_all pure_to_state_correct 78 | \\ disch_then $ qspec_then ‘c’ strip_assume_tac 79 | \\ fs [pure_to_cake_def] 80 | \\ irule state_to_cakeProofTheory.compile_correct 81 | \\ fs [GSYM cns_ok_def] 82 | \\ irule state_to_cakeProofTheory.cns_ok_SUBSET 83 | \\ first_x_assum $ irule_at $ Pos hd 84 | \\ irule state_to_cakeProofTheory.cns_ok_UNION 85 | \\ fs [] 86 | QED 87 | 88 | val _ = export_theory (); 89 | -------------------------------------------------------------------------------- /compiler/backend/passes/pure_comp_confScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Configuration what to optimise. 3 | *) 4 | 5 | open HolKernel Parse boolLib bossLib intLib 6 | mlstringTheory mlintTheory mloptionTheory; 7 | 8 | val _ = new_theory "pure_comp_conf"; 9 | 10 | Datatype: 11 | inline_opts = <| 12 | depth : num ; 13 | heuristic : num ; 14 | |> 15 | End 16 | 17 | Datatype: 18 | compiler_opts = <| 19 | do_pure_sort : bool ; (* pure-to-pure binding group analysis *) 20 | do_pure_clean : bool ; (* pure-to-pure cleaning / deadcode elimination *) 21 | do_demands : bool ; (* demand analysis *) 22 | inlining : inline_opts ; (* inlining *) 23 | do_mk_delay : bool ; (* thunk-to-thunk smart mk_delay constructor *) 24 | do_let_force : bool ; (* thunk-to-thunk simplify let force *) 25 | do_split_dlam : bool ; (* thunk-to-thunk split delayed lambdas *) 26 | do_app_unit : bool ; (* state-to-state *) 27 | do_final_gc : bool ; (* invoke GC at end of CakeML program *) 28 | do_explore : bool (* print explorer output *) 29 | |> 30 | End 31 | 32 | Overload pure_sort_flag[local] = “strlit "-sort"” 33 | Overload pure_clean_flag[local] = “strlit "-clean"” 34 | Overload demands_flag[local] = “strlit "-demands"” 35 | Overload inline_depth_flag[local] = “strlit "-inline_depth="” 36 | Overload inline_size_flag[local] = “strlit "-inline_size="” 37 | Overload mk_delay_flag[local] = “strlit "-mk_delay"” 38 | Overload let_force_flag[local] = “strlit "-let_force"” 39 | Overload dlam_flag[local] = “strlit "-dlam"” 40 | Overload unit_flag[local] = “strlit "-unit"” 41 | Overload final_gc_flag[local] = “strlit "-final_gc"” 42 | Overload explore_flag[local] = “strlit "-explore"” 43 | 44 | Definition get_num_flag_def: 45 | get_num_flag flag (cl : mlstring list) = 46 | case FILTER (λs. isPrefix flag s) cl of 47 | | [] => NONE 48 | | (s::_) => 49 | let num_str = extract s (strlen flag) NONE in 50 | fromNatString num_str 51 | End 52 | 53 | Definition bool_flags_def: 54 | bool_flags = [pure_sort_flag; 55 | pure_clean_flag; 56 | demands_flag; 57 | mk_delay_flag; 58 | let_force_flag; 59 | dlam_flag; 60 | unit_flag; 61 | final_gc_flag; 62 | explore_flag] 63 | End 64 | 65 | Definition num_flags_def: 66 | num_flags = [inline_depth_flag; inline_size_flag] 67 | End 68 | 69 | Definition num_flag_ok_def: 70 | num_flag_ok s = 71 | EXISTS 72 | (λf. isPrefix f s ∧ IS_SOME (fromNatString $ extract s (strlen f) NONE)) 73 | num_flags 74 | End 75 | 76 | Definition check_flags_def: 77 | check_flags (cl : mlstring list) = 78 | FILTER (λs. ¬MEM s bool_flags ∧ ¬num_flag_ok s) cl 79 | End 80 | 81 | Definition read_cline_args_def: 82 | read_cline_args (cl:mlstring list) ⇔ 83 | case check_flags cl of 84 | | x::xs => INR (concat [strlit "ERROR: unknown flag(s) "; 85 | concatWith (strlit ", ") (x::xs); strlit "\n"]) 86 | | _ => 87 | let inlining_opts = 88 | <| depth := getOpt (get_num_flag inline_depth_flag cl) 5000 ; 89 | heuristic := getOpt (get_num_flag inline_size_flag cl) 10000 |> in 90 | INL <| do_pure_sort := ¬ MEM pure_sort_flag cl ; 91 | do_pure_clean := ¬ MEM pure_clean_flag cl ; 92 | do_demands := ¬ MEM demands_flag cl ; 93 | inlining := inlining_opts ; 94 | do_mk_delay := ¬ MEM mk_delay_flag cl ; 95 | do_let_force := ¬ MEM let_force_flag cl ; 96 | do_split_dlam := ¬ MEM dlam_flag cl ; 97 | do_app_unit := ¬ MEM unit_flag cl ; 98 | do_final_gc := MEM final_gc_flag cl ; (* NB final GC only if flag is present *) 99 | do_explore := MEM explore_flag cl |> 100 | End 101 | 102 | val default = EVAL “read_cline_args []” |> concl |> rand |> rand 103 | 104 | Definition default_conf_def: 105 | default_conf = ^default 106 | End 107 | 108 | val _ = export_theory (); 109 | -------------------------------------------------------------------------------- /compiler/backend/passes/pure_dead_letScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Elimination of dead let-bindings 3 | *) 4 | open HolKernel Parse boolLib bossLib; 5 | open pure_letrec_cexpTheory; 6 | 7 | val _ = new_theory "pure_dead_let"; 8 | 9 | (* 10 | dead_let keeps track of free variables as it goes 11 | (as in `pure_letrec_cexpTheory`) 12 | *) 13 | 14 | Definition dead_let_def: 15 | dead_let (Let c x ce1 ce2) = ( 16 | let ce2' = dead_let ce2 in 17 | case lookup (get_info ce2') x of (* if x not free in ce2' *) 18 | | NONE => ce2' (* remove let-binding *) 19 | | SOME _ => let ce1' = dead_let ce1 (* otherwise recurse *) 20 | in Let (union (get_info ce1') (delete (get_info ce2') x)) 21 | x ce1' ce2') ∧ 22 | 23 | (* Boilerplate: *) 24 | dead_let (Var c v) = Var (insert empty v ()) v ∧ 25 | dead_let (Prim c cop ces) = ( 26 | let ces' = MAP dead_let ces 27 | in Prim (list_union $ MAP get_info ces') cop ces') ∧ 28 | dead_let (App c ce ces) = ( 29 | let ces' = MAP dead_let ces; 30 | ce' = dead_let ce 31 | in App (list_union (MAP get_info (ce'::ces'))) ce' ces') ∧ 32 | dead_let (pure_cexp$Lam c xs ce) = ( 33 | let ce' = dead_let ce 34 | in Lam (list_delete (get_info ce') xs) xs ce') ∧ 35 | dead_let (Letrec c fns ce) = ( 36 | let fns' = MAP (λ(f,body). f, dead_let body) fns; 37 | ce' = dead_let ce; 38 | c' = list_delete 39 | (list_union (get_info ce' :: MAP (λ(f,body). get_info body) fns')) 40 | (MAP FST fns') 41 | in Letrec c' fns' ce') ∧ 42 | dead_let (Case c ce x css us) = ( 43 | let ce' = dead_let ce; 44 | css' = MAP (λ(cn,vs,ce). cn, vs, dead_let ce) css; 45 | us' = OPTION_MAP (λ(cn_ars,ce). cn_ars, dead_let ce) us; 46 | c' = union (get_info ce') $ combin$C delete x $ list_union $ 47 | (case us' of NONE => empty | SOME (_,ce') => get_info ce') :: 48 | MAP (λ(cn,vs,ce). list_delete (get_info ce) vs) css' 49 | in Case c' ce' x css' us') ∧ 50 | dead_let (NestedCase c ce x p pce pces) = ( 51 | let ce' = dead_let ce; 52 | pce' = dead_let pce; 53 | pces' = MAP (λ(p,ce). p, dead_let ce) pces; 54 | c' = union (get_info ce') $ combin$C delete x $ list_union $ 55 | MAP (λ(p,ce). list_delete (get_info ce) (cepat_vars_l p)) $ 56 | (p,pce')::pces' 57 | in NestedCase c' ce' x p pce' pces') 58 | Termination 59 | WF_REL_TAC `measure $ cexp_size (K 0)` 60 | End 61 | 62 | val _ = export_theory(); 63 | -------------------------------------------------------------------------------- /compiler/backend/passes/pure_namesScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | A function tha collects all names in a pureLang cexp 3 | *) 4 | open HolKernel Parse boolLib bossLib BasicProvers; 5 | open listTheory pairTheory mlstringTheory; 6 | open pure_cexpTheory var_setTheory; 7 | 8 | val _ = set_grammar_ancestry ["var_set", "pure_cexp"]; 9 | 10 | val _ = new_theory "pure_names"; 11 | 12 | Definition extract_names_def: 13 | extract_names s (pure_cexp$Var c v) = insert_var s v ∧ 14 | extract_names s (Lam c ns x) = extract_names (insert_vars s ns) x ∧ 15 | extract_names s (Letrec c xs y) = 16 | (let s = insert_vars s (MAP FST xs) in 17 | let s = extract_names_list s (MAP SND xs) in 18 | extract_names s y) ∧ 19 | extract_names s (Prim c p xs) = 20 | extract_names_list s xs ∧ 21 | extract_names s (App c x ys) = 22 | extract_names_list (extract_names s x) ys ∧ 23 | extract_names s (Let c n x y) = 24 | extract_names (extract_names (insert_var s n) x) y ∧ 25 | extract_names s (Case c x n ys eopt) = 26 | (let s = extract_names (insert_var s n) x in 27 | let s = insert_vars s (FLAT (MAP (FST o SND) ys)) in 28 | let s = extract_names_list s (MAP (SND o SND) ys) in 29 | case eopt of 30 | | NONE => s 31 | | SOME (a,e) => extract_names s e) ∧ 32 | extract_names s (NestedCase c g gv p e pes) = 33 | (let s = extract_names (insert_var s gv) g in 34 | let s = extract_names s e in 35 | extract_names_list s (MAP SND pes)) ∧ 36 | extract_names_list s [] = s ∧ 37 | extract_names_list s (x::xs) = 38 | extract_names_list (extract_names s x) xs 39 | Termination 40 | WF_REL_TAC `measure $ λx. case x of 41 | | INL x => cexp_size (K 0) (SND x) 42 | | INR x => list_size (cexp_size (K 0)) (SND x)` 43 | \\ fs [pure_cexpTheory.cexp_size_eq] \\ rw [] 44 | >~ [‘list_size (cexp_size (K 0)) (MAP SND pes)’] >- 45 | (Induct_on ‘pes’ \\ fs [listTheory.list_size_def,FORALL_PROD] 46 | \\ rw [] \\ fs [basicSizeTheory.pair_size_def]) 47 | >~ [‘list_size (cexp_size (K 0)) (MAP SND xs)’] >- 48 | (pop_assum kall_tac 49 | \\ Induct_on ‘xs’ \\ fs [listTheory.list_size_def,FORALL_PROD] 50 | \\ rw [] \\ fs [basicSizeTheory.pair_size_def]) 51 | >~ [‘list_size (cexp_size (K 0)) (MAP (λx. SND (SND x)) ys)’] >- 52 | (pop_assum kall_tac 53 | \\ Induct_on ‘ys’ \\ fs [listTheory.list_size_def,FORALL_PROD] 54 | \\ rw [] \\ fs [basicSizeTheory.pair_size_def]) 55 | End 56 | 57 | Definition pure_names_def: 58 | pure_names e = extract_names empty_vars e 59 | End 60 | 61 | val _ = export_theory(); 62 | -------------------------------------------------------------------------------- /compiler/backend/passes/pure_nestedcaseScript.sml: -------------------------------------------------------------------------------- 1 | open HolKernel Parse boolLib bossLib; 2 | 3 | open listTheory 4 | open pure_cexpTheory 5 | 6 | val _ = new_theory "pure_nestedcase"; 7 | 8 | Definition updlast_def[simp]: 9 | updlast [] rep = rep ∧ 10 | updlast [h] rep = rep ∧ 11 | updlast (h1::h2::t) rep = h1 :: updlast (h2::t) rep 12 | End 13 | 14 | Theorem updlast_EQ_NIL[simp]: 15 | ∀l rep. updlast l rep = [] ⇔ rep = [] ∧ LENGTH l < 2 16 | Proof recInduct updlast_ind >> rw[] 17 | QED 18 | 19 | Theorem LAST_updlast: 20 | ∀l rep. rep ≠ [] ⇒ LAST (updlast l rep) = LAST rep 21 | Proof 22 | recInduct updlast_ind >> rw[] >> gs[] >> simp[LAST_CONS_cond] 23 | QED 24 | 25 | Definition lift_uscore1_def: 26 | (lift_uscore1 (NestedCase c t tv p e pes) = 27 | case LAST ((p,e)::pes) of 28 | (lp,le) => if lp = cepatUScore then 29 | case dest_nestedcase le of 30 | SOME (v, vnm, pes') => 31 | if tv = vnm ∧ dest_var v = SOME vnm then 32 | case updlast ((p,e)::pes) pes' of 33 | [] => Var c (implode "Fail/can't happen") 34 | | (p',e')::rest => 35 | NestedCase c t tv p' e' rest 36 | else NestedCase c t tv p e pes 37 | | NONE => NestedCase c t tv p e pes 38 | else 39 | NestedCase c t tv p e pes) ∧ 40 | (lift_uscore1 e = e) 41 | End 42 | 43 | Overload lift_uscore = “gencexp_recurse lift_uscore1” 44 | 45 | Theorem lift_uscore_thm = 46 | gencexp_recurse_def 47 | |> CONJUNCTS 48 | |> map SPEC_ALL 49 | |> map (Q.INST [‘f’ |-> ‘lift_uscore1’]) 50 | |> map GEN_ALL |> LIST_CONJ 51 | |> SRULE [lift_uscore1_def, SF boolSimps.ETA_ss, 52 | listTheory.LAST_MAP] 53 | 54 | val _ = export_theory(); 55 | -------------------------------------------------------------------------------- /compiler/backend/passes/pure_to_cakeScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Composition of compiler passes from pureLang to CakeML, not including 3 | pureLang-to-pureLang passes. 4 | *) 5 | 6 | open HolKernel Parse boolLib bossLib term_tactic monadsyntax dep_rewrite; 7 | open pure_to_thunkTheory thunk_to_envTheory env_to_stateTheory state_to_cakeTheory; 8 | open pure_comp_confTheory 9 | 10 | val _ = new_theory "pure_to_cake"; 11 | 12 | val _ = set_grammar_ancestry 13 | ["pure_to_thunk", "thunk_to_env", "env_to_state", "state_to_cake"]; 14 | 15 | Definition pure_to_env_def: 16 | pure_to_env (c:compiler_opts) e = 17 | let thunk_prog = pure_to_thunk$compile_to_thunk c e in 18 | let _ = empty_ffi (strlit "to_thunk") in 19 | let env_prog = thunk_to_env$to_env thunk_prog in 20 | let _ = empty_ffi (strlit "to_env") in 21 | env_prog 22 | End 23 | 24 | Definition pure_to_state_def: 25 | pure_to_state c e = 26 | let env_prog = pure_to_env c e in 27 | let state_prog = compile_to_state c env_prog in 28 | let _ = empty_ffi (strlit "to_state") in 29 | state_prog 30 | End 31 | 32 | Definition pure_to_cake_def: 33 | pure_to_cake c ns e = 34 | let state_prog = pure_to_state c e in 35 | let cake_prog = compile_with_preamble c ((I ## K ns) initial_namespace) state_prog in 36 | let _ = empty_ffi (strlit "to_cake") in 37 | cake_prog 38 | End 39 | 40 | val _ = export_theory (); 41 | -------------------------------------------------------------------------------- /compiler/backend/passes/state_app_unitScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Compiler from envLang to stateLang 3 | *) 4 | 5 | open HolKernel Parse boolLib bossLib BasicProvers dep_rewrite; 6 | open stringTheory optionTheory sumTheory pairTheory listTheory alistTheory 7 | finite_mapTheory pred_setTheory rich_listTheory arithmeticTheory 8 | open pure_miscTheory pure_configTheory state_cexpTheory; 9 | 10 | val _ = new_theory "state_app_unit"; 11 | 12 | val _ = set_grammar_ancestry ["state_cexp"]; 13 | 14 | Definition unit_apps_def: 15 | unit_apps k x = if k = 0n then (x:cexp) else unit_apps (k-1) (app x Unit) 16 | End 17 | 18 | Definition any_el_def: 19 | any_el n [] = Unit:state_cexp$cexp ∧ 20 | any_el n (x::xs) = if n = 0:num then x else any_el (n-1) xs 21 | End 22 | 23 | Definition push_app_unit_def: 24 | push_app_unit l ((Var v):cexp) = 25 | unit_apps l (Var v) ∧ 26 | push_app_unit l (App op xs) = 27 | (if op = AppOp ∧ LENGTH xs = 2 then 28 | if any_el 1 xs = Unit then 29 | push_app_unit (l+1n) (any_el 0 xs) 30 | else unit_apps l $ App op (MAP (push_app_unit 0) xs) 31 | else unit_apps l $ App op (MAP (push_app_unit 0) xs)) ∧ 32 | push_app_unit l (Lam vn x) = 33 | (if l ≠ 0 ∧ vn = NONE then 34 | push_app_unit (l-1n) x 35 | else unit_apps l (Lam vn (push_app_unit 0 x))) ∧ 36 | push_app_unit l (Letrec funs x) = 37 | Letrec (MAP (λ(f,v,y). (f,v,push_app_unit 0 y)) funs) (push_app_unit l x) ∧ 38 | push_app_unit l (Let vn x y) = 39 | Let vn (push_app_unit 0 x) (push_app_unit l y) ∧ 40 | push_app_unit l (If x y z) = 41 | If (push_app_unit 0 x) (push_app_unit l y) (push_app_unit l z) ∧ 42 | push_app_unit l (Case v rows d) = 43 | unit_apps l 44 | (Case v (MAP (λ(v,vs,y). (v,vs,push_app_unit 0 y)) rows) 45 | (case d of NONE => NONE | SOME (a,e) => SOME (a,push_app_unit 0 e))) ∧ 46 | push_app_unit l (Raise x) = 47 | unit_apps l (Raise (push_app_unit 0 x)) ∧ 48 | push_app_unit l (Handle x v y) = 49 | unit_apps l (Handle (push_app_unit 0 x) v (push_app_unit 0 y)) ∧ 50 | push_app_unit l (HandleApp x y) = 51 | unit_apps l (HandleApp (push_app_unit 0 x) (push_app_unit 0 y)) 52 | Termination 53 | WF_REL_TAC ‘measure (cexp_size o SND)’ 54 | \\ gvs [LENGTH_EQ_NUM_compute,PULL_EXISTS,cexp_size_eq,list_size_def,any_el_def] 55 | End 56 | 57 | Triviality push_app_unit_test: 58 | push_app_unit 0 (App AppOp [Let NONE (Var w) (Lam NONE (Var v)); Unit]) = 59 | Let NONE (Var w) (Var v) 60 | Proof 61 | EVAL_TAC 62 | QED 63 | 64 | Definition optimise_app_unit_def: 65 | optimise_app_unit do_it x = 66 | if do_it then push_app_unit 0 x else x 67 | End 68 | 69 | val _ = export_theory (); 70 | -------------------------------------------------------------------------------- /compiler/backend/passes/state_namesScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Definition of compilation that inserts names for Lam NONE and 3 | replaces HandleApp by a Handle and an App. 4 | *) 5 | 6 | open HolKernel Parse boolLib bossLib BasicProvers dep_rewrite; 7 | open stringTheory optionTheory sumTheory pairTheory listTheory; 8 | open state_cexpTheory state_cexpTheory mlstringTheory; 9 | 10 | val _ = new_theory "state_names"; 11 | 12 | val _ = set_grammar_ancestry ["state_cexp"]; 13 | 14 | Overload str_prefix = “strlit "ignore"” 15 | Overload str_prefix_len = (EVAL “strlen str_prefix” |> concl |> rand); 16 | 17 | Definition max_name_def: 18 | max_name (v:mlstring) = 19 | if isPrefix str_prefix v then 20 | (strlen v + 1) - str_prefix_len 21 | else 0 22 | End 23 | 24 | Triviality max_name_test: 25 | max_name (strlit "hello") = 0 ∧ 26 | max_name (strlit "ignore") = 1 ∧ 27 | max_name (strlit "ignore'") = 2 28 | Proof 29 | EVAL_TAC 30 | QED 31 | 32 | Definition make_name_def: 33 | make_name n = str_prefix ^ concat (REPLICATE n (strlit "'")) 34 | End 35 | 36 | Definition list_max_def: 37 | list_max [] = 0:num ∧ 38 | list_max (n::ns) = MAX n (list_max ns) 39 | End 40 | 41 | Definition give_names_def: 42 | give_names ((Var v):cexp) = 43 | (Var v, max_name v) ∧ 44 | give_names (Lam vn x) = 45 | (let (y,n) = give_names x in 46 | case vn of 47 | | NONE => (Lam (SOME (make_name n)) y, n) 48 | | _ => (Lam vn y, n)) ∧ 49 | give_names (Let vn x y) = 50 | (let (x',m) = give_names x in 51 | let (y',n) = give_names y in 52 | let k = MAX n m in 53 | case vn of 54 | | NONE => (Let (SOME (make_name n)) x' y', k) 55 | | _ => (Let vn x' y', k)) ∧ 56 | give_names (App op xs) = 57 | (let res = MAP give_names xs in 58 | (App op (MAP FST res), list_max (MAP SND res))) ∧ 59 | give_names (Handle x t y) = 60 | (let (x',m) = give_names x in 61 | let (y',n) = give_names y in 62 | (Handle x' t y', MAX n m)) ∧ 63 | give_names (HandleApp x y) = 64 | (let (x',m) = give_names x in 65 | let (y',n) = give_names y in 66 | let nm = make_name m in 67 | (Handle y' nm (App AppOp [x'; Var nm]), MAX n m)) ∧ 68 | give_names (If x y z) = 69 | (let (x',m) = give_names x in 70 | let (y',n) = give_names y in 71 | let (z',k) = give_names z in 72 | (If x' y' z', MAX n (MAX m k))) ∧ 73 | give_names (Raise x) = 74 | (let (x',m) = give_names x in 75 | (Raise x', m)) ∧ 76 | give_names (Letrec fs d) = 77 | (let res = MAP (λx. case x of (_,_,y) => give_names y) fs in 78 | let rs = MAP2 (λ(a,b,_) (x,_). (a,b,x)) fs res in 79 | let n = list_max (MAP SND res) in 80 | let (e,m) = give_names d in 81 | (Letrec rs e, MAX n m)) ∧ 82 | give_names (Case v rows d) = 83 | (let res = MAP (λ(_,_,x). give_names x) rows in 84 | let rs = MAP2 (λ(a,b,_) (x,_). (a,b,x)) rows res in 85 | let n = list_max (max_name v :: MAP SND res) in 86 | case d of 87 | | NONE => (Case v rs d, n) 88 | | SOME (a,e) => 89 | let (e1,n1) = give_names e in 90 | (Case v rs (SOME (a,e1)), MAX n n1)) 91 | Termination 92 | WF_REL_TAC ‘measure cexp_size’ 93 | End 94 | 95 | Definition give_all_names_def: 96 | give_all_names e = FST (give_names e) 97 | End 98 | 99 | val _ = export_theory (); 100 | -------------------------------------------------------------------------------- /compiler/backend/passes/tests/Holmakefile: -------------------------------------------------------------------------------- 1 | INCLUDES = ../ \ 2 | ../../../parsing/sexp/ 3 | -------------------------------------------------------------------------------- /compiler/backend/passes/tests/pure_inline_testScript.sml: -------------------------------------------------------------------------------- 1 | 2 | open HolKernel Parse boolLib bossLib term_tactic; 3 | open arithmeticTheory; 4 | open intLib pure_printTheory pure_printLib; 5 | open pure_inline_cexpTheory pure_letrec_spec_cexpTheory; 6 | 7 | val _ = new_theory "pure_inline_test"; 8 | 9 | val toMLstring = stringLib.fromMLstring o dest_QUOTE; 10 | 11 | val example_paper_partially_specialised = toMLstring ` 12 | (letrec 13 | (map 14 | (lam (f lst) 15 | (case lst temp 16 | ((((Nil) (cons Nil)) 17 | ((Cons x xs) (cons Cons (app f x) (app map f xs)))) 18 | . NONE)))) 19 | (let f (lam (v) (+ v (int 1))) 20 | (letrec 21 | (map1 22 | (lam (lst) 23 | (case lst temp 24 | ((((Nil) (cons Nil)) 25 | ((Cons x xs) (cons Cons (app f x) (app map1 f xs)))) 26 | . NONE)))) 27 | map1)))`; 28 | 29 | val example_paper_partially_specialised_cexp = “parse_cexp ^example_paper_partially_specialised” 30 | |> EVAL |> concl |> rand; 31 | 32 | val inline_example_paper_partially_specialised = 33 | EVAL “inline_all 5 (tree_size_heuristic 100) ^example_paper_partially_specialised_cexp” |> 34 | concl |> 35 | rand |> 36 | print_cexp; 37 | 38 | val example_paper = toMLstring ` 39 | (letrec 40 | (map (lam (f lst) 41 | (case lst temp 42 | ((((Nil) (cons Nil)) 43 | ((Cons (x xs)) (cons Cons (app f x) (app map f xs)))) . NONE)))) 44 | 45 | (app map (lam (v) (+ v (int 1)))))`; 46 | 47 | val example_paper_cexp = “parse_cexp ^example_paper” 48 | |> EVAL |> concl |> rand; 49 | 50 | val inline_example_paper = 51 | EVAL “inline_all 5 (tree_size_heuristic 100) ^example_paper_cexp” |> 52 | concl |> 53 | rand |> 54 | print_cexp; 55 | 56 | val example_foldr_sum = toMLstring ` 57 | (letrec 58 | (foldr (lam (f x lst) 59 | (case lst temp 60 | ((((Nil) x) 61 | ((Cons (y ys)) (app f y (app foldr f x ys)))) . NONE)))) 62 | 63 | (app foldr (lam (v w) (+ v w)) (int 0)))`; 64 | 65 | val example_foldr_sum_cexp = “parse_cexp ^example_foldr_sum” 66 | |> EVAL |> concl |> rand; 67 | 68 | val inline_example_foldr_sum = 69 | EVAL “inline_all 5 (tree_size_heuristic 100) ^example_foldr_sum_cexp” |> 70 | concl |> 71 | rand |> 72 | print_cexp; 73 | 74 | val map_def = toMLstring ` 75 | (lam (f lst) 76 | (case lst temp 77 | ((((Nil) (cons Nil)) 78 | ((Cons (x xs)) (cons Cons (app f x) (app map f xs)))) . NONE)))`; 79 | 80 | val map_def_cexp = “parse_cexp ^map_def” 81 | |> EVAL |> concl |> rand; 82 | 83 | val specialise_map_def = 84 | EVAL “specialise «map» ^map_def_cexp” |> 85 | concl |> 86 | rand |> 87 | rand |> 88 | print_cexp; 89 | 90 | val mapfy_def = toMLstring ` 91 | (lam (f lst y) 92 | (case lst temp 93 | ((((Nil) (cons Nil)) 94 | ((Cons (x xs)) (cons Cons (app f x y) (app mapfy f xs y)))) . NONE)))`; 95 | 96 | val mapfy_def_cexp = “parse_cexp ^mapfy_def” 97 | |> EVAL |> concl |> rand; 98 | 99 | val specialise_mapfy_def = 100 | EVAL “specialise «mapfy» ^mapfy_def_cexp” |> 101 | concl |> 102 | rand |> 103 | rand |> 104 | print_cexp; 105 | 106 | val sum_letrec = toMLstring ` 107 | (letrec 108 | (sum (lam (lst) 109 | (case lst temp 110 | ((((Nil) (int 0)) 111 | ((Cons (x xs)) (+ x (app sum xs)))) . NONE)))) 112 | 113 | (app sum (cons Cons (int 1) (cons Cons (int 2) (cons Cons (int 3) (cons Nil))))))`; 114 | 115 | val sum_letrec_cexp = “parse_cexp ^sum_letrec” 116 | |> EVAL |> concl |> rand; 117 | 118 | val inline_sum_letrec = 119 | EVAL “inline_all 5 (tree_size_heuristic 100) ^sum_letrec_cexp” |> 120 | concl |> 121 | rand |> 122 | print_cexp; 123 | 124 | Definition example_1_def: 125 | example_1 = parse_cexp "(let x (int 7) (lam (m) (app m x)))" 126 | End 127 | 128 | val inline_example_1 = 129 | EVAL “inline_all 2 (tree_size_heuristic 100) example_1” |> 130 | concl |> 131 | rand |> 132 | print_cexp 133 | 134 | Definition example_2_def: 135 | example_2 = parse_cexp "(let f (lam (x) (+ x (int 5))) (let y (app f (int 1)) (+ 1 y)))" 136 | End 137 | 138 | val inline_example_2 = 139 | EVAL “inline_all 2 (tree_size_heuristic 100) example_2” |> 140 | concl |> 141 | rand |> 142 | print_cexp 143 | 144 | Definition example_3_def: 145 | example_3 = parse_cexp "(letrec (map (lam (f) (lam (lst) (case lst temp ((((nil) nil) ((con (x xs)) (app (app (cons con) (app f x)) (app (app map f) xs)))) . NONE))))) (let foo (lam (v) (+ v (int 1))) (app map foo)))" 146 | End 147 | 148 | val inline_example_3 = 149 | EVAL “inline_all 2 (tree_size_heuristic 100) example_3” |> 150 | concl |> 151 | rand |> 152 | print_cexp 153 | 154 | Definition example_4_def: 155 | example_4 = parse_cexp "(let f (lam (x) (+ x (int 5))) (app f (int 1)))" 156 | End 157 | 158 | val inline_example_4 = 159 | EVAL “inline_all 2 (tree_size_heuristic 100) example_4” |> 160 | concl |> 161 | rand |> 162 | print_cexp 163 | 164 | Definition example_5_def: 165 | example_5 = parse_cexp "(letrec (map (lam (f) (lam (lst) (case lst temp ((((nil) nil) ((con (x xs)) (app (app (cons con) (app f x)) (app (app map f) xs)))) . NONE))))) (app map (lam (v) (+ v (int 1)))))" 166 | End 167 | 168 | val _ = 169 | EVAL “example_5” |> print_thm 170 | 171 | val inline_example_5 = 172 | EVAL “inline_all 1 (tree_size_heuristic 100) example_5” |> 173 | concl |> 174 | rand |> 175 | print_cexp 176 | 177 | val _ = export_theory(); 178 | -------------------------------------------------------------------------------- /compiler/backend/passes/thunk_let_forceScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Optimisation pass that turns Force (Var v) into Var w under 3 | Let (SOME w) (Force (Var v)). 4 | *) 5 | 6 | open HolKernel Parse boolLib bossLib pairTheory listTheory; 7 | open thunk_cexpTheory mlstringTheory; 8 | 9 | val _ = new_theory "thunk_let_force"; 10 | 11 | Definition d_Var_def[simp]: 12 | d_Var (Var n : thunk_cexp$cexp) = SOME n ∧ 13 | d_Var _ = NONE 14 | End 15 | 16 | Definition d_Force_Var_def: 17 | d_Force_Var v (Force x) = 18 | (case d_Var x of NONE => NONE | SOME n => if n ≠ v then SOME n else NONE) ∧ 19 | d_Force_Var v _ = NONE 20 | End 21 | 22 | Definition can_keep_def: 23 | can_keep m (a,b) ⇔ m ≠ a ∧ m ≠ b:mlstring 24 | End 25 | 26 | Definition can_keep_list_def: 27 | can_keep_list ms (a,b) ⇔ ~MEM a ms ∧ ~MEM (b:mlstring) ms 28 | End 29 | 30 | Definition let_force_def: 31 | let_force (m:(mlstring # mlstring) list) ((Var v):thunk_cexp$cexp) = Var v:thunk_cexp$cexp∧ 32 | let_force m (Let opt x y) = 33 | (case opt of 34 | | NONE => Let opt (let_force m x) (let_force m y) 35 | | SOME v => 36 | case d_Force_Var v x of 37 | | NONE => Let opt (let_force m x) (let_force (FILTER (can_keep v) m) y) 38 | | SOME w => 39 | let m1 = FILTER (can_keep v) m in 40 | case ALOOKUP m w of 41 | | SOME t => Let opt (Var t) (let_force m1 y) 42 | | NONE => Let opt x (let_force ((w,v)::m1) y)) ∧ 43 | let_force m (Lam vs x) = Lam vs (let_force (FILTER (can_keep_list vs) m) x) ∧ 44 | let_force m (App x xs) = App (let_force m x) (MAP (let_force m) xs) ∧ 45 | let_force m (Delay x) = Delay (let_force m x) ∧ 46 | let_force m (Force x) = 47 | (case d_Var x of 48 | | NONE => Force (let_force m x) 49 | | SOME v => case ALOOKUP m v of 50 | | NONE => Force (let_force m x) 51 | | SOME t => Var t) ∧ 52 | let_force m (Letrec fs x) = 53 | (let m1 = FILTER (can_keep_list (MAP FST fs)) m in 54 | Letrec (MAP (λ(n,x). (n,let_force m1 x)) fs) (let_force m1 x)) ∧ 55 | let_force m (Case v rows d) = 56 | Case v (MAP (λ(n,p,x). (n,p,let_force (FILTER (can_keep_list p) m) x)) rows) 57 | (case d of NONE => NONE | SOME (a,e) => SOME (a,let_force m e)) ∧ 58 | let_force m (Prim p xs) = Prim p (MAP (let_force m) xs) ∧ 59 | let_force m (Monad mop xs) = Monad mop (MAP (let_force m) xs) 60 | Termination 61 | WF_REL_TAC ‘measure $ cexp_size o SND’ 62 | End 63 | 64 | Definition simp_let_force_def: 65 | simp_let_force do_it e = if do_it then let_force [] e else e 66 | End 67 | 68 | val _ = export_theory (); 69 | -------------------------------------------------------------------------------- /compiler/backend/passes/thunk_to_envScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Definition of thunk_to_env compiler pass. 3 | *) 4 | 5 | open HolKernel Parse boolLib bossLib term_tactic monadsyntax; 6 | open stringTheory optionTheory sumTheory pairTheory listTheory; 7 | open thunk_cexpTheory env_cexpTheory; 8 | 9 | val _ = new_theory "thunk_to_env"; 10 | 11 | val _ = set_grammar_ancestry ["thunk_cexp", "env_cexp"] 12 | 13 | Definition get_arg_def: 14 | get_arg n [] = env_cexp$Prim (Cons (strlit "")) [] ∧ 15 | get_arg n (x::xs) = if n = 0:num then x else get_arg (n-1) xs 16 | End 17 | 18 | Definition remove_Delay_def[simp]: 19 | remove_Delay (env_cexp$Delay x) = x ∧ 20 | remove_Delay y = y 21 | End 22 | 23 | Definition op_to_env_def: 24 | op_to_env (thunk_cexp$AtomOp a) = env_cexp$AtomOp a ∧ 25 | op_to_env (Cons n) = Cons n 26 | End 27 | 28 | Definition to_env_def: 29 | to_env ((Var v):thunk_cexp$cexp) = Var v:env_cexp$cexp ∧ 30 | to_env (Let opt x y) = Let opt (to_env x) (to_env y) ∧ 31 | to_env (Lam vs x) = Lams vs (to_env x) ∧ 32 | to_env (App x xs) = Apps (to_env x) (MAP to_env xs) ∧ 33 | to_env (Delay x) = Delay (to_env x) ∧ 34 | to_env (Force x) = Force (to_env x) ∧ 35 | to_env (Letrec fs x) = Letrec (REVERSE (MAP (λ(n,x). (n,to_env x)) fs)) (to_env x) ∧ 36 | to_env (Case v rows d) = Case v (MAP (λ(n,p,x). (n,p,to_env x)) rows) 37 | (case d of NONE => NONE | SOME (a,e) => SOME (a,to_env e)) ∧ 38 | to_env (Prim p xs) = Prim (op_to_env p) (MAP to_env xs) ∧ 39 | to_env (Monad mop xs) = 40 | let ys = MAP to_env xs in 41 | let y0 = get_arg 0 ys in 42 | let y1 = get_arg 1 ys in 43 | let y2 = get_arg 2 ys in 44 | case mop of 45 | | Ret => Ret y0 46 | | Raise => Raise y0 47 | | Bind => Bind y0 y1 48 | | Handle => Handle y0 y1 49 | | Act => Act y0 50 | | Length => Length y0 51 | | Alloc => Alloc y0 y1 52 | | Deref => Deref y0 y1 53 | | Update => Update y0 y1 y2 54 | Termination 55 | WF_REL_TAC ‘measure cexp_size’ 56 | End 57 | 58 | val _ = export_theory (); 59 | -------------------------------------------------------------------------------- /compiler/binary/Holmakefile: -------------------------------------------------------------------------------- 1 | INCLUDES = ../../language \ 2 | .. \ 3 | ../backend \ 4 | ../backend/passes \ 5 | ../../meta-theory \ 6 | $(CAKEMLDIR)/basis/pure \ 7 | $(CAKEMLDIR)/basis \ 8 | $(CAKEMLDIR)/examples \ 9 | $(CAKEMLDIR)/translator \ 10 | $(CAKEMLDIR)/compiler \ 11 | $(CAKEMLDIR)/cv_translator \ 12 | $(HOLDIR)/examples/formal-languages/context-free \ 13 | $(HOLDIR)/examples/algorithms \ 14 | $(HOLDIR)/examples/algorithms/unification/triangular/first-order 15 | 16 | ifdef POLY 17 | HOLHEAP = $(CAKEMLDIR)/cv_translator/cake_compile_heap 18 | endif 19 | -------------------------------------------------------------------------------- /compiler/binary/pure_compilerCompileScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Compiles the PureCake compiler using the CakeML compiler 3 | *) 4 | 5 | open preamble pure_compilerProgTheory 6 | eval_cake_compile_x64Lib 7 | eval_cake_compile_arm8Lib 8 | 9 | val _ = new_theory "pure_compilerCompile" 10 | 11 | Theorem pure_compiler_compiled_x64 = 12 | eval_cake_compile_x64 "x64_" pure_compiler_prog_def "pure.S"; 13 | 14 | Theorem pure_compiler_compiled_arm8 = 15 | eval_cake_compile_arm8 "arm8_" pure_compiler_prog_def "pure_arm8.S"; 16 | 17 | val _ = export_theory (); 18 | -------------------------------------------------------------------------------- /compiler/binary/pure_compilerProgScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Translation of top-level pure-to-cake compiler function. 3 | *) 4 | open basis 5 | mlstringTheory 6 | pure_backendProgTheory 7 | pure_frontendProgTheory; 8 | 9 | val _ = new_theory "pure_compilerProg"; 10 | 11 | val _ = set_grammar_ancestry ["pure_frontendProg", "mlstring"]; 12 | 13 | val _ = translation_extends "pure_frontendProg"; 14 | 15 | val _ = (max_print_depth := 30); 16 | 17 | val res = translate pure_inferenceTheory.to_option_def; 18 | val res = translate pure_compilerTheory.compile_def; 19 | 20 | val res = translate pure_comp_confTheory.bool_flags_def; 21 | val res = translate pure_comp_confTheory.num_flags_def; 22 | val res = translate pure_comp_confTheory.num_flag_ok_def; 23 | val res = translate (pure_comp_confTheory.check_flags_def 24 | |> REWRITE_RULE [ml_translatorTheory.MEMBER_INTRO]); 25 | val res = translate pure_comp_confTheory.get_num_flag_def; 26 | val res = translate pure_comp_confTheory.read_cline_args_def; 27 | 28 | 29 | Definition main_function_def: 30 | main_function cl s = 31 | case read_cline_args cl of 32 | | INR err_msg => err_msg 33 | | INL c => 34 | case pure_compiler$compile c (explode s) of 35 | | NONE => strlit "ERROR" 36 | | SOME s => implode s 37 | End 38 | 39 | val _ = (next_ml_names := ["main_function"]); 40 | val res = translate main_function_def; 41 | 42 | val _ = type_of “main_function” = “:mlstring list -> mlstring -> mlstring” 43 | orelse failwith "The main_function has the wrong type."; 44 | 45 | val main = process_topdecs 46 | `print (main_function (CommandLine.arguments()) 47 | (TextIO.inputAll TextIO.stdIn));`; 48 | 49 | val prog = 50 | get_ml_prog_state () 51 | |> ml_progLib.clean_state 52 | |> ml_progLib.remove_snocs 53 | |> ml_progLib.get_thm 54 | |> REWRITE_RULE [ml_progTheory.ML_code_def] 55 | |> concl |> rator |> rator |> rand 56 | |> (fn tm => “^tm ++ ^main”) 57 | |> EVAL |> concl |> rand 58 | 59 | Definition pure_compiler_prog_def: 60 | pure_compiler_prog = ^prog 61 | End 62 | 63 | val _ = export_theory (); 64 | -------------------------------------------------------------------------------- /compiler/parsing/.gitignore: -------------------------------------------------------------------------------- 1 | parsing-selftest.log 2 | -------------------------------------------------------------------------------- /compiler/parsing/Holmakefile: -------------------------------------------------------------------------------- 1 | ifndef CAKEMLDIR 2 | CAKEMLDIR = $(HOME)/cakeml/master 3 | endif 4 | 5 | INCLUDES = $(HOLDIR)/examples/formal-languages/context-free \ 6 | $(CAKEMLDIR)/semantics \ 7 | $(CAKEMLDIR)/basis/pure \ 8 | ../backend/languages/ \ 9 | ../../typing ../backend/passes 10 | 11 | HOLHEAP = $(CAKEMLDIR)/misc/cakeml-heap 12 | 13 | all: $(DEFAULT_TARGETS) selftest.exe parsing-selftest.log 14 | 15 | .PHONY: all 16 | 17 | selftest.exe: selftest.uo 18 | $(HOLMOSMLC) -o $@ $< 19 | 20 | EXTRA_CLEANS = selftest.exe parsing-selftest.log 21 | 22 | parsing-selftest.log: selftest.exe 23 | $(tee ./$<,$@) 24 | -------------------------------------------------------------------------------- /compiler/parsing/cases-algo.ML: -------------------------------------------------------------------------------- 1 | structure cases = 2 | struct 3 | 4 | datatype pat = pv of string | pc of string * pat list | pUS 5 | 6 | datatype exp = 7 | eLet of string * string * exp | eBase of int | eNoMatch | 8 | eMatch of string * (pat * exp) list 9 | 10 | 11 | type problem = ((string * pat) list * exp) list 12 | 13 | fun A(p1,p2) = pc("Add", [p1, p2]) 14 | fun M(p1,p2) = pc("Mul", [p1, p2]) 15 | fun S p = pc ("Succ", [p]) 16 | val Z = pc ("Zero", []) 17 | 18 | val jjeg1:problem = 19 | [([("a", A(Z, Z))], eBase 1), 20 | ([("a", M(Z, pv "X"))], eBase 2), 21 | ([("a", A(S(pv "X"), pv "Y"))], eBase 3), 22 | ([("a", M(pv "X", Z))], eBase 4), 23 | ([("a", M(A(pv "X", pv "Y"), pv "Z"))], eBase 5), 24 | ([("a", A(pv "X", Z))], eBase 6), 25 | ([("a", pv "X")], eBase 7)] 26 | 27 | fun push_var (eqns, rhs) = 28 | let fun foldthis (eqn, (eqns, rhs)) = 29 | case eqn of 30 | (v, pv pnm) => (eqns, eLet (pnm,v,rhs)) 31 | | _ => (eqn::eqns, rhs) 32 | val (eqs', rhs') = List.foldl foldthis ([],rhs) eqns 33 | in 34 | (List.rev eqs', rhs') 35 | end 36 | 37 | fun push_vars (p : problem) : problem = map push_var p 38 | 39 | fun pat_arity (pc (_, args)) = List.length args 40 | | pat_arity _ = raise Fail "pat_arity on p. variable" 41 | fun pat_con (pc(cnm, _)) = cnm 42 | | pat_con _ = raise Fail "pat_con on p. variable" 43 | 44 | fun pluck P [] = NONE 45 | | pluck P (h::t) = if P h then SOME (h, t) 46 | else Option.map (fn (x,t) => (x, h::t)) (pluck P t) 47 | 48 | 49 | fun lift testvar cnm vars (p : problem) : problem * problem = 50 | let 51 | fun lift1 (c as (eqns, rhs), (A,B)) = 52 | case pluck (fn (tv, p) => tv = testvar) eqns of 53 | NONE => (c::A, c::B) 54 | | SOME ((_, pc(cnm', args')), other_tests : (string * pat) list) => 55 | if cnm' = cnm then 56 | ((ListPair.zip (vars, args') @ other_tests, rhs) :: A, B) 57 | else (A, c::B) 58 | | SOME ((_, pv _), _) => raise Fail "lift1: found pat-var binding" 59 | val (A,B) = List.foldl lift1 ([], []) p 60 | in 61 | (List.rev A, List.rev B) 62 | end 63 | 64 | fun bumpany k e m = 65 | case Binarymap.peek(m,k) of 66 | NONE => Binarymap.insert(m,k,(1,e)) 67 | | SOME (c,e0) => Binarymap.insert(m,k,(c+1,e0)) 68 | fun bumpex k m = 69 | case Binarymap.peek(m,k) of 70 | NONE => m 71 | | SOME (c,e) => Binarymap.insert(m,k,(c+1,e)) 72 | 73 | fun maxcount M = 74 | let fun foldthis (k, ce, NONE) = SOME ce 75 | | foldthis (k, ce as (c,e), A as SOME (c0,e0)) = 76 | if c > c0 then SOME ce else A 77 | in 78 | Binarymap.foldl foldthis NONE M 79 | end 80 | 81 | fun heuristic eqns rest = 82 | let val M0 = Binarymap.mkDict (pair_compare(String.compare, String.compare)) 83 | fun foldthis (e as (vnm, pc(cnm, _)), M) = bumpany (vnm,cnm) e M 84 | | foldthis (_, M) = M 85 | val M1 = List.foldl foldthis M0 eqns 86 | fun foldthis2 (e as (vnm, pc(cnm, _)), M) = bumpex (vnm,cnm) M 87 | | foldthis2 (_, M) = M 88 | val M2 = List.foldl 89 | (fn ((es,exp), A) => List.foldl foldthis2 A es) M1 rest 90 | in 91 | #2 (valOf (maxcount M2)) 92 | end 93 | 94 | 95 | fun get_firstbranch (p0 : problem) = 96 | let val p = push_vars p0 97 | in 98 | case p of 99 | ([], rhs) :: rest => rhs 100 | | (eqns, rhs) :: rest => 101 | let val (tvar, pat) = heuristic eqns rest 102 | val newvars = 103 | List.tabulate(pat_arity pat, (fn i => tvar ^ Int.toString i)) 104 | val cnm = pat_con pat 105 | val patarg_vector = map pv newvars 106 | val pat1 = pc(cnm, patarg_vector) 107 | val (A, B) = lift tvar cnm newvars p 108 | in 109 | eMatch (tvar, [(pc (cnm, patarg_vector), get_firstbranch A), 110 | (pUS, get_firstbranch B)]) 111 | end 112 | | [] => eNoMatch 113 | end 114 | 115 | fun updlast [] rep = rep 116 | | updlast [h] rep = rep 117 | | updlast (h::t) rep = h::updlast t rep 118 | 119 | fun merge_dumbUS e = 120 | case e of 121 | eMatch (testv1, pes) => 122 | let val pes' = map (apsnd merge_dumbUS) pes 123 | in 124 | case last pes' of 125 | (pUS, eMatch (testv2, uspes)) => 126 | if testv1 = testv2 then 127 | eMatch (testv1, updlast pes' uspes) 128 | else eMatch (testv1, pes') 129 | | _ => eMatch (testv1, pes') 130 | end 131 | | eLet(v1,v2,e) => eLet(v1,v2,merge_dumbUS e) 132 | | _ => e 133 | 134 | val jjeg2 : problem = 135 | [([("a", A (A(pv "X", pv "Y"), Z))], eBase 1), 136 | ([("a", A (M(pv "X", pv "Y"), Z))], eBase 2), 137 | ([("a", A (pv "X", M(pv "Y", pv "Z")))], eBase 3), 138 | ([("a", A (pv "X", A(pv "Y", pv "Z")))], eBase 4), 139 | ([("a", A (pv "X", Z))], eBase 5)] 140 | 141 | val sol2 = merge_dumbUS $ get_firstbranch jjeg2 142 | 143 | fun uniq_pfx p slist = 144 | case List.filter (String.isPrefix p) slist of 145 | [] => p 146 | | ss => uniq_pfx (p ^ "%") ss 147 | 148 | end 149 | -------------------------------------------------------------------------------- /compiler/parsing/gram.txt: -------------------------------------------------------------------------------- 1 | TyBase ::= capIDᵍᵉ | lcIdᵍᵉ 2 | | "("ᵍᵉ (Tyᵍᵉ (","ᵍᵉ Tyᵍᵉ)꙳)? ")"ᵍᵉ 3 | | "["ᵍᵉ Tyᵍᵉ "]"ᵍᵉ 4 | TyApp ::= (TyBaseᵍᵉ)⁺ 5 | Ty ::= TyAppᵍᵉ ("->"ᵍᵉ TyAppᵍᵉ)꙳ 6 | 7 | TyConDecl ::= capIdᵍᵉ (TyBaseᵍᵉ)꙳ 8 | 9 | Decl ::= lcId⁼ "::"ᵍᵗ Tyᵍᵗ 10 | | "data"⁼ capIDᵍᵗ (lcIdᵍᵗ)꙳ "="ᵍᵗ TyConDeclᵍᵗ ("|"ᵍᵗ TyConDeclᵍᵗ)꙳ 11 | | Exp⁼ "="ᵍᵗ Expᵍᵗ 12 | Decls ::= (Decl⁼)꙳ 13 | 14 | APat ::= lcId⁼ | Lit⁼ 15 | 16 | Exp ::= "\"ᵍᵉ (APatᵍᵉ)⁺ "->"ᵍᵉ Expᵍᵉ 17 | | "if"ᵍᵉ Expᵍᵉ "then"ᵍᵉ Expᵍᵉ "else"ᵍᵉ Expᵍᵉ 18 | | IExpᵍᵉ 19 | 20 | IExp ::= FExpᵍᵉ (Opᵍᵉ FExpᵍᵉ)꙳ 21 | Op ::= "$"⁼ | "$!"⁼ | "`seq`"⁼ | "+"⁼ | "*"⁼ | ":"⁼ 22 | 23 | FExp ::= AExpᵍᵉ (AExpᵍᵉ)꙳ 24 | AExp ::= Lit⁼ 25 | | "("⁼ (Expᵍᵉ (","ᵍᵉ Expᵍᵉ)꙳)? ")"ᵍᵉ 26 | | "["⁼ (Expᵍᵉ (","ᵍᵉ Expᵍᵉ)꙳)? "]"ᵍᵉ 27 | | lcId⁼ 28 | -------------------------------------------------------------------------------- /compiler/parsing/paper.hs: -------------------------------------------------------------------------------- 1 | read_arg1 = Act (#(cline_arg) " ") 2 | 3 | str_elem :: String -> Int -> Int 4 | str_elem s i = #(__Elem) s i 5 | 6 | strlen :: String -> Int 7 | strlen s = #(__Len) s 8 | 9 | numbers :: [Int] 10 | numbers = 11 | let num n = n : num (n + 1) 12 | in num 0 13 | 14 | take :: Int -> [a] -> [a] 15 | take n l = 16 | if n == 0 then [] 17 | else 18 | case l of 19 | [] -> [] 20 | h:t -> h : take (n - 1) t 21 | 22 | factA :: Int -> Int -> Int 23 | factA a n = 24 | if n < 2 then a 25 | else factA (a * n) (n - 1) 26 | 27 | map :: (a -> b) -> [a] -> [b] 28 | map f l = 29 | case l of 30 | [] -> [] 31 | h:t -> f h : map f t 32 | 33 | factorials :: [Int] 34 | factorials = map (factA 1) numbers 35 | 36 | fromStringI :: Int -> Int -> Int -> String -> Int 37 | fromStringI i limit acc s = 38 | if limit == i then acc 39 | else if limit < i then acc 40 | else 41 | fromStringI (i + 1) limit (acc * 10 + (str_elem s i - 48)) s 42 | 43 | fromString :: String -> Int 44 | fromString s = fromStringI 0 (strlen s) 0 s 45 | 46 | -- delete this, and defs of div and mod below it when 47 | -- new binary built 48 | x < y = 49 | let testi i = if x + i == y then True 50 | else if y + i == x then False 51 | else testi (i + 1) 52 | in 53 | if x == y then False else testi 1 54 | 55 | div m n = if m < n then 0 else 1 + div (m - n) n 56 | mod m n = if m < n then m else mod (m - n) n 57 | 58 | f $ x = f x 59 | 60 | s1 ++ s2 = #(__Concat) s1 s2 61 | 62 | implode l = 63 | case l of 64 | [] -> "" 65 | h:t -> #(__Implode) h ++ implode t 66 | 67 | toString0 :: Int -> [Int] 68 | toString0 i = 69 | if i == 0 then [] 70 | else (mod i 10 + 48) : toString0 (div i 10) 71 | 72 | reverse :: [a] -> [a] 73 | reverse l = 74 | let revA a l = 75 | case l of [] -> a 76 | h:t -> revA (h:a) t 77 | in 78 | revA [] l 79 | 80 | 81 | toString :: Int -> String 82 | toString i = 83 | if i < 0 then "-" ++ (implode $ reverse $ toString0 (0-i)) 84 | else if i == 0 then "0" 85 | else implode $ reverse $ toString0 i 86 | 87 | print s = Act (#(stdout) (s ++ "\n")) 88 | 89 | return v = Ret v 90 | 91 | app :: (a -> IO b) -> [a] -> IO () 92 | app f l = 93 | case l of 94 | [] -> return () 95 | h:t -> do f h 96 | app f t 97 | 98 | main = do 99 | arg1 <- read_arg1 100 | -- fromString == 0 on malformed input 101 | let i = fromString arg1 102 | facts = take i factorials 103 | app (\i -> print $ toString i) facts 104 | -------------------------------------------------------------------------------- /compiler/parsing/pureASTScript.sml: -------------------------------------------------------------------------------- 1 | open HolKernel Parse boolLib bossLib; 2 | 3 | local open stringTheory integerTheory pure_configTheory in end 4 | val _ = new_theory "pureAST"; 5 | 6 | val _ = set_grammar_ancestry ["string", "integer", "pure_config"] 7 | 8 | (* by convention tyOps will be capitalised alpha-idents, or "->", 9 | and tyVars will be lower-case alpha-idents. 10 | 11 | The tyTup constructor should never be applied to a singleton list 12 | *) 13 | Datatype: 14 | tyAST = tyOp string (tyAST list) 15 | | tyVar string 16 | | tyTup (tyAST list) 17 | End 18 | 19 | Overload boolTy = “tyOp "Bool" []”; 20 | Overload intTy = “tyOp "Integer" []” 21 | Overload listTy = “λty. tyOp "[]" [ty]” 22 | Overload funTy = “λd r. tyOp "Fun" [d; r]” 23 | 24 | Datatype: 25 | litAST = litInt int | litString string 26 | End 27 | 28 | Datatype: 29 | patAST = patVar string 30 | | patApp string (patAST list) 31 | | patTup (patAST list) 32 | | patLit litAST 33 | | patUScore 34 | End 35 | 36 | Datatype: 37 | expAST = expVar string 38 | | expCon string (expAST list) 39 | | expOp pure_config$atom_op (expAST list) 40 | | expTup (expAST list) 41 | | expApp expAST expAST 42 | | expAbs patAST expAST 43 | | expIf expAST expAST expAST 44 | | expLit litAST 45 | | expLet (expdecAST list) expAST 46 | | expDo (expdostmtAST list) expAST 47 | | expCase expAST ((patAST # expAST) list); 48 | expdecAST = expdecTysig string tyAST 49 | | expdecPatbind patAST expAST 50 | | expdecFunbind string (patAST list) expAST ; 51 | expdostmtAST = expdostmtExp expAST 52 | | expdostmtBind patAST expAST 53 | | expdostmtLet (expdecAST list) 54 | End 55 | 56 | Theorem better_expAST_induction = 57 | TypeBase.induction_of “:expAST” 58 | |> Q.SPECL [‘eP’, ‘dP’, ‘doP’, 59 | ‘λpes. ∀p e. MEM (p,e) pes ⇒ eP e’, 60 | ‘λpe. eP (SND pe)’, 61 | ‘λdds. ∀ds. MEM ds dds ⇒ doP ds’, 62 | ‘λes. ∀e. MEM e es ⇒ eP e’, 63 | ‘λds. ∀d. MEM d ds ⇒ dP d’] 64 | |> SRULE [DISJ_IMP_THM, FORALL_AND_THM, pairTheory.FORALL_PROD, 65 | DECIDE “p ∧ q ⇒ q ⇔ T”] 66 | |> UNDISCH 67 | |> SRULE [Cong (DECIDE “p = p' ∧ (p' ⇒ q = q') ⇒ (p ∧ q ⇔ p' ∧ q')”)] 68 | |> DISCH_ALL 69 | |> Q.GENL [‘eP’, ‘dP’, ‘doP’] 70 | 71 | val _ = add_strliteral_form {ldelim = "‹", inj = “expVar”} 72 | Overload pNIL = “expCon "[]" []” 73 | Overload pCONS = “λe1 e2. expCon "::" [e1;e2]” 74 | val _ = set_mapped_fixity {fixity = Infixr 490,term_name = "pCONS",tok = "::ₚ"} 75 | 76 | val _ = set_fixity "⬝" (Infixl 600) 77 | Overload "⬝" = “expApp” 78 | 79 | Definition strip_comb_def: 80 | strip_comb (expApp f x) = (I ## (λl. l ++ [x])) (strip_comb f) ∧ 81 | strip_comb e = (e, []) 82 | End 83 | 84 | Definition dest_expVar_def: 85 | dest_expVar (expVar s) = SOME s ∧ 86 | dest_expVar _ = NONE 87 | End 88 | 89 | Definition dest_expLet_def: 90 | dest_expLet (expLet ads e) = SOME (ads,e) ∧ 91 | dest_expLet _ = NONE 92 | End 93 | 94 | val _ = add_rule {term_name = "expAbs", fixity = Prefix 1, 95 | block_style = (AroundEachPhrase, (PP.CONSISTENT, 0)), 96 | pp_elements = [TOK "𝝺", TM, TOK "．", BreakSpace(1,2)], 97 | paren_style = OnlyIfNecessary} 98 | 99 | Datatype: 100 | declAST = declTysig string tyAST 101 | | declData string (string list) 102 | ((string # tyAST list) list) 103 | | declFunbind string (patAST list) expAST 104 | | declPatbind patAST expAST 105 | End 106 | 107 | 108 | val _ = export_theory(); 109 | -------------------------------------------------------------------------------- /compiler/parsing/pureNTScript.sml: -------------------------------------------------------------------------------- 1 | open HolKernel Parse boolLib bossLib; 2 | 3 | val _ = new_theory "pureNT"; 4 | 5 | val _ = set_grammar_ancestry ["list"] 6 | 7 | Datatype: 8 | ppegnt = nDecls | nDecl | nTyBase | nTy | nTyConDecl | nTyApp 9 | | nPat | nAPat | nFunRHS 10 | | nExp | nExpEQ | nLSafeExp | nLSafeExpEQ | nIExp | nIExpEQ 11 | | nFExp | nFExpEQ | nFExp2 | nAExp | nAExpEQ 12 | | nLit | nOp 13 | | nEqBindSeq | nEqBindSeq' | nEqBind | nFreeEqBind | nValBinding 14 | | nDoStmt | nDoBlock | nBlockLayout | nDoStmtEQ | nPatAlt | nPatAlts 15 | | nDoStmtSeq | nDoStmtSeqEQ | nDoBlockLayout 16 | End 17 | 18 | val distinct_ths = let 19 | val ntlist = TypeBase.constructors_of ``:ppegnt`` 20 | fun recurse [] = [] 21 | | recurse (t::ts) = let 22 | val eqns = map (fn t' => mk_eq(t,t')) ts 23 | val ths0 = map (SIMP_CONV (srw_ss()) []) eqns 24 | val ths1 = map (CONV_RULE (LAND_CONV (REWR_CONV EQ_SYM_EQ))) ths0 25 | in 26 | ths0 @ ths1 @ recurse ts 27 | end 28 | in 29 | recurse ntlist 30 | end 31 | 32 | Theorem pureNTs_distinct[compute] = LIST_CONJ distinct_ths 33 | 34 | val _ = export_theory(); 35 | -------------------------------------------------------------------------------- /compiler/parsing/pureParseScript.sml: -------------------------------------------------------------------------------- 1 | open HolKernel Parse boolLib bossLib; 2 | 3 | (* supposed to contain all the things *) 4 | 5 | open purePEGTheory cst_to_astTheory ast_to_cexpTheory 6 | open pure_inferenceTheory 7 | 8 | 9 | val _ = new_theory "pureParse"; 10 | 11 | Definition string_to_cst_def: 12 | string_to_cst s = 13 | case ispeg_exec purePEG (nt (INL nDecls) I lrOK) (pure_lexer_impl$lexer_fun s) 14 | lpTOP [] NONE [] done failed 15 | of 16 | Result (Success [] pts _ _ ) => SOME pts 17 | | _ => NONE 18 | End 19 | 20 | val _ = computeLib.add_funs [pure_lexer_implTheory.get_token_def, 21 | listTheory.LIST_REL_def, 22 | ASCIInumbersTheory.s2n_compute, 23 | numposrepTheory.l2n_def] 24 | 25 | 26 | val fact_s = “"f :: Int -> Int\n\ 27 | \f x = if x == 0 then 1 else x * f(x - 1)\n\ 28 | \z = 4\n"” 29 | val fact_cst = EVAL “string_to_cst ^fact_s” 30 | 31 | Definition string_to_asts_def: 32 | string_to_asts s = 33 | do 34 | csts <- string_to_cst s ; 35 | cst <- oHD csts ; 36 | astDecls cst 37 | od 38 | End 39 | 40 | val fact_ast = EVAL “string_to_ast ^fact_s” 41 | 42 | Definition string_to_cexp0_def: 43 | string_to_cexp0 s = 44 | do 45 | asts <- string_to_asts s ; 46 | decls_to_letrec asts 47 | od 48 | End 49 | 50 | Definition string_to_cexp_def: 51 | string_to_cexp s = 52 | do 53 | asts <- string_to_asts s ; 54 | (ce, tysig) <- decls_to_letrec asts ; 55 | assert (closed_under empty ce) ; 56 | assert (cexp_wf ce) ; 57 | assert (NestedCase_free ce) ; 58 | return (ce, tysig) 59 | od 60 | End 61 | 62 | Overload "𝕍" = “λs. Var () s” 63 | Overload "𝕀" = “λi. Prim () (AtomOp (Lit (Int i))) []” 64 | Overload "*" = “λx y. Prim () (AtomOp Mul) [x; y]” 65 | Overload "-" = “λx y. Prim () (AtomOp Sub) [x; y]” 66 | 67 | Theorem fact_cexp = EVAL “string_to_cexp ^fact_s” 68 | 69 | (* doesn't EVAL *) 70 | Definition parse_tcheck_def: 71 | parse_tcheck s = 72 | do 73 | (ce, tysig) <- string_to_cexp s ; 74 | tyresult <- to_option $ 75 | infer_top_level ((I ## K tysig) initial_namespace) () ce ; 76 | return (ce, tyresult) ; 77 | od 78 | End 79 | 80 | val _ = export_theory(); 81 | -------------------------------------------------------------------------------- /compiler/parsing/pureParsingLib.sig: -------------------------------------------------------------------------------- 1 | signature pureParsingLib = 2 | sig 3 | 4 | 5 | val toASTdecls : 'a Portable.frag list -> term list 6 | 7 | end 8 | -------------------------------------------------------------------------------- /compiler/parsing/pureParsingLib.sml: -------------------------------------------------------------------------------- 1 | structure pureParsingLib :> pureParsingLib = 2 | struct 3 | 4 | 5 | local open pureParseTheory in end 6 | val _ = computeLib.add_funs [lexer_funTheory.get_token_def, 7 | listTheory.LIST_REL_def, 8 | ASCIInumbersTheory.s2n_compute, 9 | numposrepTheory.l2n_def] 10 | 11 | val string_to_asts_t = 12 | prim_mk_const{Thy = "pureParse", Name = "string_to_asts"} 13 | 14 | fun toASTdecls q = 15 | let 16 | val s = Portable.quote_to_string (fn _ => "") q 17 | val s_t = stringSyntax.fromMLstring s 18 | val t = mk_comb(string_to_asts_t, s_t) 19 | in 20 | t |> EVAL 21 | |> concl 22 | |> rhs 23 | |> rand 24 | |> listSyntax.dest_list 25 | |> #1 26 | end 27 | 28 | 29 | end 30 | -------------------------------------------------------------------------------- /compiler/parsing/pureTokenUtilsScript.sml: -------------------------------------------------------------------------------- 1 | open HolKernel Parse boolLib bossLib; 2 | 3 | open tokenUtilsTheory 4 | 5 | val _ = new_theory "pureTokenUtils"; 6 | 7 | val _ = set_grammar_ancestry ["tokenUtils"] 8 | val _ = monadsyntax.enable_monadsyntax() 9 | val _ = monadsyntax.enable_monad "option" 10 | 11 | Definition capname_def: 12 | capname nm ⇔ 13 | do 14 | c1 <- oHD nm ; 15 | assert $ isUpper c1 16 | od = SOME () 17 | End 18 | 19 | Definition capname_tok_def: 20 | capname_tok tk <=> 21 | do 22 | s <- destAlphaT tk; 23 | assert $ capname s 24 | od = SOME () 25 | End 26 | 27 | Definition keywords_def: 28 | keywords = ["data"; "where"; "let"; "in"; "if"; "then"; "else"; "do";] 29 | End 30 | 31 | Definition lcname_def: 32 | lcname s ⇔ 33 | do 34 | assert (¬MEM s keywords); 35 | c1 <- oHD s; 36 | assert $ isLower c1 37 | od = SOME () 38 | End 39 | 40 | 41 | Definition lcname_tok_def: 42 | lcname_tok tk <=> 43 | do 44 | s <- destAlphaT tk; 45 | assert $ lcname s 46 | od = SOME () 47 | End 48 | 49 | Definition isSymbolOpT_def: 50 | isSymbolOpT t ⇔ 51 | do 52 | s <- destSymbolT t ; 53 | assert (s ≠ "<-" ∧ s ≠ "::" ∧ s ≠ "->" ∧ s ≠ "`"); 54 | od = SOME () 55 | End 56 | 57 | val _ = export_theory(); 58 | -------------------------------------------------------------------------------- /compiler/parsing/sexp/Holmakefile: -------------------------------------------------------------------------------- 1 | INCLUDES = ../../backend/languages/ $(HOLDIR)/examples/bootstrap 2 | -------------------------------------------------------------------------------- /compiler/parsing/sexp/pure_printLib.sig: -------------------------------------------------------------------------------- 1 | signature pure_printLib = 2 | sig 3 | 4 | include Abbrev 5 | 6 | val dest_QUOTE : term frag list -> string 7 | 8 | (* parsing *) 9 | 10 | val parse_cexp : string -> term 11 | val parse_prog : string -> term 12 | val Cexp : term frag list -> term 13 | val Prog : term frag list -> term 14 | 15 | (* printing *) 16 | 17 | val print_cexp : term -> unit 18 | 19 | end 20 | -------------------------------------------------------------------------------- /compiler/parsing/sexp/pure_printLib.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Library for pretty printing and basic parsing of cexp 3 | *) 4 | structure pure_printLib :> pure_printLib = 5 | struct 6 | 7 | open HolKernel Parse boolLib bossLib; 8 | open pure_printTheory intLib; 9 | 10 | fun dest_QUOTE (q: term frag list) = 11 | let 12 | fun drop_until [] = [] 13 | | drop_until (x::xs) = if x = #")" then xs else drop_until xs; 14 | in 15 | case q of 16 | [QUOTE str] => (String.implode o drop_until o String.explode) str 17 | | _ => failwith "not a single QUOTE" 18 | end; 19 | 20 | fun print_cexp tm = 21 | “str_of ^tm” |> EVAL |> concl |> rand |> stringSyntax.fromHOLstring |> print; 22 | 23 | fun parse_cexp s = 24 | mk_comb(“parse_cexp”,stringLib.fromMLstring s) 25 | |> EVAL |> concl |> rand; 26 | 27 | fun parse_prog s = 28 | mk_comb(“parse_prog”,stringLib.fromMLstring s) 29 | |> EVAL |> concl |> rand; 30 | 31 | val Cexp = parse_cexp o dest_QUOTE 32 | val Prog = parse_prog o dest_QUOTE 33 | 34 | end 35 | -------------------------------------------------------------------------------- /compiler/parsing/sexp/pure_print_testScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | Pretty printing and basic parsing of cexp 3 | *) 4 | open HolKernel Parse boolLib bossLib term_tactic; 5 | open intLib pure_printTheory pure_printLib; 6 | 7 | val _ = new_theory "pure_print_test"; 8 | 9 | val p = Prog ‘ 10 | 11 | (define if 12 | (lam (x y z) (case x temp ((True) y) 13 | ((False) z)))) 14 | 15 | (define even 16 | (lam (n) (app if (= n (int 0)) 17 | (cons True) 18 | (app odd (- n (int 1)))))) 19 | 20 | (define odd 21 | (lam (n) (app if (= n (int 0)) 22 | (cons False) 23 | (app even (- n (int 1)))))) 24 | 25 | (app even (int 8)) 26 | 27 | ’ 28 | 29 | val _ = print_cexp p 30 | 31 | val _ = export_theory(); 32 | -------------------------------------------------------------------------------- /compiler/parsing/test1.hs: -------------------------------------------------------------------------------- 1 | numbers :: [Int] 2 | numbers = 3 | let num n = n : num (n + 1) 4 | in num 0 5 | 6 | -- take :: Int -> [a] -> [a] 7 | -- take n l = 8 | -- if n == 0 then [] 9 | -- else 10 | -- case l of 11 | -- [] -> [] 12 | -- h:t -> h : take (n - 1) t 13 | 14 | factA :: Int -> Int -> Int 15 | factA a n = if n < 2 then a else factA (a * n) (n - 1) 16 | 17 | fact :: Int -> Int 18 | fact = factA 1 19 | 20 | -- map :: (a -> b) -> [a] -> [b] 21 | -- map f l = 22 | -- case l of 23 | -- [] -> [] 24 | -- h:t -> f h : map f t 25 | 26 | factorials :: [Int] 27 | factorials = map fact numbers 28 | 29 | -- head :: [a] -> IO a 30 | -- head l = case l of 31 | -- [] -> raise "Empty" 32 | -- h:t -> return h 33 | 34 | -- ffi_action :: Message -> IO String 35 | -- array_length :: Array a -> IO Int 36 | -- return :: a -> IO a 37 | 38 | str_elem :: String -> Int -> Int 39 | str_elem s i = ord (s !! i) 40 | 41 | strlen :: String -> Int 42 | strlen = length 43 | -------------------------------------------------------------------------------- /compiler/proofs/Holmakefile: -------------------------------------------------------------------------------- 1 | INCLUDES = .. \ 2 | ../../language \ 3 | ../../meta-theory \ 4 | ../../typing \ 5 | ../parsing \ 6 | ../backend/languages \ 7 | ../backend/languages/semantics \ 8 | ../backend/passes \ 9 | ../backend/passes/proofs \ 10 | $(CAKEMLDIR)/compiler/parsing \ 11 | $(HOLDIR)/examples/bootstrap \ 12 | $(CAKEMLDIR)/compiler/backend/proofs 13 | -------------------------------------------------------------------------------- /compiler/proofs/pure_end_to_endProofScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | End-to-end correctness for the PureCake compiler 3 | *) 4 | open HolKernel Parse boolLib bossLib; 5 | open pure_compilerProofTheory backend_itreeProofTheory state_to_cakeProofTheory; 6 | 7 | val _ = new_theory "pure_end_to_endProof"; 8 | 9 | Overload cake_compile = ``backend$compile``; 10 | 11 | Overload target_configs_ok = 12 | ``λconf (mc,ms). backend_config_ok conf ∧ mc_conf_ok mc ∧ mc_init_ok conf mc`` 13 | 14 | Overload code_in_memory = 15 | ``λconf (bytes,bitmaps,c') (mc,ms). 16 | ∃cbspace data_sp. 17 | installed bytes cbspace bitmaps data_sp c'.lab_conf.ffi_names 18 | (backendProof$heap_regs conf.stack_conf.reg_names) 19 | mc c'.lab_conf.shmem_extra ms`` 20 | 21 | Overload prunes = ``λpt mt. ∃ct. itree_rel pt ct ∧ prune ffi_convention F ct mt`` 22 | 23 | Theorem end_to_end_correctness: 24 | compile_to_ast c s = SOME cake ∧ 25 | cake_compile conf cake = SOME code ∧ 26 | target_configs_ok conf m ∧ 27 | code_in_memory conf code m 28 | ⇒ ∃ce ns. string_to_cexp s = SOME (ce,ns) ∧ 29 | prunes (pure_semantics$itree_of (exp_of ce)) (machine_sem_itree m) 30 | Proof 31 | rw[] >> drule pure_compilerProofTheory.compiler_correctness >> 32 | strip_tac >> simp[] >> 33 | PairCases_on `m` >> PairCases_on `code` >> 34 | gvs[ffi_convention_def] >> goal_assum drule >> 35 | irule itree_compile_correct >> gvs[PULL_EXISTS, GSYM ffi_convention_def] >> 36 | rpt $ goal_assum $ drule_at Any >> simp[] 37 | QED 38 | 39 | val _ = export_theory(); 40 | 41 | -------------------------------------------------------------------------------- /compiler/pure_compilerScript.sml: -------------------------------------------------------------------------------- 1 | (* 2 | PureLang compiler: concrete syntax -> CakeML AST 3 | *) 4 | open HolKernel Parse boolLib bossLib term_tactic; 5 | open fixedPointTheory arithmeticTheory listTheory stringTheory alistTheory 6 | optionTheory pairTheory ltreeTheory llistTheory bagTheory dep_rewrite 7 | BasicProvers pred_setTheory relationTheory rich_listTheory finite_mapTheory; 8 | open pure_cexpTheory pure_to_cakeTheory pureParseTheory pure_inferenceTheory 9 | pure_letrec_cexpTheory pure_demands_analysisTheory pure_inline_cexpTheory 10 | fromSexpTheory simpleSexpParseTheory pure_printTheory; 11 | 12 | val _ = set_grammar_ancestry 13 | ["pure_cexp", "pure_to_cake", "pureParse", "pure_inference", 14 | "pure_letrec_cexp", "pure_demands_analysis", 15 | "pure_inline_cexp", "fromSexp", "simpleSexpParse"]; 16 | 17 | val _ = new_theory "pure_compiler"; 18 | 19 | Definition ast_to_string_def: 20 | ast_to_string prog = print_sexp (listsexp (MAP decsexp prog)) 21 | End 22 | 23 | Overload debug_print = ``λs. empty_ffi (implode s)``; 24 | Overload explore_print = 25 | ``λc s. if c.do_explore then debug_print s else ()``; 26 | 27 | 28 | Definition compile_def: 29 | compile c s = 30 | let _ = debug_print "starting..." in 31 | let r = string_to_cexp s in 32 | let _ = debug_print "parsing" in 33 | case r of 34 | | NONE => NONE 35 | | SOME (e,ns) => 36 | let e = transform_cexp c e in 37 | let _ = debug_print "transform_cexp" in 38 | let e = inline_top_level c e in 39 | let _ = debug_print "inlining" in 40 | let _ = explore_print c $ 41 | "after inlining:\n" ++ pure_print$str_of e ++ "\n" in 42 | let i = infer_types ns e in 43 | let _ = debug_print "infer_types" in 44 | case to_option i of 45 | | NONE => NONE 46 | | SOME _ => 47 | let e = clean_cexp c e in 48 | let _ = debug_print "clean_cexp" in 49 | let e = demands_analysis c e in 50 | let _ = debug_print "demands_analysis" in 51 | let _ = explore_print c $ 52 | "after demands:\n" ++ pure_print$str_of e ++ "\n" in 53 | SOME (ast_to_string $ pure_to_cake c ns e) 54 | End 55 | 56 | Definition compile_to_ast_def: 57 | compile_to_ast c s = 58 | case string_to_cexp s of 59 | | NONE => NONE 60 | | SOME (e,ns) => 61 | let e = transform_cexp c e in 62 | let e = inline_top_level c e in 63 | let i = infer_types ns e in 64 | case to_option i of 65 | | NONE => NONE 66 | | SOME _ => 67 | let e = clean_cexp c e in 68 | let e = demands_analysis c e in 69 | SOME (pure_to_cake c ns e) 70 | End 71 | 72 | (********** Alternative phrasings **********) 73 | 74 | Theorem compile_monadically: 75 | compile c s = 76 | do 77 | (e,ns) <- string_to_cexp s ; 78 | e <<- transform_cexp c e ; 79 | e <<- inline_top_level c e ; 80 | to_option $ infer_types ns e ; 81 | e <<- clean_cexp c e ; 82 | e <<- demands_analysis c e ; 83 | return (ast_to_string $ pure_to_cake c ns e) 84 | od 85 | Proof 86 | simp[compile_def]>> EVERY_CASE_TAC >> simp[] 87 | QED 88 | 89 | Definition frontend_def: 90 | frontend c s = 91 | case string_to_cexp s of 92 | | NONE => NONE 93 | | SOME (e,ns) => 94 | let e = transform_cexp c e in 95 | let e = inline_top_level c e in 96 | let i = infer_types ns e in 97 | case to_option i of 98 | | NONE => NONE 99 | | SOME _ => SOME (e,ns) 100 | End 101 | 102 | Theorem compile_to_string: 103 | compile c s = OPTION_MAP ast_to_string $ compile_to_ast c s 104 | Proof 105 | rw[compile_def, compile_to_ast_def] >> 106 | rpt (TOP_CASE_TAC >> gvs[]) 107 | QED 108 | 109 | Theorem compile_to_ast_alt_def: 110 | compile_to_ast c s = 111 | case frontend c s of 112 | | NONE => NONE 113 | | SOME (e,ns) => 114 | let e = clean_cexp c e in 115 | let e = demands_analysis c e in 116 | SOME (pure_to_cake c ns e) 117 | Proof 118 | rw[compile_to_ast_def, frontend_def] >> 119 | rpt (TOP_CASE_TAC >> simp[]) 120 | QED 121 | 122 | val _ = export_theory(); 123 | -------------------------------------------------------------------------------- /examples/.gitignore: -------------------------------------------------------------------------------- 1 | cake 2 | pure 3 | pure.tar.gz 4 | out 5 | benchmark/*.csv 6 | benchmark/*.pdf 7 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | all: factorials.exe 2 | .PHONY: all check clean download 3 | 4 | # Apple Silicon can emulate the x86 5 | ifeq ($(shell uname), Darwin) 6 | CCOPT = -arch x86_64 7 | endif 8 | 9 | CAKEOPT = --skip_type_inference=true --exclude_prelude=true --sexp=true 10 | LDLIBS = -lm 11 | 12 | ifeq ($(DEBUG),1) 13 | CAKEOPT += --emit_empty_ffi=true 14 | CCOPT += -DDEBUG_FFI 15 | endif 16 | 17 | %.exe: %.S lib/basis_ffi.o 18 | @mkdir -p $(dir out/$@) 19 | $(CC) $(CCOPT) $< lib/basis_ffi.o -o out/$@ $(LDLIBS) 20 | 21 | %.S: %.hs lib/pure lib/cake 22 | cat $< | ./lib/pure $(PUREOPT) | ./lib/cake $(CAKEOPT) > $@ 23 | 24 | check: $(patsubst %.hs,%.exe,$(wildcard *.hs)) \ 25 | $(patsubst %.hs,%.exe,$(wildcard prelude/*.hs)) 26 | 27 | lib/pure: lib/pure.S lib/basis_ffi.o 28 | $(CC) $(CCOPT) -o $@ $^ $(LDLIBS) 29 | 30 | lib/cake: lib/cake.S lib/basis_ffi.o 31 | $(CC) $(CCOPT) -o $@ $^ $(LDLIBS) 32 | 33 | lib/basis_ffi.o: lib/basis_ffi.c 34 | $(CC) $(CCOPT) -c -o $@ $^ $(LDLIBS) 35 | 36 | lib/pure.S: 37 | @if [ ! -f "../compiler/binary/$(@F)" ] ; then $(MAKE) download ; else cp ../compiler/binary/$(@F) $@ ; fi 38 | 39 | download: 40 | @echo "$(red)Could not find \`pure.S\`. Downloading the latest version from PureCake's GitHub releases.$(reset)" 41 | wget -q https://github.com/cakeml/pure/releases/latest/download/pure.S -P lib 42 | 43 | lib/cake.S: 44 | wget -q https://github.com/cakeml/cakeml/releases/latest/download/cake-x64-64.tar.gz 45 | @tar -zxf cake-x64-64.tar.gz --directory $(@D) --strip-components 1 cake-x64-64/$(@F) 46 | @rm cake-x64-64.tar.gz 47 | 48 | clean: 49 | rm -rf out lib/basis_ffi.o lib/cake lib/pure lib/cake.S lib/pure.S 50 | 51 | red = \033[0;31m 52 | reset = \033[0m 53 | -------------------------------------------------------------------------------- /examples/README.md: -------------------------------------------------------------------------------- 1 | # Sample PureLang programs and benchmarks 2 | 3 | This directory contains sample PureLang programs which showcase its expressivity, and benchmarks to evaluate performance. 4 | The file [`syntax.hs`](syntax.hs) contains a near-exhaustive demonstration of PureLang's concrete syntax. 5 | The other `.hs` files are non-trivial programs written in PureLang. 6 | 7 | 8 | ## Compiling sample programs using PureCake 9 | 10 | The [`Makefile`](Makefile) in this directory enables compilation of all sample programs. 11 | To compile and execute `foo.hs`: 12 | ```bash 13 | make foo.exe 14 | ./out/foo.exe 15 | ``` 16 | Note that executables are placed in the `out` directory. 17 | 18 | The first time you run `make`, it will: 19 | - download a prebuilt `cake.S` (the CakeML compiler); 20 | - copy in the PureCake compiler (`pure.S`): either from `../compiler/binary` if it has been built, or from our GitHub releases if not. 21 | - build the compiler executables `pure` and `cake`, and the FFI object `basis_ffi.o`. 22 | 23 | Running `make` without arguments produces `factorials.exe`. 24 | Running `make clean` removes all generated files, including `lib/{pure.S,cake.S}`. 25 | Running `make check` compiles all `.hs` files. 26 | Running `make download` will download a prebuilt `pure.S` from our GitHub releases. 27 | 28 | ### Using your own versions of the PureCake/CakeML compilers 29 | 30 | You can replace `lib/{pure.S,cake.S}` with your own versions. 31 | 32 | 33 | ## PureCake's "prelude" 34 | 35 | The [`prelude`](prelude) directory is inspired by its namesake in Haskell: it is a (work-in-progress) collection of useful functions on basic data types. 36 | PureCake does not yet have an import system, so the functions are not directly usable. 37 | However, they can be a useful set of "building blocks" when creating larger PureLang programs. 38 | 39 | To build and run file in the `prelude` directory: 40 | ```bash 41 | make prelude/bar.exe 42 | ./out/prelude/bar.exe 43 | ``` 44 | Note that no files in `prelude` will have observable effects when executed. 45 | They are compiled and typechecked only. 46 | 47 | 48 | ## Benchmarking 49 | 50 | The [`benchmark`](benchmark) directory allows simple benchmarking of PureCake as follows: 51 | ```bash 52 | git apply benchmark/benchmark.patch 53 | touch lib/basis_ffi.c # ensure PureCake's FFI is rebuilt with debug output enabled 54 | cd benchmark 55 | benchmark.py # takes ~4 hrs with supplied configuration 56 | benchmark.py --mode plot 57 | ``` 58 | This will: 59 | 1. Patch some programs to make them suitable for benchmarking: 60 | remove functional quicksort from [`quicksort.hs`](quicksort.hs) and remove polymorphic usages of functions (these will not typecheck if binding group analysis is disabled). 61 | 2. Compile and run the benchmarks as specified in [`bench.config`](benchmark/bench.config), collecting data on timings and heap allocations into `benchmark/data.csv`. 62 | 3. Plot graphs from the collected data, saving them to `benchmark/data.pdf`. 63 | These show base-2 logarithm of runtime speedup and reduction in heap allocations. 64 | 65 | ### [`bench.config`](benchmark/bench.config) 66 | 67 | This specifies the benchmarking configuration for [`benchmark.py`](benchmark/benchmark.py): 68 | - `settings.iterations`: number of iterations to run each program/flag combination. 69 | - `settings.heap`: CakeML heap size in bytes. 70 | - `programs`: key-value pairs of benchmark names (without the `.hs` suffix) and their commandline inputs. 71 | - `flags`: key-value pairs of names and sets of flags used when invoking PureCake. 72 | 73 | Each program will be compiled and run with each set of supplied flags. 74 | Possible flags are: 75 | - `-sort`: binding group analysis in PureLang 76 | - `-clean`: deadcode elimination in PureLang 77 | - `-inline_depth=N`, `inline_size=N`: inlining in PureLang 78 | - `-demands`: demand analysis in PureLang 79 | - `-mk_delay`: `mk_delay` smart constructor in ThunkLang 80 | - `-dlam`: split delayed `lambda`s under `letrec`s in ThunkLang 81 | - `-let_force`: common subexpression elimination of `force (var v)` in ThunkLang 82 | - `-unit`: pushing in applications to `unit` in StateLang 83 | 84 | **NB for boolean flags, supplying the flag *disables* the corresponding optimisation**. 85 | Graphs produced by [`benchmark.py`](benchmark/benchmark.py) therefore show the improvements made when *removing* the flags specified. 86 | 87 | ### [`benchmark.py`](benchmark/benchmark.py) 88 | 89 | **Dependencies:** `python3`, [`parse`](https://pypi.org/project/parse/), [`matplotlib`](https://pypi.org/project/matplotlib/), [`pandas`](https://pypi.org/project/pandas/). 90 | Run `benchmark.py -h` for usage information. 91 | By default, it will read/write `data.{csv,pdf}` - you can change this with e.g. `benchmark.py --filestem foo` to read/write `foo.{csv,pdf}`. 92 | To compile all benchmarks specified in [`bench.config`](benchmark/bench.config) *without* running them, use `benchmark.py --mode compile`. 93 | 94 | ## Compiling programs with GHC 95 | 96 | PureLang resembles a subset of Haskell, so PureLang programs are accepted by GHC with minimal changes. 97 | The diff [`ghc.patch`](./ghc.patch) demonstrates these changes on some examples, and can be applied as follows: 98 | ``` 99 | git apply ghc.patch 100 | ``` 101 | The changes mostly: 102 | - reconcile PureLang/GHC I/O and monads, including converting PureLang's `Array` to GHC's `IOArray` 103 | - adapt PureLang primitives to GHC - including appropriate casts between `Int`/`Integer` 104 | - use functions from GHC's `Prelude` rather than manually defining them 105 | 106 | -------------------------------------------------------------------------------- /examples/benchmark/bench.config: -------------------------------------------------------------------------------- 1 | [settings] 2 | iterations = 10 3 | heap = 1024 4 | 5 | [programs] 6 | # Numeric 7 | primes = 5000 8 | maxCollatzSequence = 2500000 9 | # Lists 10 | gameOfLife = 6000 11 | queens = 13 12 | # Arrays 13 | quicksort = 20000 14 | # Inlining 15 | suc_list = 500 16 | 17 | [flags] 18 | base = 19 | pure = -sort -clean 20 | inlining = -inline_depth=0 -inline_size=0 21 | demands = -demands 22 | thunk = -dlam -mk_delay -let_force 23 | state = -unit 24 | all = -sort -clean -demands -dlam -mk_delay -let_force -unit 25 | 26 | -------------------------------------------------------------------------------- /examples/factorials.hs: -------------------------------------------------------------------------------- 1 | numbers :: [Integer] 2 | numbers = 3 | let num n = n : num (n + 1) 4 | in num 0 5 | 6 | factA :: Integer -> Integer -> Integer 7 | factA a n = 8 | if n < 2 then a 9 | else factA (a * n) (n - 1) 10 | 11 | factorials :: [Integer] 12 | factorials = map (factA 1) numbers 13 | 14 | app :: (a -> IO b) -> [a] -> IO () 15 | app f l = case l of 16 | [] -> return () 17 | h:t -> do f h ; app f t 18 | 19 | main :: IO () 20 | main = do 21 | arg1 <- read_arg1 22 | -- fromString == 0 on malformed input 23 | let i = fromString arg1 24 | facts = take i factorials 25 | app (\i -> print $ toString i) facts 26 | 27 | 28 | -- Code below this line omitted from the paper 29 | 30 | 31 | -- Standard functions 32 | 33 | f $ x = f x 34 | 35 | map :: (a -> b) -> [a] -> [b] 36 | map f l = 37 | case l of 38 | [] -> [] 39 | h:t -> f h : map f t 40 | 41 | take :: Integer -> [a] -> [a] 42 | take n l = 43 | if n == 0 then [] 44 | else 45 | case l of 46 | [] -> [] 47 | h:t -> h : take (n - 1) t 48 | 49 | 50 | -- I/O helpers 51 | 52 | reverse :: [a] -> [a] 53 | reverse l = 54 | let revA a l = case l of [] -> a 55 | h:t -> revA (h:a) t 56 | in revA [] l 57 | 58 | fromString :: String -> Integer 59 | fromString s = 60 | let fromStringI i limit acc s = 61 | if limit == i then acc 62 | else if limit < i then acc 63 | else 64 | fromStringI (i + 1) limit (acc * 10 + (str_elem s i - 48)) s 65 | in fromStringI 0 (strlen s) 0 s 66 | 67 | toString :: Integer -> String 68 | toString i = 69 | let toString0 i = 70 | if i == 0 then [] 71 | else (i `mod` 10 + 48) : toString0 (i `div` 10) 72 | in if i < 0 then "-" ++ (implode $ reverse $ toString0 (0-i)) 73 | else if i == 0 then "0" 74 | else implode $ reverse $ toString0 i 75 | 76 | implode l = 77 | case l of 78 | [] -> "" 79 | h:t -> #(__Implode) h ++ implode t 80 | 81 | read_arg1 = Act (#(cline_arg) " ") 82 | 83 | print s = Act (#(stdout) (s ++ "\n")) 84 | 85 | 86 | -- Overloads 87 | 88 | s1 ++ s2 = #(__Concat) s1 s2 89 | 90 | str_elem :: String -> Integer -> Integer 91 | str_elem s i = #(__Elem) s i 92 | 93 | strlen :: String -> Integer 94 | strlen s = #(__Len) s 95 | 96 | return v = Ret v 97 | 98 | -------------------------------------------------------------------------------- /examples/invertTree.hs: -------------------------------------------------------------------------------- 1 | -- Generate a binary search tree, then invert it and find its max depth 2 | main :: IO () 3 | main = do 4 | arg1 <- read_arg1 5 | let n = fromString arg1 6 | print $ "Generating tree with " ++ toString n ++ " insertions..." 7 | let t = loop n 42 Leaf 8 | let t' = invert t 9 | print $ "Max depth: " ++ toString (maxHeight t') 10 | Ret () 11 | 12 | -- Main loop 13 | loop :: Integer 14 | loop n rand t = if n < 0 then t 15 | else let rand' = lcg rand 16 | t' = insertInteger (rand' `mod` mask) t 17 | in loop (n - 1) rand' t' 18 | 19 | 20 | -- Linear congruential generator 21 | -- From https://en.wikipedia.org/wiki/Linear_congruential_generator#Parameters_in_common_use (`glibc` entry) 22 | lcg :: Integer -> Integer 23 | lcg seed = (a * seed + c) `mod` m 24 | 25 | mask = 2 ** 16 26 | 27 | m = 2 ** 31 28 | a = 1103515245 29 | c = 12345 30 | 31 | 32 | -- Binary trees 33 | data Tree a = Leaf | Branch (Tree a) a (Tree a) 34 | 35 | insertInteger :: Integer -> Tree Integer -> Tree Integer 36 | insertInteger n t = 37 | case t of Leaf -> Branch Leaf n Leaf 38 | Branch l a r -> if n == a then Branch l n r 39 | else if n < a then Branch (insertInteger n l) a r 40 | else Branch l a (insertInteger n r) 41 | 42 | invert :: Tree a -> Tree a 43 | invert t = case t of Leaf -> Leaf 44 | Branch l a r -> Branch (invert l) a (invert r) 45 | 46 | maxHeight :: Tree a -> Integer 47 | maxHeight t = case t of Leaf -> 0 48 | Branch l a r -> 1 + max (maxHeight l) (maxHeight r) 49 | 50 | 51 | -- Helpers 52 | 53 | x ** a = 54 | let expAux acc a = if a < 1 then acc else expAux (acc * x) (a - 1) 55 | in expAux 1 a 56 | 57 | max :: Integer -> Integer -> Integer 58 | max x y = if x < y then y else x 59 | 60 | 61 | -- I/O helpers 62 | 63 | f $ x = f x 64 | 65 | s1 ++ s2 = #(__Concat) s1 s2 66 | 67 | reverse :: [a] -> [a] 68 | reverse l = 69 | let revA a l = case l of [] -> a 70 | h:t -> revA (h:a) t 71 | in revA [] l 72 | 73 | fromString :: String -> Integer 74 | fromString s = 75 | let fromStringI i limit acc s = 76 | if limit == i then acc 77 | else if limit < i then acc 78 | else 79 | fromStringI (i + 1) limit (acc * 10 + (#(__Elem) s i - 48)) s 80 | in fromStringI 0 (#(__Len) s) 0 s 81 | 82 | toString :: Integer -> String 83 | toString i = 84 | let toString0 i = 85 | if i == 0 then [] 86 | else (mod i 10 + 48) : toString0 (div i 10) 87 | in if i < 0 then "-" ++ (implode $ reverse $ toString0 (0-i)) 88 | else if i == 0 then "0" 89 | else implode $ reverse $ toString0 i 90 | 91 | implode l = 92 | case l of 93 | [] -> "" 94 | h:t -> #(__Implode) h ++ implode t 95 | 96 | read_arg1 = Act (#(cline_arg) " ") 97 | 98 | print s = Act (#(stdout) (s ++ "\n")) 99 | 100 | -------------------------------------------------------------------------------- /examples/maxCollatzSequence.hs: -------------------------------------------------------------------------------- 1 | -- Calculate longest Collatz sequence less than n (inefficiently, i.e. w/o memo) 2 | -- import Prelude hiding (map, take) 3 | 4 | main :: IO () 5 | main = do 6 | arg1 <- read_arg1 7 | let n = fromString arg1 8 | print $ "Finding longest Collatz sequence less than " ++ toString n 9 | let res = maxCollatzSequence n 10 | print $ "Number with longest sequence: " ++ toString (fst res) 11 | print $ "Length of sequence: " ++ toString (snd res) 12 | Ret () 13 | 14 | maxCollatzSequence :: Integer -> (Integer, Integer) 15 | maxCollatzSequence n = maxIndex (take n collatzSequences) 16 | 17 | collatzSequences :: [Integer] 18 | collatzSequences = map collatzSequence (numbers 0) 19 | 20 | collatzSequence :: Integer -> Integer 21 | collatzSequence n = 22 | let seqAux acc n = 23 | if n < 1 then (0-1) 24 | else if n == 1 then acc 25 | else seqAux (acc + 1) (collatz n) 26 | in seqAux 0 n 27 | 28 | collatz :: Integer -> Integer 29 | collatz n = if n `mod` 2 == 0 then n `div` 2 else 3 * n + 1 30 | 31 | 32 | -- Helper functions 33 | 34 | numbers :: Integer -> [Integer] 35 | numbers n = n : numbers (n + 1) 36 | 37 | maxIndex :: [Integer] -> (Integer, Integer) 38 | maxIndex l = 39 | let maxAux maxIdx maxElem idx l = 40 | case l of [] -> (maxIdx, maxElem) 41 | h:t -> if maxElem < h then maxAux idx h (idx + 1) t 42 | else maxAux maxIdx maxElem (idx + 1) t 43 | in maxAux (0-1) (0-1) 0 l 44 | 45 | map :: (a -> b) -> [a] -> [b] 46 | map f l = case l of [] -> [] 47 | h:t -> f h : map f t 48 | 49 | take :: Integer -> [a] -> [a] 50 | take n l = 51 | if n < 1 then [] 52 | else case l of [] -> [] 53 | h:t -> h : take (n - 1) t 54 | 55 | fst :: (a, b) -> a 56 | fst p = case p of (a,b) -> a 57 | 58 | snd :: (a, b) -> b 59 | snd p = case p of (a,b) -> b 60 | 61 | 62 | -- I/O helpers 63 | 64 | f $ x = f x 65 | 66 | s1 ++ s2 = #(__Concat) s1 s2 67 | 68 | reverse :: [a] -> [a] 69 | reverse l = 70 | let revA a l = case l of [] -> a 71 | h:t -> revA (h:a) t 72 | in revA [] l 73 | 74 | fromString :: String -> Integer 75 | fromString s = 76 | let fromStringI i limit acc s = 77 | if limit == i then acc 78 | else if limit < i then acc 79 | else 80 | fromStringI (i + 1) limit (acc * 10 + (#(__Elem) s i - 48)) s 81 | in fromStringI 0 (#(__Len) s) 0 s 82 | 83 | toString :: Integer -> String 84 | toString i = 85 | let toString0 i = 86 | if i == 0 then [] 87 | else (i `mod` 10 + 48) : toString0 (i `div` 10) 88 | in if i < 0 then "-" ++ (implode $ reverse $ toString0 (0-i)) 89 | else if i == 0 then "0" 90 | else implode $ reverse $ toString0 i 91 | 92 | implode l = 93 | case l of 94 | [] -> "" 95 | h:t -> #(__Implode) h ++ implode t 96 | 97 | read_arg1 = Act (#(cline_arg) " ") 98 | 99 | print s = Act (#(stdout) (s ++ "\n")) 100 | 101 | -------------------------------------------------------------------------------- /examples/permutations.hs: -------------------------------------------------------------------------------- 1 | -- Finding permutations of a list 2 | -- adapted from GHC's Data.List 3 | 4 | main :: IO () 5 | main = do 6 | arg1 <- read_arg1 7 | let n = fromString arg1 8 | print $ "Finding no. permutations for [1.." ++ toString n ++ "]" 9 | let perms = permutations (numbersUpTo n) 10 | print $ "Computed " ++ (toString (length perms)) ++ " permutations" 11 | Ret () 12 | 13 | 14 | permutations :: [a] -> [[a]] 15 | permutations xs0 = 16 | let interleave t ts xs r = snd (interleave' t ts id xs r) 17 | 18 | interleave' t ts f l r = 19 | case l of [] -> (ts, r) 20 | y:ys -> let p = interleave' t ts (\x -> f (y:x)) ys r 21 | in case p of (us,zs) -> (y:us, f (t:y:us) : zs) 22 | 23 | perms l is = 24 | case l of [] -> [] 25 | t:ts -> foldr (interleave t ts) 26 | (perms ts (t:is)) (permutations is) 27 | 28 | in xs0 : perms xs0 [] 29 | 30 | numbersUpTo :: Integer -> [Integer] 31 | numbersUpTo n = 32 | if n < 0 then [] else 33 | let numbersAux start = 34 | if start < n + 1 then start : numbersAux (start + 1) 35 | else [] 36 | in numbersAux 1 37 | 38 | printIntegers :: [Integer] -> IO String 39 | printIntegers l = case l of [] -> printOnly "\n" 40 | h:t -> do printOnly (toString h ++ " ") ; printIntegers t 41 | 42 | 43 | -- Helper functions 44 | 45 | id :: a -> a 46 | id x = x 47 | 48 | snd :: (a,b) -> b 49 | snd p = case p of (a,b) -> b 50 | 51 | 52 | length :: [a] -> Integer 53 | length l = case l of [] -> 0 54 | h:t -> 1 + length t 55 | 56 | foldr :: (a -> b -> b) -> b -> [a] -> b 57 | foldr f acc l = case l of [] -> acc 58 | h:t -> f h (foldr f acc t) 59 | 60 | -- I/O helpers 61 | 62 | f $ x = f x 63 | 64 | s1 ++ s2 = #(__Concat) s1 s2 65 | 66 | reverse :: [a] -> [a] 67 | reverse l = 68 | let revA a l = case l of [] -> a 69 | h:t -> revA (h:a) t 70 | in revA [] l 71 | 72 | fromString :: String -> Integer 73 | fromString s = 74 | let fromStringI i limit acc s = 75 | if limit == i then acc 76 | else if limit < i then acc 77 | else 78 | fromStringI (i + 1) limit (acc * 10 + (#(__Elem) s i - 48)) s 79 | in fromStringI 0 (#(__Len) s) 0 s 80 | 81 | toString :: Integer -> String 82 | toString i = 83 | let toString0 i = 84 | if i == 0 then [] 85 | else (i `mod` 10 + 48) : toString0 (i `div` 10) 86 | in if i < 0 then "-" ++ (implode $ reverse $ toString0 (0-i)) 87 | else if i == 0 then "0" 88 | else implode $ reverse $ toString0 i 89 | 90 | implode l = 91 | case l of 92 | [] -> "" 93 | h:t -> #(__Implode) h ++ implode t 94 | 95 | read_arg1 = Act (#(cline_arg) " ") 96 | 97 | print s = Act (#(stdout) (s ++ "\n")) 98 | 99 | printOnly s = Act (#(stdout) s) 100 | 101 | -------------------------------------------------------------------------------- /examples/prelude/arrays.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = Ret () 3 | 4 | alloc :: Integer -> a -> IO Array a 5 | alloc len elem = Alloc len elem 6 | 7 | length :: Array a -> IO Integer 8 | length a = Length a 9 | 10 | get :: Array a -> Integer -> IO a 11 | get a idx = Deref a idx 12 | 13 | getAndHandle :: Array a -> Integer -> (Exception -> Integer) -> IO Integer 14 | getAndHandle a idx handler = Handle (get a idx) (\e -> Ret (handler e)) 15 | 16 | update :: Array a -> Integer -> a -> IO () 17 | update a idx a' = Update a idx a' 18 | 19 | index :: Array a -> Integer -> IO (Maybe a) 20 | index a idx = 21 | if idx < 0 then Ret Nothing else do 22 | len <- length a 23 | if len < idx + 1 then Ret Nothing else do 24 | elem <- get a idx 25 | Ret (Just elem) 26 | 27 | toString :: (a -> String) -> Array String -> IO String 28 | toString f a = 29 | let toStringAux i len = 30 | if i < len then do 31 | elem <- Deref a i 32 | rest <- toStringAux (i + 1) len 33 | Ret (#(__Concat) (f elem) (if i < len - 1 then ", " else "") rest) 34 | else Ret "" 35 | in do 36 | len <- Length a 37 | inner <- toStringAux 0 len 38 | Ret (#(__Concat) "[" inner "]") 39 | 40 | 41 | -- Helpers 42 | data Maybe a = Nothing | Just a 43 | 44 | -------------------------------------------------------------------------------- /examples/prelude/bools.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = Ret () 3 | 4 | not :: Bool -> Bool 5 | not b = if b then False else True 6 | 7 | equal :: Bool -> Bool -> Bool 8 | equal b1 b2 = if b1 then b2 else not b2 9 | 10 | and :: Bool -> Bool -> Bool 11 | and b1 b2 = if b1 then b2 else False 12 | 13 | or :: Bool -> Bool -> Bool 14 | or b1 b2 = if b1 then True else b2 15 | 16 | xor :: Bool -> Bool -> Bool 17 | xor b1 b2 = not (equal b1 b2) 18 | 19 | toString :: Bool -> String 20 | toString b = if b then "True" else "False" 21 | 22 | fromString :: String -> Maybe Bool 23 | fromString s = if #(__StrEq) s "True" then Just True 24 | else if #(__StrEq) s "False" then Just False 25 | else Nothing 26 | 27 | 28 | -- Helpers 29 | 30 | data Maybe a = Nothing | Just a 31 | 32 | -------------------------------------------------------------------------------- /examples/prelude/combinators.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = Ret () 3 | 4 | f $ x = f x 5 | 6 | f |> x = f x 7 | 8 | compose :: (b -> c) -> (a -> b) -> a -> c 9 | compose f g = \x -> f (g x) 10 | 11 | s :: (a -> b -> c) -> (a -> b) -> a -> c 12 | s x y z = x z (y z) 13 | 14 | k :: a -> b -> a 15 | k x y = x 16 | 17 | i :: a -> a 18 | i x = x 19 | 20 | fix :: (a -> a) -> a 21 | fix f = f (fix f) 22 | 23 | -------------------------------------------------------------------------------- /examples/prelude/either.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = Ret () 3 | 4 | data Either a b = Left a | Right b 5 | 6 | either :: (a -> c) -> (b -> c) -> Either a b -> c 7 | either f g e = case e of Left a -> f a 8 | Right b -> g b 9 | 10 | -------------------------------------------------------------------------------- /examples/prelude/integers.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = Ret () 3 | 4 | numbers :: Integer -> [Integer] 5 | numbers n = n : numbers (n + 1) 6 | 7 | abs :: Integer -> Integer 8 | abs n = if n < 0 then 0 - n else n 9 | 10 | isEven :: Integer -> Bool 11 | isEven n = if n == 0 then True 12 | else isOdd (abs n - 1) 13 | 14 | isOdd :: Integer -> Bool 15 | isOdd n = if n == 0 then False 16 | else isEven (abs n - 1) 17 | 18 | exp :: Integer -> Integer -> Integer 19 | exp n a = 20 | let expAux acc a = if a < 1 then acc else expAux (acc * n) (a - 1) 21 | in expAux 1 a 22 | 23 | ntimes :: Integer -> (a -> a) -> a -> a 24 | ntimes n f x = if n < 1 then x 25 | else ntimes (n - 1) f (f x) 26 | 27 | fibonacci :: Integer -> Integer 28 | fibonacci n = 29 | if n < 1 then 0 else 30 | let fib n a b = if n == 0 then b 31 | else fib (n - 1) b (a + b) 32 | in fib n 0 1 33 | 34 | factorial :: Integer -> Integer 35 | factorial n = 36 | if n < 1 then 0 else 37 | let fact n acc = if n == 1 then acc 38 | else fact (n - 1) (n * acc) 39 | in fact n 1 40 | 41 | gcd :: Integer -> Integer -> Integer 42 | gcd n m = 43 | let gcd' a b = if b == 0 then a 44 | else gcd' b (a `mod` b) 45 | in gcd' (abs n) (abs m) 46 | 47 | collatz :: Integer -> [Integer] 48 | collatz n = 49 | let n' = abs n 50 | rest = if n' < 2 then [] 51 | else if n' `mod` 2 == 0 then collatz (n `div` 2) 52 | else collatz (3 * n + 1) 53 | in n' : rest 54 | 55 | primitiveRecursion :: (Integer -> Integer) -> (Integer -> Integer -> Integer -> Integer) -> (Integer -> Integer -> Integer) 56 | primitiveRecursion f g x y = 57 | if y == 0 then f x 58 | else g x (y - 1) (primitiveRecursion f g x (y - 1)) 59 | 60 | minimisation :: (Integer -> Integer -> Integer) -> Integer -> Integer 61 | minimisation f x = 62 | let min' f x n = if f x n == 0 then n 63 | else min' f x (n + 1) 64 | in min' f x 0 65 | 66 | ackermann :: Integer -> Integer -> Integer 67 | ackermann m n = 68 | if m < 0 then ackermann (abs m) n 69 | else if n < 0 then ackermann m (abs n) 70 | else if m == 0 then n + 1 71 | else if n == 0 then (m - 1) 72 | else ackermann (m - 1) (ackermann m (n - 1)) 73 | 74 | fromString :: String -> Integer 75 | fromString s = 76 | let fromStringAux i limit acc s = 77 | if limit == i then acc 78 | else if limit < i then acc 79 | else fromStringAux (i + 1) limit (acc * 10 + (#(__Elem) s i - 48)) s 80 | in fromStringAux 0 (#(__Len) s) 0 s 81 | 82 | toString :: Integer -> String 83 | toString i = 84 | let toStringAux acc i = if i == 0 then acc 85 | else toStringAux ((i `mod` 10 + 48) : acc) (i `div` 10) 86 | implode l = case l of [] -> "" 87 | h:t -> #(__Concat) (#(__Implode) h) (implode t) 88 | in if i < 0 then #(__Concat) "-" (toString (abs i)) 89 | else if i == 0 then "0" 90 | else implode (toStringAux [] i) 91 | 92 | -------------------------------------------------------------------------------- /examples/prelude/io.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = Ret () 3 | 4 | return v = Ret v 5 | 6 | bind x f = Bind x f 7 | 8 | app :: (a -> IO b) -> [a] -> IO () 9 | app f l = case l of [] -> return () 10 | h:t -> do f h ; app f t 11 | 12 | read_args n = 13 | let make_str n = if n < 1 then "" 14 | else #(__Concat) " " (make_str (n - 1)) 15 | in Act (#(cline_arg) (make_str n)) 16 | 17 | print :: String -> IO String 18 | print s = Act (#(stdout) s) 19 | 20 | println :: String -> IO String 21 | println s = print (#(__Concat) s "\n") 22 | 23 | -------------------------------------------------------------------------------- /examples/prelude/lists.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = Ret () 3 | 4 | 5 | -- Basic operations 6 | 7 | append :: [a] -> [a] -> [a] 8 | append l1 l2 = case l1 of [] -> l2 9 | h:t -> h : append t l2 10 | 11 | head :: [a] -> Maybe a 12 | head l = case l of [] -> Nothing 13 | h:t -> Just h 14 | 15 | last :: [a] -> Maybe a 16 | last l = case l of [] -> Nothing 17 | h:t -> if null t then Just h else last t 18 | 19 | tail :: [a] -> [a] 20 | tail l = case l of [] -> [] 21 | h:t -> t 22 | 23 | singleton :: a -> [a] 24 | singleton a = [a] 25 | 26 | null :: [a] -> Bool 27 | null l = case l of [] -> True 28 | h:t -> False 29 | 30 | length :: [a] -> Integer 31 | length l = case l of [] -> 0 32 | h:t -> 1 + length t 33 | 34 | 35 | -- List transformations 36 | 37 | map :: (a -> b) -> [a] -> [b] 38 | map f l = case l of [] -> [] 39 | h:t -> f h : map f t 40 | 41 | reverse :: [a] -> [a] 42 | reverse l = 43 | let revA a l = case l of [] -> a 44 | h:t -> revA (h:a) t 45 | in revA [] l 46 | 47 | 48 | -- Folds / unfolds 49 | 50 | foldr :: (a -> b -> b) -> b -> [a] -> b 51 | foldr f acc l = case l of [] -> acc 52 | h:t -> f h (foldr f acc t) 53 | 54 | foldl :: (b -> a -> b) -> b -> [a] -> b 55 | foldl f acc l = case l of [] -> acc 56 | h:t -> foldl f (f acc h) t 57 | 58 | foldl' :: (b -> a -> b) -> b -> [a] -> b 59 | foldl' f acc l = case l of [] -> acc 60 | h:t -> let acc' = f acc h in 61 | acc' `seq` (foldl' f acc' t) 62 | 63 | unfoldr :: (b -> Maybe (a, b)) -> b -> [a] 64 | unfoldr f x = 65 | case f x of Nothing -> [] 66 | Just p -> case p of (a,b) -> a : unfoldr f b 67 | 68 | concat :: [[a]] -> [a] 69 | concat ll = case ll of [] -> [] 70 | h:t -> append h (concat t) 71 | 72 | all :: (a -> Bool) -> [a] -> Bool 73 | all f l = case l of [] -> True 74 | h:t -> if f h then all f t else False 75 | 76 | any :: (a -> Bool) -> [a] -> Bool 77 | any f l = case l of [] -> False 78 | h:t -> if f h then True else any f t 79 | 80 | 81 | -- Generating lists 82 | 83 | iterate :: (a -> a) -> a -> [a] 84 | iterate f x = x : iterate f (f x) 85 | 86 | repeat :: a -> [a] 87 | repeat x = x : repeat x 88 | 89 | replicate :: Integer -> a -> [a] 90 | replicate i x = if i < 1 then [] else x : replicate (i - 1) x 91 | 92 | 93 | -- Sublists 94 | 95 | take :: Integer -> [a] -> [a] 96 | take n l = if n < 1 then [] 97 | else case l of [] -> [] 98 | h:t -> h : (take (n - 1) t) 99 | 100 | drop :: Integer -> [a] -> [a] 101 | drop n l = if n < 1 then l 102 | else case l of [] -> [] 103 | h:t -> drop (n - 1) t 104 | 105 | 106 | -- Searching / indexing 107 | 108 | filter :: (a -> Bool) -> [a] -> [a] 109 | filter f l = case l of [] -> [] 110 | h:t -> if f h then h : filter f t else filter f t 111 | 112 | first :: (a -> Bool) -> [a] -> Maybe (Integer, a) 113 | first f l = 114 | let firstAux i l = 115 | case l of [] -> Nothing 116 | h:t -> if f h then Just (i, h) else firstAux (i + 1) t 117 | in firstAux 0 l 118 | 119 | lookup :: (a -> Bool) -> [(a,b)] -> Maybe b 120 | lookup eq l = 121 | case l of [] -> Nothing 122 | h:t -> case h of (k,v) -> if eq k then Just v else lookup eq t 123 | 124 | 125 | index :: Integer -> [a] -> Maybe a 126 | index n l = if n < 0 then Nothing else 127 | case l of [] -> Nothing 128 | h:t -> if n == 0 then Just h else index (n - 1) l 129 | 130 | 131 | -- Combining lists 132 | 133 | interleave :: [a] -> [a] -> [a] 134 | interleave l1 l2 = case l1 of [] -> l2 135 | h:t -> h : interleave l2 t 136 | 137 | zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] 138 | zipWith f as bs = 139 | case as of [] -> [] 140 | a:ta -> case bs of [] -> [] 141 | b:tb -> f a b : zipWith f ta tb 142 | 143 | unzip :: [(a,b)] -> ([a], [b]) 144 | unzip l = 145 | case l of 146 | [] -> ([], []) 147 | h:t -> let rest = unzip t 148 | in case h of (a,b) -> case rest of (as, bs) -> (a:as, b:bs) 149 | 150 | 151 | -- Convert to string 152 | toString :: (a -> String) -> [a] -> String 153 | toString f l = 154 | let toStringAux l = 155 | case l of [] -> "" 156 | h:t -> #(__Concat) (f h) (if null t then "" else ", ") (toStringAux t) 157 | in #(__Concat) "[" (toStringAux l) "]" 158 | 159 | 160 | -- Helpers 161 | 162 | data Maybe a = Nothing | Just a 163 | 164 | -------------------------------------------------------------------------------- /examples/prelude/maybe.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = Ret () 3 | 4 | data Maybe a = Nothing | Just a 5 | 6 | maybe :: a -> Maybe a 7 | maybe a = Just a 8 | 9 | fold :: (a -> b) -> b -> Maybe a -> b 10 | fold f b m = case m of Nothing -> b 11 | Just a -> f a 12 | 13 | map :: (a -> b) -> Maybe a -> Maybe b 14 | map f m = case m of Nothing -> Nothing 15 | Just a -> Just (f a) 16 | 17 | bind :: Maybe a -> (a -> Maybe b) -> Maybe b 18 | bind m f = fold f Nothing m 19 | 20 | toString :: (a -> String) -> Maybe a -> String 21 | toString f m = case m of Nothing -> "Nothing" 22 | Just a -> #(__Concat) "Just " (f a) 23 | 24 | -------------------------------------------------------------------------------- /examples/prelude/strings.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = Ret () 3 | 4 | get :: String -> Integer -> Integer 5 | get s idx = #(__Elem) s idx 6 | 7 | index :: String -> Integer -> Maybe Integer 8 | index s idx = if idx < 0 then Nothing 9 | else if length s < idx + 1 then Nothing 10 | else Just (get s idx) 11 | 12 | length :: String -> Integer 13 | length s = #(__Len) s 14 | 15 | concat :: String -> String -> String 16 | concat s1 s2 = #(__Concat) s1 s2 17 | 18 | substring2 :: String -> Integer -> String 19 | substring2 s start = #(__Substring) s start 20 | 21 | substring3 :: String -> Integer -> Integer -> String 22 | substring3 s start len = #(__Substring) s start len 23 | 24 | equal :: String -> String -> Bool 25 | equal s1 s2 = #(__StrEq) s1 s2 26 | 27 | less :: String -> String -> Bool 28 | less s1 s2 = #(__StrLt) s1 s2 29 | 30 | greater :: String -> String -> Bool 31 | greater s1 s2 = #(__StrGt) s1 s2 32 | 33 | leq :: String -> String -> Bool 34 | leq s1 s2 = #(__StrLeq) s1 s2 35 | 36 | geq :: String -> String -> Bool 37 | geq s1 s2 = #(__StrGeq) s1 s2 38 | 39 | implode :: [Integer] -> String 40 | implode l = case l of [] -> "" 41 | h:t -> concat (#(__Implode) h) (implode t) 42 | 43 | explode :: String -> [Integer] 44 | explode s = 45 | let from i = if i < length s then get s i : from (i + 1) else [] 46 | in from 0 47 | 48 | reverse :: String -> String 49 | reverse s = 50 | let revAux i limit acc = if i == limit then acc else 51 | revAux (i + 1) limit ((get s i) : acc) 52 | in implode (revAux 0 (length s) []) 53 | 54 | 55 | -- Helpers 56 | 57 | data Maybe a = Nothing | Just a 58 | 59 | -------------------------------------------------------------------------------- /examples/prelude/trees.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = Ret () 3 | 4 | -- Binary trees 5 | 6 | data Tree a = Leaf | Branch (Tree a) a (Tree a) 7 | 8 | fold :: (a -> b -> b -> b) -> b -> Tree a -> b 9 | fold f acc t = case t of Leaf -> acc 10 | Branch l a r -> f a (fold f acc l) (fold f acc r) 11 | 12 | flatten :: ([a] -> a -> [a] -> [a]) -> Tree a -> [a] 13 | flatten f t = 14 | case t of Leaf -> [] 15 | Branch l a r -> f (flatten f l) a (flatten f r) 16 | 17 | inorder :: Tree a -> [a] 18 | inorder t = flatten (\l a r -> l ++ (a : r)) t 19 | 20 | preorder :: Tree a -> [a] 21 | preorder t = flatten (\l a r -> a : l ++ r) t 22 | 23 | postorder :: Tree a -> [a] 24 | postorder t = flatten (\l a r -> l ++ r ++ [a]) t 25 | 26 | invert :: Tree a -> Tree a 27 | invert t = case t of Leaf -> Leaf 28 | Branch l a r -> Branch (invert l) a (invert r) 29 | 30 | 31 | -- Rose trees 32 | 33 | data Rose a = Tree a [Rose a] 34 | 35 | foldRose :: (a -> [b] -> b) -> Rose a -> b 36 | foldRose f t = 37 | case t of Tree a rs -> f a (map (foldRose f) rs) 38 | 39 | flattenRose t = 40 | case t of Tree a rs -> a : concat (map flattenRose rs) 41 | 42 | invertRose t = 43 | case t of Tree a rs -> Tree a (reverse rs) 44 | 45 | 46 | -- Helpers 47 | 48 | l1 ++ l2 = case l1 of [] -> l2 49 | h:t -> h : (t ++ l2) 50 | 51 | reverse :: [a] -> [a] 52 | reverse l = 53 | let revA a l = case l of [] -> a 54 | h:t -> revA (h:a) t 55 | in revA [] l 56 | 57 | map :: (a -> b) -> [a] -> [b] 58 | map f l = case l of [] -> [] 59 | h:t -> f h : map f t 60 | 61 | concat :: [[a]] -> [a] 62 | concat ll = case ll of [] -> [] 63 | h:t -> h ++ concat t 64 | 65 | -------------------------------------------------------------------------------- /examples/prelude/tuples.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = Ret () 3 | 4 | fst :: (a, b) -> a 5 | fst p = case p of (a, b) -> a 6 | 7 | snd :: (a, b) -> b 8 | snd p = case p of (a, b) -> b 9 | 10 | curry :: ((a, b) -> c) -> a -> b -> c 11 | curry f a b = f (a, b) 12 | 13 | uncurry :: (a -> b -> c) -> (a, b) -> c 14 | uncurry f p = case p of (a, b) -> f a b 15 | 16 | -------------------------------------------------------------------------------- /examples/primes.hs: -------------------------------------------------------------------------------- 1 | -- Primality testing using two methods 2 | 3 | main :: IO () 4 | main = do 5 | arg1 <- read_arg1 6 | let n = fromString arg1 7 | print $ "Finding prime no. " ++ toString n 8 | let a = primeA n 9 | b = primeB n 10 | print $ "Sieve of Eratosthenes: " ++ toString a 11 | print $ "Divisor testing: " ++ toString b 12 | Ret () 13 | 14 | 15 | -- Method 1: sieve of Eratosthenes 16 | 17 | primesA :: [Integer] 18 | primesA = 19 | let sieve l = 20 | case l of 21 | [] -> [] -- should not happen 22 | h:t -> h : filter (\n -> not $ n `mod` h == 0) (sieve t) 23 | in sieve $ numbers 2 24 | 25 | primeA :: Integer -> Integer 26 | primeA n = idx n primesA 27 | 28 | 29 | -- Method 2: divisor testing 30 | 31 | isPrime :: Integer -> Bool 32 | isPrime n = 33 | let checkPrime div n = if n < div * div then True 34 | else if n `mod` div == 0 then False 35 | else checkPrime (div + 1) n 36 | in if n < 2 then False else checkPrime 2 n 37 | 38 | primesB :: [Integer] 39 | primesB = filter isPrime $ numbers 2 40 | 41 | primeB :: Integer -> Integer 42 | primeB n = idx n primesB 43 | 44 | 45 | -- Helper functions 46 | 47 | f $ x = f x 48 | 49 | not :: Bool -> Bool 50 | not b = case b of True -> False 51 | False -> True 52 | 53 | filter :: (a -> Bool) -> [a] -> [a] 54 | filter f l = 55 | case l of 56 | [] -> [] 57 | h:t -> if f h then h : filter f t 58 | else filter f t 59 | 60 | idx :: Integer -> [Integer] -> Integer 61 | idx n l = 62 | case l of 63 | [] -> ~1 -- should not happen 64 | h:t -> if n == 0 then h else idx (n - 1) t 65 | 66 | numbers :: Integer -> [Integer] 67 | numbers n = n : numbers (n + 1) 68 | 69 | 70 | -- I/O helpers 71 | 72 | reverse :: [a] -> [a] 73 | reverse l = 74 | let revA a l = case l of [] -> a 75 | h:t -> revA (h:a) t 76 | in revA [] l 77 | 78 | fromString :: String -> Integer 79 | fromString s = 80 | let fromStringI i limit acc s = 81 | if limit == i then acc 82 | else if limit < i then acc 83 | else 84 | fromStringI (i + 1) limit (acc * 10 + (str_elem s i - 48)) s 85 | in fromStringI 0 (strlen s) 0 s 86 | 87 | toString :: Integer -> String 88 | toString i = 89 | let toString0 i = 90 | if i == 0 then [] 91 | else (i `mod` 10 + 48) : toString0 (i `div` 10) 92 | in if i < 0 then "-" ++ (implode $ reverse $ toString0 (0-i)) 93 | else if i == 0 then "0" 94 | else implode $ reverse $ toString0 i 95 | 96 | implode l = 97 | case l of 98 | [] -> "" 99 | h:t -> #(__Implode) h ++ implode t 100 | 101 | read_arg1 = Act (#(cline_arg) " ") 102 | 103 | print s = Act (#(stdout) (s ++ "\n")) 104 | 105 | 106 | -- Overloads 107 | 108 | s1 ++ s2 = #(__Concat) s1 s2 109 | 110 | str_elem :: String -> Integer -> Integer 111 | str_elem s i = #(__Elem) s i 112 | 113 | strlen :: String -> Integer 114 | strlen s = #(__Len) s 115 | 116 | 117 | 118 | 119 | 120 | -------------------------------------------------------------------------------- /examples/queens.hs: -------------------------------------------------------------------------------- 1 | -- Compute number of N-Queens solutions (brute force) 2 | -- adapted from albertnetymk.github.io 3 | 4 | 5 | main :: IO () 6 | main = do 7 | arg1 <- read_arg1 8 | let n = fromString arg1 9 | print $ "Finding no. N-Queens solutions for board size " ++ toString n 10 | let boards = queens n 11 | print $ "No. solutions: " ++ toString (length boards) 12 | Ret () 13 | 14 | queens :: Integer -> [[Integer]] 15 | queens n = 16 | if n < 0 then [] else 17 | let test x c n = and [not (x == c), not (x == c + n), not (x == c - n)] 18 | 19 | noCapture x l n = 20 | case l of 21 | [] -> True 22 | h:t -> and [test x h n, noCapture x t (n + 1)] 23 | 24 | extend current board = 25 | if current < n + 1 then 26 | let rest = extend (current + 1) board 27 | in if noCapture current board 1 then (current : board) : rest else rest 28 | else [] 29 | 30 | iter boards counter = 31 | if counter == n then boards 32 | else iter (concatMap (extend 1) boards) (counter + 1) 33 | 34 | in iter [[]] 0 35 | 36 | printBoard :: [[Integer]] -> IO String 37 | printBoard l = 38 | let rowToString l = case l of [] -> "" 39 | h:t -> toString h ++ rowToString t 40 | boardToString l = case l of [] -> "" 41 | h:t -> rowToString h ++ "\n" ++ boardToString t 42 | in print (boardToString l) 43 | 44 | 45 | -- Helper functions 46 | 47 | and :: [Bool] -> Bool 48 | and l = case l of [] -> True 49 | h:t -> if h then and t else False 50 | 51 | not :: Bool -> Bool 52 | not b = case b of True -> False 53 | False -> True 54 | 55 | length :: [a] -> Integer 56 | length l = case l of [] -> 0 57 | h:t -> 1 + length t 58 | 59 | append :: [a] -> [a] -> [a] 60 | append l1 l2 = case l1 of [] -> l2 61 | h:t -> h : append t l2 62 | 63 | foldr :: (a -> b -> b) -> b -> [a] -> b 64 | foldr f acc l = case l of [] -> acc 65 | h:t -> f h (foldr f acc t) 66 | 67 | concatMap :: (a -> [b]) -> [a] -> [b] 68 | concatMap f = foldr (\a -> append (f a)) [] 69 | 70 | 71 | -- I/O helpers 72 | 73 | f $ x = f x 74 | 75 | s1 ++ s2 = #(__Concat) s1 s2 76 | 77 | reverse :: [a] -> [a] 78 | reverse l = 79 | let revA a l = case l of [] -> a 80 | h:t -> revA (h:a) t 81 | in revA [] l 82 | 83 | fromString :: String -> Integer 84 | fromString s = 85 | let fromStringI i limit acc s = 86 | if limit == i then acc 87 | else if limit < i then acc 88 | else 89 | fromStringI (i + 1) limit (acc * 10 + (#(__Elem) s i - 48)) s 90 | in fromStringI 0 (#(__Len) s) 0 s 91 | 92 | toString :: Integer -> String 93 | toString i = 94 | let toString0 i = 95 | if i == 0 then [] 96 | else (i `mod` 10 + 48) : toString0 (i `div` 10) 97 | in if i < 0 then "-" ++ (implode $ reverse $ toString0 (0-i)) 98 | else if i == 0 then "0" 99 | else implode $ reverse $ toString0 i 100 | 101 | implode l = 102 | case l of 103 | [] -> "" 104 | h:t -> #(__Implode) h ++ implode t 105 | 106 | read_arg1 = Act (#(cline_arg) " ") 107 | 108 | print s = Act (#(stdout) (s ++ "\n")) 109 | 110 | -------------------------------------------------------------------------------- /examples/quicksort.hs: -------------------------------------------------------------------------------- 1 | -- Simple functional and imperative quicksort 2 | -- import Prelude hiding (and) 3 | 4 | main :: IO () 5 | main = do 6 | arg1 <- read_arg1 7 | let n = fromString arg1 8 | printOnly $ "Sorting the *list* [" ++ toString n ++ "..0]... " 9 | let res = qsortList (numbersList n) 10 | print $ if isSortedList res then "Success!" else "Failure :(" 11 | printOnly $ "Sorting the *array* [" ++ toString n ++ "..0]... " 12 | a <- numbersArray n 13 | len <- Length a 14 | qsortArray a 15 | ok <- isSortedArray a 16 | print $ if ok then "Success!" else "Failure :(" 17 | Ret () 18 | 19 | 20 | -- Functional quicksort 21 | 22 | qsortList :: [Integer] -> [Integer] 23 | qsortList l = 24 | case l of 25 | [] -> [] 26 | h:t -> 27 | let parts = partitionList h t 28 | in case parts of 29 | (less, greaterEq) -> 30 | append (qsortList less) (h : qsortList greaterEq) 31 | 32 | 33 | partitionList :: Integer -> [Integer] -> ([Integer],[Integer]) 34 | partitionList pivot l = 35 | case l of 36 | [] -> ([],[]) 37 | h:t -> 38 | let rest = partitionList pivot t 39 | in case rest of 40 | (less, greaterEq) -> 41 | if h < pivot then (h:less, greaterEq) 42 | else (less, h:greaterEq) 43 | 44 | 45 | -- Imperative quicksort 46 | 47 | qsortArray :: Array Integer -> IO () 48 | qsortArray a = 49 | let qsortAux a lo hi = 50 | if lo < 0 then Ret () 51 | else if hi < lo + 1 then Ret () 52 | else do 53 | pivot <- partitionArray a lo hi 54 | qsortAux a lo (pivot - 1) 55 | qsortAux a (pivot + 1) hi 56 | in do 57 | len <- Length a 58 | qsortAux a 0 (len - 1) 59 | 60 | 61 | partitionArray :: Array Integer -> Integer -> Integer -> IO Integer 62 | partitionArray a lo hi = do 63 | pivotElem <- Deref a hi 64 | let loop i j = do 65 | if j < hi then do 66 | jElem <- Deref a j 67 | if jElem < pivotElem + 1 then do 68 | do swap a (i + 1) j ; loop (i + 1) (j + 1) 69 | else loop i (j + 1) 70 | else Ret i 71 | i <- loop (lo - 1) lo 72 | swap a (i + 1) hi 73 | Ret (i + 1) 74 | 75 | swap :: Array a -> Integer -> Integer -> IO () 76 | swap a i j = do 77 | iElem <- Deref a i 78 | jElem <- Deref a j 79 | Update a i jElem 80 | Update a j iElem 81 | 82 | 83 | -- List helper functions 84 | 85 | append :: [a] -> [a] -> [a] 86 | append l1 l2 = case l1 of [] -> l2 87 | h:t -> h : append t l2 88 | 89 | numbersList :: Integer -> [Integer] 90 | numbersList n = if n < 0 then [] 91 | else n : numbersList (n - 1) 92 | 93 | -- numbersList :: Integer -> [Integer] 94 | -- numbersList n = 95 | -- let numbersAux current = 96 | -- if current < n then current : numbersAux (current + 1) else [] 97 | -- in if n < 0 then [] else numbersAux 0 98 | 99 | isSortedList :: [Integer] -> Bool 100 | isSortedList l = 101 | let sortedAux last l = 102 | case l of [] -> True 103 | h:t -> if last < h + 1 then sortedAux h t 104 | else False 105 | in case l of [] -> True 106 | h:t -> sortedAux h t 107 | 108 | 109 | -- Array helper functions 110 | 111 | numbersArray :: Integer -> IO (Array Integer) 112 | numbersArray n = 113 | let length = if n < 0 then 0 else n 114 | fill a next remaining = 115 | if remaining == 0 then Ret () 116 | else do 117 | Update a next remaining 118 | fill a (next + 1) (remaining - 1) 119 | in do 120 | a <- Alloc length 0 121 | fill a 0 length 122 | Ret a 123 | 124 | isSortedArray :: Array Integer -> IO Bool 125 | isSortedArray a = 126 | let loop lastElem nextIdx len = 127 | if nextIdx < len then do 128 | nextElem <- Deref a nextIdx 129 | if lastElem < nextElem + 1 then 130 | loop nextElem (nextIdx + 1) len 131 | else Ret False 132 | else Ret True 133 | in do 134 | len <- Length a 135 | if len < 1 then Ret True else do 136 | first <- Deref a 0 137 | loop first 1 len 138 | 139 | printArray :: Array Integer -> IO () 140 | printArray a = 141 | let printAux i len = 142 | if i < len then do 143 | elem <- Deref a i 144 | printOnly (toString elem) 145 | if i < len - 1 then 146 | do printOnly ", " ; Ret () 147 | else Ret () 148 | printAux (i + 1) len 149 | else Ret () 150 | in do 151 | printOnly "[" 152 | len <- Length a 153 | printAux 0 len 154 | printOnly "]\n" 155 | Ret () 156 | 157 | 158 | -- I/O helpers 159 | 160 | f $ x = f x 161 | 162 | s1 ++ s2 = #(__Concat) s1 s2 163 | 164 | reverse :: [a] -> [a] 165 | reverse l = 166 | let revA a l = case l of [] -> a 167 | h:t -> revA (h:a) t 168 | in revA [] l 169 | 170 | fromString :: String -> Integer 171 | fromString s = 172 | let fromStringI i limit acc s = 173 | if limit == i then acc 174 | else if limit < i then acc 175 | else 176 | fromStringI (i + 1) limit (acc * 10 + (#(__Elem) s i - 48)) s 177 | in fromStringI 0 (#(__Len) s) 0 s 178 | 179 | toString :: Integer -> String 180 | toString i = 181 | let toString0 i = 182 | if i == 0 then [] 183 | else (i `mod` 10 + 48) : toString0 (i `div` 10) 184 | in if i < 0 then "-" ++ (implode $ reverse $ toString0 (0-i)) 185 | else if i == 0 then "0" 186 | else implode $ reverse $ toString0 i 187 | 188 | implode l = 189 | case l of 190 | [] -> "" 191 | h:t -> #(__Implode) h ++ implode t 192 | 193 | read_arg1 = Act (#(cline_arg) " ") 194 | 195 | printOnly s = Act (#(stdout) s) 196 | 197 | print s = Act (#(stdout) (s ++ "\n")) 198 | 199 | -------------------------------------------------------------------------------- /examples/suc_list.hs: -------------------------------------------------------------------------------- 1 | numbers :: [Integer] 2 | numbers = 3 | let num n = n : num (n + 1) 4 | in num 0 5 | 6 | suc_list :: [Integer] -> [Integer] 7 | suc_list = map (\n -> n + 1) 8 | 9 | n_times :: Integer -> (a -> a) -> a -> a 10 | n_times n f x = 11 | if n < 1 then x 12 | else n_times (n - 1) f (f x) 13 | 14 | app :: (a -> IO b) -> [a] -> IO () 15 | app f l = case l of 16 | [] -> return () 17 | h:t -> do f h ; app f t 18 | 19 | main :: IO () 20 | main = do 21 | arg1 <- read_arg1 22 | -- fromString == 0 on malformed input 23 | let i = fromString arg1 24 | ns = take i numbers 25 | app (\i -> print $ toString i) (n_times 1000000 suc_list ns) 26 | 27 | 28 | -- Code below this line omitted from the paper 29 | 30 | 31 | -- Standard functions 32 | 33 | f $ x = f x 34 | 35 | map :: (a -> b) -> [a] -> [b] 36 | map f l = 37 | case l of 38 | [] -> [] 39 | h:t -> f h : map f t 40 | 41 | take :: Integer -> [a] -> [a] 42 | take n l = 43 | if n == 0 then [] 44 | else 45 | case l of 46 | [] -> [] 47 | h:t -> h : take (n - 1) t 48 | 49 | 50 | -- I/O helpers 51 | 52 | reverse :: [a] -> [a] 53 | reverse l = 54 | let revA a l = case l of [] -> a 55 | h:t -> revA (h:a) t 56 | in revA [] l 57 | 58 | fromString :: String -> Integer 59 | fromString s = 60 | let fromStringI i limit acc s = 61 | if limit == i then acc 62 | else if limit < i then acc 63 | else 64 | fromStringI (i + 1) limit (acc * 10 + (str_elem s i - 48)) s 65 | in fromStringI 0 (strlen s) 0 s 66 | 67 | toString :: Integer -> String 68 | toString i = 69 | let toString0 i = 70 | if i == 0 then [] 71 | else (i `mod` 10 + 48) : toString0 (i `div` 10) 72 | in if i < 0 then "-" ++ (implode $ reverse $ toString0 (0-i)) 73 | else if i == 0 then "0" 74 | else implode $ reverse $ toString0 i 75 | 76 | implode l = 77 | case l of 78 | [] -> "" 79 | h:t -> #(__Implode) h ++ implode t 80 | 81 | read_arg1 = Act (#(cline_arg) " ") 82 | 83 | print s = Act (#(stdout) (s ++ "\n")) 84 | 85 | 86 | -- Overloads 87 | 88 | s1 ++ s2 = #(__Concat) s1 s2 89 | 90 | str_elem :: String -> Integer -> Integer 91 | str_elem s i = #(__Elem) s i 92 | 93 | strlen :: String -> Integer 94 | strlen s = #(__Len) s 95 | 96 | return v = Ret v 97 | -------------------------------------------------------------------------------- /examples/syntax.hs: -------------------------------------------------------------------------------- 1 | -- ***** A near-exhaustive demonstration of PureLang syntax ***** 2 | 3 | -- NB all constructors and built-ins must be fully applied 4 | 5 | -- ** Built-ins ** 6 | 7 | -- Unit and tuples, of types `()`, `(a,b,...)` 8 | unit = () 9 | unitTriple = ( () , () , () ) 10 | 11 | -- Booleans, of type `Bool` 12 | bools = (True, False) 13 | 14 | -- Arbitrary-precision ("bignum") integers, of type `Integer` 15 | zero = 0 16 | minusOne = ~1 17 | fortyTwo = 42 18 | 19 | integerOperations i i' = 20 | ( i + i' -- addition 21 | , i - i' -- subtraction 22 | , i * i' -- multiplication 23 | , div i i' -- integer division (round down, i.e. -3 / 2 == -2) - NB ∀i. i / 0 == 0 24 | , mod i i' -- modulus (e.g. mod 5 2 == 1) - NB negative when i' is negative, and ∀i. mod i 0 == 0 25 | ) 26 | 27 | integerComparisons i i' = -- return type `Bool` 28 | ( i == i' -- equality 29 | , i < i' -- less than 30 | , i > i' -- greater than 31 | -- , i <= i' -- coming soon: less than or equal 32 | -- , i >= i' -- coming soon: greater than or equal to 33 | ) 34 | 35 | -- Strings, of type `String` 36 | -- NB strings are *not* lists of characters, but packed-bytes (like Haskell's `Text`) 37 | -- we use `Integer` for character-based operations 38 | stringLiterals = ( "" , "Hello" , "World!" , "\n") 39 | 40 | stringOperations s s' = 41 | ( #(__Len) s -- length 42 | , #(__Elem) s 0 -- index a character (i.e. `Integer` - -1 if out of bounds) 43 | , #(__Concat) s s' -- concatenation (multi-arity, i.e. #(__Concat) s1 s2 s3 ... is fine) 44 | , #(__Implode) 70 111 111 -- string from integers, i.e. "Foo" (multi-arity, considers input modulus 256) 45 | , #(__Substring) s 2 -- substring, removes first two characters 46 | , #(__Substring) s 2 5 -- substring, removes first two characters and takes next five 47 | ) -- NB substring operations will adjust bounds to fall within the string 48 | 49 | stringComparisons s s' = -- return type `Bool` 50 | ( #(__StrEq) s s' -- equality 51 | , #(__StrLt) s s' -- less than 52 | , #(__StrLeq) s s' -- less than or equal 53 | , #(__StrGt) s s' -- greater than 54 | , #(__StrGeq) s s' -- greater than or equal to 55 | ) 56 | 57 | -- Lists, of type `[a]` 58 | listLiterals = ( [] , [1,2,3] , 4:5:6:[] ) 59 | 60 | 61 | -- ** Monadic operations, returning type `IO a` ** 62 | 63 | -- Monadic sequencing 64 | return x = Ret x 65 | bind x f = Bind x f 66 | 67 | doNotation f g input = do 68 | Ret () -- return value, do not bind result 69 | x <- input -- bind value 70 | let y = f x -- pure assignment 71 | g y 72 | -- can use indentation insenstive forms: 73 | -- x <- input ; Ret x { x <- input 74 | -- Ret x } 75 | 76 | -- Arrays, of type `Array a` 77 | arrayOperations a len elem idx = 78 | ( Alloc len elem -- allocate with length `len`, filled with `elem` 79 | , Length a -- length 80 | , Deref a idx -- index, throws `Subscript` on out-of-bounds 81 | , Update a idx elem -- update at index, throws `Subscript` on out-of-bounds 82 | ) 83 | 84 | -- Exceptions 85 | -- coming soon: declarable exceptions, i.e. ML-style extensible exception type 86 | -- e.g. exn MyException String 87 | exceptions = [ Subscript ] 88 | 89 | throwException = Raise Subscript 90 | exceptionHandler e = Ret "oops!" 91 | handleException = Handle throwException exceptionHandler 92 | 93 | 94 | -- Foreign function interface 95 | performFFI ffiAction = Act ffiAction 96 | 97 | printAction string = #(stdout) string -- does not add line break 98 | readArgumentAction = #(cline_arg) " " 99 | -- TODO others? 100 | 101 | 102 | -- ** Expressions and declarations ** 103 | 104 | -- Top-level declarations - mutually recursive, reorderable 105 | myFunc arg1 arg2 = myVal arg2 arg1 -- function declaration 106 | myVal = myFunc -- value declaration 107 | 108 | f $ x = f x -- infix declaration 109 | quotedInfix = 42 `mod` 6 -- back-quoted infix operations 110 | compose f g = \x -> f (g x) -- lambdas / anonymous functions 111 | 112 | id :: a -> a -- with type signature (currently ignored) 113 | id x = x 114 | 115 | -- ($) : (a -> b) -> a -> b -- coming soon: type signatures for infixes 116 | -- myInfix = ($) -- coming soon: partially-applied infixes 117 | 118 | data Tree a = Leaf -- data type declaration 119 | | Branch (Tree a) a (Tree a) 120 | 121 | sequence a b = seq a b -- Haskell's `seq` statement 122 | 123 | -- if-statements 124 | myIf b e1 e2 = if b then e1 else e2 125 | -- indentation sensitive, e.g. 126 | -- if b then e1 if b then e1 if b then if b then 127 | -- else e2 else e2 e1 e1 128 | -- else e2 else 129 | -- e2 130 | 131 | -- let-statements 132 | -- can be (mutually) recursive, re-orderable 133 | myLet = let f = id 134 | g = id 135 | in f g 136 | -- indentation insenstive form: 137 | -- let { f = id 138 | -- ; g = id } in f g 139 | 140 | -- case-statements 141 | -- must be exhaustive - or last row can be wildcard (`_`) instead 142 | -- no nested pattern-matches - can only match on constructors applied to variables 143 | isEmptyList l = case l of [] -> True 144 | _ -> False 145 | 146 | isEmptyTree t = 147 | case t of 148 | Leaf -> True 149 | Branch l a r -> False -- `Branch Leaf a r` is illegal here 150 | 151 | true = case bools of (b1, b2) -> b1 152 | 153 | -- main :: IO () must be declared 154 | main = Ret () 155 | 156 | -------------------------------------------------------------------------------- /language/Holmakefile: -------------------------------------------------------------------------------- 1 | INCLUDES = ../misc 2 | -------------------------------------------------------------------------------- /meta-theory/Holmakefile: -------------------------------------------------------------------------------- 1 | INCLUDES = ../misc ../language 2 | -------------------------------------------------------------------------------- /meta-theory/exp_eqSimps.sig: -------------------------------------------------------------------------------- 1 | signature exp_eqSimps = 2 | sig 3 | 4 | val EXPEQ_ss : simpLib.ssfrag 5 | 6 | end 7 | -------------------------------------------------------------------------------- /meta-theory/exp_eqSimps.sml: -------------------------------------------------------------------------------- 1 | structure exp_eqSimps :> exp_eqSimps = 2 | struct 3 | 4 | 5 | open HolKernel simpLib boolSimps boolLib bossLib 6 | 7 | open pure_congruenceTheory pure_congruence_lemmasTheory 8 | structure Parse = 9 | struct 10 | open Parse 11 | val (Type,Term) = parse_from_grammars $ valOf $ grammarDB {thyname="pure_congruence"} 12 | end 13 | 14 | val intro_cong = Q.prove( 15 | ‘a1 ≅ a2 ⇒ b1 ≅ b2 ⇒ (a1 ≅ b1 ⇔ a2 ≅ b2)’, 16 | metisLib.METIS_TAC[exp_eq_sym, exp_eq_trans]); 17 | 18 | val impi = REWRITE_RULE [GSYM AND_IMP_INTRO] 19 | 20 | val PAIR_REL_REFL' = Q.prove( 21 | ‘(∀x. R1 x x) ∧ (∀y. R2 y y) ⇒ ∀p. (R1 ### R2) p p’, 22 | rpt strip_tac >> Cases_on ‘p’ >> simp[pairTheory.PAIR_REL]); 23 | 24 | val PAIR_REL_TRANS' = Q.prove( 25 | ‘(∀x y z. R1 x y ∧ R1 y z ⇒ R1 x z) ∧ (∀a b c. R2 a b ∧ R2 b c ⇒ R2 a c) ⇒ 26 | ∀p1 p2 p3. (R1 ### R2) p1 p2 ∧ (R1 ### R2) p2 p3 ⇒ (R1 ### R2) p1 p3’, 27 | rpt strip_tac >> map_every Cases_on [‘p1’, ‘p2’, ‘p3’] >> 28 | gs[pairTheory.PAIR_REL] >> metis_tac[]); 29 | 30 | val PAIR_REL_SYM' = Q.prove( 31 | ‘(∀x y. R1 x y ⇒ R1 y x) ∧ (∀a b. R2 a b ⇒ R2 b a) ⇒ 32 | ∀p1 p2. (R1 ### R2) p1 p2 ⇒ (R1 ### R2) p2 p1’, 33 | rpt strip_tac >> map_every Cases_on [‘p1’, ‘p2’] >> 34 | gs[pairTheory.PAIR_REL]); 35 | 36 | 37 | val EXPEQ_ss = let 38 | val rsd = {refl = exp_eq_refl, trans = exp_eq_trans, 39 | weakenings = [intro_cong], 40 | subsets = [], 41 | rewrs = [beta_equality, exp_eq_Add, Let_Var, exp_eq_IfT, Let_Var', 42 | Seq_Fail, Let_Fail]} 43 | val frag1 = relsimp_ss rsd 44 | val congs = SSFRAG { 45 | dprocs = [], ac = [], rewrs = [], name = NONE, 46 | congs = [exp_eq_Lam_cong, exp_eq_App_cong, exp_eq_Let_cong_noaconv, 47 | exp_eq_If_cong, exp_eq_COND_cong, exp_eq_Seq_cong 48 | (* , 49 | letrec_cong'*) ], 50 | convs = [], 51 | filter = NONE} 52 | in 53 | merge_ss [frag1, congs] |> name_ss "EXPEQ_ss" |> register_frag 54 | end 55 | 56 | (* 57 | val lreq_refl = Q.prove( 58 | ‘lrt xs xs’, 59 | simp[listTheory.EVERY2_refl,PAIR_REL_REFL',exp_eq_refl]); 60 | val lreq_trans = Q.prove( 61 | ‘lrt x y ∧ lrt y z ⇒ lrt x z’, 62 | MATCH_MP_TAC pure_miscTheory.LIST_REL_TRANS >> 63 | MATCH_MP_TAC PAIR_REL_TRANS' >> simp[] >> 64 | ACCEPT_TAC exp_eq_trans); 65 | val lreq_sym = Q.prove( 66 | ‘lrt x y ⇒ lrt y x’, 67 | MATCH_MP_TAC $ iffLR LIST_REL_SYM >> 68 | simp[EQ_IMP_THM, FORALL_AND_THM, SF CONJ_ss] >> rpt gen_tac >> 69 | MATCH_MP_TAC PAIR_REL_SYM' >> simp[exp_eq_sym]); 70 | val lrintro_cong = Q.prove( 71 | ‘lrt a1 a2 ∧ lrt b1 b2 ⇒ (lrt a1 b1 ⇔ lrt a2 b2)’, 72 | metisLib.METIS_TAC[lreq_sym, lreq_trans]); 73 | 74 | val lr_cons_cong = Q.prove( 75 | ‘k1 = k2 ⇒ x ≅ y ⇒ lrt xs ys ⇒ lrt ((k1,x)::xs) ((k2,y)::ys)’, 76 | rpt strip_tac >> 77 | simp[listTheory.LIST_REL_CONS1, pairTheory.PAIR_REL]); 78 | 79 | val LREXPEQ_ss = let 80 | val rsd = {refl = lreq_refl, trans = lreq_trans, 81 | weakenings = [lrintro_cong], 82 | subsets = [], 83 | rewrs = []} 84 | val frag1 = relsimp_ss rsd 85 | val congs = SSFRAG {dprocs = [], ac = [], rewrs = [], name = NONE, 86 | congs = [lr_cons_cong], 87 | convs = [], 88 | filter = NONE} 89 | in 90 | merge_ss [frag1, congs] |> name_ss "LREXPEQ_ss" 91 | end 92 | 93 | 94 | val doeswork = 95 | SIMP_CONV (srw_ss() ++ EXPEQ_ss) 96 | [pure_expTheory.closed_def, pure_expTheory.freevars_def, 97 | pure_exp_lemmasTheory.subst1_def] 98 | “X ≅ Let x (Lit (Int 3)) (Prim (AtomOp Add) [Var x; Lit (Int 4)])”; 99 | 100 | (* sadly doesn't work 101 | SIMP_CONV (srw_ss() ++ EXPEQ_ss ++ LREXPEQ_ss) 102 | [pure_expTheory.closed_def, pure_expTheory.freevars_def, 103 | pure_exp_lemmasTheory.subst1_def] 104 | “Y ≅ Letrec [(f, Prim (AtomOp Add) [Lit (Int 4); Lit(Int 7)])] (Var x)” 105 | *) 106 | 107 | *) 108 | end (* struct *) 109 | -------------------------------------------------------------------------------- /meta-theory/pure_congruence_lemmasScript.sml: -------------------------------------------------------------------------------- 1 | open HolKernel Parse boolLib bossLib; 2 | 3 | open listTheory pred_setTheory finite_mapTheory 4 | open pure_congruenceTheory pure_exp_lemmasTheory 5 | 6 | val _ = new_theory "pure_congruence_lemmas"; 7 | 8 | Theorem Apps_APPEND: 9 | ∀f xs ys. Apps f (xs ++ ys) = Apps (Apps f xs) ys 10 | Proof 11 | Induct_on ‘xs’ >> simp[pure_expTheory.Apps_def] 12 | QED 13 | 14 | Theorem exp_eq_Apps_cong: 15 | ∀b f1 f2 es1 es2. 16 | (f1 ≅? f2) b ∧ LIST_REL (λe1 e2. (e1 ≅? e2) b) es1 es2 ⇒ 17 | (Apps f1 es1 ≅? Apps f2 es2) b 18 | Proof 19 | Induct_on ‘es1’ using SNOC_INDUCT >> 20 | simp[Apps_SNOC, LIST_REL_SNOC, PULL_EXISTS, Apps_APPEND, 21 | pure_expTheory.Apps_def] >> rpt strip_tac >> 22 | irule exp_eq_App_cong >> simp[] 23 | QED 24 | 25 | Theorem exp_eq_Lams_cong_noaconv: 26 | (e1 ≅? e2) b ⇒ (Lams vs e1 ≅? Lams vs e2) b 27 | Proof 28 | Induct_on ‘vs’ >> simp[pure_expTheory.Lams_def, exp_eq_Lam_cong] 29 | QED 30 | 31 | Theorem exp_eq_Let_cong_noaconv: 32 | (e1 ≅? e2) b ∧ (bod1 ≅? bod2) b ⇒ 33 | (Let v e1 bod1 ≅? Let v e2 bod2) b 34 | Proof 35 | simp[exp_eq_App_cong, exp_eq_Lam_cong] 36 | QED 37 | 38 | Theorem exp_eq_If_cong: 39 | (g1 ≅? g2) b ∧ (t1 ≅? t2) b ∧ (e1 ≅? e2) b ⇒ 40 | (If g1 t1 e1 ≅? If g2 t2 e2) b 41 | Proof 42 | simp[exp_eq_Prim_cong] 43 | QED 44 | 45 | Theorem exp_eq_Seq_cong: 46 | (e11 ≅? e21) b ∧ (e12 ≅? e22) b ⇒ (Seq e11 e12 ≅? Seq e21 e22) b 47 | Proof 48 | strip_tac >> irule exp_eq_Prim_cong >> simp[] 49 | QED 50 | 51 | Theorem exp_eq_IfT: 52 | (If (Cons "True" []) e1 e2 ≅? e1) b 53 | Proof 54 | irule pure_exp_relTheory.eval_IMP_exp_eq >> 55 | simp[pure_expTheory.subst_def, pure_evalTheory.eval_thm] 56 | QED 57 | 58 | Theorem exp_eq_COND_cong: 59 | (P ⇒ e1 ≅ d1) ∧ (¬P ⇒ e2 ≅ d2) ⇒ 60 | (if P then e1 else e2) ≅ (if P then d1 else d2) 61 | Proof 62 | rw[] 63 | QED 64 | 65 | Theorem Let_Fail: 66 | (Let w e Fail ≅? Fail) b 67 | Proof 68 | simp[Let_Prim_alt] 69 | QED 70 | 71 | Theorem Seq_Fail: 72 | (Seq Fail e ≅? Fail) b 73 | Proof 74 | simp[pure_exp_relTheory.exp_eq_def, pure_expTheory.bind_def] >> rw[] >> 75 | irule pure_exp_relTheory.eval_IMP_app_bisimilarity >> 76 | simp[pure_expTheory.subst_def] >> conj_tac 77 | >- (irule IMP_closed_subst >> gs[FRANGE_DEF, PULL_EXISTS, FLOOKUP_DEF]) >> 78 | simp[pure_evalTheory.eval_thm] 79 | QED 80 | 81 | Theorem Let_Var': 82 | (Let v (Var v) M ≅? M) b 83 | Proof 84 | simp[pure_exp_relTheory.exp_eq_def, pure_expTheory.bind_def] >> rw[] >> 85 | simp[pure_expTheory.subst_def] >> 86 | irule pure_exp_relTheory.eval_IMP_app_bisimilarity >> 87 | ‘(∀v. v ∈ FRANGE f ⇒ closed v) ∧ (∀w. w ∈ FRANGE (f \\ v) ⇒ closed w)’ 88 | by gs[FRANGE_DEF, PULL_EXISTS, FLOOKUP_DEF, DOMSUB_FAPPLY_THM] >> 89 | rw[] 90 | >- (simp[freevars_subst] >> gs[SUBSET_DEF, SF CONJ_ss]) 91 | >- gs[FLOOKUP_DEF] 92 | >- (irule IMP_closed_subst >> simp[]) >> 93 | gs[pure_evalTheory.eval_Let, pure_expTheory.bind_def, FLOOKUP_DEF] >> 94 | simp[subst_subst_FUNION] >> rpt (AP_TERM_TAC ORELSE AP_THM_TAC) >> 95 | simp[fmap_EXT] >> rw[] 96 | >- (simp[EXTENSION] >> metis_tac[]) 97 | >- simp[FUNION_DEF, DOMSUB_FAPPLY_THM] 98 | >- simp[FUNION_DEF, DOMSUB_FAPPLY_THM] 99 | QED 100 | 101 | val _ = export_theory(); 102 | -------------------------------------------------------------------------------- /misc/fix_files.sml: -------------------------------------------------------------------------------- 1 | 2 | fun curry f x y = f (x,y); 3 | 4 | fun read_all_lines filename = 5 | let 6 | val f = TextIO.openIn(filename) 7 | fun read_rest () = 8 | case TextIO.inputLine(f) of 9 | NONE => [] 10 | | SOME line => line :: read_rest () 11 | val all_lines = read_rest () 12 | val _ = TextIO.closeIn f 13 | in SOME all_lines end 14 | handle e => NONE; 15 | 16 | fun write_file filename lines = let 17 | val f = TextIO.openOut(filename) 18 | val _ = List.app (curry TextIO.output f) lines 19 | val _ = TextIO.closeOut f 20 | in () end; 21 | 22 | val old_suffix = " " ^ implode (map chr [226, 136, 167, 10]); 23 | val old_prefix = "[" 24 | val new_suffix = "\n" 25 | 26 | fun process [] = [] 27 | | process [l1] = [l1] 28 | | process (l1::l2::[]) = l1::l2::[] 29 | | process (l1::l2::l3::lines) = 30 | if String.isSuffix old_suffix l1 andalso 31 | (String.isPrefix old_prefix l2 orelse 32 | (String.isPrefix old_prefix l3 andalso l2 = "\n")) 33 | then 34 | (String.substring(l1,0,String.size(l1) - String.size(old_suffix)) ^ new_suffix) 35 | :: process (l2::l3::lines) 36 | else 37 | l1 :: process (l2::l3::lines); 38 | 39 | fun fix_file filename = 40 | case read_all_lines filename of 41 | NONE => () 42 | | SOME lines => write_file filename (process lines); 43 | 44 | fun main () = 45 | let 46 | val args = CommandLine.arguments () 47 | in 48 | List.app fix_file args 49 | end; 50 | -------------------------------------------------------------------------------- /misc/quotient_llistScript.sml: -------------------------------------------------------------------------------- 1 | 2 | open bossLib boolLib; 3 | open HolKernel llistTheory listTheory quotientLib pure_miscTheory; 4 | 5 | val _ = new_theory "quotient_llist"; 6 | 7 | Triviality LMAP_id: 8 | LMAP (\x. x) = \x. x 9 | Proof 10 | irule EQ_EXT >> 11 | irule LLIST_EQ >> 12 | rw[] >> 13 | Cases_on `x` >> gvs[LMAP] 14 | QED 15 | 16 | Theorem llist_map_I: 17 | LMAP I = I 18 | Proof 19 | rw [I_def, LMAP_id] 20 | QED 21 | 22 | Theorem llist_rel_equality: 23 | llist_rel $= = $= 24 | Proof 25 | irule EQ_EXT >> rw[] >> 26 | irule EQ_EXT >> rw[] >> 27 | rename1 `llist_rel _ a b` >> 28 | fs[llist_rel_def] >> 29 | EQ_TAC >> rw[] >> gvs[] >> 30 | rw[LNTH_EQ] >> 31 | Cases_on `LNTH n a` 32 | >- ( 33 | imp_res_tac LNTH_NONE_LLENGTH >> gvs[] >> 34 | imp_res_tac LNTH_LLENGTH_NONE >> gvs[] 35 | ) >> 36 | reverse (Cases_on `LNTH n b`) >> gvs[] 37 | >- ( 38 | first_x_assum irule >> 39 | goal_assum drule >> simp[] 40 | ) 41 | >- ( 42 | imp_res_tac LNTH_NONE_LLENGTH >> gvs[] >> 43 | imp_res_tac LNTH_LLENGTH_NONE >> gvs[] 44 | ) 45 | QED 46 | 47 | Theorem llist_rel_REFL: 48 | ∀R. 49 | (∀x y. R x y ⇔ R x = R y) ⇒ 50 | ∀z. llist_rel R z z 51 | Proof 52 | simp [llist_rel_def, PULL_FORALL] 53 | \\ rpt gen_tac 54 | \\ map_every qid_spec_tac [‘x’, ‘y’, ‘z’, ‘i’] 55 | \\ Induct \\ rw [] 56 | >- fs [LNTH] 57 | \\ Q.ISPECL_THEN [‘z’] strip_assume_tac llist_CASES \\ fs [] 58 | QED 59 | 60 | Triviality llist_rel_lemma: 61 | ∀R. 62 | (∀x y. R x y ⇔ R x = R y) ⇒ 63 | ∀z w. 64 | llist_rel R z w ⇒ llist_rel R z = llist_rel R w 65 | Proof 66 | rw[] >> irule EQ_EXT >> fs[llist_rel_def] >> 67 | rw[] >> EQ_TAC >> rw[] >> 68 | rfs[] >> res_tac 69 | >- ( 70 | qsuff_tac `∃ elem_z . LNTH i z = SOME elem_z` 71 | >- (strip_tac >> gvs[]) >> 72 | Cases_on `LNTH i z` >> gvs[] >> 73 | imp_res_tac LNTH_NONE_LLENGTH >> gvs[] >> 74 | imp_res_tac LNTH_LLENGTH_NONE >> gvs[] 75 | ) 76 | >- ( 77 | qsuff_tac `∃ elem_w . LNTH i w = SOME elem_w` 78 | >- (strip_tac >> gvs[]) >> 79 | Cases_on `LNTH i w` >> gvs[] >> 80 | imp_res_tac LNTH_NONE_LLENGTH >> gvs[] >> 81 | imp_res_tac LNTH_LLENGTH_NONE >> gvs[] 82 | ) 83 | QED 84 | 85 | Theorem llist_EQUIV: 86 | ∀R. EQUIV R ⇒ EQUIV (llist_rel R) 87 | Proof 88 | gen_tac 89 | \\ rw [EQUIV_def] 90 | \\ eq_tac 91 | >- metis_tac [llist_rel_lemma] 92 | \\ rw [FUN_EQ_THM] 93 | \\ irule llist_rel_REFL \\ fs [] 94 | QED 95 | 96 | Theorem llist_QUOTIENT: 97 | ∀R abs rep. 98 | QUOTIENT R abs rep ⇒ 99 | QUOTIENT (llist_rel R) (LMAP abs) (LMAP rep) 100 | Proof 101 | rpt strip_tac >> 102 | rw[QUOTIENT_def] 103 | >- ( 104 | drule QUOTIENT_ABS_REP >> 105 | rw[LMAP_MAP, combinTheory.o_DEF, LMAP_id] 106 | ) 107 | >- ( 108 | drule_then assume_tac QUOTIENT_REP_REFL >> 109 | rw[llist_rel_def] >> fs[] 110 | ) >> 111 | rw[llist_rel_def] >> EQ_TAC >> rw[] >> gvs[] 112 | >- ( 113 | first_x_assum drule >> 114 | Cases_on `LNTH i s` >> gvs[] 115 | >- ( 116 | imp_res_tac LNTH_NONE_LLENGTH >> gvs[] >> 117 | imp_res_tac LNTH_LLENGTH_NONE >> gvs[] 118 | ) >> 119 | qpat_x_assum `QUOTIENT _ _ _` mp_tac >> 120 | once_rewrite_tac [QUOTIENT_def] >> 121 | rpt strip_tac >> res_tac 122 | ) 123 | >- ( 124 | first_x_assum (drule_at (Pos last)) >> 125 | Cases_on `LNTH i r` >> gvs[] 126 | >- ( 127 | imp_res_tac LNTH_NONE_LLENGTH >> gvs[] >> 128 | imp_res_tac LNTH_LLENGTH_NONE >> gvs[] 129 | ) >> 130 | qpat_x_assum `QUOTIENT _ _ _` mp_tac >> 131 | once_rewrite_tac [QUOTIENT_def] >> 132 | rpt strip_tac >> res_tac 133 | ) 134 | >- ( 135 | rw[LNTH_EQ] >> 136 | Cases_on `LNTH n r` 137 | >- ( 138 | imp_res_tac LNTH_NONE_LLENGTH >> gvs[] >> 139 | imp_res_tac LNTH_LLENGTH_NONE >> gvs[] 140 | ) >> 141 | Cases_on `LNTH n s` 142 | >- ( 143 | imp_res_tac LNTH_NONE_LLENGTH >> gvs[] >> 144 | imp_res_tac LNTH_LLENGTH_NONE >> gvs[] 145 | ) >> 146 | fs[] >> 147 | first_x_assum (drule_all_then assume_tac) >> 148 | drule_then assume_tac QUOTIENT_REL >> 149 | res_tac 150 | ) 151 | >- ( 152 | `LLENGTH (LMAP abs r) = LLENGTH (LMAP abs s)` by fs[] >> 153 | fs[LLENGTH_MAP] 154 | ) 155 | >- ( 156 | rpt (first_x_assum drule_all >> strip_tac) >> 157 | qpat_x_assum `QUOTIENT _ _ _` mp_tac >> 158 | once_rewrite_tac [QUOTIENT_def] >> strip_tac >> 159 | simp[] >> 160 | `LNTH i (LMAP abs r) = LNTH i (LMAP abs s)` by metis_tac[] >> 161 | pop_assum mp_tac >> simp[] 162 | ) 163 | QED 164 | 165 | val _ = export_theory (); 166 | 167 | -------------------------------------------------------------------------------- /typeclass/Holmakefile: -------------------------------------------------------------------------------- 1 | ifndef CAKEMLDIR 2 | CAKEMLDIR = $(HOME)/cakeml/master 3 | endif 4 | 5 | INCLUDES = $(CAKEMLDIR)/basis/pure \ 6 | $(PUREDIR)/misc \ 7 | $(HOLDIR)/examples/algorithms \ 8 | $(PUREDIR)/typeclass/typing \ 9 | $(PUREDIR)/typeclass/compiler/parsing \ 10 | 11 | -------------------------------------------------------------------------------- /typeclass/README.md: -------------------------------------------------------------------------------- 1 | # TypeclassLang 2 | 3 | This is a language that support type classes. The file structure is similar to pure. 4 | - compiler/parsing: contains the AST for typeclassLang and defines how the AST is translated to TypeclassLang. The lexer and parser is not done yet. 5 | - typing: It contains all the typing related stuffs 6 | - `typeclass_types`: We update the datatype for types to allow types like `m a`. 7 | - `typeclass_kindCheck`: This defines the kinding rules. 8 | - `typeclass_typing`: This translates TypeclassLang to pureLang. It defines the type elaborating relation and the dictionary construction relation (We split the relation in the original paper into two relations). The ie parameter in the relations is generated from the `class_map` and `inst_list`. It also contains how types and environment is translated when typeclassLang is translated to pureLang. 9 | - `test_typeclass_typing`: This is an example that types a program in TypeclassLang and translates it to pureLang. 10 | - `pure_tcexp_typing`: This defines the typing rules for tcexp. We need to change the typing rules because we need to allow constructors like `MonadDict (forall a. m a -> (a -> m a) -> m a)` to make the type translation proof work. 11 | - `typeclass_typingProof`: This proves the if the expression in typeclassLang is well-typed, and we can construct the dictionaries, then the translated expression in pureLang is well-typed. 12 | - `pure_tcexp_typingProof`: This proves the type soundness of the typing relation defined in `pure_tcexp_typing`. The `NestedCase` is still WIP. 13 | - `typeclass_env_map_impl`: This defines the concreate data structures for classes and instances. It defines some well-formedness conditions. It also defines `by_super`, `by_inst` and `entail` (an implementation of `has_dict`), which should be useful for inferencing. 14 | 15 | TODO: 16 | - type soundness proof (`NestedCase` case) 17 | - parsing: lexer, parser and well-formedness check 18 | - concrete implementation of dictionary construction 19 | - type inferencing 20 | - kind inferencing 21 | 22 | -------------------------------------------------------------------------------- /typeclass/compiler/parsing/.gitignore: -------------------------------------------------------------------------------- 1 | parsing-selftest.log 2 | -------------------------------------------------------------------------------- /typeclass/compiler/parsing/Holmakefile: -------------------------------------------------------------------------------- 1 | ifndef CAKEMLDIR 2 | CAKEMLDIR = $(HOME)/cakeml/master 3 | endif 4 | 5 | INCLUDES = $(HOLDIR)/examples/formal-languages/context-free \ 6 | $(CAKEMLDIR)/semantics \ 7 | $(CAKEMLDIR)/basis/pure \ 8 | $(PUREDIR)/typeclass/typing \ 9 | $(PUREDIR)/misc/ 10 | 11 | HOLHEAP = $(CAKEMLDIR)/misc/cakeml-heap 12 | 13 | all: $(DEFAULT_TARGETS) 14 | 15 | .PHONY: all 16 | 17 | -------------------------------------------------------------------------------- /typeclass/compiler/parsing/typeclassASTScript.sml: -------------------------------------------------------------------------------- 1 | open HolKernel Parse boolLib bossLib; 2 | 3 | local open stringTheory integerTheory pure_configTheory in end 4 | val _ = new_theory "typeclassAST"; 5 | 6 | val _ = set_grammar_ancestry ["string", "integer", "pure_config"] 7 | 8 | (* by convention tyOps will be capitalised alpha-idents, or "->", 9 | and tyVars will be lower-case alpha-idents. 10 | 11 | The tyTup constructor should never be applied to a singleton list 12 | *) 13 | 14 | Type ty_consAST = ``:num + string``; 15 | 16 | Datatype: 17 | tyAST = tyOp ty_consAST (tyAST list) (* INL for Tuple *) 18 | | tyVarOp string (tyAST list) 19 | End 20 | 21 | Datatype: 22 | PredtyAST = Predty ((string # tyAST) list) tyAST 23 | End 24 | 25 | Overload boolTy = “tyOp (INR "Bool") []”; 26 | Overload intTy = “tyOp (INR "Integer") []” 27 | Overload listTy = “λty. tyOp (INR "[]") [ty]” 28 | Overload funTy = “λd r. tyOp (INR "Fun") [d; r]” 29 | 30 | Datatype: 31 | litAST = litInt int | litString string 32 | End 33 | 34 | Datatype: 35 | patAST = patVar string 36 | | patApp string (patAST list) 37 | | patTup (patAST list) 38 | | patLit litAST 39 | (* TODO: annotate the type of the pattern *) 40 | (* | patTy patAST tyAST *) 41 | | patUScore 42 | End 43 | 44 | Datatype: 45 | expAST = expVar string 46 | | expCon string (expAST list) 47 | | expOp pure_config$atom_op (expAST list) 48 | | expTup (expAST list) 49 | | expApp expAST expAST 50 | | expAbs patAST expAST 51 | | expIf expAST expAST expAST 52 | | expLit litAST 53 | | expLet (expdecAST list) expAST 54 | | expDo (expdostmtAST list) expAST 55 | | expCase expAST ((patAST # expAST) list) 56 | | expUserAnnot tyAST expAST; 57 | expdecAST = expdecTysig string PredtyAST 58 | | expdecPatbind patAST expAST 59 | | expdecFunbind string (patAST list) expAST ; 60 | expdostmtAST = expdostmtExp expAST 61 | | expdostmtBind patAST expAST 62 | | expdostmtLet (expdecAST list) 63 | End 64 | 65 | Theorem better_expAST_induction = 66 | TypeBase.induction_of “:expAST” 67 | |> Q.SPECL [‘eP’, ‘dP’, ‘doP’, 68 | ‘λpes. ∀p e. MEM (p,e) pes ⇒ eP e’, 69 | ‘λpe. eP (SND pe)’, 70 | ‘λdds. ∀ds. MEM ds dds ⇒ doP ds’, 71 | ‘λes. ∀e. MEM e es ⇒ eP e’, 72 | ‘λds. ∀d. MEM d ds ⇒ dP d’] 73 | |> SRULE [DISJ_IMP_THM, FORALL_AND_THM, pairTheory.FORALL_PROD, 74 | DECIDE “p ∧ q ⇒ q ⇔ T”] 75 | |> UNDISCH 76 | |> SRULE [Cong (DECIDE “p = p' ∧ (p' ⇒ q = q') ⇒ (p ∧ q ⇔ p' ∧ q')”)] 77 | |> DISCH_ALL 78 | |> Q.GENL [‘eP’, ‘dP’, ‘doP’] 79 | 80 | val _ = add_strliteral_form {ldelim = "‹", inj = “expVar”} 81 | Overload pNIL = “expCon "[]" []” 82 | Overload pCONS = “λe1 e2. expCon "::" [e1;e2]” 83 | val _ = set_mapped_fixity {fixity = Infixr 490,term_name = "pCONS",tok = "::ₚ"} 84 | 85 | val _ = set_fixity "⬝" (Infixl 600) 86 | Overload "⬝" = “expApp” 87 | 88 | Definition strip_comb_def: 89 | strip_comb (expApp f x) = (I ## (λl. l ++ [x])) (strip_comb f) ∧ 90 | strip_comb (expUserAnnot ty x) = strip_comb x ∧ 91 | strip_comb e = (e, []) 92 | End 93 | 94 | Definition dest_expVar_def: 95 | dest_expVar (expVar s) = SOME s ∧ 96 | dest_expVar (expUserAnnot t e) = dest_expVar e ∧ 97 | dest_expVar _ = NONE 98 | End 99 | 100 | Definition dest_expLet_def: 101 | dest_expLet (expLet ads e) = SOME (ads,e) ∧ 102 | dest_expLet (expUserAnnot t e) = dest_expLet e ∧ 103 | dest_expLet _ = NONE 104 | End 105 | 106 | val _ = add_rule {term_name = "expAbs", fixity = Prefix 1, 107 | block_style = (AroundEachPhrase, (PP.CONSISTENT, 0)), 108 | pp_elements = [TOK "𝝺", TM, TOK "．", BreakSpace(1,2)], 109 | paren_style = OnlyIfNecessary} 110 | 111 | Type classname = ``:string``; 112 | 113 | Type minImplAST = ``:(string list) list``; (* DNF of function names*) 114 | 115 | (* for declClass: 116 | * we only allow something like class Functor a => Monad a, 117 | * where there is only one type variable and 118 | * it cannot used as Functor [a] *) 119 | (* only classname list is needed is for now *) 120 | 121 | (* for declInst: 122 | * we only allow the constraints to be 123 | * ``instance (Cl1 a,Cl2 b,...) => Cl ty``, 124 | * where ty can be any type that uses a, b... 125 | * This ensures that ty is not smaller or equal to a,b..., 126 | * which let us prove the termination of typeclass resolution. 127 | *) 128 | 129 | Datatype: 130 | declAST = declTysig string PredtyAST 131 | | declData string (string list) 132 | ((string # tyAST list) list) 133 | | declFunbind string (patAST list) expAST 134 | | declPatbind patAST expAST 135 | | declClass (classname list) classname string minImplAST (expdecAST list) 136 | (* enforce type sigs for functions definintion in class *) 137 | | declInst 138 | (* constraints: list of class and variables *) 139 | ((classname # string) list) 140 | classname 141 | (* type must be in the form `C v1 v2 ...`, 142 | * where C is a type constructor *) 143 | ty_consAST (string list) 144 | (expdecAST list) 145 | End 146 | 147 | val _ = export_theory(); 148 | -------------------------------------------------------------------------------- /typeclass/typing/Holmakefile: -------------------------------------------------------------------------------- 1 | INCLUDES = $(PUREDIR)/misc $(PUREDIR)/language $(PUREDIR)/meta-theory \ 2 | $(PUREDIR)/compiler/backend \ 3 | $(PUREDIR)/compiler/parsing/sexp \ 4 | $(PUREDIR)/compiler/backend/languages/properties \ 5 | $(PUREDIR)/compiler/backend/languages/semantics \ 6 | $(PUREDIR)/compiler/backend/passes \ 7 | $(CAKEMLDIR)/basis/pure \ 8 | $(HOLDIR)/examples/algorithms/unification/triangular/first-order 9 | -------------------------------------------------------------------------------- /typeclass/typing/acyclic_terminationScript.sml: -------------------------------------------------------------------------------- 1 | open HolKernel Parse boolLib bossLib BasicProvers dep_rewrite; 2 | open arithmeticTheory listTheory; 3 | open relationTheory set_relationTheory pred_setTheory finite_mapTheory; 4 | 5 | val _ = new_theory "acyclic_termination"; 6 | 7 | Definition acyclic_rec_def: 8 | acyclic_rec r f err x = 9 | if acyclic r ∧ ∃s. FINITE s ∧ domain r ⊆ s ∧ range r ⊆ s 10 | then 11 | let children = SET_TO_LIST {y | r (y,x)} in 12 | f x children (MAP (acyclic_rec r f err) children) 13 | else err 14 | Termination 15 | WF_REL_TAC `λx y. 16 | FST x = FST y ∧ 17 | acyclic (FST y) ∧ ∃s. FINITE s ∧ domain (FST y) ⊆ s ∧ range (FST y) ⊆ s ∧ 18 | (FST y) (SND $ SND $ SND x, SND $ SND $ SND y)` 19 | >- ( 20 | qspecl_then [ 21 | `\r. acyclic r ∧ ∃s. FINITE s ∧ domain r ⊆ s ∧ range r ⊆ s`, 22 | `FST`, 23 | `λr x y. r(x,y)`, 24 | `SND o SND o SND` 25 | ] irule WF_PULL >> 26 | reverse $ rw[] 27 | >- ( 28 | drule_all acyclic_WF >> 29 | simp[reln_to_rel_def,IN_DEF] 30 | ) >> 31 | metis_tac[] 32 | ) >> 33 | rw[] >> 34 | pop_assum mp_tac >> 35 | DEP_REWRITE_TAC[MEM_SET_TO_LIST] >> 36 | reverse $ rw[] 37 | >- metis_tac[] >> 38 | drule_then irule SUBSET_FINITE >> 39 | gvs[domain_def] >> 40 | rev_drule_at_then Any irule SUBSET_TRANS >> 41 | rw[SUBSET_DEF,IN_DEF] >> 42 | metis_tac[] 43 | End 44 | 45 | Definition acyclic_depth_def: 46 | acyclic_depth r x = acyclic_rec r (λx xs ys. list_max ys + 1n) 0 x 47 | End 48 | 49 | Theorem list_max_MAX_SET_set: 50 | list_max l = MAX_SET (set l) 51 | Proof 52 | Induct_on `l` >> 53 | rw[miscTheory.list_max_def,MAX_SET_THM,MAX_DEF] 54 | QED 55 | 56 | (* helper function for termination proof with acyclicity *) 57 | Theorem acyclic_depth_alt: 58 | ∀r x. 59 | acyclic_depth r x = 60 | if acyclic r ∧ ∃s. FINITE s ∧ domain r ⊆ s ∧ range r ⊆ s 61 | then 62 | MAX_SET (IMAGE (acyclic_depth r) {y | r (y,x)}) + 1 63 | else 0 64 | Proof 65 | simp[lambdify acyclic_depth_def] >> 66 | `∀r f e x. 67 | f = (λx xs ys. list_max ys + 1) ∧ e = 0 ⇒ 68 | acyclic_rec r f e x = 69 | if acyclic r ∧ ∃s. FINITE s ∧ domain r ⊆ s ∧ range r ⊆ s then 70 | MAX_SET (IMAGE (λx. acyclic_rec r f e x) {y | r (y,x)}) + 1 71 | else 0` suffices_by rw[] >> 72 | ho_match_mp_tac acyclic_rec_ind >> 73 | reverse $ rw[] 74 | >- simp[acyclic_rec_def] >> 75 | simp[Once acyclic_rec_def] >> 76 | reverse $ IF_CASES_TAC 77 | >- metis_tac[] >> 78 | simp[list_max_MAX_SET_set,LIST_TO_SET_MAP] >> 79 | DEP_REWRITE_TAC[SET_TO_LIST_INV] >> 80 | gvs[domain_def,IN_DEF] >> 81 | drule_then irule SUBSET_FINITE >> 82 | rev_drule_at_then Any irule SUBSET_TRANS >> 83 | rw[SUBSET_DEF,IN_DEF] >> 84 | metis_tac[] 85 | QED 86 | 87 | Theorem acyclic_super_FINITE: 88 | ∃s. 89 | FINITE s ∧ 90 | domain 91 | (λp. ∃s ts. FLOOKUP ce (SND p) = SOME (s,ts) ∧ 92 | MEM (FST p) s) ⊆ s ∧ 93 | range 94 | (λp. ∃s ts. FLOOKUP ce (SND p) = SOME (s,ts) ∧ 95 | MEM (FST p) s) ⊆ s 96 | Proof 97 | qexists `FDOM ce ∪ 98 | BIGUNION (IMAGE (set o FST) $ FRANGE ce)` >> 99 | rw[] 100 | >- simp[FINITE_LIST_TO_SET] 101 | >- ( 102 | irule SUBSET_TRANS >> 103 | irule_at (Pos last) $ cj 2 SUBSET_UNION >> 104 | rw[SUBSET_DEF,IN_DEF,domain_def, 105 | SRULE[IN_DEF] FRANGE_FLOOKUP] >> 106 | first_x_assum $ irule_at (Pos last) >> 107 | simp[] 108 | ) >> 109 | irule SUBSET_TRANS >> 110 | irule_at (Pos last) $ cj 1 SUBSET_UNION >> 111 | rw[SUBSET_DEF,range_def,flookup_thm] 112 | QED 113 | 114 | val _ = export_theory(); 115 | -------------------------------------------------------------------------------- /typeclass/typing/test_typeclass_typing.hs: -------------------------------------------------------------------------------- 1 | import Prelude hiding (Monoid(..),Semigroup(..),Foldable(..)) 2 | 3 | class Semigroup a where 4 | mappend :: a -> a -> a 5 | 6 | class Semigroup a => Monoid a where 7 | mempty :: a 8 | 9 | class Foldable t where 10 | foldMap :: Monoid m => (a -> m) -> t a -> m 11 | toList :: t a -> [a] 12 | toList = foldMap (\x -> [x]) 13 | 14 | instance Semigroup Integer where 15 | mappend x y = x + y 16 | 17 | instance Monoid Integer where 18 | mempty = 0 19 | 20 | instance Semigroup [a] where 21 | mappend = append 22 | 23 | instance Monoid [a] where 24 | mempty = [] 25 | 26 | instance Foldable [] where 27 | foldMap f t = case t of 28 | h:tl -> mappend (f h) (foldMap f tl) 29 | _ -> mempty 30 | 31 | instance (Monoid a,Monoid b) => Monoid (a,b) where 32 | mempty = (mempty,mempty) 33 | 34 | instance (Semigroup a,Semigroup b) => Semigroup (a,b) where 35 | mappend x y = case (x,y) of 36 | ((x1,x2),(y1,y2)) -> (mappend x1 y1,mappend x2 y2) 37 | 38 | append :: [a] -> [a] -> [a] 39 | append l r = case l of 40 | h:tl -> h:append tl r 41 | [] -> r 42 | 43 | test :: (Integer,Integer) 44 | test = 45 | let 46 | fold::(Foldable t,Monoid m) => t m -> m 47 | fold = foldMap id 48 | in fold (fold (toList [[(1::Integer,1::Integer)]])) 49 | 50 | -------------------------------------------------------------------------------- /typeclass/typing/test_typeclass_typing_translated.hs: -------------------------------------------------------------------------------- 1 | import Prelude hiding (Monoid(..),Semigroup(..),Foldable(..)) 2 | 3 | data Semigroup a = SemigroupDict (a -> a -> a) 4 | 5 | data Monoid a = MonoidDict (Semigroup a) a 6 | 7 | data Foldable t = FoldableDict 8 | (forall a m. Monoid m -> (a -> m) -> t a -> m) 9 | (forall a. t a -> [a]) 10 | 11 | mappend = \x -> case x of 12 | SemigroupDict y -> y 13 | 14 | getSemigroup = \x -> case x of 15 | MonoidDict y _ -> y 16 | 17 | mempty = \x -> case x of 18 | MonoidDict _ y -> y 19 | 20 | foldMap = \x -> case x of 21 | FoldableDict y _ -> y 22 | 23 | toList = \x -> case x of 24 | FoldableDict _ y -> y 25 | 26 | semigroupInt = SemigroupDict (\x y -> x + (y::Integer)) 27 | 28 | monoidInt = MonoidDict semigroupInt (0::Integer) 29 | 30 | foldableList = FoldableDict 31 | (\m f t -> case t of 32 | h:tl -> (mappend (getSemigroup m)) (f h) ((foldMap foldableList m) f tl) 33 | _ -> mempty m) 34 | (default_toList foldableList) 35 | 36 | default_toList = \y -> (foldMap y monoidList) (\x -> x:[]) 37 | 38 | semigroupList = SemigroupDict append 39 | 40 | monoidList = MonoidDict semigroupList [] 41 | 42 | monoidTuple = \m1 m2 -> 43 | MonoidDict 44 | (semigroupTuple (getSemigroup m1) (getSemigroup m2)) 45 | (mempty m1,mempty m2) 46 | 47 | semigroupTuple = \s1 s2 -> SemigroupDict $ 48 | \x y -> case (x,y) of 49 | ((x1,x2),(y1,y2)) -> (mappend s1 x1 y1, mappend s2 x2 y2) 50 | 51 | append l r = case l of 52 | h:tl -> h:append tl r 53 | [] -> r 54 | 55 | test = let fold = \f0 m1 -> (foldMap f0 m1) (\x -> x) in 56 | (fold foldableList (monoidTuple monoidInt monoidInt)) 57 | ((fold foldableList monoidList) 58 | ((toList foldableList) [[(1::Integer,1::Integer)]])) 59 | 60 | -------------------------------------------------------------------------------- /typeclass/typing/typeclass_inference_commonScript.sml: -------------------------------------------------------------------------------- 1 | (* Definitions common to inference theories. *) 2 | open HolKernel Parse boolLib bossLib BasicProvers dep_rewrite; 3 | open arithmeticTheory optionTheory listTheory; 4 | open typeclass_typesTheory typeclass_kindCheckTheory; 5 | 6 | val _ = new_theory "typeclass_inference_common"; 7 | 8 | Datatype: 9 | itype = iAtom atom_ty 10 | | iCons itype itype 11 | | iCVar num 12 | End 13 | 14 | Overload Unit = ``iAtom $ CompPrimTy $ Tuple 0``; 15 | Overload IntTy = ``iAtom $ PrimTy Integer``; 16 | Overload BoolTy = ``iAtom $ PrimTy Bool``; 17 | Overload StrTy = ``iAtom $ PrimTy String``; 18 | 19 | Definition iFunctions_def: 20 | iFunctions [] t = t ∧ 21 | iFunctions (at::ats) t = 22 | iCons (iCons (iAtom (CompPrimTy Function)) at) $ iFunctions ats t 23 | End 24 | 25 | Definition freedbvars_def: 26 | (freedbvars (iCons it1 it2) = freedbvars it1 ∪ freedbvars it2) ∧ 27 | (freedbvars (iAtom (VarTypeCons v)) = {v}) ∧ 28 | (freedbvars _ = {}) 29 | End 30 | 31 | Inductive ikind_ok: 32 | [~Prim:] 33 | ∀t. ikind_ok cdb vdb cvdb kindType (iAtom $ PrimTy t) 34 | [~Exception:] 35 | ikind_ok cdb vdb cvdb kindType (iAtom Exception) 36 | [~VarTypeCons:] 37 | ∀v k. 38 | LLOOKUP vdb v = SOME k ⇒ 39 | ikind_ok cdb vdb cvdb k (iAtom $ VarTypeCons v) 40 | [~TyConsINL:] 41 | ∀c k. 42 | LLOOKUP cdb c = SOME k ⇒ 43 | ikind_ok cdb vdb cvdb k (iAtom $ TypeCons (INL c)) 44 | [~TyConsFunction:] 45 | ikind_ok cdb vdb cvdb 46 | (kindArrow kindType $ kindArrow kindType kindType) 47 | (iAtom $ CompPrimTy Function) 48 | [~TypeConsArray:] 49 | ikind_ok cdb vdb cvdb (kindArrow kindType kindType) 50 | (iAtom $ CompPrimTy Array) 51 | [~TypeConsM:] 52 | ikind_ok cdb vdb cvdb (kindArrow kindType kindType) 53 | (iAtom $ CompPrimTy M) 54 | [~TypeConsTuple:] 55 | ∀n. 56 | ikind_ok cdb vdb cvdb (kind_arrows (GENLIST (K kindType) n) kindType) 57 | (iAtom $ CompPrimTy $ Tuple n) 58 | [~Cons:] 59 | ∀k1 k2 t1 t2. 60 | ikind_ok cdb vdb cvdb (kindArrow k1 k2) t1 ∧ 61 | ikind_ok cdb vdb cvdb k1 t2 ⇒ 62 | ikind_ok cdb vdb cvdb k2 (iCons t1 t2) 63 | [~CVar:] 64 | ∀n k. 65 | LLOOKUP cvdb n = SOME k ⇒ 66 | ikind_ok cdb vbd cvdb k (iCVar n) 67 | End 68 | 69 | Definition isubst_def: 70 | (isubst ts (iAtom $ VarTypeCons v) = 71 | if v < LENGTH ts then EL v ts else iAtom $ VarTypeCons $ v - LENGTH ts) ∧ 72 | (isubst ts (iCons t1 t2) = iCons (isubst ts t1) (isubst ts t2)) ∧ 73 | isubst ts t = t 74 | End 75 | 76 | Definition ishift_def: 77 | ishift n (iAtom $ VarTypeCons v) = iAtom $ VarTypeCons (v + n) ∧ 78 | ishift n (iCons t1 t2) = iCons (ishift n t1) (ishift n t2) ∧ 79 | ishift n t = t 80 | End 81 | 82 | Definition itype_of_def: 83 | itype_of (Atom at) = iAtom at ∧ 84 | itype_of (Cons t1 t2) = iCons (itype_of t1) (itype_of t2) 85 | End 86 | 87 | Definition type_of_def: 88 | type_of (iCons t1 t2) = lift2 Cons (type_of t1) (type_of t2) ∧ 89 | type_of (iAtom at) = SOME $ Atom at ∧ 90 | type_of (iCVar v) = NONE 91 | End 92 | 93 | val _ = export_theory(); 94 | 95 | -------------------------------------------------------------------------------- /typeclass/typing/typeclass_typesScript.sml: -------------------------------------------------------------------------------- 1 | open HolKernel Parse boolLib bossLib BasicProvers; 2 | open pairTheory arithmeticTheory integerTheory stringTheory optionTheory 3 | listTheory alistTheory; 4 | open mlstringTheory; 5 | open pure_configTheory; 6 | 7 | val _ = new_theory "typeclass_types"; 8 | 9 | 10 | (******************** Types ********************) 11 | 12 | Datatype: 13 | prim_ty = Integer | String | Message | Bool 14 | End 15 | 16 | Datatype: 17 | comp_prim_ty = Function | Array | M | Tuple num 18 | End 19 | 20 | Datatype: 21 | built_in_ty = PrimT prim_ty | CompPrimT comp_prim_ty 22 | End 23 | 24 | (* concrete type constructor: 25 | * INL: user-defined types, INR: built-in types *) 26 | Type ty_cons = ``:num + built_in_ty``; 27 | 28 | Datatype: 29 | atom_ty = 30 | | Exception 31 | | TypeCons ty_cons 32 | | VarTypeCons num 33 | (* variable type constructor *) 34 | (* eg. fmap :: (a -> b) -> f a -> f b *) 35 | End 36 | 37 | Datatype: 38 | type = Atom atom_ty | Cons type type 39 | (* eg. m f [a] = (m f) a --> 40 | * Cons (Cons (Atom m) (Atom f)) (Atom ) *) 41 | End 42 | 43 | Type class = ``:mlstring``; (* key for map from classname to class *) 44 | 45 | Datatype: 46 | PredType = <| predicates : ((class # type) list); 47 | type: type |> 48 | (* e.g. Monad m, Monad m2, Functor f => m1 (f a) -> m2 a *) 49 | End 50 | 51 | Overload PrimTy = ``\x. TypeCons (INR $ PrimT x)``; 52 | Overload CompPrimTy = ``\x. TypeCons (INR $ CompPrimT x)``; 53 | Overload Unit = ``Atom $ CompPrimTy $ Tuple 0``; 54 | Overload TypeVar = ``\x. Atom (VarTypeCons x)``; 55 | Overload UserType = ``\x. Atom (TypeCons $ INL x)``; 56 | Overload Tup = ``λn. Atom $ CompPrimTy $ Tuple n``; 57 | 58 | Definition collect_type_vars_def: 59 | (collect_type_vars (Cons t1 t2) = 60 | collect_type_vars t1 ∪ collect_type_vars t2) ∧ 61 | (collect_type_vars (Atom $ VarTypeCons v) = {v}) /\ 62 | (collect_type_vars _ = {}) 63 | End 64 | 65 | (********** Substitutions and shifts **********) 66 | 67 | Definition subst_db_def: 68 | (subst_db skip ts (Atom (VarTypeCons v)) = 69 | if skip ≤ v ∧ v < skip + LENGTH ts 70 | then EL (v - skip) ts 71 | else if skip ≤ v 72 | then Atom (VarTypeCons $ v - LENGTH ts) 73 | else 74 | Atom (VarTypeCons v)) ∧ 75 | (subst_db skip ts (Atom a) = Atom a) ∧ 76 | subst_db skip ts (Cons t1 t2) = 77 | Cons (subst_db skip ts t1) (subst_db skip ts t2) 78 | End 79 | 80 | Definition shift_db_def: 81 | (shift_db skip n (Atom (VarTypeCons db)) = 82 | if skip ≤ db 83 | then Atom (VarTypeCons $ db + n) 84 | else Atom (VarTypeCons db)) ∧ 85 | (shift_db skip n (Atom a) = Atom a) ∧ 86 | shift_db skip n (Cons t1 t2) = 87 | Cons (shift_db skip n t1) (shift_db skip n t2) 88 | End 89 | 90 | Definition subst_db_pred_def: 91 | subst_db_pred skip ts (PredType ps t) = 92 | PredType (MAP (I ## subst_db skip ts) ps) (subst_db skip ts t) 93 | End 94 | 95 | Definition shift_db_pred_def: 96 | shift_db_pred skip n (PredType ps t) = 97 | PredType (MAP (I ## shift_db skip n) ps) (shift_db skip n t) 98 | End 99 | 100 | Overload tsubst = ``subst_db 0``; 101 | Overload tshift = ``shift_db 0``; 102 | Overload tsubst_pred = ``subst_db_pred 0``; 103 | Overload tshift_pred = ``shift_db_pred 0``; 104 | 105 | Definition Functions_def: 106 | Functions [] t = t ∧ 107 | Functions (at::ats) t = 108 | Cons 109 | (Cons (Atom $ CompPrimTy Function) at) $ 110 | Functions ats t 111 | End 112 | 113 | Definition freetyvars_ok_def: 114 | (freetyvars_ok n (Atom (VarTypeCons v)) = (v < n)) ∧ 115 | (freetyvars_ok n (Atom a) = T) ∧ 116 | (freetyvars_ok n (Cons t1 t2) = 117 | (freetyvars_ok n t1 ∧ freetyvars_ok n t2)) 118 | End 119 | 120 | Overload freetyvars_ok_scheme = 121 | ``λn (vars,scheme). freetyvars_ok (n + vars) scheme``; 122 | 123 | Definition cons_types_def: 124 | cons_types thd [] = thd ∧ 125 | cons_types thd (t1::targs) = cons_types (Cons thd t1) targs 126 | End 127 | 128 | (* Apply the type constructor to the list of types. 129 | * Transforming from the representation of `F [a;b]` to `((F a) b)` *) 130 | Definition tcons_to_type_def: 131 | tcons_to_type tcons targs = cons_types (Atom $ TypeCons tcons) targs 132 | End 133 | 134 | (* Functions to split the type in the form `F v1 v2 ...` to 135 | * F and [v1;v2...] *) 136 | Definition head_ty_def: 137 | head_ty (Cons t1 t2) = head_ty t1 ∧ 138 | head_ty (Atom a) = a 139 | End 140 | 141 | (* head_ty but only returns SOME 142 | * when the head is a TypeCon *) 143 | Definition head_ty_cons_def: 144 | head_ty_cons (Cons t1 t2) = head_ty_cons t1 ∧ 145 | head_ty_cons (Atom $ TypeCons tc) = SOME tc ∧ 146 | head_ty_cons (Atom _) = NONE 147 | End 148 | 149 | Definition ty_args_aux_def: 150 | ty_args_aux (Cons t1 t2) l = ty_args_aux t1 (t2::l) ∧ 151 | ty_args_aux (Atom _) l = l 152 | End 153 | 154 | Definition ty_args_def: 155 | ty_args t = ty_args_aux t [] 156 | End 157 | 158 | Definition split_ty_aux_def: 159 | split_ty_aux (Cons t1 t2) l = split_ty_aux t1 (t2::l) ∧ 160 | split_ty_aux (Atom a) l = (a,l) 161 | End 162 | 163 | Definition split_ty_def: 164 | split_ty t = split_ty_aux t [] 165 | End 166 | 167 | (* split_ty but only return SOME when the head is Cons *) 168 | Definition split_ty_cons_aux_def: 169 | split_ty_cons_aux (Cons t1 t2) l = split_ty_cons_aux t1 (t2::l) ∧ 170 | split_ty_cons_aux (Atom $ TypeCons tc) l = SOME (tc,l) ∧ 171 | split_ty_cons_aux (Atom _) l = NONE 172 | End 173 | 174 | Definition split_ty_cons_def: 175 | split_ty_cons t = split_ty_cons_aux t [] 176 | End 177 | 178 | val _ = export_theory(); 179 | -------------------------------------------------------------------------------- /typing/Holmakefile: -------------------------------------------------------------------------------- 1 | INCLUDES = $(PUREDIR)/misc $(PUREDIR)/language $(PUREDIR)/meta-theory \ 2 | $(PUREDIR)/compiler/backend \ 3 | $(PUREDIR)/compiler/parsing/sexp \ 4 | $(PUREDIR)/compiler/backend/languages/properties \ 5 | $(PUREDIR)/compiler/backend/languages/semantics \ 6 | $(CAKEMLDIR)/basis/pure \ 7 | $(HOLDIR)/examples/algorithms/unification/triangular/first-order 8 | -------------------------------------------------------------------------------- /typing/pure_inferenceLib.sml: -------------------------------------------------------------------------------- 1 | (* Computation library for inference. Unification parts ported from CakeML *) 2 | structure pure_inferenceLib = struct 3 | 4 | local 5 | open HolKernel boolLib bossLib 6 | open computeLib reduceLib optionLib pairLib listSimps stringLib sptreeLib 7 | combinLib finite_mapLib pred_setLib 8 | open basisComputeLib 9 | open pure_unificationTheory pure_inferenceTheory pure_printTheory pure_printLib 10 | 11 | val pure_wfs_FEMPTY = Q.prove(`pure_wfs FEMPTY`, rw[pure_wfs_def]); 12 | 13 | val funs = [pure_walk, pure_ext_s_check, pure_unifyl_def]; 14 | 15 | val init_db = 16 | Net.insert (rand $ concl $ pure_wfs_FEMPTY, pure_wfs_FEMPTY) Net.empty; 17 | 18 | fun theory_computes thy = 19 | ThmSetData.theory_data {settype = "compute", thy = thy} |> 20 | ThmSetData.added_thms 21 | 22 | in 23 | val toMLstring = stringLib.fromMLstring o dest_QUOTE; 24 | 25 | fun add_unify_compset compset = let 26 | 27 | val db = ref init_db 28 | 29 | fun get_wfs s = 30 | case Net.index s (!db) of 31 | (th::_) => th 32 | | _ => raise mk_HOL_ERR "pure_unificationLib" "get_wfs" (term_to_string s) 33 | 34 | 35 | fun wfs_thms () = Net.listItems (!db) 36 | 37 | fun pure_unify_conv eval tm = let 38 | val (_, [s,t1,t2]) = strip_comb tm 39 | val wfs_s = get_wfs s 40 | val th1 = SPECL [t1,t2] (MATCH_MP pure_unify wfs_s) 41 | val th2 = eval (rhs (concl th1)) 42 | val th3 = TRANS th1 th2 43 | val res = rhs (concl th2) 44 | val _ = if optionSyntax.is_some res then 45 | let val key = rand res in 46 | if null (Net.index key (!db)) then 47 | db := Net.insert 48 | (key, PROVE[wfs_s,pure_unify_wfs,th3] 49 | (mk_comb (rator (concl wfs_s), key))) 50 | (!db) 51 | else () 52 | end 53 | else () 54 | in th3 end 55 | 56 | fun pure_vwalk_conv eval tm = let 57 | val (_,[s,t]) = strip_comb tm 58 | val wfs_s = get_wfs s 59 | val th1 = SPEC t (MATCH_MP pure_vwalk wfs_s) 60 | val th2 = eval (rhs (concl th1)) 61 | in TRANS th1 th2 end 62 | 63 | fun pure_oc_conv eval tm = let 64 | val (_,[s,t1,t2]) = strip_comb tm 65 | val wfs_s = get_wfs s 66 | val th1 = SPECL [t1,t2] (MATCH_MP pure_oc wfs_s) 67 | val th2 = eval (rhs (concl th1)) 68 | in TRANS th1 th2 end 69 | 70 | fun pure_walkstar_conv eval tm = let 71 | val (_,[s,t]) = strip_comb tm 72 | val wfs_s = get_wfs s 73 | val th1 = SPEC t (MATCH_MP pure_walkstar wfs_s) 74 | val th2 = eval (rhs (concl th1)) 75 | in TRANS th1 th2 end 76 | 77 | fun convs eval = [ 78 | (``pure_unify``, 3, pure_unify_conv eval), 79 | (``pure_vwalk``, 2, pure_vwalk_conv eval), 80 | (``pure_walkstar``, 2, pure_walkstar_conv eval), 81 | (``pure_oc``, 3, pure_oc_conv eval) 82 | ] 83 | 84 | val _ = computeLib.add_thms funs compset 85 | val _ = List.app (Lib.C computeLib.add_conv compset) 86 | (convs (computeLib.CBV_CONV compset)) 87 | val _ = computeLib.extend_compset [computeLib.Tys [``:utype``]] compset 88 | in 89 | () 90 | end 91 | 92 | fun pure_infer_compset () = let 93 | val cmp = reduceLib.num_compset () 94 | val _ = Lib.C computeLib.extend_compset cmp ( 95 | computeLib.Extenders [ 96 | optionLib.OPTION_rws, 97 | pairLib.add_pair_compset, 98 | listLib.list_rws, 99 | alistLib.add_alist_compset, 100 | listLib.add_rich_list_compset, 101 | stringLib.add_string_compset, 102 | sptreeLib.add_sptree_compset, 103 | combinLib.add_combin_compset, 104 | basisComputeLib.add_basis_compset, 105 | finite_mapLib.add_finite_map_compset, 106 | pred_setLib.add_pred_set_compset, 107 | add_unify_compset 108 | ] :: 109 | computeLib.Tys [``:ordering``,``:itype``,``:'a constraint``, 110 | ``:('a,'b) inferResult``] :: 111 | computeLib.Defs [pure_walk] :: 112 | map (computeLib.Defs o theory_computes) [ 113 | "pure_inference", "pure_inference_common", 114 | "mlmap", "mlstring", "balanced_map", "pure_vars" 115 | ] 116 | ) 117 | in cmp end 118 | 119 | val pure_infer_eval = CBV_CONV (pure_infer_compset ()) 120 | 121 | fun pure_parse_infer_compset () = let 122 | val cmp = pure_infer_compset () 123 | val _ = Lib.C computeLib.extend_compset cmp ( 124 | computeLib.Extenders [pred_setLib.add_pred_set_compset] :: 125 | computeLib.Tys [``:source_values$v``] :: 126 | map (computeLib.Defs o theory_computes) [ 127 | "pure_print", "parsing", "source_values" 128 | ] 129 | ) 130 | in cmp end 131 | 132 | val pure_parse_infer_eval = CBV_CONV (pure_parse_infer_compset ()) 133 | 134 | end 135 | 136 | end 137 | -------------------------------------------------------------------------------- /typing/pure_inference_commonScript.sml: -------------------------------------------------------------------------------- 1 | (* Definitions common to inference theories. *) 2 | open HolKernel Parse boolLib bossLib BasicProvers dep_rewrite; 3 | open arithmeticTheory optionTheory listTheory; 4 | open pure_typingTheory; 5 | 6 | val _ = new_theory "pure_inference_common"; 7 | 8 | Datatype: 9 | itype = DBVar num 10 | | PrimTy prim_ty 11 | | Exception 12 | | TypeCons num (itype list) 13 | | Tuple (itype list) 14 | | Function itype itype 15 | | Array itype 16 | | M itype 17 | | CVar num 18 | End 19 | 20 | Overload Unit = ``Tuple []``; 21 | Overload IntTy = ``PrimTy Integer``; 22 | Overload BoolTy = ``PrimTy Bool``; 23 | Overload StrTy = ``PrimTy String``; 24 | 25 | Theorem itype_ind: 26 | ∀P. 27 | (∀n. P (DBVar n)) ∧ (∀p. P (PrimTy p)) ∧ P Exception ∧ 28 | (∀id ts. (∀a. MEM a ts ⇒ P a) ⇒ P (TypeCons id ts)) ∧ 29 | (∀ts. (∀a. MEM a ts ⇒ P a) ⇒ P (Tuple ts)) ∧ 30 | (∀t1 t2. P t1 ∧ P t2 ⇒ P (Function t1 t2)) ∧ 31 | (∀t. P t ⇒ P (Array t)) ∧ (∀t. P t ⇒ P (M t)) ∧ (∀n. P (CVar n)) 32 | ⇒ ∀v. P v 33 | Proof 34 | ntac 3 strip_tac >> 35 | completeInduct_on `itype_size v` >> rw[] >> 36 | Cases_on `v` >> gvs[fetch "-" "itype_size_def"] >> 37 | last_x_assum irule >> rw[] >> 38 | first_x_assum irule >> simp[] >> 39 | Induct_on `l` >> rw[] >> gvs[fetch "-" "itype_size_def"] 40 | QED 41 | 42 | Definition iFunctions_def: 43 | iFunctions [] t = t ∧ 44 | iFunctions (at::ats) t = Function at (iFunctions ats t) 45 | End 46 | 47 | Definition freedbvars_def: 48 | (freedbvars (DBVar n) = {n}) ∧ 49 | (freedbvars (PrimTy pty) = {}) ∧ 50 | (freedbvars Exception = {}) ∧ 51 | (freedbvars (TypeCons id its) = BIGUNION (set (MAP freedbvars its))) ∧ 52 | (freedbvars (Tuple its) = BIGUNION (set (MAP freedbvars its))) ∧ 53 | (freedbvars (Function it1 it2) = freedbvars it1 ∪ freedbvars it2) ∧ 54 | (freedbvars (Array it) = freedbvars it) ∧ 55 | (freedbvars (M it) = freedbvars it) ∧ 56 | (freedbvars (CVar cv) = {}) 57 | Termination 58 | WF_REL_TAC `measure itype_size` >> rw[fetch "-" "itype_size_def"] >> 59 | rename1 `MEM a its` >> Induct_on `its` >> rw[] >> gvs[fetch "-" "itype_size_def"] 60 | End 61 | 62 | Definition itype_wf_def: 63 | itype_wf (typedefs : typedefs) (DBVar n) = T ∧ 64 | itype_wf typedefs (PrimTy pty) = T ∧ 65 | itype_wf typedefs Exception = T ∧ 66 | itype_wf typedefs (TypeCons id tyargs) = ( 67 | EVERY (itype_wf typedefs) tyargs ∧ 68 | ∃arity constructors. 69 | (* Type definition exists: *) 70 | oEL id typedefs = SOME (arity, constructors) ∧ 71 | (* And has correct arity: *) 72 | LENGTH tyargs = arity) ∧ 73 | itype_wf typedefs (Tuple ts) = 74 | EVERY (itype_wf typedefs) ts ∧ 75 | itype_wf typedefs (Function tf t) = ( 76 | itype_wf typedefs t ∧ itype_wf typedefs tf) ∧ 77 | itype_wf typedefs (Array t) = itype_wf typedefs t ∧ 78 | itype_wf typedefs (M t) = itype_wf typedefs t ∧ 79 | itype_wf typedefs (CVar cv) = T 80 | Termination 81 | WF_REL_TAC `measure (itype_size o SND)` >> rw[fetch "-" "itype_size_def"] >> 82 | rename1 `MEM _ ts` >> Induct_on `ts` >> rw[fetch "-" "itype_size_def"] >> gvs[] 83 | End 84 | 85 | Definition itype_ok_def: 86 | itype_ok typedefs db t ⇔ 87 | freedbvars t ⊆ count db ∧ 88 | itype_wf typedefs t 89 | End 90 | 91 | Definition isubst_def: 92 | isubst ts (DBVar v) = ( 93 | if v < LENGTH ts then EL v ts else DBVar (v - LENGTH ts)) ∧ 94 | isubst ts (PrimTy p) = PrimTy p ∧ 95 | isubst ts Exception = Exception ∧ 96 | isubst ts (TypeCons n tcs) = TypeCons n (MAP (isubst ts) tcs) ∧ 97 | isubst ts (Tuple tcs) = Tuple (MAP (isubst ts) tcs) ∧ 98 | isubst ts (Function tf t) = 99 | Function (isubst ts tf) (isubst ts t) ∧ 100 | isubst ts (Array t) = Array (isubst ts t) ∧ 101 | isubst ts (M t) = M (isubst ts t) ∧ 102 | isubst ts (CVar c) = CVar c 103 | Termination 104 | WF_REL_TAC `measure (itype_size o SND)` >> rw[fetch "-" "itype_size_def"] >> 105 | rename1 `MEM _ ts` >> Induct_on `ts` >> rw[fetch "-" "itype_size_def"] >> gvs[] 106 | End 107 | 108 | Definition ishift_def: 109 | ishift n (DBVar v) = DBVar (v + n) ∧ 110 | ishift n (PrimTy p) = PrimTy p ∧ 111 | ishift n Exception = Exception ∧ 112 | ishift n (TypeCons tn tcs) = TypeCons tn (MAP (ishift n) tcs) ∧ 113 | ishift n (Tuple tcs) = Tuple (MAP (ishift n) tcs) ∧ 114 | ishift n (Function tf t) = 115 | Function (ishift n tf) (ishift n t) ∧ 116 | ishift n (Array t) = Array (ishift n t) ∧ 117 | ishift n (M t) = M (ishift n t) ∧ 118 | ishift n (CVar c) = CVar c 119 | Termination 120 | WF_REL_TAC `measure (itype_size o SND)` >> rw[fetch "-" "itype_size_def"] >> 121 | rename1 `MEM _ ts` >> Induct_on `ts` >> rw[fetch "-" "itype_size_def"] >> gvs[] 122 | End 123 | 124 | Definition itype_of_def: 125 | itype_of (TypeVar n) = DBVar n ∧ 126 | itype_of (PrimTy p) = PrimTy p ∧ 127 | itype_of Exception = Exception ∧ 128 | itype_of (TypeCons n ts) = TypeCons n (MAP itype_of ts) ∧ 129 | itype_of (Tuple ts) = Tuple (MAP itype_of ts) ∧ 130 | itype_of (Function t1 t2) = Function (itype_of t1) (itype_of t2) ∧ 131 | itype_of (Array t) = Array (itype_of t) ∧ 132 | itype_of (M t) = M (itype_of t) 133 | Termination 134 | WF_REL_TAC `measure type_size` >> rw[type_size_def] >> 135 | rename1 `MEM _ ts` >> Induct_on `ts` >> rw[] >> gvs[type_size_def] 136 | End 137 | 138 | Definition type_of_def: 139 | type_of (DBVar n) = SOME $ TypeVar n ∧ 140 | type_of (PrimTy p) = SOME $ PrimTy p ∧ 141 | type_of Exception = SOME $ Exception ∧ 142 | type_of (TypeCons n ts) = 143 | OPTION_MAP (TypeCons n) $ 144 | FOLDR (λt ts_opt. OPTION_MAP2 CONS (type_of t) ts_opt) (SOME []) ts ∧ 145 | type_of (Tuple ts) = 146 | OPTION_MAP Tuple $ 147 | FOLDR (λt ts_opt. OPTION_MAP2 CONS (type_of t) ts_opt) (SOME []) ts ∧ 148 | type_of (Function t1 t2) = 149 | OPTION_BIND (type_of t1) 150 | (λit1. OPTION_BIND (type_of t2) (λit2. SOME $ Function it1 it2)) ∧ 151 | type_of (Array t) = OPTION_MAP Array (type_of t) ∧ 152 | type_of (M t) = OPTION_MAP M (type_of t) ∧ 153 | type_of (CVar n) = NONE 154 | Termination 155 | WF_REL_TAC `measure itype_size` >> rw[fetch "-" "itype_size_def"] >> 156 | rename1 `MEM _ ts` >> Induct_on `ts` >> rw[fetch "-" "itype_size_def"] >> gvs[] 157 | End 158 | 159 | val _ = export_theory(); 160 | 161 | --------------------------------------------------------------------------------