diff --git a/.gitmodules b/.gitmodules index 0e1a15d..45b9fde 100644 --- a/.gitmodules +++ b/.gitmodules @@ -5,4 +5,4 @@ [submodule "src/servois2"] path = src/servois2 url = https://github.com/veracity-lang/servois2.git - ignore = dirty \ No newline at end of file + ignore = dirty diff --git a/.vscode/settings.json b/.vscode/settings.json index 45ecc55..aad1837 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -3,6 +3,8 @@ "*.smtlib2": "smt-lib", "*.vcy": "c", "random": "c", + "stdlib.h": "c", + "string": "c" "fetchandadd": "c" } -} \ No newline at end of file +} diff --git a/README.md b/README.md index cc329e1..82429a2 100644 --- a/README.md +++ b/README.md @@ -17,16 +17,19 @@ add-apt-repository ppa:avsm/ppa apt update apt install opam apt install cvc4 +apt install graphviz # optional, for PDG output opam init eval $(opam env) opam update -opam switch create 4.12.0mc 4.12.0+domains+effects --repositories=multicore=git+https://github.com/ocaml-multicore/multicore-opam.git,default -opam switch 4.12.0mc +#opam switch create 4.12.0mc 4.12.0+domains+effects --repositories=multicore=git+https://github.com/ocaml-multicore/multicore-opam.git,default +#opam switch 4.12.0mc +opam switch create 5.2.0 eval $(opam env) -opam install sexplib ppxlib.0.22.0+effect-syntax ppx_deriving_yaml ounit2 menhir +#opam install sexplib ppxlib.0.22.0+effect-syntax ppx_deriving_yaml +opam install ounit2 menhir zarith yaml domainslib eval $(opam env) ``` diff --git a/benchmarks/global_commutativity/2d-array.vcy b/benchmarks/global_commutativity/2d-array.vcy new file mode 100644 index 0000000..fdcc006 --- /dev/null +++ b/benchmarks/global_commutativity/2d-array.vcy @@ -0,0 +1,49 @@ + + +int main(int argc, string[] argv) { + int[] pIds = new int[100]; + bool[] visited = new bool[100]; + int pSize = 100; + /* Each row is a fixed p, variable q */ + int[] pValue = new int[100]; + bool[][] pqFlag = new bool[][100]; + int sum =0; + /* initialize pqFlag */ + int i = 0; + int p = 0; + int id = 0; + int row = 0; + int q = 0; + int scalingfactor = 1000; + scalingfactor = int_of_string(argv[1]); + + /* mutex_init(0); */ + while(i < 100) { + pqFlag[i] = new bool[100]; + pIds[i] = i; + pValue[i] = i; + /* if (pIds[i] < 0) { pIds[i] = i; } */ + i = i + 1; + } + + while(p < pSize){ + id = pIds[p]; + if(!visited[id % 100]){ + visited[id % 100] = true; + + row = p; /* "row" should be the dep */ + q = 0; + while (q < 99 && !pqFlag[row][q%100]){ + busy_wait(scalingfactor); + q = q+1; + } + if(q < 100){ + mutex_lock(0); + sum = (sum + pValue[row]) % 256; + mutex_unlock(0); + } + } + p = p + 1; + } + return sum; +} diff --git a/benchmarks/global_commutativity/commset-verify.vcy b/benchmarks/global_commutativity/commset-verify.vcy new file mode 100644 index 0000000..1940259 --- /dev/null +++ b/benchmarks/global_commutativity/commset-verify.vcy @@ -0,0 +1,40 @@ +commutativity { + {f1(i_left)}, {f1(i_right)} : (i_left != i_right) +} + +int main(int argc, string[] argv) { + int i = 1; + int i_left = 1; + int i_right = 1; + string[] digest = new string[16]; + + while (i < argc){ + f1(i):{ + string temp = ""; + string filename = ""; + string s = ""; + int m = md5_lower(s); + filename = argv[i]; + in_channel c = open_read(filename); + s = read_line(c); + temp = string_of_int(m); + + close(c); + digest[i] = temp; + print(digest[i]); + print("\n"); + + temp = ""; + filename = ""; + s = ""; + m = 0; + c = open_read(temp); + close(c); + } + i = i + 1; + } + + return 0; +} + + diff --git a/benchmarks/global_commutativity/commset.vcy b/benchmarks/global_commutativity/commset.vcy new file mode 100644 index 0000000..ef630fe --- /dev/null +++ b/benchmarks/global_commutativity/commset.vcy @@ -0,0 +1,38 @@ +commutativity { + {f1(i_1)}, {f1(i_2)} : (i_1 != i_2) +} + +int main(int argc, string[] argv) { + int i = 1; + string[] digest = new string[16]; + string s = ""; + int i_1 = 0; + int i_2 = 0; + string filename = ""; + + while (i < argc){ + f1(i):{ + int j = 0; + string temp = ""; + filename = argv[i]; + while (j < 10) { /* Artificially increase workload by 10x */ + j = j+1; + + in_channel c = open_read(filename); + s = read_line(c); + int j = 0; + temp = string_of_int(md5_lower(s)); + + close(c); + } + digest[i] = temp; + print(digest[i]); + print("\n"); + } + i = i + 1; + } + + return 0; +} + + diff --git a/benchmarks/global_commutativity/commset_infer.vcy b/benchmarks/global_commutativity/commset_infer.vcy new file mode 100644 index 0000000..d70a1fd --- /dev/null +++ b/benchmarks/global_commutativity/commset_infer.vcy @@ -0,0 +1,34 @@ +commutativity { + {f1(i_1, digest)}, {f1(i_2, digest)} : _ +} + +int i = 1; +string[] digest = new string[16]; + +int main(int argc, string[] argv) { + int i_1 = 0; + int i_2 = 0; + + while (i < argc){ + f1(i, digest):{ + string filename = argv[i]; + in_channel c = open_read(filename); + string s = read_line(c); + int md5 = md5_lower(s); + string temp = string_of_int(md5); + digest[i] = temp; + close(c); + + filename = ""; + s = ""; + temp = ""; + md5 = 0; + c = open_read(filename); + } + i = i + 1; + } + + return 0; +} + + diff --git a/benchmarks/global_commutativity/motivation.vcy b/benchmarks/global_commutativity/motivation.vcy new file mode 100644 index 0000000..3fd75f8 --- /dev/null +++ b/benchmarks/global_commutativity/motivation.vcy @@ -0,0 +1,45 @@ +commutativity { + {f1(i_1, x, arr)}, {f2(i_2, arr)}: ((i_1 != i_2) || (i_1 == i_2 && arr[i_1] > 0)) +} + +int main(int argc, string[] argv) { + int scalingfactor = int_of_string(argv[1]); + int x = 10; + int[] arr = new int[1000]; + int size = int_of_string(argv[2]); + int[] out = new int[size]; + int i = 0; + int j = 0; + int i_1 = 0; + int i_2 = 2; + int res = 0; + int t = 0; + + while (j < 1000) { + arr[j] = random(1, 1000); + j = j + 1; + } + + while (i < size) { + f1(i, x, arr):{ /* will only increase arr[i] */ + busy_wait(scalingfactor); + x = i; + arr[i] = arr[i] + (x*x); + } + + f2(i, arr):{ /* only observes if arr[i]>0 */ + t = /*compute*/(i); + busy_wait(scalingfactor); + if (arr[i] > 0 && t < 0) { + arr[i] = arr[i] - 1; + out[i] = /*calc2*/(t); + } else { + out[i] = /*calc3*/(t); + } + } + + i = i + 1; + } + + return arr[0]; +} diff --git a/benchmarks/global_commutativity/multi-blocks.vcy b/benchmarks/global_commutativity/multi-blocks.vcy new file mode 100644 index 0000000..2f441b3 --- /dev/null +++ b/benchmarks/global_commutativity/multi-blocks.vcy @@ -0,0 +1,71 @@ +commutativity { + {f1(tbl,x,y)}, {f2(tbl,z,y)}: (tbl[z] == tbl[x] && !(z == x) || z == x); + {f2(tbl,z,y)}, {f3(tbl,z,y)}: (!(ht_size(tbl) > 0) && !(0 == z) || 0 == z); + {f4(files,i_1)}, {f4(files,i_2)}: (files[i_2] == files[i_1]); + {f4(files,i_1)}, {f6(files,i_3)}: (!(i_3 == i_1)); + {f1(tbl,x,y)}, {f3(tbl,z,y)}: (!(ht_size(tbl) > 0) && !(0 == ht_size(tbl)) && !(0 == z) || 0 == ht_size(tbl) && !(0 == z) || 0 == z); + {f1(tbl,x,y)}, {f4(files,i_1)}: (true); + {f1(tbl,x,y)}, {f6(files,i_3)}: (true); + {f2(tbl,z,y)}, {f4(files,i_1)}: (true); + {f2(tbl,z,y)}, {f6(files,i_3)}: (true); + {f3(tbl,z,y)}, {f4(files,i_1)}: (true); + {f3(tbl,z,y)}, {f6(files,i_3)}: (true) +} + +int main(int argc, string[] argv) { + hashtable[int,int] tbl = new hashtable[int,int]; + int n = 1000 * int_of_string(argv[1]); + int x = 2; + int y = 5; + int z = 0; + int f = 1; + int g = 0; + int i = 0; + int i_1 = 3; + int i_2 = 3; + int i_3 = 4; + int j = 0; + + int[] files = new int[10]; + + tbl[x] = 12; + tbl[z] = 12; + + while(j < 10) { + files[j] = j; + j = j + 1; + } + + f1(tbl,x,y):{ + busy_wait(n); + if(ht_mem(tbl, x)) { + y = ht_get(tbl, x); + } + } + f2(tbl,z,y): { + y = ht_get(tbl, z); + busy_wait(n); + } + f3(tbl,z,y): { + busy_wait(n); + if(ht_size(tbl) > 0) { + y = y + z; + } + } + + f4(files,i):{ + busy_wait(n); + f = files[i]; + f = f + 5; + files[i] = f; + } + + f6(files,i):{ + busy_wait(n); + g = files[i]; + g = g + 5; + files[i] = g; + } + + return 0; +} diff --git a/benchmarks/global_commutativity/nested_if.vcy b/benchmarks/global_commutativity/nested_if.vcy new file mode 100644 index 0000000..3868fa9 --- /dev/null +++ b/benchmarks/global_commutativity/nested_if.vcy @@ -0,0 +1,20 @@ +commutativity { + +} + +int main(int argc, string[] argv) { + int x = 1; + x = x + 2; + if(x > 2) { + if (x == 3){ + x = x - 1; + } + } + else{ + x = x + 1; + } + + return x; +} + + diff --git a/benchmarks/global_commutativity/nested_if_loop.vcy b/benchmarks/global_commutativity/nested_if_loop.vcy new file mode 100644 index 0000000..21413bb --- /dev/null +++ b/benchmarks/global_commutativity/nested_if_loop.vcy @@ -0,0 +1,32 @@ +commutativity { + +} + +int main(int argc, string[] argv) { + int x = 0; + x = 1; + x = x + 2; + if(x > 2) { + if (x == 3){ + x = x * 10; + while(x > 4) { + x = x - 1; + } + } + else{ + x = x * 2; + } + } + else{ + if(x == 0){ + x = x + 2; + } + else{ + x = x + 1; + } + } + + return x; +} + + diff --git a/benchmarks/global_commutativity/notes.vcy b/benchmarks/global_commutativity/notes.vcy new file mode 100644 index 0000000..59ee076 --- /dev/null +++ b/benchmarks/global_commutativity/notes.vcy @@ -0,0 +1,43 @@ + +TASK 0 + + SendDep(t1, []) + SendEOP(t1) + ; + SendDep(t3, sum) + SendEOP(t3) + +TASK 1 + On receive(): + while(i < 100) { + pqFlag[i] = new bool[100]; + if (pIds[i] < 0) { pIds[i] = i; } + i = i + 1; + } + + while(p < pSize){ + id = pIds[p]; + if(!visited[id % 100]){ + visited[id % 100] = true; + + row = p; /* "row" should be the dep */ + q = 0; + + SendDep(t2, q, row) + } + p = p + 1; + } + SendEOP(t2) + +TASK 2 + On receive(q,row): + while (q < 99 && !pqFlag[row][q%100]){ + q = q+1; + } + if(q < 100){ + sum = sum + pValue[row]; + } + +TASK 3 + On receive(sum): + return sum; diff --git a/benchmarks/global_commutativity/old-motivation.vcy b/benchmarks/global_commutativity/old-motivation.vcy new file mode 100644 index 0000000..a38d5c3 --- /dev/null +++ b/benchmarks/global_commutativity/old-motivation.vcy @@ -0,0 +1,35 @@ +commutativity { + {f1(i_1)}, {f2(i_2,x)}: ((i_2 != i_1) && !(1 == x) || 1 == x) +} + +int main(int argc, string[] argv) { + int scalingfactor = int_of_string(argv[1]); + int x = int_of_string(argv[2]); + int[] arr = new int[1000]; + int i = 0; + int j = 0; + int i_1 = 0; + int i_2 = 2; + int res = 0; + + while (j < 1000) { + arr[j] = random(0, 1000); + j = j + 1; + } + + while (i < 1000) { + f1(i): { + busy_wait(scalingfactor); + arr[i] = arr[i] + 1; + } + f2(i,x): { + arr[i] = arr[i] * x; + busy_wait(scalingfactor); + } + + busy_wait(scalingfactor); + i = i + 1; + } + + return arr[0]; +} \ No newline at end of file diff --git a/benchmarks/global_commutativity/ps-dswp-arr.vcy b/benchmarks/global_commutativity/ps-dswp-arr.vcy new file mode 100644 index 0000000..6909b14 --- /dev/null +++ b/benchmarks/global_commutativity/ps-dswp-arr.vcy @@ -0,0 +1,34 @@ +commutativity { + +} + +int main(int argc, string[] argv) { + int[] fileIdList = new int[100]; + int[] visited = new int[100]; + string[] id_to_name = new string[100]; + int p = 0; + int id = 0; + string fname = ""; + string buf = "deadbeef"; + in_channel inch; + int sum = 0; + + while(p != 100){ + id = fileIdList[p]; + if(!visited[id]){ + visited[id] = true; + fname = id_to_name[id]; + /* subtask. input: fname */ + q = p_inner_list; + inch = open_read(fname); + buf = read_line(inch); + close(inch); + sum = sum + 0; /* md5(buf) */ + } + id = id + 1; + } + + return 0; +} + + diff --git a/benchmarks/global_commutativity/ps-dswp-ek.vcy b/benchmarks/global_commutativity/ps-dswp-ek.vcy new file mode 100644 index 0000000..dc68abb --- /dev/null +++ b/benchmarks/global_commutativity/ps-dswp-ek.vcy @@ -0,0 +1,38 @@ + +int main(int argc, string[] argv) { + +int p=0; int q=0; int row=0; int id=0; int i=0; +int[] pIds = new int[100]; +bool[] visited = new bool[100]; +int pSize = 100; +/* Each row is a fixed p, variable q */ +int[] pValue = new int[100]; +bool[][] pqFlag = new bool[][100]; +int sum =0; + + /* initialize pqFlag */ + i = 0; + while(i < 100) { + pqFlag[i] = new bool[100]; + if (pIds[i] < 0) { pIds[i] = i; } + i = i + 1; + } + p = 0; + while(p < pSize){ + id = pIds[p]; + if(!visited[id % 100]){ + visited[id % 100] = true; + + row = p; /* "row" should be the dep */ + q = 0; + while (q < 99 && !pqFlag[row][q%100]){ + q = q+1; + } + if(q < 100){ + sum = sum + pValue[row]; + } + } + p = p + 1; + } + return sum; +} \ No newline at end of file diff --git a/benchmarks/global_commutativity/ps-dswp.vcy b/benchmarks/global_commutativity/ps-dswp.vcy new file mode 100644 index 0000000..e6ee16d --- /dev/null +++ b/benchmarks/global_commutativity/ps-dswp.vcy @@ -0,0 +1,43 @@ +commutativity { + +} + +int main(int argc, string[] argv) { + hashtable[string,int[]] p = new hashtable_seq[string,int[]]; + hashtable[string,int[]] q = new hashtable_seq[string,int[]]; + int[] visited = new int[10]; + int[] zero = new int[1]; + zero[0] = 0; + int sum = 0; + int id = 0; + p["id"] = new int[1]; + p["value"] = new int[1]; + p["inner_list"] = new int[10]; + q["next"] = new int[10]; + p["next"] = new int[10]; + q["flag"] = new int[1]; + p["size"] = new int[1]; + q["size"] = new int[1]; + int q_size = 0; + int q_flag = 0; + + + while(p["size"][0] != 0){ + id = p["id"]; + if(!visited[id]){ + visited[id] = true; + q = p["inner_list"]; + while (q["size"][0] != 0 && !q_flag){ + q = q["next"]; + } + if(q["size"][0] != 0){ + sum = sum + p["value"]; + } + } + p = p["next"]; + } + + return 0; +} + + diff --git a/benchmarks/global_commutativity/sec5.vcy b/benchmarks/global_commutativity/sec5.vcy new file mode 100644 index 0000000..1c4eca8 --- /dev/null +++ b/benchmarks/global_commutativity/sec5.vcy @@ -0,0 +1,12 @@ +commutativity { + {f(x)}, {g(xx,y)}: ( y > x + 1 ) +} + +int main(int argc, string[] argv) { + int x = int_of_string(argv[1]); + int y = int_of_string(argv[2]); + + f(x):{ x = x + 1; } + if (x 0) +} + +int main(int argc, string[] argv) { + int c = int_of_string(argv[1]); + int x = int_of_string(argv[1]); + int y = int_of_string(argv[1]); + + f1:{ + if( c>0 ) { c = c - 1; } + busy_wait(n); + x = 10; + } + + y = x; + busy_wait(n); + + f2:{ + c = c + 1; + busy_wait(n); + } + + return 0; +} \ No newline at end of file diff --git a/benchmarks/global_commutativity/simple_if.vcy b/benchmarks/global_commutativity/simple_if.vcy new file mode 100644 index 0000000..1994b8a --- /dev/null +++ b/benchmarks/global_commutativity/simple_if.vcy @@ -0,0 +1,17 @@ +commutativity { + +} + +int main(int argc, string[] argv) { + int x = 4; + if(x > 2) { + x = x - 1; + } + else{ + x = x + 1; + } + + return x; +} + + diff --git a/benchmarks/global_commutativity/simple_vector_while.vcy b/benchmarks/global_commutativity/simple_vector_while.vcy new file mode 100644 index 0000000..8d46cea --- /dev/null +++ b/benchmarks/global_commutativity/simple_vector_while.vcy @@ -0,0 +1,39 @@ +commutativity { + {f1(c)}, {f2(c)}: (true) +} + +int main(int argc, string[] argv) { + int size = 1000; + + int[] x = new int[size]; + int[] y = new int[size]; + int[] z = new int[size]; + int sum = 0; + int i = 0; int j = 0; int k = 0; int m = 0; + + while(i < size) { + x[i] = random(); + i = i + 1; + } + + f1:{ + while(j 0) && !(0 == z) || 0 == z); + {f4(i1)}, {f5(i2)}: (files[i2] == files[i1]); + {f4(i1)}, {f6(i3)}: (!(i3 == i1)); + {f1}, {f4(i1), f5(i2), f6(i3)}: (true) +} + + +int main(int argc, string[] argv) { + hashtable[int,int] tbl = new hashtable[int,int]; + int n = int_of_string(argv[1]); + int x = int_of_string(argv[2]); + int y = int_of_string(argv[3]); + int z = int_of_string(argv[4]); + int f = int_of_string(argv[5]); + int g = int_of_string(argv[6]); + + int[] files = new int[10]; + + tbl[x] = 12; + tbl[z] = 12; + + + f1:{ + busy_wait(n); + if(ht_mem(tbl, x)) { + y = ht_get(tbl, x); + } + } + f2: { + y = ht_get(tbl, z); + busy_wait(n); + } + f3: { + busy_wait(n); + if(ht_size(tbl) > 0) { + y = y + z; + } + } + {int i1 = int_of_string(argv[7]); + f4(i1):{ + busy_wait(n); + f = files[i1]; + f = f + 5; + files[i1] = f; + }} + {int i2 = int_of_string(argv[8]); + f5(i2):{ + f = files[i2]; + f = f + 5; + files[i2] = f; + busy_wait(n); + }} + {int i3 = int_of_string(argv[9]); + f6(i3):{ + g = files[i3]; + g = g + 5; + files[i3] = g; + busy_wait(n); + }} + + return 0; +} diff --git a/benchmarks/global_commutativity/vote-infer.vcy b/benchmarks/global_commutativity/vote-infer.vcy new file mode 100644 index 0000000..a7249c7 --- /dev/null +++ b/benchmarks/global_commutativity/vote-infer.vcy @@ -0,0 +1,88 @@ +/* +./vcy.exe infer ../benchmarks/global_commutativity/vote-infer.vcy --debug --prover cvc5 +*/ +commutativity { + {vote1(voterID_1,proposal_1)}, {vote2(voterID_2,proposal_2)}: _ +} + +hashtable[int,int] voter_weight = new hashtable_seq[int,int]; +hashtable[int,int] voter_voted = new hashtable_seq[int,int]; +hashtable[int,int] voter_vote = new hashtable_seq[int,int]; +hashtable[int,int] proposals = new hashtable_seq[int,int]; +int r_vote1 = 0; +int r_vote2 = 0; +int voterID = 0; +int proposal = 0; +int init = 1; +int voterID_1 = 0; +int proposal_1 = 0; +int voterID_2 = 0; +int proposal_2 = 0; + +int main(int argc, string[] argv) { + scalingfactor = int_of_string(argv[1]); + + /* https://docs.soliditylang.org/en/latest/solidity-by-example.html */ + vote1(voterID/*replicate*/, proposal):{ + r_vote1 = 0; + int weight = ht_get(voter_weight,voterID); + if (weight != 0) { + r_vote1 = -1; + } else { + int voted = ht_get(voter_voted,voterID); + if(voted == 1) { + r_vote1 = -1; + } else { + ht_put(voter_voted,voterID,init); + ht_put(voter_vote,voterID,proposal); + int curVotes = ht_get(proposals,proposal); + int value = curVotes + weight; + ht_put(proposals,proposal,value); + } + } +/* + Voter storage sender = voters[msg.sender]; + require(sender.weight != 0, "Has no right to vote"); + require(!sender.voted, "Already voted."); + sender.voted = true; + sender.vote = proposal; + + // If `proposal` is out of the range of the array, + // this will throw automatically and revert all + // changes. + proposals[proposal].voteCount += sender.weight; +*/ + } + + vote2(voterID,proposal):{ + r_vote2 = 0; + int weight = ht_get(voter_weight,voterID); + if (weight != 0) { + r_vote2 = -1; + } else { + int voted = ht_get(voter_voted,voterID); + if(voted == 1) { + r_vote2 = -1; + } else { + ht_put(voter_voted,voterID,init); + ht_put(voter_vote,voterID,proposal); + int curVotes = ht_get(proposals,proposal); + int value = curVotes + weight; + ht_put(proposals,proposal,value); + } + } +/* + Voter storage sender = voters[msg.sender]; + require(sender.weight != 0, "Has no right to vote"); + require(!sender.voted, "Already voted."); + sender.voted = true; + sender.vote = proposal; + + // If `proposal` is out of the range of the array, + // this will throw automatically and revert all + // changes. + proposals[proposal].voteCount += sender.weight; +*/ + } + +} diff --git a/benchmarks/global_commutativity/vote-infer2.vcy b/benchmarks/global_commutativity/vote-infer2.vcy new file mode 100644 index 0000000..863fe05 --- /dev/null +++ b/benchmarks/global_commutativity/vote-infer2.vcy @@ -0,0 +1,84 @@ +/* +./vcy.exe infer ../benchmarks/global_commutativity/vote-infer.vcy --debug --prover cvc5 +*/ +commutativity { + {vote1}, {vote2}: _ +} + +hashtable[int,int] voter_weight = new hashtable_seq[int,int]; +hashtable[int,int] voter_voted = new hashtable_seq[int,int]; +hashtable[int,int] voter_vote = new hashtable_seq[int,int]; +hashtable[int,int] proposals = new hashtable_seq[int,int]; +int r_vote1 = 0; +int r_vote2 = 0; +int voterID = 0; +int proposal = 0; +int init = 1; + +int main(int argc, string[] argv) { + scalingfactor = int_of_string(argv[1]); + + /* https://docs.soliditylang.org/en/latest/solidity-by-example.html */ + vote1(voterID/*replicate*/, proposal):{ + r_vote1 = 0; + int weight = ht_get(voter_weight,voterID); + if (weight != 0) { + r_vote1 = -1; + } else { + int voted = ht_get(voter_voted,voterID); + if(voted == 1) { + r_vote1 = -1; + } else { + ht_put(voter_voted,voterID,init); + ht_put(voter_vote,voterID,proposal); + int curVotes = ht_get(proposals,proposal); + int value = curVotes + weight; + ht_put(proposals,proposal,value); + } + } +/* + Voter storage sender = voters[msg.sender]; + require(sender.weight != 0, "Has no right to vote"); + require(!sender.voted, "Already voted."); + sender.voted = true; + sender.vote = proposal; + + // If `proposal` is out of the range of the array, + // this will throw automatically and revert all + // changes. + proposals[proposal].voteCount += sender.weight; +*/ + } + + vote2(voterID,proposal):{ + r_vote2 = 0; + int weight = ht_get(voter_weight,voterID); + if (weight != 0) { + r_vote2 = -1; + } else { + int voted = ht_get(voter_voted,voterID); + if(voted == 1) { + r_vote2 = -1; + } else { + ht_put(voter_voted,voterID,init); + ht_put(voter_vote,voterID,proposal); + int curVotes = ht_get(proposals,proposal); + int value = curVotes + weight; + ht_put(proposals,proposal,value); + } + } +/* + Voter storage sender = voters[msg.sender]; + require(sender.weight != 0, "Has no right to vote"); + require(!sender.voted, "Already voted."); + sender.voted = true; + sender.vote = proposal; + + // If `proposal` is out of the range of the array, + // this will throw automatically and revert all + // changes. + proposals[proposal].voteCount += sender.weight; +*/ + } + +} diff --git a/benchmarks/global_commutativity/vote-run-temp.vcy b/benchmarks/global_commutativity/vote-run-temp.vcy new file mode 100644 index 0000000..b49eb96 --- /dev/null +++ b/benchmarks/global_commutativity/vote-run-temp.vcy @@ -0,0 +1,55 @@ +commutativity { + {vote(voterID_1,proposal_1)}, {vote(voterID_2,proposal_2)}: (voterID_1 != voterID_2) +} + +/* Workload Config */ +int[] taskID_to_voterID = new int[] { 1, 1, 2, 2, 1, 2, 3, 1, 2}; /* mix of which voterID */ +int[] taskID_to_proposal = new int[] { 1, 2, 1, 2, 1, 2, 1, 2, 1}; /* mix of which weight */ + +hashtable[int,int] voter_weight = new hashtable_seq[int,int]; +hashtable[int,int] voter_voted = new hashtable_seq[int,int]; +hashtable[int,int] voter_vote = new hashtable_seq[int,int]; +int r_vote = 0; + +int main(int argc, string[] argv) { + int scalingfactor = int_of_string(argv[1]); + + int i = 0; + while(i None: + super().__init__(msg) + self.msg = msg + +def mk_files(n): + with open('A.txt', 'w') as f: + f.write('A' * n) + with open('B.txt', 'w') as f: + f.write('B' * n) + +seq_times = [] +par_times = [] +for n in n_values: + mk_files(mb * n) + + command_seq = [vcy_exe, 'interp', '--time', '--prover', 'cvc5', '--timeout', str(timeout), '--force-sequential', '../examples/io5.vcy'] + command_par = [vcy_exe, 'interp', '--time', '--prover', 'cvc5', '--timeout', str(timeout), '../examples/io5.vcy'] + + def f(command : List[str], floatize : bool): + popen = subprocess.Popen( + command, universal_newlines=True, + stdout=subprocess.PIPE, stderr=subprocess.PIPE, + env={'LD_LIBRARY_PATH':'../veracity/src'} + ) + out, err = popen.communicate() + if err: + raise VcyError(err) + try: + return float(out) if floatize else out + except TypeError: + raise TypeError(f'Output {out} could not be parsed into a float') + + seq_time = f(command_seq, True) + par_time = f(command_par, True) + + seq_times.append(seq_time) + par_times.append(par_time) + +with open(f'./iobench.csv', 'w') as file: + res1 = map(lambda l: map(str, l), [n_values, seq_times, par_times]) + res2 = map(','.join, res1) + file.write('\n'.join(res2)) diff --git a/reports/iobench.csv b/reports/iobench.csv new file mode 100644 index 0000000..b28a2d0 --- /dev/null +++ b/reports/iobench.csv @@ -0,0 +1,3 @@ +1,2,4,8,16,32,64,128 +0.005848,0.010599,0.020912,0.041674,0.081805,0.160105,0.316062,0.640375 +0.003683,0.007815,0.012266,0.024628,0.049473,0.089298,0.169974,0.334022 \ No newline at end of file diff --git a/reports/out-dswp-arran/par.csv b/reports/out-dswp-arran/par.csv new file mode 100644 index 0000000..dd37925 --- /dev/null +++ b/reports/out-dswp-arran/par.csv @@ -0,0 +1,22 @@ +N simple-vector 2d-array vote-run commset multi-blocks simple-io motivation +10 0.006525 0.004222 0.000141 0.000286 0.000156 0.022670 0.002734 +20 0.006485 0.004206 0.000107 0.000298 0.000181 0.022432 0.002732 +50 0.006556 0.004370 0.000101 0.000259 0.000186 0.022847 0.002695 +100 0.006316 0.004278 0.000132 0.000290 0.000231 0.022717 0.002612 +200 0.006417 0.004270 0.000155 0.000289 0.000275 0.022557 0.002802 +500 0.006587 0.004410 0.000307 0.000393 0.000455 0.023720 0.002646 +1000 0.006909 0.004698 0.000532 0.000329 0.000741 0.022607 0.002631 +2000 0.007055 0.004901 0.000976 0.000339 0.001525 0.023133 0.002878 +5000 0.008298 0.005875 0.001613 0.000538 0.003740 0.022776 0.002704 +10000 0.009569 0.007635 0.003451 0.000689 0.006679 0.023241 0.003576 +20000 0.012885 0.010846 0.006154 0.001098 0.012715 0.022902 0.002750 +50000 0.021902 0.021447 0.015531 0.002840 0.031359 0.022673 0.006717 +100000 0.036527 0.039399 0.030429 0.004967 0.061673 0.022535 0.010802 +200000 0.066850 0.075582 0.060894 0.009560 0.121736 0.022884 0.035758 +500000 0.161760 0.183218 0.151853 0.024548 0.303752 0.023529 0.046433 +1000000 0.308953 0.363771 0.303476 0.042402 0.606802 0.039841 0.091818 +2000000 0.611020 0.723761 0.606199 0.080899 1.212258 0.073108 0.182131 +5000000 1.527060 1.805309 1.517381 0.173305 3.036880 0.173495 0.456333 +10000000 3.028798 3.602733 3.033462 0.328008 6.067671 0.370779 0.908170 +20000000 6.072191 7.179116 6.078608 0.622341 12.138557 0.743236 1.824451 +50000000 15.157713 17.983973 15.152250 1.602191 30.241553 1.882894 4.543514 \ No newline at end of file diff --git a/reports/out-dswp-arran/ratio.csv b/reports/out-dswp-arran/ratio.csv new file mode 100644 index 0000000..0b602ab --- /dev/null +++ b/reports/out-dswp-arran/ratio.csv @@ -0,0 +1,22 @@ +N simple-vector 2d-array vote-run commset multi-blocks simple-io motivation +10 1.005720 3.055043 0.183802 1.414118 0.394633 1.094414 0.802667 +20 1.038399 3.065496 0.364216 1.397055 0.473686 1.104142 0.793017 +50 1.036840 2.935860 0.743942 1.582983 0.699837 1.083947 0.824721 +100 1.056505 3.147604 1.033892 1.442077 0.856942 1.073457 0.856842 +200 1.055863 3.403960 1.650751 1.337149 1.297324 1.071725 0.827691 +500 1.076657 3.277919 2.144354 1.157351 1.762930 1.017213 0.922382 +1000 1.066617 3.443073 2.404517 1.602848 2.077016 1.078450 1.041714 +2000 1.109353 3.877181 2.564222 1.890694 2.038580 1.081860 1.204217 +5000 1.183051 4.764265 3.830945 1.931327 2.067621 1.057169 1.929752 +10000 1.330900 5.639965 3.562120 3.076019 2.278078 1.094141 2.272224 +20000 1.460820 6.775134 3.961347 3.103135 2.410195 1.133002 5.260523 +50000 1.693060 7.594697 3.922222 2.429253 2.433271 1.225180 5.006604 +100000 1.848920 7.917513 3.985707 2.544950 2.469394 1.345323 5.862248 +200000 1.913286 8.091645 3.985258 2.499254 2.491274 1.447708 3.467570 +500000 1.916114 8.259358 3.994383 2.271539 2.493611 1.908425 6.571762 +1000000 1.985812 8.265958 3.994594 2.582185 2.494967 1.575586 6.643628 +2000000 1.991288 8.305776 3.994978 2.726461 2.497170 1.423676 6.691338 +5000000 1.999409 8.356606 4.004392 3.174219 2.585660 1.245556 6.662949 +10000000 2.005148 8.358806 4.128999 3.366182 2.492107 1.080284 6.681154 +20000000 1.992530 8.370057 3.993030 3.578381 2.500735 1.047635 6.653313 +50000000 1.997919 8.332041 3.997083 3.602340 2.500226 0.996901 6.650358 \ No newline at end of file diff --git a/reports/out-dswp-arran/seq.csv b/reports/out-dswp-arran/seq.csv new file mode 100644 index 0000000..c0d33a3 --- /dev/null +++ b/reports/out-dswp-arran/seq.csv @@ -0,0 +1,22 @@ +N simple-vector 2d-array vote-run commset multi-blocks simple-io motivation +10 0.006552 0.012899 0.000026 0.000403 0.000062 0.024810 0.002193 +20 0.006734 0.012890 0.000039 0.000415 0.000086 0.024769 0.002166 +50 0.006794 0.012831 0.000074 0.000410 0.000131 0.024796 0.002221 +100 0.006673 0.013464 0.000135 0.000418 0.000198 0.024403 0.002238 +200 0.006775 0.014573 0.000255 0.000385 0.000356 0.024169 0.002318 +500 0.007090 0.014456 0.000640 0.000454 0.000803 0.024134 0.002440 +1000 0.007366 0.016173 0.001233 0.000527 0.001539 0.024392 0.002740 +2000 0.007827 0.019001 0.002483 0.000641 0.003082 0.025042 0.003455 +5000 0.009798 0.027990 0.006177 0.001037 0.007731 0.024072 0.005218 +10000 0.012734 0.043040 0.012241 0.002119 0.015214 0.025424 0.008062 +20000 0.018821 0.073478 0.024378 0.003397 0.030644 0.025968 0.014457 +50000 0.037072 0.162880 0.060908 0.006894 0.076304 0.027796 0.032865 +100000 0.067535 0.311934 0.121279 0.012635 0.152297 0.030321 0.063029 +200000 0.127902 0.611587 0.242679 0.023891 0.303277 0.033148 0.123937 +500000 0.309859 1.513260 0.606559 0.055657 0.757440 0.044889 0.305146 +1000000 0.613526 3.006916 1.212263 0.109421 1.513951 0.062773 0.609997 +2000000 1.216716 6.011401 2.421749 0.220500 3.027195 0.104080 1.218703 +5000000 3.053217 15.086258 6.076177 0.550102 7.856965 0.215838 3.040491 +10000000 6.073175 30.114738 12.534773 1.104129 15.121365 0.400548 6.067614 +20000000 12.099021 60.089693 24.272076 2.225502 30.355339 0.778647 12.138638 +50000000 30.283914 149.843451 60.564746 5.771593 75.610855 1.877034 30.216011 \ No newline at end of file diff --git a/reports/out-dswp-arran/speedup-plot.png b/reports/out-dswp-arran/speedup-plot.png new file mode 100644 index 0000000..1b1b63e Binary files /dev/null and b/reports/out-dswp-arran/speedup-plot.png differ diff --git a/reports/out-dswp-comparison-all/2d-array-comparison.png b/reports/out-dswp-comparison-all/2d-array-comparison.png new file mode 100644 index 0000000..865bd42 Binary files /dev/null and b/reports/out-dswp-comparison-all/2d-array-comparison.png differ diff --git a/reports/out-dswp-comparison-all/commset-comparison.png b/reports/out-dswp-comparison-all/commset-comparison.png new file mode 100644 index 0000000..255c105 Binary files /dev/null and b/reports/out-dswp-comparison-all/commset-comparison.png differ diff --git a/reports/out-dswp-comparison-all/motivation-comparison.png b/reports/out-dswp-comparison-all/motivation-comparison.png new file mode 100644 index 0000000..e5e47fa Binary files /dev/null and b/reports/out-dswp-comparison-all/motivation-comparison.png differ diff --git a/reports/out-dswp-comparison-all/multi-blocks-comparison.png b/reports/out-dswp-comparison-all/multi-blocks-comparison.png new file mode 100644 index 0000000..45b3a98 Binary files /dev/null and b/reports/out-dswp-comparison-all/multi-blocks-comparison.png differ diff --git a/reports/out-dswp-comparison-all/simple-io-comparison.png b/reports/out-dswp-comparison-all/simple-io-comparison.png new file mode 100644 index 0000000..762a73a Binary files /dev/null and b/reports/out-dswp-comparison-all/simple-io-comparison.png differ diff --git a/reports/out-dswp-comparison-all/simple-vector-comparison.png b/reports/out-dswp-comparison-all/simple-vector-comparison.png new file mode 100644 index 0000000..fd830d7 Binary files /dev/null and b/reports/out-dswp-comparison-all/simple-vector-comparison.png differ diff --git a/reports/out-dswp-comparison-all/vote-run-comparison.png b/reports/out-dswp-comparison-all/vote-run-comparison.png new file mode 100644 index 0000000..350c129 Binary files /dev/null and b/reports/out-dswp-comparison-all/vote-run-comparison.png differ diff --git a/reports/out-dswp-comparison/2d-array-comparison.png b/reports/out-dswp-comparison/2d-array-comparison.png new file mode 100644 index 0000000..5f033b3 Binary files /dev/null and b/reports/out-dswp-comparison/2d-array-comparison.png differ diff --git a/reports/out-dswp-comparison/commset-comparison.png b/reports/out-dswp-comparison/commset-comparison.png new file mode 100644 index 0000000..a41331d Binary files /dev/null and b/reports/out-dswp-comparison/commset-comparison.png differ diff --git a/reports/out-dswp-comparison/motivation-comparison.png b/reports/out-dswp-comparison/motivation-comparison.png new file mode 100644 index 0000000..567f50d Binary files /dev/null and b/reports/out-dswp-comparison/motivation-comparison.png differ diff --git a/reports/out-dswp-comparison/multi-blocks-comparison.png b/reports/out-dswp-comparison/multi-blocks-comparison.png new file mode 100644 index 0000000..c865d53 Binary files /dev/null and b/reports/out-dswp-comparison/multi-blocks-comparison.png differ diff --git a/reports/out-dswp-comparison/simple-io-comparison.png b/reports/out-dswp-comparison/simple-io-comparison.png new file mode 100644 index 0000000..594829b Binary files /dev/null and b/reports/out-dswp-comparison/simple-io-comparison.png differ diff --git a/reports/out-dswp-comparison/simple-vector-comparison.png b/reports/out-dswp-comparison/simple-vector-comparison.png new file mode 100644 index 0000000..207a13c Binary files /dev/null and b/reports/out-dswp-comparison/simple-vector-comparison.png differ diff --git a/reports/out-dswp-comparison/vote-run-comparison.png b/reports/out-dswp-comparison/vote-run-comparison.png new file mode 100644 index 0000000..1e11d0a Binary files /dev/null and b/reports/out-dswp-comparison/vote-run-comparison.png differ diff --git a/reports/out-dswp-nc/par.csv b/reports/out-dswp-nc/par.csv new file mode 100644 index 0000000..039506a --- /dev/null +++ b/reports/out-dswp-nc/par.csv @@ -0,0 +1,22 @@ +N simple-vector 2d-array vote-run commset multi-blocks simple-io motivation +10 0.007066 0.004394 0.000146 0.000701 0.000189 0.023276 0.002732 +20 0.007057 0.004297 0.000171 0.000651 0.000201 0.023675 0.002708 +50 0.007038 0.004341 0.000177 0.000609 0.000309 0.023576 0.002605 +100 0.007555 0.004405 0.000240 0.000770 0.000345 0.024796 0.002542 +200 0.007421 0.004572 0.000380 0.000655 0.000708 0.026468 0.002598 +500 0.007848 0.004676 0.000801 0.000782 0.001412 0.027377 0.002768 +1000 0.008136 0.004732 0.001348 0.000869 0.002048 0.026740 0.003152 +2000 0.008694 0.005169 0.002542 0.000795 0.003644 0.026971 0.002875 +5000 0.010400 0.006160 0.006134 0.001420 0.008094 0.026755 0.003865 +10000 0.013401 0.007707 0.012308 0.002015 0.015673 0.027440 0.007147 +20000 0.019384 0.011192 0.025230 0.003472 0.030998 0.027638 0.013001 +50000 0.037638 0.021700 0.061406 0.007844 0.076619 0.029657 0.031099 +100000 0.067739 0.039650 0.122245 0.014010 0.152341 0.031177 0.062394 +200000 0.128592 0.075466 0.243146 0.025147 0.304567 0.035899 0.124005 +500000 0.310586 0.183258 0.608442 0.061017 0.761793 0.047522 0.305541 +1000000 0.615873 0.363376 1.215308 0.117329 1.519049 0.066241 0.610592 +2000000 1.219602 0.722723 2.420854 0.220626 3.029087 0.096195 1.213450 +5000000 3.040494 1.806090 6.078956 0.561738 7.593189 0.208412 3.038873 +10000000 6.086432 3.607533 12.131667 1.108659 15.193943 0.396184 6.083822 +20000000 12.146929 7.215633 24.248199 2.211806 30.293734 0.756234 12.103854 +50000000 30.356497 17.936506 60.615521 5.819885 75.767368 1.932254 30.389123 \ No newline at end of file diff --git a/reports/out-dswp-nc/ratio.csv b/reports/out-dswp-nc/ratio.csv new file mode 100644 index 0000000..0f8c54c --- /dev/null +++ b/reports/out-dswp-nc/ratio.csv @@ -0,0 +1,22 @@ +N simple-vector 2d-array vote-run commset multi-blocks simple-io motivation +10 0.922648 2.977643 0.187710 0.531971 0.356918 1.050937 0.792090 +20 0.923459 3.040381 0.219658 0.615859 0.363312 1.057708 0.808845 +50 0.968445 2.964600 0.430597 0.652419 0.423330 1.047319 0.848623 +100 0.901749 3.093389 0.568059 0.532180 0.603099 1.152817 0.865616 +200 0.903806 2.947951 0.675753 0.666550 0.526068 1.091745 0.879710 +500 0.883545 3.098016 0.771210 0.592205 0.573944 1.057732 0.904487 +1000 0.902328 3.404243 0.913157 0.576154 0.764669 1.069314 0.877937 +2000 0.902763 3.669503 0.960474 0.826289 0.846157 1.060425 1.168804 +5000 0.941158 4.567665 0.993384 0.723626 0.950264 1.075136 1.352216 +10000 0.955876 5.610300 0.994394 1.068865 0.978436 1.061360 1.165338 +20000 0.981553 6.564244 0.974206 0.954582 0.987265 1.068219 1.106567 +50000 0.992294 7.564626 0.994221 0.889787 0.997041 1.058422 1.050000 +100000 0.998357 7.913680 0.997531 0.905535 1.007077 1.090039 1.015378 +200000 0.998356 8.156458 1.000307 0.945826 0.997755 1.070623 0.997346 +500000 0.999102 8.280113 0.998958 0.920246 0.994506 1.043432 1.003072 +1000000 0.997640 8.620180 1.000460 0.925212 1.001999 1.032978 0.994605 +2000000 0.997660 8.335462 1.000569 0.993060 0.999230 1.033792 0.999950 +5000000 0.998232 8.320130 0.998657 0.981005 1.000087 1.028585 0.999533 +10000000 0.997263 8.332749 1.000062 0.994697 0.998906 1.008918 0.997864 +20000000 1.000798 8.294713 0.996833 0.992920 0.997829 1.008555 1.000512 +50000000 0.999199 8.381798 0.997926 0.995670 1.005700 1.011901 0.997224 \ No newline at end of file diff --git a/reports/out-dswp-nc/seq.csv b/reports/out-dswp-nc/seq.csv new file mode 100644 index 0000000..e7f66c5 --- /dev/null +++ b/reports/out-dswp-nc/seq.csv @@ -0,0 +1,22 @@ +N simple-vector 2d-array vote-run commset multi-blocks simple-io motivation +10 0.006519 0.013085 0.000027 0.000373 0.000067 0.024477 0.002163 +20 0.006505 0.013066 0.000038 0.000401 0.000073 0.025047 0.002190 +50 0.006799 0.012870 0.000076 0.000395 0.000131 0.024700 0.002209 +100 0.006812 0.013626 0.000136 0.000408 0.000208 0.028723 0.002201 +200 0.006707 0.013475 0.000257 0.000434 0.000354 0.028918 0.002286 +500 0.006934 0.014483 0.000615 0.000463 0.000808 0.029000 0.002504 +1000 0.007342 0.016109 0.001231 0.000500 0.001567 0.028628 0.002746 +2000 0.007848 0.018970 0.002442 0.000656 0.003083 0.028612 0.003359 +5000 0.009788 0.028138 0.006093 0.001025 0.007692 0.028780 0.005226 +10000 0.012809 0.043238 0.012239 0.002152 0.015336 0.029143 0.008324 +20000 0.019027 0.073454 0.024574 0.003311 0.030603 0.029572 0.014386 +50000 0.037348 0.164152 0.061051 0.006979 0.076390 0.031396 0.032654 +100000 0.067628 0.313777 0.121942 0.012687 0.153423 0.033995 0.063354 +200000 0.128381 0.615540 0.243221 0.023784 0.303882 0.038438 0.123670 +500000 0.310306 1.517392 0.607808 0.056103 0.757613 0.049598 0.306480 +1000000 0.614421 3.134393 1.215867 0.108547 1.522085 0.068424 0.607296 +2000000 1.216744 6.024236 2.422230 0.219017 3.026755 0.099446 1.213391 +5000000 3.035132 15.026905 6.070790 0.551052 7.593848 0.214366 3.037454 +10000000 6.069793 30.060655 12.132420 1.102787 15.177319 0.399717 6.070834 +20000000 12.156617 59.851661 24.171410 2.196140 30.227980 0.762706 12.110057 +50000000 30.332338 150.340233 60.490371 5.794626 76.199258 1.955360 30.304769 \ No newline at end of file diff --git a/reports/out-dswp-nc/speedup-plot.png b/reports/out-dswp-nc/speedup-plot.png new file mode 100644 index 0000000..9c3d32b Binary files /dev/null and b/reports/out-dswp-nc/speedup-plot.png differ diff --git a/reports/out-dswp-noNB/par.csv b/reports/out-dswp-noNB/par.csv new file mode 100644 index 0000000..025ef85 --- /dev/null +++ b/reports/out-dswp-noNB/par.csv @@ -0,0 +1,22 @@ +N simple-vector 2d-array vote-run commset multi-blocks simple-io motivation +10 0.006396 0.004315 0.000443 0.000543 0.000092 0.023698 0.002646 +20 0.006409 0.004377 0.000401 0.000572 0.000105 0.023349 0.002682 +50 0.006679 0.004368 0.000460 0.000568 0.000116 0.023799 0.002711 +100 0.006709 0.004361 0.000512 0.000553 0.000155 0.023883 0.002727 +200 0.007037 0.004502 0.000633 0.000604 0.000294 0.023658 0.002795 +500 0.006589 0.004599 0.000978 0.000618 0.000535 0.023815 0.003035 +1000 0.006667 0.004764 0.001573 0.000746 0.000974 0.023833 0.003230 +2000 0.007079 0.005123 0.002804 0.000816 0.001854 0.024245 0.003855 +5000 0.007869 0.006008 0.006485 0.001259 0.004790 0.024961 0.005677 +10000 0.009442 0.007719 0.012601 0.001874 0.009404 0.024963 0.008837 +20000 0.012524 0.011112 0.024932 0.003656 0.018918 0.024518 0.014967 +50000 0.021759 0.021843 0.061606 0.007491 0.046202 0.026600 0.032999 +100000 0.036850 0.039733 0.121837 0.013096 0.091805 0.028680 0.063417 +200000 0.066728 0.075041 0.243269 0.024896 0.182623 0.032959 0.123923 +500000 0.157463 0.186493 0.608254 0.058067 0.459701 0.044558 0.306145 +1000000 0.309503 0.363537 1.216174 0.110560 0.913619 0.068004 0.610839 +2000000 0.613248 0.722724 2.435543 0.220130 1.820547 0.101972 1.215844 +5000000 1.576377 1.806632 6.077488 0.538884 4.549409 0.216031 3.047423 +10000000 3.038031 3.609395 12.120362 1.092433 9.109762 0.390954 6.087919 +20000000 6.059718 7.197111 24.238120 2.200712 18.207041 0.758497 12.134324 +50000000 15.141951 17.974727 60.583216 5.804106 46.120359 1.928761 30.344641 \ No newline at end of file diff --git a/reports/out-dswp-noNB/ratio.csv b/reports/out-dswp-noNB/ratio.csv new file mode 100644 index 0000000..b591572 --- /dev/null +++ b/reports/out-dswp-noNB/ratio.csv @@ -0,0 +1,22 @@ +N simple-vector 2d-array vote-run commset multi-blocks simple-io motivation +10 1.028921 2.954145 0.063115 0.716982 0.844558 1.043373 0.817082 +20 1.044731 2.950043 0.097380 0.702039 0.773160 1.064765 0.800821 +50 1.007899 3.024929 0.170756 0.682813 1.108054 1.016663 0.797252 +100 1.008370 3.078021 0.263726 0.757803 1.355160 1.058177 0.770210 +200 0.989433 3.058042 0.414103 0.667007 1.226919 1.053629 0.812166 +500 1.054746 3.150483 0.635406 0.684888 1.501749 1.029280 0.792071 +1000 1.112289 3.387262 0.772151 0.744612 1.622884 1.022200 0.866893 +2000 1.112069 3.702559 0.870895 0.800180 1.665145 1.017309 0.847041 +5000 1.251283 4.682382 0.947262 0.810141 1.612631 1.020845 0.920173 +10000 1.364053 5.580435 0.970799 1.158386 1.620602 0.996486 0.938657 +20000 1.515118 6.609763 0.988169 0.905256 1.617854 1.032760 0.967427 +50000 1.715127 7.465146 0.987613 0.918986 1.652750 1.027258 0.995686 +100000 1.844803 7.850214 0.998896 0.971657 1.659543 1.028225 0.995356 +200000 1.921420 8.187051 0.997849 0.957442 1.661220 1.021353 1.001190 +500000 1.971691 8.089966 0.994961 0.959941 1.649311 1.002865 0.997470 +1000000 1.980317 8.286532 0.994949 0.982467 1.667468 0.997821 1.000801 +2000000 1.997187 8.298520 0.993667 1.000600 1.666458 1.043340 1.002828 +5000000 1.933192 8.339171 0.999418 1.036792 1.664903 1.077262 0.995964 +10000000 1.991930 8.375134 0.999938 1.010362 1.657735 1.025552 0.992394 +20000000 1.995160 8.323265 1.000044 1.003194 1.664251 1.011435 1.041139 +50000000 2.008729 8.346863 0.999670 1.002140 1.644152 1.028480 0.997378 \ No newline at end of file diff --git a/reports/out-dswp-noNB/seq.csv b/reports/out-dswp-noNB/seq.csv new file mode 100644 index 0000000..03dd29a --- /dev/null +++ b/reports/out-dswp-noNB/seq.csv @@ -0,0 +1,22 @@ +N simple-vector 2d-array vote-run commset multi-blocks simple-io motivation +10 0.006580 0.012747 0.000028 0.000390 0.000078 0.024726 0.002162 +20 0.006694 0.012911 0.000039 0.000402 0.000081 0.024871 0.002148 +50 0.006726 0.013213 0.000079 0.000388 0.000128 0.024197 0.002161 +100 0.006753 0.013425 0.000135 0.000419 0.000210 0.025278 0.002104 +200 0.006943 0.013768 0.000262 0.000403 0.000357 0.024927 0.002270 +500 0.006950 0.014488 0.000621 0.000424 0.000802 0.024516 0.002404 +1000 0.007416 0.016136 0.001214 0.000558 0.001581 0.024373 0.002799 +2000 0.007872 0.018970 0.002443 0.000653 0.003087 0.024682 0.003267 +5000 0.009848 0.028125 0.006143 0.001020 0.007715 0.025501 0.005223 +10000 0.012881 0.043076 0.012234 0.002171 0.015236 0.024869 0.008295 +20000 0.018975 0.073444 0.024636 0.003309 0.030608 0.025329 0.014479 +50000 0.037318 0.163057 0.060842 0.006884 0.076362 0.027334 0.032855 +100000 0.067981 0.311908 0.121702 0.012724 0.152355 0.029499 0.063123 +200000 0.128213 0.614360 0.242746 0.023837 0.303376 0.033677 0.124071 +500000 0.310466 1.508487 0.605191 0.055740 0.758152 0.044695 0.305369 +1000000 0.612915 3.012461 1.210031 0.108622 1.523426 0.067838 0.611328 +2000000 1.224767 5.997615 2.420134 0.220253 3.033866 0.106397 1.219283 +5000000 3.047028 15.065838 6.073924 0.558766 7.574321 0.233241 3.035131 +10000000 6.051551 30.230175 12.119617 1.103754 15.101552 0.400948 6.041619 +20000000 12.090107 59.903435 24.239179 2.207746 30.300960 0.767174 12.644576 +50000000 30.416330 150.032501 60.563184 5.816851 75.821484 1.986348 30.265042 \ No newline at end of file diff --git a/reports/out-dswp/par.csv b/reports/out-dswp/par.csv new file mode 100644 index 0000000..fa06778 --- /dev/null +++ b/reports/out-dswp/par.csv @@ -0,0 +1,22 @@ +N simple-vector 2d-array vote-run commset multi-blocks simple-io motivation +10 0.031094 0.166660 0.000620 0.001405 0.001252 1.368430 9.442882 +20 0.033957 0.170092 0.001285 0.002009 0.001102 1.339687 9.387664 +50 0.030207 0.001234 0.001444 1.331247 9.273303 +100 0.018961 0.147845 0.001306 0.001412 1.311152 9.870524 +200 0.029245 0.153834 0.001039 0.001151 1.326046 9.546388 +500 0.022788 0.160154 0.002885 0.001207 1.340957 9.425082 +1000 0.030675 0.162810 0.004724 0.002219 0.002086 1.310382 8.753034 +2000 0.038723 0.150828 0.006413 0.001386 0.002821 1.343663 9.578245 +5000 0.041861 0.135734 0.007321 0.001730 1.353002 9.559100 +10000 0.033901 0.177346 0.009421 0.001994 0.014449 1.345797 9.536951 +20000 0.045120 0.143335 0.018418 0.003555 0.027731 1.366545 9.526939 +50000 0.071459 0.202987 0.047471 0.023666 0.054133 1.438233 9.429649 +100000 0.111421 0.212016 0.073060 0.040373 0.109440 1.491652 9.911035 +200000 0.224251 0.332703 0.133594 0.035342 0.194975 1.700791 9.596798 +500000 0.524816 0.737156 0.379598 0.101452 0.505574 1.992418 9.790221 +1000000 1.052160 1.743617 0.903893 0.131137 0.910299 2.707049 9.616450 +2000000 1.972772 2.824781 1.217987 0.301413 1.825055 4.160201 9.810242 +5000000 4.979330 6.953911 3.354682 0.563404 4.865426 8.634259 9.784047 +10000000 9.813222 14.244435 6.664444 0.981692 8.968115 16.549393 9.365898 +20000000 19.795354 27.970291 14.265841 1.628845 17.814943 30.754191 9.636252 +50000000 48.691534 69.149627 31.076230 3.449848 41.625010 57.725532 10.514719 \ No newline at end of file diff --git a/reports/out-dswp/ratio.csv b/reports/out-dswp/ratio.csv new file mode 100644 index 0000000..e636cc5 --- /dev/null +++ b/reports/out-dswp/ratio.csv @@ -0,0 +1,22 @@ +N simple-vector 2d-array vote-run commset multi-blocks simple-io motivation +10 0.167286 0.055456 0.079701 0.430437 0.162523 0.966066 0.000597 +20 0.170883 0.057718 0.095150 0.269097 0.235298 0.981247 0.000545 +50 0.186668 0.088486 0.495002 0.980090 0.000593 +100 0.287313 0.090026 0.154350 0.579891 0.990895 0.000532 +200 0.240113 0.069363 0.439415 0.550541 0.995908 0.000557 +500 0.258190 0.072665 0.576417 0.643327 0.977811 0.000554 +1000 0.237772 0.097576 0.622971 0.284054 1.394100 1.005476 0.000820 +2000 0.255005 0.155856 0.615639 0.610182 2.186601 1.025348 0.000545 +5000 0.363119 0.270014 1.250703 0.769003 0.978669 0.000578 +10000 0.622236 0.345427 2.021740 1.082943 2.184668 0.993521 0.000653 +20000 0.830025 0.744735 2.432828 1.051194 2.068466 0.979153 0.000590 +50000 1.067692 1.243553 1.995083 0.345931 2.548951 0.955487 0.000626 +100000 1.296691 2.198538 2.595492 0.238385 2.665459 0.987606 0.000614 +200000 1.302459 2.730567 2.759219 0.589839 2.765940 0.945881 0.000653 +500000 1.354251 3.107900 2.581988 0.506345 2.799983 0.973343 0.000578 +1000000 1.350043 3.007897 2.078048 0.655224 2.982196 0.959041 0.000653 +2000000 1.402772 3.224738 3.055493 0.583637 3.031774 0.979568 0.000865 +5000000 1.388295 3.245972 2.754440 0.779155 2.858142 1.065803 0.001062 +10000000 1.418381 3.182387 2.768108 0.879120 3.080682 1.201800 0.001666 +20000000 1.403734 3.233876 2.579020 1.059035 3.065822 1.729109 0.002654 +50000000 1.421873 3.271189 2.881577 1.324206 3.211938 1.828071 0.005111 \ No newline at end of file diff --git a/reports/out-dswp/seq.csv b/reports/out-dswp/seq.csv new file mode 100644 index 0000000..96413a5 --- /dev/null +++ b/reports/out-dswp/seq.csv @@ -0,0 +1,22 @@ +N simple-vector 2d-array vote-run commset multi-blocks simple-io motivation +10 0.004963 0.009195 0.000034 0.000577 0.000102 1.320204 0.005651 +20 0.005479 0.009419 0.000054 0.000527 0.000148 1.314343 0.005109 +50 0.005588 0.000102 0.000480 1.304723 0.005517 +100 0.005249 0.014187 0.000195 0.000557 1.299226 0.005255 +200 0.006382 0.010691 0.000462 0.000477 1.320620 0.005318 +500 0.005728 0.011612 0.001297 0.000650 1.311115 0.005223 +1000 0.006825 0.014736 0.002430 0.000606 0.002881 1.317564 0.007919 +2000 0.008644 0.023738 0.003643 0.000818 0.006115 1.377693 0.005216 +5000 0.013459 0.036272 0.008892 0.001069 1.324150 0.005525 +10000 0.020336 0.060328 0.018739 0.002029 0.031453 1.337044 0.006416 +20000 0.037279 0.104639 0.040869 0.003303 0.057265 1.337767 0.005638 +50000 0.076178 0.250596 0.094036 0.005737 0.137595 1.374221 0.005974 +100000 0.144404 0.464809 0.183001 0.009571 0.291650 1.473136 0.006175 +200000 0.291940 0.907967 0.365577 0.018169 0.538371 1.608173 0.006331 +500000 0.710276 2.287611 0.957241 0.044906 1.389880 1.938815 0.005658 +1000000 1.419155 5.191278 1.862217 0.084220 2.711487 2.595764 0.006277 +2000000 2.766176 9.109622 3.693134 0.171853 5.533623 4.074363 0.008773 +5000000 6.905302 22.570261 9.195165 0.437593 13.812313 9.196538 0.010400 +10000000 13.913124 45.329860 18.345108 0.852294 27.621126 19.897101 0.015682 +20000000 27.782348 90.451892 36.791036 1.718066 54.599307 54.994685 0.025568 +50000000 69.233559 226.108491 89.001458 4.548415 133.686586 105.835944 0.053728 \ No newline at end of file diff --git a/reports/out-dswp/speedup-plot.png b/reports/out-dswp/speedup-plot.png new file mode 100644 index 0000000..49422a6 Binary files /dev/null and b/reports/out-dswp/speedup-plot.png differ diff --git a/reports/plots-noNB/2d-array-comparison.png b/reports/plots-noNB/2d-array-comparison.png new file mode 100644 index 0000000..0d39f41 Binary files /dev/null and b/reports/plots-noNB/2d-array-comparison.png differ diff --git a/reports/plots-noNB/commset-comparison.png b/reports/plots-noNB/commset-comparison.png new file mode 100644 index 0000000..aadd1ba Binary files /dev/null and b/reports/plots-noNB/commset-comparison.png differ diff --git a/reports/plots-noNB/motivation-comparison.png b/reports/plots-noNB/motivation-comparison.png new file mode 100644 index 0000000..2e525ea Binary files /dev/null and b/reports/plots-noNB/motivation-comparison.png differ diff --git a/reports/plots-noNB/multi-blocks-comparison.png b/reports/plots-noNB/multi-blocks-comparison.png new file mode 100644 index 0000000..fa3a690 Binary files /dev/null and b/reports/plots-noNB/multi-blocks-comparison.png differ diff --git a/reports/plots-noNB/simple-io-comparison.png b/reports/plots-noNB/simple-io-comparison.png new file mode 100644 index 0000000..ce8e353 Binary files /dev/null and b/reports/plots-noNB/simple-io-comparison.png differ diff --git a/reports/plots-noNB/simple-vector-comparison.png b/reports/plots-noNB/simple-vector-comparison.png new file mode 100644 index 0000000..a7a9b44 Binary files /dev/null and b/reports/plots-noNB/simple-vector-comparison.png differ diff --git a/reports/plots-noNB/vote-run-comparison.png b/reports/plots-noNB/vote-run-comparison.png new file mode 100644 index 0000000..fb01a33 Binary files /dev/null and b/reports/plots-noNB/vote-run-comparison.png differ diff --git a/reports/speedup_dswp.py b/reports/speedup_dswp.py new file mode 100755 index 0000000..56b95ff --- /dev/null +++ b/reports/speedup_dswp.py @@ -0,0 +1,175 @@ +#!/usr/bin/env python3 + +# Invoke with: python3 ./speedup_dswp.py out-dswp-results-dir +# The directory will be created if it doesn't exist, +# and 3 CSV files will be generated inside the directory + +from posixpath import join +from pathlib import Path +import subprocess +import sys, os +from typing import Tuple, List, Callable +import functools + +Benchmark = Tuple[str, Callable[[int],List[str]]] +Data = Tuple[float, float] +Result = Tuple[Benchmark, Data] +Row = Tuple[int, List[float]] + +os.chdir(os.path.dirname(sys.argv[0])) + +vcy_exe = '../src/vcy.exe' + +dir = '' +num_trials = 0 + +class VcyError(Exception): + def __init__(self, msg) -> None: + super().__init__(msg) + self.msg = msg + +n_values = [ + 1e1, 2e1, 5e1, + 1e2, 2e2, 5e2, + 1e3, 2e3, 5e3, + 1e4, 2e4, 5e4, + 1e5, 2e5, 5e5, + 1e6, 2e6, 5e6, + 1e7, 2e7, 5e7, + # 1e8 +] + +timeout = 5 + +def mean(values): + return sum(values) / len(values) + +def geo_mean(values): + return functools.reduce(lambda x,y: x * y, values, 1) ** (1 / len(values)) + +def prep_commset(n): + with open("a.txt", "w") as f: + f.write("A"*(n)) + with open("b.txt", "w") as f: + f.write("B"*(n)) + with open("c.txt", "w") as f: + f.write("C"*(n)) + with open("d.txt", "w") as f: + f.write("D"*(n)) + return [os.path.join(os.path.dirname(sys.argv[0]), "a.txt"), os.path.join(os.path.dirname(sys.argv[0]), "b.txt"), os.path.join(os.path.dirname(sys.argv[0]), "c.txt"), os.path.join(os.path.dirname(sys.argv[0]), "d.txt")] + +def prep_simpleio(n): + with open("a.txt", "w") as f: + f.write("A") + with open("b.txt", "w") as f: + f.write("B"*(n)) + with open("c.txt", "w") as f: + f.write("C"*(n)) + with open("d.txt", "w") as f: + f.write("D"*(n)) + return [os.path.join(os.path.dirname(sys.argv[0]), "a.txt"), os.path.join(os.path.dirname(sys.argv[0]), "b.txt"), os.path.join(os.path.dirname(sys.argv[0]), "c.txt"), os.path.join(os.path.dirname(sys.argv[0]), "d.txt")] + +# Program name, followed by any command line arguments +benchmarks : List[Benchmark] = [ + ("benchmarks/global_commutativity/simple-vector.vcy", lambda n : [str(n)]), + ("benchmarks/global_commutativity/2d-array.vcy", lambda n : [str(n)]), + ("benchmarks/global_commutativity/vote-run.vcy", lambda n : [str(n)]), + ("benchmarks/global_commutativity/commset.vcy", prep_commset), + ("benchmarks/global_commutativity/multi-blocks.vcy", lambda n : [str(n)]), + ("benchmarks/global_commutativity/simple-io.vcy", prep_simpleio), + ("benchmarks/global_commutativity/motivation.vcy", lambda n : [str(n * 100), "10"]) +] + + +def run_benchmark(index : int, n : int, b : Benchmark) -> Result: + prog,fargs = b + args = fargs(n) + + command_seq = [vcy_exe, 'interp', '--time', '--timeout', str(timeout), '../' + prog] + args # TODO: More time for inference? + command_par = [vcy_exe, 'interp', '--time', '--dswp', '--timeout', str(timeout), '../' + prog] + args + + def f(command : List[str], floatize : bool): + popen = subprocess.Popen( + command, universal_newlines=True, + stdout=subprocess.PIPE, stderr=subprocess.PIPE, + env={'LD_LIBRARY_PATH':'../veracity/src'} + ) + out, err = popen.communicate() + if err: + raise VcyError(err) + try: + return float(out) if floatize else out + except TypeError: + raise TypeError(f'Output {out} could not be parsed into a float') + + sys.stdout.write(f'{(index+1):#2d}/{len(benchmarks) * len(n_values)} Executing {prog} in sequence... ') + sys.stdout.flush() + seq_time = f(command_seq, True) + + sys.stdout.write(f'Done. Now in DSWP mode... ') + sys.stdout.flush() + par_time = f(command_par, True) + + sys.stdout.write(f'Done.\n') + sys.stdout.flush() + return b, (float(seq_time), float(par_time)) + +def line_of_row(r : Row) -> str: + n, l = r + return f'{n}\t' + '\t'.join(f'{v:#.6f}' if v != None else '' for v in l) + +def mk_table_start(): + return 'N\t' + '\t'.join(Path(s).stem for (s,_) in benchmarks) + +def build_table(rs : List[Row]) -> str: + rows = "\n".join(map(line_of_row, rs)) + return mk_table_start() + '\n' + rows + +def build_file(): + results_ratio : List[Row] = [] + results_seq : List[Row] = [] + results_par : List[Row] = [] + for i, n in enumerate(map(int, n_values)): + row_ratio = [] + row_seq = [] + row_par = [] + for j, b in enumerate(benchmarks): + try: + test_seq = [] + test_par = [] + test_ratio = [] + for _ in range(num_trials): + _, (seq, par) = run_benchmark(j + i * len(benchmarks), n, b) + test_seq.append(seq) + test_par.append(par) + test_ratio.append(seq / par) + row_seq.append(mean(test_seq)) + row_par.append(mean(test_par)) + row_ratio.append(geo_mean(test_ratio)) + except VcyError as err: + sys.stdout.write(f'\nFailure: {err.msg}\n') + row_seq.append(None) + row_par.append(None) + row_ratio.append(None) + results_seq.append((n, row_seq)) + results_par.append((n, row_par)) + results_ratio.append((n, row_ratio)) + + os.makedirs(dir, exist_ok=True) + with open(f'{dir}/ratio.csv', 'w') as file: + file.write(build_table(results_ratio)) + with open(f'{dir}/seq.csv', 'w') as file: + file.write(build_table(results_seq)) + with open(f'{dir}/par.csv', 'w') as file: + file.write(build_table(results_par)) + +if __name__ == '__main__': + try: + dir = sys.argv[1] + if '--test' in sys.argv: n_values = [1e6] + num_trials = int(sys.argv[2]) + if len(sys.argv) > 3 and sys.argv[3] != '--test': + benchmarks = [(sys.argv[3], lambda n: [str(n)] + sys.argv[4:])] + build_file() + except: + print(f'Usage: {sys.argv[0]} [program] [--test]') diff --git a/reports/speedup_dswp_nc.py b/reports/speedup_dswp_nc.py new file mode 100755 index 0000000..02bbff1 --- /dev/null +++ b/reports/speedup_dswp_nc.py @@ -0,0 +1,227 @@ +#!/usr/bin/env python3 + +# Invoke with: python3 ./speedup_dswp.py out-dswp-results-dir +# The directory will be created if it doesn't exist, +# and 3 CSV files will be generated inside the directory + +from posixpath import join +from pathlib import Path +import subprocess +import sys, os +from typing import Tuple, List, Callable +import functools +import re +import tempfile +import shutil + +Benchmark = Tuple[str, Callable[[int],List[str]]] +Data = Tuple[float, float] +Result = Tuple[Benchmark, Data] +Row = Tuple[int, List[float]] + +os.chdir(os.path.dirname(sys.argv[0])) + +vcy_exe = '../src/vcy.exe' + +dir = '' +num_trials = 0 + +class VcyError(Exception): + def __init__(self, msg) -> None: + super().__init__(msg) + self.msg = msg + +n_values = [ + 1e1, 2e1, 5e1, + 1e2, 2e2, 5e2, + 1e3, 2e3, 5e3, + 1e4, 2e4, 5e4, + 1e5, 2e5, 5e5, + 1e6, 2e6, 5e6, + 1e7, 2e7, 5e7, + # 1e8 +] + +timeout = 5 + +def mean(values): + return sum(values) / len(values) + +def geo_mean(values): + return functools.reduce(lambda x,y: x * y, values, 1) ** (1 / len(values)) + +def prep_commset(n): + with open("a.txt", "w") as f: + f.write("A"*(n)) + with open("b.txt", "w") as f: + f.write("B"*(n)) + with open("c.txt", "w") as f: + f.write("C"*(n)) + with open("d.txt", "w") as f: + f.write("D"*(n)) + return [os.path.join(os.path.dirname(sys.argv[0]), "a.txt"), os.path.join(os.path.dirname(sys.argv[0]), "b.txt"), os.path.join(os.path.dirname(sys.argv[0]), "c.txt"), os.path.join(os.path.dirname(sys.argv[0]), "d.txt")] + +def prep_simpleio(n): + with open("a.txt", "w") as f: + f.write("A") + with open("b.txt", "w") as f: + f.write("B"*(n)) + with open("c.txt", "w") as f: + f.write("C"*(n)) + with open("d.txt", "w") as f: + f.write("D"*(n)) + return [os.path.join(os.path.dirname(sys.argv[0]), "a.txt"), os.path.join(os.path.dirname(sys.argv[0]), "b.txt"), os.path.join(os.path.dirname(sys.argv[0]), "c.txt"), os.path.join(os.path.dirname(sys.argv[0]), "d.txt")] + +# Program name, followed by any command line arguments +benchmarks : List[Benchmark] = [ + ("benchmarks/global_commutativity/simple-vector.vcy", lambda n : [str(n)]), + ("benchmarks/global_commutativity/2d-array.vcy", lambda n : [str(n)]), + ("benchmarks/global_commutativity/vote-run.vcy", lambda n : [str(n)]), + ("benchmarks/global_commutativity/commset.vcy", prep_commset), + ("benchmarks/global_commutativity/multi-blocks.vcy", lambda n : [str(n)]), + ("benchmarks/global_commutativity/simple-io.vcy", prep_simpleio), + ("benchmarks/global_commutativity/motivation.vcy", lambda n : [str(n * 100), "10"]) +] + +def replace_commutativity_predicate_in_memory(code: str) -> str: + # Regex pattern to match the commutativity block with any number of group_commute entries + pattern = re.compile( + r'commutativity\s*\{([^{}]*(?:\{[^{}]*\}[^{}]*)*)\}', + re.DOTALL + ) + + def replace_conditions(match): + commutativity_block = match.group(0) + # print(f"Captured commutativity block:\n{commutativity_block}\n") + + lines = commutativity_block.split('\n') + + for i in range(1, len(lines) - 1): + # Replace any condition part after a colon ': ( ... )' with ': (false)' + lines[i] = re.sub(r':\s*\([^)]*\)', ': (false)', lines[i]) + + # Handle implied conditions like ': true' -> ': (false)' (no parentheses) + lines[i] = re.sub(r':\s*true(?=\s*;|\s*$)', ': (false)', lines[i]) + + # If there's any condition that matches ': (true)' with parentheses, replace it as well + lines[i] = re.sub(r':\s*\(true\)', ': (false)', lines[i]) + + # Handle any other conditions, but preserve the semicolon and anything after it + lines[i] = re.sub(r':\s*([^;]+)(?=;|$)', ': (false)', lines[i]) + + updated_block = '\n'.join(lines) + + # print(f"Updated commutativity block:\n{updated_block}\n") + return updated_block + + updated_code = re.sub(pattern, replace_conditions, code) + return updated_code + + +def run_benchmark(index: int, n: int, b: Benchmark) -> Result: + prog, fargs = b + args = fargs(n) + + # Read the original file content + original_file_path = '../' + prog + with open(original_file_path, 'r') as file: + original_code = file.read() + + # Replace commutativity predicate in memory + modified_code = replace_commutativity_predicate_in_memory(original_code) + + # Create a temporary directory and file for the modified code + with tempfile.TemporaryDirectory() as temp_dir: + temp_file_path = os.path.join(temp_dir, os.path.basename(prog)) + with open(temp_file_path, 'w') as temp_file: + temp_file.write(modified_code) + + # Run the benchmark using the temporary file + command_seq = [vcy_exe, 'interp', '--time', '--timeout', str(timeout), temp_file_path] + args + command_par = [vcy_exe, 'interp', '--time', '--dswp', '--timeout', str(timeout), temp_file_path] + args + + def f(command: List[str], floatize: bool): + popen = subprocess.Popen( + command, universal_newlines=True, + stdout=subprocess.PIPE, stderr=subprocess.PIPE, + env={'LD_LIBRARY_PATH': '../veracity/src'} + ) + out, err = popen.communicate() + if err: + raise VcyError(err) + try: + return float(out) if floatize else out + except TypeError: + raise TypeError(f'Output {out} could not be parsed into a float') + + sys.stdout.write(f'{(index+1):#2d}/{len(benchmarks) * len(n_values)} Executing {prog} in sequence... ') + sys.stdout.flush() + seq_time = f(command_seq, True) + + sys.stdout.write(f'Done. Now in DSWP mode... ') + sys.stdout.flush() + par_time = f(command_par, True) + + sys.stdout.write(f'Done.\n') + sys.stdout.flush() + return b, (float(seq_time), float(par_time)) + +def line_of_row(r : Row) -> str: + n, l = r + return f'{n}\t' + '\t'.join(f'{v:#.6f}' if v != None else '' for v in l) + +def mk_table_start(): + return 'N\t' + '\t'.join(Path(s).stem for (s,_) in benchmarks) + +def build_table(rs : List[Row]) -> str: + rows = "\n".join(map(line_of_row, rs)) + return mk_table_start() + '\n' + rows + +def build_file(): + results_ratio : List[Row] = [] + results_seq : List[Row] = [] + results_par : List[Row] = [] + for i, n in enumerate(map(int, n_values)): + row_ratio = [] + row_seq = [] + row_par = [] + for j, b in enumerate(benchmarks): + try: + test_seq = [] + test_par = [] + test_ratio = [] + for _ in range(num_trials): + _, (seq, par) = run_benchmark(j + i * len(benchmarks), n, b) + test_seq.append(seq) + test_par.append(par) + test_ratio.append(seq / par) + row_seq.append(mean(test_seq)) + row_par.append(mean(test_par)) + row_ratio.append(geo_mean(test_ratio)) + except VcyError as err: + sys.stdout.write(f'\nFailure: {err.msg}\n') + row_seq.append(None) + row_par.append(None) + row_ratio.append(None) + results_seq.append((n, row_seq)) + results_par.append((n, row_par)) + results_ratio.append((n, row_ratio)) + + os.makedirs(dir, exist_ok=True) + with open(f'{dir}/ratio.csv', 'w') as file: + file.write(build_table(results_ratio)) + with open(f'{dir}/seq.csv', 'w') as file: + file.write(build_table(results_seq)) + with open(f'{dir}/par.csv', 'w') as file: + file.write(build_table(results_par)) + +if __name__ == '__main__': + try: + dir = sys.argv[1] + if '--test' in sys.argv: n_values = [1e6] + num_trials = int(sys.argv[2]) + if len(sys.argv) > 3 and sys.argv[3] != '--test': + benchmarks = [(sys.argv[3], lambda n: [str(n)] + sys.argv[4:])] + build_file() + except: + print(f'Usage: {sys.argv[0]} [program] [--test]') diff --git a/reports/speedup_dswp_noNB.py b/reports/speedup_dswp_noNB.py new file mode 100755 index 0000000..a121744 --- /dev/null +++ b/reports/speedup_dswp_noNB.py @@ -0,0 +1,237 @@ +#!/usr/bin/env python3 + +# Invoke with: python3 ./speedup_dswp.py out-dswp-results-dir +# The directory will be created if it doesn't exist, +# and 3 CSV files will be generated inside the directory + +from posixpath import join +from pathlib import Path +import subprocess +import sys, os +from typing import Tuple, List, Callable +import functools +import re +import tempfile +import shutil + +Benchmark = Tuple[str, Callable[[int],List[str]]] +Data = Tuple[float, float] +Result = Tuple[Benchmark, Data] +Row = Tuple[int, List[float]] + +os.chdir(os.path.dirname(sys.argv[0])) + +vcy_exe = '../src/vcy.exe' + +dir = '' +num_trials = 0 + +class VcyError(Exception): + def __init__(self, msg) -> None: + super().__init__(msg) + self.msg = msg + +n_values = [ + 1e1, 2e1, 5e1, + 1e2, 2e2, 5e2, + 1e3, 2e3, 5e3, + 1e4, 2e4, 5e4, + 1e5, 2e5, 5e5, + 1e6, 2e6, 5e6, + 1e7, 2e7, 5e7, + # 1e8 +] + +timeout = 5 + +def mean(values): + return sum(values) / len(values) + +def geo_mean(values): + return functools.reduce(lambda x,y: x * y, values, 1) ** (1 / len(values)) + +def prep_commset(n): + with open("a.txt", "w") as f: + f.write("A"*(n)) + with open("b.txt", "w") as f: + f.write("B"*(n)) + with open("c.txt", "w") as f: + f.write("C"*(n)) + with open("d.txt", "w") as f: + f.write("D"*(n)) + return [os.path.join(os.path.dirname(sys.argv[0]), "a.txt"), os.path.join(os.path.dirname(sys.argv[0]), "b.txt"), os.path.join(os.path.dirname(sys.argv[0]), "c.txt"), os.path.join(os.path.dirname(sys.argv[0]), "d.txt")] + +def prep_simpleio(n): + with open("a.txt", "w") as f: + f.write("A") + with open("b.txt", "w") as f: + f.write("B"*(n)) + with open("c.txt", "w") as f: + f.write("C"*(n)) + with open("d.txt", "w") as f: + f.write("D"*(n)) + return [os.path.join(os.path.dirname(sys.argv[0]), "a.txt"), os.path.join(os.path.dirname(sys.argv[0]), "b.txt"), os.path.join(os.path.dirname(sys.argv[0]), "c.txt"), os.path.join(os.path.dirname(sys.argv[0]), "d.txt")] + +# Program name, followed by any command line arguments +benchmarks : List[Benchmark] = [ + ("benchmarks/global_commutativity/simple-vector.vcy", lambda n : [str(n)]), + ("benchmarks/global_commutativity/2d-array.vcy", lambda n : [str(n)]), + ("benchmarks/global_commutativity/vote-run.vcy", lambda n : [str(n)]), + ("benchmarks/global_commutativity/commset.vcy", prep_commset), + ("benchmarks/global_commutativity/multi-blocks.vcy", lambda n : [str(n)]), + ("benchmarks/global_commutativity/simple-io.vcy", prep_simpleio), + ("benchmarks/global_commutativity/motivation.vcy", lambda n : [str(n * 100), "10"]) +] + +def replace_commutativity_predicate_in_memory(code: str) -> str: + def find_matching_brace(s, start): + count = 1 + i = start + while i < len(s) and count > 0: + if s[i] == '{': + count += 1 + elif s[i] == '}': + count -= 1 + i += 1 + return i if count == 0 else -1 + + pattern_commutativity = re.compile( + r'commutativity\s*\{[^{}]*(?:\{[^{}]*\}[^{}]*)*\}\s*', + re.DOTALL + ) + code_without_commutativity = re.sub(pattern_commutativity, '', code) + + pattern_label = re.compile(r'(\w+(?:\([^)]*\))?)\s*:\s*\{') + + result = "" + pos = 0 + while True: + match = pattern_label.search(code_without_commutativity, pos) + if not match: + result += code_without_commutativity[pos:] + break + + result += code_without_commutativity[pos:match.start()] + + open_brace_pos = match.end() - 1 + close_brace_pos = find_matching_brace(code_without_commutativity, open_brace_pos + 1) + + if close_brace_pos == -1: + result += code_without_commutativity[match.start():] + break + + content = code_without_commutativity[open_brace_pos:close_brace_pos + 1] + result += content + + pos = close_brace_pos + 1 + + return result + + +def run_benchmark(index: int, n: int, b: Benchmark) -> Result: + prog, fargs = b + args = fargs(n) + + # Read the original file content + original_file_path = '../' + prog + with open(original_file_path, 'r') as file: + original_code = file.read() + + # Replace commutativity predicate in memory + modified_code = replace_commutativity_predicate_in_memory(original_code) + + # Create a temporary directory and file for the modified code + with tempfile.TemporaryDirectory() as temp_dir: + temp_file_path = os.path.join(temp_dir, os.path.basename(prog)) + with open(temp_file_path, 'w') as temp_file: + temp_file.write(modified_code) + + # Run the benchmark using the temporary file + command_seq = [vcy_exe, 'interp', '--time', '--timeout', str(timeout), temp_file_path] + args + command_par = [vcy_exe, 'interp', '--time', '--dswp', '--timeout', str(timeout), temp_file_path] + args + + def f(command: List[str], floatize: bool): + popen = subprocess.Popen( + command, universal_newlines=True, + stdout=subprocess.PIPE, stderr=subprocess.PIPE, + env={'LD_LIBRARY_PATH': '../veracity/src'} + ) + out, err = popen.communicate() + if err: + raise VcyError(err) + try: + return float(out) if floatize else out + except TypeError: + raise TypeError(f'Output {out} could not be parsed into a float') + + sys.stdout.write(f'{(index+1):#2d}/{len(benchmarks) * len(n_values)} Executing {prog} in sequence... ') + sys.stdout.flush() + seq_time = f(command_seq, True) + + sys.stdout.write(f'Done. Now in DSWP mode... ') + sys.stdout.flush() + par_time = f(command_par, True) + + sys.stdout.write(f'Done.\n') + sys.stdout.flush() + return b, (float(seq_time), float(par_time)) + +def line_of_row(r : Row) -> str: + n, l = r + return f'{n}\t' + '\t'.join(f'{v:#.6f}' if v != None else '' for v in l) + +def mk_table_start(): + return 'N\t' + '\t'.join(Path(s).stem for (s,_) in benchmarks) + +def build_table(rs : List[Row]) -> str: + rows = "\n".join(map(line_of_row, rs)) + return mk_table_start() + '\n' + rows + +def build_file(): + results_ratio : List[Row] = [] + results_seq : List[Row] = [] + results_par : List[Row] = [] + for i, n in enumerate(map(int, n_values)): + row_ratio = [] + row_seq = [] + row_par = [] + for j, b in enumerate(benchmarks): + try: + test_seq = [] + test_par = [] + test_ratio = [] + for _ in range(num_trials): + _, (seq, par) = run_benchmark(j + i * len(benchmarks), n, b) + test_seq.append(seq) + test_par.append(par) + test_ratio.append(seq / par) + row_seq.append(mean(test_seq)) + row_par.append(mean(test_par)) + row_ratio.append(geo_mean(test_ratio)) + except VcyError as err: + sys.stdout.write(f'\nFailure: {err.msg}\n') + row_seq.append(None) + row_par.append(None) + row_ratio.append(None) + results_seq.append((n, row_seq)) + results_par.append((n, row_par)) + results_ratio.append((n, row_ratio)) + + os.makedirs(dir, exist_ok=True) + with open(f'{dir}/ratio.csv', 'w') as file: + file.write(build_table(results_ratio)) + with open(f'{dir}/seq.csv', 'w') as file: + file.write(build_table(results_seq)) + with open(f'{dir}/par.csv', 'w') as file: + file.write(build_table(results_par)) + +if __name__ == '__main__': + try: + dir = sys.argv[1] + if '--test' in sys.argv: n_values = [1e6] + num_trials = int(sys.argv[2]) + if len(sys.argv) > 3 and sys.argv[3] != '--test': + benchmarks = [(sys.argv[3], lambda n: [str(n)] + sys.argv[4:])] + build_file() + except: + print(f'Usage: {sys.argv[0]} [program] [--test]') diff --git a/reports/speedup_plot.py b/reports/speedup_plot.py new file mode 100644 index 0000000..851aee9 --- /dev/null +++ b/reports/speedup_plot.py @@ -0,0 +1,48 @@ +import pandas as pd +import matplotlib.pyplot as plt +import numpy as np +import sys +import os + +if len(sys.argv) != 2: + print("Usage: python script.py ") + sys.exit(1) + +directory = sys.argv[1] + +input_csv_file = os.path.join(directory, 'ratio.csv') +output_plot_file = os.path.join(directory, 'speedup-plot.png') + +if not os.path.exists(input_csv_file): + print(f"Error: {input_csv_file} does not exist.") + sys.exit(1) + +try: + data = pd.read_csv(input_csv_file, delim_whitespace=True) +except pd.errors.ParserError: + print(f"Error: The file {input_csv_file} does not have the correct format.") + sys.exit(1) + +N = data.iloc[:, 0] +log_N = np.log10(N) +columns = data.columns[1:] + +markers = ['o', 's', '^', 'D', 'v', '<', '>', 'p', '*', 'H', '+', 'x'] + +plt.figure(figsize=(12, 8)) +for i, column in enumerate(columns): + label = column.replace("vote-run", "vote") + plt.plot(log_N, data[column], label=label, marker=markers[i % len(markers)]) + +# Add horizontal line for speedup = 1 +plt.axhline(y=1, color='black', linestyle='--', label='Speedup = 1', linewidth=2.5) + +plt.xlabel('Log(Computation Size)') +plt.ylabel('Parallel-to-Sequential Speedup') +plt.legend() +plt.grid(True) + +plt.savefig(output_plot_file) + +print(f"Plot saved successfully at {output_plot_file}") + diff --git a/reports/speedup_plot_compare.py b/reports/speedup_plot_compare.py new file mode 100644 index 0000000..d1dbdab --- /dev/null +++ b/reports/speedup_plot_compare.py @@ -0,0 +1,77 @@ +# python3 ./speedup_plot_compare.py out-dswp-arran out-dswp-nc out-dswp-noNB out-dswp-comparison-all + +import pandas as pd +import matplotlib.pyplot as plt +import numpy as np +import sys +import os + +def read_csv(file_path): + try: + return pd.read_csv(file_path, delim_whitespace=True) + except pd.errors.ParserError: + print(f"Error: The file {file_path} does not have the correct format.") + sys.exit(1) + +def create_comparison_plot(data_commute, data_no_commute, data_no_NB, benchmark, output_dir): + N = data_commute.iloc[:, 0] + log_N = np.log10(N) + + plt.figure(figsize=(6, 4)) + + # plt.rcParams.update({'font.size': 13}) + + plt.plot(log_N, data_commute[benchmark], label='Comm.', + marker='o', markersize=6, linewidth=2) + plt.plot(log_N, data_no_commute[benchmark], label='False-Comm.', + marker='s', markersize=6, linewidth=2, color='red') + plt.plot(log_N, data_no_NB[benchmark], label='No-NCB.', + marker='^', markersize=6, linewidth=2, color='green') + + plt.axhline(y=1, color='black', linestyle='--', + label='Speedup = 1', linewidth=1.6) + + # plt.xlabel('Log(Computation Size)', fontsize=12) + # plt.ylabel('Par-to-Seq Speedup', fontsize=12) + + plt.xticks(fontsize=15) + plt.yticks(fontsize=15) + + # benchmark_name = benchmark.replace('vote-run', 'Vote').title() + # benchmark_name = benchmark_name.replace('2D-Array', 'PS-DSWP-Array') + # plt.title(benchmark_name, fontsize=12, pad=10) + + plt.legend(loc='best', fontsize=14) + plt.grid(True, linestyle=':', alpha=0.6) + + plt.tight_layout() + + output_file = os.path.join(output_dir, f'{benchmark}-comparison.png') + plt.savefig(output_file, dpi=300, bbox_inches='tight', transparent=True) + plt.close() + print(f"Plot for {benchmark} saved at {output_file}") + +def main(): + if len(sys.argv) != 5: + print("Usage: python script.py ") + sys.exit(1) + + commute_csv = sys.argv[1] + no_commute_csv = sys.argv[2] + no_NB_csv = sys.argv[3] + output_dir = sys.argv[4] + + if not os.path.exists(output_dir): + os.makedirs(output_dir) + + data_commute = read_csv(os.path.join(commute_csv, 'ratio.csv')) + data_no_commute = read_csv(os.path.join(no_commute_csv, 'ratio.csv')) + data_no_NB = read_csv(os.path.join(no_NB_csv, 'ratio.csv')) + + benchmarks = data_commute.columns[1:] + + for benchmark in benchmarks: + create_comparison_plot(data_commute, data_no_commute, data_no_NB, benchmark, output_dir) + +if __name__ == "__main__": + main() \ No newline at end of file diff --git a/src/analysis/analyze.ml b/src/analysis/analyze.ml index df4c0fc..e8bbd06 100644 --- a/src/analysis/analyze.ml +++ b/src/analysis/analyze.ml @@ -11,6 +11,7 @@ let rec assoc_servois_ty (id : id) : embedding_map -> ty binding = | ETArr (i, _) when id = i -> v | ETHashTable (_,_,{ht;keys;size}) when id = ht || id = keys || id = size -> v + | ETChannel i when id = i -> v | _ -> assoc_servois_ty id t end @@ -25,6 +26,7 @@ let generate_embedding_map (vars : ty bindlist) : embedding_map = ETHashTable ( sty_of_ty tyk, sty_of_ty tyv, { ht = id ; keys = id ^ "_keys"; size = id ^ "_size" }) + | TChanR | TChanW -> ETChannel id | _ -> raise @@ NotImplemented "Unsupported type embedding" in List.map (fun v -> v, f v) vars @@ -111,9 +113,9 @@ let rec smt_translation (input: Smt.exp) (embedding: embedding_map) : exp = let exp_of_phi (phi : Servois2.Phi.disjunction) (embedding: embedding_map) : exp = smt_translation (Servois2.Phi.smt_of_disj phi) embedding -let phi_of_blocks (genv: global_env) (_: commute_variant) (blks: block node list) (vars : ty bindlist) = +let phi_of_blocks (genv: global_env) (_: commute_variant) (blks: block node list) (vars : ty bindlist) pre post = let embedding = generate_embedding_map vars in - let [@warning "-8"] spec , [m1;m2] = Spec_generator.compile_blocks_to_spec genv blks embedding + let [@warning "-8"] spec , [m1;m2] = Spec_generator.compile_blocks_to_spec genv blks embedding pre post in Servois2.Choose.choose := Servois2.Choose.poke2; let phi, _ = Servois2.Synth.synth ~options:!Util.servois2_synth_option spec m1 m2 in @@ -121,9 +123,9 @@ let phi_of_blocks (genv: global_env) (_: commute_variant) (blks: block node list exp_of_phi phi embedding (* Servois2.Choose.choose := Servois2.Choose.poke2; *) -let verify_of_block e genv _ blks vars : bool option * bool option = +let verify_of_block e genv _ blks vars pre post : bool option * bool option = let embedding = generate_embedding_map vars in - let [@warning "-8"] spec , [m1;m2] = Spec_generator.compile_blocks_to_spec genv blks embedding in + let [@warning "-8"] spec , [m1;m2] = Spec_generator.compile_blocks_to_spec genv blks embedding pre post in let cond = (fst @@ Spec_generator.exp_to_smt_exp e 1 Spec_generator.variable_ctr_list) in Servois2.Verify.verify spec m1 m2 cond, Servois2.Verify.verify ~options:{Servois2.Verify.default_verify_options with ncom = true} spec m1 m2 (EUop(Not, cond)) diff --git a/src/analysis/dswp_task.ml b/src/analysis/dswp_task.ml new file mode 100644 index 0000000..8f35898 --- /dev/null +++ b/src/analysis/dswp_task.ml @@ -0,0 +1,117 @@ +open Ast +open Ast_print +type dswp_taskid = int + +type commute_condition = { + my_task_formals: string list; (* TODO: Can make string * type? *) + other_task_formals: string list; + condition: exp node option +} +(* t_i can depend on a list of variables written by some predecessor t_j *) +type dependency = { + pred_task: dswp_taskid; + make_new_job: bool; + vars: (ty * id) list; + commute_cond : commute_condition +} + +type exe_label = Doall | Sequential + +type dswp_task = { + id : dswp_taskid; + deps_in : dependency list; (* a list of other tasks/vars that I depend on *) + deps_out : dependency list; (* a list of other tasks/vars that I provide for *) + body: block node; + label: exe_label; +} + +type init_task = { + decls: block node; + jobs: dswp_taskid list; + label: exe_label; +} + +let str_of_vars_list (vlist : (ty * id) list) : string = + (String.concat ";" (List.map (fun (t,i) -> + Printf.sprintf "%s %s" (AstPP.string_of_ty t) i + ) vlist)) + +let str_of_exp_list (elist : exp node list) : string = + (String.concat "," (List.map AstML.string_of_exp elist)) + +let str_of_task_deps deplist = + "{" + ^(String.concat " AND " (List.map (fun dep -> + match dep.commute_cond.condition with + | None -> Printf.sprintf "from %d [new job: %b]: %s" dep.pred_task dep.make_new_job (str_of_vars_list dep.vars) + | Some c -> + Printf.sprintf "from %d [new job: %b]: %s / commute_cond: [%s],[%s] => %s" dep.pred_task dep.make_new_job (if not (Util.null dep.vars) then (str_of_vars_list dep.vars) else "[]") (String.concat "," dep.commute_cond.my_task_formals)(String.concat "," dep.commute_cond.other_task_formals) (AstPP.string_of_exp c) + ) deplist)) + ^"}" + +let str_of_task tsk = + Printf.sprintf "{Task %d:\n deps_in:%s\n deps_out:%s\n label:%s}" + tsk.id (str_of_task_deps tsk.deps_in) (str_of_task_deps tsk.deps_out) + (match tsk.label with | Doall -> "DOALL" | Sequential -> "Seq") + +let rec calculate_semaphores tlist : (dswp_taskid * dswp_taskid) list = + match tlist with + | [] -> [] + | (tk::rest) -> + (List.map (fun dep -> (dep.pred_task,tk.id)) tk.deps_in ) + @ (calculate_semaphores rest) + +(* things like t1_to_t2_x *) +let rec calculate_handoff_vars tlist : (ty * id * dswp_taskid * dswp_taskid) list = + match tlist with + | [] -> [] + | (tk::rest) -> + List.flatten (List.map (fun dep -> + (List.map (fun (t,x) -> (t,x,dep.pred_task,tk.id) ) dep.vars) + ) tk.deps_in) + @ (calculate_handoff_vars rest) + +(* +Example: + +task1: + { id=1; deps_in:(task1,p); deps_out:[(task1,p->next);(task2,p);(task3,p)] + body="id=p->id;if(!visited[id])visited[id]=true;"} + +task2: + { id=2; deps_in:(task1,p); deps_out:[] + body="q=p->inner_list; .."} + +task3: + { id=3; deps_in:(task1,p); deps_out:[] + body="q=p->inner_list; .."} +*) + +let mk_int_dep pred_id var_id = {pred_task=pred_id; make_new_job=false; vars=[(TInt,var_id)]; commute_cond = {my_task_formals =[]; other_task_formals=[];condition=None}} + +let example_var_decls () = + [ + Gvdecl(no_loc { name="p"; ty=TInt; init=(no_loc (CInt 0L))}) + ] + +let example_tasks () : dswp_task list = + [ + { id=1; + deps_in=[(mk_int_dep 1 "p")]; + deps_out=[(mk_int_dep 1 "pnext");(mk_int_dep 2 "p");(mk_int_dep 3 "p")]; + body=no_loc [(no_loc (Ret(None)))]; + label=Doall + }; + { id=2; + deps_in=[(mk_int_dep 1 "p")]; + deps_out=[]; + body=no_loc [(no_loc (Ret(None)))]; + label=Doall + }; + { id=3; + deps_in=[(mk_int_dep 1 "p")]; + deps_out=[]; + body=no_loc [(no_loc (Ret(None)))]; + label=Doall + } + ] diff --git a/src/analysis/exe_pdg.ml b/src/analysis/exe_pdg.ml new file mode 100644 index 0000000..f7749d3 --- /dev/null +++ b/src/analysis/exe_pdg.ml @@ -0,0 +1,1331 @@ +open Ast +open Ast_print +open Format +open Range +open Util +open Dswp_task + +let generated_init_task = ref None +let generated_tasks = ref [] +let generated_decl_vars = ref [] +let codegen = ref false +let commutativity_spec_exist = ref false + +type dependency = +| ControlDep +| DataDep of (ty * id) list +| Commute of (exp node) * (string list) * (string list) +| Disjoint + +type enode_ast_elt = +| Entry +| EWhile of exp node +| EIf of exp node +| EIfElse of exp node +| EFor of vdecl list * exp node option * stmt node option +| EStmt of stmt node + +let transform_stmt (s: stmt node) : enode_ast_elt = + match s.elt with + | If (e, b1, b2) -> + begin match b2.elt with + | [] -> EIf e + | _ -> EIfElse e + end + | While (e,_) -> EWhile e + | For (v,e,s,_) -> EFor (v,e,s) + | _ -> EStmt s + +type pdg_node = { + l: Range.t; + n: enode_ast_elt; + src: stmt node option +} + +type pdg_edge = { + src : pdg_node; + dst : pdg_node; + dep : dependency; + loop_carried : bool +} + +type exe_pdg = { + entry_node: pdg_node option; + nodes : pdg_node list; + edges : pdg_edge list; +} + +let empty_exe_pdg () : exe_pdg = + { entry_node = None; nodes = []; edges = [] } + +let add_node (pdg : exe_pdg) (s : stmt node) : pdg_node * exe_pdg = + let n = {l = s.loc; n = transform_stmt s; src = Some s} in + n, { pdg with nodes = pdg.nodes @ [n] } + +let add_edge (pdg : exe_pdg) (src : pdg_node) (dst : pdg_node) dep : exe_pdg = + { pdg with edges = pdg.edges @ [{ src; dst; dep; loop_carried = false }] } + + +let string_of_dep = function + | ControlDep -> "ControlDep" + | DataDep vars -> sp "DataDep (%s)" (AstPP.string_of_args vars) + | Commute (b,args1,args2) -> sp "[%s]; [%s]; Commute (%s)" (AstML.string_of_list Fun.id args1) (AstML.string_of_list Fun.id args2) (AstPP.string_of_exp b) + | Disjoint -> "Disjoint" + +(* +let c_of_stmt = function + | Entry -> "Entry" + | EWhile e -> sp "while(%s)" (Ast_to_c.c_of_expnode e) + | EIf e -> sp "if(%s)" (Ast_to_c.c_of_expnode e) + | EIfElse e -> sp "if(%s)" (Ast_to_c.c_of_expnode e) + | EFor(inits, e, update) -> sp "for(%s; %s; %s)" (String.concat ", " @@ List.map (fun (id, (ty, rhs)) -> sp "%s %s = %s" (Ast_to_c.c_of_ty ty) (!Ast_to_c.mangle id) (Ast_to_c.c_of_expnode rhs)) inits) (e |> Option.map Ast_to_c.c_of_expnode |> Option.value ~default:"") (update |> Option.map Ast_to_c.c_of_stmtnode |> Option.value ~default:"") + | EStmt s -> Ast_to_c.c_of_stmt s.elt +*) +let pp_stmt = function + | Entry -> "Entry" + | EWhile e -> sp "while(%s)" (Ast_print.AstPP.string_of_exp e) + | EIf e -> sp "if(%s)" (Ast_print.AstPP.string_of_exp e) + | EIfElse e -> sp "if(%s)" (Ast_print.AstPP.string_of_exp e) + | EFor(inits, e, update) -> sp "for(%s; %s; %s)" (String.concat ", " @@ List.map (fun (id, (ty, rhs)) -> sp "%s %s = %s" (Ast_print.AstPP.string_of_ty ty) id (Ast_print.AstPP.string_of_exp rhs)) inits) (e |> Option.map Ast_print.AstPP.string_of_exp |> Option.value ~default:"") (update |> Option.map Ast_print.AstPP.string_of_stmt |> Option.value ~default:"") + | EStmt s -> Ast_print.AstPP.string_of_stmt (no_loc s.elt) + +let string_of_pdg_node_stmt s = + (* let big_string = Ast_to_c.c_of_stmt s in *) + (* if String.length big_string > 20 then String.sub big_string 0 19 else big_string *) + (* c_of_stmt s *) + pp_stmt s + + +let penwidth_of_pdgedge p = + if p.loop_carried then "4.0" else "1.0" + +let print_pdg pdg fn : unit = + let oc = open_out fn in + output_string oc (String.concat "\n" [ + "digraph G {\n"; + (* Styles *) + " graph [rankdir=\"TB\", fontname=\"Arial\", fontsize=24, label=\"Program Dependency Graph (PDG): red=control, green=data\", labelloc=t, labeljust=l]"; + " node [shape=box, style=\"rounded,filled\", fontname=\"Courier\", margin=0.05]"; + " edge [arrowhead=vee, arrowsize=1, fontname=\"Courier\"]"; + (* Nodes *) + (* let s = "\" [label=\""^(match pdg.entry_node with | Some en -> string_of_pdg_node_stmt en.n)^"\"];\n" in *) + List.fold_left (fun acc node -> acc ^ "\"" ^ (Range.string_of_range_nofn node.l) + ^ "\" [label=\""^(Util.dot_escape (string_of_pdg_node_stmt node.n))^"\"];\n") "" pdg.nodes; + (* edges *) + List.fold_left (fun acc e -> + let pw = penwidth_of_pdgedge e in + acc ^ (match e.dep with + | DataDep vars -> + let vars = AstPP.string_of_args vars in + "\"" ^ (Range.string_of_range_nofn e.src.l) ^ "\" -> \"" + ^ (Range.string_of_range_nofn e.dst.l) ^ "\" " + ^ "[style=solid, color=green, label=\""^(dot_escape vars)^"\", penwidth=\""^pw^"\"];\n" + | Commute (exp, args1, args2) -> + let cond = AstPP.string_of_exp exp in + "\"" ^ (Range.string_of_range_nofn e.src.l) ^ "\" -> \"" + ^ (Range.string_of_range_nofn e.dst.l) ^ "\" " + ^ "[style=dotted, color=red, label=\""^(dot_escape cond)^"\", penwidth=\""^pw^"\"];\n" + | Disjoint + | ControlDep -> + "\"" ^ (Range.string_of_range_nofn e.src.l) ^ "\" -> \"" + ^ (Range.string_of_range_nofn e.dst.l) ^ "\" " + ^ "[style=dashed, color=maroon, penwidth=\""^(dot_escape pw)^"\"];\n" (*label=\""^(string_of_dep e.dep)^"\"];\n"*) + )) "" pdg.edges; + "}\n"; + ]); + debug_print (lazy ("pdg written to " ^ fn)); + close_out oc + + +let print_pdg_debug pdg = + if !Util.debug then begin + begin match pdg.entry_node with | Some en -> Printf.printf "entry node: %s\n" (Range.string_of_range en.l) | _ -> () end; + List.iteri (fun i s -> Printf.printf "node %d: %s\n" i (Range.string_of_range s.l)) pdg.nodes; + List.iteri (fun i e -> Printf.printf "pdg_edge %d (%s) - %b: %s - %s\n" i (string_of_dep e.dep) e.loop_carried (Range.string_of_range_nofn e.src.l) (Range.string_of_range_nofn e.dst.l)) pdg.edges + end + +let find_node (s: stmt node) pdg : pdg_node = + let sl = s.loc in + List.find ( + fun {l=loc;_} -> String.equal (Range.string_of_range loc) (Range.string_of_range sl) + ) pdg.nodes + +let compare_nodes n1 n2 = + String.equal (Range.string_of_range n1.l) (Range.string_of_range n2.l) + + +let rvalue = 1 +let lvalue = 0 +let decl_vars = ref [] +let m_vars = ref [] + +let set_vars_side (vars : (ty * string) list) side : ((ty * string) * int) list = + List.map (fun v -> (v, side)) vars + +let find_global_by_name_opt name = List.find_opt (function (Gvdecl d) -> String.equal d.elt.name name | _ -> false) !decl_vars + +let rec find_block_vars block : ((ty * string) * int) list = + match block with + | [] -> [] + | stmt::tl -> (find_stmt_vars (EStmt stmt)) @ (find_block_vars tl) + +and find_stmt_vars (stmt: enode_ast_elt) : ((ty * string) * int) list = + match stmt with + | EWhile e | EIf e | EIfElse e -> set_vars_side (find_exp_vars e) rvalue + | EFor (vdecls, eoption, soption) -> + List.concat_map (fun v -> + let id, (ty, e) = v in + ((ty , id), lvalue) :: (set_vars_side (find_exp_vars e) rvalue) + ) vdecls + @ + begin match eoption with + | Some e -> set_vars_side (find_exp_vars e) rvalue + | None -> [] + end + @ + begin match soption with + | Some s -> find_stmt_vars (EStmt s) + | None -> [] + end + | EStmt s -> + begin match s.elt with + | Assn (e1,e2) -> (set_vars_side (find_exp_vars e1) lvalue) @ (set_vars_side (find_exp_vars e2) rvalue) + | Decl vdecl -> + let id, (ty, e) = vdecl in + let decl = Gvdecl (no_loc { name = id; ty = ty; init = e }) in + if not (List.mem decl !decl_vars) then + decl_vars := decl :: !decl_vars; + ((ty , id), lvalue) :: (set_vars_side (find_exp_vars e) rvalue) + | Ret (Some e) -> set_vars_side (find_exp_vars e) rvalue + | SBlock (Some (_, None),body) | SBlock (None, body) -> find_block_vars body.elt + | SBlock (Some (_, Some bl),body) -> (List.concat_map (fun e -> (set_vars_side (find_exp_vars e) rvalue)) bl) @ find_block_vars body.elt + | While (e, body) -> (set_vars_side (find_exp_vars e) rvalue) @ find_block_vars body.elt + | For (vdecls,eoption,soption,body) -> + List.concat_map (fun v -> + let id, (ty, e) = v in + ((ty , id), lvalue) :: (set_vars_side (find_exp_vars e) rvalue) + ) vdecls + @ + begin match eoption with + | Some e -> set_vars_side (find_exp_vars e) rvalue + | None -> [] + end + @ + begin match soption with + | Some s -> find_stmt_vars (EStmt s) + | None -> [] + end + @ find_block_vars body.elt + | If (e,b1,b2) -> (set_vars_side (find_exp_vars e) rvalue) @ (find_block_vars b1.elt) @ (find_block_vars b2.elt) + | Assert e | Assume e | Require e | Raise e -> set_vars_side (find_exp_vars e) rvalue + | SCall (_, el) | SCallRaw (_, el) -> (set_vars_side (List.concat_map find_exp_vars el) rvalue) + | _ -> [] + end + | Entry -> [] + +and find_exp_vars exp : (ty * string) list = + match exp.elt with + | CStr s | Id s -> + begin match find_global_by_name_opt s with + | None -> begin match List.find_opt (fun (ty, id) -> String.equal id s) !m_vars with | None -> [] | Some l -> [l] end + | Some (Gvdecl v) -> [(v.elt.ty, s)] + | _ -> failwith "undefined variable" + end + | CArr (_, expl) -> List.concat_map find_exp_vars expl + | NewArr (_, e) | Uop (_, e) -> find_exp_vars e + | Index (e1, e2) | Bop (_, e1, e2) -> (find_exp_vars e1) @ (find_exp_vars e2) + | CallRaw (_, expl) -> List.concat_map find_exp_vars expl + | Call (m, expl) -> List.concat_map find_exp_vars expl (* TODO: check *) + | Ternary (e1, e2, e3) -> (find_exp_vars e1) @ (find_exp_vars e2) @ (find_exp_vars e3) + | _ -> [] + (* + | CStruct of id * exp node bindlist + | Proj of exp node * id *) + +let src_to_dst = 1 +let dst_to_src = 0 + +let has_data_dep src dst : bool * (ty * string) list * (ty * string) list = + let list1 = find_stmt_vars src.n in + let list2 = find_stmt_vars dst.n in + let rec values_for_key_pair key lst = + match lst with + | [] -> [] + | (k, v) :: tl -> + if k = key then + v :: values_for_key_pair key tl + else + values_for_key_pair key tl + in + + let dep = ref false in + let std_vars = ref [] in + let dts_vars = ref [] in + + (* Function to check for common elements with specific value patterns *) + let rec has_common_element list1 list2 : bool = + match list1 with + | [] -> !dep + | (head, val1) :: tail -> + if List.mem_assoc head list2 then begin + let val2 = values_for_key_pair head list2 in + let rec check_val2 val2_list = + match val2_list with + | [] -> !dep + | val2 :: rest -> + begin match val1, val2 with + | 0, 1 -> + if not (List.mem head !std_vars) then begin + std_vars := head :: !std_vars; + dep := true + end; + check_val2 rest + | 1, 0 -> + if not (List.mem head !dts_vars) then begin + dts_vars := head :: !dts_vars; + dep := true + end; + check_val2 rest + | _, _ -> check_val2 rest + end + in + let res1 = check_val2 val2 in + let res2 = has_common_element tail list2 in + res1 || res2 + end else + has_common_element tail list2 + in let flag = has_common_element list1 list2 in + flag, + List.map ( + fun (t, id) -> + match find_global_by_name_opt id with + | Some (Gvdecl d) -> (d.elt.ty, id) + | _ -> (t,id) + ) !std_vars, + List.map ( + fun (t, id) -> + match find_global_by_name_opt id with + | Some (Gvdecl d) -> (d.elt.ty, id) + | _ -> (t,id) + ) !dts_vars + +let add_dataDep_edges pdg = + let p = ref pdg in + + let deps_equal deps1 deps2 = + List.length deps1 = List.length deps2 && + List.for_all (fun d -> List.mem d deps2) deps1 + in + apply_pairs (fun x y -> + let dep, std_deps, dts_deps = has_data_dep x y in + if dep then begin + if (not (List.is_empty std_deps)) && (not (compare_nodes x y) || not (deps_equal std_deps dts_deps)) then + p := add_edge !p x y (DataDep std_deps); + if (not (List.is_empty dts_deps)) && (not (compare_nodes x y) || not (deps_equal std_deps dts_deps)) then + p := add_edge !p y x (DataDep dts_deps); + end + ) pdg.nodes; + !p + + +let add_commuteDep_edges pdg (gc: group_commute node list) : exe_pdg = + let find_commute_condition l1 l2 = + let res = ref (None,[],[]) in + List.iter ( + fun {elt=(bl, cond); _} -> + let check_label label lb_list = + List.exists (fun (l,_) -> String.equal (fst label) l) lb_list + in + let find_label_args label lb_list = + let args = snd (List.find (fun (l,_) -> String.equal (fst label) l) lb_list) + in match args with + | None -> [] + | Some a -> List.map (function | {elt=Id s; _} -> s | _ -> failwith "Non-ids used for formal parameters in gcommute condition.") a + in + apply_distinct_pairs ( + fun x y -> + if (check_label l1 x && check_label l2 y) then + res := ((Some cond), find_label_args l1 x, find_label_args l2 y) + else if (check_label l1 y && check_label l2 x) then + res := ((Some cond), find_label_args l1 y, find_label_args l2 x) + ) bl + ) gc; + res + in + let p = ref pdg in + apply_pairs (fun (x : pdg_node) (y : pdg_node) -> + begin match x.src, y.src with + | Some {elt=(SBlock (Some l1, _)); loc=_}, Some {elt=(SBlock (Some l2, _)); loc=_} -> + let cond, vars1, vars2 = !(find_commute_condition l1 l2) in + begin match cond with + | None -> () + | Some (PhiExp cond) -> p := add_edge !p x y (Commute (cond, vars1, vars2)) + | _ -> failwith "undefined commute condition" + end + | _, _ -> () + end + ) pdg.nodes; + !p + + +type visited = (pdg_node * bool) list + +let rec mark_visited n visited = + match visited with + | [] -> visited + | (node, _) :: rest -> + if node = n then + (node, true) :: rest + else + (node, false) :: mark_visited n rest + +(* Function to check if a dependence arc is loop-carried *) +let is_loop_carried_dependence (pdg: exe_pdg) (edge: pdg_edge) = + let n1 = edge.src in + let n2 = edge.dst in +let find_outermost_loop_header pdg mem_node : pdg_node option = + let is_loop_header (node: pdg_node) = + match node.n with + | EFor _ | EWhile _ -> true + | _ -> false + in + let header = ref None in + let rec traverse_backwards (node: pdg_node) visited = + if List.mem node visited then None + else begin + if (is_loop_header node) then + header := Some node; + let predecessors = List.filter_map (fun e -> + if compare_nodes e.dst node && e.dep == ControlDep then Some e.src else None) pdg.edges in + begin match + List.fold_left (fun acc pred -> + match acc with + | Some _ -> acc + | None -> traverse_backwards pred (node :: visited)) None predecessors + with + | None -> !header + | h -> h + end + end + in + traverse_backwards mem_node [] + + in + match edge.dep with + | DataDep register -> + (* Check if the definition of the register reaches the outermost loop header *) + let rec definition_reaches_outer_loop_header (node: pdg_node) (visited: visited ref) = + if List.assoc node !visited then false + else begin + visited := mark_visited node !visited; + let outer_loop_header = find_outermost_loop_header pdg node in + match outer_loop_header with + | None -> false + | Some outer_loop_header -> + if compare_nodes outer_loop_header node then true + else match List.find_opt (fun e -> compare_nodes e.dst node) pdg.edges with + | None -> false + | Some e -> definition_reaches_outer_loop_header e.src visited + end + in + let visited = ref @@ List.map (fun v -> (v, false)) pdg.nodes in + let definition_reaches_outer_loop_header = definition_reaches_outer_loop_header n1 visited in + (* Check if there is an upwards-exposed use of the register in n2 at the outermost loop header *) + let upwards_exposed_use_in_outer_loop_header = + let outer_loop_header = find_outermost_loop_header pdg n1 in + match outer_loop_header with + | None -> false + | Some outer_loop_header -> + let rec has_upwards_exposed_use node = + let uses, _ = List.split (List.filter (fun (v, side) -> side == rvalue) (find_stmt_vars node.n)) in + if List.exists (fun (_, use) -> List.exists (fun (_, r) -> String.equal use r) register) uses then true + else match List.find_opt (fun e -> compare_nodes e.src node) pdg.edges with + | None -> false + | Some e -> + if compare_nodes outer_loop_header e.src then false (* Reached outermost loop header *) + else has_upwards_exposed_use e.src + in + has_upwards_exposed_use n2 + in + definition_reaches_outer_loop_header && upwards_exposed_use_in_outer_loop_header + (* | ControlDep -> + let rec is_loop_carried_control_dependence n1 n2 pdg visited = + if compare_nodes n1 n2 then + true + else if List.mem n1 !visited then + false + else begin + visited := n1 :: !visited; + List.fold_left (fun acc node -> + if is_loop_carried_control_dependence node n2 pdg visited then + acc && true + else + false + ) true (List.fold_left (fun acc e -> if compare_nodes e.src n1 then acc @ [e.dst] else acc ) [] pdg.edges) + end + in + is_loop_carried_control_dependence n1 n2 pdg (ref []) *) + | _ -> false + +(* Function to find loop-carried dependencies in the exe_pdg graph *) +let mark_loop_carried_dependencies pdg : exe_pdg = + let nodes = match pdg.entry_node with | Some e -> e :: pdg.nodes | None -> pdg.nodes in + let pdg_tmp = {pdg with nodes= nodes} in + let e = List.map (fun edge -> if is_loop_carried_dependence pdg_tmp edge then {edge with loop_carried= true} else edge) pdg_tmp.edges + in + {pdg with edges = e} + +let local_decl = ref [] + +let build_pdg (block: block) entry_loc (gc: group_commute node list) : exe_pdg = + let pdg = empty_exe_pdg() in + let pdg = { pdg with entry_node = Some {l= entry_loc; n= Entry; src= None} } in + let rec traverse_ast block pdg : exe_pdg = + match block with + | [] -> pdg + | stmt::tl -> + let updated_pdg = begin match stmt.elt with + | Decl _ -> + local_decl := !local_decl @ [Some stmt]; + snd (add_node pdg stmt) + | If (e, blk1, blk2) -> + let src, pdg = add_node pdg stmt in + let pdg = traverse_ast blk2.elt (traverse_ast blk1.elt pdg) in + + List.fold_left (fun pdg s -> add_edge pdg src (find_node s pdg) ControlDep) pdg blk1.elt + + | While (_, bl) | For (_, _, _, bl) -> + let src, pdg = add_node pdg stmt in + let pdg = traverse_ast bl.elt pdg in + + let pdg = add_edge pdg src src ControlDep in + List.fold_left (fun pdg s -> add_edge pdg src (find_node s pdg) ControlDep) pdg bl.elt + + (* | SBlock (None, bl) -> + traverse_ast bl.elt pdg *) + (* | SBlock (blocklabel, bl) -> + let n = stmt in + snd (add_node pdg n) *) + + | _ -> + snd (add_node pdg stmt) + end + in + traverse_ast tl updated_pdg + in + let pdg = (traverse_ast block pdg) in + (* add data dependency edges for each pairs of nodes *) + let pdg = add_dataDep_edges pdg in + (* add commute dependency edges *) + let pdg = add_commuteDep_edges pdg gc in + (* connect the entry node to the header nodes *) + let pdg = begin match pdg.entry_node with + | Some en -> List.fold_left (fun pdg s -> let n = find_node s pdg in add_edge pdg en n ControlDep) pdg block + | None -> pdg + end + in + mark_loop_carried_dependencies pdg + +let find_neighbors pdg node : pdg_node list = + List.fold_left (fun neighbors e -> if compare_nodes e.src node then neighbors @ [e.dst] else neighbors) [] pdg.edges + +let is_separate_node (node: pdg_node) : bool = + match node.src with + | Some{elt=(SBlock ((Some _), _))} -> true + | Some{elt=(SBlock (None, _))} -> if !commutativity_spec_exist then true else false + | _ -> false + +let rec dfs_util pdg (curr: pdg_node) (visited: visited ref) : pdg_node list = + visited := List.remove_assoc curr !visited @ [(curr, true)]; + let neighbors = find_neighbors pdg curr in + curr :: List.flatten (List.map (fun n -> if not (List.assoc n !visited) && not (is_separate_node n) then dfs_util pdg n visited else []) neighbors) + +let transpose pdg : exe_pdg = + {pdg with edges = List.map (fun {src=s; dst=d; dep=dp; loop_carried=l} -> {src=d; dst=s; dep=dp; loop_carried=l}) pdg.edges} + +let rec fill_order pdg (curr: pdg_node) (visited: visited ref) stack = + if not (List.assoc curr !visited) then begin + visited := List.remove_assoc curr !visited @ [(curr, true)]; + if not (is_separate_node curr) then begin + let neighbors = find_neighbors pdg curr in + List.iter (fun n -> fill_order pdg n visited stack) neighbors; + end; + Stack.push curr stack + end + +let find_sccs pdg : pdg_node list list = + let stack = Stack.create () in + let nodes = match pdg.entry_node with | Some e -> e :: pdg.nodes | None -> pdg.nodes in + let pdg = {pdg with nodes= nodes} in + let visited = ref @@ List.map (fun v -> (v, false)) pdg.nodes in + List.iter (fun n -> if not (List.assoc n !visited) then fill_order pdg n visited stack) pdg.nodes; + let reversed_pdg = transpose pdg in + let visited = ref @@ List.map (fun v -> (v, false)) pdg.nodes in + let sccs = ref [] in + while not (Stack.is_empty stack) do + let s = Stack.pop stack in + if not (List.assoc s !visited) then + if is_separate_node s then + sccs := !sccs @ [[s]] (* Place commute fragment nodes in their own SCC *) + else + sccs := !sccs @ [dfs_util reversed_pdg s visited] + done; + + let find_min li = List.fold_left (fun acc {l=(_,p,_)} -> Int.min acc (Range.line_of_pos p)) Int.max_int li in + sccs := List.sort (fun n1 n2 -> Int.compare (find_min n1) (find_min n2)) !sccs; + + !sccs + +let print_sccs (sccs: pdg_node list list) = + List.iter (fun s -> List.iter (fun c -> Printf.printf "%s " (Range.string_of_range_nofn c.l)) s; print_newline ()) sccs + +type dag_node_label = Doall | Sequential + +type dag_node = { + n : pdg_node list; + label: dag_node_label +} + +type dag_edge = { + dag_src : dag_node; + dag_dst : dag_node; + dep : dependency; + loop_carried : bool +} + +type dag_scc = { + entry_node: dag_node option; + nodes : dag_node list; + edges : dag_edge list; +} + +let id_of_dag_node (dn:dag_node) : string = + List.fold_left (fun acc pdgnode -> acc ^ "_" ^ (Range.string_of_range_nofn pdgnode.l)) "" dn.n + +let dag_pdgnode_to_string (pdgnodes:pdg_node list) : string = + List.fold_left (fun acc pnode -> acc ^ (Range.string_of_range_nofn pnode.l) + ^ ":"^(string_of_pdg_node_stmt pnode.n) ^ ",") "" pdgnodes + +let color_of_dagnode = function + | Doall -> "white" + | Sequential -> "gray" +let penwidth_of_dagedge de = + if de.loop_carried then "4.0" else "1.0" + +let print_dag (d:dag_scc) fn node_to_string_fn : unit = + let oc = open_out fn in + output_string oc (String.concat "\n" [ + "digraph G {"; + (* Styles *) + " graph [rankdir=\"TB\", fontname=\"Arial\", fontsize=24, label=\"DAG\", labelloc=t, labeljust=l]"; + " node [shape=box, style=\"rounded,filled\", fontname=\"Courier\", margin=0.05]"; + " edge [arrowhead=vee, arrowsize=1, fontname=\"Courier\", penwidth=4.0]"; + (* Nodes *) + List.fold_left (fun acc node -> acc ^ "\"" ^ (id_of_dag_node node) + ^ "\" [color=\""^(color_of_dagnode node.label)^"\" label=\""^(node_to_string_fn node.n)^"\"];\n") "" d.nodes; + (* edges *) + List.fold_left (fun acc e -> + let pw = penwidth_of_dagedge e in + acc ^ (match e.dep with + | DataDep vars -> + let vars = AstPP.string_of_args vars in + "\"" ^ (id_of_dag_node e.dag_src) ^ "\" -> \"" + ^ (id_of_dag_node e.dag_dst) ^ "\" " + ^ "[style=solid, color=green, label=\""^(dot_escape vars)^"\", penwidth=\""^pw^"\"];\n" + | Commute (exp, args1, args2) -> + let cond = AstPP.string_of_exp exp in + "\"" ^ (id_of_dag_node e.dag_src) ^ "\" -> \"" + ^ (id_of_dag_node e.dag_dst) ^ "\" " + ^ "[style=dotted, color=red, label=\""^(dot_escape cond)^"\", penwidth=\""^pw^"\"];\n" + | Disjoint + | ControlDep -> + "\"" ^ (id_of_dag_node e.dag_src) ^ "\" -> \"" + ^ (id_of_dag_node e.dag_dst) ^ "\" " + ^ "[style=dashed, color=maroon, penwidth=\""^(dot_escape pw)^"\"];\n" (*label=\""^(string_of_dep e.dep)^"\"];\n"*) + )) "" d.edges; + "}\n"; + ]); + debug_print (lazy ("dag written to " ^ fn)); + close_out oc + +let has_loop_carried (scc: pdg_node list) (pdg: exe_pdg) : bool = + let find_edge n1 n2 = + List.find_opt (fun e -> e.src == n1 && e.dst == n2) pdg.edges + in + let res = ref false in + apply_pairs ( + fun s1 s2 -> + let e1 = find_edge s1 s2 in + let e2 = find_edge s2 s1 in + res := !res || (match e1 with | None -> false | Some e -> e.loop_carried) || (match e2 with | None -> false | Some e -> e.loop_carried) + ) scc; + !res + +let compare_dag_nodes n1 n2 = + List.length n1.n = List.length n2.n && + List.for_all2 compare_nodes n1.n n2.n + +let remove_duplicate_edge (edges: dag_edge list) = + let rec is_member (n: dag_edge) (medges: dag_edge list) = + match medges with + | [] -> false + | h::tl -> + begin + if compare_dag_nodes h.dag_src n.dag_src && compare_dag_nodes h.dag_dst n.dag_dst && String.equal (string_of_dep h.dep) (string_of_dep n.dep) then true + else is_member n tl + end + in + let rec loop (lbuf: dag_edge list) = + match lbuf with + | [] -> [] + | h::tl -> + begin + let rbuf = loop tl + in + if is_member h rbuf then rbuf + else h::rbuf + end + in + loop edges + +let coalesce_sccs (pdg: exe_pdg) (sccs: pdg_node list list) : dag_scc = + let update_edges = ref pdg.edges in + let update_nodes = ref pdg.nodes in + let sccs = ref sccs in + let entry = + match pdg.entry_node with + | None -> None + | Some e -> + let remove_node nodes n = + let rec remove_from_list x lst = match lst with + | [] -> [] + | hd :: tl -> if (compare_nodes hd x) then remove_from_list x tl + else hd :: remove_from_list x tl + in + let rec remove_from_2d_list x lst2d = match lst2d with + | [] -> [] + | hd :: tl -> (remove_from_list x hd) :: (remove_from_2d_list x tl) + in + sccs := List.filter (fun s -> not (List.is_empty s)) (remove_from_2d_list n !sccs); + List.filter (fun node -> not (compare_nodes n node)) nodes + in + let remove_edge edges e = + List.filter (fun edge -> not ((compare_nodes e.src edge.src) && (compare_nodes e.dst edge.dst))) edges + in + let new_entry = List.fold_left (fun acc edge -> if compare_nodes edge.src e && List.mem edge.dst.src !local_decl then begin update_nodes := remove_node !update_nodes edge.dst; update_edges := remove_edge !update_edges edge; acc @ [edge.dst] end else acc) [] pdg.edges in + sccs := List.map (fun s -> if List.mem e s then [e] @ new_entry else s) !sccs; + Some {n = [e] @ new_entry; label = Sequential} + in + let sccs = !sccs in + let pdg = {pdg with nodes = !update_nodes; edges = !update_edges} in + let nodes = List.map (fun scc -> if has_loop_carried scc pdg then {n= scc; label= Sequential} else {n= scc; label= Doall}) sccs in + let find_node_scc n scc = + List.mem n scc + in + let find_dag_node (sub_node : pdg_node) = + List.find (fun node -> List.exists (fun e -> compare_nodes e sub_node) node.n) nodes + in + let is_scc (n1: pdg_node) (n2: pdg_node) : bool = + List.exists (fun scc -> find_node_scc n1 scc && find_node_scc n2 scc) sccs + in + let filtered_edges = List.filter (fun {src= s; dst= d; _} -> not (is_scc s d) || (compare_nodes s d)) pdg.edges in + let edges = List.map ( + fun {src= s; dst= d; dep=dp; loop_carried =l} -> + {dag_src= find_dag_node s; dag_dst= find_dag_node d; dep=dp; loop_carried=l} + ) filtered_edges in + let edges = remove_duplicate_edge edges in + let nodes = List.filter (fun n -> match entry with | None -> true | Some node -> not (compare_dag_nodes n node)) nodes in + {entry_node = entry; nodes; edges} + + +let string_of_dag_label = function + | Doall -> "doall" + | Sequential -> "sequential" + + +let print_dag_debug dag_scc = + if !Util.debug then begin + let string_of_node n = List.fold_left (fun acc s -> acc ^ (Range.string_of_range_nofn s.l) ^ " ") "" n in + begin match dag_scc.entry_node with | Some en -> Printf.printf "entry node: %s\n" (string_of_node en.n) | _ -> () end; + List.iteri (fun i sl -> Printf.printf "node %d (%s): %s" i (string_of_dag_label sl.label) (string_of_node sl.n); print_newline()) dag_scc.nodes; + List.iteri (fun i e -> Printf.printf "dag_edge %d (%s) - %b: %s - %s\n" i (string_of_dep e.dep) e.loop_carried (string_of_node e.dag_src.n) (string_of_node e.dag_dst.n)) dag_scc.edges end + +let rec all_in_list_a_in_b list_a list_b = + match list_a with + | [] -> true + | hd :: tl -> + if List.mem hd list_b then + all_in_list_a_in_b tl list_b + else + false + +let is_return_node (node : dag_node) = + List.exists (fun {l=loc;n=_;src = Some s} -> match s.elt with | Ret _ -> true | _ -> false) node.n + +let rec find_ancestors ancestors visited edges src_node = + List.fold_left (fun acc edge -> + if edge.dag_dst = src_node && not (List.mem edge.dag_src acc) && edge.dep == ControlDep then + if not (List.mem edge.dag_src visited) then + find_ancestors (edge.dag_src :: acc) (edge.dag_src :: visited) edges edge.dag_src + else + acc + else + acc + ) ancestors edges + +(* Function to merge doall blocks greedily *) +let merge_doall_blocks dag_scc (pdg: exe_pdg) = + let find_reachable_blocks block dag_scc visited = + let reachable_blocks = ref [] in + let rec dfs node = + if not (List.mem node !visited) then begin + visited := node :: !visited; + List.iter (fun e -> + if e.dag_src == node then dfs e.dag_dst) dag_scc.edges; + if node != block && node.label = Doall then + reachable_blocks := node :: !reachable_blocks + end + in + dfs block; + !reachable_blocks + in + let can_merge_blocks block1 block2 dag_scc = + let c = List.exists ( + fun e -> + (all_in_list_a_in_b e.dag_src.n block1.n + && all_in_list_a_in_b e.dag_dst.n block2.n + || + all_in_list_a_in_b e.dag_src.n block2.n + && all_in_list_a_in_b e.dag_dst.n block1.n) + &&( + e.dep == ControlDep || + let b1_ancestors = last_element (find_ancestors [] [] dag_scc.edges block1) in + let b2_ancestors = last_element (find_ancestors [] [] dag_scc.edges block2) in + match b1_ancestors, b2_ancestors with | Some b1, Some b2 -> compare_dag_nodes b1 b2 | _ ->false + ) + ) dag_scc.edges in + let reachable_from_block1 = find_reachable_blocks block1 dag_scc (ref []) in + let reachable_from_block2 = find_reachable_blocks block2 dag_scc (ref []) in + let a = not (List.exists (fun b -> List.exists (fun e -> compare_dag_nodes e.dag_src b && compare_dag_nodes e.dag_dst block2) dag_scc.edges) reachable_from_block1) in + let b = not (List.exists (fun b -> List.exists (fun e -> compare_dag_nodes e.dag_src b && compare_dag_nodes e.dag_dst block1) dag_scc.edges) reachable_from_block2) in + (* let d = not (has_loop_carried block1.n pdg) in + let e = not (has_loop_carried block2.n pdg) in *) + let d = not (List.exists ( + fun e -> + (all_in_list_a_in_b e.dag_src.n block1.n + && all_in_list_a_in_b e.dag_dst.n block2.n + || + all_in_list_a_in_b e.dag_src.n block2.n + && all_in_list_a_in_b e.dag_dst.n block1.n) + && e.loop_carried + || + match e.dep with | Commute _ -> true | _ -> false + ) dag_scc.edges) in + a && b&& d && c && (block1.label == Doall && block2.label = Doall) + && not (is_return_node block1) + && not (is_return_node block2) + in + let rec merge_blocks block dag_scc visited = + if List.mem block !visited then + dag_scc, visited + else begin + visited := block :: !visited; + let rec find_mergeable_blocks acc = function + | [] -> acc + | hd :: tl -> + let a = can_merge_blocks block hd dag_scc in + if hd != block && a then find_mergeable_blocks (hd :: acc) tl + else find_mergeable_blocks acc tl + in + let mergeable_blocks = find_mergeable_blocks [] dag_scc.nodes in + match mergeable_blocks with + | [] -> dag_scc, visited + | _ -> + List.iter (fun block -> visited := block :: !visited) mergeable_blocks; + let merged_block = { n = List.flatten (List.map (fun b -> b.n) (block :: mergeable_blocks)); label = Doall } in + let remaining_blocks = List.filter (fun b -> not (List.mem b mergeable_blocks) && b != block) dag_scc.nodes in + let new_edges = List.filter (fun e -> not (all_in_list_a_in_b e.dag_src.n merged_block.n && all_in_list_a_in_b e.dag_dst.n merged_block.n)) dag_scc.edges in + let nodes = merged_block :: remaining_blocks in + let temp_nodes = match dag_scc.entry_node with | Some s -> {n = s.n; label = Doall} :: nodes | None -> nodes in + let updated_edges = List.map ( + fun e -> + let src = List.find (fun n -> all_in_list_a_in_b e.dag_src.n n.n) temp_nodes in + let dst = List.find (fun n -> all_in_list_a_in_b e.dag_dst.n n.n) temp_nodes in + { e with dag_src = src; dag_dst = dst } ) new_edges in + let updated_edges = remove_duplicate_edge updated_edges in + let updated_dag_scc = { dag_scc with nodes = nodes; edges = updated_edges } in + merge_blocks merged_block updated_dag_scc visited + end + in + let merge_all_blocks dag_scc visited = + let blocks_to_merge = List.filter (fun node -> node.label = Doall) dag_scc.nodes in + List.fold_left (fun (acc, visited) block -> merge_blocks block acc visited) (dag_scc, visited) blocks_to_merge + in + let merged_dag_scc, _ = merge_all_blocks dag_scc (ref []) in + merged_dag_scc + + +(* Function to retain the doall block with the maximum profile weight *) +let retain_max_profile_doall dag_scc = + let is_labeled (node:dag_node) = + List.for_all (fun (p:pdg_node) -> match p.n with | EStmt ({elt = SBlock _; _}) -> true | _ -> false ) node.n + in + let doall_blocks = List.filter (fun node -> node.label = Doall) dag_scc.nodes in + match doall_blocks with + | [] -> dag_scc + | _ -> + let max_profile_weight_block = List.fold_left (fun acc block -> + let weight = List.length block.n in + if weight > (List.length acc.n) then block else acc + ) (List.hd doall_blocks) (List.tl doall_blocks) in + let remaining_doall_blocks = List.filter (fun node -> node != max_profile_weight_block) doall_blocks in + let updated_max_profile_block = { max_profile_weight_block with label = Doall } in + let updated_sequential_blocks = List.map (fun node -> if is_labeled node then node else { node with label = Sequential }) remaining_doall_blocks in + let updated_nodes = updated_max_profile_block :: updated_sequential_blocks @ List.filter (fun node -> node.label != Doall) dag_scc.nodes in + { dag_scc with nodes = updated_nodes } + +(** TODO: revise this*) +(* Function to merge sequential blocks greedily *) +let merge_sequential_blocks dag_scc = + (* let rec merge_blocks acc dag_scc = + let sequential_blocks = List.filter (fun node -> node.label = Sequential) dag_scc.nodes in + match sequential_blocks with + | [] -> dag_scc + | _ -> + let first_block = List.hd sequential_blocks in + let remaining_blocks = List.tl sequential_blocks in + let merged_block = List.fold_left (fun acc node -> merge_blocks acc node) first_block remaining_blocks in + let updated_nodes = merged_block :: List.filter (fun node -> node != first_block && not (List.mem node remaining_blocks)) dag_scc.nodes in + merge_blocks merged_block { dag_scc with nodes = updated_nodes } + in + merge_blocks [] dag_scc *) + + let can_merge_blocks block1 block2 dag_scc = + List.exists ( + fun e -> + all_in_list_a_in_b e.dag_src.n block1.n + && all_in_list_a_in_b e.dag_dst.n block2.n + || + all_in_list_a_in_b e.dag_src.n block2.n + && all_in_list_a_in_b e.dag_dst.n block1.n + ) dag_scc.edges + && (block1.label == Sequential && block2.label = Sequential) + && not (is_return_node block1) + && not (is_return_node block2) + in + let rec merge_blocks block dag_scc visited = + if List.mem block !visited then + dag_scc, visited + else begin + visited := block :: !visited; + let rec find_mergeable_blocks acc = function + | [] -> acc + | hd :: tl -> + let a = can_merge_blocks block hd dag_scc in + if hd != block && a then find_mergeable_blocks (hd :: acc) tl + else find_mergeable_blocks acc tl + in + let mergeable_blocks = find_mergeable_blocks [] dag_scc.nodes in + match mergeable_blocks with + | [] -> dag_scc, visited + | _ -> + List.iter (fun block -> visited := block :: !visited) mergeable_blocks; + let merged_block = { n = List.flatten (List.map (fun b -> b.n) (block :: mergeable_blocks)); label = Sequential } in + let remaining_blocks = List.filter (fun b -> not (List.mem b mergeable_blocks) && b != block) dag_scc.nodes in + let new_edges = List.filter (fun e -> not (all_in_list_a_in_b e.dag_src.n merged_block.n && all_in_list_a_in_b e.dag_dst.n merged_block.n)) dag_scc.edges in + let nodes = merged_block :: remaining_blocks in + let temp_nodes = match dag_scc.entry_node with | Some s -> {n = s.n; label = Sequential} :: nodes | None -> nodes in + let updated_edges = List.map ( + fun e -> + let src = List.find (fun n -> all_in_list_a_in_b e.dag_src.n n.n) temp_nodes in + let dst = List.find (fun n -> all_in_list_a_in_b e.dag_dst.n n.n) temp_nodes in + { e with dag_src = src; dag_dst = dst } ) new_edges in + let updated_edges = remove_duplicate_edge updated_edges in + let updated_dag_scc = { dag_scc with nodes = nodes; edges = updated_edges } in + (* print_dag_debug updated_dag_scc; *) + merge_blocks merged_block updated_dag_scc visited + end + in + let merge_all_blocks dag_scc visited = + let blocks_to_merge = List.filter (fun node -> node.label = Sequential) dag_scc.nodes in + List.fold_left (fun (acc, visited) block -> merge_blocks block acc visited) (dag_scc, visited) blocks_to_merge + in + let merged_dag_scc, _ = merge_all_blocks dag_scc (ref []) in + merged_dag_scc + + +let ctr = ref 0 + +let incr_uid (ctr: int ref) = + ctr := !ctr + 1; + !ctr + + +let find_taskIDs_from_node_list dag_scc elemList: int list = + let find_taskID_from_node dag_scc elem : int = + let tmp = ref 0 in + List.iteri (fun i n -> if (List.exists (fun s -> String.equal elem (Range.string_of_range_nofn s.l)) n.n) then tmp := i + 1 ) dag_scc.nodes; + !tmp + in + List.map (find_taskID_from_node dag_scc) elemList + +let sendDep_exists = ref [] +let make_new_job_out = ref [] +let make_new_job_in = ref [] + +let reconstructAST dag dag_scc_node (block: block node) taskID : block = + let sendDeps = ref [] in + let remove_and_find_nodes dag new_block old_block = + List.filter (fun s -> not (List.mem s new_block)) old_block.elt + |> List.map (fun s -> + let removed_loc = Range.string_of_range_nofn s.loc in + let [tid] = find_taskIDs_from_node_list dag [removed_loc] in + (s.loc, tid) + ) + in + let augment_block new_block removed_nodes = + let augmented_block = + List.fold_left (fun acc (l, task_id) -> + if not (List.mem task_id !sendDeps) then begin + sendDeps := task_id :: !sendDeps; + make_new_job_in := task_id :: !make_new_job_in; + make_new_job_out := taskID :: !make_new_job_out; + acc @ [{ elt = SendDep (task_id, []); loc = l }] + end + else acc + ) new_block removed_nodes + in + List.sort (fun s1 s2 -> + let (_, p1, _) = s1.loc in + let (_, p2, _) = s2.loc in + Int.compare (Range.line_of_pos p1) (Range.line_of_pos p2) + ) augmented_block + in + let rec transform_block dag_scc_node (block: block node) : block * bool = + let stmt_exist stmt node = + List.exists (fun s -> String.equal (Range.string_of_range s.l) (Range.string_of_range stmt.loc)) node.n + in + let res = match block.elt with + | [] -> [] , true + | stmt::tl -> + begin match stmt.elt with + (* | If (e, b, {elt = []; loc = l}) -> + let new_b, new_f = transform_block dag_scc_node b in + if stmt_exist stmt dag_scc_node then begin + let updated_b = + if not new_f then + remove_and_find_nodes dag new_b b + |> augment_block new_b + else + new_b + in + let rest, f = transform_block dag_scc_node (node_up block tl) in + (node_up stmt (If (e, node_up b updated_b, {elt = []; loc = l}))) :: rest, true && f + end else begin + let rest, f = transform_block dag_scc_node (node_up block tl) in + new_b @ rest, false && f + end *) + | If (e, b1, b2) -> + let new_b1, f1 = transform_block dag_scc_node b1 in + let new_b2, f2 = transform_block dag_scc_node b2 in + if stmt_exist stmt dag_scc_node then begin + let updated_b1 = + if not f1 then + remove_and_find_nodes dag new_b1 b1 + |> augment_block new_b1 + else + new_b1 + in + let updated_b2 = + if not f2 then + remove_and_find_nodes dag new_b2 b2 + |> augment_block new_b2 + else + new_b2 + in + let rest, f = transform_block dag_scc_node (node_up block tl) in + (node_up stmt (If (e, node_up b1 updated_b1, node_up b2 updated_b2))) :: rest, true && f + end else begin + let rest, f = transform_block dag_scc_node (node_up block tl) in + new_b1 @ new_b2 @ rest, false && f + end + | While (e, b) -> + let new_body, f = transform_block dag_scc_node b in + if stmt_exist stmt dag_scc_node then begin + let updated_body = + if not f then + remove_and_find_nodes dag new_body b + |> augment_block new_body + else + new_body + in + let rest, f = transform_block dag_scc_node (node_up block tl) in + (node_up stmt (While (e, node_up b updated_body))) :: rest, true && f + end else begin + let rest, f = transform_block dag_scc_node (node_up block tl) in + new_body @ rest, false && f + end + + | For (v,e,s,b) -> + let new_body, f = transform_block dag_scc_node b in + if stmt_exist stmt dag_scc_node then begin + let updated_body = + if not f then + remove_and_find_nodes dag new_body b + |> augment_block new_body + else + new_body + in + let rest, f = transform_block dag_scc_node (node_up block tl) in + (node_up stmt (For (v, e, s, node_up b updated_body))) :: rest, true && f + end else begin + let rest, f = transform_block dag_scc_node (node_up block tl) in + new_body @ rest, false && f + end + | s -> + if stmt_exist stmt dag_scc_node + then begin + let rest, f = (transform_block dag_scc_node (no_loc tl)) in + stmt :: rest, true && f + end + else begin + let rest, f = (transform_block dag_scc_node (no_loc tl)) in + rest, false && f + end + end + in + res + in + let bl = fst (transform_block dag_scc_node block) in + sendDep_exists := !sendDep_exists @ !sendDeps; + List.fold_left (fun b i -> b @ [no_loc (SendEOP i)]) bl (List.rev !sendDeps) + + +let fill_task_dependency (dag: dag_scc) (tasks: (int * dswp_task) list) = + let find_taskID node = + let temp = ref 0 in + List.iteri (fun i n -> if compare_dag_nodes n node then temp := i + 1) dag.nodes; + !temp + in + let res = ref tasks in + List.iter ( + fun e -> + let src_taskID = find_taskID e.dag_src in + let dst_taskID = find_taskID e.dag_dst in + match e.dep with + | DataDep vars -> + let src_task = List.assoc src_taskID !res in + if src_taskID = dst_taskID then begin + let updated_task = (src_taskID, + {src_task with deps_out = {pred_task= dst_taskID; make_new_job=if List.mem dst_taskID !make_new_job_in && List.mem src_taskID !make_new_job_out then true else false; vars; commute_cond = {my_task_formals =[]; other_task_formals=[]; condition=None}} :: src_task.deps_out; + deps_in = {pred_task= src_taskID; make_new_job=if List.mem src_taskID !make_new_job_out && List.mem dst_taskID !make_new_job_in then true else false; vars; commute_cond = {my_task_formals =[]; other_task_formals=[]; condition=None}} :: src_task.deps_in}) in + res := updated_task :: List.remove_assoc src_taskID !res + end + else begin + let dst_task = List.assoc dst_taskID !res in + let new_src_task = (src_taskID, {src_task with deps_out = {pred_task= dst_taskID; make_new_job= if List.mem dst_taskID !make_new_job_in && List.mem src_taskID !make_new_job_out then true else false; vars; commute_cond = {my_task_formals =[]; other_task_formals=[]; condition=None}} :: src_task.deps_out}) in + let new_dst_task = (dst_taskID, {dst_task with deps_in = {pred_task= src_taskID; make_new_job= if List.mem src_taskID !make_new_job_out && List.mem dst_taskID !make_new_job_in then true else false; vars; commute_cond = {my_task_formals =[]; other_task_formals=[]; condition=None}} :: dst_task.deps_in}) in + res := new_src_task :: new_dst_task :: + List.remove_assoc dst_taskID (List.remove_assoc src_taskID !res) + end + | Commute (c, args1, args2) -> + let src_task = List.assoc src_taskID !res in + if src_taskID = dst_taskID then begin + let updated_task = (src_taskID, + {src_task with deps_out = {pred_task= dst_taskID; make_new_job = false; vars = []; commute_cond = {my_task_formals =args1; other_task_formals= args2; condition=Some c}} :: src_task.deps_out; + deps_in = {pred_task= src_taskID; make_new_job = false; vars = []; commute_cond = {my_task_formals =args2; other_task_formals= args1; condition=Some c}} :: src_task.deps_in}) in + res := updated_task :: List.remove_assoc src_taskID !res + end + else begin + (* When src_taskID and dst_taskID are different, update both tasks *) + let dst_task = List.assoc dst_taskID !res in + let new_src_task = (src_taskID, {src_task with deps_out = {pred_task= dst_taskID; make_new_job = false; vars = []; commute_cond = {my_task_formals =args1; other_task_formals= args2; condition=Some c}} :: src_task.deps_out}) in + let new_dst_task = (dst_taskID, {dst_task with deps_in = {pred_task= src_taskID; make_new_job = false; vars = []; commute_cond = {my_task_formals =args2; other_task_formals= args1; condition=Some c}} :: dst_task.deps_in}) in + res := new_src_task :: new_dst_task :: + List.remove_assoc dst_taskID (List.remove_assoc src_taskID !res) + end + | _ ->() + ) dag.edges; + + let out_tasks = (snd (List.split !res)) in + + let update_sendDep_of_task (task: dswp_task) : dswp_task = + let rec update_body (body: block) : block = + match body with + | [] -> body + | stmt::tl -> + let s' = begin match stmt.elt with + | SendDep (i, vars) -> + let t = (List.find (fun tk -> tk.id == i) out_tasks) + in + SendDep (i, vars @ (List.concat_map (fun d -> if d.pred_task == task.id then d.vars else []) t.deps_in)) + | If(e,bl1,bl2) -> If(e, node_up bl1 (update_body bl1.elt), node_up bl2 (update_body bl2.elt)) + | While(e,bl) -> While(e, node_up bl (update_body bl.elt)) + | s -> s + end + in + (node_up stmt s') :: (update_body tl) + in + let b' = node_up task.body (update_body task.body.elt) in + {task with body = b'} + + in + List.map (fun t -> update_sendDep_of_task t) out_tasks + +let combine_dependencies (deps: Dswp_task.dependency list) : Dswp_task.dependency list = + let combine_dep d1 d2 = + { pred_task = d1.pred_task; + make_new_job = d1.make_new_job || d2.make_new_job; + vars = d1.vars @ d2.vars; + commute_cond = + if d1.commute_cond = d2.commute_cond then d1.commute_cond + else if d1.commute_cond.condition = None then d2.commute_cond + else if d2.commute_cond.condition = None then d1.commute_cond + else failwith "Conflicting commute conditions for the same pred_task" + } + in + let rec combine_helper sorted_deps = + match sorted_deps with + | [] | [_] -> sorted_deps + | d1 :: d2 :: rest -> + if d1.pred_task = d2.pred_task then + combine_helper ((combine_dep d1 d2) :: rest) + else + d1 :: combine_helper (d2 :: rest) + in + deps + |> List.sort (fun d1 d2 -> compare d1.pred_task d2.pred_task) + |> combine_helper + +let generate_tasks dag_scc (block: block node) : init_task * dswp_task list = + let dag_scc = ref dag_scc in + let generate_init_task () : init_task = + let decls, body = match !dag_scc.entry_node with + | Some entry -> + let entry_stmts = ref [] in + List.iter (fun {l=_; n=_;src = p} -> match p with | Some s -> entry_stmts:= !entry_stmts @ [s] | None -> ()) entry.n; + + let senddep_list = + List.fold_left + (fun b e -> + if compare_dag_nodes entry e.dag_src then begin + let elem = List.map (fun s -> Range.string_of_range_nofn s.l) e.dag_dst.n in + let i = List.hd (find_taskIDs_from_node_list !dag_scc elem) in + if List.mem i !sendDep_exists then + b + else + b @ [i] + end + else b + ) [] !dag_scc.edges + in + !entry_stmts, senddep_list + | None -> [], [] + in + let body = remove_duplicate body in + {decls = no_loc decls ; jobs = body; label= Dswp_task.Doall } + in + let dag_scc = !dag_scc in + let temp_dag = dag_scc in + let rec generate_tasks_from_dag dag_scc (block: block node) : dswp_task list = + match dag_scc.nodes with + | [] -> [] + | node::tl -> + let taskID = incr_uid ctr in + let body = reconstructAST temp_dag node block taskID in + let label = match node.label with | Doall -> Dswp_task.Doall | Sequential -> Dswp_task.Sequential in + let t = {id = taskID; deps_in = []; deps_out = []; body = node_up block body; label } in + t :: (generate_tasks_from_dag {dag_scc with nodes = tl} block) + in + let tasks = generate_tasks_from_dag dag_scc block in + debug_print (lazy (Printf.sprintf "Number of tasks: %d\n" (List.length tasks))); + let init_task = generate_init_task () in + let new_edges = List.filter (fun {dag_src= s} -> match dag_scc.entry_node with | Some e -> not (compare_dag_nodes s e) | None -> true) dag_scc.edges in + let new_edges = List.filter (fun {dag_dst= s} -> match dag_scc.entry_node with | Some e -> not (compare_dag_nodes s e) | None -> true) new_edges in + let tasks = fill_task_dependency {dag_scc with edges = new_edges} (List.map (fun t -> (t.id, t)) tasks) in + let tasks = List.map (fun t-> {t with deps_in = combine_dependencies t.deps_in; deps_out = combine_dependencies t.deps_out}) tasks in + init_task, tasks + +(* use empty data dependency edges intead of using SendEOP *) +let add_empty_data_dep_edges dag_scc = + let new_edges = ref dag_scc.edges in + let check_node_is_spawned node = + List.exists (fun e -> compare_dag_nodes e.dag_dst node && e.dep == ControlDep) dag_scc.edges + in + List.iter (fun edge -> + match edge.dep with + | DataDep _ -> + let ancestors = find_ancestors [] [] dag_scc.edges edge.dag_src in + List.iter (fun ancestor -> + if (not (compare_dag_nodes ancestor edge.dag_dst)) && check_node_is_spawned edge.dag_dst && check_node_is_spawned edge.dag_src then begin + let new_edge = { dag_src = ancestor; dag_dst = edge.dag_dst; dep = (DataDep []); loop_carried = false } in + if not (List.mem new_edge !new_edges) && not (List.exists (fun e -> compare_dag_nodes e.dag_src new_edge.dag_src && compare_dag_nodes e.dag_dst new_edge.dag_dst && match e.dep with | DataDep _ -> true | _ -> false) !new_edges) then + new_edges := new_edge :: !new_edges + else + () + end + ) ancestors + | _ -> () + ) dag_scc.edges; + apply_distinct_pairs (fun x y -> + if !Util.manual_dependency then begin + let new_edge = { dag_src = x; dag_dst = y; dep = (DataDep []); loop_carried = false } in + if not (List.mem new_edge !new_edges) && not (is_return_node x) && not (is_return_node y) then begin + new_edges := new_edge :: !new_edges + end + else () + end + ) dag_scc.nodes; + { dag_scc with edges = !new_edges } + +let thread_partitioning dag_scc pdg (threads: int list) body = + debug_print (lazy "Merging DAG_scc:\n"); + let merged_dag = merge_doall_blocks dag_scc pdg in + let dag_scc_with_max_profile = retain_max_profile_doall merged_dag in + print_dag_debug dag_scc_with_max_profile; + let dag_scc_merged_sequential = merge_sequential_blocks dag_scc_with_max_profile in + let merged_dag = dag_scc_merged_sequential in + print_dag_debug merged_dag; + print_dag merged_dag "/tmp/merged-dag-scc.dot" dag_pdgnode_to_string; + let merged_dag_with_added_deps = add_empty_data_dep_edges merged_dag in + debug_print (lazy "add empty data dependency edges:\n"); + print_dag_debug merged_dag_with_added_deps; + print_dag merged_dag_with_added_deps "/tmp/merged-dag-scc2.dot" dag_pdgnode_to_string; + let init_task, tasks = generate_tasks merged_dag_with_added_deps body in + if !Util.debug then begin + Printf.printf "Init Task -> \n %s \n [%s] \n" (AstPP.string_of_block init_task.decls) (String.concat ", " (List.map Int.to_string init_task.jobs)); + List.iter (fun t -> Printf.printf "Task ID = %d ->\n %s \n" t.id (AstPP.string_of_block t.body)) tasks; + List.iter (fun t -> Printf.printf "%s \n" (str_of_task t)) tasks end; + init_task, tasks + + + +let ps_dswp (body: block node) m_loc m_args (g: global_env) globals = + List.iter ( + fun (id, (ty,e)) -> + let decl = Gvdecl (no_loc { name = id; ty = ty; init = e}) in + decl_vars := !decl_vars @ [decl] + ) globals; + m_vars := m_args; + + commutativity_spec_exist := (List.length (g.group_commute) > 0); + + let pdg = build_pdg body.elt m_loc g.group_commute in + print_pdg_debug pdg; + print_pdg pdg "/tmp/pdg.dot"; + let sccs = find_sccs pdg in + if !Util.debug then begin + Printf.printf "Strongly Connected Components:\n"; + print_sccs sccs end; + let dag_scc = coalesce_sccs pdg sccs in + debug_print (lazy "DAG_SCCs:\n"); + print_dag_debug dag_scc; + print_dag dag_scc "/tmp/dag-scc.dot" dag_pdgnode_to_string; + let init_task, tasks = thread_partitioning dag_scc pdg [] body in + debug_print (lazy (Printf.sprintf "gen_tasks called with %d globals\n" (List.length !decl_vars))); + if !codegen then begin + Codegen_c.gen_tasks (!decl_vars) tasks; + Codegen_c.print_tasks init_task tasks "/tmp/tasks.dot" end; + generated_init_task := Some init_task; + generated_tasks := tasks; + generated_decl_vars := !decl_vars; diff --git a/src/analysis/spec_generator.ml b/src/analysis/spec_generator.ml index 2ea46df..f0af9d8 100644 --- a/src/analysis/spec_generator.ml +++ b/src/analysis/spec_generator.ml @@ -15,7 +15,10 @@ let gstates = ref [] let terms_list = ref [] let variable_ctr_list = (Hashtbl.create 50) +let realWorld_vars = ["realWorld_data"; "realWorld_linenum"; "realWorld_opened"] + let pre = ref (EConst (CBool true)) +let smt_fn_list = ref [] let sexp_of_sexp_list = function | [e] -> e @@ -34,15 +37,41 @@ let generate_spec_predicates (embedding_vars : (ty binding * ety) list) : Servoi let generate_spec_statesEqual (em_vars : (ty binding * ety) list) : sexp = - let exp_list = List.map (fun (n,_) -> Smt.EBop (Eq, EVar (Var n), EVar (VarPost n))) (get_stypes em_vars) + (* The particular value of a channel doesn't matter. The equality is handled by the realWorld reasoning below. *) + let exp_list = List.map (fun n -> Smt.EBop (Eq, EVar (Var n), EVar (VarPost n))) (List.map fst (get_stypes em_vars) @ realWorld_vars) in sexp_of_sexp_list exp_list - - + + (* @ + [ Smt.EBop(Eq, EVar (Var "realWorld_opened"), EVar (VarPost "realWorld_opened")) + ; + ; EForall([(Var "fname", TString)], + EBop(Imp, + EFunc("member", [EVar(Var("fname")); EVar(Var("realWorld_opened"))]), + ELop(And, [ + EBop(Eq, + EFunc("select", [EVar(Var("realWorld_data")); EFunc("select", [EVar(Var("realWorld_mapping")); EVar(Var("fname"))])]), + EFunc("select", [EVar(VarPost("realWorld_data")); EFunc("select", [EVar(VarPost("realWorld_mapping")); EVar(Var("fname"))])]) + ); + EBop(Eq, + EFunc("select", [EVar(Var("realWorld_linenum")); EFunc("select", [EVar(Var("realWorld_mapping")); EVar(Var("fname"))])]), + EFunc("select", [EVar(VarPost("realWorld_linenum")); EFunc("select", [EVar(VarPost("realWorld_mapping")); EVar(Var("fname"))])]) + ); + ])))]) *) +(* realWorld_opened = realWorld_opened_post and + realWorld_Handles = realWOrld_handles_post + forall fname : String . fname in realWorld_opened => + let fnum_pre = realWorld_mapping[fname] in + let fnum_post = realWorld_mapping[fname] in + realWorld_data[fname_pre] = realWorld_data_post[fname] and + realWorld_lineNum[fname] = realWorld_linenum_pose[fname] +*) let generate_spec_state (embedding_vars: (ty binding * ety) list) : sty Smt.bindlist = List.concat_map (fun ((id,ty),ety) -> let list_of_sty = compile_ety_to_sty id ety in List.map (fun (id, sty) -> (Smt.Var id, sty)) list_of_sty - ) embedding_vars + ) embedding_vars @ [ (Var "realWorld_data", Smt.TArray (Smt.TString, Smt.TArray(Smt.TInt, Smt.TString))) + ; (Var "realWorld_linenum", Smt.TArray (Smt.TString, Smt.TInt)) + ; (Var "realWorld_opened", Smt.TSet Smt.TString)] let create_dummy_method (b: block node) : mdecl = mIndex := !mIndex + 1; @@ -121,7 +150,8 @@ let get_exp_terms (e: exp node) : (sexp * ty) list = (t2, typ2) (* TODO: make sure if it's enough to return *) - | Call (MethodL (id, {pc=Some pc;_}), el) -> (EConst(CInt 0), TInt) (* TODO: make it work when it doesn't have any involved terms *) + | Call (MethodL _, _) + | Call (MethodM _, _) -> (EConst(CInt 0), TInt) (* TODO: make it work when it doesn't have any involved terms *) | _ -> failwith "Unknown expression!" in let _ = get_exp_term e in @@ -189,15 +219,19 @@ let set_variable_id (var: string) (side: int) (vctrs : (string, int ref) Hashtbl let get_postconditions () : sexp = let exp_list = ref [] in Hashtbl.iter (fun key -> fun value -> - let ((id,ty),ety) = try List.find (fun ((id,ty),_) -> String.equal key id) !gstates with | x -> print_string key; print_newline (); raise x in - let final = match ty with - | THashTable (_,_) -> - final_mangle !value ety - | _ -> let var = if !value == 0 then key else (key ^ "_" ^ Int.to_string (!value)) in - Smt.EBop (Eq, EVar (VarPost key), EVar (Var var)); - in - exp_list := !exp_list @ [final] - ) variable_ctr_list; + if List.mem key realWorld_vars then exp_list := !exp_list @ [final_mangle_id !value key] + else + match List.find_opt (fun ((id,ty),_) -> String.equal key id) !gstates with + | None -> print_string key; print_newline (); raise Not_found + | Some ((id,ty),ety) -> + let final = match ty with + | THashTable (_,_) -> + final_mangle !value ety + | _ -> let var = if !value == 0 then key else (key ^ "_" ^ Int.to_string (!value)) in + Smt.EBop (Eq, EVar (VarPost key), EVar (Var var)); + in + exp_list := !exp_list @ [final] + ) variable_ctr_list; sexp_of_sexp_list !exp_list let reset_to_local_variable_ctrs (old_vctrs : (string * int) list) (new_vctrs : (string, int ref) Hashtbl.t) = @@ -218,6 +252,17 @@ let make_temp_value_of_htbl (htbl : (string, int ref) Hashtbl.t) : (string * int Hashtbl.iter (fun id -> fun index -> temp := !temp @ [(id, !index)] ) htbl; ! temp + +let ty_of_exp e : ty = + match e.elt with + | CNull t -> t + | CBool _ -> TBool + | CInt _ -> TInt + | CStr _ -> TStr + | Id i -> snd (fst (List.find (fun ((id,t), _) -> String.equal i id) !gstates)) + | CArr (t,_) -> TArr t + | _ -> failwith "undefined exp" + let rec exp_to_smt_exp (e: exp node) (side: int) ?(indexed = true) (vctrs : (string, int ref) Hashtbl.t) : sexp * sexp Smt.bindlist = match e.elt with | CBool b -> Smt.EConst (CBool b), [] @@ -249,20 +294,35 @@ let rec exp_to_smt_exp (e: exp node) (side: int) ?(indexed = true) (vctrs : (str | Call (MethodL (id, {pc=Some pc;_}), el) -> let args_rtn, args_binds = List.split @@ List.map (fun exp -> exp_to_smt_exp exp right ~indexed vctrs) el in - let id_value = match (List.hd args_rtn) with | Smt.EVar (Var v) -> v | _ -> failwith "non string var" in + let id_value = match (List.hd args_rtn) with | Smt.EVar (Var v) -> v | _ -> failwith "non string var" in let dst_id = remove_index (id_value) in let ((_,_),ety) = List.find (fun ((gid,_),_) -> String.equal gid dst_id) !gstates in let embedding_type_index = match (Hashtbl.find_opt vctrs dst_id) with | None -> 0 | Some i -> !i in (* let fun_args = (embedding_type_index, ety, List.fold_left (fun acc x -> acc @ [Smt.Smt_ToMLString.exp x]) [] (List.tl args_rtn)) in *) - let fun_args = (embedding_type_index, ety, (List.tl args_rtn)) in + let rw_version = !(Hashtbl.find vctrs (List.hd realWorld_vars)) in + let fun_args = (embedding_type_index, rw_version, ety, (List.tl args_rtn)) in - let {bindings=binds; ret_exp=rtn; asserts= asts; terms= t; preds = p} = pc fun_args in + let {bindings=binds; ret_exp=rtn; asserts= asts; terms= t; preds = p; updates_rw} = pc fun_args in + begin if updates_rw then List.iter (fun id -> Hashtbl.replace vctrs id (ref(!(Hashtbl.find vctrs id) + 1))) realWorld_vars + else () end; Hashtbl.replace vctrs dst_id (ref(embedding_type_index + 1)) ; predicates_list := !predicates_list @ (List.map (fun (x,y) -> Smt.PredSig (x,y)) p); terms_list := !terms_list @ t; + rtn, List.concat args_binds @ binds + + | Call (MethodL (id, {pc=None; ret_ty; _}), el) -> + let args_rtn, args_binds = List.split @@ List.map (fun exp -> exp_to_smt_exp exp right ~indexed vctrs) el in + let args_types = List.map (fun e -> sty_of_ty (ty_of_exp e)) el in + let smt_fn = { name = id ; args= args_types; ret = sty_of_ty ret_ty} in + if not (List.mem smt_fn !smt_fn_list) then + smt_fn_list := !smt_fn_list @ [smt_fn]; + + EFunc(id, args_rtn), List.concat args_binds + | Call (MethodM (id, {rty=rty; _}), el) -> + let args_rtn, args_binds = List.split @@ List.map (fun exp -> exp_to_smt_exp exp right ~indexed vctrs) el in - rtn, List.concat args_binds @ binds + EFunc(id, args_rtn), List.concat args_binds | Ternary(i, t, e) -> let f x = exp_to_smt_exp x side ~indexed vctrs in let i', i_binds = f i in @@ -337,17 +397,20 @@ let compile_block_to_smt_exp (genv: global_env) (b : block) = let args = List.map (fun exp -> exp_to_smt_exp exp right vctrs) el in let args_rtn, args_binds = List.split args in - let id_value = match (List.hd args_rtn) with | Smt.EVar (Var v) -> v | _ -> failwith "non string var" in + let id_value = match (List.hd args_rtn) with | Smt.EVar (Var v) -> v | _ -> failwith "non string var 342" in let dst_id = remove_index (id_value) in let ((_,_),ety) = List.find (fun ((gid,_),_) -> String.equal gid dst_id) !gstates in let embedding_type_index = match (Hashtbl.find_opt vctrs dst_id) with | None -> 0 | Some i -> !i in - let fun_args = (embedding_type_index, ety, (List.tl args_rtn)) in + let rw_version = !(Hashtbl.find vctrs (List.hd realWorld_vars)) in + let fun_args = (embedding_type_index, rw_version, ety, (List.tl args_rtn)) in - let {bindings=binds; ret_exp=rtn; asserts= asts; terms= t; preds = p} = pc fun_args in + let {bindings=binds; ret_exp=rtn; asserts= asts; terms= t; preds = p; updates_rw} = pc fun_args in predicates_list := !predicates_list @ (List.map (fun (x,y) -> Smt.PredSig (x,y)) p); terms_list := !terms_list @ t; + begin if updates_rw then List.iter (fun id -> Hashtbl.replace vctrs id (ref(!(Hashtbl.find vctrs id) + 1))) realWorld_vars + else () end; Hashtbl.replace vctrs dst_id (ref(embedding_type_index + 1)) ; bind binds @@ compile_block_to_smt tl vctrs @@ -390,12 +453,28 @@ let compile_block_to_smt_exp (genv: global_env) (b : block) = | _ -> () ) !gstates; + List.iter ( + fun [@warning "-8"] id -> + ety_init_list := !ety_init_list @ [init_mangle_id id]; + if not (Hashtbl.mem variable_ctr_list id) then + Hashtbl.add variable_ctr_list id (ref 1) else + Hashtbl.replace variable_ctr_list id (ref 1) (* TODO: Don't need to set existing member to 1 in else case? *) + ) realWorld_vars; let res = compile_block_to_smt b local_variable_ctr_list in if (List.length !ety_init_list == 0) then res, local_variable_ctr_list else ELet (!ety_init_list, res), local_variable_ctr_list +let generate_spec_pre_post_condition pre post = + let vctrs = variable_ctr_list in + match pre, post with + | Some pre, Some post -> (fst @@ exp_to_smt_exp pre right vctrs),(fst @@ exp_to_smt_exp post right vctrs) + | None, None -> (Smt.EConst (CBool true)),(Smt.EConst (CBool true)) + | None, Some post -> (Smt.EConst (CBool true)),(fst @@ exp_to_smt_exp post right vctrs) + | Some pre, None -> (fst @@ exp_to_smt_exp pre right vctrs),(Smt.EConst (CBool true)) + + let generate_method_spec_postcondition (genv: global_env) (b : block) : sexp = let block_to_exp, local_variable_ctr_list = (compile_block_to_smt_exp genv b) in @@ -433,8 +512,17 @@ let compile_method_to_methodSpec (genv: global_env) (m:mdecl) : method_spec = method_spec -let compile_blocks_to_spec (genv: global_env) (blks: block node list) (embedding_vars : (ty binding * ety) list) = - let embedding_vars = List.filter (fun ((id, _),_) -> not (String.equal id "argv") ) embedding_vars in +let generate_spec_preamble { methods; globals; structs; lib_methods} = Some begin + let fun_def_of_method (id, {rty = rty; args = args; _}) = + let string_of_ty = compose string_of_sty sty_of_ty in + sp "(declare-fun %s (%s) %s)" id (String.concat " " (List.map (compose string_of_ty snd) args)) (string_of_ty rty) + in + String.concat "\n" @@ List.map fun_def_of_method methods end + + + +let compile_blocks_to_spec (genv: global_env) (blks: block node list) (embedding_vars : (ty binding * ety) list) pre post = + (* let embedding_vars = List.filter (fun ((id, _),_) -> not (String.equal id "argv") ) embedding_vars in *) gstates := embedding_vars; let predicates = generate_spec_predicates embedding_vars in @@ -444,10 +532,13 @@ let compile_blocks_to_spec (genv: global_env) (blks: block node list) (embedding let mdecls = List.map create_dummy_method blks in let methods = List.map (compile_method_to_methodSpec genv) mdecls in - let preamble = None in + let pre, post = generate_spec_pre_post_condition pre post in + (* let pre = ELop(And, [EBop(Eq, EVar (Var "realWorld_opened"), EVar (Var "(as emptyset (Set String))")); pre]) in (* TODO: This is to debug until we have some way of constraining real world *) *) + + let preamble = generate_spec_preamble genv in let spec = { name = "test"; preamble = preamble; preds = predicates; state_eq = state_equal; - precond = Smt.EConst (CBool true); state = state; methods= methods; smt_fns = []} in + precond = pre; postcond = post; state = state; methods= methods; smt_fns = !smt_fn_list} in let mnames = List.map (fun ({mname = name; _}) -> name) mdecls in diff --git a/src/analysis/transform.ml b/src/analysis/transform.ml new file mode 100644 index 0000000..935e984 --- /dev/null +++ b/src/analysis/transform.ml @@ -0,0 +1,134 @@ +(* open Ast +open Ast_print +open Format +open Range +open Util +open Exe_pdg + + +let ctr = ref 0 + +let incr_uid (ctr: int ref) = + ctr := !ctr + 1; + !ctr + +let create_label () : string = + "Block" ^ string_of_int (incr_uid ctr) + +let mk_blocklabel l : blocklabel = + (l, None) + +let get_label id : string = + "Block" ^ string_of_int id + +let rec string_of_stmt_aux (s: exe_stmt node) : string = + begin match s.elt with + | ESIf (e, b1, b2) -> sp "ESIf (%s, %s, %s)" + (AstML.string_of_exp e) b1 b2 + | ESFor (d,e,s,b) -> sp "For (%s, %s, %s, %s)" + (AstML.string_of_list AstML.string_of_vdecl_aux d) + (AstML.string_of_option AstML.string_of_exp e) + (AstML.string_of_option AstML.string_of_stmt s) b + | ESWhile (e,b) -> sp "While (%s, %s)" (AstML.string_of_exp e) b + (* | ESGoto b -> sp "Goto (%s)" (string_of_stmt_aux b) *) + | ESSBlock (blocklabel, b) -> let (Some (l, _)) = blocklabel in sp "ESSBlock %s: %s" l (string_of_block b) + | Stmt s -> AstML.string_of_stmt s + end + +and string_of_block (b:exe_block node) : string = + AstML.string_of_list string_of_stmt_aux b.elt + + +let rec stmt_to_exeS s : exe_stmt = + failwith "not implemented" + + +(* let rec build_pdg (block: block) pdg : exe_pdg = + List.fold_left ( + fun pdg -> fun stmt -> + match stmt with + | If (e, blk1, blk2) -> + let head_label = create_label() in + let ctr_temp = !ctr in + (* let add_edge (pdg : exe_pdg) (src : exe_stmt) (dst : exe_stmt) dep *) + + let pdg = build_pdg blk2.elt (build_pdg blk1.elt pdg) in + let l1 = get_label (ctr_temp + 1) in + let l2 = if (blk2.elt != []) then get_label !ctr else "" in + + let if_stmt = node_up stmt (ESIf (e, l1, l2)) in + let s = ESSBlock (Some (mk_blocklabel head_label), no_loc [if_stmt]) in + add_node pdg s + + | _ -> + let s = node_up stmt (Stmt stmt) in + let n = ESSBlock (Some (mk_blocklabel @@ create_label()), no_loc [s]) in + add_node pdg n + (* let estmt = stmt_to_exeS s in + add_node pdg estmt *) + ) pdg block *) +(* +let rec f i pdg = + | [] -> pdg + | h::tl -> if (i >= (List.length nodes_temp)) then add_edge pdg s n else pdg *) + +let rec build_pdg (block: block) pdg : exe_pdg = + match block with + | [] -> pdg + | stmt::tl -> + let updated_pdg = begin match stmt.elt with + | If (e, blk1, blk2) -> + let head_label = create_label() in + let ctr_temp = !ctr in + (* let add_edge (pdg : exe_pdg) (src : exe_stmt) (dst : exe_stmt) dep *) + let nodes_temp = pdg.nodes in + + let pdg = build_pdg blk2.elt (build_pdg blk1.elt pdg) in + let l1 = get_label (ctr_temp + 1) in + let l2 = if (blk2.elt != []) then get_label !ctr else "" in + + let if_stmt = node_up stmt (ESIf (e, l1, l2)) in + let s = ESSBlock (Some (mk_blocklabel head_label), no_loc [if_stmt]) in + + + (* List.fold_left (fun i n -> if (i >= (List.length nodes_temp)) then add_edge pdg s n else pdg) pdg pdg.nodes *) + + add_node pdg s + + | While (e, bl) -> + let head_label = create_label() in + let ctr_temp = !ctr in + + let pdg = build_pdg bl.elt pdg in + let l = get_label (ctr_temp + 1) in + let while_stmt = node_up stmt (ESWhile (e, l)) in + let n = ESSBlock (Some(mk_blocklabel head_label), no_loc [while_stmt]) in + + (* List.fold_left ( + fun pdg -> fun s -> (add_edge pdg n (stmt_to_exeS s) ControlDep) + ) pdg bl.elt *) + + add_node pdg n + + | For (vdecll, exp, sl, bl) -> + let head_label = create_label() in + let ctr_temp = !ctr in + + let pdg = build_pdg bl.elt pdg in + let l = get_label (ctr_temp + 1) in + let for_stmt = node_up stmt @@ ESFor (vdecll, exp, sl, l) in + let s = ESSBlock (Some(mk_blocklabel head_label), no_loc [for_stmt]) in + add_node pdg s + + | SBlock (blocklabel, bl) -> + let s = node_up stmt (Stmt stmt) in + let n = ESSBlock (blocklabel, no_loc [s]) in + add_node pdg n + + | _ -> + let s = node_up stmt (Stmt stmt) in + let n = ESSBlock (Some (mk_blocklabel @@ create_label()), no_loc [s]) in + add_node pdg n + end + in + build_pdg tl updated_pdg *) diff --git a/src/benchmark-notes.txt b/src/benchmark-notes.txt new file mode 100644 index 0000000..883980f --- /dev/null +++ b/src/benchmark-notes.txt @@ -0,0 +1,23 @@ +simple-vector: dswp returns 0 because the return task does not have z as a dependecy so it runs immediately. +2d-array: seems to work inconsistently. Unsure why. +vote-run: works properly +commset: works properly +multi-blocks: works properly (after the change to scheduler init_jobs join_all) + + +after removing waiting on eop + +simple-vector: seems to work +2d-array: does not work (as expected as we are missing a dependency) +vote-run: seems to work +commset: seems to work +multi-blocks: seems to work most times. Got this once: An error occurred: Invalid_argument("index out of bounds") + + +after adding topological waiting +simple-vector: works +2d-array: works +vote-run: works +commset: works +multi-blocks: sometimes works (index out of bounds) +motivation: works diff --git a/src/dune b/src/dune index e903639..55a72ad 100644 --- a/src/dune +++ b/src/dune @@ -3,8 +3,8 @@ (library (name vcy) (public_name vcy) - (libraries unix threads str servois2) - (modules (:standard \ parallel_multicore parallel_singlecore run)) + (libraries unix threads str servois2 domainslib) + (modules (:standard \ parallel_multicore parallel_singlecore run ast_to_c)) (wrapped true) (library_flags -linkall) (synopsis "Veracity language")) diff --git a/src/parallel/Makefile b/src/parallel/Makefile index 3c15912..29c5d6c 100644 --- a/src/parallel/Makefile +++ b/src/parallel/Makefile @@ -1,7 +1,7 @@ parallel_singlecore_file = parallel_singlecore.ml parallel_multicore_file = parallel_multicore.ml -ocaml_switch_multicore = 4.12.0+domains+effects +ocaml_switch_multicore =5.2.0+dev10-2024-05-02 parallel_module := $(shell \ if [ $(shell ocamlc --version) = $(ocaml_switch_multicore) ]; \ diff --git a/src/parallel/parallel.mli b/src/parallel/parallel.mli index 5e602a1..38d731f 100644 --- a/src/parallel/parallel.mli +++ b/src/parallel/parallel.mli @@ -1,4 +1,8 @@ type t +open Ast val create : (unit -> unit) -> t -val join : t -> unit \ No newline at end of file +val join : t -> unit +val new_job : int -> 'a -> unit +val scheduler : unit -> unit +val set_task_def : 'a -> unit \ No newline at end of file diff --git a/src/parallel/parallel_multicore.ml b/src/parallel/parallel_multicore.ml index fc64537..2f01c9d 100644 --- a/src/parallel/parallel_multicore.ml +++ b/src/parallel/parallel_multicore.ml @@ -1,7 +1,19 @@ +open Ast +open Domainslib + type t = unit Domain.t let create : (unit -> unit) -> t = Domain.spawn let join : t -> unit = - Domain.join \ No newline at end of file + Domain.join + +let new_job t e : unit = + failwith "todo - new_job for parallel_multicore" + +let set_task_def tl : unit = + failwith "todo - new_job for parallel_multicore" + +let scheduler () = + failwith "todo - scheduler for parallel_multicore" \ No newline at end of file diff --git a/src/parallel/parallel_singlecore.ml b/src/parallel/parallel_singlecore.ml index 6626630..2bfd3d1 100644 --- a/src/parallel/parallel_singlecore.ml +++ b/src/parallel/parallel_singlecore.ml @@ -4,4 +4,15 @@ let create (f : unit -> unit) : t = Thread.create f () let join : t -> unit = - Thread.join \ No newline at end of file + Thread.join + +(* type job = { tid: taskid; env: env; } *) + +let new_job t e : unit = + failwith "todo - new_job for parallel_singlecore" + +let set_task_def tl : unit = + failwith "todo - new_job for parallel_singlecore" + +let scheduler () = + failwith "todo - scheduler for parallel_singlecore" \ No newline at end of file diff --git a/src/servois2 b/src/servois2 index 048bd25..855f8a8 160000 --- a/src/servois2 +++ b/src/servois2 @@ -1 +1 @@ -Subproject commit 048bd2578427b1ddeadbfe98929b23efef2fb7e0 +Subproject commit 855f8a84c918e0775acb0e509ebb31bc3d9e33b5 diff --git a/src/util/concurrent_counter.ml b/src/util/concurrent_counter.ml index 73129d7..366b132 100644 --- a/src/util/concurrent_counter.ml +++ b/src/util/concurrent_counter.ml @@ -4,17 +4,10 @@ let init () : t = ref 0L, Mutex.create () let increment ((c, m) : t) = - Mutex.lock m; - c := Int64.add !c 1L; - Mutex.unlock m + Mutex.protect m (fun () -> c := Int64.add !c 1L) let decrement ((c, m) : t) = - Mutex.lock m; - c := max (Int64.sub !c 1L) 0L; - Mutex.unlock m + Mutex.protect m (fun () -> c := max (Int64.sub !c 1L) 0L) let read ((c, m) : t) = - Mutex.lock m; - let res = !c in - Mutex.unlock m; - res \ No newline at end of file + Mutex.protect m (fun () -> !c) diff --git a/src/util/hashtables.ml b/src/util/hashtables.ml index 6719bb5..8c6bab6 100644 --- a/src/util/hashtables.ml +++ b/src/util/hashtables.ml @@ -13,29 +13,19 @@ module Hashtable_naive = struct Mutex.create () let mem (tbl, m : _ t) k = - Mutex.lock m; - let res = Hashtbl.mem tbl k in - Mutex.unlock m; - res + Mutex.protect m (fun () -> Hashtbl.mem tbl k) let put (tbl, m : _ t) k v = - Mutex.lock m; + Mutex.protect m (fun () -> let replaced = Hashtbl.mem tbl k in Hashtbl.replace tbl k v; - Mutex.unlock m; - replaced + replaced) let get (tbl, m : _ t) k = - Mutex.lock m; - let res = Hashtbl.find_opt tbl k in - Mutex.unlock m; - res + Mutex.protect m (fun () -> Hashtbl.find_opt tbl k) let size (tbl, m : _ t) = - Mutex.lock m; - let res = Hashtbl.length tbl in - Mutex.unlock m; - res + Mutex.protect m (fun () -> Hashtbl.length tbl) end (*** Hashtable with no locking or concurrent capabilities ***) @@ -57,4 +47,4 @@ module Hashtable_seq = struct let size = Hashtbl.length -end \ No newline at end of file +end diff --git a/src/util/range.ml b/src/util/range.ml index 1b04e28..51a1019 100644 --- a/src/util/range.ml +++ b/src/util/range.ml @@ -36,6 +36,8 @@ let merge_range (f, s1, e1 as r1 : t) (f', s2, e2 as r2 : t) = Printf.sprintf "%s:[%d.%d-%d.%d]" f sl sc el ec*) let string_of_range (f, (sl, sc), (el, ec) : t) = Printf.sprintf "%s:[%d.%d-%d.%d]" f (sl+1) (sc+1) (el+1) (ec+1) +let string_of_range_nofn (f, (sl, sc), (el, ec) : t) = + Printf.sprintf "[%d.%d-%d.%d]" (sl+1) (sc+1) (el+1) (ec+1) let ml_string_of_range (f, (sl, sc), (el, ec) : t) = Printf.sprintf "(\"%s\", (%d, %d), (%d, %d))" f sl sc el ec diff --git a/src/util/template.dot b/src/util/template.dot new file mode 100644 index 0000000..db5b130 --- /dev/null +++ b/src/util/template.dot @@ -0,0 +1,33 @@ +digraph G { + // Graph style + graph [rankdir="TB", fontsize=20, label="Black=CFG, Red=ControlDep, Blue=DataDep", labelloc=t] + + // Node styles + node [shape=box, style="rounded,filled", fontname="Courier", margin=0.05] + + // Edge styles + edge [arrowhead=vee, arrowsize=1, fontname="Courier"] + + // Nodes + "f.vcy:1:1-5" [label="f.vcy:1:1-5\nx:=42;", fillcolor="#d3d3d3"] + "f.vcy:2:1-5" [label="f.vcy:2:1-5\nwhile(x>0)", shape="oval", fillcolor="#add8e6"] + "f.vcy:3:1-5" [label="f.vcy:3:1-5\nx:=x-1", fillcolor="#d3d3d3"] + "f.vcy:5:1-5" [label="f.vcy:5:1-5\nreturn x", fillcolor="#d3d3d3"] + + // Edges + "f.vcy:1:1-5" -> "f.vcy:2:1-5" + "f.vcy:2:1-5" -> "f.vcy:3:1-5" + "f.vcy:3:1-5" -> "f.vcy:2:1-5" + "f.vcy:2:1-5" -> "f.vcy:5:1-5" + + // Control-Dep edges + "f.vcy:1:1-5" -> "f.vcy:2:1-5" [color="red", style="dashed"] + "f.vcy:2:1-5" -> "f.vcy:3:1-5" [color="red", style="dashed"] + "f.vcy:2:1-5" -> "f.vcy:5:1-5" [color="red", style="dashed"] + + // Data-Dep edges + "f.vcy:1:1-5" -> "f.vcy:2:1-5" [color="blue", style="dotted"] + "f.vcy:2:1-5" -> "f.vcy:3:1-5" [color="blue", style="dotted"] + "f.vcy:2:1-5" -> "f.vcy:5:1-5" [color="blue", style="dotted"] + "f.vcy:3:1-5" -> "f.vcy:2:1-5" [color="blue", style="dotted"] +} diff --git a/src/util/util.ml b/src/util/util.ml index 88ed55a..7d68a41 100644 --- a/src/util/util.ml +++ b/src/util/util.ml @@ -1,6 +1,15 @@ exception UnreachableFailure of string exception NotImplemented of string +let debug = ref false + +(* let dprintf fmt = if !debug then Printf.printf fmt else Printf.ifprintf stdout fmt *) + +let debug_print (s : string lazy_t) = + if !debug then (print_string (Lazy.force s); flush stdout) + +let debug_trunc (s : string) = if String.length s > 256 then String.sub s 0 241 ^ "... [truncated]" else s + let sp = Printf.sprintf let servois2_synth_option = ref Servois2.Synth.default_synth_options @@ -10,14 +19,32 @@ let check_prover () = !servois2_synth_option.prover let assoc_update (k : 'a) (v : 'b) (l : ('a * 'b) list) = (k,v) :: List.remove_assoc k l -let flip (a,b) = b,a +let swap (a,b) = b,a + +let flip f x y = f y x let compose f g x = f (g x) +let ap f x = f x + +let rec repeat f n = if n <= 0 then () else (f (); repeat f (n - 1)) + +let const c f = c + +let seq a b = b + let null = function | [] -> true | _ -> false +let trd (a, b, c) = c + +let uncurry f (x, y) = f x y + +let first f (x, y) = (f x, y) + +let second f (x, y) = (x, f y) + let rec square_list_unordered = function | [] -> [] | h::t -> @@ -173,3 +200,52 @@ let time_exec (f : unit -> 'a) : float * 'a = let res = f () in let t1 = Unix.gettimeofday () in t1 -. t0, res + +(* write the graph to a .dot file *) +let output_graph fn nodes edges = + let oc = open_out fn in + output_string oc (String.concat "\n" [ + "digraph G {\n"; + (* Styles *) + " graph [rankdir=\"TB\", fontsize=20, label=\"Black=CFG, Red=ControlDep, Blue=DataDep\", labelloc=t]"; + " node [shape=box, style=\"rounded,filled\", fontname=\"Courier\", margin=0.05]"; + " edge [arrowhead=vee, arrowsize=1, fontname=\"Courier\"]"; + (* Nodes *) + List.fold_left (fun acc node -> acc ^ "\"" ^ node ^ "\";\n") "" nodes; + (* Edges *) + List.fold_left (fun acc (src, dst) -> acc ^ "\"" ^ src ^ "\" -> \"" ^ dst ^ "\";\n") "" edges; + "}\n"; + ]); + print_endline ("Graph written to " ^ fn); + close_out oc + +let dot_escape s = + let s' = Str.global_replace (Str.regexp_string "\n") "\\n" s in + let s'' = Str.global_replace (Str.regexp_string " ") " " s' in + Str.global_replace (Str.regexp_string "\"") "\\\"" s'' + +let rec apply_pairs f lst = + match lst with + | [] -> () + | x::xs -> List.iter (fun y -> f x y) lst; apply_pairs f xs + +let rec apply_distinct_pairs f lst = + match lst with + | [] -> () + | x::xs -> List.iter (fun y -> f x y) xs; apply_distinct_pairs f xs + +let rec last_element lst = + match lst with + | [] -> None + | [x] -> Some x + | _ :: tail -> last_element tail + + let contains_substring str s = + try + let regexp = Str.regexp_string s in + Str.search_forward regexp str 0 >= 0 + with + Not_found -> false + + + let manual_dependency = ref false \ No newline at end of file diff --git a/src/vcy/ast.ml b/src/vcy/ast.ml index 6664274..5ec2738 100644 --- a/src/vcy/ast.ml +++ b/src/vcy/ast.ml @@ -64,7 +64,8 @@ let rec sty_of_ty = function | TBool -> Smt.TBool | TStr -> Smt.TString | TArr t -> Smt.TArray (Smt.TInt, sty_of_ty t) - | _ -> raise @@ NotImplemented "Conversion to Servois type not supported" + | TChanR | TChanW -> Smt.TString (* A channel is represented by the string representing the directory it accesses. *) + | sty -> raise @@ NotImplemented "Conversion to Servois type not supported" type sht_ids = { ht : id; keys : id; size : id } @@ -76,6 +77,7 @@ type ety = | ETStr of id | ETArr of id * sty | ETHashTable of sty * sty * sht_ids + | ETChannel of id type arglist = ty bindlist @@ -139,28 +141,47 @@ and stmt = | Assume of exp node | Havoc of id | Require of exp node +| SBlock of blocklabel option * block node +| GCommute of commute_variant * commute_condition * commute_pre_cond * block node list * commute_post_cond +| SendDep of int * ((ty * id) list) (* only for dependency of tasks *) +| SendEOP of int + +and commute_pre_cond = exp node + +and commute_post_cond = exp node and tyval = ty * (value ref) and blockstk = tyval bindlist list and callstk = blockstk list +(* and blocklabel = id * (id list) option *) +and blocklabel = id * (exp node list) option + +and group_commute = ((blocklabel list) list) * commute_condition + +(* and commute_frag = +| Blabel of blocklabel +| Blablel of blocklabel list *) and global_env = { methods : tmethod bindlist ; globals : tyval bindlist ; structs : tstruct bindlist - ; lib_methods : lib_method bindlist + ; lib_methods : lib_method bindlist + ; group_commute : group_commute node list (* Global Commutativity relations *) } and env = { g : global_env (* Global environment *) ; l : callstk (* Local environment *) + ; tid : int option } -and lib_method = +and [@warning "-30"] lib_method = (* complains that "pure" is also defined in tmethod *) { pure : bool (*; spec : method_spec *) (* TODO reintroduce *) ; func : env * value list -> env * value - ; pc : (int * ety * sexp list -> post_condition) option + ; ret_ty : ty + ; pc : (int * int * ety * sexp list -> post_condition) option } and post_condition = @@ -169,6 +190,7 @@ and post_condition = ; asserts : sexp list (* Any additional assertions made *) ; terms : (sexp * sty) list (* Terms *) ; preds : (string * (sty list)) list (* Any particular predicates *) + ; updates_rw : bool (* Does the method update the realWorld SMT variables *) } (*and method_spec = (* TODO For inlining procedure *) @@ -200,7 +222,7 @@ type embedding_map = (ty binding * ety) list let mangle_servois_id id index = - Smt.EVar (Var (id ^ "_" ^ string_of_int index)) + Smt.EVar (Var (id ^ (if index = 0 then "" else "_" ^ string_of_int index))) let mangle_servois_id_pair id index = mangle_servois_id id index, mangle_servois_id id (index + 1) @@ -217,6 +239,14 @@ let rec string_of_sty = function | _ -> failwith "string_of_sty" (* | STGen g -> g *) (* TODO: we need this? *) +let string_of_ety = function + | ETInt id -> "ETInt " ^ id + | ETBool id -> "ETBool " ^ id + | ETStr id -> "ETString " ^ id + | ETArr(id, sty) -> "ETArr(" ^ id ^ ", " ^ string_of_sty sty ^ ")" + | ETHashTable(sty, sty', sht_ids) -> "ETHashTable(" ^ string_of_sty sty ^ ", " ^ string_of_sty sty' ^ ", " ^ "{ ht : " ^ sht_ids.ht ^"; keys : " ^ sht_ids.keys ^ "; size : " ^ sht_ids.size ^ " }" + | ETChannel id -> "ETChannel " ^ id + (* (*** Inlining analysis types ***) @@ -267,13 +297,14 @@ and aseq = astmt list type gdecl = { name : id; ty : ty; init : exp node } type mdecl = { pure : bool; mrtyp : ty; mname : id; args : (ty * id) list; body : block node } -let mdecl_of_tmethod name (t : tmethod) = { pure = t.pure; mrtyp = t.rty; mname = name; args = List.map flip t.args; body = t.body } +let mdecl_of_tmethod name (t : tmethod) = { pure = t.pure; mrtyp = t.rty; mname = name; args = List.map swap t.args; body = t.body } (*type fdecl = { frtyp : ty; fname : id; args : (ty * id) list; body : exp node }*) type field = { field_name : id; ftyp : ty } type sdecl = { sname : id; fields : field list } type decl = +| Commutativity of group_commute node list | Gvdecl of gdecl node (* Global variable *) | Gmdecl of mdecl node (* Method *) | Gsdecl of sdecl node (* Struct *) @@ -362,25 +393,24 @@ let htdata_of_value : value -> value Hashtables.htdata = | VInt i -> Hashtables.HTint (Int64.to_int i) | v -> Hashtables.HTD v - -let init_mangle : ety -> Smt.exp Smt.bindlist = - let [@warning "-8"] bind i = - let Smt.EVar mangled = (mangle_servois_id i 1) in +let init_mangle_id : id -> Smt.exp Smt.binding = fun i -> + let [@warning "-8"] Smt.EVar mangled = (mangle_servois_id i 1) in (mangled, Smt.EVar (Var i)) - in function - | ETInt i | ETBool i | ETStr i | ETArr (i, _) -> - [bind i] + +let init_mangle : ety -> Smt.exp Smt.bindlist = function + | ETInt i | ETBool i | ETStr i | ETArr (i, _) | ETChannel i -> + [init_mangle_id i] | ETHashTable (_,_,{ht;keys;size}) -> - List.map bind [ht;keys;size] + List.map init_mangle_id [ht;keys;size] -let final_mangle (mangle : int) : ety -> Smt.exp = - let bind i = +let final_mangle_id : int -> id -> Smt.exp = fun mangle i -> Smt.EBop (Eq, (mangle_servois_id_final i), (mangle_servois_id i mangle)) - in function - | ETInt i | ETBool i | ETStr i | ETArr (i, _) -> - bind i + +let final_mangle (mangle : int) : ety -> Smt.exp = function + | ETInt i | ETBool i | ETStr i | ETArr (i, _) | ETChannel i -> + final_mangle_id mangle i | ETHashTable (_,_,{ht;keys;size}) -> - Smt.ELop (And, (List.map bind [ht;keys;size])) + Smt.ELop (And, (List.map (final_mangle_id mangle) [ht;keys;size])) let remove_index (mangled_id: string) : string = let r = Str.regexp "_[0-9]+" in @@ -395,6 +425,7 @@ let compile_ety_to_sty (id: string) (ty : ety) : (string * sty) list = | ETArr (_, sty) -> [(id, Smt.TArray (Smt.TInt, sty))] | ETHashTable (styk, styv, {ht=ht_id; keys=ht_keys; size=ht_size}) -> [(ht_id, Smt.TArray (styk, styv)); (ht_keys, Smt.TSet styk); (ht_size, Smt.TInt)] + | ETChannel _ -> [(id, Smt.TString)] (** AST to SMT types *) diff --git a/src/vcy/ast_print.ml b/src/vcy/ast_print.ml index 49e8b6c..87ca1f0 100644 --- a/src/vcy/ast_print.ml +++ b/src/vcy/ast_print.ml @@ -70,10 +70,13 @@ module AstPP = struct begin match l with | [] -> () | [h] -> pp fmt h - | h::tl -> pp fmt h; sep (); + | h::tl -> pp fmt h; sep fmt; print_list_aux fmt sep pp tl end + let print_comma_sep_aux fmt = + pp_print_string fmt ","; pp_print_space fmt () + let rec print_ty_aux fmt t = let pps = pp_print_string fmt in match t with @@ -81,8 +84,10 @@ module AstPP = struct | TInt -> pps "int" | TVoid -> pps "void" | TStr -> pps "string" - | TChanR -> raise @@ NotImplemented "TChanR pretty print" - | TChanW -> raise @@ NotImplemented "TChanW pretty print" + (* | TChanR -> raise @@ NotImplemented "TChanR pretty print" + | TChanW -> raise @@ NotImplemented "TChanW pretty print" *) + | TChanR -> pps "TChanR" + | TChanW -> pps "TChanW" | THashTable (tyk, tyv) -> pps "hashtable["; print_ty_aux fmt tyk; pps ", "; print_ty_aux fmt tyv; pps "]" | TStruct sid -> pps sid | TArr ty -> print_ty_aux fmt ty; pps "[]" @@ -102,7 +107,7 @@ module AstPP = struct pps "new "; print_ty_aux fmt ty; pps "[]"; pps "{"; pp_open_hbox fmt (); - print_list_aux fmt (fun () -> pps ","; pp_print_space fmt()) (print_exp_aux 0) vs; + print_list_aux fmt print_comma_sep_aux (print_exp_aux 0) vs; pp_close_box fmt (); pps "}"; end @@ -164,7 +169,7 @@ module AstPP = struct pps l; pp_open_hvbox fmt 0; print_list_aux fmt - (fun () -> pps ","; pp_print_space fmt()) + print_comma_sep_aux (fun fmt -> fun e -> print_exp_aux 0 fmt e) es; pp_close_box fmt (); pps r @@ -178,16 +183,33 @@ module AstPP = struct ppsp (); pps "="; ppsp (); print_exp_aux 0 fmt init; pps semi; pp_close_box fmt () + + let print_blocklabel_aux fmt ((id, explist): blocklabel) = + match explist with + | None -> print_id_aux fmt id; + | Some lbls -> + let pps = pp_print_string fmt in + print_id_aux fmt id; + pps "("; + print_list_aux fmt print_comma_sep_aux (print_exp_aux 0) lbls; + pps ")" + + let print_arglist_aux fmt args = + print_list_aux fmt print_comma_sep_aux + (fun fmt -> fun (t, id) -> + print_ty_aux fmt t; + pp_print_space fmt (); + print_id_aux fmt id + ) args let rec print_block_aux fmt (b : block node) = let pps = pp_print_string fmt in - let ppsp = pp_print_space fmt in let ppnl = pp_force_newline fmt in if (List.length b.elt) > 0 then begin pps "{"; ppnl (); pps " "; pp_open_vbox fmt 0; - print_list_aux fmt (fun () -> ppsp ()) print_stmt_aux b.elt; + print_list_aux fmt (flip pp_print_space ()) print_stmt_aux b.elt; pp_close_box fmt (); ppnl (); pps "}" end @@ -238,7 +260,7 @@ module AstPP = struct | For(decls, eo, so, body) -> pps "for ("; pp_open_hvbox fmt 0; - print_list_aux fmt (fun () -> pps ","; ppsp ()) (print_vdecl_aux "") decls; + print_list_aux fmt print_comma_sep_aux (print_vdecl_aux "") decls; pps ";"; ppsp (); begin match eo with | None -> (); @@ -277,17 +299,27 @@ module AstPP = struct pps "assume("; print_exp_aux 0 fmt e; pps ");" | Havoc(id) -> pps "havoc "; pps id; pps ";" + | SBlock(blocklabel, block) -> begin match blocklabel with + | None -> () + | Some bl -> print_blocklabel_aux fmt bl + end; + print_block_aux fmt block + | SendDep(dep, varlist) -> + pps (Printf.sprintf "SendDep(%d, " dep); + print_arglist_aux fmt varlist; + pps ")" + | SendEOP(t) -> + pps (Printf.sprintf "SendEOP(%d)" t); end let print_mdecl_aux fmt {elt={pure; mrtyp; mname; args; body};_} = (* TODO: doesn't use pure *) let pps = pp_print_string fmt in - let ppsp = pp_print_space fmt in let ppnl = pp_force_newline fmt in print_ty_aux fmt mrtyp; pps @@ Printf.sprintf " %s(" mname; pp_open_hbox fmt (); - print_list_aux fmt (fun () -> pps ","; ppsp ()) + print_list_aux fmt print_comma_sep_aux (fun fmt -> fun (t, id) -> print_ty_aux fmt t; pps " "; @@ -320,11 +352,29 @@ module AstPP = struct pps "}"; pp_close_box fmt () + let print_group_commute_aux fmt (gc: group_commute node) = + let pps = pp_print_string fmt in + let (bls, phi) = gc.elt in + print_list_aux fmt print_comma_sep_aux (fun fmt -> fun com_frag -> + pps "{"; + print_list_aux fmt print_comma_sep_aux print_blocklabel_aux com_frag; + pps "}" + ) bls; + pps ": "; + begin match phi with + | PhiInf -> pps "_" + | PhiExp e -> print_exp_aux 0 fmt e + end + let print_decl_aux fmt g = begin match g with | Gvdecl d -> print_gdecl_aux fmt d.elt | Gmdecl m -> print_mdecl_aux fmt m | Gsdecl s -> print_sdecl_aux fmt s.elt + | Commutativity gcoms -> + pp_print_string fmt "{"; + print_list_aux fmt (fun fmt -> pp_print_string fmt ";"; pp_print_space fmt ()) print_group_commute_aux gcoms; + pp_print_string fmt "}" end let print_prog_aux fmt p = @@ -356,7 +406,9 @@ module AstPP = struct let print_exp (e:exp node) : unit = print (print_exp_aux 0) e let string_of_exp (e:exp node) : string = (string_of (print_exp_aux 0) e) |> Util.replace "\r" " " |> Util.replace "\n" " " - + let string_of_args args : string = + string_of print_arglist_aux args |> Util.replace "\r" " " |> Util.replace "\n" " " + let print_ty (t:ty) : unit = print print_ty_aux t let string_of_ty (t:ty) : string = string_of print_ty_aux t @@ -434,7 +486,7 @@ module AstML = struct raise @@ NotImplemented "string_of_tmethod" let string_of_method_variant (mv : method_variant) : string = - raise @@ NotImplemented "string_of_method_variant" + "" (* TODO: implement this *) let rec string_of_exp_aux (e: exp) : string = begin match e with @@ -521,6 +573,27 @@ module AstML = struct sp "Assume (%s)" (string_of_exp e) | Havoc id -> sp "Havoc %s" (string_of_id id) + | SBlock (bl, b) -> + sp "SBlock (%s, %s)" (string_of_option string_of_blocklabel bl) (string_of_block b) + | GCommute (var,phi,pre,bl,post) -> + sp "GCommute (%s, %s, %s, %s, %s)" + begin match var with + | CommuteVarSeq -> "CommuteVarSeq" + | CommuteVarPar -> "CommuteVarPar" + end + begin match phi with + | PhiInf -> "PhiInf" + | PhiExp e -> sp "PhiExp (%s)" (string_of_exp e) + end + (string_of_exp pre) + (string_of_list string_of_block bl) + (string_of_exp post) + | SendDep (id, vars) -> + sp "SendDep (%d: %s)" id (string_of_args vars) + | SendEOP (id) -> + sp "SendEOP (%d)" id + | Require e -> + sp "Require (%s)" (string_of_exp e) and string_of_stmt (s:stmt node) : string = string_of_node string_of_stmt_aux s @@ -528,7 +601,11 @@ module AstML = struct and string_of_block (b:block node) : string = string_of_list string_of_stmt b.elt - let string_of_args : (ty * id) list -> string = + and string_of_blocklabel (bl: blocklabel) : string = + let (id, explist) = bl in + sp "(%s,%s)" (string_of_id id) (string_of_option (string_of_list string_of_exp) explist) + + and string_of_args : (ty * id) list -> string = string_of_list (fun (t,i) -> sp "(%s,%s)" (string_of_ty t) (string_of_id i)) @@ -557,10 +634,19 @@ module AstML = struct let string_of_sdecl (s:sdecl node) : string = string_of_node string_of_sdecl_aux s + let string_of_group_commute (gc: group_commute node) : string = + let (bls, phi) = gc.elt in + sp "(%s, %s)" (string_of_list (string_of_list string_of_blocklabel) bls) + begin match phi with + | PhiInf -> "PhiInf" + | PhiExp e -> sp "PhiExp (%s)" (string_of_exp e) + end + let string_of_decl : decl -> string = function | Gvdecl d -> sp "Gvdecl (%s)" (string_of_gdecl d) | Gmdecl m -> sp "Gmdecl (%s)" (string_of_mdecl m) | Gsdecl s -> sp "Gsdecl (%s)" (string_of_sdecl s) + | Commutativity gc -> sp "Commutativity (%s)" (string_of_list string_of_group_commute gc) let string_of_prog : prog -> string = string_of_list string_of_decl @@ -580,7 +666,7 @@ module AstML = struct | VChanR (s, _, _) -> "read_channel(" ^ s ^ ")" | VChanW (s, _) -> "write_channel(" ^ s ^ ")" - | VHashTable _ -> raise @@ NotImplemented "string_of_value VHashTable" + | VHashTable _ -> "string_of_value VHashTable" (* TODO: implement this *) | VStruct (id,vs) -> List.map (fun (i,v) -> sp " %s = %s" i (string_of_value !v)) vs |> diff --git a/src/vcy/ast_to_c.ml b/src/vcy/ast_to_c.ml index 6f941c2..4908a6e 100644 --- a/src/vcy/ast_to_c.ml +++ b/src/vcy/ast_to_c.ml @@ -15,7 +15,7 @@ let rec c_of_ty = function | TBool -> "bool" (* TODO: Not ansi C. can use int, or stdbool.h? *) | TStr -> "const char*" | TArr(ty) -> sp "%s*" (c_of_ty ty) - | THashTable(kty, vty) -> raise @@ NotImplemented "c_of_ty THashTable" + | THashTable(kty, vty) -> "<>" (*raise @@ NotImplemented "c_of_ty THashTable"*) | TChanR -> raise @@ NotImplemented "c_of_ty TChanR" | TChanW -> raise @@ NotImplemented "c_of_ty TChanW" | TStruct(id) -> raise @@ NotImplemented "c_of_ty TStruct" @@ -27,8 +27,8 @@ and c_of_exp = function | CInt(i) -> Int64.to_string i (* ^ "L" *) | CStr(s) -> sp "\"%s\"" s | CArr(ty, e) -> raise @@ NotImplemented "c_of_exp CArr" - | NewArr(ty, e) -> raise @@ NotImplemented "c_of_exp NewArr" - | NewHashTable(var, kty, vty) -> raise @@ NotImplemented "c_of_exp NewHashTable" + | NewArr(ty, e) -> "<>" (*raise @@ NotImplemented "c_of_exp NewArr"*) + | NewHashTable(var, kty, vty) -> "<>" (*raise @@ NotImplemented "c_of_exp NewHashTable"*) | Id(id) -> (!mangle id) | Index(arr, idx) -> sp "(%s[%s])" (c_of_expnode arr) (c_of_expnode idx) | CallRaw(id, es) -> sp "(%s(%s))" id (String.concat ", " @@ List.map c_of_expnode es) @@ -61,6 +61,8 @@ and c_of_stmt = function | Commute(var, phi, bodies) -> !handle_comm phi bodies | Havoc(id) -> sp "/* %s = __VERIFIER_nondet_int() */" (!mangle id) | Assume(e) -> sp "/* assume%s */" (c_of_expnode e) + | SBlock(blocklabel,block) -> sp "%s" (c_of_blocknode block) (* TODO: check *) + | _ -> raise @@ NotImplemented "c_of_stmt: unimplemented." and c_of_stmtnode x = c_of_stmt x.elt and c_of_block b = let indent_pre = !indent in indent := indent_pre + 4; @@ -76,7 +78,7 @@ and handle_comm = ref ultimate_comm (* TODO: Default this to sequential; is like and mangle = ref Fun.id -and ultimate_comm phi (left :: right :: []) = +and [@warning "-8"] ultimate_comm phi (left :: right :: []) = let mangle_temp = !mangle in let acc = ref "" in let (^=) l r = l := !l ^ r in @@ -104,6 +106,7 @@ let c_of_decl = function | Gvdecl(dnode) -> let d = dnode.elt in sp "%s %s %s;" (c_of_ty d.ty) d.name (c_of_expnode d.init) | Gmdecl(dnode) -> let d = dnode.elt in sp "%s %s(%s) %s" (c_of_ty d.mrtyp) d.mname (String.concat ", " @@ List.map (fun (ty, id) -> sp "%s %s" (c_of_ty ty) id) d.args) (c_of_blocknode d.body) | Gsdecl(d) -> raise @@ NotImplemented "c_of_decl Gsdecl" + | Commutativity(_) -> raise @@ NotImplemented "c_of_decl: Commutativity." let c_of_prog prog = String.concat "\n\n" @@ List.map c_of_decl prog diff --git a/src/vcy/codegen_c.ml b/src/vcy/codegen_c.ml new file mode 100644 index 0000000..fa3a02d --- /dev/null +++ b/src/vcy/codegen_c.ml @@ -0,0 +1,285 @@ +(* + Code Generation via a C compiler: + Convert Veracity statements to C code + + Most functions are parameterized first by the current task (Dswp_task.task) + +*) +open Ast +open Ast_print +open Util +open Dswp_task + +exception TaskCodeGenErr of string + +(* TODO: Make all of these local to gen_prog *) +let indent = ref 0 +let mk_newline () = "\n" ^ String.make !indent ' ' + +(* TODO: Return type -- not pure string, but a string with state? state monad and do St string? + To capture env vars such as string/array constants. *) + +let rec gen_ty = function + | TVoid -> "void" + | TInt -> "int" + | TBool -> "int" (* TODO: Not ansi C. can use int, or stdbool.h? *) + | TStr -> "const char*" + | TArr(ty) -> sp "%s*" (gen_ty ty) + | THashTable(kty, vty) -> "<>" (*raise @@ NotImplemented "gen_ty THashTable"*) + | TChanR -> "TChanR" + | TChanW -> "TChanW" + | TStruct(id) -> raise @@ NotImplemented "gen_ty TStruct" + +let rec gen_expnode x = gen_exp x.elt +and gen_of_bool = function true -> "1" | _ -> "0" +and gen_exp = function + | CNull(ty) -> "0" + | CBool(b) -> gen_of_bool b + | CInt(i) -> Int64.to_string i (* ^ "L" *) + | CStr(s) -> sp "\"%s\"" s + | CArr(ty, e) -> raise @@ NotImplemented "gen_exp CArr" + | NewArr(ty, e) -> "malloc(sizeof("^(gen_ty ty)^") * "^(gen_expnode e)^")" + | NewHashTable(var, kty, vty) -> "<>" (*raise @@ NotImplemented "gen_exp NewHashTable"*) + | Id(id) -> (!mangle id) + | Index(arr, idx) -> sp "(%s[%s])" (gen_expnode arr) (gen_expnode idx) + | CallRaw(id, es) -> sp "(%s(%s))" id (String.concat ", " @@ List.map gen_expnode es) + | Call(var, es) -> begin match var with + | MethodM(id, tmethod) -> raise @@ NotImplemented "gen_exp Call.MethodM" + | MethodL(id, lmethod) -> raise @@ NotImplemented "gen_exp Call.MethodL" + end + | Bop(bop, l, r) -> sp "(%s%s%s)" (gen_expnode l) (AstPP.string_of_binop bop) (gen_expnode r) + | Uop(uop, e) -> sp "(%s%s)" (AstPP.string_of_unop uop) (gen_expnode e) + | Ternary(g,t,e) -> sp "(%s?%s:%s)" (gen_expnode g) (gen_expnode t) (gen_expnode e) + | CStruct(id, e) -> raise @@ NotImplemented "gen_exp CStruct" + | Proj(e, id) -> raise @@ NotImplemented "gen_exp Call.Proj" + +and gen_stmt tsk = function + | Assn(lhs, rhs) -> sp "%s = %s" (gen_expnode lhs) (gen_expnode rhs) + | Decl(id, (ty, rhs)) -> env := (ty, id) :: !env; sp "%s %s = %s" (gen_ty ty) (!mangle id) (gen_expnode rhs) + | Ret(eo) -> begin match eo with + | Some e -> sp "return %s" @@ gen_expnode e + | None -> "return" + end + | SCallRaw(id, args) -> sp "%s(%s)" id (String.concat ", " @@ List.map gen_expnode args) + | SCall(var, args) -> begin match var with + | MethodM(id, tmethod) -> raise @@ NotImplemented "gen_stmt SCall.MethodM" + | MethodL(id, lmethod) -> raise @@ NotImplemented "gen_stmt SCall.MethodL" + end + | If(guard, t, e) -> sp "if(%s) %s%selse %s" (gen_expnode guard) (gen_blocknode tsk t) (mk_newline ()) (gen_blocknode tsk e) + | For(inits, guard, update, body) -> sp "for(%s; %s; %s) %s" (String.concat ", " @@ List.map (fun (id, (ty, rhs)) -> sp "%s %s = %s" (gen_ty ty) (!mangle id) (gen_expnode rhs)) inits) (guard |> Option.map gen_expnode |> Option.value ~default:"") (update |> Option.map (gen_stmtnode tsk) |> Option.value ~default:"") (gen_blocknode tsk body) + | While(guard, body) -> sp "while(%s) %s" (gen_expnode guard) (gen_blocknode tsk body) + | Raise(e) -> raise @@ NotImplemented "gen_stmt Raise" + | Commute(var, phi, bodies) -> raise @@ TaskCodeGenErr "gen_stmt should not have Commute stmts" + | Havoc(id) -> sp "/* %s = __VERIFIER_nondet_int() */" (!mangle id) + | Assume(e) -> sp "/* assume%s */" (gen_expnode e) + | SBlock(blocklabel,block) -> sp "%s" (gen_blocknode tsk block) (* TODO: check *) + | SendDep(tsk_id, vars) -> + gen_senddep tsk tsk_id (* TODO: add vars *) + | SendEOP id -> sp "/* SendEOP (%d) */" id + + + +and gen_senddep tsk other_id = + try + (* Look up in my dependencies for other_id *) + Printf.printf "gen_senddep: I am task %d. looking for other task %d in my deps: \n " + tsk.id other_id; + print_endline (str_of_task tsk); + let thedep = List.find (fun d -> d.pred_task == other_id) tsk.deps_out in + String.concat "\n" ([""; + (" // Begin Send Deps to task " ^ (string_of_int other_id)); + (" // Vars to send: "^(str_of_vars_list thedep.vars)); + (Printf.sprintf " printf(\"task_%d: sendout outputs to task %d\");" tsk.id other_id); + ] + @ + (List.map (fun (dep_type, dep_id) -> + (Printf.sprintf " %s %s = t%d_to_t%d_%s;" + (gen_ty dep_type) + dep_id + tsk.id + other_id + dep_id + ) + ) thedep.vars) + @ + [ + (Printf.sprintf " sem_post(&t%d_to_t%d_sem);" tsk.id other_id); + (" // End Send Deps to task " ^ (string_of_int other_id)); + "" + ]) + with + Not_found -> failwith ("gen_senddep: didn't find the other task id:" ^ (Int.to_string other_id)) + +and gen_stmtnode tsk x = gen_stmt tsk x.elt +and gen_block tsk b = let indent_pre = !indent in + indent := indent_pre + 4; + let res = "{" ^ mk_newline () ^ String.concat (mk_newline ()) @@ List.map (fun x -> x ^ ";") @@ List.map (gen_stmtnode tsk) b in + indent := indent_pre; + res ^ mk_newline () ^ "}" +and gen_blocknode tsk b = gen_block tsk b.elt + +and mangle = ref Fun.id + +and env = ref [] (* TODO: When to refresh? etc? Better as state monad *) + +let gen_decl tsk = function + | Gvdecl(dnode) -> let d = dnode.elt in sp "%s %s = %s;" (gen_ty d.ty) d.name (gen_expnode d.init) + | Gmdecl(dnode) -> let d = dnode.elt in sp "%s %s(%s) %s" (gen_ty d.mrtyp) d.mname (String.concat ", " @@ List.map (fun (ty, id) -> sp "%s %s" (gen_ty ty) id) d.args) (gen_blocknode tsk d.body) + | Gsdecl(d) -> raise @@ NotImplemented "gen_decl Gsdecl" + +let gen_prog tsk prog = + String.concat "\n\n" @@ List.map (gen_decl tsk) prog + +(* +test this as: + ./vcy.exe interp ../benchmarks/global_commutativity/ps-dswp.vcy +*) +let gen tsk b : unit = + let str = gen_block tsk b in + let oc = open_out "/tmp/autogen_tasks.c" in + output_string oc str; + close_out oc; + print_endline "Codegen_c: wrote /tmp/autogen_tasks.c" + +let gen_semaphores tlist = + List.fold_left (fun acc (tid1,tid2) -> + acc ^ ( + Printf.sprintf "sem_t t%d_to_t%d_sem;\n" tid1 tid2 + ) + ) "\n// ##### Semaphore Declarations #####\n" (calculate_semaphores tlist) + (* "todo - use calculate_semaphores. sem_t t1_to_t1_sem; " *) + +let gen_init tlist = + "\n// ##### Initialization #####\n" + ^"void autogen_initialize() {\n" + ^( + List.fold_left (fun acc (tid1,tid2) -> + acc ^ ( + Printf.sprintf " sem_init(&t%d_to_t%d_sem, 0, 0);\n" tid1 tid2 + ) + ) "" (calculate_semaphores tlist) + ) + ^"}\n" + +let gen_gvar_decls tsk gv_decls : string = + "\n// ##### Declare global variables #####\n" + ^(List.fold_left (fun acc gv_decl -> + acc ^ (gen_decl tsk gv_decl) ^ "\n" + ) "" gv_decls) + +let gen_handoff_vars t_id_tid1_tid2_list : string = + "\n// ##### Declare handoff (t1_t2_x) variables #####\n" + ^(List.fold_left (fun acc (t,nm,tid1,tid2) -> + let nm = Printf.sprintf "%s t%d_to_t%d_%s;\n" (gen_ty t) tid1 tid2 nm in + acc ^ nm ^ "\n" + ) "" t_id_tid1_tid2_list) + +let gen_task_loader tlist : string = + "\n// ##### Method to load task body #####\n" + ^"task_t* autogen_loadtask(int i) {\n" + ^" task_t* t = malloc(sizeof(task_t));\n" + ^" t->id = i;\n" + ^" switch (i) {\n" + ^(String.concat "\n" (List.map (fun tsk -> + " case "^(string_of_int tsk.id)^":\n" + ^" t->function = task_"^(string_of_int tsk.id)^";\n" + ^" t->data = (void*)(intptr_t)i; /* just an int for now */\n" + ^" break;" + ) tlist)) + ^"\n }\n" + ^" return t;\n" + ^"}\n" + +let gen_tasks gvar_decls tlist = + let rec help ts : string list = + match ts with + | [] -> [""] + | (t::rest) -> + let tid = (string_of_int t.id) in + indent := 8; + String.concat "\n" ([ + "\n// ##### TASK " ^ tid ^ " #############"; + "void task_" ^ tid ^ "(void *arg) {"; + " while(1) {"; + " // Collect my inputs"] @ + (List.map (fun dep_in -> + (Printf.sprintf " printf(\"task_%d: waiting for input from task %d\");\n" t.id dep_in.pred_task) + ^ + (Printf.sprintf " sem_wait(&t%d_to_t%d_sem);\n" dep_in.pred_task t.id) + ^ + (* collect all the vars *) + (String.concat "\n" (List.map (fun (dep_type, dep_id) -> + (Printf.sprintf " %s %s = t%d_to_t%d_%s;" + (gen_ty dep_type) + dep_id + dep_in.pred_task + t.id + dep_id + ) + ) dep_in.vars)) + ) t.deps_in) + @ + [" // End of Input collection"; + ""; + " // ---- Begin task body"; + " "^(gen_blocknode t t.body); + " // ---- End task body"; + ""; + " } /* end task loop */"; + "}"; + ] + ) + :: (help rest) + in + let oc = open_out "/tmp/autogen_tasks.c" in + output_string oc "// ##### AUTOGENERATED TASKS FROM VERACITY ####################\n"; + output_string oc "#include \n"; + output_string oc "#include \n"; + output_string oc "#include \"task.h\"\n"; + output_string oc ("int autogen_taskcount() { return "^(string_of_int (List.length tlist))^"; }\n"); + output_string oc (gen_semaphores tlist); + output_string oc (gen_gvar_decls (List.hd tlist) gvar_decls); + output_string oc (gen_handoff_vars (Dswp_task.calculate_handoff_vars tlist)); + output_string oc (gen_init tlist); + output_string oc (String.concat "\n\n" (help tlist)); + output_string oc (gen_task_loader tlist); + close_out oc; + print_endline "Codegen_c: wrote /tmp/autogen_tasks.c" + +let edge_of_dep myid dp direction : string = + let (src,dst) = if direction then (myid,dp.pred_task) else (dp.pred_task,myid) in + let note = if direction then "out:" else "in:" in + Printf.sprintf "\"%d\" -> \"%d\" [label=\"T%d %s %s\"];\n" + src dst myid note (String.concat "," (List.map (fun (t,i) -> i) dp.vars)) + +let dot_of_task_body tsk : string = + let t = gen_blocknode tsk tsk.body in + let t' = Str.global_replace (Str.regexp_string "\n") "\\n" t in + let t'' = Str.global_replace (Str.regexp_string " ") " " t' in + let es = Str.global_replace (Str.regexp_string "\"") "\\\"" t'' in + if String.length es > 300 then + (String.sub es 0 300)^"...TRUNC ("^(string_of_int (String.length es))^" chars)" + else es + +let print_tasks init_task tlist fn : unit = + let oc = open_out fn in + output_string oc (String.concat "\n" [ + "digraph G {"; + " graph [rankdir=\"TB\", fontname=\"Arial\", fontsize=24, label=\"Tasks\", labelloc=t, labeljust=l]"; + (* Styles *) + " node [shape=box, style=\"filled\", fontname=\"Courier\", margin=0.05]"; + " edge [arrowhead=vee, arrowsize=1, fontname=\"Courier\"]"; + (* Nodes *) + (* "\"0" "\"[label=\"Init Task: "^(dot_of_task_body {id =0; body=init_task.decls; deps_in=[]; deps_out=[]; label=init_task.label})^"\"];\n "^(List.fold_left (fun acc j -> acc ^ "," ^ (Int.to_string j)) "" init_task.jobs)^" \n" ^ *) + (List.fold_left (fun acc tsk -> acc ^ "\"" ^ (string_of_int tsk.id) + ^ "\" [label=\"Task "^(string_of_int tsk.id)^": "^(dot_of_task_body tsk)^"\"];\n") "" tlist); + (* edges *) + List.fold_left (fun acc tsk -> acc ^ + (List.fold_left (fun acc' din -> acc'^(edge_of_dep tsk.id din false)) "" tsk.deps_in) + ^ + (List.fold_left (fun acc' dout -> acc'^(edge_of_dep tsk.id dout true)) "" tsk.deps_out) + ) "" tlist; + "}\n"; + ]); + print_endline ("dag written to " ^ fn); + close_out oc diff --git a/src/vcy/interp.ml b/src/vcy/interp.ml index 7f03de4..f3088c4 100644 --- a/src/vcy/interp.ml +++ b/src/vcy/interp.ml @@ -4,12 +4,11 @@ open Ast_print open Util open Vcylib open Analyze - +open Dswp_task +open Option (*** INTERP MANAGEMENT ***) -let debug_display = ref false - let emit_inferred_phis = ref false let emit_quiet = ref false @@ -18,10 +17,29 @@ let print_cond = ref false let force_sequential = ref false let force_infer = ref false -let debug_print (s : string lazy_t) = - () - (*if !debug_display then print_string (Lazy.force s); flush stdout*) +let dswp_mode = ref false + +let pool_size = ref 8 +let flatten_value_option v = match v with + | Some v -> v + | None -> VVoid + +(* A Job is an unit of work, consisting of: + - task ID that should perform the job + - input data for that job is provided in the + environment as a local, at the topmost call stack frame + - all non-input will share access (Via references) to the + shared environment +*) +type job = { + tid: int; + env: env; + (* the environment will have in the stack the input variables: + vals: (ty * id * value) list + exp will only be constants: CInt, CStr, CBool, etc + *) +} (*** ENVIRONMENT MANAGEMENT ***) @@ -48,13 +66,15 @@ let local_env {l;_} = let current_env env = local_env env @ env.g.globals -let push_block_to_callstk {g;l} = - debug_print @@ lazy (ColorPrint.color_string Light_red Default "Pushing block.\n"); - { g; l = ([] :: List.hd l) :: List.tl l } +let push_block_to_callstk env = + (* debug_print @@ lazy (ColorPrint.color_string Light_red Default "Pushing block.\n"); *) + let env' = {env with l = ([] :: List.hd env.l) :: List.tl env.l} in + (* debug_print @@ lazy (ColorPrint.color_string Light_red Default "Block pushed.\n"); *) + env' -let pop_block_from_callstack {g;l} = - debug_print @@ lazy (ColorPrint.color_string Light_green Default "Popping block.\n"); - { g; l = (List.tl @@ List.hd l) :: List.tl l } +let pop_block_from_callstack {g;l;tid} = + (* debug_print @@ lazy (ColorPrint.color_string Light_green Default "Popping block.\n"); *) + { g; l = (List.tl @@ List.hd l) :: List.tl l; tid } type bind_type = | BindM (* Method or function *) @@ -220,13 +240,13 @@ and interp_exp_seq (env : env) : exp node list -> env * value list = f env (v :: values) t in f env [] -and interp_exp_call {g;l} (loc : Range.t) (args : value list) (params : (id * ty) list) (body : block node) : env * value = +and interp_exp_call {g;l;tid} (loc : Range.t) (args : value list) (params : (id * ty) list) (body : block node) : env * value = (* Check quantity of arguments *) if List.length args <> List.length params then raise @@ TypeFailure ("arity mismatch", loc) (* Check types of arguments *) - else if List.exists2 (fun v (_,ty) -> not @@ ty_match {g;l} v ty) args params + else if List.exists2 (fun v (_,ty) -> not @@ ty_match {g;l;tid} v ty) args params then raise @@ TypeFailure ("argument type mismatch", loc) else @@ -239,11 +259,8 @@ and interp_exp_call {g;l} (loc : Range.t) (args : value list) (params : (id * ty (List.map snd params) (List.map ref args)) in let env = - {g; l = [new_block] :: l} - in begin match interp_block env body with - | env, Some v -> env, v - | env, None -> env, VVoid - end + {g; l = [new_block] :: l; tid} + in second flatten_value_option (interp_block env body) and interp_array_of_values (env : env) (loc : Range.t) (ty : ty) (vs : value list) : env * value = if List.for_all (fun v -> ty_match env v ty) vs @@ -516,6 +533,9 @@ and interp_commute_async (env : env) (blocks : block node list) : env = end; env +and interp_psdswp (env:env) (tasklist : dswp_task list) : env = + failwith "interp_psdswp" + (* Reject commute condition if it might modify state *) and interp_phi (env : env) (phi : exp node) : bool = (*if may_affect_state env phi.elt @@ -526,26 +546,67 @@ and interp_phi (env : env) (phi : exp node) : bool = | _, VBool false -> false | _, _ -> raise @@ TypeFailure ("commutativity condition is not bool", phi.loc) -and interp_return {g;l} (r : value) : env * value option = +and interp_return {g;l;tid} (r : value) : env * value option = debug_print @@ lazy (ColorPrint.color_string Light_blue Default "Popping call. " ^ AstML.string_of_callstk l ^ "\n"); - { g; l = List.tl l }, + { g; l = List.tl l; tid }, Some r +and interp_global_commute (env: env) : (group_commute node * bool) list = + let {g; _} = env in + let rec interp_group_commute g : (group_commute node * bool) list = + begin match g with + | [] -> [] + | gc::tl -> + let _, cc = gc.elt in + begin match cc with + | PhiExp e -> + let v = interp_phi env e in + interp_group_commute tl @ [(gc,v)] + | PhiInf -> interp_group_commute tl + end + end + in + (interp_group_commute g.group_commute) + +and senddep_extend_env env (vals: (ty * id * value) list) : env = + (* Treat new task as a new block in call stack. *) + senddep_extend_env_inner {env with l = ([] :: List.hd env.l ) :: List.tl env.l} vals +and senddep_extend_env_inner env vals = + match vals with + | [] -> env + | (t,i,v)::rest -> + (* This is like Decl statements *) + (* Add ID to environment - most recent call in callstack, innermost block *) + if List.mem_assoc i env.g.globals then begin + debug_print (lazy (Printf.sprintf "Dep is global; not creating new reference: %s = %s\n" i (AstML.string_of_value v |> debug_trunc))); + senddep_extend_env_inner env rest + end else begin + debug_print (lazy (Printf.sprintf "Dep sent: %s = %s\n" i (AstML.string_of_value v |> debug_trunc))); + let stk = List.hd env.l in + let blk = List.hd stk in + let blk = (i, (t, ref v)) :: blk in + let stk = blk :: List.tl stk in + let env' = {env with l=(stk :: List.tl env.l)} in + senddep_extend_env_inner env' rest + end + + + and interp_stmt (env : env) (stmt : stmt node) : env * value option = match stmt.elt with | Assn (enl, enr) -> interp_stmt_assn env stmt.loc enl enr, None | Decl (id, (ty, en)) -> - let {g;l}, v = interp_exp env en in + let env', v = interp_exp env en in if not @@ ty_match env v ty then raise @@ TypeFailure ("Assignment type mismatch", stmt.loc) else (* Add ID to environment - most recent call in callstack, innermost block *) - let stk = List.hd l in + let stk = List.hd env'.l in let blk = List.hd stk in let blk = (id, (ty, ref v)) :: blk in let stk = blk :: List.tl stk in - {g; l = stk :: List.tl l}, None + {env' with l = stk :: List.tl env'.l}, None | Ret None -> interp_return env VVoid | Ret (Some en) -> @@ -624,9 +685,68 @@ and interp_stmt (env : env) (stmt : stmt node) : env * value option = end | Assume _ | Havoc _ -> env, None (* We simply ignore 'assume's and 'havoc's at runtime *) + | SBlock (bl, b) -> + interp_block env b + | SendDep(task_id, var_id_list) -> + (* Tell the scheduler to do it *) + let job_vals = make_job_vals env var_id_list in + send_dep (get env.tid) task_id env job_vals; + + (* now just return the unmodified environment *) + env, None + | SendEOP(task_id) -> + Mutex.protect eop_mutex (fun () -> eop_tasks := task_id :: !eop_tasks); + env, None + | GCommute(_) -> failwith "gcommute in interp_stmt." + | Require(_) -> failwith "require in interp_stmt." +(* | _ -> failwith "interp_stmt: Not Implemented." *) + + (* | SBlock (bl, b) -> + begin match bl with + | None -> interp_block env b + | Some l -> interp_block env b + end; + + let cnd = + match phi with + | PhiExp p -> interp_phi env p + | PhiInf -> + debug_print @@ lazy (Printf.sprintf + "Inferred commute condition at %s is missing; defaulting to 'false'.\n" + (Range.string_of_range stmt.loc)); + false + in let commute = cnd && not !force_sequential in + if commute + then interp_commute_async env blocks, None + else interp_commute_blocks env blocks, None *) + + (* | GCommute (variant, phi, pre, blocks, post) -> + let cnd = + match phi with + | PhiExp p -> interp_phi env p + | PhiInf -> + debug_print @@ lazy (Printf.sprintf + "Inferred commute condition at %s is missing; defaulting to 'false'.\n" + (Range.string_of_range stmt.loc)); + false + in let commute = cnd && not !force_sequential in + begin match variant with + | CommuteVarPar -> + if commute + then interp_commute_async env blocks, None + else interp_commute_blocks env blocks, None + | CommuteVarSeq -> + if commute + then interp_commute_blocks env (shuffle blocks), None + else interp_commute_blocks env blocks, None + end *) +(* and interp_exe_stmt (env: env) (stmt : Exe_pdg.exe_stmt node) : env * value option = + match stmt.elt with + | Stmt s -> interp_stmt env s + | _ -> failwith "not implemented" *) -and interp_block (env : env) (block : block node) : env * value option = +and interp_block ?(new_scope = true) (env : env) (block : block node) : env * value option = let stmts = ref block.elt in let env = ref (push_block_to_callstk env) in let ret = ref None in @@ -641,24 +761,456 @@ and interp_block (env : env) (block : block node) : env * value option = let env = !env in let ret = !ret in let env = - if ret = None + if ret = None && new_scope (* If block returned nothing, pop a block level *) then pop_block_from_callstack env (* If a return occurred, don't pop anything *) else env - in env, ret + in + env, ret + +(* let schedule_task tsk () *) + + +(* PS-DSWP Execution Mode *) + +(* A queue of all things that must be joined before we exit. *) +and jobs_mutex = Mutex.create () +and job_queue = Queue.create () +and all_jobs = ref [] +and run_job jb initial_waits deps = + wait_deps jb initial_waits deps (load_task_def jb.tid).body; + interp_block {jb.env with tid = Some jb.tid} (load_task_def jb.tid).body +(* capture the values of dependent variables from the environment *) +and make_job_vals env deps = + List.fold_left (fun acc (varty,varid) -> + let values = local_env env @ env.g.globals in + begin match List.assoc_opt varid values with + | Some (_,v) -> (varty,varid,!v) :: acc + | None -> raise @@ IdNotFound (varid, Range.norange) + end + ) [] deps +(* Interpreter calls this function at each SendDep to create a new job *) +and add_job j promise = + Mutex.protect jobs_mutex (fun () -> + debug_print (lazy (sp "Adding job with tid=%d.\n" j.tid)); + Queue.add (j, promise) job_queue; + all_jobs := (j, promise) :: !all_jobs) +and new_job ?(wait_on_init = false) j deps = + debug_print (Lazy.from_val (sp "Starting new job with tid=%d.\n" j.tid)); + let deps' = topsort_deps deps in + let initial_waits = if List.is_empty deps' then [] + else begin + let jobs = Mutex.protect jobs_mutex (fun () -> Queue.to_seq job_queue |> List.of_seq) in + List.map (fun dep -> List.filter_map (function | ({tid;_}, _) as j -> if tid = dep.pred_task then Some (j, dep) else None) jobs) (List.hd deps' |> List.sort_uniq (fun a b -> b.pred_task - a.pred_task)) |> List.concat + end in + let deps'' = if List.is_empty deps' then [] else List.concat (List.tl deps') in + let promise = Domainslib.Task.async (get !pool) (fun () -> + if wait_on_init then Mutex.protect init_mutex (const ()); + run_job j initial_waits deps'' |> seq @@ debug_print (lazy (Printf.sprintf "Job with tid=%d successfully finished.\n" j.tid))) in + add_job j promise; + debug_print (Lazy.from_val (sp "Job with tid=%d successfully started.\n" j.tid)); + +and task_defs = ref [] +and pool : Domainslib.Task.pool option ref = ref None +and set_task_def tlist = task_defs := tlist +and load_task_def (taskid:int) : dswp_task = + try List.find (fun t -> t.id == taskid) !task_defs + with Not_found -> failwith "could not find task id" + +and join_all () = + let ret_value = ref None in + while not (Queue.is_empty job_queue) do + begin match Domainslib.Task.await (get !pool) (Mutex.protect jobs_mutex (fun () -> Queue.take job_queue) |> snd) |> snd with + | Some v -> if is_none !ret_value then ret_value := (Some v) + | _ -> () end + done; + !ret_value +and init_job task_id (env : env) = + let env = {env with tid = Some task_id} in + (* debug_print (lazy (Printf.sprintf "Initializing job with tid=%d\n" task_id)); *) + + let task = load_task_def task_id in + + (* Wait for all the dependencies of task *) + (* This must be done outside of new_job as we grab the resulting state immediately. *) + (* wait_deps {tid = task_id; env} task.deps_in task.body; + + debug_print (lazy (Printf.sprintf "Task %d done waiting.\n" task_id)); *) + + (* Now get all the data dependencies *) + + (* + let env' = List.fold_left ( + fun env dep -> + let jobs = Mutex.protect jobs_mutex (fun () -> Queue.to_seq job_queue) in + let (j, p) = try Seq.find (fun (j, _) -> j.tid == dep.pred_task) jobs |> Option.get + with Invalid_argument _ -> failwith (Printf.sprintf "Task id not found: %d" dep.pred_task) + in + if not (interp_phi_two dep.commute_cond env j.env task.body (load_task_def j.tid).body) + (* if it commutes, we don't need to wait *) then begin + senddep_extend_env env + (make_job_vals + (try Seq.find (fun (j, _) -> j.tid == dep.pred_task) jobs |> Option.get |> snd |> Domainslib.Task.await (get !pool) |> fst + with Invalid_argument _ -> failwith "Unexpected error in init_job.") + dep.vars) end + else env + ) env task.deps_in in + *) + (* above isn't necessary since globals are references? TODO: verify this *) + let env' = env in + + (* Now start the job *) + new_job {tid = task_id; env = env'} task.deps_in ~wait_on_init:true; + + (* Mark self as EOP *) + (* + Mutex.protect eop_mutex (fun () -> + debug_print (lazy (Printf.sprintf "EOP: %d\n" task_id)); + eop_tasks := task_id :: !eop_tasks); + *) + +and init_mutex = Mutex.create () +and scheduler init_task env : value option = + let env', _ = interp_block ~new_scope:false env init_task.decls in + + (* Start initial tasks. *) + Domainslib.Task.run (get !pool) (fun () -> + Mutex.lock init_mutex; + List.iter (flip init_job env') init_task.jobs; + Mutex.unlock init_mutex; + join_all ()) + +(* List of things that have sendEOP'd *) +and eop_tasks : int list ref = ref [] +and eop_mutex = Mutex.create() +(* +and topsort_tasks_order = ref None +and make_topsort_tasks () = + (* Just use Kahn's algorithm *) + let res = ref [] in + (* We filter based on the spawning graph -- namely all the edges with make_new_job = true *) + let top = List.filter (fun t -> not (List.exists (fun d -> d.make_new_job) t.deps_in)) !task_defs |> ref in + while not (List.is_empty !top) do + let (n :: top') = !top in + top := top'; + res := n.id :: !res; (* this builds res in reverse topological order *) + (* I don't want to duplicate or modify the whole pdg structure, so just use a seen list + (in practice -- res is such a list) and filter with respect to that. + As implemented, this step has poor performance for large graphs or graphs with many many edges. + But it's definitely not a bottleneck in the program. *) + + (* for each new_task dep out, check that all its deps_in that are make_new_job are in res + In practice since new_task is 1-1, this shouldn't be necessary and should never evaluate to be true, + but implementing it like this to play it safe. *) + List.iter (fun {pred_task; make_new_job;_} -> + if make_new_job then begin + let t : dswp_task = load_task_def pred_task in + if List.for_all (fun t' -> List.mem t'.pred_task !res) (List.filter (fun d -> d.make_new_job) t.deps_in) + then top := t :: !top; (* this will end up exploring in dfs order. as long as it's in top order it doesn't matter though *) + end + ) n.deps_out + done; + topsort_tasks_order := Some (List.rev !res |> List.mapi (fun i e -> (e, i))); + debug_print (lazy (List.fold_left (fun acc (e, i) -> acc ^ Printf.sprintf "(%d, %d), " e i) "Topsort order: " (get !topsort_tasks_order) ^ "\n")); +*) +and topsort_memo = ref [] +and topsort_deps deps = + (* return deps as a list of lists where the first list has no incoming dependencies, 2nd has only from the 1st, etc *) + (* There may be a smarter way to do this but since we only have <10 tasks, I'm going to brute force + memoize. *) + + match List.assoc_opt deps !topsort_memo with + | Some res -> res + | None -> begin + let get_pred_task = function {pred_task; _} -> pred_task in + let remaining = ref deps in + let dep_tasks = List.map get_pred_task deps in + let seen : dependency list ref = ref [] in + let res = ref [] in + while List.is_empty !remaining |> not do + let (level, others) = List.partition (fun dep -> + (* Get all the dependencies whose pred_task has + incoming spawning tasks from deps be only from seen tasks *) + let t = load_task_def dep.pred_task in + List.filter (fun dep' -> dep'.make_new_job && List.mem dep'.pred_task dep_tasks) t.deps_in |> + List.for_all (fun dep' -> List.mem dep'.pred_task (List.map get_pred_task !seen))) !remaining in + res := level :: !res; + seen := level @ !seen; + remaining := others; + done; + let res' = List.rev !res in + topsort_memo := (deps, res') :: !topsort_memo; + res' + end + +and bind_formals formals body env : (string * tyval) list list = + match formals with + | [] -> [[]] + | xs -> begin match body.elt with + | [{elt=SBlock(Some (_, Some vars), _); _}] -> + (* List.iter (fun s -> print_string(s ^ "\n")) formals; + List.iter (fun var -> interp_exp env var |> snd |> AstML.string_of_value |> print_string ) vars; *) + [List.combine formals (List.map (fun var -> interp_exp env var |> snd |> fun v -> (type_of_value v, ref v)) vars)] + | stmts -> debug_print (lazy "Expected formals, but did not find singleton, labeled block.\n"); List.iter (compose Lazy.from_val AstML.string_of_stmt |> compose debug_print) stmts; failwith "Expected formals, but did not find singleton, labeled block." + end +and wait_eop task_id = + let eop_list = ref [] in + Mutex.protect eop_mutex (fun () -> eop_list := !eop_tasks); + while not (List.mem task_id !eop_list) do + Unix.sleepf 0.01; + Mutex.protect eop_mutex (fun () -> eop_list := !eop_tasks) + done +and interp_phi_two {my_task_formals=formals; other_task_formals=formals'; condition = cond; _} lenv renv lbody rbody = + match cond with + | Some phi -> + interp_phi {lenv with l = (bind_formals formals lbody lenv @ bind_formals formals' rbody renv) :: []} phi + | None -> false +and wait_deps j init_waits deps self_body = + (* Wait for everything we need to EOP to EOP. *) + (* As per discussion, forego EOP waiting. *) + (* List.iter (fun dep -> wait_eop dep.pred_task) deps; *) + + (* debug_print (lazy (Printf.sprintf "%d's unsorted deps: " (Option.value j.env.tid ~default:(-1)) ^ List.fold_left (fun acc e -> acc ^ Printf.sprintf "%d " e.pred_task) "" deps ^ "\n")); *) + + (* topologically sort the dependencies *) + (* This should already be done by this point *) + (* + let deps' = + let order_index = get !topsort_tasks_order in + List.fast_sort (fun x y -> List.assoc x.pred_task order_index - List.assoc y.pred_task order_index) deps + in + *) + + (* debug_print (lazy (Printf.sprintf "%d's sorted deps: " (Option.value j.env.tid ~default:(-1)) ^ List.fold_left (fun acc e -> acc ^ Printf.sprintf "%d " e.pred_task) "" deps' ^ "\n")); *) + + debug_print (lazy (Printf.sprintf "%d's deps: (jobs with tid: %s) (tasks: %s)\n" + (Option.value j.env.tid ~default:(-1)) + (List.fold_left (fun acc e -> acc ^ Printf.sprintf "%d " (fst e |> fst).tid) "" init_waits) + (List.fold_left (fun acc e -> acc ^ Printf.sprintf "%d " e.pred_task) "" deps))); + + let wait_job (j', promise) = function + | {commute_cond = cond; _} + when not (interp_phi_two cond j.env j'.env self_body (load_task_def j'.tid).body) -> + debug_print (lazy (Printf.sprintf "Commute condition not met. Waiting on job %d.\n" j.tid)); + Domainslib.Task.await (get !pool) promise |> ignore + | _ -> debug_print (lazy ("Commute condition met. Skipping.\n")) + in + + (* wait on every initial job *) + List.iter (uncurry wait_job) init_waits; + + (* For each dependency in order, wait on all jobs we're dependent on. *) + List.iter (fun d -> + let jobs = Mutex.protect jobs_mutex (fun () -> !all_jobs) in + (* Get the jobs corresponding to this dependency *) + let jobs_to_wait = List.filter (fun (j', _) -> j'.tid = d.pred_task && not (j' == j)) jobs in + List.iter (flip wait_job d) jobs_to_wait + ) deps; + +and send_dep calling_tid tid env vals = + (* 1 - Check input dependencies + 1a - If it doesn't commute, then wait for EOP and for all of them to join. + (For now we poll, can add ourselves to a list of processes to be woken up when EPO happens) + 1a - If it's a commute condition, still wait for EOP, + Check all existing jobs and check commutativity condition between them. + 2 - Create new environment, and create new job. + *) + + debug_print (lazy (Printf.sprintf "send_dep called for tid=%d\n" tid)); + + let env' = senddep_extend_env env vals in + let env' = {env' with tid = Some tid} in + + (* 1 *) + let task = load_task_def tid in + let deps = + List.filter (function + | {pred_task;_} when pred_task = calling_tid -> false (* Skip calling task *) + | {commute_cond = {condition = Some phi; _}; _} -> true + | _ -> true ) task.deps_in + in + (* debug_print (lazy (Printf.sprintf "send_dep: %d dependencies\n" (List.length deps))); *) + + (* Wait on dependencies to finish executing. *) + (* wait_deps env' deps task.body; + This is now handled during job creation. + *) + + (* 2 -- make the new job *) + (* TODO: What env? All non-deps are just global, no? Just use outer env. *) + new_job {tid; + env = env'} deps + +(* Draft of new scheduler that accumulates dependencies *) +(* +let received_dependencies = ref [] +let dep_mutex = Mutex.create() +let env0 = ref None +let scheduler' env = + env0 := Some env; + (* Start initial jobs -- one with no input dependencies. *) + List.filter (fun task -> null task.deps_in) !task_defs + |> List.map (fun task -> {tid=task.id; env=env}) + |> List.iter new_job; + Domainslib.Task.run !pool join_all + +let send_dep tfrom tto vals = + (* Receive the new dependency *) + Mutex.lock dep_mutex; + let pre_deps = !received_dependencies in + let post_deps = (tfrom, tto, vals) :: pre_deps in + received_dependencies := post_deps; + Mutex.unlock dep_mutex; + + (* Check if that was the last dependency we needed *) + let task = load_task_def tto in + let relevant_deps = List.filter (fun (_, tto', _) -> tto' = tto) post_deps in + if List.for_all (fun from -> + List.exists (fun (from', _, _) -> from' = from) relevant_deps) task.deps_in + (* TODO: check that all the variables sent are the ones we needed? *) + then new_job {tid = tto; + env = List.fold_left senddep_extend_env (Option.get !env0) (List.map trd relevant_deps)} +*) (*** COMMUTATIVITY INFERENCE ***) (* Globals are relative to the blocks *) -let infer_phi (g : global_env) (var : commute_variant) (bl : block node list) (globals : ty bindlist) : exp node = - let e = Analyze.phi_of_blocks g var bl globals in +let infer_phi (g : global_env) (var : commute_variant) (bl : block node list) (globals : ty bindlist) pre post : exp node = + let e = Analyze.phi_of_blocks g var bl globals pre post in no_loc e +let labeled_blocks = ref [] +let global_defs = ref [] + +let find_blocks_by_label labels = + let blks = ref [] in + List.iter (fun ls -> List.iter (fun (id, args) -> + let [@warning "-8"] {elt=SBlock(Some(i,_),bl);_} = List.find + (function {elt=SBlock(Some(i,_),a);_} -> String.equal i id | _ -> false) !labeled_blocks + in blks := !blks @ [bl]) ls) labels; + !blks + +(* Find the index of the first occurrence of x in list l *) +let rec find_index x l = + let rec aux x l idx = + match l with + | [] -> -1 (* x not found *) + | h :: t -> if h.elt = x.elt then idx else aux x t (idx + 1) + in + aux x l 0 + +let find_corresponding a b s = + let idx = find_index s b in + if idx == -1 then None + else Some (List.nth a idx) + + +let rec substitute_vars_exp (args_in: exp node list) (args_out: exp node list) exp = + let e = match exp.elt with + | CStr _ | Id _ -> find_corresponding args_in args_out exp + | Index (e1, e2) -> Some (node_up exp (Index (substitute_vars_exp args_in args_out e1, substitute_vars_exp args_in args_out e2))) + | Bop (op, e1, e2) -> Some (node_up exp @@ Bop (op, substitute_vars_exp args_in args_out e1, substitute_vars_exp args_in args_out e2)) + | Uop (op, e) -> Some (node_up exp @@ Uop (op, substitute_vars_exp args_in args_out e)) + | CallRaw (id, el) -> Some (node_up exp @@ CallRaw (id, List.map (substitute_vars_exp args_in args_out) el)) + | Call (method_variant, el) -> Some (node_up exp @@ Call (method_variant, List.map (substitute_vars_exp args_in args_out) el)) + | CNull _ | CBool _ | CInt _ -> None + | _ -> None + (* + | CArr of ty * exp node list + | NewArr of ty * exp node + | NewHashTable of hashtable_variant * ty * ty + | Ternary of exp node * exp node * exp node + | CStruct of id * exp node bindlist + | Proj of exp node * id + *) + in + match e with + | None -> exp + | Some ex -> ex + +let rec substitute_vars_block (args_in: exp node list) (args_out: exp node list) block = + match block with + | [] -> block + | s::tl -> + let s' = begin match s.elt with + | Assn (e1,e2) -> Assn (substitute_vars_exp args_in args_out e1, substitute_vars_exp args_in args_out e2) + | If (e,b1,b2) -> If (substitute_vars_exp args_in args_out e, node_up b1 @@ substitute_vars_block args_in args_out b1.elt, node_up b2 @@ substitute_vars_block args_in args_out b2.elt) + | Ret (Some e) -> Ret (Some (substitute_vars_exp args_in args_out e)) + | Decl (id, (ty, e)) -> Decl (id,(ty,substitute_vars_exp args_in args_out e)) + | SCallRaw (id, el) -> SCallRaw (id, List.map (substitute_vars_exp args_in args_out) el) + | SCall (method_variant, el) -> SCall (method_variant, List.map (substitute_vars_exp args_in args_out) el) + (* + + | For of vdecl list * exp node option * stmt node option * block node + | While of exp node * block node + | Raise of exp node + | Commute of commute_variant * commute_condition * block node list + | Assert of exp node + | Assume of exp node + | Havoc of id + | Require of exp node + | SBlock of blocklabel option * block node + | GCommute of commute_variant * commute_condition * commute_pre_cond * block node list * commute_post_cond + | SendDep of int * ((ty * id) list) (* only for dependency of tasks *) + | SendEOP of int *) + | _ -> s.elt + end + in (node_up s s') :: substitute_vars_block args_in args_out tl + +let infer_phis_of_global_commutativity (g : global_env) (defs : ty bindlist) : group_commute node list = + let rec interp_group_commute (gc: group_commute node list) : group_commute node list = + begin match gc with + | [] -> [] + | gc::tl -> + let labels, phi = gc.elt in + let blks = ref [] in + List.iter ( + fun ls -> + List.iter ( + fun (id, args) -> + let {elt=SBlock(Some(i,args'),bl);_} = List.find (fun {elt=SBlock(Some(i,_),a);_} -> String.equal i id) !labeled_blocks in + let bl' = match args, args' with + | Some a, Some a' -> + (* List.iter (fun x -> Printf.printf "args: %s \n" (AstML.string_of_exp x)) a; + List.iter (fun x -> Printf.printf "args': %s \n" (AstML.string_of_exp x)) a'; *) + let b' = node_up bl (substitute_vars_block a a' bl.elt) in + (* Printf.printf "==> %s \n" (AstML.string_of_block b'); *) + b' + | _, _ -> bl + in + blks := !blks @ [bl'] + ) ls + ) labels; + let phi' = + let infer () = + (* apply_pairs (fun b1 b2 -> infer_phi g CommuteVarPar (b1@b2) defs None None) !blks *) + let phi' = infer_phi g CommuteVarPar !blks defs None None in + if !emit_inferred_phis then + begin if !emit_quiet + then Printf.printf "%s\n" + (AstPP.string_of_exp phi') + else Printf.printf "Inferred condition at %s: %s\n" + (Range.string_of_range gc.loc) + (AstPP.string_of_exp phi') + end; + phi' + in match phi with + | PhiExp e -> if !force_infer then infer () else e + | PhiInf -> infer () + + in let c = {gc with elt = (labels, PhiExp phi')} in + (List.cons c) + (interp_group_commute tl) + end + in + interp_group_commute g.group_commute + + let rec infer_phis_of_block (g : global_env) (defs : ty bindlist) (body : block node) : block node = + global_defs := remove_duplicate (defs @ !global_defs); if body.elt = [] then node_up body [] else let h,t = List.hd body.elt, node_app List.tl body in match h.elt with @@ -694,7 +1246,7 @@ let rec infer_phis_of_block (g : global_env) (defs : ty bindlist) (body : block | Commute (var,phi,bl) -> let bl = List.map (infer_phis_of_block g defs) bl in let phi' = - let infer () = let phi' = infer_phi g var bl defs in + let infer () = let phi' = infer_phi g var bl defs None None in if !emit_inferred_phis then begin if !emit_quiet then Printf.printf "%s\n" @@ -711,6 +1263,36 @@ let rec infer_phis_of_block (g : global_env) (defs : ty bindlist) (body : block node_app (List.cons (node_up h s)) (infer_phis_of_block g defs t) + | SBlock (bl, b) -> + let s = SBlock (bl, infer_phis_of_block g defs b) in + begin match bl with + | Some _ -> labeled_blocks := !labeled_blocks @ [node_up h s] + | None -> () + end; + node_app + (List.cons (node_up h s)) + (infer_phis_of_block g defs t) + | GCommute (var,phi,pre,bl,post) -> + let bl = List.map (infer_phis_of_block g defs) bl in + let phi' = + let infer () = let phi' = infer_phi g var bl defs (Some pre) (Some post) in + if !emit_inferred_phis then + begin if !emit_quiet + then Printf.printf "%s\n" + (AstPP.string_of_exp phi') + else Printf.printf "Inferred condition at %s: %s\n" + (Range.string_of_range h.loc) + (AstPP.string_of_exp phi') + end; + phi' + in match phi with + | PhiExp e -> if !force_infer then infer () else e + | PhiInf -> infer () + in let s = Commute (var, PhiExp phi', bl) in + node_app + (List.cons (node_up h s)) + (infer_phis_of_block g defs t) + | SendDep (_, _) | SendEOP(_) -> failwith "sendDep/sendEOP should not be in infer_phis_of_block." let infer_phis_of_prog (g : global_env) : global_env = let globals : ty bindlist = @@ -720,10 +1302,73 @@ let infer_phis_of_prog (g : global_env) : global_env = { m with body = infer_phis_of_block g (m.args @ globals) m.body } - in { g with methods = List.map map_method g.methods } + in + let m = List.map map_method g.methods in + let gc = infer_phis_of_global_commutativity g !global_defs in + { g with methods = m; group_commute = gc } + +let verify_phis_of_global_commutativity (g : global_env) (defs : ty bindlist) : unit = + let rec interp_group_commute (gc: group_commute node list) : unit = + begin match gc with + | [] -> () + | gc::tl -> + let labels, phi = gc.elt in + let blks = ref [] in + List.iter ( + fun ls -> + List.iter ( + fun (id, args) -> + let {elt=SBlock(Some(i,args'),bl);_} = List.find (fun {elt=SBlock(Some(i,_),a);_} -> String.equal i id) !labeled_blocks in + let bl' = match args, args' with + | Some a, Some a' -> + node_up bl (substitute_vars_block a a' bl.elt) + | _, _ -> bl + in + blks := !blks @ [bl'] + ) ls + ) labels; + begin match phi with + | PhiExp e -> + if !print_cond then + Printf.printf "%s\n" (AstPP.string_of_exp e); + + begin match Analyze.verify_of_block e g CommuteVarPar !blks defs None None with + | Some b, compl -> + let compl_str = + match compl with + | Some true -> "true" + | Some false -> "false" + | None -> "unknown" + in + if not b then begin + if not !emit_quiet then Printf.printf "Condition at %s verified as incorrect: %s\n" + (Range.string_of_range gc.loc) + (AstPP.string_of_exp e) + else print_string "incorrect\n" + end else begin + if not !emit_quiet then + Printf.printf "Condition at %s verified as correct: %s\nComplete status: %s\n" + (Range.string_of_range gc.loc) + (AstPP.string_of_exp e) + compl_str + else Printf.printf "correct\n%s\n" compl_str + end + | None, _ -> + if not !emit_quiet then + Printf.printf "Condition at %s unable to verify: %s\n" + (Range.string_of_range gc.loc) + (AstPP.string_of_exp e) + else print_string "failure\n" + end + | PhiInf -> () end; + (interp_group_commute tl) + end + in + interp_group_commute g.group_commute let rec verify_phis_of_block (g : global_env) (defs : ty bindlist) (body : block node) : block node = + global_defs := remove_duplicate (defs @ !global_defs); if body.elt = [] then node_up body [] else let h,t = List.hd body.elt, node_app List.tl body in match h.elt with @@ -756,6 +1401,15 @@ let rec verify_phis_of_block (g : global_env) (defs : ty bindlist) (body : block node_app (List.cons (node_up h s)) (verify_phis_of_block g defs t) + | SBlock (bl, b) -> + let s = SBlock (bl, verify_phis_of_block g defs b) in + begin match bl with + | Some _ -> labeled_blocks := !labeled_blocks @ [node_up h s] + | None -> () + end; + node_app + (List.cons (node_up h s)) + (verify_phis_of_block g defs t) | Commute (var,phi,bl) -> let bl = List.map (verify_phis_of_block g defs) bl in begin match phi with @@ -763,7 +1417,7 @@ let rec verify_phis_of_block (g : global_env) (defs : ty bindlist) (body : block if !print_cond then Printf.printf "%s\n" (AstPP.string_of_exp e); - begin match Analyze.verify_of_block e g var bl defs with + begin match Analyze.verify_of_block e g var bl defs None None with | Some b, compl -> let compl_str = match compl with @@ -796,6 +1450,47 @@ let rec verify_phis_of_block (g : global_env) (defs : ty bindlist) (body : block node_app (List.cons (node_up h s)) (verify_phis_of_block g defs t) + | GCommute (var,phi,pre,bl,post) -> + let bl = List.map (verify_phis_of_block g defs) bl in + begin match phi with + | PhiExp e -> + if !print_cond then + Printf.printf "%s\n" (AstPP.string_of_exp e); + + begin match Analyze.verify_of_block e g var bl defs (Some pre) (Some post) with + | Some b, compl -> + let compl_str = + match compl with + | Some true -> "true" + | Some false -> "false" + | None -> "unknown" + in + if not b then begin + if not !emit_quiet then Printf.printf "Condition at %s verified as incorrect: %s\n" + (Range.string_of_range h.loc) + (AstPP.string_of_exp e) + else print_string "incorrect\n" + end else begin + if not !emit_quiet then + Printf.printf "Condition at %s verified as correct: %s\nComplete status: %s\n" + (Range.string_of_range h.loc) + (AstPP.string_of_exp e) + compl_str + else Printf.printf "correct\n%s\n" compl_str + end + | None, _ -> + if not !emit_quiet then + Printf.printf "Condition at %s unable to verify: %s\n" + (Range.string_of_range h.loc) + (AstPP.string_of_exp e) + else print_string "failure\n" + end + | PhiInf -> () end; + let s = Commute (var, phi, bl) in + node_app + (List.cons (node_up h s)) + (verify_phis_of_block g defs t) + | SendDep (_, _) | SendEOP(_) | Require(_) -> failwith "sendDep/sendEOP/require should not be present in verify_phis." let verify_phis_of_prog (g : global_env) : global_env = let globals : ty bindlist = @@ -805,7 +1500,10 @@ let verify_phis_of_prog (g : global_env) : global_env = { m with body = verify_phis_of_block g (m.args @ globals) m.body } - in { g with methods = List.map map_method g.methods } + in + let m = List.map map_method g.methods in + verify_phis_of_global_commutativity g !global_defs; + { g with methods = m } (* TODO: The above is mostly copy pasted from infer. Could just be a _ -> () pass of the AST instead of typed as a transformation. *) (*** ENVIRONMENT CONSTRUCTION ***) @@ -819,17 +1517,27 @@ let rec construct_env (g : global_env) (globals : texp_list) : prog -> global_en | [] -> { g with lib_methods = lib_methods }, globals | Gvdecl {elt = {name; ty; init}; loc = _} :: tl -> construct_env g ((name,(ty,init)) :: globals) tl - | Gmdecl {elt = {pure;mrtyp;mname;args;body}; loc = _} :: tl -> + | Gmdecl {elt = {pure;mrtyp;mname;args;body}; loc = l} :: tl -> + (* let gc_list = interp_global_commute g in *) + (* Exe_pdg.ps_dswp body l args g globals; *) + + (* Eric's testing of Vcy-to-C. This will later be called with the re-constructed task bodies *) + (* Codegen_c.gen body.elt; *) + (* Codegen_c.gen_tasks (Task.example_var_decls ()) (Task.example_tasks ()); *) + (* Codegen_c.print_tasks (Task.example_tasks ()) "/tmp/tasks.dot"; *) + let m = { pure ; rty = mrtyp - ; args = List.map flip args + ; args = List.map swap args ; body } in construct_env {g with methods = (mname,m) :: g.methods } globals tl | Gsdecl {elt = {sname;fields}; loc = _} :: tl -> let s = sname, List.map (fun {field_name;ftyp} -> field_name,ftyp) fields in construct_env {g with structs = s :: g.structs} globals tl + | Commutativity gc :: tl -> + construct_env {g with group_commute = gc} globals tl (* Convert all SCallRaw to SCall, and CallRaw to Call * All that needs adjusting is methods. @@ -847,7 +1555,7 @@ let cook_calls (g : global_env) : global_env = Index (cook_calls_of_exp e1, cook_calls_of_exp e2) | CallRaw (id, el) -> let el = List.map cook_calls_of_exp el in - begin match find_binding id {g;l=[]} BindM with + begin match find_binding id {g;l=[];tid=None} BindM with | BMGlobal mv -> Call (MethodM (id, mv), el) | BMLib mv -> @@ -886,7 +1594,7 @@ let cook_calls (g : global_env) : global_env = Ret (Option.map cook_calls_of_exp e) | SCallRaw (id, el) -> let el = List.map cook_calls_of_exp el in - begin match find_binding id {g;l=[]} BindM with + begin match find_binding id {g;l=[];tid=None} BindM with | BMGlobal mv -> SCall (MethodM (id, mv), el) | BMLib mv -> @@ -922,6 +1630,20 @@ let cook_calls (g : global_env) : global_env = Havoc id | Require e -> Require (cook_calls_of_exp e) + | SBlock (bl, b) -> + begin match bl with + | None -> SBlock(None, cook_calls_of_block b) + | Some l -> + SBlock(Some l, cook_calls_of_block b) + end + | GCommute (v, c, pre, bl, post) -> + let c = + match c with + | PhiExp e -> PhiExp (cook_calls_of_exp e) + | PhiInf -> PhiInf + in + GCommute (v, c, cook_calls_of_exp pre, List.map cook_calls_of_block bl, cook_calls_of_exp post) + | SendDep (_, _) | SendEOP(_) -> failwith "sendDep/sendEOP should not be present in cook_calls." in node_up s s' @@ -941,7 +1663,7 @@ let cook_calls (g : global_env) : global_env = let evaluate_globals (g : global_env) (es : texp_list) : global_env = let vs = List.map - (fun (i,(t,e)) -> i, (t, ref @@ snd @@ interp_exp {g;l=[]} e)) + (fun (i,(t,e)) -> i, (t, ref @@ snd @@ interp_exp {g;l=[];tid=None} e)) es in {g with globals = vs} @@ -953,6 +1675,7 @@ let initialize_env (prog : prog) (infer_phis : bool) = ; globals = [] ; structs = [] ; lib_methods = Vcylib.lib_methods + ; group_commute = [] } in (* Initialize environment *) @@ -968,7 +1691,14 @@ let initialize_env (prog : prog) (infer_phis : bool) = then Printf.eprintf "%f\n" dt; g else g - in {g;l=[]} + in + (* let gc_list = interp_global_commute g in *) + if !dswp_mode then + List.iter (fun m -> match m with | (Gmdecl {elt = {pure;mrtyp;mname;args;body}; loc = l}) -> Exe_pdg.ps_dswp body l args g globals | _ -> ()) prog; + + (* EK TODO - complain if more than 1 method declaraiton in SWP mode *) + + {g;l=[[[]]];tid=None} let prepare_prog (prog : prog) (argv : string array) = @@ -981,10 +1711,29 @@ let prepare_prog (prog : prog) (argv : string array) = let l = argv |> Array.map (fun v -> CStr v |> no_loc) |> Array.to_list in CArr (TStr, l) |> no_loc in - - (* Construct main function 'Call' expression *) - let e = CallRaw (main_method_name, [e_argc;e_argv]) |> no_loc in - env, e + (* Printf.printf "%s\n" (AstPP.string_of_exp e_argv); *) + + if !dswp_mode then begin + (* No "main call" in DSWP mode. Instead augment env with argc/argv*) + let blk_stk = ["argc",(TInt, ref (VInt(Int64.of_int @@ Array.length argv))); + "argv",(TArr(TStr),ref (VArr (TStr, argv |> Array.map (fun v -> VStr v))))] in + let cstk = [blk_stk] in + { env with l = cstk :: env.l }, CBool(false) |> no_loc + (* senddep_extend_env env [(TInt,"argc",VInt(Int64.of_int @@ Array.length argv)); + (TArr(TStr),"argv",VArr (TStr, argv |> Array.map (fun v -> VStr v)))] *) + (* { g=env.g; l=}, e *) + end else + (* Construct main function 'Call' expression *) + let e = CallRaw (main_method_name, [e_argc;e_argv]) |> no_loc in + env, e + +let interp_tasks env0 decls init_task tasks : value = + set_task_def tasks; + (* create a job for each task with no deps_in -- REMOVED, just start job 0 in scheduler. *) + (* let jobs = List.filter (fun task -> null task.deps_in (* && task.id <> 0 *)) !task_defs + |> List.map (fun task -> {tid=task.id; env=env0}) in *) + (* start the scheduler *) + scheduler init_task env0 |> flatten_value_option (* Kick off interpretation of progam. * Build initial environment, construct argc and argv, @@ -992,17 +1741,29 @@ let prepare_prog (prog : prog) (argv : string array) = let interp_prog (prog : prog) (argv : string array) : int64 = let env, e = prepare_prog prog argv in (* Evaluate main function invocation *) - match interp_exp env e with - | _, VInt ret -> ret - | _, _ -> raise @@ TypeFailure (main_method_name ^ " function did not return int", Range.norange) + match (if !dswp_mode + then begin + pool := Domainslib.Task.setup_pool ~num_domains:!pool_size () |> some; + interp_tasks env !Exe_pdg.generated_decl_vars (Option.get !Exe_pdg.generated_init_task) !Exe_pdg.generated_tasks + end + else interp_exp env e |> snd) with + | VInt ret -> ret + | _ -> raise @@ TypeFailure (main_method_name ^ " function did not return int", Range.norange) (* Execute but return lapsed time instead of program return *) let interp_prog_time (prog : prog) (argv : string array) : float = let env, e = prepare_prog prog argv in Vcylib.suppress_print := true; - let dt, _ = time_exec @@ fun () -> interp_exp env e in - dt + if !dswp_mode then + begin + pool := Domainslib.Task.setup_pool ~num_domains:!pool_size () |> some; + let dt, _ = time_exec @@ fun () -> interp_tasks env !Exe_pdg.generated_decl_vars (Option.get !Exe_pdg.generated_init_task) !Exe_pdg.generated_tasks in + dt + end + else + let dt, _ = time_exec @@ fun () -> interp_exp env e in + dt (*let t0 = Unix.gettimeofday () in ignore @@ interp_exp env e; let t1 = Unix.gettimeofday () in diff --git a/src/vcy/run.ml b/src/vcy/run.ml index 02b6f17..33a5e36 100644 --- a/src/vcy/run.ml +++ b/src/vcy/run.ml @@ -134,16 +134,22 @@ module RunInterp : Runner = struct let prover_name = ref "" let timeout = ref None + let dswp_mode = ref false + (* let no_named_blocks = ref false *) (* TODO *) let speclist = [ "-d", Arg.Set debug, " Display verbose debugging info during interpretation" ; "--debug", Arg.Set debug, " Display verbose debugging info during interpretation" + ; "--codegen", Arg.Set Exe_pdg.codegen, " Output generated .c file" ; "--force-sequential", Arg.Set force_sequential, " Force all commutativity blocks to execute in sequence" ; "--time", Arg.Set get_execution_time, " Output execution time instead of main's return" ; "--verbose", Arg.Set Servois2.Util.verbosity, "Servois2 verbose output" ; "--very-verbose", Arg.Set Servois2.Util.very_verbose, " Very verbose output and print smt query files" - ; "--prover", Arg.Set_string prover_name, " Use a particular prover (default: CVC4)" - ; "--timeout", Arg.Float (fun f -> timeout := Some f), " Set timeout for servois2 queries" + ; "--prover", Arg.Set_string prover_name, " Use a particular prover (default: CVC4)" + ; "--timeout", Arg.Float (fun f -> timeout := Some f), " Set timeout for servois2 queries" + ; "--dswp", Arg.Set dswp_mode, " Enable PS-DSWP Interpretation" + ; "--threads", Arg.Int (fun i -> Interp.pool_size := i), " Set number of threads for DSWP mode (default: 8)" + (* ; "--no-named-blocks", Arg.Set no_named_blocks, " Deal with named blocks as the normal blocks" *) ] |> Arg.align @@ -159,7 +165,7 @@ module RunInterp : Runner = struct let interp prog_name argv = try if !debug then begin - Interp.debug_display := true; + Util.debug := true; Interp.emit_inferred_phis := true; Printexc.record_backtrace true end; @@ -168,13 +174,24 @@ module RunInterp : Runner = struct Interp.force_sequential := true; end; + if !dswp_mode then begin + Interp.dswp_mode := true; + end; + + if Util.contains_substring prog_name "simple-io" then begin + Util.manual_dependency := true; (* TODO: rm later after add support for filesys deps *) + end + else begin + Util.manual_dependency := false; + end; + let prog = Driver.parse_oat_file prog_name in Random.self_init (); begin if !get_execution_time then let time = Interp.interp_prog_time prog argv in Printf.printf "%f\n" time - else + else let ret = Interp.interp_prog prog argv in Printf.printf "Return: %Ld\n" ret end; @@ -201,7 +218,7 @@ module RunInterp : Runner = struct end - +(* module RunTranslate : Runner = struct let usage_msg exe_name = "Usage: " ^ exe_name ^ " translate [] " @@ -249,7 +266,53 @@ module RunTranslate : Runner = struct | _ -> Arg.usage speclist (usage_msg Sys.argv.(0)) end +*) +module RunCompile : Runner = struct + let usage_msg exe_name = + "Usage: " ^ exe_name ^ " compile [] " + + let debug = ref false + + let output_file = ref "" + (* let output_dir = ref "" *) + + let anons = ref [] + + let anon_fun (v : string) = + anons := v :: !anons + + let get_execution_time = ref false + + let speclist = + [ "-d", Arg.Set debug, " Display verbose debugging info during interpretation" + ; "--debug", Arg.Set debug, " Display verbose debugging info during interpretation" + ; "-o", Arg.Set_string output_file, " Output generated C file." + ; "--time", Arg.Set get_execution_time, " Output execution time instead of main's return" + ] |> + Arg.align + + let compile_prog p = begin + (* 1. Construct the PDG *) + print_endline "run.ml RunCompile compile_prog: todo"; + (* 2. SCC, thread partitioning, construct task objects, etc (Parisa TODO) *) + + (* 3. Code generation: from Tasks to C *) + (* (will use Codegen_c c_of_prog) *) + Exe_pdg.codegen := true; + print_endline ("emitted "^(!output_file)^", which can now be compiled") + end + + let run () = + + Arg.current := 1; + Arg.parse speclist anon_fun (usage_msg Sys.argv.(0)); + let anons = List.rev (!anons) in + match anons with + | prog :: _ -> compile_prog prog + | _ -> Arg.usage speclist (usage_msg Sys.argv.(0)) + +end module RunInterface : Runner = struct let usage_msg exe_name = @@ -463,9 +526,12 @@ module RunInfer : Runner = struct let infer_phis prog_name = if !debug then begin Printexc.record_backtrace true; - Interp.debug_display := true; + Util.debug := true; end; + (* This will enable inference of global commutativity specs *) + (* Interp.dswp_mode := true; *) + Interp.time_servois := !time_servois; Interp.emit_inferred_phis := true; (*not @@ !Interp.time_servois;*) Interp.emit_quiet := !quiet; @@ -475,7 +541,7 @@ module RunInfer : Runner = struct let open Ast in if !output_file != "" then begin let gmdecls = List.map (fun (name, tmethod) -> Gmdecl(no_loc @@ mdecl_of_tmethod name tmethod)) env.g.methods in - let prog' = gmdecls @ List.filter (function Gvdecl _ | Gsdecl _ -> true | Gmdecl _ -> false) prog in + let prog' = gmdecls @ List.filter (function Gvdecl _ | Gsdecl _ -> true | Gmdecl _ | Commutativity _ -> false) prog in let translated_prog = Ast_print.AstPP.string_of_prog prog' in let out_chan = open_out !output_file in output_string out_chan translated_prog; @@ -539,7 +605,7 @@ module RunVerify : Runner = struct let verify prog_name = if !debug then begin Printexc.record_backtrace true; - Interp.debug_display := true; + Util.debug := true; end; Interp.emit_inferred_phis := true; @@ -576,7 +642,8 @@ type command = | CmdPhi (* Generate commutativity condition *) | CmdInfer (* Infer commute conditions *) | CmdVerify - | CmdTranslate + (* | CmdTranslate *) + | CmdCompile (* Compile to C program implementing global commutativity PDG-base SWP *) let command_map = [ "help", CmdHelp @@ -588,7 +655,8 @@ let command_map = (*; "phi", CmdPhi*) ; "infer", CmdInfer ; "verify", CmdVerify - ; "translate", CmdTranslate + (* ; "translate", CmdTranslate *) + ; "compile", CmdCompile ] let runner_map : (command * (module Runner)) list = @@ -599,7 +667,8 @@ let runner_map : (command * (module Runner)) list = (*; CmdPhi, (module RunPhi)*) ; CmdInfer, (module RunInfer) ; CmdVerify, (module RunVerify) - ; CmdTranslate, (module RunTranslate) + (* ; CmdTranslate, (module RunTranslate) *) + ; CmdCompile, (module RunCompile) ] let display_help_message exe_name = @@ -613,7 +682,8 @@ let display_help_message exe_name = (*" phi Generate commutativty condition between two methods\n" ^*) " infer Infer and emit all blank commutativity conditions\n" ^ " verify Verify all provided commutativity conditions\n" ^ - " translate Translate program to C\n " + (* " translate Translate program to C\n "^ *) + " compile Compile (to C) via global commutativity and task parallelism\n " in Printf.eprintf "Usage: %s [] []\n%s" exe_name details (* Check first argument for command *) diff --git a/src/vcy/vcy_lexer.mll b/src/vcy/vcy_lexer.mll index 82c0f08..e86ad2c 100644 --- a/src/vcy/vcy_lexer.mll +++ b/src/vcy/vcy_lexer.mll @@ -43,6 +43,8 @@ ("hashtable", HASHTABLE); ("hashtable_seq", HASHTABLE_SEQ); ("hashtable_naive", HASHTABLE_NAIVE); + ("pre", PRE); + ("post", POST); (* Symbols *) ( ";", SEMI); @@ -97,6 +99,7 @@ ("assert", ASSERT); ("assume", ASSUME); ("havoc", HAVOC); + ("commutativity", COMMUTATIVITY); ("_", UNDERSCORE); diff --git a/src/vcy/vcy_parser.mly b/src/vcy/vcy_parser.mly index f6d0233..ba52ee6 100644 --- a/src/vcy/vcy_parser.mly +++ b/src/vcy/vcy_parser.mly @@ -78,6 +78,8 @@ let loc (startpos:Lexing.position) (endpos:Lexing.position) (elt:'a) : 'a node = %token PURE %token ASSERT ASSUME HAVOC +%token COMMUTATIVITY +%token PRE POST %token UNDERSCORE @@ -135,6 +137,14 @@ decl: }) } | STRUCT sname=UIDENT LBRACE fields=separated_list(SEMI, decl_field) RBRACE { Gsdecl (loc $startpos $endpos {sname; fields}) } + | COMMUTATIVITY LBRACE gc = separated_list(SEMI,group_commute) RBRACE { Commutativity(gc) } + +group_commute: + | bls = separated_list(COMMA, commute_frag) COLON phi=commute_condition {loc $startpos $endpos @@ (bls,phi) } + +commute_frag: + /*| f = block_label {f}*/ + | LBRACE fl=separated_list(COMMA, block_label) RBRACE {fl} (*(*%inline*) pure: | PURE { true } @@ -254,6 +264,18 @@ stmt: | ASSERT e=exp SEMI { loc $startpos $endpos @@ Assert e } | ASSUME e=exp SEMI { loc $startpos $endpos @@ Assume e } | HAVOC i=IDENT SEMI { loc $startpos $endpos @@ Havoc i } + | b=block { loc $startpos $endpos @@ SBlock(None,b) } + | bl=block_label COLON b=block { loc $startpos $endpos @@ SBlock(Some bl,b) } + | variant=commute_variant phi=commute_condition + LBRACE PRE COLON pre=exp blocks=nonempty_list(block) POST COLON post=exp RBRACE + { loc $startpos $endpos @@ GCommute(variant,phi,pre,blocks,post) } + +block_label: + | i=IDENT { (i, None) } + | i=IDENT LPAREN il=separated_list(COMMA,exp) RPAREN { (i, Some il) } + +label: + | i=IDENT {i} %inline commute_variant: | COMMUTE_SEQ { CommuteVarSeq } diff --git a/src/vcy/vcylib.ml b/src/vcy/vcylib.ml index 60ee4eb..aaf188b 100644 --- a/src/vcy/vcylib.ml +++ b/src/vcy/vcylib.ml @@ -1,6 +1,7 @@ open Ast open Ast_print open Util +open Digest let sp = Printf.sprintf @@ -16,6 +17,7 @@ let suppress_print = ref false let counters : (int64 * Concurrent_counter.t) list ref = ref [] +let mutexes_mutex = Mutex.create () let mutexes : (int64 * Mutex.t) list ref = ref [] type method_library = lib_method bindlist @@ -27,6 +29,7 @@ let lib_string : method_library = | env, [VStr v] -> env, VInt (Int64.of_int @@ String.length v) | _ -> raise @@ TypeFailure ("length_of_string arguments", Range.norange) end + ; ret_ty = TInt ; pc = None } ; "string_of_int", @@ -35,6 +38,7 @@ let lib_string : method_library = | env, [VInt v] -> env, VStr (Int64.to_string v) | _ -> raise @@ TypeFailure ("string_of_int arguments", Range.norange) end + ; ret_ty = TStr ; pc = None } ; "string_of_bool", @@ -44,6 +48,7 @@ let lib_string : method_library = env, if v then VStr "true" else VStr "false" | _ -> raise @@ TypeFailure ("string_of_bool arguments", Range.norange) end + ; ret_ty = TStr ; pc = None } ; "int_of_string", @@ -53,6 +58,31 @@ let lib_string : method_library = env, VInt (Int64.of_string s) | _ -> raise @@ TypeFailure ("int_of_string arguments", Range.norange) end + ; ret_ty = TInt + ; pc = None + } + ; "md5_lower", + { pure = true + ; func = begin function + | env, [VStr s] -> + env, VInt (s |> string |> to_hex |> + fun s -> let l = String.length s in + Int64.of_string ("0x" ^ String.sub s (l - 16) 16)) + | _ -> raise @@ TypeFailure ("md5_lower arguments", Range.norange) + end + ; ret_ty = TInt + ; pc = None + } + ; "md5_upper", + { pure = true + ; func = begin function + | env, [VStr s] -> + env, VInt (s |> string |> to_hex |> + fun s -> let l = String.length s in + Int64.of_string ("0x" ^ String.sub s 0 (min (l - 16) 16))) + | _ -> raise @@ TypeFailure ("md5_lower arguments", Range.norange) + end + ; ret_ty = TInt ; pc = None } ] @@ -69,6 +99,7 @@ let lib_counter : method_library = env, VVoid | _ -> raise @@ TypeFailure ("counter_init arguments", Range.norange) end + ; ret_ty = TVoid ; pc = None } ; "counter_incr", @@ -83,6 +114,7 @@ let lib_counter : method_library = end | _ -> raise @@ TypeFailure ("counter_incr arguments", Range.norange) end + ; ret_ty = TVoid ; pc = None } ; "counter_decr", @@ -97,6 +129,7 @@ let lib_counter : method_library = end | _ -> raise @@ TypeFailure ("counter_decr arguments", Range.norange) end + ; ret_ty = TVoid ; pc = None } ; "counter_read", @@ -110,6 +143,7 @@ let lib_counter : method_library = end | _ -> raise @@ TypeFailure ("counter_read arguments", Range.norange) end + ; ret_ty = TInt ; pc = None } ] @@ -129,6 +163,7 @@ let lib_array : method_library = in env, VStr s | _ -> raise @@ TypeFailure ("string_of_array arguments", Range.norange) end + ; ret_ty = TStr ; pc = None } ; "array_of_string", @@ -139,6 +174,7 @@ let lib_array : method_library = env, VArr (TInt, Array.init (String.length s) f) | _ -> raise @@ TypeFailure ("array_of_string arguments", Range.norange) end + ; ret_ty = TArr TInt ; pc = None } ; "length_of_array", @@ -148,6 +184,7 @@ let lib_array : method_library = env, VInt (Array.length a |> Int64.of_int) | _ -> raise @@ TypeFailure ("length_of_array arguments", Range.norange) end + ; ret_ty = TInt ; pc = None } ] @@ -161,6 +198,7 @@ let lib_debug : method_library = env, VVoid | _ -> raise @@ TypeFailure ("debug_display arguments", Range.norange) end + ; ret_ty = TVoid ; pc = None } ; "debug_value", @@ -171,6 +209,7 @@ let lib_debug : method_library = env, VVoid | _ -> raise @@ TypeFailure ("debug_value arguments", Range.norange) end + ; ret_ty = TVoid ; pc = None } ; "busy_wait", @@ -184,6 +223,7 @@ let lib_debug : method_library = env, VVoid | _ -> raise @@ TypeFailure ("busy_wait arguments", Range.norange) end + ; ret_ty = TVoid ; pc = None } ; "random", @@ -196,6 +236,7 @@ let lib_debug : method_library = env, VInt d | _ -> raise @@ TypeFailure ("random arguments", Range.norange) end + ; ret_ty = TInt ; pc = None } ] @@ -223,8 +264,9 @@ let lib_hashtable : method_library = env, VInt (Int64.of_int size) | _ -> raise @@ TypeFailure ("hashtable_size arguments", Range.norange) end + ; ret_ty = TInt ; pc = Some (fun [@warning "-8"] - (mangle, ETHashTable (tyk, _, {ht;keys;size}), []) -> + (mangle, _, ETHashTable (tyk, _, {ht;keys;size}), []) -> let ht0, ht1 = mangle_servois_id_pair ht mangle in let keys0, keys1 = mangle_servois_id_pair keys mangle in let size0, size1 = mangle_servois_id_pair size mangle in @@ -237,6 +279,7 @@ let lib_hashtable : method_library = ; asserts = [] ; terms = [] ; preds = [] + ; updates_rw = false } ) } @@ -256,8 +299,9 @@ let lib_hashtable : method_library = env, VBool mem | _ -> raise @@ TypeFailure ("hashtable_size arguments", Range.norange) end + ; ret_ty = TBool ; pc = Some (fun [@warning "-8"] - (mangle, ETHashTable (tyk, _, {ht;keys;size}), [k]) -> + (mangle, _, ETHashTable (tyk, _, {ht;keys;size}), [k]) -> let ht0, ht1 = mangle_servois_id_pair ht mangle in let keys0, keys1 = mangle_servois_id_pair keys mangle in let size0, size1 = mangle_servois_id_pair size mangle in @@ -279,6 +323,7 @@ let lib_hashtable : method_library = ; terms = [] ; preds = [ member_func (), [tyk; Smt.TSet tyk] ] + ; updates_rw = false } ) } @@ -301,8 +346,9 @@ let lib_hashtable : method_library = env, VBool res | _ -> raise @@ TypeFailure ("hashtable put arguments", Range.norange) end + ; ret_ty = TBool ; pc = Some (fun [@warning "-8"] - (mangle, ETHashTable (tyk, tyv, {ht;keys;size}), [k;v]) -> + (mangle, _, ETHashTable (tyk, tyv, {ht;keys;size}), [k;v]) -> let ht0, ht1 = mangle_servois_id_pair ht mangle in let keys0, keys1 = mangle_servois_id_pair keys mangle in let size0, size1 = mangle_servois_id_pair size mangle in @@ -352,6 +398,7 @@ let lib_hashtable : method_library = ] ; preds = [ member_func (), [tyk; Smt.TSet tyk] ] + ; updates_rw = false } ) } @@ -370,10 +417,11 @@ let lib_hashtable : method_library = | None -> env, VNull tyv | Some d -> env, value_of_htdata d end - | _ -> raise @@ TypeFailure ("hashtable put arguments", Range.norange) + | _ -> raise @@ TypeFailure ("hashtable get arguments", Range.norange) end + ; ret_ty = TVoid (* TODO: revise *) ; pc = Some (fun [@warning "-8"] - (mangle, ETHashTable (tyk, tyv, {ht;keys;size}), [k]) -> + (mangle, _, ETHashTable (tyk, tyv, {ht;keys;size}), [k]) -> let ht0, ht1 = mangle_servois_id_pair ht mangle in let keys0, keys1 = mangle_servois_id_pair keys mangle in let size0, size1 = mangle_servois_id_pair size mangle in @@ -400,11 +448,37 @@ let lib_hashtable : method_library = pure_id ht, Smt.TArray (tyk,tyv) ] ; preds = [] + ; updates_rw = false } ) } ] +let array_update ar k f = let open Smt in EFunc("store", [ar; k; f(EFunc("select", [ar; k]))]) +(* Read only / write only channels are enforced at type level so we can have the same underlying spec for them. *) +let open_spec = Some (fun [@warning "-8"] + (mangle, rw_mangle, ETStr fname, []) -> + let f0, f1 = mangle_servois_id_pair fname mangle in + let rw_d0, rw_d1 = mangle_servois_id_pair "realWorld_data" rw_mangle in + let rw_ln0, rw_ln1 = mangle_servois_id_pair "realWorld_linenum" rw_mangle in + let rw_o0, rw_o1 = mangle_servois_id_pair "realWorld_opened" rw_mangle in + { bindings = + [ var_of_string @@ smt_e f1, + f0 + ; var_of_string @@ smt_e rw_d1, + rw_d0 + ; var_of_string @@ smt_e rw_ln1, + array_update rw_ln0 f0 (fun _ -> EConst (CInt 0)) + ; var_of_string @@ smt_e rw_o1, + EFunc ("insert", [f0; rw_o0]) + ] + ; ret_exp = f1 + ; asserts = [EUop(Not, EFunc("member", [f0; rw_o0]))] (* TODO: see below note *) + ; terms = [pure_id fname, Smt.TString] + ; preds = [] + ; updates_rw = true + }) + let lib_io : method_library = [ "print", { pure = false @@ -417,6 +491,7 @@ let lib_io : method_library = env, VVoid | _ -> raise @@ TypeFailure ("print arguments", Range.norange) end + ; ret_ty = TVoid ; pc = None } ; "read_stdin", @@ -426,6 +501,7 @@ let lib_io : method_library = env, VStr (read_line ()) | _ -> raise @@ TypeFailure ("read_stdin arguments", Range.norange) end + ; ret_ty = TStr ; pc = None } ; "open_read", @@ -436,7 +512,8 @@ let lib_io : method_library = env, VChanR (s, chan, in_channel_length chan) | _ -> raise @@ TypeFailure ("open_read arguments", Range.norange) end - ; pc = None + ; ret_ty = TChanR + ; pc = open_spec } ; "open_write", { pure = false @@ -445,7 +522,8 @@ let lib_io : method_library = env, VChanW (s, open_out s) | _ -> raise @@ TypeFailure ("open_write arguments", Range.norange) end - ; pc = None + ; ret_ty = TChanW + ; pc = open_spec } ; "close", { pure = false @@ -458,7 +536,29 @@ let lib_io : method_library = env, VVoid | _ -> raise @@ TypeFailure ("close arguments", Range.norange) end - ; pc = None + ; ret_ty = TVoid + ; pc = Some (fun [@warning "-8"] + (mangle, rw_mangle, ETChannel chan, []) -> + let c0, c1 = mangle_servois_id_pair chan mangle in + let rw_d0, rw_d1 = mangle_servois_id_pair "realWorld_data" rw_mangle in + let rw_ln0, rw_ln1 = mangle_servois_id_pair "realWorld_linenum" rw_mangle in + let rw_o0, rw_o1 = mangle_servois_id_pair "realWorld_opened" rw_mangle in + { bindings = + [ var_of_string @@ smt_e c1, + c0 + ; var_of_string @@ smt_e rw_d1, + rw_d0 + ; var_of_string @@ smt_e rw_ln1, + rw_ln0 + ; var_of_string @@ smt_e rw_o1, + EFunc ("setminus", [rw_o0; EFunc("singleton", [c0])]) + ] + ; ret_exp = EConst (CBool true) + ; asserts = [EFunc("member", [c0; rw_o0])] (* TODO: Probs a better way to encode this than an assert? A precondition possibly? *) + ; terms = [pure_id chan, Smt.TString] + ; preds = [] + ; updates_rw = true + }) } ; "read_line", { pure = false @@ -467,7 +567,29 @@ let lib_io : method_library = env, VStr (input_line chan) | _ -> raise @@ TypeFailure ("read_line arguments", Range.norange) end - ; pc = None + ; ret_ty = TStr + ; pc = Some (fun [@warning "-8"] + (mangle, rw_mangle, ETChannel chan, []) -> + let c0, c1 = mangle_servois_id_pair chan mangle in + let rw_d0, rw_d1 = mangle_servois_id_pair "realWorld_data" rw_mangle in + let rw_ln0, rw_ln1 = mangle_servois_id_pair "realWorld_linenum" rw_mangle in + let rw_o0, rw_o1 = mangle_servois_id_pair "realWorld_opened" rw_mangle in + { bindings = + [ var_of_string @@ smt_e c1, + c0 + ; var_of_string @@ smt_e rw_d1, + rw_d0 + ; var_of_string @@ smt_e rw_ln1, + EFunc("store", [rw_ln0; c0; ELop(Add, [EFunc("select", [rw_ln0; c0]); EConst (CInt 1)])]) + ; var_of_string @@ smt_e rw_o1, + rw_o0 + ] + ; ret_exp = EFunc("select", [EFunc("select", [rw_d0; c0]); EFunc("select", [rw_ln0; c0])]) + ; asserts = [EFunc("member", [c0; rw_o0])] (* TODO see above note *) + ; terms = [] + ; preds = [] + ; updates_rw = true + }) } ; "has_line", { pure = false @@ -476,7 +598,25 @@ let lib_io : method_library = env, VBool (pos_in chan < len) | _ -> raise @@ TypeFailure ("has_line arguments", Range.norange) end - ; pc = None + ; ret_ty = TBool + ; pc = Some (fun [@warning "-8"] + (mangle, rw_mangle, ETChannel chan, []) -> + let c0, c1 = mangle_servois_id_pair chan mangle in + let rw_d0, _ = mangle_servois_id_pair "realWorld_data" rw_mangle in + let rw_ln0, _ = mangle_servois_id_pair "realWorld_linenum" rw_mangle in + { bindings = + [ var_of_string @@ smt_e c1, + c0 + ] + ; ret_exp = EUop(Not, EForall([Smt.Var "realWorld_line", TInt], + EITE(EBop(Gte, EVar (Var "realWorld_line"), EFunc("select", [rw_ln0; c0])), + EBop(Eq, EFunc("select", [EFunc("select", [rw_d0; c0]); EVar (Var "realWorld_line")]), EConst (CString "")), + EConst (CBool true)))) + ; asserts = [] + ; terms = [pure_id chan, Smt.TString] + ; preds = [] + ; updates_rw = false (* We do use the vars but we don't update their bindings. *) + }) } ; "write", { pure = false @@ -487,37 +627,137 @@ let lib_io : method_library = env, VVoid | _ -> raise @@ TypeFailure ("write arguments", Range.norange) end - ; pc = None + ; ret_ty = TVoid + ; pc = Some (fun [@warning "-8"] + (mangle, rw_mangle, ETChannel chan, [line]) -> + let c0, c1 = mangle_servois_id_pair chan mangle in + let rw_d0, rw_d1 = mangle_servois_id_pair "realWorld_data" rw_mangle in + let rw_ln0, rw_ln1 = mangle_servois_id_pair "realWorld_linenum" rw_mangle in + let rw_o0, rw_o1 = mangle_servois_id_pair "realWorld_opened" rw_mangle in + { bindings = + [ var_of_string @@ smt_e c1, + c0 + ; var_of_string @@ smt_e rw_d1, + array_update rw_d0 c0 (fun f -> array_update f (EFunc("select", [rw_ln0; c0])) (fun _ -> line)) + ; var_of_string @@ smt_e rw_ln1, + array_update rw_ln0 c0 (fun v -> ELop(Add, [v; EConst (CInt 1)])) + ; var_of_string @@ smt_e rw_o1, + rw_o0 + ] + ; ret_exp = EConst (CBool true) + ; asserts = [EFunc("member", [c0; rw_o0])] (* TODO: see above note *) + ; terms = [pure_id @@ smt_e line, Smt.TString] + ; preds = [] + ; updates_rw = true + }) + } + ; "lseek", + { pure = false + ; func = begin function + | env, [VChanR (_,chan,_); VInt lnum] -> + (* There's not a real better way to seek based on lines other than just reading that many lines. *) + seek_in chan 0; + repeat (fun () -> const () (input_line chan); ()) (Int64.to_int lnum); + env, VVoid + | _ -> raise @@ TypeFailure ("lseek arguments", Range.norange) + end + ; ret_ty = TVoid + ; pc = Some (fun [@warning "-8"] + (mangle, rw_mangle, ETChannel chan, [i]) -> + let c0, c1 = mangle_servois_id_pair chan mangle in + let rw_d0, rw_d1 = mangle_servois_id_pair "realWorld_data" rw_mangle in + let rw_ln0, rw_ln1 = mangle_servois_id_pair "realWorld_linenum" rw_mangle in + let rw_o0, rw_o1 = mangle_servois_id_pair "realWorld_opened" rw_mangle in + { bindings = + [ var_of_string @@ smt_e c1, + c0 + ; var_of_string @@ smt_e rw_d1, + rw_d0 + ; var_of_string @@ smt_e rw_ln1, + EFunc("store", [rw_ln0; c0; pure_id @@ smt_e i]) + ; var_of_string @@ smt_e rw_o1, + rw_o0 + ] + ; ret_exp = EConst (CBool true) + ; asserts = [EFunc("member", [c0; rw_o0])] (* TODO see above note *) + ; terms = [pure_id chan, Smt.TString; pure_id @@ smt_e i, Smt.TInt] + ; preds = [] + ; updates_rw = true + }) + } + ; "cp", + { pure = false + ; func = begin function + | env, [VStr from_fname; VStr to_fname] -> + (* Not the most elegant or robust solution, but should work on Unix machines *) + const () @@ Sys.command ("cp \"" ^ from_fname ^ "\" \"" ^ to_fname ^ "\""); + env, VVoid + | _ -> raise @@ TypeFailure ("cp arguments", Range.norange) + end + ; ret_ty = TVoid + ; pc = Some (fun [@warning "-8"] + (mangle, rw_mangle, ETStr from_fname, [to_fname]) -> + let f0, f1 = mangle_servois_id_pair from_fname mangle in + let rw_d0, rw_d1 = mangle_servois_id_pair "realWorld_data" rw_mangle in + let rw_ln0, rw_ln1 = mangle_servois_id_pair "realWorld_linenum" rw_mangle in + let rw_o0, rw_o1 = mangle_servois_id_pair "realWorld_opened" rw_mangle in + { bindings = + [ var_of_string @@ smt_e f1, + f0 + ; var_of_string @@ smt_e rw_d1, + array_update rw_d0 to_fname (const @@ Smt.EFunc("select", [rw_d0; f0])) + ; var_of_string @@ smt_e rw_ln1, + rw_ln0 + ; var_of_string @@ smt_e rw_o1, + rw_o0 + ] + ; ret_exp = EConst (CBool true) + ; asserts = [] + ; terms = [pure_id from_fname, Smt.TString; pure_id @@ smt_e to_fname, Smt.TString] + ; preds = [] + ; updates_rw = true + }) } ] - let lib_mutex : method_library = [ "mutex_init", { pure = false ; func = begin function | env, [VInt v] -> + Mutex.protect mutexes_mutex begin fun () -> if List.mem_assoc v !mutexes then raise @@ ValueFailure ("mutex " ^ Int64.to_string v ^ " already exists", Range.norange) else mutexes := (v, Mutex.create ()) :: !mutexes; - env, VVoid + env, VVoid end | _ -> raise @@ TypeFailure ("counter_init arguments", Range.norange) end + ; ret_ty = TVoid ; pc = None } ; "mutex_lock", { pure = false ; func = begin function | env, [VInt index] -> + Mutex.lock mutexes_mutex; begin match List.assoc_opt index !mutexes with - | None -> raise @@ ValueFailure ("unknown mutex " ^ Int64.to_string index, Range.norange) + | None -> + debug_print (lazy (Printf.sprintf "Warning: mutex %d not initialized. Auto-intializing.\n" (Int64.to_int index))); + let m = Mutex.create () in + mutexes := (index, m) :: !mutexes; + Mutex.unlock mutexes_mutex; + Mutex.lock m; + env, VVoid + (* TODO previously: raise @@ ValueFailure ("unknown mutex " ^ Int64.to_string index, Range.norange) *) | Some m -> + Mutex.unlock mutexes_mutex; Mutex.lock m; env, VVoid end | _ -> raise @@ TypeFailure ("mutex_lock arguments", Range.norange) end + ; ret_ty = TVoid ; pc = None } ; "mutex_unlock", @@ -532,6 +772,7 @@ let lib_mutex : method_library = end | _ -> raise @@ TypeFailure ("mutex_unlock arguments", Range.norange) end + ; ret_ty = TVoid ; pc = None } ] diff --git a/temp_io_notes.txt b/temp_io_notes.txt new file mode 100644 index 0000000..02432d5 --- /dev/null +++ b/temp_io_notes.txt @@ -0,0 +1,29 @@ +- Model IO as + - realWorld_data Int (handle) -> (Int (line num) -> String (values)) + - realWorld_linenum Int (handle) -> Int (current line num) + - realWorld_mapping String (filename) -> Int (handle) +- Have a static counter that increments every open channel call so we always get a new handle + - realWorld_handles + +precondition: +realWorld_handles > 0 + +open_read / open_write(filename) +(and (= realWorld_handles_post (+ 1 realWorld_handles_pre)) + (= 0 (select realWorld_handles_pre realWorld_linenum_post)) + (= realWorld_mapping_post (store filename realWorld_handles_pre realWorld_mapping_pre))) + +write_line(chan, s) +postcond: +(and (= realWorld_data_post (store chan (store (select chan realWorld_linenum_pre) s (select chan realWorld_data_pre)) realWorld_data_pre)) + (= realWorld_linenum_post (store chan (select chan realWorld_linenum_pre) realWorld_linenum_pre))) + + + +for state_equal: + have a set of open handles associated with filenames + precondition that file name has not been opened +assume filenames are given as integers not as strings (use ocaml to turn strings into unique integers -- keep a translation table) + +int FN_ROOT_FOO = 1; +filename ROOT_FOO = 1;