├── .github └── workflows │ ├── docker-action.yml │ └── nix-action-8.18.yml ├── .gitignore ├── .nix ├── config.nix ├── coq-nix-toolbox.nix └── coq-overlays │ └── stablesort │ └── default.nix ├── CeCILL-B ├── Make ├── Make.benchmark ├── Make.misc ├── Makefile ├── Makefile.benchmark.coq.local ├── README.md ├── _CoqProject ├── benchmark ├── benchmark.v ├── benchmark_compute.v ├── benchmark_exp_compute.v ├── benchmark_exp_lazy.v ├── benchmark_exp_native1.v ├── benchmark_exp_native2.v ├── benchmark_exp_vm.v ├── benchmark_lazy.v ├── benchmark_native1.v ├── benchmark_native2.v ├── benchmark_vm1.v ├── benchmark_vm2.v ├── extraction_cbn.v ├── extraction_cbnacc.v ├── extraction_cbv.v ├── extraction_cbvacc.v ├── haskell │ ├── Benchlib.hs │ ├── Benchmark.hs │ ├── BenchmarkExp.hs │ ├── MergesortHaskellNTRStack.hs │ ├── MergesortHaskellNTRStack_.hs │ ├── MergesortHaskellStdlib.hs │ ├── MergesortHaskellTRStack.hs │ ├── MergesortHaskellTRStack_.hs │ └── TestStability.hs └── ocaml │ ├── benchlib.ml │ ├── benchmark.ml │ ├── benchmark_exp.ml │ ├── dune │ ├── dune-project │ ├── mergesort_coq_cbn_tmc.patch │ ├── mergesort_coq_cbnacc_tmc.patch │ ├── mergesort_ocaml.ml │ ├── mergesort_ocaml.mli │ └── test_stability.ml ├── coq-stablesort.opam ├── default.nix ├── meta.yml ├── misc └── topdown_tailrec.v └── theories ├── param.v └── stablesort.v /.github/workflows/docker-action.yml: -------------------------------------------------------------------------------- 1 | # This file was generated from `meta.yml`, please do not edit manually. 2 | # Follow the instructions on https://github.com/coq-community/templates to regenerate. 3 | name: Docker CI 4 | 5 | on: 6 | push: 7 | branches: 8 | - master 9 | pull_request: 10 | branches: 11 | - '**' 12 | 13 | jobs: 14 | build: 15 | # the OS must be GNU/Linux to be able to use the docker-coq-action 16 | runs-on: ubuntu-latest 17 | strategy: 18 | matrix: 19 | image: 20 | - 'mathcomp/mathcomp:1.13.0-coq-8.13' 21 | - 'mathcomp/mathcomp:1.13.0-coq-8.14' 22 | - 'mathcomp/mathcomp:1.13.0-coq-8.15' 23 | - 'mathcomp/mathcomp:1.14.0-coq-8.13' 24 | - 'mathcomp/mathcomp:1.14.0-coq-8.14' 25 | - 'mathcomp/mathcomp:1.14.0-coq-8.15' 26 | - 'mathcomp/mathcomp:1.15.0-coq-8.13' 27 | - 'mathcomp/mathcomp:1.15.0-coq-8.14' 28 | - 'mathcomp/mathcomp:1.15.0-coq-8.15' 29 | - 'mathcomp/mathcomp:1.15.0-coq-8.16' 30 | - 'mathcomp/mathcomp:1.16.0-coq-8.13' 31 | - 'mathcomp/mathcomp:1.16.0-coq-8.14' 32 | - 'mathcomp/mathcomp:1.16.0-coq-8.15' 33 | - 'mathcomp/mathcomp:1.16.0-coq-8.16' 34 | - 'mathcomp/mathcomp:1.16.0-coq-8.17' 35 | - 'mathcomp/mathcomp:1.16.0-coq-8.18' 36 | - 'mathcomp/mathcomp:1.17.0-coq-8.15' 37 | - 'mathcomp/mathcomp:1.17.0-coq-8.16' 38 | - 'mathcomp/mathcomp:1.17.0-coq-8.17' 39 | - 'mathcomp/mathcomp:1.17.0-coq-8.18' 40 | - 'mathcomp/mathcomp:1.18.0-coq-8.16' 41 | - 'mathcomp/mathcomp:1.18.0-coq-8.17' 42 | - 'mathcomp/mathcomp:1.18.0-coq-8.18' 43 | - 'mathcomp/mathcomp:1.19.0-coq-8.16' 44 | - 'mathcomp/mathcomp:1.19.0-coq-8.17' 45 | - 'mathcomp/mathcomp:1.19.0-coq-8.18' 46 | - 'mathcomp/mathcomp:1.19.0-coq-8.19' 47 | - 'mathcomp/mathcomp:2.0.0-coq-8.16' 48 | - 'mathcomp/mathcomp:2.0.0-coq-8.17' 49 | - 'mathcomp/mathcomp:2.0.0-coq-8.18' 50 | - 'mathcomp/mathcomp:2.1.0-coq-8.16' 51 | - 'mathcomp/mathcomp:2.1.0-coq-8.17' 52 | - 'mathcomp/mathcomp:2.1.0-coq-8.18' 53 | - 'mathcomp/mathcomp:2.2.0-coq-8.16' 54 | - 'mathcomp/mathcomp:2.2.0-coq-8.17' 55 | - 'mathcomp/mathcomp:2.2.0-coq-8.18' 56 | - 'mathcomp/mathcomp:2.2.0-coq-8.19' 57 | - 'mathcomp/mathcomp:2.2.0-coq-8.20' 58 | - 'mathcomp/mathcomp:2.2.0-coq-dev' 59 | - 'mathcomp/mathcomp:2.3.0-coq-8.18' 60 | - 'mathcomp/mathcomp:2.3.0-coq-8.19' 61 | - 'mathcomp/mathcomp:2.3.0-coq-8.20' 62 | - 'mathcomp/mathcomp:2.3.0-coq-dev' 63 | - 'mathcomp/mathcomp-dev:coq-8.19' 64 | - 'mathcomp/mathcomp-dev:coq-8.20' 65 | - 'mathcomp/mathcomp-dev:rocq-prover-9.0' 66 | - 'mathcomp/mathcomp-dev:rocq-prover-dev' 67 | fail-fast: false 68 | steps: 69 | - uses: actions/checkout@v4 70 | - uses: coq-community/docker-coq-action@v1 71 | with: 72 | opam_file: 'coq-stablesort.opam' 73 | custom_image: ${{ matrix.image }} 74 | export: 'OPAMWITHTEST' 75 | env: 76 | OPAMWITHTEST: true 77 | 78 | # See also: 79 | # https://github.com/coq-community/docker-coq-action#readme 80 | # https://github.com/erikmd/docker-coq-github-action-demo 81 | -------------------------------------------------------------------------------- /.github/workflows/nix-action-8.18.yml: -------------------------------------------------------------------------------- 1 | jobs: 2 | coq: 3 | needs: [] 4 | runs-on: ubuntu-latest 5 | steps: 6 | - name: Determine which commit to initially checkout 7 | run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ 8 | \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ 9 | \ }}\" >> $GITHUB_ENV\nfi\n" 10 | - name: Git checkout 11 | uses: actions/checkout@v3 12 | with: 13 | fetch-depth: 0 14 | ref: ${{ env.target_commit }} 15 | - name: Determine which commit to test 16 | run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{\ 17 | \ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{\ 18 | \ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge\ 19 | \ | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ 20 | \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ 21 | \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; then\n echo\ 22 | \ \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n\ 23 | \ else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" 24 | - name: Git checkout 25 | uses: actions/checkout@v3 26 | with: 27 | fetch-depth: 0 28 | ref: ${{ env.tested_commit }} 29 | - name: Cachix install 30 | uses: cachix/install-nix-action@v27 31 | with: 32 | nix_path: nixpkgs=channel:nixpkgs-unstable 33 | - name: Cachix setup coq 34 | uses: cachix/cachix-action@v15 35 | with: 36 | extraPullNames: coq-community, math-comp 37 | name: coq 38 | - id: stepCheck 39 | name: Checking presence of CI target coq 40 | run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ 41 | \ bundle \"8.18\" --argstr job \"coq\" \\\n --dry-run 2>&1 > /dev/null)\n\ 42 | echo $nb_dry_run\necho status=$(echo $nb_dry_run | grep \"built:\" | sed \"\ 43 | s/.*/built/\") >> $GITHUB_OUTPUT\n" 44 | - if: steps.stepCheck.outputs.status == 'built' 45 | name: Building/fetching current CI target 46 | run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "8.18" --argstr 47 | job "coq" 48 | stablesort: 49 | needs: 50 | - coq 51 | runs-on: ubuntu-latest 52 | steps: 53 | - name: Determine which commit to initially checkout 54 | run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ 55 | \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ 56 | \ }}\" >> $GITHUB_ENV\nfi\n" 57 | - name: Git checkout 58 | uses: actions/checkout@v3 59 | with: 60 | fetch-depth: 0 61 | ref: ${{ env.target_commit }} 62 | - name: Determine which commit to test 63 | run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{\ 64 | \ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{\ 65 | \ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge\ 66 | \ | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ 67 | \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ 68 | \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; then\n echo\ 69 | \ \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n\ 70 | \ else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" 71 | - name: Git checkout 72 | uses: actions/checkout@v3 73 | with: 74 | fetch-depth: 0 75 | ref: ${{ env.tested_commit }} 76 | - name: Cachix install 77 | uses: cachix/install-nix-action@v27 78 | with: 79 | nix_path: nixpkgs=channel:nixpkgs-unstable 80 | - name: Cachix setup coq 81 | uses: cachix/cachix-action@v15 82 | with: 83 | extraPullNames: coq-community, math-comp 84 | name: coq 85 | - id: stepCheck 86 | name: Checking presence of CI target stablesort 87 | run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ 88 | \ bundle \"8.18\" --argstr job \"stablesort\" \\\n --dry-run 2>&1 > /dev/null)\n\ 89 | echo $nb_dry_run\necho status=$(echo $nb_dry_run | grep \"built:\" | sed \"\ 90 | s/.*/built/\") >> $GITHUB_OUTPUT\n" 91 | - if: steps.stepCheck.outputs.status == 'built' 92 | name: 'Building/fetching previous CI target: coq' 93 | run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "8.18" --argstr 94 | job "coq" 95 | - if: steps.stepCheck.outputs.status == 'built' 96 | name: 'Building/fetching previous CI target: mathcomp' 97 | run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "8.18" --argstr 98 | job "mathcomp" 99 | - if: steps.stepCheck.outputs.status == 'built' 100 | name: 'Building/fetching previous CI target: paramcoq' 101 | run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "8.18" --argstr 102 | job "paramcoq" 103 | - if: steps.stepCheck.outputs.status == 'built' 104 | name: Building/fetching current CI target 105 | run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "8.18" --argstr 106 | job "stablesort" 107 | name: Nix CI for bundle 8.18 108 | 'on': 109 | pull_request: 110 | paths: 111 | - .github/workflows/nix-action-8.18.yml 112 | pull_request_target: 113 | paths-ignore: 114 | - .github/workflows/nix-action-8.18.yml 115 | types: 116 | - opened 117 | - synchronize 118 | - reopened 119 | push: 120 | branches: 121 | - master 122 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Coq 2 | *.d 3 | *.vo 4 | *.vio 5 | *.vos 6 | *.vok 7 | *.glob 8 | *.aux 9 | .coq-native 10 | Make*.coq 11 | Make*.coq.conf 12 | 13 | # OCaml 14 | _build 15 | benchmark/ocaml/mergesort_coq* 16 | benchmark/ocaml/benchmark 17 | benchmark/ocaml/benchmark_exp 18 | benchmark/ocaml/test_stability 19 | 20 | # Haskell 21 | *.hi 22 | *.o 23 | benchmark/haskell/MergesortCoq*.hs 24 | benchmark/haskell/Benchmark 25 | benchmark/haskell/BenchmarkExp 26 | benchmark/haskell/TestStability 27 | -------------------------------------------------------------------------------- /.nix/config.nix: -------------------------------------------------------------------------------- 1 | { 2 | ## DO NOT CHANGE THIS 3 | format = "1.0.0"; 4 | ## unless you made an automated or manual update 5 | ## to another supported format. 6 | 7 | ## The attribute to build from the local sources, 8 | ## either using nixpkgs data or the overlays located in `.nix/coq-overlays` 9 | ## Will determine the default main-job of the bundles defined below 10 | attribute = "stablesort"; 11 | 12 | ## If you want to select a different attribute (to build from the local sources as well) 13 | ## when calling `nix-shell` and `nix-build` without the `--argstr job` argument 14 | # shell-attribute = "{{nix_name}}"; 15 | 16 | ## Maybe the shortname of the library is different from 17 | ## the name of the nixpkgs attribute, if so, set it here: 18 | # pname = "{{shortname}}"; 19 | 20 | ## Lists the dependencies, phrased in terms of nix attributes. 21 | ## No need to list Coq, it is already included. 22 | ## These dependencies will systematically be added to the currently 23 | ## known dependencies, if any more than Coq. 24 | ## /!\ Remove this field as soon as the package is available on nixpkgs. 25 | ## /!\ Manual overlays in `.nix/coq-overlays` should be preferred then. 26 | # buildInputs = [ ]; 27 | 28 | ## Indicate the relative location of your _CoqProject 29 | ## If not specified, it defaults to "_CoqProject" 30 | # coqproject = "_CoqProject"; 31 | 32 | ## select an entry to build in the following `bundles` set 33 | ## defaults to "default" 34 | default-bundle = "8.18"; 35 | 36 | ## write one `bundles.name` attribute set per 37 | ## alternative configuration 38 | ## When generating GitHub Action CI, one workflow file 39 | ## will be created per bundle 40 | bundles."8.18" = { 41 | 42 | ## You can override Coq and other Coq coqPackages 43 | ## through the following attribute 44 | coqPackages.coq.override.version = "8.18"; 45 | 46 | ## In some cases, light overrides are not available/enough 47 | ## in which case you can use either 48 | # coqPackages..overrideAttrs = o: ; 49 | ## or a "long" overlay to put in `.nix/coq-overlays 50 | ## you may use `nix-shell --run fetchOverlay ` 51 | ## to automatically retrieve the one from nixpkgs 52 | ## if it exists and is correctly named/located 53 | 54 | ## You can override Coq and other coqPackages 55 | ## through the following attribute 56 | ## If does not support light overrides, 57 | ## you may use `overrideAttrs` or long overlays 58 | ## located in `.nix/ocaml-overlays` 59 | ## (there is no automation for this one) 60 | # ocamlPackages..override.version = "x.xx"; 61 | 62 | ## You can also override packages from the nixpkgs toplevel 63 | # .override.overrideAttrs = o: ; 64 | ## Or put an overlay in `.nix/overlays` 65 | 66 | ## you may mark a package as a main CI job (one to take deps and 67 | ## rev deps from) as follows 68 | # coqPackages..main-job = true; 69 | ## by default the current package and its shell attributes are main jobs 70 | 71 | ## you may mark a package as a CI job as follows 72 | # coqPackages..job = "test"; 73 | ## It can then built through 74 | ## nix-build --argstr bundle "default" --arg job "test"; 75 | ## in the absence of such a directive, the job "another-pkg" will 76 | ## is still available, but will be automatically included in the CI 77 | ## via the command genNixActions only if it is a dependency or a 78 | ## reverse dependency of a job flagged as "main-job" (see above). 79 | 80 | }; 81 | 82 | ## Cachix caches to use in CI 83 | ## Below we list some standard ones 84 | cachix.coq = {}; 85 | cachix.math-comp = {}; 86 | cachix.coq-community = {}; 87 | 88 | ## If you have write access to one of these caches you can 89 | ## provide the auth token or signing key through a secret 90 | ## variable on GitHub. Then, you should give the variable 91 | ## name here. For instance, coq-community projects can use 92 | ## the following line instead of the one above: 93 | # cachix.coq-community.authToken = "CACHIX_AUTH_TOKEN"; 94 | 95 | ## Or if you have a signing key for a given Cachix cache: 96 | # cachix.my-cache.signingKey = "CACHIX_SIGNING_KEY" 97 | 98 | ## Note that here, CACHIX_AUTH_TOKEN and CACHIX_SIGNING_KEY 99 | ## are the names of secret variables. They are set in 100 | ## GitHub's web interface. 101 | } 102 | -------------------------------------------------------------------------------- /.nix/coq-nix-toolbox.nix: -------------------------------------------------------------------------------- 1 | "5814f779562efc3e3c0f9bfeaea0468728e2e08b" 2 | -------------------------------------------------------------------------------- /.nix/coq-overlays/stablesort/default.nix: -------------------------------------------------------------------------------- 1 | { mkCoqDerivation, coq, mathcomp, paramcoq, 2 | version ? null }: 3 | 4 | mkCoqDerivation { 5 | pname = "stablesort"; 6 | defaultVersion = "null"; 7 | inherit version; 8 | propagatedBuildInputs = [ mathcomp paramcoq ]; 9 | } 10 | -------------------------------------------------------------------------------- /CeCILL-B: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pi8027/stablesort/49c3785a605b48f0bafedf831708d0d4cb7c7144/CeCILL-B -------------------------------------------------------------------------------- /Make: -------------------------------------------------------------------------------- 1 | theories/param.v 2 | theories/stablesort.v 3 | 4 | -R theories stablesort 5 | 6 | -arg -w -arg -notation-overridden 7 | -------------------------------------------------------------------------------- /Make.benchmark: -------------------------------------------------------------------------------- 1 | benchmark/benchmark.v 2 | benchmark/extraction_cbn.v 3 | benchmark/extraction_cbnacc.v 4 | benchmark/extraction_cbv.v 5 | benchmark/extraction_cbvacc.v 6 | 7 | -R theories stablesort 8 | -R benchmark stablesort.benchmark 9 | 10 | -arg -w -arg -notation-overridden 11 | -------------------------------------------------------------------------------- /Make.misc: -------------------------------------------------------------------------------- 1 | misc/topdown_tailrec.v 2 | 3 | -R theories stablesort 4 | -R misc stablesort.misc 5 | 6 | -arg -w -arg -notation-overridden 7 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # KNOWNTARGETS will not be passed along to CoqMakefile 2 | KNOWNTARGETS := Makefile.coq Makefile.misc.coq build-misc \ 3 | Makefile.benchmark.coq build-benchmark \ 4 | clean cleanall distclean 5 | # KNOWNFILES will not get implicit targets from the final rule, and so 6 | # depending on them won't invoke the submake 7 | # Warning: These files get declared as PHONY, so any targets depending 8 | # on them always get rebuilt 9 | KNOWNFILES := Makefile Make Make.misc Make.benchmark 10 | 11 | .DEFAULT_GOAL := invoke-coqmakefile 12 | 13 | COQMAKEFILE = $(COQBIN)coq_makefile 14 | COQMAKE = $(MAKE) --no-print-directory -f Makefile.coq 15 | COQMAKE_MISC = $(MAKE) --no-print-directory -f Makefile.misc.coq 16 | COQMAKE_BENCHMARK = $(MAKE) --no-print-directory -f Makefile.benchmark.coq 17 | 18 | Makefile.coq: Makefile Make 19 | $(COQMAKEFILE) -f Make -o Makefile.coq 20 | 21 | Makefile.misc.coq: Makefile Make.misc 22 | $(COQMAKEFILE) -f Make.misc -o Makefile.misc.coq 23 | 24 | Makefile.benchmark.coq: Makefile Make.benchmark 25 | $(COQMAKEFILE) -f Make.benchmark -o Makefile.benchmark.coq 26 | 27 | invoke-coqmakefile: Makefile.coq 28 | $(COQMAKE) $(filter-out $(KNOWNTARGETS),$(MAKECMDGOALS)) 29 | 30 | build-misc: Makefile.misc.coq invoke-coqmakefile 31 | $(COQMAKE_MISC) 32 | 33 | build-benchmark: Makefile.benchmark.coq invoke-coqmakefile 34 | $(COQMAKE_BENCHMARK) 35 | 36 | theories/%.vo: Makefile.coq 37 | $(COQMAKE) $@ 38 | 39 | misc/%.vo: Makefile.misc.coq 40 | $(COQMAKE_MISC) $@ 41 | 42 | benchmark/%.vo: Makefile.benchmark.coq 43 | $(COQMAKE_BENCHMARK) $@ 44 | 45 | clean:: 46 | @if [ -f Makefile.coq ]; then $(COQMAKE) clean; fi 47 | @if [ -f Makefile.misc.coq ]; then $(COQMAKE_MISC) clean; fi 48 | @if [ -f Makefile.benchmark.coq ]; then $(COQMAKE_BENCHMARK) clean; fi 49 | 50 | cleanall:: 51 | @if [ -f Makefile.coq ]; then $(COQMAKE) cleanall; fi 52 | @if [ -f Makefile.misc.coq ]; then $(COQMAKE_MISC) cleanall; fi 53 | @if [ -f Makefile.benchmark.coq ]; then $(COQMAKE_BENCHMARK) cleanall; fi 54 | 55 | distclean:: cleanall 56 | rm -f Makefile.coq Makefile.coq.conf 57 | rm -f Makefile.misc.coq Makefile.misc.coq.conf 58 | rm -f Makefile.benchmark.coq Makefile.benchmark.coq.conf 59 | 60 | .PHONY: invoke-coqmakefile $(KNOWNFILES) 61 | 62 | #################################################################### 63 | ## Your targets here ## 64 | #################################################################### 65 | 66 | # This should be the last rule, to handle any targets not declared above 67 | %: invoke-coqmakefile 68 | @true 69 | -------------------------------------------------------------------------------- /Makefile.benchmark.coq.local: -------------------------------------------------------------------------------- 1 | # Workaround for the issue that building the benchmark programs require two 2 | # versions of OCaml. 3 | OCAML_OPAMSWITCH?= 4 | ifeq (,$(OCAML_OPAMSWITCH)) 5 | DUNE?= dune 6 | else 7 | DUNE?= opam exec --switch $(OCAML_OPAMSWITCH) -- dune 8 | endif 9 | 10 | HSDIR := benchmark/haskell 11 | MLDIR := benchmark/ocaml 12 | 13 | EXTRACTED_HS_FILES := \ 14 | $(HSDIR)/MergesortCoqCbn.hs \ 15 | $(HSDIR)/MergesortCoqCbnAcc.hs \ 16 | $(HSDIR)/MergesortCoqCbv.hs \ 17 | $(HSDIR)/MergesortCoqCbvAcc.hs 18 | 19 | HS_FILES := $(EXTRACTED_HS_FILES) \ 20 | $(HSDIR)/MergesortHaskellNTRStack.hs \ 21 | $(HSDIR)/MergesortHaskellNTRStack_.hs \ 22 | $(HSDIR)/MergesortHaskellTRStack.hs \ 23 | $(HSDIR)/MergesortHaskellTRStack_.hs \ 24 | $(HSDIR)/MergesortHaskellStdlib.hs 25 | 26 | HS_FLAGS := -with-rtsopts="-T -I0 -A8G -G1 -m1" -O2 27 | 28 | EXTRACTED_ML_FILES := \ 29 | $(MLDIR)/mergesort_coq_cbn.ml \ 30 | $(MLDIR)/mergesort_coq_cbnacc.ml \ 31 | $(MLDIR)/mergesort_coq_cbv.ml \ 32 | $(MLDIR)/mergesort_coq_cbvacc.ml \ 33 | $(MLDIR)/mergesort_coq_cbn_tmc.ml \ 34 | $(MLDIR)/mergesort_coq_cbnacc_tmc.ml 35 | 36 | ML_FILES := $(EXTRACTED_ML_FILES) $(MLDIR)/mergesort_ocaml.ml 37 | 38 | BINARIES := \ 39 | $(HSDIR)/Benchmark $(HSDIR)/BenchmarkExp $(HSDIR)/TestStability \ 40 | $(MLDIR)/benchmark $(MLDIR)/benchmark_exp $(MLDIR)/test_stability 41 | 42 | $(HSDIR)/Benchmark: $(HSDIR)/Benchmark.hs $(HSDIR)/Benchlib.hs $(HS_FILES) 43 | cd $(HSDIR) && stack ghc Benchmark.hs -- $(HS_FLAGS) 44 | 45 | $(HSDIR)/BenchmarkExp: $(HSDIR)/BenchmarkExp.hs $(HSDIR)/Benchlib.hs $(HS_FILES) 46 | cd $(HSDIR) && stack ghc BenchmarkExp.hs -- $(HS_FLAGS) 47 | 48 | $(HSDIR)/TestStability: $(HSDIR)/TestStability.hs $(HS_FILES) 49 | cd $(HSDIR) && stack ghc TestStability.hs -- $(HS_FLAGS) 50 | 51 | $(MLDIR)/benchmark: $(MLDIR)/benchmark.ml $(MLDIR)/benchlib.ml \ 52 | $(ML_FILES) $(ML_FILES:.ml=.mli) 53 | cd $(MLDIR) && \ 54 | $(DUNE) build benchmark.exe && \ 55 | ln -sf _build/default/benchmark.exe benchmark 56 | 57 | $(MLDIR)/benchmark_exp: $(MLDIR)/benchmark_exp.ml $(MLDIR)/benchlib.ml \ 58 | $(ML_FILES) $(ML_FILES:.ml=.mli) 59 | cd $(MLDIR) && \ 60 | $(DUNE) build benchmark_exp.exe && \ 61 | ln -sf _build/default/benchmark_exp.exe benchmark_exp 62 | 63 | $(MLDIR)/test_stability: $(MLDIR)/test_stability.ml \ 64 | $(ML_FILES) $(ML_FILES:.ml=.mli) 65 | cd $(MLDIR) && \ 66 | $(DUNE) build test_stability.exe && \ 67 | ln -sf _build/default/test_stability.exe test_stability 68 | 69 | $(HSDIR)/MergesortCoqCbn.hs $(MLDIR)/mergesort_coq_cbn.ml: \ 70 | benchmark/extraction_cbn.vo 71 | 72 | $(HSDIR)/MergesortCoqCbnAcc.hs $(MLDIR)/mergesort_coq_cbnacc.ml: \ 73 | benchmark/extraction_cbnacc.vo 74 | 75 | $(HSDIR)/MergesortCoqCbv.hs $(MLDIR)/mergesort_coq_cbv.ml: \ 76 | benchmark/extraction_cbv.vo 77 | 78 | $(HSDIR)/MergesortCoqCbvAcc.hs $(MLDIR)/mergesort_coq_cbvacc.ml: \ 79 | benchmark/extraction_cbvacc.vo 80 | 81 | $(MLDIR)/%_tmc.ml: $(MLDIR)/%.ml $(MLDIR)/%_tmc.patch 82 | patch $^ -o $@ 83 | 84 | $(MLDIR)/%_tmc.mli: $(MLDIR)/%.mli 85 | cp $< $@ 86 | 87 | post-all:: $(BINARIES) 88 | 89 | clean:: 90 | $(HIDE)rm -f $(EXTRACTED_HS_FILES) 91 | $(HIDE)rm -f $(HS_FILES:.hs=.hi) 92 | $(HIDE)rm -f $(HS_FILES:.hs=.o) 93 | $(HIDE)rm -f $(EXTRACTED_ML_FILES) 94 | $(HIDE)rm -f $(EXTRACTED_ML_FILES:.ml=.mli) 95 | $(HIDE)rm -f $(BINARIES) 96 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 5 | # Stable sort algorithms in Coq 6 | 7 | [![Docker CI][docker-action-shield]][docker-action-link] 8 | 9 | [docker-action-shield]: https://github.com/pi8027/stablesort/actions/workflows/docker-action.yml/badge.svg?branch=master 10 | [docker-action-link]: https://github.com/pi8027/stablesort/actions/workflows/docker-action.yml 11 | 12 | 13 | 14 | 15 | This library provides a generic and modular way to prove the correctness, 16 | including stability, of several mergesort functions. The correctness lemmas in 17 | this library are overloaded using a canonical structure 18 | (`StableSort.function`). This structure characterizes stable mergesort 19 | functions, say `sort`, by its abstract version `asort` parameterized over the 20 | type of sorted lists and its operators such as merge, the relational 21 | parametricity of `asort`, and two equational properties that `asort` 22 | instantiated with merge and concatenation are `sort` and the identity 23 | function, respectively, which intuitively mean that replacing merge with 24 | concatenation turns `sort` into the identity function. 25 | From this characterization, we derive an induction principle over 26 | traces—binary trees reflecting the underlying divide-and-conquer structure of 27 | mergesort—to reason about the relation between the input and output of 28 | `sort`, and the naturality of `sort`. These two properties are sufficient to 29 | deduce several correctness results of mergesort, including stability. Thus, 30 | one may prove the stability of a new sorting function by defining its abstract 31 | version, proving the relational parametricity of the latter using the 32 | parametricity translation (the Paramcoq plugin), and manually providing the 33 | equational properties. 34 | 35 | As an application of the above proof methodology, this library provides two 36 | kinds of optimized mergesorts. 37 | The first kind is non-tail-recursive mergesort. In call-by-need evaluation, 38 | they allow us to compute the first k smallest elements of a list of length n 39 | in the optimal O(n + k log k) time complexity of the partial and incremental 40 | sorting problems. However, the non-tail-recursive merge function linearly 41 | consumes the call stack and triggers a stack overflow in call-by-value 42 | evaluation. 43 | The second kind is tail-recursive mergesorts and thus solves the above issue 44 | in call-by-value evaluation. However, it does not allow us to compute the 45 | output incrementally regardless of the evaluation strategy. 46 | Therefore, there is a performance trade-off between non-tail-recursive and 47 | tail-recursive mergesorts, and the best mergesort function for lists depends 48 | on the situation, in particular, the evaluation strategy and whether it should 49 | be incremental or not. 50 | In addition, each of the above two kinds of mergesort functions has a smooth 51 | (also called natural) variant of mergesort, which takes advantage of sorted 52 | slices in the input. 53 | 54 | ## Meta 55 | 56 | - Author(s): 57 | - Kazuhiko Sakaguchi (initial) 58 | - Cyril Cohen 59 | - License: [CeCILL-B Free Software License Agreement](CeCILL-B) 60 | - Compatible Coq versions: 8.13 or later 61 | - Additional dependencies: 62 | - [MathComp](https://math-comp.github.io) 1.13.0 or later 63 | - [Paramcoq](https://github.com/coq-community/paramcoq) 1.1.3 or later 64 | - [Mczify](https://github.com/math-comp/mczify) (required only for the test suite) 65 | - [Equations](https://github.com/mattam82/Coq-Equations) (required only for the test suite) 66 | - Coq namespace: `stablesort` 67 | - Related publication(s): 68 | - [A bargain for mergesorts (functional pearl) — How to prove your mergesort correct and stable, almost for free](https://arxiv.org/abs/2403.08173) doi:[10.48550/arXiv.2403.08173](https://doi.org/10.48550/arXiv.2403.08173) 69 | 70 | ## Building and installation instructions 71 | The easiest way to install the development version of Stable sort algorithms in Coq 72 | is via [OPAM](https://opam.ocaml.org/doc/Install.html): 73 | ``` shell 74 | git clone https://github.com/pi8027/stablesort.git 75 | cd stablesort 76 | opam repo add coq-released https://coq.inria.fr/opam/released 77 | opam install ./coq-stablesort.opam 78 | ``` 79 | 80 | ## Credits 81 | The mergesort functions and the stability proofs provided in this library are 82 | mostly based on ones in the `path` library of Mathematical Components. 83 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R theories stablesort 2 | -Q benchmark benchmark 3 | 4 | -arg -w -arg -notation-overridden 5 | -------------------------------------------------------------------------------- /benchmark/benchmark.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import NArith. 2 | From elpi Require Import elpi. 3 | From mathcomp Require Import all_ssreflect. 4 | 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | Elpi Command sort_benchmark. 10 | Elpi Accumulate lp:{{ 11 | 12 | kind triple type -> type -> type -> type. 13 | type triple A -> B -> C -> triple A B C. 14 | 15 | % [eucldiv N D M R] N = D * M + R 16 | pred eucldiv o:int, i:int, o:int, i:int. 17 | eucldiv N D M R :- var N, var M, !, declare_constraint (eucldiv N D M R) [N, M]. 18 | eucldiv N D M R :- var N, N is D * M + R. 19 | eucldiv N D M R :- var M, M is N div D, R is N mod D. 20 | 21 | pred positive-constant o:int, o:term. 22 | positive-constant 1 {{ lib:num.pos.xH }}. 23 | positive-constant N {{ lib:num.pos.xO lp:T }} :- 24 | eucldiv N 2 M 0, positive-constant M T. 25 | positive-constant N {{ lib:num.pos.xI lp:T }} :- 26 | eucldiv N 2 M 1, positive-constant M T. 27 | 28 | pred n-constant o:int, o:term. 29 | n-constant N _ :- not (var N), N < 0, !, fail. 30 | n-constant 0 {{ lib:num.N.N0 }} :- !. 31 | n-constant N {{ lib:num.N.Npos lp:T }} :- !, positive-constant N T. 32 | 33 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 34 | 35 | % [random-N-list N Bound NS] unifies [NS] with a list of size [N] consists of 36 | % random values of type [BinNums.N] between [0] and [Bound - 1]. 37 | pred random-N-list i:int, i:int, o:term. 38 | random-N-list N _ _ :- N < 0, !, fail. 39 | random-N-list 0 _ {{ @nil N }} :- !. 40 | random-N-list N Bound {{ @cons N lp:H lp:T }} :- std.do! [ 41 | n-constant {random.int Bound} H, 42 | random-N-list {calc (N - 1)} Bound T 43 | ]. 44 | 45 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 46 | 47 | pred insert i:A, i:list A, o:list A. 48 | insert X [] [X] :- !. 49 | insert X [Y|YS] [X, Y|YS] :- X =< Y, !. 50 | insert X [Y|YS] [Y|YS'] :- Y < X, !, insert X YS YS'. 51 | 52 | pred sort i:list A, o:list A. 53 | sort [] [] :- !. 54 | sort [X|XS] RS :- !, sort XS XS', !, insert X XS' RS. 55 | 56 | pred median i:list float, o:float. 57 | median TS Out :- 58 | 1 is {std.length TS} mod 2, !, 59 | std.nth {calc ({std.length TS} div 2)} {sort TS} Out. 60 | 61 | pred time-median-rec 62 | i:int, i:prop, i:list float, i:list float, o:float, o:float. 63 | time-median-rec 0 _ TS WS TOut WOut :- !, median TS TOut, median WS WOut. 64 | time-median-rec N P TS WS TOut WOut :- std.do! [ 65 | 0 < N, 66 | % invoke GC explicitly before each measurement 67 | gc.compact, 68 | % change the verbosity to observe automatic GC invocation 69 | gc.get _ _ _ Verbose _ _ _ _, 70 | gc.set _ _ _ 31 _ _ _ _, 71 | % check for the amount of memory allocated 72 | gc.quick-stat Minor1 Promoted1 Major1 _ _ _ _ _ _ _, 73 | % measurement 74 | std.time P Time, 75 | % check for the amount of memory allocated, again 76 | gc.quick-stat Minor2 Promoted2 Major2 _ _ _ _ _ _ _, 77 | % restore the verbosity 78 | gc.set _ _ _ Verbose _ _ _ _, 79 | Words is ((Minor2 + Major2 - Promoted2) r- (Minor1 + Major1 - Promoted1)), 80 | time-median-rec {calc (N - 1)} P [Time|TS] [Words|WS] TOut WOut 81 | ]. 82 | 83 | pred time-median i:int, i:prop, o:float, o:float. 84 | time-median N P Time Words :- !, time-median-rec N P [] [] Time Words. 85 | 86 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 87 | 88 | pred benchmark-case 89 | i:string, i:(term -> term -> term -> prop), i:int, i:list (pair string term), 90 | i:term, i:term, i:int, o:list string, o:list string. 91 | benchmark-case RedStr Red MedianOf Config Preproc SizeC Size TS MS :- std.do! [ 92 | coq.env.begin-section "Sec", 93 | coq.reduction.vm.norm 94 | (app [Preproc, {random-N-list Size Size}]) {{ list N }} Input, 95 | if (RedStr = "native_compute") 96 | (Cname is "input" ^ {std.any->string {new_int} }, 97 | @global! => coq.env.add-const Cname Input {{ list N }} @transparent! C, 98 | Red (global (const C)) _ _) 99 | (@local! => coq.env.add-const "input" Input {{ list N }} @transparent! C), 100 | std.map Config 101 | (c\ r\ sigma Name Func Comp SimplComp CompTy Time Words Mem TStr MStr\ 102 | std.do! [ 103 | c = pr Name Func, 104 | Comp = {{ lp:Func lp:SizeC lp:{{ global (const C) }} }}, 105 | std.assert-ok! (coq.typecheck Comp CompTy) "bad term", 106 | hd-beta-zeta-reduce Comp SimplComp, 107 | time-median MedianOf (Red SimplComp CompTy _) Time Words, 108 | std.any->string Time TStr, 109 | Mem is Words / (128.0 * 1024.0), % memory consumption in MBs 110 | std.any->string Mem MStr, 111 | r is triple Name TStr MStr 112 | ]) RS, 113 | std.any->string Size SizeStr, 114 | Str is RedStr ^ ", size: " ^ SizeStr ^ "; " ^ 115 | {std.string.concat "; " 116 | {std.map RS (r\ s\ sigma Name TStr MStr\ 117 | r = triple Name TStr MStr, 118 | s is Name ^ ": " ^ TStr ^ "s, " ^ MStr ^ "MB")} }, 119 | coq.say Str, 120 | std.map RS (r\ s\ r = triple _ s _) TS, 121 | std.map RS (r\ s\ r = triple _ _ s) MS, 122 | coq.env.end-section 123 | ]. 124 | 125 | pred benchmark 126 | i:string, i:(term -> term -> term -> prop), i:int, i:list (pair string term), 127 | i:term, i:term, o:list (list string), o:list (list string). 128 | benchmark RedStr Red MedianOf Config Preproc Size TSS MSS :- !, 129 | benchmark_aux RedStr Red MedianOf Config Preproc 130 | {coq.reduction.lazy.whd_all Size} TSS MSS. 131 | 132 | pred benchmark_aux 133 | i:string, i:(term -> term -> term -> prop), i:int, i:list (pair string term), 134 | i:term, i:term, o:list (list string), o:list (list string). 135 | benchmark_aux _ _ _ _ _ {{ @nil _ }} [] [] :- !. 136 | benchmark_aux RedStr Red MedianOf Config Preproc {{ @cons _ lp:SizeH lp:Size }} 137 | [[SizeHStr|TS]|TSS] [[SizeHStr|MS]|MSS] :- std.do! [ 138 | coq.reduction.cbv.norm SizeH SizeH', 139 | n-constant SizeH'' SizeH', 140 | std.any->string SizeH'' SizeHStr, 141 | benchmark-case RedStr Red MedianOf Config Preproc SizeH' SizeH'' TS MS, 142 | benchmark RedStr Red MedianOf Config Preproc Size TSS MSS 143 | ]. 144 | benchmark_aux _ _ _ _ _ _ _ _ :- 145 | coq.error "benchmark_aux: the head symbol of Size is not a constructor". 146 | 147 | pred get-reduction-machine i:string, o:(term -> term -> term -> prop). 148 | get-reduction-machine "lazy" Red :- !, 149 | Red = t\ _\ tred\ coq.reduction.lazy.whd_all t tred. 150 | get-reduction-machine "compute" Red :- !, 151 | Red = t\ _\ tred\ coq.reduction.cbv.norm t tred. 152 | get-reduction-machine "vm_compute" coq.reduction.vm.norm :- !. 153 | get-reduction-machine "native_compute" coq.reduction.native.norm :- 154 | coq.reduction.native.available?, !. 155 | get-reduction-machine M _ :- 156 | coq.error "Reduction machine" M "is not available". 157 | 158 | pred parse-config i:list argument, o: list (pair string term). 159 | parse-config [] [] :- !. 160 | parse-config [str Name, trm Func | ConfList] [pr Name Func | Conf] :- !, 161 | parse-config ConfList Conf. 162 | parse-config _ _ :- coq.error "ill-formed arguments". 163 | 164 | main [str FileName, str RedStr, int MedianOf, trm Size, trm Preproc | 165 | ConfList] :- std.do! [ 166 | std.assert-ok! (coq.typecheck Size {{ seq N }}) "bad term", 167 | std.assert-ok! (coq.typecheck Preproc {{ seq N -> seq N }}) "bad term", 168 | parse-config ConfList Config, 169 | % enlarge the minor heap to 16GB 170 | gc.get Minor _ _ _ _ _ _ _, 171 | gc.set {calc (2 * 1024 * 1024 * 1024)} _ _ _ _ _ _ _, 172 | % benchmark 173 | benchmark RedStr {get-reduction-machine RedStr} MedianOf Config Preproc Size 174 | TSS MSS, 175 | % restore the initial size of the minor heap 176 | gc.set Minor _ _ _ _ _ _ _, 177 | % pgfplot 178 | open_out {calc (FileName ^ ".time.csv")} TStream, 179 | output TStream "Size", 180 | std.forall Config (conf\ sigma Name\ 181 | conf = pr Name _, 182 | output TStream ", ", 183 | output TStream Name), 184 | output TStream "\n", 185 | std.forall TSS (ts\ sigma T TS\ 186 | ts = [T|TS], 187 | output TStream T, 188 | std.forall TS (t\ output TStream ", ", output TStream t), 189 | output TStream "\n"), 190 | close_out TStream, 191 | open_out {calc (FileName ^ ".mem.csv")} MStream, 192 | output MStream "Size", 193 | std.forall Config (conf\ sigma Name\ 194 | conf = pr Name _, 195 | output MStream ", ", 196 | output MStream Name), 197 | output MStream "\n", 198 | std.forall MSS (ms\ sigma M MS\ 199 | ms = [M|MS], 200 | output MStream M, 201 | std.forall MS (m\ output MStream ", ", output MStream m), 202 | output MStream "\n"), 203 | close_out MStream 204 | ]. 205 | main _ :- !, coq.error "ill-formed arguments". 206 | 207 | }}. 208 | Elpi Typecheck. 209 | 210 | Definition N_iota (n m : N) : seq N := 211 | N.iter m (fun f n => n :: f (N.succ n)) (fun => [::]) n. 212 | 213 | Notation lazy_bench sort := 214 | (fun n xs => sorted N.leb (take 10 (sort _ N.leb xs))). 215 | 216 | Notation eager_bench sort := 217 | (fun n xs => sorted N.leb (sort _ N.leb xs)). 218 | 219 | Fixpoint sort_blocks (T : Type) (leT : rel T) (n : nat) (xs : seq T) := 220 | if xs is x :: xs' then 221 | sort leT (take n xs) ++ sort_blocks leT n (drop n.-1 xs') else [::]. 222 | -------------------------------------------------------------------------------- /benchmark/benchmark_compute.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import NArith. 2 | From mathcomp Require Import all_ssreflect. 3 | From stablesort Require Import stablesort. 4 | From benchmark Require Import benchmark. 5 | 6 | Elpi sort_benchmark 7 | "compute1" "compute" 8 | 5 (map (N.mul 100) (N_iota 1 40)) (id) 9 | "CBN.sort1" (eager_bench CBN.sort1) 10 | "CBN.sort2" (eager_bench CBN.sort2) 11 | "CBN.sort3" (eager_bench CBN.sort3) 12 | "CBN.sortN" (eager_bench CBN.sortN) 13 | "CBNAcc.sort1" (eager_bench CBNAcc.sort1) 14 | "CBNAcc.sort2" (eager_bench CBNAcc.sort2) 15 | "CBNAcc.sort3" (eager_bench CBNAcc.sort3) 16 | "CBNAcc.sortN" (eager_bench CBNAcc.sortN) 17 | "CBV.sort1" (eager_bench CBV.sort1) 18 | "CBV.sort2" (eager_bench CBV.sort2) 19 | "CBV.sort3" (eager_bench CBV.sort3) 20 | "CBV.sortN" (eager_bench CBV.sortN) 21 | "CBVAcc.sort1" (eager_bench CBVAcc.sort1) 22 | "CBVAcc.sort2" (eager_bench CBVAcc.sort2) 23 | "CBVAcc.sort3" (eager_bench CBVAcc.sort3) 24 | "CBVAcc.sortN" (eager_bench CBVAcc.sortN). 25 | 26 | Elpi sort_benchmark 27 | "compute2" "compute" 28 | 5 (map (N.mul 100) (N_iota 1 40)) (sort_blocks N.leb 50) 29 | "CBN.sort1" (eager_bench CBN.sort1) 30 | "CBN.sort2" (eager_bench CBN.sort2) 31 | "CBN.sort3" (eager_bench CBN.sort3) 32 | "CBN.sortN" (eager_bench CBN.sortN) 33 | "CBNAcc.sort1" (eager_bench CBNAcc.sort1) 34 | "CBNAcc.sort2" (eager_bench CBNAcc.sort2) 35 | "CBNAcc.sort3" (eager_bench CBNAcc.sort3) 36 | "CBNAcc.sortN" (eager_bench CBNAcc.sortN) 37 | "CBV.sort1" (eager_bench CBV.sort1) 38 | "CBV.sort2" (eager_bench CBV.sort2) 39 | "CBV.sort3" (eager_bench CBV.sort3) 40 | "CBV.sortN" (eager_bench CBV.sortN) 41 | "CBVAcc.sort1" (eager_bench CBVAcc.sort1) 42 | "CBVAcc.sort2" (eager_bench CBVAcc.sort2) 43 | "CBVAcc.sort3" (eager_bench CBVAcc.sort3) 44 | "CBVAcc.sortN" (eager_bench CBVAcc.sortN). 45 | -------------------------------------------------------------------------------- /benchmark/benchmark_exp_compute.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import NArith List. 2 | From mathcomp Require Import all_ssreflect. 3 | From stablesort Require Import stablesort. 4 | From benchmark Require Import benchmark. 5 | 6 | Elpi sort_benchmark 7 | "compute-total-random" "compute" 8 | 9 (map (N.pow 2) (N_iota 3 10)) (id) 9 | "CBN.sort2" (eager_bench CBN.sort2) 10 | "CBN.sort3" (eager_bench CBN.sort3) 11 | "CBN.sortN" (eager_bench CBN.sortN) 12 | "CBV.sort2" (eager_bench CBV.sort2) 13 | "CBV.sort3" (eager_bench CBV.sort3) 14 | "CBV.sortN" (eager_bench CBV.sortN). 15 | 16 | Elpi sort_benchmark 17 | "compute-total-smooth" "compute" 18 | 9 (map (N.pow 2) (N_iota 3 10)) (sort_blocks N.leb 50) 19 | "CBN.sort2" (eager_bench CBN.sort2) 20 | "CBN.sort3" (eager_bench CBN.sort3) 21 | "CBN.sortN" (eager_bench CBN.sortN) 22 | "CBV.sort2" (eager_bench CBV.sort2) 23 | "CBV.sort3" (eager_bench CBV.sort3) 24 | "CBV.sortN" (eager_bench CBV.sortN). 25 | -------------------------------------------------------------------------------- /benchmark/benchmark_exp_lazy.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import NArith List. 2 | From mathcomp Require Import all_ssreflect. 3 | From stablesort Require Import stablesort. 4 | From benchmark Require Import benchmark. 5 | 6 | Definition lazy_bench 7 | (sort : forall T : Type, rel T -> seq T -> seq T) (n : N) (xs : seq N) := 8 | sorted N.leb (take (N.to_nat (N.div n 4)) (sort _ N.leb xs)). 9 | 10 | Elpi sort_benchmark 11 | "lazy-partial-random" "lazy" 12 | 9 (map (N.pow 2) (N_iota 3 10)) (id) 13 | "CBN.sort2" (lazy_bench CBN.sort2) 14 | "CBN.sort3" (lazy_bench CBN.sort3) 15 | "CBN.sortN" (lazy_bench CBN.sortN) 16 | "CBV.sort2" (lazy_bench CBV.sort2) 17 | "CBV.sort3" (lazy_bench CBV.sort3) 18 | "CBV.sortN" (lazy_bench CBV.sortN). 19 | 20 | Elpi sort_benchmark 21 | "lazy-partial-smooth" "lazy" 22 | 9 (map (N.pow 2) (N_iota 3 10)) (sort_blocks N.leb 50) 23 | "CBN.sort2" (lazy_bench CBN.sort2) 24 | "CBN.sort3" (lazy_bench CBN.sort3) 25 | "CBN.sortN" (lazy_bench CBN.sortN) 26 | "CBV.sort2" (lazy_bench CBV.sort2) 27 | "CBV.sort3" (lazy_bench CBV.sort3) 28 | "CBV.sortN" (lazy_bench CBV.sortN). 29 | 30 | Elpi sort_benchmark 31 | "lazy-total-random" "lazy" 32 | 9 (map (N.pow 2) (N_iota 3 10)) (id) 33 | "CBN.sort2" (eager_bench CBN.sort2) 34 | "CBN.sort3" (eager_bench CBN.sort3) 35 | "CBN.sortN" (eager_bench CBN.sortN) 36 | "CBV.sort2" (eager_bench CBV.sort2) 37 | "CBV.sort3" (eager_bench CBV.sort3) 38 | "CBV.sortN" (eager_bench CBV.sortN). 39 | 40 | Elpi sort_benchmark 41 | "lazy-total-smooth" "lazy" 42 | 9 (map (N.pow 2) (N_iota 3 10)) (sort_blocks N.leb 50) 43 | "CBN.sort2" (eager_bench CBN.sort2) 44 | "CBN.sort3" (eager_bench CBN.sort3) 45 | "CBN.sortN" (eager_bench CBN.sortN) 46 | "CBV.sort2" (eager_bench CBV.sort2) 47 | "CBV.sort3" (eager_bench CBV.sort3) 48 | "CBV.sortN" (eager_bench CBV.sortN). 49 | -------------------------------------------------------------------------------- /benchmark/benchmark_exp_native1.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import NArith List. 2 | From mathcomp Require Import all_ssreflect. 3 | From stablesort Require Import stablesort. 4 | From benchmark Require Import benchmark. 5 | 6 | Elpi sort_benchmark 7 | "native-total-random" "native_compute" 8 | 9 (map (N.pow 2) (N_iota 5 15)) (id) 9 | "CBN.sort2" (eager_bench CBN.sort2) 10 | "CBN.sort3" (eager_bench CBN.sort3) 11 | "CBN.sortN" (eager_bench CBN.sortN) 12 | "CBV.sort2" (eager_bench CBV.sort2) 13 | "CBV.sort3" (eager_bench CBV.sort3) 14 | "CBV.sortN" (eager_bench CBV.sortN). 15 | -------------------------------------------------------------------------------- /benchmark/benchmark_exp_native2.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import NArith List. 2 | From mathcomp Require Import all_ssreflect. 3 | From stablesort Require Import stablesort. 4 | From benchmark Require Import benchmark. 5 | 6 | Elpi sort_benchmark 7 | "native-total-smooth" "native_compute" 8 | 9 (map (N.pow 2) (N_iota 5 15)) (sort_blocks N.leb 50) 9 | "CBN.sort2" (eager_bench CBN.sort2) 10 | "CBN.sort3" (eager_bench CBN.sort3) 11 | "CBN.sortN" (eager_bench CBN.sortN) 12 | "CBV.sort2" (eager_bench CBV.sort2) 13 | "CBV.sort3" (eager_bench CBV.sort3) 14 | "CBV.sortN" (eager_bench CBV.sortN). 15 | -------------------------------------------------------------------------------- /benchmark/benchmark_exp_vm.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import NArith List. 2 | From mathcomp Require Import all_ssreflect. 3 | From stablesort Require Import stablesort. 4 | From benchmark Require Import benchmark. 5 | 6 | Elpi sort_benchmark 7 | "vm-total-random" "vm_compute" 8 | 9 (map (N.pow 2) (N_iota 3 15)) (id) 9 | "CBN.sort2" (eager_bench CBN.sort2) 10 | "CBN.sort3" (eager_bench CBN.sort3) 11 | "CBN.sortN" (eager_bench CBN.sortN) 12 | "CBV.sort2" (eager_bench CBV.sort2) 13 | "CBV.sort3" (eager_bench CBV.sort3) 14 | "CBV.sortN" (eager_bench CBV.sortN). 15 | 16 | Elpi sort_benchmark 17 | "vm-total-smooth" "vm_compute" 18 | 9 (map (N.pow 2) (N_iota 3 15)) (sort_blocks N.leb 50) 19 | "CBN.sort2" (eager_bench CBN.sort2) 20 | "CBN.sort3" (eager_bench CBN.sort3) 21 | "CBN.sortN" (eager_bench CBN.sortN) 22 | "CBV.sort2" (eager_bench CBV.sort2) 23 | "CBV.sort3" (eager_bench CBV.sort3) 24 | "CBV.sortN" (eager_bench CBV.sortN). 25 | -------------------------------------------------------------------------------- /benchmark/benchmark_lazy.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import NArith. 2 | From mathcomp Require Import all_ssreflect. 3 | From stablesort Require Import stablesort. 4 | From benchmark Require Import benchmark. 5 | 6 | Elpi sort_benchmark 7 | "lazy1" "lazy" 8 | 5 (map (N.mul 100) (N_iota 1 40)) (id) 9 | "CBN.sort1" (lazy_bench CBN.sort1) 10 | "CBN.sort2" (lazy_bench CBN.sort2) 11 | "CBN.sort3" (lazy_bench CBN.sort3) 12 | "CBN.sortN" (lazy_bench CBN.sortN) 13 | "CBNAcc.sort1" (lazy_bench CBNAcc.sort1) 14 | "CBNAcc.sort2" (lazy_bench CBNAcc.sort2) 15 | "CBNAcc.sort3" (lazy_bench CBNAcc.sort3) 16 | "CBNAcc.sortN" (lazy_bench CBNAcc.sortN) 17 | "CBV.sort1" (lazy_bench CBV.sort1) 18 | "CBV.sort2" (lazy_bench CBV.sort2) 19 | "CBV.sort3" (lazy_bench CBV.sort3) 20 | "CBV.sortN" (lazy_bench CBV.sortN) 21 | "CBVAcc.sort1" (lazy_bench CBVAcc.sort1) 22 | "CBVAcc.sort2" (lazy_bench CBVAcc.sort2) 23 | "CBVAcc.sort3" (lazy_bench CBVAcc.sort3) 24 | "CBVAcc.sortN" (lazy_bench CBVAcc.sortN). 25 | 26 | Elpi sort_benchmark 27 | "lazy2" "lazy" 28 | 5 (map (N.mul 100) (N_iota 1 40)) (sort_blocks N.leb 50) 29 | "CBN.sort1" (lazy_bench CBN.sort1) 30 | "CBN.sort2" (lazy_bench CBN.sort2) 31 | "CBN.sort3" (lazy_bench CBN.sort3) 32 | "CBN.sortN" (lazy_bench CBN.sortN) 33 | "CBNAcc.sort1" (lazy_bench CBNAcc.sort1) 34 | "CBNAcc.sort2" (lazy_bench CBNAcc.sort2) 35 | "CBNAcc.sort3" (lazy_bench CBNAcc.sort3) 36 | "CBNAcc.sortN" (lazy_bench CBNAcc.sortN) 37 | "CBV.sort1" (lazy_bench CBV.sort1) 38 | "CBV.sort2" (lazy_bench CBV.sort2) 39 | "CBV.sort3" (lazy_bench CBV.sort3) 40 | "CBV.sortN" (lazy_bench CBV.sortN) 41 | "CBVAcc.sort1" (lazy_bench CBVAcc.sort1) 42 | "CBVAcc.sort2" (lazy_bench CBVAcc.sort2) 43 | "CBVAcc.sort3" (lazy_bench CBVAcc.sort3) 44 | "CBVAcc.sortN" (lazy_bench CBVAcc.sortN). 45 | 46 | Elpi sort_benchmark 47 | "lazy3" "lazy" 48 | 5 (map (N.mul 100) (N_iota 1 40)) (id) 49 | "CBN.sort1" (eager_bench CBN.sort1) 50 | "CBN.sort2" (eager_bench CBN.sort2) 51 | "CBN.sort3" (eager_bench CBN.sort3) 52 | "CBN.sortN" (eager_bench CBN.sortN) 53 | "CBNAcc.sort1" (eager_bench CBNAcc.sort1) 54 | "CBNAcc.sort2" (eager_bench CBNAcc.sort2) 55 | "CBNAcc.sort3" (eager_bench CBNAcc.sort3) 56 | "CBNAcc.sortN" (eager_bench CBNAcc.sortN) 57 | "CBV.sort1" (eager_bench CBV.sort1) 58 | "CBV.sort2" (eager_bench CBV.sort2) 59 | "CBV.sort3" (eager_bench CBV.sort3) 60 | "CBV.sortN" (eager_bench CBV.sortN) 61 | "CBVAcc.sort1" (eager_bench CBVAcc.sort1) 62 | "CBVAcc.sort2" (eager_bench CBVAcc.sort2) 63 | "CBVAcc.sort3" (eager_bench CBVAcc.sort3) 64 | "CBVAcc.sortN" (eager_bench CBVAcc.sortN). 65 | 66 | Elpi sort_benchmark 67 | "lazy4" "lazy" 68 | 5 (map (N.mul 100) (N_iota 1 40)) (sort_blocks N.leb 50) 69 | "CBN.sort1" (eager_bench CBN.sort1) 70 | "CBN.sort2" (eager_bench CBN.sort2) 71 | "CBN.sort3" (eager_bench CBN.sort3) 72 | "CBN.sortN" (eager_bench CBN.sortN) 73 | "CBNAcc.sort1" (eager_bench CBNAcc.sort1) 74 | "CBNAcc.sort2" (eager_bench CBNAcc.sort2) 75 | "CBNAcc.sort3" (eager_bench CBNAcc.sort3) 76 | "CBNAcc.sortN" (eager_bench CBNAcc.sortN) 77 | "CBV.sort1" (eager_bench CBV.sort1) 78 | "CBV.sort2" (eager_bench CBV.sort2) 79 | "CBV.sort3" (eager_bench CBV.sort3) 80 | "CBV.sortN" (eager_bench CBV.sortN) 81 | "CBVAcc.sort1" (eager_bench CBVAcc.sort1) 82 | "CBVAcc.sort2" (eager_bench CBVAcc.sort2) 83 | "CBVAcc.sort3" (eager_bench CBVAcc.sort3) 84 | "CBVAcc.sortN" (eager_bench CBVAcc.sortN). 85 | -------------------------------------------------------------------------------- /benchmark/benchmark_native1.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import NArith. 2 | From mathcomp Require Import all_ssreflect. 3 | From stablesort Require Import stablesort. 4 | From benchmark Require Import benchmark. 5 | 6 | Elpi sort_benchmark 7 | "native1" "native_compute" 8 | 5 (map (N.mul 1000) (N_iota 1 40)) (id) 9 | "CBN.sort1" (eager_bench CBN.sort1) 10 | "CBN.sort2" (eager_bench CBN.sort2) 11 | "CBN.sort3" (eager_bench CBN.sort3) 12 | "CBN.sortN" (eager_bench CBN.sortN) 13 | "CBNAcc.sort1" (eager_bench CBNAcc.sort1) 14 | "CBNAcc.sort2" (eager_bench CBNAcc.sort2) 15 | "CBNAcc.sort3" (eager_bench CBNAcc.sort3) 16 | "CBNAcc.sortN" (eager_bench CBNAcc.sortN) 17 | "CBV.sort1" (eager_bench CBV.sort1) 18 | "CBV.sort2" (eager_bench CBV.sort2) 19 | "CBV.sort3" (eager_bench CBV.sort3) 20 | "CBV.sortN" (eager_bench CBV.sortN) 21 | "CBVAcc.sort1" (eager_bench CBVAcc.sort1) 22 | "CBVAcc.sort2" (eager_bench CBVAcc.sort2) 23 | "CBVAcc.sort3" (eager_bench CBVAcc.sort3) 24 | "CBVAcc.sortN" (eager_bench CBVAcc.sortN). 25 | -------------------------------------------------------------------------------- /benchmark/benchmark_native2.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import NArith. 2 | From mathcomp Require Import all_ssreflect. 3 | From stablesort Require Import stablesort. 4 | From benchmark Require Import benchmark. 5 | 6 | Elpi sort_benchmark 7 | "native2" "native_compute" 8 | 5 (map (N.mul 1000) (N_iota 1 40)) (sort_blocks N.leb 50) 9 | "CBN.sort1" (eager_bench CBN.sort1) 10 | "CBN.sort2" (eager_bench CBN.sort2) 11 | "CBN.sort3" (eager_bench CBN.sort3) 12 | "CBN.sortN" (eager_bench CBN.sortN) 13 | "CBNAcc.sort1" (eager_bench CBNAcc.sort1) 14 | "CBNAcc.sort2" (eager_bench CBNAcc.sort2) 15 | "CBNAcc.sort3" (eager_bench CBNAcc.sort3) 16 | "CBNAcc.sortN" (eager_bench CBNAcc.sortN) 17 | "CBV.sort1" (eager_bench CBV.sort1) 18 | "CBV.sort2" (eager_bench CBV.sort2) 19 | "CBV.sort3" (eager_bench CBV.sort3) 20 | "CBV.sortN" (eager_bench CBV.sortN) 21 | "CBVAcc.sort1" (eager_bench CBVAcc.sort1) 22 | "CBVAcc.sort2" (eager_bench CBVAcc.sort2) 23 | "CBVAcc.sort3" (eager_bench CBVAcc.sort3) 24 | "CBVAcc.sortN" (eager_bench CBVAcc.sortN). 25 | -------------------------------------------------------------------------------- /benchmark/benchmark_vm1.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import NArith. 2 | From mathcomp Require Import all_ssreflect. 3 | From stablesort Require Import stablesort. 4 | From benchmark Require Import benchmark. 5 | 6 | Elpi sort_benchmark 7 | "vm1" "vm_compute" 8 | 5 (map (N.mul 1000) (N_iota 1 40)) (id) 9 | "CBN.sort1" (eager_bench CBN.sort1) 10 | "CBN.sort2" (eager_bench CBN.sort2) 11 | "CBN.sort3" (eager_bench CBN.sort3) 12 | "CBN.sortN" (eager_bench CBN.sortN) 13 | "CBNAcc.sort1" (eager_bench CBNAcc.sort1) 14 | "CBNAcc.sort2" (eager_bench CBNAcc.sort2) 15 | "CBNAcc.sort3" (eager_bench CBNAcc.sort3) 16 | "CBNAcc.sortN" (eager_bench CBNAcc.sortN) 17 | "CBV.sort1" (eager_bench CBV.sort1) 18 | "CBV.sort2" (eager_bench CBV.sort2) 19 | "CBV.sort3" (eager_bench CBV.sort3) 20 | "CBV.sortN" (eager_bench CBV.sortN) 21 | "CBVAcc.sort1" (eager_bench CBVAcc.sort1) 22 | "CBVAcc.sort2" (eager_bench CBVAcc.sort2) 23 | "CBVAcc.sort3" (eager_bench CBVAcc.sort3) 24 | "CBVAcc.sortN" (eager_bench CBVAcc.sortN). 25 | -------------------------------------------------------------------------------- /benchmark/benchmark_vm2.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import NArith. 2 | From mathcomp Require Import all_ssreflect. 3 | From stablesort Require Import stablesort. 4 | From benchmark Require Import benchmark. 5 | 6 | Elpi sort_benchmark 7 | "vm2" "vm_compute" 8 | 5 (map (N.mul 1000) (N_iota 1 40)) (sort_blocks N.leb 50) 9 | "CBN.sort1" (eager_bench CBN.sort1) 10 | "CBN.sort2" (eager_bench CBN.sort2) 11 | "CBN.sort3" (eager_bench CBN.sort3) 12 | "CBN.sortN" (eager_bench CBN.sortN) 13 | "CBNAcc.sort1" (eager_bench CBNAcc.sort1) 14 | "CBNAcc.sort2" (eager_bench CBNAcc.sort2) 15 | "CBNAcc.sort3" (eager_bench CBNAcc.sort3) 16 | "CBNAcc.sortN" (eager_bench CBNAcc.sortN) 17 | "CBV.sort1" (eager_bench CBV.sort1) 18 | "CBV.sort2" (eager_bench CBV.sort2) 19 | "CBV.sort3" (eager_bench CBV.sort3) 20 | "CBV.sortN" (eager_bench CBV.sortN) 21 | "CBVAcc.sort1" (eager_bench CBVAcc.sort1) 22 | "CBVAcc.sort2" (eager_bench CBVAcc.sort2) 23 | "CBVAcc.sort3" (eager_bench CBVAcc.sort3) 24 | "CBVAcc.sortN" (eager_bench CBVAcc.sortN). 25 | -------------------------------------------------------------------------------- /benchmark/extraction_cbn.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From stablesort Require Import stablesort. 3 | From Coq Require Import Extraction. 4 | 5 | Set Extraction Flag 2031. 6 | 7 | Include CBN. 8 | 9 | (******************************************************************************) 10 | 11 | Extraction Language Haskell. 12 | 13 | Extract Inductive bool => "Prelude.Bool" ["Prelude.True" "Prelude.False"]. 14 | 15 | Extract Inlined Constant negb => "Prelude.not". 16 | Extract Inlined Constant eqb => "(Prelude.==)". 17 | 18 | Extract Inductive list => "([])" ["([])" "(:)"]. 19 | 20 | Extraction "benchmark/haskell/MergesortCoqCbn.hs" sort1 sort2 sort3 sortN. 21 | 22 | (******************************************************************************) 23 | 24 | Extraction Language OCaml. 25 | 26 | Extract Inductive bool => "bool" ["true" "false"]. 27 | 28 | Extract Inlined Constant negb => "not". 29 | Extract Inlined Constant eqb => "((=) : bool -> bool -> bool)". 30 | 31 | Extract Inductive list => "list" ["[]" "(::)"]. 32 | 33 | Extract Inlined Constant catrev => "List.rev_append". 34 | Extract Inlined Constant rev => "List.rev". 35 | 36 | Extraction "benchmark/ocaml/mergesort_coq_cbn.ml" sort1 sort2 sort3 sortN. 37 | -------------------------------------------------------------------------------- /benchmark/extraction_cbnacc.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From stablesort Require Import stablesort. 3 | From Coq Require Import Extraction. 4 | 5 | Set Extraction Flag 2031. 6 | 7 | Include CBNAcc. 8 | 9 | (******************************************************************************) 10 | 11 | Extraction Language Haskell. 12 | 13 | Extract Inductive bool => "Prelude.Bool" ["Prelude.True" "Prelude.False"]. 14 | 15 | Extract Inlined Constant negb => "Prelude.not". 16 | Extract Inlined Constant eqb => "(Prelude.==)". 17 | 18 | Extract Inductive list => "([])" ["([])" "(:)"]. 19 | 20 | Extraction "benchmark/haskell/MergesortCoqCbnAcc.hs" sort1 sort2 sort3 sortN. 21 | 22 | (******************************************************************************) 23 | 24 | Extraction Language OCaml. 25 | 26 | Extract Inductive bool => "bool" ["true" "false"]. 27 | 28 | Extract Inlined Constant negb => "not". 29 | Extract Inlined Constant eqb => "((=) : bool -> bool -> bool)". 30 | 31 | Extract Inductive list => "list" ["[]" "(::)"]. 32 | 33 | Extract Inlined Constant catrev => "List.rev_append". 34 | Extract Inlined Constant rev => "List.rev". 35 | 36 | Extraction "benchmark/ocaml/mergesort_coq_cbnacc.ml" sort1 sort2 sort3 sortN. 37 | -------------------------------------------------------------------------------- /benchmark/extraction_cbv.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From stablesort Require Import stablesort. 3 | From Coq Require Import Extraction. 4 | 5 | Set Extraction Flag 2031. 6 | 7 | Include CBV. 8 | 9 | (******************************************************************************) 10 | 11 | Extraction Language Haskell. 12 | 13 | Extract Inductive bool => "Prelude.Bool" ["Prelude.True" "Prelude.False"]. 14 | 15 | Extract Inlined Constant negb => "Prelude.not". 16 | Extract Inlined Constant eqb => "(Prelude.==)". 17 | 18 | Extract Inductive list => "([])" ["([])" "(:)"]. 19 | 20 | Extraction "benchmark/haskell/MergesortCoqCbv.hs" sort1 sort2 sort3 sortN. 21 | 22 | (******************************************************************************) 23 | 24 | Extraction Language OCaml. 25 | 26 | Extract Inductive bool => "bool" ["true" "false"]. 27 | 28 | Extract Inlined Constant negb => "not". 29 | Extract Inlined Constant eqb => "((=) : bool -> bool -> bool)". 30 | 31 | Extract Inductive list => "list" ["[]" "(::)"]. 32 | 33 | Extract Inlined Constant catrev => "List.rev_append". 34 | Extract Inlined Constant rev => "List.rev". 35 | 36 | Extraction "benchmark/ocaml/mergesort_coq_cbv.ml" sort1 sort2 sort3 sortN. 37 | -------------------------------------------------------------------------------- /benchmark/extraction_cbvacc.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import all_ssreflect. 2 | From stablesort Require Import stablesort. 3 | From Coq Require Import Extraction. 4 | 5 | Set Extraction Flag 2031. 6 | 7 | Include CBVAcc. 8 | 9 | (******************************************************************************) 10 | 11 | Extraction Language Haskell. 12 | 13 | Extract Inductive bool => "Prelude.Bool" ["Prelude.True" "Prelude.False"]. 14 | 15 | Extract Inlined Constant negb => "Prelude.not". 16 | Extract Inlined Constant eqb => "(Prelude.==)". 17 | 18 | Extract Inductive list => "([])" ["([])" "(:)"]. 19 | 20 | Extraction "benchmark/haskell/MergesortCoqCbvAcc.hs" sort1 sort2 sort3 sortN. 21 | 22 | (******************************************************************************) 23 | 24 | Extraction Language OCaml. 25 | 26 | Extract Inductive bool => "bool" ["true" "false"]. 27 | 28 | Extract Inlined Constant negb => "not". 29 | Extract Inlined Constant eqb => "((=) : bool -> bool -> bool)". 30 | 31 | Extract Inductive list => "list" ["[]" "(::)"]. 32 | 33 | Extract Inlined Constant catrev => "List.rev_append". 34 | Extract Inlined Constant rev => "List.rev". 35 | 36 | Extraction "benchmark/ocaml/mergesort_coq_cbvacc.ml" sort1 sort2 sort3 sortN. 37 | -------------------------------------------------------------------------------- /benchmark/haskell/Benchlib.hs: -------------------------------------------------------------------------------- 1 | module Benchlib where 2 | 3 | import Data.List 4 | import Data.Time.Clock.POSIX (getPOSIXTime) 5 | import Text.Printf 6 | import Control.Monad 7 | import Control.DeepSeq 8 | import System.Random 9 | import System.IO 10 | import qualified System.Mem 11 | 12 | time :: IO a -> IO Double 13 | time act = do 14 | System.Mem.performMajorGC 15 | time1 <- realToFrac <$> getPOSIXTime 16 | _ <- act 17 | time2 <- realToFrac <$> getPOSIXTime 18 | return $ time2 - time1 19 | 20 | median :: (Ord a, Fractional a) => [a] -> a 21 | median xs = 22 | let sorted = sort xs in 23 | if odd (length xs) then 24 | sorted !! (length xs `div` 2) 25 | else 26 | (sorted !! (length xs `div` 2 - 1) + sorted !! (length xs `div` 2)) / 2 27 | 28 | withTimerMedian :: Int -> (a -> IO ()) -> a -> IO Double 29 | withTimerMedian n act arg = median <$> mapM (time . act) (replicate n arg) 30 | 31 | genList :: StdGen -> Int -> [Int] 32 | genList seed elems = 33 | take elems (unfoldr (Just . randomR (0, elems - 1)) seed) 34 | 35 | benchmark :: 36 | String -> [Int] -> ([Int] -> [Int]) -> [(String, Int -> [Int] -> IO ())] -> IO () 37 | benchmark filename size preproc config = do 38 | let seeds = unfoldr (Just . random) (mkStdGen 0) :: [Int] 39 | rs <- zipWithM (\size seed -> do 40 | let input = preproc (genList (mkStdGen seed) size) 41 | r <- input `deepseq` mapM (\(name, act) -> do 42 | time <- withTimerMedian 5 (uncurry act) (size, input) 43 | return (name, time)) config 44 | printf "size: %7d" size 45 | mapM_ (uncurry (printf "; %s: %8.6fs")) r 46 | putStrLn "" 47 | return (size, map snd r)) size seeds 48 | withFile (filename ++ ".time.csv") WriteMode $ \handle -> do 49 | hPrintf handle "Size" 50 | mapM_ (\(name, _) -> hPrintf handle ", %s" name) config 51 | hPrintf handle "\n" 52 | mapM_ (\(size, times) -> do 53 | hPrintf handle "%d" size 54 | mapM_ (hPrintf handle ", %f") times 55 | hPrintf handle "\n") rs 56 | 57 | path :: Ord a => a -> [a] -> Bool 58 | path _ [] = True 59 | path x (y : xs) = (x <= y) && path y xs 60 | 61 | sorted :: Ord a => [a] -> Bool 62 | sorted [] = True 63 | sorted (x : xs) = path x xs 64 | 65 | sort_blocks :: Ord a => Int -> [a] -> [a] 66 | sort_blocks _ [] = [] 67 | sort_blocks n xs = 68 | let (xs1, xs2) = splitAt n xs in sort xs1 ++ sort_blocks n xs2 69 | -------------------------------------------------------------------------------- /benchmark/haskell/Benchmark.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | import qualified Data.List 5 | import qualified MergesortCoqCbn 6 | import qualified MergesortCoqCbnAcc 7 | import qualified MergesortCoqCbv 8 | import qualified MergesortCoqCbvAcc 9 | import qualified GHC.Stats 10 | 11 | import Benchlib 12 | 13 | main :: IO () 14 | main = do 15 | statsEnabled <- GHC.Stats.getRTSStatsEnabled 16 | unless statsEnabled (error "+RTS -T required.") 17 | benchmark 18 | "haskell1" (map (25000 *) [1..40]) id 19 | [("Data.List.sort", \_ xs -> sorted (take 1000 (Data.List.sort xs)) `seq` return ()), 20 | ("CBN.sort1", \_ xs -> sorted (take 1000 (MergesortCoqCbn.sort1 (<=) xs)) `seq` return ()), 21 | ("CBN.sort2", \_ xs -> sorted (take 1000 (MergesortCoqCbn.sort2 (<=) xs)) `seq` return ()), 22 | ("CBN.sort3", \_ xs -> sorted (take 1000 (MergesortCoqCbn.sort3 (<=) xs)) `seq` return ()), 23 | ("CBN.sortN", \_ xs -> sorted (take 1000 (MergesortCoqCbn.sortN (<=) xs)) `seq` return ()), 24 | ("CBNAcc.sort1", \_ xs -> sorted (take 1000 (MergesortCoqCbnAcc.sort1 (<=) xs)) `seq` return ()), 25 | ("CBNAcc.sort2", \_ xs -> sorted (take 1000 (MergesortCoqCbnAcc.sort2 (<=) xs)) `seq` return ()), 26 | ("CBNAcc.sort3", \_ xs -> sorted (take 1000 (MergesortCoqCbnAcc.sort3 (<=) xs)) `seq` return ()), 27 | ("CBNAcc.sortN", \_ xs -> sorted (take 1000 (MergesortCoqCbnAcc.sortN (<=) xs)) `seq` return ()), 28 | ("CBV.sort1", \_ xs -> sorted (take 1000 (MergesortCoqCbv.sort1 (<=) xs)) `seq` return ()), 29 | ("CBV.sort2", \_ xs -> sorted (take 1000 (MergesortCoqCbv.sort2 (<=) xs)) `seq` return ()), 30 | ("CBV.sort3", \_ xs -> sorted (take 1000 (MergesortCoqCbv.sort3 (<=) xs)) `seq` return ()), 31 | ("CBV.sortN", \_ xs -> sorted (take 1000 (MergesortCoqCbv.sortN (<=) xs)) `seq` return ()), 32 | ("CBVAcc.sort1", \_ xs -> sorted (take 1000 (MergesortCoqCbvAcc.sort1 (<=) xs)) `seq` return ()), 33 | ("CBVAcc.sort2", \_ xs -> sorted (take 1000 (MergesortCoqCbvAcc.sort2 (<=) xs)) `seq` return ()), 34 | ("CBVAcc.sort3", \_ xs -> sorted (take 1000 (MergesortCoqCbvAcc.sort3 (<=) xs)) `seq` return ()), 35 | ("CBVAcc.sortN", \_ xs -> sorted (take 1000 (MergesortCoqCbvAcc.sortN (<=) xs)) `seq` return ())] 36 | benchmark 37 | "haskell2" (map (25000 *) [1..40]) (sort_blocks 50) 38 | [("Data.List.sort", \_ xs -> sorted (take 1000 (Data.List.sort xs)) `seq` return ()), 39 | ("CBN.sort1", \_ xs -> sorted (take 1000 (MergesortCoqCbn.sort1 (<=) xs)) `seq` return ()), 40 | ("CBN.sort2", \_ xs -> sorted (take 1000 (MergesortCoqCbn.sort2 (<=) xs)) `seq` return ()), 41 | ("CBN.sort3", \_ xs -> sorted (take 1000 (MergesortCoqCbn.sort3 (<=) xs)) `seq` return ()), 42 | ("CBN.sortN", \_ xs -> sorted (take 1000 (MergesortCoqCbn.sortN (<=) xs)) `seq` return ()), 43 | ("CBNAcc.sort1", \_ xs -> sorted (take 1000 (MergesortCoqCbnAcc.sort1 (<=) xs)) `seq` return ()), 44 | ("CBNAcc.sort2", \_ xs -> sorted (take 1000 (MergesortCoqCbnAcc.sort2 (<=) xs)) `seq` return ()), 45 | ("CBNAcc.sort3", \_ xs -> sorted (take 1000 (MergesortCoqCbnAcc.sort3 (<=) xs)) `seq` return ()), 46 | ("CBNAcc.sortN", \_ xs -> sorted (take 1000 (MergesortCoqCbnAcc.sortN (<=) xs)) `seq` return ()), 47 | ("CBV.sort1", \_ xs -> sorted (take 1000 (MergesortCoqCbv.sort1 (<=) xs)) `seq` return ()), 48 | ("CBV.sort2", \_ xs -> sorted (take 1000 (MergesortCoqCbv.sort2 (<=) xs)) `seq` return ()), 49 | ("CBV.sort3", \_ xs -> sorted (take 1000 (MergesortCoqCbv.sort3 (<=) xs)) `seq` return ()), 50 | ("CBV.sortN", \_ xs -> sorted (take 1000 (MergesortCoqCbv.sortN (<=) xs)) `seq` return ()), 51 | ("CBVAcc.sort1", \_ xs -> sorted (take 1000 (MergesortCoqCbvAcc.sort1 (<=) xs)) `seq` return ()), 52 | ("CBVAcc.sort2", \_ xs -> sorted (take 1000 (MergesortCoqCbvAcc.sort2 (<=) xs)) `seq` return ()), 53 | ("CBVAcc.sort3", \_ xs -> sorted (take 1000 (MergesortCoqCbvAcc.sort3 (<=) xs)) `seq` return ()), 54 | ("CBVAcc.sortN", \_ xs -> sorted (take 1000 (MergesortCoqCbvAcc.sortN (<=) xs)) `seq` return ())] 55 | benchmark 56 | "haskell3" (map (25000 *) [1..40]) id 57 | [("Data.List.sort", \_ xs -> sorted (Data.List.sort xs) `seq` return ()), 58 | ("CBN.sort1", \_ xs -> sorted (MergesortCoqCbn.sort1 (<=) xs) `seq` return ()), 59 | ("CBN.sort2", \_ xs -> sorted (MergesortCoqCbn.sort2 (<=) xs) `seq` return ()), 60 | ("CBN.sort3", \_ xs -> sorted (MergesortCoqCbn.sort3 (<=) xs) `seq` return ()), 61 | ("CBN.sortN", \_ xs -> sorted (MergesortCoqCbn.sortN (<=) xs) `seq` return ()), 62 | ("CBNAcc.sort1", \_ xs -> sorted (MergesortCoqCbnAcc.sort1 (<=) xs) `seq` return ()), 63 | ("CBNAcc.sort2", \_ xs -> sorted (MergesortCoqCbnAcc.sort2 (<=) xs) `seq` return ()), 64 | ("CBNAcc.sort3", \_ xs -> sorted (MergesortCoqCbnAcc.sort3 (<=) xs) `seq` return ()), 65 | ("CBNAcc.sortN", \_ xs -> sorted (MergesortCoqCbnAcc.sortN (<=) xs) `seq` return ()), 66 | ("CBV.sort1", \_ xs -> sorted (MergesortCoqCbv.sort1 (<=) xs) `seq` return ()), 67 | ("CBV.sort2", \_ xs -> sorted (MergesortCoqCbv.sort2 (<=) xs) `seq` return ()), 68 | ("CBV.sort3", \_ xs -> sorted (MergesortCoqCbv.sort3 (<=) xs) `seq` return ()), 69 | ("CBV.sortN", \_ xs -> sorted (MergesortCoqCbv.sortN (<=) xs) `seq` return ()), 70 | ("CBVAcc.sort1", \_ xs -> sorted (MergesortCoqCbvAcc.sort1 (<=) xs) `seq` return ()), 71 | ("CBVAcc.sort2", \_ xs -> sorted (MergesortCoqCbvAcc.sort2 (<=) xs) `seq` return ()), 72 | ("CBVAcc.sort3", \_ xs -> sorted (MergesortCoqCbvAcc.sort3 (<=) xs) `seq` return ()), 73 | ("CBVAcc.sortN", \_ xs -> sorted (MergesortCoqCbvAcc.sortN (<=) xs) `seq` return ())] 74 | benchmark 75 | "haskell4" (map (25000 *) [1..40]) (sort_blocks 50) 76 | [("Data.List.sort", \_ xs -> sorted (Data.List.sort xs) `seq` return ()), 77 | ("CBN.sort1", \_ xs -> sorted (MergesortCoqCbn.sort1 (<=) xs) `seq` return ()), 78 | ("CBN.sort2", \_ xs -> sorted (MergesortCoqCbn.sort2 (<=) xs) `seq` return ()), 79 | ("CBN.sort3", \_ xs -> sorted (MergesortCoqCbn.sort3 (<=) xs) `seq` return ()), 80 | ("CBN.sortN", \_ xs -> sorted (MergesortCoqCbn.sortN (<=) xs) `seq` return ()), 81 | ("CBNAcc.sort1", \_ xs -> sorted (MergesortCoqCbnAcc.sort1 (<=) xs) `seq` return ()), 82 | ("CBNAcc.sort2", \_ xs -> sorted (MergesortCoqCbnAcc.sort2 (<=) xs) `seq` return ()), 83 | ("CBNAcc.sort3", \_ xs -> sorted (MergesortCoqCbnAcc.sort3 (<=) xs) `seq` return ()), 84 | ("CBNAcc.sortN", \_ xs -> sorted (MergesortCoqCbnAcc.sortN (<=) xs) `seq` return ()), 85 | ("CBV.sort1", \_ xs -> sorted (MergesortCoqCbv.sort1 (<=) xs) `seq` return ()), 86 | ("CBV.sort2", \_ xs -> sorted (MergesortCoqCbv.sort2 (<=) xs) `seq` return ()), 87 | ("CBV.sort3", \_ xs -> sorted (MergesortCoqCbv.sort3 (<=) xs) `seq` return ()), 88 | ("CBV.sortN", \_ xs -> sorted (MergesortCoqCbv.sortN (<=) xs) `seq` return ()), 89 | ("CBVAcc.sort1", \_ xs -> sorted (MergesortCoqCbvAcc.sort1 (<=) xs) `seq` return ()), 90 | ("CBVAcc.sort2", \_ xs -> sorted (MergesortCoqCbvAcc.sort2 (<=) xs) `seq` return ()), 91 | ("CBVAcc.sort3", \_ xs -> sorted (MergesortCoqCbvAcc.sort3 (<=) xs) `seq` return ()), 92 | ("CBVAcc.sortN", \_ xs -> sorted (MergesortCoqCbvAcc.sortN (<=) xs) `seq` return ())] 93 | -------------------------------------------------------------------------------- /benchmark/haskell/BenchmarkExp.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | import qualified Data.List 5 | import qualified MergesortHaskellNTRStack 6 | import qualified MergesortHaskellNTRStack_ 7 | import qualified MergesortHaskellTRStack 8 | import qualified MergesortHaskellTRStack_ 9 | import qualified MergesortHaskellStdlib 10 | import qualified MergesortCoqCbn 11 | import qualified MergesortCoqCbnAcc 12 | import qualified MergesortCoqCbv 13 | import qualified MergesortCoqCbvAcc 14 | import qualified GHC.Stats 15 | 16 | import Benchlib 17 | 18 | main :: IO () 19 | main = do 20 | statsEnabled <- GHC.Stats.getRTSStatsEnabled 21 | unless statsEnabled (error "+RTS -T required.") 22 | benchmark 23 | "haskell-partial-random" (map (\i -> 128 * 2 ^ i) [0..14]) id 24 | [("Data.List.sort (old)", \n xs -> sorted (take (n `div` 4) (MergesortHaskellStdlib.oldSort (<=) xs)) `seq` return ()), 25 | ("Data.List.sort (new)", \n xs -> sorted (take (n `div` 4) (MergesortHaskellStdlib.newSort (<=) xs)) `seq` return ()), 26 | ("NTRStack.sort3", \n xs -> sorted (take (n `div` 4) (MergesortHaskellNTRStack.sort3 (<=) xs)) `seq` return ()), 27 | ("NTRStack.sortN", \n xs -> sorted (take (n `div` 4) (MergesortHaskellNTRStack.sortN (<=) xs)) `seq` return ()), 28 | ("NTRStack.sort3N", \n xs -> sorted (take (n `div` 4) (MergesortHaskellNTRStack.sort3N (<=) xs)) `seq` return ()), 29 | ("NTRStack_.sort3", \n xs -> sorted (take (n `div` 4) (MergesortHaskellNTRStack_.sort3 (<=) xs)) `seq` return ()), 30 | ("NTRStack_.sortN", \n xs -> sorted (take (n `div` 4) (MergesortHaskellNTRStack_.sortN (<=) xs)) `seq` return ()), 31 | ("NTRStack_.sort3N", \n xs -> sorted (take (n `div` 4) (MergesortHaskellNTRStack_.sort3N (<=) xs)) `seq` return ()), 32 | ("TRStack.sort3", \n xs -> sorted (take (n `div` 4) (MergesortHaskellTRStack.sort3 (<=) xs)) `seq` return ()), 33 | ("TRStack.sortN", \n xs -> sorted (take (n `div` 4) (MergesortHaskellTRStack.sortN (<=) xs)) `seq` return ()), 34 | ("TRStack.sort3N", \n xs -> sorted (take (n `div` 4) (MergesortHaskellTRStack.sort3N (<=) xs)) `seq` return ()), 35 | ("TRStack_.sort3", \n xs -> sorted (take (n `div` 4) (MergesortHaskellTRStack_.sort3 (<=) xs)) `seq` return ()), 36 | ("TRStack_.sortN", \n xs -> sorted (take (n `div` 4) (MergesortHaskellTRStack_.sortN (<=) xs)) `seq` return ()), 37 | ("TRStack_.sort3N", \n xs -> sorted (take (n `div` 4) (MergesortHaskellTRStack_.sort3N (<=) xs)) `seq` return ()), 38 | ("CBNAcc.sort2", \n xs -> sorted (take (n `div` 4) (MergesortCoqCbnAcc.sort2 (<=) xs)) `seq` return ()), 39 | ("CBNAcc.sort3", \n xs -> sorted (take (n `div` 4) (MergesortCoqCbnAcc.sort3 (<=) xs)) `seq` return ()), 40 | ("CBNAcc.sortN", \n xs -> sorted (take (n `div` 4) (MergesortCoqCbnAcc.sortN (<=) xs)) `seq` return ()), 41 | ("CBVAcc.sort2", \n xs -> sorted (take (n `div` 4) (MergesortCoqCbvAcc.sort2 (<=) xs)) `seq` return ()), 42 | ("CBVAcc.sort3", \n xs -> sorted (take (n `div` 4) (MergesortCoqCbvAcc.sort3 (<=) xs)) `seq` return ()), 43 | ("CBVAcc.sortN", \n xs -> sorted (take (n `div` 4) (MergesortCoqCbvAcc.sortN (<=) xs)) `seq` return ())] 44 | benchmark 45 | "haskell-partial-smooth" (map (\i -> 128 * 2 ^ i) [0..14]) (sort_blocks 50) 46 | [("Data.List.sort (old)", \n xs -> sorted (take (n `div` 4) (MergesortHaskellStdlib.oldSort (<=) xs)) `seq` return ()), 47 | ("Data.List.sort (new)", \n xs -> sorted (take (n `div` 4) (MergesortHaskellStdlib.newSort (<=) xs)) `seq` return ()), 48 | ("NTRStack.sort3", \n xs -> sorted (take (n `div` 4) (MergesortHaskellNTRStack.sort3 (<=) xs)) `seq` return ()), 49 | ("NTRStack.sortN", \n xs -> sorted (take (n `div` 4) (MergesortHaskellNTRStack.sortN (<=) xs)) `seq` return ()), 50 | ("NTRStack.sort3N", \n xs -> sorted (take (n `div` 4) (MergesortHaskellNTRStack.sort3N (<=) xs)) `seq` return ()), 51 | ("NTRStack_.sort3", \n xs -> sorted (take (n `div` 4) (MergesortHaskellNTRStack_.sort3 (<=) xs)) `seq` return ()), 52 | ("NTRStack_.sortN", \n xs -> sorted (take (n `div` 4) (MergesortHaskellNTRStack_.sortN (<=) xs)) `seq` return ()), 53 | ("NTRStack_.sort3N", \n xs -> sorted (take (n `div` 4) (MergesortHaskellNTRStack_.sort3N (<=) xs)) `seq` return ()), 54 | ("TRStack.sort3", \n xs -> sorted (take (n `div` 4) (MergesortHaskellTRStack.sort3 (<=) xs)) `seq` return ()), 55 | ("TRStack.sortN", \n xs -> sorted (take (n `div` 4) (MergesortHaskellTRStack.sortN (<=) xs)) `seq` return ()), 56 | ("TRStack.sort3N", \n xs -> sorted (take (n `div` 4) (MergesortHaskellTRStack.sort3N (<=) xs)) `seq` return ()), 57 | ("TRStack_.sort3", \n xs -> sorted (take (n `div` 4) (MergesortHaskellTRStack_.sort3 (<=) xs)) `seq` return ()), 58 | ("TRStack_.sortN", \n xs -> sorted (take (n `div` 4) (MergesortHaskellTRStack_.sortN (<=) xs)) `seq` return ()), 59 | ("TRStack_.sort3N", \n xs -> sorted (take (n `div` 4) (MergesortHaskellTRStack_.sort3N (<=) xs)) `seq` return ()), 60 | ("CBNAcc.sort2", \n xs -> sorted (take (n `div` 4) (MergesortCoqCbnAcc.sort2 (<=) xs)) `seq` return ()), 61 | ("CBNAcc.sort3", \n xs -> sorted (take (n `div` 4) (MergesortCoqCbnAcc.sort3 (<=) xs)) `seq` return ()), 62 | ("CBNAcc.sortN", \n xs -> sorted (take (n `div` 4) (MergesortCoqCbnAcc.sortN (<=) xs)) `seq` return ()), 63 | ("CBVAcc.sort2", \n xs -> sorted (take (n `div` 4) (MergesortCoqCbvAcc.sort2 (<=) xs)) `seq` return ()), 64 | ("CBVAcc.sort3", \n xs -> sorted (take (n `div` 4) (MergesortCoqCbvAcc.sort3 (<=) xs)) `seq` return ()), 65 | ("CBVAcc.sortN", \n xs -> sorted (take (n `div` 4) (MergesortCoqCbvAcc.sortN (<=) xs)) `seq` return ())] 66 | benchmark 67 | "haskell-total-random" (map (\i -> 128 * 2 ^ i) [0..14]) id 68 | [("Data.List.sort (old)", \_ xs -> sorted (MergesortHaskellStdlib.oldSort (<=) xs) `seq` return ()), 69 | ("Data.List.sort (new)", \_ xs -> sorted (MergesortHaskellStdlib.newSort (<=) xs) `seq` return ()), 70 | ("NTRStack.sort3", \_ xs -> sorted (MergesortHaskellNTRStack.sort3 (<=) xs) `seq` return ()), 71 | ("NTRStack.sortN", \_ xs -> sorted (MergesortHaskellNTRStack.sortN (<=) xs) `seq` return ()), 72 | ("NTRStack.sort3N", \_ xs -> sorted (MergesortHaskellNTRStack.sort3N (<=) xs) `seq` return ()), 73 | ("NTRStack_.sort3", \_ xs -> sorted (MergesortHaskellNTRStack_.sort3 (<=) xs) `seq` return ()), 74 | ("NTRStack_.sortN", \_ xs -> sorted (MergesortHaskellNTRStack_.sortN (<=) xs) `seq` return ()), 75 | ("NTRStack_.sort3N", \_ xs -> sorted (MergesortHaskellNTRStack_.sort3N (<=) xs) `seq` return ()), 76 | ("TRStack.sort3", \_ xs -> sorted (MergesortHaskellTRStack.sort3 (<=) xs) `seq` return ()), 77 | ("TRStack.sortN", \_ xs -> sorted (MergesortHaskellTRStack.sortN (<=) xs) `seq` return ()), 78 | ("TRStack.sort3N", \_ xs -> sorted (MergesortHaskellTRStack.sort3N (<=) xs) `seq` return ()), 79 | ("TRStack_.sort3", \_ xs -> sorted (MergesortHaskellTRStack_.sort3 (<=) xs) `seq` return ()), 80 | ("TRStack_.sortN", \_ xs -> sorted (MergesortHaskellTRStack_.sortN (<=) xs) `seq` return ()), 81 | ("TRStack_.sort3N", \_ xs -> sorted (MergesortHaskellTRStack_.sort3N (<=) xs) `seq` return ()), 82 | ("CBNAcc.sort2", \_ xs -> sorted (MergesortCoqCbnAcc.sort2 (<=) xs) `seq` return ()), 83 | ("CBNAcc.sort3", \_ xs -> sorted (MergesortCoqCbnAcc.sort3 (<=) xs) `seq` return ()), 84 | ("CBNAcc.sortN", \_ xs -> sorted (MergesortCoqCbnAcc.sortN (<=) xs) `seq` return ()), 85 | ("CBVAcc.sort2", \_ xs -> sorted (MergesortCoqCbvAcc.sort2 (<=) xs) `seq` return ()), 86 | ("CBVAcc.sort3", \_ xs -> sorted (MergesortCoqCbvAcc.sort3 (<=) xs) `seq` return ()), 87 | ("CBVAcc.sortN", \_ xs -> sorted (MergesortCoqCbvAcc.sortN (<=) xs) `seq` return ())] 88 | benchmark 89 | "haskell-total-smooth" (map (\i -> 128 * 2 ^ i) [0..14]) (sort_blocks 50) 90 | [("Data.List.sort (old)", \_ xs -> sorted (MergesortHaskellStdlib.oldSort (<=) xs) `seq` return ()), 91 | ("Data.List.sort (new)", \_ xs -> sorted (MergesortHaskellStdlib.newSort (<=) xs) `seq` return ()), 92 | ("NTRStack.sort3", \_ xs -> sorted (MergesortHaskellNTRStack.sort3 (<=) xs) `seq` return ()), 93 | ("NTRStack.sortN", \_ xs -> sorted (MergesortHaskellNTRStack.sortN (<=) xs) `seq` return ()), 94 | ("NTRStack.sort3N", \_ xs -> sorted (MergesortHaskellNTRStack.sort3N (<=) xs) `seq` return ()), 95 | ("NTRStack_.sort3", \_ xs -> sorted (MergesortHaskellNTRStack_.sort3 (<=) xs) `seq` return ()), 96 | ("NTRStack_.sortN", \_ xs -> sorted (MergesortHaskellNTRStack_.sortN (<=) xs) `seq` return ()), 97 | ("NTRStack_.sort3N", \_ xs -> sorted (MergesortHaskellNTRStack_.sort3N (<=) xs) `seq` return ()), 98 | ("TRStack.sort3", \_ xs -> sorted (MergesortHaskellTRStack.sort3 (<=) xs) `seq` return ()), 99 | ("TRStack.sortN", \_ xs -> sorted (MergesortHaskellTRStack.sortN (<=) xs) `seq` return ()), 100 | ("TRStack.sort3N", \_ xs -> sorted (MergesortHaskellTRStack.sort3N (<=) xs) `seq` return ()), 101 | ("TRStack_.sort3", \_ xs -> sorted (MergesortHaskellTRStack_.sort3 (<=) xs) `seq` return ()), 102 | ("TRStack_.sortN", \_ xs -> sorted (MergesortHaskellTRStack_.sortN (<=) xs) `seq` return ()), 103 | ("TRStack_.sort3N", \_ xs -> sorted (MergesortHaskellTRStack_.sort3N (<=) xs) `seq` return ()), 104 | ("CBNAcc.sort2", \_ xs -> sorted (MergesortCoqCbnAcc.sort2 (<=) xs) `seq` return ()), 105 | ("CBNAcc.sort3", \_ xs -> sorted (MergesortCoqCbnAcc.sort3 (<=) xs) `seq` return ()), 106 | ("CBNAcc.sortN", \_ xs -> sorted (MergesortCoqCbnAcc.sortN (<=) xs) `seq` return ()), 107 | ("CBVAcc.sort2", \_ xs -> sorted (MergesortCoqCbvAcc.sort2 (<=) xs) `seq` return ()), 108 | ("CBVAcc.sort3", \_ xs -> sorted (MergesortCoqCbvAcc.sort3 (<=) xs) `seq` return ()), 109 | ("CBVAcc.sortN", \_ xs -> sorted (MergesortCoqCbvAcc.sortN (<=) xs) `seq` return ())] 110 | -------------------------------------------------------------------------------- /benchmark/haskell/MergesortHaskellNTRStack.hs: -------------------------------------------------------------------------------- 1 | -- Stack-based bottom-up non-tail-recursive mergesorts 2 | {-# LANGUAGE BangPatterns #-} 3 | module MergesortHaskellNTRStack where 4 | 5 | import Data.Bits 6 | 7 | sort3 :: (a -> a -> Bool) -> [a] -> [a] 8 | sort3 (<=) = sortRec (0 :: Int) [] where 9 | merge [] ys = ys 10 | merge xs [] = xs 11 | merge xs@(x : xs') ys@(y : ys') 12 | | x <= y = x : merge xs' ys 13 | | otherwise = y : merge xs ys' 14 | 15 | push xs k stack | testBit k 0 = 16 | let ys : stack' = stack in 17 | let !xys = merge ys xs in 18 | let !k' = shift k (- 1) in push xys k' stack' 19 | push xs k stack = xs : stack 20 | 21 | pop xs [] = xs 22 | pop xs (ys : stack) = let !xys = merge ys xs in pop xys stack 23 | 24 | sortRec k stack (x : y : z : s) = 25 | let !xyz = if x <= y then 26 | if y <= z then [x, y, z] 27 | else if x <= z then [x, z, y] else [z, x, y] 28 | else 29 | if x <= z then [y, x, z] 30 | else if y <= z then [y, z, x] else [z, y, x] 31 | in 32 | let !k' = k + 1 in 33 | let !stack' = push xyz k stack in sortRec k' stack' s 34 | sortRec k stack s@[x, y] = 35 | let !xy = if x <= y then s else [y, x] in pop xy stack 36 | sortRec k stack s = pop s stack 37 | 38 | sortN :: (a -> a -> Bool) -> [a] -> [a] 39 | sortN (<=) = sortRec (0 :: Int) [] where 40 | merge [] ys = ys 41 | merge xs [] = xs 42 | merge xs@(x : xs') ys@(y : ys') 43 | | x <= y = x : merge xs' ys 44 | | otherwise = y : merge xs ys' 45 | 46 | push xs k stack | testBit k 0 = 47 | let ys : stack' = stack in 48 | let !xys = merge ys xs in 49 | let !k' = shift k (- 1) in push xys k' stack' 50 | push xs k stack = xs : stack 51 | 52 | pop xs [] = xs 53 | pop xs (ys : stack) = let !xys = merge ys xs in pop xys stack 54 | 55 | sortRec k stack (x : y : s) = 56 | if x <= y then ascending (x :) y s else descending [x] y s 57 | where 58 | ascending accu x [] = let !xs = accu [x] in pop xs stack 59 | ascending accu x (y : s) | x <= y = 60 | ascending (\ys -> accu (x : ys)) y s 61 | ascending accu x s = 62 | let !k' = k + 1 in 63 | let !xs = accu [x] in 64 | let !stack' = push xs k stack in sortRec k' stack' s 65 | 66 | descending accu x [] = pop (x : accu) stack 67 | descending accu x (y : s) | not (x <= y) = descending (x : accu) y s 68 | descending accu x s = 69 | let !k' = k + 1 in 70 | let !stack' = push (x : accu) k stack in sortRec k' stack' s 71 | sortRec k stack s = pop s stack 72 | 73 | sort3N :: (a -> a -> Bool) -> [a] -> [a] 74 | sort3N (<=) = sortRec (0 :: Int) [] where 75 | merge [] ys = ys 76 | merge xs [] = xs 77 | merge xs@(x : xs') ys@(y : ys') 78 | | x <= y = x : merge xs' ys 79 | | otherwise = y : merge xs ys' 80 | 81 | push xs k stack | testBit k 0 = 82 | let ys : stack' = stack in 83 | let !xys = merge ys xs in 84 | let !k' = shift k (- 1) in push xys k' stack' 85 | push xs k stack = xs : stack 86 | 87 | pop xs [] = xs 88 | pop xs (ys : stack) = let !xys = merge ys xs in pop xys stack 89 | 90 | sortRec k stack (x : y : z : s) 91 | | x <= y, y <= z = ascending (\s -> x : y : s) z s 92 | | not (x <= y), not (y <= z) = descending [y, x] z s 93 | | x <= y, not (y <= z) = 94 | let !k' = k + 1 in 95 | let !xyz = if x <= z then [x, z, y] else [z, x, y] in 96 | let !stack' = push xyz k stack in sortRec k' stack' s 97 | | not (x <= y), y <= z = 98 | let !k' = k + 1 in 99 | let !xyz = if x <= z then [y, x, z] else [y, z, x] in 100 | let !stack' = push xyz k stack in sortRec k' stack' s 101 | where 102 | ascending accu x [] = let !xs = accu [x] in pop xs stack 103 | ascending accu x (y : s) | x <= y = 104 | ascending (\ys -> accu (x : ys)) y s 105 | ascending accu x s = 106 | let !k' = k + 1 in 107 | let !xs = accu [x] in 108 | let !stack' = push xs k stack in sortRec k' stack' s 109 | 110 | descending accu x [] = pop (x : accu) stack 111 | descending accu x (y : s) | not (x <= y) = descending (x : accu) y s 112 | descending accu x s = 113 | let !k' = k + 1 in 114 | let !stack' = push (x : accu) k stack in sortRec k' stack' s 115 | sortRec k stack s@[x, y] = 116 | let !xy = if x <= y then s else [y, x] in pop xy stack 117 | sortRec k stack s = pop s stack 118 | -------------------------------------------------------------------------------- /benchmark/haskell/MergesortHaskellNTRStack_.hs: -------------------------------------------------------------------------------- 1 | -- Stack-based bottom-up non-tail-recursive mergesorts without the counter 2 | {-# LANGUAGE BangPatterns #-} 3 | module MergesortHaskellNTRStack_ where 4 | 5 | sort3 :: (a -> a -> Bool) -> [a] -> [a] 6 | sort3 (<=) = sortRec [] where 7 | merge [] ys = ys 8 | merge xs [] = xs 9 | merge xs@(x : xs') ys@(y : ys') 10 | | x <= y = x : merge xs' ys 11 | | otherwise = y : merge xs ys' 12 | 13 | push xs [] = [xs] 14 | push xs ([] : stack) = xs : stack 15 | push xs (ys : stack) = 16 | let !xys = merge ys xs in 17 | let !stack' = push xys stack in [] : stack' 18 | 19 | pop xs [] = xs 20 | pop xs (ys : stack) = let !xys = merge ys xs in pop xys stack 21 | 22 | sortRec stack (x : y : z : s) = 23 | let xyz = if x <= y then 24 | if y <= z then [x, y, z] 25 | else if x <= z then [x, z, y] else [z, x, y] 26 | else 27 | if x <= z then [y, x, z] 28 | else if y <= z then [y, z, x] else [z, y, x] 29 | in 30 | let !stack' = push xyz stack in sortRec stack' s 31 | sortRec stack s@[x, y] = 32 | let !xy = if x <= y then s else [y, x] in pop xy stack 33 | sortRec stack s = pop s stack 34 | 35 | sortN :: (a -> a -> Bool) -> [a] -> [a] 36 | sortN (<=) = sortRec [] where 37 | merge [] ys = ys 38 | merge xs [] = xs 39 | merge xs@(x : xs') ys@(y : ys') 40 | | x <= y = x : merge xs' ys 41 | | otherwise = y : merge xs ys' 42 | 43 | push xs [] = [xs] 44 | push xs ([] : stack) = xs : stack 45 | push xs (ys : stack) = 46 | let !xys = merge ys xs in 47 | let !stack' = push xys stack in [] : stack' 48 | 49 | pop xs [] = xs 50 | pop xs (ys : stack) = let !xys = merge ys xs in pop xys stack 51 | 52 | sortRec stack (x : y : s) = 53 | if x <= y then ascending (x :) y s else descending [x] y s 54 | where 55 | ascending accu x [] = let !xs = accu [x] in pop xs stack 56 | ascending accu x (y : s) | x <= y = 57 | ascending (\ys -> accu (x : ys)) y s 58 | ascending accu x s = 59 | let !xs = accu [x] in 60 | let !stack' = push xs stack in sortRec stack' s 61 | 62 | descending accu x [] = pop (x : accu) stack 63 | descending accu x (y : s) | not (x <= y) = descending (x : accu) y s 64 | descending accu x s = 65 | let !stack' = push (x : accu) stack in sortRec stack' s 66 | sortRec stack s = pop s stack 67 | 68 | sort3N :: (a -> a -> Bool) -> [a] -> [a] 69 | sort3N (<=) = sortRec [] where 70 | merge [] ys = ys 71 | merge xs [] = xs 72 | merge xs@(x : xs') ys@(y : ys') 73 | | x <= y = x : merge xs' ys 74 | | otherwise = y : merge xs ys' 75 | 76 | push xs [] = [xs] 77 | push xs ([] : stack) = xs : stack 78 | push xs (ys : stack) = 79 | let !xys = merge ys xs in 80 | let !stack' = push xys stack in [] : stack' 81 | 82 | pop xs [] = xs 83 | pop xs (ys : stack) = let !xys = merge ys xs in pop xys stack 84 | 85 | sortRec stack (x : y : z : s) 86 | | x <= y, y <= z = ascending (\s -> x : y : s) z s 87 | | not (x <= y), not (y <= z) = descending [y, x] z s 88 | | x <= y, not (y <= z) = 89 | let !xyz = if x <= z then [x, z, y] else [z, x, y] in 90 | let !stack' = push xyz stack in sortRec stack' s 91 | | not (x <= y), y <= z = 92 | let xyz = if x <= z then [y, x, z] else [y, z, x] in 93 | let !stack' = push xyz stack in sortRec stack' s 94 | where 95 | ascending accu x [] = let !xs = accu [x] in pop xs stack 96 | ascending accu x (y : s) | x <= y = 97 | ascending (\ys -> accu (x : ys)) y s 98 | ascending accu x s = 99 | let !xs = accu [x] in 100 | let !stack' = push xs stack in sortRec stack' s 101 | 102 | descending accu x [] = pop (x : accu) stack 103 | descending accu x (y : s) | not (x <= y) = descending (x : accu) y s 104 | descending accu x s = 105 | let !stack' = push (x : accu) stack in sortRec stack' s 106 | sortRec stack s@[x, y] = 107 | let !xy = if x <= y then s else [y, x] in pop xy stack 108 | sortRec stack s = pop s stack 109 | -------------------------------------------------------------------------------- /benchmark/haskell/MergesortHaskellStdlib.hs: -------------------------------------------------------------------------------- 1 | -- Copies of Data.List.sort of GHC libraries: 2 | -- - oldSort is one from GHC < 9.12.1, slightly modified to take (<=) of type 3 | -- [a -> a -> Bool] instead of [cmp] of type [a -> a -> Ordering] 4 | -- - newSort is one from GHC >= 9.12.1, slightly modified to take (<=) instead 5 | -- of (>) 6 | {-# LANGUAGE BangPatterns #-} 7 | module MergesortHaskellStdlib where 8 | 9 | oldSort :: (a -> a -> Bool) -> [a] -> [a] 10 | oldSort (<=) = mergeAll . sequences 11 | where 12 | sequences (a:b:xs) 13 | | a <= b = ascending b (a:) xs 14 | | otherwise = descending b [a] xs 15 | sequences xs = [xs] 16 | 17 | descending a as (b:bs) 18 | | not (a <= b) = descending b (a:as) bs 19 | descending a as bs = (a:as): sequences bs 20 | 21 | ascending a as (b:bs) 22 | | a <= b = ascending b (\ys -> as (a:ys)) bs 23 | ascending a as bs = let !x = as [a] 24 | in x : sequences bs 25 | 26 | mergeAll [x] = x 27 | mergeAll xs = mergeAll (mergePairs xs) 28 | 29 | mergePairs (a:b:xs) = let !x = merge a b 30 | in x : mergePairs xs 31 | mergePairs xs = xs 32 | 33 | merge as@(a:as') bs@(b:bs') 34 | | a <= b = a:merge as' bs 35 | | otherwise = b:merge as bs' 36 | merge [] bs = bs 37 | merge as [] = as 38 | 39 | newSort :: (a -> a -> Bool) -> [a] -> [a] 40 | newSort (<=) ns 41 | | [] <- ns = [] 42 | | [a] <- ns = [a] 43 | | [a,b] <- ns = merge [a] [b] 44 | | [a,b,c] <- ns = merge3 [a] [b] [c] 45 | | [a,b,c,d] <- ns = merge4 [a] [b] [c] [d] 46 | | otherwise = merge_all (sequences ns) 47 | where 48 | sequences (a:b:xs) 49 | | a <= b = ascending b (a:) xs 50 | | otherwise = descending b [a] xs 51 | sequences xs = [xs] 52 | 53 | descending a as (b:bs) 54 | | not (a <= b) = descending b (a:as) bs 55 | descending a as bs = (a:as): sequences bs 56 | 57 | ascending a as (b:bs) 58 | | a <= b = ascending b (\ys -> as (a:ys)) bs 59 | ascending a as bs = let !x = as [a] 60 | in x : sequences bs 61 | 62 | merge_all [x] = x 63 | merge_all xs = merge_all (reduce_once xs) 64 | 65 | reduce_once [] = [] 66 | reduce_once [a] = [a] 67 | reduce_once [a,b] = [merge a b] 68 | reduce_once [a,b,c] = [merge3 a b c] 69 | reduce_once [a,b,c,d,e] = [merge a b, merge3 c d e] 70 | reduce_once [a,b,c,d,e,f] = [merge3 a b c, merge3 d e f] 71 | reduce_once (a:b:c:d:xs) = let !x = merge4 a b c d 72 | in x : reduce_once xs 73 | 74 | merge as@(a:as') bs@(b:bs') 75 | | a <= b = a : merge as' bs 76 | | otherwise = b : merge as bs' 77 | merge [] bs = bs 78 | merge as [] = as 79 | 80 | -- `merge3` is a manually fused version of `merge (merge as bs) cs` 81 | merge3 as@(a:as') bs@(b:bs') cs 82 | | a <= b = merge3X a as' bs cs 83 | | otherwise = merge3X b as bs' cs 84 | merge3 [] bs cs = merge bs cs 85 | merge3 as [] cs = merge as cs 86 | 87 | merge3X x as bs cs@(c:cs') 88 | | x <= c = x : merge3 as bs cs 89 | | otherwise = c : merge3X x as bs cs' 90 | merge3X x as bs [] = x : merge as bs 91 | 92 | merge3Y as@(a:as') y bs cs 93 | | a <= y = a : merge3Y as' y bs cs 94 | | otherwise = y : merge3 as bs cs 95 | merge3Y [] x bs cs = x : merge bs cs 96 | 97 | -- `merge4 as bs cs ds` is (essentially) a manually fused version of 98 | -- `merge (merge as bs) (merge cs ds)` 99 | merge4 as@(a:as') bs@(b:bs') cs ds 100 | | a <= b = merge4X a as' bs cs ds 101 | | otherwise = merge4X b as bs' cs ds 102 | merge4 [] bs cs ds = merge3 bs cs ds 103 | merge4 as [] cs ds = merge3 as cs ds 104 | 105 | merge4X x as bs cs@(c:cs') ds@(d:ds') 106 | | c <= d = merge4XY x as bs c cs' ds 107 | | otherwise = merge4XY x as bs d cs ds' 108 | merge4X x as bs [] ds = merge3X x as bs ds 109 | merge4X x as bs cs [] = merge3X x as bs cs 110 | 111 | merge4Y as@(a:as') bs@(b:bs') y cs ds 112 | | a <= b = merge4XY a as' bs y cs ds 113 | | otherwise = merge4XY b as bs' y cs ds 114 | merge4Y as [] y cs ds = merge3Y as y cs ds 115 | merge4Y [] bs y cs ds = merge3Y bs y cs ds 116 | 117 | merge4XY x as bs y cs ds 118 | | x <= y = x : merge4Y as bs y cs ds 119 | | otherwise = y : merge4X x as bs cs ds 120 | -------------------------------------------------------------------------------- /benchmark/haskell/MergesortHaskellTRStack.hs: -------------------------------------------------------------------------------- 1 | -- Stack-based bottom-up tail-recursive mergesorts 2 | {-# LANGUAGE BangPatterns #-} 3 | module MergesortHaskellTRStack where 4 | 5 | import Data.List 6 | import Data.Bits 7 | 8 | catrev [] ys = ys 9 | catrev (x : xs) ys = catrev xs (x : ys) 10 | 11 | sort3 :: (a -> a -> Bool) -> [a] -> [a] 12 | sort3 (<=) = sortRec (0 :: Int) [] where 13 | revmerge [] ys accu = catrev ys accu 14 | revmerge xs [] accu = catrev xs accu 15 | revmerge xs@(x : xs') ys@(y : ys') accu 16 | | x <= y = revmerge xs' ys (x : accu) 17 | | otherwise = revmerge xs ys' (y : accu) 18 | 19 | revmergeRev [] ys accu = catrev ys accu 20 | revmergeRev xs [] accu = catrev xs accu 21 | revmergeRev xs@(x : xs') ys@(y : ys') accu 22 | | y <= x = revmergeRev xs' ys (x : accu) 23 | | otherwise = revmergeRev xs ys' (y : accu) 24 | 25 | push xs k stack | even k = xs : stack 26 | push xs k stack 27 | | testBit k 1 = 28 | let ys : zs : stack' = stack in 29 | let !xys = revmerge ys xs [] in 30 | let !xyzs = revmergeRev xys zs [] in 31 | let !k' = shift k (- 2) in push xyzs k' stack' 32 | | otherwise = 33 | let ys : stack' = stack in 34 | let !xys = revmerge ys xs [] in xys : stack' 35 | 36 | pop xs k [] = xs 37 | pop xs k stack | odd k = 38 | let ys : stack' = stack in 39 | let !xys = revmerge ys xs [] in 40 | let !k' = shift k (- 1) in popRev xys k' stack' 41 | pop xs k stack 42 | | testBit k 1 = 43 | let !xs' = reverse xs in 44 | let !k' = shift k (- 1) in popRev xs' k' stack 45 | | otherwise = let !k' = shift k (- 2) in pop xs k' stack 46 | popRev xs k [] = reverse xs 47 | popRev xs k stack | odd k = 48 | let ys : stack' = stack in 49 | let !xys = revmergeRev xs ys [] in 50 | let !k' = shift k (- 1) in pop xys k' stack' 51 | popRev xs k stack 52 | | testBit k 1 = 53 | let !xs' = reverse xs in 54 | let !k' = shift k (- 1) in pop xs' k' stack 55 | | otherwise = let !k' = shift k (- 2) in popRev xs k' stack 56 | 57 | sortRec k stack (x : y : z : s) = 58 | let xyz = if x <= y then 59 | if y <= z then [x, y, z] 60 | else if x <= z then [x, z, y] else [z, x, y] 61 | else 62 | if x <= z then [y, x, z] 63 | else if y <= z then [y, z, x] else [z, y, x] 64 | in 65 | let !k' = k + 1 in 66 | let !stack' = push xyz k stack in sortRec k' stack' s 67 | sortRec k stack s@[x, y] = 68 | let !xy = if x <= y then s else [y, x] in pop xy k stack 69 | sortRec k stack s = pop s k stack 70 | 71 | sortN :: (a -> a -> Bool) -> [a] -> [a] 72 | sortN (<=) = sortRec (0 :: Int) [] where 73 | revmerge [] ys accu = catrev ys accu 74 | revmerge xs [] accu = catrev xs accu 75 | revmerge xs@(x : xs') ys@(y : ys') accu 76 | | x <= y = revmerge xs' ys (x : accu) 77 | | otherwise = revmerge xs ys' (y : accu) 78 | 79 | revmergeRev [] ys accu = catrev ys accu 80 | revmergeRev xs [] accu = catrev xs accu 81 | revmergeRev xs@(x : xs') ys@(y : ys') accu 82 | | y <= x = revmergeRev xs' ys (x : accu) 83 | | otherwise = revmergeRev xs ys' (y : accu) 84 | 85 | push xs k stack | even k = xs : stack 86 | push xs k stack 87 | | testBit k 1 = 88 | let ys : zs : stack' = stack in 89 | let !xys = revmerge ys xs [] in 90 | let !xyzs = revmergeRev xys zs [] in 91 | let !k' = shift k (- 2) in push xyzs k' stack' 92 | | otherwise = 93 | let ys : stack' = stack in 94 | let !xys = revmerge ys xs [] in xys : stack' 95 | 96 | pop xs k [] = xs 97 | pop xs k stack | odd k = 98 | let ys : stack' = stack in 99 | let !xys = revmerge ys xs [] in 100 | let !k' = shift k (- 1) in popRev xys k' stack' 101 | pop xs k stack 102 | | testBit k 1 = 103 | let !xs' = reverse xs in 104 | let !k' = shift k (- 1) in popRev xs' k' stack 105 | | otherwise = let !k' = shift k (- 2) in pop xs k' stack 106 | popRev xs k [] = reverse xs 107 | popRev xs k stack | odd k = 108 | let ys : stack' = stack in 109 | let !xys = revmergeRev xs ys [] in 110 | let !k' = shift k (- 1) in pop xys k' stack' 111 | popRev xs k stack 112 | | testBit k 1 = 113 | let !xs' = reverse xs in 114 | let !k' = shift k (- 1) in pop xs' k' stack 115 | | otherwise = let !k' = shift k (- 2) in popRev xs k' stack 116 | 117 | sortRec k stack (x : y : s) = 118 | if x <= y then ascending (x :) y s else descending [x] y s 119 | where 120 | ascending accu x [] = let !xs = accu [x] in pop xs k stack 121 | ascending accu x (y : s) | x <= y = 122 | ascending (\ys -> accu (x : ys)) y s 123 | ascending accu x s = 124 | let !k' = k + 1 in 125 | let !xs = accu [x] in 126 | let !stack' = push xs k stack in sortRec k' stack' s 127 | 128 | descending accu x [] = pop (x : accu) k stack 129 | descending accu x (y : s) | not (x <= y) = descending (x : accu) y s 130 | descending accu x s = 131 | let !k' = k + 1 in 132 | let !stack' = push (x : accu) k stack in sortRec k' stack' s 133 | sortRec k stack s = pop s k stack 134 | 135 | sort3N :: (a -> a -> Bool) -> [a] -> [a] 136 | sort3N (<=) = sortRec (0 :: Int) [] where 137 | revmerge [] ys accu = catrev ys accu 138 | revmerge xs [] accu = catrev xs accu 139 | revmerge xs@(x : xs') ys@(y : ys') accu 140 | | x <= y = revmerge xs' ys (x : accu) 141 | | otherwise = revmerge xs ys' (y : accu) 142 | 143 | revmergeRev [] ys accu = catrev ys accu 144 | revmergeRev xs [] accu = catrev xs accu 145 | revmergeRev xs@(x : xs') ys@(y : ys') accu 146 | | y <= x = revmergeRev xs' ys (x : accu) 147 | | otherwise = revmergeRev xs ys' (y : accu) 148 | 149 | push xs k stack | even k = xs : stack 150 | push xs k stack 151 | | testBit k 1 = 152 | let ys : zs : stack' = stack in 153 | let !xys = revmerge ys xs [] in 154 | let !xyzs = revmergeRev xys zs [] in 155 | let !k' = shift k (- 2) in push xyzs k' stack' 156 | | otherwise = 157 | let ys : stack' = stack in 158 | let !xys = revmerge ys xs [] in xys : stack' 159 | 160 | pop xs k [] = xs 161 | pop xs k stack | odd k = 162 | let ys : stack' = stack in 163 | let !xys = revmerge ys xs [] in 164 | let !k' = shift k (- 1) in popRev xys k' stack' 165 | pop xs k stack 166 | | testBit k 1 = 167 | let !xs' = reverse xs in 168 | let !k' = shift k (- 1) in popRev xs' k' stack 169 | | otherwise = let !k' = shift k (- 2) in pop xs k' stack 170 | popRev xs k [] = reverse xs 171 | popRev xs k stack | odd k = 172 | let ys : stack' = stack in 173 | let !xys = revmergeRev xs ys [] in 174 | let !k' = shift k (- 1) in pop xys k' stack' 175 | popRev xs k stack 176 | | testBit k 1 = 177 | let !xs' = reverse xs in 178 | let !k' = shift k (- 1) in pop xs' k' stack 179 | | otherwise = let !k' = shift k (- 2) in popRev xs k' stack 180 | 181 | sortRec k stack (x : y : z : s) 182 | | x <= y, y <= z = ascending (\s -> x : y : s) z s 183 | | not (x <= y), not (y <= z) = descending [y, x] z s 184 | | x <= y , not (y <= z) = 185 | let !k' = k + 1 in 186 | let !xyz = if x <= z then [x, z, y] else [z, x, y] in 187 | let !stack' = push xyz k stack in sortRec k' stack' s 188 | | not (x <= y), y <= z = 189 | let !k' = k + 1 in 190 | let !xyz = if x <= z then [y, x, z] else [y, z, x] in 191 | let !stack' = push xyz k stack in sortRec k' stack' s 192 | where 193 | ascending accu x [] = let !xs = accu [x] in pop xs k stack 194 | ascending accu x (y : s) | x <= y = 195 | ascending (\ys -> accu (x : ys)) y s 196 | ascending accu x s = 197 | let !k' = k + 1 in 198 | let !xs = accu [x] in 199 | let !stack' = push xs k stack in sortRec k' stack' s 200 | 201 | descending accu x [] = pop (x : accu) k stack 202 | descending accu x (y : s) | not (x <= y) = descending (x : accu) y s 203 | descending accu x s = 204 | let !k' = k + 1 in 205 | let !stack' = push (x : accu) k stack in sortRec k' stack' s 206 | sortRec k stack s@[x, y] = 207 | let !xy = if x <= y then s else [y, x] in pop xy k stack 208 | sortRec k stack s = pop s k stack 209 | -------------------------------------------------------------------------------- /benchmark/haskell/MergesortHaskellTRStack_.hs: -------------------------------------------------------------------------------- 1 | -- Stack-based bottom-up tail-recursive mergesorts without the counter 2 | {-# LANGUAGE BangPatterns #-} 3 | module MergesortHaskellTRStack_ where 4 | 5 | import Data.List 6 | import Data.Bits 7 | 8 | catrev [] ys = ys 9 | catrev (x : xs) ys = catrev xs (x : ys) 10 | 11 | sort3 :: (a -> a -> Bool) -> [a] -> [a] 12 | sort3 (<=) = sortRec [] where 13 | revmerge [] ys accu = catrev ys accu 14 | revmerge xs [] accu = catrev xs accu 15 | revmerge xs@(x : xs') ys@(y : ys') accu 16 | | x <= y = revmerge xs' ys (x : accu) 17 | | otherwise = revmerge xs ys' (y : accu) 18 | 19 | revmergeRev [] ys accu = catrev ys accu 20 | revmergeRev xs [] accu = catrev xs accu 21 | revmergeRev xs@(x : xs') ys@(y : ys') accu 22 | | y <= x = revmergeRev xs' ys (x : accu) 23 | | otherwise = revmergeRev xs ys' (y : accu) 24 | 25 | push xs [] = [xs] 26 | push xs ([] : stack) = xs : stack 27 | push xs [ys] = let !xys = revmerge ys xs [] in [[], xys] 28 | push xs (ys : [] : stack) = let !xys = revmerge ys xs [] in [] : xys : stack 29 | push xs (ys : zs : stack) = 30 | let !xys = revmerge ys xs [] in 31 | let !xyzs = revmergeRev xys zs [] in [] : [] : push xyzs stack 32 | 33 | pop xs [] = xs 34 | pop xs ([] : [] : stack) = pop xs stack 35 | pop xs ([] : stack) = popRev (reverse xs) stack 36 | pop xs (ys : stack) = let !xys = revmerge ys xs [] in popRev xys stack 37 | popRev xs [] = reverse xs 38 | popRev xs ([] : [] : stack) = popRev xs stack 39 | popRev xs ([] : stack) = pop (reverse xs) stack 40 | popRev xs (ys : stack) = let !xys = revmergeRev xs ys [] in pop xys stack 41 | 42 | sortRec stack (x : y : z : s) = 43 | let xyz = if x <= y then 44 | if y <= z then [x, y, z] 45 | else if x <= z then [x, z, y] else [z, x, y] 46 | else 47 | if x <= z then [y, x, z] 48 | else if y <= z then [y, z, x] else [z, y, x] 49 | in 50 | let !stack' = push xyz stack in sortRec stack' s 51 | sortRec stack s@[x, y] = 52 | let !xy = if x <= y then s else [y, x] in pop xy stack 53 | sortRec stack s = pop s stack 54 | 55 | sortN :: (a -> a -> Bool) -> [a] -> [a] 56 | sortN (<=) = sortRec [] where 57 | revmerge [] ys accu = catrev ys accu 58 | revmerge xs [] accu = catrev xs accu 59 | revmerge xs@(x : xs') ys@(y : ys') accu 60 | | x <= y = revmerge xs' ys (x : accu) 61 | | otherwise = revmerge xs ys' (y : accu) 62 | 63 | revmergeRev [] ys accu = catrev ys accu 64 | revmergeRev xs [] accu = catrev xs accu 65 | revmergeRev xs@(x : xs') ys@(y : ys') accu 66 | | y <= x = revmergeRev xs' ys (x : accu) 67 | | otherwise = revmergeRev xs ys' (y : accu) 68 | 69 | push xs [] = [xs] 70 | push xs ([] : stack) = xs : stack 71 | push xs [ys] = let !xys = revmerge ys xs [] in [[], xys] 72 | push xs (ys : [] : stack) = let !xys = revmerge ys xs [] in [] : xys : stack 73 | push xs (ys : zs : stack) = 74 | let !xys = revmerge ys xs [] in 75 | let !xyzs = revmergeRev xys zs [] in [] : [] : push xyzs stack 76 | 77 | pop xs [] = xs 78 | pop xs ([] : [] : stack) = pop xs stack 79 | pop xs ([] : stack) = popRev (reverse xs) stack 80 | pop xs (ys : stack) = let !xys = revmerge ys xs [] in popRev xys stack 81 | popRev xs [] = reverse xs 82 | popRev xs ([] : [] : stack) = popRev xs stack 83 | popRev xs ([] : stack) = pop (reverse xs) stack 84 | popRev xs (ys : stack) = let !xys = revmergeRev xs ys [] in pop xys stack 85 | 86 | sortRec stack (x : y : s) = 87 | if x <= y then ascending (x :) y s else descending [x] y s 88 | where 89 | ascending accu x [] = let !xs = accu [x] in pop xs stack 90 | ascending accu x (y : s) | x <= y = 91 | ascending (\ys -> accu (x : ys)) y s 92 | ascending accu x s = 93 | let !xs = accu [x] in 94 | let !stack' = push xs stack in sortRec stack' s 95 | 96 | descending accu x [] = pop (x : accu) stack 97 | descending accu x (y : s) | not (x <= y) = descending (x : accu) y s 98 | descending accu x s = 99 | let !stack' = push (x : accu) stack in sortRec stack' s 100 | sortRec stack s = pop s stack 101 | 102 | sort3N :: (a -> a -> Bool) -> [a] -> [a] 103 | sort3N (<=) = sortRec [] where 104 | revmerge [] ys accu = catrev ys accu 105 | revmerge xs [] accu = catrev xs accu 106 | revmerge xs@(x : xs') ys@(y : ys') accu 107 | | x <= y = revmerge xs' ys (x : accu) 108 | | otherwise = revmerge xs ys' (y : accu) 109 | 110 | revmergeRev [] ys accu = catrev ys accu 111 | revmergeRev xs [] accu = catrev xs accu 112 | revmergeRev xs@(x : xs') ys@(y : ys') accu 113 | | y <= x = revmergeRev xs' ys (x : accu) 114 | | otherwise = revmergeRev xs ys' (y : accu) 115 | 116 | push xs [] = [xs] 117 | push xs ([] : stack) = xs : stack 118 | push xs [ys] = let !xys = revmerge ys xs [] in [[], xys] 119 | push xs (ys : [] : stack) = let !xys = revmerge ys xs [] in [] : xys : stack 120 | push xs (ys : zs : stack) = 121 | let !xys = revmerge ys xs [] in 122 | let !xyzs = revmergeRev xys zs [] in [] : [] : push xyzs stack 123 | 124 | pop xs [] = xs 125 | pop xs ([] : [] : stack) = pop xs stack 126 | pop xs ([] : stack) = popRev (reverse xs) stack 127 | pop xs (ys : stack) = let !xys = revmerge ys xs [] in popRev xys stack 128 | popRev xs [] = reverse xs 129 | popRev xs ([] : [] : stack) = popRev xs stack 130 | popRev xs ([] : stack) = pop (reverse xs) stack 131 | popRev xs (ys : stack) = let !xys = revmergeRev xs ys [] in pop xys stack 132 | 133 | sortRec stack (x : y : z : s) 134 | | x <= y, y <= z = ascending (\s -> x : y : s) z s 135 | | not (x <= y), not (y <= z) = descending [y, x] z s 136 | | x <= y, not (y <= z) = 137 | let !xyz = if x <= z then [x, z, y] else [z, x, y] in 138 | let !stack' = push xyz stack in sortRec stack' s 139 | | not (x <= y), y <= z = 140 | let !xyz = if x <= z then [y, x, z] else [y, z, x] in 141 | let !stack' = push xyz stack in sortRec stack' s 142 | where 143 | ascending accu x [] = let !xs = accu [x] in pop xs stack 144 | ascending accu x (y : s) | x <= y = 145 | ascending (\ys -> accu (x : ys)) y s 146 | ascending accu x s = 147 | let !xs = accu [x] in 148 | let !stack' = push xs stack in sortRec stack' s 149 | 150 | descending accu x [] = pop (x : accu) stack 151 | descending accu x (y : s) | not (x <= y) = descending (x : accu) y s 152 | descending accu x s = 153 | let !stack' = push (x : accu) stack in sortRec stack' s 154 | sortRec stack s@[x, y] = 155 | let !xy = if x <= y then s else [y, x] in pop xy stack 156 | sortRec stack s = pop s stack 157 | -------------------------------------------------------------------------------- /benchmark/haskell/TestStability.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Function 4 | import Test.QuickCheck 5 | import qualified Data.List 6 | import qualified MergesortHaskellNTRStack 7 | import qualified MergesortHaskellNTRStack_ 8 | import qualified MergesortHaskellTRStack 9 | import qualified MergesortHaskellTRStack_ 10 | import qualified MergesortHaskellStdlib 11 | 12 | spec_ntrcount_sort3 :: [(Int, Int)] -> Bool 13 | spec_ntrcount_sort3 xs = 14 | Data.List.sortBy (compare `on` fst) xs == 15 | MergesortHaskellNTRStack.sort3 ((<=) `on` fst) xs 16 | 17 | spec_ntrcount_sortN :: [(Int, Int)] -> Bool 18 | spec_ntrcount_sortN xs = 19 | Data.List.sortBy (compare `on` fst) xs == 20 | MergesortHaskellNTRStack.sortN ((<=) `on` fst) xs 21 | 22 | spec_ntrcount_sort3N :: [(Int, Int)] -> Bool 23 | spec_ntrcount_sort3N xs = 24 | Data.List.sortBy (compare `on` fst) xs == 25 | MergesortHaskellNTRStack.sort3N ((<=) `on` fst) xs 26 | 27 | spec_ntrstack_sort3 :: [(Int, Int)] -> Bool 28 | spec_ntrstack_sort3 xs = 29 | Data.List.sortBy (compare `on` fst) xs == 30 | MergesortHaskellNTRStack_.sort3 ((<=) `on` fst) xs 31 | 32 | spec_ntrstack_sortN :: [(Int, Int)] -> Bool 33 | spec_ntrstack_sortN xs = 34 | Data.List.sortBy (compare `on` fst) xs == 35 | MergesortHaskellNTRStack_.sortN ((<=) `on` fst) xs 36 | 37 | spec_ntrstack_sort3N :: [(Int, Int)] -> Bool 38 | spec_ntrstack_sort3N xs = 39 | Data.List.sortBy (compare `on` fst) xs == 40 | MergesortHaskellNTRStack_.sort3N ((<=) `on` fst) xs 41 | 42 | spec_trcount_sort3 :: [(Int, Int)] -> Bool 43 | spec_trcount_sort3 xs = 44 | Data.List.sortBy (compare `on` fst) xs == 45 | MergesortHaskellTRStack.sort3 ((<=) `on` fst) xs 46 | 47 | spec_trcount_sortN :: [(Int, Int)] -> Bool 48 | spec_trcount_sortN xs = 49 | Data.List.sortBy (compare `on` fst) xs == 50 | MergesortHaskellTRStack.sortN ((<=) `on` fst) xs 51 | 52 | spec_trcount_sort3N :: [(Int, Int)] -> Bool 53 | spec_trcount_sort3N xs = 54 | Data.List.sortBy (compare `on` fst) xs == 55 | MergesortHaskellTRStack.sort3N ((<=) `on` fst) xs 56 | 57 | spec_trstack_sort3 :: [(Int, Int)] -> Bool 58 | spec_trstack_sort3 xs = 59 | Data.List.sortBy (compare `on` fst) xs == 60 | MergesortHaskellTRStack_.sort3 ((<=) `on` fst) xs 61 | 62 | spec_trstack_sortN :: [(Int, Int)] -> Bool 63 | spec_trstack_sortN xs = 64 | Data.List.sortBy (compare `on` fst) xs == 65 | MergesortHaskellTRStack_.sortN ((<=) `on` fst) xs 66 | 67 | spec_trstack_sort3N :: [(Int, Int)] -> Bool 68 | spec_trstack_sort3N xs = 69 | Data.List.sortBy (compare `on` fst) xs == 70 | MergesortHaskellTRStack_.sort3N ((<=) `on` fst) xs 71 | 72 | spec_stdlib_oldSort :: [(Int, Int)] -> Bool 73 | spec_stdlib_oldSort xs = 74 | Data.List.sortBy (compare `on` fst) xs == 75 | MergesortHaskellStdlib.oldSort ((<=) `on` fst) xs 76 | 77 | spec_stdlib_newSort :: [(Int, Int)] -> Bool 78 | spec_stdlib_newSort xs = 79 | Data.List.sortBy (compare `on` fst) xs == 80 | MergesortHaskellStdlib.newSort ((<=) `on` fst) xs 81 | 82 | main = do 83 | quickCheck spec_ntrcount_sort3 84 | quickCheck spec_ntrcount_sortN 85 | quickCheck spec_ntrcount_sort3N 86 | quickCheck spec_ntrstack_sort3 87 | quickCheck spec_ntrstack_sortN 88 | quickCheck spec_ntrstack_sort3N 89 | quickCheck spec_trcount_sort3 90 | quickCheck spec_trcount_sortN 91 | quickCheck spec_trcount_sort3N 92 | quickCheck spec_trstack_sort3 93 | quickCheck spec_trstack_sortN 94 | quickCheck spec_trstack_sort3N 95 | quickCheck spec_stdlib_oldSort 96 | quickCheck spec_stdlib_newSort 97 | -------------------------------------------------------------------------------- /benchmark/ocaml/benchlib.ml: -------------------------------------------------------------------------------- 1 | let with_timer f = 2 | Gc.compact (); 3 | Gc.set { (Gc.get()) with Gc.verbose = 0x01f }; 4 | let s1 = Gc.quick_stat () in 5 | let t1 = Unix.gettimeofday () in 6 | let v = f () in 7 | let t2 = Unix.gettimeofday () in 8 | let s2 = Gc.quick_stat () in 9 | Gc.set { (Gc.get()) with Gc.verbose = 0x000 }; 10 | let mem_words = 11 | (s2.Gc.minor_words +. s2.Gc.major_words -. s2.Gc.promoted_words) -. 12 | (s1.Gc.minor_words +. s1.Gc.major_words -. s1.Gc.promoted_words) 13 | in 14 | (t2 -. t1, mem_words /. (128.0 *. 1024.0), v) 15 | ;; 16 | 17 | let median (xs : float list) : float = 18 | let sorted = List.sort compare xs in 19 | if List.length sorted mod 2 = 1 20 | then List.nth sorted (List.length sorted / 2) 21 | else (List.nth sorted (List.length sorted / 2 - 1) +. 22 | List.nth sorted (List.length sorted / 2)) /. 2. 23 | ;; 24 | 25 | let with_timer_median n f = 26 | let time_list = ref [] in 27 | let mem_list = ref [] in 28 | for i = 1 to n do 29 | let (time, mem, _) = with_timer f in 30 | time_list := time :: !time_list; 31 | mem_list := mem :: !mem_list 32 | done; 33 | (median !time_list, median !mem_list) 34 | ;; 35 | 36 | let gen_list seed elems = 37 | Random.init seed; List.init elems (fun _ -> Random.int elems) 38 | ;; 39 | 40 | let benchmark 41 | (filename : string) (size : int list) (preproc : int list -> int list) 42 | (config : (string * (int list -> int list)) list) = 43 | let result = List.map (fun (seed, size) -> 44 | let input = preproc (gen_list seed size) in 45 | let r = 46 | List.map (fun (name, sort) -> 47 | let (time, mem) = with_timer_median 5 (fun _ -> sort input) in 48 | (name, time, mem)) config 49 | in 50 | Printf.printf "size: %7d" size; 51 | List.iter (fun (name, time, mem) -> 52 | Printf.printf "; %s: %8.6fs, %10.6fMB" name time mem 53 | ) r; 54 | Printf.printf "\n%!"; 55 | (size, List.map (fun (_, t, _) -> t) r, List.map (fun (_, _, m) -> m) r) 56 | ) (List.map (fun s -> (Random.bits (), s)) size) 57 | in 58 | let outc = open_out (filename ^ ".time.csv") in 59 | Printf.fprintf outc "Size"; 60 | List.iter (fun (name, _) -> Printf.fprintf outc ", %s" name) config; 61 | Printf.fprintf outc "\n"; 62 | List.iter (fun (size, times, _) -> 63 | Printf.fprintf outc "%d" size; 64 | List.iter (Printf.fprintf outc ", %f") times; 65 | Printf.fprintf outc "\n") result; 66 | close_out outc; 67 | let outc = open_out (filename ^ ".mem.csv") in 68 | Printf.fprintf outc "Size"; 69 | List.iter (fun (name, _) -> Printf.fprintf outc ", %s" name) config; 70 | Printf.fprintf outc "\n"; 71 | List.iter (fun (size, _, mems) -> 72 | Printf.fprintf outc "%d" size; 73 | List.iter (Printf.fprintf outc ", %f") mems; 74 | Printf.fprintf outc "\n") result; 75 | close_out outc 76 | ;; 77 | 78 | let split_n n xs = 79 | let rec aux i xs acc = 80 | match i, xs with 81 | | 0, _ | _, [] -> (List.rev acc, xs) 82 | | i, x :: xs -> aux (i - 1) xs (x :: acc) 83 | in aux n xs [] 84 | ;; 85 | 86 | let rec sort_blocks (n : int) = function 87 | | [] -> [] 88 | | xs -> 89 | let (xs1, xs2) = split_n n xs in 90 | List.append (List.sort compare xs1) (sort_blocks n xs2) 91 | ;; 92 | -------------------------------------------------------------------------------- /benchmark/ocaml/benchmark.ml: -------------------------------------------------------------------------------- 1 | Random.self_init ();; 2 | Gc.set { (Gc.get()) with Gc.minor_heap_size = 2 * 1024 * 1024 * 1024 };; 3 | 4 | Benchlib.benchmark "ocaml1" (List.init 40 (fun i -> 25000 * (i + 1))) (fun xs -> xs) 5 | [("List.stable_sort", List.stable_sort (compare : int -> int -> int)); 6 | ("CBN.sort1", Mergesort_coq_cbn.sort1 ((<=) : int -> int -> bool)); 7 | ("CBN.sort2", Mergesort_coq_cbn.sort2 ((<=) : int -> int -> bool)); 8 | ("CBN.sort3", Mergesort_coq_cbn.sort3 ((<=) : int -> int -> bool)); 9 | ("CBN.sortN", Mergesort_coq_cbn.sortN ((<=) : int -> int -> bool)); 10 | ("CBNAcc.sort1", Mergesort_coq_cbnacc.sort1 ((<=) : int -> int -> bool)); 11 | ("CBNAcc.sort2", Mergesort_coq_cbnacc.sort2 ((<=) : int -> int -> bool)); 12 | ("CBNAcc.sort3", Mergesort_coq_cbnacc.sort3 ((<=) : int -> int -> bool)); 13 | ("CBNAcc.sortN", Mergesort_coq_cbnacc.sortN ((<=) : int -> int -> bool)); 14 | ("CBN.sort1 (TMC)", Mergesort_coq_cbn_tmc.sort1 ((<=) : int -> int -> bool)); 15 | ("CBN.sort2 (TMC)", Mergesort_coq_cbn_tmc.sort2 ((<=) : int -> int -> bool)); 16 | ("CBN.sort3 (TMC)", Mergesort_coq_cbn_tmc.sort3 ((<=) : int -> int -> bool)); 17 | ("CBN.sortN (TMC)", Mergesort_coq_cbn_tmc.sortN ((<=) : int -> int -> bool)); 18 | ("CBNAcc.sort1 (TMC)", Mergesort_coq_cbnacc_tmc.sort1 ((<=) : int -> int -> bool)); 19 | ("CBNAcc.sort2 (TMC)", Mergesort_coq_cbnacc_tmc.sort2 ((<=) : int -> int -> bool)); 20 | ("CBNAcc.sort3 (TMC)", Mergesort_coq_cbnacc_tmc.sort3 ((<=) : int -> int -> bool)); 21 | ("CBNAcc.sortN (TMC)", Mergesort_coq_cbnacc_tmc.sortN ((<=) : int -> int -> bool)); 22 | ("CBV.sort1", Mergesort_coq_cbv.sort1 ((<=) : int -> int -> bool)); 23 | ("CBV.sort2", Mergesort_coq_cbv.sort2 ((<=) : int -> int -> bool)); 24 | ("CBV.sort3", Mergesort_coq_cbv.sort3 ((<=) : int -> int -> bool)); 25 | ("CBV.sortN", Mergesort_coq_cbv.sortN ((<=) : int -> int -> bool)); 26 | ("CBVAcc.sort1", Mergesort_coq_cbvacc.sort1 ((<=) : int -> int -> bool)); 27 | ("CBVAcc.sort2", Mergesort_coq_cbvacc.sort2 ((<=) : int -> int -> bool)); 28 | ("CBVAcc.sort3", Mergesort_coq_cbvacc.sort3 ((<=) : int -> int -> bool)); 29 | ("CBVAcc.sortN", Mergesort_coq_cbvacc.sortN ((<=) : int -> int -> bool))] 30 | ;; 31 | 32 | Benchlib.benchmark "ocaml2" (List.init 40 (fun i -> 25000 * (i + 1))) (Benchlib.sort_blocks 50) 33 | [("List.stable_sort", List.stable_sort (compare : int -> int -> int)); 34 | ("CBN.sort1", Mergesort_coq_cbn.sort1 ((<=) : int -> int -> bool)); 35 | ("CBN.sort2", Mergesort_coq_cbn.sort2 ((<=) : int -> int -> bool)); 36 | ("CBN.sort3", Mergesort_coq_cbn.sort3 ((<=) : int -> int -> bool)); 37 | ("CBN.sortN", Mergesort_coq_cbn.sortN ((<=) : int -> int -> bool)); 38 | ("CBNAcc.sort1", Mergesort_coq_cbnacc.sort1 ((<=) : int -> int -> bool)); 39 | ("CBNAcc.sort2", Mergesort_coq_cbnacc.sort2 ((<=) : int -> int -> bool)); 40 | ("CBNAcc.sort3", Mergesort_coq_cbnacc.sort3 ((<=) : int -> int -> bool)); 41 | ("CBNAcc.sortN", Mergesort_coq_cbnacc.sortN ((<=) : int -> int -> bool)); 42 | ("CBN.sort1 (TMC)", Mergesort_coq_cbn_tmc.sort1 ((<=) : int -> int -> bool)); 43 | ("CBN.sort2 (TMC)", Mergesort_coq_cbn_tmc.sort2 ((<=) : int -> int -> bool)); 44 | ("CBN.sort3 (TMC)", Mergesort_coq_cbn_tmc.sort3 ((<=) : int -> int -> bool)); 45 | ("CBN.sortN (TMC)", Mergesort_coq_cbn_tmc.sortN ((<=) : int -> int -> bool)); 46 | ("CBNAcc.sort1 (TMC)", Mergesort_coq_cbnacc_tmc.sort1 ((<=) : int -> int -> bool)); 47 | ("CBNAcc.sort2 (TMC)", Mergesort_coq_cbnacc_tmc.sort2 ((<=) : int -> int -> bool)); 48 | ("CBNAcc.sort3 (TMC)", Mergesort_coq_cbnacc_tmc.sort3 ((<=) : int -> int -> bool)); 49 | ("CBNAcc.sortN (TMC)", Mergesort_coq_cbnacc_tmc.sortN ((<=) : int -> int -> bool)); 50 | ("CBV.sort1", Mergesort_coq_cbv.sort1 ((<=) : int -> int -> bool)); 51 | ("CBV.sort2", Mergesort_coq_cbv.sort2 ((<=) : int -> int -> bool)); 52 | ("CBV.sort3", Mergesort_coq_cbv.sort3 ((<=) : int -> int -> bool)); 53 | ("CBV.sortN", Mergesort_coq_cbv.sortN ((<=) : int -> int -> bool)); 54 | ("CBVAcc.sort1", Mergesort_coq_cbvacc.sort1 ((<=) : int -> int -> bool)); 55 | ("CBVAcc.sort2", Mergesort_coq_cbvacc.sort2 ((<=) : int -> int -> bool)); 56 | ("CBVAcc.sort3", Mergesort_coq_cbvacc.sort3 ((<=) : int -> int -> bool)); 57 | ("CBVAcc.sortN", Mergesort_coq_cbvacc.sortN ((<=) : int -> int -> bool))] 58 | ;; 59 | -------------------------------------------------------------------------------- /benchmark/ocaml/benchmark_exp.ml: -------------------------------------------------------------------------------- 1 | open Mergesort_ocaml;; 2 | 3 | Random.self_init ();; 4 | Gc.set { (Gc.get()) with Gc.minor_heap_size = 2 * 1024 * 1024 * 1024 };; 5 | 6 | Benchlib.benchmark "ocaml-random" (List.init 15 (fun i -> Int.shift_left 128 i)) (fun xs -> xs) 7 | [("List.stable_sort", StdlibSort.sort ((<=) : int -> int -> bool)); 8 | ("NTRStack.sort3", NTRStack.sort3 ((<=) : int -> int -> bool)); 9 | ("NTRStack.sortN", NTRStack.sortN ((<=) : int -> int -> bool)); 10 | ("NTRStack.sort3N", NTRStack.sort3N ((<=) : int -> int -> bool)); 11 | ("NTRStack_.sort3", NTRStack_.sort3 ((<=) : int -> int -> bool)); 12 | ("NTRStack_.sortN", NTRStack_.sortN ((<=) : int -> int -> bool)); 13 | ("NTRStack_.sort3N", NTRStack_.sort3N ((<=) : int -> int -> bool)); 14 | ("TRMCStack.sort3", TRMCStack.sort3 ((<=) : int -> int -> bool)); 15 | ("TRMCStack.sortN", TRMCStack.sortN ((<=) : int -> int -> bool)); 16 | ("TRMCStack.sort3N", TRMCStack.sort3N ((<=) : int -> int -> bool)); 17 | ("TRMCStack_.sort3", TRMCStack_.sort3 ((<=) : int -> int -> bool)); 18 | ("TRMCStack_.sortN", TRMCStack_.sortN ((<=) : int -> int -> bool)); 19 | ("TRMCStack_.sort3N", TRMCStack_.sort3N ((<=) : int -> int -> bool)); 20 | ("TRStack.sort3", TRStack.sort3 ((<=) : int -> int -> bool)); 21 | ("TRStack.sortN", TRStack.sortN ((<=) : int -> int -> bool)); 22 | ("TRStack.sort3N", TRStack.sort3N ((<=) : int -> int -> bool)); 23 | ("TRStack_.sort3", TRStack_.sort3 ((<=) : int -> int -> bool)); 24 | ("TRStack_.sortN", TRStack_.sortN ((<=) : int -> int -> bool)); 25 | ("TRStack_.sort3N", TRStack_.sort3N ((<=) : int -> int -> bool)); 26 | ("CBNAcc.sort2", Mergesort_coq_cbnacc.sort2 ((<=) : int -> int -> bool)); 27 | ("CBNAcc.sort3", Mergesort_coq_cbnacc.sort3 ((<=) : int -> int -> bool)); 28 | ("CBNAcc.sortN", Mergesort_coq_cbnacc.sortN ((<=) : int -> int -> bool)); 29 | ("CBNAcc.sort2 (TMC)", Mergesort_coq_cbnacc_tmc.sort2 ((<=) : int -> int -> bool)); 30 | ("CBNAcc.sort3 (TMC)", Mergesort_coq_cbnacc_tmc.sort3 ((<=) : int -> int -> bool)); 31 | ("CBNAcc.sortN (TMC)", Mergesort_coq_cbnacc_tmc.sortN ((<=) : int -> int -> bool)); 32 | ("CBVAcc.sort2", Mergesort_coq_cbvacc.sort2 ((<=) : int -> int -> bool)); 33 | ("CBVAcc.sort3", Mergesort_coq_cbvacc.sort3 ((<=) : int -> int -> bool)); 34 | ("CBVAcc.sortN", Mergesort_coq_cbvacc.sortN ((<=) : int -> int -> bool))] 35 | ;; 36 | 37 | Benchlib.benchmark "ocaml-smooth" (List.init 15 (fun i -> Int.shift_left 128 i)) (Benchlib.sort_blocks 50) 38 | [("List.stable_sort", StdlibSort.sort ((<=) : int -> int -> bool)); 39 | ("NTRStack.sort3", NTRStack.sort3 ((<=) : int -> int -> bool)); 40 | ("NTRStack.sortN", NTRStack.sortN ((<=) : int -> int -> bool)); 41 | ("NTRStack.sort3N", NTRStack.sort3N ((<=) : int -> int -> bool)); 42 | ("NTRStack_.sort3", NTRStack_.sort3 ((<=) : int -> int -> bool)); 43 | ("NTRStack_.sortN", NTRStack_.sortN ((<=) : int -> int -> bool)); 44 | ("NTRStack_.sort3N", NTRStack_.sort3N ((<=) : int -> int -> bool)); 45 | ("TRMCStack.sort3", TRMCStack.sort3 ((<=) : int -> int -> bool)); 46 | ("TRMCStack.sortN", TRMCStack.sortN ((<=) : int -> int -> bool)); 47 | ("TRMCStack.sort3N", TRMCStack.sort3N ((<=) : int -> int -> bool)); 48 | ("TRMCStack_.sort3", TRMCStack_.sort3 ((<=) : int -> int -> bool)); 49 | ("TRMCStack_.sortN", TRMCStack_.sortN ((<=) : int -> int -> bool)); 50 | ("TRMCStack_.sort3N", TRMCStack_.sort3N ((<=) : int -> int -> bool)); 51 | ("TRStack.sort3", TRStack.sort3 ((<=) : int -> int -> bool)); 52 | ("TRStack.sortN", TRStack.sortN ((<=) : int -> int -> bool)); 53 | ("TRStack.sort3N", TRStack.sort3N ((<=) : int -> int -> bool)); 54 | ("TRStack_.sort3", TRStack_.sort3 ((<=) : int -> int -> bool)); 55 | ("TRStack_.sortN", TRStack_.sortN ((<=) : int -> int -> bool)); 56 | ("TRStack_.sort3N", TRStack_.sort3N ((<=) : int -> int -> bool)); 57 | ("CBNAcc.sort2", Mergesort_coq_cbnacc.sort2 ((<=) : int -> int -> bool)); 58 | ("CBNAcc.sort3", Mergesort_coq_cbnacc.sort3 ((<=) : int -> int -> bool)); 59 | ("CBNAcc.sortN", Mergesort_coq_cbnacc.sortN ((<=) : int -> int -> bool)); 60 | ("CBNAcc.sort2 (TMC)", Mergesort_coq_cbnacc_tmc.sort2 ((<=) : int -> int -> bool)); 61 | ("CBNAcc.sort3 (TMC)", Mergesort_coq_cbnacc_tmc.sort3 ((<=) : int -> int -> bool)); 62 | ("CBNAcc.sortN (TMC)", Mergesort_coq_cbnacc_tmc.sortN ((<=) : int -> int -> bool)); 63 | ("CBVAcc.sort2", Mergesort_coq_cbvacc.sort2 ((<=) : int -> int -> bool)); 64 | ("CBVAcc.sort3", Mergesort_coq_cbvacc.sort3 ((<=) : int -> int -> bool)); 65 | ("CBVAcc.sortN", Mergesort_coq_cbvacc.sortN ((<=) : int -> int -> bool))] 66 | ;; 67 | -------------------------------------------------------------------------------- /benchmark/ocaml/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names benchmark benchmark_exp test_stability) 3 | (libraries unix qcheck) 4 | (flags (:standard -w a)) 5 | (ocamlopt_flags (:standard -O3))) 6 | -------------------------------------------------------------------------------- /benchmark/ocaml/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) 2 | (name stablesort_benchmarks) 3 | -------------------------------------------------------------------------------- /benchmark/ocaml/mergesort_coq_cbn_tmc.patch: -------------------------------------------------------------------------------- 1 | --- benchmark/ocaml/mergesort_coq_cbn.ml 2 | +++ benchmark/ocaml/mergesort_coq_cbn_tmc.ml 3 | @@ -7,13 +7,13 @@ module Merge = 4 | struct 5 | (** val merge : 'a1 rel -> 'a1 list -> 'a1 list -> 'a1 list **) 6 | 7 | - let rec merge leT xs ys = 8 | + let[@tail_mod_cons] rec merge leT xs ys = 9 | match xs with 10 | | [] -> ys 11 | | x::xs' -> 12 | - let rec merge' ys0 = match ys0 with 13 | + let[@tail_mod_cons] rec merge' ys0 = match ys0 with 14 | | [] -> xs 15 | - | y::ys' -> if leT x y then x::(merge leT xs' ys0) else y::(merge' ys') 16 | + | y::ys' -> if leT x y then x::((merge[@tailcall]) leT xs' ys0) else y::((merge'[@tailcall]) ys') 17 | in merge' ys 18 | end 19 | 20 | -------------------------------------------------------------------------------- /benchmark/ocaml/mergesort_coq_cbnacc_tmc.patch: -------------------------------------------------------------------------------- 1 | --- benchmark/ocaml/mergesort_coq_cbnacc.ml 2 | +++ benchmark/ocaml/mergesort_coq_cbnacc_tmc.ml 3 | @@ -7,7 +7,7 @@ module MergeAcc = 4 | struct 5 | (** val merge_rec : 'a1 rel -> 'a1 list -> 'a1 list -> 'a1 list **) 6 | 7 | - let rec merge_rec leT xs ys = 8 | + let[@tail_mod_cons] rec merge_rec leT xs ys = 9 | match xs with 10 | | [] -> ys 11 | | x::xs' -> 12 | @@ -15,8 +15,8 @@ module MergeAcc = 13 | | [] -> xs 14 | | y::ys' -> 15 | if leT x y 16 | - then x::(merge_rec leT xs' ys) 17 | - else y::(merge_rec leT xs ys')) 18 | + then x::((merge_rec[@tailcall]) leT xs' ys) 19 | + else y::((merge_rec[@tailcall]) leT xs ys')) 20 | 21 | (** val merge : 'a1 rel -> 'a1 list -> 'a1 list -> 'a1 list **) 22 | 23 | -------------------------------------------------------------------------------- /benchmark/ocaml/mergesort_ocaml.ml: -------------------------------------------------------------------------------- 1 | open List 2 | 3 | let rec split_n s n = 4 | match s with 5 | | x :: s when 0 < n -> 6 | let (s1, s2) = split_n s (n - 1) in (x :: s1, s2) 7 | | _ -> ([], s) 8 | 9 | (* Non-tail-recursive merge *) 10 | module NTRMerge = struct 11 | 12 | let rec merge (<=) xs ys = 13 | match xs, ys with 14 | | [], ys -> ys 15 | | xs, [] -> xs 16 | | x :: xs', y :: ys' -> 17 | if x <= y then 18 | x :: merge (<=) xs' ys 19 | else 20 | y :: merge (<=) xs ys' 21 | 22 | end;; 23 | 24 | (* Tail-recursive-modulo-cons merge *) 25 | module TRMCMerge = struct 26 | 27 | let[@tail_mod_cons] rec merge (<=) xs ys = 28 | match xs, ys with 29 | | [], _ -> ys 30 | | _, [] -> xs 31 | | x :: xs', y :: ys' -> 32 | if x <= y 33 | then x :: merge (<=) xs' ys 34 | else y :: merge (<=) xs ys' 35 | 36 | end;; 37 | 38 | (* Tail-recursive merge *) 39 | module TRMerge = struct 40 | 41 | let rec rev_merge (<=) xs ys accu = 42 | match xs, ys with 43 | | [], _ -> rev_append ys accu 44 | | _, [] -> rev_append xs accu 45 | | x :: xs', y :: ys' -> 46 | if x <= y 47 | then rev_merge (<=) xs' ys (x :: accu) 48 | else rev_merge (<=) xs ys' (y :: accu) 49 | 50 | let rec rev_merge_rev (<=) xs ys accu = 51 | match xs, ys with 52 | | [], _ -> rev_append ys accu 53 | | _, [] -> rev_append xs accu 54 | | x :: xs', y :: ys' -> 55 | if y <= x 56 | then rev_merge_rev (<=) xs' ys (x :: accu) 57 | else rev_merge_rev (<=) xs ys' (y :: accu) 58 | 59 | end;; 60 | 61 | module NaiveTopDown = struct 62 | 63 | open NTRMerge 64 | 65 | let rec sort (<=) = function 66 | | [] -> [] 67 | | [x] -> [x] 68 | | xs -> 69 | let k = length xs / 2 in 70 | let (xs1, xs2) = split_n xs k in 71 | merge (<=) (sort (<=) xs1) (sort (<=) xs2) 72 | 73 | end;; 74 | 75 | module NaiveBottomUp = struct 76 | 77 | open NTRMerge 78 | 79 | let sort (<=) xs = 80 | let rec merge_pairs = function 81 | | a :: b :: xs -> 82 | merge (<=) a b :: merge_pairs xs 83 | | xs -> xs in 84 | let rec merge_all = function 85 | | [] -> [] 86 | | [x] -> x 87 | | xs -> merge_all (merge_pairs xs) 88 | in 89 | merge_all (map (fun x -> [x]) xs) 90 | 91 | end;; 92 | 93 | module TopDown = struct 94 | 95 | open NTRMerge 96 | 97 | let rec sort_rec (<=) n xs = 98 | match n, xs with 99 | | 1, x :: xs -> ([x], xs) 100 | | _, _ -> 101 | let n1 = n / 2 in 102 | let n2 = n - n1 in 103 | let s1, xs1 = sort_rec (<=) n1 xs in 104 | let s2, xs2 = sort_rec (<=) n2 xs1 in 105 | (merge (<=) s1 s2, xs2) 106 | 107 | let sort (<=) xs = 108 | if xs = [] then [] else fst (sort_rec (<=) (length xs) xs) 109 | 110 | end;; 111 | 112 | module BottomUp = struct 113 | 114 | open NTRMerge 115 | 116 | let rec push (<=) xs k stack = 117 | match k mod 2, stack with 118 | | 0, _ -> xs :: stack 119 | | 1, ys :: stack -> push (<=) (merge (<=) ys xs) (k / 2) stack 120 | 121 | let rec pop (<=) xs = function 122 | | [] -> xs 123 | | ys :: stack -> pop (<=) (merge (<=) ys xs) stack 124 | 125 | let rec sort_rec (<=) k stack = function 126 | | x :: s -> sort_rec (<=) (k + 1) (push (<=) [x] k stack) s 127 | | [] -> pop (<=) [] stack 128 | 129 | let sort (<=) s = sort_rec (<=) 0 [] s 130 | 131 | end;; 132 | 133 | module Smooth = struct 134 | 135 | open NTRMerge 136 | 137 | let rec push (<=) xs k stack = 138 | match k mod 2, stack with 139 | | 0, _ -> xs :: stack 140 | | 1, ys :: stack -> push (<=) (merge (<=) ys xs) (k / 2) stack 141 | 142 | let rec pop (<=) xs = function 143 | | [] -> xs 144 | | ys :: stack -> pop (<=) (merge (<=) ys xs) stack 145 | 146 | let rec sort_rec (<=) k stack s = 147 | let rec sort_rec' mode accu x s = 148 | let accu = x :: accu in 149 | match s with 150 | | y :: s when (x <= y) = mode -> sort_rec' mode accu y s 151 | | _ -> sort_rec (<=) (k + 1) 152 | (push (<=) (if mode then rev accu else accu) k stack) s 153 | in 154 | match s with 155 | | x :: y :: s -> sort_rec' (x <= y) [x] y s 156 | | _ -> pop (<=) s stack 157 | 158 | let sort (<=) s = sort_rec (<=) 0 [] s 159 | 160 | end;; 161 | 162 | module TailRec = struct 163 | 164 | open TRMerge 165 | 166 | let rec push (<=) mode xs k stack = 167 | let (>=) x y = (<=) y x in 168 | match k mod 2, stack with 169 | | 0, _ -> xs :: stack 170 | | 1, ys :: stack -> 171 | push (<=) (not mode) 172 | (if mode then rev_merge (>=) xs ys [] else rev_merge (<=) ys xs []) 173 | (k / 2) stack 174 | 175 | let rec pop (<=) mode xs k stack = 176 | match k mod 2, stack with 177 | | _, [] -> if mode then rev xs else xs 178 | | 0, _ -> pop (<=) (not mode) (rev xs) (k / 2) stack 179 | | 1, ys :: stack -> 180 | pop (<=) (not mode) 181 | (if mode then rev_merge (>=) xs ys [] else rev_merge (<=) ys xs []) 182 | (k / 2) stack 183 | 184 | let rec sort_rec (<=) k stack = 185 | function 186 | | x :: s -> sort_rec (<=) (k + 1) (push (<=) false [x] k stack) s 187 | | [] -> pop (<=) false [] k stack 188 | 189 | let sort (<=) s = sort_rec (<=) 0 [] s 190 | 191 | end;; 192 | 193 | (* Stack-based bottom-up non-tail-recursive mergesorts *) 194 | module NTRStack = struct 195 | 196 | open NTRMerge 197 | 198 | let rec push (<=) xs k stack = 199 | match k land 1, stack with 200 | | 0, _ -> xs :: stack 201 | | 1, ys :: stack -> push (<=) (merge (<=) ys xs) (k lsr 1) stack 202 | 203 | let rec pop (<=) xs = function 204 | | [] -> xs 205 | | ys :: stack -> pop (<=) (merge (<=) ys xs) stack 206 | 207 | let rec sort3rec (<=) k stack = function 208 | | x :: y :: z :: s -> 209 | let xyz = 210 | if x <= y then 211 | if y <= z then [x; y; z] else if x <= z then [x; z; y] else [z; x; y] 212 | else 213 | if x <= z then [y; x; z] else if y <= z then [y; z; x] else [z; y; x] 214 | in 215 | sort3rec (<=) (k + 1) (push (<=) xyz k stack) s 216 | | [x; y] as s -> pop (<=) (if x <= y then s else [y; x]) stack 217 | | s -> pop (<=) s stack 218 | 219 | let sort3 (<=) s = sort3rec (<=) 0 [] s 220 | 221 | let rec sortNrec (<=) k stack s = 222 | let rec ascending accu x s = 223 | let accu = x :: accu in 224 | match s with 225 | | [] -> pop (<=) (rev accu) stack 226 | | y :: s when x <= y -> ascending accu y s 227 | | _ -> sortNrec (<=) (k + 1) (push (<=) (rev accu) k stack) s 228 | in 229 | let rec descending accu x s = 230 | let accu = x :: accu in 231 | match s with 232 | | [] -> pop (<=) accu stack 233 | | y :: s when not (x <= y) -> descending accu y s 234 | | _ -> sortNrec (<=) (k + 1) (push (<=) accu k stack) s 235 | in 236 | match s with 237 | | x :: y :: s -> 238 | if x <= y then ascending [x] y s else descending [x] y s 239 | | _ -> pop (<=) s stack 240 | 241 | let sortN (<=) s = sortNrec (<=) 0 [] s 242 | 243 | let rec sort3Nrec (<=) k stack s = 244 | let rec ascending accu x s = 245 | let accu = x :: accu in 246 | match s with 247 | | [] -> pop (<=) (rev accu) stack 248 | | y :: s when x <= y -> ascending accu y s 249 | | _ -> sort3Nrec (<=) (k + 1) (push (<=) (rev accu) k stack) s 250 | in 251 | let rec descending accu x s = 252 | let accu = x :: accu in 253 | match s with 254 | | [] -> pop (<=) accu stack 255 | | y :: s when not (x <= y) -> descending accu y s 256 | | _ -> sort3Nrec (<=) (k + 1) (push (<=) accu k stack) s 257 | in 258 | match s with 259 | | x :: y :: z :: s -> 260 | begin match x <= y, y <= z with 261 | | true, true -> ascending [y; x] z s 262 | | false, false -> descending [y; x] z s 263 | | true, false -> 264 | let xyz = if x <= z then [x; z; y] else [z; x; y] in 265 | sort3Nrec (<=) (k + 1) (push (<=) xyz k stack) s 266 | | false, true -> 267 | let xyz = if x <= z then [y; x; z] else [y; z; x] in 268 | sort3Nrec (<=) (k + 1) (push (<=) xyz k stack) s 269 | end 270 | | [x; y] -> pop (<=) (if x <= y then [x; y] else [y; x]) stack 271 | | _ -> pop (<=) s stack 272 | 273 | let sort3N (<=) s = sort3Nrec (<=) 0 [] s 274 | 275 | end;; 276 | 277 | (* Stack-based bottom-up non-tail-recursive mergesorts without the counter *) 278 | module NTRStack_ = struct 279 | 280 | open NTRMerge 281 | 282 | let rec push (<=) xs = function 283 | | [] :: stack | ([] as stack) -> xs :: stack 284 | | ys :: stack -> [] :: push (<=) (merge (<=) ys xs) stack 285 | 286 | let rec pop (<=) xs = function 287 | | [] -> xs 288 | | ys :: stack -> pop (<=) (merge (<=) ys xs) stack 289 | 290 | let rec sort3rec (<=) stack = function 291 | | x :: y :: z :: s -> 292 | let xyz = 293 | if x <= y then 294 | if y <= z then [x; y; z] else if x <= z then [x; z; y] else [z; x; y] 295 | else 296 | if x <= z then [y; x; z] else if y <= z then [y; z; x] else [z; y; x] 297 | in 298 | sort3rec (<=) (push (<=) xyz stack) s 299 | | [x; y] as s -> pop (<=) (if x <= y then s else [y; x]) stack 300 | | s -> pop (<=) s stack 301 | 302 | let sort3 (<=) s = sort3rec (<=) [] s 303 | 304 | let rec sortNrec (<=) stack s = 305 | let rec ascending accu x s = 306 | let accu = x :: accu in 307 | match s with 308 | | [] -> pop (<=) (rev accu) stack 309 | | y :: s when x <= y -> ascending accu y s 310 | | _ -> sortNrec (<=) (push (<=) (rev accu) stack) s 311 | in 312 | let rec descending accu x s = 313 | let accu = x :: accu in 314 | match s with 315 | | [] -> pop (<=) accu stack 316 | | y :: s when not (x <= y) -> descending accu y s 317 | | _ -> sortNrec (<=) (push (<=) accu stack) s 318 | in 319 | match s with 320 | | x :: y :: s -> 321 | if x <= y then ascending [x] y s else descending [x] y s 322 | | _ -> pop (<=) s stack 323 | 324 | let sortN (<=) s = sortNrec (<=) [] s 325 | 326 | let rec sort3Nrec (<=) stack s = 327 | let rec ascending accu x s = 328 | let accu = x :: accu in 329 | match s with 330 | | [] -> pop (<=) (rev accu) stack 331 | | y :: s when x <= y -> ascending accu y s 332 | | _ -> sort3Nrec (<=) (push (<=) (rev accu) stack) s 333 | in 334 | let rec descending accu x s = 335 | let accu = x :: accu in 336 | match s with 337 | | [] -> pop (<=) accu stack 338 | | y :: s when not (x <= y) -> descending accu y s 339 | | _ -> sort3Nrec (<=) (push (<=) accu stack) s 340 | in 341 | match s with 342 | | x :: y :: z :: s -> 343 | begin match x <= y, y <= z with 344 | | true, true -> ascending [y; x] z s 345 | | false, false -> descending [y; x] z s 346 | | true, false -> 347 | let xyz = if x <= z then [x; z; y] else [z; x; y] in 348 | sort3Nrec (<=) (push (<=) xyz stack) s 349 | | false, true -> 350 | let xyz = if x <= z then [y; x; z] else [y; z; x] in 351 | sort3Nrec (<=) (push (<=) xyz stack) s 352 | end 353 | | [x; y] -> pop (<=) (if x <= y then [x; y] else [y; x]) stack 354 | | _ -> pop (<=) s stack 355 | 356 | let sort3N (<=) s = sort3Nrec (<=) [] s 357 | 358 | end;; 359 | 360 | (* Stack-based bottom-up tail-recursive-modulo-cons mergesorts *) 361 | module TRMCStack = struct 362 | 363 | open TRMCMerge 364 | 365 | let rec push (<=) xs k stack = 366 | match k land 1, stack with 367 | | 0, _ -> xs :: stack 368 | | 1, ys :: stack -> push (<=) (merge (<=) ys xs) (k lsr 1) stack 369 | 370 | let rec pop (<=) xs = function 371 | | [] -> xs 372 | | ys :: stack -> pop (<=) (merge (<=) ys xs) stack 373 | 374 | let rec sort3rec (<=) k stack = function 375 | | x :: y :: z :: s -> 376 | let xyz = 377 | if x <= y then 378 | if y <= z then [x; y; z] else if x <= z then [x; z; y] else [z; x; y] 379 | else 380 | if x <= z then [y; x; z] else if y <= z then [y; z; x] else [z; y; x] 381 | in 382 | sort3rec (<=) (k + 1) (push (<=) xyz k stack) s 383 | | [x; y] as s -> pop (<=) (if x <= y then s else [y; x]) stack 384 | | s -> pop (<=) s stack 385 | 386 | let sort3 (<=) s = sort3rec (<=) 0 [] s 387 | 388 | let rec sortNrec (<=) k stack s = 389 | let rec ascending accu x s = 390 | let accu = x :: accu in 391 | match s with 392 | | [] -> pop (<=) (rev accu) stack 393 | | y :: s when x <= y -> ascending accu y s 394 | | _ -> sortNrec (<=) (k + 1) (push (<=) (rev accu) k stack) s 395 | in 396 | let rec descending accu x s = 397 | let accu = x :: accu in 398 | match s with 399 | | [] -> pop (<=) accu stack 400 | | y :: s when not (x <= y) -> descending accu y s 401 | | _ -> sortNrec (<=) (k + 1) (push (<=) accu k stack) s 402 | in 403 | match s with 404 | | x :: y :: s -> 405 | if x <= y then ascending [x] y s else descending [x] y s 406 | | _ -> pop (<=) s stack 407 | 408 | let sortN (<=) s = sortNrec (<=) 0 [] s 409 | 410 | let rec sort3Nrec (<=) k stack s = 411 | let rec ascending accu x s = 412 | let accu = x :: accu in 413 | match s with 414 | | [] -> pop (<=) (rev accu) stack 415 | | y :: s when x <= y -> ascending accu y s 416 | | _ -> sort3Nrec (<=) (k + 1) (push (<=) (rev accu) k stack) s 417 | in 418 | let rec descending accu x s = 419 | let accu = x :: accu in 420 | match s with 421 | | [] -> pop (<=) accu stack 422 | | y :: s when not (x <= y) -> descending accu y s 423 | | _ -> sort3Nrec (<=) (k + 1) (push (<=) accu k stack) s 424 | in 425 | match s with 426 | | x :: y :: z :: s -> 427 | begin match x <= y, y <= z with 428 | | true, true -> ascending [y; x] z s 429 | | false, false -> descending [y; x] z s 430 | | true, false -> 431 | let xyz = if x <= z then [x; z; y] else [z; x; y] in 432 | sort3Nrec (<=) (k + 1) (push (<=) xyz k stack) s 433 | | false, true -> 434 | let xyz = if x <= z then [y; x; z] else [y; z; x] in 435 | sort3Nrec (<=) (k + 1) (push (<=) xyz k stack) s 436 | end 437 | | [x; y] -> pop (<=) (if x <= y then [x; y] else [y; x]) stack 438 | | _ -> pop (<=) s stack 439 | 440 | let sort3N (<=) s = sort3Nrec (<=) 0 [] s 441 | 442 | end;; 443 | 444 | (* Stack-based bottom-up tail-recursive-modulo-cons mergesorts without the *) 445 | (* counter *) 446 | module TRMCStack_ = struct 447 | 448 | open TRMCMerge 449 | 450 | let rec push (<=) xs = function 451 | | [] :: stack | ([] as stack) -> xs :: stack 452 | | ys :: stack -> [] :: push (<=) (merge (<=) ys xs) stack 453 | 454 | let rec pop (<=) xs = function 455 | | [] -> xs 456 | | ys :: stack -> pop (<=) (merge (<=) ys xs) stack 457 | 458 | let rec sort3rec (<=) stack = function 459 | | x :: y :: z :: s -> 460 | let xyz = 461 | if x <= y then 462 | if y <= z then [x; y; z] else if x <= z then [x; z; y] else [z; x; y] 463 | else 464 | if x <= z then [y; x; z] else if y <= z then [y; z; x] else [z; y; x] 465 | in 466 | sort3rec (<=) (push (<=) xyz stack) s 467 | | [x; y] as s -> pop (<=) (if x <= y then s else [y; x]) stack 468 | | s -> pop (<=) s stack 469 | 470 | let sort3 (<=) s = sort3rec (<=) [] s 471 | 472 | let rec sortNrec (<=) stack s = 473 | let rec ascending accu x s = 474 | let accu = x :: accu in 475 | match s with 476 | | [] -> pop (<=) (rev accu) stack 477 | | y :: s when x <= y -> ascending accu y s 478 | | _ -> sortNrec (<=) (push (<=) (rev accu) stack) s 479 | in 480 | let rec descending accu x s = 481 | let accu = x :: accu in 482 | match s with 483 | | [] -> pop (<=) accu stack 484 | | y :: s when not (x <= y) -> descending accu y s 485 | | _ -> sortNrec (<=) (push (<=) accu stack) s 486 | in 487 | match s with 488 | | x :: y :: s -> 489 | if x <= y then ascending [x] y s else descending [x] y s 490 | | _ -> pop (<=) s stack 491 | 492 | let sortN (<=) s = sortNrec (<=) [] s 493 | 494 | let rec sort3Nrec (<=) stack s = 495 | let rec ascending accu x s = 496 | let accu = x :: accu in 497 | match s with 498 | | [] -> pop (<=) (rev accu) stack 499 | | y :: s when x <= y -> ascending accu y s 500 | | _ -> sort3Nrec (<=) (push (<=) (rev accu) stack) s 501 | in 502 | let rec descending accu x s = 503 | let accu = x :: accu in 504 | match s with 505 | | [] -> pop (<=) accu stack 506 | | y :: s when not (x <= y) -> descending accu y s 507 | | _ -> sort3Nrec (<=) (push (<=) accu stack) s 508 | in 509 | match s with 510 | | x :: y :: z :: s -> 511 | begin match x <= y, y <= z with 512 | | true, true -> ascending [y; x] z s 513 | | false, false -> descending [y; x] z s 514 | | true, false -> 515 | let xyz = if x <= z then [x; z; y] else [z; x; y] in 516 | sort3Nrec (<=) (push (<=) xyz stack) s 517 | | false, true -> 518 | let xyz = if x <= z then [y; x; z] else [y; z; x] in 519 | sort3Nrec (<=) (push (<=) xyz stack) s 520 | end 521 | | [x; y] -> pop (<=) (if x <= y then [x; y] else [y; x]) stack 522 | | _ -> pop (<=) s stack 523 | 524 | let sort3N (<=) s = sort3Nrec (<=) [] s 525 | 526 | end;; 527 | 528 | (* Stack-based bottom-up tail-recursive mergesorts *) 529 | module TRStack = struct 530 | 531 | open TRMerge 532 | 533 | let rec push (<=) xs k stack = 534 | match k land 3, stack with 535 | | 0, _ | 2, _ -> xs :: stack 536 | | 1, ys :: stack -> rev_merge (<=) ys xs [] :: stack 537 | | 3, ys :: zs :: stack -> 538 | push (<=) (rev_merge_rev (<=) (rev_merge (<=) ys xs []) zs []) 539 | (k lsr 2) stack 540 | 541 | let rec pop (<=) xs k stack = 542 | match k land 3, stack with 543 | | _, [] -> xs 544 | | 0, _ -> pop (<=) xs (k lsr 2) stack 545 | | 2, _ -> pop_rev (<=) (rev xs) (k lsr 1) stack 546 | | 1, ys :: stack | 3, ys :: stack -> 547 | pop_rev (<=) (rev_merge (<=) ys xs []) (k lsr 1) stack 548 | and pop_rev (<=) xs k stack = 549 | match k land 3, stack with 550 | | _, [] -> rev xs 551 | | 0, _ -> pop_rev (<=) xs (k lsr 2) stack 552 | | 2, _ -> pop (<=) (rev xs) (k lsr 1) stack 553 | | 1, ys :: stack | 3, ys :: stack -> 554 | pop (<=) (rev_merge_rev (<=) xs ys []) (k lsr 1) stack 555 | 556 | let rec sort3rec (<=) k stack = function 557 | | x :: y :: z :: s -> 558 | let xyz = 559 | if x <= y then 560 | if y <= z then [x; y; z] else if x <= z then [x; z; y] else [z; x; y] 561 | else 562 | if x <= z then [y; x; z] else if y <= z then [y; z; x] else [z; y; x] 563 | in 564 | sort3rec (<=) (k + 1) (push (<=) xyz k stack) s 565 | | [x; y] as s -> pop (<=) (if x <= y then s else [y; x]) k stack 566 | | s -> pop (<=) s k stack 567 | 568 | let sort3 (<=) s = sort3rec (<=) 0 [] s 569 | 570 | let rec sortNrec (<=) k stack s = 571 | let rec ascending accu x s = 572 | let accu = x :: accu in 573 | match s with 574 | | [] -> pop (<=) (rev accu) k stack 575 | | y :: s when x <= y -> ascending accu y s 576 | | _ -> sortNrec (<=) (k + 1) (push (<=) (rev accu) k stack) s 577 | in 578 | let rec descending accu x s = 579 | let accu = x :: accu in 580 | match s with 581 | | [] -> pop (<=) accu k stack 582 | | y :: s when not (x <= y) -> descending accu y s 583 | | _ -> sortNrec (<=) (k + 1) (push (<=) accu k stack) s 584 | in 585 | match s with 586 | | x :: y :: s -> 587 | if x <= y then ascending [x] y s else descending [x] y s 588 | | _ -> pop (<=) s k stack 589 | 590 | let sortN (<=) s = sortNrec (<=) 0 [] s 591 | 592 | let rec sort3Nrec (<=) k stack s = 593 | let rec ascending accu x s = 594 | let accu = x :: accu in 595 | match s with 596 | | [] -> pop (<=) (rev accu) k stack 597 | | y :: s when x <= y -> ascending accu y s 598 | | _ -> sort3Nrec (<=) (k + 1) (push (<=) (rev accu) k stack) s 599 | in 600 | let rec descending accu x s = 601 | let accu = x :: accu in 602 | match s with 603 | | [] -> pop (<=) accu k stack 604 | | y :: s when not (x <= y) -> descending accu y s 605 | | _ -> sort3Nrec (<=) (k + 1) (push (<=) accu k stack) s 606 | in 607 | match s with 608 | | x :: y :: z :: s -> 609 | begin match x <= y, y <= z with 610 | | true, true -> ascending [y; x] z s 611 | | false, false -> descending [y; x] z s 612 | | true, false -> 613 | let xyz = if x <= z then [x; z; y] else [z; x; y] in 614 | sort3Nrec (<=) (k + 1) (push (<=) xyz k stack) s 615 | | false, true -> 616 | let xyz = if x <= z then [y; x; z] else [y; z; x] in 617 | sort3Nrec (<=) (k + 1) (push (<=) xyz k stack) s 618 | end 619 | | [x; y] -> pop (<=) (if x <= y then [x; y] else [y; x]) k stack 620 | | _ -> pop (<=) s k stack 621 | 622 | let sort3N (<=) s = sort3Nrec (<=) 0 [] s 623 | 624 | end;; 625 | 626 | (* Stack-based bottom-up tail-recursive mergesorts without the counter *) 627 | module TRStack_ = struct 628 | 629 | open TRMerge 630 | 631 | let rec push (<=) xs = function 632 | | [] :: stack | ([] as stack) -> xs :: stack 633 | | ys :: [] :: stack | ys :: ([] as stack) -> 634 | [] :: rev_merge (<=) ys xs [] :: stack 635 | | ys :: zs :: stack -> 636 | [] :: [] :: push (<=) 637 | (rev_merge_rev (<=) (rev_merge (<=) ys xs []) zs []) stack 638 | 639 | let rec pop (<=) xs = function 640 | | [] -> xs 641 | | [] :: [] :: stack -> pop (<=) xs stack 642 | | [] :: stack -> pop_rev (<=) (rev xs) stack 643 | | ys :: stack -> pop_rev (<=) (rev_merge (<=) ys xs []) stack 644 | and pop_rev (<=) xs = function 645 | | [] -> rev xs 646 | | [] :: [] :: stack -> pop_rev (<=) xs stack 647 | | [] :: stack -> pop (<=) (rev xs) stack 648 | | ys :: stack -> pop (<=) (rev_merge_rev (<=) xs ys []) stack 649 | 650 | let rec sort3rec (<=) stack = function 651 | | x :: y :: z :: s -> 652 | let xyz = 653 | if x <= y then 654 | if y <= z then [x; y; z] else if x <= z then [x; z; y] else [z; x; y] 655 | else 656 | if x <= z then [y; x; z] else if y <= z then [y; z; x] else [z; y; x] 657 | in 658 | sort3rec (<=) (push (<=) xyz stack) s 659 | | [x; y] as s -> pop (<=) (if x <= y then s else [y; x]) stack 660 | | s -> pop (<=) s stack 661 | 662 | let sort3 (<=) s = sort3rec (<=) [] s 663 | 664 | let rec sortNrec (<=) stack s = 665 | let rec ascending accu x s = 666 | let accu = x :: accu in 667 | match s with 668 | | [] -> pop (<=) (rev accu) stack 669 | | y :: s when x <= y -> ascending accu y s 670 | | _ -> sortNrec (<=) (push (<=) (rev accu) stack) s 671 | in 672 | let rec descending accu x s = 673 | let accu = x :: accu in 674 | match s with 675 | | [] -> pop (<=) accu stack 676 | | y :: s when not (x <= y) -> descending accu y s 677 | | _ -> sortNrec (<=) (push (<=) accu stack) s 678 | in 679 | match s with 680 | | x :: y :: s -> 681 | if x <= y then ascending [x] y s else descending [x] y s 682 | | _ -> pop (<=) s stack 683 | 684 | let sortN (<=) s = sortNrec (<=) [] s 685 | 686 | let rec sort3Nrec (<=) stack s = 687 | let rec ascending accu x s = 688 | let accu = x :: accu in 689 | match s with 690 | | [] -> pop (<=) (rev accu) stack 691 | | y :: s when x <= y -> ascending accu y s 692 | | _ -> sort3Nrec (<=) (push (<=) (rev accu) stack) s 693 | in 694 | let rec descending accu x s = 695 | let accu = x :: accu in 696 | match s with 697 | | [] -> pop (<=) accu stack 698 | | y :: s when not (x <= y) -> descending accu y s 699 | | _ -> sort3Nrec (<=) (push (<=) accu stack) s 700 | in 701 | match s with 702 | | x :: y :: z :: s -> 703 | begin match x <= y, y <= z with 704 | | true, true -> ascending [y; x] z s 705 | | false, false -> descending [y; x] z s 706 | | true, false -> 707 | let xyz = if x <= z then [x; z; y] else [z; x; y] in 708 | sort3Nrec (<=) (push (<=) xyz stack) s 709 | | false, true -> 710 | let xyz = if x <= z then [y; x; z] else [y; z; x] in 711 | sort3Nrec (<=) (push (<=) xyz stack) s 712 | end 713 | | [x; y] -> pop (<=) (if x <= y then [x; y] else [y; x]) stack 714 | | _ -> pop (<=) s stack 715 | 716 | let sort3N (<=) s = sort3Nrec (<=) [] s 717 | 718 | end;; 719 | 720 | (* A copy of List.stable_sort from the standard library of OCaml, slightly *) 721 | (* modified to take (<=) of type ['a -> 'a -> bool] instead of [cmp] of type *) 722 | (* ['a -> 'a -> int] *) 723 | module StdlibSort = struct 724 | 725 | open TRMerge 726 | 727 | let sort (<=) l = 728 | let rec rev_merge l1 l2 accu = 729 | match l1, l2 with 730 | | [], l2 -> rev_append l2 accu 731 | | l1, [] -> rev_append l1 accu 732 | | h1::t1, h2::t2 -> 733 | if h1 <= h2 734 | then rev_merge t1 l2 (h1::accu) 735 | else rev_merge l1 t2 (h2::accu) 736 | in 737 | let rec rev_merge_rev l1 l2 accu = 738 | match l1, l2 with 739 | | [], l2 -> rev_append l2 accu 740 | | l1, [] -> rev_append l1 accu 741 | | h1::t1, h2::t2 -> 742 | if h1 <= h2 743 | then rev_merge_rev l1 t2 (h2::accu) 744 | else rev_merge_rev t1 l2 (h1::accu) 745 | in 746 | let rec sort n l = 747 | match n, l with 748 | | 2, x1 :: x2 :: tl -> 749 | let s = if x1 <= x2 then [x1; x2] else [x2; x1] in 750 | (s, tl) 751 | | 3, x1 :: x2 :: x3 :: tl -> 752 | let s = 753 | if x1 <= x2 then 754 | if x2 <= x3 then [x1; x2; x3] 755 | else if x1 <= x3 then [x1; x3; x2] 756 | else [x3; x1; x2] 757 | else if x1 <= x3 then [x2; x1; x3] 758 | else if x2 <= x3 then [x2; x3; x1] 759 | else [x3; x2; x1] 760 | in 761 | (s, tl) 762 | | n, l -> 763 | let n1 = n asr 1 in 764 | let n2 = n - n1 in 765 | let s1, l2 = rev_sort n1 l in 766 | let s2, tl = rev_sort n2 l2 in 767 | (rev_merge_rev s1 s2 [], tl) 768 | and rev_sort n l = 769 | match n, l with 770 | | 2, x1 :: x2 :: tl -> 771 | let s = if x1 <= x2 then [x2; x1] else [x1; x2] in 772 | (s, tl) 773 | | 3, x1 :: x2 :: x3 :: tl -> 774 | let s = 775 | if x1 <= x2 then 776 | if x1 <= x3 then 777 | if x2 <= x3 then [x3; x2; x1] else [x2; x3; x1] 778 | else [x2; x1; x3] 779 | else 780 | if x2 <= x3 then 781 | if x1 <= x3 then [x3; x1; x2] else [x1; x3; x2] 782 | else [x1; x2; x3] 783 | in 784 | (s, tl) 785 | | n, l -> 786 | let n1 = n asr 1 in 787 | let n2 = n - n1 in 788 | let s1, l2 = sort n1 l in 789 | let s2, tl = sort n2 l2 in 790 | (rev_merge s1 s2 [], tl) 791 | in 792 | let len = length l in 793 | if len < 2 then l else fst (sort len l) 794 | 795 | end;; 796 | -------------------------------------------------------------------------------- /benchmark/ocaml/mergesort_ocaml.mli: -------------------------------------------------------------------------------- 1 | module NaiveTopDown : sig 2 | val sort : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 3 | end 4 | 5 | module NaiveBottomUp : sig 6 | val sort : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 7 | end 8 | 9 | module TopDown : sig 10 | val sort : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 11 | end 12 | 13 | module BottomUp : sig 14 | val sort : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 15 | end 16 | 17 | module Smooth : sig 18 | val sort : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 19 | end 20 | 21 | module TailRec : sig 22 | val sort : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 23 | end 24 | 25 | module NTRStack : sig 26 | val sort3 : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 27 | val sortN : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 28 | val sort3N : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 29 | end 30 | 31 | module NTRStack_ : sig 32 | val sort3 : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 33 | val sortN : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 34 | val sort3N : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 35 | end 36 | 37 | module TRMCStack : sig 38 | val sort3 : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 39 | val sortN : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 40 | val sort3N : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 41 | end 42 | 43 | module TRMCStack_ : sig 44 | val sort3 : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 45 | val sortN : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 46 | val sort3N : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 47 | end 48 | 49 | module TRStack : sig 50 | val sort3 : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 51 | val sortN : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 52 | val sort3N : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 53 | end 54 | 55 | module TRStack_ : sig 56 | val sort3 : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 57 | val sortN : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 58 | val sort3N : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 59 | end 60 | 61 | module StdlibSort : sig 62 | val sort : ('a1 -> 'a1 -> bool) -> 'a1 list -> 'a1 list 63 | end 64 | -------------------------------------------------------------------------------- /benchmark/ocaml/test_stability.ml: -------------------------------------------------------------------------------- 1 | open Mergesort_ocaml;; 2 | 3 | let test_stability sort = 4 | QCheck.Test.make ~count:2000 ~name:"sort_stability" 5 | QCheck.(list (pair small_nat small_nat)) 6 | (fun l -> 7 | let le_fst x y = fst x <= fst y in 8 | let cmp_fst x y = compare (fst x) (fst y) in 9 | sort le_fst l = List.stable_sort cmp_fst l);; 10 | 11 | QCheck.Test.check_exn (test_stability NaiveTopDown.sort);; 12 | QCheck.Test.check_exn (test_stability NaiveBottomUp.sort);; 13 | QCheck.Test.check_exn (test_stability TopDown.sort);; 14 | QCheck.Test.check_exn (test_stability BottomUp.sort);; 15 | QCheck.Test.check_exn (test_stability Smooth.sort);; 16 | QCheck.Test.check_exn (test_stability TailRec.sort);; 17 | QCheck.Test.check_exn (test_stability NTRStack.sort3);; 18 | QCheck.Test.check_exn (test_stability NTRStack.sortN);; 19 | QCheck.Test.check_exn (test_stability NTRStack.sort3N);; 20 | QCheck.Test.check_exn (test_stability NTRStack_.sort3);; 21 | QCheck.Test.check_exn (test_stability NTRStack_.sortN);; 22 | QCheck.Test.check_exn (test_stability NTRStack_.sort3N);; 23 | QCheck.Test.check_exn (test_stability TRMCStack.sort3);; 24 | QCheck.Test.check_exn (test_stability TRMCStack.sortN);; 25 | QCheck.Test.check_exn (test_stability TRMCStack.sort3N);; 26 | QCheck.Test.check_exn (test_stability TRMCStack_.sort3);; 27 | QCheck.Test.check_exn (test_stability TRMCStack_.sortN);; 28 | QCheck.Test.check_exn (test_stability TRMCStack_.sort3N);; 29 | QCheck.Test.check_exn (test_stability TRStack.sort3);; 30 | QCheck.Test.check_exn (test_stability TRStack.sortN);; 31 | QCheck.Test.check_exn (test_stability TRStack.sort3N);; 32 | QCheck.Test.check_exn (test_stability TRStack_.sort3);; 33 | QCheck.Test.check_exn (test_stability TRStack_.sortN);; 34 | QCheck.Test.check_exn (test_stability TRStack_.sort3N);; 35 | QCheck.Test.check_exn (test_stability StdlibSort.sort);; 36 | -------------------------------------------------------------------------------- /coq-stablesort.opam: -------------------------------------------------------------------------------- 1 | # This file was generated from `meta.yml`, please do not edit manually. 2 | # Follow the instructions on https://github.com/coq-community/templates to regenerate. 3 | 4 | opam-version: "2.0" 5 | maintainer: "kazuhiko.sakaguchi@ens-lyon.fr" 6 | version: "dev" 7 | 8 | homepage: "https://github.com/pi8027/stablesort" 9 | dev-repo: "git+https://github.com/pi8027/stablesort.git" 10 | bug-reports: "https://github.com/pi8027/stablesort/issues" 11 | license: "CECILL-B" 12 | 13 | synopsis: "Stable sort algorithms and their stability proofs in Coq" 14 | description: """ 15 | This library provides a generic and modular way to prove the correctness, 16 | including stability, of several mergesort functions. The correctness lemmas in 17 | this library are overloaded using a canonical structure 18 | (`StableSort.function`). This structure characterizes stable mergesort 19 | functions, say `sort`, by its abstract version `asort` parameterized over the 20 | type of sorted lists and its operators such as merge, the relational 21 | parametricity of `asort`, and two equational properties that `asort` 22 | instantiated with merge and concatenation are `sort` and the identity 23 | function, respectively, which intuitively mean that replacing merge with 24 | concatenation turns `sort` into the identity function. 25 | From this characterization, we derive an induction principle over 26 | traces—binary trees reflecting the underlying divide-and-conquer structure of 27 | mergesort—to reason about the relation between the input and output of 28 | `sort`, and the naturality of `sort`. These two properties are sufficient to 29 | deduce several correctness results of mergesort, including stability. Thus, 30 | one may prove the stability of a new sorting function by defining its abstract 31 | version, proving the relational parametricity of the latter using the 32 | parametricity translation (the Paramcoq plugin), and manually providing the 33 | equational properties. 34 | 35 | As an application of the above proof methodology, this library provides two 36 | kinds of optimized mergesorts. 37 | The first kind is non-tail-recursive mergesort. In call-by-need evaluation, 38 | they allow us to compute the first k smallest elements of a list of length n 39 | in the optimal O(n + k log k) time complexity of the partial and incremental 40 | sorting problems. However, the non-tail-recursive merge function linearly 41 | consumes the call stack and triggers a stack overflow in call-by-value 42 | evaluation. 43 | The second kind is tail-recursive mergesorts and thus solves the above issue 44 | in call-by-value evaluation. However, it does not allow us to compute the 45 | output incrementally regardless of the evaluation strategy. 46 | Therefore, there is a performance trade-off between non-tail-recursive and 47 | tail-recursive mergesorts, and the best mergesort function for lists depends 48 | on the situation, in particular, the evaluation strategy and whether it should 49 | be incremental or not. 50 | In addition, each of the above two kinds of mergesort functions has a smooth 51 | (also called natural) variant of mergesort, which takes advantage of sorted 52 | slices in the input.""" 53 | 54 | build: [make "-j%{jobs}%"] 55 | # The filter below has been added by hand to avoid running the test suite with 56 | # Coq 8.17. 57 | run-test: [ [make "-j%{jobs}%" "build-misc" ] { coq:version < "8.17~" | "8.18~" <= coq:version } ] 58 | install: [make "install"] 59 | depends: [ 60 | "coq" {>= "8.13"} 61 | "coq-mathcomp-ssreflect" {>= "1.13.0"} 62 | "coq-paramcoq" {>= "1.1.3"} 63 | "coq-mathcomp-zify" {with-test} 64 | "coq-equations" {with-test} 65 | ] 66 | 67 | tags: [ 68 | "logpath:stablesort" 69 | ] 70 | authors: [ 71 | "Kazuhiko Sakaguchi" 72 | "Cyril Cohen" 73 | ] 74 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { config ? {}, withEmacs ? false, print-env ? false, do-nothing ? false, 2 | update-nixpkgs ? false, ci-matrix ? false, 3 | override ? {}, ocaml-override ? {}, global-override ? {}, 4 | bundle ? null, job ? null, inNixShell ? null, src ? ./., 5 | }@args: 6 | let auto = fetchGit { 7 | url = "https://github.com/coq-community/coq-nix-toolbox.git"; 8 | ref = "master"; 9 | rev = import .nix/coq-nix-toolbox.nix; 10 | }; 11 | in 12 | import auto ({inherit src;} // args) 13 | -------------------------------------------------------------------------------- /meta.yml: -------------------------------------------------------------------------------- 1 | --- 2 | fullname: Stable sort algorithms in Coq 3 | shortname: stablesort 4 | organization: pi8027 5 | action: true 6 | dune: false 7 | 8 | synopsis: >- 9 | Stable sort algorithms and their stability proofs in Coq 10 | 11 | description: |- 12 | This library provides a generic and modular way to prove the correctness, 13 | including stability, of several mergesort functions. The correctness lemmas in 14 | this library are overloaded using a canonical structure 15 | (`StableSort.function`). This structure characterizes stable mergesort 16 | functions, say `sort`, by its abstract version `asort` parameterized over the 17 | type of sorted lists and its operators such as merge, the relational 18 | parametricity of `asort`, and two equational properties that `asort` 19 | instantiated with merge and concatenation are `sort` and the identity 20 | function, respectively, which intuitively mean that replacing merge with 21 | concatenation turns `sort` into the identity function. 22 | From this characterization, we derive an induction principle over 23 | traces—binary trees reflecting the underlying divide-and-conquer structure of 24 | mergesort—to reason about the relation between the input and output of 25 | `sort`, and the naturality of `sort`. These two properties are sufficient to 26 | deduce several correctness results of mergesort, including stability. Thus, 27 | one may prove the stability of a new sorting function by defining its abstract 28 | version, proving the relational parametricity of the latter using the 29 | parametricity translation (the Paramcoq plugin), and manually providing the 30 | equational properties. 31 | 32 | As an application of the above proof methodology, this library provides two 33 | kinds of optimized mergesorts. 34 | The first kind is non-tail-recursive mergesort. In call-by-need evaluation, 35 | they allow us to compute the first k smallest elements of a list of length n 36 | in the optimal O(n + k log k) time complexity of the partial and incremental 37 | sorting problems. However, the non-tail-recursive merge function linearly 38 | consumes the call stack and triggers a stack overflow in call-by-value 39 | evaluation. 40 | The second kind is tail-recursive mergesorts and thus solves the above issue 41 | in call-by-value evaluation. However, it does not allow us to compute the 42 | output incrementally regardless of the evaluation strategy. 43 | Therefore, there is a performance trade-off between non-tail-recursive and 44 | tail-recursive mergesorts, and the best mergesort function for lists depends 45 | on the situation, in particular, the evaluation strategy and whether it should 46 | be incremental or not. 47 | In addition, each of the above two kinds of mergesort functions has a smooth 48 | (also called natural) variant of mergesort, which takes advantage of sorted 49 | slices in the input. 50 | 51 | publications: 52 | - pub_url: https://arxiv.org/abs/2403.08173 53 | pub_title: A bargain for mergesorts (functional pearl) — How to prove your mergesort correct and stable, almost for free 54 | pub_doi: 10.48550/arXiv.2403.08173 55 | 56 | authors: 57 | - name: Kazuhiko Sakaguchi 58 | initial: true 59 | - name: Cyril Cohen 60 | initial: false 61 | 62 | opam-file-maintainer: kazuhiko.sakaguchi@ens-lyon.fr 63 | 64 | license: 65 | fullname: CeCILL-B Free Software License Agreement 66 | identifier: CECILL-B 67 | file: CeCILL-B 68 | 69 | supported_coq_versions: 70 | text: 8.13 or later 71 | opam: '{>= "8.13"}' 72 | 73 | tested_coq_nix_versions: 74 | 75 | tested_coq_opam_versions: 76 | - version: '1.13.0-coq-8.13' 77 | repo: 'mathcomp/mathcomp' 78 | - version: '1.13.0-coq-8.14' 79 | repo: 'mathcomp/mathcomp' 80 | - version: '1.13.0-coq-8.15' 81 | repo: 'mathcomp/mathcomp' 82 | - version: '1.14.0-coq-8.13' 83 | repo: 'mathcomp/mathcomp' 84 | - version: '1.14.0-coq-8.14' 85 | repo: 'mathcomp/mathcomp' 86 | - version: '1.14.0-coq-8.15' 87 | repo: 'mathcomp/mathcomp' 88 | - version: '1.15.0-coq-8.13' 89 | repo: 'mathcomp/mathcomp' 90 | - version: '1.15.0-coq-8.14' 91 | repo: 'mathcomp/mathcomp' 92 | - version: '1.15.0-coq-8.15' 93 | repo: 'mathcomp/mathcomp' 94 | - version: '1.15.0-coq-8.16' 95 | repo: 'mathcomp/mathcomp' 96 | - version: '1.16.0-coq-8.13' 97 | repo: 'mathcomp/mathcomp' 98 | - version: '1.16.0-coq-8.14' 99 | repo: 'mathcomp/mathcomp' 100 | - version: '1.16.0-coq-8.15' 101 | repo: 'mathcomp/mathcomp' 102 | - version: '1.16.0-coq-8.16' 103 | repo: 'mathcomp/mathcomp' 104 | - version: '1.16.0-coq-8.17' 105 | repo: 'mathcomp/mathcomp' 106 | - version: '1.16.0-coq-8.18' 107 | repo: 'mathcomp/mathcomp' 108 | - version: '1.17.0-coq-8.15' 109 | repo: 'mathcomp/mathcomp' 110 | - version: '1.17.0-coq-8.16' 111 | repo: 'mathcomp/mathcomp' 112 | - version: '1.17.0-coq-8.17' 113 | repo: 'mathcomp/mathcomp' 114 | - version: '1.17.0-coq-8.18' 115 | repo: 'mathcomp/mathcomp' 116 | - version: '1.18.0-coq-8.16' 117 | repo: 'mathcomp/mathcomp' 118 | - version: '1.18.0-coq-8.17' 119 | repo: 'mathcomp/mathcomp' 120 | - version: '1.18.0-coq-8.18' 121 | repo: 'mathcomp/mathcomp' 122 | - version: '1.19.0-coq-8.16' 123 | repo: 'mathcomp/mathcomp' 124 | - version: '1.19.0-coq-8.17' 125 | repo: 'mathcomp/mathcomp' 126 | - version: '1.19.0-coq-8.18' 127 | repo: 'mathcomp/mathcomp' 128 | - version: '1.19.0-coq-8.19' 129 | repo: 'mathcomp/mathcomp' 130 | - version: '2.0.0-coq-8.16' 131 | repo: 'mathcomp/mathcomp' 132 | - version: '2.0.0-coq-8.17' 133 | repo: 'mathcomp/mathcomp' 134 | - version: '2.0.0-coq-8.18' 135 | repo: 'mathcomp/mathcomp' 136 | - version: '2.1.0-coq-8.16' 137 | repo: 'mathcomp/mathcomp' 138 | - version: '2.1.0-coq-8.17' 139 | repo: 'mathcomp/mathcomp' 140 | - version: '2.1.0-coq-8.18' 141 | repo: 'mathcomp/mathcomp' 142 | - version: '2.2.0-coq-8.16' 143 | repo: 'mathcomp/mathcomp' 144 | - version: '2.2.0-coq-8.17' 145 | repo: 'mathcomp/mathcomp' 146 | - version: '2.2.0-coq-8.18' 147 | repo: 'mathcomp/mathcomp' 148 | - version: '2.2.0-coq-8.19' 149 | repo: 'mathcomp/mathcomp' 150 | - version: '2.2.0-coq-8.20' 151 | repo: 'mathcomp/mathcomp' 152 | - version: '2.2.0-coq-dev' 153 | repo: 'mathcomp/mathcomp' 154 | - version: '2.3.0-coq-8.18' 155 | repo: 'mathcomp/mathcomp' 156 | - version: '2.3.0-coq-8.19' 157 | repo: 'mathcomp/mathcomp' 158 | - version: '2.3.0-coq-8.20' 159 | repo: 'mathcomp/mathcomp' 160 | - version: '2.3.0-coq-dev' 161 | repo: 'mathcomp/mathcomp' 162 | - version: 'coq-8.19' 163 | repo: 'mathcomp/mathcomp-dev' 164 | - version: 'coq-8.20' 165 | repo: 'mathcomp/mathcomp-dev' 166 | - version: 'rocq-prover-9.0' 167 | repo: 'mathcomp/mathcomp-dev' 168 | - version: 'rocq-prover-dev' 169 | repo: 'mathcomp/mathcomp-dev' 170 | 171 | dependencies: 172 | - opam: 173 | name: coq-mathcomp-ssreflect 174 | version: '{>= "1.13.0"}' 175 | description: |- 176 | [MathComp](https://math-comp.github.io) 1.13.0 or later 177 | - opam: 178 | name: coq-paramcoq 179 | version: '{>= "1.1.3"}' 180 | description: |- 181 | [Paramcoq](https://github.com/coq-community/paramcoq) 1.1.3 or later 182 | - opam: 183 | name: coq-mathcomp-zify 184 | version: '{with-test}' 185 | description: |- 186 | [Mczify](https://github.com/math-comp/mczify) (required only for the test suite) 187 | - opam: 188 | name: coq-equations 189 | version: '{with-test}' 190 | description: |- 191 | [Equations](https://github.com/mattam82/Coq-Equations) (required only for the test suite) 192 | 193 | test_target: build-misc 194 | namespace: stablesort 195 | 196 | action_appendix: |2- 197 | export: 'OPAMWITHTEST' 198 | env: 199 | OPAMWITHTEST: true 200 | 201 | build: |- 202 | ## Building and installation instructions 203 | The easiest way to install the development version of Stable sort algorithms in Coq 204 | is via [OPAM](https://opam.ocaml.org/doc/Install.html): 205 | ``` shell 206 | git clone https://github.com/pi8027/stablesort.git 207 | cd stablesort 208 | opam repo add coq-released https://coq.inria.fr/opam/released 209 | opam install ./coq-stablesort.opam 210 | ``` 211 | 212 | documentation: |- 213 | ## Credits 214 | The mergesort functions and the stability proofs provided in this library are 215 | mostly based on ones in the `path` library of Mathematical Components. 216 | --- 217 | -------------------------------------------------------------------------------- /misc/topdown_tailrec.v: -------------------------------------------------------------------------------- 1 | (* A verified version of top-down tail-recursive mergesort, presented in *) 2 | (* Sections 4.1 and 4.3.2 of the paper *) 3 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path. 4 | From mathcomp Require Import zify. 5 | From stablesort Require Import param stablesort. 6 | From Equations Require Import Equations. 7 | 8 | Set Implicit Arguments. 9 | Unset Strict Implicit. 10 | Unset Printing Implicit Defensive. 11 | 12 | Lemma if_nilp (T S : Type) (s : seq T) (x y : S) : 13 | (if nilp s then x else y) = if s is [::] then x else y. 14 | Proof. by case: s. Qed. 15 | 16 | Section Revmerge. 17 | 18 | Context (T : Type) (leT : rel T). 19 | 20 | Fixpoint merge_rec (xs ys accu : seq T) : seq T := 21 | if xs is x :: xs' then 22 | (fix merge_rec' (ys accu : seq T) := 23 | if ys is y :: ys' then 24 | if leT x y then 25 | merge_rec xs' ys (x :: accu) else merge_rec' ys' (y :: accu) 26 | else 27 | catrev xs accu) ys accu 28 | else catrev ys accu. 29 | 30 | Definition revmerge (xs ys : seq T) : seq T := merge_rec xs ys [::]. 31 | 32 | Lemma revmergeE (xs ys : seq T) : revmerge xs ys = rev (merge leT xs ys). 33 | Proof. 34 | rewrite /revmerge /rev; move: xs ys [::]. 35 | by elim=> [|x xs IHxs]; elim=> [|y ys IHys] accu //=; case: ifP => /=. 36 | Qed. 37 | 38 | End Revmerge. 39 | 40 | Module Abstract. 41 | Section Abstract. 42 | 43 | Context (T R : Type) (leT : rel T). 44 | Context (merge merge' : R -> R -> R) (singleton : T -> R) (empty : R). 45 | 46 | (* The abstract top-down tail-recursive mergesort (Section 4.3.2) *) 47 | Equations sort_rec (xs : seq T) (b : bool) (n fuel : nat) : 48 | R * seq T by struct fuel := 49 | (* The following three cases ar absurd because [0 < n <= size xs] and *) 50 | (* [n <= fuel] should hold. Nevertheless, we add them to make [sort_rec] *) 51 | (* total and to make its correctness proof easier. *) 52 | sort_rec xs _ _ 0 => (empty, xs); 53 | sort_rec xs _ 0 _ => (empty, xs); 54 | sort_rec [::] _ _ _ => (empty, [::]); 55 | (* end absurd cases *) 56 | sort_rec (x :: xs) _ 1 _ => (singleton x, xs); 57 | sort_rec xs b n fuel.+1 => 58 | let n1 := n./2 in 59 | let (s1, xs') := sort_rec xs (~~ b) n1 fuel in 60 | let (s2, xs'') := sort_rec xs' (~~ b) (n - n1) fuel in 61 | ((if b then merge' s1 s2 else merge s1 s2), xs''). 62 | 63 | #[using="All"] 64 | Definition sort (xs : seq T) : R := 65 | if xs is [::] then empty else let n := size xs in (sort_rec xs true n n).1. 66 | 67 | End Abstract. 68 | 69 | Parametricity sort. 70 | 71 | End Abstract. 72 | 73 | Section Concrete. 74 | 75 | Context (T : Type) (leT : rel T). 76 | Let geT x y := leT y x. 77 | 78 | (* The concrete top-down tail-recursive mergesort (Section 4.1) *) 79 | Equations sort_rec (xs : seq T) (b : bool) (n fuel : nat) : 80 | seq T * seq T by struct fuel := 81 | (* begin absurd cases (cf. Abstract.sort_rec) *) 82 | sort_rec xs _ _ 0 => ([::], xs); 83 | sort_rec xs _ 0 _ => ([::], xs); 84 | sort_rec [::] _ _ _ => ([::], [::]); 85 | (* end absurd cases *) 86 | sort_rec (x :: xs) _ 1 _ => ([:: x], xs); 87 | sort_rec xs b n fuel.+1 => 88 | let n1 := n./2 in 89 | let (s1, xs') := sort_rec xs (~~ b) n1 fuel in 90 | let (s2, xs'') := sort_rec xs' (~~ b) (n - n1) fuel in 91 | (if b then revmerge geT s2 s1 else revmerge leT s1 s2, xs''). 92 | 93 | Definition sort (xs : seq T) : seq T := 94 | if xs is [::] then [::] else let n := size xs in (sort_rec xs true n n).1. 95 | 96 | Notation merge := (path.merge leT) (only parsing). 97 | Notation merge' := 98 | (fun xs ys => rev (path.merge geT (rev ys) (rev xs))) (only parsing). 99 | 100 | (* The proof of Equation (5) *) 101 | Lemma asort_mergeE : 102 | Abstract.sort leT merge merge' (fun x => [:: x]) [::] =1 sort. 103 | Proof. 104 | rewrite /Abstract.sort /sort => xs; rewrite -!if_nilp. 105 | congr (if _ then _ else _.1). 106 | pose condrev b (p : seq T * seq T) := ((if b then p.1 else rev p.1), p.2). 107 | set rhs := RHS; have ->: rhs = condrev true rhs by case: rhs. 108 | rewrite {}/rhs; move: {2 4}(size xs) => fuel. 109 | apply_funelim (sort_rec xs true (size xs) fuel); 110 | try by move=> *; case: (b in condrev b). 111 | move=> x {}xs b n {}fuel IHl IHr. 112 | rewrite Abstract.sort_rec_equation_5 /= {}IHl /= {IHr}(IHr [::]) /=. 113 | case: (sort_rec (x :: xs)) => s1 xs' /=; case: sort_rec => s2 xs'' /=. 114 | by rewrite !revmergeE /condrev; case: b; rewrite /= !revK. 115 | Qed. 116 | 117 | (* The proof of Equation (6) *) 118 | Lemma asort_catE : Abstract.sort leT cat cat (fun x => [:: x]) [::] =1 id. 119 | Proof. 120 | rewrite /Abstract.sort => xs. 121 | rewrite (_ : Abstract.sort_rec _ _ _ _ _ _ _ _ = 122 | (take (size xs) xs, drop (size xs) xs)). 123 | by rewrite take_size; case: xs. 124 | move: {2 4}(size xs) (leqnn (size xs)) => fuel. 125 | apply_funelim 126 | (Abstract.sort_rec cat cat (fun x => [:: x]) [::] xs true (size xs) fuel). 127 | - by move=> {}xs _ [] //; rewrite take0 drop0. 128 | - by move=> {}xs; rewrite take0 drop0. 129 | - by []. 130 | - by move=> x {}xs; rewrite /= take0 drop0. 131 | move=> x {}xs b n {}fuel IHl IHr; rewrite ltnS => n_lt_fuel. 132 | rewrite [LHS]/= {}IHl 1?{}(IHr [::]) 1?if_same; try lia. 133 | rewrite -takeD drop_drop; congr (take _ _, drop _ _); lia. 134 | Qed. 135 | 136 | End Concrete. 137 | 138 | Canonical sort_stable := 139 | StableSort sort Abstract.sort Abstract.sort_R asort_mergeE asort_catE. 140 | -------------------------------------------------------------------------------- /theories/param.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path. 2 | From Param Require Export Param. 3 | 4 | Set Implicit Arguments. 5 | Unset Strict Implicit. 6 | Unset Printing Implicit Defensive. 7 | 8 | Ltac destruct_reflexivity := 9 | intros ; repeat match goal with 10 | | [ x : _ |- _ = _ ] => destruct x; reflexivity; fail 11 | end. 12 | 13 | Global Parametricity Tactic := ((destruct_reflexivity; fail) || auto). 14 | 15 | Parametricity False. 16 | Parametricity eq. 17 | Parametricity or. 18 | Parametricity Acc. 19 | Parametricity unit. 20 | Parametricity bool. 21 | Parametricity option. 22 | Parametricity prod. 23 | Parametricity nat. 24 | Parametricity list. 25 | Parametricity pred. 26 | Parametricity rel. 27 | Parametricity BinNums.positive. 28 | Parametricity BinNums.N. 29 | Parametricity merge. 30 | Parametricity rev. 31 | 32 | Lemma bool_R_refl b1 b2 : b1 = b2 -> bool_R b1 b2. 33 | Proof. by case: b1 => <-; constructor. Qed. 34 | 35 | Lemma map_rel_map A B (f : A -> B) (l : seq A) : 36 | list_R (fun x y => f x = y) l (map f l). 37 | Proof. by elim: l; constructor. Qed. 38 | 39 | Lemma rel_map_map A B (f : A -> B) (l : seq A) (fl : seq B) : 40 | list_R (fun x y => f x = y) l fl -> fl = map f l. 41 | Proof. by elim/list_R_ind: l fl / => //= ? ? <- ? ? _ ->. Qed. 42 | --------------------------------------------------------------------------------