diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 244724ed2..d9b5fba5e 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -1,6 +1,6 @@ # This GitHub workflow config has been generated by a script via # -# haskell-ci 'github' '--config=cabal.haskell-ci' 'cabal.project' +# haskell-ci '--distribution' 'jammy' 'github' 'cabal.project' # # To regenerate the script (for example after adjusting tested-with) run # @@ -8,9 +8,9 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.15.20221225 +# version: 0.16.3 # -# REGENDATA ("0.15.20221225",["github","--config=cabal.haskell-ci","cabal.project"]) +# REGENDATA ("0.16.3",["--distribution","jammy","github","cabal.project"]) # name: Haskell-CI on: @@ -19,11 +19,11 @@ on: jobs: linux: name: Haskell-CI - Linux - ${{ matrix.compiler }} - runs-on: ubuntu-20.04 + runs-on: ubuntu-22.04 timeout-minutes: 60 container: - image: buildpack-deps:bionic + image: buildpack-deps:jammy continue-on-error: ${{ matrix.allow-failure }} strategy: matrix: @@ -51,18 +51,18 @@ jobs: - compiler: ghc-8.8.4 compilerKind: ghc compilerVersion: 8.8.4 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false - compiler: ghc-8.6.5 compilerKind: ghc compilerVersion: 8.6.5 - setup-method: hvr-ppa - allow-failure: false + setup-method: ghcup + allow-failure: true - compiler: ghc-8.4.4 compilerKind: ghc compilerVersion: 8.4.4 - setup-method: hvr-ppa - allow-failure: false + setup-method: ghcup + allow-failure: true fail-fast: false steps: - name: apt @@ -71,18 +71,18 @@ jobs: apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 if [ "${{ matrix.setup-method }}" = ghcup ]; then mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup" + curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) - "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) else apt-add-repository -y 'ppa:hvr/ghc' apt-get update apt-get install -y "$HCNAME" mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup" + curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) fi env: HCKIND: ${{ matrix.compilerKind }} @@ -95,18 +95,19 @@ jobs: echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" HCDIR=/opt/$HCKIND/$HCVER + if [ "${{ matrix.setup-method }}" = ghcup ]; then HC=$HOME/.ghcup/bin/$HCKIND-$HCVER echo "HC=$HC" >> "$GITHUB_ENV" echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" else HC=$HCDIR/bin/$HCKIND echo "HC=$HC" >> "$GITHUB_ENV" echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" fi HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') @@ -158,14 +159,14 @@ jobs: - name: install cabal-plan run: | mkdir -p $HOME/.cabal/bin - curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz - echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - + curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.7.3.0/cabal-plan-0.7.3.0-x86_64-linux.xz > cabal-plan.xz + echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan rm -f cabal-plan.xz chmod a+x $HOME/.cabal/bin/cabal-plan cabal-plan --version - name: checkout - uses: actions/checkout@v2 + uses: actions/checkout@v3 with: path: source - name: initial cabal.project for sdist @@ -200,13 +201,11 @@ jobs: run: | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all cabal-plan - - name: cache - uses: actions/cache@v2 + - name: restore cache + uses: actions/cache/restore@v3 with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} - path: | - ~/.cabal/store - ~/.cabal/packages + path: ~/.cabal/store restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- - name: install dependencies run: | @@ -218,3 +217,9 @@ jobs: - name: tests run: | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct + - name: save cache + uses: actions/cache/save@v3 + if: always() + with: + key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} + path: ~/.cabal/store diff --git a/.github/workflows/test-gibbon-examples.yml b/.github/workflows/test-gibbon-examples.yml index dcf7f100b..24370675a 100644 --- a/.github/workflows/test-gibbon-examples.yml +++ b/.github/workflows/test-gibbon-examples.yml @@ -1,21 +1,33 @@ name: Test Gibbon examples -on: - - push - - pull_request +on: [ push, pull_request ] jobs: linux: - name: test-gibbon-examples - runs-on: ubuntu-18.04 + name: test-gibbon + runs-on: ubuntu-22.04 steps: - name: dependencies run: | - sudo apt-get update - sudo apt-add-repository -y 'ppa:hvr/ghc' sudo apt-get update sudo add-apt-repository -y 'ppa:plt/racket' sudo apt-get update - sudo apt-get install -y libgc-dev libgmp-dev uthash-dev gcc-7 ghc-9.0.1 racket - sudo unlink /usr/bin/gcc && sudo ln -s /usr/bin/gcc-7 /usr/bin/gcc + sudo add-apt-repository -y ppa:ubuntu-toolchain-r/test + sudo apt update + sudo apt-get install -y libgc-dev libgmp-dev uthash-dev gcc-11 racket + sudo unlink /usr/bin/gcc && sudo ln -s /usr/bin/gcc-11 /usr/bin/gcc + - name: ghc and cabal + env: + HCKIND: ghc + HCVER: 9.0.1 + run: | + mkdir -p "$HOME/.ghcup/bin" + curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" + sudo chmod a+x "$HOME/.ghcup/bin/ghcup" + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + HC=$HOME/.ghcup/bin/$HCKIND-$HCVER + echo "HC=$HC" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" + echo "$HOME/.ghcup/bin/" >> $GITHUB_PATH - name: versions run: | ghc --version @@ -25,8 +37,8 @@ jobs: cabal --version - name: checkout uses: actions/checkout@v2 - - run: cabal v2-update -w /opt/ghc/9.0.1/bin/ghc - - run: cabal v2-freeze -w /opt/ghc/9.0.1/bin/ghc + - run: cabal v2-update -w $HC + - run: cabal v2-freeze -w $HC - name: cache-cabal uses: actions/cache@v3 with: @@ -40,8 +52,13 @@ jobs: - name: build run: | cd gibbon-compiler - cabal v2-update -w /opt/ghc/9.0.1/bin/ghc - cabal v2-build -w /opt/ghc/9.0.1/bin/ghc . + cabal v2-update -w $HC + cabal v2-build -w $HC . + - name: cache-answers + uses: actions/cache@v2 + with: + key: ${{ runner.os }}-answers + path: gibbon-compiler/examples/build_tmp/*.ans - name: answers run: | cd gibbon-compiler @@ -53,4 +70,4 @@ jobs: run: | export GIBBONDIR=`pwd` cd gibbon-compiler/ - cabal v2-exec -w /opt/ghc/9.0.1/bin/ghc test-gibbon-examples -- -v2 + cabal v2-exec -w $HC test-gibbon-examples -- -v2 diff --git a/gibbon-compiler/examples/gc/Reverse_master_1.c b/gibbon-compiler/examples/gc/Reverse_master_1.c index 7316b594d..10daff58a 100644 --- a/gibbon-compiler/examples/gc/Reverse_master_1.c +++ b/gibbon-compiler/examples/gc/Reverse_master_1.c @@ -180,47 +180,6 @@ void restore_alloc_state() {} #endif // BUMPALLOC -// ------------------------------------- -// Bump allocated nursery for regions -// ------------------------------------- - -// See https://github.com/iu-parfunc/gibbon/issues/122. - -__thread char* nursery_heap_ptr = (char*)NULL; -__thread char* nursery_heap_ptr_end = (char*)NULL; - -#define NURSERY_SIZE 0 -// #define NURSERY_SIZE global_init_biginf_buf_size -#define NURSERY_ALLOC_UPPER_BOUND 1024 - -static inline void init_nursery() { - nursery_heap_ptr = (char*)malloc(NURSERY_SIZE); - if (nursery_heap_ptr == NULL) { - printf("init_region: malloc failed: %d", NURSERY_SIZE); - exit(1); - } - nursery_heap_ptr_end = nursery_heap_ptr + NURSERY_SIZE; -#ifdef _DEBUG - printf("init_nursery: DONE, heap_ptr = %p\n", nursery_heap_ptr); -#endif -} - -static inline void* alloc_in_nursery(long long n) { - if (! nursery_heap_ptr) { - init_nursery(); - } - if (nursery_heap_ptr + n < nursery_heap_ptr_end) { - char* old = nursery_heap_ptr; - nursery_heap_ptr += n; -#ifdef _DEBUG - printf("alloc_in_nursery: DONE, %lld\n", n); -#endif - return old; - } else { - return NULL; - } -} - // ------------------------------------- // ALLOC and ALLOC_PACKED macros // ------------------------------------- @@ -228,7 +187,7 @@ static inline void* alloc_in_nursery(long long n) { /* -If parallelism is enabled, we always use a nursery/malloc based allocator +If parallelism is enabled, we always use a malloc based allocator since Boehm GC is not thread-safe in its default configuration. It can be made thread-safe by building it with appropriate flags, but we don't do that. Presently, all parallel pointer-based programs will leak memory. @@ -641,7 +600,7 @@ Garbage collection and for garbage collection. The footer: ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - serialized data | rf_reg_metadata_ptr | rf_seq_no | rf_nursery_allocated | rf_size | rf_next | rf_prev + serialized data | rf_reg_metadata_ptr | rf_seq_no | rf_size | rf_next | rf_prev ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The metadata after the serialized data serves various purposes: @@ -659,8 +618,6 @@ Garbage collection - rf_seq_no: The index of this particular chunk in the list. - - rf_nursery_allocated: Whether this chunk was allocated in a nursery. - - rf_size: Used during bounds checking to calculate the size of the next region in the linked list. @@ -710,7 +667,6 @@ typedef struct RegionFooter_struct { RegionTy *rf_reg_metadata_ptr; IntTy rf_seq_no; - bool rf_nursery_allocated; IntTy rf_size; struct RegionFooter_struct *rf_next; struct RegionFooter_struct *rf_prev; @@ -771,9 +727,7 @@ RegionTy *alloc_region(IntTy size) { // Allocate the first chunk. IntTy total_size = size + sizeof(RegionFooter); - CursorTy heap; - bool nursery_allocated = false; - heap = malloc(total_size); + CursorTy heap = ALLOC_PACKED_BIG(total_size); if (heap == NULL) { printf("alloc_region: malloc failed: %lld", total_size); exit(1); @@ -788,14 +742,13 @@ RegionTy *alloc_region(IntTy size) { reg->reg_outset_len = 0; #ifdef _DEBUG - printf("Allocated a region(%lld): %lld bytes, nursery=%d.\n", reg->reg_id, size, nursery_allocated); + printf("Allocated a region(%lld): %lld bytes.\n", reg->reg_id, size); #endif // Write the footer. RegionFooter *footer = (RegionFooter *) heap_end; footer->rf_reg_metadata_ptr = reg; footer->rf_seq_no = 1; - footer->rf_nursery_allocated = nursery_allocated; footer->rf_size = size; footer->rf_next = NULL; footer->rf_prev = NULL; @@ -834,7 +787,6 @@ ChunkTy alloc_chunk(CursorTy end_old_chunk) { RegionFooter* new_footer = (RegionFooter *) end; new_footer->rf_reg_metadata_ptr = footer->rf_reg_metadata_ptr; new_footer->rf_seq_no = footer->rf_seq_no + 1; - new_footer->rf_nursery_allocated = false; new_footer->rf_size = newsize; new_footer->rf_next = NULL; new_footer->rf_prev = footer; @@ -980,18 +932,14 @@ void free_region(CursorTy end_reg) { next_chunk = (char*) footer->rf_next; #ifdef _DEBUG - printf("free_region(%lld): first chunk in nursery: %d\n", - reg->reg_id, - first_chunk_footer->rf_nursery_allocated); + printf("free_region(%lld)\n", reg->reg_id); #endif - if (! first_chunk_footer->rf_nursery_allocated) { - #ifdef _DEBUG - num_freed_chunks++; - total_bytesize = total_bytesize + first_chunk_footer->rf_size; - #endif - free(first_chunk); - } +#ifdef _DEBUG + num_freed_chunks++; + total_bytesize = total_bytesize + first_chunk_footer->rf_size; +#endif + free(first_chunk); while (next_chunk != NULL) { next_chunk_footer = (RegionFooter *) next_chunk; diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1ContentSearch.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1ContentSearch.hs index 11a248e7a..052d2f28d 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1ContentSearch.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1ContentSearch.hs @@ -16,7 +16,7 @@ emphKeywordInContent keyword blogs = --_ = printPacked newContent --_ = printsym (quote "NEWLINE") newRst = emphKeywordInContent keyword rst - in Layout1 (header) (id) (author) (copyPacked date) (copyPacked newContent) (copyPacked tags) (copyPacked newRst) + in Layout1 header id author date newContent tags newRst -- main function gibbon_main = @@ -98,14 +98,14 @@ gibbon_main = ft10 = readArrayFile (Just ("blog10/blog10Tag.txt", 485)) lfc = mkListFiles fc1 fc2 fc3 fc4 fc5 fc6 fc7 fc8 fc9 fc10 9 ltc = mkListFiles ft1 ft2 ft3 ft4 ft5 ft6 ft7 ft8 ft9 ft10 9 - blogs = mkBlogs_layout1 lfc ltc 10000 - --_ = printPacked blogs - --_ = printsym (quote "NEWLINE") - --_ = printsym (quote "NEWLINE") + blogs = mkBlogs_layout1 lfc ltc 2 + _ = printPacked blogs + _ = printsym (quote "NEWLINE") + _ = printsym (quote "NEWLINE") keyword :: Vector Char keyword = "feelings" newblgs = iterate (emphKeywordInContent keyword blogs) - --_ = printPacked newblgs - --_ = printsym (quote "NEWLINE") - --_ = printsym (quote "NEWLINE") + _ = printPacked newblgs + _ = printsym (quote "NEWLINE") + _ = printsym (quote "NEWLINE") in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1DeleteTag.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1DeleteTag.hs index 9983e5604..999c2a09e 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1DeleteTag.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1DeleteTag.hs @@ -18,7 +18,7 @@ deleteKeywordInTagList keyword blogs = case blogs of --_ = printsym (quote "NEWLINE") --_ = printsym (quote "NEWLINE") newRst = deleteKeywordInTagList keyword rst - in Layout1 header id author date (copyPacked content) (copyPacked newTags) (copyPacked newRst) + in Layout1 header id author date content newTags newRst -- main function @@ -58,4 +58,4 @@ gibbon_main = --_ = printPacked newblgs --_ = printsym (quote "NEWLINE") --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1InsertTag.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1InsertTag.hs index cb3c5b950..958063769 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1InsertTag.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1InsertTag.hs @@ -21,7 +21,7 @@ insertKeywordInTagList keyword blogs = case blogs of newTags = insertBlogTags keyword tags newRst = insertKeywordInTagList keyword rst - in Layout1 header id author date (copyPacked content) (copyPacked newTags) (copyPacked newRst) + in Layout1 header id author date content newTags newRst -- main function gibbon_main = @@ -60,4 +60,4 @@ gibbon_main = --_ = printPacked newblgs --_ = printsym (quote "NEWLINE") --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1TagSearch.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1TagSearch.hs index bd40884ce..c5755ddf9 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1TagSearch.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1TagSearch.hs @@ -3,18 +3,31 @@ import GenerateLayout1 type Text = Vector Char +-- emphKeywordInTag :: Text -> Blog -> Blog +-- emphKeywordInTag keyword blogs = case blogs of +-- End -> End +-- Layout1 header id author date content tags rst -> let present = searchBlogTags keyword tags -- search the tags for the keyword +-- --_ = printsym (quote "NEWLINE") +-- --_ = printPacked id +-- --_ = printsym (quote " ") +-- --_ = printbool present +-- --_ = printsym (quote "NEWLINE") +-- newContent = emphasizeBlogContent keyword content present -- get the new content, this should be inlined +-- newRst = emphKeywordInTag keyword rst +-- in Layout1 header id author (copyPacked date) (copyPacked newContent) (copyPacked tags) (copyPacked newRst) + + emphKeywordInTag :: Text -> Blog -> Blog emphKeywordInTag keyword blogs = case blogs of End -> End - Layout1 header id author date content tags rst -> let present = searchBlogTags keyword tags -- search the tags for the keyword - --_ = printsym (quote "NEWLINE") - --_ = printPacked id - --_ = printsym (quote " ") - --_ = printbool present - --_ = printsym (quote "NEWLINE") - newContent = emphasizeBlogContent keyword content present -- get the new content, this should be inlined - newRst = emphKeywordInTag keyword rst - in Layout1 header id author (copyPacked date) (copyPacked newContent) (copyPacked tags) (copyPacked newRst) + Layout1 header id author date content tags rst -> let present = searchBlogTags keyword tags -- search the tags for the keyword + in if (present) + then let newContent = emphasizeBlogContent keyword content present + newRst = emphKeywordInTag keyword rst + in Layout1 header id author date newContent tags newRst + else + let newRst = emphKeywordInTag keyword rst + in Layout1 header id author date content tags newRst @@ -55,4 +68,4 @@ gibbon_main = --_ = printPacked newblgs --_ = printsym (quote "NEWLINE") --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2ContentSearch.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2ContentSearch.hs index 50bcc76fb..b6e436b42 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2ContentSearch.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2ContentSearch.hs @@ -10,7 +10,7 @@ emphKeywordInContent keyword blogs = Layout2 content tags rst header id author date -> let --present = searchBlogContent keyword content newContent = emphasizeBlogContent' keyword content newRst = emphKeywordInContent keyword rst - in Layout2 (newContent) (copyPacked tags) (copyPacked newRst) header id author date + in Layout2 newContent tags newRst header id author date -- main function gibbon_main = diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2DeleteTag.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2DeleteTag.hs index a79916b6a..78e17023e 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2DeleteTag.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2DeleteTag.hs @@ -10,7 +10,7 @@ deleteKeywordInTagList keyword blogs = case blogs of Layout2 content tags rst header id author date -> let newTags = deleteBlogTags keyword tags newRst = deleteKeywordInTagList keyword rst - in Layout2 (copyPacked content) (copyPacked newTags) (copyPacked newRst) header id author date + in Layout2 content newTags newRst header id author date -- main function @@ -50,4 +50,4 @@ gibbon_main = --_ = printPacked newblgs --_ = printsym (quote "NEWLINE") --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2InsertTag.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2InsertTag.hs index 0f330efa7..61a7d9d7b 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2InsertTag.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2InsertTag.hs @@ -10,7 +10,7 @@ insertKeywordInTagList keyword blogs = case blogs of Layout2 content tags rst header id author date -> let newTags = insertBlogTags keyword tags newRst = insertKeywordInTagList keyword rst - in Layout2 (copyPacked content) (copyPacked newTags) (copyPacked newRst) header id author date + in Layout2 content newTags newRst header id author date -- main function @@ -50,4 +50,4 @@ gibbon_main = --_ = printPacked newblgs --_ = printsym (quote "NEWLINE") --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2TagSearch.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2TagSearch.hs index 0faa66872..583cd4bfd 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2TagSearch.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2TagSearch.hs @@ -7,15 +7,14 @@ type Text = Vector Char emphKeywordInTag :: Text -> Blog -> Blog emphKeywordInTag keyword blogs = case blogs of End -> End - Layout2 content tags rst header id author date -> let present = searchBlogTags keyword tags -- search the tags for the keyword - --_ = printsym (quote "NEWLINE") - --_ = printPacked id - --_ = printsym (quote " ") - --_ = printbool present - --_ = printsym (quote "NEWLINE") - newContent = emphasizeBlogContent keyword content present -- get the new content, this should be inlined - newRst = emphKeywordInTag keyword rst - in Layout2 (newContent) (copyPacked tags) (copyPacked newRst) header id author date + Layout2 content tags rst header id author date -> let present = searchBlogTags keyword tags -- search the tags for the keyword + in if (present) + then let newContent = emphasizeBlogContent keyword content present + newRst = emphKeywordInTag keyword rst + in Layout2 newContent tags newRst header id author date + else + let newRst = emphKeywordInTag keyword rst + in Layout2 content tags newRst header id author date @@ -45,14 +44,14 @@ gibbon_main = ft10 = readArrayFile (Just ("blog10/blog10Tag.txt", 485)) lfc = mkListFiles fc1 fc2 fc3 fc4 fc5 fc6 fc7 fc8 fc9 fc10 9 ltc = mkListFiles ft1 ft2 ft3 ft4 ft5 ft6 ft7 ft8 ft9 ft10 9 - blogs = mkBlogs_layout2 lfc ltc 10000 - --_ = printPacked blogs - --_ = printsym (quote "NEWLINE") - --_ = printsym (quote "NEWLINE") + blogs = mkBlogs_layout2 lfc ltc 2 + _ = printPacked blogs + _ = printsym (quote "NEWLINE") + _ = printsym (quote "NEWLINE") keyword :: Vector Char keyword = "31517" newblgs = iterate (emphKeywordInTag keyword blogs) - --_ = printPacked newblgs - --_ = printsym (quote "NEWLINE") - --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + _ = printPacked newblgs + _ = printsym (quote "NEWLINE") + _ = printsym (quote "NEWLINE") + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout3ContentSearch.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout3ContentSearch.hs index 6e51b46be..9f5d79d91 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout3ContentSearch.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout3ContentSearch.hs @@ -10,7 +10,7 @@ emphKeywordInContent keyword blogs = Layout3 tags rst content header id author date -> let --present = searchBlogContent keyword content newContent = emphasizeBlogContent' keyword content newRst = emphKeywordInContent keyword rst - in Layout3 (copyPacked tags) (copyPacked newRst) (copyPacked newContent) header id author date + in Layout3 tags newRst newContent header id author date -- main function diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout3TagSearch.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout3TagSearch.hs index c88fc788c..64574f2c9 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout3TagSearch.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout3TagSearch.hs @@ -8,14 +8,15 @@ emphKeywordInTag :: Text -> Blog -> Blog emphKeywordInTag keyword blogs = case blogs of End -> End Layout3 tags rst content header id author date -> let present = searchBlogTags keyword tags -- search the tags for the keyword - --_ = printsym (quote "NEWLINE") - --_ = printPacked id - --_ = printsym (quote " ") - --_ = printbool present - --_ = printsym (quote "NEWLINE") - newContent = emphasizeBlogContent keyword content present -- get the new content, this should be inlined - newRst = emphKeywordInTag keyword rst - in Layout3 (copyPacked tags) (copyPacked newRst) (copyPacked newContent) header id author date + in if present then + let + newContent = emphasizeBlogContent keyword content present -- get the new content, this should be inlined + newRst = emphKeywordInTag keyword rst + in Layout3 tags newRst newContent header id author date + else + let + newRst = emphKeywordInTag keyword rst + in Layout3 tags newRst content header id author date @@ -46,14 +47,14 @@ gibbon_main = ft10 = readArrayFile (Just ("blog10/blog10Tag.txt", 485)) lfc = mkListFiles fc1 fc2 fc3 fc4 fc5 fc6 fc7 fc8 fc9 fc10 9 ltc = mkListFiles ft1 ft2 ft3 ft4 ft5 ft6 ft7 ft8 ft9 ft10 9 - blogs = mkBlogs_layout3 lfc ltc 10000 - --_ = printPacked blogs - --_ = printsym (quote "NEWLINE") - --_ = printsym (quote "NEWLINE") + blogs = mkBlogs_layout3 lfc ltc 2 + _ = printPacked blogs + _ = printsym (quote "NEWLINE") + _ = printsym (quote "NEWLINE") keyword :: Vector Char keyword = "31517" newblgs = iterate (emphKeywordInTag keyword blogs) - --_ = printPacked newblgs - --_ = printsym (quote "NEWLINE") - --_ = printsym (quote "NEWLINE") + _ = printPacked newblgs + _ = printsym (quote "NEWLINE") + _ = printsym (quote "NEWLINE") in () \ No newline at end of file diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout4ContentSearch.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout4ContentSearch.hs index f102bb385..6d754f9b5 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout4ContentSearch.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout4ContentSearch.hs @@ -10,7 +10,7 @@ emphKeywordInContent keyword blogs = Layout4 tags content rst header id author date -> let --present = searchBlogContent keyword content newContent = emphasizeBlogContent' keyword content --present newRst = emphKeywordInContent keyword rst - in Layout4 (copyPacked tags) (copyPacked newContent) (copyPacked newRst) (header) id author date + in Layout4 tags newContent newRst header id author date -- main function diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout4TagSearch.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout4TagSearch.hs index 4a3e1a593..d949f1b02 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout4TagSearch.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout4TagSearch.hs @@ -7,15 +7,14 @@ type Text = Vector Char emphKeywordInTag :: Text -> Blog -> Blog emphKeywordInTag keyword blogs = case blogs of End -> End - Layout4 tags content rst header id author date -> let present = searchBlogTags keyword tags -- search the tags for the keyword - --_ = printsym (quote "NEWLINE") - --_ = printPacked id - --_ = printsym (quote " ") - --_ = printbool present - --_ = printsym (quote "NEWLINE") - newContent = emphasizeBlogContent keyword content present -- get the new content, this should be inlined - newRst = emphKeywordInTag keyword rst - in Layout4 (copyPacked tags) (copyPacked newContent) (copyPacked newRst) (header) id author date + Layout4 tags content rst header id author date -> let present = searchBlogTags keyword tags + in if (present) then + let newContent = emphasizeBlogContent keyword content present + newRst = emphKeywordInTag keyword rst + in Layout4 tags newContent newRst header id author date + else + let newRst = emphKeywordInTag keyword rst + in Layout4 tags content newRst header id author date @@ -46,14 +45,14 @@ gibbon_main = ft10 = readArrayFile (Just ("blog10/blog10Tag.txt", 485)) lfc = mkListFiles fc1 fc2 fc3 fc4 fc5 fc6 fc7 fc8 fc9 fc10 9 ltc = mkListFiles ft1 ft2 ft3 ft4 ft5 ft6 ft7 ft8 ft9 ft10 9 - blogs = mkBlogs_layout4 lfc ltc 10000 - --_ = printPacked blogs - --_ = printsym (quote "NEWLINE") - --_ = printsym (quote "NEWLINE") + blogs = mkBlogs_layout4 lfc ltc 2 + _ = printPacked blogs + _ = printsym (quote "NEWLINE") + _ = printsym (quote "NEWLINE") keyword :: Vector Char keyword = "31517" newblgs = iterate (emphKeywordInTag keyword blogs) - --_ = printPacked newblgs - --_ = printsym (quote "NEWLINE") - --_ = printsym (quote "NEWLINE") + _ = printPacked newblgs + _ = printsym (quote "NEWLINE") + _ = printsym (quote "NEWLINE") in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout5ContentSearch.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout5ContentSearch.hs index 9d493c89c..049fd7e18 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout5ContentSearch.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout5ContentSearch.hs @@ -10,7 +10,7 @@ emphKeywordInContent keyword blogs = Layout5 rst tags content header id author date -> let --present = searchBlogContent keyword content newContent = emphasizeBlogContent' keyword content --present newRst = emphKeywordInContent keyword rst - in Layout5 (newRst) (copyPacked tags) (copyPacked newContent) (header) id author date + in Layout5 newRst tags newContent header id author date diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout5DeleteTag.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout5DeleteTag.hs index 1603e6037..933ca9da6 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout5DeleteTag.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout5DeleteTag.hs @@ -10,7 +10,7 @@ deleteKeywordInTagList keyword blogs = case blogs of Layout5 rst tags content header id author date -> let newTags = deleteBlogTags keyword tags newRst = deleteKeywordInTagList keyword rst - in Layout5 newRst (copyPacked newTags) (copyPacked content) header id author date + in Layout5 newRst newTags content header id author date -- main function @@ -50,4 +50,4 @@ gibbon_main = --_ = printPacked newblgs --_ = printsym (quote "NEWLINE") --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout5InsertTag.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout5InsertTag.hs index 7b663489c..0221bf1fa 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout5InsertTag.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout5InsertTag.hs @@ -10,7 +10,7 @@ insertKeywordInTagList keyword blogs = case blogs of Layout5 rst tags content header id author date -> let newTags = insertBlogTags keyword tags newRst = insertKeywordInTagList keyword rst - in Layout5 newRst (copyPacked newTags) (copyPacked content) header id author date + in Layout5 newRst newTags content header id author date -- main function @@ -50,4 +50,4 @@ gibbon_main = --_ = printPacked newblgs --_ = printsym (quote "NEWLINE") --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout5TagSearch.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout5TagSearch.hs index 18ee25657..1dd9e67b5 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout5TagSearch.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout5TagSearch.hs @@ -9,14 +9,13 @@ emphKeywordInTag :: Text -> Blog -> Blog emphKeywordInTag keyword blogs = case blogs of End -> End Layout5 rst tags content header id author date -> let present = searchBlogTags keyword tags -- search the tags for the keyword - --_ = printsym (quote "NEWLINE") - --_ = printPacked id - --_ = printsym (quote " ") - --_ = printbool present - --_ = printsym (quote "NEWLINE") - newContent = emphasizeBlogContent keyword content present -- get the new content, this should be inlined - newRst = emphKeywordInTag keyword rst - in Layout5 (newRst) (copyPacked tags) (copyPacked newContent) (header) id author date + in if present then + let newContent = emphasizeBlogContent keyword content present -- get the new content, this should be inlined + newRst = emphKeywordInTag keyword rst + in Layout5 newRst tags newContent header id author date + else + let newRst = emphKeywordInTag keyword rst + in Layout5 newRst tags content header id author date gibbon_main = @@ -45,14 +44,14 @@ gibbon_main = ft10 = readArrayFile (Just ("blog10/blog10Tag.txt", 485)) lfc = mkListFiles fc1 fc2 fc3 fc4 fc5 fc6 fc7 fc8 fc9 fc10 9 ltc = mkListFiles ft1 ft2 ft3 ft4 ft5 ft6 ft7 ft8 ft9 ft10 9 - blogs = mkBlogs_layout5 lfc ltc 10000 - --_ = printPacked blogs - --_ = printsym (quote "NEWLINE") - --_ = printsym (quote "NEWLINE") + blogs = mkBlogs_layout5 lfc ltc 2 + _ = printPacked blogs + _ = printsym (quote "NEWLINE") + _ = printsym (quote "NEWLINE") keyword :: Vector Char keyword = "31517" newblgs = iterate (emphKeywordInTag keyword blogs) - --_ = printPacked newblgs - --_ = printsym (quote "NEWLINE") - --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + _ = printPacked newblgs + _ = printsym (quote "NEWLINE") + _ = printsym (quote "NEWLINE") + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout6ContentSearch.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout6ContentSearch.hs index 052f4b6b6..5f8fdef66 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout6ContentSearch.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout6ContentSearch.hs @@ -10,7 +10,7 @@ emphKeywordInContent keyword blogs = Layout6 header id author date content rst tags -> let --present = searchBlogContent keyword content newContent = emphasizeBlogContent' keyword content --present newRst = emphKeywordInContent keyword rst - in Layout6 header id author (copyPacked date) (copyPacked newContent) (copyPacked newRst) (tags) + in Layout6 header id author date newContent newRst tags diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout6DeleteTag.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout6DeleteTag.hs index ee1fc7e05..bee65a933 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout6DeleteTag.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout6DeleteTag.hs @@ -10,7 +10,7 @@ deleteKeywordInTagList keyword blogs = case blogs of Layout6 header id author date content rst tags -> let newTags = deleteBlogTags keyword tags newRst = deleteKeywordInTagList keyword rst - in Layout6 header id author date content (copyPacked newRst) (copyPacked newTags) + in Layout6 header id author date content newRst newTags -- main function @@ -50,4 +50,4 @@ gibbon_main = --_ = printPacked newblgs --_ = printsym (quote "NEWLINE") --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout6InsertTag.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout6InsertTag.hs index f8d796139..9b7b1b793 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout6InsertTag.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout6InsertTag.hs @@ -10,7 +10,7 @@ insertKeywordInTagList keyword blogs = case blogs of Layout6 header id author date content rst tags -> let newTags = insertBlogTags keyword tags newRst = insertKeywordInTagList keyword rst - in Layout6 header id author date content (copyPacked newRst) (copyPacked newTags) + in Layout6 header id author date content newRst newTags -- main function @@ -50,4 +50,4 @@ gibbon_main = --_ = printPacked newblgs --_ = printsym (quote "NEWLINE") --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout6TagSearch.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout6TagSearch.hs index ea4f023a8..030fc0095 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout6TagSearch.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout6TagSearch.hs @@ -9,14 +9,14 @@ emphKeywordInTag :: Text -> Blog -> Blog emphKeywordInTag keyword blogs = case blogs of End -> End Layout6 header id author date content rst tags -> let present = searchBlogTags keyword tags -- search the tags for the keyword - --_ = printsym (quote "NEWLINE") - --_ = printPacked id - --_ = printsym (quote " ") - --_ = printbool present - --_ = printsym (quote "NEWLINE") - newContent = emphasizeBlogContent keyword content present -- get the new content, this should be inlined - newRst = emphKeywordInTag keyword rst - in Layout6 header id author (copyPacked date) (copyPacked newContent) (copyPacked newRst) (tags) + in if present then + let newContent = emphasizeBlogContent keyword content present -- get the new content, this should be inlined + newRst = emphKeywordInTag keyword rst + in Layout6 header id author date newContent newRst tags + else + let newRst = emphKeywordInTag keyword rst + in Layout6 header id author date content newRst tags + gibbon_main = @@ -45,14 +45,14 @@ gibbon_main = ft10 = readArrayFile (Just ("blog10/blog10Tag.txt", 485)) lfc = mkListFiles fc1 fc2 fc3 fc4 fc5 fc6 fc7 fc8 fc9 fc10 9 ltc = mkListFiles ft1 ft2 ft3 ft4 ft5 ft6 ft7 ft8 ft9 ft10 9 - blogs = mkBlogs_layout6 lfc ltc 10000 - --_ = printPacked blogs - --_ = printsym (quote "NEWLINE") - --_ = printsym (quote "NEWLINE") + blogs = mkBlogs_layout6 lfc ltc 2 + _ = printPacked blogs + _ = printsym (quote "NEWLINE") + _ = printsym (quote "NEWLINE") keyword :: Vector Char keyword = "31517" newblgs = iterate (emphKeywordInTag keyword blogs) - --_ = printPacked newblgs - --_ = printsym (quote "NEWLINE") - --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + _ = printPacked newblgs + _ = printsym (quote "NEWLINE") + _ = printsym (quote "NEWLINE") + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout7ContentSearch.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout7ContentSearch.hs index 2e4e75a30..ae6434a15 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout7ContentSearch.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout7ContentSearch.hs @@ -10,7 +10,7 @@ emphKeywordInContent keyword blogs = Layout7 rst content header id author date tags -> let --present = searchBlogContent keyword content newContent = emphasizeBlogContent' keyword content --present newRst = emphKeywordInContent keyword rst - in Layout7 newRst (copyPacked newContent) (header) id author date tags + in Layout7 newRst newContent header id author date tags @@ -58,4 +58,4 @@ gibbon_main = --_ = printPacked newblgs --_ = printsym (quote "NEWLINE") --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout7DeleteTag.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout7DeleteTag.hs index c86aad04a..9eaa9dd7b 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout7DeleteTag.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout7DeleteTag.hs @@ -10,7 +10,7 @@ deleteKeywordInTagList keyword blogs = case blogs of Layout7 rst content header id author date tags -> let newTags = deleteBlogTags keyword tags newRst = deleteKeywordInTagList keyword rst - in Layout7 (newRst) (copyPacked content) header id author (copyPacked date) (copyPacked newTags) + in Layout7 newRst content header id author date newTags -- main function @@ -50,4 +50,4 @@ gibbon_main = --_ = printPacked newblgs --_ = printsym (quote "NEWLINE") --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout7InsertTag.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout7InsertTag.hs index 96775a13a..ea50d3841 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout7InsertTag.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout7InsertTag.hs @@ -10,7 +10,7 @@ insertKeywordInTagList keyword blogs = case blogs of Layout7 rst content header id author date tags -> let newTags = insertBlogTags keyword tags newRst = insertKeywordInTagList keyword rst - in Layout7 (newRst) (copyPacked content) header id author (copyPacked date) (copyPacked newTags) + in Layout7 newRst content header id author date newTags -- main function @@ -50,4 +50,4 @@ gibbon_main = --_ = printPacked newblgs --_ = printsym (quote "NEWLINE") --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout7TagSearch.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout7TagSearch.hs index 4392117a6..b2f7606bb 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout7TagSearch.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout7TagSearch.hs @@ -8,14 +8,14 @@ emphKeywordInTag :: Text -> Blog -> Blog emphKeywordInTag keyword blogs = case blogs of End -> End Layout7 rst content header id author date tags -> let present = searchBlogTags keyword tags -- search the tags for the keyword - --_ = printsym (quote "NEWLINE") - --_ = printPacked id - --_ = printsym (quote " ") - --_ = printbool present - --_ = printsym (quote "NEWLINE") - newContent = emphasizeBlogContent keyword content present -- get the new content, this should be inlined - newRst = emphKeywordInTag keyword rst - in Layout7 newRst (copyPacked newContent) (header) id author date tags + in if present then + let newContent = emphasizeBlogContent keyword content present -- get the new content, this should be inlined + newRst = emphKeywordInTag keyword rst + in Layout7 newRst newContent header id author date tags + else + let newRst = emphKeywordInTag keyword rst + in Layout7 newRst content header id author date tags + gibbon_main = let @@ -43,14 +43,14 @@ gibbon_main = ft10 = readArrayFile (Just ("blog10/blog10Tag.txt", 485)) lfc = mkListFiles fc1 fc2 fc3 fc4 fc5 fc6 fc7 fc8 fc9 fc10 9 ltc = mkListFiles ft1 ft2 ft3 ft4 ft5 ft6 ft7 ft8 ft9 ft10 9 - blogs = mkBlogs_layout7 lfc ltc 10000 - --_ = printPacked blogs - --_ = printsym (quote "NEWLINE") - --_ = printsym (quote "NEWLINE") + blogs = mkBlogs_layout7 lfc ltc 2 + _ = printPacked blogs + _ = printsym (quote "NEWLINE") + _ = printsym (quote "NEWLINE") keyword :: Vector Char keyword = "31517" newblgs = iterate (emphKeywordInTag keyword blogs) - --_ = printPacked newblgs - --_ = printsym (quote "NEWLINE") - --_ = printsym (quote "NEWLINE") + _ = printPacked newblgs + _ = printsym (quote "NEWLINE") + _ = printsym (quote "NEWLINE") in () \ No newline at end of file diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout8DeleteTag.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout8DeleteTag.hs index 970a8ea54..72c712452 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout8DeleteTag.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout8DeleteTag.hs @@ -10,7 +10,7 @@ deleteKeywordInTagList keyword blogs = case blogs of Layout8 content rst id author date header tags -> let newTags = deleteBlogTags keyword tags newRst = deleteKeywordInTagList keyword rst - in Layout8 content newRst id author date (copyPacked header) (copyPacked newTags) + in Layout8 content newRst id author date header newTags -- main function @@ -50,4 +50,4 @@ gibbon_main = --_ = printPacked newblgs --_ = printsym (quote "NEWLINE") --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout8InsertTag.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout8InsertTag.hs index d0eb6b0cc..31040f79b 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout8InsertTag.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout8InsertTag.hs @@ -10,7 +10,7 @@ insertKeywordInTagList keyword blogs = case blogs of Layout8 content rst id author date header tags -> let newTags = insertBlogTags keyword tags newRst = insertKeywordInTagList keyword rst - in Layout8 content newRst id author date (copyPacked header) (copyPacked newTags) + in Layout8 content newRst id author date header newTags -- main function @@ -50,4 +50,4 @@ gibbon_main = --_ = printPacked newblgs --_ = printsym (quote "NEWLINE") --_ = printsym (quote "NEWLINE") - in () \ No newline at end of file + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout8TagSearch.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout8TagSearch.hs index 2144a090f..ee8acaea7 100644 --- a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout8TagSearch.hs +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout8TagSearch.hs @@ -9,14 +9,14 @@ emphKeywordInTag :: Text -> Blog -> Blog emphKeywordInTag keyword blogs = case blogs of End -> End Layout8 content rst id author date header tags -> let present = searchBlogTags keyword tags -- search the tags for the keyword - --_ = printsym (quote "NEWLINE") - --_ = printPacked id - --_ = printsym (quote " ") - --_ = printbool present - --_ = printsym (quote "NEWLINE") - newContent = emphasizeBlogContent keyword content present -- get the new content, this should be inlined - newRst = emphKeywordInTag keyword rst - in Layout8 newContent newRst id author date header tags + in if present then + let newContent = emphasizeBlogContent keyword content present -- get the new content, this should be inlined + newRst = emphKeywordInTag keyword rst + in Layout8 newContent newRst id author date header tags + else + let newRst = emphKeywordInTag keyword rst + in Layout8 content newRst id author date header tags + gibbon_main = let @@ -44,14 +44,14 @@ gibbon_main = ft10 = readArrayFile (Just ("blog10/blog10Tag.txt", 485)) lfc = mkListFiles fc1 fc2 fc3 fc4 fc5 fc6 fc7 fc8 fc9 fc10 9 ltc = mkListFiles ft1 ft2 ft3 ft4 ft5 ft6 ft7 ft8 ft9 ft10 9 - blogs = mkBlogs_layout8 lfc ltc 10000 - --_ = printPacked blogs - --_ = printsym (quote "NEWLINE") - --_ = printsym (quote "NEWLINE") + blogs = mkBlogs_layout8 lfc ltc 2 + _ = printPacked blogs + _ = printsym (quote "NEWLINE") + _ = printsym (quote "NEWLINE") keyword :: Vector Char keyword = "31517" newblgs = iterate (emphKeywordInTag keyword blogs) - --_ = printPacked newblgs - --_ = printsym (quote "NEWLINE") - --_ = printsym (quote "NEWLINE") + _ = printPacked newblgs + _ = printsym (quote "NEWLINE") + _ = printsym (quote "NEWLINE") in () \ No newline at end of file diff --git a/gibbon-compiler/examples/rbty.hs b/gibbon-compiler/examples/rbty.hs new file mode 100644 index 000000000..111764898 --- /dev/null +++ b/gibbon-compiler/examples/rbty.hs @@ -0,0 +1,160 @@ +-- Written by jazullo. + +import Gibbon.Maybe + +data B = B Bool + +tru :: B +tru = B True + +fal :: B +fal = B False + +unB :: B -> Bool +unB bPacked = case bPacked of + B b -> b + +data I = I Int +data O = Lt | Eq | Gt + +unI :: I -> Int +unI iPacked = case iPacked of + I i -> i + +cmp :: I -> I -> O +cmp ip1 ip2 = + let + i1 = unI ip1 + i2 = unI ip2 + in if i1 < i2 then Lt + else if i1 > i2 then Gt + else Eq + +data RBT + = Empty + | Node B I RBT RBT + + +empty :: RBT +empty = Empty + +singleton :: I -> RBT +singleton x = Node tru x Empty Empty + +insert :: I -> RBT -> RBT +insert e1 t = case t of + Empty -> singleton e1 + Node colorx x left right -> + flipColors (rotateRight (rotateLeft (case cmp x e1 of + Gt -> Node colorx x left (insert e1 right) + Lt -> Node colorx x (insert e1 left) right + Eq -> t + ))) + +rotateLeft :: RBT -> RBT +rotateLeft t = case t of + Empty -> Empty + Node colorx x leftx rightx -> case rightx of + Empty -> t + Node c z leftz rightz -> + if isRed rightx && isBlack leftx + then Node colorx z (Node tru x leftx leftz) rightz + else t + +rotateRight :: RBT -> RBT +rotateRight t = case t of + Empty -> Empty + Node colorx x leftx rightx -> case leftx of + Empty -> t + Node c y lefty righty -> + if isRed leftx && isRed lefty + then Node colorx y lefty (Node tru x righty rightx) + else t + +flipColors :: RBT -> RBT +flipColors t = case t of + Empty -> Empty + Node c x leftx rightx -> case leftx of + Empty -> t + Node c1 y lefty righty -> case rightx of + Empty -> t + Node c2 z leftz rightz -> + if isRed leftx && isRed rightx + then Node tru x (Node fal y lefty righty) (Node fal z leftz rightz) + else t + +isRed :: RBT -> Bool +isRed t = case t of + Empty -> False + Node c1 x l r -> unB c1 + +isBlack :: RBT -> Bool +isBlack t = case t of + Empty -> True + Node c1 x l r -> if unB c1 then False else True + +ins :: Int -> RBT -> RBT +ins x t = insert (I x) (copyPacked t) + +mini :: RBT -> I +mini t = case t of + Empty -> I (0 - 1) + Node c x l r -> case l of + Empty -> x + Node cl xl ll rl -> mini l + +-------------------------------------------------------------------------------- + +not :: Bool -> Bool +not b = + if b then False else True + +checkBlackHeight :: RBT -> Maybe Int +checkBlackHeight tree = + case tree of + Empty -> Just 1 + Node c x l r -> + let mb_lh = checkBlackHeight l + mb_rh = checkBlackHeight r in + case mb_lh of + Nothing -> Nothing + Just lh -> case mb_rh of + Nothing -> Nothing + Just rh -> if not (lh == rh) + then Nothing + else if isBlack tree + then Just (lh + 1) + else if (isBlack l) && (isBlack r) + then Nothing + else Just lh + +checkTree :: RBT -> Bool +checkTree root = +{- + +-- True if the given list is ordered +isSorted :: Ord a => [a] -> Bool +isSorted = undefined + +-- True if every red node only has black children +checkRedParents :: RBTree a -> Bool +checkRedParents = undefined + +-} + -- isSorted (inorder root) && + -- checkRedParents root && + isJust (checkBlackHeight root) && + isBlack root + + + +gibbon_main = + let + t1 = ins 5 empty + t2 = ins 3 t1 + t3 = ins 8 t2 + t4 = ins 9 t3 + t5 = ins 4 t4 + t6 = ins 1 t5 + _ = printPacked t6 + in checkTree t6 diff --git a/gibbon-compiler/examples/rbty_ghc.hs b/gibbon-compiler/examples/rbty_ghc.hs new file mode 100644 index 000000000..1a8071411 --- /dev/null +++ b/gibbon-compiler/examples/rbty_ghc.hs @@ -0,0 +1,154 @@ +-- Written by jazullo. +import Data.Maybe (isJust) + +data B = B Bool deriving Show + +tru :: B +tru = B True + +fal :: B +fal = B False + +unB :: B -> Bool +unB bPacked = case bPacked of + B b -> b + +data I = I Int deriving Show +data O = Lt | Eq | Gt deriving Show + +unI :: I -> Int +unI iPacked = case iPacked of + I i -> i + +cmp :: I -> I -> O +cmp ip1 ip2 = + let + i1 = unI ip1 + i2 = unI ip2 + in if i1 < i2 then Lt + else if i1 > i2 then Gt + else Eq + +data RBT + = Empty + | Node B I RBT RBT + deriving Show + +empty :: RBT +empty = Empty + +singleton :: I -> RBT +singleton x = Node tru x Empty Empty + +insert :: I -> RBT -> RBT +insert e1 t = case t of + Empty -> singleton e1 + Node colorx x left right -> + flipColors (rotateRight (rotateLeft (case cmp x e1 of + Gt -> Node colorx x left (insert e1 right) + Lt -> Node colorx x (insert e1 left) right + Eq -> t + ))) + +rotateLeft :: RBT -> RBT +rotateLeft t = case t of + Empty -> Empty + Node colorx x leftx rightx -> case rightx of + Empty -> t + Node c z leftz rightz -> + if isRed rightx && isBlack leftx + then Node colorx z (Node tru x leftx leftz) rightz + else t + +rotateRight :: RBT -> RBT +rotateRight t = case t of + Empty -> Empty + Node colorx x leftx rightx -> case leftx of + Empty -> t + Node c y lefty righty -> + if isRed leftx && isRed lefty + then Node colorx y lefty (Node tru x righty rightx) + else t + +flipColors :: RBT -> RBT +flipColors t = case t of + Empty -> Empty + Node c x leftx rightx -> case leftx of + Empty -> t + Node c1 y lefty righty -> case rightx of + Empty -> t + Node c2 z leftz rightz -> + if isRed leftx && isRed rightx + then Node tru x (Node fal y lefty righty) (Node fal z leftz rightz) + else t + +isRed :: RBT -> Bool +isRed t = case t of + Empty -> False + Node c1 x l r -> unB c1 + +isBlack :: RBT -> Bool +isBlack t = case t of + Empty -> True + Node c1 x l r -> if unB c1 then False else True + +ins :: Int -> RBT -> RBT +ins x t = insert (I x) t + +mini :: RBT -> I +mini t = case t of + Empty -> I (0 - 1) + Node c x l r -> case l of + Empty -> x + Node cl xl ll rl -> mini l + +-------------------------------------------------------------------------------- + +checkBlackHeight :: RBT -> Maybe Int +checkBlackHeight tree = + case tree of + Empty -> Just 1 + Node c x l r -> + let mb_lh = checkBlackHeight l + mb_rh = checkBlackHeight r in + case mb_lh of + Nothing -> Nothing + Just lh -> case mb_rh of + Nothing -> Nothing + Just rh -> if not (lh == rh) + then Nothing + else if isBlack tree + then Just (lh + 1) + else if (isBlack l) && (isBlack r) + then Nothing + else Just lh + +checkTree :: RBT -> Bool +checkTree root = +{- + +-- True if the given list is ordered +isSorted :: Ord a => [a] -> Bool +isSorted = undefined + +-- True if every red node only has black children +checkRedParents :: RBTree a -> Bool +checkRedParents = undefined + +-} + -- isSorted (inorder root) && + -- checkRedParents root && + isJust (checkBlackHeight root) && + isBlack root + +main = + let + t1 = ins 5 empty + t2 = ins 3 t1 + t3 = ins 8 t2 + t4 = ins 9 t3 + t5 = ins 4 t4 + t6 = ins 1 t5 + in do + print t6 + print (checkTree t6) diff --git a/gibbon-compiler/examples/test_191.ans b/gibbon-compiler/examples/test_191.ans new file mode 100644 index 000000000..1828a9fee --- /dev/null +++ b/gibbon-compiler/examples/test_191.ans @@ -0,0 +1 @@ +(Cons 12 ->i (I 2) (Cons 12 ->i (I 1) (Nil)))'#() diff --git a/gibbon-compiler/examples/test_191.hs b/gibbon-compiler/examples/test_191.hs new file mode 100644 index 000000000..ac775a572 --- /dev/null +++ b/gibbon-compiler/examples/test_191.hs @@ -0,0 +1,27 @@ +data Integer = I Int +data Lst = Cons Int Integer Lst | Nil + +foo :: Lst -> Lst +foo lst = case lst of + Nil -> Nil + Cons v1 v2 rst -> if (v1 == 0) + then let val = 10 + rst' = foo rst + in Cons val v2 rst' + else let val = 12 + rst' = foo rst + in Cons val v2 rst' + +mkList :: Int -> Lst +mkList len = if len <= 0 + then Nil + else + let rst = mkList (len-1) + in Cons len (I len) rst + +gibbon_main = + let + lst = mkList 2 + lst' = foo lst + _ = printPacked lst' + in () diff --git a/gibbon-compiler/src/Gibbon/Common.hs b/gibbon-compiler/src/Gibbon/Common.hs index f72f8b832..85c5993ad 100644 --- a/gibbon-compiler/src/Gibbon/Common.hs +++ b/gibbon-compiler/src/Gibbon/Common.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} @@ -38,10 +37,10 @@ where import Control.DeepSeq (NFData(..), force) import Control.Exception (evaluate) -#if !MIN_VERSION_base(4,13,0) --- https://downloads.haskell.org/ghc/8.8.1/docs/html/users_guide/8.8.1-notes.html -import Control.Monad.Fail(MonadFail(..)) -#endif + + + + import Control.Monad.State.Strict import Control.Monad.Reader import Data.Functor.Foldable @@ -76,10 +75,10 @@ instance Out Var where docPrec n v = docPrec n (fromVar v) instance NFData Var where - rnf = (rnf . fromVar) + rnf = rnf . fromVar instance ToIdent Var where - toIdent = (toIdent . fromVar) + toIdent = toIdent . fromVar instance IsString Var where fromString = toVar @@ -102,7 +101,7 @@ cleanFunName f = toVar [ if isNumber c || isAlpha c then c else '_' - | c <- (fromVar f) ] + | c <- fromVar f ] toEndV :: Var -> Var toEndV = varAppend "end_" @@ -125,7 +124,7 @@ instance Out TyVar where doc (SkolemTv s v) = text s <+> text "sk:" PP.<> doc v doc (UserTv v) = text "u:" PP.<> doc v - docPrec _ v = doc v + docPrec _ = doc isUserTv :: TyVar -> Bool isUserTv tv = @@ -151,7 +150,7 @@ gensym :: MonadState Int m => Var -> m Var gensym v = state (\n -> (cleanFunName v `varAppend` "_" `varAppend` toVar (show n), n + 1)) gensym_tag :: MonadState Int m => Var -> String -> m Var -gensym_tag v str = state (\n -> (cleanFunName v `varAppend` toVar ((show n)++ str) , n + 1)) +gensym_tag v str = state (\n -> (cleanFunName v `varAppend` toVar (show n ++ str) , n + 1)) -- | An infinite alphabet generator: 'a','b', ... ,'z','a0', ... genLetter :: MonadState Int m => m Var @@ -188,7 +187,7 @@ defaultPackedRunPassM = runPassM (defaultConfig { dynflags = dflags}) 0 where dflags = gopt_set Opt_Packed defaultDynFlags getDynFlags :: MonadReader Config m => m DynFlags -getDynFlags = dynflags <$> ask +getDynFlags = asks dynflags getGibbonConfig :: MonadReader Config m => m Config getGibbonConfig = ask @@ -382,6 +381,7 @@ cataM alg = c where -------------------------------------------------------------------------------- theEnv :: [(String, String)] +{-# NOINLINE theEnv #-} theEnv = unsafePerformIO getEnvironment -- | Debugging flag shared by all modules. @@ -440,7 +440,7 @@ dumpIfSet cfg flag msg = n <- randomIO :: IO Int let fp = "gibbon-" ++ show n ++ "." ++ suffix dbgTraceIt ("dumpIfSet: Got -ddump-to-file, but 'srcFile' is not set in config. Dumping output to " ++ fp) (pure fp) - withFile fp WriteMode (\h -> hPutStrLn h msg) + writeFile fp (msg ++ "\n") where src_file = srcFile cfg dflags = dynflags cfg diff --git a/gibbon-compiler/src/Gibbon/Compiler.hs b/gibbon-compiler/src/Gibbon/Compiler.hs index f1630bceb..c7bf5d694 100644 --- a/gibbon-compiler/src/Gibbon/Compiler.hs +++ b/gibbon-compiler/src/Gibbon/Compiler.hs @@ -20,13 +20,13 @@ module Gibbon.Compiler import Control.DeepSeq import Control.Exception -#if !MIN_VERSION_base(4,15,0) -#endif + + import Control.Monad.State.Strict import Control.Monad.Reader (ask) -#if !MIN_VERSION_base(4,11,0) -import Data.Monoid -#endif + + + import Options.Applicative import System.Directory import System.Environment @@ -61,9 +61,10 @@ import Gibbon.Passes.Freshen (freshNames) import Gibbon.Passes.Flatten (flattenL1, flattenL2, flattenL3) import Gibbon.Passes.InlineTriv (inlineTriv) import Gibbon.Passes.Simplifier (simplifyL1, lateInlineTriv, simplifyLocBinds) +-- import Gibbon.Passes.Sequentialize (sequentialize) + import Gibbon.Passes.DirectL3 (directL3) -import Gibbon.Passes.InferLocations (inferLocs, copyOutOfOrderPacked, fixRANs) -import Gibbon.Passes.Simplifier (simplifyLocBinds) +import Gibbon.Passes.InferLocations (inferLocs, copyOutOfOrderPacked, fixRANs, removeAliasesForCopyCalls) -- This is the custom pass reference to issue #133 that moves regionsInwards import Gibbon.Passes.RegionsInwards (regionsInwards) -- import Gibbon.Passes.RepairProgram (repairProgram) @@ -92,9 +93,9 @@ import Gibbon.Passes.CalculateBounds (inferRegSize) import Gibbon.Pretty -#ifdef LLVM_ENABLED -import qualified Gibbon.Passes.LLVM.Codegen as LLVM -#endif + + + @@ -108,30 +109,42 @@ suppress_warnings = "" configParser :: Parser Config configParser = Config <$> inputParser <*> modeParser - <*> ((Just <$> strOption (long "bench-input" <> metavar "FILE" <> - help ("Hard-code the input file for --bench-fun, otherwise it"++ - " becomes a command-line argument of the resulting binary."++ - " Also we RUN the benchmark right away if this is provided."))) - <|> pure Nothing) - <*> ((Just <$> strOption (long "array-input" <> metavar "FILE" <> - help ("Hard-code the input file for readArrayFile or it"++ - " becomes a command-line argument of the resulting binary."))) - <|> pure Nothing) - <*> (option auto (short 'v' <> long "verbose" <> - help "Set the debug output level, 1-5, mirrors DEBUG env var.") - <|> pure 1) - <*> ((strOption $ long "cc" <> help "Set C compiler, default 'gcc'") - <|> pure (cc defaultConfig)) - <*> ((strOption $ long "optc" <> help "Set C compiler options, default '-std=gnu11 -O3'") + <*> optional (strOption $ mconcat + [ long "bench-input" + , metavar "FILE" + , help $ mconcat + [ "Hard-code the input file for --bench-fun, otherwise it" + , " becomes a command-line argument of the resulting binary." + , " Also we RUN the benchmark right away if this is provided." + ] + ]) + <*> optional (strOption $ mconcat + [ long "array-input" + , metavar "FILE" + , help $ mconcat + [ "Hard-code the input file for readArrayFile or it" + , " becomes a command-line argument of the resulting binary." + ] + ]) + <*> (option auto (mconcat + [ short 'v' + , long "verbose" + , help "Set the debug output level, 1-5, mirrors DEBUG env var." + ]) <|> pure 1) + <*> (strOption (long "cc" <> help "Set C compiler, default 'gcc'") + <|> pure (cc defaultConfig)) + <*> (strOption (long "optc" <> help "Set C compiler options, default '-std=gnu11 -O3'") <|> pure (optc defaultConfig)) - <*> ((fmap Just (strOption $ long "cfile" <> help "Set the destination file for generated C code")) + <*> (fmap Just (strOption $ long "cfile" <> help "Set the destination file for generated C code") <|> pure (cfile defaultConfig)) - <*> ((fmap Just (strOption $ short 'o' <> long "exefile" <> - help "Set the destination file for the executable")) - <|> pure (exefile defaultConfig)) + <*> (fmap Just (strOption $ mconcat + [ short 'o' + , long "exefile" + , help "Set the destination file for the executable" + ]) <|> pure (exefile defaultConfig)) <*> backendParser <*> dynflagsParser - <*> (Just <$> strOption hidden <|> pure Nothing) + <*> optional (strOption hidden) where inputParser :: Parser Input -- I'd like to display a separator and some more info. How? @@ -149,8 +162,8 @@ configParser = Config <$> inputParser flag' Interp1 (long "interp1" <> help "run through the interpreter early, right after parsing") <|> flag' Interp2 (short 'i' <> long "interp2" <> help "Run through the interpreter after cursor insertion") <|> - flag' RunExe (short 'r' <> long "run" <> help "Compile and then run executable") <|> - (Bench <$> toVar <$> strOption (short 'b' <> long "bench-fun" <> metavar "FUN" <> + flag' RunExe (short 'r' <> long "run" <> help "Compile and then run executable") <|> + (Bench . toVar <$> strOption (short 'b' <> long "bench-fun" <> metavar "FUN" <> help ("Generate code to benchmark a 1-argument FUN against a input packed file."++ " If --bench-input is provided, then the benchmark is run as well."))) @@ -162,8 +175,7 @@ configParser = Config <$> inputParser -- | Parse configuration as well as file arguments. configWithArgs :: Parser (Config,[FilePath]) configWithArgs = (,) <$> configParser - <*> some (argument str (metavar "FILES..." - <> help "Files to compile.")) + <*> some (argument str (metavar "FILES..." <> help "Files to compile.")) -------------------------------------------------------------------------------- @@ -178,13 +190,14 @@ compileCmd args = withArgs args $ do (cfg,files) <- execParser opts case files of [f] -> compile cfg f - _ -> do dbgPrintLn 1 $ "Compiling multiple files: "++show files + _ -> do dbgPrintLn 1 $ "Compiling multiple files: " ++ show files mapM_ (compile cfg) files where - opts = info (helper <*> configWithArgs) - ( fullDesc - <> progDesc "Compile FILES according to the below options." - <> header "A compiler for a minature tree traversal language" ) + opts = info (helper <*> configWithArgs) $ mconcat + [ fullDesc + , progDesc "Compile FILES according to the below options." + , header "A compiler for a minature tree traversal language" + ] sepline :: String @@ -232,7 +245,7 @@ compile config@Config{mode,input,verbosity,backend,cfile} fp0 = do dbgPrintLn passChatterLvl $ " [compiler] pipeline starting, parsed program: "++ if dbgLvl >= passChatterLvl+1 - then "\n"++sepline ++ "\n" ++ (sdoc l0) + then "\n"++sepline ++ "\n" ++ sdoc l0 else show (length (sdoc l0)) ++ " characters." -- (Stage 1) Run the program through the interpreter @@ -254,9 +267,9 @@ compile config@Config{mode,input,verbosity,backend,cfile} fp0 = do else do str <- case backend of C -> codegenProg config' l4 -#ifdef LLVM_ENABLED - LLVM -> LLVM.codegenProg True l4 -#endif + + + LLVM -> error $ "Cannot execute through the LLVM backend. To build Gibbon with LLVM: " ++ "stack build --flag gibbon:llvm_enabled" @@ -323,12 +336,13 @@ parseInput cfg ip fp = do f2 = fp ++ "gib" f1' <- doesFileExist f1 f2' <- doesFileExist f2 - if f1' && oth == "" - then (,f2) <$> SExp.parseFile f1 - else if f2' && oth == "." - then (,f2) <$> SExp.parseFile f1 - else error$ "compile: unrecognized file extension: "++ - show oth++" Please specify compile input format." + if (f1' && oth == "") || (f2' && oth == ".") + then (,f2) <$> SExp.parseFile f1 + else error $ mconcat + [ "compile: unrecognized file extension: " + , show oth + , " Please specify compile input format." + ] let l0' = do parsed <- l0 -- dbgTraceIt (sdoc parsed) (pure ()) HS.desugarLinearExts parsed @@ -487,7 +501,7 @@ getExeFile _ _ (Just override) = override getExeFile backend fp Nothing = let fp' = case backend of C -> fp - LLVM -> replaceFileName fp ((takeBaseName fp) ++ "_llvm") + LLVM -> replaceFileName fp (takeBaseName fp ++ "_llvm") in replaceExtension fp' ".exe" -- | Compilation command @@ -548,22 +562,21 @@ benchMainExp l1 = do ([arg@(L1.PackedTy tyc _)], ret) = L1.getFunTy fnname l1 -- At L1, we assume ReadPackedFile has a single return value: newExp = L1.TimeIt ( - (L1.LetE (toVar tmp, [], + L1.LetE (toVar tmp, [], arg, L1.PrimAppE (L1.ReadPackedFile benchInput tyc Nothing arg) []) $ L1.LetE (toVar "benchres", [], ret, - (L1.AppE fnname [] [L1.VarE (toVar tmp)])) - $ + L1.AppE fnname [] [L1.VarE (toVar tmp)]) -- FIXME: should actually return the result, -- as soon as we are able to print it. - (if (gopt Opt_BenchPrint dynflags) + (if gopt Opt_BenchPrint dynflags then L1.VarE (toVar "benchres") - else L1.PrimAppE L1.MkTrue [])) + else L1.PrimAppE L1.MkTrue []) ) ret True -- Initialize the main expression with a void type. The typechecker will fix it later. - return $ l1{ L1.mainExp = Just $ (newExp, L1.voidTy) } + return $ l1{ L1.mainExp = Just (newExp, L1.voidTy) } _ -> return l1 addRedirectionCon :: L2.Prog2 -> PassM L2.Prog2 @@ -627,11 +640,14 @@ passes config@Config{dynflags} l0 = do -- Note: L1 -> L2 -- l1 <- goE1 "copyOutOfOrderPacked" copyOutOfOrderPacked l1 l1 <- go "L1.typecheck" L1.tcProg l1 + l1 <- goE1 "removeCopyAliases" removeAliasesForCopyCalls l1 l2 <- goE2 "inferLocations" inferLocs l1 - l2 <- goE2 "simplifyLocBinds" (simplifyLocBinds True) l2 - l2 <- go "fixRANs" fixRANs l2 + l2 <- goE2 "simplifyLocBinds_a" simplifyLocBinds l2 + l2 <- go "L2.typecheck" L2.tcProg l2 + l2 <- go "regionsInwards" regionsInwards l2 l2 <- go "L2.typecheck" L2.tcProg l2 - l2 <- go "regionsInwards" regionsInwards l2 + l2 <- goE2 "simplifyLocBinds" simplifyLocBinds l2 + l2 <- go "fixRANs" fixRANs l2 l2 <- go "L2.typecheck" L2.tcProg l2 l2 <- goE2 "L2.flatten" flattenL2 l2 l2 <- go "L2.typecheck" L2.tcProg l2 @@ -681,8 +697,10 @@ Also see Note [Adding dummy traversals] and Note [Adding random access nodes]. let need = needsRAN l2 l1 <- goE1 "addRAN" (addRAN need) l1 l1 <- go "L1.typecheck" L1.tcProg l1 + -- NOTE: Calling copyOutOfOrderPacked here seems redundant since all the copy calls seem be exists in the correct place. + -- In addititon, calling it here gives a compile time error. -- l1 <- goE1 "copyOutOfOrderPacked" copyOutOfOrderPacked l1 - l1 <- go "L1.typecheck" L1.tcProg l1 + -- l1 <- go "L1.typecheck" L1.tcProg l1 l2 <- go "inferLocations2" inferLocs l1 l2 <- go "simplifyLocBinds" (simplifyLocBinds True) l2 l2 <- go "fixRANs" fixRANs l2 @@ -823,7 +841,7 @@ passE s config@Config{mode} = wrapInterp s mode (pass config) -- FINISHME! For now not interpreting. -- passF :: Config -> PassRunner p1 p2 v -passF config = pass config +passF = pass -- | Wrapper to enable running a pass AND interpreting the result. @@ -841,10 +859,21 @@ wrapInterp s mode pass who fn x = runConf <- getRunConfig [] let res2 = gInterpNoLogs s runConf p2 res2' <- catch (evaluate (force res2)) - (\exn -> error $ "Exception while running interpreter on pass result:\n"++sepline++"\n" - ++ show (exn::SomeException) ++ "\n"++sepline++"\nProgram was: "++abbrv 300 p2) + (\exn -> error $ mconcat + [ "Exception while running interpreter on pass result:\n" + , sepline, "\n" + , show (exn::SomeException), "\n" + , sepline, "\n" + , "Program was: ", abbrv 300 p2 + ]) unless (show res1 == res2') $ - error $ "After pass "++who++", evaluating the program yielded the wrong answer.\nReceived: " - ++show res2'++"\nExpected: "++show res1 - dbgPrintLn interpDbgLevel $ " [interp] answer after " ++ who ++ " was: "++ res2' + error $ mconcat + [ "After pass " , who + , ", evaluating the program yielded the wrong answer.\nReceived: " , show res2' + , "\nExpected: ", show res1 + ] + dbgPrintLn interpDbgLevel $ mconcat + [ " [interp] answer after ", who + , " was: ", res2' + ] return p2 diff --git a/gibbon-compiler/src/Gibbon/L0/Specialize2.hs b/gibbon-compiler/src/Gibbon/L0/Specialize2.hs index eeb96bf0a..d40289ec1 100644 --- a/gibbon-compiler/src/Gibbon/L0/Specialize2.hs +++ b/gibbon-compiler/src/Gibbon/L0/Specialize2.hs @@ -1738,7 +1738,7 @@ floatOutCase (Prog ddefs fundefs mainExp) = do args' <- mapM recur args pure $ PrimAppE pr args' LetE (v,tyapps,ty,rhs) bod -> do - rhs' <- recur rhs + rhs' <- go True env2 rhs let env2'= extendVEnv v ty env2 bod' <- go True env2' bod pure $ LetE (v,tyapps,ty,rhs') bod' diff --git a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs index 0aab952ab..601194363 100644 --- a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs +++ b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs @@ -10,7 +10,7 @@ module Gibbon.Passes.InferLocations fresh, freshUnifyLoc, finalUnifyLoc, fixLoc, freshLocVar, finalLocVar, assocLoc, finishExp, prim, emptyEnv, -- main functions - unify, inferLocs, inferExp, inferExp', convertFunTy, copyOutOfOrderPacked, fixRANs) + unify, inferLocs, inferExp, inferExp', convertFunTy, copyOutOfOrderPacked, fixRANs, removeAliasesForCopyCalls) where {- @@ -87,6 +87,7 @@ import qualified Data.Map as M import qualified Data.Set as S import qualified Data.List as L import qualified Data.Foldable as F +import Prelude as P import Data.Maybe import qualified Control.Monad.Trans.State.Strict as St import Control.Monad @@ -325,8 +326,8 @@ inferExp' env exp bound dest= Ext (LetLocE lv1 (AfterVariableLE v' lv2 True) a') in do res <- inferExp env exp dest - (e,ty,cs) <- bindAllLocations res - e' <- finishExp e + (e,ty,cs) <- bindAllLocations res + e' <- finishExp e let (e'',s) = cleanExp e' unbound = (s S.\\ S.fromList bound) e''' <- bindAllUnbound e'' (S.toList unbound) @@ -458,7 +459,9 @@ inferExp env@FullEnv{dataDefs} ex0 dest = if v == v' then do lv1' <- finalLocVar lv1 lv2' <- finalLocVar lv2 - return (Ext (LetLocE lv1' (AfterVariableLE v lv2 True) e), ty, cs) + let res' = (Ext (LetLocE lv1' (AfterVariableLE v lv2 True) e), ty, cs) + res'' <- bindAfterLoc v res' + return res'' else do (e',ty',cs') <- bindAfterLoc v (e,ty,cs) return (e',ty',c:cs') AfterCopyL lv1 v1 v' lv2 f lvs -> @@ -471,8 +474,9 @@ inferExp env@FullEnv{dataDefs} ex0 dest = copyRetTy = case arrOut arrty of PackedTy _ loc -> substLoc (M.singleton loc lv2) (arrOut arrty) _ -> error "bindAfterLoc: Not a packed type" - return (LetE (v',[],copyRetTy,AppE f lvs [VarE v1]) $ - Ext (LetLocE lv1' (AfterVariableLE v' lv2' True) e), ty, cs) + let res' = (LetE (v',[],copyRetTy,AppE f lvs [VarE v1]) $ Ext (LetLocE lv1' (AfterVariableLE v' lv2' True) e), ty, cs) + res'' <- bindAfterLoc v res' + return res'' else do (e',ty',cs') <- bindAfterLoc v (e,ty,cs) return (e',ty',c:cs') _ -> do (e',ty',cs') <- bindAfterLoc v (e,ty,cs) @@ -481,10 +485,11 @@ inferExp env@FullEnv{dataDefs} ex0 dest = -- | Transform a result by discharging AfterVariable constraints corresponding to -- a list of newly bound variables. + -- NOTE : Reversing the order in which bindings are discharged seems to fix the location type check error. bindAfterLocs :: [Var] -> Result -> TiM Result bindAfterLocs (v:vs) res = - do res' <- bindAfterLoc v res - bindAfterLocs vs res' + do res'' <- bindAfterLocs vs res + bindAfterLoc v res'' bindAfterLocs [] res = return res -- | Transforms a result by binding any additional locations that are safe to be bound @@ -528,7 +533,7 @@ inferExp env@FullEnv{dataDefs} ex0 dest = newtys = L.map (\(ty,(_,lv)) -> fmap (const lv) ty) $ zip contys vars' env' = L.foldr (\(v,ty) a -> extendVEnv v ty a) env $ zip (L.map fst vars') newtys res <- inferExp env' rhs dst - (rhs',ty',cs') <- bindAfterLocs (L.map fst vars') res + (rhs',ty',cs') <- bindAfterLocs (freeVarsInOrder rhs) res -- let cs'' = removeLocs (L.map snd vars') cs' -- TODO: check constraints are correct and fail/repair if they're not!!! return ((con,vars',rhs'),ty',cs') @@ -743,8 +748,17 @@ inferExp env@FullEnv{dataDefs} ex0 dest = assumeEq bty BoolTy -- Here BOTH branches are unified into the destination, so -- there is no need to unify with eachother. - (b',tyb,csb) <- inferExp env b dest - (c',tyc,csc) <- inferExp env c dest + res <- inferExp env b dest + -- bind variables after if branch + -- This ensures that the location bindings are not freely floated up to the upper level expressions + (b',tyb,csb) <- bindAfterLocs (removeDuplicates (freeVarsInOrder b)) res + + -- Else branch + res' <- inferExp env c dest + -- bind variables after else branch + -- This ensures that the location bindings are not freely floated up to the upper level expressions + (c',tyc,csc) <- bindAfterLocs (removeDuplicates (freeVarsInOrder c)) res' + return (IfE a' b' c', tyc, L.nub $ acs ++ csb ++ csc) PrimAppE (DictInsertP dty) [(VarE var),d,k,v] -> @@ -885,9 +899,11 @@ inferExp env@FullEnv{dataDefs} ex0 dest = IfE a b c -> do (boda,tya,csa) <- inferExp env a NoDest -- just assuming tyb == tyc - (bodb,tyb,csb) <- inferExp env b NoDest - (bodc,tyc,csc) <- inferExp env c NoDest - (bod',ty',cs') <- inferExp (extendVEnv vr tyc env) bod dest + res <- inferExp env b NoDest + (bodb,tyb,csb) <- bindAfterLocs (removeDuplicates (freeVarsInOrder b)) res + res' <- inferExp env c NoDest + (bodc,tyc,csc) <- bindAfterLocs (removeDuplicates (freeVarsInOrder c)) res' + (bod',ty',cs') <- inferExp (extendVEnv vr tyc env) bod dest let cs = L.nub $ csa ++ csb ++ csc ++ cs' return (L2.LetE (vr,[],tyc,L2.IfE boda bodb bodc) bod', ty', cs) @@ -1128,7 +1144,7 @@ inferExp env@FullEnv{dataDefs} ex0 dest = -- | Transforms an expression by updating all locations to their final mapping -- as a result of unification. finishExp :: Exp2 -> TiM (Exp2) -finishExp e = +finishExp e = case e of VarE v -> return $ VarE v LitE i -> return $ LitE i @@ -1537,12 +1553,17 @@ unifyAll (_:_) [] _ _ = err$ "Mismatched destination and product type arity" unifyAll [] (_:_) _ _ = err$ "Mismatched destination and product type arity" unifyAll [] [] successA _ = successA + +isCpyCallExpr1 :: Exp1 -> Bool +isCpyCallExpr1 (AppE f _ _ ) = isCpyVar f +isCpyCallExpr1 _ = False + isCpyVar :: Var -> Bool -isCpyVar v = (take 3 (fromVar v)) == "cpy" +isCpyVar v = L.isInfixOf ("copy") (fromVar v) isCpyCall :: Exp2 -> Bool isCpyCall (AppE f _ _) = True -- TODO: check if it's a real copy call, to be safe -isCpyCall _ = False +isCpyCall _ = False freshLocVar :: String -> PassM LocVar freshLocVar m = gensym (toVar m) @@ -1971,7 +1992,7 @@ copyOutOfOrderPacked prg@(Prog ddfs fndefs mnExp) = do Nothing -> acc3 Just ls -> let binds = map (\(old,new) -> - let PackedTy tycon _ = L1.lookupVEnv old env2 + let PackedTy tycon _ = L1.lookupVEnv old env2' f = mkCopyFunName tycon in (new,[],PackedTy tycon (),AppE f [] [VarE old])) ls @@ -2007,9 +2028,15 @@ copyOutOfOrderPacked prg@(Prog ddfs fndefs mnExp) = do pure $ (cpy_env1, PrimAppE pr ls1) IfE a b c -> do (cpy_env1, a1) <- go env2 cpy_env order a + -- Here each branch should be given its the same env since we are assuming that the branchches unify with the destination and not with each other. + -- TODO : Confirm (cpy_env2, b1) <- go env2 cpy_env1 order b - (cpy_env3, c1) <- go env2 cpy_env2 order c - pure $ (cpy_env3, IfE a1 b1 c1) + (cpy_env3, c1) <- go env2 cpy_env1 order c + let list_env2 = M.toList cpy_env2 + let list_env3 = M.toList cpy_env3 + let new_env = list_env2 ++ list_env3 + let map_new_env = M.fromList $ updateCpyEnv new_env + pure $ (map_new_env, IfE a1 b1 c1) MkProdE ls -> do (cpy_env1, ls1) <- F.foldrM (\e (acc1,acc2) -> do @@ -2049,7 +2076,131 @@ copyOutOfOrderPacked prg@(Prog ddfs fndefs mnExp) = do MapE{} -> error "copyOutOfOrderPacked: todo MapE" FoldE{} -> error "copyOutOfOrderPacked: todo FoldE" +-- Updating environment correctly for some branches. +updateCpyEnv :: [(Var, [(Var, Var)])] -> [(Var, [(Var, Var)])] +updateCpyEnv env = case env of + [] -> [] + x:xs -> let (key, val) = x + commonKeys = P.concat $ P.map (\(a, b) -> if (fromVar a) == (fromVar key) then [(a, b)] + else [] ) xs + commonVals = P.concat $ P.map (\(a, b) -> b) commonKeys + commonValNew = commonVals ++ val + removedKeys = P.concat $ P.map (\(a, b) -> if (fromVar a) == (fromVar key) then [] + else [(a, b)] ) xs + in [(key, commonValNew)] ++ (updateCpyEnv removedKeys) + + +-- Alias analysis for copyPacked Calls +-- Data type for storing variables Expressions and aliases. + +type AliasEnv = M.Map Exp1 (Var, S.Set Var) + +removeAliasesForCopyCalls :: Prog1 -> PassM Prog1 +removeAliasesForCopyCalls prg@(Prog ddfs fndefs mnExp) = do + mnExp' <- case mnExp of + Nothing -> pure Nothing + Just (ex,ty) -> do + ex' <- removeAliases ex (M.empty) + pure $ Just (ex', ty) + fndefs' <- mapM fd fndefs + let prg' = Prog ddfs fndefs' mnExp' + p0 <- flattenL1 prg' + inlineTriv p0 + where + fd :: FunDef1 -> PassM FunDef1 + fd fn@FunDef{funArgs,funBody,funTy} = do + funBody' <- removeAliases funBody (M.empty) + pure $ fn { funBody = funBody' } + + unifyEnvs :: [AliasEnv] -> AliasEnv + unifyEnvs envList = M.unionsWith unifyVals envList + + unifyVals :: (Var, S.Set Var) -> (Var, S.Set Var) -> (Var, S.Set Var) + unifyVals (v, vs) (v', vs') = if v == v' then (v, vs `S.union` vs') + else error "unifyVals: Variable should be same if key is same!" + + myLookup :: Exp1 -> [((Exp1, Var), b)] -> Maybe b + myLookup _ [] = Nothing + myLookup key ((thiskey,thisval):rest) = + let (rhs, v) = thiskey + in if rhs == key + then Just thisval + else myLookup key rest + + removeAliases :: Exp1 -> AliasEnv -> PassM Exp1 + removeAliases exp env = case exp of + DataConE loc dcon args -> do + args' <- mapM (\expr -> removeAliases expr env) args + pure $ DataConE loc dcon args' + VarE v -> do + let vals = M.elems env + let newVar = P.map (\(a, b) -> if (S.member v b) then a + else v ) vals + case (removeDuplicates newVar) of + [] -> return $ VarE v + [v'] -> return $ VarE v' + _ -> error "removeAliases: Did not expect more than one variable!" + LitE{} -> pure exp + CharE{} -> pure exp + FloatE{} -> pure exp + LitSymE{} -> pure exp + AppE f locs args -> do + args' <- mapM (\expr -> removeAliases expr env) args + pure $ AppE f locs args' + PrimAppE f args -> do + args' <- mapM (\expr -> removeAliases expr env) args + pure $ PrimAppE f args' + LetE (v, loc, ty, rhs) bod -> do + let isCpy = isCpyCallExpr1 rhs + rhs' <- removeAliases rhs env + if (isCpy) then do + let val' = M.lookup rhs env + case val' of + Nothing -> do + let newEnv = (M.insert rhs (v, S.empty) env) + LetE (v, loc, ty, rhs') <$> removeAliases bod newEnv + Just (v', e') -> do + let e'' = S.insert v e' + let newEnv = (M.insert rhs (v', e'') env) + if v' == v then LetE (v, loc, ty, rhs') <$> removeAliases bod newEnv + else removeAliases bod newEnv + else LetE (v, loc, ty, rhs') <$> removeAliases bod env + CaseE scrt mp -> do + mp' <- mapM (\(a, b, c) -> do + c' <- removeAliases c env + return (a, b, c') + ) mp + return $ CaseE scrt mp' + IfE a b c -> do + a' <- removeAliases a env + b' <- removeAliases b env + c' <- removeAliases c env + if b' == c' then return b' + else return $ IfE a' b' c' + MkProdE xs -> do + xs' <- mapM (\expr -> removeAliases expr env) xs + pure $ MkProdE xs' + ProjE i e -> do + e' <- removeAliases e env + pure $ ProjE i e' + TimeIt e ty b -> do + e' <- removeAliases e env + pure $ TimeIt e' ty b + WithArenaE v e -> do + e' <- removeAliases e env + pure $ WithArenaE v e' + SpawnE f locs args -> do + args' <- mapM (\expr -> removeAliases expr env) args + pure $ SpawnE f locs args' + SyncE -> pure exp + Ext _ -> pure exp + MapE{} -> error "removeAliasesForCopyCalls: todo MapE" + FoldE{} -> error "removeAliasesForCopyCalls: todo FoldE" + + + + {-- @@ -2179,3 +2330,46 @@ idFun :: L1.FunDef Ty1 (L L1.Exp1) idFun = L1.FunDef "id" ("tr",treeTy) treeTy (VarE "tr") --} + +removeDuplicates :: Eq a => [a] -> [a] +removeDuplicates list = case list of + [] -> [] + a:as -> a:removeDuplicates (P.filter (/=a) as) + +-- https://www.reddit.com/r/haskell/comments/u841av/trying_to_remove_all_the_elements_that_occur_in/ +deleteOne :: Eq a => a -> [a] -> [a] +deleteOne _ [] = [] -- Nothing to delete +deleteOne x (y:ys) | x == y = ys -- Drop exactly one matching item +deleteOne x (y:ys) = y : deleteOne x ys -- Drop one, but not this one (doesn't match). + +deleteMany :: Eq a => [a] -> [a] -> [a] +deleteMany [] = id -- Nothing to delete +deleteMany (x:xs) = deleteMany xs . deleteOne x -- Delete one, then the rest. + +freeVarsInOrder :: Exp1 -> [Var] +freeVarsInOrder exp = case exp of + VarE v -> [v] + LitE _ -> [] + CharE _ -> [] + FloatE{} -> [] + LitSymE _ -> [] + ProjE _ e -> freeVarsInOrder e + IfE a b c -> (freeVarsInOrder a) ++ (freeVarsInOrder b) ++ (freeVarsInOrder c) + AppE v _ ls -> [v] ++ (L.concat $ (L.map freeVarsInOrder ls)) + PrimAppE _ ls -> L.concat $ (L.map freeVarsInOrder ls) + LetE (v,_,_,rhs) bod -> (freeVarsInOrder rhs) ++ (deleteOne v (freeVarsInOrder bod)) + CaseE e ls -> (freeVarsInOrder e) ++ (L.concat $ + (L.map (\(_, vlocs, ee) -> + let (vars,_) = unzip vlocs + in deleteMany (freeVarsInOrder ee) vars) ls) ) + MkProdE ls -> L.concat $ L.map freeVarsInOrder ls + DataConE _ _ ls -> L.concat $ L.map freeVarsInOrder ls + TimeIt e _ _ -> freeVarsInOrder e + MapE (v,_t,rhs) bod -> (freeVarsInOrder rhs) ++ (deleteOne v (freeVarsInOrder bod)) + FoldE (v1,_t1,r1) (v2,_t2,r2) bod -> + (freeVarsInOrder r1) ++ (freeVarsInOrder r2) ++ (deleteOne v1 $ deleteOne v2 $ freeVarsInOrder bod) + + WithArenaE v e -> deleteOne v $ freeVarsInOrder e + + SpawnE v _ ls -> [v] ++ (L.concat $ L.map freeVarsInOrder ls) + SyncE -> [] diff --git a/gibbon-compiler/src/Gibbon/Passes/RegionsInwards.hs b/gibbon-compiler/src/Gibbon/Passes/RegionsInwards.hs index 72b8a153c..03c3680ce 100644 --- a/gibbon-compiler/src/Gibbon/Passes/RegionsInwards.hs +++ b/gibbon-compiler/src/Gibbon/Passes/RegionsInwards.hs @@ -185,14 +185,16 @@ placeRegionInwards env scopeSet ex = DataConE loc dataCons args -> do let allKeys = M.keys env -- List of all keys from env - keyList = map (\variable -> F.find (S.member variable) allKeys) [loc] -- For each var in the input set find its corresponding key + freelist = map freeVars args + freevars = foldl (\s1 s2 -> s1 `S.union` s2) (S.empty) freelist + keyList = map (\variable -> F.find (S.member variable) allKeys) ((S.toList freevars) ++ [loc]) -- For each var in the input set find its corresponding key keyList' = S.catMaybes keyList -- Filter all the Nothing values from the list and let only Just values in the list newKeys = S.toList $ S.fromList allKeys `S.difference` S.fromList keyList' -- Filter all the Nothing values from the list and let only Just values in the list newVals = map (\key -> M.findWithDefault [] key env) newKeys tupleList = zip newKeys newVals newEnv' = M.fromList tupleList in do args' <- mapM (placeRegionInwards newEnv' scopeSet) args - let (_, ex') = dischargeBinds' env (S.singleton loc) (DataConE loc dataCons args') + let (_, ex') = dischargeBinds' env (freevars `S.union` (S.singleton loc)) (DataConE loc dataCons args') in return ex' ProjE i e -> ProjE i <$> go e {- Simple recursion on e -} diff --git a/gibbon-compiler/tests/test-gibbon-examples.yaml b/gibbon-compiler/tests/test-gibbon-examples.yaml index 8e756bdc4..9380f47e2 100644 --- a/gibbon-compiler/tests/test-gibbon-examples.yaml +++ b/gibbon-compiler/tests/test-gibbon-examples.yaml @@ -550,3 +550,8 @@ tests: - name: test_power.hs answer-file: examples/test_power.ans + + - name: test_191.hs + answer-file: examples/test_191.ans + failing: [pointer, gibbon1, interp1] + run-modes: ["gibbon2"]