From 00f8e58a9d6f730a477b534a673b19ff9d98d9c7 Mon Sep 17 00:00:00 2001 From: Vidush Singhal Date: Sun, 23 Apr 2023 10:20:59 -0400 Subject: [PATCH 01/25] some OOPSLA benchmarks (marmoset) --- .../blog_management/marmoset/Eval.hs | 44 +++++++++++++++++++ .../blog_management/marmoset/eval_bench.hs | 11 +++++ .../marmoset/layout1ListLen.hs | 41 +++++++++++++++++ .../marmoset/layout2ListLen.hs | 43 ++++++++++++++++++ 4 files changed, 139 insertions(+) create mode 100644 gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/Eval.hs create mode 100644 gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/eval_bench.hs create mode 100644 gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1ListLen.hs create mode 100644 gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2ListLen.hs diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/Eval.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/Eval.hs new file mode 100644 index 000000000..aa5a3775a --- /dev/null +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/Eval.hs @@ -0,0 +1,44 @@ +data Ast + = Val Bool + | Not Ast + | Or Ast Ast + | And Ast Ast + +--eval :: Ast -> Bool +--eval x = case x of +-- Val b -> b +-- Not e -> if eval e then False else True +-- Or e1 e2 -> +-- if eval e1 then True +-- else eval e2 +-- And e1 e2 -> +-- if eval e1 then eval e2 +-- else False + +--simplify :: Ast -> Ast +--simplify x = Val (eval x) + +evalR :: Ast -> Bool +{-# ANN evalR Or #-} +{-# ANN evalR And #-} +evalR x = case x of + Val b -> b + Not e -> if evalR e then False else True + Or e1 e2 -> + if evalR e2 then True + else evalR e1 + And e1 e2 -> + if evalR e2 then evalR e1 + else False + +simplifyR :: Ast -> Ast +simplifyR x = Val (evalR x) + +mkRandTree :: Int -> Ast +mkRandTree n = + if n > 0 then + let m = mod rand 3 in + if m == 0 then Not (mkRandTree (n-1)) + else if m == 1 then And (mkRandTree (n-1)) (mkRandTree (n-1)) + else Or (mkRandTree (n-1)) (mkRandTree (n-1)) + else Val (mod rand 2 == 0) diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/eval_bench.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/eval_bench.hs new file mode 100644 index 000000000..88c75f31d --- /dev/null +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/eval_bench.hs @@ -0,0 +1,11 @@ +import Eval + +gibbon_main = + let + n = 45 + t = mkRandTree n + + -- _ = iterate (eval t) + s = iterate (evalR t) + in () + diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1ListLen.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1ListLen.hs new file mode 100644 index 000000000..f749cb9bc --- /dev/null +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout1ListLen.hs @@ -0,0 +1,41 @@ +type Text = Vector Char + +data Content = Str Text Content + | End + +data List = Snoc (List) Content + | Nil + + +mkContent :: Int -> Content +mkContent len = if len <= 0 then End + else Str "abcdef" (mkContent (len - 1)) + + +mkSnocList :: Int -> List +mkSnocList len = if len <= 0 + then Nil + else let + rst = mkSnocList (len - 1) + val = mkContent 100 + in Snoc rst val + +getLengthSnoc :: List -> Int +{-# ANN getLengthSnoc Snoc #-} +getLengthSnoc lst = case lst of + Snoc rst val -> 1 + getLengthSnoc rst + Nil -> 0 + + +gibbon_main = + let snocList = mkSnocList 1000000 + --consList = mkConsList 100000 + l1 = iterate (getLengthSnoc snocList) + --l2 = getLengthCons consList + _ = printsym (quote "Length Snoc: ") + _ = printint l1 + _ = printsym (quote "NEWLINE") + --_ = printsym (quote "Length Cons: ") + --_ = printint l2 + --_ = printsym (quote "NEWLINE") + in () diff --git a/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2ListLen.hs b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2ListLen.hs new file mode 100644 index 000000000..2fe8600e4 --- /dev/null +++ b/gibbon-compiler/examples/layout_benchmarks/blog_management/marmoset/layout2ListLen.hs @@ -0,0 +1,43 @@ +type Text = Vector Char + +data Content = Str Text Content + | End + +data List = Cons Content (List) + | Nil + + +mkContent :: Int -> Content +mkContent len = if len <= 0 then End + else Str "abcdef" (mkContent (len - 1)) + + +mkConsList :: Int -> List +mkConsList len = if len <= 0 + then Nil + else let + --val = mkContent 100 + rst = mkConsList (len - 1) + val = mkContent 100 + in Cons val rst + +getLengthCons :: List -> Int +{-# ANN getLengthCons Cons #-} +getLengthCons lst = case lst of + Cons val rst -> getLengthCons rst + 1 + Nil -> 0 + + + +gibbon_main = + let --snocList = mkSnocList 90000 + consList = mkConsList 3000000 + --l1 = getLengthSnoc snocList + l2 = iterate (getLengthCons consList) + --_ = printsym (quote "Length Snoc: ") + --_ = printint l1 + --_ = printsym (quote "NEWLINE") + _ = printsym (quote "Length Cons: ") + _ = printint l2 + _ = printsym (quote "NEWLINE") + in () From af5ac71870ac8f8875e89fc105ec1807ce352b33 Mon Sep 17 00:00:00 2001 From: Vidush Singhal Date: Fri, 9 Jun 2023 16:02:40 -0400 Subject: [PATCH 02/25] tail recursion microbench --- microbench/tail_recursion/sumTree.autoropes.c | 161 ++++++++++++++++++ microbench/tail_recursion/sumTree.nontail.c | 87 ++++++++++ 2 files changed, 248 insertions(+) create mode 100644 microbench/tail_recursion/sumTree.autoropes.c create mode 100644 microbench/tail_recursion/sumTree.nontail.c diff --git a/microbench/tail_recursion/sumTree.autoropes.c b/microbench/tail_recursion/sumTree.autoropes.c new file mode 100644 index 000000000..92840e23e --- /dev/null +++ b/microbench/tail_recursion/sumTree.autoropes.c @@ -0,0 +1,161 @@ +#pragma GCC optimize("O3", "omit-frame-pointer","inline") + +#include +#include +#include +#include + +#define stack_size 10000000 +//uintptr_t stack[stack_size]; +//int top=-1; + +clock_t start, end; +double cpu_time_used; + +typedef struct Tree { + int value; + struct Tree* right; + struct Tree* left; +} Tree; + +// void display() +// { +// if(top>=0) +// { +// printf("\n The elements in STACK \n"); +// for(int i=top; i>=0; i--) +// printf("\n%ld\n",stack[i]); +// } +// else +// { +// printf("\n The STACK is empty"); +// } + +// } + +static inline void push(uintptr_t pointer, int* top, uintptr_t* stack){ + + if(*top < stack_size - 1){ + (*top)++; + stack[*top] = pointer; + } + else{ + printf("Stack Overflow!!\n"); + } +} + +static inline uintptr_t pop(int* top, uintptr_t* stack){ + + if(*top > -1){ + uintptr_t pointer = stack[*top]; + (*top)--; + return pointer; + } + else{ + printf("Stack Underflow\n"); + return -1; + } + +} + +int isEmptyStack(int* top){ + + if (*top > -1){ + return 0; + } + + return -1; + +} + +Tree* mkTreeNode (int value){ + + Tree * newNode = (Tree*) malloc(sizeof(Tree)); + + newNode->value = value; + newNode->left = NULL; + newNode->right = NULL; + + return newNode; +} + +Tree* mkTree(int depth){ + + if (depth <= 0){ + return NULL; + } + + Tree* root = mkTreeNode(depth); + root->left = mkTree(depth-1); + root->right = mkTree(depth-1); + + return root; +} + +void _sumTree(Tree* root, int* sum){ + + if(root == NULL){ + return; + } + + *sum += root->value; + _sumTree(root->left, sum); + _sumTree(root->right, sum); + +} + +void _sumTreeAutoRopes(Tree* root, int* sum){ + + uintptr_t* stack = (uintptr_t*) malloc(sizeof(uintptr_t*) * stack_size); + int top = -1; + + push((uintptr_t) root, &top, stack); + + while(isEmptyStack(&top) == 0 ){ + + root = (Tree*) pop(&top, stack); + + *sum += root->value; + if(root->right != NULL) + push((uintptr_t) (root->right), &top, stack); + if(root->left != NULL) + push((uintptr_t) (root->left), &top, stack); + } +} + +void printTree(Tree* root){ + + if(root == NULL){ + printf(" NULL "); + } + else if (root->left == NULL && root->right == NULL){ + printf(" LEAF %d", root->value); + } + else{ + printf(" (NODE %d", root->value); + printTree(root->left); + printTree(root->right); + printf(")"); + } + +} + +int main(){ + + Tree* tree = mkTree(29); + //printTree(tree); + //printf("\n"); + //printf("\n"); + + int sum = 0; + + start = clock(); + _sumTreeAutoRopes(tree, &sum); + end = clock(); + + cpu_time_used = ((double) (end - start)) / CLOCKS_PER_SEC; + + printf("Execution time:%lf seconds\n", cpu_time_used); + printf("The sum of the tree was %d\n", sum); + +} \ No newline at end of file diff --git a/microbench/tail_recursion/sumTree.nontail.c b/microbench/tail_recursion/sumTree.nontail.c new file mode 100644 index 000000000..305510b02 --- /dev/null +++ b/microbench/tail_recursion/sumTree.nontail.c @@ -0,0 +1,87 @@ +#pragma GCC optimize("O3","omit-frame-pointer","inline") + +#include +#include +#include + +clock_t start, end; +double cpu_time_used; + +typedef struct Tree { + int value; + struct Tree* right; + struct Tree* left; +} Tree; + +Tree* mkTreeNode (int value){ + + Tree * newNode = (Tree*) malloc(sizeof(Tree)); + + newNode->value = value; + newNode->left = NULL; + newNode->right = NULL; + + return newNode; +} + +Tree* mkTree(int depth){ + + if (depth <= 0){ + return NULL; + } + + Tree* root = mkTreeNode(depth); + root->left = mkTree(depth-1); + root->right = mkTree(depth-1); + + return root; +} + +int sumTree(Tree* root){ + + if(root == NULL){ + return 0; + } + + int sum = root->value; + sum += sumTree(root->left); + sum += sumTree(root->right); + + return sum; +} + +void printTree(Tree* root){ + + if(root == NULL){ + printf(" NULL "); + } + else if (root->left == NULL && root->right == NULL){ + printf(" LEAF %d", root->value); + } + else{ + printf(" (NODE %d", root->value); + printTree(root->left); + printTree(root->right); + printf(")"); + } + +} + +int main(){ + + Tree* tree = mkTree(29); + //printTree(tree); + //printf("\n"); + //printf("\n"); + + start = clock(); + int sum = sumTree(tree); + end = clock(); + + cpu_time_used = ((double) (end - start)) / CLOCKS_PER_SEC; + + printf("Execution time:%lf seconds\n", cpu_time_used); + printf("The sum of the tree was %d\n", sum); + +} + From e322a69f01a0a54eced75ca1b1a66c1d319a62fd Mon Sep 17 00:00:00 2001 From: Vidush Singhal Date: Fri, 9 Jun 2023 19:05:07 -0400 Subject: [PATCH 03/25] Microbench: sumTree: autropes, return-recursion, void-recursion --- microbench/tail_recursion/bench.py | 81 +++++++++++++++++ .../tail_recursion/experiment_timings.txt | 75 ++++++++++++++++ microbench/tail_recursion/sumTree.autoropes.c | 62 ++++++------- microbench/tail_recursion/sumTree.nontail.c | 8 +- microbench/tail_recursion/sumTree.noreturn.c | 89 +++++++++++++++++++ 5 files changed, 274 insertions(+), 41 deletions(-) create mode 100644 microbench/tail_recursion/bench.py create mode 100644 microbench/tail_recursion/experiment_timings.txt create mode 100644 microbench/tail_recursion/sumTree.noreturn.c diff --git a/microbench/tail_recursion/bench.py b/microbench/tail_recursion/bench.py new file mode 100644 index 000000000..8234700a7 --- /dev/null +++ b/microbench/tail_recursion/bench.py @@ -0,0 +1,81 @@ +import os +import subprocess +import re +import statistics as stat + +iterations = 9 + +rootdir = "/home/shay/a/singhav/gibbon/microbench/tail_recursion" + + +FILES = ["sumTree.autoropes", "sumTree.nontail", "sumTree.noreturn"] + +Timings = {} + +#Compilation phase +for file in FILES: + + gibbon_file_name = file + + gibbon_cmd = "gcc" + file + ".c" + " -o " + gibbon_file_name + + print("The gcc command was: ") + print() + print(gibbon_cmd) + print() + + gibbon_cmd_c = subprocess.run(["gcc", file + ".c", "-o", gibbon_file_name]) + print() + + print("The exit code for the gcc compilation was %d" % gibbon_cmd_c.returncode) + + + +#run the files and get the timings +iterations = 9 + +for size in range(5, 30): + for files in FILES: + + times = [] + gibbon_binary = files + + print() + print("Running the binary " + str(gibbon_binary)) + print() + + for i in range(iterations): + + file_stats = gibbon_binary + ".txt" + + cmd = "(" + "cd " + rootdir + " && " + "(" + "./" + gibbon_binary + " " + str(size) + " > " + file_stats + ")" + ")" + + print(cmd) + + gibbon_binary_cmd = subprocess.call(cmd, shell=True) + + data = open(file_stats, 'r').read() + + exec_time = re.findall("Execution time: (.*)", data) + times.append(float(exec_time[0])) + + print() + print(times) + + averageTimes = float (sum(times) / iterations) + medianTimes = stat.median(times) + + tupleTimes = (averageTimes, medianTimes) + + Timings[(gibbon_binary, size)] = tupleTimes + + print() + +print(Timings) + +f = open("experiment_timings.txt", "w") + +for key, value in Timings.items(): + f.write('%s:(average:%s, median:%s)\n' % (key, value[0], value[1])) + +f.close() \ No newline at end of file diff --git a/microbench/tail_recursion/experiment_timings.txt b/microbench/tail_recursion/experiment_timings.txt new file mode 100644 index 000000000..ad0cd5d3e --- /dev/null +++ b/microbench/tail_recursion/experiment_timings.txt @@ -0,0 +1,75 @@ +('sumTree.autoropes', 5):(average:1e-06, median:1e-06) +('sumTree.nontail', 5):(average:7.777777777777777e-07, median:1e-06) +('sumTree.noreturn', 5):(average:1.111111111111111e-06, median:1e-06) +('sumTree.autoropes', 6):(average:1.4444444444444443e-06, median:1e-06) +('sumTree.nontail', 6):(average:1.6666666666666665e-06, median:2e-06) +('sumTree.noreturn', 6):(average:1.7777777777777777e-06, median:2e-06) +('sumTree.autoropes', 7):(average:1.7777777777777777e-06, median:2e-06) +('sumTree.nontail', 7):(average:2e-06, median:2e-06) +('sumTree.noreturn', 7):(average:2e-06, median:2e-06) +('sumTree.autoropes', 8):(average:2.1111111111111114e-06, median:2e-06) +('sumTree.nontail', 8):(average:2.222222222222223e-06, median:2e-06) +('sumTree.noreturn', 8):(average:2.666666666666667e-06, median:3e-06) +('sumTree.autoropes', 9):(average:2.3333333333333336e-06, median:3e-06) +('sumTree.nontail', 9):(average:3.666666666666666e-06, median:4e-06) +('sumTree.noreturn', 9):(average:3.666666666666666e-06, median:4e-06) +('sumTree.autoropes', 10):(average:3.7777777777777777e-06, median:4e-06) +('sumTree.nontail', 10):(average:4.8888888888888885e-06, median:6e-06) +('sumTree.noreturn', 10):(average:5.666666666666666e-06, median:6e-06) +('sumTree.autoropes', 11):(average:5.333333333333334e-06, median:6e-06) +('sumTree.nontail', 11):(average:7.77777777777778e-06, median:8e-06) +('sumTree.noreturn', 11):(average:7.888888888888888e-06, median:8e-06) +('sumTree.autoropes', 12):(average:1.2e-05, median:1.1e-05) +('sumTree.nontail', 12):(average:1.3111111111111113e-05, median:1.3e-05) +('sumTree.noreturn', 12):(average:1.211111111111111e-05, median:1.2e-05) +('sumTree.autoropes', 13):(average:1.9333333333333333e-05, median:1.9e-05) +('sumTree.nontail', 13):(average:2.1888888888888884e-05, median:2.2e-05) +('sumTree.noreturn', 13):(average:2.1e-05, median:2.1e-05) +('sumTree.autoropes', 14):(average:3.733333333333333e-05, median:3.7e-05) +('sumTree.nontail', 14):(average:3.288888888888889e-05, median:3.9e-05) +('sumTree.noreturn', 14):(average:3.688888888888889e-05, median:3.9e-05) +('sumTree.autoropes', 15):(average:6.877777777777778e-05, median:7.6e-05) +('sumTree.nontail', 15):(average:7e-05, median:7.4e-05) +('sumTree.noreturn', 15):(average:7.544444444444444e-05, median:7.7e-05) +('sumTree.autoropes', 16):(average:0.00015033333333333332, median:0.000149) +('sumTree.nontail', 16):(average:0.00014855555555555553, median:0.000147) +('sumTree.noreturn', 16):(average:0.0001428888888888889, median:0.000143) +('sumTree.autoropes', 17):(average:0.00028966666666666664, median:0.00029) +('sumTree.nontail', 17):(average:0.00030877777777777777, median:0.000308) +('sumTree.noreturn', 17):(average:0.0002741111111111111, median:0.000273) +('sumTree.autoropes', 18):(average:0.0006308888888888888, median:0.000625) +('sumTree.nontail', 18):(average:0.0006927777777777778, median:0.000694) +('sumTree.noreturn', 18):(average:0.0006054444444444445, median:0.000603) +('sumTree.autoropes', 19):(average:0.0015257777777777778, median:0.001517) +('sumTree.nontail', 19):(average:0.0016451111111111113, median:0.001646) +('sumTree.noreturn', 19):(average:0.0014374444444444445, median:0.001434) +('sumTree.autoropes', 20):(average:0.0028782222222222226, median:0.00285) +('sumTree.nontail', 20):(average:0.0033494444444444444, median:0.003351) +('sumTree.noreturn', 20):(average:0.002837, median:0.002829) +('sumTree.autoropes', 21):(average:0.004374222222222222, median:0.004412) +('sumTree.nontail', 21):(average:0.004556666666666666, median:0.00457) +('sumTree.noreturn', 21):(average:0.004198222222222222, median:0.004197) +('sumTree.autoropes', 22):(average:0.008737333333333335, median:0.008818) +('sumTree.nontail', 22):(average:0.009101, median:0.009106) +('sumTree.noreturn', 22):(average:0.008369, median:0.008375) +('sumTree.autoropes', 23):(average:0.017423555555555553, median:0.01756) +('sumTree.nontail', 23):(average:0.018263222222222222, median:0.018224) +('sumTree.noreturn', 23):(average:0.016718999999999998, median:0.016723) +('sumTree.autoropes', 24):(average:0.033946444444444446, median:0.033926) +('sumTree.nontail', 24):(average:0.03610433333333332, median:0.036073) +('sumTree.noreturn', 24):(average:0.033018000000000006, median:0.032936) +('sumTree.autoropes', 25):(average:0.069254, median:0.069442) +('sumTree.nontail', 25):(average:0.07198433333333333, median:0.072018) +('sumTree.noreturn', 25):(average:0.06582022222222222, median:0.065889) +('sumTree.autoropes', 26):(average:0.14113088888888886, median:0.142127) +('sumTree.nontail', 26):(average:0.14539544444444444, median:0.145906) +('sumTree.noreturn', 26):(average:0.13209100000000001, median:0.131969) +('sumTree.autoropes', 27):(average:0.282364, median:0.283466) +('sumTree.nontail', 27):(average:0.28602866666666665, median:0.285609) +('sumTree.noreturn', 27):(average:0.2635363333333334, median:0.263534) +('sumTree.autoropes', 28):(average:0.5668533333333333, median:0.565137) +('sumTree.nontail', 28):(average:0.5706432222222222, median:0.572578) +('sumTree.noreturn', 28):(average:0.5264073333333334, median:0.525447) +('sumTree.autoropes', 29):(average:1.1268954444444443, median:1.12778) +('sumTree.nontail', 29):(average:1.1358716666666668, median:1.137612) +('sumTree.noreturn', 29):(average:1.050808, median:1.047538) diff --git a/microbench/tail_recursion/sumTree.autoropes.c b/microbench/tail_recursion/sumTree.autoropes.c index 92840e23e..5fe7df108 100644 --- a/microbench/tail_recursion/sumTree.autoropes.c +++ b/microbench/tail_recursion/sumTree.autoropes.c @@ -4,10 +4,9 @@ #include #include #include +#include #define stack_size 10000000 -//uintptr_t stack[stack_size]; -//int top=-1; clock_t start, end; double cpu_time_used; @@ -18,20 +17,20 @@ typedef struct Tree { struct Tree* left; } Tree; -// void display() -// { -// if(top>=0) -// { -// printf("\n The elements in STACK \n"); -// for(int i=top; i>=0; i--) -// printf("\n%ld\n",stack[i]); -// } -// else -// { -// printf("\n The STACK is empty"); -// } +void display(int* top, uintptr_t* stack) +{ + if(*top>=0) + { + printf("\n The elements in STACK \n"); + for(int i=*top; i>=0; i--) + printf("\n%ld\n",stack[i]); + } + else + { + printf("\n The STACK is empty"); + } -// } +} static inline void push(uintptr_t pointer, int* top, uintptr_t* stack){ @@ -58,13 +57,13 @@ static inline uintptr_t pop(int* top, uintptr_t* stack){ } -int isEmptyStack(int* top){ +static inline bool isEmptyStack(int* top){ if (*top > -1){ - return 0; + return false; } - return -1; + return true; } @@ -92,26 +91,13 @@ Tree* mkTree(int depth){ return root; } -void _sumTree(Tree* root, int* sum){ - - if(root == NULL){ - return; - } - - *sum += root->value; - _sumTree(root->left, sum); - _sumTree(root->right, sum); - -} - -void _sumTreeAutoRopes(Tree* root, int* sum){ +void _sumTreeAutoRopes(Tree* root, int* sum, uintptr_t* stack){ - uintptr_t* stack = (uintptr_t*) malloc(sizeof(uintptr_t*) * stack_size); int top = -1; push((uintptr_t) root, &top, stack); - while(isEmptyStack(&top) == 0 ){ + while(!isEmptyStack(&top)){ root = (Tree*) pop(&top, stack); @@ -140,22 +126,24 @@ void printTree(Tree* root){ } -int main(){ +int main(int argc, char** argv){ - Tree* tree = mkTree(29); + Tree* tree = mkTree(atoi(argv[1])); //printTree(tree); //printf("\n"); //printf("\n"); int sum = 0; + + uintptr_t* stack = (uintptr_t*) malloc(sizeof(uintptr_t*) * stack_size); start = clock(); - _sumTreeAutoRopes(tree, &sum); + _sumTreeAutoRopes(tree, &sum, stack); end = clock(); cpu_time_used = ((double) (end - start)) / CLOCKS_PER_SEC; - printf("Execution time:%lf seconds\n", cpu_time_used); + printf("Execution time: %lf\n", cpu_time_used); printf("The sum of the tree was %d\n", sum); } \ No newline at end of file diff --git a/microbench/tail_recursion/sumTree.nontail.c b/microbench/tail_recursion/sumTree.nontail.c index 305510b02..84c38b9b5 100644 --- a/microbench/tail_recursion/sumTree.nontail.c +++ b/microbench/tail_recursion/sumTree.nontail.c @@ -1,7 +1,7 @@ #pragma GCC optimize("O3","omit-frame-pointer","inline") #include -#include +#include #include clock_t start, end; @@ -67,9 +67,9 @@ void printTree(Tree* root){ } -int main(){ +int main(int argc, char** argv){ - Tree* tree = mkTree(29); + Tree* tree = mkTree(atoi(argv[1])); //printTree(tree); //printf("\n"); //printf("\n"); @@ -80,7 +80,7 @@ int main(){ cpu_time_used = ((double) (end - start)) / CLOCKS_PER_SEC; - printf("Execution time:%lf seconds\n", cpu_time_used); + printf("Execution time: %lf\n", cpu_time_used); printf("The sum of the tree was %d\n", sum); } diff --git a/microbench/tail_recursion/sumTree.noreturn.c b/microbench/tail_recursion/sumTree.noreturn.c new file mode 100644 index 000000000..4516a8722 --- /dev/null +++ b/microbench/tail_recursion/sumTree.noreturn.c @@ -0,0 +1,89 @@ +#pragma GCC optimize("O3", "omit-frame-pointer","inline") + +#include +#include +#include +#include + + +clock_t start, end; +double cpu_time_used; + +typedef struct Tree { + int value; + struct Tree* right; + struct Tree* left; +} Tree; + +Tree* mkTreeNode (int value){ + + Tree * newNode = (Tree*) malloc(sizeof(Tree)); + + newNode->value = value; + newNode->left = NULL; + newNode->right = NULL; + + return newNode; +} + +Tree* mkTree(int depth){ + + if (depth <= 0){ + return NULL; + } + + Tree* root = mkTreeNode(depth); + root->left = mkTree(depth-1); + root->right = mkTree(depth-1); + + return root; +} + +void _sumTree(Tree* root, int* sum){ + + if(root == NULL){ + return; + } + + *sum += root->value; + _sumTree(root->left, sum); + _sumTree(root->right, sum); + +} + +void printTree(Tree* root){ + + if(root == NULL){ + printf(" NULL "); + } + else if (root->left == NULL && root->right == NULL){ + printf(" LEAF %d", root->value); + } + else{ + printf(" (NODE %d", root->value); + printTree(root->left); + printTree(root->right); + printf(")"); + } + +} + +int main(int argc, char** argv){ + + Tree* tree = mkTree(atoi(argv[1])); + //printTree(tree); + //printf("\n"); + //printf("\n"); + + int sum = 0; + + start = clock(); + _sumTree(tree, &sum); + end = clock(); + + cpu_time_used = ((double) (end - start)) / CLOCKS_PER_SEC; + + printf("Execution time: %lf\n", cpu_time_used); + printf("The sum of the tree was %d\n", sum); + +} \ No newline at end of file From ba918ecab4e5e13ca5b68c32cffec7bec2ef7b51 Mon Sep 17 00:00:00 2001 From: Vidush Singhal Date: Fri, 9 Jun 2023 20:13:21 -0400 Subject: [PATCH 04/25] tail_rec: optimizations --- microbench/tail_recursion/bench.py | 6 +- .../tail_recursion/experiment_timings.txt | 148 +++++++++--------- microbench/tail_recursion/sumTree.autoropes.c | 41 ++++- microbench/tail_recursion/sumTree.nontail.c | 2 +- microbench/tail_recursion/sumTree.noreturn.c | 2 +- 5 files changed, 113 insertions(+), 86 deletions(-) diff --git a/microbench/tail_recursion/bench.py b/microbench/tail_recursion/bench.py index 8234700a7..9856f716c 100644 --- a/microbench/tail_recursion/bench.py +++ b/microbench/tail_recursion/bench.py @@ -17,14 +17,14 @@ gibbon_file_name = file - gibbon_cmd = "gcc" + file + ".c" + " -o " + gibbon_file_name + gibbon_cmd = "gcc -O3 " + file + ".c" + " -o " + gibbon_file_name print("The gcc command was: ") print() print(gibbon_cmd) print() - gibbon_cmd_c = subprocess.run(["gcc", file + ".c", "-o", gibbon_file_name]) + gibbon_cmd_c = subprocess.run(["gcc", "-O3" , file + ".c", "-o", gibbon_file_name]) print() print("The exit code for the gcc compilation was %d" % gibbon_cmd_c.returncode) @@ -34,7 +34,7 @@ #run the files and get the timings iterations = 9 -for size in range(5, 30): +for size in range(5, 25): for files in FILES: times = [] diff --git a/microbench/tail_recursion/experiment_timings.txt b/microbench/tail_recursion/experiment_timings.txt index ad0cd5d3e..56fbb204f 100644 --- a/microbench/tail_recursion/experiment_timings.txt +++ b/microbench/tail_recursion/experiment_timings.txt @@ -1,75 +1,75 @@ -('sumTree.autoropes', 5):(average:1e-06, median:1e-06) -('sumTree.nontail', 5):(average:7.777777777777777e-07, median:1e-06) -('sumTree.noreturn', 5):(average:1.111111111111111e-06, median:1e-06) -('sumTree.autoropes', 6):(average:1.4444444444444443e-06, median:1e-06) -('sumTree.nontail', 6):(average:1.6666666666666665e-06, median:2e-06) -('sumTree.noreturn', 6):(average:1.7777777777777777e-06, median:2e-06) -('sumTree.autoropes', 7):(average:1.7777777777777777e-06, median:2e-06) -('sumTree.nontail', 7):(average:2e-06, median:2e-06) -('sumTree.noreturn', 7):(average:2e-06, median:2e-06) -('sumTree.autoropes', 8):(average:2.1111111111111114e-06, median:2e-06) -('sumTree.nontail', 8):(average:2.222222222222223e-06, median:2e-06) -('sumTree.noreturn', 8):(average:2.666666666666667e-06, median:3e-06) -('sumTree.autoropes', 9):(average:2.3333333333333336e-06, median:3e-06) -('sumTree.nontail', 9):(average:3.666666666666666e-06, median:4e-06) +('sumTree.autoropes', 5):(average:1.111111111111111e-06, median:1e-06) +('sumTree.nontail', 5):(average:1.2222222222222223e-06, median:1e-06) +('sumTree.noreturn', 5):(average:1.5555555555555556e-06, median:2e-06) +('sumTree.autoropes', 6):(average:1.1111111111111112e-06, median:1e-06) +('sumTree.nontail', 6):(average:1.1111111111111112e-06, median:1e-06) +('sumTree.noreturn', 6):(average:1.3333333333333334e-06, median:1e-06) +('sumTree.autoropes', 7):(average:1.3333333333333334e-06, median:1e-06) +('sumTree.nontail', 7):(average:1.7777777777777777e-06, median:2e-06) +('sumTree.noreturn', 7):(average:2.2222222222222225e-06, median:2e-06) +('sumTree.autoropes', 8):(average:2e-06, median:2e-06) +('sumTree.nontail', 8):(average:2.7777777777777783e-06, median:3e-06) +('sumTree.noreturn', 8):(average:2.4444444444444442e-06, median:2e-06) +('sumTree.autoropes', 9):(average:3e-06, median:3e-06) +('sumTree.nontail', 9):(average:3.333333333333333e-06, median:3e-06) ('sumTree.noreturn', 9):(average:3.666666666666666e-06, median:4e-06) -('sumTree.autoropes', 10):(average:3.7777777777777777e-06, median:4e-06) -('sumTree.nontail', 10):(average:4.8888888888888885e-06, median:6e-06) -('sumTree.noreturn', 10):(average:5.666666666666666e-06, median:6e-06) -('sumTree.autoropes', 11):(average:5.333333333333334e-06, median:6e-06) -('sumTree.nontail', 11):(average:7.77777777777778e-06, median:8e-06) -('sumTree.noreturn', 11):(average:7.888888888888888e-06, median:8e-06) -('sumTree.autoropes', 12):(average:1.2e-05, median:1.1e-05) -('sumTree.nontail', 12):(average:1.3111111111111113e-05, median:1.3e-05) -('sumTree.noreturn', 12):(average:1.211111111111111e-05, median:1.2e-05) -('sumTree.autoropes', 13):(average:1.9333333333333333e-05, median:1.9e-05) -('sumTree.nontail', 13):(average:2.1888888888888884e-05, median:2.2e-05) -('sumTree.noreturn', 13):(average:2.1e-05, median:2.1e-05) -('sumTree.autoropes', 14):(average:3.733333333333333e-05, median:3.7e-05) -('sumTree.nontail', 14):(average:3.288888888888889e-05, median:3.9e-05) -('sumTree.noreturn', 14):(average:3.688888888888889e-05, median:3.9e-05) -('sumTree.autoropes', 15):(average:6.877777777777778e-05, median:7.6e-05) -('sumTree.nontail', 15):(average:7e-05, median:7.4e-05) -('sumTree.noreturn', 15):(average:7.544444444444444e-05, median:7.7e-05) -('sumTree.autoropes', 16):(average:0.00015033333333333332, median:0.000149) -('sumTree.nontail', 16):(average:0.00014855555555555553, median:0.000147) -('sumTree.noreturn', 16):(average:0.0001428888888888889, median:0.000143) -('sumTree.autoropes', 17):(average:0.00028966666666666664, median:0.00029) -('sumTree.nontail', 17):(average:0.00030877777777777777, median:0.000308) -('sumTree.noreturn', 17):(average:0.0002741111111111111, median:0.000273) -('sumTree.autoropes', 18):(average:0.0006308888888888888, median:0.000625) -('sumTree.nontail', 18):(average:0.0006927777777777778, median:0.000694) -('sumTree.noreturn', 18):(average:0.0006054444444444445, median:0.000603) -('sumTree.autoropes', 19):(average:0.0015257777777777778, median:0.001517) -('sumTree.nontail', 19):(average:0.0016451111111111113, median:0.001646) -('sumTree.noreturn', 19):(average:0.0014374444444444445, median:0.001434) -('sumTree.autoropes', 20):(average:0.0028782222222222226, median:0.00285) -('sumTree.nontail', 20):(average:0.0033494444444444444, median:0.003351) -('sumTree.noreturn', 20):(average:0.002837, median:0.002829) -('sumTree.autoropes', 21):(average:0.004374222222222222, median:0.004412) -('sumTree.nontail', 21):(average:0.004556666666666666, median:0.00457) -('sumTree.noreturn', 21):(average:0.004198222222222222, median:0.004197) -('sumTree.autoropes', 22):(average:0.008737333333333335, median:0.008818) -('sumTree.nontail', 22):(average:0.009101, median:0.009106) -('sumTree.noreturn', 22):(average:0.008369, median:0.008375) -('sumTree.autoropes', 23):(average:0.017423555555555553, median:0.01756) -('sumTree.nontail', 23):(average:0.018263222222222222, median:0.018224) -('sumTree.noreturn', 23):(average:0.016718999999999998, median:0.016723) -('sumTree.autoropes', 24):(average:0.033946444444444446, median:0.033926) -('sumTree.nontail', 24):(average:0.03610433333333332, median:0.036073) -('sumTree.noreturn', 24):(average:0.033018000000000006, median:0.032936) -('sumTree.autoropes', 25):(average:0.069254, median:0.069442) -('sumTree.nontail', 25):(average:0.07198433333333333, median:0.072018) -('sumTree.noreturn', 25):(average:0.06582022222222222, median:0.065889) -('sumTree.autoropes', 26):(average:0.14113088888888886, median:0.142127) -('sumTree.nontail', 26):(average:0.14539544444444444, median:0.145906) -('sumTree.noreturn', 26):(average:0.13209100000000001, median:0.131969) -('sumTree.autoropes', 27):(average:0.282364, median:0.283466) -('sumTree.nontail', 27):(average:0.28602866666666665, median:0.285609) -('sumTree.noreturn', 27):(average:0.2635363333333334, median:0.263534) -('sumTree.autoropes', 28):(average:0.5668533333333333, median:0.565137) -('sumTree.nontail', 28):(average:0.5706432222222222, median:0.572578) -('sumTree.noreturn', 28):(average:0.5264073333333334, median:0.525447) -('sumTree.autoropes', 29):(average:1.1268954444444443, median:1.12778) -('sumTree.nontail', 29):(average:1.1358716666666668, median:1.137612) -('sumTree.noreturn', 29):(average:1.050808, median:1.047538) +('sumTree.autoropes', 10):(average:3.888888888888889e-06, median:4e-06) +('sumTree.nontail', 10):(average:5.444444444444444e-06, median:5e-06) +('sumTree.noreturn', 10):(average:5.333333333333334e-06, median:5e-06) +('sumTree.autoropes', 11):(average:6.4444444444444445e-06, median:6e-06) +('sumTree.nontail', 11):(average:8.333333333333332e-06, median:8e-06) +('sumTree.noreturn', 11):(average:7.88888888888889e-06, median:8e-06) +('sumTree.autoropes', 12):(average:1.1444444444444442e-05, median:1.1e-05) +('sumTree.nontail', 12):(average:1.3000000000000001e-05, median:1.3e-05) +('sumTree.noreturn', 12):(average:1.2555555555555555e-05, median:1.3e-05) +('sumTree.autoropes', 13):(average:2.077777777777778e-05, median:2.1e-05) +('sumTree.nontail', 13):(average:2.1444444444444443e-05, median:2.1e-05) +('sumTree.noreturn', 13):(average:2.1666666666666664e-05, median:2.1e-05) +('sumTree.autoropes', 14):(average:4.055555555555555e-05, median:4.1e-05) +('sumTree.nontail', 14):(average:4.044444444444444e-05, median:3.8e-05) +('sumTree.noreturn', 14):(average:4.066666666666666e-05, median:4e-05) +('sumTree.autoropes', 15):(average:8.255555555555555e-05, median:8e-05) +('sumTree.nontail', 15):(average:7.822222222222222e-05, median:7.6e-05) +('sumTree.noreturn', 15):(average:7.677777777777777e-05, median:7.4e-05) +('sumTree.autoropes', 16):(average:0.00015377777777777775, median:0.000153) +('sumTree.nontail', 16):(average:0.00014566666666666667, median:0.000144) +('sumTree.noreturn', 16):(average:0.0001387777777777778, median:0.000139) +('sumTree.autoropes', 17):(average:0.00030533333333333335, median:0.000301) +('sumTree.nontail', 17):(average:0.00030622222222222227, median:0.000302) +('sumTree.noreturn', 17):(average:0.000295, median:0.000287) +('sumTree.autoropes', 18):(average:0.0006912222222222222, median:0.00067) +('sumTree.nontail', 18):(average:0.0007152222222222222, median:0.00071) +('sumTree.noreturn', 18):(average:0.0006173333333333332, median:0.000605) +('sumTree.autoropes', 19):(average:0.0015822222222222223, median:0.001561) +('sumTree.nontail', 19):(average:0.001706, median:0.001707) +('sumTree.noreturn', 19):(average:0.0015488888888888887, median:0.001528) +('sumTree.autoropes', 20):(average:0.0028651111111111112, median:0.002895) +('sumTree.nontail', 20):(average:0.003151777777777777, median:0.003372) +('sumTree.noreturn', 20):(average:0.0028872222222222224, median:0.002887) +('sumTree.autoropes', 21):(average:0.004249666666666667, median:0.004255) +('sumTree.nontail', 21):(average:0.004581222222222222, median:0.004594) +('sumTree.noreturn', 21):(average:0.004242666666666666, median:0.004253) +('sumTree.autoropes', 22):(average:0.008504888888888888, median:0.008491) +('sumTree.nontail', 22):(average:0.009238222222222222, median:0.009226) +('sumTree.noreturn', 22):(average:0.008426333333333334, median:0.008418) +('sumTree.autoropes', 23):(average:0.016855444444444447, median:0.016734) +('sumTree.nontail', 23):(average:0.018291222222222223, median:0.018262) +('sumTree.noreturn', 23):(average:0.01669411111111111, median:0.016739) +('sumTree.autoropes', 24):(average:0.03363055555555556, median:0.033584) +('sumTree.nontail', 24):(average:0.036695222222222226, median:0.036647) +('sumTree.noreturn', 24):(average:0.033570555555555555, median:0.033546) +('sumTree.autoropes', 25):(average:0.06767944444444444, median:0.067911) +('sumTree.nontail', 25):(average:0.07346055555555557, median:0.073409) +('sumTree.noreturn', 25):(average:0.06660577777777778, median:0.066383) +('sumTree.autoropes', 26):(average:0.13595955555555556, median:0.13601) +('sumTree.nontail', 26):(average:0.14572455555555555, median:0.145619) +('sumTree.noreturn', 26):(average:0.13266133333333335, median:0.132734) +('sumTree.autoropes', 27):(average:0.26850466666666667, median:0.26757) +('sumTree.nontail', 27):(average:0.2871353333333333, median:0.287519) +('sumTree.noreturn', 27):(average:0.26298533333333335, median:0.263459) +('sumTree.autoropes', 28):(average:0.5416366666666667, median:0.541493) +('sumTree.nontail', 28):(average:0.571546, median:0.572006) +('sumTree.noreturn', 28):(average:0.528146, median:0.526279) +('sumTree.autoropes', 29):(average:1.0946895555555554, median:1.092287) +('sumTree.nontail', 29):(average:1.1400879999999998, median:1.138315) +('sumTree.noreturn', 29):(average:1.054961111111111, median:1.055604) diff --git a/microbench/tail_recursion/sumTree.autoropes.c b/microbench/tail_recursion/sumTree.autoropes.c index 5fe7df108..0ef9c5063 100644 --- a/microbench/tail_recursion/sumTree.autoropes.c +++ b/microbench/tail_recursion/sumTree.autoropes.c @@ -1,4 +1,4 @@ -#pragma GCC optimize("O3", "omit-frame-pointer","inline") +#pragma GCC optimize("O3", "inline") #include #include @@ -34,7 +34,10 @@ void display(int* top, uintptr_t* stack) static inline void push(uintptr_t pointer, int* top, uintptr_t* stack){ - if(*top < stack_size - 1){ + if ((void*)pointer == NULL) + return; + + if(*top < stack_size - 1 ){ (*top)++; stack[*top] = pointer; } @@ -57,6 +60,31 @@ static inline uintptr_t pop(int* top, uintptr_t* stack){ } +static inline uintptr_t _top(int* top, uintptr_t* stack){ + + if(*top > -1){ + return stack[*top]; + } + else{ + printf("Stack Underflow\n"); + return -1; + } + +} + +static inline void _pop(int* top){ + + if(*top > -1){ + (*top)--; + return; + } + else{ + printf("Stack Underflow\n"); + return; + } + +} + static inline bool isEmptyStack(int* top){ if (*top > -1){ @@ -99,13 +127,12 @@ void _sumTreeAutoRopes(Tree* root, int* sum, uintptr_t* stack){ while(!isEmptyStack(&top)){ - root = (Tree*) pop(&top, stack); + root = (Tree*) _top(&top, stack); + _pop(&top); *sum += root->value; - if(root->right != NULL) - push((uintptr_t) (root->right), &top, stack); - if(root->left != NULL) - push((uintptr_t) (root->left), &top, stack); + push((uintptr_t) (root->right), &top, stack); + push((uintptr_t) (root->left), &top, stack); } } diff --git a/microbench/tail_recursion/sumTree.nontail.c b/microbench/tail_recursion/sumTree.nontail.c index 84c38b9b5..853dff7cc 100644 --- a/microbench/tail_recursion/sumTree.nontail.c +++ b/microbench/tail_recursion/sumTree.nontail.c @@ -1,4 +1,4 @@ -#pragma GCC optimize("O3","omit-frame-pointer","inline") +#pragma GCC optimize("O3", "inline") #include #include diff --git a/microbench/tail_recursion/sumTree.noreturn.c b/microbench/tail_recursion/sumTree.noreturn.c index 4516a8722..59faf7e09 100644 --- a/microbench/tail_recursion/sumTree.noreturn.c +++ b/microbench/tail_recursion/sumTree.noreturn.c @@ -1,4 +1,4 @@ -#pragma GCC optimize("O3", "omit-frame-pointer","inline") +#pragma GCC optimize("O3", "inline") #include #include From ceb3aa77407808f3f055b5f0f6789ac9b09367e8 Mon Sep 17 00:00:00 2001 From: vidsinghal Date: Fri, 9 Jun 2023 22:20:14 -0400 Subject: [PATCH 05/25] tailrec: optimize code --- microbench/tail_recursion/bench.py | 6 +- .../tail_recursion/experiment_timings.txt | 150 +++++++++--------- microbench/tail_recursion/sumTree.autoropes.c | 13 +- 3 files changed, 86 insertions(+), 83 deletions(-) diff --git a/microbench/tail_recursion/bench.py b/microbench/tail_recursion/bench.py index 9856f716c..7624a874f 100644 --- a/microbench/tail_recursion/bench.py +++ b/microbench/tail_recursion/bench.py @@ -32,9 +32,9 @@ #run the files and get the timings -iterations = 9 +iterations = 15 -for size in range(5, 25): +for size in range(5, 30): for files in FILES: times = [] @@ -73,7 +73,7 @@ print(Timings) -f = open("experiment_timings.txt", "w") +f = open("experiment_timings1.txt", "w") for key, value in Timings.items(): f.write('%s:(average:%s, median:%s)\n' % (key, value[0], value[1])) diff --git a/microbench/tail_recursion/experiment_timings.txt b/microbench/tail_recursion/experiment_timings.txt index 56fbb204f..5c08b9547 100644 --- a/microbench/tail_recursion/experiment_timings.txt +++ b/microbench/tail_recursion/experiment_timings.txt @@ -1,75 +1,75 @@ -('sumTree.autoropes', 5):(average:1.111111111111111e-06, median:1e-06) -('sumTree.nontail', 5):(average:1.2222222222222223e-06, median:1e-06) -('sumTree.noreturn', 5):(average:1.5555555555555556e-06, median:2e-06) -('sumTree.autoropes', 6):(average:1.1111111111111112e-06, median:1e-06) -('sumTree.nontail', 6):(average:1.1111111111111112e-06, median:1e-06) -('sumTree.noreturn', 6):(average:1.3333333333333334e-06, median:1e-06) -('sumTree.autoropes', 7):(average:1.3333333333333334e-06, median:1e-06) -('sumTree.nontail', 7):(average:1.7777777777777777e-06, median:2e-06) -('sumTree.noreturn', 7):(average:2.2222222222222225e-06, median:2e-06) -('sumTree.autoropes', 8):(average:2e-06, median:2e-06) -('sumTree.nontail', 8):(average:2.7777777777777783e-06, median:3e-06) -('sumTree.noreturn', 8):(average:2.4444444444444442e-06, median:2e-06) -('sumTree.autoropes', 9):(average:3e-06, median:3e-06) -('sumTree.nontail', 9):(average:3.333333333333333e-06, median:3e-06) -('sumTree.noreturn', 9):(average:3.666666666666666e-06, median:4e-06) -('sumTree.autoropes', 10):(average:3.888888888888889e-06, median:4e-06) -('sumTree.nontail', 10):(average:5.444444444444444e-06, median:5e-06) -('sumTree.noreturn', 10):(average:5.333333333333334e-06, median:5e-06) -('sumTree.autoropes', 11):(average:6.4444444444444445e-06, median:6e-06) -('sumTree.nontail', 11):(average:8.333333333333332e-06, median:8e-06) -('sumTree.noreturn', 11):(average:7.88888888888889e-06, median:8e-06) -('sumTree.autoropes', 12):(average:1.1444444444444442e-05, median:1.1e-05) -('sumTree.nontail', 12):(average:1.3000000000000001e-05, median:1.3e-05) -('sumTree.noreturn', 12):(average:1.2555555555555555e-05, median:1.3e-05) -('sumTree.autoropes', 13):(average:2.077777777777778e-05, median:2.1e-05) -('sumTree.nontail', 13):(average:2.1444444444444443e-05, median:2.1e-05) -('sumTree.noreturn', 13):(average:2.1666666666666664e-05, median:2.1e-05) -('sumTree.autoropes', 14):(average:4.055555555555555e-05, median:4.1e-05) -('sumTree.nontail', 14):(average:4.044444444444444e-05, median:3.8e-05) -('sumTree.noreturn', 14):(average:4.066666666666666e-05, median:4e-05) -('sumTree.autoropes', 15):(average:8.255555555555555e-05, median:8e-05) -('sumTree.nontail', 15):(average:7.822222222222222e-05, median:7.6e-05) -('sumTree.noreturn', 15):(average:7.677777777777777e-05, median:7.4e-05) -('sumTree.autoropes', 16):(average:0.00015377777777777775, median:0.000153) -('sumTree.nontail', 16):(average:0.00014566666666666667, median:0.000144) -('sumTree.noreturn', 16):(average:0.0001387777777777778, median:0.000139) -('sumTree.autoropes', 17):(average:0.00030533333333333335, median:0.000301) -('sumTree.nontail', 17):(average:0.00030622222222222227, median:0.000302) -('sumTree.noreturn', 17):(average:0.000295, median:0.000287) -('sumTree.autoropes', 18):(average:0.0006912222222222222, median:0.00067) -('sumTree.nontail', 18):(average:0.0007152222222222222, median:0.00071) -('sumTree.noreturn', 18):(average:0.0006173333333333332, median:0.000605) -('sumTree.autoropes', 19):(average:0.0015822222222222223, median:0.001561) -('sumTree.nontail', 19):(average:0.001706, median:0.001707) -('sumTree.noreturn', 19):(average:0.0015488888888888887, median:0.001528) -('sumTree.autoropes', 20):(average:0.0028651111111111112, median:0.002895) -('sumTree.nontail', 20):(average:0.003151777777777777, median:0.003372) -('sumTree.noreturn', 20):(average:0.0028872222222222224, median:0.002887) -('sumTree.autoropes', 21):(average:0.004249666666666667, median:0.004255) -('sumTree.nontail', 21):(average:0.004581222222222222, median:0.004594) -('sumTree.noreturn', 21):(average:0.004242666666666666, median:0.004253) -('sumTree.autoropes', 22):(average:0.008504888888888888, median:0.008491) -('sumTree.nontail', 22):(average:0.009238222222222222, median:0.009226) -('sumTree.noreturn', 22):(average:0.008426333333333334, median:0.008418) -('sumTree.autoropes', 23):(average:0.016855444444444447, median:0.016734) -('sumTree.nontail', 23):(average:0.018291222222222223, median:0.018262) -('sumTree.noreturn', 23):(average:0.01669411111111111, median:0.016739) -('sumTree.autoropes', 24):(average:0.03363055555555556, median:0.033584) -('sumTree.nontail', 24):(average:0.036695222222222226, median:0.036647) -('sumTree.noreturn', 24):(average:0.033570555555555555, median:0.033546) -('sumTree.autoropes', 25):(average:0.06767944444444444, median:0.067911) -('sumTree.nontail', 25):(average:0.07346055555555557, median:0.073409) -('sumTree.noreturn', 25):(average:0.06660577777777778, median:0.066383) -('sumTree.autoropes', 26):(average:0.13595955555555556, median:0.13601) -('sumTree.nontail', 26):(average:0.14572455555555555, median:0.145619) -('sumTree.noreturn', 26):(average:0.13266133333333335, median:0.132734) -('sumTree.autoropes', 27):(average:0.26850466666666667, median:0.26757) -('sumTree.nontail', 27):(average:0.2871353333333333, median:0.287519) -('sumTree.noreturn', 27):(average:0.26298533333333335, median:0.263459) -('sumTree.autoropes', 28):(average:0.5416366666666667, median:0.541493) -('sumTree.nontail', 28):(average:0.571546, median:0.572006) -('sumTree.noreturn', 28):(average:0.528146, median:0.526279) -('sumTree.autoropes', 29):(average:1.0946895555555554, median:1.092287) -('sumTree.nontail', 29):(average:1.1400879999999998, median:1.138315) -('sumTree.noreturn', 29):(average:1.054961111111111, median:1.055604) +('sumTree.autoropes', 5):(average:1.2666666666666667e-06, median:1e-06) +('sumTree.nontail', 5):(average:1.6666666666666669e-06, median:2e-06) +('sumTree.noreturn', 5):(average:1.2666666666666669e-06, median:1e-06) +('sumTree.autoropes', 6):(average:1.3333333333333334e-06, median:1e-06) +('sumTree.nontail', 6):(average:1.6666666666666669e-06, median:2e-06) +('sumTree.noreturn', 6):(average:1.7333333333333336e-06, median:2e-06) +('sumTree.autoropes', 7):(average:1.5333333333333336e-06, median:2e-06) +('sumTree.nontail', 7):(average:1.9333333333333336e-06, median:2e-06) +('sumTree.noreturn', 7):(average:1.9333333333333336e-06, median:2e-06) +('sumTree.autoropes', 8):(average:2.0000000000000003e-06, median:2e-06) +('sumTree.nontail', 8):(average:2.466666666666667e-06, median:2e-06) +('sumTree.noreturn', 8):(average:2.466666666666667e-06, median:2e-06) +('sumTree.autoropes', 9):(average:2.4e-06, median:2e-06) +('sumTree.nontail', 9):(average:3.6666666666666674e-06, median:4e-06) +('sumTree.noreturn', 9):(average:3.3999999999999996e-06, median:3e-06) +('sumTree.autoropes', 10):(average:3.4666666666666664e-06, median:3e-06) +('sumTree.nontail', 10):(average:5.4666666666666654e-06, median:5e-06) +('sumTree.noreturn', 10):(average:5.2e-06, median:5e-06) +('sumTree.autoropes', 11):(average:5.533333333333333e-06, median:6e-06) +('sumTree.nontail', 11):(average:8.466666666666668e-06, median:8e-06) +('sumTree.noreturn', 11):(average:8.133333333333334e-06, median:8e-06) +('sumTree.autoropes', 12):(average:8.933333333333333e-06, median:9e-06) +('sumTree.nontail', 12):(average:1.3066666666666665e-05, median:1.3e-05) +('sumTree.noreturn', 12):(average:1.2199999999999997e-05, median:1.2e-05) +('sumTree.autoropes', 13):(average:1.6600000000000004e-05, median:1.7e-05) +('sumTree.nontail', 13):(average:2.126666666666667e-05, median:2.1e-05) +('sumTree.noreturn', 13):(average:2.0866666666666668e-05, median:2.1e-05) +('sumTree.autoropes', 14):(average:3.3066666666666666e-05, median:3.1e-05) +('sumTree.nontail', 14):(average:3.9133333333333334e-05, median:3.8e-05) +('sumTree.noreturn', 14):(average:3.8599999999999996e-05, median:3.8e-05) +('sumTree.autoropes', 15):(average:6.586666666666666e-05, median:6.2e-05) +('sumTree.nontail', 15):(average:7.42e-05, median:7.2e-05) +('sumTree.noreturn', 15):(average:7.219999999999999e-05, median:7.1e-05) +('sumTree.autoropes', 16):(average:0.00012093333333333334, median:0.000121) +('sumTree.nontail', 16):(average:0.00014353333333333326, median:0.000143) +('sumTree.noreturn', 16):(average:0.00014319999999999998, median:0.000142) +('sumTree.autoropes', 17):(average:0.00024406666666666667, median:0.000244) +('sumTree.nontail', 17):(average:0.0003027333333333334, median:0.000302) +('sumTree.noreturn', 17):(average:0.0002831333333333334, median:0.000282) +('sumTree.autoropes', 18):(average:0.0005537333333333334, median:0.000537) +('sumTree.nontail', 18):(average:0.0007198, median:0.000695) +('sumTree.noreturn', 18):(average:0.0006369333333333335, median:0.000615) +('sumTree.autoropes', 19):(average:0.0014812, median:0.001481) +('sumTree.nontail', 19):(average:0.001690466666666667, median:0.001691) +('sumTree.noreturn', 19):(average:0.0015083333333333335, median:0.001513) +('sumTree.autoropes', 20):(average:0.0027620666666666673, median:0.00277) +('sumTree.nontail', 20):(average:0.0034211333333333334, median:0.003386) +('sumTree.noreturn', 20):(average:0.0028672666666666666, median:0.002873) +('sumTree.autoropes', 21):(average:0.004230599999999999, median:0.004244) +('sumTree.nontail', 21):(average:0.0045572, median:0.004555) +('sumTree.noreturn', 21):(average:0.004234, median:0.004225) +('sumTree.autoropes', 22):(average:0.008371466666666667, median:0.00837) +('sumTree.nontail', 22):(average:0.009096066666666668, median:0.009107) +('sumTree.noreturn', 22):(average:0.008391133333333333, median:0.008409) +('sumTree.autoropes', 23):(average:0.016794866666666665, median:0.016797) +('sumTree.nontail', 23):(average:0.018253399999999996, median:0.018236) +('sumTree.noreturn', 23):(average:0.016725, median:0.016736) +('sumTree.autoropes', 24):(average:0.03312893333333334, median:0.033109) +('sumTree.nontail', 24):(average:0.03610886666666667, median:0.036229) +('sumTree.noreturn', 24):(average:0.032984200000000005, median:0.032991) +('sumTree.autoropes', 25):(average:0.06668546666666668, median:0.066351) +('sumTree.nontail', 25):(average:0.07254886666666667, median:0.072647) +('sumTree.noreturn', 25):(average:0.06635753333333333, median:0.066588) +('sumTree.autoropes', 26):(average:0.13499213333333332, median:0.134674) +('sumTree.nontail', 26):(average:0.1441618666666667, median:0.144302) +('sumTree.noreturn', 26):(average:0.13175846666666666, median:0.131681) +('sumTree.autoropes', 27):(average:0.2692754666666667, median:0.265715) +('sumTree.nontail', 27):(average:0.28701139999999997, median:0.286794) +('sumTree.noreturn', 27):(average:0.2621621333333333, median:0.262387) +('sumTree.autoropes', 28):(average:0.5435515333333333, median:0.543395) +('sumTree.nontail', 28):(average:0.570502, median:0.570885) +('sumTree.noreturn', 28):(average:0.5279483999999999, median:0.527691) +('sumTree.autoropes', 29):(average:1.096979, median:1.105299) +('sumTree.nontail', 29):(average:1.135754666666667, median:1.133518) +('sumTree.noreturn', 29):(average:1.0565331999999998, median:1.0579) diff --git a/microbench/tail_recursion/sumTree.autoropes.c b/microbench/tail_recursion/sumTree.autoropes.c index 0ef9c5063..492a92224 100644 --- a/microbench/tail_recursion/sumTree.autoropes.c +++ b/microbench/tail_recursion/sumTree.autoropes.c @@ -124,15 +124,18 @@ void _sumTreeAutoRopes(Tree* root, int* sum, uintptr_t* stack){ int top = -1; push((uintptr_t) root, &top, stack); - + root = NULL; + while(!isEmptyStack(&top)){ - - root = (Tree*) _top(&top, stack); - _pop(&top); + + if (root == NULL){ + root = (Tree*) _top(&top, stack); + _pop(&top); + } *sum += root->value; push((uintptr_t) (root->right), &top, stack); - push((uintptr_t) (root->left), &top, stack); + root = root->left; } } From 83d539443d17584f11daec9a4eaffe193e6929e8 Mon Sep 17 00:00:00 2001 From: vidsinghal Date: Sat, 10 Jun 2023 13:07:21 -0400 Subject: [PATCH 06/25] Tailrec: linked list examples and results --- .../tail_recursion/add1List.autoropes.c | 159 ++++++++++++++++++ microbench/tail_recursion/add1List.notail.c | 82 +++++++++ microbench/tail_recursion/add1List.tailrec.c | 81 +++++++++ microbench/tail_recursion/bench_add1.py | 81 +++++++++ .../experiment_timings_add1.txt | 15 ++ .../experiment_timings_add2.txt | 20 +++ 6 files changed, 438 insertions(+) create mode 100644 microbench/tail_recursion/add1List.autoropes.c create mode 100644 microbench/tail_recursion/add1List.notail.c create mode 100644 microbench/tail_recursion/add1List.tailrec.c create mode 100644 microbench/tail_recursion/bench_add1.py create mode 100644 microbench/tail_recursion/experiment_timings_add1.txt create mode 100644 microbench/tail_recursion/experiment_timings_add2.txt diff --git a/microbench/tail_recursion/add1List.autoropes.c b/microbench/tail_recursion/add1List.autoropes.c new file mode 100644 index 000000000..0b1bed7d8 --- /dev/null +++ b/microbench/tail_recursion/add1List.autoropes.c @@ -0,0 +1,159 @@ +#pragma GCC optimize("O3", "inline") + +#include +#include +#include +#include +#include + + +typedef struct List{ + int value; + struct List* next; +} List; + + +#define stack_size 10000000 + +clock_t start, end; +double cpu_time_used; + + +void display(int* top, uintptr_t* stack) +{ + if(*top>=0) + { + printf("\n The elements in STACK \n"); + for(int i=*top; i>=0; i--) + printf("\n%ld\n",stack[i]); + } + else + { + printf("\n The STACK is empty"); + } + +} + +static inline void push(uintptr_t pointer, int* top, uintptr_t* stack){ + + if ((void*)pointer == NULL) + return; + + if(*top < stack_size - 1 ){ + (*top)++; + stack[*top] = pointer; + } + else{ + printf("Stack Overflow!!\n"); + } +} + +static inline uintptr_t pop(int* top, uintptr_t* stack){ + + if(*top > -1){ + int value = stack[*top]; + (*top)--; + return value; + } + else{ + printf("Stack Underflow\n"); + return -1; + } + +} + +static inline uintptr_t _top(int* top, uintptr_t* stack){ + + if(*top > -1){ + return stack[*top]; + } + else{ + printf("Stack Underflow\n"); + return -1; + } + +} + +static inline void _pop(int* top){ + + if(*top > -1){ + (*top)--; + return; + } + else{ + printf("Stack Underflow\n"); + return; + } + +} + +static inline bool isEmptyStack(int* top){ + + if (*top > -1){ + return false; + } + + return true; + +} + + +void add1ListAutoropes(List* head, uintptr_t* stack){ + + int top = -1; + push((uintptr_t) head, &top, stack); + + while(!isEmptyStack(&top)){ + + head = (List*) _top(&top, stack); + _pop(&top); + + head->value += 1; + + push((uintptr_t) head->next, &top, stack); + + } +} + +List* mkNode(int value){ + + List* newNode = (List*) malloc(sizeof(List)); + newNode->value = value; + newNode->next = NULL; + + return newNode; + +} + +List* initList(int size){ + + List* head = mkNode(0); + List* temp = head; + + for(int i=0; inext = mkNode(i); + temp = temp->next; + } + + return head; + +} + + +int main(int argc, char** argv){ + + int list_size = atoi(argv[1]); + + List* head = initList(list_size); + + uintptr_t* stack = (uintptr_t*) malloc(sizeof(uintptr_t) * stack_size); + + start = clock(); + add1ListAutoropes(head, stack); + end = clock(); + + cpu_time_used = ((double) (end - start)) / CLOCKS_PER_SEC; + + printf("Execution time: %lf\n", cpu_time_used); + +} \ No newline at end of file diff --git a/microbench/tail_recursion/add1List.notail.c b/microbench/tail_recursion/add1List.notail.c new file mode 100644 index 000000000..878f832b4 --- /dev/null +++ b/microbench/tail_recursion/add1List.notail.c @@ -0,0 +1,82 @@ +#pragma GCC optimize("O3", "inline") +#include +#include +#include + +clock_t start, end; +double cpu_time_used; + +typedef struct List{ + int value; + struct List* next; +} List; + +void initArray(int* array, int* arraySize){ + + for(int i=0; i<*arraySize; i++){ + array[i] = i; + } + +} + +void printArray(int* array, int* arraySize){ + + for(int i=0; i<*arraySize; i++){ + printf(" %d ", array[i]); + } + +} + + +__attribute__((optimize("no-optimize-sibling-calls"))) +void add1List_notail(List* head){ + + if (head == NULL){ + return; + } + + head->value += 1; + add1List_notail(head->next); +} + +List* mkNode(int value){ + + List* newNode = (List*) malloc(sizeof(List)); + newNode->value = value; + newNode->next = NULL; + + return newNode; + +} + +List* initList(int size){ + + List* head = mkNode(0); + List* temp = head; + + for(int i=0; inext = mkNode(i); + temp = temp->next; + } + + return head; + +} + + +int main(int argc, char** argv){ + + int list_size = atoi(argv[1]); + + List* head = initList(list_size); + + + start = clock(); + add1List_notail(head); + end = clock(); + + cpu_time_used = ((double) (end - start)) / CLOCKS_PER_SEC; + + printf("Execution time: %lf\n", cpu_time_used); + +} \ No newline at end of file diff --git a/microbench/tail_recursion/add1List.tailrec.c b/microbench/tail_recursion/add1List.tailrec.c new file mode 100644 index 000000000..b13c94e38 --- /dev/null +++ b/microbench/tail_recursion/add1List.tailrec.c @@ -0,0 +1,81 @@ +#pragma GCC optimize("O3", "inline") +#include +#include +#include + +clock_t start, end; +double cpu_time_used; + +typedef struct List{ + int value; + struct List* next; +} List; + +void initArray(int* array, int* arraySize){ + + for(int i=0; i<*arraySize; i++){ + array[i] = i; + } + +} + +void printArray(int* array, int* arraySize){ + + for(int i=0; i<*arraySize; i++){ + printf(" %d ", array[i]); + } + +} + + +void add1List(List* head){ + + if (head == NULL){ + return; + } + + head->value += 1; + add1List(head->next); +} + +List* mkNode(int value){ + + List* newNode = (List*) malloc(sizeof(List)); + newNode->value = value; + newNode->next = NULL; + + return newNode; + +} + +List* initList(int size){ + + List* head = mkNode(0); + List* temp = head; + + for(int i=0; inext = mkNode(i); + temp = temp->next; + } + + return head; + +} + + +int main(int argc, char** argv){ + + int list_size = atoi(argv[1]); + + List* head = initList(list_size); + + + start = clock(); + add1List(head); + end = clock(); + + cpu_time_used = ((double) (end - start)) / CLOCKS_PER_SEC; + + printf("Execution time: %lf\n", cpu_time_used); + +} \ No newline at end of file diff --git a/microbench/tail_recursion/bench_add1.py b/microbench/tail_recursion/bench_add1.py new file mode 100644 index 000000000..95fda6ea3 --- /dev/null +++ b/microbench/tail_recursion/bench_add1.py @@ -0,0 +1,81 @@ +import os +import subprocess +import re +import statistics as stat + +iterations = 9 + +rootdir = "/home/shay/a/singhav/gibbon/microbench/tail_recursion" + + +FILES = ["add1List.autoropes", "add1List.tailrec"] + +Timings = {} + +#Compilation phase +for file in FILES: + + gibbon_file_name = file + + gibbon_cmd = "gcc -O3 " + file + ".c" + " -o " + gibbon_file_name + + print("The gcc command was: ") + print() + print(gibbon_cmd) + print() + + gibbon_cmd_c = subprocess.run(["gcc", "-O3" , file + ".c", "-o", gibbon_file_name]) + print() + + print("The exit code for the gcc compilation was %d" % gibbon_cmd_c.returncode) + + + +#run the files and get the timings +iterations = 15 + +for size in range(1000000, 11000000, 1000000): + for files in FILES: + + times = [] + gibbon_binary = files + + print() + print("Running the binary " + str(gibbon_binary)) + print() + + for i in range(iterations): + + file_stats = gibbon_binary + ".txt" + + cmd = "(" + "cd " + rootdir + " && " + "(" + "./" + gibbon_binary + " " + str(size) + " > " + file_stats + ")" + ")" + + print(cmd) + + gibbon_binary_cmd = subprocess.call(cmd, shell=True) + + data = open(file_stats, 'r').read() + + exec_time = re.findall("Execution time: (.*)", data) + times.append(float(exec_time[0])) + + print() + print(times) + + averageTimes = float (sum(times) / iterations) + medianTimes = stat.median(times) + + tupleTimes = (averageTimes, medianTimes) + + Timings[(gibbon_binary, size)] = tupleTimes + + print() + +print(Timings) + +f = open("experiment_timings_add2.txt", "w") + +for key, value in Timings.items(): + f.write('%s:(average:%s, median:%s)\n' % (key, value[0], value[1])) + +f.close() \ No newline at end of file diff --git a/microbench/tail_recursion/experiment_timings_add1.txt b/microbench/tail_recursion/experiment_timings_add1.txt new file mode 100644 index 000000000..b80c6126f --- /dev/null +++ b/microbench/tail_recursion/experiment_timings_add1.txt @@ -0,0 +1,15 @@ +('add1array.autoropes', 100000):(average:0.0002543333333333333, median:0.000257) +('add1array.notail', 100000):(average:0.0003590666666666667, median:0.000357) +('add1array.tailrec', 100000):(average:0.00020320000000000003, median:0.000201) +('add1array.autoropes', 600000):(average:0.002308666666666667, median:0.002321) +('add1array.notail', 600000):(average:0.0028222, median:0.002821) +('add1array.tailrec', 600000):(average:0.0022367333333333335, median:0.002242) +('add1array.autoropes', 1100000):(average:0.004299333333333333, median:0.004334) +('add1array.notail', 1100000):(average:0.004946866666666666, median:0.004938) +('add1array.tailrec', 1100000):(average:0.0039265333333333334, median:0.003907) +('add1array.autoropes', 1600000):(average:0.004747133333333333, median:0.004738) +('add1array.notail', 1600000):(average:0.0054388, median:0.005375) +('add1array.tailrec', 1600000):(average:0.004568466666666667, median:0.004565) +('add1array.autoropes', 2100000):(average:0.006035066666666668, median:0.005938) +('add1array.notail', 2100000):(average:0.006984866666666668, median:0.007025) +('add1array.tailrec', 2100000):(average:0.006174666666666666, median:0.006139) diff --git a/microbench/tail_recursion/experiment_timings_add2.txt b/microbench/tail_recursion/experiment_timings_add2.txt new file mode 100644 index 000000000..d55e9fa52 --- /dev/null +++ b/microbench/tail_recursion/experiment_timings_add2.txt @@ -0,0 +1,20 @@ +('add1List.autoropes', 1000000):(average:0.0036674000000000003, median:0.003692) +('add1List.tailrec', 1000000):(average:0.003529199999999999, median:0.00352) +('add1List.autoropes', 2000000):(average:0.005822, median:0.005827) +('add1List.tailrec', 2000000):(average:0.005680000000000001, median:0.005577) +('add1List.autoropes', 3000000):(average:0.008976266666666668, median:0.008874) +('add1List.tailrec', 3000000):(average:0.008686, median:0.00872) +('add1List.autoropes', 4000000):(average:0.01213413333333333, median:0.012445) +('add1List.tailrec', 4000000):(average:0.011377733333333334, median:0.011318) +('add1List.autoropes', 5000000):(average:0.01519373333333333, median:0.015613) +('add1List.tailrec', 5000000):(average:0.013906000000000002, median:0.013543) +('add1List.autoropes', 6000000):(average:0.01801173333333333, median:0.018895) +('add1List.tailrec', 6000000):(average:0.01798046666666667, median:0.01807) +('add1List.autoropes', 7000000):(average:0.020375199999999996, median:0.019056) +('add1List.tailrec', 7000000):(average:0.020174533333333338, median:0.020355) +('add1List.autoropes', 8000000):(average:0.02474393333333334, median:0.024709) +('add1List.tailrec', 8000000):(average:0.023061133333333334, median:0.022882) +('add1List.autoropes', 9000000):(average:0.02718493333333333, median:0.027432) +('add1List.tailrec', 9000000):(average:0.025847533333333336, median:0.0265) +('add1List.autoropes', 10000000):(average:0.028658599999999996, median:0.029584) +('add1List.tailrec', 10000000):(average:0.029542133333333335, median:0.030078) From cca5dc97fa17fc364bf535e55abc80e575b8be1c Mon Sep 17 00:00:00 2001 From: Chaitanya Koparkar Date: Tue, 6 Jun 2023 16:18:37 -0400 Subject: [PATCH 07/25] Minor tweak to the workflow file --- .github/workflows/haskell-ci.yml | 18 +----------------- .github/workflows/test-gibbon.yml | 13 ++----------- 2 files changed, 3 insertions(+), 28 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 180f650a4..615a930b6 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -13,19 +13,9 @@ # REGENDATA ("0.12.1",["github","--config=cabal.haskell-ci","cabal.project"]) # name: Haskell-CI -on: - push: - branches: - - master - pull_request: - types: - - opened - - reopened - - synchronize - - ready_for_review +on: [ push, pull_request ] jobs: linux: - if: github.event.pull_request.draft == false name: Haskell-CI - Linux - ${{ matrix.compiler }} runs-on: ubuntu-18.04 container: @@ -170,9 +160,3 @@ jobs: - name: tests run: | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct - fail_if_pull_request_is_draft: - if: github.event.pull_request.draft == true - runs-on: ubuntu-18.04 - steps: - - name: Fails in order to indicate that pull request needs to be marked as ready to review and unit tests workflow needs to pass. - run: exit 1 \ No newline at end of file diff --git a/.github/workflows/test-gibbon.yml b/.github/workflows/test-gibbon.yml index cec83d6ba..2be695993 100644 --- a/.github/workflows/test-gibbon.yml +++ b/.github/workflows/test-gibbon.yml @@ -1,14 +1,5 @@ name: test-gibbon -on: - push: - branches: - - master - pull_request: - types: - - opened - - reopened - - synchronize - - ready_for_review +on: [ push, pull_request ] jobs: linux: if: github.event.pull_request.draft == false @@ -72,4 +63,4 @@ jobs: runs-on: ubuntu-18.04 steps: - name: Fails in order to indicate that pull request needs to be marked as ready to review and unit tests workflow needs to pass. - run: exit 1 \ No newline at end of file + run: exit 1 From aadfbf36dd4e6cfe5ee73518b3ef6db1ea63b90a Mon Sep 17 00:00:00 2001 From: Chaitanya Koparkar Date: Wed, 7 Jun 2023 07:04:23 -0400 Subject: [PATCH 08/25] Use Ubuntu 22.04 on CI --- .github/workflows/haskell-ci.yml | 2 +- .github/workflows/test-gibbon.yml | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 615a930b6..aec048c7f 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -17,7 +17,7 @@ on: [ push, pull_request ] jobs: linux: name: Haskell-CI - Linux - ${{ matrix.compiler }} - runs-on: ubuntu-18.04 + runs-on: ubuntu-22.04 container: image: buildpack-deps:bionic continue-on-error: ${{ matrix.allow-failure }} diff --git a/.github/workflows/test-gibbon.yml b/.github/workflows/test-gibbon.yml index 2be695993..6f7dbceae 100644 --- a/.github/workflows/test-gibbon.yml +++ b/.github/workflows/test-gibbon.yml @@ -4,7 +4,7 @@ jobs: linux: if: github.event.pull_request.draft == false name: test-gibbon - runs-on: ubuntu-18.04 + runs-on: ubuntu-22.04 steps: - name: dependencies run: | @@ -13,6 +13,8 @@ jobs: sudo apt-get update sudo add-apt-repository -y 'ppa:plt/racket' sudo apt-get update + 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-7 ghc-9.0.1 racket sudo unlink /usr/bin/gcc && sudo ln -s /usr/bin/gcc-7 /usr/bin/gcc - name: versions From 750632fad1d6b16f93a9a9be9523ae9714aaec64 Mon Sep 17 00:00:00 2001 From: Chaitanya Koparkar Date: Wed, 7 Jun 2023 08:06:24 -0400 Subject: [PATCH 09/25] Use GCC11 and use ghcup to install GHC --- .github/workflows/haskell-ci.yml | 125 +++++++++++++++++++++--------- .github/workflows/test-gibbon.yml | 36 +++++---- 2 files changed, 110 insertions(+), 51 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index aec048c7f..17fb46e20 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,65 +8,109 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.12.1 +# version: 0.16.3 # -# REGENDATA ("0.12.1",["github","--config=cabal.haskell-ci","cabal.project"]) +# REGENDATA ("0.16.3",["--distribution","jammy","github","cabal.project"]) # name: Haskell-CI -on: [ push, pull_request ] +on: + - push + - pull_request jobs: linux: name: Haskell-CI - Linux - ${{ matrix.compiler }} 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: include: - compiler: ghc-9.0.1 + compilerKind: ghc + compilerVersion: 9.0.1 + setup-method: ghcup allow-failure: false - compiler: ghc-8.10.4 + compilerKind: ghc + compilerVersion: 8.10.4 + setup-method: ghcup allow-failure: false - compiler: ghc-8.8.4 + compilerKind: ghc + compilerVersion: 8.8.4 + setup-method: ghcup allow-failure: false - compiler: ghc-8.6.5 + compilerKind: ghc + compilerVersion: 8.6.5 + setup-method: ghcup allow-failure: false - compiler: ghc-8.4.4 + compilerKind: ghc + compilerVersion: 8.4.4 + setup-method: ghcup allow-failure: false fail-fast: false steps: - name: apt run: | apt-get update - apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common - apt-add-repository -y 'ppa:hvr/ghc' - apt-get update - apt-get install -y $CC cabal-install-3.4 + 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.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.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.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.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + fi env: - CC: ${{ matrix.compiler }} + HCKIND: ${{ matrix.compilerKind }} + HCNAME: ${{ matrix.compiler }} + HCVER: ${{ matrix.compilerVersion }} - name: Set PATH and environment variables run: | echo "$HOME/.cabal/bin" >> $GITHUB_PATH - echo "LANG=C.UTF-8" >> $GITHUB_ENV - echo "CABAL_DIR=$HOME/.cabal" >> $GITHUB_ENV - echo "CABAL_CONFIG=$HOME/.cabal/config" >> $GITHUB_ENV - HCDIR=$(echo "/opt/$CC" | sed 's/-/\//') - HCNAME=ghc - HC=$HCDIR/bin/$HCNAME - echo "HC=$HC" >> $GITHUB_ENV - echo "HCPKG=$HCDIR/bin/$HCNAME-pkg" >> $GITHUB_ENV - echo "HADDOCK=$HCDIR/bin/haddock" >> $GITHUB_ENV - echo "CABAL=/opt/cabal/3.4/bin/cabal -vnormal+nowrap" >> $GITHUB_ENV + echo "LANG=C.UTF-8" >> "$GITHUB_ENV" + 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.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.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))') - echo "HCNUMVER=$HCNUMVER" >> $GITHUB_ENV - echo "ARG_TESTS=--enable-tests" >> $GITHUB_ENV - echo "ARG_BENCH=--enable-benchmarks" >> $GITHUB_ENV - echo "HEADHACKAGE=false" >> $GITHUB_ENV - echo "ARG_COMPILER=--$HCNAME --with-compiler=$HC" >> $GITHUB_ENV - echo "GHCJSARITH=0" >> $GITHUB_ENV + echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" + echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" + echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" + echo "HEADHACKAGE=false" >> "$GITHUB_ENV" + echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" + echo "GHCJSARITH=0" >> "$GITHUB_ENV" env: - CC: ${{ matrix.compiler }} + HCKIND: ${{ matrix.compilerKind }} + HCNAME: ${{ matrix.compiler }} + HCVER: ${{ matrix.compilerVersion }} - name: env run: | env @@ -89,6 +133,10 @@ jobs: repository hackage.haskell.org url: http://hackage.haskell.org/ EOF + cat >> $CABAL_CONFIG < 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 @@ -127,7 +175,8 @@ jobs: - name: generate cabal.project run: | PKGDIR_gibbon="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/gibbon-[0-9.]*')" - echo "PKGDIR_gibbon=${PKGDIR_gibbon}" >> $GITHUB_ENV + echo "PKGDIR_gibbon=${PKGDIR_gibbon}" >> "$GITHUB_ENV" + rm -f cabal.project cabal.project.local touch cabal.project touch cabal.project.local echo "packages: ${PKGDIR_gibbon}" >> cabal.project @@ -142,13 +191,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: | @@ -160,3 +207,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.yml b/.github/workflows/test-gibbon.yml index 6f7dbceae..e0c6764f3 100644 --- a/.github/workflows/test-gibbon.yml +++ b/.github/workflows/test-gibbon.yml @@ -8,15 +8,27 @@ jobs: 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 add-apt-repository -y ppa:ubuntu-toolchain-r/test sudo apt 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 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 @@ -26,8 +38,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@v2 with: @@ -41,8 +53,8 @@ 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: @@ -59,10 +71,4 @@ jobs: run: | export GIBBONDIR=`pwd` cd gibbon-compiler/ - cabal v2-exec -w /opt/ghc/9.0.1/bin/ghc test-gibbon-examples -- -v2 - fail_if_pull_request_is_draft: - if: github.event.pull_request.draft == true - runs-on: ubuntu-18.04 - steps: - - name: Fails in order to indicate that pull request needs to be marked as ready to review and unit tests workflow needs to pass. - run: exit 1 + cabal v2-exec -w $HC test-gibbon-examples -- -v2 From 33aa00736da970839f8f70dfba13b8cbfbcf6acf Mon Sep 17 00:00:00 2001 From: Chaitanya Koparkar Date: Wed, 14 Jun 2023 11:05:19 -0400 Subject: [PATCH 10/25] Allow GHC 8.6.5 and 8.4.4 to fail --- .github/workflows/haskell-ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 17fb46e20..418ebd73d 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -47,12 +47,12 @@ jobs: compilerKind: ghc compilerVersion: 8.6.5 setup-method: ghcup - allow-failure: false + allow-failure: true - compiler: ghc-8.4.4 compilerKind: ghc compilerVersion: 8.4.4 setup-method: ghcup - allow-failure: false + allow-failure: true fail-fast: false steps: - name: apt From 9a628eaba4a568fd4c807c2fafc826d3fcd9d147 Mon Sep 17 00:00:00 2001 From: Chaitanya Koparkar Date: Wed, 14 Jun 2023 11:26:51 -0400 Subject: [PATCH 11/25] Mark failing tests --- .github/workflows/test-gibbon.yml | 2 +- gibbon-compiler/tests/config.yaml | 20 +++++++++++++++++--- 2 files changed, 18 insertions(+), 4 deletions(-) diff --git a/.github/workflows/test-gibbon.yml b/.github/workflows/test-gibbon.yml index e0c6764f3..e6c3b14dc 100644 --- a/.github/workflows/test-gibbon.yml +++ b/.github/workflows/test-gibbon.yml @@ -31,7 +31,7 @@ jobs: echo "$HOME/.ghcup/bin/" >> $GITHUB_PATH - name: versions run: | - ghc --version + $HC --version racket --version gcc --version stack --version diff --git a/gibbon-compiler/tests/config.yaml b/gibbon-compiler/tests/config.yaml index ab65ffa72..956e9cf49 100644 --- a/gibbon-compiler/tests/config.yaml +++ b/gibbon-compiler/tests/config.yaml @@ -71,6 +71,8 @@ tests: - name: test11f_funrec.gib - name: test11_fundata.gib - name: test12b_traverse.gib + # Unexpected segfault. + failing: [pointer] - name: test12c_traverse.gib - name: test13b_build.gib - name: test13_build.gib @@ -91,11 +93,15 @@ tests: - name: test14c_tail.gib - name: test14d_unary_tup.gib - name: test15a_symsearch.gib + # Unexpected segfault. + failing: [pointer] - name: test15c_printsym.gib skip: true # printing symbols is broken atm - name: test15d_symsearch.hs answer-file: examples/test15d_symsearch.ans + # Unexpected segfault. + failing: [pointer] - name: test15e_gensym.hs answer-file: examples/test15e_gensym.ans # Gensym is broken in the interpreter. (randomIO is not determinisitc, we probably should use a fixed seed for interpreter) @@ -330,6 +336,8 @@ tests: - name: NeedsClosure.hs dir: examples/poly answer-file: examples/poly/NeedsClosure.hs.ans + # Unexpected segfault. + failing: [pointer] - name: MutualRec.hs dir: examples/poly @@ -414,12 +422,16 @@ tests: test-flags: ["--parallel"] failing: [interp1] answer-file: examples/vectors/Vector.hs.ans + # Needs cilk. + skip: true - name: SortPrim.hs dir: examples/vectors test-flags: ["--parallel"] failing: [interp1] answer-file: examples/vectors/SortPrim.ans + # Needs cilk. + skip: true - name: Sort.hs skip: true @@ -430,6 +442,8 @@ tests: dir: examples/vectors test-flags: ["--parallel"] answer-file: examples/vectors/DataVector.hs.ans + # Needs cilk. + skip: true ## AST benchmarks - name: C1.hs @@ -442,7 +456,7 @@ tests: - name: test29d_list.gib failing: [gibbon1] - name: test18f_flip.gib - failing: [gibbon2, gibbon1] + failing: [gibbon2, gibbon1, pointer] - name: pp_projs.gib skip: true - name: test12_skip.gib @@ -514,5 +528,5 @@ tests: - name: test_191.hs answer-file: examples/test_191.ans - failing: [pointer, gibbon1, interp1] - run-modes: ["gibbon2"] + failing: [pointer, gibbon1, interp1] + run-modes: ["gibbon2"] From 218bbdabbaba7b81cddc831c18a16b79eca4b829 Mon Sep 17 00:00:00 2001 From: Chaitanya Koparkar Date: Mon, 26 Jun 2023 12:33:29 -0400 Subject: [PATCH 12/25] Disable tests that build with GHC 8.6.5 and 8.4.4 --- .github/workflows/haskell-ci.yml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 418ebd73d..a6d0bba11 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -43,16 +43,16 @@ jobs: compilerVersion: 8.8.4 setup-method: ghcup allow-failure: false - - compiler: ghc-8.6.5 - compilerKind: ghc - compilerVersion: 8.6.5 - setup-method: ghcup - allow-failure: true - - compiler: ghc-8.4.4 - compilerKind: ghc - compilerVersion: 8.4.4 - setup-method: ghcup - allow-failure: true + # - compiler: ghc-8.6.5 + # compilerKind: ghc + # compilerVersion: 8.6.5 + # setup-method: ghcup + # allow-failure: true + # - compiler: ghc-8.4.4 + # compilerKind: ghc + # compilerVersion: 8.4.4 + # setup-method: ghcup + # allow-failure: true fail-fast: false steps: - name: apt From 4df576fad65c34ee707d696ee6f1aded0f6ca8d0 Mon Sep 17 00:00:00 2001 From: Chaitanya Koparkar Date: Wed, 5 Jul 2023 07:48:23 -0400 Subject: [PATCH 13/25] Update GHC to v9.6.2 --- .github/workflows/haskell-ci.yml | 29 ++++++----- .github/workflows/test-gibbon.yml | 2 +- gibbon-compiler/gibbon.cabal | 51 ++++++++++---------- gibbon-compiler/src/Gibbon/Common.hs | 1 + gibbon-compiler/src/Gibbon/Compiler.hs | 7 +-- gibbon-compiler/src/Gibbon/L0/Specialize2.hs | 3 +- gibbon-compiler/src/Gibbon/L0/Syntax.hs | 1 - gibbon-compiler/src/Gibbon/L1/Typecheck.hs | 5 +- gibbon-compiler/src/Gibbon/L2/Interp.hs | 1 + gibbon-compiler/src/Gibbon/L2/Typecheck.hs | 7 +-- gibbon-compiler/src/Gibbon/L3/Typecheck.hs | 3 +- gibbon-compiler/src/Gibbon/Passes/Flatten.hs | 1 + shell.nix | 20 ++++---- 13 files changed, 72 insertions(+), 59 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index a6d0bba11..404589731 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -28,9 +28,24 @@ jobs: strategy: matrix: include: - - compiler: ghc-9.0.1 + - compiler: ghc-9.6.2 compilerKind: ghc - compilerVersion: 9.0.1 + compilerVersion: 9.6.2 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.4.5 + compilerKind: ghc + compilerVersion: 9.4.5 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.2.8 + compilerKind: ghc + compilerVersion: 9.2.8 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.0.2 + compilerKind: ghc + compilerVersion: 9.0.2 setup-method: ghcup allow-failure: false - compiler: ghc-8.10.4 @@ -43,16 +58,6 @@ jobs: compilerVersion: 8.8.4 setup-method: ghcup allow-failure: false - # - compiler: ghc-8.6.5 - # compilerKind: ghc - # compilerVersion: 8.6.5 - # setup-method: ghcup - # allow-failure: true - # - compiler: ghc-8.4.4 - # compilerKind: ghc - # compilerVersion: 8.4.4 - # setup-method: ghcup - # allow-failure: true fail-fast: false steps: - name: apt diff --git a/.github/workflows/test-gibbon.yml b/.github/workflows/test-gibbon.yml index e6c3b14dc..1c67b468e 100644 --- a/.github/workflows/test-gibbon.yml +++ b/.github/workflows/test-gibbon.yml @@ -18,7 +18,7 @@ jobs: - name: ghc and cabal env: HCKIND: ghc - HCVER: 9.0.1 + HCVER: 9.6.2 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" diff --git a/gibbon-compiler/gibbon.cabal b/gibbon-compiler/gibbon.cabal index eb9e85b1e..c8f910f70 100644 --- a/gibbon-compiler/gibbon.cabal +++ b/gibbon-compiler/gibbon.cabal @@ -13,11 +13,12 @@ category: Compilers/Interpreters build-type: Simple extra-source-files: README.md, cbits/rts.c cabal-version: >=1.10 -tested-with: GHC==9.0.1 +tested-with: GHC==9.6.2 + , GHC==9.4.5 + , GHC==9.2.8 + , GHC==9.0.2 , GHC==8.10.4 , GHC==8.8.4 - , GHC==8.6.5 - , GHC==8.4.4 flag LLVM_ENABLED description: Enable LLVM backend @@ -84,34 +85,34 @@ library other-extensions: DeriveDataTypeable CPP - build-depends: base >= 4.11 && < 4.16 - , bytestring >= 0.10.8.1 && < 0.11 - , text >= 1.2.3 && < 1.3 - , process >= 1.4.3 && < 1.7 - , filepath >= 1.4.1 && < 1.5 - , directory >= 1.3 && < 1.4 + build-depends: base >= 4.11 && < 5 + , bytestring >= 0.10.8.1 && < 1 + , text >= 1.2.3 && < 3 + , process >= 1.4.3 && < 2 + , filepath >= 1.4.1 && < 2 + , directory >= 1.3 && < 2 , containers >= 0.5.8 && < 0.7 , deepseq >= 1.4.2 && < 1.5 - , mtl >= 2.2.1 && < 2.3 - , transformers >= 0.5.2 && < 0.6 - , clock >= 0.7.1 && < 0.9 - , random >= 1.1 && < 1.2 + , mtl >= 2.2.1 && < 3 + , transformers >= 0.5.2 && < 1 + , clock >= 0.7.1 && < 1 + , random >= 1.1 && < 1.3 , recursion-schemes >= 5.1 && < 6 - , vector - , tuple + , vector >= 0.12 && < 0.14 + , tuple >= 0.3 && < 1 -- Parsers: - , parsec >= 3.1.13 && < 3.2 - , optparse-applicative >= 0.13.2 && < 0.17 - , haskell-src-exts >= 1.20.2 && < 1.22 - , hse-cpp >= 0.1 && < 0.3 - , s-cargot >= 0.1.3 && < 0.2 - , srcloc >= 0.5.1 && < 0.6 - , symbol >= 0.2.4 && < 0.3 + , parsec >= 3 && < 4 + , optparse-applicative >= 0.13 && < 1 + , haskell-src-exts >= 1.20 && < 2 + , hse-cpp >= 0.1 && < 1 + , s-cargot >= 0.1.3 && < 1 + , srcloc >= 0.6 && < 1 + , symbol >= 0.2.4 && < 1 -- Pretty printers: , pretty >= 1.1.1.3 && < 1.2 - , GenericPretty >= 1.2.1 && < 1.3 - , language-c-quote >= 0.12.1 && < 0.13 - , mainland-pretty >= 0.6.1 && < 0.8 + , GenericPretty >= 1.2.1 && < 2 + , language-c-quote >= 0.12.1 && < 1 + , mainland-pretty >= 0.6.1 && < 1 -- Brings in lots of ekmett dependencies: -- , either diff --git a/gibbon-compiler/src/Gibbon/Common.hs b/gibbon-compiler/src/Gibbon/Common.hs index da795d166..8e69c53f7 100644 --- a/gibbon-compiler/src/Gibbon/Common.hs +++ b/gibbon-compiler/src/Gibbon/Common.hs @@ -42,6 +42,7 @@ import Control.Exception (evaluate) -- 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 import Control.Monad.State.Strict import Control.Monad.Reader import Data.Functor.Foldable diff --git a/gibbon-compiler/src/Gibbon/Compiler.hs b/gibbon-compiler/src/Gibbon/Compiler.hs index 6b7b87465..f4cc919e8 100644 --- a/gibbon-compiler/src/Gibbon/Compiler.hs +++ b/gibbon-compiler/src/Gibbon/Compiler.hs @@ -22,6 +22,7 @@ import Control.DeepSeq import Control.Exception #if !MIN_VERSION_base(4,15,0) #endif +import Control.Monad import Control.Monad.State.Strict import Control.Monad.Reader (ask) #if !MIN_VERSION_base(4,11,0) @@ -535,7 +536,7 @@ 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 + l1 <- goE1 "removeCopyAliases" removeAliasesForCopyCalls l1 l2 <- goE2 "inferLocations" inferLocs l1 l2 <- goE2 "simplifyLocBinds_a" simplifyLocBinds l2 l2 <- go "L2.typecheck" L2.tcProg l2 @@ -592,8 +593,8 @@ 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. + -- 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 l2 <- go "inferLocations2" inferLocs l1 diff --git a/gibbon-compiler/src/Gibbon/L0/Specialize2.hs b/gibbon-compiler/src/Gibbon/L0/Specialize2.hs index 151d008be..1f11ccd17 100644 --- a/gibbon-compiler/src/Gibbon/L0/Specialize2.hs +++ b/gibbon-compiler/src/Gibbon/L0/Specialize2.hs @@ -17,6 +17,7 @@ module Gibbon.L0.Specialize2 (bindLambdas, monomorphize, specLambdas, desugarL0, toL1, floatOutCase) where +import Control.Monad import Control.Monad.State import Data.Foldable ( foldlM, foldrM ) import qualified Data.Map as M @@ -1492,7 +1493,7 @@ desugarL0 (Prog ddefs fundefs' mainExp') = do (bnds', args') <- unzip <$> zipWithM flattenTupleArgs args tys' pure (concat bnds',concat args') _ -> do - -- generating alias so that repeated expression is + -- generating alias so that repeated expression is -- eliminated and we are taking projection of trivial varEs argalias <- gensym "alias" ys <- mapM (\_ -> gensym "proj") tys' diff --git a/gibbon-compiler/src/Gibbon/L0/Syntax.hs b/gibbon-compiler/src/Gibbon/L0/Syntax.hs index 77bf64acc..0ab8cae48 100644 --- a/gibbon-compiler/src/Gibbon/L0/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/L0/Syntax.hs @@ -75,7 +75,6 @@ data LinearExt loc dec = deriving instance Generic Loc.Loc deriving instance Generic Loc.Pos -deriving instance Ord Loc.Loc deriving instance NFData Loc.Pos deriving instance NFData Loc.Loc diff --git a/gibbon-compiler/src/Gibbon/L1/Typecheck.hs b/gibbon-compiler/src/Gibbon/L1/Typecheck.hs index 4b7f4dcd7..ddc081b23 100644 --- a/gibbon-compiler/src/Gibbon/L1/Typecheck.hs +++ b/gibbon-compiler/src/Gibbon/L1/Typecheck.hs @@ -13,6 +13,7 @@ module Gibbon.L1.Typecheck where +import Control.Monad import Control.Monad.Except import Data.Map as M import Data.Set as S @@ -125,12 +126,12 @@ tcExp ddfs env exp = _ <- ensureEqualTy (es !! 0) FloatTy (tys !! 0) _ <- ensureEqualTy (es !! 1) FloatTy (tys !! 1) pure BoolTy - + char_cmps = do len2 _ <- ensureEqualTy (es !! 0) CharTy (tys !! 0) _ <- ensureEqualTy (es !! 1) CharTy (tys !! 1) - pure BoolTy + pure BoolTy case pr of MkTrue -> mk_bools diff --git a/gibbon-compiler/src/Gibbon/L2/Interp.hs b/gibbon-compiler/src/Gibbon/L2/Interp.hs index cc4f6e335..f36fb0bb2 100644 --- a/gibbon-compiler/src/Gibbon/L2/Interp.hs +++ b/gibbon-compiler/src/Gibbon/L2/Interp.hs @@ -14,6 +14,7 @@ where import Control.DeepSeq import Control.Monad.Writer import Control.Monad.State +import Control.Monad import Data.ByteString.Builder (Builder, toLazyByteString, string8) import Data.Foldable (foldlM) import System.Clock diff --git a/gibbon-compiler/src/Gibbon/L2/Typecheck.hs b/gibbon-compiler/src/Gibbon/L2/Typecheck.hs index c235bbdda..7caf5938b 100644 --- a/gibbon-compiler/src/Gibbon/L2/Typecheck.hs +++ b/gibbon-compiler/src/Gibbon/L2/Typecheck.hs @@ -18,8 +18,9 @@ module Gibbon.L2.Typecheck where import Control.DeepSeq +import Control.Monad import Control.Monad.Except -import Data.Foldable ( foldlM ) +import Data.Foldable ( foldlM, foldrM ) import qualified Data.Set as S import qualified Data.List as L import qualified Data.Map as M @@ -231,8 +232,8 @@ tcExp ddfs env funs constrs regs tstatein exp = _ <- ensureEqualTy (es !! 0) FloatTy (tys !! 0) _ <- ensureEqualTy (es !! 1) FloatTy (tys !! 1) pure (BoolTy, tstate) - - char_cmps = do + + char_cmps = do len2 _ <- ensureEqualTy (es !! 0) CharTy (tys !! 0) _ <- ensureEqualTy (es !! 1) CharTy (tys !! 1) diff --git a/gibbon-compiler/src/Gibbon/L3/Typecheck.hs b/gibbon-compiler/src/Gibbon/L3/Typecheck.hs index f95b74685..f8276ccec 100644 --- a/gibbon-compiler/src/Gibbon/L3/Typecheck.hs +++ b/gibbon-compiler/src/Gibbon/L3/Typecheck.hs @@ -7,6 +7,7 @@ module Gibbon.L3.Typecheck ( tcProg, tcExp ) where +import Control.Monad import Control.Monad.Except import qualified Data.Map as M import qualified Data.List as L @@ -252,7 +253,7 @@ tcExp isPacked ddfs env exp = _ <- ensureEqualTy (es !! 0) FloatTy (tys !! 0) _ <- ensureEqualTy (es !! 1) FloatTy (tys !! 1) pure BoolTy - + char_cmps = do len2 _ <- ensureEqualTy (es !! 0) CharTy (tys !! 0) diff --git a/gibbon-compiler/src/Gibbon/Passes/Flatten.hs b/gibbon-compiler/src/Gibbon/Passes/Flatten.hs index 16110416e..03cfc1973 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Flatten.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Flatten.hs @@ -8,6 +8,7 @@ module Gibbon.Passes.Flatten ( flattenL0, flattenL1, flattenL2, flattenL3 ) where +import Control.Monad import Control.Monad.State import Text.PrettyPrint.GenericPretty import Prelude hiding (exp) diff --git a/shell.nix b/shell.nix index 4a7ec2e62..b117fcb6d 100644 --- a/shell.nix +++ b/shell.nix @@ -1,22 +1,22 @@ { pkgs ? import (builtins.fetchGit { - name = "nixos-unstable-2021-03-11"; - url = "https://github.com/nixos/nixpkgs/"; - # Commit hash for nixos-unstable as of 2021-03-11 - # `git ls-remote https://github.com/nixos/nixpkgs master` - ref = "refs/heads/master"; - rev = "a3228bb6e8bdbb9900f30a11fe09006fdabf7b71"; - }) {} + name = "nixos-master"; + url = "https://github.com/nixos/nixpkgs/"; + # Commit hash for nixos as of 2023-07-05 + # `git ls-remote https://github.com/nixos/nixpkgs master` + ref = "refs/heads/master"; + rev = "26402a0a438220e418c31a2c93c15f319d19527a"; + }) {} , stdenv ? pkgs.overrideCC pkgs.stdenv pkgs.gcc7 -, ghc ? pkgs.haskell.compiler.ghc865 -, ghc901 ? pkgs.haskell.compiler.ghc901 +, ghc ? pkgs.haskell.compiler.ghc96 +, ghc902 ? pkgs.haskell.compiler.ghc902 }: with pkgs; stdenv.mkDerivation { name = "basicGibbonEnv"; - buildInputs = [ ghc ghc901 gcc7 which boehmgc uthash racket cabal-install ghcid + buildInputs = [ ghc ghc902 gcc7 which boehmgc uthash racket cabal-install ghcid gdb valgrind stack stdenv ncurses unzip rr ]; } From 04615d74bac2c210c6c1f60538ecb0b159eb99e0 Mon Sep 17 00:00:00 2001 From: Aditya Gupta Date: Fri, 23 Jun 2023 01:50:10 +0000 Subject: [PATCH 14/25] Update devcontainers [skip ci] --- .devcontainer/Dockerfile | 55 ++++++++++++++++++++++++--------- .devcontainer/devcontainer.json | 8 ++--- 2 files changed, 43 insertions(+), 20 deletions(-) diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile index 8fa61acb6..01ba1becc 100644 --- a/.devcontainer/Dockerfile +++ b/.devcontainer/Dockerfile @@ -1,18 +1,43 @@ -# See here for image contents: https://github.com/microsoft/vscode-dev-containers/tree/v0.194.0/containers/ubuntu/.devcontainer/base.Dockerfile +# Ubuntu 22 +ARG VARIANT="jammy" +ARG DEBIAN_FRONTEND=noninteractive +FROM mcr.microsoft.com/vscode/devcontainers/base:0-${VARIANT} as base +ENV USERNAME=vscode -# [Choice] Ubuntu version: bionic, focal -ARG VARIANT="bionic" -FROM mcr.microsoft.com/vscode/devcontainers/base:0-${VARIANT} -# [Optional] Uncomment this section to install additional OS packages. -RUN apt-get update && export DEBIAN_FRONTEND=noninteractive \ - && sudo apt-get -y install --no-install-recommends software-properties-common \ - && sudo add-apt-repository -y ppa:plt/racket \ - && sudo add-apt-repository -y ppa:hvr/ghc \ - && sudo apt-get -y install --no-install-recommends libgc-dev libgmp-dev \ - gcc-7 uthash-dev racket \ - ghc-9.0.1 cabal-install-3.4 vim -RUN curl -sSL https://get.haskellstack.org/ | sh -ENV PATH /opt/ghc/bin:/opt/cabal/bin:$PATH -RUN sudo ln -sf /usr/bin/gcc-7 /usr/bin/gcc +# install dependencies +RUN --mount=target=/var/lib/apt/lists,type=cache,sharing=locked \ + --mount=target=/var/cache/apt,type=cache,sharing=locked \ + apt-get update && \ + apt-get -y install --no-install-recommends software-properties-common && \ + add-apt-repository -y ppa:plt/racket && \ + apt-get -y install --no-install-recommends \ + libgc-dev \ + libgmp-dev \ + racket \ + uthash-dev \ + vim + +# update path +USER ${USERNAME} +WORKDIR /home/${USERNAME} +ENV PATH="/home/${USERNAME}/.local/bin:/home/${USERNAME}/.cabal/bin:/home/${USERNAME}/.ghcup/bin:$PATH" +RUN echo "export PATH=${PATH}" >> /home/${USERNAME}/.profile + +# install ghcup +RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh + +ARG GHC=9.0.2 +ARG CABAL=3.4 +ARG STACK=2.9.3 +ARG HLS=recommended + +# install GHC, cabal and HLS +RUN \ + ghcup install ghc ${GHC} --set && \ + ghcup install cabal ${CABAL} --set && \ + ghcup install stack ${STACK} --set && \ + ghcup install hls ${HLS} --set + +# update cabal package list RUN cabal update \ No newline at end of file diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json index 65a932251..141669ed2 100644 --- a/.devcontainer/devcontainer.json +++ b/.devcontainer/devcontainer.json @@ -3,10 +3,9 @@ { "name": "Ubuntu", "build": { - "dockerfile": "Dockerfile", - // Update 'VARIANT' to pick an Ubuntu version: focal, bionic - "args": { "VARIANT": "bionic" } - }, + "dockerfile": "Dockerfile", + "args": { "VARIANT": "jammy" } + }, // Set *default* container specific settings.json values on container create. "settings": {}, @@ -23,5 +22,4 @@ // Comment out connect as root instead. More info: https://aka.ms/vscode-remote/containers/non-root. "remoteUser": "vscode" - } \ No newline at end of file From e554f1cf8cb8468e84103ae6ba72abc91e3f68bc Mon Sep 17 00:00:00 2001 From: vidsinghal Date: Wed, 16 Aug 2023 11:22:26 -0400 Subject: [PATCH 15/25] Passes: Control Flow Graph --- gibbon-compiler/gibbon.cabal | 1 + .../src/Gibbon/Passes/ControlFlowGraph.hs | 200 ++++++++++++++++++ 2 files changed, 201 insertions(+) create mode 100644 gibbon-compiler/src/Gibbon/Passes/ControlFlowGraph.hs diff --git a/gibbon-compiler/gibbon.cabal b/gibbon-compiler/gibbon.cabal index c8f910f70..e879129bd 100644 --- a/gibbon-compiler/gibbon.cabal +++ b/gibbon-compiler/gibbon.cabal @@ -82,6 +82,7 @@ library Gibbon.Passes.RearrangeFree Gibbon.Passes.Codegen Gibbon.Passes.CalculateBounds + Gibbon.Passes.ControlFlowGraph other-extensions: DeriveDataTypeable CPP diff --git a/gibbon-compiler/src/Gibbon/Passes/ControlFlowGraph.hs b/gibbon-compiler/src/Gibbon/Passes/ControlFlowGraph.hs new file mode 100644 index 000000000..d24ae03c9 --- /dev/null +++ b/gibbon-compiler/src/Gibbon/Passes/ControlFlowGraph.hs @@ -0,0 +1,200 @@ +module Gibbon.Passes.ControlFlowGraph + ( getFunctionCFG + , CFGfunctionMap(..) + ) where + + +-- Gibbon Imports +import Gibbon.Common +import Gibbon.Language +import Gibbon.Language.Syntax + +import Control.Monad as Monad +import Data.Graph as G +import Data.List as L +import Data.Map as M +import Data.Maybe as Maybe +import Data.Set as S + +-- Haskell Imports +import Prelude as P + + +-- | CFGfunctionMap ex, a map storing a function, represented by Var (function name) to its control flow graph +-- | Edge == (ex, Integer) the IR expression and its corresponding probability +-- | See Data.Containers for detailed definition about how the graph is stored and represented. +type CFGfunctionMap ex + = M.Map Var ( G.Graph + , G.Vertex -> ((ex, Integer), Integer, [Integer]) + , Integer -> Maybe G.Vertex) + + +-- -- | Takes a map, list of function definitions, return update map with CFG for each funciton in the list +-- generateCfgFunctions :: CFGfunctionMap -> FieldMap -> [FunDef (PreExp e l d)] -> DataCon -> (CFGfunctionMap, FieldMap) +-- generateCfgFunctions cfgMap fieldMap defs datacon = +-- case defs of +-- [] -> (cfgMap, fieldMap) +-- x:xs -> let +-- (cfgMapNew, edgeList, fieldGraphEdges) = generateCfgFunction cfgMap x datacon +-- dconAccessMap = M.insert datacon fieldGraphEdges (M.empty) +-- updatedFieldMap = M.insert x dconAccessMap fieldMap +-- in generateCfgFunctions cfgMapNew updatedFieldMap xs datacon + +-- -- | Generate a CFG for the corresponsing function +-- generateCfgFunction :: CFGfunctionMap -> FunDef (PreExp e l d) -> DataCon -> (CFGfunctionMap, [(((PreExp e l d), Integer) , Integer, [Integer])], [((Integer, Integer), Integer)]) +-- generateCfgFunction cfgMap f@FunDef { funName, funBody, funTy, funArgs } datacon = +-- let (edgeList, succ, maxDepth) = generateCFGExp 0 100 funBody +-- (graph, nodeFromVertex, vertexFromKey) = G.graphFromEdges edgeList +-- newCFGMap = M.insert f (graph, nodeFromVertex, vertexFromKey) cfgMap +-- topSortedVertices = topSort graph +-- topSortedNodes = P.map nodeFromVertex topSortedVertices +-- map = backtrackVariablesToDataConFields topSortedNodes +-- edges = constructFieldGraph Nothing nodeFromVertex vertexFromKey topSortedNodes topSortedNodes map datacon +-- in (newCFGMap, edgeList, edges) +-- -- dbgTraceIt (sdoc varList) dbgTraceIt ("\n") dbgTraceIt (sdoc varList') dbgTraceIt ("\n") +-- -- dbgTraceIt (sdoc x') dbgTraceIt ("\n") dbgTraceIt (sdoc map) dbgTraceIt ("\n") +-- -- pure (cfgMap, edgeList) +-- -- dbgTraceIt (sdoc x) dbgTraceIt (sdoc x') dbgTraceIt ("\n") dbgTraceIt (sdoc edges) dbgTraceIt ("\n") pure (cfgMap, edgeList) + +-- | Generate a CFG out of a Function definition. +-- | Returns a map mapping a function to its corresponding CFG +getFunctionCFG :: FunDef (PreExp e l d) -> CFGfunctionMap (PreExp e l d) +getFunctionCFG f@FunDef {funName, funBody, funTy, funArgs} = + let (edgeList, _, _) = generateCFGExp 0 100 funBody + (graph, nodeFromVertex, vertexFromKey) = G.graphFromEdges edgeList + in M.insert funName (graph, nodeFromVertex, vertexFromKey) (M.empty) + + +-- | generate the Edges from the IR expression. +generateCFGExp :: + Integer + -> Integer + -> (PreExp e l d) + -> ([(((PreExp e l d), Integer), Integer, [Integer])], Integer, Integer) +generateCFGExp vertexCounter edgeWeight exp = + case exp of + DataConE loc dcon args -> + let edge = ((exp, edgeWeight), vertexCounter, []) + in ([edge], vertexCounter, vertexCounter) + VarE {} -> + let edge = ((exp, edgeWeight), vertexCounter, []) + in ([edge], vertexCounter, vertexCounter) + LitE {} -> + let edge = ((exp, edgeWeight), vertexCounter, []) + in ([edge], vertexCounter, vertexCounter) + CharE {} -> + let edge = ((exp, edgeWeight), vertexCounter, []) + in ([edge], vertexCounter, vertexCounter) + FloatE {} -> + let edge = ((exp, edgeWeight), vertexCounter, []) + in ([edge], vertexCounter, vertexCounter) + LitSymE {} -> + let edge = ((exp, edgeWeight), vertexCounter, []) + in ([edge], vertexCounter, vertexCounter) + AppE f locs args -> + let (edgeList, succList, maxDepth) = + processExpListSeq (vertexCounter + 1) edgeWeight args + edge = (((VarE f), edgeWeight), vertexCounter, succList) + newEdges = edgeList ++ [edge] + in (newEdges, vertexCounter, maxDepth) + PrimAppE f args -> + let (edgeList, succList, maxDepth) = + processExpListSeq (vertexCounter + 1) edgeWeight args + edge = ((exp, edgeWeight), vertexCounter, succList) + newEdges = edgeList ++ [edge] + in (newEdges, vertexCounter, maxDepth) + LetE (v, loc, ty, rhs) bod -> + let (edgeList, succ, maxDepth) = + generateCFGExp (vertexCounter + 1) edgeWeight bod + exp' = LetE (v, loc, ty, rhs) $ VarE v + edge = ((exp', edgeWeight), vertexCounter, [succ]) + edgeList' = edgeList ++ [edge] + in (edgeList', vertexCounter, maxDepth) + CaseE scrt mp -> + let (edgeList, succList, maxDepth) = + processExpSeqCase + (vertexCounter + 1) + (edgeWeight `div` (P.toInteger (P.length mp))) + mp + edge = ((scrt, edgeWeight), vertexCounter, succList) + newEdges = edgeList ++ [edge] + in (newEdges, vertexCounter, maxDepth) + IfE a b c -> + let (edgeListB, succB, d1) = + generateCFGExp (vertexCounter + 1) (edgeWeight `div` 2) b + (edgeListC, succC, d2) = + generateCFGExp (d1 + 1) (edgeWeight `div` 2) c + succList = [succB, succC] + edge = ((a, edgeWeight), vertexCounter, succList) + newEdges = edgeListB ++ edgeListC ++ [edge] + in (newEdges, vertexCounter, P.maximum [d1, d2]) + MkProdE xs -> + let (edgeList, succList, maxDepth) = + processExpListSeq (vertexCounter + 1) edgeWeight xs + edge = ((exp, edgeWeight), vertexCounter, succList) + newEdges = edgeList ++ [edge] + in (newEdges, vertexCounter, maxDepth) + ProjE i e -> error "generateCFGExp: TODO ProjE" + TimeIt e ty b -> error "generateCFGExp: TODO TimeIt" + WithArenaE v e -> error "generateCFGExp: TODO WithArenaE" + SpawnE f locs args -> error "generateCFGExp: TODO SpawnE" + SyncE -> error "generateCFGExp: TODO SyncE" + Ext _ -> error "generateCFGExp: TODO Ext" + MapE {} -> error "generateCFGExp: TODO MapE" + FoldE {} -> error "generateCFGExp: TODO FoldE" + + +-- | Process a list of expressions seqientially rather than in parallel +-- | Otherwise threading an integer becomes difficult +processExpListSeq :: + Integer + -> Integer + -> [(PreExp e l d)] + -> ([(((PreExp e l d), Integer), Integer, [Integer])], [Integer], Integer) +processExpListSeq currVertex edgeWeight exp = + case exp of + [] -> ([], [], currVertex) + x:xs -> + let (edgeList, succ, maxDepth) = generateCFGExp currVertex edgeWeight x + (edgeList', succ', maxDepth') = + processExpListSeq (maxDepth + 1) edgeWeight xs + newEdgeList = edgeList ++ edgeList' + succList = [succ] ++ succ' + in (newEdgeList, succList, maxDepth') + + +-- | Process a list of case expressions sequentially rather than in parallel +processExpSeqCase :: + Integer + -> Integer + -> [(DataCon, [(Var, loc)], (PreExp e l d))] + -> ([(((PreExp e l d), Integer), Integer, [Integer])], [Integer], Integer) +processExpSeqCase currVertex edgeWeight lst = + case lst of + [] -> ([], [], currVertex) + x:xs -> + let (edgeList, succ, maxDepth) = + generateVerticesCase currVertex edgeWeight x + (edgeList', succList, maxDepth') = + processExpSeqCase (maxDepth + 1) edgeWeight xs + newEdgeList = edgeList ++ edgeList' + succList' = [succ] ++ succList + in (newEdgeList, succList', maxDepth') + + +-- | Helper function to generate a vertex for each case binding +generateVerticesCase :: + Integer + -> Integer + -> (DataCon, [(Var, loc)], (PreExp e l d)) + -> ([(((PreExp e l d), Integer), Integer, [Integer])], Integer, Integer) +generateVerticesCase currVertex edgeWeight branch = + let datacon = fst3 branch + fields_locs = snd3 branch + fields = P.map (\x -> (VarE (fst x))) fields_locs + dataconExp = DataConE _ datacon fields + (edgeList, succ, maxDepth) = + generateCFGExp (currVertex + 1) edgeWeight (thd3 branch) + edge = ((dataconExp, edgeWeight), currVertex, [succ]) + newEdges = edgeList ++ [edge] + in (newEdges, currVertex, maxDepth) From 4a51fec7626b74cf8b1c09fe867fe15cafcd03fb Mon Sep 17 00:00:00 2001 From: vidsinghal Date: Wed, 16 Aug 2023 11:58:20 -0400 Subject: [PATCH 16/25] Passes: Support for Definition Use Chains --- gibbon-compiler/gibbon.cabal | 1 + gibbon-compiler/src/Gibbon/Common.hs | 1 - gibbon-compiler/src/Gibbon/L0/Specialize2.hs | 2371 +++++++------ gibbon-compiler/src/Gibbon/L0/Syntax.hs | 692 ++-- gibbon-compiler/src/Gibbon/L1/Examples.hs | 147 +- gibbon-compiler/src/Gibbon/L1/Syntax.hs | 138 +- gibbon-compiler/src/Gibbon/L2/Examples.hs | 59 +- gibbon-compiler/src/Gibbon/L2/Syntax.hs | 1165 +++--- gibbon-compiler/src/Gibbon/L3/Syntax.hs | 434 +-- gibbon-compiler/src/Gibbon/Language.hs | 1198 ++++--- gibbon-compiler/src/Gibbon/Language/Syntax.hs | 1067 ++++-- .../src/Gibbon/Passes/DefinitionUseChains.hs | 302 ++ gibbon-compiler/src/Gibbon/Passes/Fusion2.hs | 3121 +++++++++-------- 13 files changed, 6101 insertions(+), 4595 deletions(-) create mode 100644 gibbon-compiler/src/Gibbon/Passes/DefinitionUseChains.hs diff --git a/gibbon-compiler/gibbon.cabal b/gibbon-compiler/gibbon.cabal index e879129bd..7fd6c521d 100644 --- a/gibbon-compiler/gibbon.cabal +++ b/gibbon-compiler/gibbon.cabal @@ -83,6 +83,7 @@ library Gibbon.Passes.Codegen Gibbon.Passes.CalculateBounds Gibbon.Passes.ControlFlowGraph + Gibbon.Passes.DefinitionUseChains other-extensions: DeriveDataTypeable CPP diff --git a/gibbon-compiler/src/Gibbon/Common.hs b/gibbon-compiler/src/Gibbon/Common.hs index 8e69c53f7..da795d166 100644 --- a/gibbon-compiler/src/Gibbon/Common.hs +++ b/gibbon-compiler/src/Gibbon/Common.hs @@ -42,7 +42,6 @@ import Control.Exception (evaluate) -- 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 import Control.Monad.State.Strict import Control.Monad.Reader import Data.Functor.Foldable diff --git a/gibbon-compiler/src/Gibbon/L0/Specialize2.hs b/gibbon-compiler/src/Gibbon/L0/Specialize2.hs index 1f11ccd17..49a486c71 100644 --- a/gibbon-compiler/src/Gibbon/L0/Specialize2.hs +++ b/gibbon-compiler/src/Gibbon/L0/Specialize2.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {- L0 Specializer (part 2): ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -12,27 +12,31 @@ transform a fully polymorphic L0 program, into a monomorphic L1 program. This module is the first attempt to do that. -} - module Gibbon.L0.Specialize2 - (bindLambdas, monomorphize, specLambdas, desugarL0, toL1, floatOutCase) - where + ( bindLambdas + , monomorphize + , specLambdas + , desugarL0 + , toL1 + , floatOutCase + ) where -import Control.Monad import Control.Monad.State -import Data.Foldable ( foldlM, foldrM ) -import qualified Data.Map as M -import qualified Data.Set as S -import GHC.Stack (HasCallStack) +import Data.Foldable (foldlM, foldrM) +import qualified Data.Map as M +import qualified Data.Set as S +import GHC.Stack (HasCallStack) import Text.PrettyPrint.GenericPretty +import Data.Bifunctor import Gibbon.Common -import Gibbon.Pretty import Gibbon.L0.Syntax import Gibbon.L0.Typecheck -import qualified Gibbon.L1.Syntax as L1 -import Data.Bifunctor --------------------------------------------------------------------------------- +import qualified Gibbon.L1.Syntax as L1 +import Gibbon.Pretty + +-------------------------------------------------------------------------------- {- Transforming L0 to L1 @@ -125,192 +129,206 @@ Assume that the input program is monomorphic. -- Just a mechanical transformation .. toL1 :: Prog0 -> L1.Prog1 -toL1 Prog{ddefs, fundefs, mainExp} = - Prog (M.map toL1DDef ddefs) (M.map toL1FunDef fundefs) mainExp' +toL1 Prog {ddefs, fundefs, mainExp} = + Prog (M.map toL1DDef ddefs) (M.map toL1FunDef fundefs) mainExp' where - mainExp' = case mainExp of - Nothing -> Nothing - Just (e,ty) -> Just (toL1Exp e, toL1Ty ty) - + mainExp' = + case mainExp of + Nothing -> Nothing + Just (e, ty) -> Just (toL1Exp e, toL1Ty ty) toL1DDef :: DDef0 -> L1.DDef1 - toL1DDef ddf@DDef{dataCons} = - ddf { dataCons = map (\(dcon, btys) -> (dcon, map (\(a,b) -> (a, toL1Ty b)) btys)) dataCons } - + toL1DDef ddf@DDef {dataCons} = + ddf + { dataCons = + map + (\(dcon, btys) -> (dcon, map (\(a, b) -> (a, toL1Ty b)) btys)) + dataCons + } toL1FunDef :: FunDef0 -> L1.FunDef1 - toL1FunDef fn@FunDef{funTy, funBody} = - fn { funTy = toL1TyS funTy - , funBody = toL1Exp funBody } - + toL1FunDef fn@FunDef {funTy, funBody} = + fn {funTy = toL1TyS funTy, funBody = toL1Exp funBody} toL1Exp :: Exp0 -> L1.Exp1 toL1Exp ex = case ex of - VarE v -> L1.VarE v - LitE n -> L1.LitE n - CharE n -> L1.CharE n - FloatE n -> L1.FloatE n + VarE v -> L1.VarE v + LitE n -> L1.LitE n + CharE n -> L1.CharE n + FloatE n -> L1.FloatE n LitSymE v -> L1.LitSymE v - AppE f [] args -> AppE f [] (map toL1Exp args) - AppE{} -> err1 (sdoc ex) + AppE f [] args -> AppE f [] (map toL1Exp args) + AppE {} -> err1 (sdoc ex) PrimAppE pr args -> - case pr of + case pr -- This is always going to have a function reference which -- we cannot eliminate. - VSortP{} -> + of + VSortP {} -> case args of [ls, Ext (FunRefE _ fp)] -> PrimAppE (toL1Prim pr) [toL1Exp ls, VarE fp] [ls, Ext (L _ (Ext (FunRefE _ fp)))] -> PrimAppE (toL1Prim pr) [toL1Exp ls, VarE fp] - _ -> PrimAppE (toL1Prim pr)(map toL1Exp args) + _ -> PrimAppE (toL1Prim pr) (map toL1Exp args) _ -> PrimAppE (toL1Prim pr) (map toL1Exp args) - LetE (v,[],ty,rhs) bod -> LetE (v,[], toL1Ty ty, toL1Exp rhs) (toL1Exp bod) - LetE{} -> err1 (sdoc ex) - IfE a b c -> IfE (toL1Exp a) (toL1Exp b) (toL1Exp c) + LetE (v, [], ty, rhs) bod -> + LetE (v, [], toL1Ty ty, toL1Exp rhs) (toL1Exp bod) + LetE {} -> err1 (sdoc ex) + IfE a b c -> IfE (toL1Exp a) (toL1Exp b) (toL1Exp c) MkProdE ls -> MkProdE (map toL1Exp ls) - ProjE i a -> ProjE i (toL1Exp a) - CaseE scrt brs -> CaseE (toL1Exp scrt) (map (\(a,b,c) -> (a, - map (\(x,_) -> (x,())) b, - toL1Exp c) ) - brs) + ProjE i a -> ProjE i (toL1Exp a) + CaseE scrt brs -> + CaseE + (toL1Exp scrt) + (map (\(a, b, c) -> (a, map (\(x, _) -> (x, ())) b, toL1Exp c)) brs) DataConE (ProdTy []) dcon ls -> DataConE () dcon (map toL1Exp ls) - DataConE{} -> err1 (sdoc ex) - TimeIt e ty b -> TimeIt (toL1Exp e) (toL1Ty ty) b + DataConE {} -> err1 (sdoc ex) + TimeIt e ty b -> TimeIt (toL1Exp e) (toL1Ty ty) b SpawnE f [] args -> SpawnE f [] (map toL1Exp args) - SpawnE{} -> err1 (sdoc ex) - SyncE -> SyncE + SpawnE {} -> err1 (sdoc ex) + SyncE -> SyncE WithArenaE v e -> WithArenaE v (toL1Exp e) - MapE{} -> err1 (sdoc ex) - FoldE{} -> err1 (sdoc ex) + MapE {} -> err1 (sdoc ex) + FoldE {} -> err1 (sdoc ex) Ext ext -> case ext of - LambdaE{} -> err2 (sdoc ex) - PolyAppE{} -> err2 (sdoc ex) - FunRefE{} -> err2 (sdoc ex) + LambdaE {} -> err2 (sdoc ex) + PolyAppE {} -> err2 (sdoc ex) + FunRefE {} -> err2 (sdoc ex) BenchE fn tyapps args b -> case tyapps of [] -> Ext $ L1.BenchE fn [] (map toL1Exp args) b _ -> error "toL1: Polymorphic 'bench' not supported yet." - ParE0{} -> error "toL1: ParE0" - PrintPacked{} -> error "toL1: PrintPacked" - CopyPacked{} -> error "toL1: CopyPacked" - TravPacked{} -> error "toL1: TravPacked" - LinearExt{} -> error $ "toL1: a linear types extension wasn't desugared: " ++ sdoc ex + ParE0 {} -> error "toL1: ParE0" + PrintPacked {} -> error "toL1: PrintPacked" + CopyPacked {} -> error "toL1: CopyPacked" + TravPacked {} -> error "toL1: TravPacked" + LinearExt {} -> + error $ + "toL1: a linear types extension wasn't desugared: " ++ sdoc ex -- Erase srclocs while going to L1 - L _ e -> toL1Exp e - + L _ e -> toL1Exp e toL1Prim :: Prim Ty0 -> Prim L1.Ty1 toL1Prim = fmap toL1Ty - toL1Ty :: Ty0 -> L1.Ty1 toL1Ty ty = case ty of - CharTy -> L1.CharTy - IntTy -> L1.IntTy + CharTy -> L1.CharTy + IntTy -> L1.IntTy FloatTy -> L1.FloatTy - SymTy0 -> L1.SymTy - BoolTy -> L1.BoolTy - TyVar{} -> err1 (sdoc ty) - MetaTv{} -> err1 (sdoc ty) - ProdTy tys -> L1.ProdTy $ map toL1Ty tys + SymTy0 -> L1.SymTy + BoolTy -> L1.BoolTy + TyVar {} -> err1 (sdoc ty) + MetaTv {} -> err1 (sdoc ty) + ProdTy tys -> L1.ProdTy $ map toL1Ty tys SymDictTy (Just v) a -> L1.SymDictTy (Just v) $ toL1Ty a - SymDictTy Nothing a -> L1.SymDictTy Nothing $ toL1Ty a + SymDictTy Nothing a -> L1.SymDictTy Nothing $ toL1Ty a PDictTy k v -> L1.PDictTy (toL1Ty k) (toL1Ty v) - ArrowTy{} -> err2 (sdoc ty) - PackedTy tycon tyapps | tyapps == [] -> L1.PackedTy tycon () - | otherwise -> err1 (sdoc ty) + ArrowTy {} -> err2 (sdoc ty) + PackedTy tycon tyapps + | tyapps == [] -> L1.PackedTy tycon () + | otherwise -> err1 (sdoc ty) ArenaTy -> L1.ArenaTy SymSetTy -> L1.SymSetTy SymHashTy -> L1.SymHashTy IntHashTy -> L1.IntHashTy - VectorTy a -> L1.VectorTy (toL1Ty a) - ListTy a -> L1.ListTy (toL1Ty a) - + VectorTy a -> L1.VectorTy (toL1Ty a) + ListTy a -> L1.ListTy (toL1Ty a) toL1TyS :: ArrowTy Ty0 -> ArrowTy L1.Ty1 toL1TyS t@(ForAll tyvars (ArrowTy as b)) | tyvars == [] = (map toL1Ty as, toL1Ty b) | otherwise = err1 (sdoc t) toL1TyS (ForAll _ t) = error $ "toL1: Not a function type: " ++ sdoc t - - err1 msg = error $ "toL1: Program was not fully monomorphized. Encountered: " ++ msg - + err1 msg = + error $ "toL1: Program was not fully monomorphized. Encountered: " ++ msg err2 msg = error $ "toL1: Could not lift all lambdas. Encountered: " ++ msg + -------------------------------------------------------------------------------- -- The monomorphization monad. type MonoM a = StateT MonoState PassM a -data MonoState = MonoState - { mono_funs_todo :: M.Map (Var, [Ty0]) Var - , mono_funs_done :: M.Map (Var, [Ty0]) Var - , mono_lams :: M.Map (Var, [Ty0]) Var - , mono_dcons :: M.Map (TyCon, [Ty0]) Var -- suffix - } +data MonoState = + MonoState + { mono_funs_todo :: M.Map (Var, [Ty0]) Var + , mono_funs_done :: M.Map (Var, [Ty0]) Var + , mono_lams :: M.Map (Var, [Ty0]) Var + , mono_dcons :: M.Map (TyCon, [Ty0]) Var -- suffix + } deriving (Show, Read, Ord, Eq, Generic, Out) emptyMonoState :: MonoState -emptyMonoState = MonoState - { mono_funs_todo = M.empty, mono_funs_done = M.empty - , mono_lams = M.empty, mono_dcons = M.empty } +emptyMonoState = + MonoState + { mono_funs_todo = M.empty + , mono_funs_done = M.empty + , mono_lams = M.empty + , mono_dcons = M.empty + } + +extendFuns :: (Var, [Ty0]) -> Var -> MonoState -> MonoState +extendFuns k v mono_st@MonoState {mono_funs_todo} = + mono_st {mono_funs_todo = M.insert k v mono_funs_todo} -extendFuns :: (Var,[Ty0]) -> Var -> MonoState -> MonoState -extendFuns k v mono_st@MonoState{mono_funs_todo} = - mono_st { mono_funs_todo = M.insert k v mono_funs_todo } +extendLambdas :: (Var, [Ty0]) -> Var -> MonoState -> MonoState +extendLambdas k v mono_st@MonoState {mono_lams} = + mono_st {mono_lams = M.insert k v mono_lams} -extendLambdas :: (Var,[Ty0]) -> Var -> MonoState -> MonoState -extendLambdas k v mono_st@MonoState{mono_lams} = - mono_st { mono_lams = M.insert k v mono_lams } +extendDatacons :: (TyCon, [Ty0]) -> Var -> MonoState -> MonoState +extendDatacons k v mono_st@MonoState {mono_dcons} = + mono_st {mono_dcons = M.insert k v mono_dcons} -extendDatacons :: (TyCon,[Ty0]) -> Var -> MonoState -> MonoState -extendDatacons k v mono_st@MonoState{mono_dcons} = - mono_st { mono_dcons = M.insert k v mono_dcons } -- We need this wrapper because of the way these maps are defined. -- -- getLambdaObls id { mono_lams = [ ((id,[IntTy]), id1), ((id,[BoolTy]), id2) ] } -- = [ (id2, [IntTy]), (id2, [BoolTy]) ] getLambdaObls :: Var -> MonoState -> (M.Map Var [Ty0]) -getLambdaObls f MonoState{mono_lams} = - M.fromList $ map (\((_,tys), w) -> (w, tys)) f_mono_st +getLambdaObls f MonoState {mono_lams} = + M.fromList $ map (\((_, tys), w) -> (w, tys)) f_mono_st where - f_mono_st = filter (\((v,_), _) -> v == f) (M.toList mono_lams) + f_mono_st = filter (\((v, _), _) -> v == f) (M.toList mono_lams) -------------------------------------------------------------------------------- - monomorphize :: Prog0 -> PassM Prog0 -monomorphize p@Prog{ddefs,fundefs,mainExp} = do +monomorphize p@Prog {ddefs, fundefs, mainExp} = do let env2 = Env2 M.empty (M.map funTy fundefs) - - let mono_m = do + let mono_m -- Step (0) + = do (ddfs0 :: [DDef0]) <- mapM (monoOblsDDef ddefs) (M.elems ddefs) - let ddefs' = M.fromList $ map (\a -> (tyName a,a)) ddfs0 + let ddefs' = M.fromList $ map (\a -> (tyName a, a)) ddfs0 -- Step (1) mainExp' <- case mainExp of Nothing -> pure Nothing - Just (e,ty) -> do - mainExp' <- collectMonoObls ddefs' env2 toplevel e + Just (e, ty) -> do + mainExp' <- collectMonoObls ddefs' env2 toplevel e mainExp'' <- monoLambdas mainExp' - mono_st <- get + mono_st <- get assertLambdasMonomorphized mono_st pure $ Just (mainExp'', ty) -- Step (1.2) let mono_funs = M.filter isMonoFun fundefs mono_funs' <- foldlM - (\funs fn@FunDef{funArgs,funName,funBody,funTy} -> do - let env2' = extendsVEnv (M.fromList $ zip funArgs (inTys funTy)) env2 - let (ForAll tyvars (ArrowTy as b)) = funTy - as' <- mapM (monoOblsTy ddefs) as - b' <- monoOblsTy ddefs b - funBody' <- collectMonoObls ddefs' env2' toplevel funBody - funBody'' <- monoLambdas funBody' - mono_st <- get - assertLambdasMonomorphized mono_st - let fn' = fn { funBody = funBody'', funTy = ForAll tyvars (ArrowTy as' b')} - pure $ M.insert funName fn' funs) + (\funs fn@FunDef {funArgs, funName, funBody, funTy} -> do + let env2' = + extendsVEnv (M.fromList $ zip funArgs (inTys funTy)) env2 + let (ForAll tyvars (ArrowTy as b)) = funTy + as' <- mapM (monoOblsTy ddefs) as + b' <- monoOblsTy ddefs b + funBody' <- collectMonoObls ddefs' env2' toplevel funBody + funBody'' <- monoLambdas funBody' + mono_st <- get + assertLambdasMonomorphized mono_st + let fn' = + fn + { funBody = funBody'' + , funTy = ForAll tyvars (ArrowTy as' b') + } + pure $ M.insert funName fn' funs) mono_funs (M.elems mono_funs) let fundefs' = mono_funs' `M.union` fundefs @@ -321,111 +339,141 @@ monomorphize p@Prog{ddefs,fundefs,mainExp} = do mono_st <- get -- Step (3) ddefs'' <- monoDDefs ddefs' - let p3 = p { ddefs = ddefs'', fundefs = fundefs'', mainExp = mainExp' } + let p3 = p {ddefs = ddefs'', fundefs = fundefs'', mainExp = mainExp'} let p3' = updateTyCons mono_st p3 -- Important; p3 is not type-checkable until updateTyCons runs. -- Step (4) lift $ tcProg p3' - - (p4,_) <- runStateT mono_m emptyMonoState - - -- Step (5) - let p5 = purgePolyDDefs p4 + (p4, _) <- runStateT mono_m emptyMonoState + let p5 = purgePolyDDefs p4 let p5' = purgePolyFuns p5 - -- Step (6) + +-- Step (6) tcProg p5' where toplevel = M.keysSet fundefs - - -- Create monomorphic versions of all polymorphic functions. monoFunDefs :: FunDefs0 -> MonoM FunDefs0 monoFunDefs fundefs1 = do mono_st <- get if M.null (mono_funs_todo mono_st) - then pure fundefs1 - else do - let (((fun_name, tyapps), new_fun_name):rst) = M.toList (mono_funs_todo mono_st) - fn@FunDef{funArgs, funName, funBody} = fundefs # fun_name - tyvars = tyVarsFromScheme (funTy fn) - assertSameLength ("While monormorphizing the function: " ++ sdoc funName) tyvars tyapps - let mp = M.fromList $ zip tyvars tyapps - funTy' = ForAll [] (substTyVar mp (tyFromScheme (funTy fn))) - funBody' = substTyVarExp mp funBody + then pure fundefs1 + else do + let (((fun_name, tyapps), new_fun_name):rst) = + M.toList (mono_funs_todo mono_st) + fn@FunDef {funArgs, funName, funBody} = fundefs # fun_name + tyvars = tyVarsFromScheme (funTy fn) + assertSameLength + ("While monormorphizing the function: " ++ sdoc funName) + tyvars + tyapps + let mp = M.fromList $ zip tyvars tyapps + funTy' = ForAll [] (substTyVar mp (tyFromScheme (funTy fn))) + funBody' = substTyVarExp mp funBody -- Move this obligation from todo to done. - mono_st' = mono_st { mono_funs_done = M.insert (fun_name, tyapps) new_fun_name (mono_funs_done mono_st) - , mono_funs_todo = M.fromList rst } - put mono_st' - -- Collect any more obligations generated due to the monormorphization - let argEnv = M.fromList $ zip funArgs (inTys funTy') - let (argFenv, argVenv) = M.partition (\case ArrowTy {} -> True; _ -> False) argEnv - let argFenv' = M.map (ForAll []) argFenv - let env21 = Env2 argVenv (M.union argFenv' (M.map funTy fundefs1)) - funBody'' <- collectMonoObls ddefs env21 toplevel funBody' - funBody''' <- monoLambdas funBody'' - let fn' = fn { funName = new_fun_name, funTy = funTy', funBody = funBody''' } - monoFunDefs (M.insert new_fun_name fn' fundefs1) - - -- Create monomorphic versions of all polymorphic datatypes. + mono_st' = + mono_st + { mono_funs_done = + M.insert + (fun_name, tyapps) + new_fun_name + (mono_funs_done mono_st) + , mono_funs_todo = M.fromList rst + } + put mono_st' + +-- Collect any more obligations generated due to the monormorphization + let argEnv = M.fromList $ zip funArgs (inTys funTy') + let (argFenv, argVenv) = + M.partition + (\case + ArrowTy {} -> True + _ -> False) + argEnv + let argFenv' = M.map (ForAll []) argFenv + let env21 = Env2 argVenv (M.union argFenv' (M.map funTy fundefs1)) + funBody'' <- collectMonoObls ddefs env21 toplevel funBody' + funBody''' <- monoLambdas funBody'' + let fn' = + fn + {funName = new_fun_name, funTy = funTy', funBody = funBody'''} + monoFunDefs (M.insert new_fun_name fn' fundefs1) monoDDefs :: DDefs0 -> MonoM DDefs0 monoDDefs ddefs1 = do mono_st <- get if M.null (mono_dcons mono_st) - then pure ddefs1 - else do - let (((tycon, tyapps), suffix):rst) = M.toList (mono_dcons mono_st) - ddf@DDef{tyName,tyArgs,dataCons} = lookupDDef ddefs tycon - assertSameLength ("In the datacon: " ++ sdoc tyName) tyArgs tyapps - let tyName' = varAppend tyName suffix - dataCons' = map - (\(dcon,vtys) -> - let (vars,tys) = unzip vtys - sbst = M.fromList (zip tyArgs tyapps) - tys' = map (substTyVar sbst) tys - tys'' = map (updateTyConsTy ddefs1 mono_st) tys' - vtys' = zip vars tys'' - in (dcon ++ fromVar suffix, vtys')) - dataCons - ddefs1' = M.insert tyName' (ddf { tyName = tyName', tyArgs = [], dataCons = dataCons' }) ddefs1 - mono_st' = mono_st { mono_dcons = M.fromList rst } - put mono_st' - monoDDefs ddefs1' - - -- See examples/T127. Bar is monomorphic, but uses a monomorphized-by-hand + then pure ddefs1 + else do + let (((tycon, tyapps), suffix):rst) = M.toList (mono_dcons mono_st) + ddf@DDef {tyName, tyArgs, dataCons} = lookupDDef ddefs tycon + assertSameLength ("In the datacon: " ++ sdoc tyName) tyArgs tyapps + let tyName' = varAppend tyName suffix + dataCons' = + map + (\(dcon, vtys) -> + let (vars, tys) = unzip vtys + sbst = M.fromList (zip tyArgs tyapps) + tys' = map (substTyVar sbst) tys + tys'' = map (updateTyConsTy ddefs1 mono_st) tys' + vtys' = zip vars tys'' + in (dcon ++ fromVar suffix, vtys')) + dataCons + ddefs1' = + M.insert + tyName' + (ddf {tyName = tyName', tyArgs = [], dataCons = dataCons'}) + ddefs1 + mono_st' = mono_st {mono_dcons = M.fromList rst} + put mono_st' + monoDDefs ddefs1' -- Foo. We must update Bar to use the correct Foo. monoOblsDDef :: DDefs0 -> DDef0 -> MonoM DDef0 - monoOblsDDef ddefs1 d@DDef{dataCons} = do - dataCons' <- mapM (\(dcon, args) -> (dcon,) <$> mapM (\(a,ty) -> (a,) <$> monoOblsTy ddefs1 ty) args) dataCons - pure $ d{ dataCons = dataCons' } + monoOblsDDef ddefs1 d@DDef {dataCons} = do + dataCons' <- + mapM + (\(dcon, args) -> + (dcon, ) <$> mapM (\(a, ty) -> (a, ) <$> monoOblsTy ddefs1 ty) args) + dataCons + pure $ d {dataCons = dataCons'} + +-- Step (5) +-- Create monomorphic versions of all polymorphic functions. + +-- Create monomorphic versions of all polymorphic datatypes. +-- See examples/T127. Bar is monomorphic, but uses a monomorphized-by-hand -- After 'monoLambdas' runs, (mono_lams MonoState) must be empty assertLambdasMonomorphized :: (Monad m, HasCallStack) => MonoState -> m () -assertLambdasMonomorphized MonoState{mono_lams} = +assertLambdasMonomorphized MonoState {mono_lams} = if M.null mono_lams - then pure () - else error $ "Expected 0 lambda monormorphization obligations. Got " ++ sdoc mono_lams + then pure () + else error $ + "Expected 0 lambda monormorphization obligations. Got " ++ + sdoc mono_lams -assertSameLength :: (Out a, Out b, Monad m, HasCallStack) => String -> [a] -> [b] -> m () +assertSameLength :: + (Out a, Out b, Monad m, HasCallStack) => String -> [a] -> [b] -> m () assertSameLength msg as bs = if length as /= length bs - then error $ "assertSameLength: Type applications " ++ sdoc bs ++ " incompatible with the type variables: " ++ - sdoc as ++ ".\n " ++ msg - else pure () - + then error $ + "assertSameLength: Type applications " ++ + sdoc bs ++ + " incompatible with the type variables: " ++ sdoc as ++ ".\n " ++ msg + else pure () monoOblsTy :: DDefs0 -> Ty0 -> MonoM Ty0 monoOblsTy ddefs1 t = do case t of - CharTy -> pure t - IntTy -> pure t - FloatTy -> pure t - SymTy0 -> pure t - BoolTy -> pure t - TyVar{} -> pure t - MetaTv{} -> pure t + CharTy -> pure t + IntTy -> pure t + FloatTy -> pure t + SymTy0 -> pure t + BoolTy -> pure t + TyVar {} -> pure t + MetaTv {} -> pure t ProdTy ls -> ProdTy <$> mapM (monoOblsTy ddefs1) ls - SymDictTy{} -> pure t - PDictTy{} -> pure t + SymDictTy {} -> pure t + PDictTy {} -> pure t ArrowTy as b -> do as' <- mapM (monoOblsTy ddefs1) as b' <- monoOblsTy ddefs1 b @@ -434,27 +482,28 @@ monoOblsTy ddefs1 t = do case tyapps of [] -> pure t -- We're only looking for fully monomorphized datatypes here - _ -> case tyVarsInTys tyapps of - [] -> do - tyapps' <- mapM (monoOblsTy ddefs1) tyapps - mono_st <- get - case M.lookup (tycon, tyapps') (mono_dcons mono_st) of - Nothing -> do - let DDef{tyArgs} = lookupDDef ddefs1 tycon - assertSameLength ("In the type: " ++ sdoc t) tyArgs tyapps' - suffix <- lift $ gensym "_v" - let mono_st' = extendDatacons (tycon, tyapps') suffix mono_st - tycon' = tycon ++ (fromVar suffix) - put mono_st' - pure $ PackedTy tycon' [] - Just suffix -> pure $ PackedTy (tycon ++ (fromVar suffix)) [] - _ -> pure t - VectorTy{} -> pure t - ListTy{} -> pure t - ArenaTy -> pure t + _ -> + case tyVarsInTys tyapps of + [] -> do + tyapps' <- mapM (monoOblsTy ddefs1) tyapps + mono_st <- get + case M.lookup (tycon, tyapps') (mono_dcons mono_st) of + Nothing -> do + let DDef {tyArgs} = lookupDDef ddefs1 tycon + assertSameLength ("In the type: " ++ sdoc t) tyArgs tyapps' + suffix <- lift $ gensym "_v" + let mono_st' = extendDatacons (tycon, tyapps') suffix mono_st + tycon' = tycon ++ (fromVar suffix) + put mono_st' + pure $ PackedTy tycon' [] + Just suffix -> pure $ PackedTy (tycon ++ (fromVar suffix)) [] + _ -> pure t + VectorTy {} -> pure t + ListTy {} -> pure t + ArenaTy -> pure t SymSetTy -> pure t - SymHashTy-> pure t - IntHashTy-> pure t + SymHashTy -> pure t + IntHashTy -> pure t -- | Collect monomorphization obligations. @@ -465,18 +514,18 @@ collectMonoObls ddefs env2 toplevel ex = args' <- mapM (collectMonoObls ddefs env2 toplevel) args pure $ AppE f [] args' AppE f tyapps args -> do - args' <- mapM (collectMonoObls ddefs env2 toplevel) args + args' <- mapM (collectMonoObls ddefs env2 toplevel) args tyapps' <- mapM (monoOblsTy ddefs) tyapps f' <- addFnObl f tyapps' pure $ AppE f' [] args' - LetE (v, [], ty@ArrowTy{}, rhs) bod ->do + LetE (v, [], ty@ArrowTy {}, rhs) bod -> do let env2' = (extendVEnv v ty env2) case rhs of - Ext (LambdaE{}) -> do + Ext (LambdaE {}) -> do rhs' <- go rhs bod' <- collectMonoObls ddefs env2' toplevel bod - pure $ LetE (v,[],ty,rhs') bod' - _ -> do + pure $ LetE (v, [], ty, rhs') bod' + _ -- Special case for lambda bindings passed in as function arguments: -- -- 'v' is an ArrowTy, but not a lambda defn -- this let binding must @@ -485,64 +534,70 @@ collectMonoObls ddefs env2 toplevel ex = -- It'll be handled when the the outer fn is processed. -- To ensure that (AppE v ...) stays the same, we add 'v' into -- mono_st s.t. it's new name would be same as it's old name. - state (\st -> ((), extendLambdas (v,[]) v st)) + -> do + state (\st -> ((), extendLambdas (v, []) v st)) rhs' <- go rhs bod' <- collectMonoObls ddefs env2' toplevel bod pure $ LetE (v, [], ty, rhs') bod' - - LetE (v,[],ty,rhs) bod -> do + LetE (v, [], ty, rhs) bod -> do let env2' = (extendVEnv v ty env2) rhs' <- go rhs bod' <- collectMonoObls ddefs env2' toplevel bod - pure $ LetE (v,[],ty,rhs') bod' - - LetE (_, (_:_), _, _) _ -> error $ "collectMonoObls: Let not monomorphized: " ++ sdoc ex - + pure $ LetE (v, [], ty, rhs') bod' + LetE (_, (_:_), _, _) _ -> + error $ "collectMonoObls: Let not monomorphized: " ++ sdoc ex CaseE scrt brs -> do case recoverType ddefs env2 scrt of PackedTy tycon tyapps -> do mono_st <- get (suffix, mono_st'') <- - case tyapps of + case tyapps -- It's a monomorphic datatype. + of [] -> pure ("", mono_st) - _ -> do + _ -> do tyapps' <- mapM (monoOblsTy ddefs) tyapps case M.lookup (tycon, tyapps') (mono_dcons mono_st) of Nothing -> do - let DDef{tyArgs} = lookupDDef ddefs tycon - assertSameLength ("In the expression: " ++ sdoc ex) tyArgs tyapps' + let DDef {tyArgs} = lookupDDef ddefs tycon + assertSameLength + ("In the expression: " ++ sdoc ex) + tyArgs + tyapps' suffix <- lift $ gensym "_v" - let mono_st' = extendDatacons (tycon, tyapps') suffix mono_st + let mono_st' = + extendDatacons (tycon, tyapps') suffix mono_st pure (suffix, mono_st') Just suffix -> pure (suffix, mono_st) put mono_st'' scrt' <- go scrt brs' <- foldlM - (\acc (dcon,vtys,bod) -> do - let env2' = extendsVEnv (M.fromList vtys) env2 - bod' <- collectMonoObls ddefs env2' toplevel bod - pure $ acc ++ [(dcon ++ fromVar suffix,vtys,bod')]) - [] brs + (\acc (dcon, vtys, bod) -> do + let env2' = extendsVEnv (M.fromList vtys) env2 + bod' <- collectMonoObls ddefs env2' toplevel bod + pure $ acc ++ [(dcon ++ fromVar suffix, vtys, bod')]) + [] + brs pure $ CaseE scrt' brs' - - ty -> error $ "collectMonoObls: Unexpected type for the scrutinee, " ++ sdoc ty ++ - ". In the expression: " ++ sdoc ex - + ty -> + error $ + "collectMonoObls: Unexpected type for the scrutinee, " ++ + sdoc ty ++ ". In the expression: " ++ sdoc ex DataConE (ProdTy tyapps) dcon args -> do args' <- mapM (collectMonoObls ddefs env2 toplevel) args - case tyapps of + case tyapps -- It's a monomorphic datatype. + of [] -> pure $ DataConE (ProdTy []) dcon args' - _ -> do + _ -> do mono_st <- get -- Collect datacon instances here. let tycon = getTyOfDataCon ddefs dcon tyapps' <- mapM (monoOblsTy ddefs) tyapps case M.lookup (tycon, tyapps') (mono_dcons mono_st) of Nothing -> do - let DDef{tyArgs} = lookupDDef ddefs tycon + let DDef {tyArgs} = lookupDDef ddefs tycon assertSameLength ("In the expression: " ++ sdoc ex) tyArgs tyapps' suffix <- lift $ gensym "_v" let mono_st' = extendDatacons (tycon, tyapps) suffix mono_st @@ -552,19 +607,17 @@ collectMonoObls ddefs env2 toplevel ex = Just suffix -> do let dcon' = dcon ++ (fromVar suffix) pure $ DataConE (ProdTy []) dcon' args' - - DataConE{} -> error $ "collectMonoObls: DataConE expected ProdTy tyapps, got " ++ sdoc ex - + DataConE {} -> + error $ + "collectMonoObls: DataConE expected ProdTy tyapps, got " ++ sdoc ex PrimAppE pr args -> do args' <- mapM (collectMonoObls ddefs env2 toplevel) args pure $ PrimAppE pr args' - - -- Straightforward recursion - VarE{} -> pure ex - LitE{} -> pure ex - CharE{} -> pure ex - FloatE{} -> pure ex - LitSymE{} -> pure ex + VarE {} -> pure ex + LitE {} -> pure ex + CharE {} -> pure ex + FloatE {} -> pure ex + LitSymE {} -> pure ex IfE a b c -> do a' <- go a b' <- go b @@ -585,20 +638,28 @@ collectMonoObls ddefs env2 toplevel ex = Ext ext -> case ext of LambdaE args bod -> do - bod' <- collectMonoObls ddefs (extendsVEnv (M.fromList args) env2) toplevel bod + bod' <- + collectMonoObls + ddefs + (extendsVEnv (M.fromList args) env2) + toplevel + bod pure $ Ext $ LambdaE args bod' - PolyAppE{} -> error ("collectMonoObls: TODO, "++ sdoc ext) + PolyAppE {} -> error ("collectMonoObls: TODO, " ++ sdoc ext) FunRefE tyapps f -> case tyapps of [] -> pure $ Ext $ FunRefE [] f - _ -> do + _ -> do tyapps' <- mapM (monoOblsTy ddefs) tyapps f' <- addFnObl f tyapps' pure $ Ext $ FunRefE [] f' BenchE _fn tyapps _args _b -> case tyapps of [] -> pure ex - _ -> error $ "collectMonoObls: Polymorphic bench not supported yet. In: " ++ sdoc ex + _ -> + error $ + "collectMonoObls: Polymorphic bench not supported yet. In: " ++ + sdoc ex ParE0 ls -> do ls' <- mapM (collectMonoObls ddefs env2 toplevel) ls pure $ Ext $ ParE0 ls' @@ -614,43 +675,50 @@ collectMonoObls ddefs env2 toplevel ex = L p e -> do e' <- go e pure $ Ext $ L p e' - LinearExt{} -> error $ "collectMonoObls: a linear types extension wasn't desugared: " ++ sdoc ex + LinearExt {} -> + error $ + "collectMonoObls: a linear types extension wasn't desugared: " ++ + sdoc ex SpawnE f [] args -> do args' <- mapM (collectMonoObls ddefs env2 toplevel) args pure $ SpawnE f [] args' SpawnE f tyapps args -> do - args' <- mapM (collectMonoObls ddefs env2 toplevel) args + args' <- mapM (collectMonoObls ddefs env2 toplevel) args tyapps' <- mapM (monoOblsTy ddefs) tyapps f' <- addFnObl f tyapps' pure $ SpawnE f' [] args' - SyncE -> pure SyncE - MapE{} -> error $ "collectMonoObls: TODO: " ++ sdoc ex - FoldE{} -> error $ "collectMonoObls: TODO: " ++ sdoc ex + SyncE -> pure SyncE + MapE {} -> error $ "collectMonoObls: TODO: " ++ sdoc ex + FoldE {} -> error $ "collectMonoObls: TODO: " ++ sdoc ex where go = collectMonoObls ddefs env2 toplevel - - -- 'fn' Could be either a lambda, or toplevel addFnObl :: Var -> [Ty0] -> MonoM Var addFnObl f tyapps = do mono_st <- get if f `S.member` toplevel - then case (M.lookup (f,tyapps) (mono_funs_done mono_st), M.lookup (f,tyapps) (mono_funs_todo mono_st)) of - (Nothing, Nothing) -> do - new_name <- lift $ gensym f - state (\st -> ((), extendFuns (f,tyapps) new_name st)) - pure new_name - (Just fn_name, _) -> pure fn_name - (_, Just fn_name) -> pure fn_name - - -- Why (f,[])? See "Special case for lambda bindings passed in as function arguments". - else case (M.lookup (f,[]) (mono_lams mono_st), M.lookup (f,tyapps) (mono_lams mono_st)) of - (Nothing, Nothing) -> do - new_name <- lift $ gensym f - state (\st -> ((),extendLambdas (f,tyapps) new_name st)) - pure new_name - (_,Just lam_name) -> pure lam_name - (Just lam_name,_) -> pure lam_name - + then case ( M.lookup (f, tyapps) (mono_funs_done mono_st) + , M.lookup (f, tyapps) (mono_funs_todo mono_st)) of + (Nothing, Nothing) -> do + new_name <- lift $ gensym f + state (\st -> ((), extendFuns (f, tyapps) new_name st)) + pure new_name + (Just fn_name, _) -> pure fn_name + (_, Just fn_name) -> pure fn_name + else case ( M.lookup (f, []) (mono_lams mono_st) + , M.lookup (f, tyapps) (mono_lams mono_st)) of + (Nothing, Nothing) -> do + new_name <- lift $ gensym f + state (\st -> ((), extendLambdas (f, tyapps) new_name st)) + pure new_name + (_, Just lam_name) -> pure lam_name + (Just lam_name, _) -> pure lam_name + + +-- Straightforward recursion + +-- 'fn' Could be either a lambda, or toplevel + +-- Why (f,[])? See "Special case for lambda bindings passed in as function arguments". -- | Create monomorphic versions of lambdas bound in this expression. -- This does not float out the lambda definitions. @@ -658,188 +726,222 @@ monoLambdas :: Exp0 -> MonoM Exp0 -- Assummption: lambdas only appear as RHS in a let. monoLambdas ex = case ex of - LetE (v,[],vty, rhs@(Ext (LambdaE args lam_bod))) bod -> do + LetE (v, [], vty, rhs@(Ext (LambdaE args lam_bod))) bod -> do mono_st <- get let lam_mono_st = getLambdaObls v mono_st if M.null lam_mono_st -- This lambda is not polymorphic, don't monomorphize. - then do - bod' <- go bod - lam_bod' <- monoLambdas lam_bod - pure $ LetE (v, [], vty, (Ext (LambdaE args lam_bod'))) bod' - -- Monomorphize and only bind those, drop the polymorphic defn. - -- Also drop the obligation that we applied from MonoState. - -- So after 'monoLambdas' is done, (mono_lams MonoState) should be []. - else do - -- new_lam_mono_st = old_lam_mono_st - applied_lam_mono_st - let new_lam_mono_st = (mono_lams mono_st) `M.difference` - (M.fromList $ map (\(w,wtyapps) -> ((v,wtyapps), w)) (M.toList lam_mono_st)) - mono_st' = mono_st { mono_lams = new_lam_mono_st } - put mono_st' - bod' <- monoLambdas bod - monomorphized <- monoLamBinds (M.toList lam_mono_st) (vty, rhs) - pure $ foldl (\acc bind -> LetE bind acc) bod' monomorphized - - LetE (_,(_:_),_,_) _ -> error $ "monoLambdas: Let not monomorphized: " ++ sdoc ex - + then do + bod' <- go bod + lam_bod' <- monoLambdas lam_bod + pure $ LetE (v, [], vty, (Ext (LambdaE args lam_bod'))) bod' + else do + let new_lam_mono_st = + (mono_lams mono_st) `M.difference` + (M.fromList $ + map (\(w, wtyapps) -> ((v, wtyapps), w)) (M.toList lam_mono_st)) + mono_st' = mono_st {mono_lams = new_lam_mono_st} + put mono_st' + bod' <- monoLambdas bod + monomorphized <- monoLamBinds (M.toList lam_mono_st) (vty, rhs) + pure $ foldl (\acc bind -> LetE bind acc) bod' monomorphized + LetE (_, (_:_), _, _) _ -> + error $ "monoLambdas: Let not monomorphized: " ++ sdoc ex -- Straightforward recursion - VarE{} -> pure ex - LitE{} -> pure ex - CharE{} -> pure ex - FloatE{} -> pure ex - LitSymE{} -> pure ex + VarE {} -> pure ex + LitE {} -> pure ex + CharE {} -> pure ex + FloatE {} -> pure ex + LitSymE {} -> pure ex AppE f tyapps args -> case tyapps of - [] -> do args' <- mapM monoLambdas args - pure $ AppE f [] args' - _ -> error $ "monoLambdas: Expression probably not processed by collectMonoObls: " ++ sdoc ex - PrimAppE pr args -> do args' <- mapM monoLambdas args - pure $ PrimAppE pr args' - LetE (v,[],ty,rhs) bod -> do + [] -> do + args' <- mapM monoLambdas args + pure $ AppE f [] args' + _ -> + error $ + "monoLambdas: Expression probably not processed by collectMonoObls: " ++ + sdoc ex + PrimAppE pr args -> do + args' <- mapM monoLambdas args + pure $ PrimAppE pr args' + LetE (v, [], ty, rhs) bod -> do rhs' <- go rhs bod' <- monoLambdas bod pure $ LetE (v, [], ty, rhs') bod' - IfE a b c -> IfE <$> go a <*> go b <*> go c + IfE a b c -> IfE <$> go a <*> go b <*> go c MkProdE ls -> MkProdE <$> mapM monoLambdas ls - ProjE i a -> (ProjE i) <$> go a + ProjE i a -> (ProjE i) <$> go a CaseE scrt brs -> do scrt' <- go scrt - brs' <- mapM (\(a,b,c) -> (a,b,) <$> go c) brs + brs' <- mapM (\(a, b, c) -> (a, b, ) <$> go c) brs pure $ CaseE scrt' brs' - DataConE tyapp dcon args -> - (DataConE tyapp dcon) <$> mapM monoLambdas args - TimeIt e ty b -> (\e' -> TimeIt e' ty b) <$> go e + DataConE tyapp dcon args -> (DataConE tyapp dcon) <$> mapM monoLambdas args + TimeIt e ty b -> (\e' -> TimeIt e' ty b) <$> go e WithArenaE v e -> (\e' -> WithArenaE v e') <$> go e - Ext (LambdaE{}) -> error $ "monoLambdas: Encountered a LambdaE outside a let binding. In\n" ++ sdoc ex - Ext (PolyAppE{}) -> error $ "monoLambdas: TODO: " ++ sdoc ex - Ext (FunRefE{}) -> pure ex - Ext (BenchE{}) -> pure ex - Ext (ParE0 ls) -> Ext <$> ParE0 <$> mapM monoLambdas ls - Ext (PrintPacked ty arg)-> Ext <$> (PrintPacked ty) <$> monoLambdas arg - Ext (CopyPacked ty arg)-> Ext <$> (CopyPacked ty) <$> monoLambdas arg - Ext (TravPacked ty arg)-> Ext <$> (TravPacked ty) <$> monoLambdas arg - Ext (L p e) -> Ext <$> (L p) <$> monoLambdas e - Ext (LinearExt{}) -> error $ "monoLambdas: a linear types extension wasn't desugared: " ++ sdoc ex + Ext (LambdaE {}) -> + error $ + "monoLambdas: Encountered a LambdaE outside a let binding. In\n" ++ + sdoc ex + Ext (PolyAppE {}) -> error $ "monoLambdas: TODO: " ++ sdoc ex + Ext (FunRefE {}) -> pure ex + Ext (BenchE {}) -> pure ex + Ext (ParE0 ls) -> Ext <$> ParE0 <$> mapM monoLambdas ls + Ext (PrintPacked ty arg) -> Ext <$> (PrintPacked ty) <$> monoLambdas arg + Ext (CopyPacked ty arg) -> Ext <$> (CopyPacked ty) <$> monoLambdas arg + Ext (TravPacked ty arg) -> Ext <$> (TravPacked ty) <$> monoLambdas arg + Ext (L p e) -> Ext <$> (L p) <$> monoLambdas e + Ext (LinearExt {}) -> + error $ + "monoLambdas: a linear types extension wasn't desugared: " ++ sdoc ex SpawnE f tyapps args -> case tyapps of - [] -> do args' <- mapM monoLambdas args - pure $ SpawnE f [] args' - _ -> error $ "monoLambdas: Expression probably not processed by collectMonoObls: " ++ sdoc ex - SyncE -> pure SyncE - MapE{} -> error $ "monoLambdas: TODO: " ++ sdoc ex - FoldE{} -> error $ "monoLambdas: TODO: " ++ sdoc ex - where go = monoLambdas - - monoLamBinds :: [(Var,[Ty0])] -> (Ty0, Exp0) -> MonoM [(Var, [Ty0], Ty0, Exp0)] - monoLamBinds [] _ = pure [] - monoLamBinds ((w, tyapps):rst) (ty,ex1) = do - let tyvars = tyVarsInTy ty - assertSameLength ("In the expression: " ++ sdoc ex1) tyvars tyapps - let mp = M.fromList $ zip tyvars tyapps - ty' = substTyVar mp ty - ex' = substTyVarExp mp ex1 - (++ [(w, [], ty', ex')]) <$> monoLamBinds rst (ty,ex1) + [] -> do + args' <- mapM monoLambdas args + pure $ SpawnE f [] args' + _ -> + error $ + "monoLambdas: Expression probably not processed by collectMonoObls: " ++ + sdoc ex + SyncE -> pure SyncE + MapE {} -> error $ "monoLambdas: TODO: " ++ sdoc ex + FoldE {} -> error $ "monoLambdas: TODO: " ++ sdoc ex + where + go = monoLambdas + monoLamBinds :: + [(Var, [Ty0])] -> (Ty0, Exp0) -> MonoM [(Var, [Ty0], Ty0, Exp0)] + monoLamBinds [] _ = pure [] + monoLamBinds ((w, tyapps):rst) (ty, ex1) = do + let tyvars = tyVarsInTy ty + assertSameLength ("In the expression: " ++ sdoc ex1) tyvars tyapps + let mp = M.fromList $ zip tyvars tyapps + ty' = substTyVar mp ty + ex' = substTyVarExp mp ex1 + (++ [(w, [], ty', ex')]) <$> monoLamBinds rst (ty, ex1) -- | Remove all polymorphic functions and datatypes from a program. 'monoLambdas' -- already gets rid of polymorphic mono_lams. purgePolyFuns :: Prog0 -> Prog0 -purgePolyFuns p@Prog{fundefs} = - p { fundefs = M.filter isMonoFun fundefs } +purgePolyFuns p@Prog {fundefs} = p {fundefs = M.filter isMonoFun fundefs} isMonoFun :: FunDef0 -> Bool -isMonoFun FunDef{funTy} = (tyVarsFromScheme funTy) == [] +isMonoFun FunDef {funTy} = (tyVarsFromScheme funTy) == [] purgePolyDDefs :: Prog0 -> Prog0 -purgePolyDDefs p@Prog{ddefs} = - p { ddefs = M.filter isMonoDDef ddefs } +purgePolyDDefs p@Prog {ddefs} = p {ddefs = M.filter isMonoDDef ddefs} where - isMonoDDef DDef{tyArgs} = tyArgs == [] + isMonoDDef DDef {tyArgs} = tyArgs == [] + -- See Step (4) in the big note. Lot of code duplication :( updateTyCons :: MonoState -> Prog0 -> Prog0 -updateTyCons mono_st p@Prog{ddefs, fundefs,mainExp}= +updateTyCons mono_st p@Prog {ddefs, fundefs, mainExp} = let fundefs' = M.map fixFunDef fundefs - mainExp' = case mainExp of - Nothing -> Nothing - Just (e,ty) -> Just (updateTyConsExp ddefs mono_st e, updateTyConsTy ddefs mono_st ty) - in p { fundefs = fundefs', mainExp = mainExp' } + mainExp' = + case mainExp of + Nothing -> Nothing + Just (e, ty) -> + Just + (updateTyConsExp ddefs mono_st e, updateTyConsTy ddefs mono_st ty) + in p {fundefs = fundefs', mainExp = mainExp'} where fixFunDef :: FunDef0 -> FunDef0 - fixFunDef fn@FunDef{funTy, funBody} = - let funTy' = ForAll (tyVarsFromScheme funTy) (updateTyConsTy ddefs mono_st (tyFromScheme funTy)) + fixFunDef fn@FunDef {funTy, funBody} = + let funTy' = + ForAll + (tyVarsFromScheme funTy) + (updateTyConsTy ddefs mono_st (tyFromScheme funTy)) funBody' = updateTyConsExp ddefs mono_st funBody - in fn { funTy = funTy', funBody = funBody' } + in fn {funTy = funTy', funBody = funBody'} + -- | -updateTyConsExp :: DDefs0 -> MonoState -> Exp0 -> Exp0 +updateTyConsExp :: DDefs0 -> MonoState -> Exp0 -> Exp0 updateTyConsExp ddefs mono_st ex = case ex of - VarE{} -> ex - LitE{} -> ex - CharE{} -> ex - FloatE{} -> ex - LitSymE{} -> ex - AppE f tyapps args -> AppE f tyapps (map go args) - PrimAppE pr args -> PrimAppE pr (map go args) - LetE (v,tyapps,ty,rhs) bod -> LetE (v, tyapps, updateTyConsTy ddefs mono_st ty, go rhs) (go bod) - IfE a b c -> IfE (go a) (go b) (go c) + VarE {} -> ex + LitE {} -> ex + CharE {} -> ex + FloatE {} -> ex + LitSymE {} -> ex + AppE f tyapps args -> AppE f tyapps (map go args) + PrimAppE pr args -> PrimAppE pr (map go args) + LetE (v, tyapps, ty, rhs) bod -> + LetE (v, tyapps, updateTyConsTy ddefs mono_st ty, go rhs) (go bod) + IfE a b c -> IfE (go a) (go b) (go c) MkProdE ls -> MkProdE (map go ls) - ProjE i e -> ProjE i (go e) + ProjE i e -> ProjE i (go e) CaseE scrt brs -> - CaseE (go scrt) (map - (\(dcon,vtys,rhs) -> let (vars,tys) = unzip vtys - vtys' = zip vars $ map (updateTyConsTy ddefs mono_st) tys - in (dcon, vtys', go rhs)) - brs) + CaseE + (go scrt) + (map + (\(dcon, vtys, rhs) -> + let (vars, tys) = unzip vtys + vtys' = zip vars $ map (updateTyConsTy ddefs mono_st) tys + in (dcon, vtys', go rhs)) + brs) DataConE (ProdTy tyapps) dcon args -> let tyapps' = map (updateTyConsTy ddefs mono_st) tyapps - tycon = getTyOfDataCon ddefs dcon - dcon' = case M.lookup (tycon,tyapps') (mono_dcons mono_st) of - Nothing -> dcon - Just suffix -> dcon ++ fromVar suffix - in DataConE (ProdTy tyapps) dcon' (map go args) - DataConE{} -> error $ "updateTyConsExp: DataConE expected ProdTy tyapps, got: " ++ sdoc ex + tycon = getTyOfDataCon ddefs dcon + dcon' = + case M.lookup (tycon, tyapps') (mono_dcons mono_st) of + Nothing -> dcon + Just suffix -> dcon ++ fromVar suffix + in DataConE (ProdTy tyapps) dcon' (map go args) + DataConE {} -> + error $ + "updateTyConsExp: DataConE expected ProdTy tyapps, got: " ++ sdoc ex TimeIt e ty b -> TimeIt (go e) (updateTyConsTy ddefs mono_st ty) b WithArenaE v e -> WithArenaE v (go e) SpawnE fn tyapps args -> SpawnE fn tyapps (map go args) - SyncE -> SyncE - MapE{} -> error $ "updateTyConsExp: TODO: " ++ sdoc ex - FoldE{} -> error $ "updateTyConsExp: TODO: " ++ sdoc ex - Ext (LambdaE args bod) -> Ext (LambdaE (map (\(v,ty) -> (v, updateTyConsTy ddefs mono_st ty)) args) (go bod)) + SyncE -> SyncE + MapE {} -> error $ "updateTyConsExp: TODO: " ++ sdoc ex + FoldE {} -> error $ "updateTyConsExp: TODO: " ++ sdoc ex + Ext (LambdaE args bod) -> + Ext + (LambdaE + (map (\(v, ty) -> (v, updateTyConsTy ddefs mono_st ty)) args) + (go bod)) Ext (PolyAppE a b) -> Ext (PolyAppE (go a) (go b)) - Ext (FunRefE{}) -> ex - Ext (BenchE{}) -> ex - Ext (ParE0 ls) -> Ext $ ParE0 $ map go ls - Ext (PrintPacked ty arg) -> Ext $ PrintPacked (updateTyConsTy ddefs mono_st ty) (go arg) - Ext (CopyPacked ty arg) -> Ext $ CopyPacked (updateTyConsTy ddefs mono_st ty) (go arg) - Ext (TravPacked ty arg) -> Ext $ TravPacked (updateTyConsTy ddefs mono_st ty) (go arg) - Ext (L p e) -> Ext $ L p (go e) - Ext (LinearExt{}) -> error $ "updateTyConsExp: a linear types extension wasn't desugared: " ++ sdoc ex + Ext (FunRefE {}) -> ex + Ext (BenchE {}) -> ex + Ext (ParE0 ls) -> Ext $ ParE0 $ map go ls + Ext (PrintPacked ty arg) -> + Ext $ PrintPacked (updateTyConsTy ddefs mono_st ty) (go arg) + Ext (CopyPacked ty arg) -> + Ext $ CopyPacked (updateTyConsTy ddefs mono_st ty) (go arg) + Ext (TravPacked ty arg) -> + Ext $ TravPacked (updateTyConsTy ddefs mono_st ty) (go arg) + Ext (L p e) -> Ext $ L p (go e) + Ext (LinearExt {}) -> + error $ + "updateTyConsExp: a linear types extension wasn't desugared: " ++ sdoc ex where go = updateTyConsExp ddefs mono_st + -- | Update TyCons if an appropriate monomorphization obligation exists. updateTyConsTy :: DDefs0 -> MonoState -> Ty0 -> Ty0 updateTyConsTy ddefs mono_st ty = case ty of - CharTy -> ty - IntTy -> ty + CharTy -> ty + IntTy -> ty FloatTy -> ty - SymTy0 -> ty - BoolTy -> ty - TyVar{} -> ty - MetaTv{} -> ty - ProdTy tys -> ProdTy (map go tys) + SymTy0 -> ty + BoolTy -> ty + TyVar {} -> ty + MetaTv {} -> ty + ProdTy tys -> ProdTy (map go tys) SymDictTy v t -> SymDictTy v (go t) PDictTy k v -> PDictTy (go k) (go v) - ArrowTy as b -> ArrowTy (map go as) (go b) + ArrowTy as b -> ArrowTy (map go as) (go b) PackedTy t tys -> let tys' = map go tys - in case M.lookup (t,tys') (mono_dcons mono_st) of - Nothing -> PackedTy t tys' + in case M.lookup (t, tys') (mono_dcons mono_st) of + Nothing -> PackedTy t tys' -- Why [] ? The type arguments aren't required as the DDef is monomorphic. - Just suffix -> PackedTy (t ++ fromVar suffix) [] + Just suffix -> PackedTy (t ++ fromVar suffix) [] VectorTy t -> VectorTy (go t) ListTy t -> ListTy (go t) ArenaTy -> ty @@ -849,18 +951,19 @@ updateTyConsTy ddefs mono_st ty = where go = updateTyConsTy ddefs mono_st --------------------------------------------------------------------------------- - +--------------------------------------------------------------------------- -- The specialization monad. type SpecM a = StateT SpecState PassM a type FunRef = Var -data SpecState = SpecState - { sp_funs_todo :: M.Map (Var, [FunRef]) Var - , sp_funs_done :: M.Map (Var, [FunRef]) Var - , sp_extra_args :: M.Map Var [(Var, Ty0)] - , sp_fundefs :: FunDefs0 } +data SpecState = + SpecState + { sp_funs_todo :: M.Map (Var, [FunRef]) Var + , sp_funs_done :: M.Map (Var, [FunRef]) Var + , sp_extra_args :: M.Map Var [(Var, Ty0)] + , sp_fundefs :: FunDefs0 + } deriving (Show, Eq, Generic, Out) {-| @@ -883,7 +986,7 @@ becomes -} specLambdas :: Prog0 -> PassM Prog0 -specLambdas prg@Prog{ddefs,fundefs,mainExp} = do +specLambdas prg@Prog {ddefs, fundefs, mainExp} = do let spec_m = do let env2 = progToEnv prg mainExp' <- @@ -895,217 +998,266 @@ specLambdas prg@Prog{ddefs,fundefs,mainExp} = do -- Same reason as Step (1.2) in monomorphization. let fo_funs = M.filter isFOFun fundefs mapM_ - (\fn@FunDef{funName,funArgs,funTy,funBody} -> do - let venv = M.fromList (fragileZip funArgs (inTys funTy)) - env2' = extendsVEnv venv env2 - funBody' <- specLambdasExp ddefs env2' funBody - sp_state <- get - let funs = sp_fundefs sp_state - fn' = fn { funBody = funBody' } - funs' = M.insert funName fn' funs - sp_state' = sp_state { sp_fundefs = funs' } - put sp_state' - pure ()) + (\fn@FunDef {funName, funArgs, funTy, funBody} -> do + let venv = M.fromList (fragileZip funArgs (inTys funTy)) + env2' = extendsVEnv venv env2 + funBody' <- specLambdasExp ddefs env2' funBody + sp_state <- get + let funs = sp_fundefs sp_state + fn' = fn {funBody = funBody'} + funs' = M.insert funName fn' funs + sp_state' = sp_state {sp_fundefs = funs'} + put sp_state' + pure ()) (M.elems fo_funs) fixpoint pure mainExp' - - (mainExp',sp_state'') <- runStateT spec_m emptySpecState - -- Get rid of all higher order functions. + (mainExp', sp_state'') <- runStateT spec_m emptySpecState let fundefs' = purgeHO (sp_fundefs sp_state'') - prg' = prg { mainExp = mainExp', fundefs = fundefs' } - -- Typecheck again. + prg' = prg {mainExp = mainExp', fundefs = fundefs'} + +-- Typecheck again. tcProg prg' where emptySpecState :: SpecState emptySpecState = SpecState M.empty M.empty M.empty fundefs - -- Lower functions fixpoint :: SpecM () fixpoint = do sp_state <- get if M.null (sp_funs_todo sp_state) - then pure () - else do - let fns = sp_fundefs sp_state - fn = fns # fn_name - ((fn_name, refs), new_fn_name) = M.elemAt 0 (sp_funs_todo sp_state) - specLambdasFun ddefs new_fn_name refs fn - state (\st -> ((), st { sp_funs_todo = M.delete (fn_name, refs) (sp_funs_todo st) - , sp_funs_done = M.insert (fn_name, refs) new_fn_name (sp_funs_done st) })) - fixpoint - + then pure () + else do + let fns = sp_fundefs sp_state + fn = fns # fn_name + ((fn_name, refs), new_fn_name) = + M.elemAt 0 (sp_funs_todo sp_state) + specLambdasFun ddefs new_fn_name refs fn + state + (\st -> + ( () + , st + { sp_funs_todo = M.delete (fn_name, refs) (sp_funs_todo st) + , sp_funs_done = + M.insert (fn_name, refs) new_fn_name (sp_funs_done st) + })) + fixpoint purgeHO :: FunDefs0 -> FunDefs0 purgeHO fns = M.filter isFOFun fns - isFOFun :: FunDef0 -> Bool - isFOFun FunDef{funTy} = + isFOFun FunDef {funTy} = let ForAll _ (ArrowTy arg_tys ret_ty) = funTy - in all (null . arrowTysInTy) arg_tys && - arrowTysInTy ret_ty == [] + in all (null . arrowTysInTy) arg_tys && arrowTysInTy ret_ty == [] + +-- Get rid of all higher order functions. -- Eliminate all functions passed in as arguments to this function. specLambdasFun :: DDefs0 -> Var -> [FunRef] -> FunDef0 -> SpecM () -specLambdasFun ddefs new_fn_name refs fn@FunDef{funArgs, funTy} = do +specLambdasFun ddefs new_fn_name refs fn@FunDef {funArgs, funTy} = do sp_state <- get - let - -- lamda args - funArgs' = map fst $ filter (isFunTy . snd) $ zip funArgs (inTys funTy) - specs = fragileZip funArgs' refs - -- non-lambda args - funArgs'' = map fst $ filter (not . isFunTy . snd) $ zip funArgs (inTys funTy) - fn' = fn { funName = new_fn_name - , funBody = do_spec specs (funBody fn) } + let funArgs' = map fst $ filter (isFunTy . snd) $ zip funArgs (inTys funTy) + specs = fragileZip funArgs' refs + funArgs'' = + map fst $ filter (not . isFunTy . snd) $ zip funArgs (inTys funTy) + fn' = fn {funName = new_fn_name, funBody = do_spec specs (funBody fn)} let venv = M.fromList (fragileZip funArgs'' (inTys funTy')) env2 = Env2 venv (initFunEnv (sp_fundefs sp_state)) funBody' <- specLambdasExp ddefs env2 (funBody fn') sp_state' <- get - let (funArgs''', funTy'') = case M.lookup new_fn_name (sp_extra_args sp_state') of - Nothing -> (funArgs'', funTy') - Just extra_args -> - let ForAll tyvars1 (ArrowTy arg_tys1 ret_ty1) = funTy' - (extra_vars, extra_tys) = unzip extra_args - in (funArgs'' ++ extra_vars, ForAll tyvars1 (ArrowTy (arg_tys1 ++ extra_tys) ret_ty1)) - let fn'' = fn' { funBody = funBody' - , funArgs = funArgs''' - -- N.B. Only update the type after 'specExp' runs. - , funTy = funTy'' } - state (\st -> ((), st { sp_fundefs = M.insert new_fn_name fn'' (sp_fundefs st) })) + let (funArgs''', funTy'') = + case M.lookup new_fn_name (sp_extra_args sp_state') of + Nothing -> (funArgs'', funTy') + Just extra_args -> + let ForAll tyvars1 (ArrowTy arg_tys1 ret_ty1) = funTy' + (extra_vars, extra_tys) = unzip extra_args + in ( funArgs'' ++ extra_vars + , ForAll tyvars1 (ArrowTy (arg_tys1 ++ extra_tys) ret_ty1)) + let fn'' = + fn' + { funBody = funBody' + , funArgs = funArgs''' + +-- N.B. Only update the type after 'specExp' runs. + , funTy = funTy'' + } + state + (\st -> ((), st {sp_fundefs = M.insert new_fn_name fn'' (sp_fundefs st)})) where ForAll tyvars (ArrowTy arg_tys ret_ty) = funTy - - -- TODO: What if the function returns another function ? Not handled yet. + +-- TODO: What if the function returns another function ? Not handled yet. -- First order type funTy' = ForAll tyvars (ArrowTy (filter (not . isFunTy) arg_tys) ret_ty) - - do_spec :: [(Var,Var)] -> Exp0 -> Exp0 + do_spec :: [(Var, Var)] -> Exp0 -> Exp0 do_spec lams e = foldr (uncurry subst') e lams - subst' old new ex = gRename (M.singleton old new) ex +-- lamda args +-- non-lambda args specLambdasExp :: DDefs0 -> Env2 Ty0 -> Exp0 -> SpecM Exp0 specLambdasExp ddefs env2 ex = case ex of - -- TODO, docs. AppE f [] args -> do args' <- mapM go args let args'' = dropFunRefs f env2 args' - refs = foldr collectFunRefs [] args' + refs = foldr collectFunRefs [] args' sp_state <- get case refs of [] -> - case M.lookup f (sp_extra_args sp_state) of - Nothing -> pure $ AppE f [] args'' - Just extra_args -> do - let (vars,_) = unzip extra_args - args''' = args'' ++ map VarE vars - pure $ AppE f [] args''' - _ -> do - let extra_args = foldr (\fnref acc -> - case M.lookup fnref (sp_extra_args sp_state) of - Nothing -> acc - Just extra -> extra ++ acc) - [] refs - let (vars,_) = unzip extra_args + case M.lookup f (sp_extra_args sp_state) of + Nothing -> pure $ AppE f [] args'' + Just extra_args -> do + let (vars, _) = unzip extra_args + args''' = args'' ++ map VarE vars + pure $ AppE f [] args''' + _ -> do + let extra_args = + foldr + (\fnref acc -> + case M.lookup fnref (sp_extra_args sp_state) of + Nothing -> acc + Just extra -> extra ++ acc) + [] + refs + let (vars, _) = unzip extra_args args''' = args'' ++ (map VarE vars) - case (M.lookup (f,refs) (sp_funs_done sp_state), M.lookup (f,refs) (sp_funs_todo sp_state)) of + case ( M.lookup (f, refs) (sp_funs_done sp_state) + , M.lookup (f, refs) (sp_funs_todo sp_state)) of (Nothing, Nothing) -> do f' <- lift $ gensym f let (ForAll _ (ArrowTy as _)) = lookupFEnv f env2 arrow_tys = concatMap arrowTysInTy as - -- Check that the # of refs we collected actually matches the # + +-- Check that the # of refs we collected actually matches the # -- of functions 'f' expects. - assertSameLength ("While lowering the expression " ++ sdoc ex) refs arrow_tys + assertSameLength + ("While lowering the expression " ++ sdoc ex) + refs + arrow_tys -- We have a new lowering obligation. - let sp_extra_args' = case extra_args of - [] -> sp_extra_args sp_state - _ -> M.insert f' extra_args (sp_extra_args sp_state) - let sp_state' = sp_state { sp_funs_todo = M.insert (f,refs) f' (sp_funs_todo sp_state) - , sp_extra_args = sp_extra_args' - } + let sp_extra_args' = + case extra_args of + [] -> sp_extra_args sp_state + _ -> M.insert f' extra_args (sp_extra_args sp_state) + let sp_state' = + sp_state + { sp_funs_todo = + M.insert (f, refs) f' (sp_funs_todo sp_state) + , sp_extra_args = sp_extra_args' + } put sp_state' pure $ AppE f' [] args''' (Just f', _) -> pure $ AppE f' [] args''' (_, Just f') -> pure $ AppE f' [] args''' - AppE _ (_:_) _ -> error $ "specLambdasExp: Call-site not monomorphized: " ++ sdoc ex - + AppE _ (_:_) _ -> + error $ "specLambdasExp: Call-site not monomorphized: " ++ sdoc ex -- Float out a lambda fun to the top-level. LetE (v, [], ty, (Ext (LambdaE args lam_bod))) bod -> do v' <- lift $ gensym v let bod' = gRename (M.singleton v v') bod sp_state <- get let arg_vars = map fst args - captured_vars = gFreeVars lam_bod `S.difference` (S.fromList arg_vars) - `S.difference` (M.keysSet (sp_fundefs sp_state)) - lam_bod' <- specLambdasExp ddefs (L1.extendsVEnv (M.fromList args) env2) lam_bod + captured_vars = + gFreeVars lam_bod `S.difference` (S.fromList arg_vars) `S.difference` + (M.keysSet (sp_fundefs sp_state)) + lam_bod' <- + specLambdasExp ddefs (L1.extendsVEnv (M.fromList args) env2) lam_bod if not (S.null captured_vars) -- Pass captured values as extra arguments - then do - let ls = S.toList captured_vars - tys = map (\w -> case M.lookup w (vEnv env2) of - Nothing -> error $ "Unbound variable: " ++ pprender w - Just ty1 -> ty1) - ls - fns = collectAllFuns lam_bod [] - extra_args = foldr (\fnref acc -> - case M.lookup fnref (sp_extra_args sp_state) of - Nothing -> acc - Just extra -> extra ++ acc) - [] fns - extra_args1 = (zip ls tys) ++ extra_args - (vars1,tys1) = unzip extra_args1 - ty' = addArgsToTy tys1 (ForAll [] ty) - fn = FunDef { funName = v' - , funArgs = arg_vars ++ vars1 - , funTy = ty' - , funBody = lam_bod' - , funMeta = FunMeta { funRec = NotRec - , funInline = Inline - , funCanTriggerGC = False - } + then do + let ls = S.toList captured_vars + tys = + map + (\w -> + case M.lookup w (vEnv env2) of + Nothing -> error $ "Unbound variable: " ++ pprender w + Just ty1 -> ty1) + ls + fns = collectAllFuns lam_bod [] + extra_args = + foldr + (\fnref acc -> + case M.lookup fnref (sp_extra_args sp_state) of + Nothing -> acc + Just extra -> extra ++ acc) + [] + fns + extra_args1 = (zip ls tys) ++ extra_args + (vars1, tys1) = unzip extra_args1 + ty' = addArgsToTy tys1 (ForAll [] ty) + fn = + FunDef + { funName = v' + , funArgs = arg_vars ++ vars1 + , funTy = ty' + , funBody = lam_bod' + , funMeta = + FunMeta + { funRec = NotRec + , funInline = Inline + , funCanTriggerGC = False + , funOptLayout = NoLayoutOpt + , userConstraintsDataCon = Nothing } - env2' = extendFEnv v' ty' env2 - state (\st -> ((), st { sp_fundefs = M.insert v' fn (sp_fundefs st) - , sp_extra_args = M.insert v' extra_args1 (sp_extra_args st)})) - specLambdasExp ddefs env2' bod' - else do - let fns = collectAllFuns lam_bod [] - let extra_args = foldr (\fnref acc -> - case M.lookup fnref (sp_extra_args sp_state) of - Nothing -> acc - Just extra -> extra ++ acc) - [] fns - let (vars,tys) = unzip extra_args - ty' = addArgsToTy tys (ForAll [] ty) - let fn = FunDef { funName = v' - , funArgs = arg_vars ++ vars - , funTy = ty' - , funBody = lam_bod' - , funMeta = FunMeta { funRec = NotRec - , funInline = Inline - , funCanTriggerGC = False - } + } + env2' = extendFEnv v' ty' env2 + state + (\st -> + ( () + , st + { sp_fundefs = M.insert v' fn (sp_fundefs st) + , sp_extra_args = M.insert v' extra_args1 (sp_extra_args st) + })) + specLambdasExp ddefs env2' bod' + else do + let fns = collectAllFuns lam_bod [] + let extra_args = + foldr + (\fnref acc -> + case M.lookup fnref (sp_extra_args sp_state) of + Nothing -> acc + Just extra -> extra ++ acc) + [] + fns + let (vars, tys) = unzip extra_args + ty' = addArgsToTy tys (ForAll [] ty) + let fn = + FunDef + { funName = v' + , funArgs = arg_vars ++ vars + , funTy = ty' + , funBody = lam_bod' + , funMeta = + FunMeta + { funRec = NotRec + , funInline = Inline + , funCanTriggerGC = False + , funOptLayout = NoLayoutOpt + , userConstraintsDataCon = Nothing } - env2' = extendFEnv v' (ForAll [] ty) env2 - state (\st -> ((), st { sp_fundefs = M.insert v' fn (sp_fundefs st) - , sp_extra_args = M.insert v' extra_args (sp_extra_args st)})) - specLambdasExp ddefs env2' bod' - + } + env2' = extendFEnv v' (ForAll [] ty) env2 + state + (\st -> + ( () + , st + { sp_fundefs = M.insert v' fn (sp_fundefs st) + , sp_extra_args = M.insert v' extra_args (sp_extra_args st) + })) + specLambdasExp ddefs env2' bod' LetE (v, [], ty, rhs) bod -> do let _fn_refs = collectFunRefs rhs [] env2' = (extendVEnv v ty env2) rhs' <- go rhs bod' <- specLambdasExp ddefs env2' bod pure $ LetE (v, [], ty, rhs') bod' - - LetE (_, (_:_),_,_) _ -> error $ "specExp: Binding not monomorphized: " ++ sdoc ex - - -- Straightforward recursion - VarE{} -> pure ex - LitE{} -> pure ex - CharE{} -> pure ex - FloatE{} -> pure ex - LitSymE{} -> pure ex + LetE (_, (_:_), _, _) _ -> + error $ "specExp: Binding not monomorphized: " ++ sdoc ex + VarE {} -> pure ex + LitE {} -> pure ex + CharE {} -> pure ex + FloatE {} -> pure ex + LitSymE {} -> pure ex PrimAppE pr args -> do args' <- mapM go args pure $ PrimAppE pr args' @@ -1114,171 +1266,213 @@ specLambdasExp ddefs env2 ex = ProjE i a -> (ProjE i) <$> go a CaseE scrt brs -> do scrt' <- go scrt - brs' <- mapM - (\(dcon,vtys,rhs) -> do - let env2' = extendsVEnv (M.fromList vtys) env2 - (dcon,vtys,) <$> specLambdasExp ddefs env2' rhs) - brs + brs' <- + mapM + (\(dcon, vtys, rhs) -> do + let env2' = extendsVEnv (M.fromList vtys) env2 + (dcon, vtys, ) <$> specLambdasExp ddefs env2' rhs) + brs pure $ CaseE scrt' brs' DataConE tyapp dcon args -> (DataConE tyapp dcon) <$> mapM go args TimeIt e ty b -> do - e' <- go e - pure $ TimeIt e' ty b + e' <- go e + pure $ TimeIt e' ty b WithArenaE v e -> do - e' <- specLambdasExp ddefs (extendVEnv v ArenaTy env2) e - pure $ WithArenaE v e' + e' <- specLambdasExp ddefs (extendVEnv v ArenaTy env2) e + pure $ WithArenaE v e' SpawnE fn tyapps args -> do e' <- specLambdasExp ddefs env2 (AppE fn tyapps args) case e' of AppE fn' tyapps' args' -> pure $ SpawnE fn' tyapps' args' - _ -> error "specLambdasExp: SpawnE" - SyncE -> pure SyncE - MapE{} -> error $ "specLambdasExp: TODO: " ++ sdoc ex - FoldE{} -> error $ "specLambdasExp: TODO: " ++ sdoc ex + _ -> error "specLambdasExp: SpawnE" + SyncE -> pure SyncE + MapE {} -> error $ "specLambdasExp: TODO: " ++ sdoc ex + FoldE {} -> error $ "specLambdasExp: TODO: " ++ sdoc ex Ext ext -> case ext of - LambdaE{} -> error $ "specLambdasExp: Should reach a LambdaE. It should be floated out by the Let case." ++ sdoc ex - PolyAppE{} -> error $ "specLambdasExp: TODO: " ++ sdoc ex - FunRefE{} -> pure ex - BenchE{} -> pure ex + LambdaE {} -> + error $ + "specLambdasExp: Should reach a LambdaE. It should be floated out by the Let case." ++ + sdoc ex + PolyAppE {} -> error $ "specLambdasExp: TODO: " ++ sdoc ex + FunRefE {} -> pure ex + BenchE {} -> pure ex ParE0 ls -> do - let mk_fn :: Exp0 -> SpecM (Maybe FunDef0, [(Var, [Ty0], Ty0, (PreExp E0Ext Ty0 Ty0))], Exp0) + let mk_fn :: + Exp0 + -> SpecM ( Maybe FunDef0 + , [(Var, [Ty0], Ty0, (PreExp E0Ext Ty0 Ty0))] + , Exp0) mk_fn e0 = do let vars = S.toList $ gFreeVars e0 args <- mapM (\v -> lift $ gensym v) vars - let e0' = foldr (\(old,new) acc -> - gSubst old (VarE new) acc) - e0 - (zip vars args) + let e0' = + foldr + (\(old, new) acc -> gSubst old (VarE new) acc) + e0 + (zip vars args) -- let bind args = vars before call_a fnname <- lift $ gensym "fn" - let binds = map (\(v,w,ty) -> (v,[],ty,VarE w)) (zip3 args vars argtys) - retty = recoverType ddefs env2 e0 + let binds = + map + (\(v, w, ty) -> (v, [], ty, VarE w)) + (zip3 args vars argtys) + retty = recoverType ddefs env2 e0 argtys = map (\v -> lookupVEnv v env2) vars - fn = FunDef { funName = fnname - , funArgs = args - , funTy = ForAll [] (ArrowTy argtys retty) - , funBody = e0' - , funMeta = FunMeta { funRec = NotRec - , funInline = NoInline - , funCanTriggerGC = False - } - } + fn = + FunDef + { funName = fnname + , funArgs = args + , funTy = ForAll [] (ArrowTy argtys retty) + , funBody = e0' + , funMeta = + FunMeta + { funRec = NotRec + , funInline = NoInline + , funCanTriggerGC = False + , funOptLayout = NoLayoutOpt + , userConstraintsDataCon = Nothing + } + } pure (Just fn, binds, AppE fnname [] (map VarE args)) - let mb_insert mb_fn mp = case mb_fn of - Just fn -> M.insert (funName fn) fn mp - Nothing -> mp - (mb_fns, binds, calls) <- unzip3 <$> mapM (\a -> case a of - AppE{} -> pure (Nothing, [], a) - _ -> mk_fn a) - ls - state (\st -> ((), st { sp_fundefs = foldr mb_insert (sp_fundefs st) mb_fns })) + let mb_insert mb_fn mp = + case mb_fn of + Just fn -> M.insert (funName fn) fn mp + Nothing -> mp + (mb_fns, binds, calls) <- + unzip3 <$> + mapM + (\a -> + case a of + AppE {} -> pure (Nothing, [], a) + _ -> mk_fn a) + ls + state + (\st -> + ((), st {sp_fundefs = foldr mb_insert (sp_fundefs st) mb_fns})) pure $ mkLets (concat binds) (Ext $ ParE0 calls) PrintPacked ty arg -> Ext <$> (PrintPacked ty) <$> go arg CopyPacked ty arg -> Ext <$> (CopyPacked ty) <$> go arg TravPacked ty arg -> Ext <$> (TravPacked ty) <$> go arg - LinearExt{} -> error $ "specLambdasExp: a linear types extension wasn't desugared: " ++ sdoc ex + LinearExt {} -> + error $ + "specLambdasExp: a linear types extension wasn't desugared: " ++ + sdoc ex L p e -> Ext <$> (L p) <$> go e where go = specLambdasExp ddefs env2 - _isFunRef e = case e of VarE v -> M.member v (fEnv env2) - _ -> False - - -- fn_0 (fn_1, thing, fn_2) => fn_0 (thing) + _ -> False dropFunRefs :: Var -> Env2 Ty0 -> [Exp0] -> [Exp0] dropFunRefs fn_name env21 args = - foldr (\(a,t) acc -> if isFunTy t then acc else a:acc) [] (zip args arg_tys) + foldr + (\(a, t) acc -> + if isFunTy t + then acc + else a : acc) + [] + (zip args arg_tys) where ForAll _ (ArrowTy arg_tys _) = lookupFEnv fn_name env21 - collectFunRefs :: Exp0 -> [FunRef] -> [FunRef] collectFunRefs e acc = case e of - VarE{} -> acc - LitE{} -> acc - CharE{} -> acc - FloatE{} -> acc - LitSymE{} -> acc - AppE _ _ args -> foldr collectFunRefs acc args + VarE {} -> acc + LitE {} -> acc + CharE {} -> acc + FloatE {} -> acc + LitSymE {} -> acc + AppE _ _ args -> foldr collectFunRefs acc args PrimAppE _ args -> foldr collectFunRefs acc args - LetE (_,_,_, rhs) bod -> foldr collectFunRefs acc [bod, rhs] - IfE a b c -> foldr collectFunRefs acc [c, b, a] + LetE (_, _, _, rhs) bod -> foldr collectFunRefs acc [bod, rhs] + IfE a b c -> foldr collectFunRefs acc [c, b, a] MkProdE ls -> foldr collectFunRefs acc ls - ProjE _ a -> collectFunRefs a acc + ProjE _ a -> collectFunRefs a acc DataConE _ _ ls -> foldr collectFunRefs acc ls - TimeIt a _ _ -> collectFunRefs a acc - WithArenaE _ e1-> collectFunRefs e1 acc - CaseE scrt brs -> foldr - (\(_,_,b) acc2 -> collectFunRefs b acc2) - (collectFunRefs scrt acc) - brs + TimeIt a _ _ -> collectFunRefs a acc + WithArenaE _ e1 -> collectFunRefs e1 acc + CaseE scrt brs -> + foldr + (\(_, _, b) acc2 -> collectFunRefs b acc2) + (collectFunRefs scrt acc) + brs SpawnE _ _ args -> foldr collectFunRefs acc args - SyncE -> acc - MapE{} -> error $ "collectFunRefs: TODO: " ++ sdoc e - FoldE{} -> error $ "collectFunRefs: TODO: " ++ sdoc e + SyncE -> acc + MapE {} -> error $ "collectFunRefs: TODO: " ++ sdoc e + FoldE {} -> error $ "collectFunRefs: TODO: " ++ sdoc e Ext ext -> case ext of - LambdaE _ bod -> collectFunRefs bod acc - PolyAppE rator rand -> collectFunRefs rand (collectFunRefs rator acc) - FunRefE _ f -> f : acc - BenchE{} -> acc - ParE0 ls -> foldr collectFunRefs acc ls + LambdaE _ bod -> collectFunRefs bod acc + PolyAppE rator rand -> + collectFunRefs rand (collectFunRefs rator acc) + FunRefE _ f -> f : acc + BenchE {} -> acc + ParE0 ls -> foldr collectFunRefs acc ls PrintPacked _ty arg -> collectFunRefs arg acc CopyPacked _ty arg -> collectFunRefs arg acc TravPacked _ty arg -> collectFunRefs arg acc - L _ e1 -> collectFunRefs e1 acc - LinearExt{} -> error $ "collectFunRefs: a linear types extension wasn't desugared: " ++ sdoc ex - - -- Returns all functions used in an expression, both in AppE's and FunRefE's. + L _ e1 -> collectFunRefs e1 acc + LinearExt {} -> + error $ + "collectFunRefs: a linear types extension wasn't desugared: " ++ + sdoc ex + +-- Returns all functions used in an expression, both in AppE's and FunRefE's. collectAllFuns :: Exp0 -> [FunRef] -> [FunRef] collectAllFuns e acc = case e of - VarE{} -> acc - LitE{} -> acc - CharE{} -> acc - FloatE{} -> acc - LitSymE{} -> acc - AppE f _ args -> f : foldr collectAllFuns acc args + VarE {} -> acc + LitE {} -> acc + CharE {} -> acc + FloatE {} -> acc + LitSymE {} -> acc + AppE f _ args -> f : foldr collectAllFuns acc args PrimAppE _ args -> foldr collectAllFuns acc args - LetE (_,_,_, rhs) bod -> foldr collectAllFuns acc [bod, rhs] - IfE a b c -> foldr collectAllFuns acc [c, b, a] + LetE (_, _, _, rhs) bod -> foldr collectAllFuns acc [bod, rhs] + IfE a b c -> foldr collectAllFuns acc [c, b, a] MkProdE ls -> foldr collectAllFuns acc ls - ProjE _ a -> collectAllFuns a acc + ProjE _ a -> collectAllFuns a acc DataConE _ _ ls -> foldr collectAllFuns acc ls - TimeIt a _ _ -> collectAllFuns a acc - WithArenaE _ e1-> collectAllFuns e1 acc - CaseE scrt brs -> foldr - (\(_,_,b) acc2 -> collectAllFuns b acc2) - (collectAllFuns scrt acc) - brs + TimeIt a _ _ -> collectAllFuns a acc + WithArenaE _ e1 -> collectAllFuns e1 acc + CaseE scrt brs -> + foldr + (\(_, _, b) acc2 -> collectAllFuns b acc2) + (collectAllFuns scrt acc) + brs SpawnE _ _ args -> foldr collectAllFuns acc args - SyncE -> acc - MapE{} -> error $ "collectAllFuns: TODO: " ++ sdoc e - FoldE{} -> error $ "collectAllFuns: TODO: " ++ sdoc e + SyncE -> acc + MapE {} -> error $ "collectAllFuns: TODO: " ++ sdoc e + FoldE {} -> error $ "collectAllFuns: TODO: " ++ sdoc e Ext ext -> case ext of - LambdaE _ bod -> collectAllFuns bod acc - PolyAppE rator rand -> collectAllFuns rand (collectAllFuns rator acc) - FunRefE _ f -> f : acc - BenchE{} -> acc - ParE0 ls -> foldr collectAllFuns acc ls + LambdaE _ bod -> collectAllFuns bod acc + PolyAppE rator rand -> + collectAllFuns rand (collectAllFuns rator acc) + FunRefE _ f -> f : acc + BenchE {} -> acc + ParE0 ls -> foldr collectAllFuns acc ls PrintPacked _ty arg -> collectAllFuns arg acc CopyPacked _ty arg -> collectAllFuns arg acc TravPacked _ty arg -> collectAllFuns arg acc - L _ e1 -> collectAllFuns e1 acc - LinearExt{} -> error $ "collectAllFuns: a linear types extension wasn't desugared: " ++ sdoc ex + L _ e1 -> collectAllFuns e1 acc + LinearExt {} -> + error $ + "collectAllFuns: a linear types extension wasn't desugared: " ++ + sdoc ex + +-- TODO, docs. +-- Straightforward recursion +-- fn_0 (fn_1, thing, fn_2) => fn_0 (thing) addArgsToTy :: [Ty0] -> TyScheme -> TyScheme addArgsToTy ls (ForAll tyvars (ArrowTy in_tys ret_ty)) = - let in_tys' = in_tys ++ ls - in ForAll tyvars (ArrowTy in_tys' ret_ty) + let in_tys' = in_tys ++ ls + in ForAll tyvars (ArrowTy in_tys' ret_ty) addArgsToTy _ oth = error $ "addArgsToTy: " ++ sdoc oth ++ " is not ArrowTy." - - {-| Let bind all anonymous lambdas. @@ -1295,422 +1489,584 @@ lambdas into top-level functions. -} bindLambdas :: Prog0 -> PassM Prog0 -bindLambdas prg@Prog{fundefs,mainExp} = do - mainExp' <- case mainExp of - Nothing -> pure Nothing - Just (a, ty) -> Just <$> (,ty) <$> goExp a - fundefs' <- mapM - (\fn@FunDef{funBody} -> goExp funBody >>= - \b' -> pure $ fn {funBody = b'}) - fundefs - pure $ prg { fundefs = fundefs' - , mainExp = mainExp' } +bindLambdas prg@Prog {fundefs, mainExp} = do + mainExp' <- + case mainExp of + Nothing -> pure Nothing + Just (a, ty) -> Just <$> (, ty) <$> goExp a + fundefs' <- + mapM + (\fn@FunDef {funBody} -> goExp funBody >>= \b' -> pure $ fn {funBody = b'}) + fundefs + pure $ prg {fundefs = fundefs', mainExp = mainExp'} where goExp :: Exp0 -> PassM Exp0 goExp ex0 = gocap ex0 where - gocap ex = do (lets,ex') <- go ex - pure $ mkLets lets ex' - go :: Exp0 -> PassM ([(Var,[Ty0],Ty0,Exp0)], Exp0) - go e0 = - case e0 of - (Ext (LambdaE{})) -> do - v <- gensym "lam" - ty <- newMetaTy - pure ([(v,[],ty,e0)], VarE v) - (LetE (v,tyapps,t,rhs@(Ext LambdaE{})) bod) -> do - (lts2, bod') <- go bod - pure (lts2, LetE (v,tyapps,t,rhs) bod') - -- boilerplate - (Ext (ParE0 ls)) -> do - ls' <- mapM gocap ls - pure ([], Ext $ ParE0 ls') - (Ext PolyAppE{}) -> pure ([], e0) - (Ext FunRefE{}) -> pure ([], e0) - (Ext BenchE{}) -> pure ([], e0) - (Ext (PrintPacked ty arg)) -> do - (lts, arg') <- go arg - pure (lts, Ext (PrintPacked ty arg')) - (Ext (CopyPacked ty arg)) -> do - (lts, arg') <- go arg - pure (lts, Ext (CopyPacked ty arg')) - (Ext (TravPacked ty arg)) -> do - (lts, arg') <- go arg - pure (lts, Ext (TravPacked ty arg')) - (Ext (L p e1)) -> do - (ls, e1') <- go e1 - pure (ls, Ext $ L p e1') - (Ext (LinearExt{})) -> error $ "bindLambdas: a linear types extension wasn't desugared: " ++ sdoc e0 - (LitE _) -> pure ([], e0) - (CharE _) -> pure ([], e0) - (FloatE{}) -> pure ([], e0) - (LitSymE _) -> pure ([], e0) - (VarE _) -> pure ([], e0) - (PrimAppE{}) -> pure ([], e0) - (AppE f tyapps args) -> do - (ltss,args') <- unzip <$> mapM go args - pure (concat ltss, AppE f tyapps args') - (MapE _ _) -> error "bindLambdas: FINISHME MapE" - (FoldE _ _ _) -> error "bindLambdas: FINISHME FoldE" - (LetE (v,tyapps,t,rhs) bod) -> do - (lts1, rhs') <- go rhs - bod' <- gocap bod - pure (lts1, LetE (v,tyapps,t,rhs') bod') - (IfE e1 e2 e3) -> do - (lts1, e1') <- go e1 - e2' <- gocap e2 - e3' <- gocap e3 - pure (lts1, IfE e1' e2' e3') - (ProjE i e) -> do (lts,e') <- go e - pure (lts, ProjE i e') - (MkProdE es) -> do (ltss,es') <- unzip <$> mapM go es - pure (concat ltss, MkProdE es') - (CaseE scrt ls) -> do (lts,scrt') <- go scrt - ls' <- mapM (\(a,b,c) -> (a,b,) <$> gocap c) ls - pure (lts, CaseE scrt' ls') - (DataConE c loc es) -> do (ltss,es') <- unzip <$> mapM go es - pure (concat ltss, DataConE c loc es') - (SpawnE f tyapps args) -> do - (ltss,args') <- unzip <$> mapM go args - pure (concat ltss, SpawnE f tyapps args') - (SyncE) -> pure ([], SyncE) - (WithArenaE v e) -> do - e' <- (gocap e) - pure ([], WithArenaE v e') - (TimeIt e t b) -> do (lts,e') <- go e - pure (lts, TimeIt e' t b) - --------------------------------------------------------------------------------- - + gocap ex = do + (lets, ex') <- go ex + pure $ mkLets lets ex' + go :: Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0) + go e0 = + case e0 of + (Ext (LambdaE {})) -> do + v <- gensym "lam" + ty <- newMetaTy + pure ([(v, [], ty, e0)], VarE v) + (LetE (v, tyapps, t, rhs@(Ext LambdaE {})) bod) -> do + (lts2, bod') <- go bod + pure (lts2, LetE (v, tyapps, t, rhs) bod') + (Ext (ParE0 ls)) -> do + ls' <- mapM gocap ls + pure ([], Ext $ ParE0 ls') + (Ext PolyAppE {}) -> pure ([], e0) + (Ext FunRefE {}) -> pure ([], e0) + (Ext BenchE {}) -> pure ([], e0) + (Ext (PrintPacked ty arg)) -> do + (lts, arg') <- go arg + pure (lts, Ext (PrintPacked ty arg')) + (Ext (CopyPacked ty arg)) -> do + (lts, arg') <- go arg + pure (lts, Ext (CopyPacked ty arg')) + (Ext (TravPacked ty arg)) -> do + (lts, arg') <- go arg + pure (lts, Ext (TravPacked ty arg')) + (Ext (L p e1)) -> do + (ls, e1') <- go e1 + pure (ls, Ext $ L p e1') + (Ext (LinearExt {})) -> + error $ + "bindLambdas: a linear types extension wasn't desugared: " ++ + sdoc e0 + (LitE _) -> pure ([], e0) + (CharE _) -> pure ([], e0) + (FloatE {}) -> pure ([], e0) + (LitSymE _) -> pure ([], e0) + (VarE _) -> pure ([], e0) + (PrimAppE {}) -> pure ([], e0) + (AppE f tyapps args) -> do + (ltss, args') <- unzip <$> mapM go args + pure (concat ltss, AppE f tyapps args') + (MapE _ _) -> error "bindLambdas: FINISHME MapE" + (FoldE _ _ _) -> error "bindLambdas: FINISHME FoldE" + (LetE (v, tyapps, t, rhs) bod) -> do + (lts1, rhs') <- go rhs + bod' <- gocap bod + pure (lts1, LetE (v, tyapps, t, rhs') bod') + (IfE e1 e2 e3) -> do + (lts1, e1') <- go e1 + e2' <- gocap e2 + e3' <- gocap e3 + pure (lts1, IfE e1' e2' e3') + (ProjE i e) -> do + (lts, e') <- go e + pure (lts, ProjE i e') + (MkProdE es) -> do + (ltss, es') <- unzip <$> mapM go es + pure (concat ltss, MkProdE es') + (CaseE scrt ls) -> do + (lts, scrt') <- go scrt + ls' <- mapM (\(a, b, c) -> (a, b, ) <$> gocap c) ls + pure (lts, CaseE scrt' ls') + (DataConE c loc es) -> do + (ltss, es') <- unzip <$> mapM go es + pure (concat ltss, DataConE c loc es') + (SpawnE f tyapps args) -> do + (ltss, args') <- unzip <$> mapM go args + pure (concat ltss, SpawnE f tyapps args') + (SyncE) -> pure ([], SyncE) + (WithArenaE v e) -> do + e' <- (gocap e) + pure ([], WithArenaE v e') + (TimeIt e t b) -> do + (lts, e') <- go e + pure (lts, TimeIt e' t b) + + +-- boilerplate +--- +----------------------------------------------------------------------------- -- | Desugar parallel tuples to spawn's and sync's, and printPacked into function calls. desugarL0 :: Prog0 -> PassM Prog0 desugarL0 (Prog ddefs fundefs' mainExp') = do - -- (Prog ddefs' fundefs' mainExp') <- addRepairFns prg let ddefs'' = M.map desugar_tuples ddefs - fundefs'' <- mapM (\fn@FunDef{funBody} -> go funBody >>= \b -> pure $ fn {funBody = b}) fundefs' - mainExp'' <- case mainExp' of - Nothing -> pure Nothing - Just (e,ty) -> Just <$> (,ty) <$> go e + fundefs'' <- + mapM + (\fn@FunDef {funBody} -> go funBody >>= \b -> pure $ fn {funBody = b}) + fundefs' + mainExp'' <- + case mainExp' of + Nothing -> pure Nothing + Just (e, ty) -> Just <$> (, ty) <$> go e addRepairFns $ Prog ddefs'' fundefs'' mainExp'' where err1 msg = error $ "desugarL0: " ++ msg - desugar_tuples :: DDef0 -> DDef0 - desugar_tuples d@DDef{dataCons} = - let dataCons' = map (second (concatMap goty)) dataCons - in d { dataCons = dataCons' } + desugar_tuples d@DDef {dataCons} = + let dataCons' = map (second (concatMap goty)) dataCons + in d {dataCons = dataCons'} where goty :: (t, Ty0) -> [(t, Ty0)] goty (isBoxed, ty) = case ty of - ProdTy ls -> concatMap (goty . (isBoxed,)) ls - _ -> [(isBoxed, ty)] - + ProdTy ls -> concatMap (goty . (isBoxed, )) ls + _ -> [(isBoxed, ty)] go :: Exp0 -> PassM Exp0 go ex = case ex of - VarE{} -> pure ex - LitE{} -> pure ex - CharE{} -> pure ex - FloatE{} -> pure ex - LitSymE{} -> pure ex - AppE f tyapps args-> AppE f tyapps <$> mapM go args - PrimAppE pr args -> do - -- This is always going to have a function reference which + VarE {} -> pure ex + LitE {} -> pure ex + CharE {} -> pure ex + FloatE {} -> pure ex + LitSymE {} -> pure ex + AppE f tyapps args -> AppE f tyapps <$> mapM go args + PrimAppE pr args + +-- This is always going to have a function reference which -- we cannot eliminate. + -> do let args' = case pr of - VSortP{} -> + VSortP {} -> case args of - [ls, Ext (FunRefE _ fp)] -> [ls, VarE fp] + [ls, Ext (FunRefE _ fp)] -> [ls, VarE fp] [ls, Ext (L _ (Ext (FunRefE _ fp)))] -> [ls, VarE fp] _ -> error $ "desugarL0: vsort" ++ sdoc ex - InplaceVSortP{} -> + InplaceVSortP {} -> case args of - [ls, Ext (FunRefE _ fp)] -> [ls, VarE fp] + [ls, Ext (FunRefE _ fp)] -> [ls, VarE fp] [ls, Ext (L _ (Ext (FunRefE _ fp)))] -> [ls, VarE fp] _ -> error $ "desugarL0: vsort" ++ sdoc ex _ -> args args'' <- mapM go args' pure $ PrimAppE pr args'' - LetE (v,_tyapps,(ProdTy tys),(Ext (ParE0 ls))) bod -> do + LetE (v, _tyapps, (ProdTy tys), (Ext (ParE0 ls))) bod -> do vs <- mapM (\_ -> gensym "par_") ls let xs = (zip3 vs tys ls) spawns = init xs - (a,b,c) = last xs - ls' = foldr - (\(w,ty1,(AppE fn tyapps1 args)) acc -> - (w,[],ty1,(SpawnE fn tyapps1 args)) : acc) - [] - spawns - ls'' = ls' ++ [(a,[],b,c)] - ls''' <- mapM (\(w,x,y,z) -> (w,x,y,) <$> go z) ls'' + (a, b, c) = last xs + ls' = + foldr + (\(w, ty1, (AppE fn tyapps1 args)) acc -> + (w, [], ty1, (SpawnE fn tyapps1 args)) : acc) + [] + spawns + ls'' = ls' ++ [(a, [], b, c)] + ls''' <- mapM (\(w, x, y, z) -> (w, x, y, ) <$> go z) ls'' let binds = ls''' ++ [("_", [], ProdTy [], SyncE)] - bod' = foldr (\((x,_,_,_),i) acc -> - gSubstE (ProjE i (VarE v)) (VarE x) acc) - bod - (zip ls''' [0..]) + bod' = + foldr + (\((x, _, _, _), i) acc -> + gSubstE (ProjE i (VarE v)) (VarE x) acc) + bod + (zip ls''' [0 ..]) bod'' <- go bod' - pure $ mkLets binds bod'' - LetE (v,tyapps,ty,rhs) bod -> LetE <$> (v,tyapps,ty,) <$> go rhs <*> go bod - IfE a b c -> IfE <$> go a <*> go b <*> go c + pure $ mkLets binds bod'' + LetE (v, tyapps, ty, rhs) bod -> + LetE <$> (v, tyapps, ty, ) <$> go rhs <*> go bod + IfE a b c -> IfE <$> go a <*> go b <*> go c MkProdE ls -> MkProdE <$> mapM go ls - ProjE i a -> (ProjE i) <$> go a + ProjE i a -> (ProjE i) <$> go a CaseE scrt brs -> do scrt' <- go scrt - brs' <- mapM (\(dcon,vtys,bod) -> do - let (xs,_tyapps) = unzip vtys - bod' <- go bod - let dcon_tys = lookupDataCon ddefs dcon - flattenTupleArgs :: (Var, Ty0) -> ([Var], Exp0) -> PassM ([Var], Exp0) - flattenTupleArgs (v, vty) (vs0, bod0) = - case vty of - ProdTy ls -> do + brs' <- + mapM + (\(dcon, vtys, bod) -> do + let (xs, _tyapps) = unzip vtys + bod' <- go bod + let dcon_tys = lookupDataCon ddefs dcon + flattenTupleArgs :: + (Var, Ty0) -> ([Var], Exp0) -> PassM ([Var], Exp0) + flattenTupleArgs (v, vty) (vs0, bod0) = + case vty of + ProdTy ls -- create projection variables: v = (y1, y2, ...) - ys <- mapM (\_ -> gensym "y") ls + -> do + ys <- mapM (\_ -> gensym "y") ls -- substitute projections in body with new variable: yi = ProjE i v - let bod1 = foldr (\(i, y) bod1' -> gSubstE (ProjE i (VarE v)) (VarE y) bod1') bod0 (zip [0..] ys) + let bod1 = + foldr + (\(i, y) bod1' -> + gSubstE (ProjE i (VarE v)) (VarE y) bod1') + bod0 + (zip [0 ..] ys) -- substitute whole variable v with product: v = MkProdE (y1, y2, ...) - let bod2 = gSubstE (VarE v) (MkProdE (map VarE ys)) bod1 + let bod2 = + gSubstE (VarE v) (MkProdE (map VarE ys)) bod1 -- flatten each of yis - (ys', bod3) <- foldrM flattenTupleArgs (vs0, bod2) (zip ys ls) - pure (ys', bod3) - _ -> pure (v:vs0, bod0) - - (xs',bod'') <- foldrM flattenTupleArgs ([], bod') (zip xs dcon_tys) - let vtys' = zip xs' (repeat (ProdTy [])) - pure (dcon, vtys', bod'')) - brs + (ys', bod3) <- + foldrM flattenTupleArgs (vs0, bod2) (zip ys ls) + pure (ys', bod3) + _ -> pure (v : vs0, bod0) + (xs', bod'') <- + foldrM flattenTupleArgs ([], bod') (zip xs dcon_tys) + let vtys' = zip xs' (repeat (ProdTy [])) + pure (dcon, vtys', bod'')) + brs pure $ CaseE scrt' brs' DataConE a dcon ls -> do ls' <- mapM go ls let tys = lookupDataCon ddefs dcon - flattenTupleArgs :: Exp0 -> Ty0 -> PassM ([(Var, [loc], Ty0, Exp0)] ,[Exp0]) - flattenTupleArgs arg ty = case ty of - ProdTy tys' -> - case arg of - MkProdE args -> do - (bnds', args') <- unzip <$> zipWithM flattenTupleArgs args tys' - pure (concat bnds',concat args') - _ -> do + flattenTupleArgs :: + Exp0 -> Ty0 -> PassM ([(Var, [loc], Ty0, Exp0)], [Exp0]) + flattenTupleArgs arg ty = + case ty of + ProdTy tys' -> + case arg of + MkProdE args -> do + (bnds', args') <- + unzip <$> zipWithM flattenTupleArgs args tys' + pure (concat bnds', concat args') + _ -- generating alias so that repeated expression is -- eliminated and we are taking projection of trivial varEs - argalias <- gensym "alias" - ys <- mapM (\_ -> gensym "proj") tys' - let vs = map VarE ys - (bnds', args') <- unzip <$> zipWithM flattenTupleArgs vs tys' - let bnds'' = (argalias,[],ty, arg):[(y,[],ty',ProjE i (VarE argalias))| (y, ty', i) <- zip3 ys tys' [0..]] - pure (bnds'' ++ concat bnds', concat args') - _ -> do - pure ([], [arg]) + -> do + argalias <- gensym "alias" + ys <- mapM (\_ -> gensym "proj") tys' + let vs = map VarE ys + (bnds', args') <- + unzip <$> zipWithM flattenTupleArgs vs tys' + let bnds'' = + (argalias, [], ty, arg) : + [ (y, [], ty', ProjE i (VarE argalias)) + | (y, ty', i) <- zip3 ys tys' [0 ..] + ] + pure (bnds'' ++ concat bnds', concat args') + _ -> do + pure ([], [arg]) (binds, args) <- unzip <$> zipWithM flattenTupleArgs ls' tys pure $ mkLets (concat binds) $ DataConE a dcon (concat args) - TimeIt e ty b -> (\a -> TimeIt a ty b) <$> go e + TimeIt e ty b -> (\a -> TimeIt a ty b) <$> go e WithArenaE v e -> (WithArenaE v) <$> go e SpawnE fn tyapps args -> (SpawnE fn tyapps) <$> mapM go args - SyncE -> pure SyncE - MapE{} -> err1 (sdoc ex) - FoldE{} -> err1 (sdoc ex) + SyncE -> pure SyncE + MapE {} -> err1 (sdoc ex) + FoldE {} -> err1 (sdoc ex) Ext ext -> case ext of - LambdaE{} -> err1 (sdoc ex) - PolyAppE{} -> err1 (sdoc ex) - FunRefE{} -> err1 (sdoc ex) - BenchE fn _tyapps args b -> (\a -> Ext $ BenchE fn [] a b) <$> mapM go args + LambdaE {} -> err1 (sdoc ex) + PolyAppE {} -> err1 (sdoc ex) + FunRefE {} -> err1 (sdoc ex) + BenchE fn _tyapps args b -> + (\a -> Ext $ BenchE fn [] a b) <$> mapM go args ParE0 ls -> err1 ("unbound ParE0" ++ sdoc ls) PrintPacked ty arg | (PackedTy tycon _) <- ty -> do - let f = mkPrinterName tycon - pure $ AppE f [] [arg] - | otherwise -> err1 $ "printPacked without a packed type. Got " ++ sdoc ty + let f = mkPrinterName tycon + pure $ AppE f [] [arg] + | otherwise -> + err1 $ "printPacked without a packed type. Got " ++ sdoc ty CopyPacked ty arg | (PackedTy tycon _) <- ty -> do - let f = mkCopyFunName tycon - pure $ AppE f [] [arg] - | otherwise -> err1 $ "printPacked without a packed type. Got " ++ sdoc ty + let f = mkCopyFunName tycon + pure $ AppE f [] [arg] + | otherwise -> + err1 $ "printPacked without a packed type. Got " ++ sdoc ty TravPacked ty arg | (PackedTy tycon _) <- ty -> do - let f = mkTravFunName tycon - pure $ AppE f [] [arg] - | otherwise -> err1 $ "printPacked without a packed type. Got " ++ sdoc ty - L p e -> Ext <$> (L p) <$> (go e) - LinearExt{} -> err1 (sdoc ex) + let f = mkTravFunName tycon + pure $ AppE f [] [arg] + | otherwise -> + err1 $ "printPacked without a packed type. Got " ++ sdoc ty + L p e -> Ext <$> (L p) <$> (go e) + LinearExt {} -> err1 (sdoc ex) --------------------------------------------------------------------------------- +-- (Prog ddefs' fundefs' mainExp') <- addRepairFns prg +-- +------------------------------------------------------------------------------ -- | Add copy & traversal functions for each data type in a prog addRepairFns :: Prog0 -> PassM Prog0 addRepairFns (Prog dfs fds me) = do - newFns <- concat <$> - mapM (\d -> do - copy_fn <- genCopyFn d - copy2_fn <- genCopySansPtrsFn d - trav_fn <- genTravFn d - print_fn <- genPrintFn d - return [copy_fn, copy2_fn, trav_fn, print_fn]) - (filter (not . isVoidDDef) (M.elems dfs)) + newFns <- + concat <$> + mapM + (\d -> do + copy_fn <- genCopyFn d + copy2_fn <- genCopySansPtrsFn d + trav_fn <- genTravFn d + print_fn <- genPrintFn d + return [copy_fn, copy2_fn, trav_fn, print_fn]) + (filter (not . isVoidDDef) (M.elems dfs)) let fds' = fds `M.union` (M.fromList $ map (\f -> (funName f, f)) newFns) pure $ Prog dfs fds' me -- | Generate a copy function for a particular data definition. + -- Note: there will be redundant let bindings in the function body which may need to be inlined. genCopyFn :: DDef0 -> PassM FunDef0 -genCopyFn DDef{tyName, dataCons} = do +genCopyFn DDef {tyName, dataCons} = do arg <- gensym $ "arg" - casebod <- forM dataCons $ \(dcon, dtys) -> - do let tys = map snd dtys - xs <- mapM (\_ -> gensym "x") tys - ys <- mapM (\_ -> gensym "y") tys + casebod <- + forM dataCons $ \(dcon, dtys) -> do + let tys = map snd dtys + xs <- mapM (\_ -> gensym "x") tys + ys <- mapM (\_ -> gensym "y") tys -- let packed_vars = map fst $ filter (\(x,ty) -> isPackedTy ty) (zip ys tys) - let bod = foldr (\(ty,x,y) acc -> - case ty of - PackedTy tycon _ -> LetE (y, [], ty, AppE (mkCopyFunName tycon) [] [VarE x]) acc - _ -> LetE (y, [], ty, VarE x) acc) - (DataConE (ProdTy []) dcon $ map VarE ys) (zip3 tys xs ys) - return (dcon, map (\x -> (x,(ProdTy []))) xs, bod) - return $ FunDef { funName = mkCopyFunName (fromVar tyName) - , funArgs = [arg] - , funTy = (ForAll [] (ArrowTy [PackedTy (fromVar tyName) []] (PackedTy (fromVar tyName) []))) - , funBody = CaseE (VarE arg) casebod - , funMeta = FunMeta { funRec = Rec - , funInline = NoInline - , funCanTriggerGC = False - } - } + let bod = + foldr + (\(ty, x, y) acc -> + case ty of + PackedTy tycon _ -> + LetE + (y, [], ty, AppE (mkCopyFunName tycon) [] [VarE x]) + acc + _ -> LetE (y, [], ty, VarE x) acc) + (DataConE (ProdTy []) dcon $ map VarE ys) + (zip3 tys xs ys) + return (dcon, map (\x -> (x, (ProdTy []))) xs, bod) + return $ + FunDef + { funName = mkCopyFunName (fromVar tyName) + , funArgs = [arg] + , funTy = + (ForAll + [] + (ArrowTy + [PackedTy (fromVar tyName) []] + (PackedTy (fromVar tyName) []))) + , funBody = CaseE (VarE arg) casebod + , funMeta = + FunMeta + { funRec = Rec + , funInline = NoInline + , funCanTriggerGC = False + , funOptLayout = NoLayoutOpt + , userConstraintsDataCon = Nothing + } + } genCopySansPtrsFn :: DDef0 -> PassM FunDef0 -genCopySansPtrsFn DDef{tyName,dataCons} = do +genCopySansPtrsFn DDef {tyName, dataCons} = do arg <- gensym $ "arg" - casebod <- forM dataCons $ \(dcon, dtys) -> - do let tys = map snd dtys - xs <- mapM (\_ -> gensym "x") tys - ys <- mapM (\_ -> gensym "y") tys + casebod <- + forM dataCons $ \(dcon, dtys) -> do + let tys = map snd dtys + xs <- mapM (\_ -> gensym "x") tys + ys <- mapM (\_ -> gensym "y") tys -- let packed_vars = map fst $ filter (\(x,ty) -> isPackedTy ty) (zip ys tys) - let bod = foldr (\(ty,x,y) acc -> - case ty of - PackedTy tycon _ -> LetE (y, [], ty, AppE (mkCopySansPtrsFunName tycon) [] [VarE x]) acc - _ -> LetE (y, [], ty, VarE x) acc) - (DataConE (ProdTy []) dcon $ map VarE ys) (zip3 tys xs ys) - return (dcon, map (\x -> (x,(ProdTy []))) xs, bod) - return $ FunDef { funName = mkCopySansPtrsFunName (fromVar tyName) - , funArgs = [arg] - , funTy = (ForAll [] (ArrowTy [PackedTy (fromVar tyName) []] (PackedTy (fromVar tyName) []))) - , funBody = CaseE (VarE arg) casebod - , funMeta = FunMeta { funRec = Rec - , funInline = NoInline - , funCanTriggerGC = False - } - } - - + let bod = + foldr + (\(ty, x, y) acc -> + case ty of + PackedTy tycon _ -> + LetE + ( y + , [] + , ty + , AppE (mkCopySansPtrsFunName tycon) [] [VarE x]) + acc + _ -> LetE (y, [], ty, VarE x) acc) + (DataConE (ProdTy []) dcon $ map VarE ys) + (zip3 tys xs ys) + return (dcon, map (\x -> (x, (ProdTy []))) xs, bod) + return $ + FunDef + { funName = mkCopySansPtrsFunName (fromVar tyName) + , funArgs = [arg] + , funTy = + (ForAll + [] + (ArrowTy + [PackedTy (fromVar tyName) []] + (PackedTy (fromVar tyName) []))) + , funBody = CaseE (VarE arg) casebod + , funMeta = + FunMeta + { funRec = Rec + , funInline = NoInline + , funCanTriggerGC = False + , funOptLayout = NoLayoutOpt + , userConstraintsDataCon = Nothing + } + } -- | Traverses a packed data type. genTravFn :: DDef0 -> PassM FunDef0 -genTravFn DDef{tyName, dataCons} = do +genTravFn DDef {tyName, dataCons} = do arg <- gensym $ "arg" - casebod <- forM dataCons $ \(dcon, tys) -> - do xs <- mapM (\_ -> gensym "x") tys - ys <- mapM (\_ -> gensym "y") tys - let bod = foldr (\(ty,x,y) acc -> - case ty of - PackedTy tycon _ -> LetE (y, [], ProdTy [], AppE (mkTravFunName tycon) [] [VarE x]) acc - _ -> acc) - (MkProdE []) - (zip3 (map snd tys) xs ys) - return (dcon, map (\x -> (x,ProdTy [])) xs, bod) - return $ FunDef { funName = mkTravFunName (fromVar tyName) - , funArgs = [arg] - , funTy = (ForAll [] (ArrowTy [PackedTy (fromVar tyName) []] (ProdTy []))) - , funBody = CaseE (VarE arg) casebod - , funMeta = FunMeta { funRec = Rec - , funInline = NoInline - , funCanTriggerGC = False - } - } + casebod <- + forM dataCons $ \(dcon, tys) -> do + xs <- mapM (\_ -> gensym "x") tys + ys <- mapM (\_ -> gensym "y") tys + let bod = + foldr + (\(ty, x, y) acc -> + case ty of + PackedTy tycon _ -> + LetE + ( y + , [] + , ProdTy [] + , AppE (mkTravFunName tycon) [] [VarE x]) + acc + _ -> acc) + (MkProdE []) + (zip3 (map snd tys) xs ys) + return (dcon, map (\x -> (x, ProdTy [])) xs, bod) + return $ + FunDef + { funName = mkTravFunName (fromVar tyName) + , funArgs = [arg] + , funTy = (ForAll [] (ArrowTy [PackedTy (fromVar tyName) []] (ProdTy []))) + , funBody = CaseE (VarE arg) casebod + , funMeta = + FunMeta + { funRec = Rec + , funInline = NoInline + , funCanTriggerGC = False + , funOptLayout = NoLayoutOpt + , userConstraintsDataCon = Nothing + } + } -- | Print a packed datatype. genPrintFn :: DDef0 -> PassM FunDef0 -genPrintFn DDef{tyName, dataCons} = do +genPrintFn DDef {tyName, dataCons} = do arg <- gensym "arg" - casebod <- forM dataCons $ \(dcon, tys) -> - do xs <- mapM (\_ -> gensym "x") tys - ys <- mapM (\_ -> gensym "y") tys - let bnds = foldr (\(ty,x,y) acc -> - case ty of - IntTy -> (y, [], ProdTy [], PrimAppE PrintInt [VarE x]) : acc - FloatTy -> (y, [], ProdTy [], PrimAppE PrintFloat [VarE x]) : acc - SymTy0 -> (y, [], ProdTy [], PrimAppE PrintSym [VarE x]) : acc - BoolTy -> (y, [], ProdTy [], PrimAppE PrintBool [VarE x]) : acc - PackedTy tycon _ -> (y, [], ProdTy [], AppE (mkPrinterName tycon) [] [VarE x]) : acc - SymDictTy{} -> (y, [], ProdTy [], PrimAppE PrintSym [LitSymE (toVar "SymDict")]) : acc - VectorTy{} -> (y, [], ProdTy [], PrimAppE PrintSym [LitSymE (toVar "Vector")]) : acc - PDictTy{} -> (y, [], ProdTy [], PrimAppE PrintSym [LitSymE (toVar "PDict")]) : acc - ListTy{} -> (y, [], ProdTy [], PrimAppE PrintSym [LitSymE (toVar "List")]) : acc - ArenaTy{} -> (y, [], ProdTy [], PrimAppE PrintSym [LitSymE (toVar "Arena")]) : acc - SymSetTy{} -> (y, [], ProdTy [], PrimAppE PrintSym [LitSymE (toVar "SymSet")]) : acc - SymHashTy{} -> (y, [], ProdTy [], PrimAppE PrintSym [LitSymE (toVar "SymHash")]) : acc - IntHashTy{} -> (y, [], ProdTy [], PrimAppE PrintSym [LitSymE (toVar "IntHash")]) : acc - _ -> acc) - [] - (zip3 (map snd tys) xs ys) - w1 <- gensym "wildcard" - w2 <- gensym "wildcard" - let add_spaces :: [(Var, [Ty0], Ty0, PreExp E0Ext Ty0 Ty0)] -> PassM [(Var, [Ty0], Ty0, PreExp E0Ext Ty0 Ty0)] - add_spaces [] = pure [] - add_spaces [z] = pure [z] - add_spaces (z:zs) = do - zs' <- add_spaces zs - wi <- gensym "wildcard" - pure $ z:(wi, [], ProdTy [], PrimAppE PrintSym [(LitSymE (toVar " "))] ):zs' - - bnds'' <- add_spaces $ [(w1, [], ProdTy [], PrimAppE PrintSym [(LitSymE (toVar ("(" ++ dcon)))])] ++ bnds - let bnds' = bnds'' ++ [(w2, [], ProdTy [], PrimAppE PrintSym [(LitSymE (toVar ")"))])] - bod = mkLets bnds' (MkProdE []) - return (dcon, map (\x -> (x,ProdTy [])) xs, bod) - return $ FunDef { funName = mkPrinterName (fromVar tyName) - , funArgs = [arg] - , funTy = (ForAll [] (ArrowTy [PackedTy (fromVar tyName) []] (ProdTy []))) - , funBody = CaseE (VarE arg) casebod - , funMeta = FunMeta { funRec = Rec - , funInline = NoInline - , funCanTriggerGC = False - } - } - - --------------------------------------------------------------------------------- - + casebod <- + forM dataCons $ \(dcon, tys) -> do + xs <- mapM (\_ -> gensym "x") tys + ys <- mapM (\_ -> gensym "y") tys + let bnds = + foldr + (\(ty, x, y) acc -> + case ty of + IntTy -> (y, [], ProdTy [], PrimAppE PrintInt [VarE x]) : acc + FloatTy -> + (y, [], ProdTy [], PrimAppE PrintFloat [VarE x]) : acc + SymTy0 -> + (y, [], ProdTy [], PrimAppE PrintSym [VarE x]) : acc + BoolTy -> + (y, [], ProdTy [], PrimAppE PrintBool [VarE x]) : acc + PackedTy tycon _ -> + (y, [], ProdTy [], AppE (mkPrinterName tycon) [] [VarE x]) : + acc + SymDictTy {} -> + ( y + , [] + , ProdTy [] + , PrimAppE PrintSym [LitSymE (toVar "SymDict")]) : + acc + VectorTy {} -> + ( y + , [] + , ProdTy [] + , PrimAppE PrintSym [LitSymE (toVar "Vector")]) : + acc + PDictTy {} -> + ( y + , [] + , ProdTy [] + , PrimAppE PrintSym [LitSymE (toVar "PDict")]) : + acc + ListTy {} -> + ( y + , [] + , ProdTy [] + , PrimAppE PrintSym [LitSymE (toVar "List")]) : + acc + ArenaTy {} -> + ( y + , [] + , ProdTy [] + , PrimAppE PrintSym [LitSymE (toVar "Arena")]) : + acc + SymSetTy {} -> + ( y + , [] + , ProdTy [] + , PrimAppE PrintSym [LitSymE (toVar "SymSet")]) : + acc + SymHashTy {} -> + ( y + , [] + , ProdTy [] + , PrimAppE PrintSym [LitSymE (toVar "SymHash")]) : + acc + IntHashTy {} -> + ( y + , [] + , ProdTy [] + , PrimAppE PrintSym [LitSymE (toVar "IntHash")]) : + acc + _ -> acc) + [] + (zip3 (map snd tys) xs ys) + w1 <- gensym "wildcard" + w2 <- gensym "wildcard" + let add_spaces :: + [(Var, [Ty0], Ty0, PreExp E0Ext Ty0 Ty0)] + -> PassM [(Var, [Ty0], Ty0, PreExp E0Ext Ty0 Ty0)] + add_spaces [] = pure [] + add_spaces [z] = pure [z] + add_spaces (z:zs) = do + zs' <- add_spaces zs + wi <- gensym "wildcard" + pure $ + z : + (wi, [], ProdTy [], PrimAppE PrintSym [(LitSymE (toVar " "))]) : + zs' + bnds'' <- + add_spaces $ + [ ( w1 + , [] + , ProdTy [] + , PrimAppE PrintSym [(LitSymE (toVar ("(" ++ dcon)))]) + ] ++ + bnds + let bnds' = + bnds'' ++ + [(w2, [], ProdTy [], PrimAppE PrintSym [(LitSymE (toVar ")"))])] + bod = mkLets bnds' (MkProdE []) + return (dcon, map (\x -> (x, ProdTy [])) xs, bod) + return $ + FunDef + { funName = mkPrinterName (fromVar tyName) + , funArgs = [arg] + , funTy = (ForAll [] (ArrowTy [PackedTy (fromVar tyName) []] (ProdTy []))) + , funBody = CaseE (VarE arg) casebod + , funMeta = + FunMeta + { funRec = Rec + , funInline = NoInline + , funCanTriggerGC = False + , funOptLayout = NoLayoutOpt + , userConstraintsDataCon = Nothing + } + } + +------------------------------------------------------------------------------- type FloatState = FunDefs0 + type FloatM a = StateT FloatState PassM a floatOutCase :: Prog0 -> PassM Prog0 floatOutCase (Prog ddefs fundefs mainExp) = do - let float_m = do - mapM_ - (\fn@FunDef{funName,funArgs,funTy,funBody} -> do - fstate <- get - let venv = M.fromList (fragileZip funArgs (inTys funTy)) - let env2 = Env2 venv (initFunEnv fstate) - funBody' <- go False env2 funBody - let fn' = fn { funBody = funBody' } - state (\s -> ((), M.insert funName fn' s))) - (M.elems fundefs) - float_main <- do + let float_m = do + mapM_ + (\fn@FunDef {funName, funArgs, funTy, funBody} -> do fstate <- get + let venv = M.fromList (fragileZip funArgs (inTys funTy)) + let env2 = Env2 venv (initFunEnv fstate) + funBody' <- go False env2 funBody + let fn' = fn {funBody = funBody'} + state (\s -> ((), M.insert funName fn' s))) + (M.elems fundefs) + float_main <- + do fstate <- get let env2 = Env2 M.empty (initFunEnv fstate) case mainExp of - Nothing -> pure Nothing - Just (e,ty) -> Just <$> (,ty) <$> go True env2 e - pure float_main - - (mainExp',state') <- runStateT float_m fundefs - pure $ (Prog ddefs state' mainExp') + Nothing -> pure Nothing + Just (e, ty) -> Just <$> (, ty) <$> go True env2 e + pure float_main + (mainExp', state') <- runStateT float_m fundefs + pure $ (Prog ddefs state' mainExp') where err1 msg = error $ "floatOutCase: " ++ msg - float_fn :: Env2 Ty0 -> Exp0 -> FloatM Exp0 float_fn env2 ex = do fundefs' <- get @@ -1722,50 +2078,61 @@ floatOutCase (Prog ddefs fundefs mainExp) = do fn_ty = ForAll [] (ArrowTy in_tys ret_ty) fn_name <- lift $ gensym "caseFn" args <- mapM (\x -> lift $ gensym x) free - let ex' = foldr (\(from,to) acc -> gSubst from (VarE to) acc) ex (zip free args) - let fn = FunDef fn_name args fn_ty ex' (FunMeta NotRec NoInline False) + let ex' = + foldr + (\(from, to) acc -> gSubst from (VarE to) acc) + ex + (zip free args) + let fn = + FunDef + fn_name + args + fn_ty + ex' + (FunMeta NotRec NoInline False NoLayoutOpt Nothing) state (\s -> ((AppE fn_name [] (map VarE free)), M.insert fn_name fn s)) - go :: Bool -> Env2 Ty0 -> Exp0 -> FloatM Exp0 go float env2 ex = case ex of - VarE{} -> pure ex - LitE{} -> pure ex - CharE{} -> pure ex - FloatE{} -> pure ex - LitSymE{} -> pure ex - AppE f tyapps args-> AppE f tyapps <$> mapM recur args - PrimAppE pr args -> do + VarE {} -> pure ex + LitE {} -> pure ex + CharE {} -> pure ex + FloatE {} -> pure ex + LitSymE {} -> pure ex + AppE f tyapps args -> AppE f tyapps <$> mapM recur args + PrimAppE pr args -> do args' <- mapM recur args pure $ PrimAppE pr args' - LetE (v,tyapps,ty,rhs) bod -> do + LetE (v, tyapps, ty, rhs) bod -> do rhs' <- go True env2 rhs - let env2'= extendVEnv v ty env2 + let env2' = extendVEnv v ty env2 bod' <- go True env2' bod - pure $ LetE (v,tyapps,ty,rhs') bod' - IfE a b c -> IfE <$> go True env2 a <*> go True env2 b <*> go True env2 c + pure $ LetE (v, tyapps, ty, rhs') bod' + IfE a b c -> + IfE <$> go True env2 a <*> go True env2 b <*> go True env2 c MkProdE ls -> MkProdE <$> mapM recur ls - ProjE i a -> (ProjE i) <$> recur a + ProjE i a -> (ProjE i) <$> recur a CaseE scrt brs -> do scrt' <- go float env2 scrt - brs' <- mapM (\(dcon,vtys,rhs) -> do - let vars = map fst vtys - let tys = lookupDataCon ddefs dcon - let env2' = extendsVEnv (M.fromList (zip vars tys)) env2 - rhs' <- go True env2' rhs - pure (dcon,vtys,rhs')) - brs + brs' <- + mapM + (\(dcon, vtys, rhs) -> do + let vars = map fst vtys + let tys = lookupDataCon ddefs dcon + let env2' = extendsVEnv (M.fromList (zip vars tys)) env2 + rhs' <- go True env2' rhs + pure (dcon, vtys, rhs')) + brs if float - then float_fn env2 (CaseE scrt' brs') - else pure $ CaseE scrt' brs' + then float_fn env2 (CaseE scrt' brs') + else pure $ CaseE scrt' brs' DataConE a dcon ls -> DataConE a dcon <$> mapM recur ls - TimeIt e ty b -> (\a -> TimeIt a ty b) <$> recur e + TimeIt e ty b -> (\a -> TimeIt a ty b) <$> recur e WithArenaE v e -> (WithArenaE v) <$> recur e SpawnE fn tyapps args -> (SpawnE fn tyapps) <$> mapM recur args - SyncE -> pure SyncE - Ext{} -> pure ex - MapE{} -> err1 (sdoc ex) - FoldE{} -> err1 (sdoc ex) - + SyncE -> pure SyncE + Ext {} -> pure ex + MapE {} -> err1 (sdoc ex) + FoldE {} -> err1 (sdoc ex) where recur = go float env2 diff --git a/gibbon-compiler/src/Gibbon/L0/Syntax.hs b/gibbon-compiler/src/Gibbon/L0/Syntax.hs index 0ab8cae48..19d9d817c 100644 --- a/gibbon-compiler/src/Gibbon/L0/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/L0/Syntax.hs @@ -1,229 +1,260 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + -- | A higher-ordered surface language that supports Rank-1 parametric -- polymorphism. module Gibbon.L0.Syntax - ( module Gibbon.L0.Syntax, - module Gibbon.Language, - ) -where - -import Control.Monad.State ( MonadState ) -import Control.DeepSeq (NFData) -import qualified Data.List as L -import qualified Data.Loc as Loc + ( module Gibbon.L0.Syntax + , module Gibbon.Language + ) where + +import Control.DeepSeq (NFData) +import Control.Monad.State (MonadState) +import qualified Data.List as L +import qualified Data.Loc as Loc +import qualified Data.Map as M +import qualified Data.Set as S import GHC.Generics import Text.PrettyPrint.GenericPretty -import Text.PrettyPrint.HughesPJ as PP -import qualified Data.Set as S -import qualified Data.Map as M +import Text.PrettyPrint.HughesPJ as PP + +import Gibbon.Common as C +import Gibbon.Language hiding (UrTy (..)) -import Gibbon.Common as C -import Gibbon.Language hiding (UrTy(..)) -------------------------------------------------------------------------------- +type Exp0 = PreExp E0Ext Ty0 Ty0 + +type DDefs0 = DDefs Ty0 + +type DDef0 = DDef Ty0 + +type FunDef0 = FunDef Exp0 -type Exp0 = PreExp E0Ext Ty0 Ty0 -type DDefs0 = DDefs Ty0 -type DDef0 = DDef Ty0 -type FunDef0 = FunDef Exp0 type FunDefs0 = FunDefs Exp0 -type Prog0 = Prog Exp0 + +type Prog0 = Prog Exp0 + -------------------------------------------------------------------------------- -- | The extension point for L0. -data E0Ext loc dec = - LambdaE [(Var,dec)] -- Variable tagged with type - (PreExp E0Ext loc dec) - | PolyAppE (PreExp E0Ext loc dec) -- Operator - (PreExp E0Ext loc dec) -- Operand - | FunRefE [loc] Var -- Reference to a function (toplevel or lambda), +data E0Ext loc dec + = LambdaE + [(Var, dec)] -- Variable tagged with type + (PreExp E0Ext loc dec) + | PolyAppE + (PreExp E0Ext loc dec) -- Operator + (PreExp E0Ext loc dec) -- Operand + | FunRefE [loc] Var -- Reference to a function (toplevel or lambda), -- along with its tyapps. - | BenchE Var [loc] [(PreExp E0Ext loc dec)] Bool - | ParE0 [(PreExp E0Ext loc dec)] - | PrintPacked dec (PreExp E0Ext loc dec) -- ^ Print a packed value to standard out. - | CopyPacked dec (PreExp E0Ext loc dec) -- ^ Copy a packed value. - | TravPacked dec (PreExp E0Ext loc dec) -- ^ Traverse a packed value. - | L Loc.Loc (PreExp E0Ext loc dec) - | LinearExt (LinearExt loc dec) - deriving (Show, Ord, Eq, Read, Generic, NFData) + | BenchE Var [loc] [(PreExp E0Ext loc dec)] Bool + | ParE0 [(PreExp E0Ext loc dec)] + | PrintPacked dec (PreExp E0Ext loc dec) -- ^ Print a packed value to standard out. + | CopyPacked dec (PreExp E0Ext loc dec) -- ^ Copy a packed value. + | TravPacked dec (PreExp E0Ext loc dec) -- ^ Traverse a packed value. + | L Loc.Loc (PreExp E0Ext loc dec) + | LinearExt (LinearExt loc dec) + deriving (Show, Ord, Eq, Read, Generic, NFData) + -- | Linear types primitives. -data LinearExt loc dec = +data LinearExt loc dec -- (&) :: a %1 -> (a %1 -> b) %1 -> b - ReverseAppE (PreExp E0Ext loc dec) (PreExp E0Ext loc dec) - - -- lseq :: a %1-> b %1-> b + = ReverseAppE (PreExp E0Ext loc dec) (PreExp E0Ext loc dec) + +-- lseq :: a %1-> b %1-> b | LseqE (PreExp E0Ext loc dec) (PreExp E0Ext loc dec) - - -- unsafeAlias :: a %1-> (a,a) + +-- unsafeAlias :: a %1-> (a,a) | AliasE (PreExp E0Ext loc dec) - - -- unsafeToLinear :: (a %p-> b) %1-> (a %1-> b) + +-- unsafeToLinear :: (a %p-> b) %1-> (a %1-> b) | ToLinearE (PreExp E0Ext loc dec) - deriving (Show, Ord, Eq, Read, Generic, NFData) + -------------------------------------------------------------------------------- -- Helper methods to integrate the Data.Loc with Gibbon - deriving instance Generic Loc.Loc + deriving instance Generic Loc.Pos -deriving instance NFData Loc.Pos -deriving instance NFData Loc.Loc + +--deriving instance Ord Loc.Loc +deriving instance NFData Loc.Pos + +deriving instance NFData Loc.Loc + -- | Orphaned instance: read without source locations. -instance Read t => Read (Loc.L t) where - readsPrec n str = [ (Loc.L Loc.NoLoc a,s) | (a,s) <- readsPrec n str ] +instance Read t => Read (Loc.L t) + where + readsPrec n str = [(Loc.L Loc.NoLoc a, s) | (a, s) <- readsPrec n str] -instance Out Loc.Loc where +instance Out Loc.Loc + where docPrec _ loc = doc loc - doc loc = case loc of Loc.Loc start _end -> doc start - Loc.NoLoc -> PP.empty + Loc.NoLoc -> PP.empty -instance Out Loc.Pos where +instance Out Loc.Pos + where docPrec _ pos = doc pos - doc (Loc.Pos path line col _) = hcat [doc path, colon, doc line, colon, doc col] + doc (Loc.Pos path line col _) = + hcat [doc path, colon, doc line, colon, doc col] + -------------------------------------------------------------------------------- -- Instances for E0Ext - -instance FreeVars (E0Ext l d) where +instance (Out l, Out d) => FreeVars (E0Ext l d) where gFreeVars e = case e of - LambdaE args bod -> foldr S.delete (gFreeVars bod) (map fst args) - PolyAppE f d -> gFreeVars f `S.union` gFreeVars d - FunRefE _ f -> S.singleton f - BenchE _ _ args _-> S.unions (map gFreeVars args) - ParE0 ls -> S.unions (map gFreeVars ls) - PrintPacked _ e1 -> gFreeVars e1 - CopyPacked _ e1 -> gFreeVars e1 - TravPacked _ e1 -> gFreeVars e1 - L _ e1 -> gFreeVars e1 - LinearExt ext -> gFreeVars ext - -instance (Out l, Out d, Show l, Show d) => Expression (E0Ext l d) where + LambdaE args bod -> foldr S.delete (gFreeVars bod) (map fst args) + PolyAppE f d -> gFreeVars f `S.union` gFreeVars d + FunRefE _ f -> S.singleton f + BenchE _ _ args _ -> S.unions (map gFreeVars args) + ParE0 ls -> S.unions (map gFreeVars ls) + PrintPacked _ e1 -> gFreeVars e1 + CopyPacked _ e1 -> gFreeVars e1 + TravPacked _ e1 -> gFreeVars e1 + L _ e1 -> gFreeVars e1 + LinearExt ext -> gFreeVars ext + +instance (Out l, Out d, Show l, Show d) => Expression (E0Ext l d) + where type LocOf (E0Ext l d) = l type TyOf (E0Ext l d) = d - isTrivial _ = False + isTrivial _ = False -instance (Show l, Out l) => Flattenable (E0Ext l Ty0) where - gFlattenGatherBinds _ddfs _env ex = return ([], ex) - gFlattenExp _ddfs _env ex = return ex +instance (Show l, Out l) => Flattenable (E0Ext l Ty0) + where + gFlattenGatherBinds _ddfs _env ex = return ([], ex) + gFlattenExp _ddfs _env ex = return ex -instance HasSubstitutableExt E0Ext l d => SubstitutableExt (PreExp E0Ext l d) (E0Ext l d) where +instance HasSubstitutableExt E0Ext l d => + SubstitutableExt (PreExp E0Ext l d) (E0Ext l d) where gSubstExt old new ext = case ext of - LambdaE args bod -> LambdaE args (gSubst old new bod) - PolyAppE a b -> PolyAppE (gSubst old new a) (gSubst old new b) - FunRefE{} -> ext + LambdaE args bod -> LambdaE args (gSubst old new bod) + PolyAppE a b -> PolyAppE (gSubst old new a) (gSubst old new b) + FunRefE {} -> ext BenchE fn tyapps args b -> BenchE fn tyapps (map (gSubst old new) args) b - ParE0 ls -> ParE0 $ map (gSubst old new) ls - PrintPacked ty e1 -> PrintPacked ty (gSubst old new e1) - CopyPacked ty e1 -> CopyPacked ty (gSubst old new e1) - TravPacked ty e1 -> TravPacked ty (gSubst old new e1) - L p e1 -> L p (gSubst old new e1) - LinearExt e -> LinearExt (gSubstExt old new e) - + ParE0 ls -> ParE0 $ map (gSubst old new) ls + PrintPacked ty e1 -> PrintPacked ty (gSubst old new e1) + CopyPacked ty e1 -> CopyPacked ty (gSubst old new e1) + TravPacked ty e1 -> TravPacked ty (gSubst old new e1) + L p e1 -> L p (gSubst old new e1) + LinearExt e -> LinearExt (gSubstExt old new e) gSubstEExt old new ext = case ext of LambdaE args bod -> LambdaE args (gSubstE old new bod) - PolyAppE a b -> PolyAppE (gSubstE old new a) (gSubstE old new b) - FunRefE{} -> ext + PolyAppE a b -> PolyAppE (gSubstE old new a) (gSubstE old new b) + FunRefE {} -> ext BenchE fn tyapps args b -> BenchE fn tyapps (map (gSubstE old new) args) b ParE0 ls -> ParE0 $ map (gSubstE old new) ls PrintPacked ty e -> PrintPacked ty $ (gSubstE old new e) CopyPacked ty e -> CopyPacked ty $ (gSubstE old new e) TravPacked ty e -> TravPacked ty $ (gSubstE old new e) - L p e -> L p $ (gSubstE old new e) + L p e -> L p $ (gSubstE old new e) LinearExt e -> LinearExt (gSubstEExt old new e) instance HasRenamable E0Ext l d => Renamable (E0Ext l d) where gRename env ext = case ext of - LambdaE args bod -> LambdaE (map (\(a,b) -> (go a, go b)) args) (go bod) - PolyAppE a b -> PolyAppE (go a) (go b) + LambdaE args bod -> LambdaE (map (\(a, b) -> (go a, go b)) args) (go bod) + PolyAppE a b -> PolyAppE (go a) (go b) FunRefE tyapps a -> FunRefE (map go tyapps) (go a) BenchE fn tyapps args b -> BenchE fn (map go tyapps) (map go args) b ParE0 ls -> ParE0 $ map (gRename env) ls PrintPacked ty e -> PrintPacked ty (gRename env e) CopyPacked ty e -> CopyPacked ty (gRename env e) TravPacked ty e -> TravPacked ty (gRename env e) - L p e -> L p (gRename env e) + L p e -> L p (gRename env e) LinearExt e -> LinearExt (gRename env e) where - go :: forall a. Renamable a => a -> a + go :: + forall a. Renamable a + => a + -> a go = gRename env instance (Out l, Out d) => Out (E0Ext l d) + instance Out Ty0 + instance Out TyScheme + -------------------------------------------------------------------------------- -- Instances for LinearExt - -instance FreeVars (LinearExt l d) where +instance (Out l, Out d) => FreeVars (LinearExt l d) where gFreeVars e = case e of ReverseAppE fn arg -> gFreeVars fn `S.union` (gFreeVars arg) - LseqE a b -> gFreeVars a `S.union` gFreeVars b - AliasE a -> gFreeVars a - ToLinearE a -> gFreeVars a + LseqE a b -> gFreeVars a `S.union` gFreeVars b + AliasE a -> gFreeVars a + ToLinearE a -> gFreeVars a -instance (Out l, Out d, Show l, Show d) => Expression (LinearExt l d) where +instance (Out l, Out d, Show l, Show d) => Expression (LinearExt l d) + where type LocOf (LinearExt l d) = l type TyOf (LinearExt l d) = d - isTrivial _ = False + isTrivial _ = False -instance (Show l, Out l) => Flattenable (LinearExt l Ty0) where - gFlattenGatherBinds _ddfs _env ex = return ([], ex) - gFlattenExp _ddfs _env ex = return ex +instance (Show l, Out l) => Flattenable (LinearExt l Ty0) + where + gFlattenGatherBinds _ddfs _env ex = return ([], ex) + gFlattenExp _ddfs _env ex = return ex -instance HasSubstitutableExt E0Ext l d => SubstitutableExt (PreExp E0Ext l d) (LinearExt l d) where +instance HasSubstitutableExt E0Ext l d => + SubstitutableExt (PreExp E0Ext l d) (LinearExt l d) where gSubstExt old new ext = case ext of ReverseAppE fn arg -> ReverseAppE (gSubst old new fn) (gSubst old new arg) - LseqE a b -> LseqE (gSubst old new a) (gSubst old new b) - AliasE a -> AliasE (gSubst old new a) - ToLinearE a -> ToLinearE (gSubst old new a) - + LseqE a b -> LseqE (gSubst old new a) (gSubst old new b) + AliasE a -> AliasE (gSubst old new a) + ToLinearE a -> ToLinearE (gSubst old new a) gSubstEExt old new ext = case ext of - ReverseAppE fn arg -> ReverseAppE (gSubstE old new fn) (gSubstE old new arg) - LseqE a b -> LseqE (gSubstE old new a) (gSubstE old new b) - AliasE a -> AliasE (gSubstE old new a) + ReverseAppE fn arg -> + ReverseAppE (gSubstE old new fn) (gSubstE old new arg) + LseqE a b -> LseqE (gSubstE old new a) (gSubstE old new b) + AliasE a -> AliasE (gSubstE old new a) ToLinearE a -> ToLinearE (gSubstE old new a) instance HasRenamable E0Ext l d => Renamable (LinearExt l d) where gRename env ext = case ext of ReverseAppE fn arg -> ReverseAppE (go fn) (go arg) - LseqE a b -> LseqE (go a) (go b) - AliasE a -> AliasE (go a) - ToLinearE a -> ToLinearE (go a) + LseqE a b -> LseqE (go a) (go b) + AliasE a -> AliasE (go a) + ToLinearE a -> ToLinearE (go a) where - go :: forall a. Renamable a => a -> a + go :: + forall a. Renamable a + => a + -> a go = gRename env instance (Out l, Out d) => Out (LinearExt l d) --------------------------------------------------------------------------------- -data MetaTv = Meta Int +-------------------------------------------------------------------------------- +data MetaTv = + Meta Int deriving (Read, Show, Eq, Ord, Generic, NFData) -instance Out MetaTv where +instance Out MetaTv + where doc (Meta i) = text "$" PP.<> doc i - docPrec _ v = doc v + docPrec _ v = doc v newMetaTv :: MonadState Int m => m MetaTv newMetaTv = Meta <$> newUniq @@ -235,49 +266,50 @@ newTyVar :: MonadState Int m => m TyVar newTyVar = BoundTv <$> genLetter data Ty0 - = IntTy - | CharTy - | FloatTy - | SymTy0 - | BoolTy - | TyVar TyVar -- Rigid/skolem type variables - | MetaTv MetaTv -- Unification variables - | ProdTy [Ty0] - | SymDictTy (Maybe Var) Ty0 - | PDictTy Ty0 Ty0 - | SymSetTy - | SymHashTy - | IntHashTy - | ArrowTy [Ty0] Ty0 - | PackedTy TyCon [Ty0] -- Type arguments to the type constructor - | VectorTy Ty0 - | ListTy Ty0 - | ArenaTy + = IntTy + | CharTy + | FloatTy + | SymTy0 + | BoolTy + | TyVar TyVar -- Rigid/skolem type variables + | MetaTv MetaTv -- Unification variables + | ProdTy [Ty0] + | SymDictTy (Maybe Var) Ty0 + | PDictTy Ty0 Ty0 + | SymSetTy + | SymHashTy + | IntHashTy + | ArrowTy [Ty0] Ty0 + | PackedTy TyCon [Ty0] -- Type arguments to the type constructor + | VectorTy Ty0 + | ListTy Ty0 + | ArenaTy deriving (Show, Read, Eq, Ord, Generic, NFData) -instance FunctionTy Ty0 where +instance FunctionTy Ty0 + where type ArrowTy Ty0 = TyScheme - inTys = arrIns - outTy = arrOut + inTys = arrIns + outTy = arrOut instance Renamable TyVar where gRename env tv = case tv of - BoundTv v -> BoundTv (gRename env v) - SkolemTv{} -> tv - UserTv v -> UserTv (gRename env v) + BoundTv v -> BoundTv (gRename env v) + SkolemTv {} -> tv + UserTv v -> UserTv (gRename env v) instance Renamable Ty0 where gRename env ty = case ty of - IntTy -> IntTy - CharTy -> CharTy - FloatTy-> FloatTy - SymTy0 -> SymTy0 - BoolTy -> BoolTy - TyVar tv -> TyVar (go tv) - MetaTv{} -> ty - ProdTy ls -> ProdTy (map go ls) + IntTy -> IntTy + CharTy -> CharTy + FloatTy -> FloatTy + SymTy0 -> SymTy0 + BoolTy -> BoolTy + TyVar tv -> TyVar (go tv) + MetaTv {} -> ty + ProdTy ls -> ProdTy (map go ls) SymDictTy a t -> SymDictTy a (go t) PDictTy k v -> PDictTy (go k) (go v) ArrowTy args ret -> ArrowTy (map go args) ret @@ -289,16 +321,21 @@ instance Renamable Ty0 where SymHashTy -> SymHashTy IntHashTy -> IntHashTy where - go :: forall a. Renamable a => a -> a + go :: + forall a. Renamable a + => a + -> a go = gRename env + -- | Straightforward parametric polymorphism. -data TyScheme = ForAll [TyVar] Ty0 - deriving (Show, Read, Eq, Ord, Generic, NFData) +data TyScheme = + ForAll [TyVar] Ty0 + deriving (Show, Read, Eq, Ord, Generic, NFData) + -- instance FreeVars TyScheme where -- gFreeVars (ForAll tvs ty) = gFreeVars ty `S.difference` (S.fromList tvs) - arrIns :: TyScheme -> [Ty0] arrIns (ForAll _ (ArrowTy i _)) = i arrIns err = error $ "arrIns: Not an arrow type: " ++ show err @@ -309,7 +346,7 @@ arrOut err = error $ "arrOut: Not an arrow type: " ++ show err arrIns' :: Ty0 -> [Ty0] arrIns' (ArrowTy i _) = i -arrIns' err = error $ "arrIns': Not an arrow type: " ++ show err +arrIns' err = error $ "arrIns': Not an arrow type: " ++ show err tyFromScheme :: TyScheme -> Ty0 tyFromScheme (ForAll _ a) = a @@ -318,8 +355,8 @@ tyVarsFromScheme :: TyScheme -> [TyVar] tyVarsFromScheme (ForAll a _) = a isFunTy :: Ty0 -> Bool -isFunTy ArrowTy{} = True -isFunTy _ = False +isFunTy ArrowTy {} = True +isFunTy _ = False isCallUnsaturated :: TyScheme -> [Exp0] -> Bool isCallUnsaturated sigma args = length args < length (arrIns sigma) @@ -327,23 +364,27 @@ isCallUnsaturated sigma args = length args < length (arrIns sigma) saturateCall :: MonadState Int m => TyScheme -> Exp0 -> m Exp0 saturateCall sigma ex = case ex of - AppE f [] args -> do + AppE f [] args -- # args needed to saturate this call-site. + -> do let args_wanted = length (arrIns sigma) - length args - new_args <- mapM (\_ -> gensym "sat_arg_") [0..(args_wanted-1)] - new_tys <- mapM (\_ -> newMetaTy) new_args + new_args <- mapM (\_ -> gensym "sat_arg_") [0 .. (args_wanted - 1)] + new_tys <- mapM (\_ -> newMetaTy) new_args pure $ - Ext (LambdaE (zip new_args new_tys) - (AppE f [] (args ++ (map VarE new_args)))) - + Ext + (LambdaE + (zip new_args new_tys) + (AppE f [] (args ++ (map VarE new_args)))) AppE _ tyapps _ -> error $ "saturateCall: Expected tyapps to be [], got: " ++ sdoc tyapps _ -> error $ "saturateCall: " ++ sdoc ex ++ " is not a call-site." + -- | Get the free TyVars from types; no duplicates in result. tyVarsInTy :: Ty0 -> [TyVar] tyVarsInTy ty = tyVarsInTys [ty] + -- | Like 'tyVarsInTy'. tyVarsInTys :: [Ty0] -> [TyVar] tyVarsInTys tys = foldr (go []) [] tys @@ -351,19 +392,20 @@ tyVarsInTys tys = foldr (go []) [] tys go :: [TyVar] -> Ty0 -> [TyVar] -> [TyVar] go bound ty acc = case ty of - IntTy -> acc + IntTy -> acc CharTy -> acc - FloatTy-> acc + FloatTy -> acc SymTy0 -> acc BoolTy -> acc - TyVar tv -> if (tv `elem` bound) || (tv `elem` acc) - then acc - else tv : acc + TyVar tv -> + if (tv `elem` bound) || (tv `elem` acc) + then acc + else tv : acc MetaTv _ -> acc - ProdTy tys1 -> foldr (go bound) acc tys1 - SymDictTy _ ty1 -> go bound ty1 acc - PDictTy k v -> foldr (go bound) acc [k,v] - ArrowTy tys1 b -> foldr (go bound) (go bound b acc) tys1 + ProdTy tys1 -> foldr (go bound) acc tys1 + SymDictTy _ ty1 -> go bound ty1 acc + PDictTy k v -> foldr (go bound) acc [k, v] + ArrowTy tys1 b -> foldr (go bound) (go bound b acc) tys1 PackedTy _ tys1 -> foldr (go bound) acc tys1 VectorTy ty1 -> go bound ty1 acc ListTy ty1 -> go bound ty1 acc @@ -372,10 +414,12 @@ tyVarsInTys tys = foldr (go []) [] tys SymHashTy -> acc IntHashTy -> acc + -- | Get the MetaTvs from a type; no duplicates in result. metaTvsInTy :: Ty0 -> [MetaTv] metaTvsInTy ty = metaTvsInTys [ty] + -- | Like 'metaTvsInTy'. metaTvsInTys :: [Ty0] -> [MetaTv] metaTvsInTys tys = foldr go [] tys @@ -383,19 +427,20 @@ metaTvsInTys tys = foldr go [] tys go :: Ty0 -> [MetaTv] -> [MetaTv] go ty acc = case ty of - MetaTv tv -> if tv `elem` acc - then acc - else tv : acc - IntTy -> acc - CharTy -> acc + MetaTv tv -> + if tv `elem` acc + then acc + else tv : acc + IntTy -> acc + CharTy -> acc FloatTy -> acc - SymTy0 -> acc - BoolTy -> acc - TyVar{} -> acc - ProdTy tys1 -> foldr go acc tys1 - SymDictTy _ ty1 -> go ty1 acc + SymTy0 -> acc + BoolTy -> acc + TyVar {} -> acc + ProdTy tys1 -> foldr go acc tys1 + SymDictTy _ ty1 -> go ty1 acc PDictTy k v -> go v (go k acc) - ArrowTy tys1 b -> go b (foldr go acc tys1) + ArrowTy tys1 b -> go b (foldr go acc tys1) PackedTy _ tys1 -> foldr go acc tys1 VectorTy ty1 -> go ty1 acc ListTy ty1 -> go ty1 acc @@ -404,14 +449,17 @@ metaTvsInTys tys = foldr go [] tys SymHashTy -> acc IntHashTy -> acc + -- | Like 'tyVarsInTy'. tyVarsInTyScheme :: TyScheme -> [TyVar] tyVarsInTyScheme (ForAll tyvars ty) = tyVarsInTy ty L.\\ tyvars + -- | Like 'metaTvsInTy'. metaTvsInTyScheme :: TyScheme -> [MetaTv] metaTvsInTyScheme (ForAll _ ty) = metaTvsInTy ty -- ForAll binds TyVars only + -- | Like 'metaTvsInTys'. metaTvsInTySchemes :: [TyScheme] -> [MetaTv] metaTvsInTySchemes tys = concatMap metaTvsInTyScheme tys @@ -421,69 +469,73 @@ arrowTysInTy = go [] where go acc ty = case ty of - IntTy -> acc - CharTy -> acc - FloatTy -> acc - SymTy0 -> acc - BoolTy -> acc - ArenaTy -> acc - TyVar{} -> acc - MetaTv{} -> acc - ProdTy tys -> foldl go acc tys + IntTy -> acc + CharTy -> acc + FloatTy -> acc + SymTy0 -> acc + BoolTy -> acc + ArenaTy -> acc + TyVar {} -> acc + MetaTv {} -> acc + ProdTy tys -> foldl go acc tys SymDictTy _ a -> go acc a PDictTy k v -> go (go acc k) v ArrowTy tys b -> go (foldl go acc tys) b ++ [ty] PackedTy _ vs -> foldl go acc vs - VectorTy a -> go acc a - ListTy a -> go acc a - SymSetTy -> acc - SymHashTy -> acc - IntHashTy -> acc + VectorTy a -> go acc a + ListTy a -> go acc a + SymSetTy -> acc + SymHashTy -> acc + IntHashTy -> acc + -- | Replace the specified quantified type variables by -- given meta type variables. substTyVar :: M.Map TyVar Ty0 -> Ty0 -> Ty0 substTyVar mp ty = case ty of - IntTy -> ty - CharTy -> ty - FloatTy -> ty - SymTy0 -> ty - BoolTy -> ty - TyVar v -> M.findWithDefault ty v mp - MetaTv{} -> ty - ProdTy tys -> ProdTy (map go tys) - SymDictTy v t -> SymDictTy v (go t) - PDictTy k v -> PDictTy (go k) (go v) + IntTy -> ty + CharTy -> ty + FloatTy -> ty + SymTy0 -> ty + BoolTy -> ty + TyVar v -> M.findWithDefault ty v mp + MetaTv {} -> ty + ProdTy tys -> ProdTy (map go tys) + SymDictTy v t -> SymDictTy v (go t) + PDictTy k v -> PDictTy (go k) (go v) ArrowTy tys b -> ArrowTy (map go tys) (go b) PackedTy t tys -> PackedTy t (map go tys) - VectorTy t -> VectorTy (go t) - ListTy t -> ListTy (go t) - ArenaTy -> ty - SymSetTy -> ty - SymHashTy -> ty - IntHashTy -> ty + VectorTy t -> VectorTy (go t) + ListTy t -> ListTy (go t) + ArenaTy -> ty + SymSetTy -> ty + SymHashTy -> ty + IntHashTy -> ty where go = substTyVar mp isScalarTy0 :: Ty0 -> Bool -isScalarTy0 IntTy = True -isScalarTy0 CharTy = True -isScalarTy0 SymTy0 = True -isScalarTy0 BoolTy = True -isScalarTy0 FloatTy= True -isScalarTy0 _ = False +isScalarTy0 IntTy = True +isScalarTy0 CharTy = True +isScalarTy0 SymTy0 = True +isScalarTy0 BoolTy = True +isScalarTy0 FloatTy = True +isScalarTy0 _ = False voidTy0 :: Ty0 voidTy0 = ProdTy [] + -- | Lists of scalars or flat products of scalars are allowed. isValidListElemTy0 :: Ty0 -> Bool isValidListElemTy0 ty | isScalarTy0 ty = True - | otherwise = case ty of - ProdTy tys -> all isScalarTy0 tys - _ -> False + | otherwise = + case ty of + ProdTy tys -> all isScalarTy0 tys + _ -> False + -- Hack: in the specializer, we sometimes want to know the type of -- an expression. However, we cannot derive Typeable for L0. @@ -499,48 +551,61 @@ isValidListElemTy0 ty recoverType :: DDefs0 -> Env2 Ty0 -> Exp0 -> Ty0 recoverType ddfs env2 ex = case ex of - VarE v -> M.findWithDefault (error $ "recoverType: Unbound variable " ++ show v) v (vEnv env2) - LitE _ -> IntTy - CharE _ -> CharTy - FloatE{} -> FloatTy - LitSymE _ -> IntTy - AppE v tyapps _ -> let (ForAll tyvars (ArrowTy _ retty)) = fEnv env2 # v - in substTyVar (M.fromList (fragileZip tyvars tyapps)) retty + VarE v -> + M.findWithDefault + (error $ "recoverType: Unbound variable " ++ show v) + v + (vEnv env2) + LitE _ -> IntTy + CharE _ -> CharTy + FloatE {} -> FloatTy + LitSymE _ -> IntTy + AppE v tyapps _ -> + let (ForAll tyvars (ArrowTy _ retty)) = fEnv env2 # v + in substTyVar (M.fromList (fragileZip tyvars tyapps)) retty -- PrimAppE (DictInsertP ty) ((L _ (VarE v)):_) -> SymDictTy (Just v) ty -- PrimAppE (DictEmptyP ty) ((L _ (VarE v)):_) -> SymDictTy (Just v) ty PrimAppE p _ -> primRetTy1 p - LetE (v,_,t,_) e -> recoverType ddfs (extendVEnv v t env2) e - IfE _ e _ -> recoverType ddfs env2 e - MkProdE es -> ProdTy $ map (recoverType ddfs env2) es + LetE (v, _, t, _) e -> recoverType ddfs (extendVEnv v t env2) e + IfE _ e _ -> recoverType ddfs env2 e + MkProdE es -> ProdTy $ map (recoverType ddfs env2) es DataConE (ProdTy locs) c _ -> PackedTy (getTyOfDataCon ddfs c) locs DataConE loc c _ -> PackedTy (getTyOfDataCon ddfs c) [loc] - TimeIt e _ _ -> recoverType ddfs env2 e - MapE _ e -> recoverType ddfs env2 e - FoldE _ _ e -> recoverType ddfs env2 e + TimeIt e _ _ -> recoverType ddfs env2 e + MapE _ e -> recoverType ddfs env2 e + FoldE _ _ e -> recoverType ddfs env2 e ProjE i e -> case recoverType ddfs env2 e of (ProdTy tys) -> tys !! i - oth -> error$ "typeExp: Cannot project fields from this type: "++show oth - ++"\nExpression:\n "++ sdoc ex - ++"\nEnvironment:\n "++sdoc (vEnv env2) - SpawnE v tyapps _ -> let (ForAll tyvars (ArrowTy _ retty)) = fEnv env2 # v - in substTyVar (M.fromList (fragileZip tyvars tyapps)) retty + oth -> + error $ + "typeExp: Cannot project fields from this type: " ++ + show oth ++ + "\nExpression:\n " ++ + sdoc ex ++ "\nEnvironment:\n " ++ sdoc (vEnv env2) + SpawnE v tyapps _ -> + let (ForAll tyvars (ArrowTy _ retty)) = fEnv env2 # v + in substTyVar (M.fromList (fragileZip tyvars tyapps)) retty SyncE -> voidTy0 CaseE _ mp -> - let (c,args,e) = head mp + let (c, args, e) = head mp args' = map fst args - in recoverType ddfs (extendsVEnv (M.fromList (zip args' (lookupDataCon ddfs c))) env2) e - WithArenaE{} -> error "recoverType: WithArenaE not handled." + in recoverType + ddfs + (extendsVEnv (M.fromList (zip args' (lookupDataCon ddfs c))) env2) + e + WithArenaE {} -> error "recoverType: WithArenaE not handled." Ext ext -> case ext of LambdaE args bod -> recoverType ddfs (extendsVEnv (M.fromList args) env2) bod FunRefE _ f -> case (M.lookup f (vEnv env2), M.lookup f (fEnv env2)) of - (Nothing, Nothing) -> error $ "recoverType: Unbound function " ++ show f + (Nothing, Nothing) -> + error $ "recoverType: Unbound function " ++ show f (Just ty, _) -> ty (_, Just ty) -> tyFromScheme ty -- CSK: Not sure if this is what we want? - PolyAppE{} -> error "recoverTypeep: TODO PolyAppE" + PolyAppE {} -> error "recoverTypeep: TODO PolyAppE" BenchE fn _ _ _ -> outTy $ fEnv env2 # fn PrintPacked _ arg -> recoverType ddfs env2 arg CopyPacked _ arg -> recoverType ddfs env2 arg @@ -548,17 +613,21 @@ recoverType ddfs env2 ex = ParE0 ls -> ProdTy $ map (recoverType ddfs env2) ls LinearExt lin -> case lin of - ReverseAppE fn _args -> case recoverType ddfs env2 fn of - ArrowTy _ ty -> ty - oth -> error $ "recoverType: ReverseAppE expected a function type, got: " ++ sdoc oth + ReverseAppE fn _args -> + case recoverType ddfs env2 fn of + ArrowTy _ ty -> ty + oth -> + error $ + "recoverType: ReverseAppE expected a function type, got: " ++ + sdoc oth LseqE _ b -> recoverType ddfs env2 b - AliasE a -> let ty = recoverType ddfs env2 a - in ProdTy [ty,ty] + AliasE a -> + let ty = recoverType ddfs env2 a + in ProdTy [ty, ty] ToLinearE a -> recoverType ddfs env2 a - - L _ e -> recoverType ddfs env2 e - where + L _ e -> recoverType ddfs env2 e -- Return type for a primitive operation. + where primRetTy1 :: Prim Ty0 -> Ty0 primRetTy1 p = case p of @@ -568,50 +637,50 @@ recoverType ddfs env2 ex = DivP -> IntTy ModP -> IntTy ExpP -> IntTy - RandP-> IntTy + RandP -> IntTy FAddP -> FloatTy FSubP -> FloatTy FMulP -> FloatTy FDivP -> FloatTy FExpP -> FloatTy - FSqrtP-> FloatTy - FRandP-> FloatTy + FSqrtP -> FloatTy + FRandP -> FloatTy FTanP -> FloatTy FloatToIntP -> IntTy IntToFloatP -> FloatTy - EqSymP -> BoolTy + EqSymP -> BoolTy EqBenchProgP _ -> BoolTy - EqIntP -> BoolTy - EqFloatP-> BoolTy + EqIntP -> BoolTy + EqFloatP -> BoolTy EqCharP -> BoolTy - LtP -> BoolTy - GtP -> BoolTy - OrP -> BoolTy - LtEqP-> BoolTy - GtEqP-> BoolTy - FLtP -> BoolTy - FGtP -> BoolTy - FLtEqP-> BoolTy - FGtEqP-> BoolTy + LtP -> BoolTy + GtP -> BoolTy + OrP -> BoolTy + LtEqP -> BoolTy + GtEqP -> BoolTy + FLtP -> BoolTy + FGtP -> BoolTy + FLtEqP -> BoolTy + FGtEqP -> BoolTy AndP -> BoolTy - MkTrue -> BoolTy + MkTrue -> BoolTy MkFalse -> BoolTy - Gensym -> SymTy0 - SizeParam -> IntTy - IsBig -> BoolTy - DictHasKeyP _ -> BoolTy - DictEmptyP ty -> SymDictTy Nothing ty + Gensym -> SymTy0 + SizeParam -> IntTy + IsBig -> BoolTy + DictHasKeyP _ -> BoolTy + DictEmptyP ty -> SymDictTy Nothing ty DictInsertP ty -> SymDictTy Nothing ty DictLookupP ty -> ty - VAllocP elty -> VectorTy elty - VFreeP _elty -> ProdTy [] - VFree2P _elty -> ProdTy [] + VAllocP elty -> VectorTy elty + VFreeP _elty -> ProdTy [] + VFree2P _elty -> ProdTy [] VLengthP _elty -> IntTy - VNthP elty -> elty - VSliceP elty -> VectorTy elty + VNthP elty -> elty + VSliceP elty -> VectorTy elty InplaceVUpdateP elty -> VectorTy elty - VConcatP elty -> VectorTy elty - VSortP elty -> VectorTy elty + VConcatP elty -> VectorTy elty + VSortP elty -> VectorTy elty InplaceVSortP elty -> VectorTy elty VMergeP elty -> VectorTy elty PDictInsertP kty vty -> PDictTy kty vty @@ -622,42 +691,42 @@ recoverType ddfs env2 ex = PDictJoinP kty vty -> PDictTy kty vty LLAllocP elty -> ListTy elty LLIsEmptyP _elty -> BoolTy - LLConsP elty -> ListTy elty - LLHeadP elty -> elty - LLTailP elty -> ListTy elty - LLFreeP _elty -> ProdTy [] - LLFree2P _elty -> ProdTy [] + LLConsP elty -> ListTy elty + LLHeadP elty -> elty + LLTailP elty -> ListTy elty + LLFreeP _elty -> ProdTy [] + LLFree2P _elty -> ProdTy [] LLCopyP elty -> ListTy elty GetNumProcessors -> IntTy - (ErrorP _ ty) -> ty + (ErrorP _ ty) -> ty ReadPackedFile _ _ _ ty -> ty - WritePackedFile{} -> ProdTy [] - ReadArrayFile _ ty -> ty - PrintInt -> ProdTy [] - PrintChar -> ProdTy [] - PrintFloat -> ProdTy [] - PrintBool -> ProdTy [] - PrintSym -> ProdTy [] - ReadInt -> IntTy + WritePackedFile {} -> ProdTy [] + ReadArrayFile _ ty -> ty + PrintInt -> ProdTy [] + PrintChar -> ProdTy [] + PrintFloat -> ProdTy [] + PrintBool -> ProdTy [] + PrintSym -> ProdTy [] + ReadInt -> IntTy RequestEndOf -> error "primRetTy1: RequestEndOf not handled yet" - RequestSizeOf-> error "primRetTy1: RequestSizeOf not handled yet" - SymSetEmpty -> error "primRetTy1: SymSetEmpty not handled yet" - SymSetContains-> error "primRetTy1: SymSetContains not handled yet" + RequestSizeOf -> error "primRetTy1: RequestSizeOf not handled yet" + SymSetEmpty -> error "primRetTy1: SymSetEmpty not handled yet" + SymSetContains -> error "primRetTy1: SymSetContains not handled yet" SymSetInsert -> error "primRetTy1: SymSetInsert not handled yet" SymHashEmpty -> error "primRetTy1: SymHashEmpty not handled yet" - SymHashInsert-> error "primRetTy1: SymHashInsert not handled yet" - SymHashLookup-> error "primRetTy1: SymHashLookup not handled yet" - SymHashContains-> error "primRetTy1: SymHashLookup not handled yet" + SymHashInsert -> error "primRetTy1: SymHashInsert not handled yet" + SymHashLookup -> error "primRetTy1: SymHashLookup not handled yet" + SymHashContains -> error "primRetTy1: SymHashLookup not handled yet" IntHashEmpty -> error "primRetTy1: IntHashEmpty not handled yet" - IntHashInsert-> error "primRetTy1: IntHashInsert not handled yet" - IntHashLookup-> error "primRetTy1: IntHashLookup not handled yet" - Write3dPpmFile{}-> error "primRetTy1: Write3dPpmFile not handled yet" - - + IntHashInsert -> error "primRetTy1: IntHashInsert not handled yet" + IntHashLookup -> error "primRetTy1: IntHashLookup not handled yet" + Write3dPpmFile {} -> error "primRetTy1: Write3dPpmFile not handled yet" {- + -- | Variable definitions + -- ^ Monomorphic version data VarDef a ex = VarDef { varName :: Var , varTy :: a @@ -670,10 +739,12 @@ type FunDefs0 = M.Map Var FunDef0 type FunDef0 = FunDef (L Exp0) -instance FunctionTy Ty0 where +instance FunctionTy Ty0 + where type ArrowTy Ty0 = (Ty0 , Ty0) - inTy = fst - outTy = snd + inTy = fst + outTy = snd + -- ^ Polymorphic version @@ -684,6 +755,7 @@ data PVDef a ex = PVDef { vName :: Var type PVDefs a ex = M.Map Var (PVDef a ex) + -- | for now, using a specialized DDef for L0 -- this enables the DDefs to have type variables type PDDefs a = M.Map Var (PDDef a) @@ -693,6 +765,7 @@ data PDDef a = PDDef { dName :: Var deriving (Read,Show,Eq,Ord, Generic) + -- | for now, using a specialized FunDef for L0 -- theoretically these should disappear after monomorphization -- this enables the FunDefs to have type schemes @@ -704,6 +777,7 @@ data PFDef a ex = PFDef { fName :: Var , fBody :: ex } deriving (Read,Show,Eq,Ord, Functor, Generic) + -- ^ Polymorphic program data PProg = PProg { pddefs :: PDDefs Ty0 , pfundefs :: PFDefs Ty0 (L Exp0) @@ -712,6 +786,7 @@ data PProg = PProg { pddefs :: PDDefs Ty0 } deriving (Show, Eq, Ord, Generic) + -- ^ Monomorphic program data MProg = MProg { ddefs :: DDefs Ty0 , fundefs :: FunDefs0 @@ -720,15 +795,18 @@ data MProg = MProg { ddefs :: DDefs Ty0 } deriving (Show, Eq, Ord, Generic) + -- | some type defns to make things look cleaner type Exp = (L Exp0) + -- | we now have curried functions and curried calls -- curried functions are these variable defns -- but curried calls vs function calls are PolyAppE vs AppE type CurFun = VarDef Ty0 Exp type CCall = Exp + -- | Monomorphized functions type L0Fun = FunDef0 type FCall = Exp diff --git a/gibbon-compiler/src/Gibbon/L1/Examples.hs b/gibbon-compiler/src/Gibbon/L1/Examples.hs index f55980f32..a075acfb9 100644 --- a/gibbon-compiler/src/Gibbon/L1/Examples.hs +++ b/gibbon-compiler/src/Gibbon/L1/Examples.hs @@ -1,27 +1,38 @@ module Gibbon.L1.Examples where -import Data.Map as M +import Data.Map as M -import Gibbon.L1.Syntax +import Gibbon.L1.Syntax --------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- treeTy :: Ty1 treeTy = PackedTy "Tree" () treeDD :: DDefs (UrTy ()) -treeDD = (fromListDD [DDef "Tree" [] - [ ("Leaf",[(False,IntTy)]) - , ("Node",[(False,treeTy) - ,(False,treeTy)])]]) +treeDD = + (fromListDD + [ DDef + "Tree" + [] + [ ("Leaf", [(False, IntTy)]) + , ("Node", [(False, treeTy), (False, treeTy)]) + ] + ]) mkAdd1Prog :: Exp1 -> Maybe (Exp1, Ty1) -> Prog1 -mkAdd1Prog bod mainExp = Prog treeDD - (M.fromList [("add1",mkAdd1Fun bod)]) - mainExp +mkAdd1Prog bod mainExp = + Prog treeDD (M.fromList [("add1", mkAdd1Fun bod)]) mainExp mkAdd1Fun :: Exp1 -> FunDef1 -mkAdd1Fun bod = FunDef "add1" ["tr"] ([treeTy],treeTy) bod (FunMeta Rec NoInline False) +mkAdd1Fun bod = + FunDef + "add1" + ["tr"] + ([treeTy], treeTy) + bod + (FunMeta Rec NoInline False NoLayoutOpt Nothing) + ---------------- @@ -32,42 +43,43 @@ add1Prog = mkAdd1Prog exadd1Bod Nothing exadd1Bod :: Exp1 exadd1Bod = - CaseE (VarE "tr") $ - [ ("Leaf", [("n",())], - PrimAppE AddP [VarE "n", LitE 1]) - , ("Node", [("x",()),("y",())], - DataConE () "Node" - [ AppE "add1" [] [VarE "x"] - , AppE "add1" [] [VarE "y"]]) - ] + CaseE (VarE "tr") $ + [ ("Leaf", [("n", ())], PrimAppE AddP [VarE "n", LitE 1]) + , ( "Node" + , [("x", ()), ("y", ())] + , DataConE () "Node" [AppE "add1" [] [VarE "x"], AppE "add1" [] [VarE "y"]]) + ] exadd1BodLetLeft :: Exp1 exadd1BodLetLeft = - CaseE (VarE "tr") $ - [ ("Leaf", [("n",())], PrimAppE AddP [VarE "n", LitE 1]) - , ("Node", [("x",()),("y",())], - LetE ("x2",[], treeTy, AppE "add1" [] [VarE "x"]) $ - LetE ("y2",[], treeTy, AppE "add1" [] [VarE "y"]) $ - DataConE () "Node" - [ VarE "x2", VarE "y2"]) - ] + CaseE (VarE "tr") $ + [ ("Leaf", [("n", ())], PrimAppE AddP [VarE "n", LitE 1]) + , ( "Node" + , [("x", ()), ("y", ())] + , LetE ("x2", [], treeTy, AppE "add1" [] [VarE "x"]) $ + LetE ("y2", [], treeTy, AppE "add1" [] [VarE "y"]) $ + DataConE () "Node" [VarE "x2", VarE "y2"]) + ] + -- | A more challenging case where recursions are performed right-to-left exadd1BodLetRight :: Exp1 exadd1BodLetRight = - CaseE (VarE "tr") $ - [ ("Leaf", [("n",())], PrimAppE AddP [VarE "n", LitE 1]) - , ("Node", [("x",()),("y",())], - LetE ("y2",[], treeTy, AppE "add1" [] [VarE "y"]) $ - LetE ("x2",[], treeTy, AppE "add1" [] [VarE "x"]) $ - DataConE () "Node" - [ VarE "x2", VarE "y2"]) - ] + CaseE (VarE "tr") $ + [ ("Leaf", [("n", ())], PrimAppE AddP [VarE "n", LitE 1]) + , ( "Node" + , [("x", ()), ("y", ())] + , LetE ("y2", [], treeTy, AppE "add1" [] [VarE "y"]) $ + LetE ("x2", [], treeTy, AppE "add1" [] [VarE "x"]) $ + DataConE () "Node" [VarE "x2", VarE "y2"]) + ] + -- | Add1 program with let bindings, recurring in left-to-right order. add1ProgLetLeft :: Prog1 add1ProgLetLeft = mkAdd1Prog exadd1BodLetLeft Nothing + -- | Add1 program with let bindings, recurring in right-to-left order. add1ProgLetRight :: Prog1 add1ProgLetRight = mkAdd1Prog exadd1BodLetRight Nothing @@ -77,35 +89,50 @@ add1ProgLetRight = mkAdd1Prog exadd1BodLetRight Nothing -- dependency where x2 depends on y2. add1ProgChallenge :: Prog1 add1ProgChallenge = - Prog treeDD - (M.fromList [ ("add1",mkAdd1Fun bod) - , ("pred", FunDef "pred" ["tr"] ([treeTy], BoolTy) - (CaseE (VarE "tr") $ - [ ("Leaf", [("n",())], PrimAppE MkTrue []) - , ("Node", [("x",()),("y",())], PrimAppE MkFalse [])]) - (FunMeta Rec NoInline False))]) - Nothing + Prog + treeDD + (M.fromList + [ ("add1", mkAdd1Fun bod) + , ( "pred" + , FunDef + "pred" + ["tr"] + ([treeTy], BoolTy) + (CaseE (VarE "tr") $ + [ ("Leaf", [("n", ())], PrimAppE MkTrue []) + , ("Node", [("x", ()), ("y", ())], PrimAppE MkFalse []) + ]) + (FunMeta Rec NoInline False NoLayoutOpt Nothing)) + ]) + Nothing where - bod = - CaseE (VarE "tr") $ - [ ("Leaf", [("n",())], PrimAppE AddP [VarE "n", LitE 1]) - , ("Node", [("x",()),("y",())], - LetE ("y2",[], treeTy, AppE "add1" [] [VarE "y"]) $ - LetE ("x2",[], treeTy, - (IfE (AppE "pred" [] [VarE "y2"]) - (AppE "add1" [] [VarE "x"]) - (AppE "add1" [] [VarE "x"]))) $ - DataConE () "Node" [ VarE "x2", VarE "y2"]) + bod = + CaseE (VarE "tr") $ + [ ("Leaf", [("n", ())], PrimAppE AddP [VarE "n", LitE 1]) + , ( "Node" + , [("x", ()), ("y", ())] + , LetE ("y2", [], treeTy, AppE "add1" [] [VarE "y"]) $ + LetE + ( "x2" + , [] + , treeTy + , (IfE + (AppE "pred" [] [VarE "y2"]) + (AppE "add1" [] [VarE "x"]) + (AppE "add1" [] [VarE "x"]))) $ + DataConE () "Node" [VarE "x2", VarE "y2"]) ] + -- | This program is a challenge because a packed value flows to two destinations. add1ProgSharing :: Prog1 -add1ProgSharing = Prog treeDD (M.fromList [("add1",mkAdd1Fun bod)]) Nothing +add1ProgSharing = Prog treeDD (M.fromList [("add1", mkAdd1Fun bod)]) Nothing where - bod = - CaseE (VarE "tr") $ - [ ("Leaf", [("n",())], PrimAppE AddP [VarE "n", LitE 1]) - , ("Node", [("x",()),("y",())], - LetE ("x2",[], treeTy, AppE "add1" [] [VarE "x"]) $ - DataConE () "Node" [ VarE "x2", VarE "x2"]) + bod = + CaseE (VarE "tr") $ + [ ("Leaf", [("n", ())], PrimAppE AddP [VarE "n", LitE 1]) + , ( "Node" + , [("x", ()), ("y", ())] + , LetE ("x2", [], treeTy, AppE "add1" [] [VarE "x"]) $ + DataConE () "Node" [VarE "x2", VarE "x2"]) ] diff --git a/gibbon-compiler/src/Gibbon/L1/Syntax.hs b/gibbon-compiler/src/Gibbon/L1/Syntax.hs index 3f2b8ade1..a9fb53f1d 100644 --- a/gibbon-compiler/src/Gibbon/L1/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/L1/Syntax.hs @@ -1,110 +1,150 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} + -- | The source language for recursive tree traversals. -- This is a first-order language for the "closed world" scenario: -- not integrating with a functional host language, but rather -- genarating C code like a DSL. - module Gibbon.L1.Syntax - ( -- * Core types specific to L1 - Prog1, FunDef1, FunDefs1, DDef1, DDefs1, Exp1, Ty1, E1Ext(..) - - , module Gibbon.Language - ) where + ( Prog1 + , FunDef1 + , FunDefs1 + , DDef1 + , DDefs1 + , Exp1 + , Ty1 + , E1Ext(..) + , module Gibbon.Language + ) where + +import Control.DeepSeq (NFData) +import Data.Graph as G +import Data.Map as M +import qualified Data.Set as S +import GHC.Generics +import Prelude as P +import Text.PrettyPrint.GenericPretty + +import Gibbon.Common +import Gibbon.Language -import Control.DeepSeq ( NFData ) -import qualified Data.Set as S -import GHC.Generics -import Text.PrettyPrint.GenericPretty - -import Gibbon.Language -import Gibbon.Common -------------------------------------------------------------------------------- - -instance FunctionTy Ty1 where +instance FunctionTy Ty1 -- | At this stage, function types are just (in , out) tuples. - type ArrowTy Ty1 = ([Ty1] , Ty1) - inTys = fst - outTy = snd + where + type ArrowTy Ty1 = ([Ty1], Ty1) + inTys = fst + outTy = snd + -- | A convenient, default instantiation of the L1 expression type. type Exp1 = PreExp E1Ext () Ty1 + -- | An L1 program. type Prog1 = Prog Exp1 + -- | Datatypes type DDefs1 = DDefs Ty1 -type DDef1 = DDef Ty1 + +type DDef1 = DDef Ty1 + -- | Function definition used in L1 programs. type FunDef1 = FunDef Exp1 type FunDefs1 = FunDefs Exp1 + -- | The type rperesentation used in L1. type Ty1 = UrTy () +{- +Type CFGfunctionMap: Mapping from function definition, to the control flow graph of the program. +Edge : A tuple of expression and its likelihood. +See Data.Graph in containers for more definitions. +TODO: The functions for which the CFG should be annoted at the front-end level and they should be passable to this pass. +Only generate CFG for functions which are annotated. +-} +--type CFGfunctionMap = M.Map FunDef1 (G.Graph, G.Vertex -> ( (Exp1, Integer), Integer, [Integer]), Integer -> Maybe G.Vertex) +{- A Map storing a function to its data flow graph (Use-def chains) -} +{- Var -- function name -} +{- node = (Var, Exp1, TyCon), ie, variable that's assigned and the assignment expression and type of the variable -} +{- key = Exp1, The expression is the key itself -} +--type DefUseChainsFunctionMap = M.Map Var (G.Graph, G.Vertex -> ((Var, Exp1, TyCon), Exp1, [Exp1]), Exp1 -> Maybe G.Vertex) -------------------------------------------------------------------------------- - -data E1Ext loc dec = BenchE Var [loc] [(PreExp E1Ext loc dec)] Bool - | AddFixed Var Int +data E1Ext loc dec + = BenchE Var [loc] [(PreExp E1Ext loc dec)] Bool + | AddFixed Var Int deriving (Show, Ord, Eq, Read, Generic, NFData, Out) -instance FreeVars (E1Ext l d) where +instance (Out l, Out d) => FreeVars (E1Ext l d) where gFreeVars e = case e of - BenchE _ _ args _-> S.unions (map gFreeVars args) - AddFixed v _ -> S.singleton v + BenchE _ _ args _ -> S.unions (P.map gFreeVars args) + AddFixed v _ -> S.singleton v -instance (Show l, Show d, Out l, Out d) => Expression (E1Ext l d) where - type TyOf (E1Ext l d) = d +instance (Show l, Show d, Out l, Out d) => Expression (E1Ext l d) + where + type TyOf (E1Ext l d) = d type LocOf (E1Ext l d) = l - isTrivial _ = False + isTrivial _ = False -instance (Show l, Show d, Out l, Out d) => Flattenable (E1Ext l d) where +instance (Show l, Show d, Out l, Out d) => Flattenable (E1Ext l d) + where gFlattenGatherBinds _ddfs _env ex = return ([], ex) - gFlattenExp _ddfs _env ex = return ex + gFlattenExp _ddfs _env ex = return ex -instance HasSimplifiableExt E1Ext l d => SimplifiableExt (PreExp E1Ext l d) (E1Ext l d) where +instance HasSimplifiableExt E1Ext l d => + SimplifiableExt (PreExp E1Ext l d) (E1Ext l d) + where gInlineTrivExt _env ext = ext -instance HasSubstitutableExt E1Ext l d => SubstitutableExt (PreExp E1Ext l d) (E1Ext l d) where +instance HasSubstitutableExt E1Ext l d => + SubstitutableExt (PreExp E1Ext l d) (E1Ext l d) where gSubstExt old new ext = case ext of - BenchE fn tyapps args b -> BenchE fn tyapps (map (gSubst old new) args) b - AddFixed v i -> if v == old - then case new of - (VarE v') -> AddFixed v' i - _oth -> error "Could not substitute non-variable in AddFixed" - else AddFixed v i - + BenchE fn tyapps args b -> + BenchE fn tyapps (P.map (gSubst old new) args) b + AddFixed v i -> + if v == old + then case new of + (VarE v') -> AddFixed v' i + _oth -> error "Could not substitute non-variable in AddFixed" + else AddFixed v i gSubstEExt old new ext = case ext of - BenchE fn tyapps args b -> BenchE fn tyapps (map (gSubstE old new) args) b + BenchE fn tyapps args b -> + BenchE fn tyapps (P.map (gSubstE old new) args) b AddFixed v i -> AddFixed v i -instance (Show l, Show d, Out l, Out d, FunctionTy d) => Typeable (E1Ext l d) where +instance (Show l, Show d, Out l, Out d, FunctionTy d) => + Typeable (E1Ext l d) where gRecoverType _ddefs env2 ext = case ext of BenchE fn _ _ _ -> outTy $ fEnv env2 # fn - AddFixed{} -> error "gRecoverType: AddFixed not handled." + AddFixed {} -> error "gRecoverType: AddFixed not handled." -instance Renamable () where - gRename _ () = () +instance Renamable () + where + gRename _ () = () instance HasRenamable E1Ext l d => Renamable (E1Ext l d) where gRename env ext = case ext of - BenchE fn tyapps args b -> BenchE fn tyapps (map go args) b - AddFixed v i -> AddFixed (go v) i + BenchE fn tyapps args b -> BenchE fn tyapps (P.map go args) b + AddFixed v i -> AddFixed (go v) i where - go :: forall a. Renamable a => a -> a + go :: + forall a. Renamable a + => a + -> a go = gRename env diff --git a/gibbon-compiler/src/Gibbon/L2/Examples.hs b/gibbon-compiler/src/Gibbon/L2/Examples.hs index a50dd1b36..312f5fddb 100644 --- a/gibbon-compiler/src/Gibbon/L2/Examples.hs +++ b/gibbon-compiler/src/Gibbon/L2/Examples.hs @@ -21,7 +21,8 @@ import Data.Map as M import Gibbon.Common import Gibbon.L2.Syntax --------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- ddtree :: DDefs Ty2 ddtree = fromListDD [DDef (toVar "Tree") [] @@ -44,12 +45,12 @@ testTypeable = gRecoverType ddtree emptyEnv2 tTypeable -- Add1 add1TraversedFun :: FunDef2 -add1TraversedFun = FunDef "add1" ["tr1"] add1TraversedFunTy add1FunBod (FunMeta Rec NoInline False) +add1TraversedFun = FunDef "add1" ["tr1"] add1TraversedFunTy add1FunBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where add1TraversedFunTy = add1FunTy { arrEffs = S.fromList [Traverse "lin2"] } add1Fun :: FunDef2 -add1Fun = FunDef "add1" ["tr1"] add1FunTy add1FunBod (FunMeta Rec NoInline False) +add1Fun = FunDef "add1" ["tr1"] add1FunTy add1FunBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) add1FunTy :: ArrowTy2 @@ -141,7 +142,7 @@ nodeProg = Prog ddtree M.empty (Just (nodeMainExp, PackedTy "Tree" "l156")) -------------------------------------------------------------------------------- id1Fun :: FunDef2 -id1Fun = FunDef "id1" ["tr18"] idFunTy idFunBod (FunMeta NotRec NoInline False) +id1Fun = FunDef "id1" ["tr18"] idFunTy idFunBod (FunMeta NotRec NoInline False NoLayoutOpt Nothing) where idFunBod = VarE "tr18" @@ -161,7 +162,7 @@ id1Prog = Prog ddtree (M.fromList [("id1", id1Fun)]) Nothing -------------------------------------------------------------------------------- copyTreeFun :: FunDef2 -copyTreeFun = FunDef "copyTree" ["tr22"] copyFunTy copyBod (FunMeta NotRec NoInline False) +copyTreeFun = FunDef "copyTree" ["tr22"] copyFunTy copyBod (FunMeta NotRec NoInline False NoLayoutOpt Nothing) where copyFunTy = ArrowTy2 [LRM "lin23" (VarR "r24") Input, LRM "lout25" (VarR "r752") Output] @@ -211,7 +212,7 @@ copyTreeProg = Prog ddtree (M.fromList [("copyTree", copyTreeFun)]) $ -------------------------------------------------------------------------------- id2Fun :: FunDef2 -id2Fun = FunDef "id2" ["tr41"] id2Ty id2Bod (FunMeta NotRec NoInline False) +id2Fun = FunDef "id2" ["tr41"] id2Ty id2Bod (FunMeta NotRec NoInline False NoLayoutOpt Nothing) where id2Ty :: ArrowTy2 id2Ty = ArrowTy2 @@ -263,7 +264,7 @@ id1WithCopyFun = id1Fun { funBody = AppE "copyTree" ["lin19","lout21"] -------------------------------------------------------------------------------- id3Fun :: FunDef2 -id3Fun = FunDef "id3" ["i42"] id3Ty id3Bod (FunMeta NotRec NoInline False) +id3Fun = FunDef "id3" ["i42"] id3Ty id3Bod (FunMeta NotRec NoInline False NoLayoutOpt Nothing) where id3Ty :: ArrowTy2 id3Ty = ArrowTy2 @@ -285,7 +286,7 @@ id3Prog = Prog ddtree (M.fromList [("id3", id3Fun)]) $ Just (id3MainExp, IntTy) -------------------------------------------------------------------------------- intAddFun :: FunDef2 -intAddFun = FunDef "intAdd" ["i109"] intAddTy id3Bod (FunMeta NotRec NoInline False) +intAddFun = FunDef "intAdd" ["i109"] intAddTy id3Bod (FunMeta NotRec NoInline False NoLayoutOpt Nothing) where intAddTy :: ArrowTy2 intAddTy = ArrowTy2 @@ -309,7 +310,7 @@ intAddProg = Prog M.empty (M.fromList [("intAdd", intAddFun)]) (Just (intAddMain -------------------------------------------------------------------------------- leftmostFun :: FunDef2 -leftmostFun = FunDef "leftmost" ["t111"] leftmostTy leftmostBod (FunMeta Rec NoInline False) +leftmostFun = FunDef "leftmost" ["t111"] leftmostTy leftmostBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where leftmostTy :: ArrowTy2 leftmostTy = ArrowTy2 @@ -350,7 +351,7 @@ leftmostProg = Prog ddtree (M.fromList [("leftmost", leftmostFun)]) (Just (leftm -------------------------------------------------------------------------------- rightmostFun :: FunDef2 -rightmostFun = FunDef "rightmost" ["t242"] rightmostTy rightmostBod (FunMeta Rec NoInline False) +rightmostFun = FunDef "rightmost" ["t242"] rightmostTy rightmostBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where rightmostTy :: ArrowTy2 rightmostTy = ArrowTy2 @@ -396,7 +397,7 @@ rightmostProg = Prog ddtree (M.fromList [("rightmost", rightmostFun)]) -------------------------------------------------------------------------------- buildLeafFun :: FunDef2 -buildLeafFun = FunDef "buildLeaf" ["i125"] buildLeafTy buildLeafBod (FunMeta Rec NoInline False) +buildLeafFun = FunDef "buildLeaf" ["i125"] buildLeafTy buildLeafBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where buildLeafTy :: ArrowTy2 buildLeafTy = ArrowTy2 @@ -423,7 +424,7 @@ buildLeafProg = Prog ddtree (M.fromList [("buildLeaf", buildLeafFun)]) (Just (bu -------------------------------------------------------------------------------- buildTreeFun :: FunDef2 -buildTreeFun = FunDef "buildTree" ["i270"] buildTreeTy buildTreeBod (FunMeta Rec NoInline False) +buildTreeFun = FunDef "buildTree" ["i270"] buildTreeTy buildTreeBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where buildTreeTy :: ArrowTy2 buildTreeTy = ArrowTy2 @@ -463,7 +464,7 @@ buildTreeProg = Prog ddtree (M.fromList [("buildTree", buildTreeFun)]) (Just (bu buildTwoTreesFun :: FunDef2 -buildTwoTreesFun = FunDef "buildTwoTrees" ["i750"] buildTreeTy buildTreeBod (FunMeta Rec NoInline False) +buildTwoTreesFun = FunDef "buildTwoTrees" ["i750"] buildTreeTy buildTreeBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where buildTreeTy :: ArrowTy2 buildTreeTy = ArrowTy2 @@ -500,7 +501,7 @@ buildTwoTreesProg = Prog ddtree (M.fromList [("buildTree", buildTreeFun), -------------------------------------------------------------------------------- buildTreeSumFun :: FunDef2 -buildTreeSumFun = FunDef "buildTreeSum" ["i302"] buildTreeSumTy buildTreeSumBod (FunMeta Rec NoInline False) +buildTreeSumFun = FunDef "buildTreeSum" ["i302"] buildTreeSumTy buildTreeSumBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where buildTreeSumTy :: ArrowTy2 buildTreeSumTy = ArrowTy2 @@ -552,7 +553,7 @@ buildTreeSumProg = Prog ddtree (M.fromList [("buildTreeSum", buildTreeSumFun)]) -------------------------------------------------------------------------------- sumTreeFun :: FunDef2 -sumTreeFun = FunDef "sumTree" ["tr762"] sumTreeTy sumTreeBod (FunMeta Rec NoInline False) +sumTreeFun = FunDef "sumTree" ["tr762"] sumTreeTy sumTreeBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where sumTreeTy :: ArrowTy2 sumTreeTy = ArrowTy2 @@ -642,7 +643,7 @@ addTrees t1 t2 = -} addTreesFun :: FunDef2 -addTreesFun = FunDef "addTrees" ["trees354"] addTreesTy addTreesBod (FunMeta Rec NoInline False) +addTreesFun = FunDef "addTrees" ["trees354"] addTreesTy addTreesBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where addTreesTy :: ArrowTy2 addTreesTy = ArrowTy2 @@ -717,7 +718,7 @@ addTreesProg = Prog ddtree (M.fromList [("addTrees", addTreesFun) -------------------------------------------------------------------------------- testProdFun :: FunDef2 -testProdFun = FunDef "testprod" ["tup130"] testprodTy testprodBod (FunMeta Rec NoInline False) +testProdFun = FunDef "testprod" ["tup130"] testprodTy testprodBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where testprodTy = ArrowTy2 [LRM "lin131" (VarR "r132") Input, LRM "lout133" (VarR "r755") Output] @@ -810,7 +811,7 @@ sumUp tree = -} sumUpFun :: FunDef2 -sumUpFun = FunDef "sumUp" ["tr1"] sumUpFunTy sumUpFunBod (FunMeta Rec NoInline False) +sumUpFun = FunDef "sumUp" ["tr1"] sumUpFunTy sumUpFunBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where sumUpFunTy :: ArrowTy2 sumUpFunTy = ArrowTy2 @@ -849,7 +850,7 @@ sumUpFun = FunDef "sumUp" ["tr1"] sumUpFunTy sumUpFunBod (FunMeta Rec NoInline F valueSTreeFun :: FunDef2 -valueSTreeFun = FunDef "valueSTree" ["tr522"] valueSTreeFunTy valueSTreeFunBod (FunMeta Rec NoInline False) +valueSTreeFun = FunDef "valueSTree" ["tr522"] valueSTreeFunTy valueSTreeFunBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where valueSTreeFunTy :: ArrowTy2 valueSTreeFunTy = ArrowTy2 @@ -871,7 +872,7 @@ valueSTreeFun = FunDef "valueSTree" ["tr522"] valueSTreeFunTy valueSTreeFunBod ( buildSTreeFun :: FunDef2 -buildSTreeFun = FunDef "buildSTree" ["i543"] buildSTreeTy buildSTreeBod (FunMeta Rec NoInline False) +buildSTreeFun = FunDef "buildSTree" ["i543"] buildSTreeTy buildSTreeBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where buildSTreeTy :: ArrowTy2 buildSTreeTy = ArrowTy2 @@ -919,7 +920,7 @@ buildSTreeProg = Prog stree (M.fromList [("buildSTree", buildSTreeFun)]) -------------------------------------------------------------------------------- sumSTreeFun :: FunDef2 -sumSTreeFun = FunDef "sumSTree" ["tr762"] sumSTreeTy sumSTreeBod (FunMeta Rec NoInline False) +sumSTreeFun = FunDef "sumSTree" ["tr762"] sumSTreeTy sumSTreeBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where sumSTreeTy :: ArrowTy2 sumSTreeTy = ArrowTy2 @@ -982,7 +983,7 @@ sumUpProg = Prog stree (M.fromList [("sumUp", sumUpFun) -------------------------------------------------------------------------------- evenFun :: FunDef2 -evenFun = FunDef "even" ["i560"] evenFunTy evenFunBod (FunMeta NotRec NoInline False) +evenFun = FunDef "even" ["i560"] evenFunTy evenFunBod (FunMeta NotRec NoInline False NoLayoutOpt Nothing) where evenFunTy :: ArrowTy2 evenFunTy = ArrowTy2 @@ -1018,7 +1019,7 @@ setEven tree = setEvenFun :: FunDef2 -setEvenFun = FunDef "setEven" ["tr570"] setEvenFunTy setEvenFunBod (FunMeta Rec NoInline False) +setEvenFun = FunDef "setEven" ["tr570"] setEvenFunTy setEvenFunBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where setEvenFunTy :: ArrowTy2 setEvenFunTy = ArrowTy2 @@ -1101,7 +1102,7 @@ merged tr = -} sumUpSetEvenFun :: FunDef2 -sumUpSetEvenFun = FunDef "sumUpSetEven" ["tr600"] sumUpSetEvenFunTy sumUpSetEvenFunBod (FunMeta Rec NoInline False) +sumUpSetEvenFun = FunDef "sumUpSetEven" ["tr600"] sumUpSetEvenFunTy sumUpSetEvenFunBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where sumUpSetEvenFunTy :: ArrowTy2 sumUpSetEvenFunTy = ArrowTy2 @@ -1194,7 +1195,7 @@ ddexpr = fromListDD [DDef (toVar "Expr") [] ]] copyExprFun :: FunDef2 -copyExprFun = FunDef "copyExpr" ["e700"] copyExprFunTy copyExprFunBod (FunMeta Rec NoInline False) +copyExprFun = FunDef "copyExpr" ["e700"] copyExprFunTy copyExprFunBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where copyExprFunTy :: ArrowTy2 copyExprFunTy = ArrowTy2 @@ -1226,7 +1227,7 @@ copyExprFun = FunDef "copyExpr" ["e700"] copyExprFunTy copyExprFunBod (FunMeta R substFun :: FunDef2 -substFun = FunDef "subst" ["tr653"] substFunTy substFunBod (FunMeta Rec NoInline False) +substFun = FunDef "subst" ["tr653"] substFunTy substFunBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where substFunTy :: ArrowTy2 substFunTy = ArrowTy2 @@ -1321,7 +1322,7 @@ ddtree' = fromListDD [DDef (toVar "Tree") [] -- indirection pointers to get to the rightmost node of the tree. indrBuildTreeFun :: FunDef2 -indrBuildTreeFun = FunDef "indrBuildTree" ["i270"] indrBuildTreeTy indrBuildTreeBod (FunMeta Rec NoInline False) +indrBuildTreeFun = FunDef "indrBuildTree" ["i270"] indrBuildTreeTy indrBuildTreeBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where indrBuildTreeTy :: ArrowTy2 indrBuildTreeTy = ArrowTy2 @@ -1367,7 +1368,7 @@ indrBuildTreeProg = Prog ddtree' (M.fromList [("indrBuildTree", indrBuildTreeFun indrRightmostFun :: FunDef2 -indrRightmostFun = FunDef "indrRightmost" ["t742"] indrRightmostTy indrRightmostBod (FunMeta Rec NoInline False) +indrRightmostFun = FunDef "indrRightmost" ["t742"] indrRightmostTy indrRightmostBod (FunMeta Rec NoInline False NoLayoutOpt Nothing) where indrRightmostTy :: ArrowTy2 indrRightmostTy = ArrowTy2 @@ -1403,7 +1404,7 @@ indrRightmostProg = Prog ddtree' (M.fromList [("indrRightmost", indrRightmostFun -------------------------------------------------------------------------------- indrIDFun :: FunDef2 -indrIDFun = FunDef "indrID" ["tr800"] indrIDTy indrIDBod (FunMeta NotRec NoInline False) +indrIDFun = FunDef "indrID" ["tr800"] indrIDTy indrIDBod (FunMeta NotRec NoInline False NoLayoutOpt Nothing) where indrIDTy :: ArrowTy2 indrIDTy = ArrowTy2 diff --git a/gibbon-compiler/src/Gibbon/L2/Syntax.hs b/gibbon-compiler/src/Gibbon/L2/Syntax.hs index 13d48b360..e841fd5da 100644 --- a/gibbon-compiler/src/Gibbon/L2/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/L2/Syntax.hs @@ -1,64 +1,100 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} - -{-# LANGUAGE DeriveAnyClass #-} - +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fdefer-typed-holes #-} --- | An intermediate language with an effect system that captures traversals. +-- | An intermediate language with an effect system that captures traversals. module Gibbon.L2.Syntax - ( -- * Extended language L2 with location types. - E2Ext(..) - , Prog2, DDefs2, DDef2, FunDef2, FunDefs2, Exp2, E2, Ty2 - , Effect(..), ArrowTy2(..) , LocRet(..), LocExp, PreLocExp(..) - - -- * Regions and locations - , LocVar, Region(..), Modality(..), LRM(..), dummyLRM - , Multiplicity(..), RegionSize(..), RegionType(..), regionToVar - - -- * Operations on types - , allLocVars, inLocVars, outLocVars, outRegVars, inRegVars, allRegVars, substLoc - , substLocs, substEff, substEffs, extendPatternMatchEnv - , locsInTy, dummyTyLocs, allFreeVars - - -- * Other helpers - , revertToL1, occurs, mapPacked, constPacked, depList, changeAppToSpawn - - , module Gibbon.Language - ) - where + ( E2Ext(..) + , Prog2 + , DDefs2 + , DDef2 + , FunDef2 + , FunDefs2 + , Exp2 + , E2 + , Ty2 + , Effect(..) + , ArrowTy2(..) + , LocRet(..) + , LocExp + , PreLocExp(..) + +-- * Regions and locations + , LocVar + , Region(..) + , Modality(..) + , LRM(..) + , dummyLRM + , Multiplicity(..) + , RegionSize(..) + , RegionType(..) + , regionToVar + +-- * Operations on types + , allLocVars + , inLocVars + , outLocVars + , outRegVars + , inRegVars + , allRegVars + , substLoc + , substLocs + , substEff + , substEffs + , extendPatternMatchEnv + , locsInTy + , dummyTyLocs + , allFreeVars + +-- * Other helpers + , revertToL1 + , occurs + , mapPacked + , constPacked + , depList + , changeAppToSpawn + , module Gibbon.Language + ) where import Control.DeepSeq -import qualified Data.List as L -import qualified Data.Set as S -import qualified Data.Map as M -import GHC.Stack (HasCallStack) +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S +import GHC.Stack (HasCallStack) import Text.PrettyPrint.GenericPretty import Gibbon.Common +import Gibbon.L1.Syntax hiding (AddFixed) import Gibbon.Language import Text.PrettyPrint.HughesPJ -import Gibbon.L1.Syntax hiding (AddFixed) + -------------------------------------------------------------------------------- +type Prog2 = Prog Exp2 + +type DDef2 = DDef Ty2 + +type DDefs2 = DDefs Ty2 + +type FunDef2 = FunDef Exp2 -type Prog2 = Prog Exp2 -type DDef2 = DDef Ty2 -type DDefs2 = DDefs Ty2 -type FunDef2 = FunDef Exp2 type FunDefs2 = FunDefs Exp2 + -- | Function types know about locations and traversal effects. -instance FunctionTy Ty2 where +instance FunctionTy Ty2 + where type ArrowTy Ty2 = ArrowTy2 - inTys = arrIns - outTy = arrOut + inTys = arrIns + outTy = arrOut + -- | Extended expressions, L2. -- @@ -66,62 +102,77 @@ instance FunctionTy Ty2 where -- applications, and bindings gain a location annotation. type Exp2 = E2 LocVar Ty2 + -- | L1 Types extended with abstract Locations. type Ty2 = UrTy LocVar + -------------------------------------------------------------------------------- -- | Shorthand for recursions. type E2 l d = PreExp E2Ext l d -data RegionSize = BoundedSize Int | Undefined +data RegionSize + = BoundedSize Int + | Undefined deriving (Eq, Read, Show, Generic, NFData, Out) -data RegionType = IndirectionFree | RightwardLocalIndirections | LocalIndirections | NoSharing + +data RegionType + = IndirectionFree + | RightwardLocalIndirections + | LocalIndirections + | NoSharing deriving (Eq, Ord, Read, Show, Generic, NFData, Out) -- | 'Undefined' is at the top of this lattice. -instance Ord RegionSize where +instance Ord RegionSize + where (<=) (BoundedSize sz1) (BoundedSize sz2) = sz1 <= sz2 - (<=) Undefined (BoundedSize{}) = False - (<=) (BoundedSize{}) Undefined = True - (<=) Undefined Undefined = True + (<=) Undefined (BoundedSize {}) = False + (<=) (BoundedSize {}) Undefined = True + (<=) Undefined Undefined = True -instance Semigroup RegionType where +instance Semigroup RegionType -- IndirectionFree < RightwardLocalIndirections < LocalIndirections < NoSharing - (<>) IndirectionFree v = v - (<>) v IndirectionFree = v - (<>) RightwardLocalIndirections v = v - (<>) v RightwardLocalIndirections = v - (<>) LocalIndirections v = v - (<>) v LocalIndirections = v - (<>) NoSharing v = v - -instance Semigroup RegionSize where + where + (<>) IndirectionFree v = v + (<>) v IndirectionFree = v + (<>) RightwardLocalIndirections v = v + (<>) v RightwardLocalIndirections = v + (<>) LocalIndirections v = v + (<>) v LocalIndirections = v + (<>) NoSharing v = v + +instance Semigroup RegionSize + where (<>) (BoundedSize sz1) (BoundedSize sz2) = BoundedSize (sz1 + sz2) - (<>) Undefined _ = Undefined - (<>) _ Undefined = Undefined + (<>) Undefined _ = Undefined + (<>) _ Undefined = Undefined -instance Monoid RegionSize where +instance Monoid RegionSize + where mempty = BoundedSize 0 -- | The extension that turns L1 into L2. data E2Ext loc dec - = LetRegionE Region RegionSize (Maybe RegionType) (E2 loc dec) -- ^ Allocate a new region. + = LetRegionE Region RegionSize (Maybe RegionType) (E2 loc dec) -- ^ Allocate a new region. | LetParRegionE Region RegionSize (Maybe RegionType) (E2 loc dec) -- ^ Allocate a new region for parallel allocations. - | LetLocE loc (PreLocExp loc) (E2 loc dec) -- ^ Bind a new location. - | RetE [loc] Var -- ^ Return a value together with extra loc values. - | FromEndE loc -- ^ Bind a location from an EndOf location (for RouteEnds and after). - | BoundsCheck Int -- Bytes required - loc -- Region - loc -- Write cursor + | LetLocE loc (PreLocExp loc) (E2 loc dec) -- ^ Bind a new location. + | RetE [loc] Var -- ^ Return a value together with extra loc values. + | FromEndE loc -- ^ Bind a location from an EndOf location (for RouteEnds and after). + | BoundsCheck + Int -- Bytes required + loc -- Region + loc -- Write cursor | AddFixed Var Int - | IndirectionE TyCon - DataCon - (loc,Var) -- Pointer - (loc,Var) -- Pointee (the thing that the pointer points to) - (E2 loc dec) -- If this indirection was added to get rid + | IndirectionE + TyCon + DataCon + (loc, Var) -- Pointer + (loc, Var) -- Pointee (the thing that the pointer points to) + (E2 loc dec) -- If this indirection was added to get rid -- of a copy_Foo call, we keep the fn call -- around in case we want to go back to it. -- E.g. reverting from L2 to L1. @@ -131,238 +182,252 @@ data E2Ext loc dec | LetAvail [Var] (E2 loc dec) -- ^ These variables are available to use before the join point deriving (Show, Ord, Eq, Read, Generic, NFData) + -- | Define a location in terms of a different location. -data PreLocExp loc = StartOfLE Region - | AfterConstantLE Int -- Number of bytes after. - loc -- Location which this location is offset from. - | AfterVariableLE Var -- Name of variable v. This loc is size(v) bytes after. - loc -- Location which this location is offset from. - Bool -- Whether it's running in a stolen continuation i.e +data PreLocExp loc + = StartOfLE Region + | AfterConstantLE + Int -- Number of bytes after. + loc -- Location which this location is offset from. + | AfterVariableLE + Var -- Name of variable v. This loc is size(v) bytes after. + loc -- Location which this location is offset from. + Bool -- Whether it's running in a stolen continuation i.e -- whether this should return an index in a fresh region or not. -- It's True by default and flipped by ParAlloc if required. - | InRegionLE Region - | FreeLE - | FromEndLE loc + | InRegionLE Region + | FreeLE + | FromEndLE loc deriving (Read, Show, Eq, Ord, Generic, NFData) type LocExp = PreLocExp LocVar --- | Locations (end-witnesses) returned from functions after RouteEnds. -data LocRet = EndOf LRM - deriving (Read, Show, Eq, Ord, Generic, NFData) +-- | Locations (end-witnesses) returned from functions after RouteEnds. +data LocRet = + EndOf LRM + deriving (Read, Show, Eq, Ord, Generic, NFData) -instance FreeVars (E2Ext l d) where +instance (Out l, Out d) => FreeVars (E2Ext l d) where gFreeVars e = case e of - LetRegionE _ _ _ bod -> gFreeVars bod - LetParRegionE _ _ _ bod -> gFreeVars bod - LetLocE _ rhs bod -> (case rhs of - AfterVariableLE v _loc _ -> S.singleton v - _ -> S.empty) - `S.union` - gFreeVars bod - RetE _ vr -> S.singleton vr - FromEndE _ -> S.empty - AddFixed vr _ -> S.singleton vr - BoundsCheck{} -> S.empty - IndirectionE{} -> S.empty - GetCilkWorkerNum -> S.empty - LetAvail vs bod -> S.fromList vs `S.union` gFreeVars bod - + LetRegionE _ _ _ bod -> gFreeVars bod + LetParRegionE _ _ _ bod -> gFreeVars bod + LetLocE _ rhs bod -> + (case rhs of + AfterVariableLE v _loc _ -> S.singleton v + _ -> S.empty) `S.union` + gFreeVars bod + RetE _ vr -> S.singleton vr + FromEndE _ -> S.empty + AddFixed vr _ -> S.singleton vr + BoundsCheck {} -> S.empty + IndirectionE {} -> S.empty + GetCilkWorkerNum -> S.empty + LetAvail vs bod -> S.fromList vs `S.union` gFreeVars bod instance FreeVars LocExp where gFreeVars e = case e of AfterConstantLE _ loc -> S.singleton loc - AfterVariableLE v loc _ -> S.fromList [v,loc] - _ -> S.empty + AfterVariableLE v loc _ -> S.fromList [v, loc] + _ -> S.empty -instance (Out l, Out d, Show l, Show d) => Expression (E2Ext l d) where +instance (Out l, Out d, Show l, Show d) => Expression (E2Ext l d) + where type LocOf (E2Ext l d) = l type TyOf (E2Ext l d) = d isTrivial e = case e of - LetRegionE{} -> False - LetParRegionE{} -> False - LetLocE{} -> False - RetE{} -> False -- Umm... this one could be potentially. - FromEndE{} -> True - AddFixed{} -> True - BoundsCheck{} -> False - IndirectionE{} -> False - GetCilkWorkerNum-> False - LetAvail{} -> False - -instance (Out l, Show l, Typeable (E2 l (UrTy l))) => Typeable (E2Ext l (UrTy l)) where + LetRegionE {} -> False + LetParRegionE {} -> False + LetLocE {} -> False + RetE {} -> False -- Umm... this one could be potentially. + FromEndE {} -> True + AddFixed {} -> True + BoundsCheck {} -> False + IndirectionE {} -> False + GetCilkWorkerNum -> False + LetAvail {} -> False + +instance (Out l, Show l, Typeable (E2 l (UrTy l))) => + Typeable (E2Ext l (UrTy l)) where gRecoverType ddfs env2 ex = case ex of - LetRegionE _r _ _ bod -> gRecoverType ddfs env2 bod - LetParRegionE _r _ _ bod -> gRecoverType ddfs env2 bod + LetRegionE _r _ _ bod -> gRecoverType ddfs env2 bod + LetParRegionE _r _ _ bod -> gRecoverType ddfs env2 bod LetLocE _l _rhs bod -> gRecoverType ddfs env2 bod - RetE _loc var -> case M.lookup var (vEnv env2) of - Just ty -> ty - Nothing -> error $ "gRecoverType: unbound variable " ++ sdoc var - FromEndE _loc -> error "Shouldn't enconter FromEndE in tail position" - BoundsCheck{} -> error "Shouldn't enconter BoundsCheck in tail position" - IndirectionE tycon _ _ (to,_) _ -> PackedTy tycon to - AddFixed{} -> error "Shouldn't enconter AddFixed in tail position" - GetCilkWorkerNum -> IntTy + RetE _loc var -> + case M.lookup var (vEnv env2) of + Just ty -> ty + Nothing -> error $ "gRecoverType: unbound variable " ++ sdoc var + FromEndE _loc -> error "Shouldn't enconter FromEndE in tail position" + BoundsCheck {} -> error "Shouldn't enconter BoundsCheck in tail position" + IndirectionE tycon _ _ (to, _) _ -> PackedTy tycon to + AddFixed {} -> error "Shouldn't enconter AddFixed in tail position" + GetCilkWorkerNum -> IntTy LetAvail _ bod -> gRecoverType ddfs env2 bod - -instance (Typeable (E2Ext l (UrTy l)), - Expression (E2Ext l (UrTy l)), - Flattenable (E2 l (UrTy l))) - => Flattenable (E2Ext l (UrTy l)) where - +instance ( Typeable (E2Ext l (UrTy l)) + , Expression (E2Ext l (UrTy l)) + , Flattenable (E2 l (UrTy l)) + ) => + Flattenable (E2Ext l (UrTy l)) where gFlattenGatherBinds ddfs env ex = - case ex of - LetRegionE r sz ty bod -> do - (bnds,bod') <- go bod - return ([], LetRegionE r sz ty (flatLets bnds bod')) - - LetParRegionE r sz ty bod -> do - (bnds,bod') <- go bod - return ([], LetParRegionE r sz ty (flatLets bnds bod')) - - LetLocE l rhs bod -> do (bnds,bod') <- go bod - return ([], LetLocE l rhs $ flatLets bnds bod') - - RetE{} -> return ([],ex) - FromEndE{} -> return ([],ex) - AddFixed{} -> return ([],ex) - BoundsCheck{} -> return ([],ex) - IndirectionE{}-> return ([],ex) - GetCilkWorkerNum-> return ([],ex) - LetAvail vs bod -> do (bnds,bod') <- go bod - return ([], LetAvail vs $ flatLets bnds bod') - - where go = gFlattenGatherBinds ddfs env - - gFlattenExp ddfs env ex = do (_b,e') <- gFlattenGatherBinds ddfs env ex - return e' + case ex of + LetRegionE r sz ty bod -> do + (bnds, bod') <- go bod + return ([], LetRegionE r sz ty (flatLets bnds bod')) + LetParRegionE r sz ty bod -> do + (bnds, bod') <- go bod + return ([], LetParRegionE r sz ty (flatLets bnds bod')) + LetLocE l rhs bod -> do + (bnds, bod') <- go bod + return ([], LetLocE l rhs $ flatLets bnds bod') + RetE {} -> return ([], ex) + FromEndE {} -> return ([], ex) + AddFixed {} -> return ([], ex) + BoundsCheck {} -> return ([], ex) + IndirectionE {} -> return ([], ex) + GetCilkWorkerNum -> return ([], ex) + LetAvail vs bod -> do + (bnds, bod') <- go bod + return ([], LetAvail vs $ flatLets bnds bod') + where + go = gFlattenGatherBinds ddfs env + gFlattenExp ddfs env ex = do + (_b, e') <- gFlattenGatherBinds ddfs env ex + return e' -instance HasSimplifiableExt E2Ext l d => SimplifiableExt (PreExp E2Ext l d) (E2Ext l d) where +instance HasSimplifiableExt E2Ext l d => + SimplifiableExt (PreExp E2Ext l d) (E2Ext l d) where gInlineTrivExt env ext = case ext of - LetRegionE r sz ty bod -> LetRegionE r sz ty (gInlineTrivExp env bod) - LetParRegionE r sz ty bod -> LetParRegionE r sz ty (gInlineTrivExp env bod) + LetRegionE r sz ty bod -> LetRegionE r sz ty (gInlineTrivExp env bod) + LetParRegionE r sz ty bod -> + LetParRegionE r sz ty (gInlineTrivExp env bod) LetLocE loc le bod -> LetLocE loc le (gInlineTrivExp env bod) - RetE{} -> ext - FromEndE{} -> ext - BoundsCheck{} -> ext - IndirectionE{} -> ext - AddFixed{} -> ext - GetCilkWorkerNum-> ext + RetE {} -> ext + FromEndE {} -> ext + BoundsCheck {} -> ext + IndirectionE {} -> ext + AddFixed {} -> ext + GetCilkWorkerNum -> ext LetAvail vs bod -> LetAvail vs (gInlineTrivExp env bod) - -instance HasSubstitutableExt E2Ext l d => SubstitutableExt (PreExp E2Ext l d) (E2Ext l d) where +instance HasSubstitutableExt E2Ext l d => + SubstitutableExt (PreExp E2Ext l d) (E2Ext l d) where gSubstExt old new ext = case ext of - LetRegionE r sz ty bod -> LetRegionE r sz ty (gSubst old new bod) + LetRegionE r sz ty bod -> LetRegionE r sz ty (gSubst old new bod) LetParRegionE r sz ty bod -> LetParRegionE r sz ty (gSubst old new bod) - LetLocE l le bod -> LetLocE l le (gSubst old new bod) - RetE{} -> ext - FromEndE{} -> ext - BoundsCheck{} -> ext - IndirectionE{} -> ext - AddFixed{} -> ext - GetCilkWorkerNum -> ext - LetAvail vs bod -> LetAvail vs (gSubst old new bod) - + LetLocE l le bod -> LetLocE l le (gSubst old new bod) + RetE {} -> ext + FromEndE {} -> ext + BoundsCheck {} -> ext + IndirectionE {} -> ext + AddFixed {} -> ext + GetCilkWorkerNum -> ext + LetAvail vs bod -> LetAvail vs (gSubst old new bod) gSubstEExt old new ext = case ext of - LetRegionE r sz ty bod -> LetRegionE r sz ty (gSubstE old new bod) + LetRegionE r sz ty bod -> LetRegionE r sz ty (gSubstE old new bod) LetParRegionE r sz ty bod -> LetParRegionE r sz ty (gSubstE old new bod) - LetLocE l le bod -> LetLocE l le (gSubstE old new bod) - RetE{} -> ext - FromEndE{} -> ext - BoundsCheck{} -> ext - IndirectionE{} -> ext - AddFixed{} -> ext - GetCilkWorkerNum -> ext - LetAvail vs bod -> LetAvail vs (gSubstE old new bod) + LetLocE l le bod -> LetLocE l le (gSubstE old new bod) + RetE {} -> ext + FromEndE {} -> ext + BoundsCheck {} -> ext + IndirectionE {} -> ext + AddFixed {} -> ext + GetCilkWorkerNum -> ext + LetAvail vs bod -> LetAvail vs (gSubstE old new bod) instance HasRenamable E2Ext l d => Renamable (E2Ext l d) where gRename env ext = case ext of - LetRegionE r sz ty bod -> LetRegionE r sz ty (gRename env bod) + LetRegionE r sz ty bod -> LetRegionE r sz ty (gRename env bod) LetParRegionE r sz ty bod -> LetParRegionE r sz ty (gRename env bod) - LetLocE l le bod -> LetLocE l le (gRename env bod) - RetE{} -> ext - FromEndE{} -> ext - BoundsCheck{} -> ext - IndirectionE{} -> ext - AddFixed{} -> ext - GetCilkWorkerNum -> ext - LetAvail vs bod -> LetAvail vs (gRename env bod) + LetLocE l le bod -> LetLocE l le (gRename env bod) + RetE {} -> ext + FromEndE {} -> ext + BoundsCheck {} -> ext + IndirectionE {} -> ext + AddFixed {} -> ext + GetCilkWorkerNum -> ext + LetAvail vs bod -> LetAvail vs (gRename env bod) + -- | Our type for functions grows to include effects, and explicit universal -- quantification over location/region variables. -data ArrowTy2 = ArrowTy2 - { locVars :: [LRM] -- ^ Universally-quantified location params. +data ArrowTy2 = + ArrowTy2 + { locVars :: [LRM] -- ^ Universally-quantified location params. -- Only these should be referenced in arrIn/arrOut. - , arrIns :: [Ty2] -- ^ Input type for the function. - , arrEffs :: (S.Set Effect) -- ^ These are present-but-empty initially, + , arrIns :: [Ty2] -- ^ Input type for the function. + , arrEffs :: (S.Set Effect) -- ^ These are present-but-empty initially, -- and the populated by InferEffects. - , arrOut :: Ty2 -- ^ Output type for the function. - , locRets :: [LocRet] -- ^ L2B feature: multi-valued returns. - , hasParallelism :: Bool -- ^ Does this function have parallelism + , arrOut :: Ty2 -- ^ Output type for the function. + , locRets :: [LocRet] -- ^ L2B feature: multi-valued returns. + , hasParallelism :: Bool -- ^ Does this function have parallelism } - deriving (Read,Show,Eq,Ord, Generic, NFData) + deriving (Read, Show, Eq, Ord, Generic, NFData) + -- | The side-effect of evaluating a function. -data Effect = Traverse LocVar +data Effect = + Traverse LocVar -- ^ The function, during its execution, traverses all -- of the value living at this location. - deriving (Read,Show,Eq,Ord, Generic, NFData) + deriving (Read, Show, Eq, Ord, Generic, NFData) + -------------------------------------------------------------------------------- -- -- See https://github.com/iu-parfunc/gibbon/issues/79 for more details -- | Region variants (multiplicities) data Multiplicity - = Bounded Int -- ^ Contain a finite number of values and can be + = Bounded Int -- ^ Contain a finite number of values and can be -- stack-allocated. - - | Infinite -- ^ Consist of a linked list of buffers, spread + | Infinite -- ^ Consist of a linked list of buffers, spread -- throughout memory (though possible constrained -- to 4GB regions). Writing into these regions requires -- bounds-checking. The buffers can start very small -- at the head of the list, but probably grow -- geometrically in size, making the cost of traversing -- all of them logarithmic. - - | BigInfinite -- ^ These regions are infinite, but also have the + | BigInfinite -- ^ These regions are infinite, but also have the -- expectation of containing many values. Thus we give -- them large initial page sizes. This is also could be -- the appropriate place to use mmap to grow the region -- and to establish guard places. - deriving (Read,Show,Eq,Ord,Generic) + deriving (Read, Show, Eq, Ord, Generic) -instance Out Multiplicity where +instance Out Multiplicity + where doc = text . show -instance NFData Multiplicity where +instance NFData Multiplicity + where rnf _ = () + -- | An abstract region identifier. This is used inside type signatures and elsewhere. -data Region = GlobR Var Multiplicity -- ^ A global region with lifetime equal to the +data Region + = GlobR Var Multiplicity -- ^ A global region with lifetime equal to the -- whole program. - | DynR Var Multiplicity -- ^ A dynamic region that may be created or + | DynR Var Multiplicity -- ^ A dynamic region that may be created or -- destroyed, tagged by an identifier. - | VarR Var -- ^ A region metavariable that can range over + | VarR Var -- ^ A region metavariable that can range over -- either global or dynamic regions. - | MMapR Var -- ^ A region that doesn't result in an (explicit) + | MMapR Var -- ^ A region that doesn't result in an (explicit) -- memory allocation. It merely ensures that there -- are no free locations in the program. - deriving (Read,Show,Eq,Ord, Generic) + deriving (Read, Show, Eq, Ord, Generic) instance Out Region -instance NFData Region where +instance NFData Region + where rnf (GlobR v _) = rnf v rnf (DynR v _) = rnf v rnf (VarR v) = rnf v @@ -371,34 +436,46 @@ instance NFData Region where -- | The modality of locations and cursors: input/output, for reading -- and writing, respectively. -data Modality = Input | Output - deriving (Read,Show,Eq,Ord, Generic) +data Modality + = Input + | Output + deriving (Read, Show, Eq, Ord, Generic) + instance Out Modality -instance NFData Modality where + +instance NFData Modality + where rnf Input = () rnf Output = () + -- | A location and region, together with modality. -data LRM = LRM { lrmLoc :: LocVar - , lrmReg :: Region - , lrmMode :: Modality } - deriving (Read,Show,Eq,Ord, Generic) +data LRM = + LRM + { lrmLoc :: LocVar + , lrmReg :: Region + , lrmMode :: Modality + } + deriving (Read, Show, Eq, Ord, Generic) instance Out LRM -instance NFData LRM where - rnf (LRM a b c) = rnf a `seq` rnf b `seq` rnf c +instance NFData LRM + where + rnf (LRM a b c) = rnf a `seq` rnf b `seq` rnf c + -- | A designated doesn't-really-exist-anywhere location. dummyLRM :: LRM dummyLRM = LRM "l_dummy" (VarR "r_dummy") Input regionToVar :: Region -> Var -regionToVar r = case r of - GlobR v _ -> v - DynR v _ -> v - VarR v -> v - MMapR v -> v +regionToVar r = + case r of + GlobR v _ -> v + DynR v _ -> v + VarR v -> v + MMapR v -> v -- | The 'gRecoverType' instance defined in Language.Syntax is incorrect for L2. @@ -417,56 +494,73 @@ regionToVar r = case r of instance Typeable (PreExp E2Ext LocVar (UrTy LocVar)) where gRecoverType ddfs env2 ex = case ex of - VarE v -> M.findWithDefault (error $ "Cannot find type of variable " ++ show v ++ " in " ++ show (vEnv env2)) v (vEnv env2) - LitE _ -> IntTy - CharE{} -> CharTy - FloatE{} -> FloatTy - LitSymE _ -> SymTy - AppE v locs _ -> let fnty = fEnv env2 # v - outty = arrOut fnty - mp = M.fromList $ zip (allLocVars fnty) locs - in substLoc mp outty - - PrimAppE (DictInsertP ty) ((VarE v):_) -> SymDictTy (Just v) $ stripTyLocs ty - PrimAppE (DictEmptyP ty) ((VarE v):_) -> SymDictTy (Just v) $ stripTyLocs ty + VarE v -> + M.findWithDefault + (error $ + "Cannot find type of variable " ++ + show v ++ " in " ++ show (vEnv env2)) + v + (vEnv env2) + LitE _ -> IntTy + CharE {} -> CharTy + FloatE {} -> FloatTy + LitSymE _ -> SymTy + AppE v locs _ -> + let fnty = fEnv env2 # v + outty = arrOut fnty + mp = M.fromList $ zip (allLocVars fnty) locs + in substLoc mp outty + PrimAppE (DictInsertP ty) ((VarE v):_) -> + SymDictTy (Just v) $ stripTyLocs ty + PrimAppE (DictEmptyP ty) ((VarE v):_) -> + SymDictTy (Just v) $ stripTyLocs ty PrimAppE p _ -> primRetTy p - - LetE (v,_,t,_) e -> gRecoverType ddfs (extendVEnv v t env2) e - IfE _ e _ -> gRecoverType ddfs env2 e - MkProdE es -> ProdTy $ L.map (gRecoverType ddfs env2) es + LetE (v, _, t, _) e -> gRecoverType ddfs (extendVEnv v t env2) e + IfE _ e _ -> gRecoverType ddfs env2 e + MkProdE es -> ProdTy $ L.map (gRecoverType ddfs env2) es DataConE loc c _ -> PackedTy (getTyOfDataCon ddfs c) loc - TimeIt e _ _ -> gRecoverType ddfs env2 e - MapE _ e -> gRecoverType ddfs env2 e - FoldE _ _ e -> gRecoverType ddfs env2 e - Ext ext -> gRecoverType ddfs env2 ext + TimeIt e _ _ -> gRecoverType ddfs env2 e + MapE _ e -> gRecoverType ddfs env2 e + FoldE _ _ e -> gRecoverType ddfs env2 e + Ext ext -> gRecoverType ddfs env2 ext ProjE i e -> case gRecoverType ddfs env2 e of (ProdTy tys) -> tys !! i - oth -> error$ "typeExp: Cannot project fields from this type: "++show oth - ++"\nExpression:\n "++ sdoc ex - ++"\nEnvironment:\n "++sdoc (vEnv env2) - SpawnE v locs _ -> let fnty = fEnv env2 # v - outty = arrOut fnty - mp = M.fromList $ zip (allLocVars fnty) locs - in substLoc mp outty + oth -> + error $ + "typeExp: Cannot project fields from this type: " ++ + show oth ++ + "\nExpression:\n " ++ + sdoc ex ++ "\nEnvironment:\n " ++ sdoc (vEnv env2) + SpawnE v locs _ -> + let fnty = fEnv env2 # v + outty = arrOut fnty + mp = M.fromList $ zip (allLocVars fnty) locs + in substLoc mp outty SyncE -> voidTy WithArenaE _v e -> gRecoverType ddfs env2 e CaseE _ mp -> - let (c,vlocs,e) = head mp - (vars,locs) = unzip vlocs + let (c, vlocs, e) = head mp + (vars, locs) = unzip vlocs env2' = extendPatternMatchEnv c ddfs vars locs env2 - in gRecoverType ddfs env2' e + in gRecoverType ddfs env2' e + -------------------------------------------------------------------------------- -- Do this manually to get prettier formatting: (Issue #90) - instance Out ArrowTy2 + instance Out Effect -instance Out a => Out (S.Set a) where + +instance Out a => Out (S.Set a) + where docPrec n x = docPrec n (S.toList x) - doc x = doc (S.toList x) + doc x = doc (S.toList x) + instance (Out l, Out d) => Out (E2Ext l d) + instance Out l => Out (PreLocExp l) + instance Out LocRet ------------------------------------------------------------------------------- @@ -475,43 +569,50 @@ instance Out LocRet allLocVars :: ArrowTy2 -> [LocVar] allLocVars ty = L.map (\(LRM l _ _) -> l) (locVars ty) - inLocVars :: ArrowTy2 -> [LocVar] -inLocVars ty = L.map (\(LRM l _ _) -> l) $ - L.filter (\(LRM _ _ m) -> m == Input) (locVars ty) +inLocVars ty = + L.map (\(LRM l _ _) -> l) $ L.filter (\(LRM _ _ m) -> m == Input) (locVars ty) outLocVars :: ArrowTy2 -> [LocVar] -outLocVars ty = L.map (\(LRM l _ _) -> l) $ - L.filter (\(LRM _ _ m) -> m == Output) (locVars ty) +outLocVars ty = + L.map (\(LRM l _ _) -> l) $ + L.filter (\(LRM _ _ m) -> m == Output) (locVars ty) outRegVars :: ArrowTy2 -> [LocVar] -outRegVars ty = L.map (\(LRM _ r _) -> regionToVar r) $ - L.filter (\(LRM _ _ m) -> m == Output) (locVars ty) +outRegVars ty = + L.map (\(LRM _ r _) -> regionToVar r) $ + L.filter (\(LRM _ _ m) -> m == Output) (locVars ty) inRegVars :: ArrowTy2 -> [LocVar] -inRegVars ty = L.nub $ L.map (\(LRM _ r _) -> regionToVar r) $ - L.filter (\(LRM _ _ m) -> m == Input) (locVars ty) +inRegVars ty = + L.nub $ + L.map (\(LRM _ r _) -> regionToVar r) $ + L.filter (\(LRM _ _ m) -> m == Input) (locVars ty) allRegVars :: ArrowTy2 -> [LocVar] allRegVars ty = L.nub $ L.map (\(LRM _ r _) -> regionToVar r) (locVars ty) + -- | Apply a location substitution to a type. substLoc :: M.Map LocVar LocVar -> Ty2 -> Ty2 substLoc mp ty = case ty of - SymDictTy v te -> SymDictTy v te -- (go te) - ProdTy ts -> ProdTy (L.map go ts) - PackedTy k l -> - case M.lookup l mp of - Just v -> PackedTy k v - Nothing -> PackedTy k l - _ -> ty - where go = substLoc mp + SymDictTy v te -> SymDictTy v te -- (go te) + ProdTy ts -> ProdTy (L.map go ts) + PackedTy k l -> + case M.lookup l mp of + Just v -> PackedTy k v + Nothing -> PackedTy k l + _ -> ty + where + go = substLoc mp + -- | List version of 'substLoc'. substLocs :: M.Map LocVar LocVar -> [Ty2] -> [Ty2] substLocs mp tys = L.map (substLoc mp) tys + -- | Extend an environment for a pattern match. E.g. -- -- data Foo = MkFoo Int Foo | ... @@ -519,89 +620,110 @@ substLocs mp tys = L.map (substLoc mp) tys -- case foo1 of -- MkFoo (i:loc1) (f:loc2) -> -- new_env2 = extendPatternMatchEnv [loc1,loc2] old_env2 -extendPatternMatchEnv :: HasCallStack => DataCon -> DDefs Ty2 -> [Var] -> [LocVar] - -> Env2 Ty2 -> Env2 Ty2 +extendPatternMatchEnv :: + HasCallStack + => DataCon + -> DDefs Ty2 + -> [Var] + -> [LocVar] + -> Env2 Ty2 + -> Env2 Ty2 extendPatternMatchEnv dcon ddefs vars locs env2 = - let tys = lookupDataCon ddefs dcon - tys' = foldr - (\(loc,ty) acc -> - case locsInTy ty of - [] -> ty:acc - [loc2] -> (substLoc (M.singleton loc2 loc) ty) : acc - _ -> error $ "extendPatternMatchEnv': Found more than 1 location in type: " ++ sdoc ty) - [] - (fragileZip locs tys) - in extendsVEnv (M.fromList $ fragileZip vars tys') env2 + let tys = lookupDataCon ddefs dcon + tys' = + foldr + (\(loc, ty) acc -> + case locsInTy ty of + [] -> ty : acc + [loc2] -> (substLoc (M.singleton loc2 loc) ty) : acc + _ -> + error $ + "extendPatternMatchEnv': Found more than 1 location in type: " ++ + sdoc ty) + [] + (fragileZip locs tys) + in extendsVEnv (M.fromList $ fragileZip vars tys') env2 + -- | Apply a substitution to an effect. substEff :: M.Map LocVar LocVar -> Effect -> Effect substEff mp (Traverse v) = - case M.lookup v mp of - Just v2 -> Traverse v2 - Nothing -> Traverse v + case M.lookup v mp of + Just v2 -> Traverse v2 + Nothing -> Traverse v + -- | Apply a substitution to an effect set. substEffs :: M.Map LocVar LocVar -> S.Set Effect -> S.Set Effect -substEffs mp effs = - S.map (\ef -> substEff mp ef) effs +substEffs mp effs = S.map (\ef -> substEff mp ef) effs dummyTyLocs :: Applicative f => UrTy () -> f (UrTy LocVar) dummyTyLocs ty = traverse (const (pure (toVar "dummy"))) ty + -- | Collect all the locations mentioned in a type. locsInTy :: Ty2 -> [LocVar] locsInTy ty = - case ty of - PackedTy _ lv -> [lv] - ProdTy tys -> concatMap locsInTy tys - _ -> [] + case ty of + PackedTy _ lv -> [lv] + ProdTy tys -> concatMap locsInTy tys + _ -> [] + -- Because L2 just adds a bit of metadata and enriched types, it is -- possible to strip it back down to L1. revertToL1 :: Prog2 -> Prog1 -revertToL1 Prog{ddefs,fundefs,mainExp} = - Prog ddefs' funefs' mainExp' +revertToL1 Prog {ddefs, fundefs, mainExp} = Prog ddefs' funefs' mainExp' where - ddefs' = M.map revertDDef ddefs - funefs' = M.map revertFunDef fundefs - mainExp' = case mainExp of - Nothing -> Nothing - Just (e,ty) -> Just (revertExp e, stripTyLocs ty) + ddefs' = M.map revertDDef ddefs + funefs' = M.map revertFunDef fundefs + mainExp' = + case mainExp of + Nothing -> Nothing + Just (e, ty) -> Just (revertExp e, stripTyLocs ty) revertDDef :: DDef Ty2 -> DDef Ty1 revertDDef (DDef tyargs a b) = - DDef tyargs a - (L.filter (\(dcon,_) -> not $ isIndirectionTag dcon) $ - L.map (\(dcon,tys) -> (dcon, L.map (\(x,y) -> (x, stripTyLocs y)) tys)) b) + DDef + tyargs + a + (L.filter (\(dcon, _) -> not $ isIndirectionTag dcon) $ + L.map (\(dcon, tys) -> (dcon, L.map (\(x, y) -> (x, stripTyLocs y)) tys)) b) revertFunDef :: FunDef2 -> FunDef1 -revertFunDef FunDef{funName,funArgs,funTy,funBody,funMeta} = - FunDef { funName = funName - , funArgs = funArgs - , funTy = (L.map stripTyLocs (arrIns funTy), stripTyLocs (arrOut funTy)) - , funBody = revertExp funBody - , funMeta = funMeta - } +revertFunDef FunDef {funName, funArgs, funTy, funBody, funMeta} = + FunDef + { funName = funName + , funArgs = funArgs + , funTy = (L.map stripTyLocs (arrIns funTy), stripTyLocs (arrOut funTy)) + , funBody = revertExp funBody + , funMeta = funMeta + } revertExp :: Exp2 -> Exp1 revertExp ex = case ex of - VarE v -> VarE v - LitE n -> LitE n - CharE c -> CharE c - FloatE n -> FloatE n + VarE v -> VarE v + LitE n -> LitE n + CharE c -> CharE c + FloatE n -> FloatE n LitSymE v -> LitSymE v - AppE v _ args -> AppE v [] (L.map revertExp args) + AppE v _ args -> AppE v [] (L.map revertExp args) PrimAppE p args -> PrimAppE (revertPrim p) $ L.map revertExp args - LetE (v,_,ty, (Ext (IndirectionE _ _ _ _ arg))) bod -> - let PackedTy tycon _ = ty in - LetE (v,[],(stripTyLocs ty), AppE (mkCopyFunName tycon) [] [revertExp arg]) (revertExp bod) - LetE (v,_,ty,rhs) bod -> - LetE (v,[], stripTyLocs ty, revertExp rhs) (revertExp bod) - IfE a b c -> IfE (revertExp a) (revertExp b) (revertExp c) + LetE (v, _, ty, (Ext (IndirectionE _ _ _ _ arg))) bod -> + let PackedTy tycon _ = ty + in LetE + ( v + , [] + , (stripTyLocs ty) + , AppE (mkCopyFunName tycon) [] [revertExp arg]) + (revertExp bod) + LetE (v, _, ty, rhs) bod -> + LetE (v, [], stripTyLocs ty, revertExp rhs) (revertExp bod) + IfE a b c -> IfE (revertExp a) (revertExp b) (revertExp c) MkProdE ls -> MkProdE $ L.map revertExp ls - ProjE i e -> ProjE i (revertExp e) - CaseE scrt brs -> CaseE (revertExp scrt) (L.map docase brs) + ProjE i e -> ProjE i (revertExp e) + CaseE scrt brs -> CaseE (revertExp scrt) (L.map docase brs) DataConE _ dcon ls -> DataConE () dcon $ L.map revertExp ls TimeIt e ty b -> TimeIt (revertExp e) (stripTyLocs ty) b SpawnE v _ args -> SpawnE v [] (L.map revertExp args) @@ -609,28 +731,30 @@ revertExp ex = WithArenaE v e -> WithArenaE v (revertExp e) Ext ext -> case ext of - LetRegionE _ _ _ bod -> revertExp bod + LetRegionE _ _ _ bod -> revertExp bod LetParRegionE _ _ _ bod -> revertExp bod - LetLocE _ _ bod -> revertExp bod - RetE _ v -> VarE v - AddFixed{} -> error "revertExp: AddFixed not handled." - FromEndE{} -> error "revertExp: TODO FromEndLE" - BoundsCheck{} -> error "revertExp: TODO BoundsCheck" - IndirectionE{} -> error "revertExp: TODO IndirectionE" - GetCilkWorkerNum-> LitE 0 - LetAvail _ bod -> revertExp bod - MapE{} -> error $ "revertExp: TODO MapE" - FoldE{} -> error $ "revertExp: TODO FoldE" + LetLocE _ _ bod -> revertExp bod + RetE _ v -> VarE v + AddFixed {} -> error "revertExp: AddFixed not handled." + FromEndE {} -> error "revertExp: TODO FromEndLE" + BoundsCheck {} -> error "revertExp: TODO BoundsCheck" + IndirectionE {} -> error "revertExp: TODO IndirectionE" + GetCilkWorkerNum -> LitE 0 + LetAvail _ bod -> revertExp bod + MapE {} -> error $ "revertExp: TODO MapE" + FoldE {} -> error $ "revertExp: TODO FoldE" + -- Ugh .. this is bad. Can we remove the identity cases here ? -- TODO: Get rid of this (and L3.toL3Prim) soon. revertPrim :: Prim Ty2 -> Prim Ty1 revertPrim pr = fmap stripTyLocs pr -docase :: (DataCon, [(Var,LocVar)], Exp2) -> (DataCon, [(Var,())], Exp1) -docase (dcon,vlocs,rhs) = - let (vars,_) = unzip vlocs - in (dcon, zip vars (repeat ()), revertExp rhs) +docase :: (DataCon, [(Var, LocVar)], Exp2) -> (DataCon, [(Var, ())], Exp1) +docase (dcon, vlocs, rhs) = + let (vars, _) = unzip vlocs + in (dcon, zip vars (repeat ()), revertExp rhs) + -- | Does a variable occur in an expression ? -- @@ -639,90 +763,90 @@ occurs :: S.Set Var -> Exp2 -> Bool occurs w ex = case ex of VarE v -> v `S.member` w - LitE{} -> False - CharE{} -> False - FloatE{} -> False - LitSymE{} -> False - AppE _ _ ls -> any go ls + LitE {} -> False + CharE {} -> False + FloatE {} -> False + LitSymE {} -> False + AppE _ _ ls -> any go ls PrimAppE _ ls -> any go ls - LetE (_,_,_,rhs) bod -> go rhs || go bod - IfE a b c -> go a || go b || go c - MkProdE ls -> any go ls - ProjE _ e -> go e - CaseE e brs -> go e || any (\(_,_,bod) -> go bod) brs - DataConE _ _ ls -> any go ls - TimeIt e _ _ -> go e - SpawnE _ _ ls -> any go ls - SyncE -> False + LetE (_, _, _, rhs) bod -> go rhs || go bod + IfE a b c -> go a || go b || go c + MkProdE ls -> any go ls + ProjE _ e -> go e + CaseE e brs -> go e || any (\(_, _, bod) -> go bod) brs + DataConE _ _ ls -> any go ls + TimeIt e _ _ -> go e + SpawnE _ _ ls -> any go ls + SyncE -> False WithArenaE v rhs -> v `S.member` w || go rhs Ext ext -> case ext of - LetRegionE _ _ _ bod -> go bod - LetParRegionE _ _ _ bod -> go bod - LetLocE _ le bod -> - let oc_bod = go bod in - case le of - AfterVariableLE v _ _ -> v `S.member` w || oc_bod - StartOfLE{} -> oc_bod - AfterConstantLE{} -> oc_bod - InRegionLE{} -> oc_bod - FreeLE{} -> oc_bod - FromEndLE{} -> oc_bod - RetE _ v -> v `S.member` w - FromEndE{} -> False - BoundsCheck{} -> False - AddFixed v _ -> v `S.member` w - IndirectionE _ _ (_,v1) (_,v2) ib -> - v1 `S.member` w || v2 `S.member` w || go ib + LetRegionE _ _ _ bod -> go bod + LetParRegionE _ _ _ bod -> go bod + LetLocE _ le bod -> + let oc_bod = go bod + in case le of + AfterVariableLE v _ _ -> v `S.member` w || oc_bod + StartOfLE {} -> oc_bod + AfterConstantLE {} -> oc_bod + InRegionLE {} -> oc_bod + FreeLE {} -> oc_bod + FromEndLE {} -> oc_bod + RetE _ v -> v `S.member` w + FromEndE {} -> False + BoundsCheck {} -> False + AddFixed v _ -> v `S.member` w + IndirectionE _ _ (_, v1) (_, v2) ib -> + v1 `S.member` w || v2 `S.member` w || go ib GetCilkWorkerNum -> False LetAvail _ bod -> go bod - MapE{} -> error "occurs: TODO MapE" - FoldE{} -> error "occurs: TODO FoldE" + MapE {} -> error "occurs: TODO MapE" + FoldE {} -> error "occurs: TODO FoldE" where go = occurs w - mapPacked :: (Var -> l -> UrTy l) -> UrTy l -> UrTy l mapPacked fn t = case t of - IntTy -> IntTy - CharTy -> CharTy - FloatTy-> FloatTy - BoolTy -> BoolTy - SymTy -> SymTy - (ProdTy x) -> ProdTy $ L.map (mapPacked fn) x + IntTy -> IntTy + CharTy -> CharTy + FloatTy -> FloatTy + BoolTy -> BoolTy + SymTy -> SymTy + (ProdTy x) -> ProdTy $ L.map (mapPacked fn) x (SymDictTy v x) -> SymDictTy v x - PDictTy k v -> PDictTy k v - PackedTy k l -> fn (toVar k) l - PtrTy -> PtrTy - CursorTy -> CursorTy - ArenaTy -> ArenaTy - VectorTy elty -> VectorTy elty - ListTy elty -> ListTy elty - SymSetTy -> SymSetTy - SymHashTy-> SymHashTy - IntHashTy-> IntHashTy + PDictTy k v -> PDictTy k v + PackedTy k l -> fn (toVar k) l + PtrTy -> PtrTy + CursorTy -> CursorTy + ArenaTy -> ArenaTy + VectorTy elty -> VectorTy elty + ListTy elty -> ListTy elty + SymSetTy -> SymSetTy + SymHashTy -> SymHashTy + IntHashTy -> IntHashTy constPacked :: UrTy a1 -> UrTy a2 -> UrTy a1 constPacked c t = case t of - IntTy -> IntTy - CharTy -> CharTy - FloatTy-> FloatTy - BoolTy -> BoolTy - SymTy -> SymTy - (ProdTy x) -> ProdTy $ L.map (constPacked c) x + IntTy -> IntTy + CharTy -> CharTy + FloatTy -> FloatTy + BoolTy -> BoolTy + SymTy -> SymTy + (ProdTy x) -> ProdTy $ L.map (constPacked c) x (SymDictTy v _x) -> SymDictTy v $ stripTyLocs c - PDictTy k v -> PDictTy (constPacked c k) (constPacked c v) - PackedTy _k _l -> c - PtrTy -> PtrTy - CursorTy -> CursorTy - ArenaTy -> ArenaTy - VectorTy el_ty -> VectorTy (constPacked c el_ty) - ListTy el_ty -> ListTy (constPacked c el_ty) - SymSetTy -> SymSetTy - SymHashTy-> SymHashTy - IntHashTy-> IntHashTy + PDictTy k v -> PDictTy (constPacked c k) (constPacked c v) + PackedTy _k _l -> c + PtrTy -> PtrTy + CursorTy -> CursorTy + ArenaTy -> ArenaTy + VectorTy el_ty -> VectorTy (constPacked c el_ty) + ListTy el_ty -> ListTy (constPacked c el_ty) + SymSetTy -> SymSetTy + SymHashTy -> SymHashTy + IntHashTy -> IntHashTy + -- | Build a dependency list which can be later converted to a graph depList :: Exp2 -> [(Var, Var, [Var])] @@ -730,123 +854,152 @@ depList :: Exp2 -> [(Var, Var, [Var])] -- dependencies are properly grouped, without any duplicate keys. But we -- convert it back to a list so that we can hand it off to 'graphFromEdges'. -- Reversing the list makes it easy to peek at the return value of this AST later. -depList = L.map (\(a,b) -> (a,a,b)) . M.toList . go M.empty - where - go :: M.Map Var [Var] -> Exp2 -> M.Map Var [Var] - go acc ex = - case ex of - VarE v -> M.insertWith (++) v [v] acc - LitE{} -> acc - CharE{} -> acc - FloatE{} -> acc - LitSymE{} -> acc - AppE _ _ args -> foldl go acc args - PrimAppE _ args -> foldl go acc args - LetE (v,_,_,rhs) bod -> - let acc_rhs = go acc rhs - in go (M.insertWith (++) v (S.toList $ allFreeVars rhs) acc_rhs) bod - IfE _ b c -> go (go acc b) c - MkProdE ls -> foldl go acc ls - ProjE _ e -> go acc e - CaseE _ mp -> L.foldr (\(_,_,e) acc' -> go acc' e) acc mp - DataConE _ _ args -> foldl go acc args - TimeIt e _ _ -> go acc e - WithArenaE _ e -> go acc e - SpawnE _ _ ls -> foldl go acc ls - SyncE -> acc - MapE{} -> acc - FoldE{} -> acc - Ext ext -> - case ext of - LetRegionE r _ _ rhs -> - go (M.insertWith (++) (regionToVar r) (S.toList (allFreeVars rhs)) acc) rhs - LetParRegionE r _ _ rhs -> - go (M.insertWith (++) (regionToVar r) (S.toList (allFreeVars rhs)) acc) rhs - LetLocE loc phs rhs -> - go (M.insertWith (++) loc (dep phs ++ S.toList (allFreeVars rhs)) acc) rhs - RetE{} -> acc - FromEndE{} -> acc - BoundsCheck{} -> acc - IndirectionE{} -> acc - AddFixed v _ -> M.insertWith (++) v [v] acc - GetCilkWorkerNum -> acc - LetAvail _ bod -> go acc bod - - dep :: PreLocExp LocVar -> [Var] - dep ex = - case ex of - StartOfLE r -> [regionToVar r] - AfterConstantLE _ loc -> [loc] - AfterVariableLE v loc _ -> [v,loc] - InRegionLE r -> [regionToVar r] - FromEndLE loc -> [loc] - FreeLE -> [] +depList = L.map (\(a, b) -> (a, a, b)) . M.toList . go M.empty + where + go :: M.Map Var [Var] -> Exp2 -> M.Map Var [Var] + go acc ex = + case ex of + VarE v -> M.insertWith (++) v [v] acc + LitE {} -> acc + CharE {} -> acc + FloatE {} -> acc + LitSymE {} -> acc + AppE _ _ args -> foldl go acc args + PrimAppE _ args -> foldl go acc args + LetE (v, _, _, rhs) bod -> + let acc_rhs = go acc rhs + in go (M.insertWith (++) v (S.toList $ allFreeVars rhs) acc_rhs) bod + IfE _ b c -> go (go acc b) c + MkProdE ls -> foldl go acc ls + ProjE _ e -> go acc e + CaseE _ mp -> L.foldr (\(_, _, e) acc' -> go acc' e) acc mp + DataConE _ _ args -> foldl go acc args + TimeIt e _ _ -> go acc e + WithArenaE _ e -> go acc e + SpawnE _ _ ls -> foldl go acc ls + SyncE -> acc + MapE {} -> acc + FoldE {} -> acc + Ext ext -> + case ext of + LetRegionE r _ _ rhs -> + go + (M.insertWith + (++) + (regionToVar r) + (S.toList (allFreeVars rhs)) + acc) + rhs + LetParRegionE r _ _ rhs -> + go + (M.insertWith + (++) + (regionToVar r) + (S.toList (allFreeVars rhs)) + acc) + rhs + LetLocE loc phs rhs -> + go + (M.insertWith + (++) + loc + (dep phs ++ S.toList (allFreeVars rhs)) + acc) + rhs + RetE {} -> acc + FromEndE {} -> acc + BoundsCheck {} -> acc + IndirectionE {} -> acc + AddFixed v _ -> M.insertWith (++) v [v] acc + GetCilkWorkerNum -> acc + LetAvail _ bod -> go acc bod + dep :: PreLocExp LocVar -> [Var] + dep ex = + case ex of + StartOfLE r -> [regionToVar r] + AfterConstantLE _ loc -> [loc] + AfterVariableLE v loc _ -> [v, loc] + InRegionLE r -> [regionToVar r] + FromEndLE loc -> [loc] + FreeLE -> [] + -- gFreeVars ++ locations ++ region variables allFreeVars :: Exp2 -> S.Set Var allFreeVars ex = case ex of - AppE _ locs args -> S.fromList locs `S.union` (S.unions (map allFreeVars args)) + AppE _ locs args -> + S.fromList locs `S.union` (S.unions (map allFreeVars args)) PrimAppE _ args -> (S.unions (map allFreeVars args)) - LetE (v,locs,_,rhs) bod -> (S.fromList locs `S.union` (allFreeVars rhs) `S.union` (allFreeVars bod)) - `S.difference` S.singleton v + LetE (v, locs, _, rhs) bod -> + (S.fromList locs `S.union` (allFreeVars rhs) `S.union` (allFreeVars bod)) `S.difference` + S.singleton v IfE a b c -> allFreeVars a `S.union` allFreeVars b `S.union` allFreeVars c MkProdE args -> (S.unions (map allFreeVars args)) ProjE _ bod -> allFreeVars bod - CaseE scrt brs -> (allFreeVars scrt) `S.union` (S.unions (map (\(_,vlocs,c) -> allFreeVars c `S.difference` S.fromList (map fst vlocs)) brs)) - DataConE loc _ args -> S.singleton loc `S.union` (S.unions (map allFreeVars args)) + CaseE scrt brs -> + (allFreeVars scrt) `S.union` + (S.unions + (map + (\(_, vlocs, c) -> + allFreeVars c `S.difference` S.fromList (map fst vlocs)) + brs)) + DataConE loc _ args -> + S.singleton loc `S.union` (S.unions (map allFreeVars args)) TimeIt e _ _ -> allFreeVars e WithArenaE _ e -> allFreeVars e - SpawnE _ locs args -> S.fromList locs `S.union` (S.unions (map allFreeVars args)) + SpawnE _ locs args -> + S.fromList locs `S.union` (S.unions (map allFreeVars args)) Ext ext -> case ext of LetRegionE r _ _ bod -> S.delete (regionToVar r) (allFreeVars bod) LetParRegionE r _ _ bod -> S.delete (regionToVar r) (allFreeVars bod) - LetLocE loc locexp bod -> S.delete loc (allFreeVars bod `S.union` gFreeVars locexp) - RetE locs v -> S.insert v (S.fromList locs) - FromEndE loc -> S.singleton loc - BoundsCheck _ reg cur -> S.fromList [reg,cur] - IndirectionE _ _ (a,b) (c,d) _ -> S.fromList $ [a,b,c,d] - AddFixed v _ -> S.singleton v - GetCilkWorkerNum-> S.empty + LetLocE loc locexp bod -> + S.delete loc (allFreeVars bod `S.union` gFreeVars locexp) + RetE locs v -> S.insert v (S.fromList locs) + FromEndE loc -> S.singleton loc + BoundsCheck _ reg cur -> S.fromList [reg, cur] + IndirectionE _ _ (a, b) (c, d) _ -> S.fromList $ [a, b, c, d] + AddFixed v _ -> S.singleton v + GetCilkWorkerNum -> S.empty LetAvail vs bod -> S.fromList vs `S.union` gFreeVars bod _ -> gFreeVars ex changeAppToSpawn :: Var -> [Exp2] -> Exp2 -> Exp2 changeAppToSpawn v args2 ex1 = case ex1 of - VarE{} -> ex1 - LitE{} -> ex1 - CharE{} -> ex1 - FloatE{} -> ex1 - LitSymE{} -> ex1 - AppE f locs args | v == f && args == args2 -> SpawnE f locs $ map go args + VarE {} -> ex1 + LitE {} -> ex1 + CharE {} -> ex1 + FloatE {} -> ex1 + LitSymE {} -> ex1 + AppE f locs args + | v == f && args == args2 -> SpawnE f locs $ map go args AppE f locs args -> AppE f locs $ map go args - PrimAppE f args -> PrimAppE f $ map go args - LetE (v,loc,ty,rhs) bod -> LetE (v,loc,ty, go rhs) (go bod) - IfE a b c -> IfE (go a) (go b) (go c) + PrimAppE f args -> PrimAppE f $ map go args + LetE (v, loc, ty, rhs) bod -> LetE (v, loc, ty, go rhs) (go bod) + IfE a b c -> IfE (go a) (go b) (go c) MkProdE xs -> MkProdE $ map go xs - ProjE i e -> ProjE i $ go e + ProjE i e -> ProjE i $ go e DataConE loc dcon args -> DataConE loc dcon $ map go args - CaseE scrt mp -> - CaseE (go scrt) $ map (\(a,b,c) -> (a,b, go c)) mp - TimeIt e ty b -> TimeIt (go e) ty b + CaseE scrt mp -> CaseE (go scrt) $ map (\(a, b, c) -> (a, b, go c)) mp + TimeIt e ty b -> TimeIt (go e) ty b WithArenaE v e -> WithArenaE v (go e) - SpawnE{} -> ex1 - SyncE{} -> ex1 + SpawnE {} -> ex1 + SyncE {} -> ex1 Ext ext -> case ext of - LetRegionE r sz ty rhs -> Ext $ LetRegionE r sz ty (go rhs) - LetParRegionE r sz ty rhs -> Ext $ LetParRegionE r sz ty (go rhs) - LetLocE l lhs rhs -> Ext $ LetLocE l lhs (go rhs) - RetE{} -> ex1 - FromEndE{} -> ex1 - BoundsCheck{} -> ex1 - IndirectionE{} -> ex1 - AddFixed{} -> ex1 - GetCilkWorkerNum -> ex1 - LetAvail vs bod -> Ext $ LetAvail vs (go bod) - MapE{} -> error "addRANExp: TODO MapE" - FoldE{} -> error "addRANExp: TODO FoldE" - - where go = changeAppToSpawn v args2 + LetRegionE r sz ty rhs -> Ext $ LetRegionE r sz ty (go rhs) + LetParRegionE r sz ty rhs -> Ext $ LetParRegionE r sz ty (go rhs) + LetLocE l lhs rhs -> Ext $ LetLocE l lhs (go rhs) + RetE {} -> ex1 + FromEndE {} -> ex1 + BoundsCheck {} -> ex1 + IndirectionE {} -> ex1 + AddFixed {} -> ex1 + GetCilkWorkerNum -> ex1 + LetAvail vs bod -> Ext $ LetAvail vs (go bod) + MapE {} -> error "addRANExp: TODO MapE" + FoldE {} -> error "addRANExp: TODO FoldE" + where + go = changeAppToSpawn v args2 diff --git a/gibbon-compiler/src/Gibbon/L3/Syntax.hs b/gibbon-compiler/src/Gibbon/L3/Syntax.hs index 774343bff..2e4f0b813 100644 --- a/gibbon-compiler/src/Gibbon/L3/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/L3/Syntax.hs @@ -1,219 +1,241 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} --- | An intermediate language which makes cursors explicit +-- | An intermediate language which makes cursors explicit module Gibbon.L3.Syntax - ( -- * Extended language - E3Ext(..), Prog3, DDef3, DDefs3, FunDef3, FunDefs3 , Exp3, Ty3 - , Scalar(..), mkScalar, scalarToTy + ( E3Ext(..) + , Prog3 + , DDef3 + , DDefs3 + , FunDef3 + , FunDefs3 + , Exp3 + , Ty3 + , Scalar(..) + , mkScalar + , scalarToTy + , eraseLocMarkers + , mapMExprs + , cursorizeTy + , toL3Prim + , updateAvailVars + , module Gibbon.Language + ) where - -- * Functions - , eraseLocMarkers, mapMExprs, cursorizeTy, toL3Prim, updateAvailVars - , module Gibbon.Language - ) -where +-- * Functions +import Control.DeepSeq +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S +import Text.PrettyPrint.GenericPretty -import Control.DeepSeq -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.List as L -import Text.PrettyPrint.GenericPretty +import Gibbon.Common +import qualified Gibbon.L2.Syntax as L2 +import Gibbon.Language hiding (mapMExprs) -import Gibbon.Common -import Gibbon.Language hiding (mapMExprs) -import qualified Gibbon.L2.Syntax as L2 -------------------------------------------------------------------------------- - type Prog3 = Prog Exp3 -type DDef3 = DDef Ty3 +type DDef3 = DDef Ty3 + type DDefs3 = DDefs Ty3 type FunDefs3 = FunDefs Exp3 type FunDef3 = FunDef Exp3 --- GHC uses the instance defined for L1.Ty1 --- instance FunctionTy Ty3 where +-- GHC uses the instance defined for L1.Ty1 +-- instance FunctionTy Ty3 type Exp3 = PreExp E3Ext () Ty3 type Ty3 = UrTy () + -------------------------------------------------------------------------------- -- | The extension that turns L1 into L3. -data E3Ext loc dec = - ReadScalar Scalar Var -- ^ One cursor in, (int, cursor') out +data E3Ext loc dec + = ReadScalar Scalar Var -- ^ One cursor in, (int, cursor') out | WriteScalar Scalar Var (PreExp E3Ext loc dec) -- ^ Write int at cursor, and return a cursor - | ReadTag Var -- ^ One cursor in, (tag,cursor) out - | WriteTag DataCon Var -- ^ Write Tag at Cursor, and return a cursor - | ReadCursor Var -- ^ Reads and returns the cursor at Var + | ReadTag Var -- ^ One cursor in, (tag,cursor) out + | WriteTag DataCon Var -- ^ Write Tag at Cursor, and return a cursor + | ReadCursor Var -- ^ Reads and returns the cursor at Var | WriteCursor Var (PreExp E3Ext loc dec) -- ^ Write a cursor, and return a cursor - | ReadList Var dec -- ^ Read a pointer to a linked list - | WriteList Var (PreExp E3Ext loc dec) dec -- ^ Write a pointer to a linked list - | ReadVector Var dec -- ^ Read a pointer to a vector - | WriteVector Var (PreExp E3Ext loc dec) dec -- ^ Write a pointer to a vector - | AddCursor Var (PreExp E3Ext loc dec) -- ^ Add a constant offset to a cursor variable - | SubPtr Var Var -- ^ Pointer subtraction - | NewBuffer L2.Multiplicity -- ^ Create a new buffer, and return a cursor - | ScopedBuffer L2.Multiplicity -- ^ Create a temporary scoped buffer, and return a cursor - | NewParBuffer L2.Multiplicity -- ^ Create a new buffer for parallel allocations, and return a cursor - | ScopedParBuffer L2.Multiplicity -- ^ Create a temporary scoped buffer for parallel allocations, and return a cursor - | InitSizeOfBuffer L2.Multiplicity -- ^ Returns the initial buffer size for a specific multiplicity + | ReadList Var dec -- ^ Read a pointer to a linked list + | WriteList Var (PreExp E3Ext loc dec) dec -- ^ Write a pointer to a linked list + | ReadVector Var dec -- ^ Read a pointer to a vector + | WriteVector Var (PreExp E3Ext loc dec) dec -- ^ Write a pointer to a vector + | AddCursor Var (PreExp E3Ext loc dec) -- ^ Add a constant offset to a cursor variable + | SubPtr Var Var -- ^ Pointer subtraction + | NewBuffer L2.Multiplicity -- ^ Create a new buffer, and return a cursor + | ScopedBuffer L2.Multiplicity -- ^ Create a temporary scoped buffer, and return a cursor + | NewParBuffer L2.Multiplicity -- ^ Create a new buffer for parallel allocations, and return a cursor + | ScopedParBuffer L2.Multiplicity -- ^ Create a temporary scoped buffer for parallel allocations, and return a cursor + | InitSizeOfBuffer L2.Multiplicity -- ^ Returns the initial buffer size for a specific multiplicity | MMapFileSize Var - | SizeOfPacked Var Var -- ^ Takes in start and end cursors, and returns an Int + | SizeOfPacked Var Var -- ^ Takes in start and end cursors, and returns an Int -- we'll probably represent (sizeof x) as (end_x - start_x) / INT - | SizeOfScalar Var -- ^ sizeof(var) - | BoundsCheck Int Var Var -- ^ Bytes required, region, write cursor - | BumpRefCount Var Var -- ^ Given an end-of-region ptr, bump it's refcount. + | SizeOfScalar Var -- ^ sizeof(var) + | BoundsCheck Int Var Var -- ^ Bytes required, region, write cursor + | BumpRefCount Var Var -- ^ Given an end-of-region ptr, bump it's refcount. -- Return the updated count (optional). - | BumpArenaRefCount Var Var -- ^ Given an arena and end-of-region ptr, add a + | BumpArenaRefCount Var Var -- ^ Given an arena and end-of-region ptr, add a -- reference from the arena to the region - | NullCursor -- ^ Constant null cursor value (hack?). + | NullCursor -- ^ Constant null cursor value (hack?). -- Used for dict lookup, which returns a packed value but -- no end witness. - | RetE [(PreExp E3Ext loc dec)] -- ^ Analogous to L2's RetE - | GetCilkWorkerNum -- ^ Runs __cilkrts_get_worker_number() + | RetE [(PreExp E3Ext loc dec)] -- ^ Analogous to L2's RetE + | GetCilkWorkerNum -- ^ Runs __cilkrts_get_worker_number() | LetAvail [Var] (PreExp E3Ext loc dec) -- ^ These variables are available to use before the join point deriving (Show, Ord, Eq, Read, Generic, NFData) -instance FreeVars (E3Ext l d) where - gFreeVars e = +instance (Out l, Out d) => FreeVars (E3Ext l d) where + gFreeVars e = case e of - ReadScalar _ v -> S.singleton v - WriteScalar _ v ex -> S.insert v (gFreeVars ex) - ReadTag v -> S.singleton v - WriteTag _ v -> S.singleton v - ReadCursor v -> S.singleton v - WriteCursor c ex -> S.insert c (gFreeVars ex) - ReadList v _ -> S.singleton v - WriteList c ex _ -> S.insert c (gFreeVars ex) - AddCursor v ex -> S.insert v (gFreeVars ex) - SubPtr v w -> S.fromList [v, w] - NewBuffer{} -> S.empty - NewParBuffer{} -> S.empty - ScopedBuffer{} -> S.empty - ScopedParBuffer{} -> S.empty - InitSizeOfBuffer{} -> S.empty - MMapFileSize v -> S.singleton v - SizeOfPacked c1 c2 -> S.fromList [c1, c2] - SizeOfScalar v -> S.singleton v - BoundsCheck{} -> S.empty - BumpRefCount r1 r2 -> S.fromList [r1, r2] - NullCursor -> S.empty + ReadScalar _ v -> S.singleton v + WriteScalar _ v ex -> S.insert v (gFreeVars ex) + ReadTag v -> S.singleton v + WriteTag _ v -> S.singleton v + ReadCursor v -> S.singleton v + WriteCursor c ex -> S.insert c (gFreeVars ex) + ReadList v _ -> S.singleton v + WriteList c ex _ -> S.insert c (gFreeVars ex) + AddCursor v ex -> S.insert v (gFreeVars ex) + SubPtr v w -> S.fromList [v, w] + NewBuffer {} -> S.empty + NewParBuffer {} -> S.empty + ScopedBuffer {} -> S.empty + ScopedParBuffer {} -> S.empty + InitSizeOfBuffer {} -> S.empty + MMapFileSize v -> S.singleton v + SizeOfPacked c1 c2 -> S.fromList [c1, c2] + SizeOfScalar v -> S.singleton v + BoundsCheck {} -> S.empty + BumpRefCount r1 r2 -> S.fromList [r1, r2] + NullCursor -> S.empty BumpArenaRefCount v w -> S.fromList [v, w] - RetE ls -> S.unions (L.map gFreeVars ls) - GetCilkWorkerNum -> S.empty - LetAvail ls b -> (S.fromList ls) `S.union` gFreeVars b - ReadVector{} -> error "gFreeVars: ReadVector" - WriteVector{} -> error "gFreeVars: WriteVector" - - -instance (Out l, Out d, Show l, Show d) => Expression (E3Ext l d) where + RetE ls -> S.unions (L.map gFreeVars ls) + GetCilkWorkerNum -> S.empty + LetAvail ls b -> (S.fromList ls) `S.union` gFreeVars b + ReadVector {} -> error "gFreeVars: ReadVector" + WriteVector {} -> error "gFreeVars: WriteVector" + +instance (Out l, Out d, Show l, Show d) => Expression (E3Ext l d) + where type LocOf (E3Ext l d) = l - type TyOf (E3Ext l d) = UrTy l - isTrivial _ = False - -instance (Out l, Show l, Typeable (PreExp E3Ext l (UrTy l))) => Typeable (E3Ext l (UrTy l)) where - gRecoverType _ddfs _env2 NullCursor = CursorTy - gRecoverType ddfs env2 (RetE ls) = ProdTy $ L.map (gRecoverType ddfs env2) ls - gRecoverType _ _ _ = error "L3.gRecoverType" - -instance (Show l, Out l) => Flattenable (E3Ext l (UrTy l)) where - gFlattenGatherBinds _ddfs _env ex = return ([], ex) - gFlattenExp _ddfs _env ex = return ex - -instance HasSimplifiableExt E3Ext l d => SimplifiableExt (PreExp E3Ext l d) (E3Ext l d) where - gInlineTrivExt _ _ = error $ "InlineTriv is not a safe operation to perform on L3." ++ - " A lot of L3 extensions can only use values" ++ - " via variable references. So those variables" ++ - " should *not* be inlined." ++ - " Running copy-propogation should be OK." - - -instance HasSubstitutableExt E3Ext l d => SubstitutableExt (PreExp E3Ext l d) (E3Ext l d) where + type TyOf (E3Ext l d) = UrTy l + isTrivial _ = False + +instance (Out l, Show l, Typeable (PreExp E3Ext l (UrTy l))) => + Typeable (E3Ext l (UrTy l)) + where + gRecoverType _ddfs _env2 NullCursor = CursorTy + gRecoverType ddfs env2 (RetE ls) = ProdTy $ L.map (gRecoverType ddfs env2) ls + gRecoverType _ _ _ = error "L3.gRecoverType" + +instance (Show l, Out l) => Flattenable (E3Ext l (UrTy l)) + where + gFlattenGatherBinds _ddfs _env ex = return ([], ex) + gFlattenExp _ddfs _env ex = return ex + +instance HasSimplifiableExt E3Ext l d => + SimplifiableExt (PreExp E3Ext l d) (E3Ext l d) where + gInlineTrivExt _ _ = + error $ + "InlineTriv is not a safe operation to perform on L3." ++ + " A lot of L3 extensions can only use values" ++ + " via variable references. So those variables" ++ + " should *not* be inlined." ++ " Running copy-propogation should be OK." + +instance HasSubstitutableExt E3Ext l d => + SubstitutableExt (PreExp E3Ext l d) (E3Ext l d) where gSubstExt old new ext = case ext of - WriteScalar s v bod -> WriteScalar s v (gSubst old new bod) - WriteCursor v bod -> WriteCursor v (gSubst old new bod) - AddCursor v bod -> AddCursor v (gSubst old new bod) - SubPtr v w -> SubPtr v w - LetAvail ls bod -> LetAvail ls (gSubst old new bod) - _ -> ext - + WriteScalar s v bod -> WriteScalar s v (gSubst old new bod) + WriteCursor v bod -> WriteCursor v (gSubst old new bod) + AddCursor v bod -> AddCursor v (gSubst old new bod) + SubPtr v w -> SubPtr v w + LetAvail ls bod -> LetAvail ls (gSubst old new bod) + _ -> ext gSubstEExt old new ext = case ext of - WriteScalar s v bod -> WriteScalar s v (gSubstE old new bod) - WriteCursor v bod -> WriteCursor v (gSubstE old new bod) - AddCursor v bod -> AddCursor v (gSubstE old new bod) - SubPtr v w -> SubPtr v w - LetAvail ls b -> LetAvail ls (gSubstE old new b) - _ -> ext + WriteScalar s v bod -> WriteScalar s v (gSubstE old new bod) + WriteCursor v bod -> WriteCursor v (gSubstE old new bod) + AddCursor v bod -> AddCursor v (gSubstE old new bod) + SubPtr v w -> SubPtr v w + LetAvail ls b -> LetAvail ls (gSubstE old new b) + _ -> ext instance HasRenamable E3Ext l d => Renamable (E3Ext l d) where gRename env ext = case ext of - ReadScalar s v -> ReadScalar s (go v) - WriteScalar s v bod -> WriteScalar s (go v) (go bod) - ReadCursor v -> ReadCursor (go v) - WriteCursor v bod -> WriteCursor (go v) (go bod) - ReadList v el_ty -> ReadList (go v) el_ty - WriteList v bod el_ty -> WriteList (go v) (go bod) el_ty - ReadVector v el_ty -> ReadVector (go v) el_ty - WriteVector v bod el_ty -> WriteVector (go v) (go bod) el_ty - ReadTag v -> ReadTag (go v) - WriteTag dcon v -> WriteTag dcon (go v) - AddCursor v bod -> AddCursor (go v) (go bod) - SubPtr v w -> SubPtr (go v) (go w) - NewBuffer{} -> ext - ScopedBuffer{} -> ext - NewParBuffer{} -> ext - ScopedParBuffer{} -> ext - InitSizeOfBuffer{} -> ext - MMapFileSize v -> MMapFileSize (go v) - SizeOfPacked a b -> SizeOfPacked (go a) (go b) - SizeOfScalar v -> SizeOfScalar (go v) - BoundsCheck i a b -> BoundsCheck i (go a) (go b) - BumpRefCount a b -> BumpRefCount (go a) (go b) - BumpArenaRefCount v w -> BumpArenaRefCount (go v) (go w) - NullCursor -> ext - RetE ls -> RetE (L.map go ls) - GetCilkWorkerNum -> GetCilkWorkerNum - LetAvail ls b -> LetAvail (L.map go ls) (go b) + ReadScalar s v -> ReadScalar s (go v) + WriteScalar s v bod -> WriteScalar s (go v) (go bod) + ReadCursor v -> ReadCursor (go v) + WriteCursor v bod -> WriteCursor (go v) (go bod) + ReadList v el_ty -> ReadList (go v) el_ty + WriteList v bod el_ty -> WriteList (go v) (go bod) el_ty + ReadVector v el_ty -> ReadVector (go v) el_ty + WriteVector v bod el_ty -> WriteVector (go v) (go bod) el_ty + ReadTag v -> ReadTag (go v) + WriteTag dcon v -> WriteTag dcon (go v) + AddCursor v bod -> AddCursor (go v) (go bod) + SubPtr v w -> SubPtr (go v) (go w) + NewBuffer {} -> ext + ScopedBuffer {} -> ext + NewParBuffer {} -> ext + ScopedParBuffer {} -> ext + InitSizeOfBuffer {} -> ext + MMapFileSize v -> MMapFileSize (go v) + SizeOfPacked a b -> SizeOfPacked (go a) (go b) + SizeOfScalar v -> SizeOfScalar (go v) + BoundsCheck i a b -> BoundsCheck i (go a) (go b) + BumpRefCount a b -> BumpRefCount (go a) (go b) + BumpArenaRefCount v w -> BumpArenaRefCount (go v) (go w) + NullCursor -> ext + RetE ls -> RetE (L.map go ls) + GetCilkWorkerNum -> GetCilkWorkerNum + LetAvail ls b -> LetAvail (L.map go ls) (go b) where - go :: forall a. Renamable a => a -> a + go :: + forall a. Renamable a + => a + -> a go = gRename env -data Scalar = IntS | CharS | FloatS | SymS | BoolS +data Scalar + = IntS + | CharS + | FloatS + | SymS + | BoolS deriving (Show, Ord, Eq, Read, Generic, NFData, Out) mkScalar :: Out a => UrTy a -> Scalar -mkScalar IntTy = IntS -mkScalar CharTy = CharS -mkScalar FloatTy= FloatS -mkScalar SymTy = SymS -mkScalar BoolTy = BoolS -mkScalar ty = error $ "mkScalar: Not a scalar type: " ++ sdoc ty +mkScalar IntTy = IntS +mkScalar CharTy = CharS +mkScalar FloatTy = FloatS +mkScalar SymTy = SymS +mkScalar BoolTy = BoolS +mkScalar ty = error $ "mkScalar: Not a scalar type: " ++ sdoc ty scalarToTy :: Scalar -> UrTy a -scalarToTy IntS = IntTy -scalarToTy CharS = CharTy -scalarToTy FloatS= FloatTy -scalarToTy SymS = SymTy -scalarToTy BoolS = BoolTy - +scalarToTy IntS = IntTy +scalarToTy CharS = CharTy +scalarToTy FloatS = FloatTy +scalarToTy SymS = SymTy +scalarToTy BoolS = BoolTy ----------------------------------------------------------------------------------------- -- Do this manually to get prettier formatting: (Issue #90) - instance (Out l, Out d) => Out (E3Ext l d) ----------------------------------------------------------------------------------------- @@ -221,82 +243,88 @@ instance (Out l, Out d) => Out (E3Ext l d) -- | Erase LocVar markers from the data definition eraseLocMarkers :: DDef L2.Ty2 -> DDef Ty3 eraseLocMarkers (DDef tyargs tyname ls) = DDef tyargs tyname $ L.map go ls - where go :: (DataCon,[(IsBoxed,L2.Ty2)]) -> (DataCon,[(IsBoxed,Ty3)]) - go (dcon,ls') = (dcon, L.map (\(b,ty) -> (b,L2.stripTyLocs ty)) ls') + where + go :: (DataCon, [(IsBoxed, L2.Ty2)]) -> (DataCon, [(IsBoxed, Ty3)]) + go (dcon, ls') = (dcon, L.map (\(b, ty) -> (b, L2.stripTyLocs ty)) ls') cursorizeTy :: UrTy a -> UrTy b cursorizeTy ty = case ty of - IntTy -> IntTy - CharTy -> CharTy - FloatTy -> FloatTy - SymTy -> SymTy - BoolTy -> BoolTy - ProdTy ls -> ProdTy $ L.map cursorizeTy ls - SymDictTy v _ -> SymDictTy v CursorTy - PDictTy k v -> PDictTy (cursorizeTy k) (cursorizeTy v) - PackedTy{} -> ProdTy [CursorTy, CursorTy] + IntTy -> IntTy + CharTy -> CharTy + FloatTy -> FloatTy + SymTy -> SymTy + BoolTy -> BoolTy + ProdTy ls -> ProdTy $ L.map cursorizeTy ls + SymDictTy v _ -> SymDictTy v CursorTy + PDictTy k v -> PDictTy (cursorizeTy k) (cursorizeTy v) + PackedTy {} -> ProdTy [CursorTy, CursorTy] VectorTy el_ty' -> VectorTy $ cursorizeTy el_ty' ListTy el_ty' -> ListTy $ cursorizeTy el_ty' - PtrTy -> PtrTy - CursorTy -> CursorTy - ArenaTy -> ArenaTy - SymSetTy -> SymSetTy - SymHashTy-> SymHashTy - IntHashTy-> IntHashTy + PtrTy -> PtrTy + CursorTy -> CursorTy + ArenaTy -> ArenaTy + SymSetTy -> SymSetTy + SymHashTy -> SymHashTy + IntHashTy -> IntHashTy + -- | Map exprs with an initial type environment: -- Exactly the same function that was in L2 before mapMExprs :: Monad m => (Env2 Ty3 -> Exp3 -> m Exp3) -> Prog3 -> m Prog3 mapMExprs fn (Prog ddfs fundefs mainExp) = Prog ddfs <$> - (mapM (\f@FunDef{funArgs,funTy,funBody} -> - let env = Env2 (M.fromList $ zip funArgs (fst funTy)) funEnv - in do - bod' <- fn env funBody - return $ f { funBody = bod' }) - fundefs) - <*> - (mapM (\ (e,t) -> (,t) <$> fn (Env2 M.empty funEnv) e) mainExp) - where funEnv = M.map funTy fundefs + (mapM + (\f@FunDef {funArgs, funTy, funBody} -> + let env = Env2 (M.fromList $ zip funArgs (fst funTy)) funEnv + in do bod' <- fn env funBody + return $ f {funBody = bod'}) + fundefs) <*> + (mapM (\(e, t) -> (, t) <$> fn (Env2 M.empty funEnv) e) mainExp) + where + funEnv = M.map funTy fundefs toL3Prim :: Prim L2.Ty2 -> Prim Ty3 -toL3Prim (DictEmptyP _ty) = DictEmptyP CursorTy +toL3Prim (DictEmptyP _ty) = DictEmptyP CursorTy toL3Prim (DictInsertP _ty) = DictInsertP CursorTy toL3Prim (DictLookupP _ty) = DictLookupP CursorTy toL3Prim (DictHasKeyP _ty) = DictHasKeyP CursorTy -toL3Prim pr = fmap L2.stripTyLocs pr +toL3Prim pr = fmap L2.stripTyLocs pr + -- | updateAvailVars :: [Var] -> [Var] -> Exp3 -> Exp3 updateAvailVars froms tos ex = case ex of - VarE v -> VarE v - LitE _ -> ex - CharE _ -> ex - FloatE{} -> ex - LitSymE _ -> ex - AppE v loc ls -> AppE v loc (map go ls) - PrimAppE p ls -> PrimAppE p $ L.map go ls - LetE (v,loc,t,rhs) bod -> LetE (v,loc,t,go rhs) (go bod) - ProjE i e -> ProjE i (go e) - CaseE e ls -> CaseE (go e) (L.map (\(c,vs,er) -> (c,vs,go er)) ls) - MkProdE ls -> MkProdE $ L.map go ls + VarE v -> VarE v + LitE _ -> ex + CharE _ -> ex + FloatE {} -> ex + LitSymE _ -> ex + AppE v loc ls -> AppE v loc (map go ls) + PrimAppE p ls -> PrimAppE p $ L.map go ls + LetE (v, loc, t, rhs) bod -> LetE (v, loc, t, go rhs) (go bod) + ProjE i e -> ProjE i (go e) + CaseE e ls -> CaseE (go e) (L.map (\(c, vs, er) -> (c, vs, go er)) ls) + MkProdE ls -> MkProdE $ L.map go ls DataConE loc k ls -> DataConE loc k $ L.map go ls - TimeIt e t b -> TimeIt (go e) t b - IfE a b c -> IfE (go a) (go b) (go c) - SpawnE v loc ls -> SpawnE v loc (map go ls) - SyncE -> SyncE - WithArenaE v e -> WithArenaE v (go e) - MapE (v,t,rhs) bod -> MapE (v,t, go rhs) (go bod) - FoldE (v1,t1,r1) (v2,t2,r2) bod -> - FoldE (v1,t1,go r1) (v2,t2,go r2) (go bod) + TimeIt e t b -> TimeIt (go e) t b + IfE a b c -> IfE (go a) (go b) (go c) + SpawnE v loc ls -> SpawnE v loc (map go ls) + SyncE -> SyncE + WithArenaE v e -> WithArenaE v (go e) + MapE (v, t, rhs) bod -> MapE (v, t, go rhs) (go bod) + FoldE (v1, t1, r1) (v2, t2, r2) bod -> + FoldE (v1, t1, go r1) (v2, t2, go r2) (go bod) Ext ext -> case ext of LetAvail vs bod -> - let n o = if o `elem` froms then tos else [o] + let n o = + if o `elem` froms + then tos + else [o] vs' = foldr (\v acc -> n v ++ acc) [] vs - in Ext $ LetAvail vs' (go bod) + in Ext $ LetAvail vs' (go bod) _ -> ex where go = updateAvailVars froms tos diff --git a/gibbon-compiler/src/Gibbon/Language.hs b/gibbon-compiler/src/Gibbon/Language.hs index 103bf96a7..ade39afde 100644 --- a/gibbon-compiler/src/Gibbon/Language.hs +++ b/gibbon-compiler/src/Gibbon/Language.hs @@ -1,157 +1,203 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} module Gibbon.Language - ( module Gibbon.Language.Constants - , module Gibbon.Language.Syntax + ( module Gibbon.Language.Constants + , module Gibbon.Language.Syntax + +-- * Helpers operating on expressions + , mapExt + , mapLocs + , mapExprs + , mapMExprs + , visitExp + , subst + , substE + , hasTimeIt + , hasSpawns + , hasSpawnsProg + , projNonFirst + , mkProj + , mkProd + , mkLets + , flatLets + , tuplizeRefs + +-- * Helpers operating on types + , mkProdTy + , projTy + , voidTy + , isProdTy + , isNestedProdTy + , isPackedTy + , isScalarTy + , hasPacked + , sizeOfTy + , primArgsTy + , primRetTy + , tyToDataCon + , stripTyLocs + , isValidListElemTy + , getPackedTys + +-- * Misc + , assertTriv + , assertTrivs + ) where + +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S - -- * Helpers operating on expressions - , mapExt, mapLocs, mapExprs, mapMExprs, visitExp - , subst, substE, hasTimeIt, hasSpawns, hasSpawnsProg, projNonFirst - , mkProj, mkProd, mkLets, flatLets, tuplizeRefs - - -- * Helpers operating on types - , mkProdTy, projTy , voidTy, isProdTy, isNestedProdTy, isPackedTy, isScalarTy - , hasPacked, sizeOfTy, primArgsTy, primRetTy, tyToDataCon - , stripTyLocs, isValidListElemTy, getPackedTys - - -- * Misc - , assertTriv, assertTrivs - - ) where - -import qualified Data.Map as M -import qualified Data.List as L -import qualified Data.Set as S -- import Data.Functor.Foldable import Text.PrettyPrint.GenericPretty +import GHC.Stack +import Gibbon.Common import Gibbon.Language.Constants import Gibbon.Language.Syntax -import Gibbon.Common -import GHC.Stack --------------------------------------------------------------------------------- -instance (Out l, Show l, Show d, Out d, Expression (e l d)) - => Expression (PreExp e l d) where +-------------------------------------------------------------------------------- +instance (Out l, Show l, Show d, Out d, Expression (e l d)) => + Expression (PreExp e l d) + where type (TyOf (PreExp e l d)) = d type (LocOf (PreExp e l d)) = l - isTrivial = f + isTrivial = f where f :: (PreExp e l d) -> Bool f e = - case e of - VarE _ -> True - LitE _ -> True - CharE _ -> True - FloatE{} -> True - LitSymE _ -> True - PrimAppE{} -> False - + case e of + VarE _ -> True + LitE _ -> True + CharE _ -> True + FloatE {} -> True + LitSymE _ -> True + PrimAppE {} -> False ----------------- POLICY DECISION --------------- -- Tuples and projections are NOT trivial! - ProjE{} -> False - MkProdE{} -> False - - -- DataCon's are a bit tricky. May want to inline them at + ProjE {} -> False + MkProdE {} -> False + +-- DataCon's are a bit tricky. May want to inline them at -- some point if it avoids region conflicts. - DataConE{} -> False - - IfE{} -> False - CaseE{} -> False - LetE {} -> False - MapE {} -> False - FoldE {} -> False - AppE {} -> False - TimeIt {} -> False - WithArenaE{} -> False - SpawnE{} -> False - SyncE -> False - Ext ext -> isTrivial ext + DataConE {} -> False + IfE {} -> False + CaseE {} -> False + LetE {} -> False + MapE {} -> False + FoldE {} -> False + AppE {} -> False + TimeIt {} -> False + WithArenaE {} -> False + SpawnE {} -> False + SyncE -> False + Ext ext -> isTrivial ext + -- | Free data variables. Does not include function variables, which -- currently occupy a different namespace. Does not include location/region variables. -instance FreeVars (e l d) => FreeVars (PreExp e l d) where - gFreeVars ex = case ex of - VarE v -> S.singleton v - LitE _ -> S.empty - CharE _ -> S.empty - FloatE{} -> S.empty +instance (FreeVars (e l d), Out l, Out d) => FreeVars (PreExp e l d) where + gFreeVars ex = + case ex of + VarE v -> S.singleton v + LitE _ -> S.empty + CharE _ -> S.empty + FloatE {} -> S.empty LitSymE _ -> S.empty ProjE _ e -> gFreeVars e IfE a b c -> gFreeVars a `S.union` gFreeVars b `S.union` gFreeVars c - AppE v _ ls -> S.unions $ (S.singleton v) : (L.map gFreeVars ls) - PrimAppE _ ls -> S.unions (L.map gFreeVars ls) - LetE (v,_,_,rhs) bod -> gFreeVars rhs `S.union` - S.delete v (gFreeVars bod) - CaseE e ls -> S.union (gFreeVars e) - (S.unions $ L.map (\(_, vlocs, ee) -> - let (vars,_) = unzip vlocs - in (gFreeVars ee) `S.difference` (S.fromList vars)) - ls) - MkProdE ls -> S.unions $ L.map gFreeVars ls - DataConE _ _ ls -> S.unions $ L.map gFreeVars ls - TimeIt e _ _ -> gFreeVars e - MapE (v,_t,rhs) bod -> gFreeVars rhs `S.union` - S.delete v (gFreeVars bod) - FoldE (v1,_t1,r1) (v2,_t2,r2) bod -> - gFreeVars r1 `S.union` gFreeVars r2 `S.union` - (S.delete v1 $ S.delete v2 $ gFreeVars bod) - + AppE v _ ls -> S.unions $ (S.singleton v) : (L.map gFreeVars ls) + PrimAppE _ ls -> S.unions (L.map gFreeVars ls) + LetE (v, _, _, rhs) bod -> + gFreeVars rhs `S.union` S.delete v (gFreeVars bod) + CaseE e ls -> + S.union + (gFreeVars e) + (S.unions $ + L.map + (\(_, vlocs, ee) -> + let (vars, _) = unzip vlocs + in (gFreeVars ee) `S.difference` (S.fromList vars)) + ls) + MkProdE ls -> S.unions $ L.map gFreeVars ls + DataConE _ _ ls -> S.unions $ L.map gFreeVars ls + TimeIt e _ _ -> gFreeVars e + MapE (v, _t, rhs) bod -> + gFreeVars rhs `S.union` S.delete v (gFreeVars bod) + FoldE (v1, _t1, r1) (v2, _t2, r2) bod -> + gFreeVars r1 `S.union` gFreeVars r2 `S.union` + (S.delete v1 $ S.delete v2 $ gFreeVars bod) WithArenaE v e -> S.delete v $ gFreeVars e - SpawnE v _ ls -> S.unions $ (S.singleton v) : (L.map gFreeVars ls) SyncE -> S.empty - Ext q -> gFreeVars q -- | A Typeable instance for L1 and L3 (L2 defines it's own) -instance (Show (), Out (), Expression (e () (UrTy ())), - TyOf (e () (UrTy ())) ~ TyOf (PreExp e () (UrTy ())), - FunctionTy (UrTy ()), Typeable (e () (UrTy ()))) - => Typeable (PreExp e () (UrTy ())) where +instance ( Show () + , Out () + , Expression (e () (UrTy ())) + , TyOf (e () (UrTy ())) ~ TyOf (PreExp e () (UrTy ())) + , FunctionTy (UrTy ()) + , Typeable (e () (UrTy ())) + ) => + Typeable (PreExp e () (UrTy ())) where gRecoverType ddfs env2 ex = case ex of - VarE v -> M.findWithDefault (error $ "Cannot find type of variable " ++ show v ++ " in " ++ show (vEnv env2)) v (vEnv env2) - LitE _ -> IntTy - CharE _ -> CharTy - FloatE{} -> FloatTy - LitSymE _ -> SymTy - AppE v _ _ -> outTy $ fEnv env2 # v - PrimAppE (DictInsertP ty) ((VarE v):_) -> SymDictTy (Just v) $ stripTyLocs ty - PrimAppE (DictEmptyP ty) ((VarE v):_) -> SymDictTy (Just v) $ stripTyLocs ty + VarE v -> + M.findWithDefault + (error $ + "Cannot find type of variable " ++ + show v ++ " in " ++ show (vEnv env2)) + v + (vEnv env2) + LitE _ -> IntTy + CharE _ -> CharTy + FloatE {} -> FloatTy + LitSymE _ -> SymTy + AppE v _ _ -> outTy $ fEnv env2 # v + PrimAppE (DictInsertP ty) ((VarE v):_) -> + SymDictTy (Just v) $ stripTyLocs ty + PrimAppE (DictEmptyP ty) ((VarE v):_) -> + SymDictTy (Just v) $ stripTyLocs ty PrimAppE p _ -> primRetTy p - - LetE (v,_,t,_) e -> gRecoverType ddfs (extendVEnv v t env2) e - IfE _ e _ -> gRecoverType ddfs env2 e - MkProdE es -> ProdTy $ L.map (gRecoverType ddfs env2) es + LetE (v, _, t, _) e -> gRecoverType ddfs (extendVEnv v t env2) e + IfE _ e _ -> gRecoverType ddfs env2 e + MkProdE es -> ProdTy $ L.map (gRecoverType ddfs env2) es DataConE loc c _ -> PackedTy (getTyOfDataCon ddfs c) loc - TimeIt e _ _ -> gRecoverType ddfs env2 e - MapE _ e -> gRecoverType ddfs env2 e - FoldE _ _ e -> gRecoverType ddfs env2 e - Ext ext -> gRecoverType ddfs env2 ext + TimeIt e _ _ -> gRecoverType ddfs env2 e + MapE _ e -> gRecoverType ddfs env2 e + FoldE _ _ e -> gRecoverType ddfs env2 e + Ext ext -> gRecoverType ddfs env2 ext ProjE i e -> case gRecoverType ddfs env2 e of (ProdTy tys) -> tys !! i - oth -> error$ "typeExp: Cannot project fields from this type: "++show oth - ++"\nExpression:\n "++ sdoc ex - ++"\nEnvironment:\n "++sdoc (vEnv env2) + oth -> + error $ + "typeExp: Cannot project fields from this type: " ++ + show oth ++ + "\nExpression:\n " ++ + sdoc ex ++ "\nEnvironment:\n " ++ sdoc (vEnv env2) WithArenaE _v e -> gRecoverType ddfs env2 e - SpawnE v _ _ -> outTy $ fEnv env2 # v - SyncE -> voidTy + SpawnE v _ _ -> outTy $ fEnv env2 # v + SyncE -> voidTy CaseE _ mp -> - let (c,args,e) = head mp + let (c, args, e) = head mp args' = L.map fst args - in gRecoverType ddfs (extendsVEnv (M.fromList (zip args' (lookupDataCon ddfs c))) env2) e - + in gRecoverType + ddfs + (extendsVEnv (M.fromList (zip args' (lookupDataCon ddfs c))) env2) + e -instance Renamable Var where +instance Renamable Var + where gRename env v = M.findWithDefault v v env -instance HasSubstitutable e l d => Substitutable (PreExp e l d) where +instance HasSubstitutable e l d => Substitutable (PreExp e l d) + where gSubst = subst gSubstE = substE @@ -159,34 +205,43 @@ instance HasRenamable e l d => Renamable (PreExp e l d) where gRename env ex = case ex of VarE v -> VarE (go v) - LitE{} -> ex - CharE{} -> ex - FloatE{} -> ex - LitSymE{} -> ex + LitE {} -> ex + CharE {} -> ex + FloatE {} -> ex + LitSymE {} -> ex AppE f locs args -> AppE (go f) (gol locs) (gol args) PrimAppE pr args -> PrimAppE pr (gol args) - LetE (v,locs,ty,rhs) bod -> LetE (go v, gol locs, go ty, go rhs) (go bod) - IfE a b c -> IfE (go a) (go b) (go c) + LetE (v, locs, ty, rhs) bod -> + LetE (go v, gol locs, go ty, go rhs) (go bod) + IfE a b c -> IfE (go a) (go b) (go c) MkProdE ls -> MkProdE (gol ls) - ProjE i e -> ProjE i (go e) + ProjE i e -> ProjE i (go e) CaseE scrt ls -> - CaseE (go scrt) (map (\(a,b,c) -> (a, map (\(d,e) -> (go d, go e)) b, go c)) ls) + CaseE + (go scrt) + (map (\(a, b, c) -> (a, map (\(d, e) -> (go d, go e)) b, go c)) ls) DataConE loc dcon ls -> DataConE (go loc) dcon (gol ls) TimeIt e ty b -> TimeIt (go e) (go ty) b SpawnE f locs args -> SpawnE (go f) (gol locs) (gol args) - SyncE -> SyncE + SyncE -> SyncE WithArenaE v e -> WithArenaE (go v) (go e) Ext ext -> Ext (go ext) - MapE{} -> ex - FoldE{} -> ex - where - go :: forall a. Renamable a => a -> a - go = gRename env - - gol :: forall a. Renamable a => [a] -> [a] - gol ls = map go ls - -instance Renamable a => Renamable (UrTy a) where + MapE {} -> ex + FoldE {} -> ex + where + go :: + forall a. Renamable a + => a + -> a + go = gRename env + gol :: + forall a. Renamable a + => [a] + -> [a] + gol ls = map go ls + +instance Renamable a => Renamable (UrTy a) + where gRename env = fmap (gRename env) @@ -198,330 +253,390 @@ instance Renamable a => Renamable (UrTy a) where mapExt :: (e1 l d -> e2 l d) -> PreExp e1 l d -> PreExp e2 l d mapExt fn = visitExp id fn id + -- | Apply a function to the locations only. mapLocs :: (e l2 d -> e l2 d) -> PreExp e l2 d -> PreExp e l2 d mapLocs fn = visitExp id fn id + -- | Transform the expressions within a program. mapExprs :: (e -> e) -> Prog e -> Prog e -mapExprs fn prg@Prog{fundefs,mainExp} = - let mainExp' = case mainExp of - Nothing -> Nothing - Just (ex,ty) -> Just (fn ex, ty) - in - prg{ fundefs = M.map (\g -> g {funBody = fn (funBody g)}) fundefs - , mainExp = mainExp' } +mapExprs fn prg@Prog {fundefs, mainExp} = + let mainExp' = + case mainExp of + Nothing -> Nothing + Just (ex, ty) -> Just (fn ex, ty) + in prg + { fundefs = M.map (\g -> g {funBody = fn (funBody g)}) fundefs + , mainExp = mainExp' + } + -- | Monadic 'mapExprs'. mapMExprs :: Monad m => (e -> m e) -> Prog e -> m (Prog e) -mapMExprs fn prg@Prog{fundefs,mainExp} = do - mainExp' <- case mainExp of - Nothing -> pure Nothing - Just (ex,ty) -> do ex' <- fn ex - pure $ Just (ex', ty) - fundefs' <- traverse (\g -> do funBody' <- fn (funBody g) - pure $ g {funBody = funBody'}) - fundefs - pure $ prg { fundefs = fundefs', mainExp = mainExp' } +mapMExprs fn prg@Prog {fundefs, mainExp} = do + mainExp' <- + case mainExp of + Nothing -> pure Nothing + Just (ex, ty) -> do + ex' <- fn ex + pure $ Just (ex', ty) + fundefs' <- + traverse + (\g -> do + funBody' <- fn (funBody g) + pure $ g {funBody = funBody'}) + fundefs + pure $ prg {fundefs = fundefs', mainExp = mainExp'} -- | Apply a function to the locations, extensions, and -- binder-decorations, respectively. -visitExp :: forall l1 l2 e1 e2 d1 d2 . - (l1 -> l2) -> (e1 l1 d1 -> e2 l2 d2) -> (d1 -> d2) -> - PreExp e1 l1 d1 -> PreExp e2 l2 d2 +visitExp :: + forall l1 l2 e1 e2 d1 d2. + (l1 -> l2) + -> (e1 l1 d1 -> e2 l2 d2) + -> (d1 -> d2) + -> PreExp e1 l1 d1 + -> PreExp e2 l2 d2 visitExp _fl fe _fd exp0 = go exp0 - where - go :: (PreExp e1 l1 d1) -> (PreExp e2 l2 d2) - go ex = - case ex of - Ext x -> Ext (fe x) - _ -> _finishme + where + go :: (PreExp e1 l1 d1) -> (PreExp e2 l2 d2) + go ex = + case ex of + Ext x -> Ext (fe x) + _ -> _finishme -- | Substitute an expression in place of a variable. -subst :: HasSubstitutable e l d - => Var -> (PreExp e l d) -> (PreExp e l d) -> (PreExp e l d) +subst :: + HasSubstitutable e l d + => Var + -> (PreExp e l d) + -> (PreExp e l d) + -> (PreExp e l d) subst old new ex = - let go = subst old new in - case ex of - VarE v | v == old -> new - | otherwise -> VarE v - LitE _ -> ex - CharE{} -> ex - FloatE{} -> ex - LitSymE _ -> ex - AppE v loc ls -> AppE v loc (map go ls) - PrimAppE p ls -> PrimAppE p $ L.map go ls - LetE (v,loc,t,rhs) bod | v == old -> LetE (v,loc,t,go rhs) bod - | otherwise -> LetE (v,loc,t,go rhs) (go bod) - ProjE i e -> ProjE i (go e) - CaseE e ls -> - CaseE (go e) (L.map f ls) - where f (c,vs,er) = if L.elem old (L.map fst vs) - then (c,vs,er) - else (c,vs,go er) - MkProdE ls -> MkProdE $ L.map go ls - DataConE loc k ls -> DataConE loc k $ L.map go ls - TimeIt e t b -> TimeIt (go e) t b - IfE a b c -> IfE (go a) (go b) (go c) - - SpawnE v loc ls -> SpawnE v loc (map go ls) - SyncE -> SyncE - - MapE (v,t,rhs) bod | v == old -> MapE (v,t, rhs) (go bod) - | otherwise -> MapE (v,t, go rhs) (go bod) - FoldE (v1,t1,r1) (v2,t2,r2) bod -> - let r1' = if v1 == old then r1 else go r1 - r2' = if v2 == old then r2 else go r2 - in FoldE (v1,t1,r1') (v2,t2,r2') (go bod) - - Ext ext -> Ext (gSubstExt old new ext) - - WithArenaE v e | v == old -> WithArenaE v e - | otherwise -> WithArenaE v (go e) + let go = subst old new + in case ex of + VarE v + | v == old -> new + | otherwise -> VarE v + LitE _ -> ex + CharE {} -> ex + FloatE {} -> ex + LitSymE _ -> ex + AppE v loc ls -> AppE v loc (map go ls) + PrimAppE p ls -> PrimAppE p $ L.map go ls + LetE (v, loc, t, rhs) bod + | v == old -> LetE (v, loc, t, go rhs) bod + | otherwise -> LetE (v, loc, t, go rhs) (go bod) + ProjE i e -> ProjE i (go e) + CaseE e ls -> CaseE (go e) (L.map f ls) + where f (c, vs, er) = + if L.elem old (L.map fst vs) + then (c, vs, er) + else (c, vs, go er) + MkProdE ls -> MkProdE $ L.map go ls + DataConE loc k ls -> DataConE loc k $ L.map go ls + TimeIt e t b -> TimeIt (go e) t b + IfE a b c -> IfE (go a) (go b) (go c) + SpawnE v loc ls -> SpawnE v loc (map go ls) + SyncE -> SyncE + MapE (v, t, rhs) bod + | v == old -> MapE (v, t, rhs) (go bod) + | otherwise -> MapE (v, t, go rhs) (go bod) + FoldE (v1, t1, r1) (v2, t2, r2) bod -> + let r1' = + if v1 == old + then r1 + else go r1 + r2' = + if v2 == old + then r2 + else go r2 + in FoldE (v1, t1, r1') (v2, t2, r2') (go bod) + Ext ext -> Ext (gSubstExt old new ext) + WithArenaE v e + | v == old -> WithArenaE v e + | otherwise -> WithArenaE v (go e) -- | Expensive 'subst' that looks for a whole matching sub-EXPRESSION. -- If the old expression is a variable, this still avoids going under binder. -substE :: HasSubstitutable e l d - => (PreExp e l d) -> (PreExp e l d) -> (PreExp e l d) -> (PreExp e l d) +substE :: + HasSubstitutable e l d + => (PreExp e l d) + -> (PreExp e l d) + -> (PreExp e l d) + -> (PreExp e l d) substE old new ex = - let go = substE old new in - case ex of - _ | ex == old -> new - - VarE v -> VarE v - LitE _ -> ex - CharE _ -> ex - FloatE{} -> ex - LitSymE _ -> ex - AppE v loc ls -> AppE v loc (map go ls) - PrimAppE p ls -> PrimAppE p $ L.map go ls - LetE (v,loc,t,rhs) bod | (VarE v) == old -> LetE (v,loc,t,go rhs) bod - | otherwise -> LetE (v,loc,t,go rhs) (go bod) - - ProjE i e -> ProjE i (go e) - CaseE e ls -> CaseE (go e) (L.map (\(c,vs,er) -> (c,vs,go er)) ls) - MkProdE ls -> MkProdE $ L.map go ls - DataConE loc k ls -> DataConE loc k $ L.map go ls - TimeIt e t b -> TimeIt (go e) t b - IfE a b c -> IfE (go a) (go b) (go c) - SpawnE v loc ls -> SpawnE v loc (map go ls) - SyncE -> SyncE - MapE (v,t,rhs) bod | VarE v == old -> MapE (v,t, rhs) (go bod) - | otherwise -> MapE (v,t, go rhs) (go bod) - FoldE (v1,t1,r1) (v2,t2,r2) bod -> - let r1' = if VarE v1 == old then r1 else go r1 - r2' = if VarE v2 == old then r2 else go r2 - in FoldE (v1,t1,r1') (v2,t2,r2') (go bod) - - Ext ext -> Ext (gSubstEExt old new ext) - - WithArenaE v e | (VarE v) == old -> WithArenaE v e - | otherwise -> WithArenaE v (go e) + let go = substE old new + in case ex of + _ + | ex == old -> new + VarE v -> VarE v + LitE _ -> ex + CharE _ -> ex + FloatE {} -> ex + LitSymE _ -> ex + AppE v loc ls -> AppE v loc (map go ls) + PrimAppE p ls -> PrimAppE p $ L.map go ls + LetE (v, loc, t, rhs) bod + | (VarE v) == old -> LetE (v, loc, t, go rhs) bod + | otherwise -> LetE (v, loc, t, go rhs) (go bod) + ProjE i e -> ProjE i (go e) + CaseE e ls -> CaseE (go e) (L.map (\(c, vs, er) -> (c, vs, go er)) ls) + MkProdE ls -> MkProdE $ L.map go ls + DataConE loc k ls -> DataConE loc k $ L.map go ls + TimeIt e t b -> TimeIt (go e) t b + IfE a b c -> IfE (go a) (go b) (go c) + SpawnE v loc ls -> SpawnE v loc (map go ls) + SyncE -> SyncE + MapE (v, t, rhs) bod + | VarE v == old -> MapE (v, t, rhs) (go bod) + | otherwise -> MapE (v, t, go rhs) (go bod) + FoldE (v1, t1, r1) (v2, t2, r2) bod -> + let r1' = + if VarE v1 == old + then r1 + else go r1 + r2' = + if VarE v2 == old + then r2 + else go r2 + in FoldE (v1, t1, r1') (v2, t2, r2') (go bod) + Ext ext -> Ext (gSubstEExt old new ext) + WithArenaE v e + | (VarE v) == old -> WithArenaE v e + | otherwise -> WithArenaE v (go e) -- | Does the expression contain a TimeIt form? hasTimeIt :: (PreExp e l d) -> Bool hasTimeIt rhs = - case rhs of - TimeIt _ _ _ -> True - DataConE{} -> False - VarE _ -> False - LitE _ -> False - CharE _ -> False - FloatE{} -> False - LitSymE _ -> False - AppE _ _ _ -> False - PrimAppE _ _ -> False - ProjE _ e -> hasTimeIt e - MkProdE ls -> any hasTimeIt ls - IfE a b c -> hasTimeIt a || hasTimeIt b || hasTimeIt c - CaseE _ ls -> any hasTimeIt [ e | (_,_,e) <- ls ] - LetE (_,_,_,e1) e2 -> hasTimeIt e1 || hasTimeIt e2 - SpawnE _ _ _ -> False - SyncE -> False - MapE (_,_,e1) e2 -> hasTimeIt e1 || hasTimeIt e2 - FoldE (_,_,e1) (_,_,e2) e3 -> hasTimeIt e1 || hasTimeIt e2 || hasTimeIt e3 - Ext _ -> False - WithArenaE _ e -> hasTimeIt e + case rhs of + TimeIt _ _ _ -> True + DataConE {} -> False + VarE _ -> False + LitE _ -> False + CharE _ -> False + FloatE {} -> False + LitSymE _ -> False + AppE _ _ _ -> False + PrimAppE _ _ -> False + ProjE _ e -> hasTimeIt e + MkProdE ls -> any hasTimeIt ls + IfE a b c -> hasTimeIt a || hasTimeIt b || hasTimeIt c + CaseE _ ls -> any hasTimeIt [e | (_, _, e) <- ls] + LetE (_, _, _, e1) e2 -> hasTimeIt e1 || hasTimeIt e2 + SpawnE _ _ _ -> False + SyncE -> False + MapE (_, _, e1) e2 -> hasTimeIt e1 || hasTimeIt e2 + FoldE (_, _, e1) (_, _, e2) e3 -> + hasTimeIt e1 || hasTimeIt e2 || hasTimeIt e3 + Ext _ -> False + WithArenaE _ e -> hasTimeIt e hasSpawnsProg :: Prog (PreExp e l d) -> Bool hasSpawnsProg (Prog _ fundefs mainExp) = - any (\FunDef{funBody} -> hasSpawns funBody) (M.elems fundefs) || - case mainExp of - Nothing -> False - Just (e,_ty) -> hasSpawns e + any (\FunDef {funBody} -> hasSpawns funBody) (M.elems fundefs) || + case mainExp of + Nothing -> False + Just (e, _ty) -> hasSpawns e + -- | Does the expression contain a SpawnE form? hasSpawns :: (PreExp e l d) -> Bool hasSpawns rhs = - case rhs of - DataConE{} -> False - VarE{} -> False - LitE{} -> False - CharE{} -> False - FloatE{} -> False - LitSymE{} -> False - AppE{} -> False - PrimAppE{} -> False - ProjE _ e -> hasSpawns e - MkProdE ls -> any hasSpawns ls - IfE a b c -> hasSpawns a || hasSpawns b || hasSpawns c - CaseE _ ls -> any hasSpawns [ e | (_,_,e) <- ls ] - LetE (_,_,_,e1) e2 -> hasSpawns e1 || hasSpawns e2 - SpawnE{} -> True - SyncE -> False - TimeIt e _ _ -> hasSpawns e - MapE (_,_,e1) e2 -> hasSpawns e1 || hasSpawns e2 - FoldE (_,_,e1) (_,_,e2) e3 -> - hasSpawns e1 || hasSpawns e2 || hasSpawns e3 - Ext _ -> False - WithArenaE _ e -> hasSpawns e + case rhs of + DataConE {} -> False + VarE {} -> False + LitE {} -> False + CharE {} -> False + FloatE {} -> False + LitSymE {} -> False + AppE {} -> False + PrimAppE {} -> False + ProjE _ e -> hasSpawns e + MkProdE ls -> any hasSpawns ls + IfE a b c -> hasSpawns a || hasSpawns b || hasSpawns c + CaseE _ ls -> any hasSpawns [e | (_, _, e) <- ls] + LetE (_, _, _, e1) e2 -> hasSpawns e1 || hasSpawns e2 + SpawnE {} -> True + SyncE -> False + TimeIt e _ _ -> hasSpawns e + MapE (_, _, e1) e2 -> hasSpawns e1 || hasSpawns e2 + FoldE (_, _, e1) (_, _, e2) e3 -> + hasSpawns e1 || hasSpawns e2 || hasSpawns e3 + Ext _ -> False + WithArenaE _ e -> hasSpawns e + -- | Project something which had better not be the first thing in a tuple. -projNonFirst :: (Out l, Out d, Out (e l d)) => Int -> (PreExp e l d) -> (PreExp e l d) -projNonFirst 0 e = error $ "projNonFirst: expected nonzero index into expr: " ++ sdoc e +projNonFirst :: + (Out l, Out d, Out (e l d)) => Int -> (PreExp e l d) -> (PreExp e l d) +projNonFirst 0 e = + error $ "projNonFirst: expected nonzero index into expr: " ++ sdoc e projNonFirst i e = ProjE i e + -- | Smart constructor that immediately destroys products if it can: -- Does NOT avoid single-element tuples. mkProj :: Int -> (PreExp e l d) -> (PreExp e l d) mkProj ix (MkProdE ls) = ls !! ix -mkProj ix e = (ProjE ix e) +mkProj ix e = (ProjE ix e) + -- | Make a product type while avoiding unary products. -mkProd :: [(PreExp e l d)]-> (PreExp e l d) +mkProd :: [(PreExp e l d)] -> (PreExp e l d) mkProd [e] = e mkProd ls = MkProdE ls + -- | Make a nested series of lets. -mkLets :: [(Var, [loc], dec, (PreExp ext loc dec))] -> (PreExp ext loc dec) -> (PreExp ext loc dec) +mkLets :: + [(Var, [loc], dec, (PreExp ext loc dec))] + -> (PreExp ext loc dec) + -> (PreExp ext loc dec) mkLets [] bod = bod mkLets (b:bs) bod = LetE b (mkLets bs bod) + -- | Helper function that lifts out Lets on the RHS of other Lets. -- Absolutely requires unique names. mkLetE :: (Var, [l], d, (PreExp e l d)) -> (PreExp e l d) -> (PreExp e l d) -mkLetE (vr,lvs,ty,(LetE bnd e)) bod = mkLetE bnd $ mkLetE (vr,lvs,ty,e) bod +mkLetE (vr, lvs, ty, (LetE bnd e)) bod = + mkLetE bnd $ mkLetE (vr, lvs, ty, e) bod mkLetE bnd bod = LetE bnd bod + -- | Alternative version of L1.mkLets that also flattens -flatLets :: [(Var,[l],d,(PreExp e l d))] -> (PreExp e l d) -> (PreExp e l d) -flatLets [] bod = bod +flatLets :: [(Var, [l], d, (PreExp e l d))] -> (PreExp e l d) -> (PreExp e l d) +flatLets [] bod = bod flatLets (b:bs) bod = mkLetE b (flatLets bs bod) tuplizeRefs :: Var -> [Var] -> [d] -> (PreExp e l d) -> (PreExp e l d) tuplizeRefs ref vars tys = mkLets $ - L.map (\(v,ty,ix) -> (v,[],ty,mkProj ix (VarE ref))) (L.zip3 vars tys [0..]) + L.map + (\(v, ty, ix) -> (v, [], ty, mkProj ix (VarE ref))) + (L.zip3 vars tys [0 ..]) + -------------------------------------------------------------------------------- -- Helpers operating on types -------------------------------------------------------------------------------- -- | Same as mkProd, at the type level -mkProdTy :: [UrTy a]-> UrTy a +mkProdTy :: [UrTy a] -> UrTy a mkProdTy [t] = t mkProdTy ls = ProdTy ls projTy :: (Out a) => Int -> UrTy a -> UrTy a -projTy 0 (ProdTy (ty:_)) = ty -projTy n (ProdTy (_:tys)) = projTy (n-1) (ProdTy tys) +projTy 0 (ProdTy (ty:_)) = ty +projTy n (ProdTy (_:tys)) = projTy (n - 1) (ProdTy tys) projTy _ ty = error $ "projTy: " ++ sdoc ty ++ " is not a projection!" + -- | A makeshift void type. voidTy :: UrTy a voidTy = ProdTy [] + -- | Are values of this type tuples ? isProdTy :: UrTy a -> Bool -isProdTy ProdTy{} = True -isProdTy _ = False +isProdTy ProdTy {} = True +isProdTy _ = False + -- | Do values of this type contain nested tuples ? isNestedProdTy :: UrTy a -> Bool isNestedProdTy ty = case ty of - ProdTy tys -> if any isProdTy tys - then True - else False + ProdTy tys -> + if any isProdTy tys + then True + else False _ -> False + -- | Are values of this type Packed ? isPackedTy :: UrTy a -> Bool -isPackedTy PackedTy{} = True -isPackedTy _ = False +isPackedTy PackedTy {} = True +isPackedTy _ = False isScalarTy :: UrTy a -> Bool -isScalarTy IntTy = True -isScalarTy CharTy = True -isScalarTy SymTy = True -isScalarTy BoolTy = True -isScalarTy FloatTy= True -isScalarTy _ = False +isScalarTy IntTy = True +isScalarTy CharTy = True +isScalarTy SymTy = True +isScalarTy BoolTy = True +isScalarTy FloatTy = True +isScalarTy _ = False + -- | Lists of scalars or flat products of scalars are allowed. isValidListElemTy :: UrTy a -> Bool isValidListElemTy ty | isScalarTy ty = True - | otherwise = case ty of - VectorTy elty -> isValidListElemTy elty - ListTy elty -> isValidListElemTy elty - ProdTy tys -> all isScalarTy tys - _ -> False + | otherwise = + case ty of + VectorTy elty -> isValidListElemTy elty + ListTy elty -> isValidListElemTy elty + ProdTy tys -> all isScalarTy tys + _ -> False + -- | Do values of this type contain packed data? hasPacked :: Show a => UrTy a -> Bool hasPacked t = case t of - PackedTy{} -> True - ProdTy ls -> any hasPacked ls - SymTy -> False - BoolTy -> False - IntTy -> False - CharTy -> False - FloatTy -> False - SymDictTy _ _ -> False -- hasPacked ty - PDictTy k v -> hasPacked k || hasPacked v - VectorTy ty -> hasPacked ty - ListTy ty -> hasPacked ty - PtrTy -> False - CursorTy -> False - ArenaTy -> False - SymSetTy -> False - SymHashTy -> False - IntHashTy -> False + PackedTy {} -> True + ProdTy ls -> any hasPacked ls + SymTy -> False + BoolTy -> False + IntTy -> False + CharTy -> False + FloatTy -> False + SymDictTy _ _ -> False -- hasPacked ty + PDictTy k v -> hasPacked k || hasPacked v + VectorTy ty -> hasPacked ty + ListTy ty -> hasPacked ty + PtrTy -> False + CursorTy -> False + ArenaTy -> False + SymSetTy -> False + SymHashTy -> False + IntHashTy -> False -- | Get all packed types in a type. getPackedTys :: Show a => UrTy a -> [UrTy a] getPackedTys t = case t of - PackedTy{} -> [t] - ProdTy ls -> concatMap getPackedTys ls - SymTy -> [] - BoolTy -> [] - IntTy -> [] - CharTy -> [] - FloatTy -> [] - SymDictTy _ _ -> [] -- getPackedTys ty - PDictTy k v -> getPackedTys k ++ getPackedTys v - VectorTy ty -> getPackedTys ty - ListTy ty -> getPackedTys ty - PtrTy -> [] - CursorTy -> [] - ArenaTy -> [] - SymSetTy -> [] - SymHashTy -> [] - IntHashTy -> [] + PackedTy {} -> [t] + ProdTy ls -> concatMap getPackedTys ls + SymTy -> [] + BoolTy -> [] + IntTy -> [] + CharTy -> [] + FloatTy -> [] + SymDictTy _ _ -> [] -- getPackedTys ty + PDictTy k v -> getPackedTys k ++ getPackedTys v + VectorTy ty -> getPackedTys ty + ListTy ty -> getPackedTys ty + PtrTy -> [] + CursorTy -> [] + ArenaTy -> [] + SymSetTy -> [] + SymHashTy -> [] + IntHashTy -> [] + -- | Provide a size in bytes, if it is statically known. sizeOfTy :: UrTy a -> Maybe Int sizeOfTy t = case t of - PackedTy{} -> Nothing + PackedTy {} -> Nothing ProdTy ls -> sum <$> mapM sizeOfTy ls SymDictTy _ _ -> Just 8 -- Always a pointer. PDictTy _ _ -> Just 8 -- Always a pointer. @@ -530,241 +645,246 @@ sizeOfTy t = FloatTy -> Just 4 SymTy -> Just 8 BoolTy -> Just 1 - VectorTy{} -> Just 8 -- Always a pointer. - ListTy{} -> Just 8 -- Always a pointer. - PtrTy{} -> Just 8 -- Assuming 64 bit - CursorTy{} -> Just 8 + VectorTy {} -> Just 8 -- Always a pointer. + ListTy {} -> Just 8 -- Always a pointer. + PtrTy {} -> Just 8 -- Assuming 64 bit + CursorTy {} -> Just 8 ArenaTy -> Just 8 SymSetTy -> error "sizeOfTy: SymSetTy not handled." SymHashTy -> error "sizeOfTy: SymHashTy not handled." IntHashTy -> error "sizeOfTy: SymHashTy not handled." + -- | Type of the arguments for a primitive operation. primArgsTy :: Prim (UrTy a) -> [UrTy a] primArgsTy p = case p of - AddP -> [IntTy, IntTy] - SubP -> [IntTy, IntTy] - MulP -> [IntTy, IntTy] - DivP -> [IntTy, IntTy] - ModP -> [IntTy, IntTy] - ExpP -> [IntTy, IntTy] - FRandP -> [] - FAddP -> [FloatTy, FloatTy] - FSubP -> [FloatTy, FloatTy] - FMulP -> [FloatTy, FloatTy] - FDivP -> [FloatTy, FloatTy] - FExpP -> [FloatTy, FloatTy] - FSqrtP -> [FloatTy] - FTanP -> [FloatTy] - FloatToIntP -> [FloatTy] - IntToFloatP -> [IntTy] - RandP -> [] - EqSymP -> [SymTy, SymTy] - EqBenchProgP _ -> [] - EqIntP -> [IntTy, IntTy] - EqFloatP-> [FloatTy, FloatTy] - EqCharP -> [CharTy, CharTy] - LtP -> [IntTy, IntTy] - GtP -> [IntTy, IntTy] - LtEqP-> [IntTy, IntTy] - GtEqP-> [IntTy, IntTy] - FLtP -> [FloatTy, FloatTy] - FGtP -> [FloatTy, FloatTy] - FLtEqP-> [FloatTy, FloatTy] - FGtEqP-> [FloatTy, FloatTy] - OrP -> [BoolTy, BoolTy] - AndP -> [BoolTy, BoolTy] - Gensym -> [] - MkTrue -> [] - MkFalse -> [] - SizeParam -> [] - IsBig -> [IntTy, PackedTy "HOLE" _error] - DictEmptyP _ty -> [] - DictInsertP _ty -> error "primArgsTy: dicts not handled yet" - DictLookupP _ty -> error "primArgsTy: dicts not handled yet" - DictHasKeyP _ty -> error "primArgsTy: dicts not handled yet" - VAllocP _elty -> [IntTy] - VFreeP elty -> [VectorTy elty] - VFree2P elty -> [VectorTy elty] - VLengthP elty -> [VectorTy elty] - VNthP elty -> [VectorTy elty, IntTy] - VSliceP elty -> [IntTy, IntTy, VectorTy elty] - InplaceVUpdateP elty -> [VectorTy elty, IntTy, elty] - VConcatP elty -> [VectorTy (VectorTy elty)] + AddP -> [IntTy, IntTy] + SubP -> [IntTy, IntTy] + MulP -> [IntTy, IntTy] + DivP -> [IntTy, IntTy] + ModP -> [IntTy, IntTy] + ExpP -> [IntTy, IntTy] + FRandP -> [] + FAddP -> [FloatTy, FloatTy] + FSubP -> [FloatTy, FloatTy] + FMulP -> [FloatTy, FloatTy] + FDivP -> [FloatTy, FloatTy] + FExpP -> [FloatTy, FloatTy] + FSqrtP -> [FloatTy] + FTanP -> [FloatTy] + FloatToIntP -> [FloatTy] + IntToFloatP -> [IntTy] + RandP -> [] + EqSymP -> [SymTy, SymTy] + EqBenchProgP _ -> [] + EqIntP -> [IntTy, IntTy] + EqFloatP -> [FloatTy, FloatTy] + EqCharP -> [CharTy, CharTy] + LtP -> [IntTy, IntTy] + GtP -> [IntTy, IntTy] + LtEqP -> [IntTy, IntTy] + GtEqP -> [IntTy, IntTy] + FLtP -> [FloatTy, FloatTy] + FGtP -> [FloatTy, FloatTy] + FLtEqP -> [FloatTy, FloatTy] + FGtEqP -> [FloatTy, FloatTy] + OrP -> [BoolTy, BoolTy] + AndP -> [BoolTy, BoolTy] + Gensym -> [] + MkTrue -> [] + MkFalse -> [] + SizeParam -> [] + IsBig -> [IntTy, PackedTy "HOLE" _error] + DictEmptyP _ty -> [] + DictInsertP _ty -> error "primArgsTy: dicts not handled yet" + DictLookupP _ty -> error "primArgsTy: dicts not handled yet" + DictHasKeyP _ty -> error "primArgsTy: dicts not handled yet" + VAllocP _elty -> [IntTy] + VFreeP elty -> [VectorTy elty] + VFree2P elty -> [VectorTy elty] + VLengthP elty -> [VectorTy elty] + VNthP elty -> [VectorTy elty, IntTy] + VSliceP elty -> [IntTy, IntTy, VectorTy elty] + InplaceVUpdateP elty -> [VectorTy elty, IntTy, elty] + VConcatP elty -> [VectorTy (VectorTy elty)] -- The voidTy is just a placeholder. -- We don't have a type for function pointers. - VSortP elty -> [VectorTy elty, voidTy] - InplaceVSortP elty -> [VectorTy elty, voidTy] - VMergeP elty -> [VectorTy elty, VectorTy elty] - PDictInsertP kty vty -> [kty, vty, PDictTy kty vty] - PDictLookupP kty vty -> [kty, PDictTy kty vty] + VSortP elty -> [VectorTy elty, voidTy] + InplaceVSortP elty -> [VectorTy elty, voidTy] + VMergeP elty -> [VectorTy elty, VectorTy elty] + PDictInsertP kty vty -> [kty, vty, PDictTy kty vty] + PDictLookupP kty vty -> [kty, PDictTy kty vty] PDictAllocP _kty _vty -> [] - PDictHasKeyP kty vty -> [kty, PDictTy kty vty] - PDictForkP kty vty -> [PDictTy kty vty] - PDictJoinP kty vty -> [PDictTy kty vty, PDictTy kty vty] - LLAllocP _elty -> [] - LLIsEmptyP elty -> [ListTy elty] - LLConsP elty -> [elty, ListTy elty] - LLHeadP elty -> [ListTy elty] - LLTailP elty -> [ListTy elty] - LLFreeP elty -> [ListTy elty] - LLFree2P elty -> [ListTy elty] - LLCopyP elty -> [ListTy elty] - GetNumProcessors -> [] - PrintInt -> [IntTy] - PrintChar -> [CharTy] - PrintFloat -> [FloatTy] - PrintBool -> [BoolTy] - PrintSym -> [SymTy] - ReadInt -> [] - SymSetEmpty -> [] - SymSetInsert -> [SymSetTy, SymTy] - SymSetContains -> [SymSetTy, SymTy] - SymHashEmpty -> [] - SymHashInsert -> [SymHashTy,SymTy,SymTy] - SymHashLookup -> [SymHashTy,SymTy] - SymHashContains -> [SymHashTy,SymTy] - IntHashEmpty -> [] - IntHashInsert -> [IntHashTy,SymTy,IntTy] - IntHashLookup -> [IntHashTy,SymTy] - ReadPackedFile{} -> [] - WritePackedFile _ ty -> [ty] - ReadArrayFile{} -> [] - (ErrorP _ _) -> [] - RequestEndOf -> error "primArgsTy: RequestEndOf not handled yet" - RequestSizeOf -> error "primArgsTy: RequestSizeOf not handled yet" - Write3dPpmFile{} -> error "primArgsTy: Write3dPpmFile not handled yet" + PDictHasKeyP kty vty -> [kty, PDictTy kty vty] + PDictForkP kty vty -> [PDictTy kty vty] + PDictJoinP kty vty -> [PDictTy kty vty, PDictTy kty vty] + LLAllocP _elty -> [] + LLIsEmptyP elty -> [ListTy elty] + LLConsP elty -> [elty, ListTy elty] + LLHeadP elty -> [ListTy elty] + LLTailP elty -> [ListTy elty] + LLFreeP elty -> [ListTy elty] + LLFree2P elty -> [ListTy elty] + LLCopyP elty -> [ListTy elty] + GetNumProcessors -> [] + PrintInt -> [IntTy] + PrintChar -> [CharTy] + PrintFloat -> [FloatTy] + PrintBool -> [BoolTy] + PrintSym -> [SymTy] + ReadInt -> [] + SymSetEmpty -> [] + SymSetInsert -> [SymSetTy, SymTy] + SymSetContains -> [SymSetTy, SymTy] + SymHashEmpty -> [] + SymHashInsert -> [SymHashTy, SymTy, SymTy] + SymHashLookup -> [SymHashTy, SymTy] + SymHashContains -> [SymHashTy, SymTy] + IntHashEmpty -> [] + IntHashInsert -> [IntHashTy, SymTy, IntTy] + IntHashLookup -> [IntHashTy, SymTy] + ReadPackedFile {} -> [] + WritePackedFile _ ty -> [ty] + ReadArrayFile {} -> [] + (ErrorP _ _) -> [] + RequestEndOf -> error "primArgsTy: RequestEndOf not handled yet" + RequestSizeOf -> error "primArgsTy: RequestSizeOf not handled yet" + Write3dPpmFile {} -> error "primArgsTy: Write3dPpmFile not handled yet" + -- | Return type for a primitive operation. primRetTy :: Prim (UrTy a) -> (UrTy a) primRetTy p = case p of - AddP -> IntTy - SubP -> IntTy - MulP -> IntTy - DivP -> IntTy - ModP -> IntTy - ExpP -> IntTy - FRandP-> FloatTy - FAddP -> FloatTy - FSubP -> FloatTy - FMulP -> FloatTy - FDivP -> FloatTy - FExpP -> FloatTy - FSqrtP-> FloatTy - FTanP -> FloatTy - FloatToIntP -> IntTy - IntToFloatP -> FloatTy - RandP-> IntTy - Gensym -> SymTy - EqSymP -> BoolTy - EqBenchProgP _ -> BoolTy - EqIntP -> BoolTy - EqFloatP-> BoolTy - EqCharP -> BoolTy - LtP -> BoolTy - GtP -> BoolTy - LtEqP-> BoolTy - GtEqP-> BoolTy - FLtP -> BoolTy - FGtP -> BoolTy - FLtEqP-> BoolTy - FGtEqP-> BoolTy - OrP -> BoolTy - AndP -> BoolTy - MkTrue -> BoolTy - MkFalse -> BoolTy - SizeParam -> IntTy - IsBig -> BoolTy - DictHasKeyP _ -> BoolTy - DictEmptyP ty -> SymDictTy Nothing $ stripTyLocs ty - DictInsertP ty -> SymDictTy Nothing $ stripTyLocs ty - DictLookupP ty -> ty - VAllocP elty -> VectorTy elty - VFreeP _elty -> ProdTy [] - VFree2P _elty -> ProdTy [] - VLengthP _elty -> IntTy - VNthP elty -> elty - VSliceP elty -> VectorTy elty - InplaceVUpdateP elty -> VectorTy elty - VConcatP elty -> VectorTy elty - VSortP elty -> VectorTy elty - InplaceVSortP elty -> VectorTy elty - VMergeP elty -> VectorTy elty - PDictInsertP kty vty -> PDictTy kty vty - PDictLookupP _kty vty -> vty - PDictAllocP kty vty -> PDictTy kty vty - PDictHasKeyP _kty _vty -> BoolTy - PDictForkP kty vty -> ProdTy [PDictTy kty vty, PDictTy kty vty] - PDictJoinP kty vty -> PDictTy kty vty - LLAllocP elty -> ListTy elty - LLIsEmptyP _elty -> BoolTy - LLConsP elty -> ListTy elty - LLHeadP elty -> elty - LLTailP elty -> ListTy elty - LLFreeP _elty -> ProdTy [] - LLFree2P _elty -> ProdTy [] - LLCopyP elty -> ListTy elty - GetNumProcessors -> IntTy - PrintInt -> ProdTy [] - PrintChar -> ProdTy [] - PrintFloat -> ProdTy [] - PrintBool -> ProdTy [] - PrintSym -> ProdTy [] - ReadInt -> IntTy - SymSetEmpty -> SymSetTy - SymSetInsert -> SymSetTy - SymSetContains -> BoolTy - SymHashEmpty -> SymHashTy - SymHashInsert -> SymHashTy - SymHashLookup -> SymTy - SymHashContains -> BoolTy - IntHashEmpty -> IntHashTy - IntHashInsert -> IntHashTy - IntHashLookup -> IntTy - (ErrorP _ ty) -> ty + AddP -> IntTy + SubP -> IntTy + MulP -> IntTy + DivP -> IntTy + ModP -> IntTy + ExpP -> IntTy + FRandP -> FloatTy + FAddP -> FloatTy + FSubP -> FloatTy + FMulP -> FloatTy + FDivP -> FloatTy + FExpP -> FloatTy + FSqrtP -> FloatTy + FTanP -> FloatTy + FloatToIntP -> IntTy + IntToFloatP -> FloatTy + RandP -> IntTy + Gensym -> SymTy + EqSymP -> BoolTy + EqBenchProgP _ -> BoolTy + EqIntP -> BoolTy + EqFloatP -> BoolTy + EqCharP -> BoolTy + LtP -> BoolTy + GtP -> BoolTy + LtEqP -> BoolTy + GtEqP -> BoolTy + FLtP -> BoolTy + FGtP -> BoolTy + FLtEqP -> BoolTy + FGtEqP -> BoolTy + OrP -> BoolTy + AndP -> BoolTy + MkTrue -> BoolTy + MkFalse -> BoolTy + SizeParam -> IntTy + IsBig -> BoolTy + DictHasKeyP _ -> BoolTy + DictEmptyP ty -> SymDictTy Nothing $ stripTyLocs ty + DictInsertP ty -> SymDictTy Nothing $ stripTyLocs ty + DictLookupP ty -> ty + VAllocP elty -> VectorTy elty + VFreeP _elty -> ProdTy [] + VFree2P _elty -> ProdTy [] + VLengthP _elty -> IntTy + VNthP elty -> elty + VSliceP elty -> VectorTy elty + InplaceVUpdateP elty -> VectorTy elty + VConcatP elty -> VectorTy elty + VSortP elty -> VectorTy elty + InplaceVSortP elty -> VectorTy elty + VMergeP elty -> VectorTy elty + PDictInsertP kty vty -> PDictTy kty vty + PDictLookupP _kty vty -> vty + PDictAllocP kty vty -> PDictTy kty vty + PDictHasKeyP _kty _vty -> BoolTy + PDictForkP kty vty -> ProdTy [PDictTy kty vty, PDictTy kty vty] + PDictJoinP kty vty -> PDictTy kty vty + LLAllocP elty -> ListTy elty + LLIsEmptyP _elty -> BoolTy + LLConsP elty -> ListTy elty + LLHeadP elty -> elty + LLTailP elty -> ListTy elty + LLFreeP _elty -> ProdTy [] + LLFree2P _elty -> ProdTy [] + LLCopyP elty -> ListTy elty + GetNumProcessors -> IntTy + PrintInt -> ProdTy [] + PrintChar -> ProdTy [] + PrintFloat -> ProdTy [] + PrintBool -> ProdTy [] + PrintSym -> ProdTy [] + ReadInt -> IntTy + SymSetEmpty -> SymSetTy + SymSetInsert -> SymSetTy + SymSetContains -> BoolTy + SymHashEmpty -> SymHashTy + SymHashInsert -> SymHashTy + SymHashLookup -> SymTy + SymHashContains -> BoolTy + IntHashEmpty -> IntHashTy + IntHashInsert -> IntHashTy + IntHashLookup -> IntTy + (ErrorP _ ty) -> ty ReadPackedFile _ _ _ ty -> ty - WritePackedFile{} -> ProdTy [] + WritePackedFile {} -> ProdTy [] ReadArrayFile _ ty -> ty - RequestEndOf -> CursorTy - RequestSizeOf -> IntTy - Write3dPpmFile{} -> error "primRetTy: Write3dPpmFile not handled yet" + RequestEndOf -> CursorTy + RequestSizeOf -> IntTy + Write3dPpmFile {} -> error "primRetTy: Write3dPpmFile not handled yet" stripTyLocs :: UrTy a -> UrTy () stripTyLocs ty = case ty of - IntTy -> IntTy - CharTy -> CharTy - FloatTy -> FloatTy - SymTy -> SymTy - BoolTy -> BoolTy - ProdTy ls -> ProdTy $ L.map stripTyLocs ls + IntTy -> IntTy + CharTy -> CharTy + FloatTy -> FloatTy + SymTy -> SymTy + BoolTy -> BoolTy + ProdTy ls -> ProdTy $ L.map stripTyLocs ls SymDictTy v ty' -> SymDictTy v $ stripTyLocs ty' - PDictTy k v -> PDictTy (stripTyLocs k) (stripTyLocs v) + PDictTy k v -> PDictTy (stripTyLocs k) (stripTyLocs v) PackedTy tycon _ -> PackedTy tycon () - VectorTy ty' -> VectorTy $ stripTyLocs ty' - ListTy ty' -> ListTy $ stripTyLocs ty' - PtrTy -> PtrTy - CursorTy -> CursorTy - SymSetTy -> SymSetTy - SymHashTy -> SymHashTy - IntHashTy -> IntHashTy - ArenaTy -> ArenaTy + VectorTy ty' -> VectorTy $ stripTyLocs ty' + ListTy ty' -> ListTy $ stripTyLocs ty' + PtrTy -> PtrTy + CursorTy -> CursorTy + SymSetTy -> SymSetTy + SymHashTy -> SymHashTy + IntHashTy -> IntHashTy + ArenaTy -> ArenaTy + -- | Get the data constructor type from a type, failing if it's not packed tyToDataCon :: Show a => UrTy a -> DataCon tyToDataCon (PackedTy dcon _) = dcon tyToDataCon oth = error $ "tyToDataCon: " ++ show oth ++ " is not packed" + -- | Ensure that an expression is trivial. assertTriv :: (HasCallStack, Expression e) => e -> a -> a assertTriv e = if isTrivial e - then id - else error$ "Expected trivial argument, got: "++sdoc e + then id + else error $ "Expected trivial argument, got: " ++ sdoc e + -- | List version of 'assertTriv'. assertTrivs :: (HasCallStack, Expression e) => [e] -> a -> a -assertTrivs [] = id +assertTrivs [] = id assertTrivs (a:b) = assertTriv a . assertTrivs b diff --git a/gibbon-compiler/src/Gibbon/Language/Syntax.hs b/gibbon-compiler/src/Gibbon/Language/Syntax.hs index 366f0bace..14a61064a 100644 --- a/gibbon-compiler/src/Gibbon/Language/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/Language/Syntax.hs @@ -1,53 +1,111 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} module Gibbon.Language.Syntax - ( -- * Datatype definitions - DDefs, DataCon, TyCon, Tag, IsBoxed, DDef(..) - , lookupDDef, getConOrdering, getTyOfDataCon, lookupDataCon, lkp - , lookupDataCon', insertDD, emptyDD, fromListDD, isVoidDDef - - -- * Function definitions - , FunctionTy(..), FunDefs, FunDef(..), FunMeta(..), FunRec(..), FunInline(..) - , insertFD, fromListFD, initFunEnv - - -- * Programs - , Prog(..), progToEnv, getFunTy - - -- * Environments - , TyEnv, Env2(..), emptyEnv2 - , extendVEnv, extendsVEnv, lookupVEnv, extendFEnv, lookupFEnv - - -- * Expresssions and thier types - , PreExp(..), Prim(..), UrTy(..) - - -- * Functors for recursion-schemes - , PreExpF(..), PrimF(..), UrTyF(..) - - -- * Generic operations - , FreeVars(..), Expression(..), Binds, Flattenable(..) - , Simplifiable(..), SimplifiableExt(..), Typeable(..) - , Substitutable(..), SubstitutableExt(..), Renamable(..) - - -- * Helpers for writing instances - , HasSimplifiable, HasSimplifiableExt, HasSubstitutable, HasSubstitutableExt - , HasRenamable, HasOut, HasShow, HasEq, HasGeneric, HasNFData - - , -- * Interpreter - Interp(..), InterpExt(..), InterpProg(..), Value(..), ValEnv, InterpLog, - InterpM, runInterpM, execAndPrint - + ( DDefs + , DataCon + , TyCon + , Tag + , IsBoxed + , DDef(..) + , DataConMap + , UserOrdering(..) + , Constr(..) + , lookupDDef + , getConOrdering + , getTyOfDataCon + , lookupDataCon + , lkp + , lookupDataCon' + , insertDD + , emptyDD + , fromListDD + , isVoidDDef + +-- * Function definitions + , FunctionTy(..) + , FunDefs + , FunDef(..) + , FunMeta(..) + , FunRec(..) + , FunInline(..) + , FunOptimizeLayout(..) + , insertFD + , fromListFD + , initFunEnv + +-- * Programs + , Prog(..) + , progToEnv + , getFunTy + +-- * Environments + , TyEnv + , Env2(..) + , emptyEnv2 + , extendVEnv + , extendsVEnv + , lookupVEnv + , extendFEnv + , lookupFEnv + , unionEnv2 + , unionEnv2s + , lookupVEnv' + +-- * Expresssions and thier types + , PreExp(..) + , Prim(..) + , UrTy(..) + +-- * Functors for recursion-schemes + , PreExpF(..) + , PrimF(..) + , UrTyF(..) + +-- * Generic operations + , FreeVars(..) + , Expression(..) + , Binds + , Flattenable(..) + , Simplifiable(..) + , SimplifiableExt(..) + , Typeable(..) + , Substitutable(..) + , SubstitutableExt(..) + , Renamable(..) + +-- * Helpers for writing instances + , HasSimplifiable + , HasSimplifiableExt + , HasSubstitutable + , HasSubstitutableExt + , HasRenamable + , HasOut + , HasShow + , HasEq + , HasGeneric + , HasNFData + -- * Interpreter + , Interp(..) + , InterpExt(..) + , InterpProg(..) + , Value(..) + , ValEnv + , InterpLog + , InterpM + , runInterpM + , execAndPrint ) where import Control.DeepSeq @@ -55,33 +113,36 @@ import Control.Monad.State import Control.Monad.Writer #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(..)) +import Control.Monad.Fail (MonadFail (..)) #endif -import qualified Data.Map as M -import qualified Data.List as L -import qualified Data.Set as S -import Data.Word ( Word8 ) -import Data.Kind ( Type ) -import Text.PrettyPrint.GenericPretty +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Lazy.Char8 as B import Data.Functor.Foldable.TH -import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Builder (Builder) -import System.IO.Unsafe (unsafePerformIO) +import Data.Kind (Type) +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Word (Word8) +import System.IO.Unsafe (unsafePerformIO) +import Text.PrettyPrint.GenericPretty import Gibbon.Common + -------------------------------------------------------------------------------- -- Data type definitions -------------------------------------------------------------------------------- - type DDefs a = M.Map Var (DDef a) type DataCon = String -type TyCon = String -type Tag = Word8 + +type TyCon = String + +type Tag = Word8 type IsBoxed = Bool + -- | Data type definitions. -- -- Monomorphism: In the extreme case we can strip packed datatypes of @@ -93,139 +154,226 @@ type IsBoxed = Bool -- should be boxed. We say that a regular, pointer-based datatype has -- all-boxed fields, whereas a fully serialized datatype has no boxed -- fields. -data DDef a = DDef { tyName :: Var - , tyArgs :: [TyVar] - , dataCons :: [(DataCon,[(IsBoxed,a)])] } +data DDef a = + DDef + { tyName :: Var + , tyArgs :: [TyVar] + , dataCons :: [(DataCon, [(IsBoxed, a)])] + } deriving (Read, Show, Eq, Ord, Functor, Generic) -instance NFData a => NFData (DDef a) where +instance NFData a => NFData (DDef a) instance Out a => Out (DDef a) + -- | Lookup a ddef in its entirety lookupDDef :: Out a => DDefs a -> TyCon -> DDef a lookupDDef mp tycon = - case M.lookup (toVar tycon) mp of - Just x -> x - Nothing -> error $ "lookupDDef failed on symbol: "++ tycon ++"\nDDefs: "++sdoc mp + case M.lookup (toVar tycon) mp of + Just x -> x + Nothing -> + error $ "lookupDDef failed on symbol: " ++ tycon ++ "\nDDefs: " ++ sdoc mp + -- | Get the canonical ordering for data constructors, currently based -- on ordering in the original source code. Takes a TyCon as argument. getConOrdering :: Out a => DDefs a -> TyCon -> [DataCon] getConOrdering dd tycon = L.map fst dataCons - where DDef{dataCons} = lookupDDef dd tycon + where + DDef {dataCons} = lookupDDef dd tycon + -- | Lookup the name of the TyCon that goes with a given DataCon. -- Must be unique! getTyOfDataCon :: Out a => DDefs a -> DataCon -> TyCon getTyOfDataCon dds con = (fromVar . fst) $ lkp dds con + -- | Lookup the arguments to a data contstructor. lookupDataCon :: Out a => DDefs a -> DataCon -> [a] -lookupDataCon dds con = +lookupDataCon dds con -- dbgTrace 5 ("lookupDataCon -- "++sdoc(dds,con)) $ - L.map snd $ snd $ snd $ lkp dds con + = L.map snd $ snd $ snd $ lkp dds con + -- | Like 'lookupDataCon' but lookup arguments to a data contstructor for a -- specific instance of a datatype. -- -- lookupDataCon' (Maybe Int) Just = [Int] lookupDataCon' :: Out a => DDef a -> DataCon -> [a] -lookupDataCon' ddf@DDef{dataCons} con = - case L.filter ((== con) . fst) dataCons of - [] -> error$ "lookupDataCon': could not find constructor " ++ show con - ++ ", in datatype:\n " ++ sdoc ddf - [hit] -> L.map snd (snd hit) - _ -> error$ "lookupDataCon': found multiple occurences of constructor "++show con - ++ ", in datatype:\n " ++ sdoc ddf +lookupDataCon' ddf@DDef {dataCons} con = + case L.filter ((== con) . fst) dataCons of + [] -> + error $ + "lookupDataCon': could not find constructor " ++ + show con ++ ", in datatype:\n " ++ sdoc ddf + [hit] -> L.map snd (snd hit) + _ -> + error $ + "lookupDataCon': found multiple occurences of constructor " ++ + show con ++ ", in datatype:\n " ++ sdoc ddf + -- | Lookup a Datacon. Return (TyCon, (DataCon, [flds])) -lkp :: Out a => DDefs a -> DataCon -> (Var, (DataCon, [(IsBoxed,a)])) -lkp dds con = +lkp :: Out a => DDefs a -> DataCon -> (Var, (DataCon, [(IsBoxed, a)])) +lkp dds con -- Here we try to lookup in ALL datatypes, assuming unique datacons: - case [ (tycon,variant) - | (tycon, DDef{dataCons}) <- M.toList dds - , variant <- L.filter ((==con). fst) dataCons ] of - [] -> error$ "lookupDataCon: could not find constructor "++show con - ++", in datatypes:\n "++sdoc dds + = + case [ (tycon, variant) + | (tycon, DDef {dataCons}) <- M.toList dds + , variant <- L.filter ((== con) . fst) dataCons + ] of + [] -> + error $ + "lookupDataCon: could not find constructor " ++ + show con ++ ", in datatypes:\n " ++ sdoc dds [hit] -> hit - _ -> error$ "lookupDataCon: found multiple occurences of constructor "++show con - ++", in datatypes:\n "++sdoc dds - + _ -> + error $ + "lookupDataCon: found multiple occurences of constructor " ++ + show con ++ ", in datatypes:\n " ++ sdoc dds insertDD :: DDef a -> DDefs a -> DDefs a insertDD d = M.insertWith err' (tyName d) d where - err' = error $ "insertDD: data definition with duplicate name: "++show (tyName d) + err' = + error $ + "insertDD: data definition with duplicate name: " ++ show (tyName d) emptyDD :: DDefs a -emptyDD = M.empty +emptyDD = M.empty fromListDD :: [DDef a] -> DDefs a fromListDD = L.foldr insertDD M.empty + -- | Is this an empty type (like 'data Void' in Haskell) ? isVoidDDef :: DDef a -> Bool -isVoidDDef DDef{dataCons} = L.null dataCons +isVoidDDef DDef {dataCons} = L.null dataCons + -------------------------------------------------------------------------------- -- Function definitions -------------------------------------------------------------------------------- -- | A type family describing function types. -class (Out (ArrowTy ty), Show (ArrowTy ty)) => FunctionTy ty where +class (Out (ArrowTy ty), Show (ArrowTy ty)) => + FunctionTy ty + where type ArrowTy ty inTys :: ArrowTy ty -> [ty] outTy :: ArrowTy ty -> ty + -- | A set of top-level recursive function definitions. type FunDefs ex = M.Map Var (FunDef ex) -data FunRec = Rec | NotRec | TailRec +data FunRec + = Rec + | NotRec + | TailRec + deriving (Read, Show, Eq, Ord, Generic, NFData, Out) + +data FunInline + = Inline + | NoInline + | Inlineable + deriving (Read, Show, Eq, Ord, Generic, NFData, Out) + +data FunOptimizeLayout + = Single DataCon + | LayoutOptAll + | NoLayoutOpt deriving (Read, Show, Eq, Ord, Generic, NFData, Out) -data FunInline = Inline | NoInline | Inlineable + +-- StrongMap, first integer is old position, second is new. +data UserOrdering + = Strong Integer Integer + | Immediate Integer Integer deriving (Read, Show, Eq, Ord, Generic, NFData, Out) -data FunMeta = FunMeta - { funRec :: FunRec - , funInline :: FunInline + +-- Constraints and Edges used in the ILP solver +type Edge + = ( Integer {- from -} + , Integer {- to -} + ) + +data Constr + = Soft (Edge, Integer) + | Imm Edge + | Absolute Edge + deriving (Read, Show, Eq, Ord, Generic, NFData, Out) + +type DataConMap = M.Map DataCon [UserOrdering] + +data FunMeta = + FunMeta + { funRec :: FunRec + , funInline :: FunInline -- Whether the transitive closure of this function can trigger GC. - , funCanTriggerGC :: Bool - } + , funCanTriggerGC :: Bool + , funOptLayout :: FunOptimizeLayout + , userConstraintsDataCon :: Maybe DataConMap + } deriving (Read, Show, Eq, Ord, Generic, NFData, Out) + -- | A function definiton indexed by a type and expression. -data FunDef ex = FunDef { funName :: Var - , funArgs :: [Var] - , funTy :: ArrowTy (TyOf ex) - , funBody :: ex - , funMeta :: FunMeta - } - -deriving instance (Read ex, Read (ArrowTy (TyOf ex))) => Read (FunDef ex) -deriving instance (Show ex, Show (ArrowTy (TyOf ex))) => Show (FunDef ex) +data FunDef ex = + FunDef + { funName :: Var + , funArgs :: [Var] + , funTy :: ArrowTy (TyOf ex) + , funBody :: ex + , funMeta :: FunMeta + } + +deriving instance + (Read ex, Read (ArrowTy (TyOf ex))) => Read (FunDef ex) + +deriving instance + (Show ex, Show (ArrowTy (TyOf ex))) => Show (FunDef ex) + deriving instance (Eq ex, Eq (ArrowTy (TyOf ex))) => Eq (FunDef ex) -deriving instance (Ord ex, Ord (ArrowTy (TyOf ex))) => Ord (FunDef ex) + +deriving instance + (Ord ex, Ord (ArrowTy (TyOf ex))) => Ord (FunDef ex) + deriving instance Generic (FunDef ex) -deriving instance (Generic (ArrowTy (TyOf ex)), NFData ex, NFData (ArrowTy (TyOf ex))) => NFData (FunDef ex) -deriving instance (Generic (ArrowTy (TyOf ex)), Out ex, Out (ArrowTy (TyOf ex))) => Out (FunDef ex) + +deriving instance + (Generic (ArrowTy (TyOf ex)), NFData ex, + NFData (ArrowTy (TyOf ex))) => + NFData (FunDef ex) + +deriving instance + (Generic (ArrowTy (TyOf ex)), Out ex, Out (ArrowTy (TyOf ex))) => + Out (FunDef ex) + -- | Insert a 'FunDef' into 'FunDefs'. -- Raise an error if a function with the same name already exists. insertFD :: FunDef ex -> FunDefs ex -> FunDefs ex insertFD d = M.insertWith err' (funName d) d where - err' = error $ "insertFD: function definition with duplicate name: "++show (funName d) + err' = + error $ + "insertFD: function definition with duplicate name: " ++ show (funName d) + -- | fromListFD :: [FunDef ex] -> FunDefs ex fromListFD = L.foldr insertFD M.empty + -- | initFunEnv :: FunDefs a -> TyEnv (ArrowTy (TyOf a)) initFunEnv fds = M.map funTy fds + -------------------------------------------------------------------------------- -- Programs -------------------------------------------------------------------------------- @@ -236,37 +384,63 @@ initFunEnv fds = M.map funTy fds -- datatype. For running a pass benchmark, main will be Nothing and -- we will expect a "benchmark" function definition which consumes an -- appropriate packed AST datatype. -data Prog ex = Prog { ddefs :: DDefs (TyOf ex) - , fundefs :: FunDefs ex - , mainExp :: Maybe (ex, (TyOf ex)) - } +data Prog ex = + Prog + { ddefs :: DDefs (TyOf ex) + , fundefs :: FunDefs ex + , mainExp :: Maybe (ex, (TyOf ex)) + } + -- Since 'FunDef' is defined using a type family, we cannot use the deriving clause. -- Ryan Scott recommended using singletons-like alternative outlined here: -- https://lpaste.net/365181 -- -deriving instance (Read (TyOf ex), Read ex, Read (ArrowTy (TyOf ex))) => Read (Prog ex) -deriving instance (Show (TyOf ex), Show ex, Show (ArrowTy (TyOf ex))) => Show (Prog ex) -deriving instance (Eq (TyOf ex), Eq ex, Eq (ArrowTy (TyOf ex))) => Eq (Prog ex) -deriving instance (Ord (TyOf ex), Ord ex, Ord (ArrowTy (TyOf ex))) => Ord (Prog ex) +deriving instance + (Read (TyOf ex), Read ex, Read (ArrowTy (TyOf ex))) => + Read (Prog ex) + +deriving instance + (Show (TyOf ex), Show ex, Show (ArrowTy (TyOf ex))) => + Show (Prog ex) + +deriving instance + (Eq (TyOf ex), Eq ex, Eq (ArrowTy (TyOf ex))) => Eq (Prog ex) + +deriving instance + (Ord (TyOf ex), Ord ex, Ord (ArrowTy (TyOf ex))) => Ord (Prog ex) + deriving instance Generic (Prog ex) -deriving instance (NFData (TyOf ex), NFData (ArrowTy (TyOf ex)), NFData ex, Generic (ArrowTy (TyOf ex))) => NFData (Prog ex) + +deriving instance + (NFData (TyOf ex), NFData (ArrowTy (TyOf ex)), NFData ex, + Generic (ArrowTy (TyOf ex))) => + NFData (Prog ex) + -- | Abstract some of the differences of top level program types, by -- having a common way to extract an initial environment. The -- initial environment has types only for functions. progToEnv :: Prog a -> Env2 (TyOf a) -progToEnv Prog{fundefs} = Env2 M.empty (initFunEnv fundefs) +progToEnv Prog {fundefs} = Env2 M.empty (initFunEnv fundefs) + -- | Look up the input/output type of a top-level function binding. getFunTy :: Var -> Prog ex -> ArrowTy (TyOf ex) -getFunTy fn Prog{fundefs} = - case M.lookup fn fundefs of - Just f -> funTy f - Nothing -> error $ "getFunTy: L1 program does not contain binding for function: "++show fn +getFunTy fn Prog {fundefs} = + case M.lookup fn fundefs of + Just f -> funTy f + Nothing -> + error $ + "getFunTy: L1 program does not contain binding for function: " ++ show fn + +instance ( Generic (ArrowTy (TyOf ex)) + , Out (ArrowTy (TyOf ex)) + , Out (TyOf ex) + , Out ex + ) => + Out (Prog ex) -instance (Generic (ArrowTy (TyOf ex)), Out (ArrowTy (TyOf ex)), - Out (TyOf ex), Out ex) => Out (Prog ex) -------------------------------------------------------------------------------- -- Environments @@ -278,34 +452,60 @@ type TyEnv a = M.Map Var a emptyTyEnv :: TyEnv a emptyTyEnv = M.empty + -- | A common currency for a two part environment consisting of -- function bindings and regular value bindings. -data Env2 a = Env2 { vEnv :: TyEnv a - , fEnv :: TyEnv (ArrowTy a) } +data Env2 a = + Env2 + { vEnv :: TyEnv a + , fEnv :: TyEnv (ArrowTy a) + } +deriving instance + (Show (TyOf a), Show a, Show (ArrowTy a)) => Show (Env2 a) + +deriving instance + (Read (TyOf a), Read a, Read (ArrowTy a)) => Read (Env2 a) + +deriving instance + (Eq (TyOf a), Eq a, Eq (ArrowTy a)) => Eq (Env2 a) -deriving instance (Show (TyOf a), Show a, Show (ArrowTy a)) => Show (Env2 a) -deriving instance (Read (TyOf a), Read a, Read (ArrowTy a)) => Read (Env2 a) -deriving instance (Eq (TyOf a), Eq a, Eq (ArrowTy a)) => Eq (Env2 a) -- deriving instance (Ord (TyOf a), Ord a, Ord (ArrowTy a)) => Ord (Env2 a) deriving instance Generic (Env2 a) + instance (Out a, Out (ArrowTy a)) => Out (Env2 a) emptyEnv2 :: Env2 a -emptyEnv2 = Env2 { vEnv = emptyTyEnv - , fEnv = M.empty } +emptyEnv2 = Env2 {vEnv = emptyTyEnv, fEnv = M.empty} + -- | Extend non-function value environment. extendVEnv :: Var -> a -> Env2 a -> Env2 a extendVEnv v t (Env2 ve fe) = Env2 (M.insert v t ve) fe + -- | Extend multiple times in one go. extendsVEnv :: M.Map Var a -> Env2 a -> Env2 a extendsVEnv mp (Env2 ve fe) = Env2 (M.union mp ve) fe + +-- | unions for Env2 +unionEnv2s :: [Env2 a] -> Env2 a +unionEnv2s envs = foldr unionEnv2 emptyEnv2 envs + + +-- union for Env2 +unionEnv2 :: Env2 a -> Env2 a -> Env2 a +unionEnv2 (Env2 ve1 fe1) (Env2 ve2 fe2) = + Env2 (M.union ve1 ve2) (M.union fe1 fe2) + lookupVEnv :: Out a => Var -> Env2 a -> a lookupVEnv v env2 = (vEnv env2) # v +lookupVEnv' :: Out a => Var -> Env2 a -> Maybe a +lookupVEnv' v (Env2 ve _) = M.lookup v ve + + -- | Extend function type environment. extendFEnv :: Var -> ArrowTy a -> Env2 a -> Env2 a extendFEnv v t (Env2 ve fe) = Env2 ve (M.insert v t fe) @@ -313,7 +513,6 @@ extendFEnv v t (Env2 ve fe) = Env2 ve (M.insert v t fe) lookupFEnv :: Out (ArrowTy a) => Var -> Env2 a -> ArrowTy a lookupFEnv v env2 = (fEnv env2) # v - -------------------------------------------------------------------------------- -- Expressions -------------------------------------------------------------------------------- @@ -331,60 +530,66 @@ lookupFEnv v env2 = (fEnv env2) # v -- -- (3) It is parameterized by a decoration, d, attached to every binder. -- -data PreExp (ext :: Type -> Type -> Type) loc dec = - VarE Var -- ^ Variable reference - | LitE Int -- ^ Numeric literal - | CharE Char -- ^ A character literal - | FloatE Double -- ^ Floating point literal - | LitSymE Var -- ^ A quoted symbol literal - | AppE Var [loc] [EXP] +data PreExp (ext :: Type -> Type -> Type) loc dec + = VarE Var -- ^ Variable reference + | LitE Int -- ^ Numeric literal + | CharE Char -- ^ A character literal + | FloatE Double -- ^ Floating point literal + | LitSymE Var -- ^ A quoted symbol literal + | AppE Var [loc] [EXP] -- ^ Apply a top-level / first-order function. Instantiate -- its type schema by providing location-variable arguments, -- if applicable. - | PrimAppE (Prim dec) [EXP] + | PrimAppE (Prim dec) [EXP] -- ^ Primitive applications don't manipulate locations. - | LetE (Var,[loc],dec, EXP) -- binding - EXP -- body + | LetE + (Var, [loc], dec, EXP) -- binding + EXP -- body -- ^ One binding at a time. Allows binding a list of -- implicit *location* return vales from the RHS, plus a single "real" value. -- This list of implicit returnsb - - | IfE EXP EXP EXP - - -- TODO: eventually tuples will just be a wired-in datatype. - | MkProdE [EXP] -- ^ Tuple construction - | ProjE Int EXP -- ^ Tuple projection. - - | CaseE EXP [(DataCon, [(Var,loc)], EXP)] + | IfE EXP EXP EXP + +-- TODO: eventually tuples will just be a wired-in datatype. + | MkProdE [EXP] -- ^ Tuple construction + | ProjE Int EXP -- ^ Tuple projection. + | CaseE EXP [(DataCon, [(Var, loc)], EXP)] -- ^ Case on a datatype. Each bound, unpacked variable lives at -- a fixed, read-only location. - - | DataConE loc DataCon [EXP] + | DataConE loc DataCon [EXP] -- ^ Construct data that may unpack some fields. The location -- argument, if applicable, is the byte location at which to -- write the tag for the sum type. - - | TimeIt EXP dec Bool + | TimeIt EXP dec Bool -- ^ The boolean being true indicates this TimeIt is really (iterate _) -- This iterate form is used for criterion-style benchmarking. - - | WithArenaE Var EXP - - | SpawnE Var [loc] [EXP] - | SyncE - - -- Limited list handling: + | WithArenaE Var EXP + | SpawnE Var [loc] [EXP] + | SyncE + +-- Limited list handling: -- TODO: RENAME to "Array". -- TODO: Replace with Generate, add array reference. - | MapE (Var,dec, EXP) EXP - | FoldE { initial :: (Var,dec,EXP) - , iterator :: (Var,dec,EXP) - , body :: EXP } - - ---------------------------------------- + | MapE (Var, dec, EXP) EXP + | FoldE + { initial :: (Var, dec, EXP) + , iterator :: (Var, dec, EXP) + , body :: EXP + } + +---------------------------------------- | Ext (ext loc dec) -- ^ Extension point for downstream language extensions. - - deriving (Show, Read, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable, Out) + deriving ( Show + , Read + , Eq + , Ord + , Generic + , NFData + , Functor + , Foldable + , Traversable + , Out + ) -------------------------------------------------------------------------------- @@ -394,129 +599,143 @@ data PreExp (ext :: Type -> Type -> Type) loc dec = -- | Some of these primitives are (temporarily) tagged directly with -- their return types. data Prim ty - = AddP | SubP | MulP -- ^ May need more numeric primitives... - | DivP | ModP -- ^ Integer division and modulus - | ExpP -- ^ Exponentiation - | RandP -- ^ Generate a random number. + = AddP + | SubP + | MulP -- ^ May need more numeric primitives... + | DivP + | ModP -- ^ Integer division and modulus + | ExpP -- ^ Exponentiation + | RandP -- ^ Generate a random number. -- Translates to 'rand()' in C. - | EqIntP -- ^ Equality on Int - | LtP | GtP -- ^ (<) and (>) for Int's - | LtEqP | GtEqP -- ^ <= and >= - | FAddP | FSubP | FMulP | FDivP | FExpP | FRandP | EqFloatP | EqCharP | FLtP | FGtP | FLtEqP | FGtEqP | FSqrtP | IntToFloatP | FloatToIntP - | FTanP -- ^ Translates to 'tan()' in C. - | EqSymP -- ^ Equality on Sym - | EqBenchProgP String - | OrP | AndP - | MkTrue -- ^ Zero argument constructor. - | MkFalse -- ^ Zero argument constructor. - - | ErrorP String ty + | EqIntP -- ^ Equality on Int + | LtP + | GtP -- ^ (<) and (>) for Int's + | LtEqP + | GtEqP -- ^ <= and >= + | FAddP + | FSubP + | FMulP + | FDivP + | FExpP + | FRandP + | EqFloatP + | EqCharP + | FLtP + | FGtP + | FLtEqP + | FGtEqP + | FSqrtP + | IntToFloatP + | FloatToIntP + | FTanP -- ^ Translates to 'tan()' in C. + | EqSymP -- ^ Equality on Sym + | EqBenchProgP String + | OrP + | AndP + | MkTrue -- ^ Zero argument constructor. + | MkFalse -- ^ Zero argument constructor. + | ErrorP String ty -- ^ crash and issue a static error message. -- To avoid needing inference, this is labeled with a return type. - - | SizeParam - - | IsBig -- ^ Check the size of constructors with size. - | GetNumProcessors -- ^ Return the number of processors - - | PrintInt -- ^ Print an integer to standard out - | PrintChar -- ^ Print a character to standard out - | PrintFloat -- ^ Print a floating point number to standard out - | PrintBool -- ^ Print a boolean to standard out - | PrintSym -- ^ Print a symbol to standard out - | ReadInt -- ^ Read an int from standard in - - -- Dictionaries. - - | DictInsertP ty -- ^ takes dict, k,v; annotated with element type - | DictLookupP ty -- ^ takes dict,k errors if absent; annotated with element type - | DictEmptyP ty -- ^ annotated with element type to avoid ambiguity - | DictHasKeyP ty -- ^ takes dict,k; returns a Bool, annotated with element type - - | SymSetEmpty -- ^ Creates an empty set - | SymSetInsert -- ^ Inserts a symbol into a set of symbols - | SymSetContains -- ^ Queries if a symbol is in a set - - | SymHashEmpty -- ^ Create empty hash table of symbols - | SymHashInsert -- ^ Insert a symbol into a hash table - | SymHashLookup -- ^ Look up a symbol in a hash table (takes default symbol) - | SymHashContains -- ^ Queries if a symbol is in a hash - - | IntHashEmpty -- ^ Create empty hash table of integers - | IntHashInsert -- ^ Insert an integer into a hash table - | IntHashLookup -- ^ Look up a integer in a hash table (takes default integer) - - -- Thread safe dictionaries. - | PDictAllocP ty ty -- ^ annotated with element type to avoid ambiguity - | PDictInsertP ty ty -- ^ takes dict, k, v; annotated with element type - | PDictLookupP ty ty -- ^ takes dict, k. errors if absent; annotated with element type - | PDictHasKeyP ty ty -- ^ takes dict,k; returns a Bool, annotated with element type - | PDictForkP ty ty -- ^ takes dict; returns thread safe safe dicts. - | PDictJoinP ty ty -- ^ takes 2 dicts; returns a merged dict. - - -- Linked Lists. - | LLAllocP ty - | LLIsEmptyP ty - | LLConsP ty - | LLHeadP ty - | LLTailP ty - | LLFreeP ty -- ^ Free the list, and it's data. - | LLFree2P ty -- ^ Free list struct, but not it's data. - | LLCopyP ty -- ^ Copy the list node. - - -- Operations on vectors - | VAllocP ty -- ^ Allocate a vector - | VFreeP ty -- ^ Free a vector, and it's data. - | VFree2P ty -- ^ Free the vector struct, but not it's data. - | VLengthP ty -- ^ Length of the vector - | VNthP ty -- ^ Fetch the nth element - | VSliceP ty -- ^ An efficient slice operation - | InplaceVUpdateP ty -- ^ Update ith element of the vector - | VConcatP ty -- ^ Flatten a vector - | VSortP ty -- ^ A sort primop that accepts a function pointer - | InplaceVSortP ty -- ^ A sort primop that sorts the array in place - | VMergeP ty -- ^ ASSUMPTION: the vectors being merged have the same + | SizeParam + | IsBig -- ^ Check the size of constructors with size. + | GetNumProcessors -- ^ Return the number of processors + | PrintInt -- ^ Print an integer to standard out + | PrintChar -- ^ Print a character to standard out + | PrintFloat -- ^ Print a floating point number to standard out + | PrintBool -- ^ Print a boolean to standard out + | PrintSym -- ^ Print a symbol to standard out + | ReadInt -- ^ Read an int from standard in + +-- Dictionaries. + | DictInsertP ty -- ^ takes dict, k,v; annotated with element type + | DictLookupP ty -- ^ takes dict,k errors if absent; annotated with element type + | DictEmptyP ty -- ^ annotated with element type to avoid ambiguity + | DictHasKeyP ty -- ^ takes dict,k; returns a Bool, annotated with element type + | SymSetEmpty -- ^ Creates an empty set + | SymSetInsert -- ^ Inserts a symbol into a set of symbols + | SymSetContains -- ^ Queries if a symbol is in a set + | SymHashEmpty -- ^ Create empty hash table of symbols + | SymHashInsert -- ^ Insert a symbol into a hash table + | SymHashLookup -- ^ Look up a symbol in a hash table (takes default symbol) + | SymHashContains -- ^ Queries if a symbol is in a hash + | IntHashEmpty -- ^ Create empty hash table of integers + | IntHashInsert -- ^ Insert an integer into a hash table + | IntHashLookup -- ^ Look up a integer in a hash table (takes default integer) + +-- Thread safe dictionaries. + | PDictAllocP ty ty -- ^ annotated with element type to avoid ambiguity + | PDictInsertP ty ty -- ^ takes dict, k, v; annotated with element type + | PDictLookupP ty ty -- ^ takes dict, k. errors if absent; annotated with element type + | PDictHasKeyP ty ty -- ^ takes dict,k; returns a Bool, annotated with element type + | PDictForkP ty ty -- ^ takes dict; returns thread safe safe dicts. + | PDictJoinP ty ty -- ^ takes 2 dicts; returns a merged dict. + +-- Linked Lists. + | LLAllocP ty + | LLIsEmptyP ty + | LLConsP ty + | LLHeadP ty + | LLTailP ty + | LLFreeP ty -- ^ Free the list, and it's data. + | LLFree2P ty -- ^ Free list struct, but not it's data. + | LLCopyP ty -- ^ Copy the list node. + +-- Operations on vectors + | VAllocP ty -- ^ Allocate a vector + | VFreeP ty -- ^ Free a vector, and it's data. + | VFree2P ty -- ^ Free the vector struct, but not it's data. + | VLengthP ty -- ^ Length of the vector + | VNthP ty -- ^ Fetch the nth element + | VSliceP ty -- ^ An efficient slice operation + | InplaceVUpdateP ty -- ^ Update ith element of the vector + | VConcatP ty -- ^ Flatten a vector + | VSortP ty -- ^ A sort primop that accepts a function pointer + | InplaceVSortP ty -- ^ A sort primop that sorts the array in place + | VMergeP ty -- ^ ASSUMPTION: the vectors being merged have the same -- underlying mutable array. This assumption is checked -- at the type level with a Rank-2 type variable. But this -- evidence is erased (by the desugarer) by the time we get -- to L0. - - | Write3dPpmFile FilePath - - | ReadPackedFile (Maybe FilePath) TyCon (Maybe Var) ty + | Write3dPpmFile FilePath + | ReadPackedFile (Maybe FilePath) TyCon (Maybe Var) ty -- ^ Read (mmap) a binary file containing packed data. This must be annotated with the -- type of the file being read. The `Ty` tracks the type as the program evolvels -- (first PackedTy then CursorTy). The TyCon tracks the original type name. -- The variable represents the region that this file will be mapped to, and is -- set by InferLocations. - - | WritePackedFile FilePath ty + | WritePackedFile FilePath ty -- ^ Write a packed value to a file. -- To enable re-reading this packed value with Gibbon, this primitive gets rid -- of any absolute pointers in the value. First, it inlines (by copying) any -- regions pointed to by the packed value. Next, random access nodes are eliminated. -- We could change them to relative pointers (numeric offsets), -- but for a first version we can simplify things by getting rid of them completely. - - | ReadArrayFile (Maybe (FilePath, Int)) ty + | ReadArrayFile (Maybe (FilePath, Int)) ty -- ^ Parse a file into a Vector. This is decorated with the -- element type. If the element type is a struct, -- like (Int, Int) for example, each line must contain 2 numbers -- separated by a space. The Int is the number of lines in the -- file. - - | RequestEndOf + | RequestEndOf -- ^ Conveys a demand for the "end of" some packed value, which is -- fulfilled by Cursorize. N.B. the argument must be a VarE that -- refers to a packed value. - - | RequestSizeOf + | RequestSizeOf -- ^ Like 'RequestEndOf' but gets the size of a packed value. Assume -- that the value is written in a contiguous region, and size = end_v - v. - - | Gensym - - deriving (Read, Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable, Out) + | Gensym + deriving ( Read + , Show + , Eq + , Ord + , Generic + , NFData + , Functor + , Foldable + , Traversable + , Out + ) -------------------------------------------------------------------------------- @@ -526,47 +745,46 @@ data Prim ty -- | Types include boxed/pointer-based products as well as unpacked -- algebraic datatypes. This data is parameterized to allow -- annotation on Packed types later on. -data UrTy a = - IntTy - | CharTy - | FloatTy - | SymTy -- ^ Symbols used in writing compiler passes. - | BoolTy - | ProdTy [UrTy a] -- ^ An N-ary tuple - | SymDictTy (Maybe Var) (UrTy ()) -- ^ A map from SymTy to Ty +data UrTy a + = IntTy + | CharTy + | FloatTy + | SymTy -- ^ Symbols used in writing compiler passes. + | BoolTy + | ProdTy [UrTy a] -- ^ An N-ary tuple + | SymDictTy (Maybe Var) (UrTy ()) -- ^ A map from SymTy to Ty -- ^ We allow built-in dictionaries from symbols to a value type. - - | PackedTy TyCon a -- ^ No type arguments to TyCons for now. (No polymorphism.) - - | VectorTy (UrTy a) -- ^ Vectors are decorated with the types of their elements; + | PackedTy TyCon a -- ^ No type arguments to TyCons for now. (No polymorphism.) + | VectorTy (UrTy a) -- ^ Vectors are decorated with the types of their elements; -- which can only include scalars or flat products of scalars. - - | PDictTy (UrTy a) (UrTy a) -- ^ Thread safe dictionaries decorated with + | PDictTy (UrTy a) (UrTy a) -- ^ Thread safe dictionaries decorated with -- key and value type. - - | ListTy (UrTy a) -- ^ Linked lists are decorated with the types of their elements; + | ListTy (UrTy a) -- ^ Linked lists are decorated with the types of their elements; -- which can only include scalars or flat products of scalars. - - | ArenaTy -- ^ Collection of allocated, non-packed values - - | SymSetTy -- ^ Set of symbols - - | SymHashTy -- ^ Hash table of symbols - - | IntHashTy -- ^ Hash table of integers - - ---------- These are not used initially ---------------- + | ArenaTy -- ^ Collection of allocated, non-packed values + | SymSetTy -- ^ Set of symbols + | SymHashTy -- ^ Hash table of symbols + | IntHashTy -- ^ Hash table of integers + +---------- These are not used initially ---------------- -- (They could be added by a later IR instead:) - - | PtrTy -- ^ A machine pointer tvo a complete value in memory. + | PtrTy -- ^ A machine pointer tvo a complete value in memory. -- This is decorated with the region it points into, which -- may affect the memory layout. - - | CursorTy -- ^ A cursor for reading or writing, which may point + | CursorTy -- ^ A cursor for reading or writing, which may point -- to an unkwown type or to a fraction of a complete value. -- It is a machine pointer that can point to any byte. - - deriving (Show, Read, Ord, Eq, Generic, NFData, Functor, Foldable, Traversable, Out) + deriving ( Show + , Read + , Ord + , Eq + , Generic + , NFData + , Functor + , Foldable + , Traversable + , Out + ) -------------------------------------------------------------------------------- @@ -574,15 +792,19 @@ data UrTy a = -------------------------------------------------------------------------------- -- | Expression and program types which support a notion of free variables. -class FreeVars a where +class (Out a) => + FreeVars a -- | Return a set of free TERM variables. Does not return location variables. - gFreeVars :: a -> S.Set Var + where + gFreeVars :: a -> S.Set Var -- | A generic interface to expressions found in different phases of -- the compiler. -class (Show e, Out e, FreeVars e) => Expression e where +class (Show e, Out e, FreeVars e) => + Expression e -- | The type representation used in this expression. + where type TyOf e -- | The location (variable) representation used in this expression. type LocOf e @@ -591,17 +813,20 @@ class (Show e, Out e, FreeVars e) => Expression e where -- | IRs amenable to flattening -class Expression e => Flattenable e where +class Expression e => + Flattenable e -- | Process an expression into a fully-flattened expression which typically includes a -- larger number of temporary, local variable bindings. + where gFlattenExp :: DDefs (TyOf e) -> Env2 (TyOf e) -> e -> PassM e - - -- | A private method. Gather the bindings from a subexpression, + +-- | A private method. Gather the bindings from a subexpression, -- but do not "discharge" them by creating a let expression. They -- are in order, so later may depend on earlier. - gFlattenGatherBinds :: DDefs (TyOf e) -> Env2 (TyOf e) -> e -> PassM ([Binds e],e) + gFlattenGatherBinds :: + DDefs (TyOf e) -> Env2 (TyOf e) -> e -> PassM ([Binds e], e) -type Binds e = (Var,[LocOf e],TyOf e, e) +type Binds e = (Var, [LocOf e], TyOf e, e) -- | IRs amenable to simplification/inlineTrivs. Note that there's a @@ -611,45 +836,65 @@ type Binds e = (Var,[LocOf e],TyOf e, e) -- where e is a top-level IR. Right now we don't have a class (and probably -- don't want to have one as well) which ties an extension point with an IR. -- Keeping these classes separate works out nicely. -class Expression e => Simplifiable e where +class Expression e => + Simplifiable e + where gInlineTrivExp :: M.Map Var e -> e -> e -class Expression e => SimplifiableExt e ext where +class Expression e => + SimplifiableExt e ext + where gInlineTrivExt :: M.Map Var e -> ext -> ext -type HasSimplifiable e l d = ( Show l, Out l, Show d, Out d - , Expression (e l d) - , SimplifiableExt (PreExp e l d) (e l d) - ) +type HasSimplifiable e l d + = ( Show l + , Out l + , Show d + , Out d + , Expression (e l d) + , SimplifiableExt (PreExp e l d) (e l d)) -type HasSimplifiableExt e l d = ( Show l, Out l, Show d, Out d - , Simplifiable (PreExp e l d) - ) +type HasSimplifiableExt e l d + = (Show l, Out l, Show d, Out d, Simplifiable (PreExp e l d)) -- | This is NOT a replacement for any typechecker. This only recover type of -- an expression given a type-environment. Without this, we cannot have truly -- generic Flattenable, b/c we need to know the type of an expression before we -- bind it with a LetE. -class Expression e => Typeable e where +class Expression e => + Typeable e + where gRecoverType :: DDefs (TyOf e) -> Env2 (TyOf e) -> e -> TyOf e + -- | Generic substitution over expressions. -class Expression e => Substitutable e where - gSubst :: Var -> e -> e -> e - gSubstE :: e -> e -> e -> e +class Expression e => + Substitutable e + where + gSubst :: Var -> e -> e -> e + gSubstE :: e -> e -> e -> e -class Expression e => SubstitutableExt e ext where - gSubstExt :: Var -> e -> ext -> ext - gSubstEExt :: e -> e -> ext -> ext +class Expression e => + SubstitutableExt e ext + where + gSubstExt :: Var -> e -> ext -> ext + gSubstEExt :: e -> e -> ext -> ext + +type HasSubstitutable e l d + = ( Expression (e l d) + , SubstitutableExt (PreExp e l d) (e l d) + , Eq d + , Show d + , Out d + , Eq l + , Show l + , Out l + , Eq (e l d)) -type HasSubstitutable e l d = ( Expression (e l d) - , SubstitutableExt (PreExp e l d) (e l d) - , Eq d, Show d, Out d, Eq l, Show l, Out l - , Eq (e l d) ) +type HasSubstitutableExt e l d + = (Eq d, Show d, Out d, Eq l, Show l, Out l, Substitutable (PreExp e l d)) -type HasSubstitutableExt e l d = ( Eq d, Show d, Out d, Eq l, Show l, Out l - , Substitutable (PreExp e l d) ) -- | Alpha renaming, without worrying about name capture -- assuming that Freshen -- has run before! @@ -658,114 +903,170 @@ class Renamable e where type HasRenamable e l d = (Renamable l, Renamable d, Renamable (e l d)) + -- A convenience wrapper over some of the constraints. type HasOut ex = (Out ex, Out (TyOf ex), Out (ArrowTy (TyOf ex))) + type HasShow ex = (Show ex, Show (TyOf ex), Show (ArrowTy (TyOf ex))) + type HasEq ex = (Eq ex, Eq (TyOf ex), Eq (ArrowTy (TyOf ex))) -type HasGeneric ex = (Generic ex, Generic (TyOf ex), Generic (ArrowTy (TyOf ex))) + +type HasGeneric ex + = (Generic ex, Generic (TyOf ex), Generic (ArrowTy (TyOf ex))) + type HasNFData ex = (NFData ex, NFData (TyOf ex), NFData (ArrowTy (TyOf ex))) + -------------------------------------------------------------------------------- -- Things which can be interpreted to yield a final, printed value. -------------------------------------------------------------------------------- - type ValEnv e = M.Map Var (Value e) -type InterpLog = Builder -newtype InterpM s e a = InterpM { unInterpM :: WriterT InterpLog (StateT s IO) a } - deriving newtype (Functor, Applicative, Monad, MonadState s, MonadIO, MonadWriter InterpLog) +type InterpLog = Builder -instance MonadFail (InterpM a b) where - fail = error +newtype InterpM s e a = + InterpM + { unInterpM :: WriterT InterpLog (StateT s IO) a + } + deriving newtype ( Functor + , Applicative + , Monad + , MonadState s + , MonadIO + , MonadWriter InterpLog + ) + +instance MonadFail (InterpM a b) + where + fail = error runInterpM :: InterpM s e a -> s -> IO (a, InterpLog, s) runInterpM m s = do - ((v,logs), s1) <- runStateT (runWriterT (unInterpM m)) s - pure (v, logs, s1) + ((v, logs), s1) <- runStateT (runWriterT (unInterpM m)) s + pure (v, logs, s1) + -- | Pure Gibbon programs, at any stage of compilation, should always -- be evaluatable to a unique value. The only side effects are timing. -class Expression e => Interp s e where - gInterpExp :: RunConfig -> ValEnv e -> DDefs (TyOf e) -> FunDefs e -> e -> InterpM s e (Value e) - -class (Expression e, Expression ext) => InterpExt s e ext where - gInterpExt :: RunConfig -> ValEnv e -> DDefs (TyOf e) -> FunDefs e -> ext -> InterpM s e (Value e) - -class Interp s e => InterpProg s e where +class Expression e => + Interp s e + where + gInterpExp :: + RunConfig + -> ValEnv e + -> DDefs (TyOf e) + -> FunDefs e + -> e + -> InterpM s e (Value e) + +class (Expression e, Expression ext) => + InterpExt s e ext + where + gInterpExt :: + RunConfig + -> ValEnv e + -> DDefs (TyOf e) + -> FunDefs e + -> ext + -> InterpM s e (Value e) + +class Interp s e => + InterpProg s e + where {-# MINIMAL gInterpProg #-} gInterpProg :: s -> RunConfig -> Prog e -> IO (s, Value e, B.ByteString) - - -- | Interpret while ignoring timing constructs, and dropping the + +-- | Interpret while ignoring timing constructs, and dropping the -- corresponding output to stdout. gInterpNoLogs :: s -> RunConfig -> Prog e -> String gInterpNoLogs s rc p = unsafePerformIO $ show . snd3 <$> gInterpProg s rc p - - -- | Interpret and produce a "log" of output lines, as well as a + +-- | Interpret and produce a "log" of output lines, as well as a -- final, printed result. The output lines include timing information. - gInterpWithStdout :: s -> RunConfig -> Prog e -> IO (String,[String]) + gInterpWithStdout :: s -> RunConfig -> Prog e -> IO (String, [String]) gInterpWithStdout s rc p = do - (_s1,res,logs) <- gInterpProg s rc p + (_s1, res, logs) <- gInterpProg s rc p return (show res, lines (B.unpack logs)) -- | It's a first order language with simple values. -data Value e = VInt Int - | VChar Char - | VFloat Double - | VSym String - | VBool Bool - | VDict (M.Map (Value e) (Value e)) - | VProd [(Value e)] - | VList [(Value e)] - | VPacked DataCon [(Value e)] - | VLoc { bufID :: Var, offset :: Int } - | VCursor { bufID :: Var, offset :: Int } - | VPtr { bufID :: Var, offset :: Int } +data Value e + = VInt Int + | VChar Char + | VFloat Double + | VSym String + | VBool Bool + | VDict (M.Map (Value e) (Value e)) + | VProd [(Value e)] + | VList [(Value e)] + | VPacked DataCon [(Value e)] + | VLoc + { bufID :: Var + , offset :: Int + } + | VCursor + { bufID :: Var + , offset :: Int + } + | VPtr + { bufID :: Var + , offset :: Int + } -- ^ Cursor are a pointer into the Store plus an offset into the Buffer. - | VLam [Var] e (ValEnv e) - | VWrapId Int (Value e) + | VLam [Var] e (ValEnv e) + | VWrapId Int (Value e) -- ^ A wrapper for vectors that wraps the value with an "id". -- All Inplace* operations use this "id" to update the value -- in 'ValEnv'. - deriving (Read,Eq,Ord,Generic) + deriving (Read, Eq, Ord, Generic) instance Out e => Out (Value e) + instance NFData e => NFData (Value e) instance Show e => Show (Value e) where - show v = - case v of - VInt n -> show n - VChar c -> show c - VFloat n -> show n - VSym s -> "'" ++ s - VBool b -> if b then truePrinted else falsePrinted + show v = + case v of + VInt n -> show n + VChar c -> show c + VFloat n -> show n + VSym s -> "'" ++ s + VBool b -> + if b + then truePrinted + else falsePrinted + VProd [] -> "" + VProd ls -> "'#(" ++ concat (L.intersperse " " (L.map show ls)) ++ ")" + VList ls -> show ls + VDict m -> show (M.toList m) + -- For now, Racket style: + VPacked k ls -> "(" ++ k ++ concat (L.map ((" " ++) . show) ls) ++ ")" + VLoc buf off -> "" + VCursor idx off -> "" + VPtr idx off -> "" + VLam args bod env -> + "(Clos (lambda (" ++ + concat (map ((++ " ") . show) args) ++ + ") " ++ show bod ++ ") #{" ++ show env ++ "})" + VWrapId vid val -> "(id: " ++ show vid ++ " " ++ show val ++ ")" + -- TODO: eventually want Haskell style tuple-printing: -- VProd ls -> "("++ concat(intersperse ", " (L.map show ls)) ++")" -- For now match Gibbon's Racket backend - VProd [] -> "" - VProd ls -> "'#("++ concat(L.intersperse " " (L.map show ls)) ++")" - VList ls -> show ls - VDict m -> show (M.toList m) - -- For now, Racket style: - VPacked k ls -> "(" ++ k ++ concat (L.map ((" "++) . show) ls) ++ ")" - VLoc buf off -> "" - VCursor idx off -> "" - VPtr idx off -> "" - VLam args bod env -> "(Clos (lambda (" ++ concat (map ((++" ") . show) args) ++ ") " ++ show bod ++ ") #{" ++ show env ++ "})" - VWrapId vid val -> "(id: " ++ show vid ++ " " ++ show val ++ ")" - execAndPrint :: (InterpProg s ex) => s -> RunConfig -> Prog ex -> IO () execAndPrint s rc prg = do - (_s1,val,logs) <- gInterpProg s rc prg + (_s1, val, logs) <- gInterpProg s rc prg B.putStr logs - case val of + case val -- Special case: don't print void return: + of VProd [] -> return () -- FIXME: remove this. - _ -> print val + _ -> print val --------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- makeBaseFunctor ''PreExp + makeBaseFunctor ''UrTy + makeBaseFunctor ''Prim diff --git a/gibbon-compiler/src/Gibbon/Passes/DefinitionUseChains.hs b/gibbon-compiler/src/Gibbon/Passes/DefinitionUseChains.hs new file mode 100644 index 000000000..35016070b --- /dev/null +++ b/gibbon-compiler/src/Gibbon/Passes/DefinitionUseChains.hs @@ -0,0 +1,302 @@ +module Gibbon.Passes.DefinitionUseChains + ( progToVEnv + , generateDefUseChainsFunction + , DefUseChainsFunctionMap(..) + ) where + + +-- Gibbon imports +import Gibbon.Common +import Gibbon.Language +import Gibbon.Language.Syntax + +import Control.Monad as Monad +import Data.Graph as G +import Data.List as L +import Data.Map as M +import Data.Maybe as Maybe +import Data.Set as S + + +-- haskell imports +import Prelude as P +import Text.PrettyPrint.GenericPretty + + +-- | A Map storing a function to the data flow graph that is Definition Use chains +-- | Type definition +-- | Outer Map Definition +-- | Key type Var == Function name +-- | Value type == Triple storing graph and graph associated functions. See Data.Contatiners +-- | Graph Edge == (Var, ex, (TyOf ex)), i.e., variable that's assigned, the assignment expression (polymorphic to IR), and type of the Variable. +-- | key in the Graph = ex, The expression (polymorphic IR expression) is the key itself +type DefUseChainsFunctionMap ex + = M.Map Var ( G.Graph + , G.Vertex -> ((Var, ex, (TyOf ex)), ex, [ex]) + , ex -> Maybe G.Vertex) + +progToVEnv :: + (FreeVars (e l d), Ord l, Ord d, Ord (e l d), Out d, Out l) + => Prog (PreExp e l d) + -> Env2 (TyOf (PreExp e l d)) +progToVEnv p@Prog {ddefs, fundefs, mainExp} = + case mainExp of + Just (exp, ty) -> + unionEnv2 (unionEnv2 initialEnv extendedVEnv) (getExpTyEnv emptyEnv2 exp) + Nothing -> error "progToVEnv : No main expression found!" + where + initialEnv = progToEnv p + extendedVEnv = unionEnv2s (L.map (getFunTyEnv initialEnv) (M.elems fundefs)) + getFunTyEnv env f@FunDef {funName, funBody, funTy, funArgs} = + getExpTyEnv env funBody + getExpTyEnv env exp = + case exp of + DataConE loc dcon args -> unionEnv2s (L.map (getExpTyEnv env) args) + VarE {} -> emptyEnv2 + LitE {} -> emptyEnv2 + CharE {} -> emptyEnv2 + FloatE {} -> emptyEnv2 + LitSymE {} -> emptyEnv2 + AppE f locs args -> unionEnv2s (L.map (getExpTyEnv env) args) + PrimAppE f args -> unionEnv2s (L.map (getExpTyEnv env) args) + LetE (v, loc, ty, rhs) bod -> extendVEnv v ty env + -- a == DataCon + -- b == [(Var, loc)] + -- c == Case Body + CaseE scrt mp -> + unionEnv2s $ + P.map + (\(a, b, c) -> + let tys = lookupDataCon ddefs a + b' = L.map fst b + env' = extendsVEnv (M.fromList (zip b' tys)) env + in env') + mp + IfE a b c -> + let expEnva = getExpTyEnv env a + expEnvb = getExpTyEnv env b + expEnvc = getExpTyEnv env c + in unionEnv2s $ [expEnva, expEnvb, expEnvc] + MkProdE xs -> unionEnv2s (L.map (getExpTyEnv env) xs) + ProjE i e -> error "getExpTyEnv: TODO ProjE" + TimeIt e ty b -> error "getExpTyEnv: TODO TimeIt" + WithArenaE v e -> error "getExpTyEnv: TODO WithArenaE" + SpawnE f locs args -> error "getExpTyEnv: TODO SpawnE" + SyncE -> error "getExpTyEnv: TODO SyncE" + Ext _ -> error "getExpTyEnv: TODO Ext" + MapE {} -> error "getExpTyEnv: TODO MapE" + FoldE {} -> error "getExpTyEnv: TODO FoldE" + +generateDefUseChainsFunction :: + (FreeVars (e l d), Ord l, Ord d, Ord (e l d), Out d, Out l) + => Env2 (TyOf (PreExp e l d)) + -> FunDef (PreExp e l d) + -> DefUseChainsFunctionMap (PreExp e l d) +generateDefUseChainsFunction env f@FunDef {funName, funBody, funTy, funArgs} = + let edgeList = generateDefUseChainsFunBody env funBody + (graph, nodeFromVertex, vertexFromKey) = G.graphFromEdges edgeList + in dbgTraceIt + (sdoc edgeList) + dbgTraceIt + ("\n") + M.insert + funName + (graph, nodeFromVertex, vertexFromKey) + M.empty + +generateDefUseChainsExp :: + (FreeVars (e l d), Ord l, Ord d, Ord (e l d), Out d, Out l) + => Env2 (TyOf (PreExp e l d)) + -> Var + -> (PreExp e l d) + -> DefUseChainsFunctionMap (PreExp e l d) +generateDefUseChainsExp env key expr = + let edgeList = generateDefUseChainsFunBody env expr + (graph, nodeFromVertex, vertexFromKey) = G.graphFromEdges edgeList + in dbgTraceIt + (sdoc edgeList) + dbgTraceIt + ("\n") + M.insert + key + (graph, nodeFromVertex, vertexFromKey) + M.empty + +generateDefUseChainsFunBody :: + (FreeVars (e l d), Ord l, Ord d, Ord (e l d), Out d, Out l) + => Env2 (TyOf (PreExp e l d)) + -> (PreExp e l d) + -> [( (Var, (PreExp e l d), (TyOf (PreExp e l d))) + , (PreExp e l d) + , [(PreExp e l d)])] +generateDefUseChainsFunBody env exp = + case exp of + DataConE loc dcon args -> P.concatMap (generateDefUseChainsFunBody env) args + VarE {} -> [] + LitE {} -> [] + CharE {} -> [] + FloatE {} -> [] + LitSymE {} -> [] + AppE f locs args -> P.concatMap (generateDefUseChainsFunBody env) args + PrimAppE f args -> P.concatMap (generateDefUseChainsFunBody env) args + LetE (v, loc, ty, rhs) bod -> + let successors = getDefUseChainsVar v bod False + currExpKey = LetE (v, loc, ty, rhs) $ VarE v + currNode = (v, currExpKey, ty) + recurseBod = (generateDefUseChainsFunBody env) bod + in [(currNode, currExpKey, successors)] ++ recurseBod + -- a == DataCon + -- b == [(Var, loc)] + -- c == Case Body + CaseE scrt mp -> + let edges = + P.concatMap + (\(a, b, c) -> + let e = + P.concatMap + (\(v, _) -> + let successors = getDefUseChainsVar v c False + currExpKey = + DataConE _ a (P.map (\(v', _) -> VarE v') b) + currNode = (v, currExpKey, (lookupVEnv v env)) + in [(currNode, currExpKey, successors)]) + b + e' = (generateDefUseChainsFunBody env) c + in e ++ e') + mp + in edges + IfE a b c -> + let definitionsCond = (generateDefUseChainsFunBody env) a + thenBody = (generateDefUseChainsFunBody env) b + elseBody = (generateDefUseChainsFunBody env) c + in definitionsCond ++ thenBody ++ elseBody + MkProdE xs -> P.concatMap (generateDefUseChainsFunBody env) xs + _ -> + error + "generateDefUseChainsFunBody: Encountered expression which is not implemented yet!" + +getDefUseChainsVar :: + (FreeVars (e l d), Ord l, Ord d, Ord (e l d), Out d, Out l) + => Var + -> (PreExp e l d) + -> Bool + -> [(PreExp e l d)] +getDefUseChainsVar var exp isReDefined = + case exp of + DataConE loc dcon args -> + case isReDefined of + True -> [] + False -> + let freeVars = S.unions $ L.map gFreeVars args + in if (S.member var freeVars) + then [DataConE loc dcon args] + else [] + -- Program is in ANF, so we can assume that its flattned + -- so args is not going to be a complex nested expression. + -- check if var is in freeVars + -- If yes, add then return [exp1] + -- If no, then return [] + VarE {} -> [] + LitE {} -> [] + CharE {} -> [] + FloatE {} -> [] + LitSymE {} -> [] + AppE f locs args -> + case isReDefined of + True -> [] + False -> + let freeVars = S.unions $ L.map gFreeVars args + in if (S.member var freeVars) + then [AppE f locs args] + else [] + -- check if var is in freeVars + -- If yes, then return [exp1] + -- If no, then return [] + PrimAppE f args -> + case isReDefined of + True -> [] + False -> + let freeVars = S.unions $ L.map gFreeVars args + in if (S.member var freeVars) + then [PrimAppE f args] + else [] + -- check if var is in freeVars + -- If yes, then return [exp1] + -- If no, then return [] + LetE (v, loc, ty, rhs) bod -> + case isReDefined of + True -> [] + False -> + let freeVars = gFreeVars rhs + usedInRhs = + if (S.member var freeVars) + then True + else False + isReDefined = + if (var == v) + then True + else False + in if usedInRhs + then let expr = [LetE (v, loc, ty, rhs) $ (VarE v)] + moreExpr = getDefUseChainsVar var bod isReDefined + in expr ++ moreExpr + else getDefUseChainsVar var bod False + -- check if var is in freeVars + -- equality test on v and var + -- If yes, then, recurse on bod, pass result of equality check + -- add LetE (v,loc,ty,rhs) $ (VarE v) to returned val + -- return new value + CaseE scrt mp -> + case isReDefined of + True -> [] + -- see if the variable is used in scrt + False -> + case scrt of + VarE v -> + if (v == var) + then let expr = [CaseE scrt []] + -- Here making as assumption that the variable is not shadowed by + -- a case binding in b == [(Var, loc)] + moreExpr = + P.concatMap + (\(_, _, c) -> getDefUseChainsVar var c False) + mp + in expr ++ moreExpr + else let exprs = + P.concatMap + (\(_, _, c) -> getDefUseChainsVar var c False) + mp + in exprs + _ -> error "getDefUseChainsVar: CaseE did not expect case: " + IfE a b c -> + case isReDefined of + True -> [] + False -> + let freeVarsA = gFreeVars a + in if (S.member var freeVarsA) + then let expra = [a] + exprsb = getDefUseChainsVar var b False + exprsc = getDefUseChainsVar var c False + in expra ++ exprsb ++ exprsc + else let exprsb = getDefUseChainsVar var b False + exprsc = getDefUseChainsVar var c False + in exprsb ++ exprsc + MkProdE xs -> + case isReDefined of + True -> [] + False -> + let freeVars = S.unions $ L.map gFreeVars xs + in if (S.member var freeVars) + then [MkProdE xs] + else [] + -- I don't think there is a need to recurse on xs + -- since it would be in A-normal form at this point. + -- Check? + ProjE i e -> error "getDefUseChainsVar: TODO ProjE" + TimeIt e ty b -> error "getDefUseChainsVar: TODO TimeIt" + WithArenaE v e -> error "getDefUseChainsVar: TODO WithArenaE" + SpawnE f locs args -> error "getDefUseChainsVar: TODO SpawnE" + SyncE -> error "getDefUseChainsVar: TODO SyncE" + MapE {} -> error "getDefUseChainsVar: TODO MapE" + FoldE {} -> error "getDefUseChainsVar: TODO FoldE" + Ext _ -> error "getDefUseChainsVar: TODO Ext" diff --git a/gibbon-compiler/src/Gibbon/Passes/Fusion2.hs b/gibbon-compiler/src/Gibbon/Passes/Fusion2.hs index f024df735..4ba5376ac 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Fusion2.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Fusion2.hs @@ -1,28 +1,34 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -Wno-all #-} -module Gibbon.Passes.Fusion2 (fusion2) where -import Prelude hiding (exp) -import Control.Arrow ((&&&)) +module Gibbon.Passes.Fusion2 + ( fusion2 + ) where +import Control.Arrow ((&&&)) +import Prelude hiding (exp) + +import Control.DeepSeq import Control.Exception -import qualified Data.Map as M -import qualified Data.List as L -import qualified Data.Set as S -import qualified Data.Vector as V +import Control.Monad +import Data.Char (toLower) +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S import Data.Symbol -import Data.Char ( toLower ) -import Debug.Trace -import Control.DeepSeq -import GHC.Generics (Generic, Generic1) +import Data.Text (breakOnAll, pack, splitOn) import Data.Tuple.All -import Control.Monad -import Gibbon.Pretty -import Gibbon.Common -import Gibbon.Passes.Freshen (freshExp1) -import Gibbon.L1.Syntax as L1 -import Data.Text (breakOnAll, pack, splitOn) +import qualified Data.Vector as V +import Debug.Trace +import GHC.Generics (Generic, Generic1) +import Gibbon.Common +import Gibbon.L1.Syntax as L1 +import Gibbon.Passes.Freshen (freshExp1) +import Gibbon.Pretty + + -------------------------------------------------------------------------------- -- countFUS :: String -> Int @@ -31,25 +37,27 @@ import Data.Text (breakOnAll, pack, splitOn) -- -- (show str) L.++"\nress:\n" -- -- L.++ (show (breakOnAll (pack str) (pack "FUS") )) -- -- ) - - wordCount :: String -> [(String, Int)] -wordCount = map (L.head &&& L.length) . L.group . L.sort . L.words . L.map toLower +wordCount = + map (L.head &&& L.length) . L.group . L.sort . L.words . L.map toLower countFUS :: String -> (Int, Int) -countFUS str = let ls1= splitOn "_f_" (pack str) in - let ls2 = L.concatMap (\txt -> splitOn "_FUS" txt ) ls1 in - let ls3 = L.filter (\txt -> (txt/= "") && (txt /= "_") ) ls2 in - let ls4 = L.group (L.sort ls3) in - let ls5 = L.map (\ls ->L.length ls) ls4 in - let mx =maximum ls5 in - (mx, L.length ls3) - `debug1` ((show mx) L.++ "opppa" L.++ ( show ls5) L.++ (show ls3) L.++ (show str)) +countFUS str = + let ls1 = splitOn "_f_" (pack str) + in let ls2 = L.concatMap (\txt -> splitOn "_FUS" txt) ls1 + in let ls3 = L.filter (\txt -> (txt /= "") && (txt /= "_")) ls2 + in let ls4 = L.group (L.sort ls3) + in let ls5 = L.map (\ls -> L.length ls) ls4 + in let mx = maximum ls5 + in (mx, L.length ls3) `debug1` + ((show mx) L.++ "opppa" L.++ (show ls5) L.++ + (show ls3) L.++ + (show str)) + +debug = flip (dbgTrace 5) - - -debug = flip (dbgTrace 5) debug1 = flip (dbgTrace 2) + {- E.g. @@ -75,8 +83,6 @@ For htis program, the DefTAble looks like: } -} - - type DefTable = M.Map Symbol DefTableEntry {- There will be one entry for each variable in the table. Each entry consist of @@ -84,155 +90,157 @@ type DefTable = M.Map Symbol DefTableEntry 2)The index at which the definition appears at in the argument list. 3)The defined symbol, if the the consuming expression of the form let x=App. -} -data DefTableEntry = DefTableEntry - { def :: !Exp1 -- ^ The expression that defines this variable - , fun_uses :: ![FunctionUses] -- () - , all_use_count :: !Int -- ^ total number of uses (calls and not) - , varType :: Ty1 - } deriving (Show , Generic) - -type FunctionUses = - ( Exp1 -- The AppE that uses a variable. - , Int -- i where variable V is the i'th argument in this function call. - , Maybe Symbol -- The variable that binds this AppE. - ) - +data DefTableEntry = + DefTableEntry + { def :: !Exp1 -- ^ The expression that defines this variable + , fun_uses :: ![FunctionUses] -- () + , all_use_count :: !Int -- ^ total number of uses (calls and not) + , varType :: Ty1 + } + deriving (Show, Generic) + +type FunctionUses + = ( Exp1 -- The AppE that uses a variable. + , Int -- i where variable V is the i'th argument in this function call. + , Maybe Symbol -- The variable that binds this AppE. + ) type PotentialPair = (Symbol, Symbol) -type PotentialsList = [DefTableEntry] +type PotentialsList = [DefTableEntry] freshFunction :: FunDef1 -> PassM FunDef1 freshFunction f = do - body' <- freshExp1 M.empty (funBody f) - let f' = f{funBody = body' } + body' <- freshExp1 M.empty (funBody f) + let f' = f {funBody = body'} let argsOld = funArgs f' argsNew <- Prelude.mapM gensym argsOld - let f'' = f'{funArgs = argsNew} - return $ substArgs f'' argsOld argsNew - where - substArgs f [] [] = f - substArgs f (old:told) (new:tnew) = - let f' = f{funBody = substE (VarE old) (VarE new) (funBody f)} - in substArgs f' told tnew - -removeCommonExpressions :: Exp1-> Exp1 + let f'' = f' {funArgs = argsNew} + return $ substArgs f'' argsOld argsNew + where + substArgs f [] [] = f + substArgs f (old:told) (new:tnew) = + let f' = f {funBody = substE (VarE old) (VarE new) (funBody f)} + in substArgs f' told tnew + +removeCommonExpressions :: Exp1 -> Exp1 removeCommonExpressions = go - where - go exp = case exp of - LetE (v, ls, t, bind) body -> - case bind of + where + go exp = + case exp of + LetE (v, ls, t, bind) body -> + case bind of ProjE i e -> let oldExp = VarE v newExp = ProjE i e body' = substE oldExp newExp body - in go body'-- `debug` ("replace ::"L.++ (show oldExp) L.++ "with" L.++ (show newExp)) + in go body' -- `debug` ("replace ::"L.++ (show oldExp) L.++ "with" L.++ (show newExp)) VarE v' -> let oldExp = VarE v newExp = VarE v' body' = substE oldExp newExp body - in go body' + in go body' otherwise -> let oldExp = bind newExp = VarE v body' = substE oldExp newExp body --`debug` ("removing duplicates of "L.++ (show oldExp)) - in LetE (v, ls, t, bind) (go body') - IfE cond thenBody elseBody -> - IfE (go cond) (go thenBody) (go elseBody) - - CaseE e ls -> let ls' = L.map (\(x, y, exp) -> (x, y, go exp)) ls - in CaseE e ls' - - TimeIt exp x y -> TimeIt (go exp) x y - x -> x + in LetE (v, ls, t, bind) (go body') + IfE cond thenBody elseBody -> IfE (go cond) (go thenBody) (go elseBody) + CaseE e ls -> + let ls' = L.map (\(x, y, exp) -> (x, y, go exp)) ls + in CaseE e ls' + TimeIt exp x y -> TimeIt (go exp) x y + x -> x -simplifyProjections :: Exp1-> Exp1 +simplifyProjections :: Exp1 -> Exp1 simplifyProjections expin = removeCommonExpressions (go expin M.empty) - where - go exp mp = case exp of - LetE (v, ls, t, bind) body -> - case bind of + where + go exp mp = + case exp of + LetE (v, ls, t, bind) body -> + case bind of MkProdE prodList -> let bind' = go bind mp mp' = M.insert v (V.fromList prodList) mp body' = go body mp' - in LetE (v, ls, t, bind') body' `debug1` ("here is one lol" L.++ render (pprint expin) ) - + in LetE (v, ls, t, bind') body' `debug1` + ("here is one lol" L.++ render (pprint expin)) otherwise -> let bind' = go bind mp body' = go body mp - in LetE (v, ls, t, bind') body' - - IfE cond thenBody elseBody -> - IfE (go cond mp ) (go thenBody mp ) (go elseBody mp) - - CaseE e ls -> let ls' = L.map (\(x, y, exp) -> (x, y, go exp mp)) ls - in CaseE (go e mp) ls' - - PrimAppE p ls -> - let ls' = L.map (`go` mp) ls - in PrimAppE p ls' - - TimeIt exp x y -> TimeIt (go exp mp) x y - - L1.ProjE i e -> - case e of - VarE v -> - case M.lookup v mp of - Nothing -> L1.ProjE i e - Just ls -> ls V.! i - otherwise -> L1.ProjE i (go e mp) - DataConE x y ls-> - let ls' = L.map (`go` mp) ls - in DataConE x y ls' - AppE v loc args -> - AppE v loc (map (`go` mp) args) - MkProdE ls-> - let ls' = L.map (`go` mp) ls - in MkProdE ls' - - x -> x - -replaceLeafWithExp :: Exp1 -> Exp1 -> Exp1 -replaceLeafWithExp exp newTail = - go exp - where - go ex = + in LetE (v, ls, t, bind') body' + IfE cond thenBody elseBody -> + IfE (go cond mp) (go thenBody mp) (go elseBody mp) + CaseE e ls -> + let ls' = L.map (\(x, y, exp) -> (x, y, go exp mp)) ls + in CaseE (go e mp) ls' + PrimAppE p ls -> + let ls' = L.map (`go` mp) ls + in PrimAppE p ls' + TimeIt exp x y -> TimeIt (go exp mp) x y + L1.ProjE i e -> + case e of + VarE v -> + case M.lookup v mp of + Nothing -> L1.ProjE i e + Just ls -> ls V.! i + otherwise -> L1.ProjE i (go e mp) + DataConE x y ls -> + let ls' = L.map (`go` mp) ls + in DataConE x y ls' + AppE v loc args -> AppE v loc (map (`go` mp) args) + MkProdE ls -> + let ls' = L.map (`go` mp) ls + in MkProdE ls' + x -> x + +replaceLeafWithExp :: Exp1 -> Exp1 -> Exp1 +replaceLeafWithExp exp newTail = go exp + where + go ex = case ex of - L1.LetE (v,ls,t, e1) e2 -> L1.LetE (v,ls,t, e1) (go e2) - x -> newTail + L1.LetE (v, ls, t, e1) e2 -> L1.LetE (v, ls, t, e1) (go e2) + x -> newTail replaceLeafWithBind :: Exp1 -> (Int -> Var) -> Ty1 -> Exp1 -> Exp1 -replaceLeafWithBind exp genVar varType tailExp = - go exp - where - go ex = +replaceLeafWithBind exp genVar varType tailExp = go exp + where + go ex = case ex of - L1.LetE (v,ls,t, e1) e2 -> L1.LetE (v,ls,t, e1) (go e2) - x -> case varType of - ProdTy ls2 -> - let xDestructed = V.fromList (case x of MkProdE ls -> ls) - newExp = V.ifoldl - (\tExp subscript ty -> - let newVar = genVar subscript - in L1.LetE (newVar,[],ty, xDestructed V.! subscript) tExp - ) tailExp (V.fromList ls2) - in newExp - otherwise -> - let newVar = genVar 0 - in L1.LetE (newVar,[],varType, x) tailExp - -addOuterTailCall:: Exp1 -> Var -> Var -> Ty1 -> [Exp1] -> Exp1 + L1.LetE (v, ls, t, e1) e2 -> L1.LetE (v, ls, t, e1) (go e2) + x -> + case varType of + ProdTy ls2 -> + let xDestructed = + V.fromList + (case x of + MkProdE ls -> ls) + newExp = + V.ifoldl + (\tExp subscript ty -> + let newVar = genVar subscript + in L1.LetE + (newVar, [], ty, xDestructed V.! subscript) + tExp) + tailExp + (V.fromList ls2) + in newExp + otherwise -> + let newVar = genVar 0 + in L1.LetE (newVar, [], varType, x) tailExp + +addOuterTailCall :: Exp1 -> Var -> Var -> Ty1 -> [Exp1] -> Exp1 addOuterTailCall exp fName parName varType outerArgs = removeCommonExpressions (go exp) - where - go ex = + where + go ex = case ex of - L1.LetE (v,ls,t, e1) e2 -> L1.LetE (v,ls,t, e1) (go e2) - x -> - let newCall = AppE fName [] ( (VarE parName) :outerArgs) - newLet = LetE (parName, [], varType, x) newCall - in newLet + L1.LetE (v, ls, t, e1) e2 -> L1.LetE (v, ls, t, e1) (go e2) + x -> + let newCall = AppE fName [] ((VarE parName) : outerArgs) + newLet = LetE (parName, [], varType, x) newCall + in newLet + {- This function≈ collect the following information for each defined variable: 1) The defining expression. (stored in DefTableEntry::def) 2) The consumer of the definition that are candidates for fusion;the function @@ -252,17 +260,12 @@ buildDefTable ex = go ex Nothing M.empty M.insert symLet (DefTableEntry - { def = bind - , fun_uses = [] - , all_use_count = 0 - , varType = t - }) + {def = bind, fun_uses = [], all_use_count = 0, varType = t}) table table'' = go bind (Just symLet) table' in go body definingSymbol table'' - - -- The thing that is traversed is always the first argument. - -- Here, we record a function use for the first argument + +-- Here, we record a function use for the first argument -- in the DefTable. -- add function uses of interest -- [functions calls traversing tree in first argument] @@ -302,22 +305,22 @@ buildDefTable ex = go ex Nothing M.empty ProjE index exp -> go (exp) Nothing table LitE _ -> table x -> - table `debug` - ("please handle:" L.++ show x L.++ "in buildDefTable\n") + table `debug` ("please handle:" L.++ show x L.++ "in buildDefTable\n") where incrUses (DefTableEntry def fun_uses c t) = Just $ DefTableEntry def fun_uses (c + 1) t +-- The thing that is traversed is always the first argument. +extractAppNameFromLet :: Exp1 -> Var +extractAppNameFromLet (LetE (Var symLet, _, _, (AppE var _ _)) _) = var -extractAppNameFromLet :: Exp1 -> Var -extractAppNameFromLet (LetE (Var symLet,_,_,(AppE var _ _ )) _) = var +extractLetSymbolFromLet :: Exp1 -> Symbol +extractLetSymbolFromLet (LetE (Var symLet, _, _, (AppE var _ _)) _) = symLet -extractLetSymbolFromLet :: Exp1 -> Symbol -extractLetSymbolFromLet (LetE (Var symLet,_,_,(AppE var _ _ )) _) = symLet +extractAppEName :: Exp1 -> Var +extractAppEName (AppE var _ _) = var +extractAppEName x = error (show x) -extractAppEName :: Exp1 -> Var -extractAppEName (AppE var _ _ ) = var -extractAppEName x = error(show x) -- Takes the table, and candidates which are already processed and -- return one that isn't. @@ -346,13 +349,15 @@ isPotential table symbol skipList = case symbol of Nothing -> False Just symb -> - case table M.!? symb of - Nothing -> False --`debug` (show skipList) - Just (DefTableEntry def fun_uses use_count t) -> - (L.length fun_uses == 1) && L.notElem (extractAppEName def, - extractAppEName(sel1 (L.head fun_uses)) ) skipList + case table M.!? symb of + Nothing -> False --`debug` (show skipList) + Just (DefTableEntry def fun_uses use_count t) -> + (L.length fun_uses == 1) && + L.notElem + (extractAppEName def, extractAppEName (sel1 (L.head fun_uses))) + skipList -simplifyCases2 :: Exp1 -> Exp1 +simplifyCases2 :: Exp1 -> Exp1 simplifyCases2 = go where go ex = @@ -368,8 +373,7 @@ simplifyCases2 = go where case_subst (x1:l1) (x2:l2) exp = subst (fst x2) x1 (case_subst l1 l2 exp) case_subst [] [] exp = exp - CaseE (IfE e1 e2 e3) ls -> - go $ IfE e1 (CaseE e2 ls) (CaseE e3 ls) + CaseE (IfE e1 e2 e3) ls -> go $ IfE e1 (CaseE e2 ls) (CaseE e3 ls) CaseE e1@(LetE bind body) ls1 -> let body' = go (CaseE body ls1) in LetE bind body' @@ -381,9 +385,8 @@ simplifyCases2 = go TimeIt e d b -> TimeIt (go e) d b ex -> ex -inline2 :: FunDef1 -> FunDef1 -> PassM FunDef1 -inline2 inlined_fun outer_fun = - do +inline2 :: FunDef1 -> FunDef1 -> PassM FunDef1 +inline2 inlined_fun outer_fun = do newTraversedTreeArg <- gensym (toVar "inputTree") let argTypes_outer = fst (funTy outer_fun) retType_outer = snd (funTy outer_fun) @@ -393,8 +396,6 @@ inline2 inlined_fun outer_fun = retTypeInlined = snd (funTy inlined_fun) traversedType = head argTypes_inlined -- All arguments except the one that's traversed. - - -- is it ok that those are swapped lol! sideArgsTypesInlined = tail argTypes_inlined sidArgsTypesOuter = tail argTypes_outer newType = @@ -404,55 +405,54 @@ inline2 inlined_fun outer_fun = let oldExp = VarE argVar_inlined newExp = VarE newTraversedTreeArg in substE oldExp newExp (funBody inlined_fun) - - -- the traversed tree in the outer is replaced with either a call to the inner - -- or the body of the inner + +-- or the body of the inner let oldExp = VarE argVar_outer let replaceWithCall exp = do newVar <- gensym (toVar "innerCall") let rhs = - (AppE - (funName inlined_fun) - [] - (L.map VarE ( newTraversedTreeArg:tail (funArgs inlined_fun)))) + (AppE + (funName inlined_fun) + [] + (L.map VarE (newTraversedTreeArg : tail (funArgs inlined_fun)))) body = substE oldExp (VarE newVar) exp return $ LetE (newVar, [], retTypeInlined, rhs) body - let outerCaseList = case (funBody outer_fun) of - CaseE e1 ls -> ls - + CaseE e1 ls -> ls newBody <- case (inlinedFunBody) of CaseE e1 ls -> do ls' <- Prelude.mapM (\(dataCon, vars, exp) -> do - if hasConstructorTail exp - then - do - let exp' = (CaseE (exp) outerCaseList) - exp'' <- replaceWithCall exp' - return (dataCon, vars, exp'') - else - do - newSymbol <- gensym (toVar "outerCall") - let exp' = - addOuterTailCall exp (funName outer_fun) (newSymbol) - (snd(funTy inlined_fun)) (L.map (\v -> (VarE v)) (tail (funArgs outer_fun))) - - return (dataCon, vars, exp') - ) + if hasConstructorTail exp + then do + let exp' = (CaseE (exp) outerCaseList) + exp'' <- replaceWithCall exp' + return (dataCon, vars, exp'') + else do + newSymbol <- gensym (toVar "outerCall") + let exp' = + addOuterTailCall + exp + (funName outer_fun) + (newSymbol) + (snd (funTy inlined_fun)) + (L.map (\v -> (VarE v)) (tail (funArgs outer_fun))) + return (dataCon, vars, exp')) ls return $ (CaseE (VarE newTraversedTreeArg) ls') - x-> error (render (pprint x)) - -- exp -> replaceWithCall (substE oldExp inlinedFunBody (l exp)) - + x -> error (render (pprint x)) + +-- exp -> replaceWithCall (substE oldExp inlinedFunBody (l exp)) let newArgs = [newTraversedTreeArg] L.++ L.tail (funArgs inlined_fun) L.++ L.tail (funArgs outer_fun) return outer_fun {funArgs = newArgs, funTy = newType, funBody = newBody} +-- is it ok that those are swapped lol! +-- the traversed tree in the outer is replaced with either a call to the inner {- case (case c of D1-> K ,.. -> f) @@ -486,17 +486,13 @@ inline inlined_fun outer_fun arg_pos = do let oldExp = VarE argVar_inlined newExp = VarE newTraversedTreeArg in substE oldExp newExp (funBody inlined_fun) - - -- the traversed tree in the outer is replaced with either a call to the inner - -- or the body of the inner + +-- or the body of the inner let oldExp = VarE argVar_outer let replaceWithCall exp = do newVar <- gensym (toVar "innerCall") let rhs = - (AppE - (funName inlined_fun) - [] - (L.map VarE (funArgs inlined_fun))) + (AppE (funName inlined_fun) [] (L.map VarE (funArgs inlined_fun))) body = substE oldExp (VarE newVar) exp return $ LetE (newVar, [], retTypeInlined, rhs) body newBody <- @@ -515,6 +511,7 @@ inline inlined_fun outer_fun arg_pos = do L.tail (funArgs outer_fun) return outer_fun {funArgs = newArgs, funTy = newType, funBody = newBody} +-- the traversed tree in the outer is replaced with either a call to the inner -- This function simplify the case expression when the matched expression -- is it self another case expression. @@ -536,8 +533,7 @@ simplifyCases function = function {funBody = go (funBody function)} where case_subst (x1:l1) (x2:l2) exp = subst (fst x2) x1 (case_subst l1 l2 exp) case_subst [] [] exp = exp - CaseE (IfE e1 e2 e3) ls -> - go $ IfE e1 (CaseE e2 ls) (CaseE e3 ls) + CaseE (IfE e1 e2 e3) ls -> go $ IfE e1 (CaseE e2 ls) (CaseE e3 ls) CaseE e1@((LetE bind body)) ls1 -> let body' = go (CaseE body ls1) in LetE bind body' @@ -549,102 +545,97 @@ simplifyCases function = function {funBody = go (funBody function)} TimeIt e d b -> TimeIt (go e) d b ex -> ex - foldFusedCallsF :: (Var, Var, Int, Var) -> FunDef1 -> FunDef1 foldFusedCallsF rule function = let funBody' = - case (funBody function) of + case (funBody function) of CaseE x ls -> - let ls' = L.map (\(a, b, exp) ->(a, b, foldFusedCalls rule exp )) ls in - CaseE x ls' - in function {funBody = funBody' } - + let ls' = L.map (\(a, b, exp) -> (a, b, foldFusedCalls rule exp)) ls + in CaseE x ls' + in function {funBody = funBody'} foldFusedCalls_Entry :: (Var, Var, Int, Var) -> Exp1 -> Exp1 foldFusedCalls_Entry rule@(outerName, innerName, argPos, newName) body = - case body of - CaseE x ls -> - let ls' = L.map (\(a, b, exp) ->(a, b, foldFusedCalls rule exp )) ls in - CaseE x ls' - otherwise -> foldFusedCalls rule body - - -inlineConstructorConsumers :: FunDefs1-> Exp1 -> PassM (Exp1) -inlineConstructorConsumers fdefs exp = - do - let defTable = buildDefTable (exp) - let exp2 = removeUnusedDefsExp (go defTable exp) - if(exp2 == exp) - then return exp2 - else - do - exp2' <- freshExp1 M.empty exp2 - inlineConstructorConsumers fdefs exp2' + case body of + CaseE x ls -> + let ls' = L.map (\(a, b, exp) -> (a, b, foldFusedCalls rule exp)) ls + in CaseE x ls' + otherwise -> foldFusedCalls rule body + +inlineConstructorConsumers :: FunDefs1 -> Exp1 -> PassM (Exp1) +inlineConstructorConsumers fdefs exp = do + let defTable = buildDefTable (exp) + let exp2 = removeUnusedDefsExp (go defTable exp) + if (exp2 == exp) + then return exp2 + else do + exp2' <- freshExp1 M.empty exp2 + inlineConstructorConsumers fdefs exp2' where - go defTable ex = - case ex of - original@(AppE fName loc parList) -> - case (head parList) of - VarE (Var symInner) -> - case (getDefiningConstructor symInner defTable) of - Just (DataConE loc dataCons args)-> - let calleeBody = funBody (fdefs M.! fName) - calleeArgs = funArgs (fdefs M.! fName) - calleeBody' = replaceArgs calleeBody calleeArgs parList - calleeBody'' = let oldExp = head parList - newExp =(DataConE loc dataCons args) - in substE oldExp newExp calleeBody' - - calleeBody''' = simplifyCases2 calleeBody'' - in ( calleeBody''') --`debug1` ( "here we are" L.++show (DataConE loc dataCons args )) - Nothing -> original --`debug1` ( "norm exit1" L.++show (AppE fName loc parList)) - _ -> original --`debug1` ( "norm exit2" L.++show (AppE fName loc parList)) - LetE (v, loc, t, lhs) bod -> - let normal = LetE (v, loc, t, lhs) (go defTable bod) in - case lhs of - original@(AppE fName loc parList) -> - case (head parList) of - VarE (Var symInner) -> - case (getDefiningConstructor symInner defTable) of - Just (DataConE loc dataCons args)-> do - let calleeBody = funBody (fdefs M.! fName) - calleeArgs = funArgs (fdefs M.! fName) - calleeBody' = replaceArgs calleeBody calleeArgs parList - calleeBody'' = let oldExp = head parList - newExp =(DataConE loc dataCons args) - in substE oldExp newExp calleeBody' --`debug1` ( "2here we are" L.++show ((DataConE loc dataCons args))) - - calleeBody''' = (simplifyCases2 calleeBody'') - leafExp = getLeafExpr calleeBody''' + go defTable ex = + case ex of + original@(AppE fName loc parList) -> + case (head parList) of + VarE (Var symInner) -> + case (getDefiningConstructor symInner defTable) of + Just (DataConE loc dataCons args) -> + let calleeBody = funBody (fdefs M.! fName) + calleeArgs = funArgs (fdefs M.! fName) + calleeBody' = replaceArgs calleeBody calleeArgs parList + calleeBody'' = + let oldExp = head parList + newExp = (DataConE loc dataCons args) + in substE oldExp newExp calleeBody' + calleeBody''' = simplifyCases2 calleeBody'' + in (calleeBody''') --`debug1` ( "here we are" L.++show (DataConE loc dataCons args )) + Nothing -> original --`debug1` ( "norm exit1" L.++show (AppE fName loc parList)) + _ -> original --`debug1` ( "norm exit2" L.++show (AppE fName loc parList)) + LetE (v, loc, t, lhs) bod -> + let normal = LetE (v, loc, t, lhs) (go defTable bod) + in case lhs of + original@(AppE fName loc parList) -> + case (head parList) of + VarE (Var symInner) -> + case (getDefiningConstructor symInner defTable) of + Just (DataConE loc dataCons args) -> do + let calleeBody = funBody (fdefs M.! fName) + calleeArgs = funArgs (fdefs M.! fName) + calleeBody' = + replaceArgs calleeBody calleeArgs parList + calleeBody'' = + let oldExp = head parList + newExp = (DataConE loc dataCons args) + in substE oldExp newExp calleeBody' --`debug1` ( "2here we are" L.++show ((DataConE loc dataCons args))) + calleeBody''' = (simplifyCases2 calleeBody'') + leafExp = getLeafExpr calleeBody''' -- `debug1`("A"L.++ (show calleeBody''')) - newTail = LetE (v, [], t, leafExp) (go defTable bod) + newTail = + LetE (v, [], t, leafExp) (go defTable bod) -- `debug1`("A"L.++ (show leafExp)) - go defTable (replaceLeafWithExp calleeBody''' newTail) + go defTable (replaceLeafWithExp calleeBody''' newTail) --debug1`("A"L.++ (show newTail)) - - Nothing -> normal-- `debug1` ( "2norm exit1" L.++show (AppE fName loc parList)) - _ -> normal-- `debug1` ( "2norm exit2" L.++show (AppE fName loc parList)) - _ ->normal - IfE e1 e2 e3 -> IfE (go defTable e1) (go defTable e2) (go defTable e3) - CaseE e1 ls1 -> CaseE e1 (L.map f ls1) - where f (dataCon, x, exp) = (dataCon, x, go defTable exp) - TimeIt e d b -> TimeIt (go defTable e) d b - DataConE loc dataCons ls -> DataConE loc dataCons (L.map (go defTable) ls) - _ -> ex - + Nothing -> normal -- `debug1` ( "2norm exit1" L.++show (AppE fName loc parList)) + _ -> normal -- `debug1` ( "2norm exit2" L.++show (AppE fName loc parList)) + _ -> normal + IfE e1 e2 e3 -> IfE (go defTable e1) (go defTable e2) (go defTable e3) + CaseE e1 ls1 -> CaseE e1 (L.map f ls1) + where f (dataCon, x, exp) = (dataCon, x, go defTable exp) + TimeIt e d b -> TimeIt (go defTable e) d b + DataConE loc dataCons ls -> + DataConE loc dataCons (L.map (go defTable) ls) + _ -> ex getDefiningConstructor x defTable = case M.lookup x defTable of - Nothing -> Nothing-- `debug1` ("not found" L.++ (show x)) + Nothing -> Nothing -- `debug1` ("not found" L.++ (show x)) Just entry -> case def entry of - cons@(DataConE{})-> Just cons - _ -> Nothing --`debug1` ("defined not as constr" L.++ (show x)) - + cons@(DataConE {}) -> Just cons + _ -> Nothing --`debug1` ("defined not as constr" L.++ (show x)) replaceArgs exp (h1:tailarg) (h2:tailPar) = - let oldExp = VarE h1 - newExp = h2 - exp'= substE oldExp newExp exp - in replaceArgs exp' tailarg tailPar + let oldExp = VarE h1 + newExp = h2 + exp' = substE oldExp newExp exp + in replaceArgs exp' tailarg tailPar replaceArgs exp [] [] = exp -- getArgs x defTable = -- case M.lookup x defTable of @@ -688,328 +679,345 @@ foldFusedCalls rule@(outerName, innerName, argPos, newName) body = Just entry -> case def entry of AppE v _ _ -> v - _ -> toVar "dummy" + _ -> toVar "dummy" getArgs x defTable = case M.lookup x defTable of Nothing -> error "error in foldFusedCalls" Just entry -> case def entry of AppE _ _ args -> args - _ -> error ("ops" L.++ show (def entry)) + _ -> error ("ops" L.++ show (def entry)) + -- outputPositions specify for each call i at what index is the corresponding -- output in the returned tuple -foldTupledFunctions :: Exp1 -> FunDef1 -> [Exp1] -> - V.Vector Int-> M.Map (Int, Int) (Int, Int) -> PassM (Exp1) -foldTupledFunctions bodyM newFun oldCalls outputPositions syncedArgs = - do - newVar <- gensym (toVar "tupled_output") - go bodyM newVar True +foldTupledFunctions :: + Exp1 + -> FunDef1 + -> [Exp1] + -> V.Vector Int + -> M.Map (Int, Int) (Int, Int) + -> PassM (Exp1) +foldTupledFunctions bodyM newFun oldCalls outputPositions syncedArgs = do + newVar <- gensym (toVar "tupled_output") + go bodyM newVar True where go ex newVar first = case ex of LetE (Var y, loc, t, rhs) body -> - case L.elemIndex (rhs) oldCalls of - Nothing -> - do - rhs' <- go rhs newVar first - LetE (Var y, loc, t, rhs') <$> go body newVar first - Just i -> - if first -- not valid af - then - do - body' <- go body newVar False - let args = V.ifoldl f [] (V.fromList oldCalls) - where - f ls1 fIdx exp = ls1 L.++ (extractArgs fIdx) exp - - extractArgs fIdx (AppE _ _ (h:tail)) = - V.toList (V.ifilter -- argIdx+1 because head is dropped (idx 0) - (\argIdx arg -> not ( M.member (fIdx, argIdx+1) syncedArgs)) - (V.fromList tail)) - - let args' = getFirstArg rhs:args - where - getFirstArg ((AppE _ _ (h:_)))= h --`debug` ("oldCalls" L.++ (show oldCalls) L.++ + case L.elemIndex (rhs) oldCalls of + Nothing -> do + rhs' <- go rhs newVar first + LetE (Var y, loc, t, rhs') <$> go body newVar first + Just i -> + if first -- not valid af + then do + body' <- go body newVar False + let args = V.ifoldl f [] (V.fromList oldCalls) + where + f ls1 fIdx exp = ls1 L.++ (extractArgs fIdx) exp + extractArgs fIdx (AppE _ _ (h:tail)) = + V.toList + (V.ifilter -- argIdx+1 because head is dropped (idx 0) + (\argIdx arg -> + not (M.member (fIdx, argIdx + 1) syncedArgs)) + (V.fromList tail)) + let args' = getFirstArg rhs : args + where + getFirstArg ((AppE _ _ (h:_))) = h --`debug` ("oldCalls" L.++ (show oldCalls) L.++ --(render( pprint bodyM))) - - let rhs' = AppE (funName newFun) [] args' + let rhs' = AppE (funName newFun) [] args' -- `debug` ("new call" L.++ (show (AppE (funName newFun) [] args'))) - let bindType = outTy (funTy newFun) - let rhs'' = case t of - ProdTy ls -> ( MkProdE ( - V.toList ( V.imap (\index _ -> - let idx =(outputPositions V.! i) +index - in ProjE idx (VarE newVar) ) - (V.fromList ls) )) ) - otherwise -> - let idx = outputPositions V.! i - - in ProjE idx (VarE newVar)-- not complete buggy (i +eps) - let body'' = LetE (Var y, loc, t, rhs'') body' - body3 = LetE (newVar, [], bindType, rhs') body'' - body4 = collectArgsConstruction args body3 - return body4 - - else - do - body' <- go body newVar first--`debug` ("\nhere\n") - let rhs' = case t of - ProdTy ls -> ( MkProdE ( - V.toList ( V.imap (\index _ -> - let idx = (outputPositions V.! i )+index - - in ProjE idx (VarE newVar) ) - (V.fromList ls) ))) - - _ -> - let idx = outputPositions V.! i - - in ProjE idx (VarE newVar) -- not complete buggy (i +eps) - return(LetE (Var y, loc, t, rhs') body') - - AppE name loc argList -> - do - argList' <- Prelude.mapM (\x -> go x newVar first) argList - return $ AppE name loc argList' - PrimAppE x ls -> - PrimAppE x <$> Prelude.mapM (\x -> go x newVar first) ls - - LetE (v,loc,t,rhs) bod -> do - body' <- go bod newVar first - rhs' <- go rhs newVar first - return $ LetE (v,loc,t, rhs') body' - IfE e1 e2 e3 -> do + let bindType = outTy (funTy newFun) + let rhs'' = + case t of + ProdTy ls -> + (MkProdE + (V.toList + (V.imap + (\index _ -> + let idx = + (outputPositions V.! i) + index + in ProjE idx (VarE newVar)) + (V.fromList ls)))) + otherwise -> + let idx = outputPositions V.! i + in ProjE idx (VarE newVar) -- not complete buggy (i +eps) + let body'' = LetE (Var y, loc, t, rhs'') body' + body3 = LetE (newVar, [], bindType, rhs') body'' + body4 = collectArgsConstruction args body3 + return body4 + else do + body' <- go body newVar first --`debug` ("\nhere\n") + let rhs' = + case t of + ProdTy ls -> + (MkProdE + (V.toList + (V.imap + (\index _ -> + let idx = + (outputPositions V.! i) + index + in ProjE idx (VarE newVar)) + (V.fromList ls)))) + _ -> + let idx = outputPositions V.! i + in ProjE idx (VarE newVar) -- not complete buggy (i +eps) + return (LetE (Var y, loc, t, rhs') body') + AppE name loc argList -> do + argList' <- Prelude.mapM (\x -> go x newVar first) argList + return $ AppE name loc argList' + PrimAppE x ls -> + PrimAppE x <$> Prelude.mapM (\x -> go x newVar first) ls + LetE (v, loc, t, rhs) bod -> do + body' <- go bod newVar first + rhs' <- go rhs newVar first + return $ LetE (v, loc, t, rhs') body' + IfE e1 e2 e3 -> do e1' <- go e1 newVar first e2' <- go e2 newVar first IfE e1' e2' <$> go e3 newVar first - - MkProdE ls -> - MkProdE <$> Prelude.mapM (\x -> go x newVar first) ls - ProjE index exp -> - ProjE index <$> go exp newVar first - CaseE e1 ls1 -> do + MkProdE ls -> MkProdE <$> Prelude.mapM (\x -> go x newVar first) ls + ProjE index exp -> ProjE index <$> go exp newVar first + CaseE e1 ls1 -- e1' <- go e1 newVar first - CaseE e1 <$> Prelude.mapM (\(dataCon,x,exp)-> - do - exp' <- go exp newVar True - return (dataCon, x, exp') - ) ls1 - + -> do + CaseE e1 <$> + Prelude.mapM + (\(dataCon, x, exp) -> do + exp' <- go exp newVar True + return (dataCon, x, exp')) + ls1 DataConE loc datacons ls -> DataConE loc datacons <$> Prelude.mapM (\x -> go x newVar first) ls - TimeIt e d b -> do - e'<- go e newVar first - return $ TimeIt e' d b - _ -> - return ex - + TimeIt e d b -> do + e' <- go e newVar first + return $ TimeIt e' d b + _ -> return ex defTable = buildDefTable (bodyM) - collectRec leafExp exp = + collectRec leafExp exp = case exp of VarE v@(Var symbol) -> - case M.lookup symbol defTable of - Nothing -> leafExp - Just (DefTableEntry definingExp _ _ t)-> - collectRec ( LetE (v ,[], t, definingExp) leafExp) definingExp + case M.lookup symbol defTable of + Nothing -> leafExp + Just (DefTableEntry definingExp _ _ t) -> + collectRec (LetE (v, [], t, definingExp) leafExp) definingExp AppE fName _ args -> L.foldl collectRec leafExp args - MkProdE expList -> L.foldl collectRec leafExp expList + MkProdE expList -> L.foldl collectRec leafExp expList PrimAppE _ args -> L.foldl collectRec leafExp args - IfE cond thenBody elseBody -> - L.foldl collectRec leafExp [cond, thenBody, elseBody ] + IfE cond thenBody elseBody -> + L.foldl collectRec leafExp [cond, thenBody, elseBody] DataConE _ _ expList -> L.foldl collectRec leafExp expList ProjE index exp -> collectRec leafExp exp LitE _ -> leafExp -- LetE (Var s,loc,t,rhs) bod -> -- L.foldl collectRec leafExp [rhs, bod] - x -> error ( "please handle me explicitly" L.++ (show x)) + x -> error ("please handle me explicitly" L.++ (show x)) + collectArgsConstruction args exp = L.foldl collectRec exp args - collectArgsConstruction args exp = L.foldl collectRec exp args removeUnusedDefs :: FunDef1 -> FunDef1 -removeUnusedDefs f = f{funBody = removeUnusedDefsExp (funBody f)} +removeUnusedDefs f = f {funBody = removeUnusedDefsExp (funBody f)} -removeUnusedDefsExp :: Exp1 -> Exp1 +removeUnusedDefsExp :: Exp1 -> Exp1 removeUnusedDefsExp exp = let defTable = buildDefTable (exp) - in go exp defTable - where - go ex dTable = case ex of - LetE (Var s,loc,t,rhs) bod -> - case M.lookup s dTable of - Nothing -> LetE (Var s,loc,t, go rhs dTable) (go bod dTable) - Just ( DefTableEntry _ _ 0 t) -> go bod dTable - Just _ -> LetE (Var s,loc,t, go rhs dTable) (go bod dTable) - IfE e1 e2 e3 -> - IfE (go e1 dTable) ( go e2 dTable) ( go e3 dTable) - CaseE e1 ls1 -> CaseE e1 (L.map f ls1) - where - f (dataCon,x,exp) = (dataCon, x, go exp dTable) - AppE v loc argList -> - AppE v loc (L.map (`go` dTable) argList ) - TimeIt exp a b -> TimeIt (go exp dTable) a b - _ -> ex - -tupleListOfFunctions :: DDefs Ty1 -> [FunDef1] -> Var -> - M.Map (Int, Int) (Int, Int) -> PassM FunDef1 -tupleListOfFunctions ddefs funcList newName syncedArgs = do + in go exp defTable + where + go ex dTable = + case ex of + LetE (Var s, loc, t, rhs) bod -> + case M.lookup s dTable of + Nothing -> LetE (Var s, loc, t, go rhs dTable) (go bod dTable) + Just (DefTableEntry _ _ 0 t) -> go bod dTable + Just _ -> LetE (Var s, loc, t, go rhs dTable) (go bod dTable) + IfE e1 e2 e3 -> IfE (go e1 dTable) (go e2 dTable) (go e3 dTable) + CaseE e1 ls1 -> CaseE e1 (L.map f ls1) + where f (dataCon, x, exp) = (dataCon, x, go exp dTable) + AppE v loc argList -> AppE v loc (L.map (`go` dTable) argList) + TimeIt exp a b -> TimeIt (go exp dTable) a b + _ -> ex + +tupleListOfFunctions :: + DDefs Ty1 + -> [FunDef1] + -> Var + -> M.Map (Int, Int) (Int, Int) + -> PassM FunDef1 +tupleListOfFunctions ddefs funcList newName syncedArgs = do funcBodies <- Prelude.mapM freshFunction funcList let funcBodiesV = V.fromList funcBodies - retTypes = V.map (snd . funTy) funcBodiesV - newRetType = ProdTy (V.foldl - (\ls ty -> - case ty of - ProdTy ls2 -> ls L.++ ls2 - otherwise -> ls L.++ [ty] - ) [] retTypes ) - - -- we can change this now + retTypes = V.map (snd . funTy) funcBodiesV + newRetType = + ProdTy + (V.foldl + (\ls ty -> + case ty of + ProdTy ls2 -> ls L.++ ls2 + otherwise -> ls L.++ [ty]) + [] + retTypes) newFuncInputType = V.ifoldl f [] funcBodiesV where f ls fIdx fdef = case fst (funTy fdef) of - (h:tail)-> + (h:tail) -> let concreteArgs = V.ifoldl f [] (V.fromList tail) - where - f res argIdx arg = - -- add one to argIdx becasue head is deleted - if M.member (fIdx, argIdx+1 ) syncedArgs - then res - else res L.++ [arg] - - in if fIdx == 0 - then - ls L.++ [h] L.++ concreteArgs - else - ls L.++ concreteArgs - + where + f res argIdx arg + +-- add one to argIdx becasue head is deleted + = + if M.member (fIdx, argIdx + 1) syncedArgs + then res + else res L.++ [arg] + in if fIdx == 0 + then ls L.++ [h] L.++ concreteArgs + else ls L.++ concreteArgs let traversedType = L.head newFuncInputType - traversedTreeArg <- gensym (toVar "input") - let newArgs = traversedTreeArg: + let newArgs = + traversedTreeArg : V.ifoldl - (\ls fIdx f -> - ls L.++ - (V.toList - (V.ifilter - (\argIdx _-> not (M.member (fIdx, argIdx+1) syncedArgs)) - (V.fromList (L.tail (funArgs f)))) - ) - ) [] funcBodiesV - + (\ls fIdx f -> + ls L.++ + (V.toList + (V.ifilter + (\argIdx _ -> not (M.member (fIdx, argIdx + 1) syncedArgs)) + (V.fromList (L.tail (funArgs f)))))) + [] + funcBodiesV let argsLocsToVarMap = V.ifoldl - (\mp fIdx func -> - V.ifoldl - (\mpinner argIdx argVar-> M.insert (fIdx, argIdx) argVar mpinner) - mp (V.fromList (funArgs func)) - ) M.empty funcBodiesV - - -- replace the traversed tree variable with the new common one - let functionsBodies' = V.toList (V.imap getBody funcBodiesV) - where + (\mp fIdx func -> + V.ifoldl + (\mpinner argIdx argVar -> M.insert (fIdx, argIdx) argVar mpinner) + mp + (V.fromList (funArgs func))) + M.empty + funcBodiesV + let functionsBodies' = V.toList (V.imap getBody funcBodiesV) + where getBody i func = - let oldExp = VarE (L.head (funArgs func )) + let oldExp = VarE (L.head (funArgs func)) newExp = (VarE traversedTreeArg) - in substE oldExp newExp (funBody func) - - -- output of this is a map from dataCons -> [exp'] which are the portions + in substE oldExp newExp (funBody func) -- from each functions that map to the constructor let step2 = L.foldl mapAndSplit M.empty functionsBodies' where - mapAndSplit mp (CaseE e lsCase) = L.foldl f mp lsCase - where f mp (dataCons, vars, exp) = - let exp' = subsVars exp - in case M.lookup dataCons mp of - Nothing -> M.insert dataCons [exp'] mp - Just x -> M.insert dataCons (x L.++ [exp']) mp - where - subsVars ex = V.ifoldr subsVar ex (V.fromList vars) - subsVar index v ex = - let oldExp = VarE (fst v) - newExp = (VarE (toVar (L.map toLower - (dataCons L.++ show index)))) - in substE oldExp newExp ex - - + mapAndSplit mp (CaseE e lsCase) = L.foldl f mp lsCase + where + f mp (dataCons, vars, exp) = + let exp' = subsVars exp + in case M.lookup dataCons mp of + Nothing -> M.insert dataCons [exp'] mp + Just x -> M.insert dataCons (x L.++ [exp']) mp + where + subsVars ex = V.ifoldr subsVar ex (V.fromList vars) + subsVar index v ex = + let oldExp = VarE (fst v) + newExp = + (VarE + (toVar (L.map toLower (dataCons L.++ show index)))) + in substE oldExp newExp ex let traversedTreeDDef = - lookupDDef ddefs (case traversedType of (PackedTy tName _) -> tName) - - -- this is the returned tuple (out1_1, out1_2, out2_1 ..etc) those variables - -- stores the result - let tailExpr = MkProdE ( V.ifoldl - (\ls index ty -> - case ty of - ProdTy ls2 -> - let newElements =V.toList( - V.imap (\subscript _ -> VarE (createOutVar index subscript)) - (V.fromList ls2)) - in (ls L.++ newElements) - - _ -> - let newElement = VarE (createOutVar index 0 ) - in ls L.++ [newElement] - - ) [] retTypes) - + lookupDDef + ddefs + (case traversedType of + (PackedTy tName _) -> tName) + +-- stores the result + let tailExpr = + MkProdE + (V.ifoldl + (\ls index ty -> + case ty of + ProdTy ls2 -> + let newElements = + V.toList + (V.imap + (\subscript _ -> + VarE (createOutVar index subscript)) + (V.fromList ls2)) + in (ls L.++ newElements) + _ -> + let newElement = VarE (createOutVar index 0) + in ls L.++ [newElement]) + [] + retTypes) let topLevelExpr = CaseE (VarE traversedTreeArg) [] - - let extendedCase = L.foldr addConstructorBody topLevelExpr - (dataCons traversedTreeDDef) + let extendedCase = + L.foldr addConstructorBody topLevelExpr (dataCons traversedTreeDDef) where - addConstructorBody (dataCons, varls) (CaseE e1 caseList) = - - -- a list of the names of the constructor variables - -- e.g [leaf0, leaf1] or [inner0, inner1, inner2, inner3] - let newVarsList = V.toList( V.imap (\index _ -> ( toVar (L.map - toLower (dataCons L.++ show index)) ,() ) )(V.fromList varls)) - - bodiesOfConst =V.fromList (L.reverse (step2 M.! dataCons)) - combinedBodies = V.ifoldl f tailExpr bodiesOfConst - where - f tailExp index exp = - - let pos = V.length funcBodiesV - index -1 - newVar = createOutVar pos - newVarType = snd (funTy (funcBodiesV V.!pos)) - in replaceLeafWithBind exp newVar newVarType tailExp - in CaseE e1 ((dataCons, newVarsList, combinedBodies):caseList) + addConstructorBody (dataCons, varls) (CaseE e1 caseList) + +-- e.g [leaf0, leaf1] or [inner0, inner1, inner2, inner3] + = + let newVarsList = + V.toList + (V.imap + (\index _ -> + (toVar (L.map toLower (dataCons L.++ show index)), ())) + (V.fromList varls)) + bodiesOfConst = V.fromList (L.reverse (step2 M.! dataCons)) + combinedBodies = V.ifoldl f tailExpr bodiesOfConst + where + f tailExp index exp = + let pos = V.length funcBodiesV - index - 1 + newVar = createOutVar pos + newVarType = snd (funTy (funcBodiesV V.! pos)) + in replaceLeafWithBind exp newVar newVarType tailExp + in CaseE e1 ((dataCons, newVarsList, combinedBodies) : caseList) -- replace uses of eliminated synced Input args let finalBody = - M.foldlWithKey - (\exp k v-> - let oldExp = VarE (argsLocsToVarMap M.! k) - newExp = VarE (argsLocsToVarMap M.! v) - in substE oldExp newExp exp - ) extendedCase syncedArgs + M.foldlWithKey + (\exp k v -> + let oldExp = VarE (argsLocsToVarMap M.! k) + newExp = VarE (argsLocsToVarMap M.! v) + in substE oldExp newExp exp) + extendedCase + syncedArgs + return + (FunDef + newName + newArgs + (newFuncInputType, newRetType) + finalBody + (FunMeta NotRec NoInline False NoLayoutOpt Nothing)) + where + createOutVar index subscript = + toVar ("f" L.++ show index L.++ "out" L.++ show subscript) - return (FunDef newName newArgs (newFuncInputType,newRetType) finalBody (FunMeta NotRec NoInline False)) - where - createOutVar index subscript= - toVar ("f" L.++ show index L.++"out" L.++ show subscript) +-- we can change this now +-- replace the traversed tree variable with the new common one +-- output of this is a map from dataCons -> [exp'] which are the portions +-- this is the returned tuple (out1_1, out1_2, out2_1 ..etc) those variables +-- a list of the names of the constructor variables renameFunction :: FunDef1 -> Var -> FunDef1 renameFunction function newName = - function{funName=newName, funBody = go (funBody function)} - where - go ex = - let oldName = funName function in - case ex of - AppE name loc argList -> - AppE (if name==oldName then newName else name) loc argList - PrimAppE x ls -> PrimAppE x (L.map f ls) - where f item = go item - LetE (v,loc,t,rhs) bod -> LetE (v,loc,t, go rhs) (go bod) - MkProdE ls -> MkProdE (L.map go ls) - ProjE index exp -> ProjE index (go exp) - CaseE e1 ls1 -> CaseE (go e1) (L.map f ls1) - where f (dataCon,x,exp) = (dataCon, x, go exp) - DataConE loc dataCons ls -> - DataConE loc dataCons (L.map go ls) - TimeIt e d b -> TimeIt (go e) d b - _ -> ex - - + function {funName = newName, funBody = go (funBody function)} + where + go ex = + let oldName = funName function + in case ex of + AppE name loc argList -> + AppE + (if name == oldName + then newName + else name) + loc + argList + PrimAppE x ls -> PrimAppE x (L.map f ls) + where f item = go item + LetE (v, loc, t, rhs) bod -> LetE (v, loc, t, go rhs) (go bod) + MkProdE ls -> MkProdE (L.map go ls) + ProjE index exp -> ProjE index (go exp) + CaseE e1 ls1 -> CaseE (go e1) (L.map f ls1) + where f (dataCon, x, exp) = (dataCon, x, go exp) + DataConE loc dataCons ls -> DataConE loc dataCons (L.map go ls) + TimeIt e d b -> TimeIt (go e) d b + _ -> ex {- We want to search for the following: @@ -1024,494 +1032,521 @@ the return format is the following [(x1, [f1, f2])] -} -- should be a preorder and not a post order OMG!!! -buildTupleCandidatesTable:: FunDefs1 -> Exp1 -> [Var] -> M.Map Var [Exp1] +buildTupleCandidatesTable :: FunDefs1 -> Exp1 -> [Var] -> M.Map Var [Exp1] buildTupleCandidatesTable fDefs exp argsVars = - M.map (\ls -> L.map snd ls) (go exp M.empty) - where - go ex tb = case ex of - AppE{} -> tb - PrimAppE _ _ -> tb - LetE (boundedVar,_,_,rhs) body -> - let tb'= - case rhs of - callExp@(AppE fName _ argList@((VarE inputTree):tail)) -> - let otherCalls = if M.member inputTree tb - then (tb M.! inputTree) - else [] in - if (isTupleable (fDefs M.! fName)) && - (haveIndependentArgsNew tail otherCalls) - then - let addCall Nothing = Just [(boundedVar, callExp)] - addCall (Just ls) = Just $ L.nub $(boundedVar, callExp):ls - in M.alter addCall inputTree tb - else tb - _ -> tb - in go body tb' - - IfE e1 e2 e3 -> let t1 = go e1 tb - t2 = go e2 t1 - in go e3 t2 - MkProdE ls -> tb - ProjE index exp -> tb - CaseE e1 ls1 -> error ("not expected in here ") - DataConE loc datacons ls -> - L.foldl f tb ls where f table exp = go exp table - TimeIt exp _ _ -> go exp tb - _ -> tb - where - defTable = buildDefTable (exp) - - isTupleable f = case (funBody f) of + M.map (\ls -> L.map snd ls) (go exp M.empty) + where + go ex tb = + case ex of + AppE {} -> tb + PrimAppE _ _ -> tb + LetE (boundedVar, _, _, rhs) body -> + let tb' = + case rhs of + callExp@(AppE fName _ argList@((VarE inputTree):tail)) -> + let otherCalls = + if M.member inputTree tb + then (tb M.! inputTree) + else [] + in if (isTupleable (fDefs M.! fName)) && + (haveIndependentArgsNew tail otherCalls) + then let addCall Nothing = + Just [(boundedVar, callExp)] + addCall (Just ls) = + Just $ L.nub ((boundedVar, callExp) : ls) + in M.alter addCall inputTree tb + else tb + _ -> tb + in go body tb' + IfE e1 e2 e3 -> + let t1 = go e1 tb + t2 = go e2 t1 + in go e3 t2 + MkProdE ls -> tb + ProjE index exp -> tb + CaseE e1 ls1 -> error ("not expected in here ") + DataConE loc datacons ls -> L.foldl f tb ls + where f table exp = go exp table + TimeIt exp _ _ -> go exp tb + _ -> tb + where + defTable = buildDefTable (exp) + isTupleable f = + case (funBody f) ---add a check that there is no nested case (maybe) - CaseE e _ -> case e of - VarE v -> v == L.head (funArgs f) + of + CaseE e _ -> + case e of + VarE v -> v == L.head (funArgs f) + _ -> False _ -> False - _ -> False - - isTrivial f = - if not (isTupleable f ) - then True - else - case (funBody f) of - CaseE e ls -> - L.foldl (\res (_ ,_ ,exp) -> res && (go exp )) True ls - where - go exp = - case exp of - LetE (boundedVar,_,_,rhs) body -> - case rhs of - AppE{} -> False - otherwise -> go body - AppE{} -> False - otherwise -> True - - - - - -- we want to make sure that args are independent on "other calls" - haveIndependentArgsNew args otherCalls = - let varsToAvoid = S.fromList (L.map fst otherCalls) - dependentVars = S.unions (L.map collectDependentVarsExp args) - in S.null (S.intersection varsToAvoid dependentVars) - - collectDependentVarsExp exp = - case exp of - VarE v@(Var symbol) -> - case M.lookup symbol defTable of - Nothing -> S.empty - Just (DefTableEntry definingExp _ _ _) -> - S.insert v (collectDependentVarsExp definingExp) - - AppE fName _ args -> S.unions (L.map collectDependentVarsExp args ) - MkProdE expList -> S.unions (L.map collectDependentVarsExp expList) - PrimAppE _ args-> S.unions (L.map collectDependentVarsExp args ) - - IfE cond thenBody elseBody -> - S.unions - [collectDependentVarsExp cond, collectDependentVarsExp thenBody, - collectDependentVarsExp elseBody ] - DataConE _ _ expList -> S.unions (L.map collectDependentVarsExp expList) - ProjE index exp -> collectDependentVarsExp exp - LitE _ -> S.empty - LetE (Var s,loc,t,rhs) body -> - S.unions [collectDependentVarsExp rhs, - collectDependentVarsExp body] - x -> error ( "please handle me explicitly" L.++ (show x)) - -cleanExp :: Exp1 -> Exp1 + isTrivial f = + if not (isTupleable f) + then True + else case (funBody f) of + CaseE e ls -> + L.foldl (\res (_, _, exp) -> res && (go exp)) True ls + where go exp = + case exp of + LetE (boundedVar, _, _, rhs) body -> + case rhs of + AppE {} -> False + otherwise -> go body + AppE {} -> False + otherwise -> True + haveIndependentArgsNew args otherCalls = + let varsToAvoid = S.fromList (L.map fst otherCalls) + dependentVars = S.unions (L.map collectDependentVarsExp args) + in S.null (S.intersection varsToAvoid dependentVars) + collectDependentVarsExp exp = + case exp of + VarE v@(Var symbol) -> + case M.lookup symbol defTable of + Nothing -> S.empty + Just (DefTableEntry definingExp _ _ _) -> + S.insert v (collectDependentVarsExp definingExp) + AppE fName _ args -> S.unions (L.map collectDependentVarsExp args) + MkProdE expList -> S.unions (L.map collectDependentVarsExp expList) + PrimAppE _ args -> S.unions (L.map collectDependentVarsExp args) + IfE cond thenBody elseBody -> + S.unions + [ collectDependentVarsExp cond + , collectDependentVarsExp thenBody + , collectDependentVarsExp elseBody + ] + DataConE _ _ expList -> + S.unions (L.map collectDependentVarsExp expList) + ProjE index exp -> collectDependentVarsExp exp + LitE _ -> S.empty + LetE (Var s, loc, t, rhs) body -> + S.unions + [collectDependentVarsExp rhs, collectDependentVarsExp body] + x -> error ("please handle me explicitly" L.++ (show x)) + + +-- we want to make sure that args are independent on "other calls" +cleanExp :: Exp1 -> Exp1 cleanExp exp = removeCommonExpressions (removeUnusedDefsExp exp) - -tuple_entry :: DDefs Ty1 -> FunDefs1 -> Exp1 -> [Var] -> Int -> PassM (Exp1, FunDefs1) +tuple_entry :: + DDefs Ty1 -> FunDefs1 -> Exp1 -> [Var] -> Int -> PassM (Exp1, FunDefs1) tuple_entry ddefs fdefs oldExp_ argsVars depth = do - case oldExp_ of - CaseE e ls -> - do - res <- Prelude.mapM - (\(x, y, ex) -> - do - (ex', defs) <- tuple ddefs fdefs ex argsVars depth - return ((x, y , ex'),defs)) - ls - let ls' = L.map fst res - let fdefs' = M.unions (L.map snd res) - return ((CaseE e ls') , fdefs') - otherwise -> error( render (pprint oldExp_ )) + case oldExp_ of + CaseE e ls -> do + res <- + Prelude.mapM + (\(x, y, ex) -> do + (ex', defs) <- tuple ddefs fdefs ex argsVars depth + return ((x, y, ex'), defs)) + ls + let ls' = L.map fst res + let fdefs' = M.unions (L.map snd res) + return ((CaseE e ls'), fdefs') + otherwise -> error (render (pprint oldExp_)) -- argsVars represents the arguments of the function that contains oldExp -tuple :: DDefs Ty1 -> FunDefs1 -> Exp1 -> [Var] -> Int -> PassM (Exp1, FunDefs1) -tuple ddefs fdefs oldExp_ argsVars depth= do - if depth> 1 then return (oldExp_, fdefs) - else - do ---lets pic one at a time only !! - let oldExp = cleanExp oldExp_ +tuple :: DDefs Ty1 -> FunDefs1 -> Exp1 -> [Var] -> Int -> PassM (Exp1, FunDefs1) +tuple ddefs fdefs oldExp_ argsVars depth = do + if depth > 1 + then return (oldExp_, fdefs) + else do + let oldExp = cleanExp oldExp_ -- candidates1 : a list of [(fName, CallExpressions)] functions that traverses -- same input - let candidates1 = L.filter f (M.toList (buildTupleCandidatesTable - fdefs oldExp argsVars) ) + let candidates1 = + L.filter + f + (M.toList (buildTupleCandidatesTable fdefs oldExp argsVars)) -- `debug` ("looking for candidates for " L.++ render (pprint oldExp)) - where f (_, ls) = L.length ls> 1 - - + where + f (_, ls) = L.length ls > 1 -- candidates2: a list [(tupleName, calls, syncedArgsLocs)] - -- syncedArgsLocs = [((1,2),(3,4)),..] this means args 4 in f3 is the same as - -- arg 2 in f1 - let candidates2 = L.map ( \(traversedVar, ls) -> - let sortedCalls = L.sortOn f ls - where f exp@(AppE fName _ _) = (fName, exp) - syncArgsLocs = computeSyncedArgs sortedCalls --`debug` ("done1") - - in (constructName sortedCalls (M.toList syncArgsLocs), sortedCalls, - syncArgsLocs)--`debug` ("done2") + +-- arg 2 in f1 + let candidates2 = + L.map + (\(traversedVar, ls) -> + let sortedCalls = L.sortOn f ls + where + f exp@(AppE fName _ _) = (fName, exp) + syncArgsLocs = computeSyncedArgs sortedCalls --`debug` ("done1") + in ( constructName sortedCalls (M.toList syncArgsLocs) + , sortedCalls + , syncArgsLocs --`debug` ("done2") + ) --`debug` ("orgArgs:" L.++ (render (pprint sortedCalls)) L.++ "\nargs" L.++ (show syncArgsLocs)) - ) candidates1 + ) + candidates1 -- `debug` ("filter candidates for " L.++ render (pprint oldExp)) --(newExp, fdefs') <- Control.Monad.foldM go (oldExp, fdefs) candidates2 - if L.length candidates2 > 0 - then - do - (newExp, fdefs') <- go (oldExp, fdefs) (L.head candidates2) - let newExp' = removeUnusedDefsExp (simplifyProjections newExp ) - (newExp'', fdefs'') <- tuple ddefs fdefs' newExp' argsVars depth - return (newExp'', fdefs'') `debug` (show "done one candidate") - else - return (oldExp, fdefs) `debug` (show "no candidates") - where + if L.length candidates2 > 0 + then do + (newExp, fdefs') <- go (oldExp, fdefs) (L.head candidates2) + let newExp' = removeUnusedDefsExp (simplifyProjections newExp) + (newExp'', fdefs'') <- tuple ddefs fdefs' newExp' argsVars depth + return (newExp'', fdefs'') `debug` (show "done one candidate") + else return (oldExp, fdefs) `debug` (show "no candidates") + where go (exp, fdefs) (tupledFName, callExpressions, syncArgsLocs) = case M.lookup tupledFName fdefs of Just fdef -> do - exp' <-foldTupledFunctions exp fdef callExpressions - (getOutputStartPositions fdefs callExpressions) syncArgsLocs - - let exp'' = simplifyProjections exp' - return (exp', fdefs) `debug` ("fold1" L.++ render (pprint exp'')) - + exp' <- + foldTupledFunctions + exp + fdef + callExpressions + (getOutputStartPositions fdefs callExpressions) + syncArgsLocs + let exp'' = simplifyProjections exp' + return (exp', fdefs) `debug` ("fold1" L.++ render (pprint exp'')) Nothing -> do - let functionsToTuple = L.map getCalledFunDef callExpressions - where - getCalledFunDef callExpr = case callExpr of - (AppE fName _ _) -> case M.lookup fName fdefs of - Just fdef -> fdef - - tupledFunction_ <- - tupleListOfFunctions - ddefs functionsToTuple tupledFName syncArgsLocs - `debug` ("funcs to tuple" L.++ (show functionsToTuple)) - tupledFunction <- freshFunction tupledFunction_ - - let tupledFunction' = - tupledFunction {funBody = cleanExp (funBody tupledFunction)} - `debug` ("tupled f is :" L.++ (render(pprint tupledFunction_))) - - let fdefs' = M.insert tupledFName tupledFunction' fdefs - let traversedArg = funArgs tupledFunction' - - (recTupledBody, newDefs) <- - tuple_entry ddefs fdefs' (funBody tupledFunction') traversedArg (depth+1) - `debug` ("\n done tupling :" L.++ (show tupledFName) - L.++ (render (pprint tupledFunction') ) - ) - - let tupledFunction'' = tupledFunction'{funBody=recTupledBody} - - let tupledFunction''' = - tupledFunction''{funBody= removeUnusedDefsExp - (simplifyProjections (funBody tupledFunction''))} - - let fdefs'' = M.insert tupledFName tupledFunction''' newDefs - - exp' <- - foldTupledFunctions exp tupledFunction''' callExpressions - (getOutputStartPositions fdefs'' - callExpressions ) syncArgsLocs - `debug` ("fold2 before folding" L.++ render (pprint exp)) - - let exp'' = simplifyProjections exp' - return (exp', fdefs'') `debug` ("fold2" L.++ render (pprint exp')) - + let functionsToTuple = L.map getCalledFunDef callExpressions + where + getCalledFunDef callExpr = + case callExpr of + (AppE fName _ _) -> + case M.lookup fName fdefs of + Just fdef -> fdef + tupledFunction_ <- + tupleListOfFunctions ddefs functionsToTuple tupledFName syncArgsLocs `debug` + ("funcs to tuple" L.++ (show functionsToTuple)) + tupledFunction <- freshFunction tupledFunction_ + let tupledFunction' = + tupledFunction {funBody = cleanExp (funBody tupledFunction)} `debug` + ("tupled f is :" L.++ (render (pprint tupledFunction_))) + let fdefs' = M.insert tupledFName tupledFunction' fdefs + let traversedArg = funArgs tupledFunction' + (recTupledBody, newDefs) <- + tuple_entry + ddefs + fdefs' + (funBody tupledFunction') + traversedArg + (depth + 1) `debug` + ("\n done tupling :" L.++ (show tupledFName) L.++ + (render (pprint tupledFunction'))) + let tupledFunction'' = tupledFunction' {funBody = recTupledBody} + let tupledFunction''' = + tupledFunction'' + { funBody = + removeUnusedDefsExp + (simplifyProjections (funBody tupledFunction'')) + } + let fdefs'' = M.insert tupledFName tupledFunction''' newDefs + exp' <- + foldTupledFunctions + exp + tupledFunction''' + callExpressions + (getOutputStartPositions fdefs'' callExpressions) + syncArgsLocs `debug` + ("fold2 before folding" L.++ render (pprint exp)) + let exp'' = simplifyProjections exp' + return (exp', fdefs'') `debug` ("fold2" L.++ render (pprint exp')) constructName ls syncArgsLocs = let syncedArgsText = L.foldr f "" syncArgsLocs - where - f ((f1, id1), (f2, id2)) txt = - txt L.++ "f" L.++ (show f1) L.++ "_" L.++ (show id1) L.++ "_from_" L.++ - "f" L.++ - show (f2) L.++ - "_" L.++ - (show id2) L.++ - "_n_" - in toVar - ("_TUP_" L.++ L.foldl appendName "" ls L.++ syncedArgsText L.++ "_TUP_") - - appendName str (AppE fName _ _) = - str L.++ "_t_" L.++ fromVar fName - - computeSyncedArgs callExpressions = + where + f ((f1, id1), (f2, id2)) txt = + txt L.++ "f" L.++ (show f1) L.++ "_" L.++ (show id1) L.++ + "_from_" L.++ + "f" L.++ + show (f2) L.++ + "_" L.++ + (show id2) L.++ + "_n_" + in toVar + ("_TUP_" L.++ L.foldl appendName "" ls L.++ syncedArgsText L.++ + "_TUP_") + appendName str (AppE fName _ _) = str L.++ "_t_" L.++ fromVar fName + computeSyncedArgs callExpressions --list of vectors of args [V1, V2 ...] + = let argsLists = L.map f callExpressions where f (AppE _ _ (h:tail)) = V.fromList tail - -- single list of (func-pos, arg-pos, argExp) all args in one list allArgsList = V.ifoldr f [] (V.fromList argsLists) where f idxFunc argsV res = - res L.++ V.toList - (V.imap (\idxVar var -> (idxFunc, idxVar + 1, var)) argsV) + res L.++ + V.toList + (V.imap (\idxVar var -> (idxFunc, idxVar + 1, var)) argsV) redundantPositions = L.foldr f (M.empty, M.empty) allArgsList where - f (funPos, argPos, argExp) (firstAppear, redundant) = - if M.member argExp firstAppear - then - (firstAppear, - M.insert (funPos, argPos) (firstAppear M.! argExp) redundant) - else - (M.insert argExp (funPos, argPos) firstAppear ,redundant) - + f (funPos, argPos, argExp) (firstAppear, redundant) = + if M.member argExp firstAppear + then ( firstAppear + , M.insert + (funPos, argPos) + (firstAppear M.! argExp) + redundant) + else (M.insert argExp (funPos, argPos) firstAppear, redundant) in snd redundantPositions -fixCalls :: Exp1 -> FunDef1 -> FunDef1 -> M.Map Int Int -> M.Map Int Int -> Var->Exp1 +-- syncedArgsLocs = [((1,2),(3,4)),..] this means args 4 in f3 is the same as + +--lets pic one at a time only !! +fixCalls :: + Exp1 -> FunDef1 -> FunDef1 -> M.Map Int Int -> M.Map Int Int -> Var -> Exp1 fixCalls exp fdefOld fdefNew redirectMap outputFromInput newName = go exp - where - go exp = case exp of + where + go exp = + case exp of CaseE e ls -> - let ls' = L.map (\(x, y, ex)-> (x, y, go ex)) ls - in CaseE e ls' - LetE (Var y, loc, t, rhs) body-> + let ls' = L.map (\(x, y, ex) -> (x, y, go ex)) ls + in CaseE e ls' + LetE (Var y, loc, t, rhs) body -> case rhs of AppE v ls args -> if v == funName fdefOld - then - let t' = snd (funTy fdefNew) in - let rhs' = AppE newName ls args in - let - body'= L.foldl - (\ex (i, j )-> - let oldExp = ProjE i (VarE (Var y)) - newExp = getExpAtIndex args j - in substE oldExp newExp ex `debug` ("replacing1" L.++ (show oldExp) L.++"with" L.++ ( show newExp)L.++ (show outputFromInput )) - ) body (M.toList outputFromInput) - - body'' = L.foldl - (\ex (i, j )-> - if i==j - then ex - else - let oldExp = ProjE i (VarE (Var y)) - newExp = ProjE j (VarE (Var y)) - in substE oldExp newExp ex `debug` ("replacing2" L.++ (show oldExp) L.++"with" L.++ ( show newExp)) - ) body' (M.toList redirectMap)-- in - - in LetE (Var y, loc, t', rhs') (go body'') - else - LetE (Var y, loc, t, rhs) (go body) - _ -> - LetE (Var y, loc, t, rhs) (go body) + then let t' = snd (funTy fdefNew) + in let rhs' = AppE newName ls args + in let body' = + L.foldl + (\ex (i, j) -> + let oldExp = ProjE i (VarE (Var y)) + newExp = getExpAtIndex args j + in substE oldExp newExp ex `debug` + ("replacing1" L.++ (show oldExp) L.++ + "with" L.++ + (show newExp) L.++ + (show outputFromInput))) + body + (M.toList outputFromInput) + body'' = + L.foldl + (\ex (i, j) -> + if i == j + then ex + else let oldExp = + ProjE i (VarE (Var y)) + newExp = + ProjE j (VarE (Var y)) + in substE oldExp newExp ex `debug` + ("replacing2" L.++ + (show oldExp) L.++ + "with" L.++ + (show newExp))) + body' + (M.toList redirectMap) -- in + in LetE (Var y, loc, t', rhs') (go body'') + else LetE (Var y, loc, t, rhs) (go body) + _ -> LetE (Var y, loc, t, rhs) (go body) otherwise -> otherwise -getExpAtIndex :: [Exp1] -> Int -> Exp1 +getExpAtIndex :: [Exp1] -> Int -> Exp1 getExpAtIndex ls id = ls L.!! id -getOutputStartPositions:: FunDefs1 -> [Exp1] -> V.Vector Int +getOutputStartPositions :: FunDefs1 -> [Exp1] -> V.Vector Int getOutputStartPositions fdefs callExpressions = - let functionsArgsLengths = L.map getCalledFunDef callExpressions in - let ls = L.foldl (\ls i -> ls L.++ [i+ L.last ls] ) [0] - functionsArgsLengths - in V.fromList ls - where - getCalledFunDef callExpr = case callExpr of - (AppE fName _ _) -> - case M.lookup fName fdefs of - Just fdef -> case snd (funTy fdef) of + let functionsArgsLengths = L.map getCalledFunDef callExpressions + in let ls = + L.foldl (\ls i -> ls L.++ [i + L.last ls]) [0] functionsArgsLengths + in V.fromList ls + where + getCalledFunDef callExpr = + case callExpr of + (AppE fName _ _) -> + case M.lookup fName fdefs of + Just fdef -> + case snd (funTy fdef) of ProdTy ls -> L.length ls - _ -> 1 + _ -> 1 + -- the last input argument is a set of already fused functions in the form of -- [(outer, inner, 0, fusedFunName)] -fuse :: DDefs Ty1 -> FunDefs1 -> Var -> Var -> [(Var, Var, Int, Var)] - -> PassM (Bool, Var, FunDefs1) -fuse ddefs fdefs innerVar outerVar prevFusedFuncs = do - innerFunc <- freshFunction (fdefs M.! innerVar) - outerFunc <- freshFunction (fdefs M.! outerVar) - - config <- getGibbonConfig - newName <- if verbosity config >= 0 - then return (toVar ("_FUS_f_" ++ fromVar outerVar ++ "_f_" ++ - fromVar innerVar ++ "_FUS_")) - else gensym "_FUSE_" - - step1 <- inline2 innerFunc outerFunc +fuse :: + DDefs Ty1 + -> FunDefs1 + -> Var + -> Var + -> [(Var, Var, Int, Var)] + -> PassM (Bool, Var, FunDefs1) +fuse ddefs fdefs innerVar outerVar prevFusedFuncs = do + innerFunc <- freshFunction (fdefs M.! innerVar) + outerFunc <- freshFunction (fdefs M.! outerVar) + config <- getGibbonConfig + newName <- + if verbosity config >= 0 + then return + (toVar + ("_FUS_f_" ++ + fromVar outerVar ++ "_f_" ++ fromVar innerVar ++ "_FUS_")) + else gensym "_FUSE_" + step1 <- inline2 innerFunc outerFunc -- `debug` -- ("newName is :" L.++ (show newName) L.++ "\ninner: " L.++ (render (pprint innerFunc)) L.++ "outer: " L.++ (render (pprint outerFunc)) ) - - step2 <- freshFunction (simplifyCases step1 ){funName = newName} + step2 <- freshFunction (simplifyCases step1) {funName = newName} -- `debug` ("newName is :" L.++ (show newName) L.++ render (pprint step1)) - newBody <- inlineConstructorConsumers fdefs (funBody step2 ) + newBody <- inlineConstructorConsumers fdefs (funBody step2) -- `debug` ("newName is :" L.++ (show newName) L.++ render (pprint step2)) - let step2' = step2{ funBody = newBody } + let step2' = step2 {funBody = newBody} -- `debug` ("newName is :" L.++ (show newName) L.++ render (pprint newBody)) - let step3 = foldFusedCallsF (outerVar, innerVar, -1, newName) step2' + let step3 = foldFusedCallsF (outerVar, innerVar, -1, newName) step2' -- `debug` ("newName is :" L.++ (show newName) L.++ render (pprint step2')) - let step4 = L.foldl (flip foldFusedCallsF ) step3 prevFusedFuncs + let step4 = L.foldl (flip foldFusedCallsF) step3 prevFusedFuncs -- `debug` ("newName is :" L.++ (show newName) L.++ render (pprint step3)) - let step5 = step4 {funBody = removeUnusedDefsExp (funBody step4)} - `debug` ("newName is :" L.++ (show newName) L.++ render (pprint step4)) - if( M.member newName fdefs) - then return (True, newName, fdefs)-- `debug1` ("WE ARE FASTER") - else return (True, newName, M.insert newName step5 fdefs) - -violateRestrictions :: FunDefs1 -> Var -> Var ->Int -> Bool -violateRestrictions fdefs inner outer depth= - let (n, m) = countFUS ((fromVar inner) L.++ "_FUS" L.++ (fromVar outer)) - in -- should be configurable - let p0 = --False - (n>1 || m>7 || depth>7) + let step5 = + step4 {funBody = removeUnusedDefsExp (funBody step4)} `debug` + ("newName is :" L.++ (show newName) L.++ render (pprint step4)) + if (M.member newName fdefs) + then return (True, newName, fdefs) -- `debug1` ("WE ARE FASTER") + else return (True, newName, M.insert newName step5 fdefs) + +violateRestrictions :: FunDefs1 -> Var -> Var -> Int -> Bool +violateRestrictions fdefs inner outer depth = + let (n, m) = countFUS ((fromVar inner) L.++ "_FUS" L.++ (fromVar outer)) + -- should be configurable + in let p0 --False + = (n > 1 || m > 7 || depth > 7) -- n>1 || depth>10 -- (depth>6) && - - - -- `debug` ( "n is " L.++ (show n) L.++ "for" L.++ (show inner ) L.++ (show outer)) - in - let innerDef = - case M.lookup inner fdefs of - (Just v) -> v - outerDef = - case M.lookup outer fdefs of - (Just v) -> v - p1 = - if (length (fst (funTy innerDef)) > 0) - then case head (fst (funTy innerDef)) of - (PackedTy _ _) -> False - x -> True - else True - p2 = - if (length (fst (funTy innerDef)) > 0) - then case head (fst (funTy outerDef)) of - (PackedTy _ _) -> False - x -> True - else True - p3 = - case ((funBody innerDef)) of - CaseE _ ls -> - not - (L.foldr (\(_, _, exp) res -> res && (hasConstructorTail exp)) True ls) - _ -> True - p4 = - case ((funBody outerDef)) of - CaseE _ _ -> False - _ -> True - p5 = - case ((funBody innerDef)) of - CaseE _ _ -> False - _ -> True - in (p0 || p1 || p2 || p4 || p5) - -type FusedElement = - (Var, -- outer fused function - Var, -- Inner fused function - Int, -- position at which inner is consumed - Var -- the name of the fused function - ) - -type TransformReturn = - (Exp1, --transformed expression - FunDefs1, -- updates functions stores - [FusedElement] -- list of functions that are fused during the transformation - ) - -data FusePassParams = FusePassParams - { exp :: Exp1, -- expression to transform - args :: [Var], -- arguments of the function that the transformed + in let innerDef = + case M.lookup inner fdefs of + (Just v) -> v + outerDef = + case M.lookup outer fdefs of + (Just v) -> v + p1 = + if (length (fst (funTy innerDef)) > 0) + then case head (fst (funTy innerDef)) of + (PackedTy _ _) -> False + x -> True + else True + p2 = + if (length (fst (funTy innerDef)) > 0) + then case head (fst (funTy outerDef)) of + (PackedTy _ _) -> False + x -> True + else True + p3 = + case ((funBody innerDef)) of + CaseE _ ls -> + not + (L.foldr + (\(_, _, exp) res -> res && (hasConstructorTail exp)) + True + ls) + _ -> True + p4 = + case ((funBody outerDef)) of + CaseE _ _ -> False + _ -> True + p5 = + case ((funBody innerDef)) of + CaseE _ _ -> False + _ -> True + in (p0 || p1 || p2 || p4 || p5) + + +-- `debug` ( "n is " L.++ (show n) L.++ "for" L.++ (show inner ) L.++ (show outer)) +type FusedElement + = ( Var -- outer fused function + , Var -- Inner fused function + , Int -- position at which inner is consumed + , Var -- the name of the fused function + ) + +type TransformReturn + = ( Exp1 --transformed expression + , FunDefs1 -- updates functions stores + , [FusedElement] -- list of functions that are fused during the transformation + ) + +data FusePassParams = + FusePassParams + { exp :: Exp1 -- expression to transform + , args :: [Var] -- arguments of the function that the transformed -- expression belongs to - fusedFunctions :: [FusedElement], -- already fused functions - skipList :: [(Var, Var)], -- functions to skip for fusion purposes - depth :: Int - } deriving (Show , Generic) - + , fusedFunctions :: [FusedElement] -- already fused functions + , skipList :: [(Var, Var)] -- functions to skip for fusion purposes + , depth :: Int + } + deriving (Show, Generic) tuple_pass :: DDefs Ty1 -> FunDefs1 -> PassM (FunDefs1) -tuple_pass ddefs fdefs = - foldM tupleFunction fdefs fdefs +tuple_pass ddefs fdefs = foldM tupleFunction fdefs fdefs where - tupleFunction defs' f = - do - let fName = funName f - if L.isPrefixOf "_FUS" (fromVar fName) || L.isPrefixOf "_TUP" (fromVar fName) + tupleFunction defs' f = do + let fName = funName f + if L.isPrefixOf "_FUS" (fromVar fName) || + L.isPrefixOf "_TUP" (fromVar fName) then do - (tupledBody, tupleDefs) <- tuple_entry ddefs fdefs (funBody f) (funArgs f) 0 `debug` ("run tuple for" L.++ (show (funName f))) - let defs'' = M.insert fName f{funBody = tupledBody} defs' - return (M.union defs'' tupleDefs) - - else - return defs' - - -fuse_pass :: DDefs Ty1 -> FunDefs1 -> FusePassParams -> PassM TransformReturn + (tupledBody, tupleDefs) <- + tuple_entry ddefs fdefs (funBody f) (funArgs f) 0 `debug` + ("run tuple for" L.++ (show (funName f))) + let defs'' = M.insert fName f {funBody = tupledBody} defs' + return (M.union defs'' tupleDefs) + else return defs' + +fuse_pass :: DDefs Ty1 -> FunDefs1 -> FusePassParams -> PassM TransformReturn fuse_pass ddefs funDefs (FusePassParams exp argsVars fusedFunctions skipList depth) = - if depth >10000-- then first fold before going back - then return (exp, funDefs, fusedFunctions) - else go (exp) skipList funDefs fusedFunctions - where - go body processed fdefs prevFusedFuncs = do - let defTable = buildDefTable body - potential = findPotential defTable processed - case potential of - Nothing -> do - let final_clean = removeUnusedDefsExp body - return (final_clean, fdefs, prevFusedFuncs) - - Just ((inner,outer), outerDefVarSymbol) -> - do - if violateRestrictions fdefs inner outer depth - then - go body ((inner,outer):processed) fdefs prevFusedFuncs + if depth > 10000 -- then first fold before going back + then return (exp, funDefs, fusedFunctions) + else go (exp) skipList funDefs fusedFunctions + where + go body processed fdefs prevFusedFuncs = do + let defTable = buildDefTable body + potential = findPotential defTable processed + case potential of + Nothing -> do + let final_clean = removeUnusedDefsExp body + return (final_clean, fdefs, prevFusedFuncs) + Just ((inner, outer), outerDefVarSymbol) -> do + if violateRestrictions fdefs inner outer depth + then go body ((inner, outer) : processed) fdefs prevFusedFuncs -- `debug1` ("cant fuse "L.++ (show (inner,outer))) - else do -- fuse - (validFused, fNew, fusedDefs) <- - fuse ddefs fdefs inner outer prevFusedFuncs - - let fusedFunction = fusedDefs M.! fNew + else do + (validFused, fNew, fusedDefs) <- + fuse ddefs fdefs inner outer prevFusedFuncs + let fusedFunction = fusedDefs M.! fNew -- `debug1` ("new fused function generated at depth " L.++ (show depth) L.++ (render (pprint (fusedDefs M.! fNew )))) - - --`debug` ("new fused:" L.++ ( - -- render (pprint ( fusedDefs M.! fNew )))) - newFusedEntry = (outer,inner, -1, fNew) - newFusedFunctions = newFusedEntry : prevFusedFuncs - newProcessed = (inner,outer):processed - - (retFuncBody, retFunDefs, retFusedFunctions) <- fuse_pass ddefs - fusedDefs (FusePassParams (funBody fusedFunction) (funArgs fusedFunction) - newFusedFunctions newProcessed (depth+1)) - - --clean - let newFusedFunctions2 = retFusedFunctions + +-- render (pprint ( fusedDefs M.! fNew )))) + newFusedEntry = (outer, inner, -1, fNew) + newFusedFunctions = newFusedEntry : prevFusedFuncs + newProcessed = (inner, outer) : processed + (retFuncBody, retFunDefs, retFusedFunctions) <- + fuse_pass + ddefs + fusedDefs + (FusePassParams + (funBody fusedFunction) + (funArgs fusedFunction) + newFusedFunctions + newProcessed + (depth + 1)) + let newFusedFunctions2 = retFusedFunctions -- (newFusedEntry : prevFusedFuncs) L.++ retFusedFunctions - cleanedFunction = - removeUnusedDefs fusedFunction{funBody = retFuncBody} - fdefs_tmp2 = M.union fusedDefs retFunDefs - fdefs_tmp3 = M.insert fNew cleanedFunction fdefs_tmp2 - newDefs = (M.union fdefs fdefs_tmp3) - - let foldedBody = foldFusedCalls_Entry (outer,inner, -1, fNew) body - if validFused - then - let body' = removeUnusedDefsExp foldedBody - in go (body') newProcessed newDefs newFusedFunctions2 - else - go body newProcessed fdefs prevFusedFuncs - -tupleAndOptimize :: DDefs Ty1 -> FunDefs1 ->Exp1 -> Bool->Int-> PassM (Exp1, FunDefs1) -tupleAndOptimize ddefs fdefs mainExp firstTime depth = - do - newDefs <- tuple_pass ddefs fdefs - if depth>0 ||(not firstTime && (newDefs == fdefs)) - then return (mainExp, newDefs) - else --return newDefs - let (mainExp', fdefs') = (redundancy_output_pass newDefs mainExp firstTime 0) in - tupleAndOptimize ddefs fdefs' mainExp' False (depth+1) - `debug` "run new tuple round" + cleanedFunction = + removeUnusedDefs fusedFunction {funBody = retFuncBody} + fdefs_tmp2 = M.union fusedDefs retFunDefs + fdefs_tmp3 = M.insert fNew cleanedFunction fdefs_tmp2 + newDefs = (M.union fdefs fdefs_tmp3) + let foldedBody = + foldFusedCalls_Entry (outer, inner, -1, fNew) body + if validFused + then let body' = removeUnusedDefsExp foldedBody + in go (body') newProcessed newDefs newFusedFunctions2 + else go body newProcessed fdefs prevFusedFuncs + + +--`debug` ("new fused:" L.++ ( +--clean +tupleAndOptimize :: + DDefs Ty1 -> FunDefs1 -> Exp1 -> Bool -> Int -> PassM (Exp1, FunDefs1) +tupleAndOptimize ddefs fdefs mainExp firstTime depth = do + newDefs <- tuple_pass ddefs fdefs + if depth > 0 || (not firstTime && (newDefs == fdefs)) + then return (mainExp, newDefs) + --return newDefs + else let (mainExp', fdefs') = + (redundancy_output_pass newDefs mainExp firstTime 0) + in tupleAndOptimize ddefs fdefs' mainExp' False (depth + 1) `debug` + "run new tuple round" fusion2 :: Prog1 -> PassM Prog1 fusion2 (L1.Prog defs funs main) = do @@ -1526,30 +1561,33 @@ fusion2 (L1.Prog defs funs main) = do -- then L.foldl (flip foldFusedCallsF ) fdef fuseInfo -- else fdef -- ) newDefs - (mainBody'', newDefs') <- tupleAndOptimize defs (M.union funs newDefs) mainBody' True 0 - let newDefs'' = M.filter - (\f -> - case snd (funTy f) of - ProdTy [] -> False - _ -> True - ) newDefs' - return (Just (mainBody'', ty), newDefs'') + (mainBody'', newDefs') <- + tupleAndOptimize defs (M.union funs newDefs) mainBody' True 0 + let newDefs'' = + M.filter + (\f -> + case snd (funTy f) of + ProdTy [] -> False + _ -> True) + newDefs' + return (Just (mainBody'', ty), newDefs'') -- return (Just (mainBody', ty), newDefs) return $ L1.Prog defs funs' main' -- Those functions are used for the redundancy analysis -redundancy_output_pass :: FunDefs1 -> Exp1 ->Bool ->Int ->(Exp1 ,FunDefs1) +redundancy_output_pass :: FunDefs1 -> Exp1 -> Bool -> Int -> (Exp1, FunDefs1) redundancy_output_pass fdefs mainExp firstTime depth = let (fdefs', rules) = M.foldl (pass1F fdefs) (fdefs, M.empty) fdefs fdefs'' = M.foldlWithKey pass2F fdefs' rules - in if depth>0 || (not firstTime && (fdefs'' == fdefs)) + in if depth > 0 || (not firstTime && (fdefs'' == fdefs)) then (mainExp, fdefs'') else redundancy_input_pass fdefs'' mainExp depth where pass2F fdefs fName (redirectMap, outPutFromInput, newName) = - M.map (pass2Fsub fdefs fName (redirectMap, outPutFromInput, newName)) fdefs - + M.map + (pass2Fsub fdefs fName (redirectMap, outPutFromInput, newName)) + fdefs pass2Fsub fdefs fName (redirectMap, outPutFromInput, newName) f = f { funBody = @@ -1562,92 +1600,101 @@ redundancy_output_pass fdefs mainExp firstTime depth = (fdefs M.! newName) redirectMap outPutFromInput - newName - ))) + newName))) } - pass1F orgFdefs (fdefs, rules) f = let fName = funName f in if L.isPrefixOf "_TUP" (fromVar fName) - then let testedPositions = - testAllOutputPositions orgFdefs fName - - newName = toVar (fromVar fName L.++ "outputFixed") in - if M.member newName fdefs - then - (fdefs, rules) - - else - - let (fNew, redirectMap, outPutFromInput) = - removeRedundantOutput - f - testedPositions --`debug` ("testing" L.++ (show fName)) - - in ( M.insert (funName fNew) fNew fdefs - ,M.insert fName (redirectMap, outPutFromInput, funName fNew) rules) + then let testedPositions = testAllOutputPositions orgFdefs fName + newName = toVar (fromVar fName L.++ "outputFixed") + in if M.member newName fdefs + then (fdefs, rules) + else let (fNew, redirectMap, outPutFromInput) = + removeRedundantOutput + f + testedPositions --`debug` ("testing" L.++ (show fName)) + in ( M.insert (funName fNew) fNew fdefs + , M.insert + fName + (redirectMap, outPutFromInput, funName fNew) + rules) -- `debug` ((show fName) L.++ "new things" L.++ (show (getOutputsFromInput f))) else (fdefs, rules) - -testAllOutputPositions:: FunDefs1 -> Var -> M.Map (Var,Int,Int) Bool -testAllOutputPositions fdefs fName = - let f = fdefs M.! fName - n = case snd (funTy f) of - ProdTy ls -> L.length ls +testAllOutputPositions :: FunDefs1 -> Var -> M.Map (Var, Int, Int) Bool +testAllOutputPositions fdefs fName = + let f = fdefs M.! fName + n = + case snd (funTy f) of + ProdTy ls -> L.length ls in loop1 0 0 n M.empty where - loop1 :: Int -> Int -> Int -> M.Map (Var, Int, Int) Bool -> M.Map (Var, Int, Int) Bool + loop1 :: + Int + -> Int + -> Int + -> M.Map (Var, Int, Int) Bool + -> M.Map (Var, Int, Int) Bool loop1 i j n testedPositions = - if j>=n - then - testedPositions - else - if i>= n - then - loop1 0 (j+1) n testedPositions - else - loop1 (i+1) j n (snd( testTwoOutputPositions fdefs (fName, i, j) testedPositions)) + if j >= n + then testedPositions + else if i >= n + then loop1 0 (j + 1) n testedPositions + else loop1 + (i + 1) + j + n + (snd + (testTwoOutputPositions + fdefs + (fName, i, j) + testedPositions)) -- `debug` (show"start" L.++ show((fName, i, j) )) -- For each pair of distinct output positions of a tuple: (0,1), (1,0), -- testTwoOutputPositions checks whether a particular function returns -- identical values at those positions. -testTwoOutputPositions :: FunDefs1 -> (Var, Int, Int) -> M.Map (Var,Int,Int) Bool - -> (Bool, M.Map (Var,Int,Int) Bool) +testTwoOutputPositions :: + FunDefs1 + -> (Var, Int, Int) + -> M.Map (Var, Int, Int) Bool + -> (Bool, M.Map (Var, Int, Int) Bool) testTwoOutputPositions fdefs (fName, i, j) testedPositions = - if i==j then (True, testedPositions) - else - case M.lookup (fName, i, j) testedPositions of - Just res -> (res, testedPositions) - Nothing -> - case M.lookup (fName, j, i) testedPositions of - Just res -> (res, M.insert (fName, j, i) res testedPositions) - Nothing -> - let (cond, inductiveAssumption, unresolvedConditions) = - extractAssumptionAndConditions fName i j - in if cond - then - let (cond', inductiveAssumption') = - testTwoOutputPositionsRec inductiveAssumption unresolvedConditions - in if cond' - then + if i == j + then (True, testedPositions) + else case M.lookup (fName, i, j) testedPositions of + Just res -> (res, testedPositions) + Nothing -> + case M.lookup (fName, j, i) testedPositions of + Just res -> (res, M.insert (fName, j, i) res testedPositions) + Nothing -> + let (cond, inductiveAssumption, unresolvedConditions) = + extractAssumptionAndConditions fName i j + in if cond + then let (cond', inductiveAssumption') = + testTwoOutputPositionsRec + inductiveAssumption + unresolvedConditions + in if cond' -- if there are not more conditions to resolve then we -- are done and correct ! - let testedPositions' = S.foldl - (\mp (fName, i, j) -> M.insert (fName, i, j) True mp) - testedPositions inductiveAssumption' - in (True, testedPositions') - else - (False, M.insert (fName, i, j) False testedPositions) - - else - (False, M.insert (fName, i, j) False testedPositions) - - - where - testTwoOutputPositionsRec inductiveAssumption unresolvedConditions = + then let testedPositions' = + S.foldl + (\mp (fName, i, j) -> + M.insert (fName, i, j) True mp) + testedPositions + inductiveAssumption' + in (True, testedPositions') + else ( False + , M.insert + (fName, i, j) + False + testedPositions) + else ( False + , M.insert (fName, i, j) False testedPositions) + where + testTwoOutputPositionsRec inductiveAssumption unresolvedConditions -- for each unresolved condition -- 1-check if equivalent rules are satisfied -- 2-if not return false @@ -1656,560 +1703,602 @@ testTwoOutputPositions fdefs (fName, i, j) testedPositions = -- 4-if at the end result is false we are done, otherwise if there is no -- unresolvedConditions then proof is done also, otherwise call perform the -- call recursively. - let (res, inductiveAssumption', unresolvedConditions') = - S.foldl foo (True, inductiveAssumption, S.empty) unresolvedConditions - unresolvedConditions'' = S.filter (\(f, i, j)-> - S.notMember (f, i, j) inductiveAssumption' && - S.notMember (f, j, i) inductiveAssumption') unresolvedConditions' - - in if res && S.null unresolvedConditions'' - then (res, inductiveAssumption') - else - if res==False - then - (False, S.empty) - else - testTwoOutputPositionsRec inductiveAssumption' unresolvedConditions'' - - foo :: (Bool, S.Set (Var, Int, Int), S.Set (Var, Int, Int)) + = + let (res, inductiveAssumption', unresolvedConditions') = + S.foldl + foo + (True, inductiveAssumption, S.empty) + unresolvedConditions + unresolvedConditions'' = + S.filter + (\(f, i, j) -> + S.notMember (f, i, j) inductiveAssumption' && + S.notMember (f, j, i) inductiveAssumption') + unresolvedConditions' + in if res && S.null unresolvedConditions'' + then (res, inductiveAssumption') + else if res == False + then (False, S.empty) + else testTwoOutputPositionsRec + inductiveAssumption' + unresolvedConditions'' + foo :: + (Bool, S.Set (Var, Int, Int), S.Set (Var, Int, Int)) -> (Var, Int, Int) -> (Bool, S.Set (Var, Int, Int), S.Set (Var, Int, Int)) - foo (condInput, assumptionsInput, unresolvedInput) (fName, i, j) = - - let (cond, inductiveAssumption, unresolvedConditions) = - extractAssumptionAndConditions fName i j - in (cond && condInput, S.union assumptionsInput inductiveAssumption, - S.union unresolvedConditions unresolvedInput ) - - -- TODO. - extractAssumptionAndConditions :: Var -> Int -> Int -> (Bool, S.Set (Var, Int, Int), S.Set (Var, Int, Int)) - extractAssumptionAndConditions fName i j = - let exp = funBody (fdefs M.! fName) - inlinedContent = inlineAllButAppE exp --`debug` (show (fName) L.++ "inlined body\n"L.++ (render (pprint exp))) - in case inlinedContent of - CaseE e ls -> - let parametrizedExprsList = L.map parametrizeProdExprs ls - cond = L.foldl (checkExpressions i j) True parametrizedExprsList - in if cond - then - let inductiveAssumption = S.insert (fName, i, j) S.empty - unresolvedConditions = L.foldl (collectConditions i j) - S.empty parametrizedExprsList - - unresolvedConditions' = S.filter (\(f, i, j)-> - S.notMember (f, i, j) inductiveAssumption && - S.notMember (f, j, i) inductiveAssumption) - unresolvedConditions - in (True, inductiveAssumption, unresolvedConditions) - else - (False, S.empty, S.empty) - - - parametrizeProdExprs :: (DataCon, [(Var, ())], Exp1) -> [(Exp1, [(Int, Var, Var)])] - parametrizeProdExprs (_, _, subExp) = + foo (condInput, assumptionsInput, unresolvedInput) (fName, i, j) = + let (cond, inductiveAssumption, unresolvedConditions) = + extractAssumptionAndConditions fName i j + in ( cond && condInput + , S.union assumptionsInput inductiveAssumption + , S.union unresolvedConditions unresolvedInput) + extractAssumptionAndConditions :: + Var + -> Int + -> Int + -> (Bool, S.Set (Var, Int, Int), S.Set (Var, Int, Int)) + extractAssumptionAndConditions fName i j = + let exp = funBody (fdefs M.! fName) + inlinedContent = inlineAllButAppE exp +--`debug` (show (fName) L.++ "inlined body\n"L.++ (render (pprint exp))) + in case inlinedContent of + CaseE e ls -> + let parametrizedExprsList = L.map parametrizeProdExprs ls + cond = + L.foldl (checkExpressions i j) True parametrizedExprsList + in if cond + then let inductiveAssumption = + S.insert (fName, i, j) S.empty + unresolvedConditions = + L.foldl + (collectConditions i j) + S.empty + parametrizedExprsList + unresolvedConditions' = + S.filter + (\(f, i, j) -> + S.notMember (f, i, j) inductiveAssumption && + S.notMember (f, j, i) inductiveAssumption) + unresolvedConditions + in (True, inductiveAssumption, unresolvedConditions) + else (False, S.empty, S.empty) + parametrizeProdExprs :: + (DataCon, [(Var, ())], Exp1) -> [(Exp1, [(Int, Var, Var)])] + parametrizeProdExprs (_, _, subExp) = let vars = collectVars subExp leafProd = getLeafProd subExp - varsToFuncs = collectVarToFuncs subExp - in case leafProd of - (MkProdE ls) ->L.map (parametrizeExp vars varsToFuncs) ls - - checkExpressions i j b prodListParametrized= - let (expi, pars1) = prodListParametrized L.!! i - (expj, pars2) = prodListParametrized L.!! j - in b && expi== expj && parsCheck pars1 pars2 - - parsCheck [] [] = True - parsCheck ((_, v1, _):ls1) ((_, v2, _):ls2) = - v1==v2 && parsCheck ls1 ls2 - - collectConditions i j s prodListParametrized = - let (_, ls1) = prodListParametrized L.!! i - (_, ls2) = prodListParametrized L.!! j - s' = collectConditionsPars ls1 ls2 - in S.union s' s - - collectConditionsPars [] [] = S.empty - collectConditionsPars ((idx1, v1, f):ls1) ((idx2, v2, _):ls2) = - let sNext = collectConditionsPars ls1 ls2 - in if idx1==idx2 - then - sNext - else - S.insert (f, idx1, idx2) sNext - - + varsToFuncs = collectVarToFuncs subExp + in case leafProd of + (MkProdE ls) -> L.map (parametrizeExp vars varsToFuncs) ls + checkExpressions i j b prodListParametrized = + let (expi, pars1) = prodListParametrized L.!! i + (expj, pars2) = prodListParametrized L.!! j + in b && expi == expj && parsCheck pars1 pars2 + parsCheck [] [] = True + parsCheck ((_, v1, _):ls1) ((_, v2, _):ls2) = v1 == v2 && parsCheck ls1 ls2 + collectConditions i j s prodListParametrized = + let (_, ls1) = prodListParametrized L.!! i + (_, ls2) = prodListParametrized L.!! j + s' = collectConditionsPars ls1 ls2 + in S.union s' s + collectConditionsPars [] [] = S.empty + collectConditionsPars ((idx1, v1, f):ls1) ((idx2, v2, _):ls2) = + let sNext = collectConditionsPars ls1 ls2 + in if idx1 == idx2 + then sNext + else S.insert (f, idx1, idx2) sNext + +-- TODO. getLeafExpr :: Exp1 -> Exp1 getLeafExpr = recur - where - recur ex = - case ex of - LetE _ body -> recur body - x-> x + where + recur ex = + case ex of + LetE _ body -> recur body + x -> x + -- fetch the tuple returned at the tail of subExp getLeafProd :: Exp1 -> Exp1 getLeafProd = recur - where - recur ex = - case ex of - LetE (v, ls, t, _) body -> recur body - leaf@MkProdE{} -> leaf - x-> error (show x) + where + recur ex = + case ex of + LetE (v, ls, t, _) body -> recur body + leaf@MkProdE {} -> leaf + x -> error (show x) hasConstructorTail :: Exp1 -> Bool hasConstructorTail = rec where rec ex = case ex of - LetE _ body -> rec body + LetE _ body -> rec body DataConE _ _ _ -> True - x -> False + x -> False + -- all variables which are used to bind function applications. collectVars :: Exp1 -> S.Set Var collectVars = recur - where - recur ex = case ex of - LetE (v, ls, t, AppE{}) body -> - S.insert v (recur body) - MkProdE{} -> S.empty + where + recur ex = + case ex of + LetE (v, ls, t, AppE {}) body -> S.insert v (recur body) + MkProdE {} -> S.empty + -- Map of variable binding to its function call collectVarToFuncs :: Exp1 -> M.Map Var Var collectVarToFuncs = recur - where - recur ex = case ex of - LetE (v, ls, t, (AppE f _ _)) body -> - M.insert v f (recur body) - MkProdE{} -> M.empty + where + recur ex = + case ex of + LetE (v, ls, t, (AppE f _ _)) body -> M.insert v f (recur body) + MkProdE {} -> M.empty + -- Given a set of variables that represents results of function calls -- and a mapping from those variables to the called function -- and an expression => parameterize the expression around those -parametrizeExp :: S.Set Var -> M.Map Var Var -> Exp1 -> (Exp1, [(Int, Var, Var)]) -parametrizeExp vars mp exp = - let (retExp, ls) = recur exp [] - in (retExp, L.map (\(i, v)-> (i, v, mp M.! v )) ls ) +parametrizeExp :: + S.Set Var -> M.Map Var Var -> Exp1 -> (Exp1, [(Int, Var, Var)]) +parametrizeExp vars mp exp = + let (retExp, ls) = recur exp [] + in (retExp, L.map (\(i, v) -> (i, v, mp M.! v)) ls) where - recur ex ls = case ex of - LetE{} -> error ("let not expected in parametrizeExp" L.++ (show ex)) + recur ex ls = + case ex of + LetE {} -> error ("let not expected in parametrizeExp" L.++ (show ex)) -- TODO: this is work around (correct not complete)[should be also handled] - x@(CaseE caseE caseLs) -> (x, ls) + x@(CaseE caseE caseLs) -> (x, ls) -- error( "CaseE not expected in parametrizeExp" ++ (render (pprint ex ))) - AppE v loc args -> - let (args', pList) = L.foldl f ([], ls) args - where - f (expList, projList) exp = - let (exp' , ls') = recur exp projList - in (expList L.++ [exp'], projList L.++ ls') - in ((AppE v loc args'), pList) - - DataConE loc dataCons expList-> - let (expList', pList) = L.foldl f ([], ls) expList - where - f (expList, projList) exp = - let (exp' , ls') = recur exp projList - in (expList L.++ [exp'], projList L.++ ls') - in ((DataConE loc dataCons expList'), pList) - - x@(ProjE i ((VarE v))) -> + AppE v loc args -> + let (args', pList) = L.foldl f ([], ls) args + where + f (expList, projList) exp = + let (exp', ls') = recur exp projList + in (expList L.++ [exp'], projList L.++ ls') + in ((AppE v loc args'), pList) + DataConE loc dataCons expList -> + let (expList', pList) = L.foldl f ([], ls) expList + where + f (expList, projList) exp = + let (exp', ls') = recur exp projList + in (expList L.++ [exp'], projList L.++ ls') + in ((DataConE loc dataCons expList'), pList) + x@(ProjE i ((VarE v))) -> if S.member v vars - then - let exp' = VarE (toVar ("par" L.++ show (L.length ls))) - ls' = ls L.++ [(i, v)] - in (exp', ls') - else - (x, ls) - otherwise -> (otherwise, ls) + then let exp' = VarE (toVar ("par" L.++ show (L.length ls))) + ls' = ls L.++ [(i, v)] + in (exp', ls') + else (x, ls) + otherwise -> (otherwise, ls) + -- this function inline all expressions except function application -- that returns tuples inlineAllButAppE :: Exp1 -> Exp1 inlineAllButAppE = rec - where - rec ex = case ex of - LetE (v, ls, t, bind) body -> - let oldExp = VarE v - newExp = bind - body' = substE oldExp newExp body - in case bind of - AppE{} -> case t of - ProdTy{} -> LetE (v, ls, t, bind) (rec body) - _ -> rec body' - _ -> rec body' - CaseE e ls -> - let ls' = L.map (\(x, y, exp) -> (x, y, rec exp)) ls - in CaseE e ls' - otherwise -> otherwise + where + rec ex = + case ex of + LetE (v, ls, t, bind) body -> + let oldExp = VarE v + newExp = bind + body' = substE oldExp newExp body + in case bind of + AppE {} -> + case t of + ProdTy {} -> LetE (v, ls, t, bind) (rec body) + _ -> rec body' + _ -> rec body' + CaseE e ls -> + let ls' = L.map (\(x, y, exp) -> (x, y, rec exp)) ls + in CaseE e ls' + otherwise -> otherwise + -- This function optimizes the tupled function by removing redundant output -- parameters and their computation. -- redundant positions are pr-computed and stored in testedPositions. -removeRedundantOutput :: FunDef1 -> M.Map (Var,Int,Int) Bool -> (FunDef1, M.Map Int Int, M.Map Int Int) -removeRedundantOutput fdef testedPositions = - let outputsFromInputs = getOutputsFromInput fdef in - let outputTuples = V.fromList (collectOutputs (funBody fdef)) in - let firstTuple = outputTuples V.! 0 in --return vector - let loop i j = - if j >= (V.length firstTuple) - then [] - else - let res = - if(M.member (funName fdef, i, j) testedPositions) - then testedPositions M.! (funName fdef, i, j) - else testedPositions M.! (funName fdef, j, i) - in if res - then [j] L.++ (loop i (j+1)) - else loop i (j+1) - - candidates = V.ifoldl - (\ls idx _ -> - let matches = V.fromList(loop idx (idx+1)) - cands = L.map (idx,) (V.toList matches) --`debug` (show matches) - in (ls L.++ cands) - ) [] firstTuple - - ncols = V.length firstTuple - nrows = V.length outputTuples - initialMap = M.fromList (L.map (, []) [0..(ncols-1)]) +removeRedundantOutput :: + FunDef1 + -> M.Map (Var, Int, Int) Bool + -> (FunDef1, M.Map Int Int, M.Map Int Int) +removeRedundantOutput fdef testedPositions = + let outputsFromInputs = getOutputsFromInput fdef + in let outputTuples = V.fromList (collectOutputs (funBody fdef)) + in let firstTuple = outputTuples V.! 0 --return vector + in let loop i j = + if j >= (V.length firstTuple) + then [] + else let res = + if (M.member + (funName fdef, i, j) + testedPositions) + then testedPositions M.! (funName fdef, i, j) + else testedPositions M.! (funName fdef, j, i) + in if res + then [j] L.++ (loop i (j + 1)) + else loop i (j + 1) + candidates = + V.ifoldl + (\ls idx _ -> + let matches = V.fromList (loop idx (idx + 1)) + cands = L.map (idx, ) (V.toList matches) --`debug` (show matches) + in (ls L.++ cands)) + [] + firstTuple + ncols = V.length firstTuple + nrows = V.length outputTuples + initialMap = M.fromList (L.map (, []) [0 .. (ncols - 1)]) -- tricky! - finalMap = L.foldl - (\mp (i, j) -> - let k = L.foldl - (\k idx -> if k /= -1 - then k - else - case M.lookup idx mp of - Nothing -> k - Just ls -> - case L.elemIndex i ls of - Nothing -> k - otherwise -> idx - ) (-1) [0..i] - mp' = M.delete j mp - in if k== -1 - then M.insert i ((mp' M.! i) L.++ [j] ) mp' - else M.insert k ((mp' M.! k) L.++ [j] ) mp' - ) initialMap candidates - - removedPositions_ = L.foldl - (\ls i -> - case M.lookup i finalMap of - Nothing -> ls L.++[i] - otherwise -> ls - ) [] [0..(ncols-1)] - - removedPositions = - S.toList (S.union - (S.fromList removedPositions_) - (S.fromList (L.map (\(x,y)->x ) (M.toList outputsFromInputs) ))) - newFunType = - let oldOutTypesList = V.fromList ( - case snd(funTy fdef) of ProdTy ls->ls) - newOutTypesList = V.ifoldl - (\ls idx ty -> - case L.elemIndex idx removedPositions of - Nothing -> ls L.++[ty] - otherwise-> ls - ) [] oldOutTypesList - in (fst(funTy fdef), ProdTy newOutTypesList ) - - newOutputTuples = V.map removeDropped outputTuples - where - removeDropped ls = MkProdE (V.ifoldl - (\ls idx exp -> - case L.elemIndex idx removedPositions of - Nothing -> ls L.++[exp] - otherwise -> ls - ) [] ls) - - newFunBody = case (funBody fdef) of - CaseE e ls -> - let ls' = V.toList (V.imap - (\idx (x, y, exp)-> - let exp' = replaceLeafExp exp (newOutputTuples V.! idx) - in (x, y, exp')) (V.fromList ls)) - in CaseE e ls' - fdef' = fdef{funBody = newFunBody, funTy = newFunType} - - redirectMap = V.ifoldl - (\mp idx (i, ls)-> - let mp' = M.insert i idx mp - mp'' = L.foldl (\m j -> M.insert j idx m) mp' ls - in mp'' - ) M.empty (V.fromList (M.toList finalMap)) - - removedUnhandled = L.map (\(a, b)->a) (M.toList outputsFromInputs) - redirectMap' = L.foldl (\mp i->M.delete i mp) redirectMap removedUnhandled - redirectMap'' = M.map (\v -> v- (countLess v)) redirectMap' - where - countLess v = L.foldl (\res a-> if (a + finalMap = + L.foldl + (\mp (i, j) -> + let k = + L.foldl + (\k idx -> + if k /= -1 + then k + else case M.lookup idx mp of + Nothing -> k + Just ls -> + case L.elemIndex i ls of + Nothing -> k + otherwise -> idx) + (-1) + [0 .. i] + mp' = M.delete j mp + in if k == -1 + then M.insert i ((mp' M.! i) L.++ [j]) mp' + else M.insert k ((mp' M.! k) L.++ [j]) mp') + initialMap + candidates + removedPositions_ = + L.foldl + (\ls i -> + case M.lookup i finalMap of + Nothing -> ls L.++ [i] + otherwise -> ls) + [] + [0 .. (ncols - 1)] + removedPositions = + S.toList + (S.union + (S.fromList removedPositions_) + (S.fromList + (L.map (\(x, y) -> x) (M.toList outputsFromInputs)))) + newFunType = + let oldOutTypesList = + V.fromList + (case snd (funTy fdef) of + ProdTy ls -> ls) + newOutTypesList = + V.ifoldl + (\ls idx ty -> + case L.elemIndex idx removedPositions of + Nothing -> ls L.++ [ty] + otherwise -> ls) + [] + oldOutTypesList + in (fst (funTy fdef), ProdTy newOutTypesList) + newOutputTuples = V.map removeDropped outputTuples + where + removeDropped ls = + MkProdE + (V.ifoldl + (\ls idx exp -> + case L.elemIndex idx removedPositions of + Nothing -> ls L.++ [exp] + otherwise -> ls) + [] + ls) + newFunBody = + case (funBody fdef) of + CaseE e ls -> + let ls' = + V.toList + (V.imap + (\idx (x, y, exp) -> + let exp' = + replaceLeafExp + exp + (newOutputTuples V.! idx) + in (x, y, exp')) + (V.fromList ls)) + in CaseE e ls' + fdef' = fdef {funBody = newFunBody, funTy = newFunType} + redirectMap = + V.ifoldl + (\mp idx (i, ls) -> + let mp' = M.insert i idx mp + mp'' = L.foldl (\m j -> M.insert j idx m) mp' ls + in mp'') + M.empty + (V.fromList (M.toList finalMap)) + removedUnhandled = + L.map (\(a, b) -> a) (M.toList outputsFromInputs) + redirectMap' = + L.foldl + (\mp i -> M.delete i mp) + redirectMap + removedUnhandled + redirectMap'' = M.map (\v -> v - (countLess v)) redirectMap' + where + countLess v = + L.foldl + (\res a -> + if (a < v) + then 1 + res + else res) + 0 + removedUnhandled + fdef'' = + fdef' + { funName = + if (newFunBody == funBody fdef) + then funName fdef' + else toVar + (fromVar (funName fdef') L.++ "outputFixed") + } + in (fdef'', redirectMap'', outputsFromInputs) --`debug` ("summer for " L.++ (show (funName fdef')) L.++ (show outputsFromInputs )) + where + replaceLeafExp exp replacement = + case exp of + LetE (v, ls, t, bind) body -> LetE (v, ls, t, bind) (replaceLeafExp body replacement) - MkProdE ls -> replacement - - collectOutputs exp = case exp of - CaseE e ls -> - L.map (\(x, y, subBody) -> V.fromList(extractLeafTuple subBody)) ls - where - extractLeafTuple exp = - case exp of - LetE (v, ls, t, bind) body -> extractLeafTuple body - MkProdE ls -> ls - _ -> error "not expected expression" - - _ -> error"should be case expression" + MkProdE ls -> replacement + collectOutputs exp = + case exp of + CaseE e ls -> + L.map (\(x, y, subBody) -> V.fromList (extractLeafTuple subBody)) ls + where extractLeafTuple exp = + case exp of + LetE (v, ls, t, bind) body -> extractLeafTuple body + MkProdE ls -> ls + _ -> error "not expected expression" + _ -> error "should be case expression" eliminateInputArgs :: FunDefs1 -> Var -> M.Map Int Int -> (Var, FunDefs1) eliminateInputArgs fdefs fNameOld syncedArgs = - let newName = toVar ((M.foldlWithKey buildName ((fromVar fNameOld) L.++ "elimpass_") syncedArgs)L.++"_elimpass") + let newName = + toVar + ((M.foldlWithKey + buildName + ((fromVar fNameOld) L.++ "elimpass_") + syncedArgs) L.++ + "_elimpass") fdefs' = - if M.member newName fdefs - then fdefs - else - let oldFdef = fdefs M.! fNameOld - oldInputType = fst (funTy oldFdef) - oldArgs = funArgs oldFdef - oldBody = funBody oldFdef - newInputType = - V.toList - (V.ifilter - (\idx _ -> M.notMember idx syncedArgs) - (V.fromList oldInputType) - ) - newArgs = - V.toList - (V.ifilter - (\idx _ -> M.notMember idx syncedArgs) - (V.fromList oldArgs) - ) - newBody = - M.foldlWithKey - (\exp k v -> - if (v<1000) - then - let oldExp = VarE ((V.fromList oldArgs) V.! k) - newExp = VarE ((V.fromList oldArgs) V.! v) - in substE oldExp newExp exp - else - exp - ) - (oldBody) - syncedArgs - newFdef = - oldFdef - { funBody = cleanExp newBody - , funArgs = newArgs - , funTy = (newInputType, snd (funTy oldFdef)) - , funName = newName - } - in M.insert newName newFdef fdefs - in (newName, fdefs') - where + if M.member newName fdefs + then fdefs + else let oldFdef = fdefs M.! fNameOld + oldInputType = fst (funTy oldFdef) + oldArgs = funArgs oldFdef + oldBody = funBody oldFdef + newInputType = + V.toList + (V.ifilter + (\idx _ -> M.notMember idx syncedArgs) + (V.fromList oldInputType)) + newArgs = + V.toList + (V.ifilter + (\idx _ -> M.notMember idx syncedArgs) + (V.fromList oldArgs)) + newBody = + M.foldlWithKey + (\exp k v -> + if (v < 1000) + then let oldExp = VarE ((V.fromList oldArgs) V.! k) + newExp = VarE ((V.fromList oldArgs) V.! v) + in substE oldExp newExp exp + else exp) + (oldBody) + syncedArgs + newFdef = + oldFdef + { funBody = cleanExp newBody + , funArgs = newArgs + , funTy = (newInputType, snd (funTy oldFdef)) + , funName = newName + } + in M.insert newName newFdef fdefs + in (newName, fdefs') + where buildName name i j = name L.++ "_sync" L.++ (show i) L.++ "_fr_" L.++ (show j) L.++ "sync_" + -- simplest version for single functions -getOutputsFromInput ::FunDef1 -> M.Map Int Int -getOutputsFromInput func = +getOutputsFromInput :: FunDef1 -> M.Map Int Int +getOutputsFromInput func = let body = funBody func - leafProducts = case body of - CaseE e ls -> - L.map (\(_,_,exp) -> getLeafProdExpressions exp) ls + leafProducts = + case body of + CaseE e ls -> L.map (\(_, _, exp) -> getLeafProdExpressions exp) ls inputVars = funArgs func candidatesList = - - L.map(\exprList-> - V.ifoldl f M.empty (V.fromList exprList)) leafProducts - where f out idx outExp = - case outExp of - VarE v -> - case L.elemIndex v inputVars of - Nothing -> out - Just argIdx -> M.insert idx argIdx out - otherwise -> out - candidatesListSets = L.map (\mp-> S.fromList (M.toList mp)) candidatesList - intersectionsSet = L.foldl S.intersection (L.head candidatesListSets) candidatesListSets - in M.fromList (S.toList intersectionsSet) + L.map + (\exprList -> V.ifoldl f M.empty (V.fromList exprList)) + leafProducts + where + f out idx outExp = + case outExp of + VarE v -> + case L.elemIndex v inputVars of + Nothing -> out + Just argIdx -> M.insert idx argIdx out + otherwise -> out + candidatesListSets = + L.map (\mp -> S.fromList (M.toList mp)) candidatesList + intersectionsSet = + L.foldl S.intersection (L.head candidatesListSets) candidatesListSets + in M.fromList (S.toList intersectionsSet) getLeafProdExpressions :: Exp1 -> [Exp1] getLeafProdExpressions = rec - where - rec ex = - case ex of - LetE (v, ls, t, AppE{}) body -> rec body - MkProdE ls -> ls - x-> [] - + where + rec ex = + case ex of + LetE (v, ls, t, AppE {}) body -> rec body + MkProdE ls -> ls + x -> [] -removeRedundantInputExp :: FunDefs1 -> Exp1 -> Bool -> (FunDefs1,Exp1) -removeRedundantInputExp fdefs exp mode = +removeRedundantInputExp :: FunDefs1 -> Exp1 -> Bool -> (FunDefs1, Exp1) +removeRedundantInputExp fdefs exp mode = case exp of CaseE e ls -> let (fdefs', e') = removeRedundantInputExp fdefs e mode (fdefs'', ls') = L.foldl f (fdefs', []) ls where f (fdefsInner, lsInner) (dataCon, vars, exp) = - let (fdefsInner', exp') = removeRedundantInputExp fdefsInner exp mode + let (fdefsInner', exp') = + removeRedundantInputExp fdefsInner exp mode in (fdefsInner', lsInner L.++ [(dataCon, vars, exp')]) in (fdefs'', CaseE e' ls') - LetE rhs@(var, ls, t, bind) body -> - let (fdefs', body') = removeRedundantInputExp fdefs body mode - boringCase = (fdefs', (LetE rhs body')) - in (case bind of - x@( AppE fName loc args) -> - if (L.isPrefixOf "_TUP" (fromVar fName) || - L.isPrefixOf "_FUS" (fromVar fName) ) - then - - let redundantPositions = - if(mode) - then - snd( V.ifoldl findRedundantPos (M.empty, M.empty) (V.fromList args)) - else - V.ifoldl (findRedundantPos_UnusedArgs fName) M.empty (V.fromList args) + boringCase = (fdefs', (LetE rhs body')) + in (case bind of + x@(AppE fName loc args) -> + if (L.isPrefixOf "_TUP" (fromVar fName) || + L.isPrefixOf "_FUS" (fromVar fName)) + then let redundantPositions = + if (mode) + then snd + (V.ifoldl + findRedundantPos + (M.empty, M.empty) + (V.fromList args)) + else V.ifoldl + (findRedundantPos_UnusedArgs fName) + M.empty + (V.fromList args) -- redundantPositions3 = M.union redundantPositions2 redundantPositions `debug` -- ("checking call to :" L.++ (show fName) L.++ "opppaaaa" L.++ show redundantPositions2) - in - if M.null redundantPositions - then - boringCase - else - - let (fNameNew, fdefsNew) = - eliminateInputArgs fdefs' fName redundantPositions - newCall = - AppE fNameNew loc - (V.toList - (V.ifilter - (\idx _ -> M.notMember idx redundantPositions ) - (V.fromList args))) - in (fdefsNew,(LetE (var, ls, t, newCall) body' )) - else - boringCase - otherwise -> boringCase) - + in if M.null redundantPositions + then boringCase + else let (fNameNew, fdefsNew) = + eliminateInputArgs + fdefs' + fName + redundantPositions + newCall = + AppE + fNameNew + loc + (V.toList + (V.ifilter + (\idx _ -> + M.notMember + idx + redundantPositions) + (V.fromList args))) + in ( fdefsNew + , (LetE (var, ls, t, newCall) body')) + else boringCase + otherwise -> boringCase) x@(AppE fName loc args) -> - if (L.isPrefixOf "_TUP" (fromVar fName) || - L.isPrefixOf "_FUS" (fromVar fName) ) - then - let redundantPositions = - if(mode) - then - snd( V.ifoldl findRedundantPos (M.empty, M.empty) (V.fromList args)) - else - V.ifoldl (findRedundantPos_UnusedArgs fName) M.empty (V.fromList args) + if (L.isPrefixOf "_TUP" (fromVar fName) || + L.isPrefixOf "_FUS" (fromVar fName)) + then let redundantPositions = + if (mode) + then snd + (V.ifoldl + findRedundantPos + (M.empty, M.empty) + (V.fromList args)) + else V.ifoldl + (findRedundantPos_UnusedArgs fName) + M.empty + (V.fromList args) -- redundantPositions3 = M.union redundantPositions2 redundantPositions `debug` -- ("checking call to :" L.++ (show fName) L.++ "opppaaaa" L.++ show redundantPositions2) - in - if M.null redundantPositions - then - (fdefs, x) - else - let (fNameNew, fdefsNew) = - eliminateInputArgs fdefs fName redundantPositions - newCall = - AppE fNameNew loc - (V.toList - (V.ifilter - (\idx _ -> M.notMember idx redundantPositions ) - (V.fromList args))) - in (fdefsNew,newCall) - else - (fdefs, x) - otherwise -> (fdefs, otherwise) - where - findRedundantPos (firstAppear, redundant) argIdx arg = - if M.member arg firstAppear - then - (firstAppear, M.insert argIdx (firstAppear M.! arg) redundant) - else - (M.insert arg argIdx firstAppear, redundant) - - findRedundantPos_UnusedArgs fName mp argIdx arg = - let callee = fdefs M.! fName in - if (isUsedArg (funBody callee) ((V.fromList (funArgs callee)) V.! argIdx )) - then mp - else M.insert argIdx 100000 mp - - isUsedArg exp var = - case exp of - ProjE i e -> - isUsedArg e var - - VarE v' -> - v' == var - - CaseE e ls -> - let b1 = isUsedArg e var - b2 = - L.foldl (\res (dataCon, vars, ex)-> - (res || isUsedArg ex var )) - False ls - in b1 || b2 - - - AppE fName loc args -> - L.foldl (\res ex -> (res || isUsedArg ex var )) False args - - LetE (v, ls, t, bind) body -> (isUsedArg bind var)|| (isUsedArg body var) - PrimAppE p ls -> L.foldl (\res ex -> (res || isUsedArg ex var )) False ls - MkProdE ls -> L.foldl (\res ex -> (res || isUsedArg ex var )) False ls - DataConE _ _ ls-> L.foldl (\res ex -> (res || isUsedArg ex var )) False ls - - x -> False `debug` ("not handled is "L.++ (show x)) - + in if M.null redundantPositions + then (fdefs, x) + else let (fNameNew, fdefsNew) = + eliminateInputArgs fdefs fName redundantPositions + newCall = + AppE + fNameNew + loc + (V.toList + (V.ifilter + (\idx _ -> + M.notMember idx redundantPositions) + (V.fromList args))) + in (fdefsNew, newCall) + else (fdefs, x) + otherwise -> (fdefs, otherwise) + where + findRedundantPos (firstAppear, redundant) argIdx arg = + if M.member arg firstAppear + then (firstAppear, M.insert argIdx (firstAppear M.! arg) redundant) + else (M.insert arg argIdx firstAppear, redundant) + findRedundantPos_UnusedArgs fName mp argIdx arg = + let callee = fdefs M.! fName + in if (isUsedArg + (funBody callee) + ((V.fromList (funArgs callee)) V.! argIdx)) + then mp + else M.insert argIdx 100000 mp + isUsedArg exp var = + case exp of + ProjE i e -> isUsedArg e var + VarE v' -> v' == var + CaseE e ls -> + let b1 = isUsedArg e var + b2 = + L.foldl + (\res (dataCon, vars, ex) -> (res || isUsedArg ex var)) + False + ls + in b1 || b2 + AppE fName loc args -> + L.foldl (\res ex -> (res || isUsedArg ex var)) False args + LetE (v, ls, t, bind) body -> + (isUsedArg bind var) || (isUsedArg body var) + PrimAppE p ls -> L.foldl (\res ex -> (res || isUsedArg ex var)) False ls + MkProdE ls -> L.foldl (\res ex -> (res || isUsedArg ex var)) False ls + DataConE _ _ ls -> + L.foldl (\res ex -> (res || isUsedArg ex var)) False ls + x -> False `debug` ("not handled is " L.++ (show x)) removeRedundantInputsMainExp :: FunDefs1 -> Exp1 -> (FunDefs1, Exp1) removeRedundantInputsMainExp fdefs expInput = - let (fdefs', exp) = removeRedundantInputExp fdefs expInput True -- `debug` ("Dowing1"L.++ (render (pprint expInput))) (fdefs'', exp') = removeRedundantInputExp fdefs' exp False - - in (fdefs'', exp') + in (fdefs'', exp') removeRedundantInputFunc :: FunDefs1 -> FunDef1 -> FunDefs1 removeRedundantInputFunc fdefs fdef = let (fdefs', exp) = removeRedundantInputExp fdefs (funBody fdef) True -- `debug` ("Dowing1"L.++ (show (funName fdef))) fdef' = fdef {funBody = exp} - (fdefs'', exp') = removeRedundantInputExp (M.insert (funName fdef) fdef' fdefs') - exp False - fdef'' = fdef' {funBody = exp'}-- `debug` ("Dowing2 "L.++ (render (pprint (fdef' {funBody = exp'})))) - - in (M.insert (funName fdef) fdef'' fdefs'') + (fdefs'', exp') = + removeRedundantInputExp (M.insert (funName fdef) fdef' fdefs') exp False + fdef'' = fdef' {funBody = exp'} -- `debug` ("Dowing2 "L.++ (render (pprint (fdef' {funBody = exp'})))) + in (M.insert (funName fdef) fdef'' fdefs'') -redundancy_input_pass_rec :: FunDefs1 -> Exp1->Int-> (Exp1, FunDefs1) -redundancy_input_pass_rec fdefs mainExp depth= +redundancy_input_pass_rec :: FunDefs1 -> Exp1 -> Int -> (Exp1, FunDefs1) +redundancy_input_pass_rec fdefs mainExp depth = let fdefs' = M.foldl (\fDefsInner fdef -> removeRedundantInputFunc fDefsInner fdef) fdefs fdefs - in let (fdefs'', mainExp') = removeRedundantInputsMainExp fdefs' mainExp - in if (fdefs'' == fdefs && mainExp'== mainExp) || depth> 5 - then ( mainExp', fdefs'')`debug` ("no repeeat") - else redundancy_input_pass_rec fdefs'' mainExp' (depth + 1) `debug` ("repeeat") - -redundancy_input_pass :: FunDefs1 -> Exp1-> Int-> (Exp1, FunDefs1) -redundancy_input_pass fdefs mainExp depth= - let (mainExp' , fdefs'') = redundancy_input_pass_rec fdefs mainExp 0 - in if (fdefs'' == fdefs && mainExp'== mainExp) + in let (fdefs'', mainExp') = removeRedundantInputsMainExp fdefs' mainExp + in if (fdefs'' == fdefs && mainExp' == mainExp) || depth > 5 + then (mainExp', fdefs'') `debug` ("no repeeat") + else redundancy_input_pass_rec fdefs'' mainExp' (depth + 1) `debug` + ("repeeat") + +redundancy_input_pass :: FunDefs1 -> Exp1 -> Int -> (Exp1, FunDefs1) +redundancy_input_pass fdefs mainExp depth = + let (mainExp', fdefs'') = redundancy_input_pass_rec fdefs mainExp 0 + in if (fdefs'' == fdefs && mainExp' == mainExp) then (mainExp', fdefs'') - else redundancy_output_pass fdefs'' mainExp' False (depth+1) + else redundancy_output_pass fdefs'' mainExp' False (depth + 1) From a87fd43e652236c72dc71a79ee8472fc925df0d2 Mon Sep 17 00:00:00 2001 From: vidsinghal Date: Wed, 16 Aug 2023 12:02:49 -0400 Subject: [PATCH 17/25] Passes: CallGraph --- gibbon-compiler/gibbon.cabal | 1 + .../src/Gibbon/Passes/CallGraph.hs | 110 ++++++++++++++++++ 2 files changed, 111 insertions(+) create mode 100644 gibbon-compiler/src/Gibbon/Passes/CallGraph.hs diff --git a/gibbon-compiler/gibbon.cabal b/gibbon-compiler/gibbon.cabal index 7fd6c521d..6b98d7218 100644 --- a/gibbon-compiler/gibbon.cabal +++ b/gibbon-compiler/gibbon.cabal @@ -84,6 +84,7 @@ library Gibbon.Passes.CalculateBounds Gibbon.Passes.ControlFlowGraph Gibbon.Passes.DefinitionUseChains + Gibbon.Passes.CallGraph other-extensions: DeriveDataTypeable CPP diff --git a/gibbon-compiler/src/Gibbon/Passes/CallGraph.hs b/gibbon-compiler/src/Gibbon/Passes/CallGraph.hs new file mode 100644 index 000000000..833e2fe95 --- /dev/null +++ b/gibbon-compiler/src/Gibbon/Passes/CallGraph.hs @@ -0,0 +1,110 @@ +module Gibbon.Passes.CallGraph + ( generateProducerGraph + , ProducersMap(..) + ) where + + +-- Gibbon imports +import Gibbon.Common +import Gibbon.Language +import Gibbon.Language.Syntax +import Gibbon.Passes.DefinitionUseChains (generateDefUseChainsFunction, + progToVEnv) + +import Control.Monad as Monad +import Data.Graph as G +import Data.List as L +import Data.Map as M +import Data.Maybe as Maybe +import Data.Set as S + + +-- haskell imports +import Prelude as P +import Text.PrettyPrint.GenericPretty + + +-- | A Type to store the producers of all arguments passed to a function call +-- | Outer map, maps the function name to a second map. +-- | The inner (second map) stores each variable which is the argument to the function call and its type to the function that produces the argument. +type ProducersMap ex = M.Map (Var, TyOf ex) ex + +generateProducerGraph :: + (FreeVars (e l d), Ord l, Ord d, Ord (e l d), Out d, Out l) + => Prog (PreExp e l d) + -> ProducersMap (PreExp e l d) +generateProducerGraph prg@Prog {ddefs, fundefs, mainExp} = + let vEnv = progToVEnv prg + pcMapF = + P.map + (\f@FunDef {funName, funBody, funTy, funArgs} -> + generateProducerGraphExpression vEnv funBody) + (M.elems fundefs) + in case mainExp of + Nothing -> M.unions pcMapF + Just (exp, ty) -> + let mainMap = generateProducerGraphExpression vEnv exp + in M.unions (pcMapF ++ [mainMap]) + + +-- Everything is flattned and in SSA Form so we can get away with just analyzing let expressions and case bindings. +generateProducerGraphExpression :: + (FreeVars (e l d), Ord l, Ord d, Ord (e l d), Out d, Out l) + => Env2 (TyOf (PreExp e l d)) + -> (PreExp e l d) + -> ProducersMap (PreExp e l d) +generateProducerGraphExpression venv exp = + case exp of + DataConE loc dcon args -> + let maps = P.map (generateProducerGraphExpression venv) args + in M.unions maps + VarE {} -> M.empty + LitE {} -> M.empty + CharE {} -> M.empty + FloatE {} -> M.empty + LitSymE {} -> M.empty + AppE f locs args -> + let maps = P.map (generateProducerGraphExpression venv) args + in M.unions maps + PrimAppE f args -> + let maps = P.map (generateProducerGraphExpression venv) args + in M.unions maps + LetE (v, loc, ty, rhs) bod -> + let vProducer = M.insert (v, ty) rhs M.empty + map' = (generateProducerGraphExpression venv) bod + in M.union vProducer map' + -- a == DataCon + -- b == [(Var, loc)] + -- c == Case Body + CaseE scrt mp -> + let newMaps = + P.map + (\(a, b, c) -> + let m = + P.map + (\(var, _) -> + M.insert + (var, lookupVEnv var venv) + (DataConE _ a []) + M.empty) + b + mc = generateProducerGraphExpression venv c + in M.unions (m ++ [mc])) + mp + in M.unions newMaps + IfE a b c -> + let ma = generateProducerGraphExpression venv a + mb = generateProducerGraphExpression venv b + mc = generateProducerGraphExpression venv c + in M.unions [ma, mb, mc] + MkProdE xs -> + let maps = P.map (generateProducerGraphExpression venv) xs + in M.unions maps + ProjE i e -> error "generateProducerGraphExpression: TODO ProjE" + TimeIt e ty b -> error "generateProducerGraphExpression: TODO TimeIt" + WithArenaE v e -> error "generateProducerGraphExpression: TODO WithArenaE" + SpawnE f locs args -> error "generateProducerGraphExpression: TODO SpawnE" + SyncE -> error "generateProducerGraphExpression: TODO SyncE" + MapE {} -> error "generateProducerGraphExpression: TODO MapE" + FoldE {} -> error "generateProducerGraphExpression: TODO FoldE" + Ext _ -> error "generateProducerGraphExpression: TODO Ext" From ac4bcf1f5ea68fd6416830b06fe1bd1d031ee90b Mon Sep 17 00:00:00 2001 From: vidsinghal Date: Wed, 16 Aug 2023 12:34:29 -0400 Subject: [PATCH 18/25] Fix ghc 9.6.2 build error --- gibbon-compiler/src/Gibbon/Common.hs | 1 + gibbon-compiler/src/Gibbon/L0/Specialize2.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/gibbon-compiler/src/Gibbon/Common.hs b/gibbon-compiler/src/Gibbon/Common.hs index da795d166..8e69c53f7 100644 --- a/gibbon-compiler/src/Gibbon/Common.hs +++ b/gibbon-compiler/src/Gibbon/Common.hs @@ -42,6 +42,7 @@ import Control.Exception (evaluate) -- 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 import Control.Monad.State.Strict import Control.Monad.Reader import Data.Functor.Foldable diff --git a/gibbon-compiler/src/Gibbon/L0/Specialize2.hs b/gibbon-compiler/src/Gibbon/L0/Specialize2.hs index 49a486c71..8004aff8c 100644 --- a/gibbon-compiler/src/Gibbon/L0/Specialize2.hs +++ b/gibbon-compiler/src/Gibbon/L0/Specialize2.hs @@ -21,6 +21,7 @@ module Gibbon.L0.Specialize2 , floatOutCase ) where +import Control.Monad import Control.Monad.State import Data.Foldable (foldlM, foldrM) import qualified Data.Map as M From 868c7722d94a43bdd1963798e25b67e6190e15e5 Mon Sep 17 00:00:00 2001 From: vidsinghal Date: Wed, 16 Aug 2023 15:58:43 -0400 Subject: [PATCH 19/25] Tests: Fix L1 Typecheck case to fix CI error --- gibbon-compiler/tests/L1/Typecheck.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/gibbon-compiler/tests/L1/Typecheck.hs b/gibbon-compiler/tests/L1/Typecheck.hs index 8c408cea4..e34ce9bf4 100644 --- a/gibbon-compiler/tests/L1/Typecheck.hs +++ b/gibbon-compiler/tests/L1/Typecheck.hs @@ -130,7 +130,8 @@ t1Prog = Prog {ddefs = M.fromList [], funRec = NotRec, funCanTriggerGC = False - } + }, + funOptLayout = NoLayoutOpt }), ("add2", FunDef {funName = "add2", @@ -142,7 +143,8 @@ t1Prog = Prog {ddefs = M.fromList [], funMeta = FunMeta { funInline = Inline, funRec = NotRec, funCanTriggerGC = False - } + }, + funOptLayout = NoLayoutOpt })], mainExp = Just ( AppE "mul2" [] [LitE 10, AppE "add2" [] [LitE 40, LitE 2]] From bc339a65b8f06248cf3f4f0e557638b65eba55a3 Mon Sep 17 00:00:00 2001 From: vidsinghal Date: Wed, 16 Aug 2023 16:09:03 -0400 Subject: [PATCH 20/25] fix --- gibbon-compiler/tests/L1/Typecheck.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/gibbon-compiler/tests/L1/Typecheck.hs b/gibbon-compiler/tests/L1/Typecheck.hs index e34ce9bf4..7fa01fe27 100644 --- a/gibbon-compiler/tests/L1/Typecheck.hs +++ b/gibbon-compiler/tests/L1/Typecheck.hs @@ -128,10 +128,9 @@ t1Prog = Prog {ddefs = M.fromList [], [(VarE "x_y1"), (VarE "x_y1")], funMeta = FunMeta { funInline = Inline, funRec = NotRec, - funCanTriggerGC = False - - }, - funOptLayout = NoLayoutOpt + funCanTriggerGC = False, + funOptLayout = NoLayoutOpt + } }), ("add2", FunDef {funName = "add2", @@ -142,9 +141,9 @@ t1Prog = Prog {ddefs = M.fromList [], (VarE "x_y0")], funMeta = FunMeta { funInline = Inline, funRec = NotRec, - funCanTriggerGC = False - }, - funOptLayout = NoLayoutOpt + funCanTriggerGC = False, + funOptLayout = NoLayoutOpt + } })], mainExp = Just ( AppE "mul2" [] [LitE 10, AppE "add2" [] [LitE 40, LitE 2]] From 32d884b355ab08d217d8e4de98d47ea935ea9b30 Mon Sep 17 00:00:00 2001 From: vidsinghal Date: Wed, 16 Aug 2023 16:27:19 -0400 Subject: [PATCH 21/25] fix L1 test --- gibbon-compiler/tests/L1/Typecheck.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/gibbon-compiler/tests/L1/Typecheck.hs b/gibbon-compiler/tests/L1/Typecheck.hs index 7fa01fe27..2f27ff374 100644 --- a/gibbon-compiler/tests/L1/Typecheck.hs +++ b/gibbon-compiler/tests/L1/Typecheck.hs @@ -129,7 +129,8 @@ t1Prog = Prog {ddefs = M.fromList [], funMeta = FunMeta { funInline = Inline, funRec = NotRec, funCanTriggerGC = False, - funOptLayout = NoLayoutOpt + funOptLayout = NoLayoutOpt, + userConstraintsDataCon = Nothing } }), ("add2", @@ -142,7 +143,8 @@ t1Prog = Prog {ddefs = M.fromList [], funMeta = FunMeta { funInline = Inline, funRec = NotRec, funCanTriggerGC = False, - funOptLayout = NoLayoutOpt + funOptLayout = NoLayoutOpt, + userConstraintsDataCon = Nothing } })], mainExp = Just From fab882aeb0278dc750ce4d634e6bb1bcc50a483b Mon Sep 17 00:00:00 2001 From: vidsinghal Date: Thu, 17 Aug 2023 12:17:07 -0400 Subject: [PATCH 22/25] Passes: Access patterns, update GHC version to 9.4.6 in CI --- .github/workflows/haskell-ci.yml | 4 +- .github/workflows/test-gibbon.yml | 2 +- gibbon-compiler/gibbon.cabal | 7 +- .../Gibbon/Passes/AccessPatternsAnalysis.hs | 711 ++++++++++++++++++ .../src/Gibbon/Passes/SolveLayoutConstrs.hs | 497 ++++++++++++ 5 files changed, 1217 insertions(+), 4 deletions(-) create mode 100644 gibbon-compiler/src/Gibbon/Passes/AccessPatternsAnalysis.hs create mode 100644 gibbon-compiler/src/Gibbon/Passes/SolveLayoutConstrs.hs diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 404589731..d989c07a5 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -28,9 +28,9 @@ jobs: strategy: matrix: include: - - compiler: ghc-9.6.2 + - compiler: ghc-9.4.6 compilerKind: ghc - compilerVersion: 9.6.2 + compilerVersion: 9.4.6 setup-method: ghcup allow-failure: false - compiler: ghc-9.4.5 diff --git a/.github/workflows/test-gibbon.yml b/.github/workflows/test-gibbon.yml index 1c67b468e..da61792d9 100644 --- a/.github/workflows/test-gibbon.yml +++ b/.github/workflows/test-gibbon.yml @@ -18,7 +18,7 @@ jobs: - name: ghc and cabal env: HCKIND: ghc - HCVER: 9.6.2 + HCVER: 9.4.6 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" diff --git a/gibbon-compiler/gibbon.cabal b/gibbon-compiler/gibbon.cabal index 6b98d7218..4d21c6dca 100644 --- a/gibbon-compiler/gibbon.cabal +++ b/gibbon-compiler/gibbon.cabal @@ -13,7 +13,7 @@ category: Compilers/Interpreters build-type: Simple extra-source-files: README.md, cbits/rts.c cabal-version: >=1.10 -tested-with: GHC==9.6.2 +tested-with: GHC==9.4.6 , GHC==9.4.5 , GHC==9.2.8 , GHC==9.0.2 @@ -85,6 +85,8 @@ library Gibbon.Passes.ControlFlowGraph Gibbon.Passes.DefinitionUseChains Gibbon.Passes.CallGraph + Gibbon.Passes.AccessPatternsAnalysis + Gibbon.Passes.SolveLayoutConstrs other-extensions: DeriveDataTypeable CPP @@ -116,6 +118,9 @@ library , GenericPretty >= 1.2.1 && < 2 , language-c-quote >= 0.12.1 && < 1 , mainland-pretty >= 0.6.1 && < 1 + , language-python >= 0.5.8 + , timeit >= 2.0 + , time >= 1.12.2 -- Brings in lots of ekmett dependencies: -- , either diff --git a/gibbon-compiler/src/Gibbon/Passes/AccessPatternsAnalysis.hs b/gibbon-compiler/src/Gibbon/Passes/AccessPatternsAnalysis.hs new file mode 100644 index 000000000..f6246a72f --- /dev/null +++ b/gibbon-compiler/src/Gibbon/Passes/AccessPatternsAnalysis.hs @@ -0,0 +1,711 @@ +module Gibbon.Passes.AccessPatternsAnalysis + ( generateAccessGraphs + , FieldMap + , DataConAccessMap + ) where + + +-- Gibbon imports +import Gibbon.Common +import Gibbon.Language +import Gibbon.Language.Syntax +import Gibbon.Passes.ControlFlowGraph (CFGfunctionMap) + +import Control.Monad as Mo +import Data.Graph as G +import Data.List as L +import Data.Map as M +import Data.Maybe as Mb +import Data.Set as S + +-- Haskell imports +import Prelude as P +import Text.PrettyPrint.GenericPretty + + +-- | Type VariableMap: Stores mapping from Variable to wheather it comes from a particular datacon +-- | index position in data con. +type VariableMap = M.Map Var (Maybe (DataCon, Integer)) + + +-- | Map a function to its Access map for a particular data constructor. +-- | Function stored as variable name +type FieldMap = M.Map Var DataConAccessMap + + +-- | Store the access edges for fields in a data con. +-- | Fields are represented as index positions in the DataCon. +type DataConAccessMap = M.Map DataCon [((Integer, Integer), Integer)] + +generateAccessGraphs :: + (FreeVars (e l d), Ord l, Ord d, Ord (e l d), Out d, Out l) + => CFGfunctionMap (PreExp e l d) + -> FieldMap + -> FunDef (PreExp e l d) + -> [DataCon] + -> FieldMap +generateAccessGraphs cfgMap fieldMap funDef@FunDef { funName + , funBody + , funTy + , funArgs + } dcons = + case (M.lookup funName cfgMap) of + Just (graph, nodeFromVertex, vertexFromKey) -> + let topologicallySortedVertices = topSort graph + topologicallySortedNodes = + P.map nodeFromVertex topologicallySortedVertices + map = backtrackVariablesToDataConFields topologicallySortedNodes + edges = + P.map + (constructFieldGraph + Nothing + nodeFromVertex + vertexFromKey + topologicallySortedNodes + topologicallySortedNodes + map) + dcons + accessMapsList = zipWith (\x y -> (x, y)) dcons edges + accessMaps = M.fromList accessMapsList + in M.insert funName accessMaps fieldMap + Nothing -> error "generateAccessGraphs: no CFG for function found!" + +backtrackVariablesToDataConFields :: + (FreeVars (e l d), Ord l, Ord d, Ord (e l d), Out d, Out l) + => [(((PreExp e l d), Integer), Integer, [Integer])] + -> VariableMap +backtrackVariablesToDataConFields graph = + case graph of + [] -> M.empty + x:xs -> + let newMap = processVertex graph x M.empty + mlist = M.toList (newMap) + m = backtrackVariablesToDataConFields xs + mlist' = M.toList m + newMap' = M.fromList (mlist ++ mlist') + in newMap' + +processVertex :: + (FreeVars (e l d), Ord l, Ord d, Ord (e l d), Out d, Out l) + => [(((PreExp e l d), Integer), Integer, [Integer])] + -> (((PreExp e l d), Integer), Integer, [Integer]) + -> VariableMap + -> VariableMap +processVertex graph node map = + case node of + ((expression, likelihood), id, succ) -> + case expression of + DataConE loc dcon args -> + let freeVariables = + L.concat (P.map (\x -> S.toList (gFreeVars x)) args) + maybeIndexes = + P.map (getDataConIndexFromVariable graph) freeVariables + mapList = M.toList map + newMapList = P.zipWith (\x y -> (x, y)) freeVariables maybeIndexes + in M.fromList (mapList ++ newMapList) + _ -> map + +getDataConIndexFromVariable :: + (FreeVars (e l d), Ord l, Ord d, Ord (e l d), Out d, Out l) + => [(((PreExp e l d), Integer), Integer, [Integer])] + -> Var + -> Maybe (DataCon, Integer) +getDataConIndexFromVariable graph variable = + case graph of + [] -> Nothing + x:xs -> + let status = compareVariableWithDataConFields x variable + in case status of + Nothing -> getDataConIndexFromVariable xs variable + Just val -> Just val + +compareVariableWithDataConFields :: + (FreeVars (e l d), Ord l, Ord d, Ord (e l d), Out d, Out l) + => (((PreExp e l d), Integer), Integer, [Integer]) + -> Var + -> Maybe (DataCon, Integer) +compareVariableWithDataConFields node variable = + case node of + ((exp, likelihood), id, _) -> + case exp of + DataConE loc dcon args -> + let variables = [var | VarE var <- args] + results = P.map (variable ==) variables + maybeIndex = L.elemIndex True results + in case maybeIndex of + Nothing -> Nothing + Just val -> Just (dcon, P.toInteger val) + _ -> Nothing + + +-- | Return the freeVariables bound by an expression in Order +freeVarsInOrder :: (PreExp e l d) -> [Var] +freeVarsInOrder exp = + case exp of + DataConE loc dcon args -> [] + VarE var -> [var] + LitE val -> [] + CharE char -> [] + FloatE val -> [] + LitSymE var -> [var] + AppE f locs args -> + let var_list_list = P.map (freeVarsInOrder) args + var_list = L.concat var_list_list + in var_list + PrimAppE f args -> + let var_list_list = P.map (freeVarsInOrder) args + var_list = L.concat var_list_list + in var_list + LetE (v, loc, ty, rhs) bod -> freeVarsInOrder rhs + CaseE scrt mp -> + (freeVarsInOrder scrt) ++ + (L.concat + (L.map + (\(_, vlocs, expr) -> + let (vars, _) = P.unzip vlocs + freeVarsExp = freeVarsInOrder expr + newVars = freeVarsExp ++ vars + in newVars) + mp)) + IfE a b c -> + (freeVarsInOrder a) ++ (freeVarsInOrder b) ++ (freeVarsInOrder c) + MkProdE xs -> + let var_list_list = P.map (freeVarsInOrder) xs + var_list = L.concat var_list_list + in var_list + ProjE i e -> error "freeVarsInOrder: TODO ProjE" + TimeIt e ty b -> error "freeVarsInOrder: TODO TimeIt" + WithArenaE v e -> error "freeVarsInOrder: TODO WithArenaE" + SpawnE f locs args -> error "freeVarsInOrder: TODO SpawnE" + SyncE -> error "freeVarsInOrder: TODO SyncE" + Ext _ -> error "freeVarsInOrder: TODO Ext" + MapE {} -> error "freeVarsInOrder: TODO MapE" + FoldE {} -> error "freeVarsInOrder: TODO FoldE" + +removeDuplicates :: Eq a => [a] -> [a] +removeDuplicates list = + case list of + [] -> [] + a:as -> a : removeDuplicates (P.filter (/= a) as) + + +-- | From a given graph generate the Field ordering subgraph. +-- | A subgraph that only contains Fields from the dataCons as Vertices. +-- | Edges amongst vertices amount to the READ ACCESS Patterns amongs the fields of the DataCon. +-- | For now, we only cares about read <-> read dependencies. + +-- | RETURN: an edge list and corresponding weight of the the edges +-- | Edge: a tuple from vertex to vertex, left dominates right. + +-- | TODO: any FIXMEs in the function. + +-- | a.) Multiple datacon fields read in the same expression. +-- | Since this will be run after flatten, it is safe to assume that only possibly a maximum of two variables can be read in one let binding. +-- | Except function calls! where more than two fields can be passed as arguments. +evaluateExpressionFieldGraph :: + Maybe (DataCon, Integer) + -> (G.Vertex -> (((PreExp e l d), Integer), Integer, [Integer])) + -> (Integer -> Maybe G.Vertex) + -> [(((PreExp e l d), Integer), Integer, [Integer])] + -> [(((PreExp e l d), Integer), Integer, [Integer])] + -> VariableMap + -> DataCon + -> [Var] + -> [Integer] + -> Integer + -> [((Integer, Integer), Integer)] +evaluateExpressionFieldGraph currField nodeFromVertex vertexFromNode graph xs map datacon freeVars successors likelihood = + case currField of + Nothing -> + let fromDataCon' = + P.map + (\v -> M.findWithDefault Nothing v map) + (removeDuplicates freeVars) + justDcons = [Just x | Just x <- fromDataCon'] + fromDataCon'' = + if P.null justDcons + then [Nothing] + else justDcons + in case fromDataCon'' of + [a] -> + case a of + Nothing -> + [] ++ + constructFieldGraph + Nothing + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + Just (dcon, id) -> + case (dcon == datacon) of + True -> + let succ' = Mb.catMaybes $ P.map vertexFromNode successors + succVertices = P.map nodeFromVertex succ' + succExp = P.map (\x -> (fst . fst3) x) succVertices + succprob = P.map (\x -> (snd . fst3) x) succVertices + {- list of list, where each list stores variables -} + succDataCon = + P.map + (\x -> + findFieldInDataConFromVariableInExpression + x + graph + map + datacon) + succExp + {- list of tuples, where each tuple == ([(dcon, id), ... ], likelihood) -} + succDataCon' = + P.zipWith (\x y -> (x, y)) succDataCon succprob + newEdges = + P.concat $ + P.map + (\x -> + case x of + (varsl, prob) -> + P.map (\y -> ((id, snd y), prob)) varsl) + succDataCon' + in case newEdges of + [] -> + case successors of + [] -> + [] ++ + constructFieldGraph + Nothing + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + _ -> + newEdges ++ + constructFieldGraph + (Just (dcon, id)) + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + _ -> + newEdges ++ + constructFieldGraph + Nothing + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + _ -> + [] ++ + constructFieldGraph + currField + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + _ -> + error + "evaluateExpressionFieldGraph: More than one variable from DataCon in a let binding not modelled into Field dependence graph yet!" + Just (dcon, pred) -> + let fromDataCon' = + P.map + (\v -> M.findWithDefault Nothing v map) + (removeDuplicates freeVars) + justDcons = [Just x | Just x <- fromDataCon'] + fromDataCon'' = + if P.null justDcons + then [Nothing] + else justDcons + in case fromDataCon'' of + [a] -> + case a of + Nothing -> + let succ' = Mb.catMaybes $ P.map vertexFromNode successors + succVertices = P.map nodeFromVertex succ' + succExp = P.map (\x -> (fst . fst3) x) succVertices + succprob = P.map (\x -> (snd . fst3) x) succVertices + {- list of list, where each list stores variables -} + succDataCon = + P.map + (\x -> + findFieldInDataConFromVariableInExpression + x + graph + map + datacon) + succExp + {- list of tuples, where each tuple == ([(dcon, id), ... ], likelihood) -} + succDataCon' = + P.zipWith (\x y -> (x, y)) succDataCon succprob + newEdges = + P.concat $ + P.map + (\x -> + case x of + (varsl, prob) -> + P.map (\y -> ((pred, snd y), prob)) varsl) + succDataCon' + in case newEdges of + [] -> + case successors of + [] -> + [] ++ + constructFieldGraph + Nothing + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + _ -> + newEdges ++ + constructFieldGraph + (Just (dcon, pred)) + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + _ -> + newEdges ++ + constructFieldGraph + Nothing + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + Just (dcon', id') -> + case (dcon' == datacon) of + True -> + let edges = [((pred, id'), likelihood)] + succ' = Mb.catMaybes $ P.map vertexFromNode successors + succVertices = P.map nodeFromVertex succ' + succExp = P.map (\x -> (fst . fst3) x) succVertices + succprob = P.map (\x -> (snd . fst3) x) succVertices + succDataCon = + P.map + (\x -> + findFieldInDataConFromVariableInExpression + x + graph + map + datacon) + succExp + succDataCon' = + P.zipWith (\x y -> (x, y)) succDataCon succprob + newEdges = + P.concat $ + P.map + (\x -> + case x of + (varsl, prob) -> + P.map (\y -> ((pred, snd y), prob)) varsl) + succDataCon' + in newEdges ++ + edges ++ + constructFieldGraph + Nothing + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + _ -> + [] ++ + constructFieldGraph + currField + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + _ -> + error + "evaluateExpressionFieldGraph: More than one variable from DataCon in a let binding not modelled into Field dependence graph yet!" + +constructFieldGraph :: + Maybe (DataCon, Integer) + -> (G.Vertex -> (((PreExp e l d), Integer), Integer, [Integer])) + -> (Integer -> Maybe G.Vertex) + -> [(((PreExp e l d), Integer), Integer, [Integer])] + -> [(((PreExp e l d), Integer), Integer, [Integer])] + -> VariableMap + -> DataCon + -> [((Integer, Integer), Integer)] +constructFieldGraph currField nodeFromVertex vertexFromNode graph progress map datacon = + case progress of + [] -> [] + x:xs -> + let ((exp, likelihood), id'', successors) = x + in case exp of + LitE val -> + case successors of + [] -> + [] ++ + constructFieldGraph + Nothing + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + _ -> + [] ++ + constructFieldGraph + currField + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + CharE char -> + case successors of + [] -> + [] ++ + constructFieldGraph + Nothing + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + _ -> + [] ++ + constructFieldGraph + currField + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + FloatE val -> + case successors of + [] -> + [] ++ + constructFieldGraph + Nothing + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + _ -> + [] ++ + constructFieldGraph + currField + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + DataConE loc dcon args -> + case successors of + [] -> + [] ++ + constructFieldGraph + Nothing + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + _ -> + [] ++ + constructFieldGraph + currField + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + VarE var -> + evaluateExpressionFieldGraph + currField + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + [var] + successors + likelihood + LitSymE var -> + evaluateExpressionFieldGraph + currField + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + [var] + successors + likelihood + LetE (v, loc, ty, rhs) bod -> + evaluateExpressionFieldGraph + currField + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + (freeVarsInOrder rhs) + successors + likelihood + AppE f locs args -> + evaluateExpressionFieldGraph + currField + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + (freeVarsInOrder exp) + successors + likelihood + PrimAppE f args -> + evaluateExpressionFieldGraph + currField + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + (freeVarsInOrder exp) + successors + likelihood + MkProdE xss -> + evaluateExpressionFieldGraph + currField + nodeFromVertex + vertexFromNode + graph + xs + map + datacon + (freeVarsInOrder exp) + successors + likelihood + ProjE i e -> error "constructFieldGraph: TODO ProjE" + TimeIt e ty b -> error "constructFieldGraph: TODO TimeIt" + WithArenaE v e -> error "constructFieldGraph: TODO WithArenaE" + SpawnE f locs args -> error "constructFieldGraph: TODO SpawnE" + SyncE -> error "constructFieldGraph: TODO SyncE" + Ext _ -> error "constructFieldGraph: TODO Ext" + MapE {} -> error "constructFieldGraph: TODO MapE" + FoldE {} -> error "constructFieldGraph: TODO FoldE" + + +-- | From an expression provided, Recursively find all the variables that come from a DataCon expression, that is, are fields in a DataConE. +findFieldInDataConFromVariableInExpression :: + (PreExp e l d) + -> [(((PreExp e l d), Integer), Integer, [Integer])] + -> VariableMap + -> DataCon + -> [(DataCon, Integer)] +findFieldInDataConFromVariableInExpression exp graph map datacon = + case exp of + VarE var -> + let fromDataCon = M.findWithDefault Nothing var map + in case fromDataCon of + Nothing -> [] + Just (dcon, id') -> + if dcon == datacon + then [(dcon, id')] + else [] + LitSymE var -> + let fromDataCon = M.findWithDefault Nothing var map + in case fromDataCon of + Nothing -> [] + Just (dcon, id') -> + if dcon == datacon + then [(dcon, id')] + else [] + LetE (v, loc, ty, rhs) bod -> + let freeVars = freeVarsInOrder rhs + fromDataCon = P.map (\v -> M.findWithDefault Nothing v map) freeVars + removeMaybe = Mb.catMaybes fromDataCon + newDatacons = + [ if dcon == datacon + then Just (dcon, id') + else Nothing + | (dcon, id') <- removeMaybe + ] + newDatacons' = Mb.catMaybes newDatacons + in newDatacons' + AppE f locs args -> + let freeVars = freeVarsInOrder exp + fromDataCon = P.map (\v -> M.findWithDefault Nothing v map) freeVars + removeMaybe = Mb.catMaybes fromDataCon + newDatacons = + [ if dcon == datacon + then Just (dcon, id') + else Nothing + | (dcon, id') <- removeMaybe + ] + newDatacons' = Mb.catMaybes newDatacons + in newDatacons' + PrimAppE f args -> + let freeVars = freeVarsInOrder exp + fromDataCon = P.map (\v -> M.findWithDefault Nothing v map) freeVars + removeMaybe = Mb.catMaybes fromDataCon + newDatacons = + [ if dcon == datacon + then Just (dcon, id') + else Nothing + | (dcon, id') <- removeMaybe + ] + newDatacons' = Mb.catMaybes newDatacons + in newDatacons' + LitE val -> [] + CharE char -> [] + FloatE val -> [] + DataConE loc dcon args -> [] + MkProdE xss -> + let freeVars = freeVarsInOrder exp + fromDataCon = P.map (\v -> M.findWithDefault Nothing v map) freeVars + removeMaybe = Mb.catMaybes fromDataCon + newDatacons = + [ if dcon == datacon + then Just (dcon, id') + else Nothing + | (dcon, id') <- removeMaybe + ] + newDatacons' = Mb.catMaybes newDatacons + in newDatacons' + ProjE i e -> error "findFieldInDataConFromVariableInExpression: TODO ProjE" + TimeIt e ty b -> + error "findFieldInDataConFromVariableInExpression: TODO TimeIt" + WithArenaE v e -> + error "findFieldInDataConFromVariableInExpression: TODO WithArenaE" + SpawnE f locs args -> + error "findFieldInDataConFromVariableInExpression: TODO SpawnE" + SyncE -> error "findFieldInDataConFromVariableInExpression: TODO SyncE" + Ext _ -> error "findFieldInDataConFromVariableInExpression: TODO Ext" + MapE {} -> error "findFieldInDataConFromVariableInExpression: TODO MapE" + FoldE {} -> error "findFieldInDataConFromVariableInExpression: TODO FoldE" diff --git a/gibbon-compiler/src/Gibbon/Passes/SolveLayoutConstrs.hs b/gibbon-compiler/src/Gibbon/Passes/SolveLayoutConstrs.hs new file mode 100644 index 000000000..d859859fa --- /dev/null +++ b/gibbon-compiler/src/Gibbon/Passes/SolveLayoutConstrs.hs @@ -0,0 +1,497 @@ +module Gibbon.Passes.SolveLayoutConstrs + ( solveConstrs + ) where + +import Gibbon.Common +import Gibbon.L1.Syntax + +import Gibbon.Language.Syntax + +import Control.Monad.State (lift) +import Data.Int +import qualified Data.List as L +import Data.Maybe (fromJust) +import qualified Data.Set as S +import GHC.Float +import Prelude as P +import System.Exit +import System.IO +import System.Process +import System.Random + +import qualified Language.Python.Common.AST as Py +import qualified Language.Python.Common.Pretty as Py +import qualified Language.Python.Common.PrettyAST as Py + + +-------------------------------------------------------------------------------- + +-- new positions of fields +type Layout = [(Int, Int)] + + +-- change if required +python3 :: String +python3 = "python3" + +solveConstrs :: [Constr] -> IO Layout +solveConstrs constrs = do + let pycode = fst $ defaultRunPassM (pythonCodegen constrs) + uniq <- randomIO :: IO Int8 + let fp = "./solve_ilp_" ++ show uniq ++ ".py" + writeFile fp pycode + let cmd = python3 ++ " " ++ fp + (_, Just hout, Just herr, phandle) <- + createProcess (shell cmd) {std_out = CreatePipe, std_err = CreatePipe} + exitCode <- waitForProcess phandle + case exitCode of + ExitSuccess -> do + out <- hGetContents hout + let new_positions :: [(Int, Int)] = + map ((\(x, y) -> (float2Int x, float2Int y)) . read) (lines out) + pure new_positions + ExitFailure n -> + error $ + "Running docplex program in file " ++ + fp ++ " exited with error code " ++ show n + +pythonCodegen :: [Constr] -> PassM String +pythonCodegen constrs + -- There should be a map mapping indexes to the generated variables + -- 3 maps for different constraints + -- Here have a map to seperate the soft constraints and pass as usual + = do + let idxs = + L.nub $ + P.concatMap + (\a -> + case a of + Soft ((a, b), _) -> [a, b] + _ -> []) + constrs + let softConstr = + P.concatMap + (\a -> + case a of + Soft a -> [a] + _ -> []) + constrs + let immediateConstrVariables = + L.nub $ + P.concatMap + (\a -> + case a of + Imm (a, b) -> [a, b] + _ -> []) + constrs + +-- filter out the relative constraints. + -- don't need integers in snd part of tuple since they are positions that need to be assigned not for creating variables. + let relativeConstrs = + P.concatMap + (\a -> + case a of + Imm a -> [a] + _ -> []) + constrs + let absConstrVariables = + L.nub $ + P.concatMap + (\a -> + case a of + Absolute (a, b) -> [a] + _ -> []) + constrs + let strongConstraints = + P.concatMap + (\a -> + case a of + Absolute a -> [a] + _ -> []) + constrs + +-- [ (field_index, variable_name) ] + node_map <- + mapM + (\i -> (i, ) <$> fromVar <$> gensym (toVar ("x_" ++ show i))) + (L.nub $ (idxs ++ immediateConstrVariables ++ absConstrVariables)) + let node_vars = P.concatMap (\(i, var) -> [var]) node_map + model_var <- (\i -> "model_" ++ show i) <$> newUniq + let init_model = + Py.Assign + [Py.Var (pyident model_var) ()] + (Py.Call (Py.Var (pyident "Model") ()) [] ()) + () + +-- make a map for upper, lower bounds. + let (lb, ub) = + ( fromIntegral $ 0 + , fromIntegral $ + (P.length (L.nub $ (idxs ++ immediateConstrVariables))) - 1) + let soft_rel_to_ub = + P.map + (\index -> (fromJust $ lookup index node_map, ub)) + (idxs ++ immediateConstrVariables) + let abs_ub = + P.map (\(x, y) -> (fromJust $ lookup x node_map, y)) strongConstraints + let vars_ub = soft_rel_to_ub ++ abs_ub + let init_nodes = + map + (\x -> + pyassign1 + x + (Py.Call + (Py.Dot (pyvar model_var) (pyident "integer_var") ()) + [ Py.ArgKeyword (pyident "lb") (Py.Int lb (show lb) ()) () + , Py.ArgKeyword + (pyident "ub") + (Py.Int + (fromJust $ lookup x vars_ub) + (show (fromJust $ lookup x vars_ub)) + ()) + () + , Py.ArgKeyword (pyident "name") (Py.Strings [show x] ()) () + ] + ())) + node_vars + let num_edges = + P.sum $ + P.map + (\a -> + case a of + Soft _ -> 1 + _ -> 0) + constrs + cost_map <- + mapM (\i -> (i, ) <$> fromVar <$> gensym (toVar "cost")) [1 .. num_edges] + let cost_vars = map snd cost_map + let import_doplex = + Py.FromImport + (Py.ImportRelative + 0 + (Just [pyident "docplex", pyident "mp", pyident "model"]) + ()) + (Py.FromItems [Py.FromItem (pyident "Model") Nothing ()] ()) + () + let init_costs = + map + (\x -> + pyassign1 + x + (Py.Call + (Py.Dot (pyvar model_var) (pyident "integer_var") ()) + [Py.ArgKeyword (pyident "name") (Py.Strings [show x] ()) ()] + ())) + cost_vars + minimize_parts <- + mapM (\_ -> fromVar <$> gensym (toVar "min")) [1 .. num_edges] + let constrs_for_edge = + (\(((from, to), wt), cost, minimize_part) -> do + let x = fromJust $ lookup from node_map + let y = fromJust $ lookup to node_map + -- let cost_x = fromJust $ lookup from cost_map -- Vidush review + eq_minus_one <- fromVar <$> (gensym "cost") + leq_minus_one <- fromVar <$> (gensym "cost") + eq_one <- fromVar <$> (gensym "cost") + geq_one <- fromVar <$> (gensym "cost") + neq_minus_one <- fromVar <$> (gensym "cost") + neq_one <- fromVar <$> (gensym "cost") + x_minus_y <- fromVar <$> (gensym "x_minus_y") + pure $ + [ pyassign1 + x_minus_y + (Py.Paren (Py.BinaryOp (Py.Minus ()) (pyvar x) (pyvar y) ()) ()) + , pyassign1 + eq_minus_one + (Py.Paren + (Py.BinaryOp + (Py.Equality ()) + (pyvar x_minus_y) + (Py.Int (-1) (show (-1)) ()) + ()) + ()) + , pyassign1 + leq_minus_one + (Py.Paren + (Py.BinaryOp + (Py.LessThanEquals ()) + (pyvar x_minus_y) + (Py.Int (-1) (show (-1)) ()) + ()) + ()) + , pyassign1 + eq_one + (Py.Paren + (Py.BinaryOp + (Py.Equality ()) + (pyvar x_minus_y) + (Py.Int 1 (show 1) ()) + ()) + ()) + , pyassign1 + geq_one + (Py.Paren + (Py.BinaryOp + (Py.GreaterThanEquals ()) + (pyvar x_minus_y) + (Py.Int 1 (show 1) ()) + ()) + ()) + , pyassign1 + neq_minus_one + (Py.Paren + (Py.BinaryOp + (Py.NotEquals ()) + (pyvar x_minus_y) + (Py.Int (-1) (show (-1)) ()) + ()) + ()) + , pyassign1 + neq_one + (Py.Paren + (Py.BinaryOp + (Py.NotEquals ()) + (pyvar x_minus_y) + (Py.Int 1 (show 1) ()) + ()) + ()) + , Py.StmtExpr + (Py.Call + (Py.Dot (pyvar model_var) (pyident "add") ()) + [ Py.ArgExpr + (Py.BinaryOp + (Py.LessThanEquals ()) + (pyvar eq_minus_one) + (Py.Paren + (Py.BinaryOp + (Py.Equality ()) + (pyvar cost) + (Py.Int 0 (show 0) ()) + ()) + ()) + ()) + () + ] + ()) + () + , Py.StmtExpr + (Py.Call + (Py.Dot (pyvar model_var) (pyident "add") ()) + [ Py.ArgExpr + (Py.BinaryOp + (Py.LessThanEquals ()) + (Py.Paren + (Py.BinaryOp + (Py.BinaryAnd ()) + (pyvar leq_minus_one) + (pyvar neq_minus_one) + ()) + ()) + (Py.Paren + (Py.BinaryOp + (Py.Equality ()) + (pyvar cost) + (Py.Int 100 (show 100) ()) + ()) + ()) + ()) + () + ] + ()) + () + , Py.StmtExpr + (Py.Call + (Py.Dot (pyvar model_var) (pyident "add") ()) + [ Py.ArgExpr + (Py.BinaryOp + (Py.LessThanEquals ()) + (pyvar eq_one) + (Py.Paren + (Py.BinaryOp + (Py.Equality ()) + (pyvar cost) + (Py.Int 200 (show 200) ()) + ()) + ()) + ()) + () + ] + ()) + () + , Py.StmtExpr + (Py.Call + (Py.Dot (pyvar model_var) (pyident "add") ()) + [ Py.ArgExpr + (Py.BinaryOp + (Py.LessThanEquals ()) + (Py.Paren + (Py.BinaryOp + (Py.BinaryAnd ()) + (pyvar geq_one) + (pyvar neq_one) + ()) + ()) + (Py.Paren + (Py.BinaryOp + (Py.Equality ()) + (pyvar cost) + (Py.Int 300 (show 300) ()) + ()) + ()) + ()) + () + ] + ()) + () + , pyassign1 + minimize_part + (Py.BinaryOp + (Py.Multiply ()) + (pyvar cost) + (Py.Int wt (show wt) ()) + ()) + ]) :: ((((Integer, Integer), Integer), String, String) -> PassM [(Py.Statement ())]) + constrs_for_edges <- + concat <$> mapM constrs_for_edge (zip3 softConstr cost_vars minimize_parts) + let expr_to_minimize = + foldr + (\x acc -> Py.BinaryOp (Py.Plus ()) (pyvar x) acc ()) + (Py.Int 0 (show 0) ()) + minimize_parts + let call_minimize = + Py.StmtExpr + (Py.Call + (Py.Dot (pyvar model_var) (pyident "minimize") ()) + [(Py.ArgExpr expr_to_minimize ())] + ()) + () + -- All the fields should have unique index positions. + let uniq_constrs = + map + (\[i, j] -> + Py.StmtExpr + (Py.Call + (Py.Dot (pyvar model_var) (pyident "add") ()) + [ Py.ArgExpr + (Py.BinaryOp (Py.NotEquals ()) (pyvar i) (pyvar j) ()) + () + ] + ()) + ()) + (combinations 2 node_vars) + soln_var <- fromVar <$> (gensym "soln") + let call_solve = + pyassign1 + soln_var + (Py.Call (Py.Dot (pyvar model_var) (pyident "solve") ()) [] ()) + let answer_format_str = "({},{})" + let print_left_bracket = + Py.StmtExpr + (Py.Call + (pyvar "print") + [Py.ArgExpr (Py.Strings [(show "[")] ()) ()] + ()) + () + let print_right_bracket = + Py.StmtExpr + (Py.Call + (pyvar "print") + [Py.ArgExpr (Py.Strings [(show "]")] ()) ()] + ()) + () + let print_answers = + map + (\(i, v) -> + Py.StmtExpr + (Py.Call + (pyvar "print") + [ (Py.ArgExpr + (Py.Call + (Py.Dot + (Py.Strings [show answer_format_str] ()) + (pyident "format") + ()) + [ Py.ArgExpr (Py.Int i (show i) ()) () + , Py.ArgExpr + (Py.Call + (Py.Dot + (pyvar soln_var) + (pyident "get_value") + ()) + [Py.ArgExpr (pyvar v) ()] + ()) + () + ] + ()) + ()) + ] + ()) + ()) + node_map + +-- make the relative constraints is they exist + let relativeConstrsBindings = + P.map + (\(x, y) -> + Py.StmtExpr + (Py.Call + (Py.Dot (pyvar model_var) (pyident "add") ()) + [ Py.ArgExpr + (Py.BinaryOp + (Py.Equality ()) + (pyvar (fromJust $ lookup y node_map)) + (Py.BinaryOp + (Py.Plus ()) + (pyvar (fromJust $ lookup x node_map)) + ((Py.Int 1 (show 1) ())) + ()) + ()) + () + ] + ()) + ()) + relativeConstrs + let absolute_ordering_constrs = + P.map + (\(x, y) -> + Py.StmtExpr + (Py.Call + (Py.Dot (pyvar model_var) (pyident "add") ()) + [ Py.ArgExpr + (Py.BinaryOp + (Py.Equality ()) + (pyvar (fromJust $ lookup x node_map)) + ((Py.Int y (show y) ())) + ()) + () + ] + ()) + ()) + strongConstraints + let stmts = + [import_doplex, init_model] ++ + init_nodes ++ + init_costs ++ + constrs_for_edges ++ + uniq_constrs ++ + relativeConstrsBindings ++ + absolute_ordering_constrs ++ + [call_minimize, call_solve] ++ print_answers + let pycode = Py.prettyText (Py.Module stmts) + pure pycode --dbgTraceIt (sdoc node_vars) (dbgTraceIt "\n") + + +-- https://stackoverflow.com/a/52605612 +combinations :: Int -> [a] -> [[a]] +combinations k ns = filter ((k ==) . length) $ L.subsequences ns + + +-------------------------------------------------------------------------------- +pyident :: String -> Py.Ident () +pyident s = Py.Ident s () + +pyvar :: String -> Py.Expr () +pyvar s = Py.Var (pyident s) () + +pyassign1 :: String -> Py.Expr () -> Py.Statement () +pyassign1 v rhs = Py.Assign [pyvar v] rhs () From ba19bc2932988136c023f4d144846c620765917f Mon Sep 17 00:00:00 2001 From: vidsinghal Date: Thu, 17 Aug 2023 12:24:48 -0400 Subject: [PATCH 23/25] change package versions --- gibbon-compiler/gibbon.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/gibbon-compiler/gibbon.cabal b/gibbon-compiler/gibbon.cabal index 4d21c6dca..95cebb9a8 100644 --- a/gibbon-compiler/gibbon.cabal +++ b/gibbon-compiler/gibbon.cabal @@ -118,9 +118,9 @@ library , GenericPretty >= 1.2.1 && < 2 , language-c-quote >= 0.12.1 && < 1 , mainland-pretty >= 0.6.1 && < 1 - , language-python >= 0.5.8 - , timeit >= 2.0 - , time >= 1.12.2 + , language-python >= 0.5.0 && <= 0.5.8 + , timeit >= 0.9 && <= 2.0 + , time >= 1 && <= 1.12.2 -- Brings in lots of ekmett dependencies: -- , either From 0cb2be2ec53247e5656f7f0ba6c969dc48df2476 Mon Sep 17 00:00:00 2001 From: vidsinghal Date: Thu, 17 Aug 2023 20:35:18 -0400 Subject: [PATCH 24/25] src: HaskellFrontend --- gibbon-compiler/src/Gibbon/HaskellFrontend.hs | 2768 +++++++++++------ 1 file changed, 1862 insertions(+), 906 deletions(-) diff --git a/gibbon-compiler/src/Gibbon/HaskellFrontend.hs b/gibbon-compiler/src/Gibbon/HaskellFrontend.hs index 8a74504ac..779687267 100644 --- a/gibbon-compiler/src/Gibbon/HaskellFrontend.hs +++ b/gibbon-compiler/src/Gibbon/HaskellFrontend.hs @@ -1,35 +1,42 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} module Gibbon.HaskellFrontend - ( parseFile, primMap, multiArgsToOne, desugarLinearExts ) where + ( parseFile + , primMap + , multiArgsToOne + , desugarLinearExts + ) where import Control.Monad -import Data.Foldable ( foldrM, foldl' ) -import Data.Maybe (catMaybes, isJust) -import qualified Data.Map as M -import qualified Data.Set as S +import Data.Foldable (foldl', foldrM) import Data.IORef +import qualified Data.Map as M +import Data.Maybe (catMaybes, isJust) +import qualified Data.Set as S +import Language.Haskell.Exts.CPP import Language.Haskell.Exts.Extension import Language.Haskell.Exts.Parser -import Language.Haskell.Exts.Syntax as H import Language.Haskell.Exts.Pretty import Language.Haskell.Exts.SrcLoc -import Language.Haskell.Exts.CPP -import System.Environment ( getEnvironment ) +import Language.Haskell.Exts.Syntax as H import System.Directory -import System.FilePath -import System.Process +import System.Environment (getEnvironment) import System.Exit +import System.FilePath import System.IO +import System.Process -import Gibbon.L0.Syntax as L0 import Gibbon.Common import Gibbon.DynFlags +import Gibbon.L0.Syntax as L0 --------------------------------------------------------------------------------- +import Data.List as L +import Prelude as P + +-------------------------------------------------------------------------------- {- Importing modules: @@ -56,41 +63,46 @@ it expects A.B.D to be at A/B/A/B/D.hs. [1] https://downloads.haskell.org/ghc/8.6.4/docs/html/users_guide/separate_compilation.html?#the-search-path -} - - parseFile :: Config -> FilePath -> IO (PassM Prog0) parseFile cfg path = do - pstate0_ref <- newIORef emptyParseState - parseFile' cfg pstate0_ref [] path - + pstate0_ref <- newIORef emptyParseState + parseFile' cfg pstate0_ref [] path -data ParseState = ParseState - { imported :: M.Map (String, FilePath) Prog0 } +data ParseState = + ParseState + { imported :: M.Map (String, FilePath) Prog0 + } emptyParseState :: ParseState emptyParseState = ParseState M.empty parseMode :: ParseMode -parseMode = defaultParseMode { extensions = [ EnableExtension ScopedTypeVariables - , EnableExtension CPP - , EnableExtension TypeApplications - ] - ++ (extensions defaultParseMode) - } - -parseFile' :: Config -> IORef ParseState -> [String] -> FilePath -> IO (PassM Prog0) +parseMode = + defaultParseMode + { extensions = + [ EnableExtension ScopedTypeVariables + , EnableExtension CPP + , EnableExtension TypeApplications + ] ++ + (extensions defaultParseMode) + } + +parseFile' :: + Config -> IORef ParseState -> [String] -> FilePath -> IO (PassM Prog0) parseFile' cfg pstate_ref import_route path = do - when (gopt Opt_GhcTc (dynflags cfg)) $ - typecheckWithGhc cfg path + when (gopt Opt_GhcTc (dynflags cfg)) $ typecheckWithGhc cfg path str <- readFile path let cleaned = removeLinearArrows str -- let parsed = parseModuleWithMode parseMode cleaned - parsed <- parseFileContentsWithCommentsAndCPP defaultCpphsOptions parseMode cleaned + parsed <- + parseFileContentsWithCommentsAndCPP defaultCpphsOptions parseMode cleaned case parsed of - ParseOk (hs,_comments) -> desugarModule cfg pstate_ref import_route (takeDirectory path) hs + ParseOk (hs, _comments) -> + desugarModule cfg pstate_ref import_route (takeDirectory path) hs ParseFailed loc er -> do error ("haskell-src-exts failed: " ++ er ++ ", at " ++ prettyPrint loc) + -- | ASSUMPTION: gibbon-stdlib is available to Cabal. -- -- Currently 'run_all_tests.sh' installs it with 'cabal v1-install . -w ghc-9.0.1'. @@ -98,13 +110,16 @@ typecheckWithGhc :: Config -> FilePath -> IO () typecheckWithGhc cfg path = do when (verbosity cfg >= 3) $ putStr " [compiler] Running pass, GHC typechecker\n => " - let cmd = "ghc-9.0.1 -package gibbon-stdlib-0.1 -XNoImplicitPrelude -fno-code " ++ path + let cmd = + "ghc-9.0.1 -package gibbon-stdlib-0.1 -XNoImplicitPrelude -fno-code " ++ + path (_, Just hout, Just herr, phandle) <- - createProcess (shell cmd) - { std_out = CreatePipe - , std_err = CreatePipe - , cwd = Just (takeDirectory path) - } + createProcess + (shell cmd) + { std_out = CreatePipe + , std_err = CreatePipe + , cwd = Just (takeDirectory path) + } exitCode <- waitForProcess phandle case exitCode of ExitSuccess -> do @@ -118,23 +133,25 @@ typecheckWithGhc cfg path = do err <- hGetContents herr error err + -- | Really basic, and won't catch every occurence of a linear arrow. -- -- But its only a stop-gap until we move to ghc-lib-parser, which can parse -- linear types and other things not supported by haskell-src-exts (e.g. CPP). removeLinearArrows :: String -> String removeLinearArrows str = - fst $ - foldr (\c (acc,saw_one) -> - if saw_one && c == '%' - then (acc, False) - else if saw_one && c /= '%' - then (c:'1':acc, False) + fst $ + foldr + (\c (acc, saw_one) -> + if saw_one && c == '%' + then (acc, False) + else if saw_one && c /= '%' + then (c : '1' : acc, False) else if c == '1' - then (acc, True) - else (c:acc, False)) - ([],False) - str + then (acc, True) + else (c : acc, False)) + ([], False) + str {- - messup up indendataion and causes compilation errors. - @@ -147,136 +164,312 @@ removeLinearArrows str = - lines -} + +--data Constraints = Strong Integer Integer deriving (Show, Eq) data TopLevel = HDDef (DDef Ty0) | HFunDef (FunDef Exp0) | HMain (Maybe (Exp0, Ty0)) | HInline Var + | OptimizeDcon (Var, DataCon) + | UserConstraints (M.Map Var (M.Map DataCon [UserOrdering])) deriving (Show, Eq) type TopTyEnv = TyEnv TyScheme + type TypeSynEnv = M.Map TyCon Ty0 -desugarModule :: (Show a, Pretty a) - => Config -> IORef ParseState -> [String] -> FilePath -> Module a -> IO (PassM Prog0) +desugarModule :: + (Show a, Pretty a) + => Config + -> IORef ParseState + -> [String] + -> FilePath + -> Module a + -> IO (PassM Prog0) desugarModule cfg pstate_ref import_route dir (Module _ head_mb _pragmas imports decls) = do let type_syns = foldl collectTypeSynonyms M.empty decls -- Since top-level functions and their types can't be declared in -- single top-level declaration we first collect types and then collect -- definitions. funtys = foldr (collectTopTy type_syns) M.empty decls - imported_progs :: [PassM Prog0] <- mapM (processImport cfg pstate_ref (mod_name : import_route) dir) imports + imported_progs :: [PassM Prog0] <- + mapM (processImport cfg pstate_ref (mod_name : import_route) dir) imports let prog = do toplevels <- catMaybes <$> mapM (collectTopLevel type_syns funtys) decls - let (defs,_vars,funs,inlines,main) = foldr classify init_acc toplevels - funs' = foldr (\v acc -> M.update (\fn@(FunDef{funMeta}) -> Just (fn { funMeta = funMeta { funInline = Inline }})) v acc) funs inlines + let (defs, _vars, funs, inlines, main, optimizeDcons, userOrderings) = + foldr classify init_acc toplevels + userOrderings' = M.fromList $ coalese_constraints userOrderings + funs' = + foldr + (\v acc -> + M.update + (\fn@(FunDef {funMeta}) -> + Just (fn {funMeta = funMeta {funInline = Inline}})) + v + acc) + funs + inlines + funs'' = + foldr + (\v acc -> + M.update + (\fn -> Just (addLayoutMetaData fn optimizeDcons)) + v + acc) + funs' + (P.map fst (S.toList optimizeDcons)) + funs''' = + foldr + (\k acc -> + M.update + (\fn@(FunDef {funName, funMeta}) -> + Just + (fn + { funMeta = + funMeta + { userConstraintsDataCon = + M.lookup funName userOrderings' + } + })) + k + acc) + funs'' + (M.keys userOrderings') imported_progs' <- mapM id imported_progs - let (defs0,funs0) = + let (defs0, funs0) = foldr - (\Prog{ddefs,fundefs} (defs1,funs1) -> - let ddef_names1 = M.keysSet defs1 - ddef_names2 = M.keysSet ddefs - fn_names1 = M.keysSet funs1 - fn_names2 = M.keysSet fundefs - em1 = S.intersection ddef_names1 ddef_names2 - em2 = S.intersection fn_names1 fn_names2 - conflicts1 = foldr - (\d acc -> - if (ddefs M.! d) /= (defs1 M.! d) - then d : acc - else acc) - [] - em1 - conflicts2 = foldr - (\f acc -> - if (fundefs M.! f) /= (funs1 M.! f) - then dbgTraceIt (sdoc ((fundefs M.! f), (funs1 M.! f))) (f : acc) - else acc) - [] - em2 - in case (conflicts1, conflicts2) of - ([], []) -> (M.union ddefs defs1, M.union fundefs funs1) - (_x:_xs,_) -> error $ "Conflicting definitions of " ++ show conflicts1 ++ " found in " ++ mod_name - (_,_x:_xs) -> error $ "Conflicting definitions of " ++ show (S.toList em2) ++ " found in " ++ mod_name) - (defs, funs') + (\Prog {ddefs, fundefs} (defs1, funs1) -> + let ddef_names1 = M.keysSet defs1 + ddef_names2 = M.keysSet ddefs + fn_names1 = M.keysSet funs1 + fn_names2 = M.keysSet fundefs + em1 = S.intersection ddef_names1 ddef_names2 + em2 = S.intersection fn_names1 fn_names2 + conflicts1 = + foldr + (\d acc -> + if (ddefs M.! d) /= (defs1 M.! d) + then d : acc + else acc) + [] + em1 + conflicts2 = + foldr + (\f acc -> + if (fundefs M.! f) /= (funs1 M.! f) + then dbgTraceIt + (sdoc ((fundefs M.! f), (funs1 M.! f))) + (f : acc) + else acc) + [] + em2 + in case (conflicts1, conflicts2) of + ([], []) -> + (M.union ddefs defs1, M.union fundefs funs1) + (_x:_xs, _) -> + error $ + "Conflicting definitions of " ++ + show conflicts1 ++ " found in " ++ mod_name + (_, _x:_xs) -> + error $ + "Conflicting definitions of " ++ + show (S.toList em2) ++ " found in " ++ mod_name) + (defs, funs''') imported_progs' - pure (Prog defs0 funs0 main) + pure (Prog defs0 funs0 main) --dbgTraceIt (sdoc funs) dbgTraceIt "\n" dbgTraceIt (sdoc funs''') dbgTraceIt (sdoc userOrderings') dbgTraceIt "\n" dbgTraceIt (sdoc userOrderings) pure prog where - init_acc = (M.empty, M.empty, M.empty, S.empty, Nothing) + init_acc = (M.empty, M.empty, M.empty, S.empty, Nothing, S.empty, []) mod_name = moduleName head_mb - + coalese_constraints :: + [(Var, M.Map DataCon [UserOrdering])] + -> [(Var, M.Map DataCon [UserOrdering])] + coalese_constraints constrs = + case constrs of + [] -> [] + (var, map):xs -> + let same_func_constrs = + P.concatMap + (\(a, b) -> + if (var == a) + then [(a, b)] + else []) + xs + maps_to_merge = P.concatMap (M.toList . snd) same_func_constrs + merged_maps = coalses_dconMap (maps_to_merge ++ M.toList map) + xs' = deleteMany same_func_constrs xs + in [(var, M.fromList merged_maps)] ++ (coalese_constraints xs') + coalses_dconMap :: + [(DataCon, [UserOrdering])] -> [(DataCon, [UserOrdering])] + coalses_dconMap dconOrdrs = + case dconOrdrs of + [] -> [] + (dcon, orderings):xs -> + let same_dcons = + P.concatMap + (\(a, b) -> + if (dcon == a) + then [(a, b)] + else []) + xs + same_orderings = (P.concatMap snd same_dcons) ++ orderings + xs' = deleteMany same_dcons xs + in [(dcon, same_orderings)] ++ coalses_dconMap xs' + deleteOne :: Eq x => (x, y) -> [(x, y)] -> [(x, y)] + deleteOne _ [] = [] -- Nothing to delete + deleteOne (a, b) ((c, d):ys) + | a == c = 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 x => [(x, y)] -> [(x, y)] -> [(x, y)] + deleteMany [] = id -- Nothing to delete + deleteMany (x:xs) = deleteMany xs . deleteOne x -- Delete one, then the rest. moduleName :: Maybe (ModuleHead a) -> String moduleName Nothing = "Main" moduleName (Just (ModuleHead _ mod_name1 _warnings _exports)) = mnameToStr mod_name1 - - classify thing (defs,vars,funs,inlines,main) = + classify thing (defs, vars, funs, inlines, main, optimizeDcons, userOrderings) = case thing of - HDDef d -> (M.insert (tyName d) d defs, vars, funs, inlines, main) - HFunDef f -> (defs, vars, M.insert (funName f) f funs, inlines, main) + HDDef d -> + ( M.insert (tyName d) d defs + , vars + , funs + , inlines + , main + , optimizeDcons + , userOrderings) + HFunDef f -> + ( defs + , vars + , M.insert (funName f) f funs + , inlines + , main + , optimizeDcons + , userOrderings) HMain m -> case main of - Nothing -> (defs, vars, funs, inlines, m) - Just _ -> error $ "A module cannot have two main expressions." - ++ show mod_name - HInline v -> (defs,vars,funs,S.insert v inlines,main) + Nothing -> + (defs, vars, funs, inlines, m, optimizeDcons, userOrderings) + Just _ -> + error $ + "A module cannot have two main expressions." ++ show mod_name + HInline v -> + ( defs + , vars + , funs + , S.insert v inlines + , main + , optimizeDcons + , userOrderings) + OptimizeDcon layoutOptimizationPair -> + ( defs + , vars + , funs + , inlines + , main + , S.insert layoutOptimizationPair optimizeDcons + , userOrderings) + UserConstraints map -> + ( defs + , vars + , funs + , inlines + , main + , optimizeDcons + , userOrderings ++ (M.toList map)) --error $ show thing + search :: Eq a => a -> [(a, b)] -> Maybe b + search a = fmap snd . L.find ((== a) . fst) + addLayoutMetaData :: FunDef0 -> S.Set (Var, DataCon) -> FunDef0 + addLayoutMetaData fn@(FunDef {funName, funMeta}) annotations = + let element = search funName (S.toList annotations) + in case element of + Nothing -> fn + Just dcon -> fn {funMeta = funMeta {funOptLayout = Single dcon}} desugarModule _ _ _ _ m = error $ "desugarModule: " ++ prettyPrint m stdlibModules :: [String] -stdlibModules = ["Gibbon.Prim", "Gibbon.Prelude", "Gibbon.Vector", "Gibbon.Vector.Parallel", - "Gibbon.List", "Gibbon.PList", "Gibbon.ByteString", "Gibbon.Maybe"] +stdlibModules = + [ "Gibbon.Prim" + , "Gibbon.Prelude" + , "Gibbon.Vector" + , "Gibbon.Vector.Parallel" + , "Gibbon.List" + , "Gibbon.PList" + , "Gibbon.ByteString" + , "Gibbon.Maybe" + ] -processImport :: Config -> IORef ParseState -> [String] -> FilePath -> ImportDecl a -> IO (PassM Prog0) -processImport cfg pstate_ref import_route dir decl@ImportDecl{..} +processImport :: + Config + -> IORef ParseState + -> [String] + -> FilePath + -> ImportDecl a + -> IO (PassM Prog0) +processImport cfg pstate_ref import_route dir decl@ImportDecl {..} -- When compiling with Gibbon, we should *NOT* inline things defined in Gibbon.Prim. - | mod_name == "Gibbon.Prim" = pure (pure (Prog M.empty M.empty Nothing)) - | otherwise = do + | mod_name == "Gibbon.Prim" = pure (pure (Prog M.empty M.empty Nothing)) + | otherwise = do when (mod_name `elem` import_route) $ - error $ "Circular dependency detected. Import path: "++ show (mod_name : import_route) - when (importQualified) $ error $ "Qualified imports not supported yet. Offending import: " ++ prettyPrint decl - when (isJust importAs) $ error $ "Module aliases not supported yet. Offending import: " ++ prettyPrint decl - when (isJust importSpecs) $ error $ "Selective imports not supported yet. Offending import: " ++ prettyPrint decl + error $ + "Circular dependency detected. Import path: " ++ + show (mod_name : import_route) + when (importQualified) $ + error $ + "Qualified imports not supported yet. Offending import: " ++ + prettyPrint decl + when (isJust importAs) $ + error $ + "Module aliases not supported yet. Offending import: " ++ prettyPrint decl + when (isJust importSpecs) $ + error $ + "Selective imports not supported yet. Offending import: " ++ + prettyPrint decl (ParseState imported) <- readIORef pstate_ref - mod_fp <- if mod_name `elem` stdlibModules - then stdlibImportPath mod_name - else modImportPath importModule dir + mod_fp <- + if mod_name `elem` stdlibModules + then stdlibImportPath mod_name + else modImportPath importModule dir dbgTrace 5 ("Looking at " ++ mod_name) (pure ()) dbgTrace 5 ("Previously imported: " ++ show (M.keysSet imported)) (pure ()) - prog <- case M.lookup (mod_name, mod_fp) imported of - Just prog -> do - dbgTrace 5 ("Already imported " ++ mod_name) (pure ()) - pure prog - Nothing -> do - dbgTrace 5 ("Importing " ++ mod_name ++ " from " ++ mod_fp) (pure ()) - prog0 <- parseFile' cfg pstate_ref import_route mod_fp - (ParseState imported') <- readIORef pstate_ref - let (prog0',_) = defaultRunPassM prog0 - let imported'' = M.insert (mod_name, mod_fp) prog0' imported' - let pstate' = ParseState { imported = imported'' } - writeIORef pstate_ref pstate' - pure prog0' - + prog <- + case M.lookup (mod_name, mod_fp) imported of + Just prog -> do + dbgTrace 5 ("Already imported " ++ mod_name) (pure ()) + pure prog + Nothing -> do + dbgTrace 5 ("Importing " ++ mod_name ++ " from " ++ mod_fp) (pure ()) + prog0 <- parseFile' cfg pstate_ref import_route mod_fp + (ParseState imported') <- readIORef pstate_ref + let (prog0', _) = defaultRunPassM prog0 + let imported'' = M.insert (mod_name, mod_fp) prog0' imported' + let pstate' = ParseState {imported = imported''} + writeIORef pstate_ref pstate' + pure prog0' pure (pure prog) where mod_name = mnameToStr importModule stdlibImportPath :: String -> IO FilePath stdlibImportPath mod_name = do - env <- getEnvironment - let stdlibPath = case lookup "GIBBONDIR" env of - Just p -> p "gibbon-stdlib" modNameToFilename mod_name + env <- getEnvironment + let stdlibPath = + case lookup "GIBBONDIR" env of + Just p -> p "gibbon-stdlib" modNameToFilename mod_name -- Assume we're running from the compiler dir! - Nothing -> modNameToFilename mod_name - e <- doesFileExist stdlibPath - unless e $ error$ "stdlib.hs file not found at path: "++stdlibPath - ++"\n Consider setting GIBBONDIR to repo root.\n" - pure stdlibPath + Nothing -> modNameToFilename mod_name + e <- doesFileExist stdlibPath + unless e $ + error $ + "stdlib.hs file not found at path: " ++ + stdlibPath ++ "\n Consider setting GIBBONDIR to repo root.\n" + pure stdlibPath where modNameToFilename :: String -> String modNameToFilename "Gibbon.Prelude" = "Gibbon" "Prelude.hs" modNameToFilename "Gibbon.Vector" = "Gibbon" "Vector.hs" - modNameToFilename "Gibbon.Vector.Parallel" = "Gibbon" "Vector" "Parallel.hs" + modNameToFilename "Gibbon.Vector.Parallel" = + "Gibbon" "Vector" "Parallel.hs" modNameToFilename "Gibbon.List" = "Gibbon" "List.hs" modNameToFilename "Gibbon.PList" = "Gibbon" "PList.hs" modNameToFilename "Gibbon.ByteString" = "Gibbon" "ByteString.hs" @@ -285,125 +478,183 @@ stdlibImportPath mod_name = do modImportPath :: ModuleName a -> String -> IO FilePath modImportPath importModule dir = do - let mod_name = mnameToStr importModule - mb_fp <- findModule dir importModule - case mb_fp of - Nothing -> error $ "Cannot find module: " ++ - show mod_name ++ " in " ++ dir - Just mod_fp -> pure mod_fp + let mod_name = mnameToStr importModule + mb_fp <- findModule dir importModule + case mb_fp of + Nothing -> error $ "Cannot find module: " ++ show mod_name ++ " in " ++ dir + Just mod_fp -> pure mod_fp + -- | Look for a module on the filesystem. findModule :: FilePath -> ModuleName a -> IO (Maybe FilePath) findModule dir m = do - let mod_fp = dir moduleNameToSlashes m <.> "hs" + let mod_fp = dir moduleNameToSlashes m <.> "hs" doesFileExist mod_fp >>= \b -> if b - then pure $ Just mod_fp - else pure Nothing + then pure $ Just mod_fp + else pure Nothing + -- | Returns the string version of the module name, with dots replaced by slashes. -- moduleNameToSlashes :: ModuleName a -> String moduleNameToSlashes (ModuleName _ s) = dots_to_slashes s - where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) - + where + dots_to_slashes = + map + (\c -> + if c == '.' + then pathSeparator + else c) builtinTys :: S.Set Var -builtinTys = S.fromList $ - [ "Int", "Float", "Bool", "Sym", "SymHash", "IntHash", "SymSet", "SymDict", "Arena", "Vector" ] +builtinTys = + S.fromList $ + [ "Int" + , "Float" + , "Bool" + , "Sym" + , "SymHash" + , "IntHash" + , "SymSet" + , "SymDict" + , "Arena" + , "Vector" + ] keywords :: S.Set Var -keywords = S.fromList $ map toVar $ +keywords = + S.fromList $ + map toVar $ -- These cannot be added to primMap because they all require special handling while parsing. -- - [ "quote", "bench", "error", "par", "spawn", "is_big" + [ "quote" + , "bench" + , "error" + , "par" + , "spawn" + , "is_big" -- operations on vectors - , "valloc", "vnth", "vlength", "vslice", "inplacevupdate", - "vsort", "inplacevsort", "vfree", "vfree2" + , "valloc" + , "vnth" + , "vlength" + , "vslice" + , "inplacevupdate" + , "vsort" + , "inplacevsort" + , "vfree" + , "vfree2" -- parallel dictionaries - , "alloc_pdict", "insert_pdict", "lookup_pdict", "member_pdict", "fork_pdict", "join_pdict" + , "alloc_pdict" + , "insert_pdict" + , "lookup_pdict" + , "member_pdict" + , "fork_pdict" + , "join_pdict" -- linked lists - , "alloc_ll", "is_empty_ll", "cons_ll", "head_ll", "tail_ll", "free_ll", "free2_ll", "copy_ll" - ] ++ M.keys primMap - -desugarTopType :: (Show a, Pretty a) => TypeSynEnv -> Type a -> TyScheme + , "alloc_ll" + , "is_empty_ll" + , "cons_ll" + , "head_ll" + , "tail_ll" + , "free_ll" + , "free2_ll" + , "copy_ll" + ] ++ + M.keys primMap + +desugarTopType :: (Show a, Pretty a) => TypeSynEnv -> Type a -> TyScheme desugarTopType type_syns ty = - case ty of + case ty -- forall tvs ty. + of TyForall _ mb_tvbind _ ty1 -> - let tyvars = case mb_tvbind of - Just bnds -> map desugarTyVarBind bnds - Nothing -> [] - in ForAll tyvars (desugarType type_syns ty1) + let tyvars = + case mb_tvbind of + Just bnds -> map desugarTyVarBind bnds + Nothing -> [] + in ForAll tyvars (desugarType type_syns ty1) -- quantify over all tyvars. - _ -> let ty' = desugarType type_syns ty - tyvars = tyVarsInTy ty' - in ForAll tyvars ty' + _ -> + let ty' = desugarType type_syns ty + tyvars = tyVarsInTy ty' + in ForAll tyvars ty' -desugarType :: (Show a, Pretty a) => TypeSynEnv -> Type a -> Ty0 +desugarType :: (Show a, Pretty a) => TypeSynEnv -> Type a -> Ty0 desugarType type_syns ty = case ty of H.TyVar _ (Ident _ t) -> L0.TyVar $ UserTv (toVar t) - TyTuple _ Boxed tys -> ProdTy (map (desugarType type_syns) tys) - TyCon _ (Special _ (UnitCon _)) -> ProdTy [] - TyCon _ (UnQual _ (Ident _ "Int")) -> IntTy + TyTuple _ Boxed tys -> ProdTy (map (desugarType type_syns) tys) + TyCon _ (Special _ (UnitCon _)) -> ProdTy [] + TyCon _ (UnQual _ (Ident _ "Int")) -> IntTy TyCon _ (UnQual _ (Ident _ "Char")) -> CharTy - TyCon _ (UnQual _ (Ident _ "Float"))-> FloatTy + TyCon _ (UnQual _ (Ident _ "Float")) -> FloatTy TyCon _ (UnQual _ (Ident _ "Bool")) -> BoolTy - TyCon _ (UnQual _ (Ident _ "Sym")) -> SymTy0 - TyCon _ (UnQual _ (Ident _ "SymSet")) -> SymSetTy - TyCon _ (UnQual _ (Ident _ "SymHash")) -> SymHashTy - TyCon _ (UnQual _ (Ident _ "IntHash")) -> IntHashTy + TyCon _ (UnQual _ (Ident _ "Sym")) -> SymTy0 + TyCon _ (UnQual _ (Ident _ "SymSet")) -> SymSetTy + TyCon _ (UnQual _ (Ident _ "SymHash")) -> SymHashTy + TyCon _ (UnQual _ (Ident _ "IntHash")) -> IntHashTy TyCon _ (UnQual _ (Ident _ con)) -> case M.lookup con type_syns of - Nothing -> PackedTy con [] + Nothing -> PackedTy con [] Just ty' -> ty' - TyFun _ t1 t2 -> let t1' = desugarType type_syns t1 - t2' = desugarType type_syns t2 - in ArrowTy [t1'] t2' + TyFun _ t1 t2 -> + let t1' = desugarType type_syns t1 + t2' = desugarType type_syns t2 + in ArrowTy [t1'] t2' TyParen _ ty1 -> desugarType type_syns ty1 TyApp _ tycon arg -> - let ty' = desugarType type_syns tycon in - case ty' of - PackedTy con tyargs -> - case (con,tyargs) of - ("Vector",[]) -> VectorTy (desugarType type_syns arg) - ("List",[]) -> ListTy (desugarType type_syns arg) - ("PDict",[]) -> - let arg' = desugarType type_syns arg in - case arg' of - ProdTy [k, v] -> PDictTy k v - _ -> error $ "desugarType: Unexpected PDictTy argument: " ++ show arg' + let ty' = desugarType type_syns tycon + in case ty' of + PackedTy con tyargs -> + case (con, tyargs) of + ("Vector", []) -> VectorTy (desugarType type_syns arg) + ("List", []) -> ListTy (desugarType type_syns arg) + ("PDict", []) -> + let arg' = desugarType type_syns arg + in case arg' of + ProdTy [k, v] -> PDictTy k v + _ -> + error $ + "desugarType: Unexpected PDictTy argument: " ++ + show arg' _ -> case M.lookup con type_syns of - Nothing -> PackedTy con (tyargs ++ [desugarType type_syns arg]) + Nothing -> + PackedTy con (tyargs ++ [desugarType type_syns arg]) Just ty'' -> ty'' - _ -> error $ "desugarType: Unexpected type arguments: " ++ show ty' + _ -> error $ "desugarType: Unexpected type arguments: " ++ show ty' _ -> error $ "desugarType: Unsupported type: " ++ show ty -- Like 'desugarTopType' but understands boxity. -desugarTopType' :: (Show a, Pretty a) => TypeSynEnv -> Type a -> (IsBoxed, TyScheme) +desugarTopType' :: + (Show a, Pretty a) => TypeSynEnv -> Type a -> (IsBoxed, TyScheme) desugarTopType' type_syns ty = - case ty of + case ty -- forall tvs ty. + of TyForall _ mb_tvbind _ ty1 -> - let tyvars = case mb_tvbind of - Just bnds -> map desugarTyVarBind bnds - Nothing -> [] + let tyvars = + case mb_tvbind of + Just bnds -> map desugarTyVarBind bnds + Nothing -> [] (boxity, ty') = desugarType' type_syns ty1 - in (boxity, ForAll tyvars ty') + in (boxity, ForAll tyvars ty') -- quantify over all tyvars. - _ -> let (boxity, ty') = desugarType' type_syns ty - tyvars = tyVarsInTy ty' - in (boxity, ForAll tyvars ty') + _ -> + let (boxity, ty') = desugarType' type_syns ty + tyvars = tyVarsInTy ty' + in (boxity, ForAll tyvars ty') + -- Like 'desugarType' but understands boxity. -desugarType' :: (Show a, Pretty a) => TypeSynEnv -> Type a -> (IsBoxed, Ty0) +desugarType' :: (Show a, Pretty a) => TypeSynEnv -> Type a -> (IsBoxed, Ty0) desugarType' type_syns ty = case ty of TyBang _ _ (NoUnpack _) ty1 -> (True, desugarType type_syns ty1) - _ -> (False, desugarType type_syns ty) + _ -> (False, desugarType type_syns ty) + -- | Transform a multi-argument function type to one where all inputs are a -- single tuple argument. E.g. (a -> b -> c -> d) => ((a,b,c) -> d). @@ -413,82 +664,87 @@ unCurryTopTy (ForAll tyvars ty) = ForAll tyvars (unCurryTy ty) unCurryTy :: Ty0 -> Ty0 unCurryTy ty1 = case ty1 of - ArrowTy _ ArrowTy{} -> - let (a,b) = go [] ty1 + ArrowTy _ ArrowTy {} -> + let (a, b) = go [] ty1 a' = map unCurryTy a - in ArrowTy a' b + in ArrowTy a' b _ -> ty1 where go :: [Ty0] -> Ty0 -> ([Ty0], Ty0) go acc ty = case ty of - ArrowTy as b -> (go (acc++as) b) - _ -> (acc,ty) + ArrowTy as b -> (go (acc ++ as) b) + _ -> (acc, ty) + -- ^ A map between SExp-frontend prefix function names, and Gibbon -- abstract Primops. primMap :: M.Map String (Prim a) -primMap = M.fromList - [ ("+", AddP) - , ("-", SubP) - , ("*", MulP) - , ("/", DivP) - , ("div", DivP) - , ("^", ExpP) - , (".+.", FAddP) - , (".-.", FSubP) - , (".*.", FMulP) - , ("./.", FDivP) - , ("sqrt", FSqrtP) - , ("==", EqIntP) - , (".==.", EqFloatP) - , ("*==*", EqCharP) - , ("<", LtP) - , (">", GtP) - , ("<=", LtEqP) - , (">=", GtEqP) - , (".<.", FLtP) - , (".>.", FGtP) - , (".<=.", FLtEqP) - , (".>=.", FGtEqP) - , ("tan", FTanP) - , ("mod", ModP) - , ("||" , OrP) - , ("&&", AndP) - , ("eqsym", EqSymP) - , ("rand", RandP) - , ("frand", FRandP) - , ("intToFloat", IntToFloatP) - , ("floatToInt", FloatToIntP) - , ("sizeParam", SizeParam) - , ("getNumProcessors", GetNumProcessors) - , ("True", MkTrue) - , ("False", MkFalse) - , ("gensym", Gensym) - , ("printint", PrintInt) - , ("printchar", PrintChar) - , ("printfloat", PrintFloat) - , ("printbool", PrintBool) - , ("printsym", PrintSym) - , ("readint", ReadInt) - , ("is_big", IsBig) - , ("empty_set", SymSetEmpty) - , ("insert_set", SymSetInsert) - , ("contains_set", SymSetContains) - , ("empty_hash", SymHashEmpty) - , ("insert_hash", SymHashInsert) - , ("lookup_hash", SymHashLookup) - , ("contains_hash", SymHashContains) - , ("empty_int_hash", IntHashEmpty) - , ("insert_int_hash", IntHashInsert) - , ("lookup_int_hash", IntHashLookup) - ] - -desugarExp :: (Show a, Pretty a) => TypeSynEnv -> TopTyEnv -> Exp a -> PassM Exp0 +primMap = + M.fromList + [ ("+", AddP) + , ("-", SubP) + , ("*", MulP) + , ("/", DivP) + , ("div", DivP) + , ("^", ExpP) + , (".+.", FAddP) + , (".-.", FSubP) + , (".*.", FMulP) + , ("./.", FDivP) + , ("sqrt", FSqrtP) + , ("==", EqIntP) + , (".==.", EqFloatP) + , ("*==*", EqCharP) + , ("<", LtP) + , (">", GtP) + , ("<=", LtEqP) + , (">=", GtEqP) + , (".<.", FLtP) + , (".>.", FGtP) + , (".<=.", FLtEqP) + , (".>=.", FGtEqP) + , ("tan", FTanP) + , ("mod", ModP) + , ("||", OrP) + , ("&&", AndP) + , ("eqsym", EqSymP) + , ("rand", RandP) + , ("frand", FRandP) + , ("intToFloat", IntToFloatP) + , ("floatToInt", FloatToIntP) + , ("sizeParam", SizeParam) + , ("getNumProcessors", GetNumProcessors) + , ("True", MkTrue) + , ("False", MkFalse) + , ("gensym", Gensym) + , ("printint", PrintInt) + , ("printchar", PrintChar) + , ("printfloat", PrintFloat) + , ("printbool", PrintBool) + , ("printsym", PrintSym) + , ("readint", ReadInt) + , ("is_big", IsBig) + , ("empty_set", SymSetEmpty) + , ("insert_set", SymSetInsert) + , ("contains_set", SymSetContains) + , ("empty_hash", SymHashEmpty) + , ("insert_hash", SymHashInsert) + , ("lookup_hash", SymHashLookup) + , ("contains_hash", SymHashContains) + , ("empty_int_hash", IntHashEmpty) + , ("insert_int_hash", IntHashInsert) + , ("lookup_int_hash", IntHashLookup) + ] + +desugarExp :: + (Show a, Pretty a) => TypeSynEnv -> TopTyEnv -> Exp a -> PassM Exp0 desugarExp type_syns toplevel e = case e of Paren _ (ExpTypeSig _ (App _ (H.Var _ f) (Lit _ lit)) tyc) - | (qnameToStr f) == "error" -> pure $ PrimAppE (ErrorP (litToString lit) (desugarType type_syns tyc)) [] + | (qnameToStr f) == "error" -> + pure $ + PrimAppE (ErrorP (litToString lit) (desugarType type_syns tyc)) [] -- Paren _ (App _ (H.Var _ f) (Lit _ lit)) -- | (qnameToStr f) == "error" -> pure $ PrimAppE (ErrorP (litToString lit Paren _ e2 -> desugarExp type_syns toplevel e2 @@ -496,366 +752,807 @@ desugarExp type_syns toplevel e = let str = qnameToStr qv v = (toVar str) if str == "alloc_pdict" - then do - kty <- newMetaTy - vty <- newMetaTy - pure $ PrimAppE (PDictAllocP kty vty) [] - else if str == "alloc_ll" - then do - ty <- newMetaTy - pure $ PrimAppE (LLAllocP ty) [] - else if v == "sync" - then pure SyncE - else if v == "lsync" - then pure SyncE - else if M.member str primMap - then pure $ PrimAppE (primMap M.! str) [] - else case M.lookup v toplevel of - Just sigma -> - case tyFromScheme sigma of - ArrowTy{} -> + then do + kty <- newMetaTy + vty <- newMetaTy + pure $ PrimAppE (PDictAllocP kty vty) [] + else if str == "alloc_ll" + then do + ty <- newMetaTy + pure $ PrimAppE (LLAllocP ty) [] + else if v == "sync" + then pure SyncE + else if v == "lsync" + then pure SyncE + else if M.member str primMap + then pure $ PrimAppE (primMap M.! str) [] + else case M.lookup v toplevel of + Just sigma -> + case tyFromScheme sigma of + ArrowTy {} -- Functions with >0 args must be VarE's here -- the 'App _ e1 e2' -- case below depends on it. - pure $ VarE v + -> pure $ VarE v -- Otherwise, 'v' is a top-level value binding, which we -- encode as a function which takes no arguments. - _ -> pure $ AppE v [] [] - Nothing -> pure $ VarE v - Lit _ lit -> desugarLiteral lit - + _ -> pure $ AppE v [] [] + Nothing -> pure $ VarE v + Lit _ lit -> desugarLiteral lit Lambda _ pats bod -> do bod' <- desugarExp type_syns toplevel bod - (vars,tys,bindss) <- unzip3 <$> mapM (desugarPatWithTy type_syns) pats + (vars, tys, bindss) <- unzip3 <$> mapM (desugarPatWithTy type_syns) pats let binds = concat bindss args = zip vars tys pure $ Ext $ LambdaE args (mkLets binds bod') - App _ e1 e2 -> do - desugarExp type_syns toplevel e1 >>= \case - (VarE f) -> - case M.lookup (fromVar f) primMap of - Just p -> (\e2' -> PrimAppE p [e2']) <$> desugarExp type_syns toplevel e2 - Nothing -> - if f == "quote" - then case e2 of - Lit _ lit -> pure $ LitSymE (toVar $ litToString lit) - _ -> error "desugarExp: quote only accepts string literals. E.g quote \"hello\"" - else if f == "eqBenchProg" - then case e2 of - Lit _ lit -> pure $ (PrimAppE (EqBenchProgP (litToString lit)) []) - _ -> error "desugarExp: eqBenchProg only accepts string literals." - else if f == "readArrayFile" - then let go e0 = case e0 of - Con _ (UnQual _ (Ident _ "Nothing")) -> do - t <- newMetaTy - pure $ PrimAppE (ReadArrayFile Nothing t) [] - App _ (Con _ (UnQual _ (Ident _ "Just"))) (Tuple _ Boxed [Lit _ name, Lit _ len]) -> do - t <- newMetaTy - pure $ PrimAppE (ReadArrayFile (Just (litToString name, litToInt len)) t) [] - Paren _ e3 -> go e3 - _ -> error $ "desugarExp: couldn't parse readArrayFile; " ++ show e0 - in go e2 - else if f == "readPackedFile" - then let go e0 = case e0 of - TypeApp _ (TyCon _ (UnQual _ (Ident _ con))) -> do - let ty = PackedTy con [] - pure $ PrimAppE (ReadPackedFile Nothing con Nothing ty) [] - _ -> error $ "desugarExp: couldn't parse readPackedFile; " ++ show e0 - in go e2 - else if f == "writePackedFile" - then - case e2 of - Lit _ fp -> do - ty <- newMetaTy - pure $ PrimAppE (WritePackedFile (litToString fp) ty) [] - _ -> error $ "desugarExp: couldn't parse writePackedFile; " ++ show e2 - else if f == "bench" - then do - e2' <- desugarExp type_syns toplevel e2 - pure $ Ext $ BenchE "HOLE" [] [e2'] False - else if f == "timeit" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ TimeIt e2' ty False - else if f == "iterate" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ TimeIt e2' ty True - else if f == "error" - then case e2 of - Lit _ lit -> pure $ PrimAppE (ErrorP (litToString lit) IntTy) [] -- assume int (!) - _ -> error "desugarExp: error expects String literal." - else if f == "par" - then do - e2' <- desugarExp type_syns toplevel e2 - pure $ Ext $ ParE0 [e2'] - else if f == "spawn" - then do - e2' <- desugarExp type_syns toplevel e2 - pure $ SpawnE "HOLE" [] [e2'] - else if f == "valloc" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (VAllocP ty) [e2'] - else if f == "vfree" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (VFreeP ty) [e2'] - else if f == "vfree2" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (VFree2P ty) [e2'] - else if f == "vnth" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (VNthP ty) [e2'] - else if f == "vlength" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (VLengthP ty) [e2'] - else if f == "inplacevupdate" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (InplaceVUpdateP ty) [e2'] - else if f == "vconcat" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (VConcatP ty) [e2'] - else if f == "vsort" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (VSortP ty) [e2'] - else if f == "inplacevsort" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (InplaceVSortP ty) [e2'] - else if f == "vslice" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (VSliceP ty) [e2'] - - else if f == "vmerge" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (VMergeP ty) [e2'] - else if f == "insert_pdict" - then do - e2' <- desugarExp type_syns toplevel e2 - kty <- newMetaTy - vty <- newMetaTy - pure $ PrimAppE (PDictInsertP kty vty) [e2'] - - else if f == "lookup_pdict" - then do - e2' <- desugarExp type_syns toplevel e2 - kty <- newMetaTy - vty <- newMetaTy - pure $ PrimAppE (PDictLookupP kty vty) [e2'] - else if f == "member_pdict" - then do - e2' <- desugarExp type_syns toplevel e2 - kty <- newMetaTy - vty <- newMetaTy - pure $ PrimAppE (PDictHasKeyP kty vty) [e2'] - else if f == "fork_pdict" - then do - e2' <- desugarExp type_syns toplevel e2 - kty <- newMetaTy - vty <- newMetaTy - pure $ PrimAppE (PDictForkP kty vty) [e2'] - else if f == "join_pdict" - then do - e2' <- desugarExp type_syns toplevel e2 - kty <- newMetaTy - vty <- newMetaTy - pure $ PrimAppE (PDictJoinP kty vty) [e2'] - else if f == "is_empty_ll" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (LLIsEmptyP ty) [e2'] - else if f == "cons_ll" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (LLConsP ty) [e2'] - else if f == "head_ll" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (LLHeadP ty) [e2'] - else if f == "tail_ll" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (LLTailP ty) [e2'] - else if f == "free_ll" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (LLFreeP ty) [e2'] - else if f == "free2_ll" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (LLFree2P ty) [e2'] - else if f == "copy_ll" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ PrimAppE (LLCopyP ty) [e2'] - else if f == "fst" - then do - e2' <- desugarExp type_syns toplevel e2 - pure $ ProjE 0 e2' - else if f == "snd" - then do - e2' <- desugarExp type_syns toplevel e2 - pure $ ProjE 1 e2' - else if f == "printPacked" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ Ext (PrintPacked ty e2') - else if f == "copyPacked" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ Ext (CopyPacked ty e2') - else if f == "travPacked" - then do - e2' <- desugarExp type_syns toplevel e2 - ty <- newMetaTy - pure $ Ext (TravPacked ty e2') - else if f == "unsafeAlias" - then do - e2' <- desugarExp type_syns toplevel e2 - pure $ Ext (LinearExt (AliasE e2')) - else if f == "unsafeToLinear" - then do - e2' <- desugarExp type_syns toplevel e2 - pure $ Ext (LinearExt (ToLinearE e2')) - else if f == "lseq" - then do - e2' <- desugarExp type_syns toplevel e2 - pure $ Ext (LinearExt (LseqE e2' undefined)) - else if S.member f keywords - then error $ "desugarExp: Keyword not handled: " ++ sdoc f - else AppE f [] <$> (: []) <$> desugarExp type_syns toplevel e2 - (DataConE tyapp c as) -> (\e2' -> DataConE tyapp c (as ++ [e2'])) <$> desugarExp type_syns toplevel e2 - (Ext (ParE0 ls)) -> do - e2' <- desugarExp type_syns toplevel e2 - pure $ Ext $ ParE0 (ls ++ [e2']) - (AppE f [] ls) -> do - e2' <- desugarExp type_syns toplevel e2 - pure $ AppE f [] (ls ++ [e2']) - - (Ext (BenchE fn [] ls b)) -> do - e2' <- desugarExp type_syns toplevel e2 - pure $ Ext $ BenchE fn [] (ls ++ [e2']) b - - (SpawnE fn [] ls) -> do - e2' <- desugarExp type_syns toplevel e2 - pure $ SpawnE fn [] (ls ++ [e2']) - - (PrimAppE (WritePackedFile fp ty) ls) -> do - e2' <- desugarExp type_syns toplevel e2 - pure $ PrimAppE (WritePackedFile fp ty) (ls ++ [e2']) - - (PrimAppE (ReadPackedFile _mb_fp tycon mb_var ty) []) -> - let go e0 = case e0 of - Con _ (UnQual _ (Ident _ "Nothing")) -> do - pure (PrimAppE (ReadPackedFile Nothing tycon mb_var ty) []) - App _ (Con _ (UnQual _ (Ident _ "Just"))) (Lit _ name) -> do - pure (PrimAppE (ReadPackedFile (Just (litToString name)) tycon mb_var ty) []) - Paren _ e3 -> go e3 - _ -> error $ "desugarExp: couldn't parse readPackedFile; " ++ show e0 - in go e2 - - (PrimAppE (VMergeP elty) ls) -> do - e2' <- desugarExp type_syns toplevel e2 - pure $ PrimAppE (VMergeP elty) (ls ++ [e2']) - (PrimAppE p ls) -> do - e2' <- desugarExp type_syns toplevel e2 - pure $ PrimAppE p (ls ++ [e2']) - - TimeIt{} -> - error "desugarExp: TimeIt can only accept 1 expression." - - (Ext (LinearExt (LseqE a _))) -> do - e2' <- desugarExp type_syns toplevel e2 - pure (Ext (LinearExt (LseqE a e2'))) - - (Ext (LinearExt (ToLinearE (AppE f [] ls)))) -> do - e2' <- desugarExp type_syns toplevel e2 - pure (Ext (LinearExt (ToLinearE (AppE f [] (ls ++ [e2']))))) - - (Ext (LinearExt (ToLinearE (DataConE tyapp dcon ls)))) -> do - e2' <- desugarExp type_syns toplevel e2 - pure (Ext (LinearExt (ToLinearE (DataConE tyapp dcon (ls ++ [e2']))))) - - (Ext (LinearExt (ToLinearE (Ext (LambdaE [(v,ty)] bod))))) -> do - e2' <- desugarExp type_syns toplevel e2 - pure (Ext (LinearExt (ToLinearE (LetE (v,[],ty,e2') bod)))) - - (Ext (LinearExt (ToLinearE (VarE fn)))) -> do - e2' <- desugarExp type_syns toplevel e2 - pure (Ext (LinearExt (ToLinearE (AppE fn [] [e2'])))) - - f -> error ("desugarExp: Couldn't parse function application: (" ++ show f ++ ")") - + desugarExp type_syns toplevel e1 >>= \case + (VarE f) -> + case M.lookup (fromVar f) primMap of + Just p -> + (\e2' -> PrimAppE p [e2']) <$> desugarExp type_syns toplevel e2 + Nothing -> + if f == "quote" + then case e2 of + Lit _ lit -> pure $ LitSymE (toVar $ litToString lit) + _ -> + error + "desugarExp: quote only accepts string literals. E.g quote \"hello\"" + else if f == "eqBenchProg" + then case e2 of + Lit _ lit -> + pure $ + (PrimAppE (EqBenchProgP (litToString lit)) []) + _ -> + error + "desugarExp: eqBenchProg only accepts string literals." + else if f == "readArrayFile" + then let go e0 = + case e0 of + Con _ (UnQual _ (Ident _ "Nothing")) -> do + t <- newMetaTy + pure $ + PrimAppE + (ReadArrayFile Nothing t) + [] + App _ (Con _ (UnQual _ (Ident _ "Just"))) (Tuple _ Boxed [Lit _ name, Lit _ len]) -> do + t <- newMetaTy + pure $ + PrimAppE + (ReadArrayFile + (Just + ( litToString name + , litToInt len)) + t) + [] + Paren _ e3 -> go e3 + _ -> + error $ + "desugarExp: couldn't parse readArrayFile; " ++ + show e0 + in go e2 + else if f == "readPackedFile" + then let go e0 = + case e0 of + TypeApp _ (TyCon _ (UnQual _ (Ident _ con))) -> do + let ty = PackedTy con [] + pure $ + PrimAppE + (ReadPackedFile + Nothing + con + Nothing + ty) + [] + _ -> + error $ + "desugarExp: couldn't parse readPackedFile; " ++ + show e0 + in go e2 + else if f == "writePackedFile" + then case e2 of + Lit _ fp -> do + ty <- newMetaTy + pure $ + PrimAppE + (WritePackedFile + (litToString fp) + ty) + [] + _ -> + error $ + "desugarExp: couldn't parse writePackedFile; " ++ + show e2 + else if f == "bench" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + pure $ + Ext $ + BenchE + "HOLE" + [] + [e2'] + False + else if f == "timeit" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- newMetaTy + pure $ + TimeIt + e2' + ty + False + else if f == "iterate" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + TimeIt + e2' + ty + True + else if f == + "error" + then case e2 of + Lit _ lit -> + pure $ + PrimAppE + (ErrorP + (litToString + lit) + IntTy) + [ + ] -- assume int (!) + _ -> + error + "desugarExp: error expects String literal." + else if f == + "par" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + pure $ + Ext $ + ParE0 + [ e2' + ] + else if f == + "spawn" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + pure $ + SpawnE + "HOLE" + [ + ] + [ e2' + ] + else if f == + "valloc" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (VAllocP + ty) + [ e2' + ] + else if f == + "vfree" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (VFreeP + ty) + [ e2' + ] + else if f == + "vfree2" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (VFree2P + ty) + [ e2' + ] + else if f == + "vnth" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (VNthP + ty) + [ e2' + ] + else if f == + "vlength" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (VLengthP + ty) + [ e2' + ] + else if f == + "inplacevupdate" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (InplaceVUpdateP + ty) + [ e2' + ] + else if f == + "vconcat" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (VConcatP + ty) + [ e2' + ] + else if f == + "vsort" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (VSortP + ty) + [ e2' + ] + else if f == + "inplacevsort" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (InplaceVSortP + ty) + [ e2' + ] + else if f == + "vslice" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (VSliceP + ty) + [ e2' + ] + else if f == + "vmerge" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (VMergeP + ty) + [ e2' + ] + else if f == + "insert_pdict" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + kty <- + newMetaTy + vty <- + newMetaTy + pure $ + PrimAppE + (PDictInsertP + kty + vty) + [ e2' + ] + else if f == + "lookup_pdict" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + kty <- + newMetaTy + vty <- + newMetaTy + pure $ + PrimAppE + (PDictLookupP + kty + vty) + [ e2' + ] + else if f == + "member_pdict" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + kty <- + newMetaTy + vty <- + newMetaTy + pure $ + PrimAppE + (PDictHasKeyP + kty + vty) + [ e2' + ] + else if f == + "fork_pdict" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + kty <- + newMetaTy + vty <- + newMetaTy + pure $ + PrimAppE + (PDictForkP + kty + vty) + [ e2' + ] + else if f == + "join_pdict" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + kty <- + newMetaTy + vty <- + newMetaTy + pure $ + PrimAppE + (PDictJoinP + kty + vty) + [ e2' + ] + else if f == + "is_empty_ll" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (LLIsEmptyP + ty) + [ e2' + ] + else if f == + "cons_ll" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (LLConsP + ty) + [ e2' + ] + else if f == + "head_ll" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (LLHeadP + ty) + [ e2' + ] + else if f == + "tail_ll" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (LLTailP + ty) + [ e2' + ] + else if f == + "free_ll" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (LLFreeP + ty) + [ e2' + ] + else if f == + "free2_ll" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (LLFree2P + ty) + [ e2' + ] + else if f == + "copy_ll" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + PrimAppE + (LLCopyP + ty) + [ e2' + ] + else if f == + "fst" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + pure $ + ProjE + 0 + e2' + else if f == + "snd" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + pure $ + ProjE + 1 + e2' + else if f == + "printPacked" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + Ext + (PrintPacked + ty + e2') + else if f == + "copyPacked" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + Ext + (CopyPacked + ty + e2') + else if f == + "travPacked" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + ty <- + newMetaTy + pure $ + Ext + (TravPacked + ty + e2') + else if f == + "unsafeAlias" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + pure $ + Ext + (LinearExt + (AliasE + e2')) + else if f == + "unsafeToLinear" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + pure $ + Ext + (LinearExt + (ToLinearE + e2')) + else if f == + "lseq" + then do + e2' <- + desugarExp + type_syns + toplevel + e2 + pure $ + Ext + (LinearExt + (LseqE + e2' + undefined)) + else if S.member + f + keywords + then error $ + "desugarExp: Keyword not handled: " ++ + sdoc + f + else AppE + f + [ + ] <$> + (: [ + ]) <$> + desugarExp + type_syns + toplevel + e2 + (DataConE tyapp c as) -> + (\e2' -> DataConE tyapp c (as ++ [e2'])) <$> + desugarExp type_syns toplevel e2 + (Ext (ParE0 ls)) -> do + e2' <- desugarExp type_syns toplevel e2 + pure $ Ext $ ParE0 (ls ++ [e2']) + (AppE f [] ls) -> do + e2' <- desugarExp type_syns toplevel e2 + pure $ AppE f [] (ls ++ [e2']) + (Ext (BenchE fn [] ls b)) -> do + e2' <- desugarExp type_syns toplevel e2 + pure $ Ext $ BenchE fn [] (ls ++ [e2']) b + (SpawnE fn [] ls) -> do + e2' <- desugarExp type_syns toplevel e2 + pure $ SpawnE fn [] (ls ++ [e2']) + (PrimAppE (WritePackedFile fp ty) ls) -> do + e2' <- desugarExp type_syns toplevel e2 + pure $ PrimAppE (WritePackedFile fp ty) (ls ++ [e2']) + (PrimAppE (ReadPackedFile _mb_fp tycon mb_var ty) []) -> + let go e0 = + case e0 of + Con _ (UnQual _ (Ident _ "Nothing")) -> do + pure (PrimAppE (ReadPackedFile Nothing tycon mb_var ty) []) + App _ (Con _ (UnQual _ (Ident _ "Just"))) (Lit _ name) -> do + pure + (PrimAppE + (ReadPackedFile + (Just (litToString name)) + tycon + mb_var + ty) + []) + Paren _ e3 -> go e3 + _ -> + error $ + "desugarExp: couldn't parse readPackedFile; " ++ show e0 + in go e2 + (PrimAppE (VMergeP elty) ls) -> do + e2' <- desugarExp type_syns toplevel e2 + pure $ PrimAppE (VMergeP elty) (ls ++ [e2']) + (PrimAppE p ls) -> do + e2' <- desugarExp type_syns toplevel e2 + pure $ PrimAppE p (ls ++ [e2']) + TimeIt {} -> error "desugarExp: TimeIt can only accept 1 expression." + (Ext (LinearExt (LseqE a _))) -> do + e2' <- desugarExp type_syns toplevel e2 + pure (Ext (LinearExt (LseqE a e2'))) + (Ext (LinearExt (ToLinearE (AppE f [] ls)))) -> do + e2' <- desugarExp type_syns toplevel e2 + pure (Ext (LinearExt (ToLinearE (AppE f [] (ls ++ [e2']))))) + (Ext (LinearExt (ToLinearE (DataConE tyapp dcon ls)))) -> do + e2' <- desugarExp type_syns toplevel e2 + pure (Ext (LinearExt (ToLinearE (DataConE tyapp dcon (ls ++ [e2']))))) + (Ext (LinearExt (ToLinearE (Ext (LambdaE [(v, ty)] bod))))) -> do + e2' <- desugarExp type_syns toplevel e2 + pure (Ext (LinearExt (ToLinearE (LetE (v, [], ty, e2') bod)))) + (Ext (LinearExt (ToLinearE (VarE fn)))) -> do + e2' <- desugarExp type_syns toplevel e2 + pure (Ext (LinearExt (ToLinearE (AppE fn [] [e2'])))) + f -> + error + ("desugarExp: Couldn't parse function application: (" ++ + show f ++ ")") Let _ (BDecls _ decls) rhs -> do rhs' <- desugarExp type_syns toplevel rhs let funtys = foldr (collectTopTy type_syns) M.empty decls foldrM (generateBind type_syns toplevel funtys) rhs' decls - If _ a b c -> do a' <- desugarExp type_syns toplevel a b' <- desugarExp type_syns toplevel b c' <- desugarExp type_syns toplevel c pure $ IfE a' b' c' - - Tuple _ Unboxed _ -> error $ "desugarExp: Only boxed tuples are allowed: " ++ prettyPrint e - Tuple _ Boxed es -> MkProdE <$> mapM (desugarExp type_syns toplevel) es - + Tuple _ Unboxed _ -> + error $ "desugarExp: Only boxed tuples are allowed: " ++ prettyPrint e + Tuple _ Boxed es -> MkProdE <$> mapM (desugarExp type_syns toplevel) es Case _ scrt alts -> do scrt' <- desugarExp type_syns toplevel scrt CaseE scrt' <$> mapM (desugarAlt type_syns toplevel) alts - Con _ (Special _ (UnitCon _)) -> pure $ MkProdE [] - Con _ qname -> do let dcon = qnameToStr qname case M.lookup dcon primMap of - Just p -> pure $ PrimAppE p [] - Nothing -> do + Just p -> pure $ PrimAppE p [] + Nothing -- Just a placeholder for now, the typechecker will fill this hole. + -> do ty <- newMetaTy pure $ DataConE ty dcon [] - - -- TODO: timeit: parsing it's type isn't straightforward. - + +-- TODO: timeit: parsing it's type isn't straightforward. InfixApp _ e1 (QVarOp _ (UnQual _ (Symbol _ "!!!"))) e2 -> do e1' <- desugarExp type_syns toplevel e1 case e2 of Lit _ lit -> do let i = litToInt lit pure $ ProjE i e1' - _ -> error $ "desugarExp: !!! expects a integer. Got: " ++ prettyPrint e2 - + _ -> + error $ "desugarExp: !!! expects a integer. Got: " ++ prettyPrint e2 InfixApp _ e1 op e2 -> do e1' <- desugarExp type_syns toplevel e1 e2' <- desugarExp type_syns toplevel e2 @@ -865,164 +1562,328 @@ desugarExp type_syns toplevel e = _ -> do let op' = desugarOp op pure $ PrimAppE op' [e1', e2'] - NegApp _ e1 -> do e1' <- desugarExp type_syns toplevel e1 pure $ PrimAppE SubP [LitE 0, e1'] - _ -> error ("desugarExp: Unsupported expression: " ++ prettyPrint e) -desugarFun :: (Show a, Pretty a) => TypeSynEnv -> TopTyEnv -> TopTyEnv -> Decl a -> PassM (Var, [Var], TyScheme, Exp0) +desugarFun :: + (Show a, Pretty a) + => TypeSynEnv + -> TopTyEnv + -> TopTyEnv + -> Decl a + -> PassM (Var, [Var], TyScheme, Exp0) desugarFun type_syns toplevel env decl = case decl of FunBind _ [Match _ fname pats (UnGuardedRhs _ bod) _where] -> do let fname_str = nameToStr fname fname_var = toVar (fname_str) - (vars, arg_tys,bindss) <- unzip3 <$> mapM (desugarPatWithTy type_syns) pats + (vars, arg_tys, bindss) <- + unzip3 <$> mapM (desugarPatWithTy type_syns) pats let binds = concat bindss args = vars - fun_ty <- case M.lookup fname_var env of - Nothing -> do - ret_ty <- newMetaTy - let funty = ArrowTy arg_tys ret_ty - pure $ (ForAll [] funty) - Just ty -> pure ty + fun_ty <- + case M.lookup fname_var env of + Nothing -> do + ret_ty <- newMetaTy + let funty = ArrowTy arg_tys ret_ty + pure $ (ForAll [] funty) + Just ty -> pure ty bod' <- desugarExp type_syns toplevel bod pure $ (fname_var, args, unCurryTopTy fun_ty, (mkLets binds bod')) - _ -> error $ "desugarFun: Found a function with multiple RHS, " ++ prettyPrint decl + _ -> + error $ + "desugarFun: Found a function with multiple RHS, " ++ prettyPrint decl multiArgsToOne :: [Var] -> [Ty0] -> Exp0 -> (Var, Exp0) multiArgsToOne args tys ex = let new_arg = toVar "multi_arg" - in (new_arg, tuplizeRefs new_arg args tys ex) + in (new_arg, tuplizeRefs new_arg args tys ex) -collectTopTy :: (Show a, Pretty a) => TypeSynEnv -> Decl a -> TopTyEnv -> TopTyEnv +collectTopTy :: + (Show a, Pretty a) => TypeSynEnv -> Decl a -> TopTyEnv -> TopTyEnv collectTopTy type_syns d env = case d of TypeSig _ names ty -> let ty' = desugarTopType type_syns ty - in foldr (\name acc -> - let tycon_var = toVar (nameToStr name) in - case M.lookup tycon_var acc of - Nothing -> M.insert tycon_var ty' acc - Just{} -> error $ "collectTopTy: Multiple type signatures for: " ++ show tycon_var) - env names + in foldr + (\name acc -> + let tycon_var = toVar (nameToStr name) + in case M.lookup tycon_var acc of + Nothing -> M.insert tycon_var ty' acc + Just {} -> + error $ + "collectTopTy: Multiple type signatures for: " ++ + show tycon_var) + env + names _ -> env -collectTypeSynonyms :: (Show a, Pretty a) => TypeSynEnv -> Decl a -> TypeSynEnv +collectTypeSynonyms :: (Show a, Pretty a) => TypeSynEnv -> Decl a -> TypeSynEnv collectTypeSynonyms env d = case d of TypeDecl _ (DHead _ name) ty -> let ty' = desugarType env ty tycon = nameToStr name - in case M.lookup tycon env of - Nothing -> M.insert tycon ty' env - Just{} -> error $ "collectTypeSynonyms: Multiple type synonym declarations: " ++ show tycon + in case M.lookup tycon env of + Nothing -> M.insert tycon ty' env + Just {} -> + error $ + "collectTypeSynonyms: Multiple type synonym declarations: " ++ + show tycon _ -> env -collectTopLevel :: (Show a, Pretty a) => TypeSynEnv -> TopTyEnv -> Decl a -> PassM (Maybe TopLevel) +collectTopLevel :: + (Show a, Pretty a) + => TypeSynEnv + -> TopTyEnv + -> Decl a + -> PassM (Maybe TopLevel) collectTopLevel type_syns env decl = - let toplevel = env in - case decl of + let toplevel = env + in case decl -- 'collectTopTy' takes care of this. - TypeSig{} -> pure Nothing - - -- 'collectTypeSynonyms'. - TypeDecl{} -> pure Nothing + of + TypeSig {} -> pure Nothing + +-- 'collectTypeSynonyms'. + TypeDecl {} -> pure Nothing + DataDecl _ (DataType _) _ctx decl_head cons _deriving_binds -> do + let (ty_name, ty_args) = desugarDeclHead decl_head + cons' = map (desugarConstr type_syns) cons + if ty_name `S.member` builtinTys + then error $ sdoc ty_name ++ " is a built-in type." + else pure $ Just $ HDDef (DDef ty_name ty_args cons') + +-- Reserved for HS. + PatBind _ (PVar _ (Ident _ "main")) (UnGuardedRhs _ _) _binds -> + pure Nothing + PatBind _ (PVar _ (Ident _ "gibbon_main")) (UnGuardedRhs _ rhs) _binds -> do + rhs' <- + fixupSpawn <$> verifyBenchEAssumptions True <$> + desugarExp type_syns toplevel rhs + ty <- newMetaTy + pure $ Just $ HMain $ Just (rhs', ty) + PatBind _ (PVar _ (Ident _ fn)) (UnGuardedRhs _ rhs) _binds -> + case M.lookup (toVar fn) env of + Nothing -> + error $ + "collectTopLevel: Top-level binding with no type signature: " ++ + fn + Just fun_ty + -- This is a top-level function binding of the form: + -- f = \x -> ... + -> + case rhs of + Lambda _ pats bod -> do + bod' <- desugarExp type_syns toplevel bod + case pats of + [] -> error "Impossible" + _ -> do + (vars, _tys, bindss) <- + unzip3 <$> mapM (desugarPatWithTy type_syns) pats + let binds = concat bindss + args = vars + pure $ + Just $ + HFunDef + (FunDef + { funName = toVar fn + , funArgs = args + , funTy = fun_ty + , funBody = fixupSpawn (mkLets binds bod') + , funMeta = + FunMeta + { funRec = NotRec + , funInline = NoInline + , funCanTriggerGC = False + , funOptLayout = NoLayoutOpt + , userConstraintsDataCon = Nothing + } + }) + +-- This is a top-level function that doesn't take any arguments. + _ -> do + rhs' <- desugarExp type_syns toplevel rhs + let fun_ty' = ArrowTy [] (tyFromScheme fun_ty) + fun_ty'' = ForAll (tyVarsInTy fun_ty') fun_ty' + pure $ + Just $ + HFunDef + (FunDef + { funName = toVar fn + , funArgs = [] + , funTy = fun_ty'' + , funBody = fixupSpawn rhs' + , funMeta = + FunMeta + { funRec = NotRec + , funInline = NoInline + , funCanTriggerGC = False + , funOptLayout = NoLayoutOpt + , userConstraintsDataCon = Nothing + } + }) + FunBind {} -> do + (name, args, ty, bod) <- desugarFun type_syns toplevel env decl + pure $ + Just $ + HFunDef + (FunDef + { funName = name + , funArgs = args + , funTy = ty + , funBody = fixupSpawn bod + , funMeta = + FunMeta + { funRec = NotRec + , funInline = NoInline + , funCanTriggerGC = False + , funOptLayout = NoLayoutOpt + , userConstraintsDataCon = Nothing + } + }) + InlineSig _ _ _ qname -> + pure $ Just $ HInline (toVar $ qnameToStr qname) + AnnPragma _ annotation -> + case annotation of + Ann _ name expr -> + case (name, expr) of + (Ident _ f, Con _ qname) -> + pure $ Just $ OptimizeDcon ((toVar $ f), (qnameToStr qname)) --error $ show (f) ++ "\n" ++ show (qnameToStr qname) ++ "\n" + (Ident _ conName, Tuple _ _ exprs) -> + case exprs of + [] -> + error $ + "collectTopLevel: Unsupported AnnProgma annotation: " ++ + show decl + -- VS: Add fail case if ls is empty or head doesn't have function name. + -- VS: What about the case where the first element of a tuple is not actually a function name. + ls -> + let funcName = parseFuncTotalOrdering (P.head ls) + in case (P.tail ls) of + [Tuple _ _ ls'] -> + let contrs = + P.map + (\e -> + case e of + InfixApp _ from operator to -> + case (infixOpToStr operator) of + "~>" -> + Strong + (parseIntLit from) + (parseIntLit to) + ":>" -> + Immediate + (parseIntLit from) + (parseIntLit to) + _ -> + error $ + "collectTopLevel: Unsupported infix in AnnProgma annotation: " ++ + show decl + _ -> + error $ + "collectTopLevel: Unsupported AnnProgma annotation: " ++ + show decl) + ls' + userConstrs = + UserConstraints + (M.singleton + (toVar funcName) + (M.singleton conName contrs)) + in pure $ + Just $ + UserConstraints + (M.singleton + (toVar funcName) + (M.singleton conName contrs)) --(dbgTraceIt (show userConstrs) ) + [Paren _ rhs] -> + let contrs = + case rhs of + InfixApp _ from operator to -> + case (infixOpToStr operator) of + ":>" -> + Immediate + (parseIntLit from) + (parseIntLit to) + "~>" -> + Strong + (parseIntLit from) + (parseIntLit to) + _ -> + error $ + "collectTopLevel: Unsupported infix in AnnProgma annotation: " ++ + show decl + userConstrs = + UserConstraints + (M.singleton + (toVar funcName) + (M.singleton conName [contrs])) + in pure $ + Just $ + UserConstraints + (M.singleton + (toVar funcName) + (M.singleton conName [contrs])) + _ -> + error $ + "collectTopLevel: Unsupported AnnProgma annotation: " ++ + show decl + _ -> + error $ + "collectTopLevel: Unsupported AnnProgma annotation: " ++ + show decl + _ -> + error $ + "collectTopLevel: Unsupported AnnProgma annotation: " ++ show decl + _ -> + error $ + "collectTopLevel: Unsupported top-level expression: " ++ show decl - DataDecl _ (DataType _) _ctx decl_head cons _deriving_binds -> do - let (ty_name, ty_args) = desugarDeclHead decl_head - cons' = map (desugarConstr type_syns) cons - if ty_name `S.member` builtinTys - then error $ sdoc ty_name ++ " is a built-in type." - else pure $ Just $ HDDef (DDef ty_name ty_args cons') - -- Reserved for HS. - PatBind _ (PVar _ (Ident _ "main")) (UnGuardedRhs _ _) _binds -> - pure Nothing +-- Parse Int Literal +parseIntLit :: Exp a -> Integer +parseIntLit (Lit _ (Int _ val _)) = val +parseIntLit _ = error $ "parseIntLiteral: can only take integer literals" - PatBind _ (PVar _ (Ident _ "gibbon_main")) (UnGuardedRhs _ rhs) _binds -> do - rhs' <- fixupSpawn <$> verifyBenchEAssumptions True <$> desugarExp type_syns toplevel rhs - ty <- newMetaTy - pure $ Just $ HMain $ Just (rhs', ty) +parseFuncTotalOrdering :: Exp a -> String +parseFuncTotalOrdering (H.Var _ name) = (qnameToStr name) +parseFuncTotalOrdering _ = error $ "parseFuncTotalOrdering: unexpected patterns" - PatBind _ (PVar _ (Ident _ fn)) (UnGuardedRhs _ rhs) _binds -> - case M.lookup (toVar fn) env of - Nothing -> error $ "collectTopLevel: Top-level binding with no type signature: " ++ fn - Just fun_ty -> - -- This is a top-level function binding of the form: - -- f = \x -> ... - case rhs of - Lambda _ pats bod -> do - bod' <- desugarExp type_syns toplevel bod - case pats of - [] -> error "Impossible" - _ -> do - (vars,_tys,bindss) <- unzip3 <$> mapM (desugarPatWithTy type_syns) pats - let binds = concat bindss - args = vars - pure $ Just $ HFunDef (FunDef { funName = toVar fn - , funArgs = args - , funTy = fun_ty - , funBody = fixupSpawn (mkLets binds bod') - , funMeta = FunMeta { funRec = NotRec - , funInline = NoInline - , funCanTriggerGC = False - } - }) - - -- This is a top-level function that doesn't take any arguments. - _ -> do - rhs' <- desugarExp type_syns toplevel rhs - let fun_ty' = ArrowTy [] (tyFromScheme fun_ty) - fun_ty'' = ForAll (tyVarsInTy fun_ty') fun_ty' - pure $ Just $ HFunDef (FunDef { funName = toVar fn - , funArgs = [] - , funTy = fun_ty'' - , funBody = fixupSpawn rhs' - , funMeta = FunMeta { funRec = NotRec - , funInline = NoInline - , funCanTriggerGC = False - } - }) - - - FunBind{} -> do (name,args,ty,bod) <- desugarFun type_syns toplevel env decl - pure $ Just $ HFunDef (FunDef { funName = name - , funArgs = args - , funTy = ty - , funBody = fixupSpawn bod - , funMeta = FunMeta { funRec = NotRec - , funInline = NoInline - , funCanTriggerGC = False - } - }) - - InlineSig _ _ _ qname -> pure $ Just $ HInline (toVar $ qnameToStr qname) - - _ -> error $ "collectTopLevel: Unsupported top-level expression: " ++ show decl +infixOpToStr :: QOp a -> String +infixOpToStr (QVarOp _ opName) = (qnameToStr opName) +infixOpToStr (QConOp _ opName) = (qnameToStr opName) -- pure $ LitE (litToInt lit) desugarLiteral :: Literal a -> PassM Exp0 desugarLiteral lit = case lit of - (Int _ i _) -> pure $ LitE (fromIntegral i) + (Int _ i _) -> pure $ LitE (fromIntegral i) (Char _ chr _) -> pure $ CharE chr (Frac _ i _) -> pure $ FloatE (fromRational i) (String _ str _) -> do vec <- gensym (toVar "vec") let n = length str - init_vec = LetE (vec,[],VectorTy CharTy, PrimAppE (VAllocP CharTy) [LitE n]) - fn i c b = LetE ("_",[],VectorTy CharTy, - PrimAppE (InplaceVUpdateP CharTy) [VarE vec, LitE i, CharE c]) - b - add_chars = foldr (\(i,chr) acc -> fn i chr acc) (VarE vec) - (reverse $ zip [0..n-1] str) + init_vec = + LetE (vec, [], VectorTy CharTy, PrimAppE (VAllocP CharTy) [LitE n]) + fn i c b = + LetE + ( "_" + , [] + , VectorTy CharTy + , PrimAppE (InplaceVUpdateP CharTy) [VarE vec, LitE i, CharE c]) + b + add_chars = + foldr + (\(i, chr) acc -> fn i chr acc) + (VarE vec) + (reverse $ zip [0 .. n - 1] str) pure $ init_vec add_chars - - _ -> error ("desugarLiteral: Only integer litrals are allowed: " ++ prettyPrint lit) - + _ -> + error + ("desugarLiteral: Only integer litrals are allowed: " ++ prettyPrint lit) litToInt :: Literal a -> Int litToInt (Int _ i _) = (fromIntegral i) @@ -1030,14 +1891,17 @@ litToInt lit = error ("litToInt: Not an integer: " ++ prettyPrint lit) litToString :: Literal a -> String litToString (String _ a _) = a -litToString lit = error ("litToString: Expected a String, got: " ++ prettyPrint lit) +litToString lit = + error ("litToString: Expected a String, got: " ++ prettyPrint lit) qnameToStr :: H.QName a -> String qnameToStr qname = case qname of Qual _ mname n -> (mnameToStr mname ++ "." ++ nameToStr n) - UnQual _ n -> (nameToStr n) - Special{} -> error $ "qnameToStr: Special identifiers not supported: " ++ prettyPrint qname + UnQual _ n -> (nameToStr n) + Special {} -> + error $ + "qnameToStr: Special identifiers not supported: " ++ prettyPrint qname mnameToStr :: ModuleName a -> String mnameToStr (ModuleName _ s) = s @@ -1051,89 +1915,126 @@ desugarOp qop = Nothing -> error $ "desugarOp: Unsupported binary op: " ++ show op op -> error $ "desugarOp: Unsupported op: " ++ prettyPrint op -desugarAlt :: (Show a, Pretty a) => TypeSynEnv -> TopTyEnv -> Alt a -> PassM (DataCon, [(Var,Ty0)], Exp0) +desugarAlt :: + (Show a, Pretty a) + => TypeSynEnv + -> TopTyEnv + -> Alt a + -> PassM (DataCon, [(Var, Ty0)], Exp0) desugarAlt type_syns toplevel alt = case alt of Alt _ (PApp _ qname ps) (UnGuardedRhs _ rhs) Nothing -> do let conName = qnameToStr qname desugarCase ps conName rhs - Alt _ (PWildCard _) (UnGuardedRhs _ rhs) _b -> - desugarCase [] "_default" rhs - Alt _ _ GuardedRhss{} _ -> error "desugarExp: Guarded RHS not supported in case." - Alt _ _ _ Just{} -> error "desugarExp: Where clauses not allowed in case." - Alt _ pat _ _ -> error $ "desugarExp: Unsupported pattern in case: " ++ prettyPrint pat + Alt _ (PWildCard _) (UnGuardedRhs _ rhs) _b -> desugarCase [] "_default" rhs + Alt _ _ GuardedRhss {} _ -> + error "desugarExp: Guarded RHS not supported in case." + Alt _ _ _ Just {} -> error "desugarExp: Where clauses not allowed in case." + Alt _ pat _ _ -> + error $ "desugarExp: Unsupported pattern in case: " ++ prettyPrint pat where desugarCase ps conName rhs = do - ps' <- mapM (\x -> case x of - PVar _ v -> (pure . toVar . nameToStr) v - PWildCard _ -> gensym "wildcard_" - _ -> error $ "desugarExp: Non-variable pattern in case." ++ show x) - ps + ps' <- + mapM + (\x -> + case x of + PVar _ v -> (pure . toVar . nameToStr) v + PWildCard _ -> gensym "wildcard_" + _ -> + error $ "desugarExp: Non-variable pattern in case." ++ show x) + ps rhs' <- desugarExp type_syns toplevel rhs - ps'' <- mapM (\v -> (v,) <$> newMetaTy) ps' + ps'' <- mapM (\v -> (v, ) <$> newMetaTy) ps' pure (conName, ps'', rhs') -generateBind :: (Show a, Pretty a) => TypeSynEnv -> TopTyEnv -> TopTyEnv -> Decl a -> Exp0 -> PassM (Exp0) +generateBind :: + (Show a, Pretty a) + => TypeSynEnv + -> TopTyEnv + -> TopTyEnv + -> Decl a + -> Exp0 + -> PassM (Exp0) generateBind type_syns toplevel env decl exp2 = - case decl of + case decl -- 'collectTopTy' takes care of this. - TypeSig{} -> pure exp2 + of + TypeSig {} -> pure exp2 -- 'collectTypeSynonyms' takes care of this. - TypeDecl{} -> pure exp2 - PatBind _ _ _ Just{} -> error "generateBind: where clauses not allowed" - PatBind _ _ GuardedRhss{} _ -> error "generateBind: Guarded right hand side not supported." + TypeDecl {} -> pure exp2 + PatBind _ _ _ Just {} -> error "generateBind: where clauses not allowed" + PatBind _ _ GuardedRhss {} _ -> + error "generateBind: Guarded right hand side not supported." PatBind _ (PTuple _ Boxed pats) (UnGuardedRhs _ rhs) Nothing -> do rhs' <- desugarExp type_syns toplevel rhs w <- gensym "tup" ty' <- newMetaTy - let tupexp e = LetE (w,[],ty',rhs') e - binds = reverse $ zip pats [0..] + let tupexp e = LetE (w, [], ty', rhs') e + binds = reverse $ zip pats [0 ..] prjexp <- generateTupleProjs toplevel env binds (VarE w) exp2 pure $ tupexp prjexp PatBind _ pat (UnGuardedRhs _ rhs) Nothing -> do rhs' <- desugarExp type_syns toplevel rhs - w <- case pat of - PVar _ v -> pure $ toVar (nameToStr v) - PWildCard _ -> gensym "wildcard_" - _ -> error $ "generateBind: " ++ show pat - ty' <- case M.lookup w env of - Nothing -> newMetaTy - Just (ForAll _ ty) -> pure ty + w <- + case pat of + PVar _ v -> pure $ toVar (nameToStr v) + PWildCard _ -> gensym "wildcard_" + _ -> error $ "generateBind: " ++ show pat + ty' <- + case M.lookup w env of + Nothing -> newMetaTy + Just (ForAll _ ty) -> pure ty pure $ LetE (w, [], ty', rhs') exp2 - FunBind{} -> do (name,args,ty,bod) <- desugarFun type_syns toplevel env decl - pure $ LetE (name,[], tyFromScheme ty, Ext $ LambdaE (zip args (inTys ty)) bod) exp2 + FunBind {} -> do + (name, args, ty, bod) <- desugarFun type_syns toplevel env decl + pure $ + LetE + (name, [], tyFromScheme ty, Ext $ LambdaE (zip args (inTys ty)) bod) + exp2 oth -> error ("generateBind: Unsupported pattern: " ++ prettyPrint oth) -generateTupleProjs :: (Show a, Pretty a) => TopTyEnv -> TopTyEnv -> [(Pat a,Int)] -> Exp0 -> Exp0 -> PassM (Exp0) +generateTupleProjs :: + (Show a, Pretty a) + => TopTyEnv + -> TopTyEnv + -> [(Pat a, Int)] + -> Exp0 + -> Exp0 + -> PassM (Exp0) generateTupleProjs _toplevel _env [] _tup exp2 = pure exp2 -generateTupleProjs toplevel env ((p,n):pats) tup exp2 = - case p of - (PVar _ v) -> do - let w = toVar (nameToStr v) - go w +generateTupleProjs toplevel env ((p, n):pats) tup exp2 = + case p of + (PVar _ v) -> do + let w = toVar (nameToStr v) + go w -- Don't bind wildcards from patterns. - (PWildCard _) -> do - generateTupleProjs toplevel env pats tup exp2 - - _ -> error $ "generateTupleProjs: Pattern not handled: " ++ prettyPrint p - + (PWildCard _) -> do + generateTupleProjs toplevel env pats tup exp2 + _ -> error $ "generateTupleProjs: Pattern not handled: " ++ prettyPrint p where go w = do - ty' <- case M.lookup w env of - Nothing -> newMetaTy - Just (ForAll _ ty) -> pure ty - let prjexp = LetE (w,[],ty',ProjE n tup) exp2 - generateTupleProjs toplevel env pats tup prjexp - -desugarConstr :: (Show a, Pretty a) => TypeSynEnv -> QualConDecl a -> (DataCon,[(IsBoxed, Ty0)]) + ty' <- + case M.lookup w env of + Nothing -> newMetaTy + Just (ForAll _ ty) -> pure ty + let prjexp = LetE (w, [], ty', ProjE n tup) exp2 + generateTupleProjs toplevel env pats tup prjexp + +desugarConstr :: + (Show a, Pretty a) + => TypeSynEnv + -> QualConDecl a + -> (DataCon, [(IsBoxed, Ty0)]) desugarConstr type_syns qdecl = case qdecl of - QualConDecl _ _tyvars _ctx (ConDecl _ name arg_tys) -> + QualConDecl _ _tyvars _ctx (ConDecl _ name arg_tys) -- N.B. This is a type scheme only to make the types work everywhere else -- in code. However, we shouldn't actually quantify over any additional -- type variables here. We only support Rank-1 types. - ( nameToStr name , map (desugarType' type_syns) arg_tys ) - _ -> error ("desugarConstr: Unsupported data constructor: " ++ prettyPrint qdecl) + -> (nameToStr name, map (desugarType' type_syns) arg_tys) + _ -> + error + ("desugarConstr: Unsupported data constructor: " ++ prettyPrint qdecl) desugarDeclHead :: DeclHead a -> (Var, [TyVar]) desugarDeclHead = go [] @@ -1143,42 +2044,57 @@ desugarDeclHead = go [] DHead _ name -> (toVar (nameToStr name), acc) DHParen _ dh -> go acc dh DHApp _ dh tyvar -> - let (v,acc') = go acc dh - in (v, acc' ++ [desugarTyVarBind tyvar]) - _ -> error ("collectTopLevel: Unsupported data declaration: " ++ prettyPrint decl_head) + let (v, acc') = go acc dh + in (v, acc' ++ [desugarTyVarBind tyvar]) + _ -> + error + ("collectTopLevel: Unsupported data declaration: " ++ + prettyPrint decl_head) desugarTyVarBind :: TyVarBind a -> TyVar desugarTyVarBind (UnkindedVar _ name) = UserTv (toVar (nameToStr name)) -desugarTyVarBind v@KindedVar{} = error $ "desugarTyVarBind: Vars with kinds not supported yet." ++ prettyPrint v - -desugarPatWithTy :: (Show a, Pretty a) => TypeSynEnv -> Pat a -> PassM (Var, Ty0, [L0.Binds Exp0]) +desugarTyVarBind v@KindedVar {} = + error $ + "desugarTyVarBind: Vars with kinds not supported yet." ++ prettyPrint v + +desugarPatWithTy :: + (Show a, Pretty a) + => TypeSynEnv + -> Pat a + -> PassM (Var, Ty0, [L0.Binds Exp0]) desugarPatWithTy type_syns pat = case pat of - (PParen _ p) -> desugarPatWithTy type_syns p - (PatTypeSig _ p ty) -> do (v,_ty,binds) <- desugarPatWithTy type_syns p - pure (v, desugarType type_syns ty, binds) - (PVar _ n) -> do ty <- newMetaTy - pure (toVar (nameToStr n), ty, []) - (PWildCard _) -> do v <- gensym "wildcard_" - ty <- newMetaTy - pure (v,ty,[]) - (PTuple _ Boxed pats) -> do (vars,tys,bindss) <- unzip3 <$> mapM (desugarPatWithTy type_syns) pats - tup <- gensym "tup" - let binds0 = concat bindss - binds1 = map (\(v,ty,i) -> (v,[],ty,ProjE i (VarE tup))) (zip3 vars tys [0..]) - tupty = ProdTy tys + (PParen _ p) -> desugarPatWithTy type_syns p + (PatTypeSig _ p ty) -> do + (v, _ty, binds) <- desugarPatWithTy type_syns p + pure (v, desugarType type_syns ty, binds) + (PVar _ n) -> do + ty <- newMetaTy + pure (toVar (nameToStr n), ty, []) + (PWildCard _) -> do + v <- gensym "wildcard_" + ty <- newMetaTy + pure (v, ty, []) + (PTuple _ Boxed pats) -> do + (vars, tys, bindss) <- unzip3 <$> mapM (desugarPatWithTy type_syns) pats + tup <- gensym "tup" + let binds0 = concat bindss + binds1 = + map + (\(v, ty, i) -> (v, [], ty, ProjE i (VarE tup))) + (zip3 vars tys [0 ..]) + tupty = ProdTy tys -- current bindings: binds1, recursive bindings: binds0 - pure (tup,tupty,binds1 ++ binds0) - + pure (tup, tupty, binds1 ++ binds0) (PApp _ (UnQual _ (Ident _ "Ur")) [one]) -> desugarPatWithTy type_syns one - _ -> error ("desugarPatWithTy: Unsupported pattern: " ++ show pat) nameToStr :: Name a -> String nameToStr (Ident _ s) = s nameToStr (Symbol _ s) = s -instance Pretty SrcSpanInfo where +instance Pretty SrcSpanInfo + -- | SpawnE's are parsed in a strange way. If we see a 'spawn (f x1 x2)', -- we parse it as 'SpawnE HOLE [] [(f x1 x2)]'. This function patches it @@ -1187,207 +2103,247 @@ fixupSpawn :: Exp0 -> Exp0 fixupSpawn ex = case ex of Ext (LambdaE vars bod) -> Ext (LambdaE vars (go bod)) - Ext (PolyAppE a b) -> Ext (PolyAppE (go a) (go b)) - Ext (FunRefE{}) -> ex + Ext (PolyAppE a b) -> Ext (PolyAppE (go a) (go b)) + Ext (FunRefE {}) -> ex Ext (BenchE fn tyapps args b) -> Ext (BenchE fn tyapps (map go args) b) Ext (ParE0 ls) -> Ext (ParE0 (map go ls)) Ext (PrintPacked ty arg) -> Ext (PrintPacked ty (go arg)) Ext (CopyPacked ty arg) -> Ext (CopyPacked ty (go arg)) Ext (TravPacked ty arg) -> Ext (TravPacked ty (go arg)) - Ext (L p e) -> Ext (L p (go e)) + Ext (L p e) -> Ext (L p (go e)) Ext (LinearExt ext) -> case ext of ReverseAppE fn arg -> Ext (LinearExt (ReverseAppE (go fn) (go arg))) - LseqE a b -> Ext (LinearExt (LseqE (go a) (go b))) - AliasE a -> Ext (LinearExt (AliasE (go a))) - ToLinearE a -> Ext (LinearExt (ToLinearE (go a))) + LseqE a b -> Ext (LinearExt (LseqE (go a) (go b))) + AliasE a -> Ext (LinearExt (AliasE (go a))) + ToLinearE a -> Ext (LinearExt (ToLinearE (go a))) -- Straightforward recursion ... - VarE{} -> ex - LitE{} -> ex - CharE{} -> ex - FloatE{} -> ex - LitSymE{} -> ex + VarE {} -> ex + LitE {} -> ex + CharE {} -> ex + FloatE {} -> ex + LitSymE {} -> ex AppE fn tyapps args -> AppE fn tyapps (map go args) PrimAppE pr args -> PrimAppE pr (map go args) DataConE dcon tyapps args -> DataConE dcon tyapps (map go args) - ProjE i e -> ProjE i $ go e - IfE a b c -> IfE (go a) (go b) (go c) + ProjE i e -> ProjE i $ go e + IfE a b c -> IfE (go a) (go b) (go c) MkProdE ls -> MkProdE $ map go ls -- Only allow BenchE in tail position - LetE (v,locs,ty,rhs) bod -> LetE (v,locs,ty, go rhs) (go bod) - CaseE scrt mp -> CaseE (go scrt) $ map (\(a,b,c) -> (a,b, go c)) mp + LetE (v, locs, ty, rhs) bod -> LetE (v, locs, ty, go rhs) (go bod) + CaseE scrt mp -> CaseE (go scrt) $ map (\(a, b, c) -> (a, b, go c)) mp TimeIt e ty b -> TimeIt (go e) ty b WithArenaE v e -> WithArenaE v (go e) SpawnE _ _ args -> case args of - [(AppE fn tyapps ls)] -> SpawnE fn tyapps ls - _ -> error $ "fixupSpawn: incorrect use of spawn: " ++ sdoc ex - SyncE -> SyncE - MapE{} -> error $ "fixupSpawn: TODO MapE" - FoldE{} -> error $ "fixupSpawn: TODO FoldE" - where go = fixupSpawn + [(AppE fn tyapps ls)] -> SpawnE fn tyapps ls + _ -> error $ "fixupSpawn: incorrect use of spawn: " ++ sdoc ex + SyncE -> SyncE + MapE {} -> error $ "fixupSpawn: TODO MapE" + FoldE {} -> error $ "fixupSpawn: TODO FoldE" + where + go = fixupSpawn + -- | Verify some assumptions about BenchE. verifyBenchEAssumptions :: Bool -> Exp0 -> Exp0 verifyBenchEAssumptions bench_allowed ex = case ex of Ext (LambdaE vars bod) -> Ext (LambdaE vars (not_allowed bod)) - Ext (PolyAppE a b) -> Ext (PolyAppE (not_allowed a) (not_allowed b)) - Ext (FunRefE{}) -> ex + Ext (PolyAppE a b) -> Ext (PolyAppE (not_allowed a) (not_allowed b)) + Ext (FunRefE {}) -> ex Ext (BenchE _ tyapps args b) -> - if bench_allowed then - case args of - ((VarE fn) : oth) -> Ext (BenchE fn tyapps oth b) - _ -> error $ "desugarModule: bench is a reserved keyword. Usage: bench fn_name args. Got: " ++ sdoc args - else error $ "verifyBenchEAssumptions: 'bench' can only be used as a tail of the main expression, but it was used in a function. In: " ++ sdoc ex + if bench_allowed + then case args of + ((VarE fn):oth) -> Ext (BenchE fn tyapps oth b) + _ -> + error $ + "desugarModule: bench is a reserved keyword. Usage: bench fn_name args. Got: " ++ + sdoc args + else error $ + "verifyBenchEAssumptions: 'bench' can only be used as a tail of the main expression, but it was used in a function. In: " ++ + sdoc ex Ext (ParE0 ls) -> Ext (ParE0 (map not_allowed ls)) Ext (PrintPacked ty arg) -> Ext (PrintPacked ty (not_allowed arg)) Ext (CopyPacked ty arg) -> Ext (CopyPacked ty (not_allowed arg)) Ext (TravPacked ty arg) -> Ext (TravPacked ty (not_allowed arg)) - Ext (L p e) -> Ext (L p (go e)) - Ext (LinearExt{}) -> error "verifyBenchEAssumptions: LinearExt not handled." + Ext (L p e) -> Ext (L p (go e)) + Ext (LinearExt {}) -> + error "verifyBenchEAssumptions: LinearExt not handled." -- Straightforward recursion ... - VarE{} -> ex - LitE{} -> ex - CharE{} -> ex - FloatE{} -> ex - LitSymE{} -> ex + VarE {} -> ex + LitE {} -> ex + CharE {} -> ex + FloatE {} -> ex + LitSymE {} -> ex AppE fn tyapps args -> AppE fn tyapps (map not_allowed args) PrimAppE pr args -> PrimAppE pr (map not_allowed args) DataConE dcon tyapps args -> DataConE dcon tyapps (map not_allowed args) - ProjE i e -> ProjE i $ not_allowed e - IfE a b c -> IfE (not_allowed a) (go b) (go c) + ProjE i e -> ProjE i $ not_allowed e + IfE a b c -> IfE (not_allowed a) (go b) (go c) MkProdE ls -> MkProdE $ map not_allowed ls - LetE (v,locs,ty,rhs) bod -> LetE (v,locs,ty, not_allowed rhs) (go bod) - CaseE scrt mp -> CaseE (go scrt) $ map (\(a,b,c) -> (a,b, go c)) mp + LetE (v, locs, ty, rhs) bod -> LetE (v, locs, ty, not_allowed rhs) (go bod) + CaseE scrt mp -> CaseE (go scrt) $ map (\(a, b, c) -> (a, b, go c)) mp TimeIt e ty b -> TimeIt (not_allowed e) ty b WithArenaE v e -> WithArenaE v (go e) SpawnE fn tyapps args -> SpawnE fn tyapps (map not_allowed args) - SyncE -> SyncE - MapE{} -> error $ "verifyBenchEAssumptions: TODO MapE" - FoldE{} -> error $ "verifyBenchEAssumptions: TODO FoldE" - where go = verifyBenchEAssumptions bench_allowed - not_allowed = verifyBenchEAssumptions False + SyncE -> SyncE + MapE {} -> error $ "verifyBenchEAssumptions: TODO MapE" + FoldE {} -> error $ "verifyBenchEAssumptions: TODO FoldE" + where + go = verifyBenchEAssumptions bench_allowed + not_allowed = verifyBenchEAssumptions False --------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- desugarLinearExts :: Prog0 -> PassM Prog0 desugarLinearExts (Prog ddefs fundefs main) = do - main' <- case main of - Nothing -> pure Nothing - Just (e,ty) -> do - let ty' = goty ty - e' <- go e - pure $ Just (e', ty') - fundefs' <- mapM (\fn -> do - bod <- go (funBody fn) - let (ForAll tyvars ty) = (funTy fn) - ty' = goty ty - pure $ fn { funBody = bod - , funTy = (ForAll tyvars ty') - }) - fundefs - pure (Prog ddefs fundefs' main') + main' <- + case main of + Nothing -> pure Nothing + Just (e, ty) -> do + let ty' = goty ty + e' <- go e + pure $ Just (e', ty') + fundefs' <- + mapM + (\fn -> do + bod <- go (funBody fn) + let (ForAll tyvars ty) = (funTy fn) + ty' = goty ty + pure $ fn {funBody = bod, funTy = (ForAll tyvars ty')}) + fundefs + pure (Prog ddefs fundefs' main') where goty :: Ty0 -> Ty0 goty ty = case ty of - ProdTy tys -> ProdTy (map goty tys) - SymDictTy v t -> SymDictTy v (goty t) - PDictTy k v -> PDictTy (goty k) (goty v) - ArrowTy tys b -> ArrowTy (map goty tys) (goty b) + ProdTy tys -> ProdTy (map goty tys) + SymDictTy v t -> SymDictTy v (goty t) + PDictTy k v -> PDictTy (goty k) (goty v) + ArrowTy tys b -> ArrowTy (map goty tys) (goty b) PackedTy "Ur" [one] -> one - PackedTy t tys -> PackedTy t (map goty tys) - VectorTy t -> VectorTy (goty t) - ListTy t -> ListTy (goty t) - _ -> ty - + PackedTy t tys -> PackedTy t (map goty tys) + VectorTy t -> VectorTy (goty t) + ListTy t -> ListTy (goty t) + _ -> ty go :: PreExp E0Ext Ty0 Ty0 -> PassM Exp0 go ex = case ex of - VarE{} -> pure ex - LitE{} -> pure ex - CharE{} -> pure ex - FloatE{} -> pure ex - LitSymE{} -> pure ex - AppE f tyapps args -> do args' <- mapM go args - pure (AppE f tyapps args') - PrimAppE pr args -> do args' <- mapM go args - pure (PrimAppE pr args') - LetE (v,locs,ty,rhs) bod -> do + VarE {} -> pure ex + LitE {} -> pure ex + CharE {} -> pure ex + FloatE {} -> pure ex + LitSymE {} -> pure ex + AppE f tyapps args -> do + args' <- mapM go args + pure (AppE f tyapps args') + PrimAppE pr args -> do + args' <- mapM go args + pure (PrimAppE pr args') + LetE (v, locs, ty, rhs) bod -> do let ty' = goty ty rhs' <- go rhs bod' <- go bod - pure $ LetE (v,locs,ty',rhs') bod' - IfE a b c -> do a' <- go a - b' <- go b - c' <- go c - pure (IfE a' b' c') - MkProdE ls -> do ls' <- mapM go ls - pure (MkProdE ls') - ProjE i e -> do e' <- go e - pure (ProjE i e') - CaseE scrt alts -> do scrt' <- go scrt - alts' <- mapM (\(a,b,c) -> do c' <- go c - pure (a,b,c')) - alts - pure (CaseE scrt' alts') - DataConE _ "Ur" [arg] -> do arg' <- go arg - pure arg' - DataConE locs dcon args -> do args' <- mapM go args - pure (DataConE locs dcon args') - TimeIt e ty b -> do e' <- go e - let ty' = goty ty - pure (TimeIt e' ty' b) - WithArenaE v e -> do e' <- go e - pure (WithArenaE v e') - SpawnE f tyapps args -> do args' <- mapM go args - pure (SpawnE f tyapps args') + pure $ LetE (v, locs, ty', rhs') bod' + IfE a b c -> do + a' <- go a + b' <- go b + c' <- go c + pure (IfE a' b' c') + MkProdE ls -> do + ls' <- mapM go ls + pure (MkProdE ls') + ProjE i e -> do + e' <- go e + pure (ProjE i e') + CaseE scrt alts -> do + scrt' <- go scrt + alts' <- + mapM + (\(a, b, c) -> do + c' <- go c + pure (a, b, c')) + alts + pure (CaseE scrt' alts') + DataConE _ "Ur" [arg] -> do + arg' <- go arg + pure arg' + DataConE locs dcon args -> do + args' <- mapM go args + pure (DataConE locs dcon args') + TimeIt e ty b -> do + e' <- go e + let ty' = goty ty + pure (TimeIt e' ty' b) + WithArenaE v e -> do + e' <- go e + pure (WithArenaE v e') + SpawnE f tyapps args -> do + args' <- mapM go args + pure (SpawnE f tyapps args') SyncE -> pure SyncE - MapE{} -> error "desugarLinearExts: MapE" - FoldE{} -> error "desugarLinearExts: FoldE" + MapE {} -> error "desugarLinearExts: MapE" + FoldE {} -> error "desugarLinearExts: FoldE" Ext ext -> case ext of - LambdaE args bod -> do bod' <- go bod - let args' = map (\(v,ty) -> (v,goty ty)) args - pure (Ext (LambdaE args' bod')) - PolyAppE fn arg -> do fn' <- go fn - arg' <- go arg - pure (Ext (PolyAppE fn' arg')) - FunRefE{} -> pure ex - BenchE fn tyapps args b -> do args' <- mapM go args - pure (Ext (BenchE fn tyapps args' b)) - ParE0 ls -> do ls' <- mapM go ls - pure (Ext (ParE0 ls')) - PrintPacked ty arg -> do arg' <- go arg - pure (Ext (PrintPacked ty arg')) - CopyPacked ty arg -> do arg' <- go arg - pure (Ext (CopyPacked ty arg')) - TravPacked ty arg -> do arg' <- go arg - pure (Ext (TravPacked ty arg')) - L p e -> do e' <- go e - pure (Ext (L p e')) + LambdaE args bod -> do + bod' <- go bod + let args' = map (\(v, ty) -> (v, goty ty)) args + pure (Ext (LambdaE args' bod')) + PolyAppE fn arg -> do + fn' <- go fn + arg' <- go arg + pure (Ext (PolyAppE fn' arg')) + FunRefE {} -> pure ex + BenchE fn tyapps args b -> do + args' <- mapM go args + pure (Ext (BenchE fn tyapps args' b)) + ParE0 ls -> do + ls' <- mapM go ls + pure (Ext (ParE0 ls')) + PrintPacked ty arg -> do + arg' <- go arg + pure (Ext (PrintPacked ty arg')) + CopyPacked ty arg -> do + arg' <- go arg + pure (Ext (CopyPacked ty arg')) + TravPacked ty arg -> do + arg' <- go arg + pure (Ext (TravPacked ty arg')) + L p e -> do + e' <- go e + pure (Ext (L p e')) LinearExt lin -> case lin of ReverseAppE fn (Ext (LinearExt (AliasE e))) -> do fn' <- go fn case fn' of - Ext (LambdaE [(v,ProdTy tys)] bod) -> do + Ext (LambdaE [(v, ProdTy tys)] bod) -> do let ty = head tys - bod'' = foldl' (\acc i -> gSubstE (ProjE i (VarE v)) (VarE v) acc) bod [0..(length tys)] - pure (LetE (v,[],ty,e) bod'') - _ -> error $ "desugarLinearExts: couldn't desugar " ++ sdoc ex + bod'' = + foldl' + (\acc i -> gSubstE (ProjE i (VarE v)) (VarE v) acc) + bod + [0 .. (length tys)] + pure (LetE (v, [], ty, e) bod'') + _ -> + error $ "desugarLinearExts: couldn't desugar " ++ sdoc ex ReverseAppE fn arg -> do - fn' <- go fn + fn' <- go fn arg' <- go arg case fn' of - Ext (LambdaE [(v,ty)] bod) -> do - pure (LetE (v,[],ty,arg') bod) - _ -> error $ "desugarLinearExts: couldn't desugar " ++ sdoc ex - LseqE _ b -> do b' <- go b - pure b' - AliasE a -> do v <- gensym "aliased" - ty <- newMetaTy - pure (LetE (v,[],ty,MkProdE [a,a]) (VarE v)) - ToLinearE a -> do a' <- go a - pure a' + Ext (LambdaE [(v, ty)] bod) -> do + pure (LetE (v, [], ty, arg') bod) + _ -> + error $ "desugarLinearExts: couldn't desugar " ++ sdoc ex + LseqE _ b -> do + b' <- go b + pure b' + AliasE a -> do + v <- gensym "aliased" + ty <- newMetaTy + pure (LetE (v, [], ty, MkProdE [a, a]) (VarE v)) + ToLinearE a -> do + a' <- go a + pure a' From 5827f62c5d0275234625b12bd43a6594c80e1a46 Mon Sep 17 00:00:00 2001 From: vidsinghal Date: Fri, 18 Aug 2023 17:53:53 -0400 Subject: [PATCH 25/25] AddRAN: missing fields in functionMeta record --- gibbon-compiler/src/Gibbon/Passes/AddRAN.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs b/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs index 522590cd3..6340436dd 100644 --- a/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs +++ b/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs @@ -582,5 +582,7 @@ genRelOffsetsFunNameFn needRANsTyCons ddfs DDef{tyName, dataCons} = do , funMeta = FunMeta { funRec = Rec , funInline = NoInline , funCanTriggerGC = False + , funOptLayout=NoLayoutOpt + , userConstraintsDataCon=Nothing } }