├── .gitignore ├── BUILD ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── cppsrc ├── Makefile ├── in.file ├── snarky.cpp ├── test.infile └── wit.file ├── experiments ├── benchmark-data-112415-input.dat ├── benchmark-data-112415-input.png ├── benchmark-data-112415-keccak.dat ├── benchmark-data-112415-keccak.png ├── benchmark-data-112415.dat ├── benchmark-data-112415.ods ├── benchmark-data-112415.png ├── benchmark-data-112415.txt ├── benchmark-data-112915.txt ├── benchmark-data-113015.txt ├── benchmark-data.dat ├── benchmark-data.ods ├── benchmark-data.png ├── benchmark-input.plot ├── benchmark.plot ├── ratio.dat ├── ratio.plot └── ratio.png ├── prepare-depends.sh ├── scripts ├── run-keygen.sh ├── run-proofgen.sh └── run-r1cs.sh ├── snarkl.cabal └── src ├── Common.hs ├── Compile.hs ├── Constraints.hs ├── Dataflow.hs ├── Errors.hs ├── Expr.hs ├── Field.hs ├── Games.hs ├── Interp.hs ├── Makefile ├── Poly.hs ├── R1CS.hs ├── Serialize.hs ├── SimplMonad.hs ├── Simplify.hs ├── Solve.hs ├── Syntax.hs ├── SyntaxMonad.hs ├── TExpr.hs ├── Toplevel.hs ├── UnionFind.hs ├── examples ├── Basic.hs ├── Keccak.hs ├── Lam.hs ├── List.hs ├── Matrix.hs ├── Peano.hs ├── Queue.hs ├── Stack.hs └── Tree.hs ├── testsuite ├── benchmarks │ ├── Harness.hs │ └── Main.hs └── tests │ ├── Main.hs │ └── UnitTests.hs └── todo.txt /.gitignore: -------------------------------------------------------------------------------- 1 | \#* 2 | *~ 3 | *.o 4 | *.hi 5 | src/main.exe -------------------------------------------------------------------------------- /BUILD: -------------------------------------------------------------------------------- 1 | ./prepare-depends.sh /* downloads and locally installs the 'libsnark' library */ 2 | make /* 'cabal install' snarkl in a cabal sandbox */ 3 | make test /* run testsuite */ 4 | make bench /* run some preliminary benchmarks */ -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Gordon Stewart 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Gordon Stewart nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | toplevel: 2 | cabal sandbox init; \ 3 | cabal install 4 | 5 | snarky: 6 | cd cppsrc; \ 7 | make 8 | 9 | test: toplevel snarky 10 | cabal test 11 | 12 | bench: toplevel snarky 13 | cabal bench 2> /dev/null 14 | 15 | clean: 16 | cd cppsrc; \ 17 | make clean; \ 18 | cd ..; \ 19 | cabal clean 20 | 21 | clean-all: clean 22 | rm -rf depsrc; \ 23 | rm -rf depinst; \ 24 | cabal sandbox delete 25 | 26 | .PHONY: toplevel snarky test bench clean clean-all 27 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cppsrc/Makefile: -------------------------------------------------------------------------------- 1 | #******************************************************************************** 2 | # Makefile adapted from the accountable algorithms system. 3 | #******************************************************************************** 4 | #* @author Joshua A. Kroll 5 | #* and contributors. 6 | #*******************************************************************************/ 7 | 8 | CXXFLAGS += -O3 -Wall -Wextra -Wno-unused-parameter -Wno-comment -march=native -mtune=native -std=c++11 -DDEBUG 9 | 10 | DEPSRC=../depsrc 11 | 12 | LDFLAGS += -L $(DEPSRC)/libsnark/src -Wl,-rpath $(DEPSRC)/libsnark/src 13 | LDLIBS += -lgmpxx -lgmp -lsnark -lzm 14 | CXXFLAGS += -I $(DEPSRC)/libsnark/src -DUSE_ASM -DCURVE_BN128 -DBN_SUPPORT_SNARK -g 15 | 16 | SRCS= \ 17 | snarky.cpp 18 | 19 | EXECUTABLES= \ 20 | snarky 21 | 22 | OBJS=$(patsubst %.cpp,%.o,$(SRCS)) 23 | 24 | all: bindir $(EXECUTABLES) 25 | 26 | bindir: 27 | mkdir -p bin 28 | 29 | # In order to detect changes to #include dependencies. -MMD below generates a .d file for .cpp file. Include the .d file. 30 | -include $(SRCS:.cpp=.d) 31 | 32 | $(OBJS): %.o: %.cpp 33 | $(CXX) -o $@ $< -c -MMD $(CXXFLAGS) 34 | 35 | $(EXECUTABLES): %: %.o $(OBJS) 36 | $(CXX) -o bin/$@ $^ $(CXXFLAGS) $(LDFLAGS) $(LDLIBS) 37 | 38 | # Clean generated files, except locally-compiled dependencies 39 | clean: 40 | $(RM) \ 41 | $(OBJS) \ 42 | $(EXECUTABLES) \ 43 | ${patsubst %,%.o,${EXECUTABLES}} \ 44 | ${patsubst %.cpp,%.d,${SRCS}} \ 45 | ${patsubst %,%.d,${EXECUTABLES}} 46 | rm -rf bin 47 | 48 | # Clean all, including locally-compiled dependencies 49 | clean-all: clean 50 | rm -fr $(DEPSRC) 51 | 52 | test: bin/snarky 53 | if [ -e vk.file ]; then rm vk.file; fi 54 | if [ -e pk.file ]; then rm pk.file; fi 55 | if [ -e proof.file ]; then rm proof.file; fi 56 | touch vk.file pk.file proof.file 57 | bin/snarky --generateKeys --csFile test.infile --verificationKeyFile vk.file --provingKeyFile pk.file 58 | bin/snarky --prove --provingKeyFile pk.file --inputFile in.file --witnessFile wit.file --proofFile proof.file 59 | bin/snarky --verify --verificationKeyFile vk.file --inputFile in.file --proofFile proof.file 60 | 61 | .PHONY: all clean clean-all 62 | -------------------------------------------------------------------------------- /cppsrc/in.file: -------------------------------------------------------------------------------- 1 | 2 2 | 2 -------------------------------------------------------------------------------- /cppsrc/snarky.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #include 6 | #include 7 | 8 | #include 9 | #include 10 | #include 11 | #include 12 | 13 | using namespace std; 14 | using namespace libsnark; 15 | 16 | // These extra reading functions are necessary because we want to 17 | // express constraints from an external constraint generator mod p and 18 | // libsnark wants to print numbers in Montgomery space mod p when it's 19 | // not in debug mode. Running in debug mode presents alternative 20 | // headaches. 21 | 22 | void read_lc_decimal(istream& constraintStream, linear_combination > *lc) 23 | { 24 | size_t num_terms; 25 | 26 | /* [NOTE: Linear Combination Serialization] 27 | The serialization of a linear combination is: 28 | //number of terms in the polynomial 29 | //a variable index (0 is reserved for the constant term) 30 | 31 | */ 32 | lc->terms.clear(); 33 | constraintStream >> num_terms; 34 | // cout << "num. terms: " << num_terms << "\n"; 35 | consume_newline(constraintStream); 36 | 37 | lc->terms.reserve(num_terms); 38 | for (size_t i = 0; i < num_terms; ++i) { 39 | linear_term > lt; 40 | constraintStream >> lt.index; // size_t 41 | // cout << "var. index: " << lt.index << "\n"; 42 | consume_newline(constraintStream); 43 | // lt.coeff is a Fr, which I _believe_ is a 44 | // bn128_Fr, which is definitely an Fp_model 45 | constraintStream >> lt.coeff.mont_repr; 46 | // cout << "coeff. before reduction: " << lt.coeff.mont_repr << "\n"; 47 | // Reduce to Montgomery Space, as per method in algebra/fields/fp.tcc 48 | lt.coeff.mul_reduce(Fr::Rsquared); 49 | // cout << "coeff. after reduction: " << lt.coeff.mont_repr << "\n"; 50 | consume_OUTPUT_NEWLINE(constraintStream); 51 | lc->terms.emplace_back(lt); 52 | } 53 | } 54 | 55 | void read_cs_decimal(istream& constraintStream, r1cs_constraint_system > &cs) 56 | { 57 | size_t primary_input_size; 58 | size_t auxiliary_input_size; 59 | 60 | /* [NOTE: R1CS Serialization] 61 | The serialization format for the R1CS header is: 62 | //num. input variables 63 | //num. add'l witness variables 64 | 65 | for each constraint in [0..-1]: 66 | 67 | 68 | 69 | */ 70 | constraintStream >> primary_input_size; 71 | // cout << "primary input size: " << primary_input_size << "\n"; 72 | cs.primary_input_size = primary_input_size; 73 | constraintStream >> auxiliary_input_size; 74 | // cout << "auxiliary input size: " << auxiliary_input_size << "\n"; 75 | cs.auxiliary_input_size = auxiliary_input_size; 76 | 77 | cs.constraints.clear(); 78 | size_t num_constraints; 79 | constraintStream >> num_constraints; 80 | // cout << "num. constraints: " << num_constraints << "\n"; 81 | consume_newline(constraintStream); 82 | 83 | cs.constraints.reserve(num_constraints); 84 | for (size_t i = 0; i < num_constraints; ++i) { 85 | linear_combination > A, B, C; 86 | // cout << "A:\n"; 87 | read_lc_decimal(constraintStream, &A); 88 | // cout << "B:\n"; 89 | read_lc_decimal(constraintStream, &B); 90 | // cout << "C:\n"; 91 | read_lc_decimal(constraintStream, &C); 92 | cs.add_constraint(r1cs_constraint >(A, B, C)); 93 | } 94 | } 95 | 96 | void generateKeys(istream& constraintStream, ostream& pkStream, ostream& vkStream) 97 | { 98 | r1cs_constraint_system > cs; 99 | read_cs_decimal(constraintStream, cs); 100 | // cout << "reserialization of constraint system:\n"; 101 | // cout << cs; 102 | r1cs_ppzksnark_keypair keypair = r1cs_ppzksnark_generator(cs); 103 | // Generator writes out keys 104 | pkStream << keypair.pk; 105 | vkStream << keypair.vk; 106 | } 107 | 108 | void readVariableAssignment(istream& stream, r1cs_variable_assignment >& assgn) 109 | { 110 | /* [NOTE: Variable Assignments Serialization] 111 | 112 | 113 | ... 114 | EOF 115 | */ 116 | for (string line; getline(stream, line);) 117 | { 118 | linear_term > lt; 119 | stringstream(line) >> lt.coeff.mont_repr; 120 | // cout << "coeff. before reduction: " << lt.coeff.mont_repr << "\n"; 121 | 122 | // Reduce to Montgomery Space, as per method in algebra/fields/fp.tcc 123 | lt.coeff.mul_reduce(Fr::Rsquared); 124 | 125 | // cout << "pushing " << lt.coeff.mont_repr << "\n"; 126 | assgn.push_back(lt.coeff); 127 | } 128 | } 129 | 130 | void generateProof(istream& pkStream, istream& inpStream, istream& witStream, ostream& pfStream) 131 | { 132 | //deserialize proving key 133 | r1cs_ppzksnark_proving_key pk; 134 | pkStream >> pk; 135 | 136 | //deserialize input 137 | r1cs_variable_assignment > input; 138 | readVariableAssignment(inpStream, input); 139 | // cout << "input is:\n" << input; 140 | 141 | //deserialize witness 142 | r1cs_variable_assignment > witness; 143 | readVariableAssignment(witStream, witness); 144 | // cout << "witness is:\n" << witness; 145 | 146 | //generate proof 147 | r1cs_ppzksnark_proof proof 148 | = r1cs_ppzksnark_prover(pk, input, witness); 149 | pfStream << proof; 150 | } 151 | 152 | bool verifyProof(istream& pfStream, istream& vkStream, istream& inpStream) 153 | { 154 | //deserialize proof 155 | r1cs_ppzksnark_proof proof; 156 | pfStream >> proof; 157 | 158 | //deserialize verification key 159 | r1cs_ppzksnark_verification_key vk; 160 | vkStream >> vk; 161 | 162 | //deserialize input strema 163 | r1cs_variable_assignment > input; 164 | readVariableAssignment(inpStream, input); 165 | // cout << "input is:\n" << input; 166 | return r1cs_ppzksnark_verifier_strong_IC(vk, input, proof); 167 | } 168 | 169 | void printFileError() 170 | { 171 | cout << "The wrong combination of files was specified for the requested functionality.\n"; 172 | } 173 | 174 | void maybeCloseStream(fstream & fs) 175 | { 176 | if (fs.is_open()) { 177 | fs.close(); 178 | } 179 | } 180 | 181 | int main(int argc, char* const* argv) 182 | { 183 | // declare option stuff 184 | static int generatorFlag, proverFlag, verifierFlag, reserializeFlag; 185 | static fstream csFileStream, provingKeyFileStream, verificationKeyFileStream, proofFileStream, witnessFileStream, inputFileStream; 186 | 187 | static struct option long_options[] = { 188 | {"generateKeys", no_argument, &generatorFlag, true}, 189 | {"prove", no_argument, &proverFlag, true}, 190 | {"verify", no_argument, &verifierFlag, true}, 191 | {"reserialize", no_argument, &reserializeFlag, true}, 192 | {"csFile", required_argument, 0, 'c'}, 193 | {"proofFile", required_argument, 0, 'q'}, 194 | {"provingKeyFile", required_argument, 0, 'f'}, 195 | {"verificationKeyFile", required_argument, 0, 'k'}, 196 | {"witnessFile", required_argument, 0, 'w'}, 197 | {"inputFile", required_argument, 0, 'i'}, 198 | {0,0,0,0} 199 | }; 200 | 201 | //Initialize things like field modulus (IMPORTANT!) 202 | default_ec_pp::init_public_params(); 203 | 204 | // Parse options and set up files. 205 | int option_char; 206 | int option_index; 207 | while (1) 208 | { 209 | option_char = getopt_long(argc, argv, "gpvrq:f:k:w:i:", long_options, &option_index); 210 | if (option_char == -1) { 211 | break; 212 | } 213 | switch (option_char) { 214 | case 0: 215 | // Do nothing if we've set a flag already 216 | if (long_options[option_index].flag != 0) 217 | break; 218 | case 'c': 219 | csFileStream.open(optarg, fstream::in|fstream::out); 220 | case 'q': 221 | proofFileStream.open(optarg, fstream::in|fstream::out); 222 | break; 223 | case 'f': 224 | provingKeyFileStream.open(optarg, fstream::in|fstream::out); 225 | break; 226 | case 'k': 227 | verificationKeyFileStream.open(optarg, fstream::in|fstream::out); 228 | break; 229 | case 'w': 230 | witnessFileStream.open(optarg, fstream::in|fstream::out); 231 | break; 232 | case 'i': 233 | inputFileStream.open(optarg, fstream::in|fstream::out); 234 | break; 235 | case '?': 236 | // unknown option or missing required option 237 | // getopt_long prints a basic usage message 238 | break; 239 | } 240 | } 241 | if (reserializeFlag) { 242 | // TODO 243 | } 244 | if (generatorFlag) { 245 | if (csFileStream.is_open() && provingKeyFileStream.is_open() && verificationKeyFileStream.is_open()) { 246 | generateKeys(csFileStream, provingKeyFileStream, verificationKeyFileStream); 247 | } else { 248 | printFileError(); 249 | } 250 | } else if (proverFlag) { 251 | if (provingKeyFileStream.is_open() && inputFileStream.is_open() && witnessFileStream.is_open() && proofFileStream.is_open()) { 252 | generateProof(provingKeyFileStream, inputFileStream, witnessFileStream, proofFileStream); 253 | } else { 254 | printFileError(); 255 | } 256 | } else if (verifierFlag) { 257 | if (proofFileStream.is_open() && verificationKeyFileStream.is_open() && inputFileStream.is_open()) { 258 | bool ans = verifyProof(proofFileStream, verificationKeyFileStream, inputFileStream); 259 | if (ans) { 260 | cout << "Verification Succeeded!\n"; 261 | } else { 262 | cout << "Verification Failed!\n"; 263 | } 264 | } else { 265 | printFileError(); 266 | } 267 | } 268 | 269 | // Release resources 270 | maybeCloseStream(csFileStream); 271 | maybeCloseStream(provingKeyFileStream); 272 | maybeCloseStream(verificationKeyFileStream); 273 | maybeCloseStream(proofFileStream); 274 | maybeCloseStream(witnessFileStream); 275 | maybeCloseStream(inputFileStream); 276 | } 277 | -------------------------------------------------------------------------------- /cppsrc/test.infile: -------------------------------------------------------------------------------- 1 | 2 2 | 2 3 | 2 4 | 1 5 | 0 6 | 1 7 | 3 8 | 0 9 | 0 10 | 1 11 | 2 12 | 4 13 | 21888242871839275222246405745257275088548364400416034343698204186575808495616 14 | 1 15 | 0 16 | 0 17 | 1 18 | 4 19 | 1 20 | 1 21 | 2 22 | 1 23 | 1 24 | 3 25 | 1 -------------------------------------------------------------------------------- /cppsrc/wit.file: -------------------------------------------------------------------------------- 1 | 8 2 | 4 -------------------------------------------------------------------------------- /experiments/benchmark-data-112415-input.dat: -------------------------------------------------------------------------------- 1 | Phase Interp Elaborate Constraints Simplify R1CS Witness AllButCrypto Crypto 2 | Simp - 0.5167 2.625 5.935 2.913 6.68 9.33 71.89 3 | NoSimp - 0.5167 2.625 - 2.747 7.241 8.21 73.17 4 | Interp 0.8191 -------------------------------------------------------------------------------- /experiments/benchmark-data-112415-input.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gstew5/snarkl/d6ce72b13e370d2965bb226f28a1135269e7c198/experiments/benchmark-data-112415-input.png -------------------------------------------------------------------------------- /experiments/benchmark-data-112415-keccak.dat: -------------------------------------------------------------------------------- 1 | Phase Interp Elaborate Constraints Simplify R1CS Witness AllButCrypto Crypto 2 | Simp - 0.8149 1.4761 3.238 0.126 1.928 2.262 6.155 3 | NoSimp - 0.8149 1.4761 - 1.028 5.132 6.699 51.19 4 | Interp 0.9719 -------------------------------------------------------------------------------- /experiments/benchmark-data-112415-keccak.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gstew5/snarkl/d6ce72b13e370d2965bb226f28a1135269e7c198/experiments/benchmark-data-112415-keccak.png -------------------------------------------------------------------------------- /experiments/benchmark-data-112415.dat: -------------------------------------------------------------------------------- 1 | Phase Elaborate Constraints Simplify R1CS Witness Crypto 2 | FixedMatrix-Compile 0.2489 2.631 8.93 2.2 - - 3 | FixedMatrix-Witgen - - - - 1.1 - 4 | FixedMatrix-Crypto - - - - - 1.15 5 | InputMatrices-Compile 0.5167 2.625 5.935 2.913 - - 6 | InputMatrices-Witgen - - - - 6.68 - 7 | InputMatrices-Crypto - - - - - 71.89 8 | Keccak-Compile 0.8149 1.4761 3.238 0.126 - - 9 | Keccak-Witgen - - - - 1.928 - 10 | Keccak-Crypto - - - - - 6.155 11 | List-Compile 0.01208 0.10842 0.3802 0.0387 - - 12 | List-Witgen - - - - 2.3136 - 13 | List-Crypto - - - - - 2.476 14 | -------------------------------------------------------------------------------- /experiments/benchmark-data-112415.ods: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gstew5/snarkl/d6ce72b13e370d2965bb226f28a1135269e7c198/experiments/benchmark-data-112415.ods -------------------------------------------------------------------------------- /experiments/benchmark-data-112415.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gstew5/snarkl/d6ce72b13e370d2965bb226f28a1135269e7c198/experiments/benchmark-data-112415.png -------------------------------------------------------------------------------- /experiments/benchmark-data-113015.txt: -------------------------------------------------------------------------------- 1 | Script started on Mon 30 Nov 2015 12:03:37 PM EST 2 | ]0;gstewart@gstewart-office: ~/Repos/snarklgstewart@gstewart-office:~/Repos/snarkl$ make bench 3 | cabal sandbox init; \ 4 | cabal install 5 | Writing a default package environment file to 6 | /home/gstewart/Repos/snarkl/cabal.sandbox.config 7 | Using an existing sandbox located at 8 | /home/gstewart/Repos/snarkl/.cabal-sandbox 9 | Warning: The package list for 'hackage.haskell.org' is 75.2 days old. 10 | Run 'cabal update' to get the latest list of available packages. 11 | Resolving dependencies... 12 | In order, the following will be installed: 13 | snarkl-0.1.0.0 (reinstall) 14 | Warning: Note that reinstalls are always dangerous. Continuing anyway... 15 | Notice: installing into a sandbox located at 16 | /home/gstewart/Repos/snarkl/.cabal-sandbox 17 | Configuring snarkl-0.1.0.0... 18 | Building snarkl-0.1.0.0... 19 | Installed snarkl-0.1.0.0 20 | cd cppsrc; \ 21 | make 22 | make[1]: Entering directory '/home/gstewart/Repos/snarkl/cppsrc' 23 | mkdir -p bin 24 | g++ -o bin/snarky snarky.o -O3 -Wall -Wextra -Wno-unused-parameter -Wno-comment -march=native -mtune=native -std=c++11 -DDEBUG -I ../depsrc/libsnark/src -DUSE_ASM -DCURVE_BN128 -DBN_SUPPORT_SNARK -g -L ../depsrc/libsnark/src -Wl,-rpath ../depsrc/libsnark/src -lgmpxx -lgmp -lsnark -lzm 25 | make[1]: Leaving directory '/home/gstewart/Repos/snarkl/cppsrc' 26 | cabal bench 2> /dev/null 27 | The sandbox was created after the package was already configured. 28 | Re-configuring with most recently used options. If this fails, please run 29 | configure manually. 30 | Resolving dependencies... 31 | Configuring snarkl-0.1.0.0... 32 | Preprocessing library snarkl-0.1.0.0... 33 | In-place registering snarkl-0.1.0.0... 34 | Preprocessing benchmark 'criterion' for snarkl-0.1.0.0... 35 | [25 of 25] Compiling Main ( src/testsuite/benchmarks/Main.hs, dist/build/criterion/criterion-tmp/Main.o ) 36 | Linking dist/build/criterion/criterion ... 37 | Running 1 benchmarks... 38 | Benchmark criterion: RUNNING... 39 | benchmarking keccak800/keccak800-elaborate 40 | time 459.2 ms (427.9 ms .. 489.7 ms) 41 | 0.999 R² (0.999 R² .. 1.000 R²) 42 | mean 462.1 ms (459.5 ms .. 464.6 ms) 43 | std dev 4.373 ms (0.0 s .. 4.402 ms) 44 | variance introduced by outliers: 19% (moderately inflated) 45 | 46 | benchmarking keccak800/keccak800-constraints 47 | time 1.609 s (1.551 s .. 1.697 s) 48 | 1.000 R² (0.999 R² .. 1.000 R²) 49 | mean 1.607 s (1.597 s .. 1.616 s) 50 | std dev 13.14 ms (271.9 as .. 14.41 ms) 51 | variance introduced by outliers: 19% (moderately inflated) 52 | 53 | benchmarking keccak800/keccak800-simplify 54 | time 5.225 s (4.875 s .. 5.596 s) 55 | 0.999 R² (0.998 R² .. 1.000 R²) 56 | mean 5.382 s (5.309 s .. 5.455 s) 57 | std dev 124.6 ms (0.0 s .. 125.4 ms) 58 | variance introduced by outliers: 19% (moderately inflated) 59 | 60 | benchmarking keccak800/keccak800-r1cs 61 | time 7.142 s (6.888 s .. 7.356 s) 62 | 1.000 R² (0.999 R² .. 1.000 R²) 63 | mean 7.171 s (7.120 s .. 7.210 s) 64 | std dev 59.43 ms (0.0 s .. 67.12 ms) 65 | variance introduced by outliers: 19% (moderately inflated) 66 | 67 | benchmarking keccak800/keccak800-witgen 68 | time 41.54 s (40.77 s .. 42.75 s) 69 | 1.000 R² (1.000 R² .. 1.000 R²) 70 | mean 41.17 s (40.97 s .. 41.48 s) 71 | std dev 271.9 ms (0.0 s .. 292.5 ms) 72 | variance introduced by outliers: 19% (moderately inflated) 73 | 74 | benchmarking keccak800/keccak800-keygen 75 | Keygen Succeeded. 76 | Keygen Succeeded. 77 | Keygen Succeeded. 78 | Keygen Succeeded. 79 | Keygen Succeeded. 80 | Keygen Succeeded. 81 | Keygen Succeeded. 82 | Keygen Succeeded. 83 | Keygen Succeeded. 84 | Keygen Succeeded. 85 | Keygen Succeeded. 86 | Keygen Succeeded. 87 | Keygen Succeeded. 88 | Keygen Succeeded. 89 | Keygen Succeeded. 90 | Keygen Succeeded. 91 | time 57.36 s (56.70 s .. 58.12 s) 92 | 1.000 R² (1.000 R² .. 1.000 R²) 93 | mean 57.84 s (57.64 s .. 58.03 s) 94 | std dev 304.6 ms (0.0 s .. 320.0 ms) 95 | variance introduced by outliers: 19% (moderately inflated) 96 | 97 | benchmarking keccak800/keccak800-verif 98 | Verification Succeeded. 99 | Verification Succeeded. 100 | Verification Succeeded. 101 | Verification Succeeded. 102 | Verification Succeeded. 103 | Verification Succeeded. 104 | Verification Succeeded. 105 | Verification Succeeded. 106 | Verification Succeeded. 107 | Verification Succeeded. 108 | Verification Succeeded. 109 | Verification Succeeded. 110 | Verification Succeeded. 111 | Verification Succeeded. 112 | Verification Succeeded. 113 | Verification Succeeded. 114 | time 75.83 s (73.51 s .. 78.62 s) 115 | 1.000 R² (1.000 R² .. 1.000 R²) 116 | mean 74.48 s (73.73 s .. 75.03 s) 117 | std dev 841.9 ms (0.0 s .. 958.2 ms) 118 | variance introduced by outliers: 19% (moderately inflated) 119 | 120 | benchmarking keccak800/keccak800-full 121 | sat = True, vars = 143268, constraints = 143268, result = 1 % 1 122 | ^CMakefile:13: recipe for target 'bench' failed 123 | make: *** [bench] Interrupt 124 | 125 | ]0;gstewart@gstewart-office: ~/Repos/snarklgstewart@gstewart-office:~/Repos/snarkl$ exit 126 | exit 127 | 128 | Script done on Mon 30 Nov 2015 12:55:01 PM EST 129 | -------------------------------------------------------------------------------- /experiments/benchmark-data.dat: -------------------------------------------------------------------------------- 1 | Phase Elaborate Constraints Simplify R1CS Witgen Keygen Proofgen+Verif 2 | Fixed-Matrix 1.54 17.85 59.21 11.37 6.23 2.48 1.33 3 | Input-Matrices 0.59 3.26 6.65 4.52 8.03 35.48 41.47 4 | Keccak-f800 0.62 1.54 5.07 2.40 45.65 22.38 22.34 5 | Map-List 0.26 1.34 4.52 3.01 47.58 22.22 21.08 -------------------------------------------------------------------------------- /experiments/benchmark-data.ods: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gstew5/snarkl/d6ce72b13e370d2965bb226f28a1135269e7c198/experiments/benchmark-data.ods -------------------------------------------------------------------------------- /experiments/benchmark-data.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gstew5/snarkl/d6ce72b13e370d2965bb226f28a1135269e7c198/experiments/benchmark-data.png -------------------------------------------------------------------------------- /experiments/benchmark-input.plot: -------------------------------------------------------------------------------- 1 | set terminal png nocrop enhanced size 320,320 font "arial,8" 2 | set output 'benchmark-data-112415.png' 3 | set boxwidth 0.85 absolute 4 | set style fill solid 1.00 border lt -1 5 | set key outside right top vertical Left reverse noenhanced autotitle columnhead nobox 6 | set key invert samplen 4 spacing 1 width 0 height 0 7 | set style histogram rowstacked title textcolor lt -1 8 | set datafile missing '-' 9 | set style data histograms 10 | set xtics border in scale 0,0 nomirror rotate by -25 autojustify 11 | set xtics norangelimit 12 | set xtics ("Simpl" 0, "NoSimpl" 1, "Interp" 2) 13 | set title "Compiler Phases" 14 | set yrange [ 0 : 105 ] noreverse nowriteback 15 | set ylabel "sec" 16 | set style fill pattern border 17 | x = 0.0 18 | i = 0 19 | plot 'benchmark-data-112415.dat' using 2:xtic(1), for [i=3:9] '' using i 20 | -------------------------------------------------------------------------------- /experiments/benchmark.plot: -------------------------------------------------------------------------------- 1 | set terminal pngcairo nocrop enhanced size 500,320 font "arial,12" 2 | set output 'benchmark-data.png' 3 | set boxwidth 0.75 relative 4 | set style fill solid 1 border lt -1 5 | set key outside right top vertical Left reverse noenhanced autotitle columnhead nobox 6 | set key invert samplen 4 spacing 1 width 0 height 0 7 | set style histogram rowstacked title textcolor lt -1 8 | set datafile missing '-' 9 | set style data histograms 10 | set xtics border in scale 0,0 nomirror rotate by -25 autojustify 11 | set xtics norangelimit 12 | set title "Benchmark Breakdown by Phase" 13 | set yrange [ 0.005 : 100 ] noreverse nowriteback 14 | set ylabel "% of total" 15 | set style line 100 lt 1 lc rgb "gray" lw 2 16 | set style line 101 lt 0.5 lc rgb "gray" lw 0 17 | set grid mytics ytics ls 100, ls 101 18 | set style fill pattern 19 | plot 'benchmark-data.dat' using 2:xtic(1) title columnheader(2),\ 20 | for [i=3:8] '' using i title columnheader(i) 21 | -------------------------------------------------------------------------------- /experiments/ratio.dat: -------------------------------------------------------------------------------- 1 | Keccak proofgen+verif Keccak witgen Map list proofgen+verif Map list witgen Fixed matrix proofgen+verif Fixed matrix witgen Input matrix proofgen+verif Input matrix witgen 2 | 2.84 1.96 1.128 2.55 0.22 1.03 37.61 7.28 3 | -------------------------------------------------------------------------------- /experiments/ratio.plot: -------------------------------------------------------------------------------- 1 | set terminal pngcairo nocrop enhanced size 520,320 font "arial,12" 2 | set output 'ratio.png' 3 | set title "Witness vs. Crypto Latency" 4 | set xlabel "Proof Generation and Verification (s)" 5 | set ylabel "Witness Generation (s)" 6 | set xrange [0.1:100] 7 | set yrange [0.1:100] 8 | set logscale x 9 | set logscale y 10 | set key left 11 | f(x) = x 12 | plot 'ratio.dat' using 7:8 with points title 'Input Matrices',\ 13 | 'ratio.dat' using 1:2 with points title 'Keccak-f800',\ 14 | 'ratio.dat' using 3:4 with points title 'Map List',\ 15 | 'ratio.dat' using 5:6 with points title 'Fixed Matrix',\ 16 | f(x) lt -1 title '' 17 | 18 | -------------------------------------------------------------------------------- /experiments/ratio.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gstew5/snarkl/d6ce72b13e370d2965bb226f28a1135269e7c198/experiments/ratio.png -------------------------------------------------------------------------------- /prepare-depends.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # This script fetches, builds and locally installs Joshua Kroll's fork of libsnark. 3 | # (Adapted from https://github.com/scipr-lab/libsnark.) 4 | 5 | set -x -e 6 | 7 | DEPSRC=./depsrc 8 | DEPINST=/usr 9 | 10 | mkdir -p $DEPSRC 11 | 12 | cd $DEPSRC 13 | [ ! -d libsnark ] && git clone git://github.com/jkroll/libsnark 14 | cd libsnark 15 | ./prepare-depends.sh 16 | make 17 | sudo make install PREFIX=$DEPINST 18 | 19 | 20 | -------------------------------------------------------------------------------- /scripts/run-keygen.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # This script generates, from an input R1CS configuration, a proving 4 | # key and a verification key. It then uses libsnark to generate a 5 | # proof for the R1CS, given a satisfying assignment. Finally, it runs 6 | # the libsnark verifier on the resulting proof file and reports the 7 | # result. 8 | 9 | # All libsnark output is redirected to LOG. 10 | 11 | # Exit codes: 12 | # 1: not enough arguments 13 | # 2: a required file didn't exist 14 | # 3: key-generation failed 15 | # 4: proof-generation failed 16 | # 5: verification failed 17 | 18 | LOG=run-r1cs.log 19 | 20 | snarky=../cppsrc/bin/snarky 21 | 22 | if [ "$#" -lt 3 ]; then 23 | echo "not enough arguments: 24 | Arguments: 25 | 1- R1CS configuration file 26 | 2- input assignment file 27 | 3- witness assignment file 28 | " 29 | exit 1 30 | fi 31 | 32 | exec 3>&1 1>${LOG} 2>&1 33 | 34 | global_file="" 35 | 36 | # create a fresh file in /tmp 37 | fresh_file_name() 38 | { 39 | UNIQUE=`date +%s%N | sha256sum | base64 | head -c 24` 40 | fileName="/tmp/snarkl-file-$UNIQUE" 41 | touch $fileName 42 | global_file=$fileName 43 | } 44 | 45 | ensure_file_exists() 46 | { 47 | if [ ! -f $1 ]; then 48 | echo "file $1 doesn't exist" 49 | exit 2 50 | fi 51 | } 52 | 53 | R1CS=$1 54 | echo "R1CS file: $R1CS" 55 | fresh_file_name 56 | PK="$global_file" 57 | echo "PK file: $PK" 58 | fresh_file_name 59 | VK="$global_file" 60 | echo "VK file: $VK" 61 | INPUT=$2 62 | echo "Input file: $INPUT" 63 | WITNESS=$3 64 | echo "Witness file: $WITNESS" 65 | fresh_file_name 66 | PROOF="$global_file" 67 | echo "Proof file: $PROOF" 68 | 69 | ensure_file_exists $R1CS 70 | ensure_file_exists $INPUT 71 | ensure_file_exists $WITNESS 72 | 73 | touch $PK $VK $PROOF 74 | 75 | echo "Generating Keys" 76 | time $snarky --generateKeys --csFile $R1CS --verificationKeyFile $VK --provingKeyFile $PK 77 | if [[ $? != 0 ]]; then 78 | echo "Key-generation Failed!" 1>&3 79 | exit 3 80 | fi 81 | -------------------------------------------------------------------------------- /scripts/run-proofgen.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # This script generates, from an input R1CS configuration, a proving 4 | # key and a verification key. It then uses libsnark to generate a 5 | # proof for the R1CS, given a satisfying assignment. Finally, it runs 6 | # the libsnark verifier on the resulting proof file and reports the 7 | # result. 8 | 9 | # All libsnark output is redirected to LOG. 10 | 11 | # Exit codes: 12 | # 1: not enough arguments 13 | # 2: a required file didn't exist 14 | # 3: key-generation failed 15 | # 4: proof-generation failed 16 | # 5: verification failed 17 | 18 | LOG=run-r1cs.log 19 | 20 | snarky=../cppsrc/bin/snarky 21 | 22 | if [ "$#" -lt 3 ]; then 23 | echo "not enough arguments: 24 | Arguments: 25 | 1- R1CS configuration file 26 | 2- input assignment file 27 | 3- witness assignment file 28 | " 29 | exit 1 30 | fi 31 | 32 | exec 3>&1 1>${LOG} 2>&1 33 | 34 | global_file="" 35 | 36 | # create a fresh file in /tmp 37 | fresh_file_name() 38 | { 39 | UNIQUE=`date +%s%N | sha256sum | base64 | head -c 24` 40 | fileName="/tmp/snarkl-file-$UNIQUE" 41 | touch $fileName 42 | global_file=$fileName 43 | } 44 | 45 | ensure_file_exists() 46 | { 47 | if [ ! -f $1 ]; then 48 | echo "file $1 doesn't exist" 49 | exit 2 50 | fi 51 | } 52 | 53 | R1CS=$1 54 | echo "R1CS file: $R1CS" 55 | fresh_file_name 56 | PK="$global_file" 57 | echo "PK file: $PK" 58 | fresh_file_name 59 | VK="$global_file" 60 | echo "VK file: $VK" 61 | INPUT=$2 62 | echo "Input file: $INPUT" 63 | WITNESS=$3 64 | echo "Witness file: $WITNESS" 65 | fresh_file_name 66 | PROOF="$global_file" 67 | echo "Proof file: $PROOF" 68 | 69 | ensure_file_exists $R1CS 70 | ensure_file_exists $INPUT 71 | ensure_file_exists $WITNESS 72 | 73 | touch $PK $VK $PROOF 74 | 75 | echo "Generating Keys" 76 | time $snarky --generateKeys --csFile $R1CS --verificationKeyFile $VK --provingKeyFile $PK 77 | if [[ $? != 0 ]]; then 78 | echo "Key-generation Failed!" 1>&3 79 | exit 3 80 | fi 81 | 82 | echo "Generating Proof" 83 | time $snarky --prove --provingKeyFile $PK --inputFile $INPUT \ 84 | --witnessFile $WITNESS --proofFile $PROOF 85 | if [[ $? != 0 ]]; then 86 | echo "Proof-generation Failed!" 1>&3 87 | exit 4 88 | fi 89 | -------------------------------------------------------------------------------- /scripts/run-r1cs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # This script generates, from an input R1CS configuration, a proving 4 | # key and a verification key. It then uses libsnark to generate a 5 | # proof for the R1CS, given a satisfying assignment. Finally, it runs 6 | # the libsnark verifier on the resulting proof file and reports the 7 | # result. 8 | 9 | # All libsnark output is redirected to LOG. 10 | 11 | # Exit codes: 12 | # 1: not enough arguments 13 | # 2: a required file didn't exist 14 | # 3: key-generation failed 15 | # 4: proof-generation failed 16 | # 5: verification failed 17 | 18 | LOG=run-r1cs.log 19 | 20 | snarky=../cppsrc/bin/snarky 21 | 22 | if [ "$#" -lt 3 ]; then 23 | echo "not enough arguments: 24 | Arguments: 25 | 1- R1CS configuration file 26 | 2- input assignment file 27 | 3- witness assignment file 28 | " 29 | exit 1 30 | fi 31 | 32 | exec 3>&1 1>${LOG} 2>&1 33 | 34 | global_file="" 35 | 36 | # create a fresh file in /tmp 37 | fresh_file_name() 38 | { 39 | UNIQUE=`date +%s%N | sha256sum | base64 | head -c 24` 40 | fileName="/tmp/snarkl-file-$UNIQUE" 41 | touch $fileName 42 | global_file=$fileName 43 | } 44 | 45 | ensure_file_exists() 46 | { 47 | if [ ! -f $1 ]; then 48 | echo "file $1 doesn't exist" 49 | exit 2 50 | fi 51 | } 52 | 53 | R1CS=$1 54 | echo "R1CS file: $R1CS" 55 | fresh_file_name 56 | PK="$global_file" 57 | echo "PK file: $PK" 58 | fresh_file_name 59 | VK="$global_file" 60 | echo "VK file: $VK" 61 | INPUT=$2 62 | echo "Input file: $INPUT" 63 | WITNESS=$3 64 | echo "Witness file: $WITNESS" 65 | fresh_file_name 66 | PROOF="$global_file" 67 | echo "Proof file: $PROOF" 68 | 69 | ensure_file_exists $R1CS 70 | ensure_file_exists $INPUT 71 | ensure_file_exists $WITNESS 72 | 73 | touch $PK $VK $PROOF 74 | 75 | echo "Generating Keys" 76 | time $snarky --generateKeys --csFile $R1CS --verificationKeyFile $VK --provingKeyFile $PK 77 | if [[ $? != 0 ]]; then 78 | echo "Key-generation Failed!" 1>&3 79 | exit 3 80 | fi 81 | 82 | echo "Generating Proof" 83 | time $snarky --prove --provingKeyFile $PK --inputFile $INPUT \ 84 | --witnessFile $WITNESS --proofFile $PROOF 85 | if [[ $? != 0 ]]; then 86 | echo "Proof-generation Failed!" 1>&3 87 | exit 4 88 | fi 89 | 90 | echo "Verifying Proof" 91 | time $snarky --verify --verificationKeyFile $VK --inputFile $INPUT --proofFile $PROOF 92 | if [[ $? != 0 ]]; then 93 | echo "Verification Failed!" 1>&3 94 | exit 5 95 | fi 96 | 97 | echo "Verification Succeeded." 1>&3 98 | -------------------------------------------------------------------------------- /snarkl.cabal: -------------------------------------------------------------------------------- 1 | name: snarkl 2 | 3 | -- The package version. See the Haskell package versioning policy (PVP) 4 | -- for standards guiding when and how versions should be incremented. 5 | -- http://www.haskell.org/haskellwiki/Package_versioning_policy 6 | -- PVP summary: +-+------- breaking API changes 7 | -- | | +----- non-breaking API additions 8 | -- | | | +--- code changes with no API change 9 | version: 0.1.0.0 10 | synopsis: Snarkl: An Embedded DSL for Verifiable Computing 11 | description: Snarkl: An Embedded DSL for Verifiable Computing 12 | homepage: https://github.com/gstew5/snarkl 13 | license: BSD3 14 | license-file: LICENSE 15 | author: Gordon Stewart 16 | maintainer: gstew5@gmail.com 17 | category: Language 18 | 19 | build-type: Simple 20 | extra-source-files: README.md 21 | cabal-version: >=1.10 22 | 23 | source-repository head 24 | type: git 25 | location: https://github.com/gstew5/snarkl 26 | 27 | test-suite hspec 28 | type: exitcode-stdio-1.0 29 | main-is: Main.hs 30 | hs-source-dirs: src/testsuite/tests, 31 | src/examples 32 | default-language: Haskell2010 33 | build-depends: 34 | base >=4.7, 35 | containers >=0.5 && <0.6, 36 | mtl >=2.2 && <2.3, 37 | criterion >=1.0 && <1.3, 38 | parallel >=3.2 && <3.3, 39 | hspec >=2.0, 40 | process >=1.2, 41 | snarkl >=0.1.0.0, 42 | Cabal >=1.22 43 | 44 | benchmark criterion 45 | type: exitcode-stdio-1.0 46 | main-is: Main.hs 47 | hs-source-dirs: src, 48 | src/testsuite/benchmarks, 49 | src/examples 50 | default-language: Haskell2010 51 | build-depends: 52 | base >=4.7, 53 | containers >=0.5 && <0.6, 54 | mtl >=2.2 && <2.3, 55 | criterion >=1.0 && <1.3, 56 | parallel >=3.2 && <3.3, 57 | hspec >=2.0, 58 | process >=1.2, 59 | snarkl >=0.1.0.0, 60 | Cabal >=1.22 61 | 62 | library 63 | ghc-options: 64 | -Wall 65 | -fno-warn-missing-signatures 66 | -fno-warn-unused-do-bind 67 | -funbox-strict-fields 68 | -rtsopts 69 | -- -threaded 70 | -optc-O3 71 | 72 | exposed-modules: 73 | TExpr, 74 | SyntaxMonad, Syntax, 75 | Toplevel, 76 | Compile, 77 | R1CS, 78 | Errors 79 | 80 | -- Modules included in this library but not exported. 81 | other-modules: 82 | Constraints, Field, Interp, Poly, SimplMonad, UnionFind, Expr, 83 | Solve, Simplify, Dataflow, Common, Serialize, Games 84 | 85 | other-extensions: 86 | GADTs, TypeSynonymInstances, FlexibleInstances, BangPatterns, 87 | RebindableSyntax, DataKinds, StandaloneDeriving, RankNTypes, 88 | KindSignatures, ScopedTypeVariables, FlexibleContexts, 89 | UndecidableInstances, PolyKinds, GeneralizedNewtypeDeriving, 90 | DeriveDataTypeable, AutoDeriveTypeable, TypeFamilies 91 | 92 | build-depends: 93 | base >=4.7, 94 | containers >=0.5 && <0.6, 95 | mtl >=2.2 && <2.3, 96 | criterion >=1.0 && <1.3, 97 | parallel >=3.2 && <3.3, 98 | hspec >=2.0, 99 | process >=1.2, 100 | Cabal >=1.22 101 | 102 | hs-source-dirs: src, 103 | src/testsuite/tests, 104 | src/testsuite/benchmarks, 105 | src/examples 106 | 107 | default-language: Haskell2010 108 | -------------------------------------------------------------------------------- /src/Common.hs: -------------------------------------------------------------------------------- 1 | module Common where 2 | 3 | import qualified Data.IntMap.Lazy as Map 4 | 5 | type Var = Int 6 | 7 | type Assgn a = Map.IntMap a 8 | 9 | data UnOp = ZEq 10 | deriving Eq 11 | 12 | instance Show UnOp where 13 | show ZEq = "(== 0)" 14 | 15 | data Op = Add | Sub | Mult | Div 16 | | And | Or | XOr | Eq | BEq 17 | deriving Eq 18 | 19 | instance Show Op where 20 | show Add = "+" 21 | show Sub = "-" 22 | show Mult = "*" 23 | show Div = "-*" 24 | show And = "&&" 25 | show Or = "||" 26 | show XOr = "xor" 27 | show Eq = "==" 28 | show BEq = "=b=" 29 | 30 | is_boolean :: Op -> Bool 31 | is_boolean op = case op of 32 | Add -> False 33 | Sub -> False 34 | Mult -> False 35 | Div -> False 36 | And -> True 37 | Or -> True 38 | XOr -> True 39 | Eq -> True 40 | BEq -> True 41 | 42 | is_assoc :: Op -> Bool 43 | is_assoc op = case op of 44 | Add -> True 45 | Sub -> False 46 | Mult -> True 47 | Div -> False 48 | And -> True 49 | Or -> True 50 | XOr -> True 51 | Eq -> True 52 | BEq -> True 53 | -------------------------------------------------------------------------------- /src/Compile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | module Compile 4 | ( CEnv(CEnv) 5 | , SimplParam(..) 6 | , fresh_var 7 | , cs_of_exp 8 | , get_constraints 9 | , constraints_of_texp 10 | , r1cs_of_constraints 11 | , exp_of_texp 12 | ) where 13 | 14 | import Data.Typeable 15 | import qualified Data.IntMap.Lazy as Map 16 | import qualified Data.Set as Set 17 | import Control.Monad.State 18 | 19 | import Common 20 | import Errors 21 | import Field 22 | import R1CS 23 | import SimplMonad 24 | import Simplify 25 | import Solve 26 | import Dataflow 27 | import TExpr 28 | import Expr 29 | import Constraints 30 | 31 | 32 | ---------------------------------------------------------------- 33 | -- 34 | -- Expr -> Constraints 35 | -- 36 | ---------------------------------------------------------------- 37 | 38 | data CEnv a = 39 | CEnv { cur_cs :: Set.Set (Constraint a) 40 | , next_var :: Var 41 | } 42 | 43 | add_constraint :: Ord a => Constraint a -> State (CEnv a) () 44 | add_constraint c 45 | = modify (\cenv -> cenv {cur_cs = Set.insert c $ cur_cs cenv}) 46 | 47 | get_constraints :: State (CEnv a) [Constraint a] 48 | get_constraints 49 | = do { cenv <- get 50 | ; return $ Set.toList $ cur_cs cenv 51 | } 52 | 53 | get_next_var :: State (CEnv a) Var 54 | get_next_var 55 | = do { cenv <- get 56 | ; return (next_var cenv) 57 | } 58 | 59 | set_next_var :: Var -> State (CEnv a) () 60 | set_next_var next = modify (\cenv -> cenv { next_var = next }) 61 | 62 | fresh_var :: State (CEnv a) Var 63 | fresh_var 64 | = do { next <- get_next_var 65 | ; set_next_var (next + 1) 66 | ; return next 67 | } 68 | 69 | -- | Add constraint 'x = y' 70 | ensure_equal :: Field a => (Var,Var) -> State (CEnv a) () 71 | ensure_equal (x,y) 72 | = add_constraint 73 | $ cadd zero [(x,one),(y,neg one)] 74 | 75 | -- | Add constraint 'x = c' 76 | ensure_const :: Field a => (Var,a) -> State (CEnv a) () 77 | ensure_const (x,c) 78 | = add_constraint 79 | $ cadd c [(x,neg one)] 80 | 81 | -- | Add constraint 'b^2 = b'. 82 | ensure_boolean :: Field a => Var -> State (CEnv a) () 83 | ensure_boolean b 84 | = encode_binop Mult (b,b,b) 85 | 86 | -- | Constraint 'x \/ y = z'. 87 | -- The encoding is: x+y - z = x*y; assumes x and y are boolean. 88 | encode_or :: Field a => (Var,Var,Var) -> State (CEnv a) () 89 | encode_or (x,y,z) 90 | = do { x_mult_y <- fresh_var 91 | ; cs_of_exp x_mult_y (EBinop Mult [EVar x,EVar y]) 92 | ; cs_of_exp x_mult_y (EBinop Sub 93 | [EBinop Add [EVar x,EVar y] 94 | ,EVar z]) 95 | } 96 | 97 | -- | Constraint 'x xor y = z'. 98 | -- The encoding is: x+y - z = 2(x*y); assumes x and y are boolean. 99 | encode_xor :: Field a => (Var,Var,Var) -> State (CEnv a) () 100 | encode_xor (x,y,z) 101 | = do { x_mult_y <- fresh_var 102 | ; encode_binop Mult (x,y,x_mult_y) 103 | ; add_constraint 104 | $ cadd zero [(x,one),(y,one),(z,neg one) 105 | ,(x_mult_y,neg (one `add`one))] 106 | } 107 | -- -- The following desugaring is preferable, but generates more constraints. 108 | -- -- Perhaps something to investigate wrt. Simplify.hs. 109 | -- = do { x_mult_y <- fresh_var 110 | -- ; cs_of_exp x_mult_y (EBinop Mult 111 | -- [EVal (one `add` one) 112 | -- ,EBinop Mult [EVar x,EVar y]]) 113 | -- ; cs_of_exp x_mult_y (EBinop Sub 114 | -- [EBinop Add [EVar x,EVar y] 115 | -- ,EVar z]) 116 | -- } 117 | 118 | 119 | -- | Constraint 'x == y = z' ASSUMING x, y are boolean. 120 | -- The encoding is: x*y + (1-x)*(1-y) = z. 121 | encode_boolean_eq :: Field a => (Var,Var,Var) -> State (CEnv a) () 122 | encode_boolean_eq (x,y,z) = cs_of_exp z e 123 | where e = EBinop Add 124 | [EBinop Mult [EVar x,EVar y] 125 | ,EBinop Mult 126 | [EBinop Sub [EVal one,EVar x] 127 | ,EBinop Sub [EVal one,EVar y]]] 128 | 129 | -- | Constraint 'x == y = z'. 130 | -- The encoding is: z = (x-y == 0). 131 | encode_eq :: Field a => (Var,Var,Var) -> State (CEnv a) () 132 | encode_eq (x,y,z) = cs_of_exp z e 133 | where e = EAssert 134 | (EVar z) 135 | (EUnop ZEq (EBinop Sub [EVar x,EVar y])) 136 | 137 | -- | Constraint 'y = x!=0 ? 1 : 0'. 138 | -- The encoding is: 139 | -- for some m, 140 | -- x*m = y 141 | -- /\ (1-y)*x = 0 142 | -- Cf. p7. of [pinnochio-sp13], which follows [setty-usenix12]. 143 | encode_zneq :: Field a => (Var,Var) -> State (CEnv a) () 144 | encode_zneq (x,y) 145 | = do { m <- fresh_var 146 | ; neg_y <- fresh_var 147 | -- The following 'magic' constraint resolves the value of 148 | -- nondet witness 'm': 149 | -- m = 0, x = 0 150 | -- m = inv x, x <> 0 151 | ; nm <- fresh_var 152 | ; add_constraint (CMagic nm [x,m] mf) 153 | -- END magic. 154 | ; cs_of_exp y (EBinop Mult [EVar x,EVar m]) 155 | ; cs_of_exp neg_y (EBinop Sub [EVal one,EVar y]) 156 | ; add_constraint 157 | (CMult (one,neg_y) (one,x) (zero,Nothing)) 158 | } 159 | where mf [x0,m0] 160 | = do { tx <- bind_of_var x0 161 | ; case tx of 162 | Left _ -> return False 163 | Right c -> 164 | if c == zero then 165 | do { bind_var (m0,zero) 166 | ; return True 167 | } 168 | else case inv c of 169 | Nothing -> 170 | fail_with 171 | $ ErrMsg ("expected " ++ show x0 ++ "==" ++ show c 172 | ++ " to be invertible") 173 | Just c' -> 174 | do { bind_var (m0,c') 175 | ; return True 176 | } 177 | } 178 | mf _ = fail_with 179 | $ ErrMsg "internal error in 'encode_zeq'" 180 | 181 | -- | Constraint 'y == x==0:1?0' 182 | encode_zeq :: Field a => (Var,Var) -> State (CEnv a) () 183 | encode_zeq (x,y) 184 | = do { neg_y <- fresh_var 185 | ; encode_zneq (x,neg_y) 186 | ; cs_of_exp y (EBinop Sub [EVal one,EVar neg_y]) 187 | } 188 | 189 | -- | Encode the constraint 'un_op x = y' 190 | encode_unop :: Field a => UnOp -> (Var,Var) -> State (CEnv a) () 191 | encode_unop op (x,y) = go op 192 | where go ZEq = encode_zeq (x,y) 193 | 194 | -- | Encode the constraint 'x op y = z'. 195 | encode_binop :: Field a => Op -> (Var,Var,Var) -> State (CEnv a) () 196 | encode_binop op (x,y,z) = go op 197 | where go And = encode_binop Mult (x,y,z) 198 | go Or = encode_or (x,y,z) 199 | go XOr = encode_xor (x,y,z) 200 | go Eq = encode_eq (x,y,z) 201 | go BEq = encode_boolean_eq (x,y,z) 202 | 203 | go Add 204 | = add_constraint 205 | $ cadd zero [(x,one),(y,one),(z,neg one)] 206 | 207 | go Sub 208 | = add_constraint 209 | $ cadd zero [(x,one),(y,neg one),(z,neg one)] 210 | 211 | go Mult 212 | = add_constraint 213 | $ CMult (one,x) (one,y) (one,Just z) 214 | 215 | go Div 216 | = add_constraint 217 | $ CMult (one,y) (one,z) (one,Just x) 218 | 219 | encode_linear :: Field a => Var -> [Either (Var,a) a] -> State (CEnv a) () 220 | encode_linear out xs 221 | = let c = foldl (\acc d -> d `add` acc) zero $ map (either (\_ -> zero) id) xs 222 | in add_constraint 223 | $ cadd c $ (out,neg one) : remove_consts xs 224 | where remove_consts :: [Either (Var,a) a] -> [(Var,a)] 225 | remove_consts [] = [] 226 | remove_consts (Left p : l) = p : remove_consts l 227 | remove_consts (Right _ : l) = remove_consts l 228 | 229 | cs_of_exp :: Field a => Var -> Exp a -> State (CEnv a) () 230 | cs_of_exp out e = case e of 231 | EVar x -> 232 | do { ensure_equal (out,x) 233 | } 234 | 235 | EVal c -> 236 | do { ensure_const (out,c) 237 | } 238 | 239 | EUnop op (EVar x) -> 240 | do { encode_unop op (x,out) 241 | } 242 | EUnop op e1 -> 243 | do { e1_out <- fresh_var 244 | ; cs_of_exp e1_out e1 245 | ; encode_unop op (e1_out,out) 246 | } 247 | 248 | EBinop op es -> 249 | -- [NOTE linear combination optimization:] cf. also 250 | -- 'encode_linear' above. 'go_linear' returns a list of 251 | -- (label*coeff + constant) pairs. 252 | -- (1) The label is the output wire for the expression that was 253 | -- compiled and the coefficient is its scalar field coefficient, 254 | -- or 'one' if no coefficient exists (i.e., 'e' is not of the form 255 | -- 'EBinop Mult [e_left,EVal coeff]' or symmetric. 256 | -- (2) The constant 'c' is the constant at a particular position 257 | -- in the list of expressions 'es'. 258 | -- We special-case linear combinations in this way to avoid having 259 | -- to introduce new multiplication gates for multiplication by 260 | -- constant scalars. 261 | let go_linear [] = return [] 262 | go_linear (EBinop Mult [EVar x,EVal coeff] : es') 263 | = do { labels <- go_linear es' 264 | ; return $ Left (x,coeff) : labels 265 | } 266 | go_linear (EBinop Mult [EVal coeff,EVar y] : es') 267 | = do { labels <- go_linear es' 268 | ; return $ Left (y,coeff) : labels 269 | } 270 | go_linear (EBinop Mult [e_left,EVal coeff] : es') 271 | = do { e_left_out <- fresh_var 272 | ; cs_of_exp e_left_out e_left 273 | ; labels <- go_linear es' 274 | ; return $ Left (e_left_out,coeff) : labels 275 | } 276 | go_linear (EBinop Mult [EVal coeff,e_right] : es') 277 | = do { e_right_out <- fresh_var 278 | ; cs_of_exp e_right_out e_right 279 | ; labels <- go_linear es' 280 | ; return $ Left (e_right_out,coeff) : labels 281 | } 282 | go_linear (EVal c : es') 283 | = do { labels <- go_linear es' 284 | ; return $ Right c : labels 285 | } 286 | go_linear (EVar x : es') 287 | = do { labels <- go_linear es' 288 | ; return $ Left (x,one) : labels 289 | } 290 | -- The 'go_linear' catch-all case (i.e., no optimization) 291 | go_linear (e1 : es') 292 | = do { e1_out <- fresh_var 293 | ; cs_of_exp e1_out e1 294 | ; labels <- go_linear es' 295 | ; return $ Left (e1_out,one) : labels 296 | } 297 | 298 | go_sub [] = return [] 299 | go_sub (e1 : es') 300 | = do { labels <- go_linear (e1 : es') 301 | ; case labels of 302 | [] -> fail_with $ ErrMsg "internal error in go_sub" 303 | k : ls -> return $ k : rev_pol ls 304 | } 305 | 306 | rev_pol [] = [] 307 | rev_pol (Left (x,c) : ls) = Left (x,neg c) : rev_pol ls 308 | rev_pol (Right c: ls) = Right (neg c) : rev_pol ls 309 | 310 | go_other [] = return [] 311 | go_other (EVar x : es') 312 | = do { labels <- go_other es' 313 | ; return $ x : labels 314 | } 315 | go_other (e1 : es') 316 | = do { e1_out <- fresh_var 317 | ; cs_of_exp e1_out e1 318 | ; labels <- go_other es' 319 | ; return $ e1_out : labels 320 | } 321 | 322 | encode_labels [] = return () 323 | encode_labels (_ : []) = fail_with $ ErrMsg ("wrong arity in " ++ show e) 324 | encode_labels (l1 : l2 : []) = encode_binop op (l1,l2,out) 325 | encode_labels (l1 : l2 : labels') 326 | = do { res_out <- fresh_var 327 | ; encode_labels (res_out : labels') 328 | ; encode_binop op (l1,l2,res_out) 329 | } 330 | 331 | in do { case op of 332 | -- Encode c1x1 + c2x2 + ... + cnxn directly as a linear constraint. 333 | Add -> 334 | do { labels <- go_linear es 335 | ; encode_linear out labels 336 | } 337 | 338 | Sub -> 339 | do { labels <- go_sub es 340 | ; encode_linear out labels 341 | } 342 | 343 | -- Otherwise, do the pairwise encoding. 344 | _ -> 345 | do { labels <- go_other es 346 | ; encode_labels labels 347 | } 348 | } 349 | 350 | -- Encoding: out = b*e1 + (1-b)e2 351 | EIf b e1 e2 -> cs_of_exp out e0 352 | where e0 = EBinop Add 353 | [ EBinop Mult [b,e1] 354 | , EBinop Mult [EBinop Sub [EVal one,b],e2] 355 | ] 356 | 357 | -- NOTE: when compiling assignments, the naive thing to do is 358 | -- to introduce a new var, e2_out, bound to result of e2 and 359 | -- then ensure that e2_out == x. We optimize by passing x to 360 | -- compilation of e2 directly. 361 | EAssert e1 e2 -> 362 | do { let x = var_of_exp e1 363 | ; cs_of_exp x e2 364 | } 365 | 366 | ESeq le -> 367 | do { x <- fresh_var -- x is garbage 368 | ; go x le 369 | } 370 | where go _ [] = fail_with $ ErrMsg "internal error: empty ESeq" 371 | go _ [e1] = cs_of_exp out e1 372 | go garbage_var (e1 : le') 373 | = do { cs_of_exp garbage_var e1 374 | ; go garbage_var le' 375 | } 376 | EUnit -> 377 | -- NOTE: [[ EUnit ]]_{out} = [[ EVal zero ]]_{out}. 378 | do { cs_of_exp out (EVal zero) } 379 | 380 | data SimplParam = 381 | NoSimplify 382 | | Simplify 383 | | SimplifyDataflow 384 | 385 | must_simplify NoSimplify = False 386 | must_simplify Simplify = True 387 | must_simplify SimplifyDataflow = True 388 | 389 | must_dataflow NoSimplify = False 390 | must_dataflow Simplify = False 391 | must_dataflow SimplifyDataflow = True 392 | 393 | -- | Compile a list of arithmetic constraints to a rank-1 constraint 394 | -- system. Takes as input the constraints, the input variables, and 395 | -- the output variables, and return the corresponding R1CS. 396 | r1cs_of_constraints :: Field a 397 | => SimplParam 398 | -> ConstraintSystem a 399 | -> R1CS a 400 | r1cs_of_constraints simpl cs 401 | = let -- Simplify resulting constraints. 402 | (_,cs_simpl) = if must_simplify simpl then do_simplify False Map.empty cs 403 | else (undefined,cs) 404 | cs_dataflow = if must_dataflow simpl then remove_unreachable cs_simpl else cs_simpl 405 | -- Renumber constraint variables sequentially, from 0 to 406 | -- 'max_var'. 'renumber_f' is a function mapping variables to 407 | -- their renumbered counterparts. 408 | (_,cs') = renumber_constraints cs_dataflow 409 | -- 'f' is a function mapping input bindings to witnesses. 410 | -- NOTE: we assume the initial variable assignment passed to 411 | -- 'f' is the one derived by zipping the inputs together with 412 | -- the (renamed) input vars. of the R1CS produced by this 413 | -- function. Alternatively, we could 'Map.mapKeys renumber_f' 414 | -- before applying 'solve cs''. 415 | f = solve cs' 416 | in r1cs_of_cs cs' f 417 | 418 | -- | Compile an expression to a constraint system. Takes as input the 419 | -- expression, the expression's input variables, and the name of the 420 | -- output variable. 421 | constraints_of_texp :: ( Field a 422 | , Typeable ty 423 | ) 424 | => Var -- ^ Output variable 425 | -> [Var] -- ^ Input variables 426 | -> TExp ty a -- ^ Expression 427 | -> ConstraintSystem a 428 | constraints_of_texp out in_vars te 429 | = let cenv_init = CEnv Set.empty (out+1) 430 | (constrs,_) = runState go cenv_init 431 | in constrs 432 | where go = do { let boolean_in_vars 433 | = Set.toList 434 | $ Set.fromList in_vars 435 | `Set.intersection` 436 | Set.fromList (boolean_vars_of_texp te) 437 | e0 = exp_of_texp te 438 | e = do_const_prop e0 439 | -- Compile 'e' to constraints 'cs', with output wire 'out'. 440 | ; cs_of_exp out e 441 | -- Add boolean constraints 442 | ; mapM ensure_boolean boolean_in_vars 443 | ; cs <- get_constraints 444 | ; let constraint_set = Set.fromList cs 445 | num_constraint_vars 446 | = length $ constraint_vars constraint_set 447 | ; return 448 | $ ConstraintSystem 449 | constraint_set num_constraint_vars in_vars [out] 450 | } 451 | 452 | 453 | -------------------------------------------------------------------------------- /src/Constraints.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs 2 | , TypeSynonymInstances 3 | , FlexibleInstances 4 | , BangPatterns 5 | #-} 6 | 7 | module Constraints 8 | ( CoeffList(..) 9 | , coeff_insert 10 | , Constraint(..) 11 | , cadd 12 | , ConstraintSet 13 | , ConstraintSystem(..) 14 | , r1cs_of_cs 15 | , renumber_constraints 16 | , constraint_vars 17 | ) where 18 | 19 | import qualified Data.Set as Set 20 | import qualified Data.IntMap.Lazy as Map 21 | import Control.Monad.State 22 | 23 | import Common 24 | import Errors 25 | import Field 26 | import Poly 27 | import R1CS 28 | import SimplMonad 29 | 30 | ---------------------------------------------------------------- 31 | -- Intermediate Constraint Language 32 | ---------------------------------------------------------------- 33 | 34 | newtype CoeffList k v = CoeffList { asList :: [(k,v)] } 35 | deriving (Eq) 36 | -- COEFFLIST INVARIANT: no key appears more than once. Upon duplicate 37 | -- insertion, insert field sum of the values. Terms with 0 coeff. are 38 | -- implicitly removed. Smart constructor 'cadd' (below) enforces this 39 | -- invariant. 40 | 41 | coeff_insert :: (Eq k,Field a) => k -> a -> CoeffList k a -> CoeffList k a 42 | coeff_insert k a l = CoeffList $ go (asList l) 43 | where go [] = [(k,a)] 44 | go (scrut@(k',a') : l') 45 | = if k == k' then (k,add a a') : l' 46 | else scrut : go l' 47 | 48 | coeff_merge :: (Eq k,Field a) => CoeffList k a -> CoeffList k a 49 | coeff_merge l = go (CoeffList []) (asList l) 50 | where go acc [] = acc 51 | go acc ((k,a) : l') 52 | = go (coeff_insert k a acc) l' 53 | 54 | remove_zeros :: (Field a) => CoeffList k a -> CoeffList k a 55 | remove_zeros (CoeffList l) = CoeffList $ go [] l 56 | where go acc [] = acc 57 | go acc ((_,a) : l') 58 | | a==zero 59 | = go acc l' 60 | go acc (scrut@(_,_) : l') 61 | | otherwise 62 | = go (scrut : acc) l' 63 | 64 | -- | Constraints are either 65 | -- * 'CAdd a m': A linear combination of the constant 'a' with 66 | -- the variable-coeff. terms given by map 'm : Map.Map Var a'. 67 | -- * 'CMult (c,x) (d,y) (e,mz)': A multiplicative constraint with 68 | -- interpretation cx * dy = e (when mz = Nothing), or 69 | -- cx * dy = ez (when mz = Just z). 70 | data Constraint a = 71 | CAdd !a !(CoeffList Var a) 72 | | CMult !(a,Var) !(a,Var) !(a, Maybe Var) 73 | | CMagic Var [Var] ([Var] -> State (SEnv a) Bool) 74 | 75 | -- | Smart constructor enforcing CoeffList invariant 76 | cadd :: Field a => a -> [(Var,a)] -> Constraint a 77 | cadd !a !l = CAdd a (remove_zeros $ coeff_merge $ CoeffList l) 78 | 79 | type ConstraintSet a = Set.Set (Constraint a) 80 | 81 | data ConstraintSystem a = 82 | ConstraintSystem { cs_constraints :: ConstraintSet a 83 | , cs_num_vars :: Int 84 | , cs_in_vars :: [Var] 85 | , cs_out_vars :: [Var] 86 | } 87 | deriving (Show) 88 | 89 | instance Eq a => Eq (Constraint a) where 90 | CAdd c m == CAdd c' m' 91 | = c == c' && m == m' 92 | CMult cx dy emz == CMult cx' dy' emz' 93 | = emz == emz' 94 | && (cx == cx' && dy == dy' || cx == dy' && dy == cx') 95 | CMagic nm _ _ == CMagic nm' _ _ = nm == nm' 96 | CAdd _ _ == CMult _ _ _ = False 97 | CMult _ _ _ == CAdd _ _ = False 98 | CMagic _ _ _ == _ = False 99 | _ == CMagic _ _ _ = False 100 | 101 | compare_add :: Ord a => Constraint a -> Constraint a -> Ordering 102 | {-# INLINE compare_add #-} 103 | compare_add !(CAdd c m) !(CAdd c' m') 104 | = if c == c' then compare (asList m) (asList m') 105 | else if c < c' then LT else GT 106 | compare_add !_ !_ 107 | = fail_with $ ErrMsg "internal error: compare_add" 108 | 109 | compare_mult :: Ord a => Constraint a -> Constraint a -> Ordering 110 | {-# INLINE compare_mult #-} 111 | compare_mult 112 | !(CMult (c,x) (d,y) (e,mz)) 113 | !(CMult (c',x') (d',y') (e',mz')) 114 | = if x == x' then 115 | if y == y' then 116 | case compare mz mz' of 117 | EQ -> case compare c c' of 118 | EQ -> case compare d d' of 119 | EQ -> compare e e' 120 | other -> other 121 | other -> other 122 | other -> other 123 | else if y < y' then LT else GT 124 | else if x < x' then LT else GT 125 | compare_mult !_ !_ 126 | = fail_with $ ErrMsg "internal error: compare_mult" 127 | 128 | compare_constr :: Ord a => Constraint a -> Constraint a -> Ordering 129 | {-# INLINE compare_constr #-} 130 | compare_constr !(CAdd _ _) !(CMult _ _ _) = LT 131 | compare_constr !(CMult _ _ _) !(CAdd _ _) = GT 132 | compare_constr !constr@(CAdd _ _) !constr'@(CAdd _ _) 133 | = compare_add constr constr' 134 | compare_constr !constr@(CMult {}) !constr'@(CMult {}) 135 | = compare_mult constr constr' 136 | compare_constr !(CMagic nm _ _) !(CMagic nm' _ _) = compare nm nm' 137 | compare_constr !_ !(CMagic _ _ _) = LT 138 | compare_constr !(CMagic _ _ _) !_ = GT 139 | 140 | instance Ord a => Ord (Constraint a) where 141 | {-# SPECIALIZE instance Ord (Constraint Rational) #-} 142 | compare = compare_constr 143 | 144 | instance Show a => Show (Constraint a) where 145 | show (CAdd a m) = show a ++ " + " ++ go (asList m) 146 | where go [] = " == 0" 147 | go [(x,c)] = show c ++ "x" ++ show x ++ go [] 148 | go ((x,c) : c_xs) = show c ++ "x" ++ show x ++ " + " ++ go c_xs 149 | 150 | show (CMult (c,x) (d,y) (e,mz)) 151 | = let show_term c0 x0 = show c0 ++ "x" ++ show x0 152 | in show_term c x ++ " * " ++ show_term d y 153 | ++ " == " 154 | ++ case mz of 155 | Nothing -> show e 156 | Just z -> show_term e z 157 | 158 | show (CMagic nm xs _) = "Magic " ++ show (nm,xs) 159 | 160 | ---------------------------------------------------------------- 161 | -- Compilation to R1CS 162 | ---------------------------------------------------------------- 163 | 164 | r1cs_of_cs :: Field a 165 | => ConstraintSystem a -- ^ Constraints 166 | -> (Assgn a -> Assgn a) -- ^ Witness generator 167 | -> R1CS a 168 | r1cs_of_cs cs 169 | = R1CS (go $ Set.toList $ cs_constraints cs) 170 | (cs_num_vars cs) 171 | (cs_in_vars cs) 172 | (cs_out_vars cs) 173 | where go [] = [] 174 | go (CAdd a m : cs') 175 | = R1C ( const_poly one 176 | , Poly $ Map.insert (-1) a $ Map.fromList (asList m) 177 | , const_poly zero 178 | ) : go cs' 179 | 180 | go (CMult cx dy (e,Nothing) : cs') 181 | = R1C (var_poly cx,var_poly dy,const_poly e) : go cs' 182 | 183 | go (CMult cx dy (e,Just z) : cs') 184 | = R1C (var_poly cx,var_poly dy,var_poly (e,z)) : go cs' 185 | 186 | go (CMagic _ _ _ : cs') 187 | = go cs' 188 | 189 | 190 | -- | Return the list of variables occurring in constraints 'cs'. 191 | constraint_vars :: ConstraintSet a -> [Var] 192 | constraint_vars cs 193 | = Set.toList 194 | $ Set.foldl' (\s0 c -> Set.union (get_vars c) s0) Set.empty cs 195 | where get_vars (CAdd _ m) = Set.fromList $ map fst (asList m) 196 | get_vars (CMult (_,x) (_,y) (_,Nothing)) = Set.fromList [x,y] 197 | get_vars (CMult (_,x) (_,y) (_,Just z)) = Set.fromList [x,y,z] 198 | get_vars (CMagic _ xs _) = Set.fromList xs 199 | 200 | 201 | -- | Sequentially renumber term variables '0..max_var'. Return 202 | -- renumbered constraints, together with the total number of 203 | -- variables in the (renumbered) constraint set and the (possibly 204 | -- renumbered) in and out variables. 205 | renumber_constraints :: Field a 206 | => ConstraintSystem a 207 | -> ( Var -> Var 208 | , ConstraintSystem a 209 | ) 210 | renumber_constraints cs 211 | = (renum_f,ConstraintSystem new_cs (Map.size var_map) new_in_vars new_out_vars) 212 | where new_cs = Set.map renum_constr $ cs_constraints cs 213 | new_in_vars = map renum_f $ cs_in_vars cs 214 | new_out_vars = map renum_f $ cs_out_vars cs 215 | 216 | var_map 217 | = Map.fromList 218 | $ zip (cs_in_vars cs ++ filter isnt_input all_vars) [0..] 219 | where isnt_input = not . flip Set.member in_vars_set 220 | in_vars_set = Set.fromList $ cs_in_vars cs 221 | all_vars = constraint_vars $ cs_constraints cs 222 | 223 | renum_f x 224 | = case Map.lookup x var_map of 225 | Nothing -> 226 | fail_with 227 | $ ErrMsg ("can't find a binding for variable " ++ show x 228 | ++ " in map " ++ show var_map) 229 | Just x' -> x' 230 | 231 | renum_constr c0 232 | = case c0 of 233 | CAdd a m -> 234 | cadd a $ map (\(k,v) -> (renum_f k,v)) (asList m) 235 | CMult (c,x) (d,y) (e,mz) -> 236 | CMult (c,renum_f x) (d,renum_f y) (e,fmap renum_f mz) 237 | CMagic nm xs f -> 238 | CMagic nm (map renum_f xs) f 239 | 240 | 241 | 242 | 243 | 244 | 245 | -------------------------------------------------------------------------------- /src/Dataflow.hs: -------------------------------------------------------------------------------- 1 | module Dataflow 2 | ( remove_unreachable 3 | ) where 4 | 5 | import Data.List (foldl') 6 | import Data.Set (Set) 7 | import qualified Data.Set as Set 8 | import Data.IntMap.Lazy (IntMap) 9 | import qualified Data.IntMap.Lazy as Map 10 | import Control.Monad.State 11 | 12 | import Common 13 | import Constraints 14 | 15 | number_constraints :: ConstraintSystem a -> IntMap (Constraint a) 16 | number_constraints cs 17 | = go 0 Map.empty (Set.toList $ cs_constraints cs) 18 | where go :: Int -> IntMap (Constraint a) -> [Constraint a] 19 | -> IntMap (Constraint a) 20 | go _ m [] = m 21 | go n m (c : cs') 22 | = go (n+1) (Map.insert n c m) cs' 23 | 24 | -- |Map variables to the indices of the constraints in which the vars appear. 25 | gather_vars :: Ord a => IntMap (Constraint a) -> IntMap (Set Int) 26 | gather_vars constr_map 27 | = go Map.empty (Map.toList constr_map) 28 | where go m [] = m 29 | go m ((the_id,constr) : cs') 30 | = let vars = constraint_vars (Set.singleton constr) 31 | in go (foldl' (\m0 x -> add_var x the_id m0) m vars) cs' 32 | 33 | add_var x the_id m0 34 | = case Map.lookup x m0 of 35 | Nothing -> Map.insert x (Set.singleton the_id) m0 36 | Just s0 -> Map.insert x (Set.insert the_id s0) m0 37 | 38 | data DEnv a = 39 | DEnv { df_roots :: Set Var } 40 | 41 | add_root :: Var -> State (DEnv a) () 42 | add_root x = modify (\s -> s { df_roots = Set.insert x (df_roots s) }) 43 | 44 | remove_unreachable :: (Show a,Ord a) 45 | => ConstraintSystem a 46 | -> ConstraintSystem a 47 | remove_unreachable cs 48 | = let m_constr = number_constraints cs 49 | m_var = gather_vars m_constr 50 | (var_set,_) 51 | = flip runState (DEnv Set.empty) 52 | $ do { mapM add_root (cs_out_vars cs) 53 | ; explore_vars m_constr m_var (cs_out_vars cs) 54 | ; env <- get 55 | ; return $ df_roots env 56 | } 57 | new_constrs = lookup_constraints m_constr m_var var_set 58 | in cs { cs_constraints = new_constrs } 59 | 60 | where lookup_constraints m_constr0 m_var0 var_set0 61 | = Set.foldl (\s0 x -> 62 | case Map.lookup x m_var0 of 63 | Nothing -> s0 64 | Just s_ids -> 65 | constrs_of_idset m_constr0 s_ids `Set.union` s0) 66 | Set.empty 67 | var_set0 68 | 69 | constrs_of_idset m_constr0 s_ids 70 | = Set.foldl (\s0 the_id -> 71 | case Map.lookup the_id m_constr0 of 72 | Nothing -> s0 73 | Just constr -> Set.insert constr s0) 74 | Set.empty 75 | s_ids 76 | 77 | 78 | explore_vars :: IntMap (Constraint a) -- ^ ConstraintId->Constraint 79 | -> IntMap (Set Int) -- ^ Var->Set ConstraintId 80 | -> [Var] -- ^ Roots to explore 81 | -> State (DEnv a) () 82 | explore_vars m_constr m_var roots = go roots 83 | where go [] = return () 84 | go (r : roots') 85 | = case Map.lookup r m_var of 86 | Nothing -> go roots' 87 | Just s_ids -> 88 | do { let vars = get_vars (Set.toList s_ids) 89 | ; new_roots <- filterM is_new_root vars 90 | ; mapM add_root new_roots 91 | ; go (new_roots ++ roots') 92 | } 93 | 94 | is_new_root :: Var -> State (DEnv a) Bool 95 | is_new_root x 96 | = do { env <- get 97 | ; return $ not (Set.member x $ df_roots env) 98 | } 99 | 100 | get_vars [] = [] 101 | get_vars (the_id : ids') 102 | = case Map.lookup the_id m_constr of 103 | Nothing -> get_vars ids' 104 | Just constr -> 105 | constraint_vars (Set.singleton constr) 106 | ++ get_vars ids' 107 | -------------------------------------------------------------------------------- /src/Errors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving 2 | , DeriveDataTypeable #-} 3 | 4 | module Errors where 5 | 6 | import Data.Typeable 7 | import Control.Exception 8 | 9 | newtype ErrMsg = ErrMsg { errMsg :: String } 10 | deriving (Typeable) 11 | 12 | instance Show ErrMsg where 13 | show (ErrMsg msg) = msg 14 | 15 | instance Exception ErrMsg 16 | 17 | fail_with :: ErrMsg -> a 18 | fail_with e = throw e 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /src/Expr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs 2 | , KindSignatures 3 | #-} 4 | 5 | module Expr 6 | ( Exp(..) 7 | , exp_binop 8 | , exp_seq 9 | , is_pure 10 | , var_of_exp 11 | , do_const_prop 12 | ) where 13 | 14 | import Common 15 | import Errors 16 | import Field 17 | 18 | import Control.Monad.State 19 | import Data.IntMap.Lazy (IntMap) 20 | import qualified Data.IntMap.Lazy as IntMap 21 | 22 | data Exp :: * -> * where 23 | EVar :: Var -> Exp a 24 | EVal :: Field a => a -> Exp a 25 | EUnop :: UnOp -> Exp a -> Exp a 26 | EBinop :: Op -> [Exp a] -> Exp a 27 | EIf :: Exp a -> Exp a -> Exp a -> Exp a 28 | EAssert :: Exp a -> Exp a -> Exp a 29 | ESeq :: [Exp a] -> Exp a 30 | EUnit :: Exp a 31 | 32 | instance Eq a => Eq (Exp a) where 33 | EVar x == EVar y = x == y 34 | EVal a == EVal b = a == b 35 | EUnop op e1 == EUnop op' e1' 36 | = op == op' && e1 == e1' 37 | EBinop op es == EBinop op' es' 38 | = op == op' && es == es' 39 | EIf e e1 e2 == EIf e' e1' e2' 40 | = e == e' && e1 == e1' && e2 == e2' 41 | EAssert e1 e2 == EAssert e1' e2' 42 | = e1 == e1' && e2 == e2' 43 | ESeq es == ESeq es' = es == es' 44 | EUnit == EUnit = True 45 | _ == _ = False 46 | 47 | var_of_exp :: Show a => Exp a -> Var 48 | var_of_exp e = case e of 49 | EVar x -> x 50 | _ -> fail_with $ ErrMsg ("var_of_exp: expected variable: " ++ show e) 51 | 52 | -- |Smart constructor for EBinop, ensuring all expressions (involving 53 | -- associative operations) are flattened to top level. 54 | exp_binop :: Op -> Exp a -> Exp a -> Exp a 55 | exp_binop op e1 e2 56 | = case (e1,e2) of 57 | (EBinop op1 l1,EBinop op2 l2) 58 | | op1==op2 && op2==op && is_assoc op 59 | -> EBinop op (l1++l2) 60 | 61 | (EBinop op1 l1,_) 62 | | op1==op && is_assoc op 63 | -> EBinop op (l1++[e2]) 64 | 65 | (_,EBinop op2 l2) 66 | | op2==op && is_assoc op 67 | -> EBinop op (e1 : l2) 68 | 69 | (_,_) -> EBinop op [e1,e2] 70 | 71 | -- |Smart constructor for sequence, ensuring all expressions are 72 | -- flattened to top level. 73 | exp_seq :: Exp a -> Exp a -> Exp a 74 | exp_seq e1 e2 75 | = case (e1,e2) of 76 | (ESeq l1,ESeq l2) -> ESeq (l1 ++ l2) 77 | (ESeq l1,_) -> ESeq (l1 ++ [e2]) 78 | (_,ESeq l2) -> ESeq (e1 : l2) 79 | (_,_) -> ESeq [e1, e2] 80 | 81 | is_pure :: Exp a -> Bool 82 | is_pure e 83 | = case e of 84 | EVar _ -> True 85 | EVal _ -> True 86 | EUnop _ e1 -> is_pure e1 87 | EBinop _ es -> all is_pure es 88 | EIf b e1 e2 -> is_pure b && is_pure e1 && is_pure e2 89 | EAssert _ _ -> False 90 | ESeq es -> all is_pure es 91 | EUnit -> True 92 | 93 | const_prop :: Field a => Exp a -> State (IntMap a) (Exp a) 94 | const_prop e 95 | = case e of 96 | EVar x -> lookup_var x 97 | EVal _ -> return e 98 | EUnop op e1 -> 99 | do { e1' <- const_prop e1 100 | ; return $ EUnop op e1' 101 | } 102 | EBinop op es -> 103 | do { es' <- mapM const_prop es 104 | ; return $ EBinop op es' 105 | } 106 | EIf e1 e2 e3 -> 107 | do { e1' <- const_prop e1 108 | ; e2' <- const_prop e2 109 | ; e3' <- const_prop e3 110 | ; return $ EIf e1' e2' e3' 111 | } 112 | EAssert (EVar x) (EVal c) -> add_bind (x,c) 113 | EAssert e1 e2 -> 114 | do { e1' <- const_prop e1 115 | ; e2' <- const_prop e2 116 | ; return $ EAssert e1' e2' 117 | } 118 | ESeq es -> 119 | do { es' <- mapM const_prop es 120 | ; return $ ESeq es' 121 | } 122 | EUnit -> return EUnit 123 | 124 | where lookup_var :: Field a => Int -> State (IntMap a) (Exp a) 125 | lookup_var x0 126 | = gets (\m -> case IntMap.lookup x0 m of 127 | Nothing -> EVar x0 128 | Just c -> EVal c) 129 | add_bind :: Field a => (Int,a) -> State (IntMap a) (Exp a) 130 | add_bind (x0,c0) 131 | = do { modify (IntMap.insert x0 c0) 132 | ; return EUnit 133 | } 134 | 135 | do_const_prop :: Field a => Exp a -> Exp a 136 | do_const_prop e = fst $ runState (const_prop e) IntMap.empty 137 | 138 | instance Show a => Show (Exp a) where 139 | show (EVar x) = "var " ++ show x 140 | show (EVal c) = show c 141 | show (EUnop op e1) = show op ++ show e1 142 | show (EBinop op es) = go es 143 | where go [] = "" 144 | go (e1 : []) = show e1 145 | go (e1 : es') = show e1 ++ show op ++ go es' 146 | show (EIf b e1 e2) 147 | = "if " ++ show b ++ " then " ++ show e1 ++ " else " ++ show e2 148 | show (EAssert e1 e2) = show e1 ++ " := " ++ show e2 149 | show (ESeq es) = "(" ++ go es ++ ")" 150 | where go [] = "" 151 | go (e1 : []) = show e1 152 | go (e1 : es') = show e1 ++ "; " ++ go es' 153 | show EUnit = "()" 154 | 155 | -------------------------------------------------------------------------------- /src/Field.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs,TypeSynonymInstances,FlexibleInstances #-} 2 | 3 | module Field where 4 | 5 | import Data.Ratio 6 | 7 | import Errors 8 | 9 | class (Show a,Eq a,Ord a) => Field a where 10 | zero :: a 11 | one :: a 12 | add :: a -> a -> a 13 | mult :: a -> a -> a 14 | neg :: a -> a 15 | inv :: a -> Maybe a 16 | 17 | instance Field Rational where 18 | zero = 0 19 | one = 1 20 | add = (+) 21 | mult = (*) 22 | neg = \n -> -n 23 | inv = \n -> if n == 0 then Nothing else Just $ denominator n % numerator n 24 | 25 | field_p :: Integer 26 | field_p = 21888242871839275222246405745257275088548364400416034343698204186575808495617 27 | 28 | -- Citation: http://rosettacode.org/wiki/Modular_inverse#Haskell 29 | -- License: http://www.gnu.org/licenses/fdl-1.2.html 30 | -- Extended Euclidean algorithm. Given non-negative a and b, return x, y and g 31 | -- such that ax + by = g, where g = gcd(a,b). Note that x or y may be negative. 32 | gcd_ext :: Integer -> Integer -> (Integer,Integer,Integer) 33 | gcd_ext a 0 = (1, 0, a) 34 | gcd_ext a b 35 | = let (q, r) = a `quotRem` b 36 | (s, t, g) = gcd_ext b r 37 | in (t, s - q * t, g) 38 | 39 | -- Given a and m, return Just x such that ax = 1 mod m. If there is no such x 40 | -- return Nothing. 41 | mod_inv :: Integer -> Integer -> Maybe Integer 42 | mod_inv a m 43 | = let (i, _, g) = gcd_ext a m 44 | in if g == 1 then Just (mkPos i) else Nothing 45 | where mkPos x = if x < 0 then x + m else x 46 | -- /End cited code/ 47 | 48 | newtype IntP = IntP { unIntP :: Integer } 49 | deriving ( Ord 50 | , Eq 51 | ) 52 | 53 | instance Show IntP where 54 | show (IntP i) = show i 55 | 56 | int_p :: Integer -> IntP 57 | int_p i 58 | = if i >= field_p then 59 | fail_with $ ErrMsg (show i ++ " exceeds field size") 60 | else IntP $ i `mod` field_p 61 | 62 | -- | The finite field of integers mod 'field_p'. 63 | instance Field IntP where 64 | zero = int_p 0 65 | one = int_p 1 66 | add = \n m -> int_p $ (unIntP n + unIntP m) `mod` field_p 67 | mult = \n m -> int_p $ (unIntP n * unIntP m) `mod` field_p 68 | neg = \n -> int_p $ -(unIntP n) `mod` field_p 69 | inv = \n -> case mod_inv (unIntP n) field_p of 70 | Nothing -> Nothing 71 | Just n' -> Just $ int_p n' 72 | 73 | -------------------------------------------------------------------------------- /src/Games.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax 2 | , DataKinds 3 | , GADTs 4 | , KindSignatures 5 | , RankNTypes 6 | , ScopedTypeVariables 7 | #-} 8 | 9 | module Games where 10 | 11 | import Prelude hiding 12 | ( (>>) 13 | , (>>=) 14 | , (+) 15 | , (-) 16 | , (*) 17 | , (/) 18 | , (&&) 19 | , return 20 | , fromRational 21 | , negate 22 | ) 23 | 24 | import Data.Typeable 25 | 26 | import Errors 27 | import Syntax 28 | import SyntaxMonad 29 | import TExpr 30 | import Toplevel 31 | 32 | {--------------------------------------------------------- 33 | See Vytiniotis & Kennedy, 34 | "Functional Pearl: Every Bit Counts", ICFP 2010 35 | ---------------------------------------------------------} 36 | 37 | data ISO (t :: Ty) (s :: Ty) = 38 | Iso { to :: TExp t Rational -> Comp s 39 | , from :: TExp s Rational -> Comp t 40 | } 41 | 42 | data Game :: Ty -> * where 43 | Single :: forall (s :: Ty) (t :: Ty). 44 | ( Typeable s 45 | , Typeable t 46 | ) 47 | => ISO t s -> Game t 48 | Split :: forall (t1 :: Ty) (t2 :: Ty) (t :: Ty). 49 | ( Typeable t1 50 | , Typeable t2 51 | , Typeable t 52 | , Zippable t1 53 | , Zippable t2 54 | , Zippable t 55 | , Derive t1 56 | , Derive t2 57 | ) 58 | => ISO t ('TSum t1 t2) -> Game t1 -> Game t2 -> Game t 59 | 60 | decode :: Game t -> Comp t 61 | decode (Single (Iso _ bld)) 62 | = do { x <- fresh_input 63 | ; bld x 64 | } 65 | decode (Split (Iso _ bld) g1 g2) 66 | = do { x <- fresh_input 67 | ; e1 <- decode g1 68 | ; e2 <- decode g2 69 | ; s1 <- inl e1 70 | ; s2 <- inr e2 71 | ; v1 <- bld s1 72 | ; v2 <- bld s2 73 | ; if return x then return v2 else return v1 74 | } 75 | 76 | field_game :: Game 'TField 77 | field_game = Single (Iso return return) 78 | 79 | bool_game :: Game 'TBool 80 | bool_game = Single (Iso (\be -> if return be then return 1.0 else return 0.0) 81 | (\te -> if return (zeq te) then return false else return true)) 82 | 83 | unit_game :: Game 'TUnit 84 | unit_game = Single (Iso (\_ -> return 1.0) (\_ -> return unit)) 85 | 86 | fail_game :: Typeable ty => Game ty 87 | fail_game = Single (Iso (\_ -> fail_with $ ErrMsg "fail-games can't encode") 88 | (\(_ :: TExp 'TField Rational) -> 89 | fail_with $ ErrMsg "fail-games can't decode")) 90 | 91 | sum_game :: ( Typeable t1 92 | , Typeable t2 93 | , Zippable t1 94 | , Zippable t2 95 | , Derive t1 96 | , Derive t2 97 | ) 98 | => Game t1 99 | -> Game t2 100 | -> Game ('TSum t1 t2) 101 | sum_game g1 g2 102 | = Split (Iso return return) g1 g2 103 | 104 | basic_game :: Game ('TSum 'TField 'TField) 105 | basic_game = sum_game field_game field_game 106 | 107 | basic_test :: Comp 'TField 108 | basic_test 109 | = do { s <- decode basic_game 110 | ; case_sum return return s 111 | } 112 | 113 | t1 = comp_interp basic_test [0,23,88] -- 23 114 | t2 = comp_interp basic_test [1,23,88] -- 88 115 | 116 | (+>) :: ( Typeable t 117 | , Typeable s 118 | , Zippable t 119 | , Zippable s 120 | ) 121 | => Game t -> ISO s t -> Game s 122 | (Single j) +> i = Single (i `seqI` j) 123 | (Split j g1 g2) +> i = Split (i `seqI` j) g1 g2 124 | 125 | idI :: ISO a a 126 | idI = Iso return return 127 | 128 | prodI :: ( Typeable a 129 | , Typeable b 130 | , Typeable c 131 | , Typeable d ) 132 | => ISO a b 133 | -> ISO c d 134 | -> ISO ('TProd a c) ('TProd b d) 135 | prodI (Iso f g) (Iso f' g') 136 | = Iso (\p -> do 137 | x1 <- fst_pair p 138 | x2 <- snd_pair p 139 | y1 <- f x1 140 | y2 <- f' x2 141 | pair y1 y2) 142 | (\p -> do 143 | x1 <- fst_pair p 144 | x2 <- snd_pair p 145 | y1 <- g x1 146 | y2 <- g' x2 147 | pair y1 y2) 148 | 149 | seqI :: Typeable b => ISO a b -> ISO b c -> ISO a c 150 | seqI (Iso f g) (Iso f' g') = Iso (\a -> f a >>= f') (\c -> g' c >>= g) 151 | 152 | prodLInputI :: ( Typeable a 153 | , Typeable b 154 | ) 155 | => ISO ('TProd a b) b 156 | prodLInputI 157 | = Iso snd_pair 158 | (\b -> do 159 | a <- fresh_input 160 | pair a b) 161 | 162 | prodLSumI :: ( Typeable a 163 | , Typeable b 164 | , Typeable c 165 | , Zippable a 166 | , Zippable b 167 | , Zippable c 168 | , Derive a 169 | , Derive b 170 | , Derive c 171 | ) 172 | => ISO ('TProd ('TSum b c) a) ('TSum ('TProd b a) ('TProd c a)) 173 | prodLSumI 174 | = Iso (\p -> do 175 | xbc <- fst_pair p 176 | xa <- snd_pair p 177 | case_sum 178 | (\xb -> do 179 | p' <- pair xb xa 180 | inl p') 181 | (\xc -> do 182 | p' <- pair xc xa 183 | inr p') 184 | xbc) 185 | (\s -> do 186 | case_sum 187 | (\pba -> do 188 | a <- snd_pair pba 189 | b <- fst_pair pba 190 | sb <- inl b 191 | pair sb a) 192 | (\pca -> do 193 | a <- snd_pair pca 194 | c <- fst_pair pca 195 | sc <- inr c 196 | pair sc a) 197 | s) 198 | 199 | prod_game :: ( Typeable b 200 | , Zippable a 201 | , Zippable b 202 | , Derive a 203 | , Derive b 204 | ) 205 | => Game a -> Game b -> Game ('TProd a b) 206 | prod_game (Single iso) g2 = g2 +> iso' 207 | where iso' = prodI iso idI `seqI` prodLInputI 208 | prod_game (Split iso g1a g1b) g2 209 | = Split iso' (prod_game g1a g2) (prod_game g1b g2) 210 | where iso' = prodI iso idI `seqI` prodLSumI 211 | 212 | basic_game2 :: Game ('TProd 'TField 'TField) 213 | basic_game2 = prod_game field_game field_game 214 | 215 | basic_test2 :: Comp 'TField 216 | basic_test2 217 | = do { p <- decode basic_game2 218 | ; fst_pair p 219 | } 220 | 221 | t3 = comp_interp basic_test2 [88,23] -- fst (23, 88) = 23 222 | 223 | basic_game3 :: Game ('TProd ('TProd 'TField 'TField) 'TField) 224 | basic_game3 225 | = prod_game (prod_game field_game field_game) 226 | field_game 227 | 228 | basic_test3 :: Comp 'TField 229 | basic_test3 230 | = do { p <- decode basic_game3 231 | ; p2 <- fst_pair p 232 | ; snd_pair p2 233 | } 234 | 235 | t4 = comp_interp basic_test3 [0,1,2] 236 | 237 | {--------------------------------------------------------- 238 | Generic Games 239 | ---------------------------------------------------------} 240 | 241 | class Gameable (a :: Ty) where 242 | mkGame :: Game a 243 | 244 | instance Gameable 'TField where 245 | mkGame = field_game 246 | 247 | instance Gameable 'TBool where 248 | mkGame = bool_game 249 | 250 | instance Gameable 'TUnit where 251 | mkGame = unit_game 252 | 253 | instance ( Typeable a 254 | , Typeable b 255 | , Zippable a 256 | , Zippable b 257 | , Derive a 258 | , Derive b 259 | , Gameable a 260 | , Gameable b 261 | ) 262 | => Gameable ('TProd a b) where 263 | mkGame = prod_game mkGame mkGame 264 | 265 | instance ( Typeable a 266 | , Typeable b 267 | , Zippable a 268 | , Zippable b 269 | , Derive a 270 | , Derive b 271 | , Gameable a 272 | , Gameable b 273 | ) 274 | => Gameable ('TSum a b) where 275 | mkGame = sum_game mkGame mkGame 276 | 277 | gdecode :: Gameable t => Comp t 278 | gdecode = decode mkGame 279 | 280 | 281 | 282 | 283 | 284 | 285 | -------------------------------------------------------------------------------- /src/Interp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving 2 | , GADTs 3 | #-} 4 | 5 | module Interp 6 | ( interp 7 | ) where 8 | 9 | import Data.IntMap ( IntMap ) 10 | import qualified Data.IntMap as IntMap 11 | import Control.Monad 12 | 13 | import Errors 14 | import Common 15 | import Field 16 | import TExpr 17 | 18 | type Env a = IntMap (Maybe a) 19 | 20 | newtype InterpM a b 21 | = InterpM { runInterpM :: Env a -> Either ErrMsg (Env a,b) } 22 | 23 | instance Monad (InterpM a) where 24 | (>>=) mf mg 25 | = InterpM (\rho -> case runInterpM mf rho of 26 | Left err -> Left err 27 | Right (rho',b) -> runInterpM (mg b) rho') 28 | return b 29 | = InterpM (\rho -> Right (rho,b)) 30 | 31 | instance Functor (InterpM a) where 32 | fmap f mg = return f `ap` mg 33 | 34 | instance Applicative (InterpM a) where 35 | pure = return 36 | mf <*> ma = ap mf ma 37 | 38 | raise_err err 39 | = InterpM (\_ -> Left err) 40 | 41 | add_binds binds 42 | = InterpM (\rho -> Right (IntMap.union (IntMap.fromList binds) rho,Nothing)) 43 | 44 | lookup_var x 45 | = InterpM (\rho -> case IntMap.lookup x rho of 46 | Nothing -> Left $ ErrMsg $ "unbound var " ++ show x 47 | ++ " in environment " ++ show rho 48 | Just v -> Right (rho,v)) 49 | 50 | 51 | field_of_bool :: Field a => Bool -> a 52 | field_of_bool b = if b then one else zero 53 | 54 | case_of_field :: Field a => Maybe a -> (Maybe Bool -> InterpM a b) -> InterpM a b 55 | case_of_field Nothing f = f Nothing 56 | case_of_field (Just v) f 57 | = if v == zero then f $ Just False 58 | else if v == one then f $ Just True 59 | else raise_err $ ErrMsg $ "expected " ++ show v ++ " to be boolean" 60 | 61 | bool_of_field :: Field a => a -> InterpM a Bool 62 | bool_of_field v 63 | = case_of_field (Just v) 64 | (\mb -> case mb of 65 | Nothing -> raise_err $ ErrMsg "internal error in bool_of_field" 66 | Just b -> return b) 67 | 68 | interp_unop :: Field a 69 | => TUnop ty1 ty2 -> TExp ty1 a -> InterpM a (Maybe a) 70 | interp_unop op e2 71 | = do { mv2 <- interp_texp e2 72 | ; case mv2 of 73 | Nothing -> return Nothing 74 | Just v2 -> 75 | case op of 76 | TUnop ZEq -> return $ Just $ field_of_bool (v2 == zero) 77 | } 78 | 79 | interp_binop :: Field a 80 | => TOp ty1 ty2 ty3 -> TExp ty1 a -> TExp ty2 a -> InterpM a (Maybe a) 81 | interp_binop op e1 e2 82 | = do { mv1 <- interp_texp e1 83 | ; mv2 <- interp_texp e2 84 | ; case (mv1,mv2) of 85 | (Nothing,_) -> return Nothing 86 | (_,Nothing) -> return Nothing 87 | (Just v1,Just v2) -> 88 | do { v <- interp_val_binop v1 v2 89 | ; return $ Just v 90 | } 91 | } 92 | where interp_val_binop v1 v2 93 | = case op of 94 | TOp Add -> return $ v1 `add` v2 95 | TOp Sub -> return $ v1 `add` (neg v2) 96 | TOp Mult -> return $ v1 `mult` v2 97 | TOp Div -> 98 | case inv v2 of 99 | Nothing -> raise_err $ ErrMsg $ show v2 ++ " not invertible" 100 | Just v2' -> return $ v1 `mult` v2' 101 | TOp And -> interp_boolean_binop v1 v2 102 | TOp Or -> interp_boolean_binop v1 v2 103 | TOp XOr -> interp_boolean_binop v1 v2 104 | TOp BEq -> interp_boolean_binop v1 v2 105 | TOp Eq -> return $ field_of_bool $ v1 == v2 106 | 107 | interp_boolean_binop v1 v2 108 | = do { b1 <- bool_of_field v1 109 | ; b2 <- bool_of_field v2 110 | ; let b = case op of 111 | TOp And -> b1 && b2 112 | TOp Or -> b1 || b2 113 | TOp XOr -> (b1 && not b2) || (b2 && not b1) 114 | TOp BEq -> b1 == b2 115 | _ -> fail_with $ ErrMsg "internal error in interp_binop" 116 | in return $ field_of_bool b 117 | } 118 | 119 | interp_val :: Field a => Val ty a -> InterpM a a 120 | interp_val v 121 | = case v of 122 | VField v' -> return v' 123 | VTrue -> return $ field_of_bool True 124 | VFalse -> return $ field_of_bool False 125 | VUnit -> return one 126 | VLoc _ -> raise_err $ ErrMsg "location in source program" 127 | 128 | interp_texp :: ( Eq a 129 | , Show a 130 | , Field a 131 | ) 132 | => TExp ty1 a 133 | -> InterpM a (Maybe a) 134 | interp_texp e 135 | = case e of 136 | TEVar (TVar x) -> lookup_var x 137 | TEVal v -> interp_val v >>= return . Just 138 | TEUnop op e2 -> interp_unop op e2 139 | TEBinop op e1 e2 -> interp_binop op e1 e2 140 | TEIf eb e1 e2 -> 141 | do { mv <- interp_texp eb 142 | ; case_of_field mv 143 | (\mb -> case mb of 144 | Nothing -> return Nothing 145 | Just b -> if b then interp_texp e1 else interp_texp e2) 146 | } 147 | TEAssert e1 e2 -> 148 | case (e1,e2) of 149 | (TEVar (TVar x),_) -> 150 | do { v2 <- interp_texp e2 151 | ; add_binds [(x,v2)] 152 | } 153 | (_,_) -> raise_err $ ErrMsg $ show e1 ++ " not a variable" 154 | TESeq e1 e2 -> 155 | do { interp_texp e1 156 | ; interp_texp e2 157 | } 158 | TEBot -> return Nothing 159 | 160 | interp rho e = runInterpM (interp_texp e) $ IntMap.map Just rho 161 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | GHC=ghc 2 | 3 | GHC_OPTIONS=-Werror -Wall \ 4 | -fno-warn-missing-signatures \ 5 | -fno-warn-unused-do-bind \ 6 | -funbox-strict-fields \ 7 | -rtsopts \ 8 | -threaded \ 9 | -O \ 10 | -optc-O3 11 | 12 | GHC_PROF_OPTIONS=-prof -fprof-auto 13 | 14 | HADDOCK=haddock 15 | 16 | HADDOCK_OPTS=-o doc --html 17 | 18 | all: 19 | $(GHC) $(GHC_OPTIONS) Main.hs 20 | 21 | test: all 22 | ./Main 23 | 24 | doc: 25 | $(HADDOCK) $(HADDOCK_OPTS) *.hs 26 | 27 | debug: 28 | $(GHC) Main.hs 29 | 30 | prof: 31 | $(GHC) $(GHC_OPTIONS) $(GHC_PROF_OPTIONS) Main.hs 32 | 33 | clean: 34 | rm *.o *.hi *~ main.exe doc/* 35 | -------------------------------------------------------------------------------- /src/Poly.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs,TypeSynonymInstances,FlexibleInstances #-} 2 | 3 | module Poly where 4 | 5 | import qualified Data.IntMap.Lazy as Map 6 | 7 | import Common 8 | import Field 9 | 10 | data Poly a where 11 | Poly :: Field a => Assgn a -> Poly a 12 | 13 | instance Show a => Show (Poly a) where 14 | show (Poly m) = show m 15 | 16 | -- | The constant polynomial equal 'c' 17 | const_poly :: Field a => a -> Poly a 18 | const_poly c = Poly $ Map.insert (-1) c Map.empty 19 | 20 | -- | The polynomial equal variable 'x' 21 | var_poly :: Field a 22 | => (a,Var) -- ^ Variable, with coeff 23 | -> Poly a -- ^ Resulting polynomial 24 | var_poly (coeff,x) 25 | = Poly $ Map.insert x coeff Map.empty 26 | -------------------------------------------------------------------------------- /src/R1CS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | module R1CS 4 | ( Field 5 | , Poly 6 | , Var 7 | , R1C(..) 8 | , R1CS(..) 9 | , sat_r1cs 10 | , num_constraints 11 | ) where 12 | 13 | import qualified Data.IntMap.Lazy as Map 14 | import Control.Parallel.Strategies 15 | 16 | import Common 17 | import Errors 18 | import Field 19 | import Poly 20 | 21 | ---------------------------------------------------------------- 22 | -- Rank-1 Constraint Systems -- 23 | ---------------------------------------------------------------- 24 | 25 | data R1C a where 26 | R1C :: Field a => (Poly a, Poly a, Poly a) -> R1C a 27 | 28 | instance Show a => Show (R1C a) where 29 | show (R1C (aV,bV,cV)) = show aV ++ "*" ++ show bV ++ "==" ++ show cV 30 | 31 | data R1CS a = 32 | R1CS { r1cs_clauses :: [R1C a] 33 | , r1cs_num_vars :: Int 34 | , r1cs_in_vars :: [Var] 35 | , r1cs_out_vars :: [Var] 36 | , r1cs_gen_witness :: Assgn a -> Assgn a 37 | } 38 | 39 | instance Show a => Show (R1CS a) where 40 | show (R1CS cs nvs ivs ovs _) = show (cs,nvs,ivs,ovs) 41 | 42 | num_constraints :: R1CS a -> Int 43 | num_constraints = length . r1cs_clauses 44 | 45 | -- sat_r1c: Does witness 'w' satisfy constraint 'c'? 46 | sat_r1c :: Field a => Assgn a -> R1C a -> Bool 47 | sat_r1c w c 48 | | R1C (aV, bV, cV) <- c 49 | = inner aV w `mult` inner bV w == inner cV w 50 | where inner :: Field a => Poly a -> Assgn a -> a 51 | inner (Poly v) w' 52 | = let c0 = Map.findWithDefault zero (-1) v 53 | in Map.foldlWithKey (f w') c0 v 54 | 55 | f w' acc v_key v_val 56 | = (v_val `mult` Map.findWithDefault zero v_key w') `add` acc 57 | 58 | -- sat_r1cs: Does witness 'w' satisfy constraint set 'cs'? 59 | sat_r1cs :: Field a => Assgn a -> R1CS a -> Bool 60 | sat_r1cs w cs = all id $ is_sat (r1cs_clauses cs) 61 | where is_sat cs0 = map g cs0 `using` parListChunk (chunk_sz cs0) rseq 62 | num_chunks = 32 63 | chunk_sz cs0 64 | = truncate $ (fromIntegral (length cs0) :: Rational) / num_chunks 65 | g c = if sat_r1c w c then True 66 | else fail_with 67 | $ ErrMsg ("witness\n " ++ show w 68 | ++ "\nfailed to satisfy constraint\n " ++ show c 69 | ++ "\nin R1CS\n " ++ show cs) 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | -------------------------------------------------------------------------------- /src/Serialize.hs: -------------------------------------------------------------------------------- 1 | module Serialize where 2 | 3 | import qualified Data.IntMap.Lazy as Map 4 | import Data.Ratio 5 | 6 | import Common 7 | import Errors 8 | import Field 9 | import Poly 10 | import R1CS 11 | 12 | flatten_rat :: Rational -> IntP 13 | flatten_rat r 14 | = let a = numerator r 15 | b = denominator r 16 | in case mod_inv b field_p of 17 | Nothing -> 18 | fail_with $ ErrMsg ("expected " ++ show b ++ " to be invertible") 19 | Just b_inv -> int_p (a * b_inv) 20 | 21 | serialize_assgn :: Assgn Rational -> String 22 | serialize_assgn m 23 | = let binds = Map.toAscList $ Map.mapKeys (+ 1) m 24 | in concat 25 | $ map (\(_,v) -> show (flatten_rat v) ++ "\n") binds 26 | 27 | serialize_poly :: Poly Rational -> String 28 | serialize_poly p = case p of 29 | Poly m -> 30 | let size = Map.size m 31 | binds = Map.toList $ Map.mapKeys (+ 1) m 32 | string_binds = map (\(k,v) -> show k ++ "\n" 33 | ++ show (flatten_rat v) ++ "\n") 34 | binds 35 | in show size ++ "\n" 36 | ++ concat string_binds 37 | 38 | serialize_r1c :: R1C Rational -> String 39 | serialize_r1c cons = case cons of 40 | R1C (a, b, c) -> concat $ map serialize_poly [a, b, c] 41 | 42 | serialize_r1cs :: R1CS Rational -> String 43 | serialize_r1cs cs 44 | = let r1c_strings :: String 45 | r1c_strings = concat (map serialize_r1c (r1cs_clauses cs)) 46 | num_in_vars = length $ r1cs_in_vars cs 47 | in show num_in_vars ++ "\n" 48 | ++ show (r1cs_num_vars cs - num_in_vars) ++ "\n" 49 | ++ show (length $ r1cs_clauses cs) ++ "\n" 50 | ++ r1c_strings 51 | -------------------------------------------------------------------------------- /src/SimplMonad.hs: -------------------------------------------------------------------------------- 1 | module SimplMonad 2 | ( SEnv(..) 3 | , unite_vars 4 | , bind_var 5 | , root_of_var 6 | , bind_of_var 7 | , assgn_of_vars 8 | , SolveMode(..) 9 | , solve_mode_flag 10 | ) where 11 | 12 | import qualified Data.IntMap.Lazy as Map 13 | import Control.Monad.State 14 | 15 | import Field 16 | import Common 17 | import UnionFind 18 | 19 | ---------------------------------------------------------------- 20 | -- Simplifier State Monad -- 21 | ---------------------------------------------------------------- 22 | 23 | data SolveMode = UseMagic | JustSimplify 24 | deriving Show 25 | 26 | data SEnv a = 27 | SEnv { eqs :: UnionFind a -- ^ Equalities among variables, 28 | -- together with a partial map from variables 29 | -- to constants (hidden inside the "UnionFind" 30 | -- data structure). 31 | , solve_mode :: SolveMode -- ^ Use Magic only in 'solve_mode'. 32 | -- In simplify mode, only forced equalities 33 | -- should be propagated. 34 | } 35 | deriving Show 36 | 37 | -- | Unify variables 'x' and 'y'. 38 | unite_vars :: Field a => Var -> Var -> State (SEnv a) () 39 | unite_vars x y 40 | = do { modify (\senv -> senv { eqs = unite (eqs senv) x y }) } 41 | 42 | -- | Bind variable 'x' to 'c'. 43 | bind_var :: Field a => (Var,a) -> State (SEnv a) () 44 | bind_var (x,c) 45 | = do { rx <- root_of_var x 46 | ; senv <- get 47 | ; let eqs' = (eqs senv) { extras = Map.insert rx c (extras $ eqs senv) } 48 | ; put $ senv { eqs = eqs' } 49 | } 50 | 51 | -- | Return 'x''s root (the representative of its equivalence class). 52 | root_of_var :: Field a => Var -> State (SEnv a) Var 53 | root_of_var x 54 | = do { senv <- get 55 | ; let (rx,eqs') = root (eqs senv) x 56 | ; put (senv { eqs = eqs'}) 57 | ; return rx 58 | } 59 | 60 | -- | Return the binding associated with variable 'x', or 'x''s root 61 | -- if no binding exists. 62 | bind_of_var :: Field a => Var -> State (SEnv a) (Either Var a) 63 | bind_of_var x 64 | = do { rx <- root_of_var x 65 | ; senv <- get 66 | ; case extra_of (eqs senv) rx of 67 | Nothing -> return $ Left rx 68 | Just c -> return $ Right c 69 | } 70 | 71 | -- | Construct a partial assignment from 'vars' to field elements. 72 | assgn_of_vars :: Field a => [Var] -> State (SEnv a) (Assgn a) 73 | assgn_of_vars vars 74 | = do { binds <- mapM bind_of_var vars 75 | ; return 76 | $ Map.fromList 77 | $ concatMap (\(x,ec) -> case ec of 78 | Left _ -> [] 79 | Right c -> [(x,c)]) 80 | $ zip vars binds 81 | } 82 | 83 | -- | Are we in solve mode? 84 | solve_mode_flag :: State (SEnv a) Bool 85 | solve_mode_flag 86 | = do { env <- get 87 | ; case solve_mode env of 88 | UseMagic -> return True 89 | JustSimplify -> return False 90 | } 91 | -------------------------------------------------------------------------------- /src/Simplify.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns 2 | #-} 3 | 4 | module Simplify 5 | ( do_simplify 6 | ) where 7 | 8 | import Data.List (foldl') 9 | import qualified Data.Set as Set 10 | import Control.Monad.State 11 | 12 | import Common 13 | import Errors 14 | import Field 15 | import Constraints 16 | import UnionFind 17 | import SimplMonad 18 | 19 | ---------------------------------------------------------------- 20 | -- Substitution -- 21 | ---------------------------------------------------------------- 22 | 23 | -- | Normalize constraint 'constr', by substituting roots/constants 24 | -- for the variables that appear in the constraint. Note that, when 25 | -- normalizing a multiplicative constraint, it may be necessary to 26 | -- convert it into an additive constraint. 27 | subst_constr :: Field a 28 | => Constraint a 29 | -> State (SEnv a) (Constraint a) 30 | subst_constr !constr = case constr of 31 | CMagic !_ !xs !mf -> 32 | do { solve <- solve_mode_flag 33 | ; if solve then 34 | do { b <- mf xs 35 | ; if b then return $ cadd zero [] 36 | else return constr 37 | } 38 | else return constr 39 | } 40 | 41 | CAdd a m -> 42 | do { -- Variables resolvable to constants 43 | consts' <- mapM (\(x,a0) -> 44 | do { var_or_a <- bind_of_var x 45 | ; case var_or_a of 46 | Left _ -> return [] 47 | Right a' -> return $! [(x,a0 `mult` a')] 48 | }) 49 | $! asList m 50 | ; let consts = concat consts' 51 | ; let const_keys = map fst consts 52 | ; let const_vals = map snd consts 53 | -- The new constant folding in all constant constraint variables 54 | ; let new_const = foldl' add a const_vals 55 | -- The linear combination minus 56 | -- (1) Terms whose variables resolve to constants, and 57 | -- (2) Terms with coeff 0. 58 | ; let less_consts 59 | = filter (\(k,v) -> not (elem k const_keys) && v/=zero) 60 | $! asList m 61 | -- The new linear combination: 'less_consts' with all variables 62 | -- replaced by their roots. 63 | ; new_map <- mapM (\(x,a0) -> 64 | do { rx <- root_of_var x 65 | ; return $! (rx,a0) 66 | }) 67 | less_consts 68 | ; return $! cadd new_const new_map 69 | } 70 | 71 | CMult !(c,x) !(d,y) !ez -> 72 | do { bx <- bind_of_var x 73 | ; by <- bind_of_var y 74 | ; bz <- bind_of_term ez 75 | ; case (bx,by,bz) of 76 | (Left rx,Left ry,Left (e,rz)) -> 77 | return 78 | $! CMult (c,rx) (d,ry) (e,Just rz) 79 | (Left rx,Left ry,Right e) -> 80 | return 81 | $! CMult (c,rx) (d,ry) (e,Nothing) 82 | (Left rx,Right d0,Left (e,rz)) -> 83 | return 84 | $! cadd zero [(rx,c `mult` d `mult` d0),(rz,neg e)] 85 | (Left rx,Right d0,Right e) -> 86 | return 87 | $! cadd (neg e) [(rx,c `mult` d `mult` d0)] 88 | (Right c0,Left ry,Left (e,rz)) -> 89 | return 90 | $! cadd zero [(ry,c0 `mult` c `mult` d),(rz,neg e)] 91 | (Right c0,Left ry,Right e) -> 92 | return 93 | $! cadd (neg e) [(ry,c0 `mult` c `mult` d)] 94 | (Right c0,Right d0,Left (e,rz)) -> 95 | return 96 | $! cadd (c `mult` c0 `mult` d `mult` d0) [(rz,neg e)] 97 | (Right c0,Right d0,Right e) -> 98 | return 99 | $! cadd (c `mult` c0 `mult` d `mult` d0 `add` (neg e)) [] 100 | } 101 | 102 | where bind_of_term (e,Nothing) 103 | = return $! Right e 104 | bind_of_term (e,Just z) 105 | = do { var_or_a <- bind_of_var z 106 | ; case var_or_a of 107 | Left rz -> return $! Left (e,rz) 108 | Right e0 -> return $! Right (e `mult` e0) 109 | } 110 | 111 | 112 | 113 | ---------------------------------------------------------------- 114 | -- Constraint Set Minimization -- 115 | ---------------------------------------------------------------- 116 | 117 | -- | Is 'constr' a tautology? 118 | is_taut :: Field a 119 | => Constraint a 120 | -> State (SEnv a) Bool 121 | is_taut constr 122 | = case constr of 123 | CAdd _ (CoeffList []) -> return True 124 | CAdd _ (CoeffList (_ : _)) -> return False 125 | CMult _ _ _ -> return False 126 | CMagic _ xs mf -> mf xs 127 | 128 | -- | Remove tautologous constraints. 129 | remove_tauts :: Field a => [Constraint a] -> State (SEnv a) [Constraint a] 130 | remove_tauts sigma 131 | = do { sigma_taut <- 132 | mapM (\t -> do { t' <- subst_constr t 133 | ; b <- is_taut t' 134 | ; return (b,t') }) sigma 135 | ; return $ map snd $ filter (not . fst) sigma_taut 136 | } 137 | 138 | -- | Learn bindings and variable equalities from constraint 'constr'. 139 | learn :: Field a 140 | => Constraint a 141 | -> State (SEnv a) () 142 | learn = go 143 | where go (CAdd a (CoeffList [(x,c)])) 144 | = if c == zero then return () 145 | else case inv c of 146 | Nothing -> 147 | fail_with 148 | $ ErrMsg (show c ++ " not invertible") 149 | Just c' -> bind_var (x,neg a `mult` c') 150 | 151 | go (CAdd a (CoeffList [(x,c),(y,d)])) 152 | | a==zero 153 | = if c == neg d then unite_vars x y else return () 154 | 155 | go (CAdd _ _) 156 | | otherwise 157 | = return () 158 | 159 | go _ | otherwise = return () 160 | 161 | 162 | do_simplify :: Field a 163 | => Bool -- ^ Solve mode? If 'True', use Magic. 164 | -> Assgn a -- ^ Initial variable assignment 165 | -> ConstraintSystem a -- ^ Constraint set to be simplified 166 | -> (Assgn a,ConstraintSystem a) 167 | -- ^ Resulting assignment, simplified constraint set 168 | do_simplify in_solve_mode env cs 169 | -- NOTE: Pinned vars include: 170 | -- - input vars 171 | -- - output vars 172 | -- - magic vars (those that appear in magic constraints, used to 173 | -- resolve nondeterministic inputs) 174 | -- Pinned vars are never optimized away. 175 | = let pinned_vars = cs_in_vars cs ++ cs_out_vars cs ++ magic_vars (cs_constraints cs) 176 | do_solve = if in_solve_mode then UseMagic else JustSimplify 177 | new_state = SEnv (new_uf { extras = env }) do_solve 178 | in fst $ runState (go pinned_vars) new_state 179 | where go pinned_vars 180 | = do { sigma' <- simplify pinned_vars $ cs_constraints cs 181 | -- NOTE: In the next line, it's OK that 'pinned_vars' 182 | -- may overlap with 'constraint_vars cs'. 183 | -- 'assgn_of_vars' might do a bit of duplicate 184 | -- work (to look up the same key more than once). 185 | ; assgn <- assgn_of_vars 186 | $ pinned_vars 187 | ++ constraint_vars (cs_constraints cs) 188 | ; return (assgn,cs { cs_constraints = sigma' }) 189 | } 190 | magic_vars cs0 191 | = Set.fold (\c0 acc -> 192 | case c0 of 193 | CMagic _ xs _ -> xs ++ acc 194 | _ -> acc 195 | ) [] cs0 196 | 197 | simplify :: Field a 198 | => [Var] 199 | -> ConstraintSet a 200 | -> State (SEnv a) (ConstraintSet a) 201 | simplify pinned_vars sigma 202 | = do { sigma' <- simplify_rec sigma 203 | ; sigma_subst <- mapM subst_constr $ Set.toList sigma' 204 | ; sigma_no_tauts <- remove_tauts sigma_subst 205 | ; sigma_pinned <- add_pin_eqns sigma_no_tauts 206 | ; return $ Set.fromList sigma_pinned 207 | } 208 | 209 | where -- NOTE: We handle pinned variables 'x' as follows: 210 | -- (1) Look up the term associated with 211 | -- the pinned variable, if any (call it 't'). 212 | -- (2) If there is no such term (other than 'x' itself), 213 | -- do nothing (clauses containing the pinned 214 | -- variable must still contain the pinned variable). 215 | -- (3) Otherwise, introduce a new equation 'x = t'. 216 | add_pin_eqns sigma0 217 | = do { pinned_terms <- 218 | mapM (\x -> do { var_or_a <- bind_of_var x 219 | ; return (x,var_or_a) 220 | }) pinned_vars 221 | ; let pin_eqns 222 | = map (\(x,var_or_a) -> 223 | case var_or_a of 224 | Left rx -> 225 | cadd zero [(x,one),(rx,neg one)] 226 | Right c -> 227 | cadd (neg c) [(x,one)]) 228 | $ filter (\(x,rx) -> Left x /= rx) pinned_terms 229 | ; return $ pin_eqns ++ sigma0 230 | } 231 | 232 | simplify_rec :: Field a 233 | => ConstraintSet a -- ^ Initial constraint set 234 | -> State (SEnv a) (ConstraintSet a) 235 | -- ^ Resulting simplified constraint set 236 | simplify_rec sigma 237 | = do { sigma' <- simplify_once sigma 238 | ; if Set.size sigma' < Set.size sigma then 239 | simplify_rec sigma' 240 | else if Set.difference sigma sigma' 241 | `Set.isSubsetOf` Set.empty then return sigma' 242 | else simplify_rec sigma' 243 | } 244 | where simplify_once :: Field a 245 | => ConstraintSet a -- ^ Initial constraint set 246 | -> State (SEnv a) (ConstraintSet a) 247 | -- ^ Resulting simplified constraint set 248 | simplify_once sigma0 249 | = do { sigma2 <- go Set.empty sigma0 250 | ; sigma' <- remove_tauts (Set.toList sigma2) 251 | ; return $ Set.fromList sigma' 252 | } 253 | 254 | go ws us 255 | | Set.size us == 0 256 | = return ws 257 | go ws us 258 | | otherwise 259 | = let (given,us') = choose us 260 | in do { given' <- subst_constr given 261 | ; given_taut <- is_taut given' 262 | ; if given_taut then go ws us' 263 | else do 264 | learn given' 265 | let ws' = Set.insert given' ws 266 | go ws' us' 267 | } 268 | 269 | -- NOTE: Assumes input set is nonempty 270 | choose s = Set.deleteFindMin s 271 | 272 | 273 | 274 | 275 | -------------------------------------------------------------------------------- /src/Solve.hs: -------------------------------------------------------------------------------- 1 | module Solve 2 | ( solve 3 | ) where 4 | 5 | import Data.Maybe 6 | ( isJust 7 | ) 8 | import qualified Data.IntMap.Lazy as Map 9 | 10 | import Common 11 | import Errors 12 | import Field 13 | import Constraints 14 | import Simplify 15 | 16 | -- | Starting from an initial partial assignment [env], solve the 17 | -- constraints [cs] and return the resulting complete assignment. 18 | -- If the constraints are unsolvable from [env], report the first 19 | -- constraint that is violated (under normal operation, this error 20 | -- case should NOT occur). 21 | solve :: Field a 22 | => ConstraintSystem a -- ^ Constraints to be solved 23 | -> Assgn a -- ^ Initial assignment 24 | -> Assgn a -- ^ Resulting assignment 25 | solve cs env = 26 | let pinned_vars = cs_in_vars cs ++ cs_out_vars cs 27 | all_vars = [0..cs_num_vars cs-1] 28 | (assgn,cs') = do_simplify True env cs 29 | in if all_assigned all_vars assgn then assgn 30 | else fail_with 31 | $ ErrMsg ("unassigned variables,\n " 32 | ++ show (unassigned all_vars assgn) ++ ",\n" 33 | ++ "in assignment context\n " ++ show assgn ++ ",\n" 34 | ++ "in pinned-variable context\n " ++ show pinned_vars ++ ",\n" 35 | ++ "in reduced-constraint context\n " ++ show cs' ++ ",\n" 36 | ++ "in constraint context\n " ++ show cs) 37 | 38 | where all_assigned vars0 assgn = all id $ map (is_mapped assgn) vars0 39 | is_mapped assgn x = isJust (Map.lookup x assgn) 40 | unassigned vars0 assgn = [x | x <- vars0, not $ is_mapped assgn x] 41 | -------------------------------------------------------------------------------- /src/SyntaxMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax 2 | , DataKinds 3 | , ScopedTypeVariables 4 | , PolyKinds 5 | , GADTs 6 | #-} 7 | 8 | module SyntaxMonad 9 | ( -- | Computation monad 10 | Comp 11 | , CompResult 12 | , runState 13 | , return 14 | , (>>=) 15 | , (>>) 16 | , raise_err 17 | , Env(..) 18 | , State(..) 19 | 20 | -- | Return a fresh input variable. 21 | , fresh_input 22 | -- | Return a fresh variable. 23 | , fresh_var 24 | -- | Return a fresh location. 25 | , fresh_loc 26 | 27 | -- | Basic values 28 | , unit 29 | , false 30 | , true 31 | 32 | -- | Arrays 33 | , arr 34 | , input_arr 35 | , get 36 | , set 37 | 38 | -- | Pairs 39 | , pair 40 | , fst_pair 41 | , snd_pair 42 | 43 | -- | Basic static analysis 44 | , is_true 45 | , is_false 46 | , assert_false 47 | , assert_true 48 | 49 | , is_bot 50 | , assert_bot 51 | 52 | -- | Show the current state. 53 | , debug_state 54 | 55 | -- | Misc. functions imported by 'Syntax.hs' 56 | , get_addr 57 | , guard 58 | , add_objects 59 | ) where 60 | 61 | import Prelude hiding 62 | ( (>>) 63 | , (>>=) 64 | , (+) 65 | , (-) 66 | , (*) 67 | , (/) 68 | , (&&) 69 | , not 70 | , return 71 | , fromRational 72 | , negate 73 | ) 74 | 75 | import qualified Prelude as P 76 | 77 | import Data.Typeable 78 | import qualified Data.Map.Strict as Map 79 | 80 | import Common 81 | import Errors 82 | import TExpr 83 | 84 | {----------------------------------------------- 85 | State Monad 86 | ------------------------------------------------} 87 | 88 | type CompResult s a = Either ErrMsg (a,s) 89 | 90 | data State s a = State (s -> CompResult s a) 91 | 92 | runState :: State s a -> s -> CompResult s a 93 | runState mf s = case mf of 94 | State f -> f s 95 | 96 | raise_err :: ErrMsg -> Comp ty 97 | raise_err msg = State (\_ -> Left msg) 98 | 99 | -- | We have to define our own bind operator, unfortunately, 100 | -- because the "result" that's returned is the sequential composition 101 | -- of the results of 'mf', 'g' (not just whatever 'g' returns) 102 | (>>=) :: forall (ty1 :: Ty) (ty2 :: Ty) s a. 103 | Typeable ty1 104 | => State s (TExp ty1 a) 105 | -> (TExp ty1 a -> State s (TExp ty2 a)) 106 | -> State s (TExp ty2 a) 107 | (>>=) mf g = State (\s -> 108 | case runState mf s of 109 | Left err -> Left err 110 | Right (e,s') -> case runState (g e) s' of 111 | Left err -> Left err 112 | Right (e',s'') -> Right (e `te_seq` e',s'')) 113 | 114 | (>>) :: forall (ty1 :: Ty) (ty2 :: Ty) s a. 115 | Typeable ty1 116 | => State s (TExp ty1 a) 117 | -> State s (TExp ty2 a) 118 | -> State s (TExp ty2 a) 119 | (>>) mf g = do { _ <- mf; g } 120 | 121 | return :: TExp ty a -> State s (TExp ty a) 122 | return e = State (\s -> Right (last_seq e,s)) 123 | 124 | -- | At elaboration time, we maintain an environment containing 125 | -- (i) next_var: the next free variable 126 | -- (ii) next_loc: the next fresh location 127 | -- (iii) obj_map: a symbol table mapping (obj_loc,integer index) to 128 | -- the constraint variable associated with that object, at that 129 | -- field index. A given (obj_loc,integer index) pair may also 130 | -- resolve to a constant rational, boolean, or the bottom value, 131 | -- for constant propagation. 132 | -- 133 | -- Reading from object 'a' at index 'i' (x := a_i) corresponds to: 134 | -- (a) getting y <- obj_map(a,i) 135 | -- (b) inserting the constraint (x = y), if x,y resolve to logic 136 | -- vars. 137 | 138 | data ObjBind 139 | = ObjLoc Loc 140 | | ObjVar Var 141 | deriving ( Show 142 | ) 143 | 144 | data AnalBind 145 | = AnalBool Bool 146 | | AnalConst Rational 147 | | AnalBot 148 | deriving ( Show 149 | ) 150 | 151 | type ObjMap 152 | = Map.Map ( Loc -- object a 153 | , Int -- at index i 154 | ) 155 | ObjBind -- maps to result r 156 | 157 | data Env = Env { next_var :: Int 158 | , next_loc :: Int 159 | , input_vars :: [Int] 160 | , obj_map :: ObjMap 161 | , anal_map :: Map.Map Var AnalBind -- supporting simple constprop analyses 162 | } 163 | deriving Show 164 | 165 | type Comp ty = State Env (TExp ty Rational) 166 | 167 | {----------------------------------------------- 168 | Units, Booleans (used below) 169 | ------------------------------------------------} 170 | 171 | unit :: TExp 'TUnit Rational 172 | unit = TEVal VUnit 173 | 174 | false :: TExp 'TBool Rational 175 | false = TEVal VFalse 176 | 177 | true :: TExp 'TBool Rational 178 | true = TEVal VTrue 179 | 180 | {----------------------------------------------- 181 | Arrays 182 | ------------------------------------------------} 183 | 184 | arr :: Typeable ty => Int -> Comp ('TArr ty) 185 | arr 0 = raise_err $ ErrMsg "array must have size > 0" 186 | arr len 187 | = State (\s -> Right ( TEVal (VLoc (TLoc $ next_loc s)) 188 | -- allocate: 189 | -- (1) a new location (next_loc s) 190 | -- (2) 'len' new variables [(next_var s)..(next_var s+len-1)] 191 | , s { next_var = (P.+) (next_var s) len 192 | , next_loc = (P.+) (next_loc s) 1 193 | , obj_map = new_binds s `Map.union` obj_map s 194 | } 195 | ) 196 | ) 197 | where new_binds :: Env -> ObjMap 198 | new_binds s 199 | = Map.fromList 200 | (zip (zip (repeat (next_loc s)) [0..((P.-) len 1)]) 201 | (map ObjVar [next_var s..((P.+) (next_var s) ((P.-) len 1))])) 202 | 203 | -- Like 'arr', but declare fresh array variables as inputs. 204 | input_arr :: Typeable ty => Int -> Comp ('TArr ty) 205 | input_arr 0 = raise_err $ ErrMsg "array must have size > 0" 206 | input_arr len 207 | = State (\s -> Right ( TEVal (VLoc (TLoc $ next_loc s)) 208 | -- allocate: 209 | -- (1) a new location (next_loc s) 210 | -- (2) 'len' new variables [(next_var s)..(next_var s+len-1)] 211 | -- (3) mark new vars. as inputs 212 | , s { next_var = (P.+) (next_var s) len 213 | , next_loc = (P.+) (next_loc s) 1 214 | , input_vars = new_vars s ++ input_vars s 215 | , obj_map = new_binds s `Map.union` obj_map s 216 | } 217 | ) 218 | ) 219 | where new_binds :: Env -> ObjMap 220 | new_binds s 221 | = Map.fromList 222 | (zip (zip (repeat (next_loc s)) [0..((P.-) len 1)]) (map ObjVar $ new_vars s)) 223 | 224 | new_vars s = [next_var s..((P.+) (next_var s) ((P.-) len 1))] 225 | 226 | get_addr :: Typeable ty => (Loc,Int) -> Comp ty 227 | get_addr (l,i) 228 | = State (\s -> case Map.lookup (l,i) (obj_map s) of 229 | Just (ObjLoc l') -> Right (TEVal (VLoc (TLoc l')), s) 230 | Just (ObjVar x) -> Right (TEVar (TVar x), s) 231 | Nothing -> Left $ ErrMsg ("unbound loc " ++ show (l,i) 232 | ++ " in heap " ++ show (obj_map s)) 233 | ) 234 | 235 | guard :: Typeable ty2 => (TExp ty Rational -> State Env (TExp ty2 Rational)) 236 | -> TExp ty Rational -> State Env (TExp ty2 Rational) 237 | guard f e 238 | = do { b <- is_bot e 239 | ; case b of 240 | TEVal VTrue -> return TEBot 241 | TEVal VFalse -> f e 242 | _ -> fail_with $ ErrMsg "internal error in guard" 243 | } 244 | 245 | guarded_get_addr :: Typeable ty2 => TExp ty Rational 246 | -> Int -> State Env (TExp ty2 Rational) 247 | guarded_get_addr e i = guard (\e0 -> get_addr (loc_of_texp e0,i)) e 248 | 249 | get :: Typeable ty => (TExp ('TArr ty) Rational,Int) -> Comp ty 250 | get (TEBot,_) = return TEBot 251 | get (a,i) = guarded_get_addr a i 252 | 253 | -- | Smart constructor for TEAssert 254 | te_assert x@(TEVar _) e 255 | = do { e_bot <- is_bot e 256 | ; e_true <- is_true e 257 | ; e_false <- is_false e 258 | ; case (e_bot,e_true,e_false) of 259 | (TEVal VTrue,_,_) -> assert_bot x >> return (TEAssert x e) 260 | (_,TEVal VTrue,_) -> assert_true x >> return (TEAssert x e) 261 | (_,_,TEVal VTrue) -> assert_false x >> return (TEAssert x e) 262 | _ -> return $ TEAssert x e 263 | } 264 | te_assert _ e = fail_with $ ErrMsg 265 | $ "in te_assert, expected var but got " ++ show e 266 | 267 | -- | Update array 'a' at position 'i' to expression 'e'. We special-case 268 | -- variable and location expressions, because they're representable untyped 269 | -- in the object map. 270 | set_addr :: Typeable ty 271 | => (TExp ('TArr ty) Rational, Int) 272 | -> TExp ty Rational 273 | -> Comp 'TUnit 274 | 275 | -- The following specialization (to variable expressions) is an 276 | -- optimization: we avoid introducing a fresh variable. 277 | set_addr (TEVal (VLoc (TLoc l)),i) (TEVar (TVar x)) 278 | = add_objects [((l,i),ObjVar x)] >> return unit 279 | 280 | -- The following specialization (to location values) is necessary to 281 | -- satisfy [INVARIANT]: All expressions of compound types (sums, 282 | -- products, arrays, ...) have the form (TEVal (VLoc (TLoc l))), for 283 | -- some location l. 284 | set_addr (TEVal (VLoc (TLoc l)),i) (TEVal (VLoc (TLoc l'))) 285 | = do { add_objects [((l,i),ObjLoc l')] 286 | ; return unit 287 | } 288 | 289 | -- Default: 290 | set_addr (TEVal (VLoc (TLoc l)),i) e 291 | = do { x <- fresh_var 292 | ; add_objects [((l,i),ObjVar (var_of_texp x))] 293 | ; te_assert x e 294 | } 295 | 296 | -- Err: expression does not satisfy [INVARIANT]. 297 | set_addr (e1,_) _ 298 | = raise_err $ ErrMsg ("expected " ++ show e1 ++ " a loc") 299 | 300 | set (a,i) e = set_addr (a,i) e 301 | 302 | {----------------------------------------------- 303 | Products 304 | ------------------------------------------------} 305 | 306 | pair :: ( Typeable ty1 307 | , Typeable ty2 308 | ) 309 | => TExp ty1 Rational 310 | -> TExp ty2 Rational 311 | -> Comp ('TProd ty1 ty2) 312 | pair te1 te2 313 | = do { l <- fresh_loc 314 | ; add_binds (loc_of_texp l) (last_seq te1) (last_seq te2) 315 | ; return l 316 | } 317 | where add_binds l (TEVal (VLoc (TLoc l1))) (TEVal (VLoc (TLoc l2))) 318 | = add_objects [((l,0),ObjLoc l1), ((l,1),ObjLoc l2)] 319 | add_binds l (TEVal (VLoc (TLoc l1))) e2 320 | = do { x2 <- fresh_var 321 | ; add_objects [((l,0),ObjLoc l1), ((l,1),ObjVar $ var_of_texp x2)] 322 | ; te_assert x2 e2 323 | } 324 | add_binds l e1 (TEVal (VLoc (TLoc l2))) 325 | = do { x1 <- fresh_var 326 | ; add_objects [((l,0),ObjVar $ var_of_texp x1), ((l,1),ObjLoc l2)] 327 | ; te_assert x1 e1 328 | } 329 | add_binds l e1 e2 330 | = do { x1 <- fresh_var 331 | ; x2 <- fresh_var 332 | ; add_objects [((l,0),ObjVar $ var_of_texp x1), 333 | ((l,1),ObjVar $ var_of_texp x2)] 334 | -- NOTE: return e ~~> return (last_seq e). So we rely on the 335 | -- slightly weird semantics of (>>=) to do the sequencing of 336 | -- the two assertions for us. 337 | ; te_assert x1 e1 338 | ; te_assert x2 e2 339 | } 340 | 341 | fst_pair :: ( Typeable ty1 342 | , Typeable ty2 343 | ) 344 | => TExp ('TProd ty1 ty2) Rational 345 | -> Comp ty1 346 | fst_pair TEBot = return TEBot 347 | fst_pair e = guarded_get_addr e 0 348 | 349 | snd_pair :: ( Typeable ty1 350 | , Typeable ty2 351 | ) 352 | => TExp ('TProd ty1 ty2) Rational 353 | -> Comp ty2 354 | snd_pair TEBot = return TEBot 355 | snd_pair e = guarded_get_addr e 1 356 | 357 | {----------------------------------------------- 358 | Auxiliary functions 359 | ------------------------------------------------} 360 | 361 | debug_state :: State Env (TExp 'TUnit a) 362 | debug_state 363 | = State (\s -> Left $ ErrMsg $ show s) 364 | 365 | fresh_var :: State Env (TExp ty a) 366 | fresh_var 367 | = State (\s -> Right ( TEVar (TVar $ next_var s) 368 | , s { next_var = (P.+) (next_var s) 1 369 | } 370 | ) 371 | ) 372 | 373 | fresh_input :: State Env (TExp ty a) 374 | fresh_input 375 | = State (\s -> Right ( TEVar (TVar $ next_var s) 376 | , s { next_var = (P.+) (next_var s) 1 377 | , input_vars = next_var s : input_vars s 378 | } 379 | ) 380 | ) 381 | 382 | fresh_loc :: State Env (TExp ty a) 383 | fresh_loc 384 | = State (\s -> Right ( TEVal (VLoc (TLoc $ next_loc s)) 385 | , s { next_loc = (P.+) (next_loc s) 1 386 | } 387 | ) 388 | ) 389 | 390 | add_objects :: [((Loc,Int),ObjBind)] -> Comp 'TUnit 391 | add_objects binds 392 | = State (\s -> 393 | Right ( unit 394 | , s { obj_map = Map.fromList binds `Map.union` obj_map s 395 | } 396 | ) 397 | ) 398 | 399 | add_statics :: [(Var,AnalBind)] -> Comp 'TUnit 400 | add_statics binds 401 | = State (\s -> 402 | Right ( unit 403 | , s { anal_map = Map.fromList binds `Map.union` anal_map s 404 | } 405 | ) 406 | ) 407 | 408 | -- | Does boolean expression 'e' resolve (statically) to 'b'? 409 | is_bool :: TExp ty Rational -> Bool -> Comp 'TBool 410 | is_bool (TEVal VFalse) False = return true 411 | is_bool (TEVal VTrue) True = return true 412 | is_bool e@(TEVar _) b 413 | = State (\s -> Right ( case Map.lookup (var_of_texp e) (anal_map s) of 414 | Nothing -> false 415 | Just (AnalBool b') | b/=b' -> false 416 | Just (AnalBool b') | b==b' -> true 417 | Just _ | otherwise -> false 418 | , s 419 | ) 420 | ) 421 | is_bool _ _ = return false 422 | 423 | is_false :: TExp ty Rational -> Comp 'TBool 424 | is_false = flip is_bool False 425 | 426 | is_true :: TExp ty Rational -> Comp 'TBool 427 | is_true = flip is_bool True 428 | 429 | -- | Add binding 'x = b'. 430 | assert_bool :: TExp ty Rational -> Bool -> Comp 'TUnit 431 | assert_bool (TEVar (TVar x)) b = add_statics [(x,AnalBool b)] 432 | assert_bool e _ = raise_err $ ErrMsg $ "expected " ++ show e ++ " a variable" 433 | 434 | assert_false :: TExp ty Rational -> Comp 'TUnit 435 | assert_false = flip assert_bool False 436 | 437 | assert_true :: TExp ty Rational -> Comp 'TUnit 438 | assert_true = flip assert_bool True 439 | 440 | var_is_bot :: TExp ty Rational -> Comp 'TBool 441 | var_is_bot e@(TEVar (TVar _)) 442 | = State (\s -> Right ( case Map.lookup (var_of_texp e) (anal_map s) of 443 | Nothing -> false 444 | Just AnalBot -> true 445 | Just _ -> false 446 | , s 447 | ) 448 | ) 449 | var_is_bot _ = return false 450 | 451 | is_bot :: TExp ty Rational -> Comp 'TBool 452 | is_bot e 453 | = case e of 454 | e0@(TEVar _) -> var_is_bot e0 455 | TEUnop _ e0 -> is_bot e0 456 | TEBinop _ e1 e2 -> either_is_bot e1 e2 457 | TESeq e1 e2 -> either_is_bot e1 e2 458 | TEBot -> return true 459 | _ -> return false 460 | where either_is_bot :: TExp ty1 Rational -> TExp ty2 Rational -> Comp 'TBool 461 | either_is_bot e10 e20 462 | = do { e1_bot <- is_bot e10 463 | ; e2_bot <- is_bot e20 464 | ; case (e1_bot,e2_bot) of 465 | (TEVal VTrue,_) -> return true 466 | (_,TEVal VTrue) -> return true 467 | _ -> return false 468 | } 469 | 470 | assert_bot :: TExp ty Rational -> Comp 'TUnit 471 | assert_bot (TEVar (TVar x)) = add_statics [(x,AnalBot)] 472 | assert_bot e = raise_err $ ErrMsg $ "in assert_bot, expected " ++ show e ++ " a variable" 473 | -------------------------------------------------------------------------------- /src/TExpr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs 2 | , DataKinds 3 | , KindSignatures 4 | , RankNTypes 5 | , DeriveDataTypeable 6 | , AutoDeriveTypeable 7 | , DeriveGeneric 8 | , DeriveAnyClass 9 | , TypeFamilies 10 | , UndecidableInstances 11 | , FlexibleContexts 12 | , ScopedTypeVariables 13 | #-} 14 | 15 | module TExpr 16 | ( Val(..) 17 | , TExp(..) 18 | , TFunct(..) 19 | , Ty(..) 20 | , Rep 21 | , TUnop(..) 22 | , TOp(..) 23 | , TVar(..) 24 | , Loc 25 | , TLoc(..) 26 | , boolean_vars_of_texp 27 | , var_of_texp 28 | , loc_of_texp 29 | , te_seq 30 | , last_seq 31 | , exp_of_texp 32 | ) where 33 | 34 | import Data.Typeable 35 | 36 | import Common 37 | import Errors 38 | import Field 39 | import Expr 40 | 41 | data TFunct where 42 | TFConst :: Ty -> TFunct 43 | TFId :: TFunct 44 | TFProd :: TFunct -> TFunct -> TFunct 45 | TFSum :: TFunct -> TFunct -> TFunct 46 | TFComp :: TFunct -> TFunct -> TFunct 47 | deriving Typeable 48 | 49 | data Ty where 50 | TField:: Ty 51 | TBool :: Ty 52 | TArr :: Ty -> Ty 53 | TProd :: Ty -> Ty -> Ty 54 | TSum :: Ty -> Ty -> Ty 55 | TMu :: TFunct -> Ty 56 | TUnit :: Ty 57 | deriving Typeable 58 | 59 | type family Rep (f :: TFunct) (x :: Ty) :: Ty 60 | type instance Rep ('TFConst ty) x = ty 61 | type instance Rep 'TFId x = x 62 | type instance Rep ('TFProd f g) x = 'TProd (Rep f x) (Rep g x) 63 | type instance Rep ('TFSum f g) x = 'TSum (Rep f x) (Rep g x) 64 | type instance Rep ('TFComp f g) x = Rep f (Rep g x) 65 | 66 | newtype TVar (ty :: Ty) = TVar Var 67 | 68 | var_is_boolean :: Typeable ty => TVar ty -> Bool 69 | var_is_boolean x 70 | = typeOf x == typeOf (undefined :: TVar 'TBool) 71 | 72 | instance Eq (TVar ty) where 73 | TVar x==TVar y = x==y 74 | 75 | instance Show (TVar ty) where 76 | show (TVar x) = show x 77 | 78 | type Loc = Int 79 | 80 | newtype TLoc (ty :: Ty) = TLoc Loc 81 | 82 | instance Eq (TLoc ty) where 83 | TLoc x==TLoc y = x==y 84 | 85 | instance Show (TLoc ty) where 86 | show (TLoc x) = "loc_" ++ show x 87 | 88 | data TUnop :: Ty -> Ty -> * where 89 | TUnop :: forall ty1 ty. UnOp -> TUnop ty1 ty 90 | deriving Eq 91 | 92 | data TOp :: Ty -> Ty -> Ty -> * where 93 | TOp :: forall ty1 ty2 ty. Op -> TOp ty1 ty2 ty 94 | deriving Eq 95 | 96 | data Val :: Ty -> * -> * where 97 | VField :: Field a => a -> Val 'TField a 98 | VTrue :: Val 'TBool a 99 | VFalse :: Val 'TBool a 100 | VUnit :: Val 'TUnit a 101 | VLoc :: TLoc ty -> Val ty a 102 | 103 | data TExp :: Ty -> * -> * where 104 | TEVar :: TVar ty -> TExp ty a 105 | TEVal :: Val ty a -> TExp ty a 106 | TEUnop :: ( Typeable ty1 107 | ) 108 | => TUnop ty1 ty -> TExp ty1 a -> TExp ty a 109 | TEBinop :: ( Typeable ty1 110 | , Typeable ty2 111 | ) 112 | => TOp ty1 ty2 ty -> TExp ty1 a -> TExp ty2 a -> TExp ty a 113 | TEIf :: TExp 'TBool a -> TExp ty a -> TExp ty a -> TExp ty a 114 | TEAssert :: Typeable ty => TExp ty a -> TExp ty a -> TExp 'TUnit a 115 | TESeq :: TExp 'TUnit a -> TExp ty2 a -> TExp ty2 a 116 | TEBot :: Typeable ty => TExp ty a 117 | 118 | exp_of_val :: Field a => Val ty a -> Exp a 119 | exp_of_val v = case v of 120 | VField c -> EVal c 121 | VTrue -> EVal one 122 | VFalse -> EVal zero 123 | VUnit -> EUnit 124 | VLoc l -> fail_with $ ErrMsg $ "unresolved location " ++ show l 125 | 126 | instance ( Field a 127 | , Eq a 128 | ) 129 | => Eq (Val ty a) where 130 | v1 == v2 = exp_of_val v1 == exp_of_val v2 131 | 132 | exp_of_texp :: Field a => TExp ty a -> Exp a 133 | exp_of_texp te = case te of 134 | TEVar (TVar x) -> EVar x 135 | TEVal v -> exp_of_val v 136 | TEUnop (TUnop op) te1 -> 137 | EUnop op (exp_of_texp te1) 138 | TEBinop (TOp op) te1 te2 -> 139 | exp_binop op (exp_of_texp te1) (exp_of_texp te2) 140 | TEIf te1 te2 te3 -> 141 | EIf (exp_of_texp te1) (exp_of_texp te2) (exp_of_texp te3) 142 | TEAssert te1 te2 -> 143 | EAssert (exp_of_texp te1) (exp_of_texp te2) 144 | TESeq te1 te2 -> exp_seq (exp_of_texp te1) (exp_of_texp te2) 145 | TEBot -> EUnit 146 | 147 | instance ( Field a 148 | , Eq a 149 | ) 150 | => Eq (TExp ty a) where 151 | te1 == te2 = exp_of_texp te1 == exp_of_texp te2 152 | 153 | -- | Smart constructor for 'TESeq'. Simplify 'TESeq te1 te2' to 'te2' 154 | -- whenever the normal form of 'te1' (with seq's reassociated right) 155 | -- is *not* equal 'TEAssert _ _'. 156 | te_seq :: Typeable ty1 => TExp ty1 a -> TExp ty2 a -> TExp ty2 a 157 | te_seq te1 te2 = case (te1,te2) of 158 | (TEAssert _ _,_) -> TESeq te1 te2 159 | (TESeq tx ty,_) -> te_seq tx (te_seq ty te2) 160 | (_,_) -> te2 161 | 162 | boolean_vars_of_texp :: Typeable ty => TExp ty a -> [Var] 163 | boolean_vars_of_texp = go [] 164 | where go :: Typeable ty => [Var] -> TExp ty a -> [Var] 165 | go vars (TEVar t@(TVar x)) 166 | = if var_is_boolean t then x : vars 167 | else vars 168 | go vars (TEVal _) = vars 169 | go vars (TEUnop _ e1) = go vars e1 170 | go vars (TEBinop _ e1 e2) = go (go vars e1) e2 171 | go vars (TEIf e1 e2 e3) 172 | = go (go (go vars e1) e2) e3 173 | go vars (TEAssert e1 e2) = go (go vars e1) e2 174 | go vars (TESeq e1 e2) = go (go vars e1) e2 175 | go vars TEBot = vars 176 | 177 | var_of_texp :: Show a => TExp ty a -> Var 178 | var_of_texp te = case last_seq te of 179 | TEVar (TVar x) -> x 180 | _ -> fail_with $ ErrMsg ("var_of_texp: expected var: " ++ show te) 181 | 182 | loc_of_texp :: Show a => TExp ty a -> Var 183 | loc_of_texp te = case last_seq te of 184 | TEVal (VLoc (TLoc l)) -> l 185 | _ -> fail_with $ ErrMsg ("loc_of_texp: expected loc: " ++ show te) 186 | 187 | last_seq :: TExp ty a -> TExp ty a 188 | last_seq te = case te of 189 | TESeq _ te2 -> last_seq te2 190 | _ -> te 191 | 192 | instance Show (TUnop ty1 ty) where 193 | show (TUnop op) = show op 194 | 195 | instance Show (TOp ty1 ty2 ty) where 196 | show (TOp op) = show op 197 | 198 | instance Show a => Show (Val ty a) where 199 | show (VField c) = show c 200 | show VTrue = "true" 201 | show VFalse = "false" 202 | show VUnit = "()" 203 | show (VLoc l) = "loc_" ++ show l 204 | 205 | instance Show a => Show (TExp ty a) where 206 | show (TEVar x) = "var " ++ show x 207 | show (TEVal c) = show c 208 | show (TEUnop op e1) = show op ++ show e1 209 | show (TEBinop op e1 e2) = show e1 ++ show op ++ show e2 210 | show (TEIf b e1 e2) 211 | = "if " ++ show b ++ " then " ++ show e1 ++ " else " ++ show e2 212 | show (TEAssert e1 e2) = show e1 ++ " := " ++ show e2 213 | show (TESeq e1 e2) = "(" ++ show e1 ++ "; " ++ show e2 ++ ")" 214 | show TEBot = "bot" 215 | 216 | -------------------------------------------------------------------------------- /src/Toplevel.hs: -------------------------------------------------------------------------------- 1 | module Toplevel 2 | ( -- * Interpret Snarkl Computations 3 | comp_interp 4 | 5 | -- * Desugar 6 | , TExpPkg(..) 7 | , texp_of_comp 8 | 9 | -- * Generate Constraints 10 | , constrs_of_texp 11 | , constrs_of_comp 12 | 13 | -- * Generate R1CS 14 | , r1cs_of_constrs 15 | , r1cs_of_texp 16 | , r1cs_of_comp 17 | 18 | -- * Given arguments, construct a witness 19 | , wit_of_r1cs 20 | -- * Serialize the resulting inputs assignment 21 | , serialize_inputs 22 | -- * Serialize the resulting witness assignment 23 | , serialize_witnesses 24 | 25 | -- * Serialize R1CS in 'libsnark' format 26 | , serialize_r1cs 27 | 28 | -- * For a given Snarkl computation, use 'libsnark' to test: (1) 29 | -- key generation, (2) proof generation, and (3) proof 30 | -- verification. Currently assumes 'Toplevel' is loaded in working 31 | -- directory 'base-of-snarkl-repo'. 32 | , snarkify_comp 33 | , keygen_comp -- for benchmarking 34 | , proofgen_comp -- for benchmarking 35 | , witgen_comp -- for benchmarking 36 | , r1csgen_comp -- for benchmarking 37 | 38 | -- * Convenience functions 39 | , Result(..) 40 | , result_of_comp 41 | , int_of_comp 42 | , test_comp 43 | , benchmark_comp 44 | 45 | -- * Re-exported modules 46 | , module SyntaxMonad 47 | , module Constraints 48 | , module Simplify 49 | , module R1CS 50 | ) where 51 | 52 | import System.IO 53 | ( hFlush 54 | , stdout 55 | , hPutStr 56 | , hPutStrLn 57 | , withFile 58 | , IOMode( WriteMode ) 59 | ) 60 | 61 | import qualified Data.IntMap.Lazy as IntMap 62 | import Data.List (sort) 63 | import qualified Data.Map.Strict as Map 64 | import Data.Typeable 65 | import Prelude 66 | import qualified Prelude as P 67 | import System.Exit 68 | import System.Process 69 | 70 | import Common 71 | import Compile 72 | import Constraints 73 | import Errors 74 | import Interp ( interp ) 75 | import R1CS 76 | import qualified Serialize as Serialize 77 | import Simplify 78 | import SyntaxMonad 79 | import TExpr 80 | 81 | ---------------------------------------------------- 82 | -- 83 | -- Toplevel Stuff 84 | -- 85 | ---------------------------------------------------- 86 | 87 | -- | Using the executable semantics for the 'TExp' language, execute 88 | -- the computation on the provided inputs, returning the 'Rational' result. 89 | comp_interp :: Typeable ty 90 | => Comp ty 91 | -> [Rational] 92 | -> Rational 93 | comp_interp mf inputs 94 | = let TExpPkg _ in_vars e = texp_of_comp mf 95 | input_map = IntMap.fromList $ zip in_vars inputs 96 | in case interp input_map e of 97 | Left err -> fail_with err 98 | Right (_,Nothing) -> fail_with $ ErrMsg $ show e ++ " evaluated to bot" 99 | Right (_,Just v) -> v 100 | 101 | ------------------------------------------------------ 102 | -- 103 | -- 'TExp' 104 | -- 105 | ------------------------------------------------------ 106 | 107 | -- | The result of desugaring a Snarkl computation. 108 | data TExpPkg ty 109 | = TExpPkg { comp_num_vars :: Int -- ^ The number of free variables in the computation. 110 | , comp_input_vars :: [Var] -- ^ The variables marked as inputs. 111 | , comp_texp :: TExp ty Rational -- ^ The resulting 'TExp'. 112 | } 113 | deriving Show 114 | 115 | -- | Desugar a 'Comp'utation to a pair of: 116 | -- the total number of vars, 117 | -- the input vars, 118 | -- the 'TExp'. 119 | texp_of_comp :: Typeable ty 120 | => Comp ty 121 | -> TExpPkg ty 122 | texp_of_comp mf 123 | = case run mf of 124 | Left err -> fail_with err 125 | Right (e,rho) -> 126 | let nv = next_var rho 127 | in_vars = sort $ input_vars rho 128 | in TExpPkg nv in_vars e 129 | where run :: State Env a -> CompResult Env a 130 | run mf0 = runState mf0 (Env (fromInteger 0) (fromInteger 0) 131 | [] Map.empty Map.empty) 132 | 133 | ------------------------------------------------------ 134 | -- 135 | -- Constraint generation 136 | -- 137 | ------------------------------------------------------ 138 | 139 | -- | Compile 'TExp's to constraint systems. Re-exported from 'Compile.Compile'. 140 | constrs_of_texp :: Typeable ty 141 | => TExpPkg ty 142 | -> ConstraintSystem Rational 143 | constrs_of_texp (TExpPkg out in_vars e) = constraints_of_texp out in_vars e 144 | -- | Compile Snarkl computations to constraint systems. 145 | constrs_of_comp :: Typeable ty 146 | => Comp ty 147 | -> ConstraintSystem Rational 148 | constrs_of_comp = constrs_of_texp . texp_of_comp 149 | 150 | ------------------------------------------------------ 151 | -- 152 | -- R1CS 153 | -- 154 | ------------------------------------------------------ 155 | 156 | -- | Compile constraint systems to 'R1CS'. Re-exported from 'Constraints.hs'. 157 | r1cs_of_constrs :: Field a 158 | => SimplParam 159 | -> ConstraintSystem a -- ^ Constraints 160 | -> R1CS a 161 | r1cs_of_constrs = r1cs_of_constraints 162 | 163 | -- | Compile 'TExp's to 'R1CS'. 164 | r1cs_of_texp :: Typeable ty 165 | => SimplParam 166 | -> TExpPkg ty 167 | -> R1CS Rational 168 | r1cs_of_texp simpl = (r1cs_of_constrs simpl) . constrs_of_texp 169 | 170 | -- | Compile Snarkl computations to 'R1CS'. 171 | r1cs_of_comp :: Typeable ty 172 | => SimplParam 173 | -> Comp ty 174 | -> R1CS Rational 175 | r1cs_of_comp simpl = (r1cs_of_constrs simpl) . constrs_of_comp 176 | 177 | -- | For a given R1CS and inputs, calculate a satisfying assignment. 178 | wit_of_r1cs inputs r1cs 179 | = let in_vars = r1cs_in_vars r1cs 180 | f = r1cs_gen_witness r1cs . IntMap.fromList 181 | in case length in_vars /= length inputs of 182 | True -> 183 | fail_with 184 | $ ErrMsg ("expected " ++ show (length in_vars) ++ " input(s)" 185 | ++ " but got " ++ show (length inputs) ++ " input(s)") 186 | False -> 187 | f (zip in_vars inputs) 188 | 189 | -- | For a given R1CS and inputs, serialize the input variable assignment. 190 | serialize_inputs :: [Rational] -> R1CS Rational -> String 191 | serialize_inputs inputs r1cs 192 | = let inputs_assgn = IntMap.fromList $ zip (r1cs_in_vars r1cs) inputs 193 | in Serialize.serialize_assgn inputs_assgn 194 | 195 | -- | For a given R1CS and inputs, serialize the witness variable assignment. 196 | serialize_witnesses :: [Rational] -> R1CS Rational -> String 197 | serialize_witnesses inputs r1cs 198 | = let num_in_vars = length $ r1cs_in_vars r1cs 199 | assgn = wit_of_r1cs inputs r1cs 200 | inputs_assgn = IntMap.fromList $ drop num_in_vars $ IntMap.toAscList assgn 201 | in Serialize.serialize_assgn inputs_assgn 202 | 203 | serialize_r1cs = Serialize.serialize_r1cs 204 | 205 | ------------------------------------------------------ 206 | -- 207 | -- Libsnark hooks 208 | -- 209 | ------------------------------------------------------ 210 | 211 | -- | *** WARNING *** 212 | -- This function creates/overwrites files prefixed with 'filePrefix', 213 | -- within the scripts/ subdirectory. 'snarkify_comp' also 214 | -- assumes that it's run in working directory 'base-of-snarkl-repo'. 215 | snarkify_comp filePrefix simpl c inputs 216 | = do { let r1cs = r1cs_of_comp simpl c 217 | r1cs_file = filePrefix ++ ".r1cs" 218 | inputs_file = filePrefix ++ ".inputs" 219 | wits_file = filePrefix ++ ".wits" 220 | run_r1cs = "./run-r1cs.sh" 221 | 222 | ; withFile ("scripts/" ++ r1cs_file) WriteMode (\h -> 223 | hPutStrLn h $ serialize_r1cs r1cs) 224 | 225 | ; withFile ("scripts/" ++ inputs_file) WriteMode (\h -> 226 | hPutStr h $ serialize_inputs inputs r1cs) 227 | 228 | ; withFile ("scripts/" ++ wits_file) WriteMode (\h -> 229 | hPutStr h $ serialize_witnesses inputs r1cs) 230 | 231 | ; (_,_,_,hdl) <- 232 | createProcess (proc run_r1cs [r1cs_file,inputs_file,wits_file]) 233 | { cwd = Just "scripts" } 234 | 235 | ; waitForProcess hdl 236 | } 237 | 238 | -- Like snarkify_comp, but only generate witnesses and keys 239 | -- Serializes r1cs, inputs, and witnesses to files. 240 | keygen_comp filePrefix simpl c inputs 241 | = do { let r1cs = r1cs_of_comp simpl c 242 | r1cs_file = filePrefix ++ ".r1cs" 243 | inputs_file = filePrefix ++ ".inputs" 244 | wits_file = filePrefix ++ ".wits" 245 | run_r1cs = "./run-keygen.sh" 246 | 247 | ; withFile ("scripts/" ++ r1cs_file) WriteMode (\h -> 248 | hPutStrLn h $ serialize_r1cs r1cs) 249 | 250 | ; withFile ("scripts/" ++ inputs_file) WriteMode (\h -> 251 | hPutStr h $ serialize_inputs inputs r1cs) 252 | 253 | ; withFile ("scripts/" ++ wits_file) WriteMode (\h -> 254 | hPutStr h $ serialize_witnesses inputs r1cs) 255 | 256 | ; (_,_,_,hdl) <- 257 | createProcess (proc run_r1cs [r1cs_file,inputs_file,wits_file]) 258 | { cwd = Just "scripts" } 259 | 260 | ; waitForProcess hdl 261 | } 262 | 263 | -- Like snarkify_comp, but only generate keys and proof 264 | -- (no verification) 265 | -- Serializes r1cs, inputs, witnesses. 266 | proofgen_comp filePrefix simpl c inputs 267 | = do { let r1cs = r1cs_of_comp simpl c 268 | r1cs_file = filePrefix ++ ".r1cs" 269 | inputs_file = filePrefix ++ ".inputs" 270 | wits_file = filePrefix ++ ".wits" 271 | run_r1cs = "./run-proofgen.sh" 272 | 273 | ; withFile ("scripts/" ++ r1cs_file) WriteMode (\h -> 274 | hPutStrLn h $ serialize_r1cs r1cs) 275 | 276 | ; withFile ("scripts/" ++ inputs_file) WriteMode (\h -> 277 | hPutStr h $ serialize_inputs inputs r1cs) 278 | 279 | ; withFile ("scripts/" ++ wits_file) WriteMode (\h -> 280 | hPutStr h $ serialize_witnesses inputs r1cs) 281 | 282 | ; (_,_,_,hdl) <- 283 | createProcess (proc run_r1cs [r1cs_file,inputs_file,wits_file]) 284 | { cwd = Just "scripts" } 285 | 286 | ; waitForProcess hdl 287 | } 288 | 289 | 290 | -- Like snarkify_comp, but only generate and serialize the r1cs 291 | r1csgen_comp filePrefix simpl c 292 | = do { let r1cs = r1cs_of_comp simpl c 293 | r1cs_file = filePrefix ++ ".r1cs" 294 | 295 | ; withFile ("scripts/" ++ r1cs_file) WriteMode (\h -> 296 | hPutStrLn h $ serialize_r1cs r1cs) 297 | } 298 | 299 | -- Like snarkify_comp, but only generate the witness 300 | -- (no key generation or proof) 301 | -- Serializes r1cs, inputs, and witnesses to files. 302 | witgen_comp filePrefix simpl c inputs 303 | = do { let r1cs = r1cs_of_comp simpl c 304 | r1cs_file = filePrefix ++ ".r1cs" 305 | inputs_file = filePrefix ++ ".inputs" 306 | wits_file = filePrefix ++ ".wits" 307 | 308 | ; withFile ("scripts/" ++ r1cs_file) WriteMode (\h -> 309 | hPutStrLn h $ serialize_r1cs r1cs) 310 | 311 | ; withFile ("scripts/" ++ inputs_file) WriteMode (\h -> 312 | hPutStr h $ serialize_inputs inputs r1cs) 313 | 314 | ; withFile ("scripts/" ++ wits_file) WriteMode (\h -> 315 | hPutStr h $ serialize_witnesses inputs r1cs) 316 | 317 | } 318 | 319 | ------------------------------------------------------ 320 | -- 321 | -- Convenience functions 322 | -- 323 | ------------------------------------------------------ 324 | 325 | -- | The result of compiling and executing a Snarkl computation. 326 | data Result a = 327 | Result { result_sat :: Bool 328 | , result_vars :: Int 329 | , result_constraints :: Int 330 | , result_result :: a 331 | , result_r1cs :: String 332 | } 333 | 334 | instance Show a => Show (Result a) where 335 | show (Result the_sat the_vars the_constraints the_result _) 336 | = "sat = " ++ show the_sat 337 | ++ ", vars = " ++ show the_vars 338 | ++ ", constraints = " ++ show the_constraints 339 | ++ ", result = " ++ show the_result 340 | 341 | -- | Compile a computation to R1CS, and run it on the provided inputs. 342 | -- Also, interprets the computation using the executable semantics and 343 | -- checks that the results match. 344 | result_of_comp :: Typeable ty => SimplParam -> Comp ty -> [Rational] -> Result Rational 345 | result_of_comp simpl mf inputs 346 | = execute simpl mf inputs 347 | 348 | -- | Same as 'result_of_comp', but specialized to integer arguments 349 | -- and results. Returns just the integer result. 350 | int_of_comp :: Typeable ty => SimplParam -> Comp ty -> [Int] -> Int 351 | int_of_comp simpl mf args 352 | = truncate $ result_result $ result_of_comp simpl mf (map fromIntegral args) 353 | 354 | -- | Same as 'int_of_comp', but additionally runs resulting R1CS 355 | -- through key generation, proof generation, and verification stages 356 | -- of 'libsnark'. TODO: This function does duplicate R1CS generation, 357 | -- once for 'libsnark' and a second time for 'int_of_comp'. 358 | test_comp :: Typeable ty => SimplParam -> Comp ty -> [Int] -> IO (Either ExitCode Int) 359 | test_comp simpl mf args 360 | = do { exit_code <- snarkify_comp "hspec" simpl mf (map fromIntegral args) 361 | ; case exit_code of 362 | ExitFailure _ -> Prelude.return $ Left exit_code 363 | ExitSuccess -> Prelude.return $ Right (int_of_comp simpl mf args) 364 | } 365 | 366 | 367 | -------------------------------------------------- 368 | -- 369 | -- Internal Functions 370 | -- 371 | -------------------------------------------------- 372 | 373 | -- | (1) Compile to R1CS. 374 | -- (2) Generate a satisfying assignment, 'w'. 375 | -- (3) Check whether 'w' satisfies the constraint system produced in (1). 376 | -- (4) Check whether the R1CS result matches the interpreter result. 377 | -- (5) Return the 'Result'. 378 | execute :: Typeable ty => SimplParam -> Comp ty -> [Rational] -> Result Rational 379 | execute simpl mf inputs 380 | = let TExpPkg nv in_vars e = texp_of_comp mf 381 | r1cs = r1cs_of_texp simpl (TExpPkg nv in_vars e) 382 | r1cs_string = serialize_r1cs r1cs 383 | nw = r1cs_num_vars r1cs 384 | [out_var] = r1cs_out_vars r1cs 385 | ng = num_constraints r1cs 386 | wit = wit_of_r1cs inputs r1cs 387 | out = case IntMap.lookup out_var wit of 388 | Nothing -> 389 | fail_with 390 | $ ErrMsg ("output variable " ++ show out_var 391 | ++ "not mapped, in\n " ++ show wit) 392 | Just out_val -> out_val 393 | -- Interpret the program using the executable semantics and 394 | -- the input assignment (a subset of 'wit'). 395 | -- Output the return value of 'e'. 396 | out_interp = comp_interp mf inputs 397 | result = case out_interp == out of 398 | True -> sat_r1cs wit r1cs 399 | False -> fail_with 400 | $ ErrMsg $ "interpreter result " ++ show out_interp 401 | ++ " differs from actual result " ++ show out 402 | in Result result nw ng out r1cs_string 403 | 404 | -- | 'execute' computation, reporting error if result doesn't match 405 | -- the return value provided by the caller. Also, serializes the 406 | -- resulting 'R1CS'. 407 | benchmark_comp :: Typeable ty => (SimplParam, Comp ty, [Rational], Rational) -> IO () 408 | benchmark_comp (simpl,prog,inputs,res) 409 | = let print_ln = print_ln_to_file stdout 410 | print_ln_to_file h s = (P.>>) (hPutStrLn h s) (hFlush h) 411 | print_to_file s 412 | = withFile "test_cs_in.ppzksnark" WriteMode (flip print_ln_to_file s) 413 | in case execute simpl prog inputs of 414 | r@(Result True _ _ res' r1cs_string) -> 415 | if res == res' then 416 | do { print_to_file r1cs_string 417 | ; print_ln $ show r 418 | } 419 | else 420 | print_ln 421 | $ show 422 | $ "error: results don't match: " 423 | ++ "expected " ++ show res ++ " but got " ++ show res' 424 | Result False _ _ _ _ -> 425 | print_ln $ "error: witness failed to satisfy constraints" 426 | -------------------------------------------------------------------------------- /src/UnionFind.hs: -------------------------------------------------------------------------------- 1 | module UnionFind 2 | ( root 3 | , unite 4 | , new_uf 5 | , extra_of 6 | , UnionFind(..) 7 | ) where 8 | 9 | import qualified Data.IntMap.Lazy as Map 10 | import Data.Maybe 11 | 12 | import Common 13 | import Errors 14 | 15 | data UnionFind a = 16 | UnionFind { ids :: Map.IntMap Var 17 | , sizes :: Map.IntMap Int 18 | , extras :: Map.IntMap a } 19 | deriving Show 20 | 21 | new_uf :: UnionFind a 22 | new_uf = UnionFind Map.empty Map.empty Map.empty 23 | 24 | id_of :: UnionFind a -> Var -> Var 25 | id_of uf x = fromMaybe x $ Map.lookup x (ids uf) 26 | 27 | size_of :: UnionFind a -> Var -> Int 28 | size_of uf x = fromMaybe 1 $ Map.lookup x (sizes uf) 29 | 30 | extra_of :: UnionFind a -> Var -> Maybe a 31 | extra_of uf x = Map.lookup x (extras uf) 32 | 33 | root :: (Show a,Eq a) => UnionFind a -> Var -> (Var,UnionFind a) 34 | root uf x 35 | = let px = id_of uf x 36 | in if px == x then (x,uf) 37 | else let gpx = id_of uf px 38 | uf' = merge_extras uf x gpx 39 | in root (uf' { ids = Map.insert x gpx (ids uf) }) px 40 | 41 | merge_extras :: (Show a,Eq a) => UnionFind a -> Var -> Var -> UnionFind a 42 | merge_extras uf x y 43 | = case (Map.lookup x (extras uf), Map.lookup y (extras uf)) of 44 | (Nothing,Nothing) -> uf 45 | (Nothing,Just d) -> uf { extras = Map.insert x d (extras uf) } 46 | (Just c,Nothing) -> uf { extras = Map.insert y c (extras uf) } 47 | (Just c,Just d) -> 48 | if c == d then uf 49 | else fail_with 50 | $ ErrMsg ("in UnionFind, extra data doesn't match:\n " 51 | ++ show (x,c) ++ " != " ++ show (y,d)) 52 | 53 | -- | Unify x with y. On ties, prefer smaller variables. This is just 54 | -- a heuristic that biases toward pinned variables, many of which are 55 | -- low-numbered input vars. This way, we avoid introducing pinned 56 | -- eqns. in some cases. 57 | unite :: (Show a,Eq a) => UnionFind a -> Var -> Var -> UnionFind a 58 | unite uf x y 59 | | x < y 60 | = go x y 61 | 62 | | x > y 63 | = go y x 64 | 65 | | otherwise 66 | = uf 67 | 68 | -- Left-biased: if size x == size y, prefer x as root. 69 | where go x0 y0 70 | = let (rx,uf2) = root uf x0 71 | (ry,uf') = root uf2 y0 72 | sz_rx = size_of uf' rx 73 | sz_ry = size_of uf' ry 74 | in if sz_rx >= sz_ry then 75 | uf' { ids = Map.insert y0 rx (ids uf') 76 | , sizes = Map.insert x0 (sz_rx + sz_ry) (sizes uf') 77 | } 78 | else 79 | uf' { ids = Map.insert x0 ry (ids uf') 80 | , sizes = Map.insert y0 (sz_rx + sz_ry) (sizes uf') 81 | } 82 | 83 | -------------------------------------------------------------------------------- /src/examples/Basic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax #-} 2 | {-# LANGUAGE DataKinds #-} 3 | 4 | module Basic where 5 | 6 | import Prelude hiding 7 | ( (>>) 8 | , (>>=) 9 | , (+) 10 | , (-) 11 | , (*) 12 | , (/) 13 | , (&&) 14 | , return 15 | , fromRational 16 | , negate 17 | ) 18 | 19 | import Syntax 20 | import SyntaxMonad 21 | import TExpr 22 | import Compile 23 | import Toplevel 24 | 25 | mult_ex :: 26 | TExp 'TField Rational 27 | -> TExp 'TField Rational 28 | -> Comp 'TField 29 | mult_ex x y = return $ x * y 30 | 31 | arr_ex :: TExp 'TField Rational -> Comp 'TField 32 | arr_ex x = do 33 | a <- arr 2 34 | forall [0..1] (\i -> set (a,i) x) 35 | y <- get (a,0) 36 | z <- get (a,1) 37 | return $ y + z 38 | 39 | p1 = arr_ex 1.0 40 | 41 | desugar1 = texp_of_comp p1 42 | 43 | interp1 = comp_interp p1 [] 44 | 45 | p2 = do 46 | x <- fresh_input 47 | return $ x + x 48 | 49 | desugar2 = texp_of_comp p2 50 | 51 | interp2 = comp_interp p2 [] 52 | interp2' = comp_interp p2 [256] 53 | 54 | compile1 = r1cs_of_comp Simplify p1 55 | 56 | run1 = snarkify_comp "example" Simplify p1 [] 57 | 58 | comp1 = inl false 59 | 60 | comp2 = inr 0.0 61 | 62 | test1 = do 63 | b <- fresh_input 64 | z <- if return b then comp1 else comp2 65 | case_sum (\x0 -> return x0) (\_ -> return false) z 66 | -------------------------------------------------------------------------------- /src/examples/Keccak.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax,DataKinds #-} 2 | 3 | module Keccak where 4 | 5 | import qualified Data.Map.Strict as Map 6 | import Data.Bits hiding (xor) 7 | 8 | import Prelude hiding 9 | ( (>>) 10 | , (>>=) 11 | , (+) 12 | , (-) 13 | , (*) 14 | , (/) 15 | , (&&) 16 | , not 17 | , return 18 | , fromRational 19 | , negate 20 | ) 21 | import qualified Prelude as P 22 | 23 | import SyntaxMonad 24 | import Syntax 25 | import TExpr 26 | import Toplevel 27 | 28 | num_lanes :: Int 29 | num_lanes = (P.*) 5 5 30 | 31 | ln_width :: Int 32 | ln_width = 32 33 | 34 | round1 :: (Int -> TExp 'TBool Rational) -- | 'i'th bit of round constant 35 | -> TExp ('TArr ('TArr ('TArr 'TBool))) Rational -- | Array 'a' 36 | -> Comp 'TUnit 37 | round1 rc a 38 | = do { -- Allocate local array variables [b], [c], [d]. 39 | b <- arr3 5 5 ln_width 40 | ; c <- arr2 5 ln_width 41 | ; d <- arr2 5 ln_width 42 | -- Initialize arrays. 43 | ; forall3 ([0..4],[0..4],[0..dec ln_width]) 44 | (\i j k -> set3 (b,i,j,k) false) 45 | ; forall2 ([0..4],[0..dec ln_width]) (\i j -> set2 (c,i,j) false) 46 | ; forall2 ([0..4],[0..dec ln_width]) (\i j -> set2 (d,i,j) false) 47 | -- \theta step 48 | ; forall2 ([0..4],[0..dec ln_width]) (\x i -> 49 | do q <- get3 (a,x,0,i) 50 | u <- get3 (a,x,1,i) 51 | v <- get3 (a,x,2,i) 52 | w <- get3 (a,x,3,i) 53 | z <- get3 (a,x,4,i) 54 | set2 (c,x,i) $ q `xor` u `xor` v `xor` w `xor` z) 55 | ; forall2 ([0..4],[0..dec ln_width]) (\x i -> 56 | do q <- get2 (c,dec x `mod` 5,i) 57 | u <- get2 (c,inc x `mod` 5,rot_index i 1) 58 | set2 (d,x,i) $ q `xor` u) 59 | ; forall3 ([0..4],[0..4],[0..dec ln_width]) (\x y i -> 60 | do q <- get3 (a,x,y,i) 61 | u <- get2 (d,x,i) 62 | set3 (a,x,y,i) $ q `xor` u) 63 | -- \rho and \pi steps 64 | ; forall3 ([0..4],[0..4],[0..dec ln_width]) (\x y i -> 65 | do q <- get3 (a,x,y,rot_index i (rot_tbl x y)) 66 | set3 (b,y,((P.+) ((P.*) 2 x) ((P.*) 3 y)) `mod` 5,i) q) 67 | -- \chi step 68 | ; forall3 ([0..4],[0..4],[0..dec ln_width]) (\x y i -> 69 | do q <- get3 (b,x,y,i) 70 | u <- get3 (b,inc x `mod` 5,y,i) 71 | v <- get3 (b,(inc . inc) x `mod` 5,y,i) 72 | set3 (a,x,y,i) $ q `xor` (not u && v)) 73 | -- \iota step 74 | ; forall [0..dec ln_width] (\i -> 75 | do q <- get3 (a,0,0,i) 76 | set3 (a,0,0,i) (q `xor` rc i)) 77 | } 78 | 79 | -- round constants 80 | round_consts :: [Integer] 81 | round_consts 82 | = [ 0x00000001 83 | , 0x00008082 84 | , 0x0000808a 85 | , 0x80008000 86 | , 0x0000808b 87 | , 0x80000001 88 | , 0x80008081 89 | , 0x00008009 90 | , 0x0000008a 91 | , 0x00000088 92 | , 0x80008009 93 | , 0x8000000a 94 | 95 | , 0x8000808b 96 | , 0x800000000000008b 97 | , 0x8000000000008089 98 | , 0x8000000000008003 99 | , 0x8000000000008002 100 | , 0x8000000000000080 101 | , 0x800000000000800a 102 | , 0x800000008000000a 103 | , 0x8000000080008081 104 | , 0x8000000080008080 105 | , 0x0000000080000001 106 | , 0x8000000080008008 107 | ] 108 | 109 | rot_index :: Int -- rotate index 'i' 110 | -> Int -- by 'n' (mod lane width) 111 | -> Int 112 | rot_index i n = ((P.-) i n) `mod` ln_width 113 | 114 | rot_tbl x y 115 | = let m = Map.fromList $ 116 | [ ((3,2), 25), ((4,2), 39), ((0,2), 3), ((1,2), 10), ((2,2), 43) 117 | , ((3,1), 55), ((4,1), 20), ((0,1), 36), ((1,1), 44), ((2,1), 6) 118 | , ((3,0), 28), ((4,0), 27), ((0,0), 0), ((1,0), 1), ((2,0), 62) 119 | , ((3,4), 56), ((4,4), 14), ((0,4), 18), ((1,4), 2), ((2,4), 61) 120 | , ((3,3), 21), ((4,3), 8), ((0,3), 41), ((1,3), 45), ((2,3), 15) ] 121 | in case Map.lookup (x,y) m of 122 | Nothing -> error $ show (x,y) ++ " not a valid rotation key" 123 | Just r -> r 124 | 125 | trunc :: Integer -> Int 126 | trunc rc 127 | = fromIntegral rc 128 | .&. dec (truncate (2**fromIntegral ln_width :: Double) :: Int) 129 | 130 | get_round_bit :: Int -> Int -> TExp 'TBool Rational 131 | get_round_bit round_i bit_i 132 | = let the_bit = round_consts !! round_i 133 | .&. truncate (2**fromIntegral bit_i :: Double) 134 | in case the_bit > 0 of 135 | False -> false 136 | True -> true 137 | 138 | keccak_f1 num_rounds a 139 | = forall [0..dec num_rounds] (\round_i -> 140 | round1 (\bit_i -> get_round_bit round_i bit_i) a) 141 | 142 | -- num_rounds = 12+2l, where 2^l = ln_width 143 | keccak1 num_rounds 144 | = do { a <- input_arr3 5 5 ln_width 145 | ; keccak_f1 num_rounds a 146 | ; b <- arr 1 147 | ; set (b, 0) false 148 | ; forall3 ([0..4], [0..4], [0..dec ln_width]) (\i j k -> do 149 | a_val <- get3 (a, i, j, k) 150 | b_val <- get (b, 0) 151 | set (b, 0) (a_val `xor` b_val)) 152 | ; get (b, 0) 153 | } 154 | 155 | input_vals = go ((P.*) num_lanes ln_width) 156 | where go :: Int -> [Int] 157 | go 0 = [] 158 | go n | odd n = 0 : go (dec n) 159 | go n | otherwise = 1 : go (dec n) 160 | 161 | -- test_full n 162 | -- = Top.test (keccak1 n, input_vals, (1::Integer)) 163 | 164 | -- test_interp n 165 | -- = Top.texp_interp (keccak1 n) (map fromIntegral input_vals) 166 | 167 | -- test_r1cs n 168 | -- = let (nv,in_vars,e) = Top.texp_of_comp (keccak1 n) 169 | -- r1cs = r1cs_of_texp nv in_vars e 170 | -- in putStrLn 171 | -- $ show 172 | -- $ last (r1cs_clauses r1cs) 173 | 174 | -- -- First compile to R1CS, then generate witness. 175 | -- test_wit n 176 | -- = let (nv,in_vars,e) = Top.texp_of_comp (keccak1 n) 177 | -- r1cs = r1cs_of_texp nv in_vars e 178 | -- wit = Top.wit_of_r1cs (map fromIntegral input_vals) r1cs 179 | -- in case IntMap.lookup 1000000 wit of 180 | -- Nothing -> putStr $ show $ last (r1cs_clauses r1cs) 181 | -- Just v -> putStr $ show v ++ (show $ last (r1cs_clauses r1cs)) 182 | 183 | 184 | 185 | 186 | 187 | 188 | -------------------------------------------------------------------------------- /src/examples/Lam.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax 2 | , DataKinds 3 | #-} 4 | 5 | module Lam where 6 | 7 | import Prelude hiding 8 | ( (>>) 9 | , (>>=) 10 | , (+) 11 | , (-) 12 | , (*) 13 | , (/) 14 | , (&&) 15 | , return 16 | , fromRational 17 | , negate 18 | ) 19 | 20 | import Data.Typeable 21 | 22 | import Errors 23 | import SyntaxMonad 24 | import Syntax 25 | import TExpr 26 | 27 | ---------------------------------------------------------- 28 | -- Substitutions 29 | -- \sigma ::= Shift n + (Term * \sigma) 30 | ---------------------------------------------------------- 31 | 32 | type TFSubst = 'TFSum ('TFConst 'TField) ('TFProd ('TFConst TTerm) 'TFId) 33 | 34 | type TSubst = 'TMu TFSubst 35 | 36 | subst_nil n 37 | = do { n' <- inl n 38 | ; roll n' :: Comp TSubst 39 | } 40 | 41 | subst_cons t sigma 42 | = do { p <- pair t sigma 43 | ; p' <- inr p 44 | ; roll p' :: Comp TSubst 45 | } 46 | 47 | case_subst sigma f_shift f_cons 48 | = do { sigma' <- unroll (sigma :: TExp TSubst Rational) 49 | ; case_sum f_shift go sigma' 50 | } 51 | where go p 52 | = do { t <- fst_pair p 53 | ; sigma' <- snd_pair p 54 | ; f_cons t sigma' 55 | } 56 | 57 | 58 | ---------------------------------------------------------- 59 | -- Terms 60 | -- t ::= Field + t + (t * t) 61 | ---------------------------------------------------------- 62 | 63 | type TF = 'TFSum ('TFConst 'TField) ('TFSum 'TFId ('TFProd 'TFId 'TFId)) 64 | 65 | type TTerm = 'TMu TF 66 | 67 | varN :: TExp 'TField Rational 68 | -> Comp TTerm 69 | varN e 70 | = do { v <- inl e 71 | ; roll v 72 | } 73 | 74 | varN' :: Int 75 | -> Comp TTerm 76 | varN' i 77 | = do { v <- inl (exp_of_int i) 78 | ; roll v 79 | } 80 | 81 | lam :: TExp TTerm Rational 82 | -> Comp TTerm 83 | lam t 84 | = do { t' <- inl t 85 | ; v <- inr t' 86 | ; roll v 87 | } 88 | 89 | app :: TExp TTerm Rational 90 | -> TExp TTerm Rational 91 | -> Comp TTerm 92 | app t1 t2 93 | = do { t <- pair t1 t2 94 | ; t' <- inr t 95 | ; v <- inr t' 96 | ; roll v 97 | } 98 | 99 | case_term :: ( Typeable ty 100 | , Zippable ty 101 | ) 102 | => TExp TTerm Rational 103 | -> (TExp 'TField Rational -> Comp ty) 104 | -> (TExp TTerm Rational -> Comp ty) 105 | -> (TExp TTerm Rational -> TExp TTerm Rational -> Comp ty) 106 | -> Comp ty 107 | case_term t f_var f_lam f_app 108 | = do { t' <- unroll t 109 | ; case_sum f_var (case_sum f_lam go) t' 110 | } 111 | where go p 112 | = do { e1 <- fst_pair p 113 | ; e2 <- fst_pair p 114 | ; f_app e1 e2 115 | } 116 | 117 | is_lam :: TExp TTerm Rational -> Comp 'TBool 118 | is_lam t 119 | = case_term t 120 | (const $ return false) 121 | (const $ return true) 122 | (\_ _ -> return false) 123 | 124 | shift :: TExp 'TField Rational 125 | -> TExp TTerm Rational 126 | -> Comp TTerm 127 | shift n t = fix go t 128 | where go self t0 129 | = case_term t0 130 | (\m -> varN (n + m)) 131 | (\t' -> 132 | do { t'' <- self t' 133 | ; lam t'' 134 | }) 135 | (\t1 t2 -> 136 | do { t1' <- self t1 137 | ; t2' <- self t2 138 | ; app t1' t2' 139 | }) 140 | 141 | compose sigma1 sigma2 142 | = do { p <- pair sigma1 sigma2 :: Comp ('TProd TSubst TSubst) 143 | ; fix go p 144 | } 145 | where go self p0 146 | = let recur s1 s2 = pair s1 s2 >>= self 147 | in do { s1 <- fst_pair p0 148 | ; s2 <- snd_pair p0 149 | ; case_subst s2 150 | -- Var(m) 151 | (\m -> 152 | if return (zeq m) then return s1 153 | else case_subst s1 154 | -- Var(n) 155 | (\n -> subst_nil $ n+m) 156 | -- _ . s1' 157 | (\_ s1' -> subst_nil (m-1.0) >>= recur s1')) 158 | -- t' . s2' 159 | (\t' s2' -> 160 | do { t'' <- subst_term s1 t' 161 | ; s2'' <- recur s1 s2' 162 | ; subst_cons t'' s2'' 163 | }) 164 | } 165 | 166 | subst_term sigma t 167 | = do { p <- pair sigma t :: Comp ('TProd TSubst TTerm) 168 | ; fix go p 169 | } 170 | where go self p0 171 | = let recur sigma0 t0 = pair sigma0 t0 >>= self 172 | in do { sigma0 <- fst_pair p0 173 | ; t0 <- snd_pair p0 174 | ; case_term t0 175 | -- Var(n) 176 | (\n -> 177 | case_subst sigma0 178 | (\m -> varN $ n+m) 179 | (\t' sigma' -> 180 | do { if return (zeq n) then return t' 181 | else varN (n-1.0) >>= recur sigma' 182 | })) 183 | -- Lam t1 184 | (\t1 -> 185 | do { var0 <- varN 0.0 186 | ; sigma1 <- subst_nil 1.0 187 | ; sigma2 <- compose sigma1 sigma 188 | ; sigma' <- subst_cons var0 sigma2 189 | ; t1' <- recur sigma' t1 190 | ; lam t1' 191 | }) 192 | -- App t1 t2 193 | (\t1 t2 -> 194 | do { self1 <- recur sigma t1 195 | ; self2 <- recur sigma t2 196 | ; app self1 self2 197 | }) 198 | } 199 | 200 | beta :: TExp TTerm Rational 201 | -> TExp TTerm Rational 202 | -> Comp TTerm 203 | beta t1 t2 204 | = case_term t1 205 | -- Var(_) 206 | (\_ -> fail_with $ ErrMsg "beta expects an abstraction") 207 | -- Lam t1' 208 | (\t1' -> 209 | do { id_subst <- subst_nil 0.0 210 | ; sigma <- subst_cons t2 id_subst 211 | ; subst_term sigma t1' 212 | }) 213 | -- App _ _ 214 | (\_ _ -> fail_with $ ErrMsg "beta expects an abstraction") 215 | 216 | step :: TExp TTerm Rational -> Comp TTerm 217 | step t 218 | = case_term t 219 | (\_ -> return t) 220 | (\_ -> return t) 221 | (\t1 t2 -> beta t1 t2) 222 | 223 | whnf :: TExp TTerm Rational -> Comp TTerm 224 | whnf t = fix go t 225 | where go self t0 226 | = do { t' <- step t0 227 | ; case_term t' 228 | (\_ -> fail_with $ ErrMsg "unbound variable") 229 | (\_ -> return t') 230 | (\_ _ -> self t') 231 | } 232 | 233 | -- \x y -> x 234 | term_lam :: Comp TTerm 235 | term_lam 236 | = do { x <- varN' 1 237 | ; t <- lam x 238 | ; lam t 239 | } 240 | 241 | term_app :: Comp TTerm 242 | term_app 243 | = do { t <- term_lam 244 | ; app t t 245 | } 246 | 247 | -- (\x y -> x) (\x1 y1 -> x1) 248 | -- ~~> (\y -> (\x1 y1 -> x1)) 249 | beta_test1 250 | = do { t <- term_app 251 | ; whnf t 252 | ; return 0.0 253 | } 254 | -------------------------------------------------------------------------------- /src/examples/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax 2 | , DataKinds 3 | #-} 4 | 5 | module List where 6 | 7 | import Prelude hiding 8 | ( (>>) 9 | , (>>=) 10 | , (+) 11 | , (-) 12 | , (*) 13 | , (/) 14 | , (&&) 15 | , return 16 | , fromRational 17 | , negate 18 | ) 19 | 20 | import Data.Typeable 21 | 22 | import SyntaxMonad 23 | import Syntax 24 | import TExpr 25 | import Toplevel 26 | 27 | type TF a = 'TFSum ('TFConst 'TUnit) ('TFProd ('TFConst a) 'TFId) 28 | 29 | type TList a = 'TMu (TF a) 30 | 31 | type List a = TExp (TList a) Rational 32 | 33 | nil :: Typeable a => Comp (TList a) 34 | nil = do { t <- inl unit 35 | ; roll t 36 | } 37 | 38 | cons :: Typeable a => TExp a Rational -> List a -> Comp (TList a) 39 | cons f t 40 | = do { p <- pair f t 41 | ; t' <- inr p 42 | ; roll t' 43 | } 44 | 45 | case_list :: ( Typeable a 46 | , Typeable ty 47 | , Zippable ty 48 | ) 49 | => List a 50 | -> Comp ty 51 | -> (TExp a Rational -> List a -> Comp ty) 52 | -> Comp ty 53 | case_list t f_nil f_cons 54 | = do { t' <- unroll t 55 | ; case_sum (\_ -> f_nil) go t' 56 | } 57 | where go p 58 | = do { e1 <- fst_pair p 59 | ; e2 <- snd_pair p 60 | ; f_cons e1 e2 61 | } 62 | 63 | head_list :: ( Typeable a 64 | , Zippable a 65 | , Derive a 66 | ) 67 | => TExp a Rational -> List a -> Comp a 68 | head_list def l 69 | = case_list l 70 | (return def) 71 | (\hd _ -> return hd) 72 | 73 | tail_list :: ( Typeable a 74 | , Zippable a 75 | , Derive a 76 | ) 77 | => List a -> Comp (TList a) 78 | tail_list l 79 | = case_list l 80 | nil 81 | (\_ tl -> return tl) 82 | 83 | {- rev [] = [] 84 | rev (hd : tl) = rev tl ++ [hd] 85 | -} 86 | 87 | app_list :: ( Typeable a, Zippable a, Derive a 88 | ) 89 | => List a 90 | -> List a 91 | -> Comp (TList a) 92 | app_list l1 l2 = fix go l1 93 | where go self l0 94 | = case_list l0 95 | (return l2) 96 | (\a l0' -> do 97 | l0'' <- self l0' 98 | cons a l0'') 99 | 100 | rev_list :: ( Typeable a, Zippable a, Derive a 101 | ) 102 | => List a 103 | -> Comp (TList a) 104 | rev_list l = fix go l 105 | where go self l0 106 | = case_list l0 107 | nil 108 | (\a l0' -> do 109 | l0'' <- self l0' 110 | a_tl <- nil 111 | a_l <- cons a a_tl 112 | app_list l0'' a_l) 113 | 114 | map_list :: ( Typeable a, Zippable a, Derive a 115 | , Typeable b, Zippable b, Derive b 116 | ) 117 | => (TExp a Rational -> Comp b) 118 | -> List a 119 | -> Comp (TList b) 120 | map_list f l 121 | = fix go l 122 | where go self l0 123 | = case_list l0 124 | nil 125 | (\hd tl -> 126 | do { hd' <- f hd 127 | ; tl' <- self tl 128 | ; cons hd' tl' 129 | }) 130 | 131 | last_list :: ( Typeable a, Zippable a, Derive a ) 132 | => TExp a Rational 133 | -> List a 134 | -> Comp a 135 | last_list def l 136 | = fix go l 137 | where go self l0 138 | = case_list l0 139 | (return def) 140 | (\hd tl -> 141 | case_list tl 142 | (return hd) 143 | (\_ _ -> self tl)) 144 | 145 | {------------------------------------------------ 146 | A couple (very simple) test cases 147 | ------------------------------------------------} 148 | 149 | list1 150 | = do { tl <- nil 151 | ; tl' <- cons (exp_of_int 23) tl 152 | ; cons (exp_of_int 33) tl' 153 | } 154 | 155 | inc_elem e = return $ exp_of_int 1 + e 156 | 157 | list2 158 | = do { l <- list1 159 | ; map_list inc_elem l 160 | } 161 | 162 | list_comp3 163 | = do { b <- fresh_input 164 | ; l <- nil 165 | ; l' <- cons 23.0 l 166 | ; l'' <- cons 33.0 l' 167 | ; l2 <- if return b then return l'' else return l 168 | ; l3 <- map_list inc_elem l2 169 | ; l4 <- tail_list l3 170 | ; head_list 0.0 l4 171 | } 172 | 173 | list_comp4 174 | = do { l <- list2 175 | ; last_list 0.0 l 176 | } 177 | 178 | listN n = fixN 100 go n 179 | where go self n0 = do 180 | x <- fresh_input 181 | tl <- self (n0-1.0) 182 | if return (eq n0 0.0) then nil else cons x tl 183 | 184 | test_listN = do 185 | n <-fresh_input 186 | l1 <- listN n 187 | l2 <- map_list inc_elem l1 188 | last_list 99.0 l2 189 | -------------------------------------------------------------------------------- /src/examples/Matrix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax,DataKinds #-} 2 | 3 | module Matrix where 4 | 5 | import Prelude hiding 6 | ( (>>) 7 | , (>>=) 8 | , (+) 9 | , (-) 10 | , (*) 11 | , (/) 12 | , (&&) 13 | , not 14 | , return 15 | , fromRational 16 | , negate 17 | ) 18 | 19 | 20 | 21 | import SyntaxMonad 22 | import Syntax 23 | import TExpr 24 | import Toplevel 25 | import qualified Prelude as P 26 | 27 | 28 | 29 | type Matrix = TExp ('TArr ('TArr 'TField)) 30 | 31 | new_matrix n m = arr2 n m 32 | 33 | new_rowvec n = arr n 34 | 35 | new_colvec n = arr n 36 | 37 | input_matrix n m = input_arr2 n m 38 | 39 | input_rowvec n = input_arr n 40 | 41 | input_colvec n = input_arr n 42 | 43 | 44 | type FixedMatrix = Int -> Int -> Rational 45 | 46 | -- v0 + v1 + .. + v(n-1) 47 | sum_vec n v = do 48 | iterM (dec n) (\i acc -> do 49 | a <- get (v,i) 50 | return $ a + acc) 0.0 51 | 52 | sum_mat n m mat = do 53 | iterM (dec n) (\i acc -> do 54 | a <- iterM (dec m) (\j acc' -> do 55 | mat_elem <- get2(mat, i, j) 56 | return $ mat_elem + acc') 0.0 57 | return $ a + acc) 0.0 58 | 59 | input_matrix_mult n m p = do 60 | a <- input_matrix n m 61 | b <- input_matrix m p 62 | c <- new_matrix n p 63 | 64 | forall [0.. dec n] (\i -> do 65 | forall [0..dec p] (\j -> do 66 | res <- iterM (dec m) (\k acc -> do 67 | aElem <- get2 (a, i,k) 68 | bElem <- get2 (b, k, j) 69 | return $ (bElem * aElem) + acc) 0.0 70 | set2 (c, i, j) res)) 71 | sum_mat n n c 72 | 73 | 74 | -- Pinocchio's "Fixed Matrix" microbenchmark [p9] 75 | matrix_colvec_mult fm n = do 76 | v <- input_colvec n 77 | v' <- new_colvec n 78 | 79 | -- multiply 80 | forall [0..dec n] (\i -> do 81 | res <- iterM (dec n) (\j acc -> do 82 | a <- get (v,j) 83 | return $ (fm i j)*a + acc) 0.0 84 | set (v',i) res) 85 | 86 | -- return an output that's dependent on the entire vector v' 87 | sum_vec n v' 88 | 89 | {------------------------------------------------ 90 | Test cases 91 | ------------------------------------------------} 92 | 93 | test1 n = matrix_colvec_mult (\_ _ -> 7.0) n 94 | 95 | interp1 n = comp_interp (test1 n) (map fromIntegral [0..dec n]) 96 | 97 | t2_m0 n = (map fromIntegral [0.. dec n]) 98 | 99 | t2_m1 n = reverse (t2_m0 n) 100 | 101 | test2 n = input_matrix_mult n n n 102 | 103 | interp2 n = comp_interp (test2 n) 104 | ((t2_m0 ((P.*) n n))++(t2_m1 ((P.*) n n))) 105 | 106 | -------------------------------------------------------------------------------- /src/examples/Peano.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax 2 | , DataKinds 3 | #-} 4 | 5 | module Peano where 6 | 7 | import Prelude hiding 8 | ( (>>) 9 | , (>>=) 10 | , (+) 11 | , (-) 12 | , (*) 13 | , (/) 14 | , (&&) 15 | , return 16 | , fromRational 17 | , negate 18 | ) 19 | 20 | import SyntaxMonad 21 | import Syntax 22 | import TExpr 23 | 24 | type TF = 'TFSum ('TFConst 'TUnit) 'TFId 25 | 26 | type TNat = 'TMu TF 27 | 28 | nat_zero :: Comp TNat 29 | nat_zero 30 | = do { x <- inl unit 31 | ; roll x 32 | } 33 | 34 | nat_succ :: TExp TNat Rational -> Comp TNat 35 | nat_succ n 36 | = do { x <- inr n 37 | ; roll x 38 | } 39 | 40 | nat_eq :: Int 41 | -> TExp TNat Rational 42 | -> TExp TNat Rational 43 | -> Comp 'TBool 44 | nat_eq level n m 45 | | level > 0 46 | = do { n' <- unroll n 47 | ; m' <- unroll m 48 | ; case_sum 49 | (const $ case_sum (const $ return true) (const $ return false) m') 50 | (\n'' -> case_sum 51 | (const $ return false) 52 | (\m'' -> nat_eq (dec level) n'' m'') 53 | m') 54 | n' 55 | } 56 | 57 | | otherwise 58 | = return false 59 | 60 | nat_of_int :: Int -> Comp TNat 61 | nat_of_int 0 = nat_zero 62 | nat_of_int n 63 | = do { x <- nat_of_int (dec n) 64 | ; nat_succ x 65 | } 66 | 67 | -------------------------------------------------------------------------------- /src/examples/Queue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax 2 | , DataKinds 3 | #-} 4 | 5 | module Queue where 6 | 7 | import Prelude hiding 8 | ( (>>) 9 | , (>>=) 10 | , (+) 11 | , (-) 12 | , (*) 13 | , (/) 14 | , (&&) 15 | , return 16 | , fromRational 17 | , negate 18 | ) 19 | 20 | import Data.Typeable 21 | 22 | import SyntaxMonad 23 | import Syntax 24 | import TExpr 25 | import Toplevel 26 | import Compile 27 | import List 28 | import Stack 29 | 30 | type TQueue a = 'TProd (TStack a) (TStack a) 31 | 32 | type Queue a = TExp (TQueue a) Rational 33 | 34 | empty_queue :: Typeable a => Comp (TQueue a) 35 | empty_queue = do 36 | l <- empty_stack 37 | r <- empty_stack 38 | pair l r 39 | 40 | enqueue :: (Zippable a, Derive a, Typeable a) 41 | => TExp a Rational -> Queue a -> Comp (TQueue a) 42 | enqueue v q = do 43 | l <- fst_pair q 44 | r <- snd_pair q 45 | l' <- push_stack v l 46 | pair l' r 47 | 48 | dequeue :: (Zippable a, Derive a, Typeable a) 49 | => Queue a -> TExp a Rational -> Comp ('TProd a (TQueue a)) 50 | dequeue q def = do 51 | l <- fst_pair q 52 | r <- snd_pair q 53 | l_empty <- is_empty_stack l 54 | r_empty <- is_empty_stack r 55 | if return r_empty then 56 | if return l_empty then do 57 | pair def q 58 | else do 59 | l' <- nil 60 | pre_r <- rev_list l 61 | h <- top_stack def pre_r 62 | r' <- pop_stack pre_r 63 | q' <- pair l' r' 64 | pair h q' 65 | else do 66 | h <- top_stack def r 67 | r' <- pop_stack r 68 | p <- pair l r' 69 | pair h p 70 | 71 | dequeue_rec :: (Zippable a, Derive a, Typeable a) 72 | => Queue a -> TExp a Rational -> Comp ('TProd a (TQueue a)) 73 | dequeue_rec q def = fix go q 74 | where go self q0 = do 75 | l <- fst_pair q0 76 | r <- snd_pair q0 77 | l_empty <- is_empty_stack l 78 | r_empty <- is_empty_stack r 79 | if return r_empty then 80 | if return l_empty then do 81 | pair def q0 82 | else do 83 | l' <- nil 84 | r' <- rev_list l 85 | p' <- pair l' r' 86 | self p' 87 | else do 88 | h <- top_stack def r 89 | r' <- pop_stack r 90 | p <- pair l r' 91 | pair h p 92 | 93 | is_empty q = do 94 | l <- fst_pair q 95 | r <- snd_pair q 96 | case_list l 97 | (case_list r 98 | (return true) 99 | (\ _ _ -> return false)) 100 | (\ _ _ -> return false) 101 | 102 | last_queue :: (Zippable a, Derive a, Typeable a) 103 | => Queue a -> TExp a Rational -> Comp a 104 | last_queue q def = fixN 100 go q 105 | where go self p = do 106 | p_pair <- dequeue p def 107 | p_queue <- snd_pair p_pair 108 | p_top <- fst_pair p_pair 109 | b <- is_empty p_queue 110 | if return b 111 | then return p_top 112 | else self p_queue 113 | 114 | map_queue f q = do 115 | lq <- fst_pair q 116 | rq <- snd_pair q 117 | lq' <- map_list f lq 118 | rq' <- map_list f rq 119 | pair lq' rq' 120 | ----------------------------------------- 121 | --Simple Examples------------------------ 122 | ----------------------------------------- 123 | 124 | --queue with {nonempty stack, nonempty stack} 125 | queue1 126 | = do { 127 | ; s1 <- stack1 128 | ; s2 <- stack2 129 | ; pair s1 s2 130 | } 131 | 132 | --queue with {nonempty stack, empty stack} 133 | queue2 134 | = do { 135 | ; s1 <- stack1 136 | ; s2 <- pop_stack s1 137 | ; s3 <- pop_stack s2 138 | ; s4 <- stack2 139 | ; pair s4 s3 140 | } 141 | 142 | queue_comp1 143 | = do { 144 | ; q1 <- queue1 145 | ; q2 <- enqueue 1.0 q1 146 | ; q3 <- enqueue 3.4 q2 147 | ; sx <- fst_pair q3 148 | ; top_stack 0.0 sx 149 | } 150 | 151 | --dequeue where input is queue with {nonempty, nonempty} 152 | queue_comp2 153 | = do { 154 | ; q1 <- queue1 155 | ; sx <- dequeue q1 0.0 156 | ; fst_pair sx 157 | } 158 | 159 | --dequeue where input is queue with {nonempty, empty} 160 | queue_comp3 161 | = do { 162 | ; q1 <- queue2 163 | ; sx <- dequeue q1 0.0 164 | ; fst_pair sx 165 | } 166 | 167 | 168 | queueN n = fixN 100 go n 169 | where go self n0 = do 170 | x <- fresh_input 171 | tl <- self (n0 - 1.0) 172 | if return (eq n0 0.0) 173 | then empty_queue 174 | else enqueue x tl 175 | 176 | test_queueN = do 177 | n <- fresh_input 178 | q1 <- queueN n 179 | q2 <- map_queue inc_elem q1 180 | last_queue q2 105.0 181 | -------------------------------------------------------------------------------- /src/examples/Stack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax 2 | , DataKinds 3 | #-} 4 | 5 | module Stack where 6 | 7 | import Prelude hiding 8 | ( (>>) 9 | , (>>=) 10 | , (+) 11 | , (-) 12 | , (*) 13 | , (/) 14 | , (&&) 15 | , return 16 | , fromRational 17 | , negate 18 | ) 19 | 20 | import Data.Typeable 21 | import Compile 22 | import SyntaxMonad 23 | import Syntax 24 | import TExpr 25 | import Toplevel 26 | import List 27 | 28 | type TStack a = TList a 29 | 30 | type Stack a = TExp (TStack a) Rational 31 | 32 | empty_stack :: Typeable a => Comp (TStack a) 33 | empty_stack = nil 34 | 35 | push_stack :: Typeable a => TExp a Rational -> Stack a -> Comp (TStack a) 36 | push_stack p q = cons p q 37 | 38 | pop_stack :: (Derive a, Zippable a, Typeable a) => Stack a -> Comp (TStack a) 39 | pop_stack f = tail_list f 40 | 41 | top_stack :: (Derive a, Zippable a, Typeable a) => TExp a Rational-> Stack a -> Comp a 42 | top_stack def e = head_list def e 43 | 44 | is_empty_stack :: Typeable a => Stack a -> Comp 'TBool 45 | is_empty_stack s = 46 | case_list s (return true) (\_ _ -> return false) 47 | 48 | ---Test Examples--- 49 | 50 | stack1 51 | = do { 52 | ; tl <- empty_stack 53 | ; tl' <- push_stack 15.0 tl 54 | ; push_stack 99.0 tl' 55 | } 56 | stack2 57 | = do { 58 | ; tl <- empty_stack 59 | ; tl' <- push_stack 1.0 tl 60 | ; tl'' <- push_stack 12.0 tl' 61 | ; push_stack 89.0 tl'' 62 | } 63 | 64 | --top_stack on empty stack 65 | test_top1 66 | = do { 67 | ; s1 <- stack1 68 | ; s2 <- pop_stack s1 69 | ; s3 <- pop_stack s2 70 | ; top_stack 1.0 s3 71 | } 72 | 73 | --top_stack on non-empty stack 74 | test_top2 75 | = do { 76 | ; s1 <- stack1 77 | ; top_stack 1.0 s1 78 | } 79 | 80 | --is_empty_stack on an empty stack 81 | test_empty_stack1 82 | = do { 83 | ; s1 <- stack1 84 | ; s2 <- pop_stack s1 85 | ; s3 <- pop_stack s2 86 | ; is_empty_stack s3 87 | } 88 | 89 | --is_empty_stack on non-empty stack 90 | test_empty_stack2 91 | = do { 92 | ; s1 <- stack1 93 | ; is_empty_stack s1 94 | } 95 | 96 | -------------------------------------------------------------------------------- /src/examples/Tree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax 2 | , DataKinds 3 | #-} 4 | 5 | module Tree where 6 | 7 | import Prelude hiding 8 | ( (>>) 9 | , (>>=) 10 | , (+) 11 | , (-) 12 | , (*) 13 | , (/) 14 | , (&&) 15 | , return 16 | , fromRational 17 | , negate 18 | ) 19 | 20 | import Data.Typeable 21 | 22 | import Syntax 23 | import SyntaxMonad 24 | import TExpr 25 | 26 | type TF a = 'TFSum ('TFConst 'TUnit) ('TFProd ('TFConst a) ('TFProd 'TFId 'TFId)) 27 | 28 | type TTree a = 'TMu (TF a) 29 | 30 | type Rat = TExp 'TField Rational 31 | type Tree a = TExp (TTree a) Rational 32 | 33 | leaf :: Typeable a => Comp (TTree a) 34 | leaf = do 35 | t <- inl unit 36 | roll t 37 | 38 | node :: Typeable a => TExp a Rational -> Tree a -> Tree a -> Comp (TTree a) 39 | node v t1 t2 = do 40 | p <- pair t1 t2 41 | p' <- pair v p 42 | t <- inr p' 43 | roll t 44 | 45 | case_tree :: ( Typeable a 46 | , Typeable a1 47 | , Zippable a1 48 | ) 49 | => Tree a 50 | -> Comp a1 51 | -> (TExp a Rational -> Tree a -> Tree a -> Comp a1) 52 | -> Comp a1 53 | case_tree t f_leaf f_node = do 54 | t' <- unroll t 55 | case_sum (\_ -> f_leaf) go t' 56 | where go p' = do 57 | v <- fst_pair p' 58 | p <- snd_pair p' 59 | t1 <- fst_pair p 60 | t2 <- snd_pair p 61 | f_node v t1 t2 62 | 63 | map_tree :: ( Typeable a 64 | , Typeable a1 65 | , Zippable a1 66 | , Derive a1 67 | ) 68 | => (TExp a Rational -> State Env (TExp a1 Rational)) 69 | -> TExp (TTree a) Rational 70 | -> Comp (TTree a1) 71 | map_tree f t 72 | = fix go t 73 | where go self t0 = do 74 | case_tree t0 75 | leaf 76 | (\v t1 t2 -> do 77 | v' <- f v 78 | t1' <- self t1 79 | t2' <- self t2 80 | node v' t1' t2') 81 | 82 | {------------------------------------------------ 83 | Test cases 84 | ------------------------------------------------} 85 | 86 | tree1 = do 87 | b <- fresh_input 88 | l1 <- leaf 89 | l2 <- leaf 90 | t1' <- if return b then node 77.0 l1 l2 else leaf 91 | l3 <- leaf 92 | t2 <- node 2.0 t1' l3 93 | return t2 94 | 95 | tree_test1 = do 96 | t <- tree1 97 | case_tree t (return 99.0) (\_ tl _ -> do 98 | case_tree tl (return 88.0) (\v _ _ -> do 99 | return v)) 100 | -------------------------------------------------------------------------------- /src/testsuite/benchmarks/Harness.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | module Harness where 4 | 5 | import System.IO (hPutStrLn, stderr) 6 | import GHC.IO.Exception 7 | 8 | import qualified Data.IntMap.Lazy as IntMap 9 | import qualified Data.Set as Set 10 | import Data.Typeable 11 | 12 | import Compile (SimplParam) 13 | import TExpr 14 | import Errors 15 | import Toplevel 16 | 17 | -- Just interpret. 18 | test_interp :: Typeable ty => Comp ty -> [Int] -> Rational 19 | test_interp mf inputs 20 | = comp_interp mf (map fromIntegral inputs) 21 | 22 | -- Just elaborate to TExp. 23 | test_texp :: Typeable ty => Comp ty -> IO () 24 | test_texp mf = (hPutStrLn stderr . show . extract_rat . last_seq . comp_texp . texp_of_comp) mf 25 | where extract_rat :: TExp ty Rational -> Int 26 | extract_rat te = 27 | case te of 28 | TEVar _ -> 0 29 | TEVal _ -> 1 30 | TEUnop _ _ -> 2 31 | TEBinop _ _ _ -> 3 32 | TEIf _ _ _ -> 4 33 | TEAssert _ _ -> 5 34 | TESeq _ _ -> 6 35 | TEBot -> 7 36 | 37 | -- Just compile to constraints (no simplification yet). 38 | test_constraints :: Typeable ty => Comp ty -> IO () 39 | test_constraints mf 40 | = let texp_pkg = texp_of_comp mf 41 | constrs = constrs_of_texp texp_pkg 42 | in hPutStrLn stderr 43 | $ show 44 | $ Set.size 45 | $ cs_constraints constrs 46 | 47 | -- Compile to constraints and simplify. 48 | test_simplify :: Typeable ty => Comp ty -> IO () 49 | test_simplify mf 50 | = let texp_pkg = texp_of_comp mf 51 | constrs = constrs_of_texp texp_pkg 52 | (_,constrs') = do_simplify False IntMap.empty constrs 53 | in hPutStrLn stderr 54 | $ show 55 | $ Set.size 56 | $ cs_constraints constrs' 57 | 58 | -- Generate (simplified) R1CS, but don't run it yet. (No witness is 59 | -- generated.) Also, serialize the r1cs to stderr. 60 | test_r1csgen :: Typeable ty => SimplParam -> Comp ty -> IO () 61 | test_r1csgen simpl mf 62 | = do { r1csgen_comp "test" simpl mf 63 | } 64 | 65 | -- Same as 'test_r1cs', but also generates and serializes 66 | -- a satisfying assignment, as well as serializing the given inputs. 67 | test_witgen :: (Integral a, Typeable ty) => SimplParam -> Comp ty -> [a] -> IO () 68 | test_witgen simpl mf inputs 69 | = do { witgen_comp "test" simpl mf (map fromIntegral inputs) 70 | } 71 | 72 | test_keygen :: Typeable ty => SimplParam -> Comp ty -> [Int] -> IO () 73 | test_keygen simpl mf inputs 74 | = do { exit <- keygen_comp "test" simpl mf (map fromIntegral inputs) 75 | ; case exit of 76 | ExitSuccess -> Prelude.return () 77 | ExitFailure err -> fail_with $ ErrMsg $ "test_full failed with " ++ show err 78 | } 79 | 80 | test_proofgen :: Typeable ty => SimplParam -> Comp ty -> [Int] -> IO () 81 | test_proofgen simpl mf inputs 82 | = do { exit <- proofgen_comp "test" simpl mf (map fromIntegral inputs) 83 | ; case exit of 84 | ExitSuccess -> Prelude.return () 85 | ExitFailure err -> fail_with $ ErrMsg $ "test_full failed with " ++ show err 86 | } 87 | 88 | -- Run libsnark on the resulting files. 89 | test_crypto :: Typeable ty => SimplParam -> Comp ty -> [Int] -> IO () 90 | test_crypto simpl mf inputs 91 | = do { exit <- snarkify_comp "test" simpl mf (map fromIntegral inputs) 92 | ; case exit of 93 | ExitSuccess -> Prelude.return () 94 | ExitFailure err -> fail_with $ ErrMsg $ "test_full failed with " ++ show err 95 | } 96 | 97 | -- This function "executes" the comp two ways, once by interpreting 98 | -- the resulting TExp and second by interpreting the resulting circuit 99 | -- on the inputs provided. Both results are checked to match 'res'. 100 | -- The function outputs a 'Result' that details number of variables and 101 | -- constraints in the resulting constraint system. 102 | test_numconstrs :: Typeable ty => SimplParam -> Comp ty -> [Int] -> Rational -> IO () 103 | test_numconstrs simpl mf inputs res 104 | = benchmark_comp (simpl, mf, map fromIntegral inputs, res) 105 | 106 | 107 | -------------------------------------------------------------------------------- /src/testsuite/benchmarks/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Criterion.Main 4 | 5 | import Compile (SimplParam(..)) 6 | import Harness 7 | 8 | import qualified List as List 9 | import qualified Keccak as Keccak 10 | import qualified Matrix as Matrix 11 | 12 | mk_bgroup nm mf inputs result 13 | = bgroup nm 14 | [ bench (nm ++ "-elaborate") $ nfIO $ test_texp mf 15 | , bench (nm ++ "-constraints") $ nfIO $ test_constraints mf 16 | , bench (nm ++ "-simplify") $ nfIO $ test_simplify mf 17 | , bench (nm ++ "-r1cs") $ nfIO $ test_r1csgen Simplify mf 18 | , bench (nm ++ "-witgen") $ nfIO $ test_witgen Simplify mf inputs 19 | , bench (nm ++ "-keygen") $ nfIO $ test_keygen Simplify mf inputs 20 | , bench (nm ++ "-verif") $ nfIO $ test_crypto Simplify mf inputs 21 | , bench (nm ++ "-full") $ nfIO $ test_numconstrs Simplify mf inputs result 22 | ] 23 | 24 | the_benchmarks 25 | = [ mk_bgroup "keccak800" (Keccak.keccak1 22) Keccak.input_vals 1 26 | , mk_bgroup "map-list" List.test_listN (90 : take 100 [0..]) 90 27 | , mk_bgroup "fixed-matrix600" (Matrix.test1 600) [0..599] 754740000 28 | , mk_bgroup "input-matrix70" (Matrix.test2 70) 29 | ((Matrix.t2_m0 4900)++(Matrix.t2_m1 4900)) 2048215153250 30 | ] 31 | 32 | run_benchmarks 33 | = defaultMain the_benchmarks 34 | 35 | main = run_benchmarks 36 | 37 | -------------------------------------------------------------------------------- /src/testsuite/tests/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Hspec 4 | 5 | import Keccak 6 | import Compile 7 | import Toplevel 8 | import UnitTests 9 | 10 | main :: IO () 11 | main = hspec $ do 12 | 13 | describe "Field Tests" $ do 14 | 15 | describe "if-then-else" $ do 16 | it "1-1" $ test_comp Simplify prog1 [1,2,1] `shouldReturn` Right (negate 240) 17 | 18 | describe "bigsum" $ do 19 | it "2-1" $ test_comp Simplify (prog2 4) [0] `shouldReturn` Right 10 20 | it "2-2" $ test_comp Simplify (prog2 4) [1] `shouldReturn` Right 15 21 | it "2-3" $ test_comp Simplify (prog2 4) [2] `shouldReturn` Right 20 22 | it "2-4" $ test_comp Simplify (prog2 10) [10] `shouldReturn` Right 165 23 | 24 | describe "arrays" $ do 25 | it "3-1" $ test_comp Simplify prog3 [8] `shouldReturn` Right 512 26 | it "3-2" $ test_comp Simplify prog3 [16] `shouldReturn` Right 4096 27 | it "3-3" $ test_comp Simplify prog3 [0] `shouldReturn` Right 0 28 | it "3-4" $ test_comp Simplify prog3 [-1] `shouldReturn` Right (-1) 29 | 30 | it "4-1" $ test_comp Simplify prog4 [8] `shouldReturn` Right 512 31 | it "4-2" $ test_comp Simplify prog4 [16] `shouldReturn` Right 4096 32 | it "4-3" $ test_comp Simplify prog4 [0] `shouldReturn` Right 0 33 | it "4-4" $ test_comp Simplify prog4 [-1] `shouldReturn` Right (-1) 34 | 35 | it "5-1" $ test_comp Simplify prog5 [4] `shouldReturn` Right (4^(101::Integer)) 36 | it "5-2" $ test_comp Simplify prog5 [5] `shouldReturn` Right (5^(101::Integer)) 37 | --TODO: INVESTIGATE: FAILS with "EXCEEDS FIELD SIZE" 38 | --it "5-2" $ test_comp Simplify prog5 [5] `shouldReturn` Right (5^(101::Integer)) 39 | it "5-3" $ test_comp Simplify prog5 [0] `shouldReturn` Right 0 40 | it "5-4" $ test_comp Simplify prog5 [-1] `shouldReturn` Right (-1) 41 | 42 | describe "times" $ do 43 | it "6-1" $ test_comp Simplify prog6 [8] `shouldReturn` Right 8 44 | 45 | describe "forall" $ do 46 | it "7-1" $ test_comp Simplify prog7 [] `shouldReturn` Right 100 47 | 48 | describe "forall2" $ do 49 | it "8-1" $ test_comp Simplify prog8 [] `shouldReturn` Right 29 50 | 51 | describe "unused inputs" $ do 52 | it "11-1" $ test_comp Simplify prog11 [1,1] `shouldReturn` Right 1 53 | 54 | describe "multiplicative identity" $ do 55 | it "13-1" $ test_comp Simplify prog13 [1] `shouldReturn` Right 1 56 | 57 | describe "opt: 0x * 3y = out ~~> out=0" $ do 58 | it "14-1" $ test_comp Simplify prog14 [3,4] `shouldReturn` Right 0 59 | 60 | describe "exp_binop smart constructor: 3 - (2 - 1) = 2" $ do 61 | it "15-1" $ test_comp Simplify prog15 [] `shouldReturn` Right 2 62 | 63 | describe "lists" $ do 64 | it "26-1" $ test_comp Simplify prog26 [] `shouldReturn` Right 33 65 | it "27-1" $ test_comp Simplify prog27 [] `shouldReturn` Right 34 66 | it "28-1" $ test_comp Simplify prog28 [] `shouldReturn` Right 24 67 | it "29-1" $ test_comp Simplify prog29 [1] `shouldReturn` Right 24 68 | it "30-1" $ test_comp Simplify prog30 [] `shouldReturn` Right 24 69 | it "37-1" $ test_comp Simplify prog37 (30 : (take 100 [0..])) `shouldReturn` Right 30 70 | 71 | describe "div" $ do 72 | it "31-1" $ test_comp Simplify prog31 [4,2] `shouldReturn` Right 2 73 | it "31-1" $ test_comp Simplify prog31 [4,1] `shouldReturn` Right 4 74 | it "31-1" $ test_comp Simplify prog31 [4,4] `shouldReturn` Right 1 75 | it "31-1" $ test_comp Simplify prog31 [21,7] `shouldReturn` Right 3 76 | 77 | describe "beta" $ do 78 | it "34-1" $ test_comp Simplify prog34 [] `shouldReturn` Right 0 79 | 80 | describe "trees" $ do 81 | it "35-1" $ test_comp Simplify prog35 [1] `shouldReturn` Right 77 82 | 83 | describe "Boolean Tests" $ do 84 | 85 | describe "and" $ do 86 | it "9-1" $ test_comp Simplify bool_prog9 [0,0] `shouldReturn` Right 0 87 | it "9-2" $ test_comp Simplify bool_prog9 [0,1] `shouldReturn` Right 0 88 | it "9-3" $ test_comp Simplify bool_prog9 [1,0] `shouldReturn` Right 0 89 | it "9-4" $ test_comp Simplify bool_prog9 [1,1] `shouldReturn` Right 1 90 | 91 | describe "xor" $ do 92 | it "10-1" $ test_comp Simplify bool_prog10 [0,0] `shouldReturn` Right 0 93 | it "10-2" $ test_comp Simplify bool_prog10 [0,1] `shouldReturn` Right 1 94 | it "10-3" $ test_comp Simplify bool_prog10 [1,0] `shouldReturn` Right 1 95 | it "10-4" $ test_comp Simplify bool_prog10 [1,1] `shouldReturn` Right 0 96 | 97 | describe "boolean eq" $ do 98 | it "12-1" $ test_comp Simplify bool_prog12 [0,0] `shouldReturn` Right 1 99 | it "12-2" $ test_comp Simplify bool_prog12 [0,1] `shouldReturn` Right 0 100 | it "12-3" $ test_comp Simplify bool_prog12 [1,0] `shouldReturn` Right 0 101 | it "12-4" $ test_comp Simplify bool_prog12 [1,1] `shouldReturn` Right 1 102 | 103 | describe "bool inputs" $ do 104 | it "16-1" $ test_comp Simplify bool_prog16 (take 100 $ repeat 1) `shouldReturn` Right 0 105 | 106 | describe "array" $ do 107 | it "17-1" $ test_comp Simplify bool_prog17 [] `shouldReturn` Right 1 108 | 109 | describe "input array" $ do 110 | it "18-1" $ test_comp Simplify bool_prog18 [0,1,0,1,0,1,0,1] `shouldReturn` Right 1 111 | 112 | describe "products" $ do 113 | it "19-1" $ test_comp Simplify bool_prog19 [1,1] `shouldReturn` Right 1 114 | it "20-1" $ test_comp Simplify bool_prog20 [1,1] `shouldReturn` Right 1 115 | it "21-1" $ test_comp Simplify bool_prog21 [0,1] `shouldReturn` Right 0 116 | 117 | describe "products" $ do 118 | it "22-1" $ test_comp Simplify bool_prog22 [0,1] `shouldReturn` Right 1 119 | it "23-1" $ test_comp Simplify bool_prog23 [0,1] `shouldReturn` Right 0 120 | 121 | describe "peano" $ do 122 | it "24-1" $ test_comp Simplify bool_prog24 [] `shouldReturn` Right 1 123 | 124 | describe "lam" $ do 125 | it "25-1" $ test_comp Simplify bool_prog25 [] `shouldReturn` Right 1 126 | 127 | describe "zeq" $ do 128 | it "32-1" $ test_comp Simplify bool_prog32 [0] `shouldReturn` Right 1 129 | it "32-2" $ test_comp Simplify bool_prog32 [1] `shouldReturn` Right 0 130 | it "32-3" $ test_comp Simplify bool_prog32 [2] `shouldReturn` Right 0 131 | 132 | describe "eq" $ do 133 | it "33-1" $ test_comp Simplify bool_prog33 [23,44] `shouldReturn` Right 0 134 | it "33-2" $ test_comp Simplify bool_prog33 [0,100] `shouldReturn` Right 0 135 | it "33-3" $ test_comp Simplify bool_prog33 [0,0] `shouldReturn` Right 1 136 | it "33-3" $ test_comp Simplify bool_prog33 [100,100] `shouldReturn` Right 1 137 | it "33-3" $ test_comp Simplify bool_prog33 [-33,44] `shouldReturn` Right 0 138 | it "33-3" $ test_comp Simplify bool_prog33 [-1,-1] `shouldReturn` Right 1 139 | 140 | describe "sum" $ do 141 | it "36-1" $ test_comp Simplify prog36 [0] `shouldReturn` Right 10 142 | it "36-2" $ test_comp Simplify prog36 [1] `shouldReturn` Right 7 143 | 144 | describe "Keccak Tests" $ do 145 | 146 | describe "keccak" $ do 147 | it "keccak-2" $ test_comp Simplify (keccak1 2) input_vals `shouldReturn` Right 1 148 | it "keccak-2" $ test_comp Simplify (keccak1 5) input_vals `shouldReturn` Right 1 149 | 150 | -------------------------------------------------------------------------------- /src/testsuite/tests/UnitTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax 2 | , DataKinds 3 | #-} 4 | 5 | module UnitTests where 6 | 7 | import Prelude hiding 8 | ( (>>) 9 | , (>>=) 10 | , (+) 11 | , (-) 12 | , (*) 13 | , (/) 14 | , (&&) 15 | , return 16 | , fromRational 17 | , negate 18 | ) 19 | import qualified Prelude as P 20 | 21 | import Lam 22 | import List 23 | import Tree 24 | import Peano 25 | import Syntax 26 | import SyntaxMonad 27 | import TExpr 28 | 29 | 30 | 31 | -- | 1. A standalone "program" in the expression language 32 | prog1 33 | = do { x <- fresh_input -- bool 34 | ; y <- fresh_input -- int 35 | ; z <- fresh_input -- bool 36 | ; u <- return $ y + 2.0 37 | ; v <- if return z then return y else return y 38 | ; w <- if return x then return y else return y 39 | ; return $ (u*u) - (w*u*u*y*y*v) 40 | } 41 | 42 | -- | 2. We can also mix Haskell code with R1CS expressions, by defining 43 | -- combinators over R1CS-producing functions. 44 | -- 45 | -- For example, the following code calculates the R1CS expression 46 | -- (n+e) + (n-1+e) + (n-2+e) + ... + (n-(n-1)+e) 47 | -- with e an fresh_input expression. 48 | prog2 n 49 | = do { e <- fresh_input 50 | ; let f i = exp_of_int i + e 51 | ; return $ bigsum n f 52 | } 53 | 54 | -- | 3. Declare 'a' an array of size 5. initialize slot 3 to e. 55 | -- initialize slot 4 to e*e. return a[3]*a[4]. 56 | prog3 57 | = do { e <- fresh_input 58 | ; a <- arr 5 59 | ; set (a,3) e 60 | ; set (a,4) (e*e) 61 | ; x <- get (a,3) 62 | ; y <- get (a,4) 63 | ; return (x*y) 64 | } 65 | 66 | -- | 4. Identical to 3, except allocates larger array 67 | prog4 68 | = do { e <- fresh_input 69 | ; a <- arr 1000 70 | ; set (a,3) e 71 | ; set (a,4) (e*e) 72 | ; x <- get (a,3) 73 | ; y <- get (a,4) 74 | ; return (x*y) 75 | } 76 | 77 | -- | 5. Identical to 4, except with more constraints 78 | pow :: Int -> TExp TField Rational -> TExp TField Rational 79 | pow 0 _ = 1.0 80 | pow n e = e*(pow (dec n) e) 81 | 82 | prog5 83 | = do { e <- fresh_input 84 | ; a <- arr 1000 85 | ; set (a,3) e 86 | ; set (a,4) (pow 100 e) 87 | ; x <- get (a,3) 88 | ; y <- get (a,4) 89 | ; return (x*y) 90 | } 91 | 92 | -- | 6. 'times' test 93 | prog6 94 | = do { e <- fresh_input 95 | ; a <- arr 100 96 | ; times 1 (set (a,3) e) 97 | ; x <- get (a,3) 98 | ; return x 99 | } 100 | 101 | -- | 7. 'forall' test 102 | prog7 103 | = do { a <- arr 100 104 | ; forall [0..99] (\i -> set (a,i) 0.0) 105 | ; forall [0..99] (\i -> set (a,i) (exp_of_int i)) 106 | ; x <- get (a,49) 107 | ; y <- get (a,51) 108 | ; return $ x + y 109 | } 110 | 111 | -- | 8. 'forall2' test 112 | prog8 113 | = do { a <- arr 25 114 | ; forall [0..24] (\i -> set (a,i) 0.0) 115 | ; let index i j = (P.+) ((P.*) 5 i) j 116 | ; forall2 ([0..4],[0..4]) (\i j -> 117 | set (a,index i j) (exp_of_int $ index i j)) 118 | ; x <- get (a,5) -- 5 119 | ; y <- get (a,24) -- 24 120 | ; return $ x + y 121 | } 122 | 123 | -- | 9. 'and' test 124 | bool_prog9 125 | = do { e1 <- fresh_input 126 | ; e2 <- fresh_input 127 | ; return (e1 && e2) 128 | } 129 | 130 | -- | 10. 'xor' test 131 | bool_prog10 132 | = do { e1 <- fresh_input 133 | ; e2 <- fresh_input 134 | ; return (e1 `xor` e2) 135 | } 136 | 137 | -- | 11. are unused fresh_input variables treated properly? 138 | prog11 139 | = do { _ <- fresh_input :: Comp ('TArr 'TField) 140 | ; b <- fresh_input 141 | ; return b 142 | } 143 | 144 | -- | 12. does boolean 'a' equal boolean 'b'? 145 | bool_prog12 146 | = do { a <- fresh_input 147 | ; b <- fresh_input 148 | ; return (a `beq` b) 149 | } 150 | 151 | -- | 13. multiplicative identity 152 | prog13 153 | = do { a <- fresh_input 154 | ; return $ 1.0 * a 155 | } 156 | 157 | -- | 14. opt: 0x * 3y = out ~~> out=0 158 | prog14 159 | = do { x <- fresh_input 160 | ; y <- fresh_input 161 | ; return $ (0.0*x) * (3.0*y) 162 | } 163 | 164 | -- | 15. exp_binop smart constructor: 3 - (2 - 1) = 2 165 | prog15 166 | = do { return $ 3.0 - (2.0 - 1.0) 167 | } 168 | 169 | -- | 16. bool fresh_inputs test 170 | bool_prog16 171 | = do { a <- input_arr 100 172 | ; forall [0..99] (\i -> 173 | do b <- get (a,i) 174 | set (a,i) (b && true)) 175 | ; return false 176 | } 177 | 178 | -- | 17. array test 179 | bool_prog17 180 | = do { a <- arr 2 181 | ; a' <- arr 2 182 | ; set (a',0) true 183 | ; set (a,0) a' 184 | ; get2 (a,0,0) 185 | } 186 | 187 | -- | 18. fresh_input array test 188 | bool_prog18 189 | = do { a <- input_arr3 2 2 2 190 | ; get3 (a,0,0,1) 191 | } 192 | 193 | -- | 19. products test 194 | bool_prog19 195 | = do { x <- fresh_input 196 | ; y <- fresh_input 197 | ; p <- pair x y 198 | ; c <- fst_pair p 199 | ; d <- snd_pair p 200 | ; return $ c && d 201 | } 202 | 203 | -- | 20. products test 2: snd (fst ((x,y),x)) && x == y && x 204 | bool_prog20 205 | = do { x <- fresh_input 206 | ; y <- fresh_input 207 | ; p <- pair x y 208 | ; q <- pair p x 209 | ; c <- fst_pair q 210 | ; d <- snd_pair c 211 | ; return $ d && x 212 | } 213 | 214 | -- | 21. products test 3: snd (fst ((x,y),(y,x))) && x == y && x 215 | bool_prog21 216 | = do { x <- fresh_input 217 | ; y <- fresh_input 218 | ; p <- pair x y 219 | ; q <- pair y x 220 | ; u <- pair p q 221 | ; c <- fst_pair u 222 | ; d <- snd_pair c 223 | ; return $ d && x 224 | } 225 | 226 | -- | 22. sums test 227 | bool_prog22 228 | = do { x1 <- fresh_input 229 | ; x2 <- fresh_input 230 | ; x <- pair x1 x2 231 | ; y <- (inl x :: Comp (TSum (TProd TBool TBool) TBool)) 232 | ; case_sum 233 | (\e1 -> snd_pair e1) 234 | (\e2 -> return e2) 235 | y 236 | } 237 | 238 | -- | 23. sums test 2 239 | bool_prog23 240 | = do { x1 <- fresh_input 241 | ; x2 <- fresh_input 242 | ; x <- pair x1 x2 243 | ; y <- (inr x :: Comp (TSum (TProd TBool TBool) 244 | (TProd TBool TBool))) 245 | ; z <- (inl y :: Comp (TSum (TSum (TProd TBool TBool) 246 | (TProd TBool TBool)) 247 | (TProd TBool TBool))) 248 | ; case_sum 249 | (case_sum 250 | fst_pair 251 | fst_pair) 252 | fst_pair 253 | z 254 | } 255 | 256 | -- | 24. peano test 1 257 | bool_prog24 258 | = do { n2 <- nat_of_int 3 259 | ; n3 <- nat_of_int 3 260 | ; nat_eq 4 n2 n3 261 | } 262 | 263 | -- | 25. lam test 1 264 | bool_prog25 265 | = do { t <- term_lam 266 | ; t' <- shift (exp_of_int 2) t 267 | ; is_lam t' 268 | } 269 | 270 | -- | 26. list test 1 271 | prog26 272 | = do { l <- list1 273 | ; head_list (exp_of_int 0) l 274 | } 275 | 276 | -- | 27. list test 2 277 | prog27 278 | = do { l <- list2 279 | ; head_list (exp_of_int 0) l 280 | } 281 | 282 | -- | 28. list test 3 283 | prog28 284 | = do { l <- list2 285 | ; l' <- tail_list l 286 | ; head_list (exp_of_int 0) l' 287 | } 288 | 289 | -- | 29. list test 4 290 | prog29 291 | = list_comp3 292 | 293 | -- | 30. list test 5 294 | prog30 295 | = list_comp4 296 | 297 | -- | 31. div test 298 | prog31 299 | = do { x <- fresh_input 300 | ; y <- fresh_input 301 | ; return $ x / y 302 | } 303 | 304 | -- | 32. zeq test 305 | bool_prog32 306 | = do { x <- fresh_input 307 | ; return $ zeq x 308 | } 309 | 310 | -- | 33. eq test 311 | bool_prog33 312 | = do { x <- fresh_input :: Comp TField 313 | ; y <- fresh_input 314 | ; return $ x `eq` y 315 | } 316 | 317 | -- | 34. beta test 318 | prog34 = beta_test1 319 | 320 | -- | 35. tree test 321 | prog35 = tree_test1 322 | 323 | -- | 36. sums test (ISSUE#7) 324 | prog36 :: Comp 'TField 325 | prog36 = do 326 | b1 <- fresh_input 327 | x <- if return b1 then inl 2.0 else inr 3.0 328 | case_sum (\n -> return $ n + 5.0) (\m -> return $ m + 7.0) x 329 | 330 | -- | 37. build and modify a list of user-specified length, up to size 50 331 | prog37 = test_listN 332 | 333 | tests :: [(Comp 'TField,[Int],Integer)] 334 | tests 335 | = [ (prog1, [1,2,1], P.negate 240) 336 | 337 | , (prog2 4, [0], 10) 338 | , (prog2 4, [1], 15) 339 | , (prog2 4, [2], 20) 340 | , (prog2 10, [10], 165) 341 | 342 | , (prog3, [8], 512) 343 | , (prog3, [16], 4096) 344 | , (prog3, [0], 0) 345 | , (prog3, [dec 0], fromIntegral $ dec 0) 346 | 347 | , (prog4, [8], 512) 348 | , (prog4, [16], 4096) 349 | , (prog4, [0], 0) 350 | , (prog4, [dec 0], fromIntegral $ dec 0) 351 | 352 | , (prog5, [8], 8^(101::Int)) 353 | , (prog5, [16], 16^(101::Int)) 354 | , (prog5, [0], 0) 355 | , (prog5, [dec 0], fromIntegral $ dec 0) 356 | 357 | , (prog6, [8], 8) 358 | 359 | , (prog7, [], 100) 360 | 361 | , (prog8, [], 29) 362 | 363 | , (prog11, [1,1], 1) 364 | 365 | , (prog13, [1], 1) 366 | 367 | , (prog14, [3,4], 0) 368 | 369 | , (prog15, [], 2) 370 | 371 | , (prog26, [], 33) 372 | 373 | , (prog27, [], 34) 374 | 375 | , (prog28, [], 24) 376 | 377 | , (prog29, [1], 24) 378 | 379 | , (prog30, [], 24) 380 | 381 | , (prog31, [4,2], 2) 382 | , (prog31, [4,1], 4) 383 | , (prog31, [4,4], 1) 384 | , (prog31, [21,7], 3) 385 | 386 | , (prog34, [], 0) 387 | 388 | , (prog35, [], 77) 389 | 390 | , (prog36, [0], 10) 391 | , (prog36, [1], 7) 392 | 393 | , (prog37, 30 : (take 100 [0..]), 30) 394 | ] 395 | 396 | bool_tests :: [(Comp 'TBool,[Int],Integer)] 397 | bool_tests 398 | = [ (bool_prog9, [0,0], 0) 399 | , (bool_prog9, [0,1], 0) 400 | , (bool_prog9, [1,0], 0) 401 | , (bool_prog9, [1,1], 1) 402 | 403 | , (bool_prog10, [0,0], 0) 404 | , (bool_prog10, [0,1], 1) 405 | , (bool_prog10, [1,0], 1) 406 | , (bool_prog10, [1,1], 0) 407 | 408 | , (bool_prog12, [0,0], 1) 409 | , (bool_prog12, [0,1], 0) 410 | , (bool_prog12, [1,0], 0) 411 | , (bool_prog12, [1,1], 1) 412 | 413 | , (bool_prog16, take 100 $ repeat 1, 0) 414 | 415 | , (bool_prog17, [], 1) 416 | 417 | , (bool_prog18, [0,1,0,1,0,1,0,1], 1) 418 | 419 | , (bool_prog19, [1,1], 1) 420 | 421 | , (bool_prog20, [1,1], 1) 422 | 423 | , (bool_prog21, [0,1], 0) 424 | 425 | , (bool_prog22, [0,1], 1) 426 | 427 | , (bool_prog23, [0,1], 0) 428 | 429 | , (bool_prog24, [], 1) 430 | 431 | , (bool_prog25, [], 1) 432 | 433 | , (bool_prog32, [0], 1) 434 | , (bool_prog32, [1], 0) 435 | , (bool_prog32, [2], 0) 436 | 437 | , (bool_prog33, [23,44], 0) 438 | , (bool_prog33, [0,100], 0) 439 | , (bool_prog33, [0,0], 1) 440 | , (bool_prog33, [100,100], 1) 441 | , (bool_prog33, [P.negate 33,44], 0) 442 | , (bool_prog33, [0,100], 0) 443 | , (bool_prog33, [0,0], 1) 444 | , (bool_prog33, [100,100], 1) 445 | , (bool_prog33, [P.negate 33,P.negate 33], 1) 446 | ] 447 | 448 | -------------------------------------------------------------------------------- /src/todo.txt: -------------------------------------------------------------------------------- 1 | Stupid stuff: 2 | -General inequality 3 | . inequality requires binary decomposition 4 | -Detect field overflow via static analysis on Expr language 5 | . question: can this be done directly on rationals? or should 6 | we first do the embedding into F_p? 7 | 8 | --------------------------------------------------------------------------------